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