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