/[emacs]/emacs/lisp/emacs-lisp/cl-macs.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/cl-macs.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.34 by pj, Thu Dec 20 18:51:32 2001 UTC revision 1.34.4.1 by miles, Fri Apr 4 06:20:16 2003 UTC
# Line 48  Line 48 
48      (error "Tried to load `cl-macs' before `cl'!"))      (error "Tried to load `cl-macs' before `cl'!"))
49    
50    
 ;;; We define these here so that this file can compile without having  
 ;;; loaded the cl.el file already.  
   
 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))  
 (defmacro cl-pop (place)  
   (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))  
51  (defmacro cl-pop2 (place)  (defmacro cl-pop2 (place)
52    (list 'prog1 (list 'car (list 'cdr place))    (list 'prog1 (list 'car (list 'cdr place))
53          (list 'setq place (list 'cdr (list 'cdr place)))))          (list 'setq place (list 'cdr (list 'cdr place)))))
 (put 'cl-push 'edebug-form-spec 'edebug-sexps)  
 (put 'cl-pop 'edebug-form-spec 'edebug-sexps)  
54  (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)  (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
55    
56  (defvar cl-optimize-safety)  (defvar cl-optimize-safety)
# Line 86  Line 78 
78    (run-hooks 'cl-hack-bytecomp-hook))    (run-hooks 'cl-hack-bytecomp-hook))
79    
80    
81    ;;; Some predicates for analyzing Lisp forms.  These are used by various
82    ;;; macro expanders to optimize the results in certain common cases.
83    
84    (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
85                                car-safe cdr-safe progn prog1 prog2))
86    (defconst cl-safe-funcs '(* / % length memq list vector vectorp
87                              < > <= >= = error))
88    
89    ;;; Check if no side effects, and executes quickly.
90    (defun cl-simple-expr-p (x &optional size)
91      (or size (setq size 10))
92      (if (and (consp x) (not (memq (car x) '(quote function function*))))
93          (and (symbolp (car x))
94               (or (memq (car x) cl-simple-funcs)
95                   (get (car x) 'side-effect-free))
96               (progn
97                 (setq size (1- size))
98                 (while (and (setq x (cdr x))
99                             (setq size (cl-simple-expr-p (car x) size))))
100                 (and (null x) (>= size 0) size)))
101        (and (> size 0) (1- size))))
102    
103    (defun cl-simple-exprs-p (xs)
104      (while (and xs (cl-simple-expr-p (car xs)))
105        (setq xs (cdr xs)))
106      (not xs))
107    
108    ;;; Check if no side effects.
109    (defun cl-safe-expr-p (x)
110      (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
111          (and (symbolp (car x))
112               (or (memq (car x) cl-simple-funcs)
113                   (memq (car x) cl-safe-funcs)
114                   (get (car x) 'side-effect-free))
115               (progn
116                 (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
117                 (null x)))))
118    
119    ;;; Check if constant (i.e., no side effects or dependencies).
120    (defun cl-const-expr-p (x)
121      (cond ((consp x)
122             (or (eq (car x) 'quote)
123                 (and (memq (car x) '(function function*))
124                      (or (symbolp (nth 1 x))
125                          (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
126            ((symbolp x) (and (memq x '(nil t)) t))
127            (t t)))
128    
129    (defun cl-const-exprs-p (xs)
130      (while (and xs (cl-const-expr-p (car xs)))
131        (setq xs (cdr xs)))
132      (not xs))
133    
134    (defun cl-const-expr-val (x)
135      (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
136    
137    (defun cl-expr-access-order (x v)
138      (if (cl-const-expr-p x) v
139        (if (consp x)
140            (progn
141              (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
142              v)
143          (if (eq x (car v)) (cdr v) '(t)))))
144    
145    ;;; Count number of times X refers to Y.  Return nil for 0 times.
146    (defun cl-expr-contains (x y)
147      (cond ((equal y x) 1)
148            ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
149             (let ((sum 0))
150               (while x
151                 (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
152               (and (> sum 0) sum)))
153            (t nil)))
154    
155    (defun cl-expr-contains-any (x y)
156      (while (and y (not (cl-expr-contains x (car y)))) (pop y))
157      y)
158    
159    ;;; Check whether X may depend on any of the symbols in Y.
160    (defun cl-expr-depends-p (x y)
161      (and (not (cl-const-expr-p x))
162           (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
163    
164  ;;; Symbols.  ;;; Symbols.
165    
166  (defvar *gensym-counter*)  (defvar *gensym-counter*)
# Line 111  The name is made by appending a number t Line 186  The name is made by appending a number t
186  ;;; Program structure.  ;;; Program structure.
187    
188  (defmacro defun* (name args &rest body)  (defmacro defun* (name args &rest body)
189    "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.    "Define NAME as a function.
190  Like normal `defun', except ARGLIST allows full Common Lisp conventions,  Like normal `defun', except ARGLIST allows full Common Lisp conventions,
191  and BODY is implicitly surrounded by (block NAME ...)."  and BODY is implicitly surrounded by (block NAME ...).
192    
193    \(fn NAME ARGLIST [DOCSTRING] BODY...)"
194    (let* ((res (cl-transform-lambda (cons args body) name))    (let* ((res (cl-transform-lambda (cons args body) name))
195           (form (list* 'defun name (cdr res))))           (form (list* 'defun name (cdr res))))
196      (if (car res) (list 'progn (car res) form) form)))      (if (car res) (list 'progn (car res) form) form)))
197    
198  (defmacro defmacro* (name args &rest body)  (defmacro defmacro* (name args &rest body)
199    "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.    "Define NAME as a macro.
200  Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,  Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
201  and BODY is implicitly surrounded by (block NAME ...)."  and BODY is implicitly surrounded by (block NAME ...).
202    
203    \(fn NAME ARGLIST [DOCSTRING] BODY...)"
204    (let* ((res (cl-transform-lambda (cons args body) name))    (let* ((res (cl-transform-lambda (cons args body) name))
205           (form (list* 'defmacro name (cdr res))))           (form (list* 'defmacro name (cdr res))))
206      (if (car res) (list 'progn (car res) form) form)))      (if (car res) (list 'progn (car res) form) form)))
# Line 150  ARGLIST allows full Common Lisp conventi Line 229  ARGLIST allows full Common Lisp conventi
229  (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)  (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
230    
231  (defun cl-transform-lambda (form bind-block)  (defun cl-transform-lambda (form bind-block)
232    (let* ((args (car form)) (body (cdr form))    (let* ((args (car form)) (body (cdr form)) (orig-args args)
233           (bind-defs nil) (bind-enquote nil)           (bind-defs nil) (bind-enquote nil)
234           (bind-inits nil) (bind-lets nil) (bind-forms nil)           (bind-inits nil) (bind-lets nil) (bind-forms nil)
235           (header nil) (simple-args nil))           (header nil) (simple-args nil))
236      (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))      (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
237        (cl-push (cl-pop body) header))        (push (pop body) header))
238      (setq args (if (listp args) (copy-list args) (list '&rest args)))      (setq args (if (listp args) (copy-list args) (list '&rest args)))
239      (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))      (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
240      (if (setq bind-defs (cadr (memq '&cl-defs args)))      (if (setq bind-defs (cadr (memq '&cl-defs args)))
# Line 171  ARGLIST allows full Common Lisp conventi Line 250  ARGLIST allows full Common Lisp conventi
250                  (not (memq (car args) '(nil &rest &body &key &aux)))                  (not (memq (car args) '(nil &rest &body &key &aux)))
251                  (not (and (eq (car args) '&optional)                  (not (and (eq (car args) '&optional)
252                            (or bind-defs (consp (cadr args))))))                            (or bind-defs (consp (cadr args))))))
253        (cl-push (cl-pop args) simple-args))        (push (pop args) simple-args))
254      (or (eq bind-block 'cl-none)      (or (eq bind-block 'cl-none)
255          (setq body (list (list* 'block bind-block body))))          (setq body (list (list* 'block bind-block body))))
256      (if (null args)      (if (null args)
257          (list* nil (nreverse simple-args) (nconc (nreverse header) body))          (list* nil (nreverse simple-args) (nconc (nreverse header) body))
258        (if (memq '&optional simple-args) (cl-push '&optional args))        (if (memq '&optional simple-args) (push '&optional args))
259        (cl-do-arglist args nil (- (length simple-args)        (cl-do-arglist args nil (- (length simple-args)
260                                   (if (memq '&optional simple-args) 1 0)))                                   (if (memq '&optional simple-args) 1 0)))
261        (setq bind-lets (nreverse bind-lets))        (setq bind-lets (nreverse bind-lets))
262        (list* (and bind-inits (list* 'eval-when '(compile load eval)        (list* (and bind-inits (list* 'eval-when '(compile load eval)
263                                      (nreverse bind-inits)))                                      (nreverse bind-inits)))
264               (nconc (nreverse simple-args)               (nconc (nreverse simple-args)
265                      (list '&rest (car (cl-pop bind-lets))))                      (list '&rest (car (pop bind-lets))))
266               (nconc (nreverse header)               (nconc (let ((hdr (nreverse header)))
267                          (require 'help-fns)
268                          (cons (help-add-fundoc-usage
269                                 (if (stringp (car hdr)) (pop hdr)) orig-args)
270                                hdr))
271                      (list (nconc (list 'let* bind-lets)                      (list (nconc (list 'let* bind-lets)
272                                   (nreverse bind-forms) body)))))))                                   (nreverse bind-forms) body)))))))
273    
# Line 192  ARGLIST allows full Common Lisp conventi Line 275  ARGLIST allows full Common Lisp conventi
275    (if (nlistp args)    (if (nlistp args)
276        (if (or (memq args lambda-list-keywords) (not (symbolp args)))        (if (or (memq args lambda-list-keywords) (not (symbolp args)))
277            (error "Invalid argument name: %s" args)            (error "Invalid argument name: %s" args)
278          (cl-push (list args expr) bind-lets))          (push (list args expr) bind-lets))
279      (setq args (copy-list args))      (setq args (copy-list args))
280      (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))      (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
281      (let ((p (memq '&body args))) (if p (setcar p '&rest)))      (let ((p (memq '&body args))) (if p (setcar p '&rest)))
# Line 206  ARGLIST allows full Common Lisp conventi Line 289  ARGLIST allows full Common Lisp conventi
289        (if (listp (cadr restarg))        (if (listp (cadr restarg))
290            (setq restarg (gensym "--rest--"))            (setq restarg (gensym "--rest--"))
291          (setq restarg (cadr restarg)))          (setq restarg (cadr restarg)))
292        (cl-push (list restarg expr) bind-lets)        (push (list restarg expr) bind-lets)
293        (if (eq (car args) '&whole)        (if (eq (car args) '&whole)
294            (cl-push (list (cl-pop2 args) restarg) bind-lets))            (push (list (cl-pop2 args) restarg) bind-lets))
295        (let ((p args))        (let ((p args))
296          (setq minarg restarg)          (setq minarg restarg)
297          (while (and p (not (memq (car p) lambda-list-keywords)))          (while (and p (not (memq (car p) lambda-list-keywords)))
# Line 222  ARGLIST allows full Common Lisp conventi Line 305  ARGLIST allows full Common Lisp conventi
305          (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)          (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
306                              restarg)))                              restarg)))
307            (cl-do-arglist            (cl-do-arglist
308             (cl-pop args)             (pop args)
309             (if (or laterarg (= safety 0)) poparg             (if (or laterarg (= safety 0)) poparg
310               (list 'if minarg poparg               (list 'if minarg poparg
311                     (list 'signal '(quote wrong-number-of-arguments)                     (list 'signal '(quote wrong-number-of-arguments)
# Line 230  ARGLIST allows full Common Lisp conventi Line 313  ARGLIST allows full Common Lisp conventi
313                                            (list 'quote bind-block))                                            (list 'quote bind-block))
314                                 (list 'length restarg)))))))                                 (list 'length restarg)))))))
315          (setq num (1+ num) laterarg t))          (setq num (1+ num) laterarg t))
316        (while (and (eq (car args) '&optional) (cl-pop args))        (while (and (eq (car args) '&optional) (pop args))
317          (while (and args (not (memq (car args) lambda-list-keywords)))          (while (and args (not (memq (car args) lambda-list-keywords)))
318            (let ((arg (cl-pop args)))            (let ((arg (pop args)))
319              (or (consp arg) (setq arg (list arg)))              (or (consp arg) (setq arg (list arg)))
320              (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))              (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
321              (let ((def (if (cdr arg) (nth 1 arg)              (let ((def (if (cdr arg) (nth 1 arg)
# Line 247  ARGLIST allows full Common Lisp conventi Line 330  ARGLIST allows full Common Lisp conventi
330            (let ((arg (cl-pop2 args)))            (let ((arg (cl-pop2 args)))
331              (if (consp arg) (cl-do-arglist arg restarg)))              (if (consp arg) (cl-do-arglist arg restarg)))
332          (or (eq (car args) '&key) (= safety 0) exactarg          (or (eq (car args) '&key) (= safety 0) exactarg
333              (cl-push (list 'if restarg              (push (list 'if restarg
334                             (list 'signal '(quote wrong-number-of-arguments)                             (list 'signal '(quote wrong-number-of-arguments)
335                                   (list 'list                                   (list 'list
336                                         (and (not (eq bind-block 'cl-none))                                         (and (not (eq bind-block 'cl-none))
337                                              (list 'quote bind-block))                                              (list 'quote bind-block))
338                                         (list '+ num (list 'length restarg)))))                                         (list '+ num (list 'length restarg)))))
339                       bind-forms)))                       bind-forms)))
340        (while (and (eq (car args) '&key) (cl-pop args))        (while (and (eq (car args) '&key) (pop args))
341          (while (and args (not (memq (car args) lambda-list-keywords)))          (while (and args (not (memq (car args) lambda-list-keywords)))
342            (let ((arg (cl-pop args)))            (let ((arg (pop args)))
343              (or (consp arg) (setq arg (list arg)))              (or (consp arg) (setq arg (list arg)))
344              (let* ((karg (if (consp (car arg)) (caar arg)              (let* ((karg (if (consp (car arg)) (caar arg)
345                             (intern (format ":%s" (car arg)))))                             (intern (format ":%s" (car arg)))))
# Line 285  ARGLIST allows full Common Lisp conventi Line 368  ARGLIST allows full Common Lisp conventi
368                                            'quote                                            'quote
369                                            (list nil (cl-const-expr-val def)))                                            (list nil (cl-const-expr-val def)))
370                                         (list 'list nil def))))))))                                         (list 'list nil def))))))))
371                (cl-push karg keys)))))                (push karg keys)))))
372        (setq keys (nreverse keys))        (setq keys (nreverse keys))
373        (or (and (eq (car args) '&allow-other-keys) (cl-pop args))        (or (and (eq (car args) '&allow-other-keys) (pop args))
374            (null keys) (= safety 0)            (null keys) (= safety 0)
375            (let* ((var (gensym "--keys--"))            (let* ((var (gensym "--keys--"))
376                   (allow '(:allow-other-keys))                   (allow '(:allow-other-keys))
# Line 309  ARGLIST allows full Common Lisp conventi Line 392  ARGLIST allows full Common Lisp conventi
392                                   (format "Keyword argument %%s not one of %s"                                   (format "Keyword argument %%s not one of %s"
393                                           keys)                                           keys)
394                                   (list 'car var)))))))                                   (list 'car var)))))))
395              (cl-push (list 'let (list (list var restarg)) check) bind-forms)))              (push (list 'let (list (list var restarg)) check) bind-forms)))
396        (while (and (eq (car args) '&aux) (cl-pop args))        (while (and (eq (car args) '&aux) (pop args))
397          (while (and args (not (memq (car args) lambda-list-keywords)))          (while (and args (not (memq (car args) lambda-list-keywords)))
398            (if (consp (car args))            (if (consp (car args))
399                (if (and bind-enquote (cadar args))                (if (and bind-enquote (cadar args))
400                    (cl-do-arglist (caar args)                    (cl-do-arglist (caar args)
401                                   (list 'quote (cadr (cl-pop args))))                                   (list 'quote (cadr (pop args))))
402                  (cl-do-arglist (caar args) (cadr (cl-pop args))))                  (cl-do-arglist (caar args) (cadr (pop args))))
403              (cl-do-arglist (cl-pop args) nil))))              (cl-do-arglist (pop args) nil))))
404        (if args (error "Malformed argument list %s" save-args)))))        (if args (error "Malformed argument list %s" save-args)))))
405    
406  (defun cl-arglist-args (args)  (defun cl-arglist-args (args)
407    (if (nlistp args) (list args)    (if (nlistp args) (list args)
408      (let ((res nil) (kind nil) arg)      (let ((res nil) (kind nil) arg)
409        (while (consp args)        (while (consp args)
410          (setq arg (cl-pop args))          (setq arg (pop args))
411          (if (memq arg lambda-list-keywords) (setq kind arg)          (if (memq arg lambda-list-keywords) (setq kind arg)
412            (if (eq arg '&cl-defs) (cl-pop args)            (if (eq arg '&cl-defs) (pop args)
413              (and (consp arg) kind (setq arg (car arg)))              (and (consp arg) kind (setq arg (car arg)))
414              (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))              (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
415              (setq res (nconc res (cl-arglist-args arg))))))              (setq res (nconc res (cl-arglist-args arg))))))
# Line 346  ARGLIST allows full Common Lisp conventi Line 429  ARGLIST allows full Common Lisp conventi
429  (defvar cl-not-toplevel nil)  (defvar cl-not-toplevel nil)
430    
431  (defmacro eval-when (when &rest body)  (defmacro eval-when (when &rest body)
432    "(eval-when (WHEN...) BODY...): control when BODY is evaluated.    "Control when BODY is evaluated.
433  If `compile' is in WHEN, BODY is evaluated when compiled at top-level.  If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
434  If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.  If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
435  If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level."  If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
436    
437    \(fn (WHEN...) BODY...)"
438    (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)    (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
439             (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge             (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
440        (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))        (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
# Line 422  Key values are compared by `eql'." Line 507  Key values are compared by `eql'."
507                                   (if (memq (car c) head-list)                                   (if (memq (car c) head-list)
508                                       (error "Duplicate key in case: %s"                                       (error "Duplicate key in case: %s"
509                                              (car c)))                                              (car c)))
510                                   (cl-push (car c) head-list)                                   (push (car c) head-list)
511                                   (list 'eql temp (list 'quote (car c)))))                                   (list 'eql temp (list 'quote (car c)))))
512                            (or (cdr c) '(nil)))))                            (or (cdr c) '(nil)))))
513                   clauses))))                   clauses))))
# Line 452  final clause, and matches if no other ke Line 537  final clause, and matches if no other ke
537                                   (list 'error "etypecase failed: %s, %s"                                   (list 'error "etypecase failed: %s, %s"
538                                         temp (list 'quote (reverse type-list))))                                         temp (list 'quote (reverse type-list))))
539                                  (t                                  (t
540                                   (cl-push (car c) type-list)                                   (push (car c) type-list)
541                                   (cl-make-type-test temp (car c))))                                   (cl-make-type-test temp (car c))))
542                            (or (cdr c) '(nil)))))                            (or (cdr c) '(nil)))))
543                   clauses))))                   clauses))))
# Line 527  This is compatible with Common Lisp, but Line 612  This is compatible with Common Lisp, but
612  (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)  (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
613    
614  (defmacro loop (&rest args)  (defmacro loop (&rest args)
615    "(loop CLAUSE...): The Common Lisp `loop' macro.    "The Common Lisp `loop' macro.
616  Valid clauses are:  Valid clauses are:
617    for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,    for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
618    for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,    for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
# Line 538  Valid clauses are: Line 623  Valid clauses are:
623    if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],    if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
624    unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],    unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
625    do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,    do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
626    finally return EXPR, named NAME."    finally return EXPR, named NAME.
627    
628    \(fn CLAUSE...)"
629    (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))    (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
630        (list 'block nil (list* 'while t args))        (list 'block nil (list* 'while t args))
631      (let ((loop-name nil)       (loop-bindings nil)      (let ((loop-name nil)       (loop-bindings nil)
# Line 552  Valid clauses are: Line 639  Valid clauses are:
639        (setq args (append args '(cl-end-loop)))        (setq args (append args '(cl-end-loop)))
640        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))        (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
641        (if loop-finish-flag        (if loop-finish-flag
642            (cl-push (list (list loop-finish-flag t)) loop-bindings))            (push (list (list loop-finish-flag t)) loop-bindings))
643        (if loop-first-flag        (if loop-first-flag
644            (progn (cl-push (list (list loop-first-flag t)) loop-bindings)            (progn (push (list (list loop-first-flag t)) loop-bindings)
645                   (cl-push (list 'setq loop-first-flag nil) loop-steps)))                   (push (list 'setq loop-first-flag nil) loop-steps)))
646        (let* ((epilogue (nconc (nreverse loop-finally)        (let* ((epilogue (nconc (nreverse loop-finally)
647                                (list (or loop-result-explicit loop-result))))                                (list (or loop-result-explicit loop-result))))
648               (ands (cl-loop-build-ands (nreverse loop-body)))               (ands (cl-loop-build-ands (nreverse loop-body)))
# Line 577  Valid clauses are: Line 664  Valid clauses are:
664                            (list (list 'if loop-finish-flag                            (list (list 'if loop-finish-flag
665                                        (cons 'progn epilogue) loop-result-var)))                                        (cons 'progn epilogue) loop-result-var)))
666                        epilogue))))                        epilogue))))
667          (if loop-result-var (cl-push (list loop-result-var) loop-bindings))          (if loop-result-var (push (list loop-result-var) loop-bindings))
668          (while loop-bindings          (while loop-bindings
669            (if (cdar loop-bindings)            (if (cdar loop-bindings)
670                (setq body (list (cl-loop-let (cl-pop loop-bindings) body t)))                (setq body (list (cl-loop-let (pop loop-bindings) body t)))
671              (let ((lets nil))              (let ((lets nil))
672                (while (and loop-bindings                (while (and loop-bindings
673                            (not (cdar loop-bindings)))                            (not (cdar loop-bindings)))
674                  (cl-push (car (cl-pop loop-bindings)) lets))                  (push (car (pop loop-bindings)) lets))
675                (setq body (list (cl-loop-let lets body nil))))))                (setq body (list (cl-loop-let lets body nil))))))
676          (if loop-symbol-macs          (if loop-symbol-macs
677              (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))              (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
678          (list* 'block loop-name body)))))          (list* 'block loop-name body)))))
679    
680  (defun cl-parse-loop-clause ()   ; uses args, loop-*  (defun cl-parse-loop-clause ()   ; uses args, loop-*
681    (let ((word (cl-pop args))    (let ((word (pop args))
682          (hash-types '(hash-key hash-keys hash-value hash-values))          (hash-types '(hash-key hash-keys hash-value hash-values))
683          (key-types '(key-code key-codes key-seq key-seqs          (key-types '(key-code key-codes key-seq key-seqs
684                       key-binding key-bindings)))                       key-binding key-bindings)))
# Line 601  Valid clauses are: Line 688  Valid clauses are:
688        (error "Malformed `loop' macro"))        (error "Malformed `loop' macro"))
689    
690       ((eq word 'named)       ((eq word 'named)
691        (setq loop-name (cl-pop args)))        (setq loop-name (pop args)))
692    
693       ((eq word 'initially)       ((eq word 'initially)
694        (if (memq (car args) '(do doing)) (cl-pop args))        (if (memq (car args) '(do doing)) (pop args))
695        (or (consp (car args)) (error "Syntax error on `initially' clause"))        (or (consp (car args)) (error "Syntax error on `initially' clause"))
696        (while (consp (car args))        (while (consp (car args))
697          (cl-push (cl-pop args) loop-initially)))          (push (pop args) loop-initially)))
698    
699       ((eq word 'finally)       ((eq word 'finally)
700        (if (eq (car args) 'return)        (if (eq (car args) 'return)
701            (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))            (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
702          (if (memq (car args) '(do doing)) (cl-pop args))          (if (memq (car args) '(do doing)) (pop args))
703          (or (consp (car args)) (error "Syntax error on `finally' clause"))          (or (consp (car args)) (error "Syntax error on `finally' clause"))
704          (if (and (eq (caar args) 'return) (null loop-name))          (if (and (eq (caar args) 'return) (null loop-name))
705              (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil)))              (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
706            (while (consp (car args))            (while (consp (car args))
707              (cl-push (cl-pop args) loop-finally)))))              (push (pop args) loop-finally)))))
708    
709       ((memq word '(for as))       ((memq word '(for as))
710        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)        (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
711              (ands nil))              (ands nil))
712          (while          (while
713              (let ((var (or (cl-pop args) (gensym))))              (let ((var (or (pop args) (gensym))))
714                (setq word (cl-pop args))                (setq word (pop args))
715                (if (eq word 'being) (setq word (cl-pop args)))                (if (eq word 'being) (setq word (pop args)))
716                (if (memq word '(the each)) (setq word (cl-pop args)))                (if (memq word '(the each)) (setq word (pop args)))
717                (if (memq word '(buffer buffers))                (if (memq word '(buffer buffers))
718                    (setq word 'in args (cons '(buffer-list) args)))                    (setq word 'in args (cons '(buffer-list) args)))
719                (cond                (cond
720    
721                 ((memq word '(from downfrom upfrom to downto upto                 ((memq word '(from downfrom upfrom to downto upto
722                               above below by))                               above below by))
723                  (cl-push word args)                  (push word args)
724                  (if (memq (car args) '(downto above))                  (if (memq (car args) '(downto above))
725                      (error "Must specify `from' value for downward loop"))                      (error "Must specify `from' value for downward loop"))
726                  (let* ((down (or (eq (car args) 'downfrom)                  (let* ((down (or (eq (car args) 'downfrom)
# Line 651  Valid clauses are: Line 738  Valid clauses are:
738                                        (gensym))))                                        (gensym))))
739                    (and step (numberp step) (<= step 0)                    (and step (numberp step) (<= step 0)
740                         (error "Loop `by' value is not positive: %s" step))                         (error "Loop `by' value is not positive: %s" step))
741                    (cl-push (list var (or start 0)) loop-for-bindings)                    (push (list var (or start 0)) loop-for-bindings)
742                    (if end-var (cl-push (list end-var end) loop-for-bindings))                    (if end-var (push (list end-var end) loop-for-bindings))
743                    (if step-var (cl-push (list step-var step)                    (if step-var (push (list step-var step)
744                                          loop-for-bindings))                                          loop-for-bindings))
745                    (if end                    (if end
746                        (cl-push (list                        (push (list
747                                  (if down (if excl '> '>=) (if excl '< '<=))                                  (if down (if excl '> '>=) (if excl '< '<=))
748                                  var (or end-var end)) loop-body))                                  var (or end-var end)) loop-body))
749                    (cl-push (list var (list (if down '- '+) var                    (push (list var (list (if down '- '+) var
750                                             (or step-var step 1)))                                             (or step-var step 1)))
751                             loop-for-steps)))                             loop-for-steps)))
752    
753                 ((memq word '(in in-ref on))                 ((memq word '(in in-ref on))
754                  (let* ((on (eq word 'on))                  (let* ((on (eq word 'on))
755                         (temp (if (and on (symbolp var)) var (gensym))))                         (temp (if (and on (symbolp var)) var (gensym))))
756                    (cl-push (list temp (cl-pop args)) loop-for-bindings)                    (push (list temp (pop args)) loop-for-bindings)
757                    (cl-push (list 'consp temp) loop-body)                    (push (list 'consp temp) loop-body)
758                    (if (eq word 'in-ref)                    (if (eq word 'in-ref)
759                        (cl-push (list var (list 'car temp)) loop-symbol-macs)                        (push (list var (list 'car temp)) loop-symbol-macs)
760                      (or (eq temp var)                      (or (eq temp var)
761                          (progn                          (progn
762                            (cl-push (list var nil) loop-for-bindings)                            (push (list var nil) loop-for-bindings)
763                            (cl-push (list var (if on temp (list 'car temp)))                            (push (list var (if on temp (list 'car temp)))
764                                     loop-for-sets))))                                     loop-for-sets))))
765                    (cl-push (list temp                    (push (list temp
766                                   (if (eq (car args) 'by)                                   (if (eq (car args) 'by)
767                                       (let ((step (cl-pop2 args)))                                       (let ((step (cl-pop2 args)))
768                                         (if (and (memq (car-safe step)                                         (if (and (memq (car-safe step)
# Line 688  Valid clauses are: Line 775  Valid clauses are:
775                             loop-for-steps)))                             loop-for-steps)))
776    
777                 ((eq word '=)                 ((eq word '=)
778                  (let* ((start (cl-pop args))                  (let* ((start (pop args))
779                         (then (if (eq (car args) 'then) (cl-pop2 args) start)))                         (then (if (eq (car args) 'then) (cl-pop2 args) start)))
780                    (cl-push (list var nil) loop-for-bindings)                    (push (list var nil) loop-for-bindings)
781                    (if (or ands (eq (car args) 'and))                    (if (or ands (eq (car args) 'and))
782                        (progn                        (progn
783                          (cl-push (list var                          (push (list var
784                                         (list 'if                                         (list 'if
785                                               (or loop-first-flag                                               (or loop-first-flag
786                                                   (setq loop-first-flag                                                   (setq loop-first-flag
787                                                         (gensym)))                                                         (gensym)))
788                                               start var))                                               start var))
789                                   loop-for-sets)                                   loop-for-sets)
790                          (cl-push (list var then) loop-for-steps))                          (push (list var then) loop-for-steps))
791                      (cl-push (list var                      (push (list var
792                                     (if (eq start then) start                                     (if (eq start then) start
793                                       (list 'if                                       (list 'if
794                                             (or loop-first-flag                                             (or loop-first-flag
# Line 711  Valid clauses are: Line 798  Valid clauses are:
798    
799                 ((memq word '(across across-ref))                 ((memq word '(across across-ref))
800                  (let ((temp-vec (gensym)) (temp-idx (gensym)))                  (let ((temp-vec (gensym)) (temp-idx (gensym)))
801                    (cl-push (list temp-vec (cl-pop args)) loop-for-bindings)                    (push (list temp-vec (pop args)) loop-for-bindings)
802                    (cl-push (list temp-idx -1) loop-for-bindings)                    (push (list temp-idx -1) loop-for-bindings)
803                    (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx))                    (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
804                                   (list 'length temp-vec)) loop-body)                                   (list 'length temp-vec)) loop-body)
805                    (if (eq word 'across-ref)                    (if (eq word 'across-ref)
806                        (cl-push (list var (list 'aref temp-vec temp-idx))                        (push (list var (list 'aref temp-vec temp-idx))
807                                 loop-symbol-macs)                                 loop-symbol-macs)
808                      (cl-push (list var nil) loop-for-bindings)                      (push (list var nil) loop-for-bindings)
809                      (cl-push (list var (list 'aref temp-vec temp-idx))                      (push (list var (list 'aref temp-vec temp-idx))
810                               loop-for-sets))))                               loop-for-sets))))
811    
812                 ((memq word '(element elements))                 ((memq word '(element elements))
# Line 734  Valid clauses are: Line 821  Valid clauses are:
821                                          (cadr (cl-pop2 args))                                          (cadr (cl-pop2 args))
822                                        (error "Bad `using' clause"))                                        (error "Bad `using' clause"))
823                                    (gensym))))                                    (gensym))))
824                    (cl-push (list temp-seq seq) loop-for-bindings)                    (push (list temp-seq seq) loop-for-bindings)
825                    (cl-push (list temp-idx 0) loop-for-bindings)                    (push (list temp-idx 0) loop-for-bindings)
826                    (if ref                    (if ref
827                        (let ((temp-len (gensym)))                        (let ((temp-len (gensym)))
828                          (cl-push (list temp-len (list 'length temp-seq))                          (push (list temp-len (list 'length temp-seq))
829                                   loop-for-bindings)                                   loop-for-bindings)
830                          (cl-push (list var (list 'elt temp-seq temp-idx))                          (push (list var (list 'elt temp-seq temp-idx))
831                                   loop-symbol-macs)                                   loop-symbol-macs)
832                          (cl-push (list '< temp-idx temp-len) loop-body))                          (push (list '< temp-idx temp-len) loop-body))
833                      (cl-push (list var nil) loop-for-bindings)                      (push (list var nil) loop-for-bindings)
834                      (cl-push (list 'and temp-seq                      (push (list 'and temp-seq
835                                     (list 'or (list 'consp temp-seq)                                     (list 'or (list 'consp temp-seq)
836                                           (list '< temp-idx                                           (list '< temp-idx
837                                                 (list 'length temp-seq))))                                                 (list 'length temp-seq))))
838                               loop-body)                               loop-body)
839                      (cl-push (list var (list 'if (list 'consp temp-seq)                      (push (list var (list 'if (list 'consp temp-seq)
840                                               (list 'pop temp-seq)                                               (list 'pop temp-seq)
841                                               (list 'aref temp-seq temp-idx)))                                               (list 'aref temp-seq temp-idx)))
842                               loop-for-sets))                               loop-for-sets))
843                    (cl-push (list temp-idx (list '1+ temp-idx))                    (push (list temp-idx (list '1+ temp-idx))
844                             loop-for-steps)))                             loop-for-steps)))
845    
846                 ((memq word hash-types)                 ((memq word hash-types)
# Line 804  Valid clauses are: Line 891  Valid clauses are:
891                            (t (setq buf (cl-pop2 args)))))                            (t (setq buf (cl-pop2 args)))))
892                    (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))                    (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
893                        (setq var1 (car var) var2 (cdr var))                        (setq var1 (car var) var2 (cdr var))
894                      (cl-push (list var (list 'cons var1 var2)) loop-for-sets))                      (push (list var (list 'cons var1 var2)) loop-for-sets))
895                    (setq loop-map-form                    (setq loop-map-form
896                          (list 'cl-map-intervals                          (list 'cl-map-intervals
897                                (list 'function (list 'lambda (list var1 var2)                                (list 'function (list 'lambda (list var1 var2)
# Line 831  Valid clauses are: Line 918  Valid clauses are:
918    
919                 ((memq word '(frame frames screen screens))                 ((memq word '(frame frames screen screens))
920                  (let ((temp (gensym)))                  (let ((temp (gensym)))
921                    (cl-push (list var  '(selected-frame))                    (push (list var  '(selected-frame))
922                             loop-for-bindings)                             loop-for-bindings)
923                    (cl-push (list temp nil) loop-for-bindings)                    (push (list temp nil) loop-for-bindings)
924                    (cl-push (list 'prog1 (list 'not (list 'eq var temp))                    (push (list 'prog1 (list 'not (list 'eq var temp))
925                                   (list 'or temp (list 'setq temp var)))                                   (list 'or temp (list 'setq temp var)))
926                             loop-body)                             loop-body)
927                    (cl-push (list var (list 'next-frame var))                    (push (list var (list 'next-frame var))
928                             loop-for-steps)))                             loop-for-steps)))
929    
930                 ((memq word '(window windows))                 ((memq word '(window windows))
931                  (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))                  (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
932                        (temp (gensym)))                        (temp (gensym)))
933                    (cl-push (list var (if scr                    (push (list var (if scr
934                                           (list 'frame-selected-window scr)                                           (list 'frame-selected-window scr)
935                                         '(selected-window)))                                         '(selected-window)))
936                             loop-for-bindings)                             loop-for-bindings)
937                    (cl-push (list temp nil) loop-for-bindings)                    (push (list temp nil) loop-for-bindings)
938                    (cl-push (list 'prog1 (list 'not (list 'eq var temp))                    (push (list 'prog1 (list 'not (list 'eq var temp))
939                                   (list 'or temp (list 'setq temp var)))                                   (list 'or temp (list 'setq temp var)))
940                             loop-body)                             loop-body)
941                    (cl-push (list var (list 'next-window var)) loop-for-steps)))                    (push (list var (list 'next-window var)) loop-for-steps)))
942    
943                 (t                 (t
944                  (let ((handler (and (symbolp word)                  (let ((handler (and (symbolp word)
# Line 861  Valid clauses are: Line 948  Valid clauses are:
948                      (error "Expected a `for' preposition, found %s" word)))))                      (error "Expected a `for' preposition, found %s" word)))))
949                (eq (car args) 'and))                (eq (car args) 'and))
950            (setq ands t)            (setq ands t)
951            (cl-pop args))            (pop args))
952          (if (and ands loop-for-bindings)          (if (and ands loop-for-bindings)
953              (cl-push (nreverse loop-for-bindings) loop-bindings)              (push (nreverse loop-for-bindings) loop-bindings)
954            (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)            (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
955                                       loop-bindings)))                                       loop-bindings)))
956          (if loop-for-sets          (if loop-for-sets
957              (cl-push (list 'progn              (push (list 'progn
958                             (cl-loop-let (nreverse loop-for-sets) 'setq ands)                             (cl-loop-let (nreverse loop-for-sets) 'setq ands)
959                             t) loop-body))                             t) loop-body))
960          (if loop-for-steps          (if loop-for-steps
961              (cl-push (cons (if ands 'psetq 'setq)              (push (cons (if ands 'psetq 'setq)
962                             (apply 'append (nreverse loop-for-steps)))                             (apply 'append (nreverse loop-for-steps)))
963                       loop-steps))))                       loop-steps))))
964    
965       ((eq word 'repeat)       ((eq word 'repeat)
966        (let ((temp (gensym)))        (let ((temp (gensym)))
967          (cl-push (list (list temp (cl-pop args))) loop-bindings)          (push (list (list temp (pop args))) loop-bindings)
968          (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))          (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
969    
970       ((memq word '(collect collecting))       ((memq word '(collect collecting))
971        (let ((what (cl-pop args))        (let ((what (pop args))
972              (var (cl-loop-handle-accum nil 'nreverse)))              (var (cl-loop-handle-accum nil 'nreverse)))
973          (if (eq var loop-accum-var)          (if (eq var loop-accum-var)
974              (cl-push (list 'progn (list 'push what var) t) loop-body)              (push (list 'progn (list 'push what var) t) loop-body)
975            (cl-push (list 'progn            (push (list 'progn
976                           (list 'setq var (list 'nconc var (list 'list what)))                           (list 'setq var (list 'nconc var (list 'list what)))
977                           t) loop-body))))                           t) loop-body))))
978    
979       ((memq word '(nconc nconcing append appending))       ((memq word '(nconc nconcing append appending))
980        (let ((what (cl-pop args))        (let ((what (pop args))
981              (var (cl-loop-handle-accum nil 'nreverse)))              (var (cl-loop-handle-accum nil 'nreverse)))
982          (cl-push (list 'progn          (push (list 'progn
983                         (list 'setq var                         (list 'setq var
984                               (if (eq var loop-accum-var)                               (if (eq var loop-accum-var)
985                                   (list 'nconc                                   (list 'nconc
# Line 905  Valid clauses are: Line 992  Valid clauses are:
992                                       var what))) t) loop-body)))                                       var what))) t) loop-body)))
993    
994       ((memq word '(concat concating))       ((memq word '(concat concating))
995        (let ((what (cl-pop args))        (let ((what (pop args))
996              (var (cl-loop-handle-accum "")))              (var (cl-loop-handle-accum "")))
997          (cl-push (list 'progn (list 'callf 'concat var what) t) loop-body)))          (push (list 'progn (list 'callf 'concat var what) t) loop-body)))
998    
999       ((memq word '(vconcat vconcating))       ((memq word '(vconcat vconcating))
1000        (let ((what (cl-pop args))        (let ((what (pop args))
1001              (var (cl-loop-handle-accum [])))              (var (cl-loop-handle-accum [])))
1002          (cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))          (push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
1003    
1004       ((memq word '(sum summing))       ((memq word '(sum summing))
1005        (let ((what (cl-pop args))        (let ((what (pop args))
1006              (var (cl-loop-handle-accum 0)))              (var (cl-loop-handle-accum 0)))
1007          (cl-push (list 'progn (list 'incf var what) t) loop-body)))          (push (list 'progn (list 'incf var what) t) loop-body)))
1008    
1009       ((memq word '(count counting))       ((memq word '(count counting))
1010        (let ((what (cl-pop args))        (let ((what (pop args))
1011              (var (cl-loop-handle-accum 0)))              (var (cl-loop-handle-accum 0)))
1012          (cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))          (push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
1013    
1014       ((memq word '(minimize minimizing maximize maximizing))       ((memq word '(minimize minimizing maximize maximizing))
1015        (let* ((what (cl-pop args))        (let* ((what (pop args))
1016               (temp (if (cl-simple-expr-p what) what (gensym)))               (temp (if (cl-simple-expr-p what) what (gensym)))
1017               (var (cl-loop-handle-accum nil))               (var (cl-loop-handle-accum nil))
1018               (func (intern (substring (symbol-name word) 0 3)))               (func (intern (substring (symbol-name word) 0 3)))
1019               (set (list 'setq var (list 'if var (list func var temp) temp))))               (set (list 'setq var (list 'if var (list func var temp) temp))))
1020          (cl-push (list 'progn (if (eq temp what) set          (push (list 'progn (if (eq temp what) set
1021                                  (list 'let (list (list temp what)) set))                                  (list 'let (list (list temp what)) set))
1022                         t) loop-body)))                         t) loop-body)))
1023    
1024       ((eq word 'with)       ((eq word 'with)
1025        (let ((bindings nil))        (let ((bindings nil))
1026          (while (progn (cl-push (list (cl-pop args)          (while (progn (push (list (pop args)
1027                                       (and (eq (car args) '=) (cl-pop2 args)))                                       (and (eq (car args) '=) (cl-pop2 args)))
1028                                 bindings)                                 bindings)
1029                        (eq (car args) 'and))                        (eq (car args) 'and))
1030            (cl-pop args))            (pop args))
1031          (cl-push (nreverse bindings) loop-bindings)))          (push (nreverse bindings) loop-bindings)))
1032    
1033       ((eq word 'while)       ((eq word 'while)
1034        (cl-push (cl-pop args) loop-body))        (push (pop args) loop-body))
1035    
1036       ((eq word 'until)       ((eq word 'until)
1037        (cl-push (list 'not (cl-pop args)) loop-body))        (push (list 'not (pop args)) loop-body))
1038    
1039       ((eq word 'always)       ((eq word 'always)
1040        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (gensym)))
1041        (cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body)        (push (list 'setq loop-finish-flag (pop args)) loop-body)
1042        (setq loop-result t))        (setq loop-result t))
1043    
1044       ((eq word 'never)       ((eq word 'never)
1045        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (gensym)))
1046        (cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args)))        (push (list 'setq loop-finish-flag (list 'not (pop args)))
1047                 loop-body)                 loop-body)
1048        (setq loop-result t))        (setq loop-result t))
1049    
1050       ((eq word 'thereis)       ((eq word 'thereis)
1051        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (gensym)))
1052        (or loop-result-var (setq loop-result-var (gensym)))        (or loop-result-var (setq loop-result-var (gensym)))
1053        (cl-push (list 'setq loop-finish-flag        (push (list 'setq loop-finish-flag
1054                       (list 'not (list 'setq loop-result-var (cl-pop args))))                       (list 'not (list 'setq loop-result-var (pop args))))
1055                 loop-body))                 loop-body))
1056    
1057       ((memq word '(if when unless))       ((memq word '(if when unless))
1058        (let* ((cond (cl-pop args))        (let* ((cond (pop args))
1059               (then (let ((loop-body nil))               (then (let ((loop-body nil))
1060                       (cl-parse-loop-clause)                       (cl-parse-loop-clause)
1061                       (cl-loop-build-ands (nreverse loop-body))))                       (cl-loop-build-ands (nreverse loop-body))))
1062               (else (let ((loop-body nil))               (else (let ((loop-body nil))
1063                       (if (eq (car args) 'else)                       (if (eq (car args) 'else)
1064                           (progn (cl-pop args) (cl-parse-loop-clause)))                           (progn (pop args) (cl-parse-loop-clause)))
1065                       (cl-loop-build-ands (nreverse loop-body))))                       (cl-loop-build-ands (nreverse loop-body))))
1066               (simple (and (eq (car then) t) (eq (car else) t))))               (simple (and (eq (car then) t) (eq (car else) t))))
1067          (if (eq (car args) 'end) (cl-pop args))          (if (eq (car args) 'end) (pop args))
1068          (if (eq word 'unless) (setq then (prog1 else (setq else then))))          (if (eq word 'unless) (setq then (prog1 else (setq else then))))
1069          (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))          (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
1070                            (if simple (nth 1 else) (list (nth 2 else))))))                            (if simple (nth 1 else) (list (nth 2 else))))))
1071            (if (cl-expr-contains form 'it)            (if (cl-expr-contains form 'it)
1072                (let ((temp (gensym)))                (let ((temp (gensym)))
1073                  (cl-push (list temp) loop-bindings)                  (push (list temp) loop-bindings)
1074                  (setq form (list* 'if (list 'setq temp cond)                  (setq form (list* 'if (list 'setq temp cond)
1075                                    (subst temp 'it form))))                                    (subst temp 'it form))))
1076              (setq form (list* 'if cond form)))              (setq form (list* 'if cond form)))
1077            (cl-push (if simple (list 'progn form t) form) loop-body))))            (push (if simple (list 'progn form t) form) loop-body))))
1078    
1079       ((memq word '(do doing))       ((memq word '(do doing))
1080        (let ((body nil))        (let ((body nil))
1081          (or (consp (car args)) (error "Syntax error on `do' clause"))          (or (consp (car args)) (error "Syntax error on `do' clause"))
1082          (while (consp (car args)) (cl-push (cl-pop args) body))          (while (consp (car args)) (push (pop args) body))
1083          (cl-push (cons 'progn (nreverse (cons t body))) loop-body)))          (push (cons 'progn (nreverse (cons t body))) loop-body)))
1084    
1085       ((eq word 'return)       ((eq word 'return)
1086        (or loop-finish-flag (setq loop-finish-flag (gensym)))        (or loop-finish-flag (setq loop-finish-flag (gensym)))
1087        (or loop-result-var (setq loop-result-var (gensym)))        (or loop-result-var (setq loop-result-var (gensym)))
1088        (cl-push (list 'setq loop-result-var (cl-pop args)        (push (list 'setq loop-result-var (pop args)
1089                       loop-finish-flag nil) loop-body))                       loop-finish-flag nil) loop-body))
1090    
1091       (t       (t
# Line 1006  Valid clauses are: Line 1093  Valid clauses are:
1093          (or handler (error "Expected a loop keyword, found %s" word))          (or handler (error "Expected a loop keyword, found %s" word))
1094          (funcall handler))))          (funcall handler))))
1095      (if (eq (car args) 'and)      (if (eq (car args) 'and)
1096          (progn (cl-pop args) (cl-parse-loop-clause)))))          (progn (pop args) (cl-parse-loop-clause)))))
1097    
1098  (defun cl-loop-let (specs body par)   ; uses loop-*  (defun cl-loop-let (specs body par)   ; uses loop-*
1099    (let ((p specs) (temps nil) (new nil))    (let ((p specs) (temps nil) (new nil))
# Line 1018  Valid clauses are: Line 1105  Valid clauses are:
1105             (while p             (while p
1106               (or (cl-const-expr-p (cadar p))               (or (cl-const-expr-p (cadar p))
1107                   (let ((temp (gensym)))                   (let ((temp (gensym)))
1108                     (cl-push (list temp (cadar p)) temps)                     (push (list temp (cadar p)) temps)
1109                     (setcar (cdar p) temp)))                     (setcar (cdar p) temp)))
1110               (setq p (cdr p)))))               (setq p (cdr p)))))
1111      (while specs      (while specs
1112        (if (and (consp (car specs)) (listp (caar specs)))        (if (and (consp (car specs)) (listp (caar specs)))
1113            (let* ((spec (caar specs)) (nspecs nil)            (let* ((spec (caar specs)) (nspecs nil)
1114                   (expr (cadr (cl-pop specs)))                   (expr (cadr (pop specs)))
1115                   (temp (cdr (or (assq spec loop-destr-temps)                   (temp (cdr (or (assq spec loop-destr-temps)
1116                                  (car (cl-push (cons spec (or (last spec 0)                                  (car (push (cons spec (or (last spec 0)
1117                                                               (gensym)))                                                               (gensym)))
1118                                                loop-destr-temps))))))                                                loop-destr-temps))))))
1119              (cl-push (list temp expr) new)              (push (list temp expr) new)
1120              (while (consp spec)              (while (consp spec)
1121                (cl-push (list (cl-pop spec)                (push (list (pop spec)
1122                               (and expr (list (if spec 'pop 'car) temp)))                               (and expr (list (if spec 'pop 'car) temp)))
1123                         nspecs))                         nspecs))
1124              (setq specs (nconc (nreverse nspecs) specs)))              (setq specs (nconc (nreverse nspecs) specs)))
1125          (cl-push (cl-pop specs) new)))          (push (pop specs) new)))
1126      (if (eq body 'setq)      (if (eq body 'setq)
1127          (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))          (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
1128            (if temps (list 'let* (nreverse temps) set) set))            (if temps (list 'let* (nreverse temps) set) set))
# Line 1046  Valid clauses are: Line 1133  Valid clauses are:
1133    (if (eq (car args) 'into)    (if (eq (car args) 'into)
1134        (let ((var (cl-pop2 args)))        (let ((var (cl-pop2 args)))
1135          (or (memq var loop-accum-vars)          (or (memq var loop-accum-vars)
1136              (progn (cl-push (list (list var def)) loop-bindings)              (progn (push (list (list var def)) loop-bindings)
1137                     (cl-push var loop-accum-vars)))                     (push var loop-accum-vars)))
1138          var)          var)
1139      (or loop-accum-var      (or loop-accum-var
1140          (progn          (progn
1141            (cl-push (list (list (setq loop-accum-var (gensym)) def))            (push (list (list (setq loop-accum-var (gensym)) def))
1142                     loop-bindings)                     loop-bindings)
1143            (setq loop-result (if func (list func loop-accum-var)            (setq loop-result (if func (list func loop-accum-var)
1144                                loop-accum-var))                                loop-accum-var))
# Line 1070  Valid clauses are: Line 1157  Valid clauses are:
1157                                               (cdadr clauses)                                               (cdadr clauses)
1158                                             (list (cadr clauses))))                                             (list (cadr clauses))))
1159                                    (cddr clauses)))                                    (cddr clauses)))
1160              (setq body (cdr (butlast (cl-pop clauses)))))              (setq body (cdr (butlast (pop clauses)))))
1161          (cl-push (cl-pop clauses) ands)))          (push (pop clauses) ands)))
1162      (setq ands (or (nreverse ands) (list t)))      (setq ands (or (nreverse ands) (list t)))
1163      (list (if (cdr ands) (cons 'and ands) (car ands))      (list (if (cdr ands) (cons 'and ands) (car ands))
1164            body            body
# Line 1115  Format is: (do* ((VAR INIT [STEP])...) ( Line 1202  Format is: (do* ((VAR INIT [STEP])...) (
1202                 (or (cdr endtest) '(nil)))))                 (or (cdr endtest) '(nil)))))
1203    
1204  (defmacro dolist (spec &rest body)  (defmacro dolist (spec &rest body)
1205    "(dolist (VAR LIST [RESULT]) BODY...): loop over a list.    "Loop over a list.
1206  Evaluate BODY with VAR bound to each `car' from LIST, in turn.  Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1207  Then evaluate RESULT to get return value, default nil."  Then evaluate RESULT to get return value, default nil.
1208    
1209    \(fn (VAR LIST [RESULT]) BODY...)"
1210    (let ((temp (gensym "--dolist-temp--")))    (let ((temp (gensym "--dolist-temp--")))
1211      (list 'block nil      (list 'block nil
1212            (list* 'let (list (list temp (nth 1 spec)) (car spec))            (list* 'let (list (list temp (nth 1 spec)) (car spec))
# Line 1129  Then evaluate RESULT to get return value Line 1218  Then evaluate RESULT to get return value
1218                     '(nil))))))                     '(nil))))))
1219    
1220  (defmacro dotimes (spec &rest body)  (defmacro dotimes (spec &rest body)
1221    "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times.    "Loop a certain number of times.
1222  Evaluate BODY with VAR bound to successive integers from 0, inclusive,  Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1223  to COUNT, exclusive.  Then evaluate RESULT to get return value, default  to COUNT, exclusive.  Then evaluate RESULT to get return value, default
1224  nil."  nil.
1225    
1226    \(fn (VAR COUNT [RESULT]) BODY...)"
1227    (let ((temp (gensym "--dotimes-temp--")))    (let ((temp (gensym "--dotimes-temp--")))
1228      (list 'block nil      (list 'block nil
1229            (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))            (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
# Line 1141  nil." Line 1232  nil."
1232                   (or (cdr (cdr spec)) '(nil))))))                   (or (cdr (cdr spec)) '(nil))))))
1233    
1234  (defmacro do-symbols (spec &rest body)  (defmacro do-symbols (spec &rest body)
1235    "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols.    "Loop over all symbols.
1236  Evaluate BODY with VAR bound to each interned symbol, or to each symbol  Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1237  from OBARRAY."  from OBARRAY.
1238    
1239    \(fn (VAR [OBARRAY [RESULT]]) BODY...)"
1240    ;; Apparently this doesn't have an implicit block.    ;; Apparently this doesn't have an implicit block.
1241    (list 'block nil    (list 'block nil
1242          (list 'let (list (car spec))          (list 'let (list (car spec))
# Line 1159  from OBARRAY." Line 1252  from OBARRAY."
1252  ;;; Assignments.  ;;; Assignments.
1253    
1254  (defmacro psetq (&rest args)  (defmacro psetq (&rest args)
1255    "(psetq SYM VAL SYM VAL ...): set SYMs to the values VALs in parallel.    "Set SYMs to the values VALs in parallel.
1256  This is like `setq', except that all VAL forms are evaluated (in order)  This is like `setq', except that all VAL forms are evaluated (in order)
1257  before assigning any symbols SYM to the corresponding values."  before assigning any symbols SYM to the corresponding values.
1258    
1259    \(fn SYM VAL SYM VAL ...)"
1260    (cons 'psetf args))    (cons 'psetf args))
1261    
1262    
# Line 1181  a `let' form, except that the list of sy Line 1276  a `let' form, except that the list of sy
1276    
1277  ;;; This should really have some way to shadow 'byte-compile properties, etc.  ;;; This should really have some way to shadow 'byte-compile properties, etc.
1278  (defmacro flet (bindings &rest body)  (defmacro flet (bindings &rest body)
1279    "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns.    "Make temporary function defns.
1280  This is an analogue of `let' that operates on the function cell of FUNC  This is an analogue of `let' that operates on the function cell of FUNC
1281  rather than its value cell.  The FORMs are evaluated with the specified  rather than its value cell.  The FORMs are evaluated with the specified
1282  function definitions in place, then the definitions are undone (the FUNCs  function definitions in place, then the definitions are undone (the FUNCs
1283  go back to their previous definitions, or lack thereof)."  go back to their previous definitions, or lack thereof).
1284    
1285    \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1286    (list* 'letf*    (list* 'letf*
1287           (mapcar           (mapcar
1288            (function            (function
# Line 1199  go back to their previous definitions, o Line 1296  go back to their previous definitions, o
1296                                       (list* 'block (car x) (cddr x))))))                                       (list* 'block (car x) (cddr x))))))
1297                 (if (and (cl-compiling-file)                 (if (and (cl-compiling-file)
1298                          (boundp 'byte-compile-function-environment))                          (boundp 'byte-compile-function-environment))
1299                     (cl-push (cons (car x) (eval func))                     (push (cons (car x) (eval func))
1300                              byte-compile-function-environment))                              byte-compile-function-environment))
1301                 (list (list 'symbol-function (list 'quote (car x))) func))))                 (list (list 'symbol-function (list 'quote (car x))) func))))
1302            bindings)            bindings)
1303           body))           body))
1304    
1305  (defmacro labels (bindings &rest body)  (defmacro labels (bindings &rest body)
1306    "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.    "Make temporary func bindings.
1307  This is like `flet', except the bindings are lexical instead of dynamic.  This is like `flet', except the bindings are lexical instead of dynamic.
1308  Unlike `flet', this macro is fully complaint with the Common Lisp standard."  Unlike `flet', this macro is fully compliant with the Common Lisp standard.
1309    
1310    \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1311    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))    (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1312      (while bindings      (while bindings
1313        (let ((var (gensym)))        (let ((var (gensym)))
1314          (cl-push var vars)          (push var vars)
1315          (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)          (push (list 'function* (cons 'lambda (cdar bindings))) sets)
1316          (cl-push var sets)          (push var sets)
1317          (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args)          (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
1318                         (list 'list* '(quote funcall) (list 'quote var)                         (list 'list* '(quote funcall) (list 'quote var)
1319                               'cl-labels-args))                               'cl-labels-args))
1320                   cl-macro-environment)))                   cl-macro-environment)))
# Line 1225  Unlike `flet', this macro is fully compl Line 1324  Unlike `flet', this macro is fully compl
1324  ;; The following ought to have a better definition for use with newer  ;; The following ought to have a better definition for use with newer
1325  ;; byte compilers.  ;; byte compilers.
1326  (defmacro macrolet (bindings &rest body)  (defmacro macrolet (bindings &rest body)
1327    "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.    "Make temporary macro defns.
1328  This is like `flet', but for macros instead of functions."  This is like `flet', but for macros instead of functions.
1329    
1330    \(fn ((NAME ARGLIST BODY...) ...) FORM...)"
1331    (if (cdr bindings)    (if (cdr bindings)
1332        (list 'macrolet        (list 'macrolet
1333              (list (car bindings)) (list* 'macrolet (cdr bindings) body))              (list (car bindings)) (list* 'macrolet (cdr bindings) body))
# Line 1239  This is like `flet', but for macros inst Line 1340  This is like `flet', but for macros inst
1340                                    cl-macro-environment))))))                                    cl-macro-environment))))))
1341    
1342  (defmacro symbol-macrolet (bindings &rest body)  (defmacro symbol-macrolet (bindings &rest body)
1343    "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns.    "Make symbol macro defns.
1344  Within the body FORMs, references to the variable NAME will be replaced  Within the body FORMs, references to the variable NAME will be replaced
1345  by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."  by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
1346    
1347    \(fn ((NAME EXPANSION) ...) FORM...)"
1348    (if (cdr bindings)    (if (cdr bindings)
1349        (list 'symbol-macrolet        (list 'symbol-macrolet
1350              (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))              (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
# Line 1260  lexical closures as in Common Lisp." Line 1363  lexical closures as in Common Lisp."
1363           (vars (mapcar (function           (vars (mapcar (function
1364                          (lambda (x)                          (lambda (x)
1365                            (or (consp x) (setq x (list x)))                            (or (consp x) (setq x (list x)))
1366                            (cl-push (gensym (format "--%s--" (car x)))                            (push (gensym (format "--%s--" (car x)))
1367                                     cl-closure-vars)                                     cl-closure-vars)
1368                            (set (car cl-closure-vars) [bad-lexical-ref])                            (set (car cl-closure-vars) [bad-lexical-ref])
1369                            (list (car x) (cadr x) (car cl-closure-vars))))                            (list (car x) (cadr x) (car cl-closure-vars))))
1370                         bindings))                         bindings))
1371           (ebody           (ebody
1372            (cl-macroexpand-all            (cl-macroexpand-all
1373             (cons 'progn body)             (cons 'progn body)
1374             (nconc (mapcar (function (lambda (x)             (nconc (mapcar (function (lambda (x)
# Line 1301  lexical closures as in Common Lisp." Line 1404  lexical closures as in Common Lisp."
1404    (if (null bindings) (cons 'progn body)    (if (null bindings) (cons 'progn body)
1405      (setq bindings (reverse bindings))      (setq bindings (reverse bindings))
1406      (while bindings      (while bindings
1407        (setq body (list (list* 'lexical-let (list (cl-pop bindings)) body))))        (setq body (list (list* 'lexical-let (list (pop bindings)) body))))
1408      (car body)))      (car body)))
1409    
1410  (defun cl-defun-expander (func &rest rest)  (defun cl-defun-expander (func &rest rest)
# Line 1314  lexical closures as in Common Lisp." Line 1417  lexical closures as in Common Lisp."
1417  ;;; Multiple values.  ;;; Multiple values.
1418    
1419  (defmacro multiple-value-bind (vars form &rest body)  (defmacro multiple-value-bind (vars form &rest body)
1420    "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values.    "Collect multiple return values.
1421  FORM must return a list; the BODY is then executed with the first N elements  FORM must return a list; the BODY is then executed with the first N elements
1422  of this list bound (`let'-style) to each of the symbols SYM in turn.  This  of this list bound (`let'-style) to each of the symbols SYM in turn.  This
1423  is analogous to the Common Lisp `multiple-value-bind' macro, using lists to  is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
1424  simulate true multiple return values.  For compatibility, (values A B C) is  simulate true multiple return values.  For compatibility, (values A B C) is
1425  a synonym for (list A B C)."  a synonym for (list A B C).
1426    
1427    \(fn (SYM SYM...) FORM BODY)"
1428    (let ((temp (gensym)) (n -1))    (let ((temp (gensym)) (n -1))
1429      (list* 'let* (cons (list temp form)      (list* 'let* (cons (list temp form)
1430                         (mapcar (function                         (mapcar (function
# Line 1329  a synonym for (list A B C)." Line 1434  a synonym for (list A B C)."
1434             body)))             body)))
1435    
1436  (defmacro multiple-value-setq (vars form)  (defmacro multiple-value-setq (vars form)
1437    "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values.    "Collect multiple return values.
1438  FORM must return a list; the first N elements of this list are stored in  FORM must return a list; the first N elements of this list are stored in
1439  each of the symbols SYM in turn.  This is analogous to the Common Lisp  each of the symbols SYM in turn.  This is analogous to the Common Lisp
1440  `multiple-value-setq' macro, using lists to simulate true multiple return  `multiple-value-setq' macro, using lists to simulate true multiple return
1441  values.  For compatibility, (values A B C) is a synonym for (list A B C)."  values.  For compatibility, (values A B C) is a synonym for (list A B C).
1442    
1443    \(fn (SYM SYM...) FORM)"
1444    (cond ((null vars) (list 'progn form nil))    (cond ((null vars) (list 'progn form nil))
1445          ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))          ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1446          (t          (t
1447           (let* ((temp (gensym)) (n 0))           (let* ((temp (gensym)) (n 0))
1448             (list 'let (list (list temp form))             (list 'let (list (list temp form))
1449                   (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp))                   (list 'prog1 (list 'setq (pop vars) (list 'car temp))
1450                         (cons 'setq (apply 'nconc                         (cons 'setq (apply 'nconc
1451                                            (mapcar (function                                            (mapcar (function
1452                                                     (lambda (v)                                                     (lambda (v)
# Line 1359  values.  For compatibility, (values A B Line 1466  values.  For compatibility, (values A B
1466  (defvar cl-declare-stack t)       ; for future compilers  (defvar cl-declare-stack t)       ; for future compilers
1467    
1468  (defun cl-do-proclaim (spec hist)  (defun cl-do-proclaim (spec hist)
1469    (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))    (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
1470    (cond ((eq (car-safe spec) 'special)    (cond ((eq (car-safe spec) 'special)
1471           (if (boundp 'byte-compile-bound-variables)           (if (boundp 'byte-compile-bound-variables)
1472               (setq byte-compile-bound-variables               (setq byte-compile-bound-variables
# Line 1404  values.  For compatibility, (values A B Line 1511  values.  For compatibility, (values A B
1511  ;;; Process any proclamations made before cl-macs was loaded.  ;;; Process any proclamations made before cl-macs was loaded.
1512  (defvar cl-proclaims-deferred)  (defvar cl-proclaims-deferred)
1513  (let ((p (reverse cl-proclaims-deferred)))  (let ((p (reverse cl-proclaims-deferred)))
1514    (while p (cl-do-proclaim (cl-pop p) t))    (while p (cl-do-proclaim (pop p) t))
1515    (setq cl-proclaims-deferred nil))    (setq cl-proclaims-deferred nil))
1516    
1517  (defmacro declare (&rest specs)  (defmacro declare (&rest specs)
1518    (if (cl-compiling-file)    (if (cl-compiling-file)
1519        (while specs        (while specs
1520          (if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack))          (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
1521          (cl-do-proclaim (cl-pop specs) nil)))          (cl-do-proclaim (pop specs) nil)))
1522    nil)    nil)
1523    
1524    
# Line 1419  values.  For compatibility, (values A B Line 1526  values.  For compatibility, (values A B
1526  ;;; Generalized variables.  ;;; Generalized variables.
1527    
1528  (defmacro define-setf-method (func args &rest body)  (defmacro define-setf-method (func args &rest body)
1529    "(define-setf-method NAME ARGLIST BODY...): define a `setf' method.    "Define a `setf' method.
1530  This method shows how to handle `setf's to places of the form (NAME ARGS...).  This method shows how to handle `setf's to places of the form (NAME ARGS...).
1531  The argument forms ARGS are bound according to ARGLIST, as if NAME were  The argument forms ARGS are bound according to ARGLIST, as if NAME were
1532  going to be expanded as a macro, then the BODY forms are executed and must  going to be expanded as a macro, then the BODY forms are executed and must
1533  return a list of five elements: a temporary-variables list, a value-forms  return a list of five elements: a temporary-variables list, a value-forms
1534  list, a store-variables list (of length one), a store-form, and an access-  list, a store-variables list (of length one), a store-form, and an access-
1535  form.  See `defsetf' for a simpler way to define most setf-methods."  form.  See `defsetf' for a simpler way to define most setf-methods.
1536    
1537    \(fn NAME ARGLIST BODY...)"
1538    (append '(eval-when (compile load eval))    (append '(eval-when (compile load eval))
1539            (if (stringp (car body))            (if (stringp (car body))
1540                (list (list 'put (list 'quote func) '(quote setf-documentation)                (list (list 'put (list 'quote func) '(quote setf-documentation)
1541                            (cl-pop body))))                            (pop body))))
1542            (list (cl-transform-function-property            (list (cl-transform-function-property
1543                   func 'setf-method (cons args body)))))                   func 'setf-method (cons args body)))))
1544  (defalias 'define-setf-expander 'define-setf-method)  (defalias 'define-setf-expander 'define-setf-method)
# Line 1526  Example: (defsetf nth (n x) (v) (list 's Line 1635  Example: (defsetf nth (n x) (v) (list 's
1635          (list 'aset seq n store)))          (list 'aset seq n store)))
1636  (defsetf get put)  (defsetf get put)
1637  (defsetf get* (x y &optional d) (store) (list 'put x y store))  (defsetf get* (x y &optional d) (store) (list 'put x y store))
1638  (defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h))  (defsetf gethash (x h &optional d) (store) (list 'puthash x store h))
1639  (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))  (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
1640  (defsetf subseq (seq start &optional end) (new)  (defsetf subseq (seq start &optional end) (new)
1641    (list 'progn (list 'replace seq new :start1 start :end1 end) new))    (list 'progn (list 'replace seq new :start1 start :end1 end) new))
# Line 1615  Example: (defsetf nth (n x) (v) (list 's Line 1724  Example: (defsetf nth (n x) (v) (list 's
1724  (defsetf process-buffer set-process-buffer)  (defsetf process-buffer set-process-buffer)
1725  (defsetf process-filter set-process-filter)  (defsetf process-filter set-process-filter)
1726  (defsetf process-sentinel set-process-sentinel)  (defsetf process-sentinel set-process-sentinel)
1727    (defsetf process-get process-put)
1728  (defsetf read-mouse-position (scr) (store)  (defsetf read-mouse-position (scr) (store)
1729    (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))    (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
1730  (defsetf screen-height set-screen-height t)  (defsetf screen-height set-screen-height t)
# Line 1749  a macro like `setf' or `incf'." Line 1859  a macro like `setf' or `incf'."
1859           (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))           (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
1860      (while values      (while values
1861        (if (or simple (cl-const-expr-p (car values)))        (if (or simple (cl-const-expr-p (car values)))
1862            (cl-push (cons (cl-pop temps) (cl-pop values)) subs)            (push (cons (pop temps) (pop values)) subs)
1863          (cl-push (list (cl-pop temps) (cl-pop values)) lets)))          (push (list (pop temps) (pop values)) lets)))
1864      (list (nreverse lets)      (list (nreverse lets)
1865            (cons (car (nth 2 method)) (sublis subs (nth 3 method)))            (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
1866            (sublis subs (nth 4 method)))))            (sublis subs (nth 4 method)))))
# Line 1772  a macro like `setf' or `incf'." Line 1882  a macro like `setf' or `incf'."
1882    
1883  ;;; The standard modify macros.  ;;; The standard modify macros.
1884  (defmacro setf (&rest args)  (defmacro setf (&rest args)
1885    "(setf PLACE VAL PLACE VAL ...): set each PLACE to the value of its VAL.    "Set each PLACE to the value of its VAL.
1886  This is a generalized version of `setq'; the PLACEs may be symbolic  This is a generalized version of `setq'; the PLACEs may be symbolic
1887  references such as (car x) or (aref x i), as well as plain symbols.  references such as (car x) or (aref x i), as well as plain symbols.
1888  For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).  For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
1889  The return value is the last VAL in the list."  The return value is the last VAL in the list.
1890    
1891    \(fn PLACE VAL PLACE VAL ...)"
1892    (if (cdr (cdr args))    (if (cdr (cdr args))
1893        (let ((sets nil))        (let ((sets nil))
1894          (while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets))          (while args (push (list 'setf (pop args) (pop args)) sets))
1895          (cons 'progn (nreverse sets)))          (cons 'progn (nreverse sets)))
1896      (if (symbolp (car args))      (if (symbolp (car args))
1897          (and args (cons 'setq args))          (and args (cons 'setq args))
# Line 1788  The return value is the last VAL in the Line 1900  The return value is the last VAL in the
1900          (if (car method) (list 'let* (car method) store) store)))))          (if (car method) (list 'let* (car method) store) store)))))
1901    
1902  (defmacro psetf (&rest args)  (defmacro psetf (&rest args)
1903    "(psetf PLACE VAL PLACE VAL ...): set PLACEs to the values VALs in parallel.    "Set PLACEs to the values VALs in parallel.
1904  This is like `setf', except that all VAL forms are evaluated (in order)  This is like `setf', except that all VAL forms are evaluated (in order)
1905  before assigning any PLACEs to the corresponding values."  before assigning any PLACEs to the corresponding values.
1906    
1907    \(fn PLACE VAL PLACE VAL ...)"
1908    (let ((p args) (simple t) (vars nil))    (let ((p args) (simple t) (vars nil))
1909      (while p      (while p
1910        (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))        (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
1911            (setq simple nil))            (setq simple nil))
1912        (if (memq (car p) vars)        (if (memq (car p) vars)
1913            (error "Destination duplicated in psetf: %s" (car p)))            (error "Destination duplicated in psetf: %s" (car p)))
1914        (cl-push (cl-pop p) vars)        (push (pop p) vars)
1915        (or p (error "Odd number of arguments to psetf"))        (or p (error "Odd number of arguments to psetf"))
1916        (cl-pop p))        (pop p))
1917      (if simple      (if simple
1918          (list 'progn (cons 'setf args) nil)          (list 'progn (cons 'setf args) nil)
1919        (setq args (reverse args))        (setq args (reverse args))
# Line 1841  The form returns true if TAG was found a Line 1955  The form returns true if TAG was found a
1955                  (list 'cl-do-remf tval ttag)))))                  (list 'cl-do-remf tval ttag)))))
1956    
1957  (defmacro shiftf (place &rest args)  (defmacro shiftf (place &rest args)
1958    "(shiftf PLACE PLACE... VAL): shift left among PLACEs.    "Shift left among PLACEs.
1959  Example: (shiftf A B C) sets A to B, B to C, and returns the old A.  Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
1960  Each PLACE may be a symbol, or any generalized variable allowed by `setf'."  Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
1961    
1962    \(fn PLACE PLACE... VAL)"
1963    (cond    (cond
1964     ((null args) place)     ((null args) place)
1965     ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))     ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
# Line 1854  Each PLACE may be a symbol, or any gener Line 1970  Each PLACE may be a symbol, or any gener
1970             ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))             ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
1971    
1972  (defmacro rotatef (&rest args)  (defmacro rotatef (&rest args)
1973    "(rotatef PLACE...): rotate left among PLACEs.    "Rotate left among PLACEs.
1974  Example: (rotatef A B C) sets A to B, B to C, and C to A.  It returns nil.  Example: (rotatef A B C) sets A to B, B to C, and C to A.  It returns nil.
1975  Each PLACE may be a symbol, or any generalized variable allowed by `setf'."  Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
1976    
1977    \(fn PLACE...)"
1978    (if (not (memq nil (mapcar 'symbolp args)))    (if (not (memq nil (mapcar 'symbolp args)))
1979        (and (cdr args)        (and (cdr args)
1980             (let ((sets nil)             (let ((sets nil)
1981                   (first (car args)))                   (first (car args)))
1982               (while (cdr args)               (while (cdr args)
1983                 (setq sets (nconc sets (list (cl-pop args) (car args)))))                 (setq sets (nconc sets (list (pop args) (car args)))))
1984               (nconc (list 'psetf) sets (list (car args) first))))               (nconc (list 'psetf) sets (list (car args) first))))
1985      (let* ((places (reverse args))      (let* ((places (reverse args))
1986             (temp (gensym "--rotatef--"))             (temp (gensym "--rotatef--"))
1987             (form temp))             (form temp))
1988        (while (cdr places)        (while (cdr places)
1989          (let ((method (cl-setf-do-modify (cl-pop places) 'unsafe)))          (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
1990            (setq form (list 'let* (car method)            (setq form (list 'let* (car method)
1991                             (list 'prog1 (nth 2 method)                             (list 'prog1 (nth 2 method)
1992                                   (cl-setf-do-store (nth 1 method) form))))))                                   (cl-setf-do-store (nth 1 method) form))))))
# Line 1877  Each PLACE may be a symbol, or any gener Line 1995  Each PLACE may be a symbol, or any gener
1995                (cl-setf-do-store (nth 1 method) form) nil)))))                (cl-setf-do-store (nth 1 method) form) nil)))))
1996    
1997  (defmacro letf (bindings &rest body)  (defmacro letf (bindings &rest body)
1998    "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs.    "Temporarily bind to PLACEs.
1999  This is the analogue of `let', but with generalized variables (in the  This is the analogue of `let', but with generalized variables (in the
2000  sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding  sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding
2001  VALUE, then the BODY forms are executed.  On exit, either normally or  VALUE, then the BODY forms are executed.  On exit, either normally or
2002  because of a `throw' or error, the PLACEs are set back to their original  because of a `throw' or error, the PLACEs are set back to their original
2003  values.  Note that this macro is *not* available in Common Lisp.  values.  Note that this macro is *not* available in Common Lisp.
2004  As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',  As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2005  the PLACE is not modified before executing BODY."  the PLACE is not modified before executing BODY.
2006    
2007    \(fn ((PLACE VALUE) ...) BODY...)"
2008    (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))    (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
2009        (list* 'let bindings body)        (list* 'let bindings body)
2010      (let ((lets nil) (sets nil)      (let ((lets nil) (sets nil)
# Line 1931  the PLACE is not modified before executi Line 2051  the PLACE is not modified before executi
2051        (list* 'let* lets body))))        (list* 'let* lets body))))
2052    
2053  (defmacro letf* (bindings &rest body)  (defmacro letf* (bindings &rest body)
2054    "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs.    "Temporarily bind to PLACEs.
2055  This is the analogue of `let*', but with generalized variables (in the  This is the analogue of `let*', but with generalized variables (in the
2056  sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding  sense of `setf') for the PLACEs.  Each PLACE is set to the corresponding
2057  VALUE, then the BODY forms are executed.  On exit, either normally or  VALUE, then the BODY forms are executed.  On exit, either normally or
2058  because of a `throw' or error, the PLACEs are set back to their original  because of a `throw' or error, the PLACEs are set back to their original
2059  values.  Note that this macro is *not* available in Common Lisp.  values.  Note that this macro is *not* available in Common Lisp.
2060  As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',  As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2061  the PLACE is not modified before executing BODY."  the PLACE is not modified before executing BODY.
2062    
2063    \(fn ((PLACE VALUE) ...) BODY...)"
2064    (if (null bindings)    (if (null bindings)
2065        (cons 'progn body)        (cons 'progn body)
2066      (setq bindings (reverse bindings))      (setq bindings (reverse bindings))
2067      (while bindings      (while bindings
2068        (setq body (list (list* 'letf (list (cl-pop bindings)) body))))        (setq body (list (list* 'letf (list (pop bindings)) body))))
2069      (car body)))      (car body)))
2070    
2071  (defmacro callf (func place &rest args)  (defmacro callf (func place &rest args)
2072    "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...).    "Set PLACE to (FUNC PLACE ARGS...).
2073  FUNC should be an unquoted function name.  PLACE may be a symbol,  FUNC should be an unquoted function name.  PLACE may be a symbol,
2074  or any generalized variable allowed by `setf'."  or any generalized variable allowed by `setf'.
2075    
2076    \(fn FUNC PLACE ARGS...)"
2077    (let* ((method (cl-setf-do-modify place (cons 'list args)))    (let* ((method (cl-setf-do-modify place (cons 'list args)))
2078           (rargs (cons (nth 2 method) args)))           (rargs (cons (nth 2 method) args)))
2079      (list 'let* (car method)      (list 'let* (car method)
# Line 1959  or any generalized variable allowed by ` Line 2083  or any generalized variable allowed by `
2083                                       rargs))))))                                       rargs))))))
2084    
2085  (defmacro callf2 (func arg1 place &rest args)  (defmacro callf2 (func arg1 place &rest args)
2086    "(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...).    "Set PLACE to (FUNC ARG1 PLACE ARGS...).
2087  Like `callf', but PLACE is the second argument of FUNC, not the first."  Like `callf', but PLACE is the second argument of FUNC, not the first.
2088    
2089    \(fn FUNC ARG1 PLACE ARGS...)"
2090    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))    (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
2091        (list 'setf place (list* func arg1 place args))        (list 'setf place (list* func arg1 place args))
2092      (let* ((method (cl-setf-do-modify place (cons 'list args)))      (let* ((method (cl-setf-do-modify place (cons 'list args)))
# Line 1987  from ARGLIST using FUNC: (define-modify- Line 2113  from ARGLIST using FUNC: (define-modify-
2113  ;;; Structures.  ;;; Structures.
2114    
2115  (defmacro defstruct (struct &rest descs)  (defmacro defstruct (struct &rest descs)
2116    "(defstruct (NAME OPTIONS...) (SLOT SLOT-OPTS...)...): define a struct type.    "Define a struct type.
2117  This macro defines a new Lisp data type called NAME, which contains data  This macro defines a new Lisp data type called NAME, which contains data
2118  stored in SLOTs.  This defines a `make-NAME' constructor, a `copy-NAME'  stored in SLOTs.  This defines a `make-NAME' constructor, a `copy-NAME'
2119  copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."  copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
2120    
2121    \(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)"
2122    (let* ((name (if (consp struct) (car struct) struct))    (let* ((name (if (consp struct) (car struct) struct))
2123           (opts (cdr-safe struct))           (opts (cdr-safe struct))
2124           (slots nil)           (slots nil)
# Line 2012  copier, a `NAME-p' predicate, and setf-a Line 2140  copier, a `NAME-p' predicate, and setf-a
2140           (forms nil)           (forms nil)
2141           pred-form pred-check)           pred-form pred-check)
2142      (if (stringp (car descs))      (if (stringp (car descs))
2143          (cl-push (list 'put (list 'quote name) '(quote structure-documentation)          (push (list 'put (list 'quote name) '(quote structure-documentation)
2144                         (cl-pop descs)) forms))                         (pop descs)) forms))
2145      (setq descs (cons '(cl-tag-slot)      (setq descs (cons '(cl-tag-slot)
2146                        (mapcar (function (lambda (x) (if (consp x) x (list x))))                        (mapcar (function (lambda (x) (if (consp x) x (list x))))
2147                                descs)))                                descs)))
2148      (while opts      (while opts
2149        (let ((opt (if (consp (car opts)) (caar opts) (car opts)))        (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
2150              (args (cdr-safe (cl-pop opts))))              (args (cdr-safe (pop opts))))
2151          (cond ((eq opt :conc-name)          (cond ((eq opt :conc-name)
2152                 (if args                 (if args
2153                     (setq conc-name (if (car args)                     (setq conc-name (if (car args)
2154                                         (symbol-name (car args)) ""))))                                         (symbol-name (car args)) ""))))
2155                ((eq opt :constructor)                ((eq opt :constructor)
2156                 (if (cdr args)                 (if (cdr args)
2157                     (cl-push args constrs)                     (push args constrs)
2158                   (if args (setq constructor (car args)))))                   (if args (setq constructor (car args)))))
2159                ((eq opt :copier)                ((eq opt :copier)
2160                 (if args (setq copier (car args))))                 (if args (setq copier (car args))))
# Line 2070  copier, a `NAME-p' predicate, and setf-a Line 2198  copier, a `NAME-p' predicate, and setf-a
2198                                (error "No slot %s in included struct %s"                                (error "No slot %s in included struct %s"
2199                                       (caar include-descs) include))                                       (caar include-descs) include))
2200                            old-descs)                            old-descs)
2201                      (cl-pop include-descs)))                      (pop include-descs)))
2202            (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))            (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2203                  type (car inc-type)                  type (car inc-type)
2204                  named (assq 'cl-tag-slot descs))                  named (assq 'cl-tag-slot descs))
2205            (if (cadr inc-type) (setq tag name named t))            (if (cadr inc-type) (setq tag name named t))
2206            (let ((incl include))            (let ((incl include))
2207              (while incl              (while incl
2208                (cl-push (list 'pushnew (list 'quote tag)                (push (list 'pushnew (list 'quote tag)
2209                               (intern (format "cl-struct-%s-tags" incl)))                               (intern (format "cl-struct-%s-tags" incl)))
2210                         forms)                         forms)
2211                (setq incl (get incl 'cl-struct-include)))))                (setq incl (get incl 'cl-struct-include)))))
# Line 2088  copier, a `NAME-p' predicate, and setf-a Line 2216  copier, a `NAME-p' predicate, and setf-a
2216              (if named (setq tag name)))              (if named (setq tag name)))
2217          (setq type 'vector named 'true)))          (setq type 'vector named 'true)))
2218      (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))      (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
2219      (cl-push (list 'defvar tag-symbol) forms)      (push (list 'defvar tag-symbol) forms)
2220      (setq pred-form (and named      (setq pred-form (and named
2221                           (let ((pos (- (length descs)                           (let ((pos (- (length descs)
2222                                         (length (memq (assq 'cl-tag-slot descs)                                         (length (memq (assq 'cl-tag-slot descs)
# Line 2109  copier, a `NAME-p' predicate, and setf-a Line 2237  copier, a `NAME-p' predicate, and setf-a
2237                                (cons 'and (cdddr pred-form)) pred-form)))                                (cons 'and (cdddr pred-form)) pred-form)))
2238      (let ((pos 0) (descp descs))      (let ((pos 0) (descp descs))
2239        (while descp        (while descp
2240          (let* ((desc (cl-pop descp))          (let* ((desc (pop descp))
2241                 (slot (car desc)))                 (slot (car desc)))
2242            (if (memq slot '(cl-tag-slot cl-skip-slot))            (if (memq slot '(cl-tag-slot cl-skip-slot))
2243                (progn                (progn
2244                  (cl-push nil slots)                  (push nil slots)
2245                  (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag))                  (push (and (eq slot 'cl-tag-slot) (list 'quote tag))
2246                           defaults))                           defaults))
2247              (if (assq slot descp)              (if (assq slot descp)
2248                  (error "Duplicate slots named %s in %s" slot name))                  (error "Duplicate slots named %s in %s" slot name))
2249              (let ((accessor (intern (format "%s%s" conc-name slot))))              (let ((accessor (intern (format "%s%s" conc-name slot))))
2250                (cl-push slot slots)                (push slot slots)
2251                (cl-push (nth 1 desc) defaults)                (push (nth 1 desc) defaults)
2252                (cl-push (list*                (push (list*
2253                          'defsubst* accessor '(cl-x)                          'defsubst* accessor '(cl-x)
2254                          (append                          (append
2255                           (and pred-check                           (and pred-check
# Line 2133  copier, a `NAME-p' predicate, and setf-a Line 2261  copier, a `NAME-p' predicate, and setf-a
2261                           (list (if (eq type 'vector) (list 'aref 'cl-x pos)                           (list (if (eq type 'vector) (list 'aref 'cl-x pos)
2262                                   (if (= pos 0) '(car cl-x)                                   (if (= pos 0) '(car cl-x)
2263                                     (list 'nth pos 'cl-x)))))) forms)                                     (list 'nth pos 'cl-x)))))) forms)
2264                (cl-push (cons accessor t) side-eff)                (push (cons accessor t) side-eff)
2265                (cl-push (list 'define-setf-method accessor '(cl-x)                (push (list 'define-setf-method accessor '(cl-x)
2266                               (if (cadr (memq :read-only (cddr desc)))                               (if (cadr (memq :read-only (cddr desc)))
2267                                   (list 'error (format "%s is a read-only slot"                                   (list 'error (format "%s is a read-only slot"
2268                                                        accessor))                                                        accessor))
# Line 2151  copier, a `NAME-p' predicate, and setf-a Line 2279  copier, a `NAME-p' predicate, and setf-a
2279      (setq slots (nreverse slots)      (setq slots (nreverse slots)
2280            defaults (nreverse defaults))            defaults (nreverse defaults))
2281      (and predicate pred-form      (and predicate pred-form
2282           (progn (cl-push (list 'defsubst* predicate '(cl-x)           (progn (push (list 'defsubst* predicate '(cl-x)
2283                                 (if (eq (car pred-form) 'and)                                 (if (eq (car pred-form) 'and)
2284                                     (append pred-form '(t))                                     (append pred-form '(t))
2285                                   (list 'and pred-form t))) forms)                                   (list 'and pred-form t))) forms)
2286                  (cl-push (cons predicate 'error-free) side-eff)))                  (push (cons predicate 'error-free) side-eff)))
2287      (and copier      (and copier
2288           (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms)           (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms)
2289                  (cl-push (cons copier t) side-eff)))                  (push (cons copier t) side-eff)))
2290      (if constructor      (if constructor
2291          (cl-push (list constructor          (push (list constructor
2292                         (cons '&key (delq nil (copy-sequence slots))))                         (cons '&key (delq nil (copy-sequence slots))))
2293                   constrs))                   constrs))
2294      (while constrs      (while constrs
2295        (let* ((name (caar constrs))        (let* ((name (caar constrs))
2296               (args (cadr (cl-pop constrs)))               (args (cadr (pop constrs)))
2297               (anames (cl-arglist-args args))               (anames (cl-arglist-args args))
2298               (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))               (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))
2299                              slots defaults)))                              slots defaults)))
2300          (cl-push (list 'defsubst* name          (push (list 'defsubst* name
2301                         (list* '&cl-defs (list 'quote (cons nil descs)) args)                         (list* '&cl-defs (list 'quote (cons nil descs)) args)
2302                         (cons type make)) forms)                         (cons type make)) forms)
2303          (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))          (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2304              (cl-push (cons name t) side-eff))))              (push (cons name t) side-eff))))
2305      (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))      (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2306      (if print-func      (if print-func
2307          (cl-push (list 'push          (push (list 'push
2308                         (list 'function                         (list 'function
2309                               (list 'lambda '(cl-x cl-s cl-n)                               (list 'lambda '(cl-x cl-s cl-n)
2310                                     (list 'and pred-form print-func)))                                     (list 'and pred-form print-func)))
2311                         'custom-print-functions) forms))                         'custom-print-functions) forms))
2312      (cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)      (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
2313      (cl-push (list* 'eval-when '(compile load eval)      (push (list* 'eval-when '(compile load eval)
2314                      (list 'put (list 'quote name) '(quote cl-struct-slots)                      (list 'put (list 'quote name) '(quote cl-struct-slots)
2315                            (list 'quote descs))                            (list 'quote descs))
2316                      (list 'put (list 'quote name) '(quote cl-struct-type)                      (list 'put (list 'quote name) '(quote cl-struct-type)
# Line 2312  Otherwise, return result of last FORM." Line 2440  Otherwise, return result of last FORM."
2440    `(condition-case nil (progn ,@body) (error nil)))    `(condition-case nil (progn ,@body) (error nil)))
2441    
2442    
 ;;; Some predicates for analyzing Lisp forms.  These are used by various  
 ;;; macro expanders to optimize the results in certain common cases.  
   
 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max  
                             car-safe cdr-safe progn prog1 prog2))  
 (defconst cl-safe-funcs '(* / % length memq list vector vectorp  
                           < > <= >= = error))  
   
 ;;; Check if no side effects, and executes quickly.  
 (defun cl-simple-expr-p (x &optional size)  
   (or size (setq size 10))  
   (if (and (consp x) (not (memq (car x) '(quote function function*))))  
       (and (symbolp (car x))  
            (or (memq (car x) cl-simple-funcs)  
                (get (car x) 'side-effect-free))  
            (progn  
              (setq size (1- size))  
              (while (and (setq x (cdr x))  
                          (setq size (cl-simple-expr-p (car x) size))))  
              (and (null x) (>= size 0) size)))  
     (and (> size 0) (1- size))))  
   
 (defun cl-simple-exprs-p (xs)  
   (while (and xs (cl-simple-expr-p (car xs)))  
     (setq xs (cdr xs)))  
   (not xs))  
   
 ;;; Check if no side effects.  
 (defun cl-safe-expr-p (x)  
   (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))  
       (and (symbolp (car x))  
            (or (memq (car x) cl-simple-funcs)  
                (memq (car x) cl-safe-funcs)  
                (get (car x) 'side-effect-free))  
            (progn  
              (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))  
              (null x)))))  
   
 ;;; Check if constant (i.e., no side effects or dependencies).  
 (defun cl-const-expr-p (x)  
   (cond ((consp x)  
          (or (eq (car x) 'quote)  
              (and (memq (car x) '(function function*))  
                   (or (symbolp (nth 1 x))  
                       (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))  
         ((symbolp x) (and (memq x '(nil t)) t))  
         (t t)))  
   
 (defun cl-const-exprs-p (xs)  
   (while (and xs (cl-const-expr-p (car xs)))  
     (setq xs (cdr xs)))  
   (not xs))  
   
 (defun cl-const-expr-val (x)  
   (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))  
   
 (defun cl-expr-access-order (x v)  
   (if (cl-const-expr-p x) v  
     (if (consp x)  
         (progn  
           (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))  
           v)  
       (if (eq x (car v)) (cdr v) '(t)))))  
   
 ;;; Count number of times X refers to Y.  Return nil for 0 times.  
 (defun cl-expr-contains (x y)  
   (cond ((equal y x) 1)  
         ((and (consp x) (not (memq (car-safe x) '(quote function function*))))  
          (let ((sum 0))  
            (while x  
              (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0))))  
            (and (> sum 0) sum)))  
         (t nil)))  
   
 (defun cl-expr-contains-any (x y)  
   (while (and y (not (cl-expr-contains x (car y)))) (cl-pop y))  
   y)  
   
 ;;; Check whether X may depend on any of the symbols in Y.  
 (defun cl-expr-depends-p (x y)  
   (and (not (cl-const-expr-p x))  
        (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))  
   
   
2443  ;;; Compiler macros.  ;;; Compiler macros.
2444    
2445  (defmacro define-compiler-macro (func args &rest body)  (defmacro define-compiler-macro (func args &rest body)
# Line 2410  possible.  Unlike regular macros, BODY c Line 2454  possible.  Unlike regular macros, BODY c
2454  original function call alone by declaring an initial `&whole foo' parameter  original function call alone by declaring an initial `&whole foo' parameter
2455  and then returning foo."  and then returning foo."
2456    (let ((p args) (res nil))    (let ((p args) (res nil))
2457      (while (consp p) (cl-push (cl-pop p) res))      (while (consp p) (push (pop p) res))
2458      (setq args (nconc (nreverse res) (and p (list '&rest p)))))      (setq args (nconc (nreverse res) (and p (list '&rest p)))))
2459    (list 'eval-when '(compile load eval)    (list 'eval-when '(compile load eval)
2460          (cl-transform-function-property          (cl-transform-function-property
# Line 2440  and then returning foo." Line 2484  and then returning foo."
2484      (byte-compile-form form)))      (byte-compile-form form)))
2485    
2486  (defmacro defsubst* (name args &rest body)  (defmacro defsubst* (name args &rest body)
2487    "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.    "Define NAME as a function.
2488  Like `defun', except the function is automatically declared `inline',  Like `defun', except the function is automatically declared `inline',
2489  ARGLIST allows full Common Lisp conventions, and BODY is implicitly  ARGLIST allows full Common Lisp conventions, and BODY is implicitly
2490  surrounded by (block NAME ...)."  surrounded by (block NAME ...).
2491    
2492    \(fn NAME ARGLIST [DOCSTRING] BODY...)"
2493    (let* ((argns (cl-arglist-args args)) (p argns)    (let* ((argns (cl-arglist-args args)) (p argns)
2494           (pbody (cons 'progn body))           (pbody (cons 'progn body))
2495           (unsafe (not (cl-safe-expr-p pbody))))           (unsafe (not (cl-safe-expr-p pbody))))
2496      (while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p))      (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
2497      (list 'progn      (list 'progn
2498            (if p nil   ; give up if defaults refer to earlier args            (if p nil   ; give up if defaults refer to earlier args
2499              (list 'define-compiler-macro name              (list 'define-compiler-macro name
# Line 2600  surrounded by (block NAME ...)." Line 2646  surrounded by (block NAME ...)."
2646    
2647  (run-hooks 'cl-macs-load-hook)  (run-hooks 'cl-macs-load-hook)
2648    
2649    ;;; Local variables:
2650    ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
2651    ;;; End:
2652    
2653  ;;; cl-macs.el ends here  ;;; cl-macs.el ends here

Legend:
Removed from v.1.34  
changed lines
  Added in v.1.34.4.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26