cl-macs.el 117 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

3
;; Copyright (C) 1993, 2001-2014 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 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
;; 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))

;;;###autoload
(defun cl--compiler-macro-cXXr (form x)
  (let* ((head (car form))
         (n (symbol-name (car form)))
         (i (- (length n) 2)))
    (if (not (string-match "c[ad]+r\\'" n))
        (if (and (fboundp head) (symbolp (symbol-function head)))
            (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
                                     x)
          (error "Compiler macro for cXXr applied to non-cXXr form"))
      (while (> i (match-beginning 0))
        (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
        (setq i (1- i)))
      x)))

88 89 90
;;; 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
91

92
(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
93
			    car-safe cdr-safe progn prog1 prog2))
94
(defconst cl--safe-funcs '(* / % length memq list vector vectorp
95 96
			  < > <= >= = error))

97 98
(defun cl--simple-expr-p (x &optional size)
  "Check if no side effects, and executes quickly."
99
  (or size (setq size 10))
100
  (if (and (consp x) (not (memq (car x) '(quote function cl-function))))
101
      (and (symbolp (car x))
102
	   (or (memq (car x) cl--simple-funcs)
103 104 105 106
	       (get (car x) 'side-effect-free))
	   (progn
	     (setq size (1- size))
	     (while (and (setq x (cdr x))
107
			 (setq size (cl--simple-expr-p (car x) size))))
108 109 110
	     (and (null x) (>= size 0) size)))
    (and (> size 0) (1- size))))

111 112
(defun cl--simple-exprs-p (xs)
  (while (and xs (cl--simple-expr-p (car xs)))
113 114 115
    (setq xs (cdr xs)))
  (not xs))

116 117
(defun cl--safe-expr-p (x)
  "Check if no side effects."
118
  (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
119
      (and (symbolp (car x))
120 121
	   (or (memq (car x) cl--simple-funcs)
	       (memq (car x) cl--safe-funcs)
122 123
	       (get (car x) 'side-effect-free))
	   (progn
124
	     (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
125 126 127
	     (null x)))))

;;; Check if constant (i.e., no side effects or dependencies).
128
(defun cl--const-expr-p (x)
129 130
  (cond ((consp x)
	 (or (eq (car x) 'quote)
131
	     (and (memq (car x) '(function cl-function))
132 133 134 135 136
		  (or (symbolp (nth 1 x))
		      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
	((symbolp x) (and (memq x '(nil t)) t))
	(t t)))

137
(defun cl--const-expr-val (x)
Daniel Colascione's avatar
Daniel Colascione committed
138
  "Return the value of X known at compile-time.
139 140 141 142
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
143
    (if (macroexp-const-p x)
144
        (if (consp x) (nth 1 x) x))))
145

146 147
(defun cl--expr-contains (x y)
  "Count number of times X refers to Y.  Return nil for 0 times."
148
  ;; FIXME: This is naive, and it will cl-count Y as referred twice in
149 150 151
  ;; (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.
152
  (cond ((equal y x) 1)
153
	((and (consp x) (not (memq (car x) '(quote function cl-function))))
154
	 (let ((sum 0))
155
	   (while (consp x)
156 157
	     (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
	   (setq sum (+ sum (or (cl--expr-contains x y) 0)))
158 159 160
	   (and (> sum 0) sum)))
	(t nil)))

161 162
(defun cl--expr-contains-any (x y)
  (while (and y (not (cl--expr-contains x (car y)))) (pop y))
163 164
  y)

165 166 167 168
(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))))
169

Richard M. Stallman's avatar
Richard M. Stallman committed
170 171
;;; Symbols.

172
(defvar cl--gensym-counter)
173
;;;###autoload
174
(defun cl-gensym (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
175 176
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
177 178
  (let ((pfix (if (stringp prefix) prefix "G"))
	(num (if (integerp prefix) prefix
179 180
	       (prog1 cl--gensym-counter
		 (setq cl--gensym-counter (1+ cl--gensym-counter))))))
181
    (make-symbol (format "%s%d" pfix num))))
Richard M. Stallman's avatar
Richard M. Stallman committed
182

183
;;;###autoload
184
(defun cl-gentemp (&optional prefix)
Richard M. Stallman's avatar
Richard M. Stallman committed
185 186
  "Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
187
  (let ((pfix (if (stringp prefix) prefix "G"))
Richard M. Stallman's avatar
Richard M. Stallman committed
188
	name)
189 190
    (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
191 192 193 194 195
    (intern name)))


;;; Program structure.

196
(def-edebug-spec cl-declarations
197
  (&rest ("cl-declare" &rest sexp)))
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217

(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))

218 219
(def-edebug-spec cl-type-spec sexp)

220 221 222 223 224 225 226
(defconst cl--lambda-list-keywords
  '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))

(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)

(defun cl--transform-lambda (form bind-block)
227 228 229 230 231
  "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)."
232 233 234 235 236
  (let* ((args (car form)) (body (cdr form)) (orig-args args)
	 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
	 (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
	 (header nil) (simple-args nil))
    (while (or (stringp (car body))
237
	       (memq (car-safe (car body)) '(interactive declare cl-declare)))
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
      (push (pop body) header))
    (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)))))
    (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
	(setq args (delq '&cl-defs (delq cl--bind-defs args))
	      cl--bind-defs (cadr cl--bind-defs)))
    (if (setq cl--bind-enquote (memq '&cl-quote args))
	(setq args (delq '&cl-quote args)))
    (if (memq '&whole args) (error "&whole not currently implemented"))
    (let* ((p (memq '&environment args)) (v (cadr p))
           (env-exp 'macroexpand-all-environment))
      (if p (setq args (nconc (delq (car p) (delq v args))
                              (list '&aux (list v env-exp))))))
    (while (and args (symbolp (car args))
		(not (memq (car args) '(nil &rest &body &key &aux)))
		(not (and (eq (car args) '&optional)
			  (or cl--bind-defs (consp (cadr args))))))
      (push (pop args) simple-args))
    (or (eq cl--bind-block 'cl-none)
	(setq body (list `(cl-block ,cl--bind-block ,@body))))
    (if (null args)
	(cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
      (if (memq '&optional simple-args) (push '&optional args))
      (cl--do-arglist args nil (- (length simple-args)
                                  (if (memq '&optional simple-args) 1 0)))
      (setq cl--bind-lets (nreverse cl--bind-lets))
      (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
                                ,@(nreverse cl--bind-inits)))
	     (nconc (nreverse simple-args)
		    (list '&rest (car (pop cl--bind-lets))))
	     (nconc (let ((hdr (nreverse header)))
                      ;; Macro expansion can take place in the middle of
                      ;; apparently harmless computation, so it should not
                      ;; touch the match-data.
                      (save-match-data
                        (require 'help-fns)
                        (cons (help-add-fundoc-usage
                               (if (stringp (car hdr)) (pop hdr))
276 277 278 279 280
                               ;; 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)))))
281 282 283 284 285
                              hdr)))
		    (list `(let* ,cl--bind-lets
                             ,@(nreverse cl--bind-forms)
                             ,@body)))))))

286
;;;###autoload
287
(defmacro cl-defun (name args &rest body)
288
  "Define NAME as a function.
Richard M. Stallman's avatar
Richard M. Stallman committed
289
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
290
and BODY is implicitly surrounded by (cl-block NAME ...).
291 292

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
293 294
  (declare (debug
            ;; Same as defun but use cl-lambda-list.
295
            (&define [&or name ("setf" :name setf name)]
296 297 298
                     cl-lambda-list
                     cl-declarations-or-string
                     [&optional ("interactive" interactive)]
299
                     def-body))
300
           (doc-string 3)
301
           (indent 2))
302
  (let* ((res (cl--transform-lambda (cons args body) name))
303 304
	 (form `(defun ,name ,@(cdr res))))
    (if (car res) `(progn ,(car res) ,form) form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
305

306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
;; 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])))

344
;;;###autoload
345
(defmacro cl-defmacro (name args &rest body)
346
  "Define NAME as a macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
347
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
348
and BODY is implicitly surrounded by (cl-block NAME ...).
349 350

\(fn NAME ARGLIST [DOCSTRING] BODY...)"
351
  (declare (debug
352
            (&define name cl-macro-list cl-declarations-or-string def-body))
353
           (doc-string 3)
354
           (indent 2))
355
  (let* ((res (cl--transform-lambda (cons args body) name))
356 357
	 (form `(defmacro ,name ,@(cdr res))))
    (if (car res) `(progn ,(car res) ,form) form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
358

359 360 361 362 363 364
(def-edebug-spec cl-lambda-expr
  (&define ("lambda" cl-lambda-list
	    ;;cl-declarations-or-string
	    ;;[&optional ("interactive" interactive)]
	    def-body)))

365
;; Redefine function-form to also match cl-function
366 367 368 369
(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)
370
       ("cl-function" cl-function)
371 372
       form))

373
;;;###autoload
374
(defmacro cl-function (func)
375
  "Introduce a function.
376 377
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
378
  (declare (debug (&or symbolp cl-lambda-expr)))
Richard M. Stallman's avatar
Richard M. Stallman committed
379
  (if (eq (car-safe func) 'lambda)
380
      (let* ((res (cl--transform-lambda (cdr func) 'cl-none))
381 382 383
	     (form `(function (lambda . ,(cdr res)))))
	(if (car res) `(progn ,(car res) ,form) form))
    `(function ,func)))
Richard M. Stallman's avatar
Richard M. Stallman committed
384

385 386
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))

387 388 389 390 391 392 393 394
(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)
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410
  (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)))
    ;; `orig-args' can contain &cl-defs (an internal
    ;; CL thingy I don't understand), so remove it.
    (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)
411 412 413 414 415 416 417 418
                  (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)))))))
419 420 421 422 423 424 425 426 427 428 429
                 ((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))))
430

431
(defun cl--do-arglist (args expr &optional num)   ; uses bind-*
Richard M. Stallman's avatar
Richard M. Stallman committed
432
  (if (nlistp args)
433
      (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
434
	  (error "Invalid argument name: %s" args)
435
	(push (list args expr) cl--bind-lets))
436
    (setq args (cl-copy-list args))
Richard M. Stallman's avatar
Richard M. Stallman committed
437 438 439 440 441
    (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"))
    (let ((save-args args)
	  (restarg (memq '&rest args))
442
	  (safety (if (cl--compiling-file) cl--optimize-safety 3))
Richard M. Stallman's avatar
Richard M. Stallman committed
443 444 445 446
	  (keys nil)
	  (laterarg nil) (exactarg nil) minarg)
      (or num (setq num 0))
      (if (listp (cadr restarg))
447
	  (setq restarg (make-symbol "--cl-rest--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
448
	(setq restarg (cadr restarg)))
449
      (push (list restarg expr) cl--bind-lets)
Richard M. Stallman's avatar
Richard M. Stallman committed
450
      (if (eq (car args) '&whole)
451
	  (push (list (cl--pop2 args) restarg) cl--bind-lets))
Richard M. Stallman's avatar
Richard M. Stallman committed
452 453
      (let ((p args))
	(setq minarg restarg)
454
	(while (and p (not (memq (car p) cl--lambda-list-keywords)))
Richard M. Stallman's avatar
Richard M. Stallman committed
455 456 457
	  (or (eq p args) (setq minarg (list 'cdr minarg)))
	  (setq p (cdr p)))
	(if (memq (car p) '(nil &aux))
458
	    (setq minarg `(= (length ,restarg)
459
                             ,(length (cl-ldiff args p)))
Richard M. Stallman's avatar
Richard M. Stallman committed
460
		  exactarg (not (eq args p)))))
461
      (while (and args (not (memq (car args) cl--lambda-list-keywords)))
Richard M. Stallman's avatar
Richard M. Stallman committed
462 463
	(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
			    restarg)))
464
	  (cl--do-arglist
465
	   (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
466
	   (if (or laterarg (= safety 0)) poparg
467 468
	     `(if ,minarg ,poparg
                (signal 'wrong-number-of-arguments
469 470
                        (list ,(and (not (eq cl--bind-block 'cl-none))
                                    `',cl--bind-block)
471
                              (length ,restarg)))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
472
	(setq num (1+ num) laterarg t))
473
      (while (and (eq (car args) '&optional) (pop args))
474
	(while (and args (not (memq (car args) cl--lambda-list-keywords)))
475
	  (let ((arg (pop args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
476
	    (or (consp arg) (setq arg (list arg)))
477
	    (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t)))
Richard M. Stallman's avatar
Richard M. Stallman committed
478
	    (let ((def (if (cdr arg) (nth 1 arg)
479 480
			 (or (car cl--bind-defs)
			     (nth 1 (assq (car arg) cl--bind-defs)))))
481
		  (poparg `(pop ,restarg)))
482
	      (and def cl--bind-enquote (setq def `',def))
483
	      (cl--do-arglist (car arg)
484
			     (if def `(if ,restarg ,poparg ,def) poparg))
Richard M. Stallman's avatar
Richard M. Stallman committed
485 486
	      (setq num (1+ num))))))
      (if (eq (car args) '&rest)
487
	  (let ((arg (cl--pop2 args)))
488
	    (if (consp arg) (cl--do-arglist arg restarg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
489
	(or (eq (car args) '&key) (= safety 0) exactarg
490 491 492
	    (push `(if ,restarg
                       (signal 'wrong-number-of-arguments
                               (list
493 494
                                ,(and (not (eq cl--bind-block 'cl-none))
                                      `',cl--bind-block)
495
                                (+ ,num (length ,restarg)))))
496
                  cl--bind-forms)))
497
      (while (and (eq (car args) '&key) (pop args))
498
	(while (and args (not (memq (car args) cl--lambda-list-keywords)))
499
	  (let ((arg (pop args)))
500
	    (or (consp arg) (setq arg (list arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
501
	    (let* ((karg (if (consp (car arg)) (caar arg)
502 503 504 505 506 507 508
                           (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)))))
509
		   (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
510
		   (def (if (cdr arg) (cadr arg)
511
			  (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
512
                   (look `(plist-member ,restarg ',karg)))
513
	      (and def cl--bind-enquote (setq def `',def))
Richard M. Stallman's avatar
Richard M. Stallman committed
514
	      (if (cddr arg)
515
		  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
516
			 (val `(car (cdr ,temp))))
517 518
		    (cl--do-arglist temp look)
		    (cl--do-arglist varg
519 520 521
				   `(if ,temp
                                        (prog1 ,val (setq ,temp t))
                                      ,def)))
522
		(cl--do-arglist
Richard M. Stallman's avatar
Richard M. Stallman committed
523
		 varg
524
		 `(car (cdr ,(if (null def)
Richard M. Stallman's avatar
Richard M. Stallman committed
525
				 look
526
			       `(or ,look
527
                                    ,(if (eq (cl--const-expr-p def) t)
528
					 `'(nil ,(cl--const-expr-val def))
529
				       `(list nil ,def))))))))
530
	      (push karg keys)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
531
      (setq keys (nreverse keys))
532
      (or (and (eq (car args) '&allow-other-keys) (pop args))
Richard M. Stallman's avatar
Richard M. Stallman committed
533
	  (null keys) (= safety 0)
534
	  (let* ((var (make-symbol "--cl-keys--"))
Richard M. Stallman's avatar
Richard M. Stallman committed
535
		 (allow '(:allow-other-keys))
536 537 538 539 540 541 542 543 544 545 546
		 (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)))))))
547
	    (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
548
      (while (and (eq (car args) '&aux) (pop args))
549
	(while (and args (not (memq (car args) cl--lambda-list-keywords)))
Richard M. Stallman's avatar
Richard M. Stallman committed
550
	  (if (consp (car args))
551
	      (if (and cl--bind-enquote (cl-cadar args))
552
		  (cl--do-arglist (caar args)
553
				 `',(cadr (pop args)))
554 555
		(cl--do-arglist (caar args) (cadr (pop args))))
	    (cl--do-arglist (pop args) nil))))
Richard M. Stallman's avatar
Richard M. Stallman committed
556 557
      (if args (error "Malformed argument list %s" save-args)))))

558
(defun cl--arglist-args (args)
Richard M. Stallman's avatar
Richard M. Stallman committed
559 560 561
  (if (nlistp args) (list args)
    (let ((res nil) (kind nil) arg)
      (while (consp args)
562
	(setq arg (pop args))
563
	(if (memq arg cl--lambda-list-keywords) (setq kind arg)
564
	  (if (eq arg '&cl-defs) (pop args)
Richard M. Stallman's avatar
Richard M. Stallman committed
565 566
	    (and (consp arg) kind (setq arg (car arg)))
	    (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
567
	    (setq res (nconc res (cl--arglist-args arg))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
568 569
      (nconc res (and args (list args))))))

570
;;;###autoload
571
(defmacro cl-destructuring-bind (args expr &rest body)
Glenn Morris's avatar
Glenn Morris committed
572
  "Bind the variables in ARGS to the result of EXPR and execute BODY."
573 574
  (declare (indent 2)
           (debug (&define cl-macro-list def-form cl-declarations def-body)))
575 576
  (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil)
	 (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil))
577
    (cl--do-arglist (or args '(&aux)) expr)
578 579 580
    (append '(progn) cl--bind-inits
	    (list `(let* ,(nreverse cl--bind-lets)
                     ,@(nreverse cl--bind-forms) ,@body)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
581 582


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

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

587
;;;###autoload
588
(defmacro cl-eval-when (when &rest body)
589
  "Control when BODY is evaluated.
Richard M. Stallman's avatar
Richard M. Stallman committed
590 591
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.
592 593 594
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.

\(fn (WHEN...) BODY...)"
595
  (declare (indent 1) (debug (sexp body)))
596
  (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
597
	   (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
598
      (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
599
	    (cl--not-toplevel t))
600
	(if (or (memq 'load when) (memq :load-toplevel when))
601
	    (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
602
	      `(if nil nil ,@body))
Richard M. Stallman's avatar
Richard M. Stallman committed
603
	  (progn (if comp (eval (cons 'progn body))) nil)))
604
    (and (or (memq 'eval when) (memq :execute when))
Richard M. Stallman's avatar
Richard M. Stallman committed
605 606
	 (cons 'progn body))))

607
(defun cl--compile-time-too (form)
Richard M. Stallman's avatar
Richard M. Stallman committed
608 609
  (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
      (setq form (macroexpand
610
		  form (cons '(cl-eval-when) byte-compile-macro-environment))))
Richard M. Stallman's avatar
Richard M. Stallman committed
611
  (cond ((eq (car-safe form) 'progn)
612
	 (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
613
	((eq (car-safe form) 'cl-eval-when)
Richard M. Stallman's avatar
Richard M. Stallman committed
614
	 (let ((when (nth 1 form)))
615
	   (if (or (memq 'eval when) (memq :execute when))
616
	       `(cl-eval-when (compile ,@when) ,@(cddr form))
Richard M. Stallman's avatar
Richard M. Stallman committed
617 618 619
	     form)))
	(t (eval form) form)))

620
;;;###autoload
621
(defmacro cl-load-time-value (form &optional _read-only)
Richard M. Stallman's avatar
Richard M. Stallman committed
622 623
  "Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
624
  (declare (debug (form &optional sexp)))
625
  (if (cl--compiling-file)
626
      (let* ((temp (cl-gentemp "--cl-load-time--"))
627
	     (set `(setq ,temp ,form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
628 629 630
	(if (and (fboundp 'byte-compile-file-form-defmumble)
		 (boundp 'this-kind) (boundp 'that-one))
	    (fset 'byte-compile-file-form
631 632 633 634 635
		  `(lambda (form)
                     (fset 'byte-compile-file-form
                           ',(symbol-function 'byte-compile-file-form))
                     (byte-compile-file-form ',set)
                     (byte-compile-file-form form)))
636
	  (print set (symbol-value 'byte-compile--outbuffer)))
637 638
	`(symbol-value ',temp))
    `',(eval form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
639 640 641 642


;;; Conditional control structures.

643
;;;###autoload
644
(defmacro cl-case (expr &rest clauses)
645
  "Eval EXPR and choose among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
646 647
Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
against each key in each KEYLIST; the corresponding BODY is evaluated.
648
If no clause succeeds, cl-case returns nil.  A single atom may be used in
649
place of a KEYLIST of one atom.  A KEYLIST of t or `otherwise' is
Richard M. Stallman's avatar
Richard M. Stallman committed
650
allowed only in the final clause, and matches if no other keys match.
651 652
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
653
  (declare (indent 1) (debug (form &rest (sexp body))))
654
  (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
655 656 657 658 659 660 661
	 (head-list nil)
	 (body (cons
		'cond
		(mapcar
		 (function
		  (lambda (c)
		    (cons (cond ((memq (car c) '(t otherwise)) t)
662 663
				((eq (car c) 'cl--ecase-error-flag)
				 `(error "cl-ecase failed: %s, %s"
664
                                         ,temp ',(reverse head-list)))
Richard M. Stallman's avatar
Richard M. Stallman committed
665 666
				((listp (car c))
				 (setq head-list (append (car c) head-list))
667
				 `(cl-member ,temp ',(car c)))
Richard M. Stallman's avatar
Richard M. Stallman committed
668 669 670 671
				(t
				 (if (memq (car c) head-list)
				     (error "Duplicate key in case: %s"
					    (car c)))
672
				 (push (car c) head-list)
673
				 `(eql ,temp ',(car c))))
Richard M. Stallman's avatar
Richard M. Stallman committed
674 675 676
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
677
      `(let ((,temp ,expr)) ,body))))
Richard M. Stallman's avatar
Richard M. Stallman committed
678

679
;;;###autoload
680
(defmacro cl-ecase (expr &rest clauses)
681
  "Like `cl-case', but error if no case fits.
682 683
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
684 685
  (declare (indent 1) (debug cl-case))
  `(cl-case ,expr ,@clauses (cl--ecase-error-flag)))
Richard M. Stallman's avatar
Richard M. Stallman committed
686

687
;;;###autoload
688
(defmacro cl-typecase (expr &rest clauses)
689
  "Evals EXPR, chooses among clauses on that value.
Richard M. Stallman's avatar
Richard M. Stallman committed
690 691
Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
692
cl-typecase returns nil.  A TYPE of t or `otherwise' is allowed only in the
693 694
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
695 696
  (declare (indent 1)
           (debug (form &rest ([&or cl-type-spec "otherwise"] body))))
697
  (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
Richard M. Stallman's avatar
Richard M. Stallman committed
698 699 700 701 702 703 704
	 (type-list nil)
	 (body (cons
		'cond
		(mapcar
		 (function
		  (lambda (c)
		    (cons (cond ((eq (car c) 'otherwise) t)
705 706
				((eq (car c) 'cl--ecase-error-flag)
				 `(error "cl-etypecase failed: %s, %s"
707
                                         ,temp ',(reverse type-list)))
Richard M. Stallman's avatar
Richard M. Stallman committed
708
				(t
709
				 (push (car c) type-list)
710
				 (cl--make-type-test temp (car c))))
Richard M. Stallman's avatar
Richard M. Stallman committed
711 712 713
			  (or (cdr c) '(nil)))))
		 clauses))))
    (if (eq temp expr) body
714
      `(let ((,temp ,expr)) ,body))))
Richard M. Stallman's avatar
Richard M. Stallman committed
715

716
;;;###autoload
717 718
(defmacro cl-etypecase (expr &rest clauses)
  "Like `cl-typecase', but error if no case fits.
719 720
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
721 722
  (declare (indent 1) (debug cl-typecase))
  `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag)))
Richard M. Stallman's avatar
Richard M. Stallman committed
723 724 725 726


;;; Blocks and exits.

727
;;;###autoload
728
(defmacro cl-block (name &rest body)
729
  "Define a lexically-scoped block named NAME.
730
NAME may be any symbol.  Code inside the BODY forms can call `cl-return-from'
Richard M. Stallman's avatar
Richard M. Stallman committed
731 732 733 734 735 736
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."
737
  (declare (indent 1) (debug (symbolp body)))
738
  (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
739
    `(cl--block-wrapper
740 741
      (catch ',(intern (format "--cl-block-%s--" name))
        ,@body))))
Richard M. Stallman's avatar
Richard M. Stallman committed
742

743
;;;###autoload
744
(defmacro cl-return (&optional result)
745
  "Return from the block named nil.
746
This is equivalent to `(cl-return-from nil RESULT)'."
747
  (declare (debug (&optional form)))
748
  `(cl-return-from nil ,result))
Richard M. Stallman's avatar
Richard M. Stallman committed
749

750
;;;###autoload
751
(defmacro cl-return-from (name &optional result)
752
  "Return from the block named NAME.
753
This jumps out to the innermost enclosing `(cl-block NAME ...)' form,
Richard M. Stallman's avatar
Richard M. Stallman committed
754 755 756
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."
757
  (declare (indent 1) (debug (symbolp &optional form)))
Richard M. Stallman's avatar
Richard M. Stallman committed
758
  (let ((name2 (intern (format "--cl-block-%s--" name))))
759
    `(cl--block-throw ',name2 ,result)))
Richard M. Stallman's avatar
Richard M. Stallman committed
760 761


762
;;; The "cl-loop" macro.
Richard M. Stallman's avatar
Richard M. Stallman committed
763

764
(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
Stefan Monnier's avatar
Stefan Monnier committed
765 766 767
(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?
768
(defvar cl--loop-first-flag)
Stefan Monnier's avatar
Stefan Monnier committed
769 770
(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
(defvar cl--loop-name)
771
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
772 773
(defvar cl--loop-result-var) (defvar cl--loop-steps)
(defvar cl--loop-symbol-macs)
Richard M. Stallman's avatar
Richard M. Stallman committed
774

Stefan Monnier's avatar
Stefan Monnier committed
775 776 777 778 779 780
(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)))

781
;;;###autoload
782
(defmacro cl-loop (&rest loop-args)
783
  "The Common Lisp `loop' macro.
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812
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'.
813 814

\(fn CLAUSE...)"
815 816 817 818 819 820 821 822 823 824 825 826 827 828 829
  (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"
                               "return"] form]
                         ;; Simple default, which covers 99% of the cases.
                         symbolp form)))
830 831
  (if (not (memq t (mapcar #'symbolp
                           (delq nil (delq t (cl-copy-list loop-args))))))
832 833
      `(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
834 835 836
	  (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)
837 838
	  (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
839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862
	  (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)))))
      ;;
863
      (setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
864 865
      (while (not (eq (car cl--loop-args) 'cl-end-loop))
        (cl--parse-loop-clause))
866 867 868 869 870 871
      (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)
872 873
			      (list (or cl--loop-result-explicit
                                        cl--loop-result))))
874 875
	     (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
876
	     (body (append
877
		    (nreverse cl--loop-initially)
Stefan Monnier's avatar
Stefan Monnier committed
878
		    (list (if cl--loop-iterator-function
879
			      `(cl-block --cl-finish--
Stefan Monnier's avatar
Stefan Monnier committed
880 881 882 883 884 885 886
                                 ,(funcall cl--loop-iterator-function
                                           (if (eq (car ands) t) while-body
                                             (cons `(or ,(car ands)
                                                        (cl-return-from
                                                            --cl-finish--
                                                          nil))
                                                   while-body))))
887
			    `(while ,(car ands) ,@while-body)))
888 889 890 891
		    (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
892
		      epilogue))))
893 894
	(if cl--loop-result-var
            (push (list cl--loop-result-var) cl--loop-bindings))
895 896 897
	(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
898
	    (let ((lets nil))
899 900 901 902 903
	      (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
904 905
	    (setq body
                  (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
906
	`(cl-block ,cl--loop-name ,@body)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
907

908
;; Below is a complete spec for cl-loop, in several parts that correspond
909 910
;; to the syntax given in CLtL2.  The specs do more than specify where
;; the forms are; it also specifies, as much as Edebug allows, all the
911
;; syntactically valid cl-loop clauses.  The disadvantage of this
912 913 914
;; completeness is rigidity, but the "for ... being" clause allows
;; arbitrary extensions of the form: [symbolp &rest &or symbolp form].

915
;; (def-edebug-spec cl-loop
916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059
;;   ([&optional ["named" symbolp]]
;;    [&rest
;;     &or
;;     ["repeat" form]
;;     loop-for-as
;;     loop-with
;;     loop-initial-final]
;;    [&rest loop-clause]
;;    ))

;; (def-edebug-spec loop-with
;;   ("with" loop-var
;;    loop-type-spec
;;    [&optional ["=" form]]
;;    &rest ["and" loop-var
;; 	  loop-type-spec
;; 	  [&optional ["=" form]]]))

;; (def-edebug-spec loop-for-as
;;   ([&or "for" "as"] loop-for-as-subclause
;;    &rest ["and" loop-for-as-subclause]))

;; (def-edebug-spec loop-for-as-subclause
;;   (loop-var
;;    loop-type-spec
;;    &or
;;    [[&or "in" "on" "in-ref" "across-ref"]
;;     form &optional ["by" function-form]]

;;    ["=" form &optional ["then" form]]
;;    ["across" form]
;;    ["being"
;;     [&or "the" "each"]
;;     &or
;;     [[&or "element" "elements"]
;;      [&or "of" "in" "of-ref"] form
;;      &optional "using" ["index" symbolp]];; is this right?
;;     [[&or "hash-key" "hash-keys"
;; 	  "hash-value" "hash-values"]
;;      [&or "of" "in"]
;;      hash-table-p &optional ["using" ([&or "hash-value" "hash-values"
;; 					   "hash-key" "hash-keys"] sexp)]]

;;     [[&or "symbol" "present-symbol" "external-symbol"
;; 	  "symbols" "present-symbols" "external-symbols"]
;;      [&or "in" "of"] package-p]

;;     ;; Extensions for Emacs Lisp, including Lucid Emacs.
;;     [[&or "frame" "frames"
;; 	  "screen" "screens"
;; 	  "buffer" "buffers"]]

;;     [[&or "window" "windows"]
;;      [&or "of" "in"] form]

;;     [[&or "overlay" "overlays"
;; 	  "extent" "extents"]
;;      [&or "of" "in"] form
;;      &optional [[&or "from" "to"] form]]

;;     [[&or "interval" "intervals"]
;;      [&or "in" "of"] form
;;      &optional [[&or "from" "to"] form]
;;      ["property" form]]

;;     [[&or "key-code" "key-codes"
;; 	  "key-seq" "key-seqs"
;; 	  "key-binding" "key-bindings"]
;;      [&or "in" "of"] form
;;      &optional ["using" ([&or "key-code" "key-codes"
;; 			      "key-seq" "key-seqs"
;; 			      "key-binding" "key-bindings"]
;; 			 sexp)]]
;;     ;; For arbitrary extensions, recognize anything else.
;;     [symbolp &rest &or symbolp form]
;;     ]

;;    ;; arithmetic - must be last since all parts are optional.
;;    [[&optional [[&or "from" "downfrom" "upfrom"] form]]
;;     [&optional [[&or "to" "downto" "upto" "below" "above"] form]]
;;     [&optional ["by" form]]
;;     ]))

;; (def-edebug-spec loop-initial-final
;;   (&or ["initially"
;; 	;; [&optional &or "do" "doing"]  ;; CLtL2 doesn't allow this.
;; 	&rest loop-non-atomic-expr]
;;        ["finally" &or
;; 	[[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
;; 	["return" form]]))

;; (def-edebug-spec loop-and-clause
;;   (loop-clause &rest ["and" loop-clause]))

;; (def-edebug-spec loop-clause
;;   (&or
;;    [[&or "while" "until" "always" "never" "thereis"] form]

;;    [[&or "collect" "collecting"
;; 	 "append" "appending"
;; 	 "nconc" "nconcing"
;; 	 "concat" "vconcat"] form
;; 	 [&optional ["into" loop-var]]]

;;    [[&or "count" "counting"
;; 	 "sum" "summing"
;; 	 "maximize" "maximizing"
;; 	 "minimize" "minimizing"] form
;; 	 [&optional ["into" loop-var]]
;; 	 loop-type-spec]

;;    [[&or "if" "when" "unless"]
;;     form loop-and-clause
;;     [&optional ["else" loop-and-clause]]
;;     [&optional "end"]]

;;    [[&or "do" "doing"] &rest loop-non-atomic-expr]

;;    ["return" form]
;;    loop-initial-final
;;    ))

;; (def-edebug-spec loop-non-atomic-expr
;;   ([&not atom] form))

;; (def-edebug-spec loop-var
;;   ;; The symbolp must be last alternative to recognize e.g. (a b . c)
;;   ;; loop-var =>
;;   ;; (loop-var . [&or nil loop-var])
;;   ;; (symbolp . [&or nil loop-var])
;;   ;; (symbolp . loop-var)
;;   ;; (symbolp . (symbolp . [&or nil loop-var]))
;;   ;; (symbolp . (symbolp . loop-var))
;;   ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp)
;;   (&or (loop-var . [&or nil loop-var]) [gate symbolp]))

;; (def-edebug-spec loop-type-spec
;;   (&optional ["of-type" loop-d-type-spec]))

;; (def-edebug-spec loop-d-type-spec
;;   (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))



1060
(defun cl--parse-loop-clause ()		; uses loop-*
1061
  (let ((word (pop cl--loop-args))
Richard M. Stallman's avatar
Richard M. Stallman committed
1062 1063 1064 1065 1066
	(hash-types '(hash-key hash-keys hash-value hash-values))
	(key-types '(key-code key-codes key-seq key-seqs
		     key-binding key-bindings)))
    (cond

1067
     ((null cl--loop-args)
1068
      (error "Malformed `cl-loop' macro"))
Richard M. Stallman's avatar
Richard M. Stallman committed
1069 1070

     ((eq word 'named)
1071
      (setq cl--loop-name (pop cl--loop-args)))
Richard M. Stallman's avatar
Richard M. Stallman committed
1072 1073

     ((eq word 'initially)
1074
      (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
1075 1076
      (or (consp (car cl--loop-args))
          (error "Syntax error on `initially' clause"))
1077 1078
      (while (consp (car cl--loop-args))
	(push (pop cl--loop-args) cl--loop-initially)))
Richard M. Stallman's avatar
Richard M. Stallman committed
1079 1080

     ((eq word 'finally)
1081
      (if (eq (car cl--loop-args) 'return)
1082 1083
	  (setq cl--loop-result-explicit
                (or (cl--pop2 cl--loop-args) '(quote nil)))
1084
	(if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
1085 1086
	(or (consp (car cl--loop-args))
            (error "Syntax error on `finally' clause"))
1087
	(if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name))
1088 1089
	    (setq cl--loop-result-explicit
                  (or (nth 1 (pop cl--loop-args)) '(quote nil)))
1090 1091
	  (while (consp (car cl--loop-args))
	    (push (pop cl--loop-args) cl--loop-finally)))))