cl-macs.el 126 KB
Newer Older
1
;;; cl-macs.el --- Common Lisp macros  -*- lexical-binding: t; coding: utf-8 -*-
Richard M. Stallman's avatar
Richard M. Stallman committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5

;; Author: Dave Gillespie <daveg@synaptics.com>
6
;; Old-Version: 2.02
Richard M. Stallman's avatar
Richard M. Stallman committed
7
;; Keywords: extensions
8
;; Package: emacs
Richard M. Stallman's avatar
Richard M. Stallman committed
9 10 11

;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
16 17 18 19 20 21 22

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
24

Richard M. Stallman's avatar
Richard M. Stallman committed
25
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43

;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains the portions of the Common Lisp extensions
;; package which should be autoloaded, but need only be present
;; if the compiler or interpreter is used---this file is not
;; necessary for executing compiled code.

;; See cl.el for Change Log.


Richard M. Stallman's avatar
Richard M. Stallman committed
44
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
45

46
(require 'cl-lib)
47
(require 'macroexp)
48 49
;; `gv' is required here because cl-macs can be loaded before loaddefs.el.
(require 'gv)
Richard M. Stallman's avatar
Richard M. Stallman committed
50

51
(defmacro cl--pop2 (place)
52
  (declare (debug edebug-sexps))
53 54
  `(prog1 (car (cdr ,place))
     (setq ,place (cdr (cdr ,place)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
55

56 57
(defvar cl--optimize-safety)
(defvar cl--optimize-speed)
Richard M. Stallman's avatar
Richard M. Stallman committed
58 59 60

;;; Initialization.

61 62 63 64 65 66 67 68 69 70 71 72
;; Place compiler macros at the beginning, otherwise uses of the corresponding
;; functions can lead to recursive-loads that prevent the calls from
;; being optimized.

;;;###autoload
(defun cl--compiler-macro-list* (_form arg &rest others)
  (let* ((args (reverse (cons arg others)))
	 (form (car args)))
    (while (setq args (cdr args))
      (setq form `(cons ,(car args) ,form)))
    form))

73 74 75
;; Note: `cl--compiler-macro-cXXr' has been copied to
;; `internal--compiler-macro-cXXr' in subr.el.  If you amend either
;; one, you may want to amend the other, too.
76
;;;###autoload
77 78
(define-obsolete-function-alias 'cl--compiler-macro-cXXr
  'internal--compiler-macro-cXXr "25.1")
79

80 81 82
;;; Some predicates for analyzing Lisp forms.
;; These are used by various
;; macro expanders to optimize the results in certain common cases.
Richard M. Stallman's avatar
Richard M. Stallman committed
83

84
(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
85
			    car-safe cdr-safe progn prog1 prog2))
86
(defconst cl--safe-funcs '(* / % length memq list vector vectorp
87 88
			  < > <= >= = error))

89 90
(defun cl--simple-expr-p (x &optional size)
  "Check if no side effects, and executes quickly."
91
  (or size (setq size 10))
92
  (if (and (consp x) (not (memq (car x) '(quote function cl-function))))
93
      (and (symbolp (car x))
94
	   (or (memq (car x) cl--simple-funcs)
95 96 97 98
	       (get (car x) 'side-effect-free))
	   (progn
	     (setq size (1- size))
	     (while (and (setq x (cdr x))
99
			 (setq size (cl--simple-expr-p (car x) size))))
100 101 102
	     (and (null x) (>= size 0) size)))
    (and (> size 0) (1- size))))

103 104
(defun cl--simple-exprs-p (xs)
  (while (and xs (cl--simple-expr-p (car xs)))
105 106 107
    (setq xs (cdr xs)))
  (not xs))

108 109
(defun cl--safe-expr-p (x)
  "Check if no side effects."
110
  (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
111
      (and (symbolp (car x))
112 113
	   (or (memq (car x) cl--simple-funcs)
	       (memq (car x) cl--safe-funcs)
114 115
	       (get (car x) 'side-effect-free))
	   (progn
116
	     (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
117 118 119
	     (null x)))))

;;; Check if constant (i.e., no side effects or dependencies).
120
(defun cl--const-expr-p (x)
121 122
  (cond ((consp x)
	 (or (eq (car x) 'quote)
123
	     (and (memq (car x) '(function cl-function))
124 125 126 127 128
		  (or (symbolp (nth 1 x))
		      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
	((symbolp x) (and (memq x '(nil t)) t))
	(t t)))

129
(defun cl--const-expr-val (x)
Daniel Colascione's avatar
Daniel Colascione committed
130
  "Return the value of X known at compile-time.
131 132 133 134
If X is not known at compile time, return nil.  Before testing
whether X is known at compile time, macroexpand it completely in
`macroexpand-all-environment'."
  (let ((x (macroexpand-all x macroexpand-all-environment)))
Daniel Colascione's avatar
Daniel Colascione committed
135
    (if (macroexp-const-p x)
136
        (if (consp x) (nth 1 x) x))))
137

138 139
(defun cl--expr-contains (x y)
  "Count number of times X refers to Y.  Return nil for 0 times."
140
  ;; FIXME: This is naive, and it will cl-count Y as referred twice in
141 142 143
  ;; (let ((Y 1)) Y) even though it should be 0.  Also it is often called on
  ;; non-macroexpanded code, so it may also miss some occurrences that would
  ;; only appear in the expanded code.
144
  (cond ((equal y x) 1)
145
	((and (consp x) (not (memq (car x) '(quote function cl-function))))
146
	 (let ((sum 0))
147
	   (while (consp x)
148 149
	     (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
	   (setq sum (+ sum (or (cl--expr-contains x y) 0)))
150 151 152
	   (and (> sum 0) sum)))
	(t nil)))

153 154
(defun cl--expr-contains-any (x y)
  (while (and y (not (cl--expr-contains x (car y)))) (pop y))
155 156
  y)

157 158 159 160
(defun cl--expr-depends-p (x y)
  "Check whether X may depend on any of the symbols in Y."
  (and (not (macroexp-const-p x))
       (or (not (cl--safe-expr-p x)) (cl--expr-contains-any x y))))
161

Richard M. Stallman's avatar
Richard M. Stallman committed
162 163
;;; Symbols.

164
(defvar cl--gensym-counter)
165
;;;###autoload
166
(defun cl-gensym (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
167 168
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
169 170
  (let ((pfix (if (stringp prefix) prefix "G"))
	(num (if (integerp prefix) prefix
171 172
	       (prog1 cl--gensym-counter
		 (setq cl--gensym-counter (1+ cl--gensym-counter))))))
173
    (make-symbol (format "%s%d" pfix num))))
Richard M. Stallman's avatar
Richard M. Stallman committed
174

175
;;;###autoload
176
(defun cl-gentemp (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
177 178
  "Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
179
  (let ((pfix (if (stringp prefix) prefix "G"))
Richard M. Stallman's avatar
Richard M. Stallman committed
180
	name)
181 182
    (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter)))
      (setq cl--gensym-counter (1+ cl--gensym-counter)))
Richard M. Stallman's avatar
Richard M. Stallman committed
183 184 185 186 187
    (intern name)))


;;; Program structure.

188
(def-edebug-spec cl-declarations
189
  (&rest ("cl-declare" &rest sexp)))
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209

(def-edebug-spec cl-declarations-or-string
  (&or stringp cl-declarations))

(def-edebug-spec cl-lambda-list
  (([&rest arg]
    [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
    [&optional ["&rest" arg]]
    [&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
		&optional "&allow-other-keys"]]
    [&optional ["&aux" &rest
		&or (symbolp &optional def-form) symbolp]]
    )))

(def-edebug-spec cl-&optional-arg
  (&or (arg &optional def-form arg) arg))

(def-edebug-spec cl-&key-arg
  (&or ([&or (symbolp arg) arg] &optional def-form arg) arg))

210 211
(def-edebug-spec cl-type-spec sexp)

212 213 214
(defconst cl--lambda-list-keywords
  '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))

215 216 217 218 219 220 221 222 223 224 225 226 227 228
;; Internal hacks used in formal arg lists:
;; - &cl-quote: Added to formal-arglists to mean that any default value
;;   mentioned in the formal arglist should be considered as implicitly
;;   quoted rather than evaluated.  This is used in `cl-defsubst' when
;;   performing compiler-macro-expansion, since at that time the
;;   arguments hold expressions rather than values.
;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing
;;   optional arguments which don't have an explicit default value.
;;   DEFS is an alist mapping vars to their default default value.
;;   and DEF is the default default to use for all other vars.

(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data.
(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs.
(defvar cl--bind-enquote)      ;Non-nil if &cl-quote was in the formal arglist!
229
(defvar cl--bind-lets) (defvar cl--bind-forms)
230 231

(defun cl--transform-lambda (form bind-block)
232 233 234 235 236
  "Transform a function form FORM of name BIND-BLOCK.
BIND-BLOCK is the name of the symbol to which the function will be bound,
and which will be used for the name of the `cl-block' surrounding the
function's body.
FORM is of the form (ARGS . BODY)."
237 238
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
	 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
239 240 241
         (parsed-body (macroexp-parse-body body))
	 (header (car parsed-body)) (simple-args nil))
    (setq body (cdr parsed-body))
242 243 244
    ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we
    ;; do it here as well, so as to be able to see if we can avoid
    ;; cl--do-arglist.
245 246
    (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
247 248 249 250 251
    (let ((cl-defs (memq '&cl-defs args)))
      (when cl-defs
        (setq cl--bind-defs (cadr cl-defs))
	;; Remove "&cl-defs DEFS" from args.
        (setcdr cl-defs (cddr cl-defs))
252
	(setq args (delq '&cl-defs args))))
253 254 255
    (if (setq cl--bind-enquote (memq '&cl-quote args))
	(setq args (delq '&cl-quote args)))
    (if (memq '&whole args) (error "&whole not currently implemented"))
256 257
    (let* ((p (memq '&environment args))
           (v (cadr p)))
258
      (if p (setq args (nconc (delq (car p) (delq v args))
259
                              `(&aux (,v macroexpand-all-environment))))))
260 261 262
    ;; Take away all the simple args whose parsing can be handled more
    ;; efficiently by a plain old `lambda' than the manual parsing generated
    ;; by `cl--do-arglist'.
263 264 265 266 267 268 269 270 271 272 273 274 275
    (let ((optional nil))
      (while (and args (symbolp (car args))
                  (not (memq (car args) '(nil &rest &body &key &aux)))
                  (or (not optional)
                      ;; Optional args whose default is nil are simple.
                      (null (nth 1 (assq (car args) (cdr cl--bind-defs)))))
                  (not (and (eq (car args) '&optional) (setq optional t)
                            (car cl--bind-defs))))
        (push (pop args) simple-args))
      (when optional
        (if args (push '&optional args))
        ;; Don't keep a dummy trailing &optional without actual optional args.
        (if (eq '&optional (car simple-args)) (pop simple-args))))
276 277
    (or (eq cl--bind-block 'cl-none)
	(setq body (list `(cl-block ,cl--bind-block ,@body))))
278 279 280 281 282 283 284 285 286 287 288 289 290
    (let* ((cl--bind-lets nil) (cl--bind-forms nil)
           (rest-args
            (cond
             ((null args) nil)
             ((eq (car args) '&aux)
              (cl--do-&aux args)
              (setq cl--bind-lets (nreverse cl--bind-lets))
              nil)
             (t ;; `simple-args' doesn't handle all the parsing that we need,
              ;; so we pass the rest to cl--do-arglist which will do
              ;; "manual" parsing.
              (let ((slen (length simple-args)))
                (when (memq '&optional simple-args)
291
                  (cl-decf slen))
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
                (setq header
                      ;; Macro expansion can take place in the middle of
                      ;; apparently harmless computation, so it should not
                      ;; touch the match-data.
                      (save-match-data
                        (cons (help-add-fundoc-usage
                               (if (stringp (car header)) (pop header))
                               ;; Be careful with make-symbol and (back)quote,
                               ;; see bug#12884.
                               (let ((print-gensym nil) (print-quoted t))
                                 (format "%S" (cons 'fn (cl--make-usage-args
                                                         orig-args)))))
                              header)))
                ;; FIXME: we'd want to choose an arg name for the &rest param
                ;; and pass that as `expr' to cl--do-arglist, but that ends up
                ;; generating code with a redundant let-binding, so we instead
                ;; pass a dummy and then look in cl--bind-lets to find what var
                ;; this was bound to.
                (cl--do-arglist args :dummy slen)
                (setq cl--bind-lets (nreverse cl--bind-lets))
                ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets))))
                (list '&rest (car (pop cl--bind-lets))))))))
      `(nil
        (,@(nreverse simple-args) ,@rest-args)
        ,@header
        ,(macroexp-let* cl--bind-lets
                        (macroexp-progn
                         `(,@(nreverse cl--bind-forms)
                           ,@body)))))))
321

322
;;;###autoload
323
(defmacro cl-defun (name args &rest body)
324
  "Define NAME as a function.
Richard M. Stallman's avatar
Richard M. Stallman committed
325
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
326
and BODY is implicitly surrounded by (cl-block NAME ...).
327 328

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
329 330
  (declare (debug
            ;; Same as defun but use cl-lambda-list.
331
            (&define [&or name ("setf" :name setf name)]
332 333 334
                     cl-lambda-list
                     cl-declarations-or-string
                     [&optional ("interactive" interactive)]
335
                     def-body))
336
           (doc-string 3)
337
           (indent 2))
338
  (let* ((res (cl--transform-lambda (cons args body) name))
339 340
	 (form `(defun ,name ,@(cdr res))))
    (if (car res) `(progn ,(car res) ,form) form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
341

Daniel Colascione's avatar
Daniel Colascione committed
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
;;;###autoload
(defmacro cl-iter-defun (name args &rest body)
  "Define NAME as a generator function.
Like normal `iter-defun', except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (cl-block NAME ...).

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
  (declare (debug
            ;; Same as iter-defun but use cl-lambda-list.
            (&define [&or name ("setf" :name setf name)]
                     cl-lambda-list
                     cl-declarations-or-string
                     [&optional ("interactive" interactive)]
                     def-body))
           (doc-string 3)
           (indent 2))
  (require 'generator)
  (let* ((res (cl--transform-lambda (cons args body) name))
         (form `(iter-defun ,name ,@(cdr res))))
    (if (car res) `(progn ,(car res) ,form) form)))

363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
;; The lambda list for macros is different from that of normal lambdas.
;; Note that &environment is only allowed as first or last items in the
;; top level list.

(def-edebug-spec cl-macro-list
  (([&optional "&environment" arg]
    [&rest cl-macro-arg]
    [&optional ["&optional" &rest
		&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
    [&optional [[&or "&rest" "&body"] cl-macro-arg]]
    [&optional ["&key" [&rest
			[&or ([&or (symbolp cl-macro-arg) arg]
			      &optional def-form cl-macro-arg)
			     arg]]
		&optional "&allow-other-keys"]]
    [&optional ["&aux" &rest
		&or (symbolp &optional def-form) symbolp]]
    [&optional "&environment" arg]
    )))

(def-edebug-spec cl-macro-arg
  (&or arg cl-macro-list1))

(def-edebug-spec cl-macro-list1
  (([&optional "&whole" arg]  ;; only allowed at lower levels
    [&rest cl-macro-arg]
    [&optional ["&optional" &rest
		&or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
    [&optional [[&or "&rest" "&body"] cl-macro-arg]]
    [&optional ["&key" [&rest
			[&or ([&or (symbolp cl-macro-arg) arg]
			      &optional def-form cl-macro-arg)
			     arg]]
		&optional "&allow-other-keys"]]
    [&optional ["&aux" &rest
		&or (symbolp &optional def-form) symbolp]]
    . [&or arg nil])))

401
;;;###autoload
402
(defmacro cl-defmacro (name args &rest body)
403
  "Define NAME as a macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
404
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
405
and BODY is implicitly surrounded by (cl-block NAME ...).
406 407

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
408
  (declare (debug
409
            (&define name cl-macro-list cl-declarations-or-string def-body))
410
           (doc-string 3)
411
           (indent 2))
412
  (let* ((res (cl--transform-lambda (cons args body) name))
413 414
	 (form `(defmacro ,name ,@(cdr res))))
    (if (car res) `(progn ,(car res) ,form) form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
415

416 417 418 419 420 421
(def-edebug-spec cl-lambda-expr
  (&define ("lambda" cl-lambda-list
	    ;;cl-declarations-or-string
	    ;;[&optional ("interactive" interactive)]
	    def-body)))

422
;; Redefine function-form to also match cl-function
423 424 425 426
(def-edebug-spec function-form
  ;; form at the end could also handle "function",
  ;; but recognize it specially to avoid wrapping function forms.
  (&or ([&or "quote" "function"] &or symbolp lambda-expr)
427
       ("cl-function" cl-function)
428 429
       form))

430
;;;###autoload
431
(defmacro cl-function (func)
432
  "Introduce a function.
433 434
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
435
  (declare (debug (&or symbolp cl-lambda-expr)))
Richard M. Stallman's avatar
Richard M. Stallman committed
436
  (if (eq (car-safe func) 'lambda)
437
      (let* ((res (cl--transform-lambda (cdr func) 'cl-none))
438 439 440
	     (form `(function (lambda . ,(cdr res)))))
	(if (car res) `(progn ,(car res) ,form) form))
    `(function ,func)))
Richard M. Stallman's avatar
Richard M. Stallman committed
441

442 443 444 445 446 447 448 449
(defun cl--make-usage-var (x)
  "X can be a var or a (destructuring) lambda-list."
  (cond
   ((symbolp x) (make-symbol (upcase (symbol-name x))))
   ((consp x) (cl--make-usage-args x))
   (t x)))

(defun cl--make-usage-args (arglist)
450 451 452 453 454
  (let ((aux (ignore-errors (cl-position '&aux arglist))))
    (when aux
      ;; `&aux' args aren't arguments, so let's just drop them from the
      ;; usage info.
      (setq arglist (cl-subseq arglist 0 aux))))
455 456 457 458 459 460 461 462
  (if (cdr-safe (last arglist))         ;Not a proper list.
      (let* ((last (last arglist))
             (tail (cdr last)))
        (unwind-protect
            (progn
              (setcdr last nil)
              (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail)))
          (setcdr last tail)))
463
    ;; `orig-args' can contain &cl-defs.
464 465 466 467 468 469
    (let ((x (memq '&cl-defs arglist)))
      (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
    (let ((state nil))
      (mapcar (lambda (x)
                (cond
                 ((symbolp x)
470 471 472 473 474 475 476 477
                  (let ((first (aref (symbol-name x) 0)))
                    (if (eq ?\& first)
                        (setq state x)
                      ;; Strip a leading underscore, since it only
                      ;; means that this argument is unused.
                      (make-symbol (upcase (if (eq ?_ first)
                                               (substring (symbol-name x) 1)
                                             (symbol-name x)))))))
478 479 480 481 482 483 484 485 486 487 488
                 ((not (consp x)) x)
                 ((memq state '(nil &rest)) (cl--make-usage-args x))
                 (t      ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
                  (cl-list*
                   (if (and (consp (car x)) (eq state '&key))
                       (list (caar x) (cl--make-usage-var (nth 1 (car x))))
                     (cl--make-usage-var (car x)))
                   (nth 1 x)                        ;INITFORM.
                   (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
                   ))))
              arglist))))
489

490 491 492 493
(defun cl--do-&aux (args)
  (while (and (eq (car args) '&aux) (pop args))
    (while (and args (not (memq (car args) cl--lambda-list-keywords)))
      (if (consp (car args))
494
          (if (and cl--bind-enquote (cl-cadar args))
495 496 497 498 499 500
              (cl--do-arglist (caar args)
                              `',(cadr (pop args)))
            (cl--do-arglist (caar args) (cadr (pop args))))
        (cl--do-arglist (pop args) nil))))
  (if args (error "Malformed argument list ends with: %S" args)))

501
(defun cl--do-arglist (args expr &optional num)   ; uses cl--bind-*
Richard M. Stallman's avatar
Richard M. Stallman committed
502
  (if (nlistp args)
503
      (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
504
	  (error "Invalid argument name: %s" args)
505
	(push (list args expr) cl--bind-lets))
506
    (setq args (cl-copy-list args))
Richard M. Stallman's avatar
Richard M. Stallman committed
507 508 509
    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
    (let ((p (memq '&body args))) (if p (setcar p '&rest)))
    (if (memq '&environment args) (error "&environment used incorrectly"))
510
    (let ((restarg (memq '&rest args))
511
	  (safety (if (cl--compiling-file) cl--optimize-safety 3))
Richard M. Stallman's avatar
Richard M. Stallman committed
512 513 514
	  (keys nil)
	  (laterarg nil) (exactarg nil) minarg)
      (or num (setq num 0))
515 516 517
      (setq restarg (if (listp (cadr restarg))
                        (make-symbol "--cl-rest--")
                      (cadr restarg)))
518
      (push (list restarg expr) cl--bind-lets)
Richard M. Stallman's avatar
Richard M. Stallman committed
519
      (if (eq (car args) '&whole)
520
	  (push (list (cl--pop2 args) restarg) cl--bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
521 522
      (let ((p args))
	(setq minarg restarg)
523
	(while (and p (not (memq (car p) cl--lambda-list-keywords)))
Richard M. Stallman's avatar
Richard M. Stallman committed
524 525 526
	  (or (eq p args) (setq minarg (list 'cdr minarg)))
	  (setq p (cdr p)))
	(if (memq (car p) '(nil &aux))
527
	    (setq minarg `(= (length ,restarg)
528
                             ,(length (cl-ldiff args p)))
Richard M. Stallman's avatar
Richard M. Stallman committed
529
		  exactarg (not (eq args p)))))
530
      (while (and args (not (memq (car args) cl--lambda-list-keywords)))
Richard M. Stallman's avatar
Richard M. Stallman committed
531 532
	(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
			    restarg)))
533
	  (cl--do-arglist
534
	   (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
535
	   (if (or laterarg (= safety 0)) poparg
536 537
	     `(if ,minarg ,poparg
                (signal 'wrong-number-of-arguments
538 539
                        (list ,(and (not (eq cl--bind-block 'cl-none))
                                    `',cl--bind-block)
540
                              (length ,restarg)))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
541
	(setq num (1+ num) laterarg t))
542
      (while (and (eq (car args) '&optional) (pop args))
543
	(while (and args (not (memq (car args) cl--lambda-list-keywords)))
544
	  (let ((arg (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
545
	    (or (consp arg) (setq arg (list arg)))
546
	    (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t)))
Richard M. Stallman's avatar
Richard M. Stallman committed
547
	    (let ((def (if (cdr arg) (nth 1 arg)
548 549
			 (or (car cl--bind-defs)
			     (nth 1 (assq (car arg) cl--bind-defs)))))
550
		  (poparg `(pop ,restarg)))
551
	      (and def cl--bind-enquote (setq def `',def))
552
	      (cl--do-arglist (car arg)
553
			     (if def `(if ,restarg ,poparg ,def) poparg))
Richard M. Stallman's avatar
Richard M. Stallman committed
554 555
	      (setq num (1+ num))))))
      (if (eq (car args) '&rest)
556
	  (let ((arg (cl--pop2 args)))
557
	    (if (consp arg) (cl--do-arglist arg restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
558
	(or (eq (car args) '&key) (= safety 0) exactarg
559 560 561
	    (push `(if ,restarg
                       (signal 'wrong-number-of-arguments
                               (list
562 563
                                ,(and (not (eq cl--bind-block 'cl-none))
                                      `',cl--bind-block)
564
                                (+ ,num (length ,restarg)))))
565
                  cl--bind-forms)))
566
      (while (and (eq (car args) '&key) (pop args))
567
	(while (and args (not (memq (car args) cl--lambda-list-keywords)))
568
	  (let ((arg (pop args)))
569
	    (or (consp arg) (setq arg (list arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
570
	    (let* ((karg (if (consp (car arg)) (caar arg)
571 572 573 574 575 576 577
                           (let ((name (symbol-name (car arg))))
                             ;; Strip a leading underscore, since it only
                             ;; means that this argument is unused, but
                             ;; shouldn't affect the key's name (bug#12367).
                             (if (eq ?_ (aref name 0))
                                 (setq name (substring name 1)))
                             (intern (format ":%s" name)))))
578
		   (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
579
		   (def (if (cdr arg) (cadr arg)
580 581 582 583 584 585
                          ;; The ordering between those two or clauses is
                          ;; irrelevant, since in practice only one of the two
                          ;; is ever non-nil (the car is only used for
                          ;; cl-deftype which doesn't use the cdr).
			  (or (car cl--bind-defs)
                              (cadr (assq varg cl--bind-defs)))))
586
                   (look `(plist-member ,restarg ',karg)))
587
	      (and def cl--bind-enquote (setq def `',def))
Richard M. Stallman's avatar
Richard M. Stallman committed
588
	      (if (cddr arg)
589
		  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
590
			 (val `(car (cdr ,temp))))
591 592
		    (cl--do-arglist temp look)
		    (cl--do-arglist varg
593 594 595
				   `(if ,temp
                                        (prog1 ,val (setq ,temp t))
                                      ,def)))
596
		(cl--do-arglist
Richard M. Stallman's avatar
Richard M. Stallman committed
597
		 varg
598
		 `(car (cdr ,(if (null def)
Richard M. Stallman's avatar
Richard M. Stallman committed
599
				 look
600
			       `(or ,look
601
                                    ,(if (eq (cl--const-expr-p def) t)
602
					 `'(nil ,(cl--const-expr-val def))
603
				       `(list nil ,def))))))))
604
	      (push karg keys)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
605
      (setq keys (nreverse keys))
606
      (or (and (eq (car args) '&allow-other-keys) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
607
	  (null keys) (= safety 0)
608
	  (let* ((var (make-symbol "--cl-keys--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
609
		 (allow '(:allow-other-keys))
610 611 612 613 614 615 616 617 618 619 620
		 (check `(while ,var
                           (cond
                            ((memq (car ,var) ',(append keys allow))
                             (setq ,var (cdr (cdr ,var))))
                            ((car (cdr (memq (quote ,@allow) ,restarg)))
                             (setq ,var nil))
                            (t
                             (error
                              ,(format "Keyword argument %%s not one of %s"
                                       keys)
                              (car ,var)))))))
621
	    (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
622 623
      (cl--do-&aux args)
      nil)))
Richard M. Stallman's avatar
Richard M. Stallman committed
624

625
(defun cl--arglist-args (args)
Richard M. Stallman's avatar
Richard M. Stallman committed
626 627 628
  (if (nlistp args) (list args)
    (let ((res nil) (kind nil) arg)
      (while (consp args)
629
	(setq arg (pop args))
630
	(if (memq arg cl--lambda-list-keywords) (setq kind arg)
631
	  (if (eq arg '&cl-defs) (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
632 633
	    (and (consp arg) kind (setq arg (car arg)))
	    (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
634
	    (setq res (nconc res (cl--arglist-args arg))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
635 636
      (nconc res (and args (list args))))))

637
;;;###autoload
638
(defmacro cl-destructuring-bind (args expr &rest body)
Glenn Morris's avatar
Glenn Morris committed
639
  "Bind the variables in ARGS to the result of EXPR and execute BODY."
640 641
  (declare (indent 2)
           (debug (&define cl-macro-list def-form cl-declarations def-body)))
642
  (let* ((cl--bind-lets nil) (cl--bind-forms nil)
643
	 (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
644
    (cl--do-arglist (or args '(&aux)) expr)
645 646
    (macroexp-let* (nreverse cl--bind-lets)
                   (macroexp-progn (append (nreverse cl--bind-forms) body)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
647 648


649
;;; The `cl-eval-when' form.
Richard M. Stallman's avatar
Richard M. Stallman committed
650

651
(defvar cl--not-toplevel nil)
Richard M. Stallman's avatar
Richard M. Stallman committed
652

653
;;;###autoload
654
(defmacro cl-eval-when (when &rest body)
655
  "Control when BODY is evaluated.
Richard M. Stallman's avatar
Richard M. Stallman committed
656 657
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
658 659 660
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.

\(fn (WHEN...) BODY...)"
661
  (declare (indent 1) (debug (sexp body)))
662
  (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
663
	   (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
664
      (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
665
	    (cl--not-toplevel t))
666
	(if (or (memq 'load when) (memq :load-toplevel when))
667
	    (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
668
	      `(if nil nil ,@body))
Richard M. Stallman's avatar
Richard M. Stallman committed
669
	  (progn (if comp (eval (cons 'progn body))) nil)))
670
    (and (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
671 672
	 (cons 'progn body))))

673
(defun cl--compile-time-too (form)
Richard M. Stallman's avatar
Richard M. Stallman committed
674 675
  (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
      (setq form (macroexpand
676
		  form (cons '(cl-eval-when) byte-compile-macro-environment))))
Richard M. Stallman's avatar
Richard M. Stallman committed
677
  (cond ((eq (car-safe form) 'progn)
678
	 (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
679
	((eq (car-safe form) 'cl-eval-when)
Richard M. Stallman's avatar
Richard M. Stallman committed
680
	 (let ((when (nth 1 form)))
681
	   (if (or (memq 'eval when) (memq :execute when))
682
	       `(cl-eval-when (compile ,@when) ,@(cddr form))
Richard M. Stallman's avatar
Richard M. Stallman committed
683 684 685
	     form)))
	(t (eval form) form)))

686
;;;###autoload
687
(defmacro cl-load-time-value (form &optional _read-only)
Richard M. Stallman's avatar
Richard M. Stallman committed
688 689
  "Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
690
  (declare (debug (form &optional sexp)))
691
  (if (cl--compiling-file)
692
      (let* ((temp (cl-gentemp "--cl-load-time--"))
693
	     (set `(setq ,temp ,form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
694 695
	(if (and (fboundp 'byte-compile-file-form-defmumble)
		 (boundp 'this-kind) (boundp 'that-one))
696 697 698 699 700 701 702 703 704 705 706 707 708 709
            ;; Else, we can't output right away, so we have to delay it to the
            ;; next time we're at the top-level.
            ;; FIXME: Use advice-add/remove.
            (fset 'byte-compile-file-form
                  (let ((old (symbol-function 'byte-compile-file-form)))
                    (lambda (form)
                      (fset 'byte-compile-file-form old)
                      (byte-compile-file-form set)
                      (byte-compile-file-form form))))
          ;; If we're not in the middle of compiling something, we can
          ;; output directly to byte-compile-outbuffer, to make sure
          ;; temp is set before we use it.
          (print set byte-compile--outbuffer))
	temp)
710
    `',(eval form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
711 712 713 714


;;; Conditional control structures.

715
;;;###autoload
716
(defmacro cl-case (expr &rest clauses)
717
  "Eval EXPR and choose among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
718 719
Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
720
If no clause succeeds, cl-case returns nil.  A single atom may be used in
721
place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
Richard M. Stallman's avatar
Richard M. Stallman committed
722
allowed only in the final clause, and matches if no other keys match.
723 724
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
725
  (declare (indent 1) (debug (form &rest (sexp body))))
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
  (macroexp-let2 macroexp-copyable-p temp expr
    (let* ((head-list nil))
      `(cond
        ,@(mapcar
           (lambda (c)
             (cons (cond ((memq (car c) '(t otherwise)) t)
                         ((eq (car c) 'cl--ecase-error-flag)
                          `(error "cl-ecase failed: %s, %s"
                                  ,temp ',(reverse head-list)))
                         ((listp (car c))
                          (setq head-list (append (car c) head-list))
                          `(cl-member ,temp ',(car c)))
                         (t
                          (if (memq (car c) head-list)
                              (error "Duplicate key in case: %s"
                                     (car c)))
                          (push (car c) head-list)
                          `(eql ,temp ',(car c))))
                   (or (cdr c) '(nil))))
           clauses)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
746

747
;;;###autoload
748
(defmacro cl-ecase (expr &rest clauses)
749
  "Like `cl-case', but error if no case fits.
750 751
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
752 753
  (declare (indent 1) (debug cl-case))
  `(cl-case ,expr ,@clauses (cl--ecase-error-flag)))
Richard M. Stallman's avatar
Richard M. Stallman committed
754

755
;;;###autoload
756
(defmacro cl-typecase (expr &rest clauses)
757
  "Evals EXPR, chooses among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
758 759
Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
760
cl-typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
761 762
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
763 764
  (declare (indent 1)
           (debug (form &rest ([&or cl-type-spec "otherwise"] body))))
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
  (macroexp-let2 macroexp-copyable-p temp expr
    (let* ((type-list nil))
      (cons
       'cond
       (mapcar
        (function
         (lambda (c)
           (cons (cond ((eq (car c) 'otherwise) t)
                       ((eq (car c) 'cl--ecase-error-flag)
                        `(error "cl-etypecase failed: %s, %s"
                                ,temp ',(reverse type-list)))
                       (t
                        (push (car c) type-list)
                        `(cl-typep ,temp ',(car c))))
                 (or (cdr c) '(nil)))))
        clauses)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
781

782
;;;###autoload
783 784
(defmacro cl-etypecase (expr &rest clauses)
  "Like `cl-typecase', but error if no case fits.
785 786
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
787 788
  (declare (indent 1) (debug cl-typecase))
  `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag)))
Richard M. Stallman's avatar
Richard M. Stallman committed
789 790 791 792


;;; Blocks and exits.

793
;;;###autoload
794
(defmacro cl-block (name &rest body)
795
  "Define a lexically-scoped block named NAME.
796
NAME may be any symbol.  Code inside the BODY forms can call `cl-return-from'
Richard M. Stallman's avatar
Richard M. Stallman committed
797 798 799 800 801 802
to jump prematurely out of the block.  This differs from `catch' and `throw'
in two respects:  First, the NAME is an unevaluated symbol rather than a
quoted symbol or other form; and second, NAME is lexically rather than
dynamically scoped:  Only references to it within BODY will work.  These
references may appear inside macro expansions, but not inside functions
called from BODY."
803
  (declare (indent 1) (debug (symbolp body)))
804
  (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
805
    `(cl--block-wrapper
806 807
      (catch ',(intern (format "--cl-block-%s--" name))
        ,@body))))
Richard M. Stallman's avatar
Richard M. Stallman committed
808

809
;;;###autoload
810
(defmacro cl-return (&optional result)
811
  "Return from the block named nil.
812
This is equivalent to `(cl-return-from nil RESULT)'."
813
  (declare (debug (&optional form)))
814
  `(cl-return-from nil ,result))
Richard M. Stallman's avatar
Richard M. Stallman committed
815

816
;;;###autoload
817
(defmacro cl-return-from (name &optional result)
818
  "Return from the block named NAME.
819
This jumps out to the innermost enclosing `(cl-block NAME ...)' form,
Richard M. Stallman's avatar
Richard M. Stallman committed
820 821 822
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
823
  (declare (indent 1) (debug (symbolp &optional form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
824
  (let ((name2 (intern (format "--cl-block-%s--" name))))
825
    `(cl--block-throw ',name2 ,result)))
Richard M. Stallman's avatar
Richard M. Stallman committed
826 827


828
;;; The "cl-loop" macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
829

830
(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
Stefan Monnier's avatar
Stefan Monnier committed
831 832 833
(defvar cl--loop-bindings) (defvar cl--loop-body)
(defvar cl--loop-finally)
(defvar cl--loop-finish-flag)           ;Symbol set to nil to exit the loop?
834
(defvar cl--loop-first-flag)
Stefan Monnier's avatar
Stefan Monnier committed
835 836
(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
(defvar cl--loop-name)
837
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
838 839
(defvar cl--loop-result-var) (defvar cl--loop-steps)
(defvar cl--loop-symbol-macs)
Richard M. Stallman's avatar
Richard M. Stallman committed
840

Stefan Monnier's avatar
Stefan Monnier committed
841 842 843 844 845 846
(defun cl--loop-set-iterator-function (kind iterator)
  (if cl--loop-iterator-function
      ;; FIXME: Of course, we could make it work, but why bother.
      (error "Iteration on %S does not support this combination" kind)
    (setq cl--loop-iterator-function iterator)))

847
;;;###autoload
848
(defmacro cl-loop (&rest loop-args)
849
  "The Common Lisp `loop' macro.
850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
Valid clauses include:
  For clauses:
    for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3
    for VAR = EXPR1 then EXPR2
    for VAR in/on/in-ref LIST by FUNC
    for VAR across/across-ref ARRAY
    for VAR being:
      the elements of/of-ref SEQUENCE [using (index VAR2)]
      the symbols [of OBARRAY]
      the hash-keys/hash-values of HASH-TABLE [using (hash-values/hash-keys V2)]
      the key-codes/key-bindings/key-seqs of KEYMAP [using (key-bindings VAR2)]
      the overlays/intervals [of BUFFER] [from POS1] [to POS2]
      the frames/buffers
      the windows [of FRAME]
  Iteration clauses:
    repeat INTEGER
    while/until/always/never/thereis CONDITION
  Accumulation clauses:
    collect/append/nconc/concat/vconcat/count/sum/maximize/minimize FORM
      [into VAR]
  Miscellaneous clauses:
    with VAR = INIT
    if/when/unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...]
    named NAME
    initially/finally [do] EXPRS...
    do EXPRS...
    [finally] return EXPR

For more details, see Info node `(cl)Loop Facility'.
879 880

\(fn CLAUSE...)"
881 882 883 884 885 886 887 888 889 890 891 892
  (declare (debug (&rest &or
                         ;; These are usually followed by a symbol, but it can
                         ;; actually be any destructuring-bind pattern, which
                         ;; would erroneously match `form'.
                         [[&or "for" "as" "with" "and"] sexp]
                         ;; These are followed by expressions which could
                         ;; erroneously match `symbolp'.
                         [[&or "from" "upfrom" "downfrom" "to" "upto" "downto"
                               "above" "below" "by" "in" "on" "=" "across"
                               "repeat" "while" "until" "always" "never"
                               "thereis" "collect" "append" "nconc" "sum"
                               "count" "maximize" "minimize" "if" "unless"
893 894
                               "return"]
                          form]
895 896
                         ;; Simple default, which covers 99% of the cases.
                         symbolp form)))
897 898
  (if (not (memq t (mapcar #'symbolp
                           (delq nil (delq t (cl-copy-list loop-args))))))
899 900
      `(cl-block nil (while t ,@loop-args))
    (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil)
Stefan Monnier's avatar
Stefan Monnier committed
901 902 903
	  (cl--loop-body nil)		(cl--loop-steps nil)
	  (cl--loop-result nil)		(cl--loop-result-explicit nil)
	  (cl--loop-result-var nil)	(cl--loop-finish-flag nil)
904 905
	  (cl--loop-accum-var nil)	(cl--loop-accum-vars nil)
	  (cl--loop-initially nil)	(cl--loop-finally nil)
Stefan Monnier's avatar
Stefan Monnier committed
906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929
	  (cl--loop-iterator-function nil) (cl--loop-first-flag nil)
          (cl--loop-symbol-macs nil))
      ;; Here is more or less how those dynbind vars are used after looping
      ;; over cl--parse-loop-clause:
      ;;
      ;; (cl-block ,cl--loop-name
      ;;   (cl-symbol-macrolet ,cl--loop-symbol-macs
      ;;     (foldl #'cl--loop-let
      ;;            `((,cl--loop-result-var)
      ;;              ((,cl--loop-first-flag t))
      ;;              ((,cl--loop-finish-flag t))
      ;;              ,@cl--loop-bindings)
      ;;           ,@(nreverse cl--loop-initially)
      ;;           (while                   ;(well: cl--loop-iterator-function)
      ;;               ,(car (cl--loop-build-ands (nreverse cl--loop-body)))
      ;;             ,@(cadr (cl--loop-build-ands (nreverse cl--loop-body)))
      ;;             ,@(nreverse cl--loop-steps)
      ;;             (setq ,cl--loop-first-flag nil))
      ;;           (if (not ,cl--loop-finish-flag) ;FIXME: Why `if' vs `progn'?
      ;;               ,cl--loop-result-var
      ;;             ,@(nreverse cl--loop-finally)
      ;;             ,(or cl--loop-result-explicit
      ;;                  cl--loop-result)))))
      ;;
930
      (setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
931 932
      (while (not (eq (car cl--loop-args) 'cl-end-loop))
        (cl--parse-loop-clause))
933 934 935 936 937 938
      (if cl--loop-finish-flag
	  (push `((,cl--loop-finish-flag t)) cl--loop-bindings))
      (if cl--loop-first-flag
	  (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings)
		 (push `(setq ,cl--loop-first-flag nil) cl--loop-steps)))
      (let* ((epilogue (nconc (nreverse cl--loop-finally)
939 940
			      (list (or cl--loop-result-explicit
                                        cl--loop-result))))
941 942
	     (ands (cl--loop-build-ands (nreverse cl--loop-body)))
	     (while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
943
	     (body (append
944
		    (nreverse cl--loop-initially)
Stefan Monnier's avatar
Stefan Monnier committed
945
		    (list (if cl--loop-iterator-function
946
			      `(cl-block --cl-finish--
Stefan Monnier's avatar
Stefan Monnier committed
947 948 949 950 951 952 953
                                 ,(funcall cl--loop-iterator-function
                                           (if (eq (car ands) t) while-body
                                             (cons `(or ,(car ands)
                                                        (cl-return-from
                                                            --cl-finish--
                                                          nil))
                                                   while-body))))
954
			    `(while ,(car ands) ,@while-body)))
955 956 957 958
		    (if cl--loop-finish-flag
			(if (equal epilogue '(nil)) (list cl--loop-result-var)
			  `((if ,cl--loop-finish-flag
				(progn ,@epilogue) ,cl--loop-result-var)))
Richard M. Stallman's avatar
Richard M. Stallman committed
959
		      epilogue))))
960 961
	(if cl--loop-result-var
            (push (list cl--loop-result-var) cl--loop-bindings))
962 963 964
	(while cl--loop-bindings
	  (if (cdar cl--loop-bindings)
	      (setq body (list (cl--loop-let (pop cl--loop-bindings) body t)))
Richard M. Stallman's avatar
Richard M. Stallman committed
965
	    (let ((lets nil))
966 967 968 969 970
	      (while (and cl--loop-bindings
			  (not (cdar cl--loop-bindings)))
		(push (car (pop cl--loop-bindings)) lets))
	      (setq body (list (cl--loop-let lets body nil))))))
	(if cl--loop-symbol-macs