Fix pos-visible-in-window-p under bidi redisplay.
[bpt/emacs.git] / lisp / emacs-lisp / cl-macs.el
1 ;;; cl-macs.el --- Common Lisp macros
2
3 ;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
4
5 ;; Author: Dave Gillespie <daveg@synaptics.com>
6 ;; Version: 2.02
7 ;; Keywords: extensions
8 ;; Package: emacs
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
27 ;; These are extensions to Emacs Lisp that provide a degree of
28 ;; Common Lisp compatibility, beyond what is already built-in
29 ;; in Emacs Lisp.
30 ;;
31 ;; This package was written by Dave Gillespie; it is a complete
32 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
33 ;;
34 ;; Bug reports, comments, and suggestions are welcome!
35
36 ;; This file contains the portions of the Common Lisp extensions
37 ;; package which should be autoloaded, but need only be present
38 ;; if the compiler or interpreter is used---this file is not
39 ;; necessary for executing compiled code.
40
41 ;; See cl.el for Change Log.
42
43
44 ;;; Code:
45
46 (require 'cl)
47
48 (defmacro cl-pop2 (place)
49 (list 'prog1 (list 'car (list 'cdr place))
50 (list 'setq place (list 'cdr (list 'cdr place)))))
51 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
52
53 (defvar cl-optimize-safety)
54 (defvar cl-optimize-speed)
55
56
57 ;; This kludge allows macros which use cl-transform-function-property
58 ;; to be called at compile-time.
59
60 (require
61 (progn
62 (or (fboundp 'cl-transform-function-property)
63 (defalias 'cl-transform-function-property
64 (function (lambda (n p f)
65 (list 'put (list 'quote n) (list 'quote p)
66 (list 'function (cons 'lambda f)))))))
67 (car (or features (setq features (list 'cl-kludge))))))
68
69
70 ;;; Initialization.
71
72 (defvar cl-old-bc-file-form nil)
73
74 ;;; Some predicates for analyzing Lisp forms. These are used by various
75 ;;; macro expanders to optimize the results in certain common cases.
76
77 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
78 car-safe cdr-safe progn prog1 prog2))
79 (defconst cl-safe-funcs '(* / % length memq list vector vectorp
80 < > <= >= = error))
81
82 ;;; Check if no side effects, and executes quickly.
83 (defun cl-simple-expr-p (x &optional size)
84 (or size (setq size 10))
85 (if (and (consp x) (not (memq (car x) '(quote function function*))))
86 (and (symbolp (car x))
87 (or (memq (car x) cl-simple-funcs)
88 (get (car x) 'side-effect-free))
89 (progn
90 (setq size (1- size))
91 (while (and (setq x (cdr x))
92 (setq size (cl-simple-expr-p (car x) size))))
93 (and (null x) (>= size 0) size)))
94 (and (> size 0) (1- size))))
95
96 (defun cl-simple-exprs-p (xs)
97 (while (and xs (cl-simple-expr-p (car xs)))
98 (setq xs (cdr xs)))
99 (not xs))
100
101 ;;; Check if no side effects.
102 (defun cl-safe-expr-p (x)
103 (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
104 (and (symbolp (car x))
105 (or (memq (car x) cl-simple-funcs)
106 (memq (car x) cl-safe-funcs)
107 (get (car x) 'side-effect-free))
108 (progn
109 (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
110 (null x)))))
111
112 ;;; Check if constant (i.e., no side effects or dependencies).
113 (defun cl-const-expr-p (x)
114 (cond ((consp x)
115 (or (eq (car x) 'quote)
116 (and (memq (car x) '(function function*))
117 (or (symbolp (nth 1 x))
118 (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
119 ((symbolp x) (and (memq x '(nil t)) t))
120 (t t)))
121
122 (defun cl-const-exprs-p (xs)
123 (while (and xs (cl-const-expr-p (car xs)))
124 (setq xs (cdr xs)))
125 (not xs))
126
127 (defun cl-const-expr-val (x)
128 (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
129
130 (defun cl-expr-access-order (x v)
131 ;; This apparently tries to return nil iff the expression X evaluates
132 ;; the variables V in the same order as they appear in V (so as to
133 ;; be able to replace those vars with the expressions they're bound
134 ;; to).
135 ;; FIXME: This is very naive, it doesn't even check to see if those
136 ;; variables appear more than once.
137 (if (cl-const-expr-p x) v
138 (if (consp x)
139 (progn
140 (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
141 v)
142 (if (eq x (car v)) (cdr v) '(t)))))
143
144 ;;; Count number of times X refers to Y. Return nil for 0 times.
145 (defun cl-expr-contains (x y)
146 (cond ((equal y x) 1)
147 ((and (consp x) (not (memq (car-safe x) '(quote function function*))))
148 (let ((sum 0))
149 (while x
150 (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
151 (and (> sum 0) sum)))
152 (t nil)))
153
154 (defun cl-expr-contains-any (x y)
155 (while (and y (not (cl-expr-contains x (car y)))) (pop y))
156 y)
157
158 ;;; Check whether X may depend on any of the symbols in Y.
159 (defun cl-expr-depends-p (x y)
160 (and (not (cl-const-expr-p x))
161 (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
162
163 ;;; Symbols.
164
165 (defvar *gensym-counter*)
166 ;;;###autoload
167 (defun gensym (&optional prefix)
168 "Generate a new uninterned symbol.
169 The name is made by appending a number to PREFIX, default \"G\"."
170 (let ((pfix (if (stringp prefix) prefix "G"))
171 (num (if (integerp prefix) prefix
172 (prog1 *gensym-counter*
173 (setq *gensym-counter* (1+ *gensym-counter*))))))
174 (make-symbol (format "%s%d" pfix num))))
175
176 ;;;###autoload
177 (defun gentemp (&optional prefix)
178 "Generate a new interned symbol with a unique name.
179 The name is made by appending a number to PREFIX, default \"G\"."
180 (let ((pfix (if (stringp prefix) prefix "G"))
181 name)
182 (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
183 (setq *gensym-counter* (1+ *gensym-counter*)))
184 (intern name)))
185
186
187 ;;; Program structure.
188
189 ;;;###autoload
190 (defmacro defun* (name args &rest body)
191 "Define NAME as a function.
192 Like normal `defun', except ARGLIST allows full Common Lisp conventions,
193 and BODY is implicitly surrounded by (block NAME ...).
194
195 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
196 (let* ((res (cl-transform-lambda (cons args body) name))
197 (form (list* 'defun name (cdr res))))
198 (if (car res) (list 'progn (car res) form) form)))
199
200 ;;;###autoload
201 (defmacro defmacro* (name args &rest body)
202 "Define NAME as a macro.
203 Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
204 and BODY is implicitly surrounded by (block NAME ...).
205
206 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
207 (let* ((res (cl-transform-lambda (cons args body) name))
208 (form (list* 'defmacro name (cdr res))))
209 (if (car res) (list 'progn (car res) form) form)))
210
211 ;;;###autoload
212 (defmacro function* (func)
213 "Introduce a function.
214 Like normal `function', except that if argument is a lambda form,
215 its argument list allows full Common Lisp conventions."
216 (if (eq (car-safe func) 'lambda)
217 (let* ((res (cl-transform-lambda (cdr func) 'cl-none))
218 (form (list 'function (cons 'lambda (cdr res)))))
219 (if (car res) (list 'progn (car res) form) form))
220 (list 'function func)))
221
222 (defun cl-transform-function-property (func prop form)
223 (let ((res (cl-transform-lambda form func)))
224 (append '(progn) (cdr (cdr (car res)))
225 (list (list 'put (list 'quote func) (list 'quote prop)
226 (list 'function (cons 'lambda (cdr res))))))))
227
228 (defconst lambda-list-keywords
229 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
230
231 (defvar cl-macro-environment nil
232 "Keep the list of currently active macros.
233 It is a list of elements of the form either:
234 - (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function.
235 - (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.")
236 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
237 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
238
239 (declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
240
241 (defun cl-transform-lambda (form bind-block)
242 (let* ((args (car form)) (body (cdr form)) (orig-args args)
243 (bind-defs nil) (bind-enquote nil)
244 (bind-inits nil) (bind-lets nil) (bind-forms nil)
245 (header nil) (simple-args nil))
246 (while (or (stringp (car body))
247 (memq (car-safe (car body)) '(interactive declare)))
248 (push (pop body) header))
249 (setq args (if (listp args) (copy-list args) (list '&rest args)))
250 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
251 (if (setq bind-defs (cadr (memq '&cl-defs args)))
252 (setq args (delq '&cl-defs (delq bind-defs args))
253 bind-defs (cadr bind-defs)))
254 (if (setq bind-enquote (memq '&cl-quote args))
255 (setq args (delq '&cl-quote args)))
256 (if (memq '&whole args) (error "&whole not currently implemented"))
257 (let* ((p (memq '&environment args)) (v (cadr p)))
258 (if p (setq args (nconc (delq (car p) (delq v args))
259 (list '&aux (list v 'cl-macro-environment))))))
260 (while (and args (symbolp (car args))
261 (not (memq (car args) '(nil &rest &body &key &aux)))
262 (not (and (eq (car args) '&optional)
263 (or bind-defs (consp (cadr args))))))
264 (push (pop args) simple-args))
265 (or (eq bind-block 'cl-none)
266 (setq body (list (list* 'block bind-block body))))
267 (if (null args)
268 (list* nil (nreverse simple-args) (nconc (nreverse header) body))
269 (if (memq '&optional simple-args) (push '&optional args))
270 (cl-do-arglist args nil (- (length simple-args)
271 (if (memq '&optional simple-args) 1 0)))
272 (setq bind-lets (nreverse bind-lets))
273 (list* (and bind-inits (list* 'eval-when '(compile load eval)
274 (nreverse bind-inits)))
275 (nconc (nreverse simple-args)
276 (list '&rest (car (pop bind-lets))))
277 (nconc (let ((hdr (nreverse header)))
278 ;; Macro expansion can take place in the middle of
279 ;; apparently harmless computation, so it should not
280 ;; touch the match-data.
281 (save-match-data
282 (require 'help-fns)
283 (cons (help-add-fundoc-usage
284 (if (stringp (car hdr)) (pop hdr))
285 ;; orig-args can contain &cl-defs (an internal
286 ;; CL thingy I don't understand), so remove it.
287 (let ((x (memq '&cl-defs orig-args)))
288 (if (null x) orig-args
289 (delq (car x) (remq (cadr x) orig-args)))))
290 hdr)))
291 (list (nconc (list 'let* bind-lets)
292 (nreverse bind-forms) body)))))))
293
294 (defun cl-do-arglist (args expr &optional num) ; uses bind-*
295 (if (nlistp args)
296 (if (or (memq args lambda-list-keywords) (not (symbolp args)))
297 (error "Invalid argument name: %s" args)
298 (push (list args expr) bind-lets))
299 (setq args (copy-list args))
300 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
301 (let ((p (memq '&body args))) (if p (setcar p '&rest)))
302 (if (memq '&environment args) (error "&environment used incorrectly"))
303 (let ((save-args args)
304 (restarg (memq '&rest args))
305 (safety (if (cl-compiling-file) cl-optimize-safety 3))
306 (keys nil)
307 (laterarg nil) (exactarg nil) minarg)
308 (or num (setq num 0))
309 (if (listp (cadr restarg))
310 (setq restarg (make-symbol "--cl-rest--"))
311 (setq restarg (cadr restarg)))
312 (push (list restarg expr) bind-lets)
313 (if (eq (car args) '&whole)
314 (push (list (cl-pop2 args) restarg) bind-lets))
315 (let ((p args))
316 (setq minarg restarg)
317 (while (and p (not (memq (car p) lambda-list-keywords)))
318 (or (eq p args) (setq minarg (list 'cdr minarg)))
319 (setq p (cdr p)))
320 (if (memq (car p) '(nil &aux))
321 (setq minarg (list '= (list 'length restarg)
322 (length (ldiff args p)))
323 exactarg (not (eq args p)))))
324 (while (and args (not (memq (car args) lambda-list-keywords)))
325 (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
326 restarg)))
327 (cl-do-arglist
328 (pop args)
329 (if (or laterarg (= safety 0)) poparg
330 (list 'if minarg poparg
331 (list 'signal '(quote wrong-number-of-arguments)
332 (list 'list (and (not (eq bind-block 'cl-none))
333 (list 'quote bind-block))
334 (list 'length restarg)))))))
335 (setq num (1+ num) laterarg t))
336 (while (and (eq (car args) '&optional) (pop args))
337 (while (and args (not (memq (car args) lambda-list-keywords)))
338 (let ((arg (pop args)))
339 (or (consp arg) (setq arg (list arg)))
340 (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
341 (let ((def (if (cdr arg) (nth 1 arg)
342 (or (car bind-defs)
343 (nth 1 (assq (car arg) bind-defs)))))
344 (poparg (list 'pop restarg)))
345 (and def bind-enquote (setq def (list 'quote def)))
346 (cl-do-arglist (car arg)
347 (if def (list 'if restarg poparg def) poparg))
348 (setq num (1+ num))))))
349 (if (eq (car args) '&rest)
350 (let ((arg (cl-pop2 args)))
351 (if (consp arg) (cl-do-arglist arg restarg)))
352 (or (eq (car args) '&key) (= safety 0) exactarg
353 (push (list 'if restarg
354 (list 'signal '(quote wrong-number-of-arguments)
355 (list 'list
356 (and (not (eq bind-block 'cl-none))
357 (list 'quote bind-block))
358 (list '+ num (list 'length restarg)))))
359 bind-forms)))
360 (while (and (eq (car args) '&key) (pop args))
361 (while (and args (not (memq (car args) lambda-list-keywords)))
362 (let ((arg (pop args)))
363 (or (consp arg) (setq arg (list arg)))
364 (let* ((karg (if (consp (car arg)) (caar arg)
365 (intern (format ":%s" (car arg)))))
366 (varg (if (consp (car arg)) (cadar arg) (car arg)))
367 (def (if (cdr arg) (cadr arg)
368 (or (car bind-defs) (cadr (assq varg bind-defs)))))
369 (look (list 'memq (list 'quote karg) restarg)))
370 (and def bind-enquote (setq def (list 'quote def)))
371 (if (cddr arg)
372 (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
373 (val (list 'car (list 'cdr temp))))
374 (cl-do-arglist temp look)
375 (cl-do-arglist varg
376 (list 'if temp
377 (list 'prog1 val (list 'setq temp t))
378 def)))
379 (cl-do-arglist
380 varg
381 (list 'car
382 (list 'cdr
383 (if (null def)
384 look
385 (list 'or look
386 (if (eq (cl-const-expr-p def) t)
387 (list
388 'quote
389 (list nil (cl-const-expr-val def)))
390 (list 'list nil def))))))))
391 (push karg keys)))))
392 (setq keys (nreverse keys))
393 (or (and (eq (car args) '&allow-other-keys) (pop args))
394 (null keys) (= safety 0)
395 (let* ((var (make-symbol "--cl-keys--"))
396 (allow '(:allow-other-keys))
397 (check (list
398 'while var
399 (list
400 'cond
401 (list (list 'memq (list 'car var)
402 (list 'quote (append keys allow)))
403 (list 'setq var (list 'cdr (list 'cdr var))))
404 (list (list 'car
405 (list 'cdr
406 (list 'memq (cons 'quote allow)
407 restarg)))
408 (list 'setq var nil))
409 (list t
410 (list
411 'error
412 (format "Keyword argument %%s not one of %s"
413 keys)
414 (list 'car var)))))))
415 (push (list 'let (list (list var restarg)) check) bind-forms)))
416 (while (and (eq (car args) '&aux) (pop args))
417 (while (and args (not (memq (car args) lambda-list-keywords)))
418 (if (consp (car args))
419 (if (and bind-enquote (cadar args))
420 (cl-do-arglist (caar args)
421 (list 'quote (cadr (pop args))))
422 (cl-do-arglist (caar args) (cadr (pop args))))
423 (cl-do-arglist (pop args) nil))))
424 (if args (error "Malformed argument list %s" save-args)))))
425
426 (defun cl-arglist-args (args)
427 (if (nlistp args) (list args)
428 (let ((res nil) (kind nil) arg)
429 (while (consp args)
430 (setq arg (pop args))
431 (if (memq arg lambda-list-keywords) (setq kind arg)
432 (if (eq arg '&cl-defs) (pop args)
433 (and (consp arg) kind (setq arg (car arg)))
434 (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
435 (setq res (nconc res (cl-arglist-args arg))))))
436 (nconc res (and args (list args))))))
437
438 ;;;###autoload
439 (defmacro destructuring-bind (args expr &rest body)
440 (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
441 (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil))
442 (cl-do-arglist (or args '(&aux)) expr)
443 (append '(progn) bind-inits
444 (list (nconc (list 'let* (nreverse bind-lets))
445 (nreverse bind-forms) body)))))
446
447
448 ;;; The `eval-when' form.
449
450 (defvar cl-not-toplevel nil)
451
452 ;;;###autoload
453 (defmacro eval-when (when &rest body)
454 "Control when BODY is evaluated.
455 If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
456 If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
457 If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
458
459 \(fn (WHEN...) BODY...)"
460 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
461 (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
462 (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
463 (cl-not-toplevel t))
464 (if (or (memq 'load when) (memq :load-toplevel when))
465 (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
466 (list* 'if nil nil body))
467 (progn (if comp (eval (cons 'progn body))) nil)))
468 (and (or (memq 'eval when) (memq :execute when))
469 (cons 'progn body))))
470
471 (defun cl-compile-time-too (form)
472 (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
473 (setq form (macroexpand
474 form (cons '(eval-when) byte-compile-macro-environment))))
475 (cond ((eq (car-safe form) 'progn)
476 (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
477 ((eq (car-safe form) 'eval-when)
478 (let ((when (nth 1 form)))
479 (if (or (memq 'eval when) (memq :execute when))
480 (list* 'eval-when (cons 'compile when) (cddr form))
481 form)))
482 (t (eval form) form)))
483
484 ;;;###autoload
485 (defmacro load-time-value (form &optional read-only)
486 "Like `progn', but evaluates the body at load time.
487 The result of the body appears to the compiler as a quoted constant."
488 (if (cl-compiling-file)
489 (let* ((temp (gentemp "--cl-load-time--"))
490 (set (list 'set (list 'quote temp) form)))
491 (if (and (fboundp 'byte-compile-file-form-defmumble)
492 (boundp 'this-kind) (boundp 'that-one))
493 (fset 'byte-compile-file-form
494 (list 'lambda '(form)
495 (list 'fset '(quote byte-compile-file-form)
496 (list 'quote
497 (symbol-function 'byte-compile-file-form)))
498 (list 'byte-compile-file-form (list 'quote set))
499 '(byte-compile-file-form form)))
500 (print set (symbol-value 'byte-compile--outbuffer)))
501 (list 'symbol-value (list 'quote temp)))
502 (list 'quote (eval form))))
503
504
505 ;;; Conditional control structures.
506
507 ;;;###autoload
508 (defmacro case (expr &rest clauses)
509 "Eval EXPR and choose among clauses on that value.
510 Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared
511 against each key in each KEYLIST; the corresponding BODY is evaluated.
512 If no clause succeeds, case returns nil. A single atom may be used in
513 place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is
514 allowed only in the final clause, and matches if no other keys match.
515 Key values are compared by `eql'.
516 \n(fn EXPR (KEYLIST BODY...)...)"
517 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
518 (head-list nil)
519 (body (cons
520 'cond
521 (mapcar
522 (function
523 (lambda (c)
524 (cons (cond ((memq (car c) '(t otherwise)) t)
525 ((eq (car c) 'ecase-error-flag)
526 (list 'error "ecase failed: %s, %s"
527 temp (list 'quote (reverse head-list))))
528 ((listp (car c))
529 (setq head-list (append (car c) head-list))
530 (list 'member* temp (list 'quote (car c))))
531 (t
532 (if (memq (car c) head-list)
533 (error "Duplicate key in case: %s"
534 (car c)))
535 (push (car c) head-list)
536 (list 'eql temp (list 'quote (car c)))))
537 (or (cdr c) '(nil)))))
538 clauses))))
539 (if (eq temp expr) body
540 (list 'let (list (list temp expr)) body))))
541
542 ;;;###autoload
543 (defmacro ecase (expr &rest clauses)
544 "Like `case', but error if no case fits.
545 `otherwise'-clauses are not allowed.
546 \n(fn EXPR (KEYLIST BODY...)...)"
547 (list* 'case expr (append clauses '((ecase-error-flag)))))
548
549 ;;;###autoload
550 (defmacro typecase (expr &rest clauses)
551 "Evals EXPR, chooses among clauses on that value.
552 Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
553 satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds,
554 typecase returns nil. A TYPE of t or `otherwise' is allowed only in the
555 final clause, and matches if no other keys match.
556 \n(fn EXPR (TYPE BODY...)...)"
557 (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
558 (type-list nil)
559 (body (cons
560 'cond
561 (mapcar
562 (function
563 (lambda (c)
564 (cons (cond ((eq (car c) 'otherwise) t)
565 ((eq (car c) 'ecase-error-flag)
566 (list 'error "etypecase failed: %s, %s"
567 temp (list 'quote (reverse type-list))))
568 (t
569 (push (car c) type-list)
570 (cl-make-type-test temp (car c))))
571 (or (cdr c) '(nil)))))
572 clauses))))
573 (if (eq temp expr) body
574 (list 'let (list (list temp expr)) body))))
575
576 ;;;###autoload
577 (defmacro etypecase (expr &rest clauses)
578 "Like `typecase', but error if no case fits.
579 `otherwise'-clauses are not allowed.
580 \n(fn EXPR (TYPE BODY...)...)"
581 (list* 'typecase expr (append clauses '((ecase-error-flag)))))
582
583
584 ;;; Blocks and exits.
585
586 ;;;###autoload
587 (defmacro block (name &rest body)
588 "Define a lexically-scoped block named NAME.
589 NAME may be any symbol. Code inside the BODY forms can call `return-from'
590 to jump prematurely out of the block. This differs from `catch' and `throw'
591 in two respects: First, the NAME is an unevaluated symbol rather than a
592 quoted symbol or other form; and second, NAME is lexically rather than
593 dynamically scoped: Only references to it within BODY will work. These
594 references may appear inside macro expansions, but not inside functions
595 called from BODY."
596 (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
597 (list 'cl-block-wrapper
598 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
599 body))))
600
601 ;;;###autoload
602 (defmacro return (&optional result)
603 "Return from the block named nil.
604 This is equivalent to `(return-from nil RESULT)'."
605 (list 'return-from nil result))
606
607 ;;;###autoload
608 (defmacro return-from (name &optional result)
609 "Return from the block named NAME.
610 This jumps out to the innermost enclosing `(block NAME ...)' form,
611 returning RESULT from that form (or nil if RESULT is omitted).
612 This is compatible with Common Lisp, but note that `defun' and
613 `defmacro' do not create implicit blocks as they do in Common Lisp."
614 (let ((name2 (intern (format "--cl-block-%s--" name))))
615 (list 'cl-block-throw (list 'quote name2) result)))
616
617
618 ;;; The "loop" macro.
619
620 (defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
621 (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
622 (defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
623 (defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
624 (defvar loop-result) (defvar loop-result-explicit)
625 (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
626
627 ;;;###autoload
628 (defmacro loop (&rest loop-args)
629 "The Common Lisp `loop' macro.
630 Valid clauses are:
631 for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
632 for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
633 for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
634 always COND, never COND, thereis COND, collect EXPR into VAR,
635 append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
636 count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
637 if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
638 unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
639 do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
640 finally return EXPR, named NAME.
641
642 \(fn CLAUSE...)"
643 (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
644 (list 'block nil (list* 'while t loop-args))
645 (let ((loop-name nil) (loop-bindings nil)
646 (loop-body nil) (loop-steps nil)
647 (loop-result nil) (loop-result-explicit nil)
648 (loop-result-var nil) (loop-finish-flag nil)
649 (loop-accum-var nil) (loop-accum-vars nil)
650 (loop-initially nil) (loop-finally nil)
651 (loop-map-form nil) (loop-first-flag nil)
652 (loop-destr-temps nil) (loop-symbol-macs nil))
653 (setq loop-args (append loop-args '(cl-end-loop)))
654 (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
655 (if loop-finish-flag
656 (push `((,loop-finish-flag t)) loop-bindings))
657 (if loop-first-flag
658 (progn (push `((,loop-first-flag t)) loop-bindings)
659 (push `(setq ,loop-first-flag nil) loop-steps)))
660 (let* ((epilogue (nconc (nreverse loop-finally)
661 (list (or loop-result-explicit loop-result))))
662 (ands (cl-loop-build-ands (nreverse loop-body)))
663 (while-body (nconc (cadr ands) (nreverse loop-steps)))
664 (body (append
665 (nreverse loop-initially)
666 (list (if loop-map-form
667 (list 'block '--cl-finish--
668 (subst
669 (if (eq (car ands) t) while-body
670 (cons `(or ,(car ands)
671 (return-from --cl-finish--
672 nil))
673 while-body))
674 '--cl-map loop-map-form))
675 (list* 'while (car ands) while-body)))
676 (if loop-finish-flag
677 (if (equal epilogue '(nil)) (list loop-result-var)
678 `((if ,loop-finish-flag
679 (progn ,@epilogue) ,loop-result-var)))
680 epilogue))))
681 (if loop-result-var (push (list loop-result-var) loop-bindings))
682 (while loop-bindings
683 (if (cdar loop-bindings)
684 (setq body (list (cl-loop-let (pop loop-bindings) body t)))
685 (let ((lets nil))
686 (while (and loop-bindings
687 (not (cdar loop-bindings)))
688 (push (car (pop loop-bindings)) lets))
689 (setq body (list (cl-loop-let lets body nil))))))
690 (if loop-symbol-macs
691 (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
692 (list* 'block loop-name body)))))
693
694 (defun cl-parse-loop-clause () ; uses loop-*
695 (let ((word (pop loop-args))
696 (hash-types '(hash-key hash-keys hash-value hash-values))
697 (key-types '(key-code key-codes key-seq key-seqs
698 key-binding key-bindings)))
699 (cond
700
701 ((null loop-args)
702 (error "Malformed `loop' macro"))
703
704 ((eq word 'named)
705 (setq loop-name (pop loop-args)))
706
707 ((eq word 'initially)
708 (if (memq (car loop-args) '(do doing)) (pop loop-args))
709 (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
710 (while (consp (car loop-args))
711 (push (pop loop-args) loop-initially)))
712
713 ((eq word 'finally)
714 (if (eq (car loop-args) 'return)
715 (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
716 (if (memq (car loop-args) '(do doing)) (pop loop-args))
717 (or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
718 (if (and (eq (caar loop-args) 'return) (null loop-name))
719 (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
720 (while (consp (car loop-args))
721 (push (pop loop-args) loop-finally)))))
722
723 ((memq word '(for as))
724 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
725 (ands nil))
726 (while
727 ;; Use `gensym' rather than `make-symbol'. It's important that
728 ;; (not (eq (symbol-name var1) (symbol-name var2))) because
729 ;; these vars get added to the cl-macro-environment.
730 (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
731 (setq word (pop loop-args))
732 (if (eq word 'being) (setq word (pop loop-args)))
733 (if (memq word '(the each)) (setq word (pop loop-args)))
734 (if (memq word '(buffer buffers))
735 (setq word 'in loop-args (cons '(buffer-list) loop-args)))
736 (cond
737
738 ((memq word '(from downfrom upfrom to downto upto
739 above below by))
740 (push word loop-args)
741 (if (memq (car loop-args) '(downto above))
742 (error "Must specify `from' value for downward loop"))
743 (let* ((down (or (eq (car loop-args) 'downfrom)
744 (memq (caddr loop-args) '(downto above))))
745 (excl (or (memq (car loop-args) '(above below))
746 (memq (caddr loop-args) '(above below))))
747 (start (and (memq (car loop-args) '(from upfrom downfrom))
748 (cl-pop2 loop-args)))
749 (end (and (memq (car loop-args)
750 '(to upto downto above below))
751 (cl-pop2 loop-args)))
752 (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
753 (end-var (and (not (cl-const-expr-p end))
754 (make-symbol "--cl-var--")))
755 (step-var (and (not (cl-const-expr-p step))
756 (make-symbol "--cl-var--"))))
757 (and step (numberp step) (<= step 0)
758 (error "Loop `by' value is not positive: %s" step))
759 (push (list var (or start 0)) loop-for-bindings)
760 (if end-var (push (list end-var end) loop-for-bindings))
761 (if step-var (push (list step-var step)
762 loop-for-bindings))
763 (if end
764 (push (list
765 (if down (if excl '> '>=) (if excl '< '<=))
766 var (or end-var end)) loop-body))
767 (push (list var (list (if down '- '+) var
768 (or step-var step 1)))
769 loop-for-steps)))
770
771 ((memq word '(in in-ref on))
772 (let* ((on (eq word 'on))
773 (temp (if (and on (symbolp var))
774 var (make-symbol "--cl-var--"))))
775 (push (list temp (pop loop-args)) loop-for-bindings)
776 (push (list 'consp temp) loop-body)
777 (if (eq word 'in-ref)
778 (push (list var (list 'car temp)) loop-symbol-macs)
779 (or (eq temp var)
780 (progn
781 (push (list var nil) loop-for-bindings)
782 (push (list var (if on temp (list 'car temp)))
783 loop-for-sets))))
784 (push (list temp
785 (if (eq (car loop-args) 'by)
786 (let ((step (cl-pop2 loop-args)))
787 (if (and (memq (car-safe step)
788 '(quote function
789 function*))
790 (symbolp (nth 1 step)))
791 (list (nth 1 step) temp)
792 (list 'funcall step temp)))
793 (list 'cdr temp)))
794 loop-for-steps)))
795
796 ((eq word '=)
797 (let* ((start (pop loop-args))
798 (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
799 (push (list var nil) loop-for-bindings)
800 (if (or ands (eq (car loop-args) 'and))
801 (progn
802 (push `(,var
803 (if ,(or loop-first-flag
804 (setq loop-first-flag
805 (make-symbol "--cl-var--")))
806 ,start ,var))
807 loop-for-sets)
808 (push (list var then) loop-for-steps))
809 (push (list var
810 (if (eq start then) start
811 `(if ,(or loop-first-flag
812 (setq loop-first-flag
813 (make-symbol "--cl-var--")))
814 ,start ,then)))
815 loop-for-sets))))
816
817 ((memq word '(across across-ref))
818 (let ((temp-vec (make-symbol "--cl-vec--"))
819 (temp-idx (make-symbol "--cl-idx--")))
820 (push (list temp-vec (pop loop-args)) loop-for-bindings)
821 (push (list temp-idx -1) loop-for-bindings)
822 (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
823 (list 'length temp-vec)) loop-body)
824 (if (eq word 'across-ref)
825 (push (list var (list 'aref temp-vec temp-idx))
826 loop-symbol-macs)
827 (push (list var nil) loop-for-bindings)
828 (push (list var (list 'aref temp-vec temp-idx))
829 loop-for-sets))))
830
831 ((memq word '(element elements))
832 (let ((ref (or (memq (car loop-args) '(in-ref of-ref))
833 (and (not (memq (car loop-args) '(in of)))
834 (error "Expected `of'"))))
835 (seq (cl-pop2 loop-args))
836 (temp-seq (make-symbol "--cl-seq--"))
837 (temp-idx (if (eq (car loop-args) 'using)
838 (if (and (= (length (cadr loop-args)) 2)
839 (eq (caadr loop-args) 'index))
840 (cadr (cl-pop2 loop-args))
841 (error "Bad `using' clause"))
842 (make-symbol "--cl-idx--"))))
843 (push (list temp-seq seq) loop-for-bindings)
844 (push (list temp-idx 0) loop-for-bindings)
845 (if ref
846 (let ((temp-len (make-symbol "--cl-len--")))
847 (push (list temp-len (list 'length temp-seq))
848 loop-for-bindings)
849 (push (list var (list 'elt temp-seq temp-idx))
850 loop-symbol-macs)
851 (push (list '< temp-idx temp-len) loop-body))
852 (push (list var nil) loop-for-bindings)
853 (push (list 'and temp-seq
854 (list 'or (list 'consp temp-seq)
855 (list '< temp-idx
856 (list 'length temp-seq))))
857 loop-body)
858 (push (list var (list 'if (list 'consp temp-seq)
859 (list 'pop temp-seq)
860 (list 'aref temp-seq temp-idx)))
861 loop-for-sets))
862 (push (list temp-idx (list '1+ temp-idx))
863 loop-for-steps)))
864
865 ((memq word hash-types)
866 (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
867 (let* ((table (cl-pop2 loop-args))
868 (other (if (eq (car loop-args) 'using)
869 (if (and (= (length (cadr loop-args)) 2)
870 (memq (caadr loop-args) hash-types)
871 (not (eq (caadr loop-args) word)))
872 (cadr (cl-pop2 loop-args))
873 (error "Bad `using' clause"))
874 (make-symbol "--cl-var--"))))
875 (if (memq word '(hash-value hash-values))
876 (setq var (prog1 other (setq other var))))
877 (setq loop-map-form
878 `(maphash (lambda (,var ,other) . --cl-map) ,table))))
879
880 ((memq word '(symbol present-symbol external-symbol
881 symbols present-symbols external-symbols))
882 (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
883 (setq loop-map-form
884 `(mapatoms (lambda (,var) . --cl-map) ,ob))))
885
886 ((memq word '(overlay overlays extent extents))
887 (let ((buf nil) (from nil) (to nil))
888 (while (memq (car loop-args) '(in of from to))
889 (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
890 ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
891 (t (setq buf (cl-pop2 loop-args)))))
892 (setq loop-map-form
893 `(cl-map-extents
894 (lambda (,var ,(make-symbol "--cl-var--"))
895 (progn . --cl-map) nil)
896 ,buf ,from ,to))))
897
898 ((memq word '(interval intervals))
899 (let ((buf nil) (prop nil) (from nil) (to nil)
900 (var1 (make-symbol "--cl-var1--"))
901 (var2 (make-symbol "--cl-var2--")))
902 (while (memq (car loop-args) '(in of property from to))
903 (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
904 ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
905 ((eq (car loop-args) 'property)
906 (setq prop (cl-pop2 loop-args)))
907 (t (setq buf (cl-pop2 loop-args)))))
908 (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
909 (setq var1 (car var) var2 (cdr var))
910 (push (list var (list 'cons var1 var2)) loop-for-sets))
911 (setq loop-map-form
912 `(cl-map-intervals
913 (lambda (,var1 ,var2) . --cl-map)
914 ,buf ,prop ,from ,to))))
915
916 ((memq word key-types)
917 (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
918 (let ((map (cl-pop2 loop-args))
919 (other (if (eq (car loop-args) 'using)
920 (if (and (= (length (cadr loop-args)) 2)
921 (memq (caadr loop-args) key-types)
922 (not (eq (caadr loop-args) word)))
923 (cadr (cl-pop2 loop-args))
924 (error "Bad `using' clause"))
925 (make-symbol "--cl-var--"))))
926 (if (memq word '(key-binding key-bindings))
927 (setq var (prog1 other (setq other var))))
928 (setq loop-map-form
929 `(,(if (memq word '(key-seq key-seqs))
930 'cl-map-keymap-recursively 'map-keymap)
931 (lambda (,var ,other) . --cl-map) ,map))))
932
933 ((memq word '(frame frames screen screens))
934 (let ((temp (make-symbol "--cl-var--")))
935 (push (list var '(selected-frame))
936 loop-for-bindings)
937 (push (list temp nil) loop-for-bindings)
938 (push (list 'prog1 (list 'not (list 'eq var temp))
939 (list 'or temp (list 'setq temp var)))
940 loop-body)
941 (push (list var (list 'next-frame var))
942 loop-for-steps)))
943
944 ((memq word '(window windows))
945 (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
946 (temp (make-symbol "--cl-var--"))
947 (minip (make-symbol "--cl-minip--")))
948 (push (list var (if scr
949 (list 'frame-selected-window scr)
950 '(selected-window)))
951 loop-for-bindings)
952 ;; If we started in the minibuffer, we need to
953 ;; ensure that next-window will bring us back there
954 ;; at some point. (Bug#7492).
955 ;; (Consider using walk-windows instead of loop if
956 ;; you care about such things.)
957 (push (list minip `(minibufferp (window-buffer ,var)))
958 loop-for-bindings)
959 (push (list temp nil) loop-for-bindings)
960 (push (list 'prog1 (list 'not (list 'eq var temp))
961 (list 'or temp (list 'setq temp var)))
962 loop-body)
963 (push (list var (list 'next-window var minip))
964 loop-for-steps)))
965
966 (t
967 (let ((handler (and (symbolp word)
968 (get word 'cl-loop-for-handler))))
969 (if handler
970 (funcall handler var)
971 (error "Expected a `for' preposition, found %s" word)))))
972 (eq (car loop-args) 'and))
973 (setq ands t)
974 (pop loop-args))
975 (if (and ands loop-for-bindings)
976 (push (nreverse loop-for-bindings) loop-bindings)
977 (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
978 loop-bindings)))
979 (if loop-for-sets
980 (push (list 'progn
981 (cl-loop-let (nreverse loop-for-sets) 'setq ands)
982 t) loop-body))
983 (if loop-for-steps
984 (push (cons (if ands 'psetq 'setq)
985 (apply 'append (nreverse loop-for-steps)))
986 loop-steps))))
987
988 ((eq word 'repeat)
989 (let ((temp (make-symbol "--cl-var--")))
990 (push (list (list temp (pop loop-args))) loop-bindings)
991 (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
992
993 ((memq word '(collect collecting))
994 (let ((what (pop loop-args))
995 (var (cl-loop-handle-accum nil 'nreverse)))
996 (if (eq var loop-accum-var)
997 (push (list 'progn (list 'push what var) t) loop-body)
998 (push (list 'progn
999 (list 'setq var (list 'nconc var (list 'list what)))
1000 t) loop-body))))
1001
1002 ((memq word '(nconc nconcing append appending))
1003 (let ((what (pop loop-args))
1004 (var (cl-loop-handle-accum nil 'nreverse)))
1005 (push (list 'progn
1006 (list 'setq var
1007 (if (eq var loop-accum-var)
1008 (list 'nconc
1009 (list (if (memq word '(nconc nconcing))
1010 'nreverse 'reverse)
1011 what)
1012 var)
1013 (list (if (memq word '(nconc nconcing))
1014 'nconc 'append)
1015 var what))) t) loop-body)))
1016
1017 ((memq word '(concat concating))
1018 (let ((what (pop loop-args))
1019 (var (cl-loop-handle-accum "")))
1020 (push (list 'progn (list 'callf 'concat var what) t) loop-body)))
1021
1022 ((memq word '(vconcat vconcating))
1023 (let ((what (pop loop-args))
1024 (var (cl-loop-handle-accum [])))
1025 (push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
1026
1027 ((memq word '(sum summing))
1028 (let ((what (pop loop-args))
1029 (var (cl-loop-handle-accum 0)))
1030 (push (list 'progn (list 'incf var what) t) loop-body)))
1031
1032 ((memq word '(count counting))
1033 (let ((what (pop loop-args))
1034 (var (cl-loop-handle-accum 0)))
1035 (push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
1036
1037 ((memq word '(minimize minimizing maximize maximizing))
1038 (let* ((what (pop loop-args))
1039 (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
1040 (var (cl-loop-handle-accum nil))
1041 (func (intern (substring (symbol-name word) 0 3)))
1042 (set (list 'setq var (list 'if var (list func var temp) temp))))
1043 (push (list 'progn (if (eq temp what) set
1044 (list 'let (list (list temp what)) set))
1045 t) loop-body)))
1046
1047 ((eq word 'with)
1048 (let ((bindings nil))
1049 (while (progn (push (list (pop loop-args)
1050 (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
1051 bindings)
1052 (eq (car loop-args) 'and))
1053 (pop loop-args))
1054 (push (nreverse bindings) loop-bindings)))
1055
1056 ((eq word 'while)
1057 (push (pop loop-args) loop-body))
1058
1059 ((eq word 'until)
1060 (push (list 'not (pop loop-args)) loop-body))
1061
1062 ((eq word 'always)
1063 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1064 (push (list 'setq loop-finish-flag (pop loop-args)) loop-body)
1065 (setq loop-result t))
1066
1067 ((eq word 'never)
1068 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1069 (push (list 'setq loop-finish-flag (list 'not (pop loop-args)))
1070 loop-body)
1071 (setq loop-result t))
1072
1073 ((eq word 'thereis)
1074 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
1075 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1076 (push (list 'setq loop-finish-flag
1077 (list 'not (list 'setq loop-result-var (pop loop-args))))
1078 loop-body))
1079
1080 ((memq word '(if when unless))
1081 (let* ((cond (pop loop-args))
1082 (then (let ((loop-body nil))
1083 (cl-parse-loop-clause)
1084 (cl-loop-build-ands (nreverse loop-body))))
1085 (else (let ((loop-body nil))
1086 (if (eq (car loop-args) 'else)
1087 (progn (pop loop-args) (cl-parse-loop-clause)))
1088 (cl-loop-build-ands (nreverse loop-body))))
1089 (simple (and (eq (car then) t) (eq (car else) t))))
1090 (if (eq (car loop-args) 'end) (pop loop-args))
1091 (if (eq word 'unless) (setq then (prog1 else (setq else then))))
1092 (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
1093 (if simple (nth 1 else) (list (nth 2 else))))))
1094 (if (cl-expr-contains form 'it)
1095 (let ((temp (make-symbol "--cl-var--")))
1096 (push (list temp) loop-bindings)
1097 (setq form (list* 'if (list 'setq temp cond)
1098 (subst temp 'it form))))
1099 (setq form (list* 'if cond form)))
1100 (push (if simple (list 'progn form t) form) loop-body))))
1101
1102 ((memq word '(do doing))
1103 (let ((body nil))
1104 (or (consp (car loop-args)) (error "Syntax error on `do' clause"))
1105 (while (consp (car loop-args)) (push (pop loop-args) body))
1106 (push (cons 'progn (nreverse (cons t body))) loop-body)))
1107
1108 ((eq word 'return)
1109 (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
1110 (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
1111 (push (list 'setq loop-result-var (pop loop-args)
1112 loop-finish-flag nil) loop-body))
1113
1114 (t
1115 (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
1116 (or handler (error "Expected a loop keyword, found %s" word))
1117 (funcall handler))))
1118 (if (eq (car loop-args) 'and)
1119 (progn (pop loop-args) (cl-parse-loop-clause)))))
1120
1121 (defun cl-loop-let (specs body par) ; uses loop-*
1122 (let ((p specs) (temps nil) (new nil))
1123 (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
1124 (setq p (cdr p)))
1125 (and par p
1126 (progn
1127 (setq par nil p specs)
1128 (while p
1129 (or (cl-const-expr-p (cadar p))
1130 (let ((temp (make-symbol "--cl-var--")))
1131 (push (list temp (cadar p)) temps)
1132 (setcar (cdar p) temp)))
1133 (setq p (cdr p)))))
1134 (while specs
1135 (if (and (consp (car specs)) (listp (caar specs)))
1136 (let* ((spec (caar specs)) (nspecs nil)
1137 (expr (cadr (pop specs)))
1138 (temp (cdr (or (assq spec loop-destr-temps)
1139 (car (push (cons spec (or (last spec 0)
1140 (make-symbol "--cl-var--")))
1141 loop-destr-temps))))))
1142 (push (list temp expr) new)
1143 (while (consp spec)
1144 (push (list (pop spec)
1145 (and expr (list (if spec 'pop 'car) temp)))
1146 nspecs))
1147 (setq specs (nconc (nreverse nspecs) specs)))
1148 (push (pop specs) new)))
1149 (if (eq body 'setq)
1150 (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
1151 (if temps (list 'let* (nreverse temps) set) set))
1152 (list* (if par 'let 'let*)
1153 (nconc (nreverse temps) (nreverse new)) body))))
1154
1155 (defun cl-loop-handle-accum (def &optional func) ; uses loop-*
1156 (if (eq (car loop-args) 'into)
1157 (let ((var (cl-pop2 loop-args)))
1158 (or (memq var loop-accum-vars)
1159 (progn (push (list (list var def)) loop-bindings)
1160 (push var loop-accum-vars)))
1161 var)
1162 (or loop-accum-var
1163 (progn
1164 (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def))
1165 loop-bindings)
1166 (setq loop-result (if func (list func loop-accum-var)
1167 loop-accum-var))
1168 loop-accum-var))))
1169
1170 (defun cl-loop-build-ands (clauses)
1171 (let ((ands nil)
1172 (body nil))
1173 (while clauses
1174 (if (and (eq (car-safe (car clauses)) 'progn)
1175 (eq (car (last (car clauses))) t))
1176 (if (cdr clauses)
1177 (setq clauses (cons (nconc (butlast (car clauses))
1178 (if (eq (car-safe (cadr clauses))
1179 'progn)
1180 (cdadr clauses)
1181 (list (cadr clauses))))
1182 (cddr clauses)))
1183 (setq body (cdr (butlast (pop clauses)))))
1184 (push (pop clauses) ands)))
1185 (setq ands (or (nreverse ands) (list t)))
1186 (list (if (cdr ands) (cons 'and ands) (car ands))
1187 body
1188 (let ((full (if body
1189 (append ands (list (cons 'progn (append body '(t)))))
1190 ands)))
1191 (if (cdr full) (cons 'and full) (car full))))))
1192
1193
1194 ;;; Other iteration control structures.
1195
1196 ;;;###autoload
1197 (defmacro do (steps endtest &rest body)
1198 "The Common Lisp `do' loop.
1199
1200 \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1201 (cl-expand-do-loop steps endtest body nil))
1202
1203 ;;;###autoload
1204 (defmacro do* (steps endtest &rest body)
1205 "The Common Lisp `do*' loop.
1206
1207 \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
1208 (cl-expand-do-loop steps endtest body t))
1209
1210 (defun cl-expand-do-loop (steps endtest body star)
1211 (list 'block nil
1212 (list* (if star 'let* 'let)
1213 (mapcar (function (lambda (c)
1214 (if (consp c) (list (car c) (nth 1 c)) c)))
1215 steps)
1216 (list* 'while (list 'not (car endtest))
1217 (append body
1218 (let ((sets (mapcar
1219 (function
1220 (lambda (c)
1221 (and (consp c) (cdr (cdr c))
1222 (list (car c) (nth 2 c)))))
1223 steps)))
1224 (setq sets (delq nil sets))
1225 (and sets
1226 (list (cons (if (or star (not (cdr sets)))
1227 'setq 'psetq)
1228 (apply 'append sets)))))))
1229 (or (cdr endtest) '(nil)))))
1230
1231 ;;;###autoload
1232 (defmacro dolist (spec &rest body)
1233 "Loop over a list.
1234 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
1235 Then evaluate RESULT to get return value, default nil.
1236
1237 \(fn (VAR LIST [RESULT]) BODY...)"
1238 (let ((temp (make-symbol "--cl-dolist-temp--")))
1239 ;; FIXME: Copy&pasted from subr.el.
1240 `(block nil
1241 ;; This is not a reliable test, but it does not matter because both
1242 ;; semantics are acceptable, tho one is slightly faster with dynamic
1243 ;; scoping and the other is slightly faster (and has cleaner semantics)
1244 ;; with lexical scoping.
1245 ,(if lexical-binding
1246 `(let ((,temp ,(nth 1 spec)))
1247 (while ,temp
1248 (let ((,(car spec) (car ,temp)))
1249 ,@body
1250 (setq ,temp (cdr ,temp))))
1251 ,@(if (cdr (cdr spec))
1252 ;; FIXME: This let often leads to "unused var" warnings.
1253 `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
1254 `(let ((,temp ,(nth 1 spec))
1255 ,(car spec))
1256 (while ,temp
1257 (setq ,(car spec) (car ,temp))
1258 ,@body
1259 (setq ,temp (cdr ,temp)))
1260 ,@(if (cdr (cdr spec))
1261 `((setq ,(car spec) nil) ,@(cddr spec))))))))
1262
1263 ;;;###autoload
1264 (defmacro dotimes (spec &rest body)
1265 "Loop a certain number of times.
1266 Evaluate BODY with VAR bound to successive integers from 0, inclusive,
1267 to COUNT, exclusive. Then evaluate RESULT to get return value, default
1268 nil.
1269
1270 \(fn (VAR COUNT [RESULT]) BODY...)"
1271 (let ((temp (make-symbol "--cl-dotimes-temp--"))
1272 (end (nth 1 spec)))
1273 ;; FIXME: Copy&pasted from subr.el.
1274 `(block nil
1275 ;; This is not a reliable test, but it does not matter because both
1276 ;; semantics are acceptable, tho one is slightly faster with dynamic
1277 ;; scoping and the other has cleaner semantics.
1278 ,(if lexical-binding
1279 (let ((counter '--dotimes-counter--))
1280 `(let ((,temp ,end)
1281 (,counter 0))
1282 (while (< ,counter ,temp)
1283 (let ((,(car spec) ,counter))
1284 ,@body)
1285 (setq ,counter (1+ ,counter)))
1286 ,@(if (cddr spec)
1287 ;; FIXME: This let often leads to "unused var" warnings.
1288 `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
1289 `(let ((,temp ,end)
1290 (,(car spec) 0))
1291 (while (< ,(car spec) ,temp)
1292 ,@body
1293 (incf ,(car spec)))
1294 ,@(cdr (cdr spec)))))))
1295
1296 ;;;###autoload
1297 (defmacro do-symbols (spec &rest body)
1298 "Loop over all symbols.
1299 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
1300 from OBARRAY.
1301
1302 \(fn (VAR [OBARRAY [RESULT]]) BODY...)"
1303 ;; Apparently this doesn't have an implicit block.
1304 (list 'block nil
1305 (list 'let (list (car spec))
1306 (list* 'mapatoms
1307 (list 'function (list* 'lambda (list (car spec)) body))
1308 (and (cadr spec) (list (cadr spec))))
1309 (caddr spec))))
1310
1311 ;;;###autoload
1312 (defmacro do-all-symbols (spec &rest body)
1313 (list* 'do-symbols (list (car spec) nil (cadr spec)) body))
1314
1315
1316 ;;; Assignments.
1317
1318 ;;;###autoload
1319 (defmacro psetq (&rest args)
1320 "Set SYMs to the values VALs in parallel.
1321 This is like `setq', except that all VAL forms are evaluated (in order)
1322 before assigning any symbols SYM to the corresponding values.
1323
1324 \(fn SYM VAL SYM VAL ...)"
1325 (cons 'psetf args))
1326
1327
1328 ;;; Binding control structures.
1329
1330 ;;;###autoload
1331 (defmacro progv (symbols values &rest body)
1332 "Bind SYMBOLS to VALUES dynamically in BODY.
1333 The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
1334 Each symbol in the first list is bound to the corresponding value in the
1335 second list (or made unbound if VALUES is shorter than SYMBOLS); then the
1336 BODY forms are executed and their result is returned. This is much like
1337 a `let' form, except that the list of symbols can be computed at run-time."
1338 (list 'let '((cl-progv-save nil))
1339 (list 'unwind-protect
1340 (list* 'progn (list 'cl-progv-before symbols values) body)
1341 '(cl-progv-after))))
1342
1343 ;;; This should really have some way to shadow 'byte-compile properties, etc.
1344 ;;;###autoload
1345 (defmacro flet (bindings &rest body)
1346 "Make temporary function definitions.
1347 This is an analogue of `let' that operates on the function cell of FUNC
1348 rather than its value cell. The FORMs are evaluated with the specified
1349 function definitions in place, then the definitions are undone (the FUNCs
1350 go back to their previous definitions, or lack thereof).
1351
1352 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1353 (list* 'letf*
1354 (mapcar
1355 (function
1356 (lambda (x)
1357 (if (or (and (fboundp (car x))
1358 (eq (car-safe (symbol-function (car x))) 'macro))
1359 (cdr (assq (car x) cl-macro-environment)))
1360 (error "Use `labels', not `flet', to rebind macro names"))
1361 (let ((func (list 'function*
1362 (list 'lambda (cadr x)
1363 (list* 'block (car x) (cddr x))))))
1364 (when (cl-compiling-file)
1365 ;; Bug#411. It would be nice to fix this.
1366 (and (get (car x) 'byte-compile)
1367 (error "Byte-compiling a redefinition of `%s' \
1368 will not work - use `labels' instead" (symbol-name (car x))))
1369 ;; FIXME This affects the rest of the file, when it
1370 ;; should be restricted to the flet body.
1371 (and (boundp 'byte-compile-function-environment)
1372 (push (cons (car x) (eval func))
1373 byte-compile-function-environment)))
1374 (list (list 'symbol-function (list 'quote (car x))) func))))
1375 bindings)
1376 body))
1377
1378 ;;;###autoload
1379 (defmacro labels (bindings &rest body)
1380 "Make temporary function bindings.
1381 This is like `flet', except the bindings are lexical instead of dynamic.
1382 Unlike `flet', this macro is fully compliant with the Common Lisp standard.
1383
1384 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1385 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1386 (while bindings
1387 ;; Use `gensym' rather than `make-symbol'. It's important that
1388 ;; (not (eq (symbol-name var1) (symbol-name var2))) because these
1389 ;; vars get added to the cl-macro-environment.
1390 (let ((var (gensym "--cl-var--")))
1391 (push var vars)
1392 (push (list 'function* (cons 'lambda (cdar bindings))) sets)
1393 (push var sets)
1394 (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
1395 (list 'list* '(quote funcall) (list 'quote var)
1396 'cl-labels-args))
1397 cl-macro-environment)))
1398 (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
1399 cl-macro-environment)))
1400
1401 ;; The following ought to have a better definition for use with newer
1402 ;; byte compilers.
1403 ;;;###autoload
1404 (defmacro macrolet (bindings &rest body)
1405 "Make temporary macro definitions.
1406 This is like `flet', but for macros instead of functions.
1407
1408 \(fn ((NAME ARGLIST BODY...) ...) FORM...)"
1409 (if (cdr bindings)
1410 (list 'macrolet
1411 (list (car bindings)) (list* 'macrolet (cdr bindings) body))
1412 (if (null bindings) (cons 'progn body)
1413 (let* ((name (caar bindings))
1414 (res (cl-transform-lambda (cdar bindings) name)))
1415 (eval (car res))
1416 (cl-macroexpand-all (cons 'progn body)
1417 (cons (list* name 'lambda (cdr res))
1418 cl-macro-environment))))))
1419
1420 ;;;###autoload
1421 (defmacro symbol-macrolet (bindings &rest body)
1422 "Make symbol macro definitions.
1423 Within the body FORMs, references to the variable NAME will be replaced
1424 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
1425
1426 \(fn ((NAME EXPANSION) ...) FORM...)"
1427 (if (cdr bindings)
1428 (list 'symbol-macrolet
1429 (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
1430 (if (null bindings) (cons 'progn body)
1431 (cl-macroexpand-all (cons 'progn body)
1432 (cons (list (symbol-name (caar bindings))
1433 (cadar bindings))
1434 cl-macro-environment)))))
1435
1436 (defvar cl-closure-vars nil)
1437 ;;;###autoload
1438 (defmacro lexical-let (bindings &rest body)
1439 "Like `let', but lexically scoped.
1440 The main visible difference is that lambdas inside BODY will create
1441 lexical closures as in Common Lisp.
1442 \n(fn BINDINGS BODY)"
1443 (let* ((cl-closure-vars cl-closure-vars)
1444 (vars (mapcar (function
1445 (lambda (x)
1446 (or (consp x) (setq x (list x)))
1447 (push (make-symbol (format "--cl-%s--" (car x)))
1448 cl-closure-vars)
1449 (set (car cl-closure-vars) [bad-lexical-ref])
1450 (list (car x) (cadr x) (car cl-closure-vars))))
1451 bindings))
1452 (ebody
1453 (cl-macroexpand-all
1454 (cons 'progn body)
1455 (nconc (mapcar (function (lambda (x)
1456 (list (symbol-name (car x))
1457 (list 'symbol-value (caddr x))
1458 t))) vars)
1459 (list '(defun . cl-defun-expander))
1460 cl-macro-environment))))
1461 (if (not (get (car (last cl-closure-vars)) 'used))
1462 (list 'let (mapcar (function (lambda (x)
1463 (list (caddr x) (cadr x)))) vars)
1464 (sublis (mapcar (function (lambda (x)
1465 (cons (caddr x)
1466 (list 'quote (caddr x)))))
1467 vars)
1468 ebody))
1469 (list 'let (mapcar (function (lambda (x)
1470 (list (caddr x)
1471 (list 'make-symbol
1472 (format "--%s--" (car x))))))
1473 vars)
1474 (apply 'append '(setf)
1475 (mapcar (function
1476 (lambda (x)
1477 (list (list 'symbol-value (caddr x)) (cadr x))))
1478 vars))
1479 ebody))))
1480
1481 ;;;###autoload
1482 (defmacro lexical-let* (bindings &rest body)
1483 "Like `let*', but lexically scoped.
1484 The main visible difference is that lambdas inside BODY, and in
1485 successive bindings within BINDINGS, will create lexical closures
1486 as in Common Lisp. This is similar to the behavior of `let*' in
1487 Common Lisp.
1488 \n(fn BINDINGS BODY)"
1489 (if (null bindings) (cons 'progn body)
1490 (setq bindings (reverse bindings))
1491 (while bindings
1492 (setq body (list (list* 'lexical-let (list (pop bindings)) body))))
1493 (car body)))
1494
1495 (defun cl-defun-expander (func &rest rest)
1496 (list 'progn
1497 (list 'defalias (list 'quote func)
1498 (list 'function (cons 'lambda rest)))
1499 (list 'quote func)))
1500
1501
1502 ;;; Multiple values.
1503
1504 ;;;###autoload
1505 (defmacro multiple-value-bind (vars form &rest body)
1506 "Collect multiple return values.
1507 FORM must return a list; the BODY is then executed with the first N elements
1508 of this list bound (`let'-style) to each of the symbols SYM in turn. This
1509 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
1510 simulate true multiple return values. For compatibility, (values A B C) is
1511 a synonym for (list A B C).
1512
1513 \(fn (SYM...) FORM BODY)"
1514 (let ((temp (make-symbol "--cl-var--")) (n -1))
1515 (list* 'let* (cons (list temp form)
1516 (mapcar (function
1517 (lambda (v)
1518 (list v (list 'nth (setq n (1+ n)) temp))))
1519 vars))
1520 body)))
1521
1522 ;;;###autoload
1523 (defmacro multiple-value-setq (vars form)
1524 "Collect multiple return values.
1525 FORM must return a list; the first N elements of this list are stored in
1526 each of the symbols SYM in turn. This is analogous to the Common Lisp
1527 `multiple-value-setq' macro, using lists to simulate true multiple return
1528 values. For compatibility, (values A B C) is a synonym for (list A B C).
1529
1530 \(fn (SYM...) FORM)"
1531 (cond ((null vars) (list 'progn form nil))
1532 ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1533 (t
1534 (let* ((temp (make-symbol "--cl-var--")) (n 0))
1535 (list 'let (list (list temp form))
1536 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
1537 (cons 'setq (apply 'nconc
1538 (mapcar (function
1539 (lambda (v)
1540 (list v (list
1541 'nth
1542 (setq n (1+ n))
1543 temp))))
1544 vars)))))))))
1545
1546
1547 ;;; Declarations.
1548
1549 ;;;###autoload
1550 (defmacro locally (&rest body) (cons 'progn body))
1551 ;;;###autoload
1552 (defmacro the (type form) form)
1553
1554 (defvar cl-proclaim-history t) ; for future compilers
1555 (defvar cl-declare-stack t) ; for future compilers
1556
1557 (defun cl-do-proclaim (spec hist)
1558 (and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
1559 (cond ((eq (car-safe spec) 'special)
1560 (if (boundp 'byte-compile-bound-variables)
1561 (setq byte-compile-bound-variables
1562 (append (cdr spec) byte-compile-bound-variables))))
1563
1564 ((eq (car-safe spec) 'inline)
1565 (while (setq spec (cdr spec))
1566 (or (memq (get (car spec) 'byte-optimizer)
1567 '(nil byte-compile-inline-expand))
1568 (error "%s already has a byte-optimizer, can't make it inline"
1569 (car spec)))
1570 (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
1571
1572 ((eq (car-safe spec) 'notinline)
1573 (while (setq spec (cdr spec))
1574 (if (eq (get (car spec) 'byte-optimizer)
1575 'byte-compile-inline-expand)
1576 (put (car spec) 'byte-optimizer nil))))
1577
1578 ((eq (car-safe spec) 'optimize)
1579 (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
1580 '((0 nil) (1 t) (2 t) (3 t))))
1581 (safety (assq (nth 1 (assq 'safety (cdr spec)))
1582 '((0 t) (1 t) (2 t) (3 nil)))))
1583 (if speed (setq cl-optimize-speed (car speed)
1584 byte-optimize (nth 1 speed)))
1585 (if safety (setq cl-optimize-safety (car safety)
1586 byte-compile-delete-errors (nth 1 safety)))))
1587
1588 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
1589 (while (setq spec (cdr spec))
1590 (if (consp (car spec))
1591 (if (eq (cadar spec) 0)
1592 (byte-compile-disable-warning (caar spec))
1593 (byte-compile-enable-warning (caar spec)))))))
1594 nil)
1595
1596 ;;; Process any proclamations made before cl-macs was loaded.
1597 (defvar cl-proclaims-deferred)
1598 (let ((p (reverse cl-proclaims-deferred)))
1599 (while p (cl-do-proclaim (pop p) t))
1600 (setq cl-proclaims-deferred nil))
1601
1602 ;;;###autoload
1603 (defmacro declare (&rest specs)
1604 "Declare SPECS about the current function while compiling.
1605 For instance
1606
1607 \(declare (warn 0))
1608
1609 will turn off byte-compile warnings in the function.
1610 See Info node `(cl)Declarations' for details."
1611 (if (cl-compiling-file)
1612 (while specs
1613 (if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
1614 (cl-do-proclaim (pop specs) nil)))
1615 nil)
1616
1617
1618
1619 ;;; Generalized variables.
1620
1621 ;;;###autoload
1622 (defmacro define-setf-method (func args &rest body)
1623 "Define a `setf' method.
1624 This method shows how to handle `setf's to places of the form (NAME ARGS...).
1625 The argument forms ARGS are bound according to ARGLIST, as if NAME were
1626 going to be expanded as a macro, then the BODY forms are executed and must
1627 return a list of five elements: a temporary-variables list, a value-forms
1628 list, a store-variables list (of length one), a store-form, and an access-
1629 form. See `defsetf' for a simpler way to define most setf-methods.
1630
1631 \(fn NAME ARGLIST BODY...)"
1632 (append '(eval-when (compile load eval))
1633 (if (stringp (car body))
1634 (list (list 'put (list 'quote func) '(quote setf-documentation)
1635 (pop body))))
1636 (list (cl-transform-function-property
1637 func 'setf-method (cons args body)))))
1638 (defalias 'define-setf-expander 'define-setf-method)
1639
1640 ;;;###autoload
1641 (defmacro defsetf (func arg1 &rest args)
1642 "Define a `setf' method.
1643 This macro is an easy-to-use substitute for `define-setf-method' that works
1644 well for simple place forms. In the simple `defsetf' form, `setf's of
1645 the form (setf (NAME ARGS...) VAL) are transformed to function or macro
1646 calls of the form (FUNC ARGS... VAL). Example:
1647
1648 (defsetf aref aset)
1649
1650 Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).
1651 Here, the above `setf' call is expanded by binding the argument forms ARGS
1652 according to ARGLIST, binding the value form VAL to STORE, then executing
1653 BODY, which must return a Lisp form that does the necessary `setf' operation.
1654 Actually, ARGLIST and STORE may be bound to temporary variables which are
1655 introduced automatically to preserve proper execution order of the arguments.
1656 Example:
1657
1658 (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))
1659
1660 \(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
1661 (if (and (listp arg1) (consp args))
1662 (let* ((largs nil) (largsr nil)
1663 (temps nil) (tempsr nil)
1664 (restarg nil) (rest-temps nil)
1665 (store-var (car (prog1 (car args) (setq args (cdr args)))))
1666 (store-temp (intern (format "--%s--temp--" store-var)))
1667 (lets1 nil) (lets2 nil)
1668 (docstr nil) (p arg1))
1669 (if (stringp (car args))
1670 (setq docstr (prog1 (car args) (setq args (cdr args)))))
1671 (while (and p (not (eq (car p) '&aux)))
1672 (if (eq (car p) '&rest)
1673 (setq p (cdr p) restarg (car p))
1674 (or (memq (car p) '(&optional &key &allow-other-keys))
1675 (setq largs (cons (if (consp (car p)) (car (car p)) (car p))
1676 largs)
1677 temps (cons (intern (format "--%s--temp--" (car largs)))
1678 temps))))
1679 (setq p (cdr p)))
1680 (setq largs (nreverse largs) temps (nreverse temps))
1681 (if restarg
1682 (setq largsr (append largs (list restarg))
1683 rest-temps (intern (format "--%s--temp--" restarg))
1684 tempsr (append temps (list rest-temps)))
1685 (setq largsr largs tempsr temps))
1686 (let ((p1 largs) (p2 temps))
1687 (while p1
1688 (setq lets1 (cons `(,(car p2)
1689 (make-symbol ,(format "--cl-%s--" (car p1))))
1690 lets1)
1691 lets2 (cons (list (car p1) (car p2)) lets2)
1692 p1 (cdr p1) p2 (cdr p2))))
1693 (if restarg (setq lets2 (cons (list restarg rest-temps) lets2)))
1694 `(define-setf-method ,func ,arg1
1695 ,@(and docstr (list docstr))
1696 (let*
1697 ,(nreverse
1698 (cons `(,store-temp
1699 (make-symbol ,(format "--cl-%s--" store-var)))
1700 (if restarg
1701 `((,rest-temps
1702 (mapcar (lambda (_) (make-symbol "--cl-var--"))
1703 ,restarg))
1704 ,@lets1)
1705 lets1)))
1706 (list ; 'values
1707 (,(if restarg 'list* 'list) ,@tempsr)
1708 (,(if restarg 'list* 'list) ,@largsr)
1709 (list ,store-temp)
1710 (let*
1711 ,(nreverse
1712 (cons (list store-var store-temp)
1713 lets2))
1714 ,@args)
1715 (,(if restarg 'list* 'list)
1716 ,@(cons (list 'quote func) tempsr))))))
1717 `(defsetf ,func (&rest args) (store)
1718 ,(let ((call `(cons ',arg1
1719 (append args (list store)))))
1720 (if (car args)
1721 `(list 'progn ,call store)
1722 call)))))
1723
1724 ;;; Some standard place types from Common Lisp.
1725 (defsetf aref aset)
1726 (defsetf car setcar)
1727 (defsetf cdr setcdr)
1728 (defsetf caar (x) (val) (list 'setcar (list 'car x) val))
1729 (defsetf cadr (x) (val) (list 'setcar (list 'cdr x) val))
1730 (defsetf cdar (x) (val) (list 'setcdr (list 'car x) val))
1731 (defsetf cddr (x) (val) (list 'setcdr (list 'cdr x) val))
1732 (defsetf elt (seq n) (store)
1733 (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
1734 (list 'aset seq n store)))
1735 (defsetf get put)
1736 (defsetf get* (x y &optional d) (store) (list 'put x y store))
1737 (defsetf gethash (x h &optional d) (store) (list 'puthash x store h))
1738 (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
1739 (defsetf subseq (seq start &optional end) (new)
1740 (list 'progn (list 'replace seq new :start1 start :end1 end) new))
1741 (defsetf symbol-function fset)
1742 (defsetf symbol-plist setplist)
1743 (defsetf symbol-value set)
1744
1745 ;;; Various car/cdr aliases. Note that `cadr' is handled specially.
1746 (defsetf first setcar)
1747 (defsetf second (x) (store) (list 'setcar (list 'cdr x) store))
1748 (defsetf third (x) (store) (list 'setcar (list 'cddr x) store))
1749 (defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store))
1750 (defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store))
1751 (defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store))
1752 (defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store))
1753 (defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store))
1754 (defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store))
1755 (defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store))
1756 (defsetf rest setcdr)
1757
1758 ;;; Some more Emacs-related place types.
1759 (defsetf buffer-file-name set-visited-file-name t)
1760 (defsetf buffer-modified-p (&optional buf) (flag)
1761 (list 'with-current-buffer buf
1762 (list 'set-buffer-modified-p flag)))
1763 (defsetf buffer-name rename-buffer t)
1764 (defsetf buffer-string () (store)
1765 (list 'progn '(erase-buffer) (list 'insert store)))
1766 (defsetf buffer-substring cl-set-buffer-substring)
1767 (defsetf current-buffer set-buffer)
1768 (defsetf current-case-table set-case-table)
1769 (defsetf current-column move-to-column t)
1770 (defsetf current-global-map use-global-map t)
1771 (defsetf current-input-mode () (store)
1772 (list 'progn (list 'apply 'set-input-mode store) store))
1773 (defsetf current-local-map use-local-map t)
1774 (defsetf current-window-configuration set-window-configuration t)
1775 (defsetf default-file-modes set-default-file-modes t)
1776 (defsetf default-value set-default)
1777 (defsetf documentation-property put)
1778 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
1779 (defsetf face-background-pixmap (f &optional s) (x)
1780 (list 'set-face-background-pixmap f x s))
1781 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
1782 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
1783 (defsetf face-underline-p (f &optional s) (x)
1784 (list 'set-face-underline-p f x s))
1785 (defsetf file-modes set-file-modes t)
1786 (defsetf frame-height set-screen-height t)
1787 (defsetf frame-parameters modify-frame-parameters t)
1788 (defsetf frame-visible-p cl-set-frame-visible-p)
1789 (defsetf frame-width set-screen-width t)
1790 (defsetf frame-parameter set-frame-parameter t)
1791 (defsetf terminal-parameter set-terminal-parameter)
1792 (defsetf getenv setenv t)
1793 (defsetf get-register set-register)
1794 (defsetf global-key-binding global-set-key)
1795 (defsetf keymap-parent set-keymap-parent)
1796 (defsetf local-key-binding local-set-key)
1797 (defsetf mark set-mark t)
1798 (defsetf mark-marker set-mark t)
1799 (defsetf marker-position set-marker t)
1800 (defsetf match-data set-match-data t)
1801 (defsetf mouse-position (scr) (store)
1802 (list 'set-mouse-position scr (list 'car store) (list 'cadr store)
1803 (list 'cddr store)))
1804 (defsetf overlay-get overlay-put)
1805 (defsetf overlay-start (ov) (store)
1806 (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store))
1807 (defsetf overlay-end (ov) (store)
1808 (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store))
1809 (defsetf point goto-char)
1810 (defsetf point-marker goto-char t)
1811 (defsetf point-max () (store)
1812 (list 'progn (list 'narrow-to-region '(point-min) store) store))
1813 (defsetf point-min () (store)
1814 (list 'progn (list 'narrow-to-region store '(point-max)) store))
1815 (defsetf process-buffer set-process-buffer)
1816 (defsetf process-filter set-process-filter)
1817 (defsetf process-sentinel set-process-sentinel)
1818 (defsetf process-get process-put)
1819 (defsetf read-mouse-position (scr) (store)
1820 (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
1821 (defsetf screen-height set-screen-height t)
1822 (defsetf screen-width set-screen-width t)
1823 (defsetf selected-window select-window)
1824 (defsetf selected-screen select-screen)
1825 (defsetf selected-frame select-frame)
1826 (defsetf standard-case-table set-standard-case-table)
1827 (defsetf syntax-table set-syntax-table)
1828 (defsetf visited-file-modtime set-visited-file-modtime t)
1829 (defsetf window-buffer set-window-buffer t)
1830 (defsetf window-display-table set-window-display-table t)
1831 (defsetf window-dedicated-p set-window-dedicated-p t)
1832 (defsetf window-height () (store)
1833 (list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
1834 (defsetf window-hscroll set-window-hscroll)
1835 (defsetf window-parameter set-window-parameter)
1836 (defsetf window-point set-window-point)
1837 (defsetf window-start set-window-start)
1838 (defsetf window-width () (store)
1839 (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store))
1840 (defsetf x-get-secondary-selection x-own-secondary-selection t)
1841 (defsetf x-get-selection x-own-selection t)
1842
1843 ;; This is a hack that allows (setf (eq a 7) B) to mean either
1844 ;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
1845 ;; This is useful when you have control over the PLACE but not over
1846 ;; the VALUE, as is the case in define-minor-mode's :variable.
1847 (define-setf-method eq (place val)
1848 (let ((method (get-setf-method place cl-macro-environment))
1849 (val-temp (make-symbol "--eq-val--"))
1850 (store-temp (make-symbol "--eq-store--")))
1851 (list (append (nth 0 method) (list val-temp))
1852 (append (nth 1 method) (list val))
1853 (list store-temp)
1854 `(let ((,(car (nth 2 method))
1855 (if ,store-temp ,val-temp (not ,val-temp))))
1856 ,(nth 3 method) ,store-temp)
1857 `(eq ,(nth 4 method) ,val-temp))))
1858
1859 ;;; More complex setf-methods.
1860 ;; These should take &environment arguments, but since full arglists aren't
1861 ;; available while compiling cl-macs, we fake it by referring to the global
1862 ;; variable cl-macro-environment directly.
1863
1864 (define-setf-method apply (func arg1 &rest rest)
1865 (or (and (memq (car-safe func) '(quote function function*))
1866 (symbolp (car-safe (cdr-safe func))))
1867 (error "First arg to apply in setf is not (function SYM): %s" func))
1868 (let* ((form (cons (nth 1 func) (cons arg1 rest)))
1869 (method (get-setf-method form cl-macro-environment)))
1870 (list (car method) (nth 1 method) (nth 2 method)
1871 (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
1872 (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
1873
1874 (defun cl-setf-make-apply (form func temps)
1875 (if (eq (car form) 'progn)
1876 (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form))
1877 (or (equal (last form) (last temps))
1878 (error "%s is not suitable for use with setf-of-apply" func))
1879 (list* 'apply (list 'quote (car form)) (cdr form))))
1880
1881 (define-setf-method nthcdr (n place)
1882 (let ((method (get-setf-method place cl-macro-environment))
1883 (n-temp (make-symbol "--cl-nthcdr-n--"))
1884 (store-temp (make-symbol "--cl-nthcdr-store--")))
1885 (list (cons n-temp (car method))
1886 (cons n (nth 1 method))
1887 (list store-temp)
1888 (list 'let (list (list (car (nth 2 method))
1889 (list 'cl-set-nthcdr n-temp (nth 4 method)
1890 store-temp)))
1891 (nth 3 method) store-temp)
1892 (list 'nthcdr n-temp (nth 4 method)))))
1893
1894 (define-setf-method getf (place tag &optional def)
1895 (let ((method (get-setf-method place cl-macro-environment))
1896 (tag-temp (make-symbol "--cl-getf-tag--"))
1897 (def-temp (make-symbol "--cl-getf-def--"))
1898 (store-temp (make-symbol "--cl-getf-store--")))
1899 (list (append (car method) (list tag-temp def-temp))
1900 (append (nth 1 method) (list tag def))
1901 (list store-temp)
1902 (list 'let (list (list (car (nth 2 method))
1903 (list 'cl-set-getf (nth 4 method)
1904 tag-temp store-temp)))
1905 (nth 3 method) store-temp)
1906 (list 'getf (nth 4 method) tag-temp def-temp))))
1907
1908 (define-setf-method substring (place from &optional to)
1909 (let ((method (get-setf-method place cl-macro-environment))
1910 (from-temp (make-symbol "--cl-substring-from--"))
1911 (to-temp (make-symbol "--cl-substring-to--"))
1912 (store-temp (make-symbol "--cl-substring-store--")))
1913 (list (append (car method) (list from-temp to-temp))
1914 (append (nth 1 method) (list from to))
1915 (list store-temp)
1916 (list 'let (list (list (car (nth 2 method))
1917 (list 'cl-set-substring (nth 4 method)
1918 from-temp to-temp store-temp)))
1919 (nth 3 method) store-temp)
1920 (list 'substring (nth 4 method) from-temp to-temp))))
1921
1922 ;;; Getting and optimizing setf-methods.
1923 ;;;###autoload
1924 (defun get-setf-method (place &optional env)
1925 "Return a list of five values describing the setf-method for PLACE.
1926 PLACE may be any Lisp form which can appear as the PLACE argument to
1927 a macro like `setf' or `incf'."
1928 (if (symbolp place)
1929 (let ((temp (make-symbol "--cl-setf--")))
1930 (list nil nil (list temp) (list 'setq place temp) place))
1931 (or (and (symbolp (car place))
1932 (let* ((func (car place))
1933 (name (symbol-name func))
1934 (method (get func 'setf-method))
1935 (case-fold-search nil))
1936 (or (and method
1937 (let ((cl-macro-environment env))
1938 (setq method (apply method (cdr place))))
1939 (if (and (consp method) (= (length method) 5))
1940 method
1941 (error "Setf-method for %s returns malformed method"
1942 func)))
1943 (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name)
1944 (get-setf-method (compiler-macroexpand place)))
1945 (and (eq func 'edebug-after)
1946 (get-setf-method (nth (1- (length place)) place)
1947 env)))))
1948 (if (eq place (setq place (macroexpand place env)))
1949 (if (and (symbolp (car place)) (fboundp (car place))
1950 (symbolp (symbol-function (car place))))
1951 (get-setf-method (cons (symbol-function (car place))
1952 (cdr place)) env)
1953 (error "No setf-method known for %s" (car place)))
1954 (get-setf-method place env)))))
1955
1956 (defun cl-setf-do-modify (place opt-expr)
1957 (let* ((method (get-setf-method place cl-macro-environment))
1958 (temps (car method)) (values (nth 1 method))
1959 (lets nil) (subs nil)
1960 (optimize (and (not (eq opt-expr 'no-opt))
1961 (or (and (not (eq opt-expr 'unsafe))
1962 (cl-safe-expr-p opt-expr))
1963 (cl-setf-simple-store-p (car (nth 2 method))
1964 (nth 3 method)))))
1965 (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
1966 (while values
1967 (if (or simple (cl-const-expr-p (car values)))
1968 (push (cons (pop temps) (pop values)) subs)
1969 (push (list (pop temps) (pop values)) lets)))
1970 (list (nreverse lets)
1971 (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
1972 (sublis subs (nth 4 method)))))
1973
1974 (defun cl-setf-do-store (spec val)
1975 (let ((sym (car spec))
1976 (form (cdr spec)))
1977 (if (or (cl-const-expr-p val)
1978 (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
1979 (cl-setf-simple-store-p sym form))
1980 (subst val sym form)
1981 (list 'let (list (list sym val)) form))))
1982
1983 (defun cl-setf-simple-store-p (sym form)
1984 (and (consp form) (eq (cl-expr-contains form sym) 1)
1985 (eq (nth (1- (length form)) form) sym)
1986 (symbolp (car form)) (fboundp (car form))
1987 (not (eq (car-safe (symbol-function (car form))) 'macro))))
1988
1989 ;;; The standard modify macros.
1990 ;;;###autoload
1991 (defmacro setf (&rest args)
1992 "Set each PLACE to the value of its VAL.
1993 This is a generalized version of `setq'; the PLACEs may be symbolic
1994 references such as (car x) or (aref x i), as well as plain symbols.
1995 For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
1996 The return value is the last VAL in the list.
1997
1998 \(fn PLACE VAL PLACE VAL ...)"
1999 (if (cdr (cdr args))
2000 (let ((sets nil))
2001 (while args (push (list 'setf (pop args) (pop args)) sets))
2002 (cons 'progn (nreverse sets)))
2003 (if (symbolp (car args))
2004 (and args (cons 'setq args))
2005 (let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
2006 (store (cl-setf-do-store (nth 1 method) (nth 1 args))))
2007 (if (car method) (list 'let* (car method) store) store)))))
2008
2009 ;;;###autoload
2010 (defmacro psetf (&rest args)
2011 "Set PLACEs to the values VALs in parallel.
2012 This is like `setf', except that all VAL forms are evaluated (in order)
2013 before assigning any PLACEs to the corresponding values.
2014
2015 \(fn PLACE VAL PLACE VAL ...)"
2016 (let ((p args) (simple t) (vars nil))
2017 (while p
2018 (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
2019 (setq simple nil))
2020 (if (memq (car p) vars)
2021 (error "Destination duplicated in psetf: %s" (car p)))
2022 (push (pop p) vars)
2023 (or p (error "Odd number of arguments to psetf"))
2024 (pop p))
2025 (if simple
2026 (list 'progn (cons 'setf args) nil)
2027 (setq args (reverse args))
2028 (let ((expr (list 'setf (cadr args) (car args))))
2029 (while (setq args (cddr args))
2030 (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr))))
2031 (list 'progn expr nil)))))
2032
2033 ;;;###autoload
2034 (defun cl-do-pop (place)
2035 (if (cl-simple-expr-p place)
2036 (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
2037 (let* ((method (cl-setf-do-modify place t))
2038 (temp (make-symbol "--cl-pop--")))
2039 (list 'let*
2040 (append (car method)
2041 (list (list temp (nth 2 method))))
2042 (list 'prog1
2043 (list 'car temp)
2044 (cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
2045
2046 ;;;###autoload
2047 (defmacro remf (place tag)
2048 "Remove TAG from property list PLACE.
2049 PLACE may be a symbol, or any generalized variable allowed by `setf'.
2050 The form returns true if TAG was found and removed, nil otherwise."
2051 (let* ((method (cl-setf-do-modify place t))
2052 (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--")))
2053 (val-temp (and (not (cl-simple-expr-p place))
2054 (make-symbol "--cl-remf-place--")))
2055 (ttag (or tag-temp tag))
2056 (tval (or val-temp (nth 2 method))))
2057 (list 'let*
2058 (append (car method)
2059 (and val-temp (list (list val-temp (nth 2 method))))
2060 (and tag-temp (list (list tag-temp tag))))
2061 (list 'if (list 'eq ttag (list 'car tval))
2062 (list 'progn
2063 (cl-setf-do-store (nth 1 method) (list 'cddr tval))
2064 t)
2065 (list 'cl-do-remf tval ttag)))))
2066
2067 ;;;###autoload
2068 (defmacro shiftf (place &rest args)
2069 "Shift left among PLACEs.
2070 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
2071 Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
2072
2073 \(fn PLACE... VAL)"
2074 (cond
2075 ((null args) place)
2076 ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
2077 (t
2078 (let ((method (cl-setf-do-modify place 'unsafe)))
2079 `(let* ,(car method)
2080 (prog1 ,(nth 2 method)
2081 ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
2082
2083 ;;;###autoload
2084 (defmacro rotatef (&rest args)
2085 "Rotate left among PLACEs.
2086 Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
2087 Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
2088
2089 \(fn PLACE...)"
2090 (if (not (memq nil (mapcar 'symbolp args)))
2091 (and (cdr args)
2092 (let ((sets nil)
2093 (first (car args)))
2094 (while (cdr args)
2095 (setq sets (nconc sets (list (pop args) (car args)))))
2096 (nconc (list 'psetf) sets (list (car args) first))))
2097 (let* ((places (reverse args))
2098 (temp (make-symbol "--cl-rotatef--"))
2099 (form temp))
2100 (while (cdr places)
2101 (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
2102 (setq form (list 'let* (car method)
2103 (list 'prog1 (nth 2 method)
2104 (cl-setf-do-store (nth 1 method) form))))))
2105 (let ((method (cl-setf-do-modify (car places) 'unsafe)))
2106 (list 'let* (append (car method) (list (list temp (nth 2 method))))
2107 (cl-setf-do-store (nth 1 method) form) nil)))))
2108
2109 ;;;###autoload
2110 (defmacro letf (bindings &rest body)
2111 "Temporarily bind to PLACEs.
2112 This is the analogue of `let', but with generalized variables (in the
2113 sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
2114 VALUE, then the BODY forms are executed. On exit, either normally or
2115 because of a `throw' or error, the PLACEs are set back to their original
2116 values. Note that this macro is *not* available in Common Lisp.
2117 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2118 the PLACE is not modified before executing BODY.
2119
2120 \(fn ((PLACE VALUE) ...) BODY...)"
2121 (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
2122 (list* 'let bindings body)
2123 (let ((lets nil) (sets nil)
2124 (unsets nil) (rev (reverse bindings)))
2125 (while rev
2126 (let* ((place (if (symbolp (caar rev))
2127 (list 'symbol-value (list 'quote (caar rev)))
2128 (caar rev)))
2129 (value (cadar rev))
2130 (method (cl-setf-do-modify place 'no-opt))
2131 (save (make-symbol "--cl-letf-save--"))
2132 (bound (and (memq (car place) '(symbol-value symbol-function))
2133 (make-symbol "--cl-letf-bound--")))
2134 (temp (and (not (cl-const-expr-p value)) (cdr bindings)
2135 (make-symbol "--cl-letf-val--"))))
2136 (setq lets (nconc (car method)
2137 (if bound
2138 (list (list bound
2139 (list (if (eq (car place)
2140 'symbol-value)
2141 'boundp 'fboundp)
2142 (nth 1 (nth 2 method))))
2143 (list save (list 'and bound
2144 (nth 2 method))))
2145 (list (list save (nth 2 method))))
2146 (and temp (list (list temp value)))
2147 lets)
2148 body (list
2149 (list 'unwind-protect
2150 (cons 'progn
2151 (if (cdr (car rev))
2152 (cons (cl-setf-do-store (nth 1 method)
2153 (or temp value))
2154 body)
2155 body))
2156 (if bound
2157 (list 'if bound
2158 (cl-setf-do-store (nth 1 method) save)
2159 (list (if (eq (car place) 'symbol-value)
2160 'makunbound 'fmakunbound)
2161 (nth 1 (nth 2 method))))
2162 (cl-setf-do-store (nth 1 method) save))))
2163 rev (cdr rev))))
2164 (list* 'let* lets body))))
2165
2166 ;;;###autoload
2167 (defmacro letf* (bindings &rest body)
2168 "Temporarily bind to PLACEs.
2169 This is the analogue of `let*', but with generalized variables (in the
2170 sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
2171 VALUE, then the BODY forms are executed. On exit, either normally or
2172 because of a `throw' or error, the PLACEs are set back to their original
2173 values. Note that this macro is *not* available in Common Lisp.
2174 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2175 the PLACE is not modified before executing BODY.
2176
2177 \(fn ((PLACE VALUE) ...) BODY...)"
2178 (if (null bindings)
2179 (cons 'progn body)
2180 (setq bindings (reverse bindings))
2181 (while bindings
2182 (setq body (list (list* 'letf (list (pop bindings)) body))))
2183 (car body)))
2184
2185 ;;;###autoload
2186 (defmacro callf (func place &rest args)
2187 "Set PLACE to (FUNC PLACE ARGS...).
2188 FUNC should be an unquoted function name. PLACE may be a symbol,
2189 or any generalized variable allowed by `setf'.
2190
2191 \(fn FUNC PLACE ARGS...)"
2192 (let* ((method (cl-setf-do-modify place (cons 'list args)))
2193 (rargs (cons (nth 2 method) args)))
2194 (list 'let* (car method)
2195 (cl-setf-do-store (nth 1 method)
2196 (if (symbolp func) (cons func rargs)
2197 (list* 'funcall (list 'function func)
2198 rargs))))))
2199
2200 ;;;###autoload
2201 (defmacro callf2 (func arg1 place &rest args)
2202 "Set PLACE to (FUNC ARG1 PLACE ARGS...).
2203 Like `callf', but PLACE is the second argument of FUNC, not the first.
2204
2205 \(fn FUNC ARG1 PLACE ARGS...)"
2206 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
2207 (list 'setf place (list* func arg1 place args))
2208 (let* ((method (cl-setf-do-modify place (cons 'list args)))
2209 (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--")))
2210 (rargs (list* (or temp arg1) (nth 2 method) args)))
2211 (list 'let* (append (and temp (list (list temp arg1))) (car method))
2212 (cl-setf-do-store (nth 1 method)
2213 (if (symbolp func) (cons func rargs)
2214 (list* 'funcall (list 'function func)
2215 rargs)))))))
2216
2217 ;;;###autoload
2218 (defmacro define-modify-macro (name arglist func &optional doc)
2219 "Define a `setf'-like modify macro.
2220 If NAME is called, it combines its PLACE argument with the other arguments
2221 from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
2222 (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
2223 (let ((place (make-symbol "--cl-place--")))
2224 (list 'defmacro* name (cons place arglist) doc
2225 (list* (if (memq '&rest arglist) 'list* 'list)
2226 '(quote callf) (list 'quote func) place
2227 (cl-arglist-args arglist)))))
2228
2229
2230 ;;; Structures.
2231
2232 ;;;###autoload
2233 (defmacro defstruct (struct &rest descs)
2234 "Define a struct type.
2235 This macro defines a new data type called NAME that stores data
2236 in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
2237 copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
2238 You can use the accessors to set the corresponding slots, via `setf'.
2239
2240 NAME may instead take the form (NAME OPTIONS...), where each
2241 OPTION is either a single keyword or (KEYWORD VALUE).
2242 See Info node `(cl)Structures' for a list of valid keywords.
2243
2244 Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
2245 SLOT-OPTS are keyword-value pairs for that slot. Currently, only
2246 one keyword is supported, `:read-only'. If this has a non-nil
2247 value, that slot cannot be set via `setf'.
2248
2249 \(fn NAME SLOTS...)"
2250 (let* ((name (if (consp struct) (car struct) struct))
2251 (opts (cdr-safe struct))
2252 (slots nil)
2253 (defaults nil)
2254 (conc-name (concat (symbol-name name) "-"))
2255 (constructor (intern (format "make-%s" name)))
2256 (constrs nil)
2257 (copier (intern (format "copy-%s" name)))
2258 (predicate (intern (format "%s-p" name)))
2259 (print-func nil) (print-auto nil)
2260 (safety (if (cl-compiling-file) cl-optimize-safety 3))
2261 (include nil)
2262 (tag (intern (format "cl-struct-%s" name)))
2263 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
2264 (include-descs nil)
2265 (side-eff nil)
2266 (type nil)
2267 (named nil)
2268 (forms nil)
2269 pred-form pred-check)
2270 (if (stringp (car descs))
2271 (push (list 'put (list 'quote name) '(quote structure-documentation)
2272 (pop descs)) forms))
2273 (setq descs (cons '(cl-tag-slot)
2274 (mapcar (function (lambda (x) (if (consp x) x (list x))))
2275 descs)))
2276 (while opts
2277 (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
2278 (args (cdr-safe (pop opts))))
2279 (cond ((eq opt :conc-name)
2280 (if args
2281 (setq conc-name (if (car args)
2282 (symbol-name (car args)) ""))))
2283 ((eq opt :constructor)
2284 (if (cdr args)
2285 (progn
2286 ;; If this defines a constructor of the same name as
2287 ;; the default one, don't define the default.
2288 (if (eq (car args) constructor)
2289 (setq constructor nil))
2290 (push args constrs))
2291 (if args (setq constructor (car args)))))
2292 ((eq opt :copier)
2293 (if args (setq copier (car args))))
2294 ((eq opt :predicate)
2295 (if args (setq predicate (car args))))
2296 ((eq opt :include)
2297 (setq include (car args)
2298 include-descs (mapcar (function
2299 (lambda (x)
2300 (if (consp x) x (list x))))
2301 (cdr args))))
2302 ((eq opt :print-function)
2303 (setq print-func (car args)))
2304 ((eq opt :type)
2305 (setq type (car args)))
2306 ((eq opt :named)
2307 (setq named t))
2308 ((eq opt :initial-offset)
2309 (setq descs (nconc (make-list (car args) '(cl-skip-slot))
2310 descs)))
2311 (t
2312 (error "Slot option %s unrecognized" opt)))))
2313 (if print-func
2314 (setq print-func (list 'progn
2315 (list 'funcall (list 'function print-func)
2316 'cl-x 'cl-s 'cl-n) t))
2317 (or type (and include (not (get include 'cl-struct-print)))
2318 (setq print-auto t
2319 print-func (and (or (not (or include type)) (null print-func))
2320 (list 'progn
2321 (list 'princ (format "#S(%s" name)
2322 'cl-s))))))
2323 (if include
2324 (let ((inc-type (get include 'cl-struct-type))
2325 (old-descs (get include 'cl-struct-slots)))
2326 (or inc-type (error "%s is not a struct name" include))
2327 (and type (not (eq (car inc-type) type))
2328 (error ":type disagrees with :include for %s" name))
2329 (while include-descs
2330 (setcar (memq (or (assq (caar include-descs) old-descs)
2331 (error "No slot %s in included struct %s"
2332 (caar include-descs) include))
2333 old-descs)
2334 (pop include-descs)))
2335 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2336 type (car inc-type)
2337 named (assq 'cl-tag-slot descs))
2338 (if (cadr inc-type) (setq tag name named t))
2339 (let ((incl include))
2340 (while incl
2341 (push (list 'pushnew (list 'quote tag)
2342 (intern (format "cl-struct-%s-tags" incl)))
2343 forms)
2344 (setq incl (get incl 'cl-struct-include)))))
2345 (if type
2346 (progn
2347 (or (memq type '(vector list))
2348 (error "Invalid :type specifier: %s" type))
2349 (if named (setq tag name)))
2350 (setq type 'vector named 'true)))
2351 (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
2352 (push (list 'defvar tag-symbol) forms)
2353 (setq pred-form (and named
2354 (let ((pos (- (length descs)
2355 (length (memq (assq 'cl-tag-slot descs)
2356 descs)))))
2357 (if (eq type 'vector)
2358 (list 'and '(vectorp cl-x)
2359 (list '>= '(length cl-x) (length descs))
2360 (list 'memq (list 'aref 'cl-x pos)
2361 tag-symbol))
2362 (if (= pos 0)
2363 (list 'memq '(car-safe cl-x) tag-symbol)
2364 (list 'and '(consp cl-x)
2365 (list 'memq (list 'nth pos 'cl-x)
2366 tag-symbol))))))
2367 pred-check (and pred-form (> safety 0)
2368 (if (and (eq (caadr pred-form) 'vectorp)
2369 (= safety 1))
2370 (cons 'and (cdddr pred-form)) pred-form)))
2371 (let ((pos 0) (descp descs))
2372 (while descp
2373 (let* ((desc (pop descp))
2374 (slot (car desc)))
2375 (if (memq slot '(cl-tag-slot cl-skip-slot))
2376 (progn
2377 (push nil slots)
2378 (push (and (eq slot 'cl-tag-slot) (list 'quote tag))
2379 defaults))
2380 (if (assq slot descp)
2381 (error "Duplicate slots named %s in %s" slot name))
2382 (let ((accessor (intern (format "%s%s" conc-name slot))))
2383 (push slot slots)
2384 (push (nth 1 desc) defaults)
2385 (push (list*
2386 'defsubst* accessor '(cl-x)
2387 (append
2388 (and pred-check
2389 (list (list 'or pred-check
2390 (list 'error
2391 (format "%s accessing a non-%s"
2392 accessor name)))))
2393 (list (if (eq type 'vector) (list 'aref 'cl-x pos)
2394 (if (= pos 0) '(car cl-x)
2395 (list 'nth pos 'cl-x)))))) forms)
2396 (push (cons accessor t) side-eff)
2397 (push (list 'define-setf-method accessor '(cl-x)
2398 (if (cadr (memq :read-only (cddr desc)))
2399 (list 'progn '(ignore cl-x)
2400 (list 'error
2401 (format "%s is a read-only slot"
2402 'accessor)))
2403 ;; If cl is loaded only for compilation,
2404 ;; the call to cl-struct-setf-expander would
2405 ;; cause a warning because it may not be
2406 ;; defined at run time. Suppress that warning.
2407 (list 'with-no-warnings
2408 (list 'cl-struct-setf-expander 'cl-x
2409 (list 'quote name) (list 'quote accessor)
2410 (and pred-check (list 'quote pred-check))
2411 pos))))
2412 forms)
2413 (if print-auto
2414 (nconc print-func
2415 (list (list 'princ (format " %s" slot) 'cl-s)
2416 (list 'prin1 (list accessor 'cl-x) 'cl-s)))))))
2417 (setq pos (1+ pos))))
2418 (setq slots (nreverse slots)
2419 defaults (nreverse defaults))
2420 (and predicate pred-form
2421 (progn (push (list 'defsubst* predicate '(cl-x)
2422 (if (eq (car pred-form) 'and)
2423 (append pred-form '(t))
2424 (list 'and pred-form t))) forms)
2425 (push (cons predicate 'error-free) side-eff)))
2426 (and copier
2427 (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms)
2428 (push (cons copier t) side-eff)))
2429 (if constructor
2430 (push (list constructor
2431 (cons '&key (delq nil (copy-sequence slots))))
2432 constrs))
2433 (while constrs
2434 (let* ((name (caar constrs))
2435 (args (cadr (pop constrs)))
2436 (anames (cl-arglist-args args))
2437 (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))
2438 slots defaults)))
2439 (push (list 'defsubst* name
2440 (list* '&cl-defs (list 'quote (cons nil descs)) args)
2441 (cons type make)) forms)
2442 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2443 (push (cons name t) side-eff))))
2444 (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2445 (if print-func
2446 (push `(push
2447 ;; The auto-generated function does not pay attention to
2448 ;; the depth argument cl-n.
2449 (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
2450 (and ,pred-form ,print-func))
2451 custom-print-functions)
2452 forms))
2453 (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
2454 (push (list* 'eval-when '(compile load eval)
2455 (list 'put (list 'quote name) '(quote cl-struct-slots)
2456 (list 'quote descs))
2457 (list 'put (list 'quote name) '(quote cl-struct-type)
2458 (list 'quote (list type (eq named t))))
2459 (list 'put (list 'quote name) '(quote cl-struct-include)
2460 (list 'quote include))
2461 (list 'put (list 'quote name) '(quote cl-struct-print)
2462 print-auto)
2463 (mapcar (function (lambda (x)
2464 (list 'put (list 'quote (car x))
2465 '(quote side-effect-free)
2466 (list 'quote (cdr x)))))
2467 side-eff))
2468 forms)
2469 (cons 'progn (nreverse (cons (list 'quote name) forms)))))
2470
2471 ;;;###autoload
2472 (defun cl-struct-setf-expander (x name accessor pred-form pos)
2473 (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
2474 (list (list temp) (list x) (list store)
2475 (append '(progn)
2476 (and pred-form
2477 (list (list 'or (subst temp 'cl-x pred-form)
2478 (list 'error
2479 (format
2480 "%s storing a non-%s" accessor name)))))
2481 (list (if (eq (car (get name 'cl-struct-type)) 'vector)
2482 (list 'aset temp pos store)
2483 (list 'setcar
2484 (if (<= pos 5)
2485 (let ((xx temp))
2486 (while (>= (setq pos (1- pos)) 0)
2487 (setq xx (list 'cdr xx)))
2488 xx)
2489 (list 'nthcdr pos temp))
2490 store))))
2491 (list accessor temp))))
2492
2493
2494 ;;; Types and assertions.
2495
2496 ;;;###autoload
2497 (defmacro deftype (name arglist &rest body)
2498 "Define NAME as a new data type.
2499 The type name can then be used in `typecase', `check-type', etc."
2500 (list 'eval-when '(compile load eval)
2501 (cl-transform-function-property
2502 name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body))))
2503
2504 (defun cl-make-type-test (val type)
2505 (if (symbolp type)
2506 (cond ((get type 'cl-deftype-handler)
2507 (cl-make-type-test val (funcall (get type 'cl-deftype-handler))))
2508 ((memq type '(nil t)) type)
2509 ((eq type 'null) `(null ,val))
2510 ((eq type 'atom) `(atom ,val))
2511 ((eq type 'float) `(floatp-safe ,val))
2512 ((eq type 'real) `(numberp ,val))
2513 ((eq type 'fixnum) `(integerp ,val))
2514 ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef
2515 ((memq type '(character string-char)) `(characterp ,val))
2516 (t
2517 (let* ((name (symbol-name type))
2518 (namep (intern (concat name "p"))))
2519 (if (fboundp namep) (list namep val)
2520 (list (intern (concat name "-p")) val)))))
2521 (cond ((get (car type) 'cl-deftype-handler)
2522 (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
2523 (cdr type))))
2524 ((memq (car type) '(integer float real number))
2525 (delq t (list 'and (cl-make-type-test val (car type))
2526 (if (memq (cadr type) '(* nil)) t
2527 (if (consp (cadr type)) (list '> val (caadr type))
2528 (list '>= val (cadr type))))
2529 (if (memq (caddr type) '(* nil)) t
2530 (if (consp (caddr type)) (list '< val (caaddr type))
2531 (list '<= val (caddr type)))))))
2532 ((memq (car type) '(and or not))
2533 (cons (car type)
2534 (mapcar (function (lambda (x) (cl-make-type-test val x)))
2535 (cdr type))))
2536 ((memq (car type) '(member member*))
2537 (list 'and (list 'member* val (list 'quote (cdr type))) t))
2538 ((eq (car type) 'satisfies) (list (cadr type) val))
2539 (t (error "Bad type spec: %s" type)))))
2540
2541 ;;;###autoload
2542 (defun typep (object type) ; See compiler macro below.
2543 "Check that OBJECT is of type TYPE.
2544 TYPE is a Common Lisp-style type specifier."
2545 (eval (cl-make-type-test 'object type)))
2546
2547 ;;;###autoload
2548 (defmacro check-type (form type &optional string)
2549 "Verify that FORM is of type TYPE; signal an error if not.
2550 STRING is an optional description of the desired type."
2551 (and (or (not (cl-compiling-file))
2552 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2553 (let* ((temp (if (cl-simple-expr-p form 3)
2554 form (make-symbol "--cl-var--")))
2555 (body (list 'or (cl-make-type-test temp type)
2556 (list 'signal '(quote wrong-type-argument)
2557 (list 'list (or string (list 'quote type))
2558 temp (list 'quote form))))))
2559 (if (eq temp form) (list 'progn body nil)
2560 (list 'let (list (list temp form)) body nil)))))
2561
2562 ;;;###autoload
2563 (defmacro assert (form &optional show-args string &rest args)
2564 "Verify that FORM returns non-nil; signal an error if not.
2565 Second arg SHOW-ARGS means to include arguments of FORM in message.
2566 Other args STRING and ARGS... are arguments to be passed to `error'.
2567 They are not evaluated unless the assertion fails. If STRING is
2568 omitted, a default message listing FORM itself is used."
2569 (and (or (not (cl-compiling-file))
2570 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2571 (let ((sargs (and show-args
2572 (delq nil (mapcar
2573 (lambda (x)
2574 (unless (cl-const-expr-p x)
2575 x))
2576 (cdr form))))))
2577 (list 'progn
2578 (list 'or form
2579 (if string
2580 (list* 'error string (append sargs args))
2581 (list 'signal '(quote cl-assertion-failed)
2582 (list* 'list (list 'quote form) sargs))))
2583 nil))))
2584
2585 ;;; Compiler macros.
2586
2587 ;;;###autoload
2588 (defmacro define-compiler-macro (func args &rest body)
2589 "Define a compiler-only macro.
2590 This is like `defmacro', but macro expansion occurs only if the call to
2591 FUNC is compiled (i.e., not interpreted). Compiler macros should be used
2592 for optimizing the way calls to FUNC are compiled; the form returned by
2593 BODY should do the same thing as a call to the normal function called
2594 FUNC, though possibly more efficiently. Note that, like regular macros,
2595 compiler macros are expanded repeatedly until no further expansions are
2596 possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
2597 original function call alone by declaring an initial `&whole foo' parameter
2598 and then returning foo."
2599 (let ((p args) (res nil))
2600 (while (consp p) (push (pop p) res))
2601 (setq args (nconc (nreverse res) (and p (list '&rest p)))))
2602 (list 'eval-when '(compile load eval)
2603 (cl-transform-function-property
2604 func 'cl-compiler-macro
2605 (cons (if (memq '&whole args) (delq '&whole args)
2606 (cons '_cl-whole-arg args)) body))
2607 (list 'or (list 'get (list 'quote func) '(quote byte-compile))
2608 (list 'progn
2609 (list 'put (list 'quote func) '(quote byte-compile)
2610 '(quote cl-byte-compile-compiler-macro))
2611 ;; This is so that describe-function can locate
2612 ;; the macro definition.
2613 (list 'let
2614 (list (list
2615 'file
2616 (or buffer-file-name
2617 (and (boundp 'byte-compile-current-file)
2618 (stringp byte-compile-current-file)
2619 byte-compile-current-file))))
2620 (list 'if 'file
2621 (list 'put (list 'quote func)
2622 '(quote compiler-macro-file)
2623 '(purecopy (file-name-nondirectory file)))))))))
2624
2625 ;;;###autoload
2626 (defun compiler-macroexpand (form)
2627 (while
2628 (let ((func (car-safe form)) (handler nil))
2629 (while (and (symbolp func)
2630 (not (setq handler (get func 'cl-compiler-macro)))
2631 (fboundp func)
2632 (or (not (eq (car-safe (symbol-function func)) 'autoload))
2633 (load (nth 1 (symbol-function func)))))
2634 (setq func (symbol-function func)))
2635 (and handler
2636 (not (eq form (setq form (apply handler form (cdr form))))))))
2637 form)
2638
2639 (defun cl-byte-compile-compiler-macro (form)
2640 (if (eq form (setq form (compiler-macroexpand form)))
2641 (byte-compile-normal-call form)
2642 (byte-compile-form form)))
2643
2644 ;; Optimize away unused block-wrappers.
2645
2646 (defvar cl-active-block-names nil)
2647
2648 (define-compiler-macro cl-block-wrapper (cl-form)
2649 (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
2650 (cl-active-block-names (cons cl-entry cl-active-block-names))
2651 (cl-body (macroexpand-all ;Performs compiler-macro expansions.
2652 (cons 'progn (cddr cl-form))
2653 macroexpand-all-environment)))
2654 ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
2655 ;; to indicate that this return value is already fully expanded.
2656 (if (cdr cl-entry)
2657 `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
2658 cl-body)))
2659
2660 (define-compiler-macro cl-block-throw (cl-tag cl-value)
2661 (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
2662 (if cl-found (setcdr cl-found t)))
2663 `(throw ,cl-tag ,cl-value))
2664
2665 ;;;###autoload
2666 (defmacro defsubst* (name args &rest body)
2667 "Define NAME as a function.
2668 Like `defun', except the function is automatically declared `inline',
2669 ARGLIST allows full Common Lisp conventions, and BODY is implicitly
2670 surrounded by (block NAME ...).
2671
2672 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
2673 (let* ((argns (cl-arglist-args args)) (p argns)
2674 (pbody (cons 'progn body))
2675 (unsafe (not (cl-safe-expr-p pbody))))
2676 (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
2677 (list 'progn
2678 (if p nil ; give up if defaults refer to earlier args
2679 (list 'define-compiler-macro name
2680 (if (memq '&key args)
2681 (list* '&whole 'cl-whole '&cl-quote args)
2682 (cons '&cl-quote args))
2683 (list* 'cl-defsubst-expand (list 'quote argns)
2684 (list 'quote (list* 'block name body))
2685 ;; We used to pass `simple' as
2686 ;; (not (or unsafe (cl-expr-access-order pbody argns)))
2687 ;; But this is much too simplistic since it
2688 ;; does not pay attention to the argvs (and
2689 ;; cl-expr-access-order itself is also too naive).
2690 nil
2691 (and (memq '&key args) 'cl-whole) unsafe argns)))
2692 (list* 'defun* name args body))))
2693
2694 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
2695 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
2696 (if (cl-simple-exprs-p argvs) (setq simple t))
2697 (let* ((substs ())
2698 (lets (delq nil
2699 (mapcar* (function
2700 (lambda (argn argv)
2701 (if (or simple (cl-const-expr-p argv))
2702 (progn (push (cons argn argv) substs)
2703 (and unsafe (list argn argv)))
2704 (list argn argv))))
2705 argns argvs))))
2706 ;; FIXME: `sublis/subst' will happily substitute the symbol
2707 ;; `argn' in places where it's not used as a reference
2708 ;; to a variable.
2709 ;; FIXME: `sublis/subst' will happily copy `argv' to a different
2710 ;; scope, leading to name capture.
2711 (setq body (cond ((null substs) body)
2712 ((null (cdr substs))
2713 (subst (cdar substs) (caar substs) body))
2714 (t (sublis substs body))))
2715 (if lets (list 'let lets body) body))))
2716
2717
2718 ;; Compile-time optimizations for some functions defined in this package.
2719 ;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
2720 ;; mainly to make sure these macros will be present.
2721
2722 (put 'eql 'byte-compile nil)
2723 (define-compiler-macro eql (&whole form a b)
2724 (cond ((eq (cl-const-expr-p a) t)
2725 (let ((val (cl-const-expr-val a)))
2726 (if (and (numberp val) (not (integerp val)))
2727 (list 'equal a b)
2728 (list 'eq a b))))
2729 ((eq (cl-const-expr-p b) t)
2730 (let ((val (cl-const-expr-val b)))
2731 (if (and (numberp val) (not (integerp val)))
2732 (list 'equal a b)
2733 (list 'eq a b))))
2734 ((cl-simple-expr-p a 5)
2735 (list 'if (list 'numberp a)
2736 (list 'equal a b)
2737 (list 'eq a b)))
2738 ((and (cl-safe-expr-p a)
2739 (cl-simple-expr-p b 5))
2740 (list 'if (list 'numberp b)
2741 (list 'equal a b)
2742 (list 'eq a b)))
2743 (t form)))
2744
2745 (define-compiler-macro member* (&whole form a list &rest keys)
2746 (let ((test (and (= (length keys) 2) (eq (car keys) :test)
2747 (cl-const-expr-val (nth 1 keys)))))
2748 (cond ((eq test 'eq) (list 'memq a list))
2749 ((eq test 'equal) (list 'member a list))
2750 ((or (null keys) (eq test 'eql)) (list 'memql a list))
2751 (t form))))
2752
2753 (define-compiler-macro assoc* (&whole form a list &rest keys)
2754 (let ((test (and (= (length keys) 2) (eq (car keys) :test)
2755 (cl-const-expr-val (nth 1 keys)))))
2756 (cond ((eq test 'eq) (list 'assq a list))
2757 ((eq test 'equal) (list 'assoc a list))
2758 ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
2759 (if (floatp-safe (cl-const-expr-val a))
2760 (list 'assoc a list) (list 'assq a list)))
2761 (t form))))
2762
2763 (define-compiler-macro adjoin (&whole form a list &rest keys)
2764 (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
2765 (not (memq :key keys)))
2766 (list 'if (list* 'member* a list keys) list (list 'cons a list))
2767 form))
2768
2769 (define-compiler-macro list* (arg &rest others)
2770 (let* ((args (reverse (cons arg others)))
2771 (form (car args)))
2772 (while (setq args (cdr args))
2773 (setq form (list 'cons (car args) form)))
2774 form))
2775
2776 (define-compiler-macro get* (sym prop &optional def)
2777 (if def
2778 (list 'getf (list 'symbol-plist sym) prop def)
2779 (list 'get sym prop)))
2780
2781 (define-compiler-macro typep (&whole form val type)
2782 (if (cl-const-expr-p type)
2783 (let ((res (cl-make-type-test val (cl-const-expr-val type))))
2784 (if (or (memq (cl-expr-contains res val) '(nil 1))
2785 (cl-simple-expr-p val)) res
2786 (let ((temp (make-symbol "--cl-var--")))
2787 (list 'let (list (list temp val)) (subst temp val res)))))
2788 form))
2789
2790
2791 (mapc (lambda (y)
2792 (put (car y) 'side-effect-free t)
2793 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
2794 (put (car y) 'cl-compiler-macro
2795 `(lambda (w x)
2796 ,(if (symbolp (cadr y))
2797 `(list ',(cadr y)
2798 (list ',(caddr y) x))
2799 (cons 'list (cdr y))))))
2800 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
2801 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
2802 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
2803 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
2804 (caaar car caar) (caadr car cadr) (cadar car cdar)
2805 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
2806 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
2807 (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
2808 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
2809 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
2810 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
2811 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
2812
2813 ;;; Things that are inline.
2814 (proclaim '(inline floatp-safe acons map concatenate notany notevery
2815 cl-set-elt revappend nreconc gethash))
2816
2817 ;;; Things that are side-effect-free.
2818 (mapc (lambda (x) (put x 'side-effect-free t))
2819 '(oddp evenp signum last butlast ldiff pairlis gcd lcm
2820 isqrt floor* ceiling* truncate* round* mod* rem* subseq
2821 list-length get* getf))
2822
2823 ;;; Things that are side-effect-and-error-free.
2824 (mapc (lambda (x) (put x 'side-effect-free 'error-free))
2825 '(eql floatp-safe list* subst acons equalp random-state-p
2826 copy-tree sublis))
2827
2828
2829 (run-hooks 'cl-macs-load-hook)
2830
2831 ;; Local variables:
2832 ;; byte-compile-dynamic: t
2833 ;; byte-compile-warnings: (not cl-functions)
2834 ;; generated-autoload-file: "cl-loaddefs.el"
2835 ;; End:
2836
2837 ;;; cl-macs.el ends here