aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2002-09-27 23:16:27 +0000
committerStefan Monnier2002-09-27 23:16:27 +0000
commit69d8fb1ee6d718560233ef50bef9045bc6d4c551 (patch)
tree73633f48037889c14b294ff6d2b1a9b51d07339a
parent890df022a2ba11447788f98c3522fca911c14fb4 (diff)
downloademacs-69d8fb1ee6d718560233ef50bef9045bc6d4c551.tar.gz
emacs-69d8fb1ee6d718560233ef50bef9045bc6d4c551.zip
Use the new usage-in-docstring syntax.
(cl-push, cl-pop): Remove. Use pop and push throughout the file instead. (cl-transform-lambda): Add usage info to docstring if the arglist is complex.
-rw-r--r--lisp/emacs-lisp/cl-macs.el535
1 files changed, 291 insertions, 244 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 7026ece12b9..ce5055ba087 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -44,21 +44,15 @@
44 44
45;;; Code: 45;;; Code:
46 46
47(require 'help-fns) ;For help-add-fundoc-usage.
48
47(or (memq 'cl-19 features) 49(or (memq 'cl-19 features)
48 (error "Tried to load `cl-macs' before `cl'!")) 50 (error "Tried to load `cl-macs' before `cl'!"))
49 51
50 52
51;;; We define these here so that this file can compile without having
52;;; loaded the cl.el file already.
53
54(defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
55(defmacro cl-pop (place)
56 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
57(defmacro cl-pop2 (place) 53(defmacro cl-pop2 (place)
58 (list 'prog1 (list 'car (list 'cdr place)) 54 (list 'prog1 (list 'car (list 'cdr place))
59 (list 'setq place (list 'cdr (list 'cdr place))))) 55 (list 'setq place (list 'cdr (list 'cdr place)))))
60(put 'cl-push 'edebug-form-spec 'edebug-sexps)
61(put 'cl-pop 'edebug-form-spec 'edebug-sexps)
62(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) 56(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
63 57
64(defvar cl-optimize-safety) 58(defvar cl-optimize-safety)
@@ -111,17 +105,21 @@ The name is made by appending a number to PREFIX, default \"G\"."
111;;; Program structure. 105;;; Program structure.
112 106
113(defmacro defun* (name args &rest body) 107(defmacro defun* (name args &rest body)
114 "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. 108 "Define NAME as a function.
115Like normal `defun', except ARGLIST allows full Common Lisp conventions, 109Like normal `defun', except ARGLIST allows full Common Lisp conventions,
116and BODY is implicitly surrounded by (block NAME ...)." 110and BODY is implicitly surrounded by (block NAME ...).
111
112\(fn NAME ARGLIST [DOCSTRING] BODY...)"
117 (let* ((res (cl-transform-lambda (cons args body) name)) 113 (let* ((res (cl-transform-lambda (cons args body) name))
118 (form (list* 'defun name (cdr res)))) 114 (form (list* 'defun name (cdr res))))
119 (if (car res) (list 'progn (car res) form) form))) 115 (if (car res) (list 'progn (car res) form) form)))
120 116
121(defmacro defmacro* (name args &rest body) 117(defmacro defmacro* (name args &rest body)
122 "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. 118 "Define NAME as a macro.
123Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, 119Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
124and BODY is implicitly surrounded by (block NAME ...)." 120and BODY is implicitly surrounded by (block NAME ...).
121
122\(fn NAME ARGLIST [DOCSTRING] BODY...)"
125 (let* ((res (cl-transform-lambda (cons args body) name)) 123 (let* ((res (cl-transform-lambda (cons args body) name))
126 (form (list* 'defmacro name (cdr res)))) 124 (form (list* 'defmacro name (cdr res))))
127 (if (car res) (list 'progn (car res) form) form))) 125 (if (car res) (list 'progn (car res) form) form)))
@@ -150,12 +148,12 @@ ARGLIST allows full Common Lisp conventions."
150(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) 148(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
151 149
152(defun cl-transform-lambda (form bind-block) 150(defun cl-transform-lambda (form bind-block)
153 (let* ((args (car form)) (body (cdr form)) 151 (let* ((args (car form)) (body (cdr form)) (orig-args args)
154 (bind-defs nil) (bind-enquote nil) 152 (bind-defs nil) (bind-enquote nil)
155 (bind-inits nil) (bind-lets nil) (bind-forms nil) 153 (bind-inits nil) (bind-lets nil) (bind-forms nil)
156 (header nil) (simple-args nil)) 154 (header nil) (simple-args nil))
157 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) 155 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
158 (cl-push (cl-pop body) header)) 156 (push (pop body) header))
159 (setq args (if (listp args) (copy-list args) (list '&rest args))) 157 (setq args (if (listp args) (copy-list args) (list '&rest args)))
160 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) 158 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
161 (if (setq bind-defs (cadr (memq '&cl-defs args))) 159 (if (setq bind-defs (cadr (memq '&cl-defs args)))
@@ -171,20 +169,23 @@ ARGLIST allows full Common Lisp conventions."
171 (not (memq (car args) '(nil &rest &body &key &aux))) 169 (not (memq (car args) '(nil &rest &body &key &aux)))
172 (not (and (eq (car args) '&optional) 170 (not (and (eq (car args) '&optional)
173 (or bind-defs (consp (cadr args)))))) 171 (or bind-defs (consp (cadr args))))))
174 (cl-push (cl-pop args) simple-args)) 172 (push (pop args) simple-args))
175 (or (eq bind-block 'cl-none) 173 (or (eq bind-block 'cl-none)
176 (setq body (list (list* 'block bind-block body)))) 174 (setq body (list (list* 'block bind-block body))))
177 (if (null args) 175 (if (null args)
178 (list* nil (nreverse simple-args) (nconc (nreverse header) body)) 176 (list* nil (nreverse simple-args) (nconc (nreverse header) body))
179 (if (memq '&optional simple-args) (cl-push '&optional args)) 177 (if (memq '&optional simple-args) (push '&optional args))
180 (cl-do-arglist args nil (- (length simple-args) 178 (cl-do-arglist args nil (- (length simple-args)
181 (if (memq '&optional simple-args) 1 0))) 179 (if (memq '&optional simple-args) 1 0)))
182 (setq bind-lets (nreverse bind-lets)) 180 (setq bind-lets (nreverse bind-lets))
183 (list* (and bind-inits (list* 'eval-when '(compile load eval) 181 (list* (and bind-inits (list* 'eval-when '(compile load eval)
184 (nreverse bind-inits))) 182 (nreverse bind-inits)))
185 (nconc (nreverse simple-args) 183 (nconc (nreverse simple-args)
186 (list '&rest (car (cl-pop bind-lets)))) 184 (list '&rest (car (pop bind-lets))))
187 (nconc (nreverse header) 185 (nconc (let ((hdr (nreverse header)))
186 (cons (help-add-fundoc-usage
187 (if (stringp (car hdr)) (pop hdr)) orig-args)
188 hdr))
188 (list (nconc (list 'let* bind-lets) 189 (list (nconc (list 'let* bind-lets)
189 (nreverse bind-forms) body))))))) 190 (nreverse bind-forms) body)))))))
190 191
@@ -192,7 +193,7 @@ ARGLIST allows full Common Lisp conventions."
192 (if (nlistp args) 193 (if (nlistp args)
193 (if (or (memq args lambda-list-keywords) (not (symbolp args))) 194 (if (or (memq args lambda-list-keywords) (not (symbolp args)))
194 (error "Invalid argument name: %s" args) 195 (error "Invalid argument name: %s" args)
195 (cl-push (list args expr) bind-lets)) 196 (push (list args expr) bind-lets))
196 (setq args (copy-list args)) 197 (setq args (copy-list args))
197 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) 198 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
198 (let ((p (memq '&body args))) (if p (setcar p '&rest))) 199 (let ((p (memq '&body args))) (if p (setcar p '&rest)))
@@ -206,9 +207,9 @@ ARGLIST allows full Common Lisp conventions."
206 (if (listp (cadr restarg)) 207 (if (listp (cadr restarg))
207 (setq restarg (gensym "--rest--")) 208 (setq restarg (gensym "--rest--"))
208 (setq restarg (cadr restarg))) 209 (setq restarg (cadr restarg)))
209 (cl-push (list restarg expr) bind-lets) 210 (push (list restarg expr) bind-lets)
210 (if (eq (car args) '&whole) 211 (if (eq (car args) '&whole)
211 (cl-push (list (cl-pop2 args) restarg) bind-lets)) 212 (push (list (cl-pop2 args) restarg) bind-lets))
212 (let ((p args)) 213 (let ((p args))
213 (setq minarg restarg) 214 (setq minarg restarg)
214 (while (and p (not (memq (car p) lambda-list-keywords))) 215 (while (and p (not (memq (car p) lambda-list-keywords)))
@@ -222,7 +223,7 @@ ARGLIST allows full Common Lisp conventions."
222 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) 223 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
223 restarg))) 224 restarg)))
224 (cl-do-arglist 225 (cl-do-arglist
225 (cl-pop args) 226 (pop args)
226 (if (or laterarg (= safety 0)) poparg 227 (if (or laterarg (= safety 0)) poparg
227 (list 'if minarg poparg 228 (list 'if minarg poparg
228 (list 'signal '(quote wrong-number-of-arguments) 229 (list 'signal '(quote wrong-number-of-arguments)
@@ -230,9 +231,9 @@ ARGLIST allows full Common Lisp conventions."
230 (list 'quote bind-block)) 231 (list 'quote bind-block))
231 (list 'length restarg))))))) 232 (list 'length restarg)))))))
232 (setq num (1+ num) laterarg t)) 233 (setq num (1+ num) laterarg t))
233 (while (and (eq (car args) '&optional) (cl-pop args)) 234 (while (and (eq (car args) '&optional) (pop args))
234 (while (and args (not (memq (car args) lambda-list-keywords))) 235 (while (and args (not (memq (car args) lambda-list-keywords)))
235 (let ((arg (cl-pop args))) 236 (let ((arg (pop args)))
236 (or (consp arg) (setq arg (list arg))) 237 (or (consp arg) (setq arg (list arg)))
237 (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) 238 (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
238 (let ((def (if (cdr arg) (nth 1 arg) 239 (let ((def (if (cdr arg) (nth 1 arg)
@@ -247,16 +248,16 @@ ARGLIST allows full Common Lisp conventions."
247 (let ((arg (cl-pop2 args))) 248 (let ((arg (cl-pop2 args)))
248 (if (consp arg) (cl-do-arglist arg restarg))) 249 (if (consp arg) (cl-do-arglist arg restarg)))
249 (or (eq (car args) '&key) (= safety 0) exactarg 250 (or (eq (car args) '&key) (= safety 0) exactarg
250 (cl-push (list 'if restarg 251 (push (list 'if restarg
251 (list 'signal '(quote wrong-number-of-arguments) 252 (list 'signal '(quote wrong-number-of-arguments)
252 (list 'list 253 (list 'list
253 (and (not (eq bind-block 'cl-none)) 254 (and (not (eq bind-block 'cl-none))
254 (list 'quote bind-block)) 255 (list 'quote bind-block))
255 (list '+ num (list 'length restarg))))) 256 (list '+ num (list 'length restarg)))))
256 bind-forms))) 257 bind-forms)))
257 (while (and (eq (car args) '&key) (cl-pop args)) 258 (while (and (eq (car args) '&key) (pop args))
258 (while (and args (not (memq (car args) lambda-list-keywords))) 259 (while (and args (not (memq (car args) lambda-list-keywords)))
259 (let ((arg (cl-pop args))) 260 (let ((arg (pop args)))
260 (or (consp arg) (setq arg (list arg))) 261 (or (consp arg) (setq arg (list arg)))
261 (let* ((karg (if (consp (car arg)) (caar arg) 262 (let* ((karg (if (consp (car arg)) (caar arg)
262 (intern (format ":%s" (car arg))))) 263 (intern (format ":%s" (car arg)))))
@@ -285,9 +286,9 @@ ARGLIST allows full Common Lisp conventions."
285 'quote 286 'quote
286 (list nil (cl-const-expr-val def))) 287 (list nil (cl-const-expr-val def)))
287 (list 'list nil def)))))))) 288 (list 'list nil def))))))))
288 (cl-push karg keys))))) 289 (push karg keys)))))
289 (setq keys (nreverse keys)) 290 (setq keys (nreverse keys))
290 (or (and (eq (car args) '&allow-other-keys) (cl-pop args)) 291 (or (and (eq (car args) '&allow-other-keys) (pop args))
291 (null keys) (= safety 0) 292 (null keys) (= safety 0)
292 (let* ((var (gensym "--keys--")) 293 (let* ((var (gensym "--keys--"))
293 (allow '(:allow-other-keys)) 294 (allow '(:allow-other-keys))
@@ -309,24 +310,24 @@ ARGLIST allows full Common Lisp conventions."
309 (format "Keyword argument %%s not one of %s" 310 (format "Keyword argument %%s not one of %s"
310 keys) 311 keys)
311 (list 'car var))))))) 312 (list 'car var)))))))
312 (cl-push (list 'let (list (list var restarg)) check) bind-forms))) 313 (push (list 'let (list (list var restarg)) check) bind-forms)))
313 (while (and (eq (car args) '&aux) (cl-pop args)) 314 (while (and (eq (car args) '&aux) (pop args))
314 (while (and args (not (memq (car args) lambda-list-keywords))) 315 (while (and args (not (memq (car args) lambda-list-keywords)))
315 (if (consp (car args)) 316 (if (consp (car args))
316 (if (and bind-enquote (cadar args)) 317 (if (and bind-enquote (cadar args))
317 (cl-do-arglist (caar args) 318 (cl-do-arglist (caar args)
318 (list 'quote (cadr (cl-pop args)))) 319 (list 'quote (cadr (pop args))))
319 (cl-do-arglist (caar args) (cadr (cl-pop args)))) 320 (cl-do-arglist (caar args) (cadr (pop args))))
320 (cl-do-arglist (cl-pop args) nil)))) 321 (cl-do-arglist (pop args) nil))))
321 (if args (error "Malformed argument list %s" save-args))))) 322 (if args (error "Malformed argument list %s" save-args)))))
322 323
323(defun cl-arglist-args (args) 324(defun cl-arglist-args (args)
324 (if (nlistp args) (list args) 325 (if (nlistp args) (list args)
325 (let ((res nil) (kind nil) arg) 326 (let ((res nil) (kind nil) arg)
326 (while (consp args) 327 (while (consp args)
327 (setq arg (cl-pop args)) 328 (setq arg (pop args))
328 (if (memq arg lambda-list-keywords) (setq kind arg) 329 (if (memq arg lambda-list-keywords) (setq kind arg)
329 (if (eq arg '&cl-defs) (cl-pop args) 330 (if (eq arg '&cl-defs) (pop args)
330 (and (consp arg) kind (setq arg (car arg))) 331 (and (consp arg) kind (setq arg (car arg)))
331 (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) 332 (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
332 (setq res (nconc res (cl-arglist-args arg)))))) 333 (setq res (nconc res (cl-arglist-args arg))))))
@@ -346,10 +347,12 @@ ARGLIST allows full Common Lisp conventions."
346(defvar cl-not-toplevel nil) 347(defvar cl-not-toplevel nil)
347 348
348(defmacro eval-when (when &rest body) 349(defmacro eval-when (when &rest body)
349 "(eval-when (WHEN...) BODY...): control when BODY is evaluated. 350 "Control when BODY is evaluated.
350If `compile' is in WHEN, BODY is evaluated when compiled at top-level. 351If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
351If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. 352If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
352If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." 353If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
354
355\(fn (WHEN...) BODY...)"
353 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) 356 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
354 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge 357 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
355 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) 358 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
@@ -422,7 +425,7 @@ Key values are compared by `eql'."
422 (if (memq (car c) head-list) 425 (if (memq (car c) head-list)
423 (error "Duplicate key in case: %s" 426 (error "Duplicate key in case: %s"
424 (car c))) 427 (car c)))
425 (cl-push (car c) head-list) 428 (push (car c) head-list)
426 (list 'eql temp (list 'quote (car c))))) 429 (list 'eql temp (list 'quote (car c)))))
427 (or (cdr c) '(nil))))) 430 (or (cdr c) '(nil)))))
428 clauses)))) 431 clauses))))
@@ -452,7 +455,7 @@ final clause, and matches if no other keys match."
452 (list 'error "etypecase failed: %s, %s" 455 (list 'error "etypecase failed: %s, %s"
453 temp (list 'quote (reverse type-list)))) 456 temp (list 'quote (reverse type-list))))
454 (t 457 (t
455 (cl-push (car c) type-list) 458 (push (car c) type-list)
456 (cl-make-type-test temp (car c)))) 459 (cl-make-type-test temp (car c))))
457 (or (cdr c) '(nil))))) 460 (or (cdr c) '(nil)))))
458 clauses)))) 461 clauses))))
@@ -527,7 +530,7 @@ This is compatible with Common Lisp, but note that `defun' and
527(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) 530(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
528 531
529(defmacro loop (&rest args) 532(defmacro loop (&rest args)
530 "(loop CLAUSE...): The Common Lisp `loop' macro. 533 "The Common Lisp `loop' macro.
531Valid clauses are: 534Valid clauses are:
532 for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, 535 for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
533 for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, 536 for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
@@ -538,7 +541,9 @@ Valid clauses are:
538 if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], 541 if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
539 unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], 542 unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
540 do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, 543 do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
541 finally return EXPR, named NAME." 544 finally return EXPR, named NAME.
545
546\(fn CLAUSE...)"
542 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) 547 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
543 (list 'block nil (list* 'while t args)) 548 (list 'block nil (list* 'while t args))
544 (let ((loop-name nil) (loop-bindings nil) 549 (let ((loop-name nil) (loop-bindings nil)
@@ -552,10 +557,10 @@ Valid clauses are:
552 (setq args (append args '(cl-end-loop))) 557 (setq args (append args '(cl-end-loop)))
553 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) 558 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
554 (if loop-finish-flag 559 (if loop-finish-flag
555 (cl-push (list (list loop-finish-flag t)) loop-bindings)) 560 (push (list (list loop-finish-flag t)) loop-bindings))
556 (if loop-first-flag 561 (if loop-first-flag
557 (progn (cl-push (list (list loop-first-flag t)) loop-bindings) 562 (progn (push (list (list loop-first-flag t)) loop-bindings)
558 (cl-push (list 'setq loop-first-flag nil) loop-steps))) 563 (push (list 'setq loop-first-flag nil) loop-steps)))
559 (let* ((epilogue (nconc (nreverse loop-finally) 564 (let* ((epilogue (nconc (nreverse loop-finally)
560 (list (or loop-result-explicit loop-result)))) 565 (list (or loop-result-explicit loop-result))))
561 (ands (cl-loop-build-ands (nreverse loop-body))) 566 (ands (cl-loop-build-ands (nreverse loop-body)))
@@ -577,21 +582,21 @@ Valid clauses are:
577 (list (list 'if loop-finish-flag 582 (list (list 'if loop-finish-flag
578 (cons 'progn epilogue) loop-result-var))) 583 (cons 'progn epilogue) loop-result-var)))
579 epilogue)))) 584 epilogue))))
580 (if loop-result-var (cl-push (list loop-result-var) loop-bindings)) 585 (if loop-result-var (push (list loop-result-var) loop-bindings))
581 (while loop-bindings 586 (while loop-bindings
582 (if (cdar loop-bindings) 587 (if (cdar loop-bindings)
583 (setq body (list (cl-loop-let (cl-pop loop-bindings) body t))) 588 (setq body (list (cl-loop-let (pop loop-bindings) body t)))
584 (let ((lets nil)) 589 (let ((lets nil))
585 (while (and loop-bindings 590 (while (and loop-bindings
586 (not (cdar loop-bindings))) 591 (not (cdar loop-bindings)))
587 (cl-push (car (cl-pop loop-bindings)) lets)) 592 (push (car (pop loop-bindings)) lets))
588 (setq body (list (cl-loop-let lets body nil)))))) 593 (setq body (list (cl-loop-let lets body nil))))))
589 (if loop-symbol-macs 594 (if loop-symbol-macs
590 (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) 595 (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
591 (list* 'block loop-name body))))) 596 (list* 'block loop-name body)))))
592 597
593(defun cl-parse-loop-clause () ; uses args, loop-* 598(defun cl-parse-loop-clause () ; uses args, loop-*
594 (let ((word (cl-pop args)) 599 (let ((word (pop args))
595 (hash-types '(hash-key hash-keys hash-value hash-values)) 600 (hash-types '(hash-key hash-keys hash-value hash-values))
596 (key-types '(key-code key-codes key-seq key-seqs 601 (key-types '(key-code key-codes key-seq key-seqs
597 key-binding key-bindings))) 602 key-binding key-bindings)))
@@ -601,39 +606,39 @@ Valid clauses are:
601 (error "Malformed `loop' macro")) 606 (error "Malformed `loop' macro"))
602 607
603 ((eq word 'named) 608 ((eq word 'named)
604 (setq loop-name (cl-pop args))) 609 (setq loop-name (pop args)))
605 610
606 ((eq word 'initially) 611 ((eq word 'initially)
607 (if (memq (car args) '(do doing)) (cl-pop args)) 612 (if (memq (car args) '(do doing)) (pop args))
608 (or (consp (car args)) (error "Syntax error on `initially' clause")) 613 (or (consp (car args)) (error "Syntax error on `initially' clause"))
609 (while (consp (car args)) 614 (while (consp (car args))
610 (cl-push (cl-pop args) loop-initially))) 615 (push (pop args) loop-initially)))
611 616
612 ((eq word 'finally) 617 ((eq word 'finally)
613 (if (eq (car args) 'return) 618 (if (eq (car args) 'return)
614 (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) 619 (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
615 (if (memq (car args) '(do doing)) (cl-pop args)) 620 (if (memq (car args) '(do doing)) (pop args))
616 (or (consp (car args)) (error "Syntax error on `finally' clause")) 621 (or (consp (car args)) (error "Syntax error on `finally' clause"))
617 (if (and (eq (caar args) 'return) (null loop-name)) 622 (if (and (eq (caar args) 'return) (null loop-name))
618 (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil))) 623 (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
619 (while (consp (car args)) 624 (while (consp (car args))
620 (cl-push (cl-pop args) loop-finally))))) 625 (push (pop args) loop-finally)))))
621 626
622 ((memq word '(for as)) 627 ((memq word '(for as))
623 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) 628 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
624 (ands nil)) 629 (ands nil))
625 (while 630 (while
626 (let ((var (or (cl-pop args) (gensym)))) 631 (let ((var (or (pop args) (gensym))))
627 (setq word (cl-pop args)) 632 (setq word (pop args))
628 (if (eq word 'being) (setq word (cl-pop args))) 633 (if (eq word 'being) (setq word (pop args)))
629 (if (memq word '(the each)) (setq word (cl-pop args))) 634 (if (memq word '(the each)) (setq word (pop args)))
630 (if (memq word '(buffer buffers)) 635 (if (memq word '(buffer buffers))
631 (setq word 'in args (cons '(buffer-list) args))) 636 (setq word 'in args (cons '(buffer-list) args)))
632 (cond 637 (cond
633 638
634 ((memq word '(from downfrom upfrom to downto upto 639 ((memq word '(from downfrom upfrom to downto upto
635 above below by)) 640 above below by))
636 (cl-push word args) 641 (push word args)
637 (if (memq (car args) '(downto above)) 642 (if (memq (car args) '(downto above))
638 (error "Must specify `from' value for downward loop")) 643 (error "Must specify `from' value for downward loop"))
639 (let* ((down (or (eq (car args) 'downfrom) 644 (let* ((down (or (eq (car args) 'downfrom)
@@ -651,31 +656,31 @@ Valid clauses are:
651 (gensym)))) 656 (gensym))))
652 (and step (numberp step) (<= step 0) 657 (and step (numberp step) (<= step 0)
653 (error "Loop `by' value is not positive: %s" step)) 658 (error "Loop `by' value is not positive: %s" step))
654 (cl-push (list var (or start 0)) loop-for-bindings) 659 (push (list var (or start 0)) loop-for-bindings)
655 (if end-var (cl-push (list end-var end) loop-for-bindings)) 660 (if end-var (push (list end-var end) loop-for-bindings))
656 (if step-var (cl-push (list step-var step) 661 (if step-var (push (list step-var step)
657 loop-for-bindings)) 662 loop-for-bindings))
658 (if end 663 (if end
659 (cl-push (list 664 (push (list
660 (if down (if excl '> '>=) (if excl '< '<=)) 665 (if down (if excl '> '>=) (if excl '< '<=))
661 var (or end-var end)) loop-body)) 666 var (or end-var end)) loop-body))
662 (cl-push (list var (list (if down '- '+) var 667 (push (list var (list (if down '- '+) var
663 (or step-var step 1))) 668 (or step-var step 1)))
664 loop-for-steps))) 669 loop-for-steps)))
665 670
666 ((memq word '(in in-ref on)) 671 ((memq word '(in in-ref on))
667 (let* ((on (eq word 'on)) 672 (let* ((on (eq word 'on))
668 (temp (if (and on (symbolp var)) var (gensym)))) 673 (temp (if (and on (symbolp var)) var (gensym))))
669 (cl-push (list temp (cl-pop args)) loop-for-bindings) 674 (push (list temp (pop args)) loop-for-bindings)
670 (cl-push (list 'consp temp) loop-body) 675 (push (list 'consp temp) loop-body)
671 (if (eq word 'in-ref) 676 (if (eq word 'in-ref)
672 (cl-push (list var (list 'car temp)) loop-symbol-macs) 677 (push (list var (list 'car temp)) loop-symbol-macs)
673 (or (eq temp var) 678 (or (eq temp var)
674 (progn 679 (progn
675 (cl-push (list var nil) loop-for-bindings) 680 (push (list var nil) loop-for-bindings)
676 (cl-push (list var (if on temp (list 'car temp))) 681 (push (list var (if on temp (list 'car temp)))
677 loop-for-sets)))) 682 loop-for-sets))))
678 (cl-push (list temp 683 (push (list temp
679 (if (eq (car args) 'by) 684 (if (eq (car args) 'by)
680 (let ((step (cl-pop2 args))) 685 (let ((step (cl-pop2 args)))
681 (if (and (memq (car-safe step) 686 (if (and (memq (car-safe step)
@@ -688,20 +693,20 @@ Valid clauses are:
688 loop-for-steps))) 693 loop-for-steps)))
689 694
690 ((eq word '=) 695 ((eq word '=)
691 (let* ((start (cl-pop args)) 696 (let* ((start (pop args))
692 (then (if (eq (car args) 'then) (cl-pop2 args) start))) 697 (then (if (eq (car args) 'then) (cl-pop2 args) start)))
693 (cl-push (list var nil) loop-for-bindings) 698 (push (list var nil) loop-for-bindings)
694 (if (or ands (eq (car args) 'and)) 699 (if (or ands (eq (car args) 'and))
695 (progn 700 (progn
696 (cl-push (list var 701 (push (list var
697 (list 'if 702 (list 'if
698 (or loop-first-flag 703 (or loop-first-flag
699 (setq loop-first-flag 704 (setq loop-first-flag
700 (gensym))) 705 (gensym)))
701 start var)) 706 start var))
702 loop-for-sets) 707 loop-for-sets)
703 (cl-push (list var then) loop-for-steps)) 708 (push (list var then) loop-for-steps))
704 (cl-push (list var 709 (push (list var
705 (if (eq start then) start 710 (if (eq start then) start
706 (list 'if 711 (list 'if
707 (or loop-first-flag 712 (or loop-first-flag
@@ -711,15 +716,15 @@ Valid clauses are:
711 716
712 ((memq word '(across across-ref)) 717 ((memq word '(across across-ref))
713 (let ((temp-vec (gensym)) (temp-idx (gensym))) 718 (let ((temp-vec (gensym)) (temp-idx (gensym)))
714 (cl-push (list temp-vec (cl-pop args)) loop-for-bindings) 719 (push (list temp-vec (pop args)) loop-for-bindings)
715 (cl-push (list temp-idx -1) loop-for-bindings) 720 (push (list temp-idx -1) loop-for-bindings)
716 (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx)) 721 (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
717 (list 'length temp-vec)) loop-body) 722 (list 'length temp-vec)) loop-body)
718 (if (eq word 'across-ref) 723 (if (eq word 'across-ref)
719 (cl-push (list var (list 'aref temp-vec temp-idx)) 724 (push (list var (list 'aref temp-vec temp-idx))
720 loop-symbol-macs) 725 loop-symbol-macs)
721 (cl-push (list var nil) loop-for-bindings) 726 (push (list var nil) loop-for-bindings)
722 (cl-push (list var (list 'aref temp-vec temp-idx)) 727 (push (list var (list 'aref temp-vec temp-idx))
723 loop-for-sets)))) 728 loop-for-sets))))
724 729
725 ((memq word '(element elements)) 730 ((memq word '(element elements))
@@ -734,26 +739,26 @@ Valid clauses are:
734 (cadr (cl-pop2 args)) 739 (cadr (cl-pop2 args))
735 (error "Bad `using' clause")) 740 (error "Bad `using' clause"))
736 (gensym)))) 741 (gensym))))
737 (cl-push (list temp-seq seq) loop-for-bindings) 742 (push (list temp-seq seq) loop-for-bindings)
738 (cl-push (list temp-idx 0) loop-for-bindings) 743 (push (list temp-idx 0) loop-for-bindings)
739 (if ref 744 (if ref
740 (let ((temp-len (gensym))) 745 (let ((temp-len (gensym)))
741 (cl-push (list temp-len (list 'length temp-seq)) 746 (push (list temp-len (list 'length temp-seq))
742 loop-for-bindings) 747 loop-for-bindings)
743 (cl-push (list var (list 'elt temp-seq temp-idx)) 748 (push (list var (list 'elt temp-seq temp-idx))
744 loop-symbol-macs) 749 loop-symbol-macs)
745 (cl-push (list '< temp-idx temp-len) loop-body)) 750 (push (list '< temp-idx temp-len) loop-body))
746 (cl-push (list var nil) loop-for-bindings) 751 (push (list var nil) loop-for-bindings)
747 (cl-push (list 'and temp-seq 752 (push (list 'and temp-seq
748 (list 'or (list 'consp temp-seq) 753 (list 'or (list 'consp temp-seq)
749 (list '< temp-idx 754 (list '< temp-idx
750 (list 'length temp-seq)))) 755 (list 'length temp-seq))))
751 loop-body) 756 loop-body)
752 (cl-push (list var (list 'if (list 'consp temp-seq) 757 (push (list var (list 'if (list 'consp temp-seq)
753 (list 'pop temp-seq) 758 (list 'pop temp-seq)
754 (list 'aref temp-seq temp-idx))) 759 (list 'aref temp-seq temp-idx)))
755 loop-for-sets)) 760 loop-for-sets))
756 (cl-push (list temp-idx (list '1+ temp-idx)) 761 (push (list temp-idx (list '1+ temp-idx))
757 loop-for-steps))) 762 loop-for-steps)))
758 763
759 ((memq word hash-types) 764 ((memq word hash-types)
@@ -804,7 +809,7 @@ Valid clauses are:
804 (t (setq buf (cl-pop2 args))))) 809 (t (setq buf (cl-pop2 args)))))
805 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) 810 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
806 (setq var1 (car var) var2 (cdr var)) 811 (setq var1 (car var) var2 (cdr var))
807 (cl-push (list var (list 'cons var1 var2)) loop-for-sets)) 812 (push (list var (list 'cons var1 var2)) loop-for-sets))
808 (setq loop-map-form 813 (setq loop-map-form
809 (list 'cl-map-intervals 814 (list 'cl-map-intervals
810 (list 'function (list 'lambda (list var1 var2) 815 (list 'function (list 'lambda (list var1 var2)
@@ -831,27 +836,27 @@ Valid clauses are:
831 836
832 ((memq word '(frame frames screen screens)) 837 ((memq word '(frame frames screen screens))
833 (let ((temp (gensym))) 838 (let ((temp (gensym)))
834 (cl-push (list var '(selected-frame)) 839 (push (list var '(selected-frame))
835 loop-for-bindings) 840 loop-for-bindings)
836 (cl-push (list temp nil) loop-for-bindings) 841 (push (list temp nil) loop-for-bindings)
837 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) 842 (push (list 'prog1 (list 'not (list 'eq var temp))
838 (list 'or temp (list 'setq temp var))) 843 (list 'or temp (list 'setq temp var)))
839 loop-body) 844 loop-body)
840 (cl-push (list var (list 'next-frame var)) 845 (push (list var (list 'next-frame var))
841 loop-for-steps))) 846 loop-for-steps)))
842 847
843 ((memq word '(window windows)) 848 ((memq word '(window windows))
844 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) 849 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
845 (temp (gensym))) 850 (temp (gensym)))
846 (cl-push (list var (if scr 851 (push (list var (if scr
847 (list 'frame-selected-window scr) 852 (list 'frame-selected-window scr)
848 '(selected-window))) 853 '(selected-window)))
849 loop-for-bindings) 854 loop-for-bindings)
850 (cl-push (list temp nil) loop-for-bindings) 855 (push (list temp nil) loop-for-bindings)
851 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) 856 (push (list 'prog1 (list 'not (list 'eq var temp))
852 (list 'or temp (list 'setq temp var))) 857 (list 'or temp (list 'setq temp var)))
853 loop-body) 858 loop-body)
854 (cl-push (list var (list 'next-window var)) loop-for-steps))) 859 (push (list var (list 'next-window var)) loop-for-steps)))
855 860
856 (t 861 (t
857 (let ((handler (and (symbolp word) 862 (let ((handler (and (symbolp word)
@@ -861,38 +866,38 @@ Valid clauses are:
861 (error "Expected a `for' preposition, found %s" word))))) 866 (error "Expected a `for' preposition, found %s" word)))))
862 (eq (car args) 'and)) 867 (eq (car args) 'and))
863 (setq ands t) 868 (setq ands t)
864 (cl-pop args)) 869 (pop args))
865 (if (and ands loop-for-bindings) 870 (if (and ands loop-for-bindings)
866 (cl-push (nreverse loop-for-bindings) loop-bindings) 871 (push (nreverse loop-for-bindings) loop-bindings)
867 (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) 872 (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
868 loop-bindings))) 873 loop-bindings)))
869 (if loop-for-sets 874 (if loop-for-sets
870 (cl-push (list 'progn 875 (push (list 'progn
871 (cl-loop-let (nreverse loop-for-sets) 'setq ands) 876 (cl-loop-let (nreverse loop-for-sets) 'setq ands)
872 t) loop-body)) 877 t) loop-body))
873 (if loop-for-steps 878 (if loop-for-steps
874 (cl-push (cons (if ands 'psetq 'setq) 879 (push (cons (if ands 'psetq 'setq)
875 (apply 'append (nreverse loop-for-steps))) 880 (apply 'append (nreverse loop-for-steps)))
876 loop-steps)))) 881 loop-steps))))
877 882
878 ((eq word 'repeat) 883 ((eq word 'repeat)
879 (let ((temp (gensym))) 884 (let ((temp (gensym)))
880 (cl-push (list (list temp (cl-pop args))) loop-bindings) 885 (push (list (list temp (pop args))) loop-bindings)
881 (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) 886 (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
882 887
883 ((memq word '(collect collecting)) 888 ((memq word '(collect collecting))
884 (let ((what (cl-pop args)) 889 (let ((what (pop args))
885 (var (cl-loop-handle-accum nil 'nreverse))) 890 (var (cl-loop-handle-accum nil 'nreverse)))
886 (if (eq var loop-accum-var) 891 (if (eq var loop-accum-var)
887 (cl-push (list 'progn (list 'push what var) t) loop-body) 892 (push (list 'progn (list 'push what var) t) loop-body)
888 (cl-push (list 'progn 893 (push (list 'progn
889 (list 'setq var (list 'nconc var (list 'list what))) 894 (list 'setq var (list 'nconc var (list 'list what)))
890 t) loop-body)))) 895 t) loop-body))))
891 896
892 ((memq word '(nconc nconcing append appending)) 897 ((memq word '(nconc nconcing append appending))
893 (let ((what (cl-pop args)) 898 (let ((what (pop args))
894 (var (cl-loop-handle-accum nil 'nreverse))) 899 (var (cl-loop-handle-accum nil 'nreverse)))
895 (cl-push (list 'progn 900 (push (list 'progn
896 (list 'setq var 901 (list 'setq var
897 (if (eq var loop-accum-var) 902 (if (eq var loop-accum-var)
898 (list 'nconc 903 (list 'nconc
@@ -905,100 +910,100 @@ Valid clauses are:
905 var what))) t) loop-body))) 910 var what))) t) loop-body)))
906 911
907 ((memq word '(concat concating)) 912 ((memq word '(concat concating))
908 (let ((what (cl-pop args)) 913 (let ((what (pop args))
909 (var (cl-loop-handle-accum ""))) 914 (var (cl-loop-handle-accum "")))
910 (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body))) 915 (push (list 'progn (list 'callf 'concat var what) t) loop-body)))
911 916
912 ((memq word '(vconcat vconcating)) 917 ((memq word '(vconcat vconcating))
913 (let ((what (cl-pop args)) 918 (let ((what (pop args))
914 (var (cl-loop-handle-accum []))) 919 (var (cl-loop-handle-accum [])))
915 (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) 920 (push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
916 921
917 ((memq word '(sum summing)) 922 ((memq word '(sum summing))
918 (let ((what (cl-pop args)) 923 (let ((what (pop args))
919 (var (cl-loop-handle-accum 0))) 924 (var (cl-loop-handle-accum 0)))
920 (cl-push (list 'progn (list 'incf var what) t) loop-body))) 925 (push (list 'progn (list 'incf var what) t) loop-body)))
921 926
922 ((memq word '(count counting)) 927 ((memq word '(count counting))
923 (let ((what (cl-pop args)) 928 (let ((what (pop args))
924 (var (cl-loop-handle-accum 0))) 929 (var (cl-loop-handle-accum 0)))
925 (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) 930 (push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
926 931
927 ((memq word '(minimize minimizing maximize maximizing)) 932 ((memq word '(minimize minimizing maximize maximizing))
928 (let* ((what (cl-pop args)) 933 (let* ((what (pop args))
929 (temp (if (cl-simple-expr-p what) what (gensym))) 934 (temp (if (cl-simple-expr-p what) what (gensym)))
930 (var (cl-loop-handle-accum nil)) 935 (var (cl-loop-handle-accum nil))
931 (func (intern (substring (symbol-name word) 0 3))) 936 (func (intern (substring (symbol-name word) 0 3)))
932 (set (list 'setq var (list 'if var (list func var temp) temp)))) 937 (set (list 'setq var (list 'if var (list func var temp) temp))))
933 (cl-push (list 'progn (if (eq temp what) set 938 (push (list 'progn (if (eq temp what) set
934 (list 'let (list (list temp what)) set)) 939 (list 'let (list (list temp what)) set))
935 t) loop-body))) 940 t) loop-body)))
936 941
937 ((eq word 'with) 942 ((eq word 'with)
938 (let ((bindings nil)) 943 (let ((bindings nil))
939 (while (progn (cl-push (list (cl-pop args) 944 (while (progn (push (list (pop args)
940 (and (eq (car args) '=) (cl-pop2 args))) 945 (and (eq (car args) '=) (cl-pop2 args)))
941 bindings) 946 bindings)
942 (eq (car args) 'and)) 947 (eq (car args) 'and))
943 (cl-pop args)) 948 (pop args))
944 (cl-push (nreverse bindings) loop-bindings))) 949 (push (nreverse bindings) loop-bindings)))
945 950
946 ((eq word 'while) 951 ((eq word 'while)
947 (cl-push (cl-pop args) loop-body)) 952 (push (pop args) loop-body))
948 953
949 ((eq word 'until) 954 ((eq word 'until)
950 (cl-push (list 'not (cl-pop args)) loop-body)) 955 (push (list 'not (pop args)) loop-body))
951 956
952 ((eq word 'always) 957 ((eq word 'always)
953 (or loop-finish-flag (setq loop-finish-flag (gensym))) 958 (or loop-finish-flag (setq loop-finish-flag (gensym)))
954 (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body) 959 (push (list 'setq loop-finish-flag (pop args)) loop-body)
955 (setq loop-result t)) 960 (setq loop-result t))
956 961
957 ((eq word 'never) 962 ((eq word 'never)
958 (or loop-finish-flag (setq loop-finish-flag (gensym))) 963 (or loop-finish-flag (setq loop-finish-flag (gensym)))
959 (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args))) 964 (push (list 'setq loop-finish-flag (list 'not (pop args)))
960 loop-body) 965 loop-body)
961 (setq loop-result t)) 966 (setq loop-result t))
962 967
963 ((eq word 'thereis) 968 ((eq word 'thereis)
964 (or loop-finish-flag (setq loop-finish-flag (gensym))) 969 (or loop-finish-flag (setq loop-finish-flag (gensym)))
965 (or loop-result-var (setq loop-result-var (gensym))) 970 (or loop-result-var (setq loop-result-var (gensym)))
966 (cl-push (list 'setq loop-finish-flag 971 (push (list 'setq loop-finish-flag
967 (list 'not (list 'setq loop-result-var (cl-pop args)))) 972 (list 'not (list 'setq loop-result-var (pop args))))
968 loop-body)) 973 loop-body))
969 974
970 ((memq word '(if when unless)) 975 ((memq word '(if when unless))
971 (let* ((cond (cl-pop args)) 976 (let* ((cond (pop args))
972 (then (let ((loop-body nil)) 977 (then (let ((loop-body nil))
973 (cl-parse-loop-clause) 978 (cl-parse-loop-clause)
974 (cl-loop-build-ands (nreverse loop-body)))) 979 (cl-loop-build-ands (nreverse loop-body))))
975 (else (let ((loop-body nil)) 980 (else (let ((loop-body nil))
976 (if (eq (car args) 'else) 981 (if (eq (car args) 'else)
977 (progn (cl-pop args) (cl-parse-loop-clause))) 982 (progn (pop args) (cl-parse-loop-clause)))
978 (cl-loop-build-ands (nreverse loop-body)))) 983 (cl-loop-build-ands (nreverse loop-body))))
979 (simple (and (eq (car then) t) (eq (car else) t)))) 984 (simple (and (eq (car then) t) (eq (car else) t))))
980 (if (eq (car args) 'end) (cl-pop args)) 985 (if (eq (car args) 'end) (pop args))
981 (if (eq word 'unless) (setq then (prog1 else (setq else then)))) 986 (if (eq word 'unless) (setq then (prog1 else (setq else then))))
982 (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) 987 (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
983 (if simple (nth 1 else) (list (nth 2 else)))))) 988 (if simple (nth 1 else) (list (nth 2 else))))))
984 (if (cl-expr-contains form 'it) 989 (if (cl-expr-contains form 'it)
985 (let ((temp (gensym))) 990 (let ((temp (gensym)))
986 (cl-push (list temp) loop-bindings) 991 (push (list temp) loop-bindings)
987 (setq form (list* 'if (list 'setq temp cond) 992 (setq form (list* 'if (list 'setq temp cond)
988 (subst temp 'it form)))) 993 (subst temp 'it form))))
989 (setq form (list* 'if cond form))) 994 (setq form (list* 'if cond form)))
990 (cl-push (if simple (list 'progn form t) form) loop-body)))) 995 (push (if simple (list 'progn form t) form) loop-body))))
991 996
992 ((memq word '(do doing)) 997 ((memq word '(do doing))
993 (let ((body nil)) 998 (let ((body nil))
994 (or (consp (car args)) (error "Syntax error on `do' clause")) 999 (or (consp (car args)) (error "Syntax error on `do' clause"))
995 (while (consp (car args)) (cl-push (cl-pop args) body)) 1000 (while (consp (car args)) (push (pop args) body))
996 (cl-push (cons 'progn (nreverse (cons t body))) loop-body))) 1001 (push (cons 'progn (nreverse (cons t body))) loop-body)))
997 1002
998 ((eq word 'return) 1003 ((eq word 'return)
999 (or loop-finish-flag (setq loop-finish-flag (gensym))) 1004 (or loop-finish-flag (setq loop-finish-flag (gensym)))
1000 (or loop-result-var (setq loop-result-var (gensym))) 1005 (or loop-result-var (setq loop-result-var (gensym)))
1001 (cl-push (list 'setq loop-result-var (cl-pop args) 1006 (push (list 'setq loop-result-var (pop args)
1002 loop-finish-flag nil) loop-body)) 1007 loop-finish-flag nil) loop-body))
1003 1008
1004 (t 1009 (t
@@ -1006,7 +1011,7 @@ Valid clauses are:
1006 (or handler (error "Expected a loop keyword, found %s" word)) 1011 (or handler (error "Expected a loop keyword, found %s" word))
1007 (funcall handler)))) 1012 (funcall handler))))
1008 (if (eq (car args) 'and) 1013 (if (eq (car args) 'and)
1009 (progn (cl-pop args) (cl-parse-loop-clause))))) 1014 (progn (pop args) (cl-parse-loop-clause)))))
1010 1015
1011(defun cl-loop-let (specs body par) ; uses loop-* 1016(defun cl-loop-let (specs body par) ; uses loop-*
1012 (let ((p specs) (temps nil) (new nil)) 1017 (let ((p specs) (temps nil) (new nil))
@@ -1018,24 +1023,24 @@ Valid clauses are:
1018 (while p 1023 (while p
1019 (or (cl-const-expr-p (cadar p)) 1024 (or (cl-const-expr-p (cadar p))
1020 (let ((temp (gensym))) 1025 (let ((temp (gensym)))
1021 (cl-push (list temp (cadar p)) temps) 1026 (push (list temp (cadar p)) temps)
1022 (setcar (cdar p) temp))) 1027 (setcar (cdar p) temp)))
1023 (setq p (cdr p))))) 1028 (setq p (cdr p)))))
1024 (while specs 1029 (while specs
1025 (if (and (consp (car specs)) (listp (caar specs))) 1030 (if (and (consp (car specs)) (listp (caar specs)))
1026 (let* ((spec (caar specs)) (nspecs nil) 1031 (let* ((spec (caar specs)) (nspecs nil)
1027 (expr (cadr (cl-pop specs))) 1032 (expr (cadr (pop specs)))
1028 (temp (cdr (or (assq spec loop-destr-temps) 1033 (temp (cdr (or (assq spec loop-destr-temps)
1029 (car (cl-push (cons spec (or (last spec 0) 1034 (car (push (cons spec (or (last spec 0)
1030 (gensym))) 1035 (gensym)))
1031 loop-destr-temps)))))) 1036 loop-destr-temps))))))
1032 (cl-push (list temp expr) new) 1037 (push (list temp expr) new)
1033 (while (consp spec) 1038 (while (consp spec)
1034 (cl-push (list (cl-pop spec) 1039 (push (list (pop spec)
1035 (and expr (list (if spec 'pop 'car) temp))) 1040 (and expr (list (if spec 'pop 'car) temp)))
1036 nspecs)) 1041 nspecs))
1037 (setq specs (nconc (nreverse nspecs) specs))) 1042 (setq specs (nconc (nreverse nspecs) specs)))
1038 (cl-push (cl-pop specs) new))) 1043 (push (pop specs) new)))
1039 (if (eq body 'setq) 1044 (if (eq body 'setq)
1040 (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) 1045 (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
1041 (if temps (list 'let* (nreverse temps) set) set)) 1046 (if temps (list 'let* (nreverse temps) set) set))
@@ -1046,12 +1051,12 @@ Valid clauses are:
1046 (if (eq (car args) 'into) 1051 (if (eq (car args) 'into)
1047 (let ((var (cl-pop2 args))) 1052 (let ((var (cl-pop2 args)))
1048 (or (memq var loop-accum-vars) 1053 (or (memq var loop-accum-vars)
1049 (progn (cl-push (list (list var def)) loop-bindings) 1054 (progn (push (list (list var def)) loop-bindings)
1050 (cl-push var loop-accum-vars))) 1055 (push var loop-accum-vars)))
1051 var) 1056 var)
1052 (or loop-accum-var 1057 (or loop-accum-var
1053 (progn 1058 (progn
1054 (cl-push (list (list (setq loop-accum-var (gensym)) def)) 1059 (push (list (list (setq loop-accum-var (gensym)) def))
1055 loop-bindings) 1060 loop-bindings)
1056 (setq loop-result (if func (list func loop-accum-var) 1061 (setq loop-result (if func (list func loop-accum-var)
1057 loop-accum-var)) 1062 loop-accum-var))
@@ -1070,8 +1075,8 @@ Valid clauses are:
1070 (cdadr clauses) 1075 (cdadr clauses)
1071 (list (cadr clauses)))) 1076 (list (cadr clauses))))
1072 (cddr clauses))) 1077 (cddr clauses)))
1073 (setq body (cdr (butlast (cl-pop clauses))))) 1078 (setq body (cdr (butlast (pop clauses)))))
1074 (cl-push (cl-pop clauses) ands))) 1079 (push (pop clauses) ands)))
1075 (setq ands (or (nreverse ands) (list t))) 1080 (setq ands (or (nreverse ands) (list t)))
1076 (list (if (cdr ands) (cons 'and ands) (car ands)) 1081 (list (if (cdr ands) (cons 'and ands) (car ands))
1077 body 1082 body
@@ -1115,9 +1120,11 @@ Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1115 (or (cdr endtest) '(nil))))) 1120 (or (cdr endtest) '(nil)))))
1116 1121
1117(defmacro dolist (spec &rest body) 1122(defmacro dolist (spec &rest body)
1118 "(dolist (VAR LIST [RESULT]) BODY...): loop over a list. 1123 "Loop over a list.
1119Evaluate BODY with VAR bound to each `car' from LIST, in turn. 1124Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1120Then evaluate RESULT to get return value, default nil." 1125Then evaluate RESULT to get return value, default nil.
1126
1127\(fn (VAR LIST [RESULT]) BODY...)"
1121 (let ((temp (gensym "--dolist-temp--"))) 1128 (let ((temp (gensym "--dolist-temp--")))
1122 (list 'block nil 1129 (list 'block nil
1123 (list* 'let (list (list temp (nth 1 spec)) (car spec)) 1130 (list* 'let (list (list temp (nth 1 spec)) (car spec))
@@ -1129,10 +1136,12 @@ Then evaluate RESULT to get return value, default nil."
1129 '(nil)))))) 1136 '(nil))))))
1130 1137
1131(defmacro dotimes (spec &rest body) 1138(defmacro dotimes (spec &rest body)
1132 "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. 1139 "Loop a certain number of times.
1133Evaluate BODY with VAR bound to successive integers from 0, inclusive, 1140Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1134to COUNT, exclusive. Then evaluate RESULT to get return value, default 1141to COUNT, exclusive. Then evaluate RESULT to get return value, default
1135nil." 1142nil.
1143
1144\(fn (VAR COUNT [RESULT]) BODY...)"
1136 (let ((temp (gensym "--dotimes-temp--"))) 1145 (let ((temp (gensym "--dotimes-temp--")))
1137 (list 'block nil 1146 (list 'block nil
1138 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) 1147 (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
@@ -1141,9 +1150,11 @@ nil."
1141 (or (cdr (cdr spec)) '(nil)))))) 1150 (or (cdr (cdr spec)) '(nil))))))
1142 1151
1143(defmacro do-symbols (spec &rest body) 1152(defmacro do-symbols (spec &rest body)
1144 "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. 1153 "Loop over all symbols.
1145Evaluate BODY with VAR bound to each interned symbol, or to each symbol 1154Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1146from OBARRAY." 1155from OBARRAY.
1156
1157\(fn (VAR [OBARRAY [RESULT]]) BODY...)"
1147 ;; Apparently this doesn't have an implicit block. 1158 ;; Apparently this doesn't have an implicit block.
1148 (list 'block nil 1159 (list 'block nil
1149 (list 'let (list (car spec)) 1160 (list 'let (list (car spec))
@@ -1159,9 +1170,11 @@ from OBARRAY."
1159;;; Assignments. 1170;;; Assignments.
1160 1171
1161(defmacro psetq (&rest args) 1172(defmacro psetq (&rest args)
1162 "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel. 1173 "Set SYMs to the values VALs in parallel.
1163This is like `setq', except that all VAL forms are evaluated (in order) 1174This is like `setq', except that all VAL forms are evaluated (in order)
1164before assigning any symbols SYM to the corresponding values." 1175before assigning any symbols SYM to the corresponding values.
1176
1177\(fn SYM VAL SYM VAL ...)"
1165 (cons 'psetf args)) 1178 (cons 'psetf args))
1166 1179
1167 1180
@@ -1181,11 +1194,13 @@ a `let' form, except that the list of symbols can be computed at run-time."
1181 1194
1182;;; This should really have some way to shadow 'byte-compile properties, etc. 1195;;; This should really have some way to shadow 'byte-compile properties, etc.
1183(defmacro flet (bindings &rest body) 1196(defmacro flet (bindings &rest body)
1184 "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. 1197 "Make temporary function defns.
1185This is an analogue of `let' that operates on the function cell of FUNC 1198This is an analogue of `let' that operates on the function cell of FUNC
1186rather than its value cell. The FORMs are evaluated with the specified 1199rather than its value cell. The FORMs are evaluated with the specified
1187function definitions in place, then the definitions are undone (the FUNCs 1200function definitions in place, then the definitions are undone (the FUNCs
1188go back to their previous definitions, or lack thereof)." 1201go back to their previous definitions, or lack thereof).
1202
1203\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1189 (list* 'letf* 1204 (list* 'letf*
1190 (mapcar 1205 (mapcar
1191 (function 1206 (function
@@ -1199,23 +1214,25 @@ go back to their previous definitions, or lack thereof)."
1199 (list* 'block (car x) (cddr x)))))) 1214 (list* 'block (car x) (cddr x))))))
1200 (if (and (cl-compiling-file) 1215 (if (and (cl-compiling-file)
1201 (boundp 'byte-compile-function-environment)) 1216 (boundp 'byte-compile-function-environment))
1202 (cl-push (cons (car x) (eval func)) 1217 (push (cons (car x) (eval func))
1203 byte-compile-function-environment)) 1218 byte-compile-function-environment))
1204 (list (list 'symbol-function (list 'quote (car x))) func)))) 1219 (list (list 'symbol-function (list 'quote (car x))) func))))
1205 bindings) 1220 bindings)
1206 body)) 1221 body))
1207 1222
1208(defmacro labels (bindings &rest body) 1223(defmacro labels (bindings &rest body)
1209 "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. 1224 "Make temporary func bindings.
1210This is like `flet', except the bindings are lexical instead of dynamic. 1225This is like `flet', except the bindings are lexical instead of dynamic.
1211Unlike `flet', this macro is fully complaint with the Common Lisp standard." 1226Unlike `flet', this macro is fully compliant with the Common Lisp standard.
1227
1228\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1212 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) 1229 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1213 (while bindings 1230 (while bindings
1214 (let ((var (gensym))) 1231 (let ((var (gensym)))
1215 (cl-push var vars) 1232 (push var vars)
1216 (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) 1233 (push (list 'function* (cons 'lambda (cdar bindings))) sets)
1217 (cl-push var sets) 1234 (push var sets)
1218 (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) 1235 (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
1219 (list 'list* '(quote funcall) (list 'quote var) 1236 (list 'list* '(quote funcall) (list 'quote var)
1220 'cl-labels-args)) 1237 'cl-labels-args))
1221 cl-macro-environment))) 1238 cl-macro-environment)))
@@ -1225,8 +1242,10 @@ Unlike `flet', this macro is fully complaint with the Common Lisp standard."
1225;; The following ought to have a better definition for use with newer 1242;; The following ought to have a better definition for use with newer
1226;; byte compilers. 1243;; byte compilers.
1227(defmacro macrolet (bindings &rest body) 1244(defmacro macrolet (bindings &rest body)
1228 "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. 1245 "Make temporary macro defns.
1229This is like `flet', but for macros instead of functions." 1246This is like `flet', but for macros instead of functions.
1247
1248\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
1230 (if (cdr bindings) 1249 (if (cdr bindings)
1231 (list 'macrolet 1250 (list 'macrolet
1232 (list (car bindings)) (list* 'macrolet (cdr bindings) body)) 1251 (list (car bindings)) (list* 'macrolet (cdr bindings) body))
@@ -1239,9 +1258,11 @@ This is like `flet', but for macros instead of functions."
1239 cl-macro-environment)))))) 1258 cl-macro-environment))))))
1240 1259
1241(defmacro symbol-macrolet (bindings &rest body) 1260(defmacro symbol-macrolet (bindings &rest body)
1242 "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. 1261 "Make symbol macro defns.
1243Within the body FORMs, references to the variable NAME will be replaced 1262Within the body FORMs, references to the variable NAME will be replaced
1244by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." 1263by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
1264
1265\(fn ((NAME EXPANSION) ...) FORM...)"
1245 (if (cdr bindings) 1266 (if (cdr bindings)
1246 (list 'symbol-macrolet 1267 (list 'symbol-macrolet
1247 (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) 1268 (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
@@ -1260,7 +1281,7 @@ lexical closures as in Common Lisp."
1260 (vars (mapcar (function 1281 (vars (mapcar (function
1261 (lambda (x) 1282 (lambda (x)
1262 (or (consp x) (setq x (list x))) 1283 (or (consp x) (setq x (list x)))
1263 (cl-push (gensym (format "--%s--" (car x))) 1284 (push (gensym (format "--%s--" (car x)))
1264 cl-closure-vars) 1285 cl-closure-vars)
1265 (set (car cl-closure-vars) [bad-lexical-ref]) 1286 (set (car cl-closure-vars) [bad-lexical-ref])
1266 (list (car x) (cadr x) (car cl-closure-vars)))) 1287 (list (car x) (cadr x) (car cl-closure-vars))))
@@ -1301,7 +1322,7 @@ lexical closures as in Common Lisp."
1301 (if (null bindings) (cons 'progn body) 1322 (if (null bindings) (cons 'progn body)
1302 (setq bindings (reverse bindings)) 1323 (setq bindings (reverse bindings))
1303 (while bindings 1324 (while bindings
1304 (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body)))) 1325 (setq body (list (list* 'lexical-let (list (pop bindings)) body))))
1305 (car body))) 1326 (car body)))
1306 1327
1307(defun cl-defun-expander (func &rest rest) 1328(defun cl-defun-expander (func &rest rest)
@@ -1314,12 +1335,14 @@ lexical closures as in Common Lisp."
1314;;; Multiple values. 1335;;; Multiple values.
1315 1336
1316(defmacro multiple-value-bind (vars form &rest body) 1337(defmacro multiple-value-bind (vars form &rest body)
1317 "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. 1338 "Collect multiple return values.
1318FORM must return a list; the BODY is then executed with the first N elements 1339FORM must return a list; the BODY is then executed with the first N elements
1319of this list bound (`let'-style) to each of the symbols SYM in turn. This 1340of this list bound (`let'-style) to each of the symbols SYM in turn. This
1320is analogous to the Common Lisp `multiple-value-bind' macro, using lists to 1341is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
1321simulate true multiple return values. For compatibility, (values A B C) is 1342simulate true multiple return values. For compatibility, (values A B C) is
1322a synonym for (list A B C)." 1343a synonym for (list A B C).
1344
1345\(fn (SYM SYM...) FORM BODY)"
1323 (let ((temp (gensym)) (n -1)) 1346 (let ((temp (gensym)) (n -1))
1324 (list* 'let* (cons (list temp form) 1347 (list* 'let* (cons (list temp form)
1325 (mapcar (function 1348 (mapcar (function
@@ -1329,17 +1352,19 @@ a synonym for (list A B C)."
1329 body))) 1352 body)))
1330 1353
1331(defmacro multiple-value-setq (vars form) 1354(defmacro multiple-value-setq (vars form)
1332 "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. 1355 "Collect multiple return values.
1333FORM must return a list; the first N elements of this list are stored in 1356FORM must return a list; the first N elements of this list are stored in
1334each of the symbols SYM in turn. This is analogous to the Common Lisp 1357each of the symbols SYM in turn. This is analogous to the Common Lisp
1335`multiple-value-setq' macro, using lists to simulate true multiple return 1358`multiple-value-setq' macro, using lists to simulate true multiple return
1336values. For compatibility, (values A B C) is a synonym for (list A B C)." 1359values. For compatibility, (values A B C) is a synonym for (list A B C).
1360
1361\(fn (SYM SYM...) FORM)"
1337 (cond ((null vars) (list 'progn form nil)) 1362 (cond ((null vars) (list 'progn form nil))
1338 ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) 1363 ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1339 (t 1364 (t
1340 (let* ((temp (gensym)) (n 0)) 1365 (let* ((temp (gensym)) (n 0))
1341 (list 'let (list (list temp form)) 1366 (list 'let (list (list temp form))
1342 (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp)) 1367 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
1343 (cons 'setq (apply 'nconc 1368 (cons 'setq (apply 'nconc
1344 (mapcar (function 1369 (mapcar (function
1345 (lambda (v) 1370 (lambda (v)
@@ -1359,7 +1384,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)."
1359(defvar cl-declare-stack t) ; for future compilers 1384(defvar cl-declare-stack t) ; for future compilers
1360 1385
1361(defun cl-do-proclaim (spec hist) 1386(defun cl-do-proclaim (spec hist)
1362 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) 1387 (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
1363 (cond ((eq (car-safe spec) 'special) 1388 (cond ((eq (car-safe spec) 'special)
1364 (if (boundp 'byte-compile-bound-variables) 1389 (if (boundp 'byte-compile-bound-variables)
1365 (setq byte-compile-bound-variables 1390 (setq byte-compile-bound-variables
@@ -1404,14 +1429,14 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)."
1404;;; Process any proclamations made before cl-macs was loaded. 1429;;; Process any proclamations made before cl-macs was loaded.
1405(defvar cl-proclaims-deferred) 1430(defvar cl-proclaims-deferred)
1406(let ((p (reverse cl-proclaims-deferred))) 1431(let ((p (reverse cl-proclaims-deferred)))
1407 (while p (cl-do-proclaim (cl-pop p) t)) 1432 (while p (cl-do-proclaim (pop p) t))
1408 (setq cl-proclaims-deferred nil)) 1433 (setq cl-proclaims-deferred nil))
1409 1434
1410(defmacro declare (&rest specs) 1435(defmacro declare (&rest specs)
1411 (if (cl-compiling-file) 1436 (if (cl-compiling-file)
1412 (while specs 1437 (while specs
1413 (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack)) 1438 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
1414 (cl-do-proclaim (cl-pop specs) nil))) 1439 (cl-do-proclaim (pop specs) nil)))
1415 nil) 1440 nil)
1416 1441
1417 1442
@@ -1419,17 +1444,19 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)."
1419;;; Generalized variables. 1444;;; Generalized variables.
1420 1445
1421(defmacro define-setf-method (func args &rest body) 1446(defmacro define-setf-method (func args &rest body)
1422 "(define-setf-method NAME ARGLIST BODY...): define a `setf' method. 1447 "Define a `setf' method.
1423This method shows how to handle `setf's to places of the form (NAME ARGS...). 1448This method shows how to handle `setf's to places of the form (NAME ARGS...).
1424The argument forms ARGS are bound according to ARGLIST, as if NAME were 1449The argument forms ARGS are bound according to ARGLIST, as if NAME were
1425going to be expanded as a macro, then the BODY forms are executed and must 1450going to be expanded as a macro, then the BODY forms are executed and must
1426return a list of five elements: a temporary-variables list, a value-forms 1451return a list of five elements: a temporary-variables list, a value-forms
1427list, a store-variables list (of length one), a store-form, and an access- 1452list, a store-variables list (of length one), a store-form, and an access-
1428form. See `defsetf' for a simpler way to define most setf-methods." 1453form. See `defsetf' for a simpler way to define most setf-methods.
1454
1455\(fn NAME ARGLIST BODY...)"
1429 (append '(eval-when (compile load eval)) 1456 (append '(eval-when (compile load eval))
1430 (if (stringp (car body)) 1457 (if (stringp (car body))
1431 (list (list 'put (list 'quote func) '(quote setf-documentation) 1458 (list (list 'put (list 'quote func) '(quote setf-documentation)
1432 (cl-pop body)))) 1459 (pop body))))
1433 (list (cl-transform-function-property 1460 (list (cl-transform-function-property
1434 func 'setf-method (cons args body))))) 1461 func 'setf-method (cons args body)))))
1435(defalias 'define-setf-expander 'define-setf-method) 1462(defalias 'define-setf-expander 'define-setf-method)
@@ -1526,7 +1553,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
1526 (list 'aset seq n store))) 1553 (list 'aset seq n store)))
1527(defsetf get put) 1554(defsetf get put)
1528(defsetf get* (x y &optional d) (store) (list 'put x y store)) 1555(defsetf get* (x y &optional d) (store) (list 'put x y store))
1529(defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) 1556(defsetf gethash (x h &optional d) (store) (list 'puthash x store h))
1530(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) 1557(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
1531(defsetf subseq (seq start &optional end) (new) 1558(defsetf subseq (seq start &optional end) (new)
1532 (list 'progn (list 'replace seq new :start1 start :end1 end) new)) 1559 (list 'progn (list 'replace seq new :start1 start :end1 end) new))
@@ -1749,8 +1776,8 @@ a macro like `setf' or `incf'."
1749 (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) 1776 (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
1750 (while values 1777 (while values
1751 (if (or simple (cl-const-expr-p (car values))) 1778 (if (or simple (cl-const-expr-p (car values)))
1752 (cl-push (cons (cl-pop temps) (cl-pop values)) subs) 1779 (push (cons (pop temps) (pop values)) subs)
1753 (cl-push (list (cl-pop temps) (cl-pop values)) lets))) 1780 (push (list (pop temps) (pop values)) lets)))
1754 (list (nreverse lets) 1781 (list (nreverse lets)
1755 (cons (car (nth 2 method)) (sublis subs (nth 3 method))) 1782 (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
1756 (sublis subs (nth 4 method))))) 1783 (sublis subs (nth 4 method)))))
@@ -1772,14 +1799,16 @@ a macro like `setf' or `incf'."
1772 1799
1773;;; The standard modify macros. 1800;;; The standard modify macros.
1774(defmacro setf (&rest args) 1801(defmacro setf (&rest args)
1775 "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL. 1802 "Set each PLACE to the value of its VAL.
1776This is a generalized version of `setq'; the PLACEs may be symbolic 1803This is a generalized version of `setq'; the PLACEs may be symbolic
1777references such as (car x) or (aref x i), as well as plain symbols. 1804references such as (car x) or (aref x i), as well as plain symbols.
1778For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). 1805For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
1779The return value is the last VAL in the list." 1806The return value is the last VAL in the list.
1807
1808\(fn PLACE VAL PLACE VAL ...)"
1780 (if (cdr (cdr args)) 1809 (if (cdr (cdr args))
1781 (let ((sets nil)) 1810 (let ((sets nil))
1782 (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets)) 1811 (while args (push (list 'setf (pop args) (pop args)) sets))
1783 (cons 'progn (nreverse sets))) 1812 (cons 'progn (nreverse sets)))
1784 (if (symbolp (car args)) 1813 (if (symbolp (car args))
1785 (and args (cons 'setq args)) 1814 (and args (cons 'setq args))
@@ -1788,18 +1817,20 @@ The return value is the last VAL in the list."
1788 (if (car method) (list 'let* (car method) store) store))))) 1817 (if (car method) (list 'let* (car method) store) store)))))
1789 1818
1790(defmacro psetf (&rest args) 1819(defmacro psetf (&rest args)
1791 "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel. 1820 "Set PLACEs to the values VALs in parallel.
1792This is like `setf', except that all VAL forms are evaluated (in order) 1821This is like `setf', except that all VAL forms are evaluated (in order)
1793before assigning any PLACEs to the corresponding values." 1822before assigning any PLACEs to the corresponding values.
1823
1824\(fn PLACE VAL PLACE VAL ...)"
1794 (let ((p args) (simple t) (vars nil)) 1825 (let ((p args) (simple t) (vars nil))
1795 (while p 1826 (while p
1796 (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) 1827 (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
1797 (setq simple nil)) 1828 (setq simple nil))
1798 (if (memq (car p) vars) 1829 (if (memq (car p) vars)
1799 (error "Destination duplicated in psetf: %s" (car p))) 1830 (error "Destination duplicated in psetf: %s" (car p)))
1800 (cl-push (cl-pop p) vars) 1831 (push (pop p) vars)
1801 (or p (error "Odd number of arguments to psetf")) 1832 (or p (error "Odd number of arguments to psetf"))
1802 (cl-pop p)) 1833 (pop p))
1803 (if simple 1834 (if simple
1804 (list 'progn (cons 'setf args) nil) 1835 (list 'progn (cons 'setf args) nil)
1805 (setq args (reverse args)) 1836 (setq args (reverse args))
@@ -1841,9 +1872,11 @@ The form returns true if TAG was found and removed, nil otherwise."
1841 (list 'cl-do-remf tval ttag))))) 1872 (list 'cl-do-remf tval ttag)))))
1842 1873
1843(defmacro shiftf (place &rest args) 1874(defmacro shiftf (place &rest args)
1844 "(shiftf PLACE PLACE... VAL): shift left among PLACEs. 1875 "Shift left among PLACEs.
1845Example: (shiftf A B C) sets A to B, B to C, and returns the old A. 1876Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
1846Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 1877Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
1878
1879\(fn PLACE PLACE... VAL)"
1847 (cond 1880 (cond
1848 ((null args) place) 1881 ((null args) place)
1849 ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) 1882 ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
@@ -1854,21 +1887,23 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
1854 ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) 1887 ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
1855 1888
1856(defmacro rotatef (&rest args) 1889(defmacro rotatef (&rest args)
1857 "(rotatef PLACE...): rotate left among PLACEs. 1890 "Rotate left among PLACEs.
1858Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. 1891Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
1859Each PLACE may be a symbol, or any generalized variable allowed by `setf'." 1892Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
1893
1894\(fn PLACE...)"
1860 (if (not (memq nil (mapcar 'symbolp args))) 1895 (if (not (memq nil (mapcar 'symbolp args)))
1861 (and (cdr args) 1896 (and (cdr args)
1862 (let ((sets nil) 1897 (let ((sets nil)
1863 (first (car args))) 1898 (first (car args)))
1864 (while (cdr args) 1899 (while (cdr args)
1865 (setq sets (nconc sets (list (cl-pop args) (car args))))) 1900 (setq sets (nconc sets (list (pop args) (car args)))))
1866 (nconc (list 'psetf) sets (list (car args) first)))) 1901 (nconc (list 'psetf) sets (list (car args) first))))
1867 (let* ((places (reverse args)) 1902 (let* ((places (reverse args))
1868 (temp (gensym "--rotatef--")) 1903 (temp (gensym "--rotatef--"))
1869 (form temp)) 1904 (form temp))
1870 (while (cdr places) 1905 (while (cdr places)
1871 (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe))) 1906 (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
1872 (setq form (list 'let* (car method) 1907 (setq form (list 'let* (car method)
1873 (list 'prog1 (nth 2 method) 1908 (list 'prog1 (nth 2 method)
1874 (cl-setf-do-store (nth 1 method) form)))))) 1909 (cl-setf-do-store (nth 1 method) form))))))
@@ -1877,14 +1912,16 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
1877 (cl-setf-do-store (nth 1 method) form) nil))))) 1912 (cl-setf-do-store (nth 1 method) form) nil)))))
1878 1913
1879(defmacro letf (bindings &rest body) 1914(defmacro letf (bindings &rest body)
1880 "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. 1915 "Temporarily bind to PLACEs.
1881This is the analogue of `let', but with generalized variables (in the 1916This is the analogue of `let', but with generalized variables (in the
1882sense of `setf') for the PLACEs. Each PLACE is set to the corresponding 1917sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
1883VALUE, then the BODY forms are executed. On exit, either normally or 1918VALUE, then the BODY forms are executed. On exit, either normally or
1884because of a `throw' or error, the PLACEs are set back to their original 1919because of a `throw' or error, the PLACEs are set back to their original
1885values. Note that this macro is *not* available in Common Lisp. 1920values. Note that this macro is *not* available in Common Lisp.
1886As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', 1921As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
1887the PLACE is not modified before executing BODY." 1922the PLACE is not modified before executing BODY.
1923
1924\(fn ((PLACE VALUE) ...) BODY...)"
1888 (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) 1925 (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
1889 (list* 'let bindings body) 1926 (list* 'let bindings body)
1890 (let ((lets nil) (sets nil) 1927 (let ((lets nil) (sets nil)
@@ -1931,25 +1968,29 @@ the PLACE is not modified before executing BODY."
1931 (list* 'let* lets body)))) 1968 (list* 'let* lets body))))
1932 1969
1933(defmacro letf* (bindings &rest body) 1970(defmacro letf* (bindings &rest body)
1934 "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. 1971 "Temporarily bind to PLACEs.
1935This is the analogue of `let*', but with generalized variables (in the 1972This is the analogue of `let*', but with generalized variables (in the
1936sense of `setf') for the PLACEs. Each PLACE is set to the corresponding 1973sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
1937VALUE, then the BODY forms are executed. On exit, either normally or 1974VALUE, then the BODY forms are executed. On exit, either normally or
1938because of a `throw' or error, the PLACEs are set back to their original 1975because of a `throw' or error, the PLACEs are set back to their original
1939values. Note that this macro is *not* available in Common Lisp. 1976values. Note that this macro is *not* available in Common Lisp.
1940As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', 1977As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
1941the PLACE is not modified before executing BODY." 1978the PLACE is not modified before executing BODY.
1979
1980\(fn ((PLACE VALUE) ...) BODY...)"
1942 (if (null bindings) 1981 (if (null bindings)
1943 (cons 'progn body) 1982 (cons 'progn body)
1944 (setq bindings (reverse bindings)) 1983 (setq bindings (reverse bindings))
1945 (while bindings 1984 (while bindings
1946 (setq body (list (list* 'letf (list (cl-pop bindings)) body)))) 1985 (setq body (list (list* 'letf (list (pop bindings)) body))))
1947 (car body))) 1986 (car body)))
1948 1987
1949(defmacro callf (func place &rest args) 1988(defmacro callf (func place &rest args)
1950 "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...). 1989 "Set PLACE to (FUNC PLACE ARGS...).
1951FUNC should be an unquoted function name. PLACE may be a symbol, 1990FUNC should be an unquoted function name. PLACE may be a symbol,
1952or any generalized variable allowed by `setf'." 1991or any generalized variable allowed by `setf'.
1992
1993\(fn FUNC PLACE ARGS...)"
1953 (let* ((method (cl-setf-do-modify place (cons 'list args))) 1994 (let* ((method (cl-setf-do-modify place (cons 'list args)))
1954 (rargs (cons (nth 2 method) args))) 1995 (rargs (cons (nth 2 method) args)))
1955 (list 'let* (car method) 1996 (list 'let* (car method)
@@ -1959,8 +2000,10 @@ or any generalized variable allowed by `setf'."
1959 rargs)))))) 2000 rargs))))))
1960 2001
1961(defmacro callf2 (func arg1 place &rest args) 2002(defmacro callf2 (func arg1 place &rest args)
1962 "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...). 2003 "Set PLACE to (FUNC ARG1 PLACE ARGS...).
1963Like `callf', but PLACE is the second argument of FUNC, not the first." 2004Like `callf', but PLACE is the second argument of FUNC, not the first.
2005
2006\(fn FUNC ARG1 PLACE ARGS...)"
1964 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) 2007 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
1965 (list 'setf place (list* func arg1 place args)) 2008 (list 'setf place (list* func arg1 place args))
1966 (let* ((method (cl-setf-do-modify place (cons 'list args))) 2009 (let* ((method (cl-setf-do-modify place (cons 'list args)))
@@ -1987,10 +2030,12 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
1987;;; Structures. 2030;;; Structures.
1988 2031
1989(defmacro defstruct (struct &rest descs) 2032(defmacro defstruct (struct &rest descs)
1990 "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type. 2033 "Define a struct type.
1991This macro defines a new Lisp data type called NAME, which contains data 2034This macro defines a new Lisp data type called NAME, which contains data
1992stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' 2035stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME'
1993copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." 2036copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
2037
2038\(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)"
1994 (let* ((name (if (consp struct) (car struct) struct)) 2039 (let* ((name (if (consp struct) (car struct) struct))
1995 (opts (cdr-safe struct)) 2040 (opts (cdr-safe struct))
1996 (slots nil) 2041 (slots nil)
@@ -2012,21 +2057,21 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2012 (forms nil) 2057 (forms nil)
2013 pred-form pred-check) 2058 pred-form pred-check)
2014 (if (stringp (car descs)) 2059 (if (stringp (car descs))
2015 (cl-push (list 'put (list 'quote name) '(quote structure-documentation) 2060 (push (list 'put (list 'quote name) '(quote structure-documentation)
2016 (cl-pop descs)) forms)) 2061 (pop descs)) forms))
2017 (setq descs (cons '(cl-tag-slot) 2062 (setq descs (cons '(cl-tag-slot)
2018 (mapcar (function (lambda (x) (if (consp x) x (list x)))) 2063 (mapcar (function (lambda (x) (if (consp x) x (list x))))
2019 descs))) 2064 descs)))
2020 (while opts 2065 (while opts
2021 (let ((opt (if (consp (car opts)) (caar opts) (car opts))) 2066 (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
2022 (args (cdr-safe (cl-pop opts)))) 2067 (args (cdr-safe (pop opts))))
2023 (cond ((eq opt :conc-name) 2068 (cond ((eq opt :conc-name)
2024 (if args 2069 (if args
2025 (setq conc-name (if (car args) 2070 (setq conc-name (if (car args)
2026 (symbol-name (car args)) "")))) 2071 (symbol-name (car args)) ""))))
2027 ((eq opt :constructor) 2072 ((eq opt :constructor)
2028 (if (cdr args) 2073 (if (cdr args)
2029 (cl-push args constrs) 2074 (push args constrs)
2030 (if args (setq constructor (car args))))) 2075 (if args (setq constructor (car args)))))
2031 ((eq opt :copier) 2076 ((eq opt :copier)
2032 (if args (setq copier (car args)))) 2077 (if args (setq copier (car args))))
@@ -2070,14 +2115,14 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2070 (error "No slot %s in included struct %s" 2115 (error "No slot %s in included struct %s"
2071 (caar include-descs) include)) 2116 (caar include-descs) include))
2072 old-descs) 2117 old-descs)
2073 (cl-pop include-descs))) 2118 (pop include-descs)))
2074 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) 2119 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2075 type (car inc-type) 2120 type (car inc-type)
2076 named (assq 'cl-tag-slot descs)) 2121 named (assq 'cl-tag-slot descs))
2077 (if (cadr inc-type) (setq tag name named t)) 2122 (if (cadr inc-type) (setq tag name named t))
2078 (let ((incl include)) 2123 (let ((incl include))
2079 (while incl 2124 (while incl
2080 (cl-push (list 'pushnew (list 'quote tag) 2125 (push (list 'pushnew (list 'quote tag)
2081 (intern (format "cl-struct-%s-tags" incl))) 2126 (intern (format "cl-struct-%s-tags" incl)))
2082 forms) 2127 forms)
2083 (setq incl (get incl 'cl-struct-include))))) 2128 (setq incl (get incl 'cl-struct-include)))))
@@ -2088,7 +2133,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2088 (if named (setq tag name))) 2133 (if named (setq tag name)))
2089 (setq type 'vector named 'true))) 2134 (setq type 'vector named 'true)))
2090 (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) 2135 (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
2091 (cl-push (list 'defvar tag-symbol) forms) 2136 (push (list 'defvar tag-symbol) forms)
2092 (setq pred-form (and named 2137 (setq pred-form (and named
2093 (let ((pos (- (length descs) 2138 (let ((pos (- (length descs)
2094 (length (memq (assq 'cl-tag-slot descs) 2139 (length (memq (assq 'cl-tag-slot descs)
@@ -2109,19 +2154,19 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2109 (cons 'and (cdddr pred-form)) pred-form))) 2154 (cons 'and (cdddr pred-form)) pred-form)))
2110 (let ((pos 0) (descp descs)) 2155 (let ((pos 0) (descp descs))
2111 (while descp 2156 (while descp
2112 (let* ((desc (cl-pop descp)) 2157 (let* ((desc (pop descp))
2113 (slot (car desc))) 2158 (slot (car desc)))
2114 (if (memq slot '(cl-tag-slot cl-skip-slot)) 2159 (if (memq slot '(cl-tag-slot cl-skip-slot))
2115 (progn 2160 (progn
2116 (cl-push nil slots) 2161 (push nil slots)
2117 (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag)) 2162 (push (and (eq slot 'cl-tag-slot) (list 'quote tag))
2118 defaults)) 2163 defaults))
2119 (if (assq slot descp) 2164 (if (assq slot descp)
2120 (error "Duplicate slots named %s in %s" slot name)) 2165 (error "Duplicate slots named %s in %s" slot name))
2121 (let ((accessor (intern (format "%s%s" conc-name slot)))) 2166 (let ((accessor (intern (format "%s%s" conc-name slot))))
2122 (cl-push slot slots) 2167 (push slot slots)
2123 (cl-push (nth 1 desc) defaults) 2168 (push (nth 1 desc) defaults)
2124 (cl-push (list* 2169 (push (list*
2125 'defsubst* accessor '(cl-x) 2170 'defsubst* accessor '(cl-x)
2126 (append 2171 (append
2127 (and pred-check 2172 (and pred-check
@@ -2133,8 +2178,8 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2133 (list (if (eq type 'vector) (list 'aref 'cl-x pos) 2178 (list (if (eq type 'vector) (list 'aref 'cl-x pos)
2134 (if (= pos 0) '(car cl-x) 2179 (if (= pos 0) '(car cl-x)
2135 (list 'nth pos 'cl-x)))))) forms) 2180 (list 'nth pos 'cl-x)))))) forms)
2136 (cl-push (cons accessor t) side-eff) 2181 (push (cons accessor t) side-eff)
2137 (cl-push (list 'define-setf-method accessor '(cl-x) 2182 (push (list 'define-setf-method accessor '(cl-x)
2138 (if (cadr (memq :read-only (cddr desc))) 2183 (if (cadr (memq :read-only (cddr desc)))
2139 (list 'error (format "%s is a read-only slot" 2184 (list 'error (format "%s is a read-only slot"
2140 accessor)) 2185 accessor))
@@ -2151,38 +2196,38 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
2151 (setq slots (nreverse slots) 2196 (setq slots (nreverse slots)
2152 defaults (nreverse defaults)) 2197 defaults (nreverse defaults))
2153 (and predicate pred-form 2198 (and predicate pred-form
2154 (progn (cl-push (list 'defsubst* predicate '(cl-x) 2199 (progn (push (list 'defsubst* predicate '(cl-x)
2155 (if (eq (car pred-form) 'and) 2200 (if (eq (car pred-form) 'and)
2156 (append pred-form '(t)) 2201 (append pred-form '(t))
2157 (list 'and pred-form t))) forms) 2202 (list 'and pred-form t))) forms)
2158 (cl-push (cons predicate 'error-free) side-eff))) 2203 (push (cons predicate 'error-free) side-eff)))
2159 (and copier 2204 (and copier
2160 (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms) 2205 (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms)
2161 (cl-push (cons copier t) side-eff))) 2206 (push (cons copier t) side-eff)))
2162 (if constructor 2207 (if constructor
2163 (cl-push (list constructor 2208 (push (list constructor
2164 (cons '&key (delq nil (copy-sequence slots)))) 2209 (cons '&key (delq nil (copy-sequence slots))))
2165 constrs)) 2210 constrs))
2166 (while constrs 2211 (while constrs
2167 (let* ((name (caar constrs)) 2212 (let* ((name (caar constrs))
2168 (args (cadr (cl-pop constrs))) 2213 (args (cadr (pop constrs)))
2169 (anames (cl-arglist-args args)) 2214 (anames (cl-arglist-args args))
2170 (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) 2215 (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))
2171 slots defaults))) 2216 slots defaults)))
2172 (cl-push (list 'defsubst* name 2217 (push (list 'defsubst* name
2173 (list* '&cl-defs (list 'quote (cons nil descs)) args) 2218 (list* '&cl-defs (list 'quote (cons nil descs)) args)
2174 (cons type make)) forms) 2219 (cons type make)) forms)
2175 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) 2220 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2176 (cl-push (cons name t) side-eff)))) 2221 (push (cons name t) side-eff))))
2177 (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) 2222 (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2178 (if print-func 2223 (if print-func
2179 (cl-push (list 'push 2224 (push (list 'push
2180 (list 'function 2225 (list 'function
2181 (list 'lambda '(cl-x cl-s cl-n) 2226 (list 'lambda '(cl-x cl-s cl-n)
2182 (list 'and pred-form print-func))) 2227 (list 'and pred-form print-func)))
2183 'custom-print-functions) forms)) 2228 'custom-print-functions) forms))
2184 (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) 2229 (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
2185 (cl-push (list* 'eval-when '(compile load eval) 2230 (push (list* 'eval-when '(compile load eval)
2186 (list 'put (list 'quote name) '(quote cl-struct-slots) 2231 (list 'put (list 'quote name) '(quote cl-struct-slots)
2187 (list 'quote descs)) 2232 (list 'quote descs))
2188 (list 'put (list 'quote name) '(quote cl-struct-type) 2233 (list 'put (list 'quote name) '(quote cl-struct-type)
@@ -2382,12 +2427,12 @@ Otherwise, return result of last FORM."
2382 ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) 2427 ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
2383 (let ((sum 0)) 2428 (let ((sum 0))
2384 (while x 2429 (while x
2385 (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0)))) 2430 (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
2386 (and (> sum 0) sum))) 2431 (and (> sum 0) sum)))
2387 (t nil))) 2432 (t nil)))
2388 2433
2389(defun cl-expr-contains-any (x y) 2434(defun cl-expr-contains-any (x y)
2390 (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y)) 2435 (while (and y (not (cl-expr-contains x (car y)))) (pop y))
2391 y) 2436 y)
2392 2437
2393;;; Check whether X may depend on any of the symbols in Y. 2438;;; Check whether X may depend on any of the symbols in Y.
@@ -2410,7 +2455,7 @@ possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
2410original function call alone by declaring an initial `&whole foo' parameter 2455original function call alone by declaring an initial `&whole foo' parameter
2411and then returning foo." 2456and then returning foo."
2412 (let ((p args) (res nil)) 2457 (let ((p args) (res nil))
2413 (while (consp p) (cl-push (cl-pop p) res)) 2458 (while (consp p) (push (pop p) res))
2414 (setq args (nconc (nreverse res) (and p (list '&rest p))))) 2459 (setq args (nconc (nreverse res) (and p (list '&rest p)))))
2415 (list 'eval-when '(compile load eval) 2460 (list 'eval-when '(compile load eval)
2416 (cl-transform-function-property 2461 (cl-transform-function-property
@@ -2440,14 +2485,16 @@ and then returning foo."
2440 (byte-compile-form form))) 2485 (byte-compile-form form)))
2441 2486
2442(defmacro defsubst* (name args &rest body) 2487(defmacro defsubst* (name args &rest body)
2443 "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. 2488 "Define NAME as a function.
2444Like `defun', except the function is automatically declared `inline', 2489Like `defun', except the function is automatically declared `inline',
2445ARGLIST allows full Common Lisp conventions, and BODY is implicitly 2490ARGLIST allows full Common Lisp conventions, and BODY is implicitly
2446surrounded by (block NAME ...)." 2491surrounded by (block NAME ...).
2492
2493\(fn NAME ARGLIST [DOCSTRING] BODY...)"
2447 (let* ((argns (cl-arglist-args args)) (p argns) 2494 (let* ((argns (cl-arglist-args args)) (p argns)
2448 (pbody (cons 'progn body)) 2495 (pbody (cons 'progn body))
2449 (unsafe (not (cl-safe-expr-p pbody)))) 2496 (unsafe (not (cl-safe-expr-p pbody))))
2450 (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p)) 2497 (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
2451 (list 'progn 2498 (list 'progn
2452 (if p nil ; give up if defaults refer to earlier args 2499 (if p nil ; give up if defaults refer to earlier args
2453 (list 'define-compiler-macro name 2500 (list 'define-compiler-macro name