diff options
| author | Daniel Colascione <dancol@dancol.org> | 2014-04-20 17:03:44 -0700 |
|---|---|---|
| committer | Daniel Colascione <dancol@dancol.org> | 2014-04-20 17:03:44 -0700 |
| commit | 6d25ce843f93d105576841c220e8260d3017644f (patch) | |
| tree | 5b396efe43c4a68bf2b055cc256d1f13acdf933f | |
| parent | c3be603e8fdad37084cf7ae4806dbd916a81a83e (diff) | |
| download | emacs-6d25ce843f93d105576841c220e8260d3017644f.tar.gz | |
Untabify cl-macs.ellost+found/6d25ce843f93d105576841c220e8260d3017644f
| -rw-r--r-- | lisp/ChangeLog | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 1626 |
2 files changed, 817 insertions, 813 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1b8693af3ac..b9d6712e09b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2014-04-21 Daniel Colascione <dancol@dancol.org> + + * emacs-lisp/cl-macs.el: Untabify file. + 2014-04-20 Daniel Colascione <dancol@dancol.org> * vc/vc.el (vc-root-dir): New public autoloaded function for diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5fc8c9f9a42..9658aa6e59f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -65,7 +65,7 @@ ;;;###autoload (defun cl--compiler-macro-list* (_form arg &rest others) (let* ((args (reverse (cons arg others))) - (form (car args))) + (form (car args))) (while (setq args (cdr args)) (setq form `(cons ,(car args) ,form))) form)) @@ -90,22 +90,22 @@ ;; macro expanders to optimize the results in certain common cases. (defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max - car-safe cdr-safe progn prog1 prog2)) + car-safe cdr-safe progn prog1 prog2)) (defconst cl--safe-funcs '(* / % length memq list vector vectorp - < > <= >= = error)) + < > <= >= = error)) (defun cl--simple-expr-p (x &optional size) "Check if no side effects, and executes quickly." (or size (setq size 10)) (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) - (or (memq (car x) cl--simple-funcs) - (get (car x) 'side-effect-free)) - (progn - (setq size (1- size)) - (while (and (setq x (cdr x)) - (setq size (cl--simple-expr-p (car x) size)))) - (and (null x) (>= size 0) size))) + (or (memq (car x) cl--simple-funcs) + (get (car x) 'side-effect-free)) + (progn + (setq size (1- size)) + (while (and (setq x (cdr x)) + (setq size (cl--simple-expr-p (car x) size)))) + (and (null x) (>= size 0) size))) (and (> size 0) (1- size)))) (defun cl--simple-exprs-p (xs) @@ -117,22 +117,22 @@ "Check if no side effects." (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) (and (symbolp (car x)) - (or (memq (car x) cl--simple-funcs) - (memq (car x) cl--safe-funcs) - (get (car x) 'side-effect-free)) - (progn - (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) - (null x))))) + (or (memq (car x) cl--simple-funcs) + (memq (car x) cl--safe-funcs) + (get (car x) 'side-effect-free)) + (progn + (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) + (null x))))) ;;; Check if constant (i.e., no side effects or dependencies). (defun cl--const-expr-p (x) (cond ((consp x) - (or (eq (car x) 'quote) - (and (memq (car x) '(function cl-function)) - (or (symbolp (nth 1 x)) - (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) - ((symbolp x) (and (memq x '(nil t)) t)) - (t t))) + (or (eq (car x) 'quote) + (and (memq (car x) '(function cl-function)) + (or (symbolp (nth 1 x)) + (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) + ((symbolp x) (and (memq x '(nil t)) t)) + (t t))) (defun cl--const-expr-val (x &optional environment default) "Return the value of X known at compile-time. @@ -151,13 +151,13 @@ ENVIRONMENT." ;; non-macroexpanded code, so it may also miss some occurrences that would ;; only appear in the expanded code. (cond ((equal y x) 1) - ((and (consp x) (not (memq (car x) '(quote function cl-function)))) - (let ((sum 0)) - (while (consp x) - (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) - (setq sum (+ sum (or (cl--expr-contains x y) 0))) - (and (> sum 0) sum))) - (t nil))) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) + (let ((sum 0)) + (while (consp x) + (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl--expr-contains x y) 0))) + (and (> sum 0) sum))) + (t nil))) (defun cl--expr-contains-any (x y) (while (and y (not (cl--expr-contains x (car y)))) (pop y)) @@ -176,9 +176,9 @@ ENVIRONMENT." "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) - (num (if (integerp prefix) prefix - (prog1 cl--gensym-counter - (setq cl--gensym-counter (1+ cl--gensym-counter)))))) + (num (if (integerp prefix) prefix + (prog1 cl--gensym-counter + (setq cl--gensym-counter (1+ cl--gensym-counter)))))) (make-symbol (format "%s%d" pfix num)))) ;;;###autoload @@ -186,7 +186,7 @@ The name is made by appending a number to PREFIX, default \"G\"." "Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) - name) + name) (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter))) (setq cl--gensym-counter (1+ cl--gensym-counter))) (intern name))) @@ -205,9 +205,9 @@ The name is made by appending a number to PREFIX, default \"G\"." [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] [&optional ["&rest" arg]] [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] - &optional "&allow-other-keys"]] + &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (symbolp &optional def-form) symbolp]] ))) (def-edebug-spec cl-&optional-arg @@ -231,42 +231,42 @@ and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." (let* ((args (car form)) (body (cdr form)) (orig-args args) - (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (header nil) (simple-args nil)) (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) + (memq (car-safe (car body)) '(interactive declare cl-declare))) (push (pop body) header)) (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) (if (setq cl--bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) + (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) (let* ((p (memq '&environment args)) (v (cadr p)) (env-exp 'macroexpand-all-environment)) (if p (setq args (nconc (delq (car p) (delq v args)) (list '&aux (list v env-exp)))))) (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) + (not (memq (car args) '(nil &rest &body &key &aux))) + (not (and (eq (car args) '&optional) + (or cl--bind-defs (consp (cadr args)))))) (push (pop args) simple-args)) (or (eq cl--bind-block 'cl-none) - (setq body (list `(cl-block ,cl--bind-block ,@body)))) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) (if (memq '&optional simple-args) (push '&optional args)) (cl--do-arglist args nil (- (length simple-args) (if (memq '&optional simple-args) 1 0))) (setq cl--bind-lets (nreverse cl--bind-lets)) (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) + (nconc (nreverse simple-args) + (list '&rest (car (pop cl--bind-lets)))) + (nconc (let ((hdr (nreverse header))) ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. @@ -280,7 +280,7 @@ FORM is of the form (ARGS . BODY)." (format "%S" (cons 'fn (cl--make-usage-args orig-args))))) hdr))) - (list `(let* ,cl--bind-lets + (list `(let* ,cl--bind-lets ,@(nreverse cl--bind-forms) ,@body))))))) @@ -301,7 +301,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (doc-string 3) (indent 2)) (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defun ,name ,@(cdr res)))) + (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) ;; The lambda list for macros is different from that of normal lambdas. @@ -312,15 +312,15 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (([&optional "&environment" arg] [&rest cl-macro-arg] [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] [&optional [[&or "&rest" "&body"] cl-macro-arg]] [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (symbolp &optional def-form) symbolp]] [&optional "&environment" arg] ))) @@ -331,15 +331,15 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (([&optional "&whole" arg] ;; only allowed at lower levels [&rest cl-macro-arg] [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] [&optional [[&or "&rest" "&body"] cl-macro-arg]] [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (symbolp &optional def-form) symbolp]] . [&or arg nil]))) ;;;###autoload @@ -354,14 +354,14 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (doc-string 3) (indent 2)) (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defmacro ,name ,@(cdr res)))) + (form `(defmacro ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) (def-edebug-spec cl-lambda-expr (&define ("lambda" cl-lambda-list - ;;cl-declarations-or-string - ;;[&optional ("interactive" interactive)] - def-body))) + ;;cl-declarations-or-string + ;;[&optional ("interactive" interactive)] + def-body))) ;; Redefine function-form to also match cl-function (def-edebug-spec function-form @@ -379,8 +379,8 @@ its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) - (form `(function (lambda . ,(cdr res))))) - (if (car res) `(progn ,(car res) ,form) form)) + (form `(function (lambda . ,(cdr res))))) + (if (car res) `(progn ,(car res) ,form) form)) `(function ,func))) (declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) @@ -432,63 +432,63 @@ its argument list allows full Common Lisp conventions." (defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) - (error "Invalid argument name: %s" args) - (push (list args expr) cl--bind-lets)) + (error "Invalid argument name: %s" args) + (push (list args expr) cl--bind-lets)) (setq args (cl-copy-list args)) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) (let ((save-args args) - (restarg (memq '&rest args)) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) - (keys nil) - (laterarg nil) (exactarg nil) minarg) + (restarg (memq '&rest args)) + (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (keys nil) + (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) (if (listp (cadr restarg)) - (setq restarg (make-symbol "--cl-rest--")) - (setq restarg (cadr restarg))) + (setq restarg (make-symbol "--cl-rest--")) + (setq restarg (cadr restarg))) (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) - (push (list (cl--pop2 args) restarg) cl--bind-lets)) + (push (list (cl--pop2 args) restarg) cl--bind-lets)) (let ((p args)) - (setq minarg restarg) - (while (and p (not (memq (car p) cl--lambda-list-keywords))) - (or (eq p args) (setq minarg (list 'cdr minarg))) - (setq p (cdr p))) - (if (memq (car p) '(nil &aux)) - (setq minarg `(= (length ,restarg) + (setq minarg restarg) + (while (and p (not (memq (car p) cl--lambda-list-keywords))) + (or (eq p args) (setq minarg (list 'cdr minarg))) + (setq p (cdr p))) + (if (memq (car p) '(nil &aux)) + (setq minarg `(= (length ,restarg) ,(length (cl-ldiff args p))) - exactarg (not (eq args p))))) + exactarg (not (eq args p))))) (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) - restarg))) - (cl--do-arglist - (pop args) - (if (or laterarg (= safety 0)) poparg - `(if ,minarg ,poparg + (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) + restarg))) + (cl--do-arglist + (pop args) + (if (or laterarg (= safety 0)) poparg + `(if ,minarg ,poparg (signal 'wrong-number-of-arguments (list ,(and (not (eq cl--bind-block 'cl-none)) `',cl--bind-block) (length ,restarg))))))) - (setq num (1+ num) laterarg t)) + (setq num (1+ num) laterarg t)) (while (and (eq (car args) '&optional) (pop args)) - (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (let ((arg (pop args))) - (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) - (let ((def (if (cdr arg) (nth 1 arg) - (or (car cl--bind-defs) - (nth 1 (assq (car arg) cl--bind-defs))))) - (poparg `(pop ,restarg))) - (and def cl--bind-enquote (setq def `',def)) - (cl--do-arglist (car arg) - (if def `(if ,restarg ,poparg ,def) poparg)) - (setq num (1+ num)))))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (let ((arg (pop args))) + (or (consp arg) (setq arg (list arg))) + (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) + (let ((def (if (cdr arg) (nth 1 arg) + (or (car cl--bind-defs) + (nth 1 (assq (car arg) cl--bind-defs))))) + (poparg `(pop ,restarg))) + (and def cl--bind-enquote (setq def `',def)) + (cl--do-arglist (car arg) + (if def `(if ,restarg ,poparg ,def) poparg)) + (setq num (1+ num)))))) (if (eq (car args) '&rest) - (let ((arg (cl--pop2 args))) - (if (consp arg) (cl--do-arglist arg restarg))) - (or (eq (car args) '&key) (= safety 0) exactarg - (push `(if ,restarg + (let ((arg (cl--pop2 args))) + (if (consp arg) (cl--do-arglist arg restarg))) + (or (eq (car args) '&key) (= safety 0) exactarg + (push `(if ,restarg (signal 'wrong-number-of-arguments (list ,(and (not (eq cl--bind-block 'cl-none)) @@ -496,10 +496,10 @@ its argument list allows full Common Lisp conventions." (+ ,num (length ,restarg))))) cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) - (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (let ((arg (pop args))) - (or (consp arg) (setq arg (list arg))) - (let* ((karg (if (consp (car arg)) (caar arg) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (let ((arg (pop args))) + (or (consp arg) (setq arg (list arg))) + (let* ((karg (if (consp (car arg)) (caar arg) (let ((name (symbol-name (car arg)))) ;; Strip a leading underscore, since it only ;; means that this argument is unused, but @@ -507,35 +507,35 @@ its argument list allows full Common Lisp conventions." (if (eq ?_ (aref name 0)) (setq name (substring name 1))) (intern (format ":%s" name))))) - (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) - (def (if (cdr arg) (cadr arg) - (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) + (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) + (def (if (cdr arg) (cadr arg) + (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) (look `(plist-member ,restarg ',karg))) - (and def cl--bind-enquote (setq def `',def)) - (if (cddr arg) - (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) - (val `(car (cdr ,temp)))) - (cl--do-arglist temp look) - (cl--do-arglist varg - `(if ,temp + (and def cl--bind-enquote (setq def `',def)) + (if (cddr arg) + (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) + (val `(car (cdr ,temp)))) + (cl--do-arglist temp look) + (cl--do-arglist varg + `(if ,temp (prog1 ,val (setq ,temp t)) ,def))) - (cl--do-arglist - varg - `(car (cdr ,(if (null def) - look - `(or ,look + (cl--do-arglist + varg + `(car (cdr ,(if (null def) + look + `(or ,look ,(if (eq (cl--const-expr-p def) t) - `'(nil ,(cl--const-expr-val + `'(nil ,(cl--const-expr-val def macroexpand-all-environment)) - `(list nil ,def)))))))) - (push karg keys))))) + `(list nil ,def)))))))) + (push karg keys))))) (setq keys (nreverse keys)) (or (and (eq (car args) '&allow-other-keys) (pop args)) - (null keys) (= safety 0) - (let* ((var (make-symbol "--cl-keys--")) - (allow '(:allow-other-keys)) - (check `(while ,var + (null keys) (= safety 0) + (let* ((var (make-symbol "--cl-keys--")) + (allow '(:allow-other-keys)) + (check `(while ,var (cond ((memq (car ,var) ',(append keys allow)) (setq ,var (cdr (cdr ,var)))) @@ -546,27 +546,27 @@ its argument list allows full Common Lisp conventions." ,(format "Keyword argument %%s not one of %s" keys) (car ,var))))))) - (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (if (consp (car args)) - (if (and cl--bind-enquote (cl-cadar args)) - (cl--do-arglist (caar args) - `',(cadr (pop args))) - (cl--do-arglist (caar args) (cadr (pop args)))) - (cl--do-arglist (pop args) nil)))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (if (consp (car args)) + (if (and cl--bind-enquote (cl-cadar args)) + (cl--do-arglist (caar args) + `',(cadr (pop args))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) (defun cl--arglist-args (args) (if (nlistp args) (list args) (let ((res nil) (kind nil) arg) (while (consp args) - (setq arg (pop args)) - (if (memq arg cl--lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl--arglist-args arg)))))) + (setq arg (pop args)) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) + (if (eq arg '&cl-defs) (pop args) + (and (consp arg) kind (setq arg (car arg))) + (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) + (setq res (nconc res (cl--arglist-args arg)))))) (nconc res (and args (list args)))))) ;;;###autoload @@ -575,10 +575,10 @@ its argument list allows full Common Lisp conventions." (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) - (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) + (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) (cl--do-arglist (or args '(&aux)) expr) (append '(progn) cl--bind-inits - (list `(let* ,(nreverse cl--bind-lets) + (list `(let* ,(nreverse cl--bind-lets) ,@(nreverse cl--bind-forms) ,@body))))) @@ -596,28 +596,28 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" (declare (indent 1) (debug (sexp body))) (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) - (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. + (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) - (cl--not-toplevel t)) - (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) - `(if nil nil ,@body)) - (progn (if comp (eval (cons 'progn body))) nil))) + (cl--not-toplevel t)) + (if (or (memq 'load when) (memq :load-toplevel when)) + (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + `(if nil nil ,@body)) + (progn (if comp (eval (cons 'progn body))) nil))) (and (or (memq 'eval when) (memq :execute when)) - (cons 'progn body)))) + (cons 'progn body)))) (defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand - form (cons '(cl-eval-when) byte-compile-macro-environment)))) + form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) - ((eq (car-safe form) 'cl-eval-when) - (let ((when (nth 1 form))) - (if (or (memq 'eval when) (memq :execute when)) - `(cl-eval-when (compile ,@when) ,@(cddr form)) - form))) - (t (eval form) form))) + (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + ((eq (car-safe form) 'cl-eval-when) + (let ((when (nth 1 form))) + (if (or (memq 'eval when) (memq :execute when)) + `(cl-eval-when (compile ,@when) ,@(cddr form)) + form))) + (t (eval form) form))) ;;;###autoload (defmacro cl-load-time-value (form &optional _read-only) @@ -626,17 +626,17 @@ The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) (if (cl--compiling-file) (let* ((temp (cl-gentemp "--cl-load-time--")) - (set `(setq ,temp ,form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) - (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - `(lambda (form) + (set `(setq ,temp ,form))) + (if (and (fboundp 'byte-compile-file-form-defmumble) + (boundp 'this-kind) (boundp 'that-one)) + (fset 'byte-compile-file-form + `(lambda (form) (fset 'byte-compile-file-form ',(symbol-function 'byte-compile-file-form)) (byte-compile-file-form ',set) (byte-compile-file-form form))) - (print set (symbol-value 'byte-compile--outbuffer))) - `(symbol-value ',temp)) + (print set (symbol-value 'byte-compile--outbuffer))) + `(symbol-value ',temp)) `',(eval form))) @@ -654,27 +654,27 @@ Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (head-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-ecase failed: %s, %s" + (head-list nil) + (body (cons + 'cond + (mapcar + (function + (lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" ,temp ',(reverse head-list))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - `(cl-member ,temp ',(car c))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (push (car c) head-list) - `(eql ,temp ',(car c)))) - (or (cdr c) '(nil))))) - clauses)))) + ((listp (car c)) + (setq head-list (append (car c) head-list)) + `(cl-member ,temp ',(car c))) + (t + (if (memq (car c) head-list) + (error "Duplicate key in case: %s" + (car c))) + (push (car c) head-list) + `(eql ,temp ',(car c)))) + (or (cdr c) '(nil))))) + clauses)))) (if (eq temp expr) body `(let ((,temp ,expr)) ,body)))) @@ -697,21 +697,21 @@ final clause, and matches if no other keys match. (declare (indent 1) (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (type-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-etypecase failed: %s, %s" + (type-list nil) + (body (cons + 'cond + (mapcar + (function + (lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" ,temp ',(reverse type-list))) - (t - (push (car c) type-list) - (cl--make-type-test temp (car c)))) - (or (cdr c) '(nil))))) - clauses)))) + (t + (push (car c) type-list) + (cl--make-type-test temp (car c)))) + (or (cdr c) '(nil))))) + clauses)))) (if (eq temp expr) body `(let ((,temp ,expr)) ,body)))) @@ -833,12 +833,12 @@ For more details, see Info node `(cl)Loop Facility'. (delq nil (delq t (cl-copy-list loop-args)))))) `(cl-block nil (while t ,@loop-args)) (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) - (cl--loop-body nil) (cl--loop-steps nil) - (cl--loop-result nil) (cl--loop-result-explicit nil) - (cl--loop-result-var nil) (cl--loop-finish-flag nil) - (cl--loop-accum-var nil) (cl--loop-accum-vars nil) - (cl--loop-initially nil) (cl--loop-finally nil) - (cl--loop-iterator-function nil) (cl--loop-first-flag nil) + (cl--loop-body nil) (cl--loop-steps nil) + (cl--loop-result nil) (cl--loop-result-explicit nil) + (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-accum-var nil) (cl--loop-accum-vars nil) + (cl--loop-initially nil) (cl--loop-finally nil) + (cl--loop-iterator-function nil) (cl--loop-first-flag nil) (cl--loop-symbol-macs nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: @@ -866,19 +866,19 @@ For more details, see Info node `(cl)Loop Facility'. (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl--parse-loop-clause)) (if cl--loop-finish-flag - (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) + (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) (if cl--loop-first-flag - (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) - (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) + (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) + (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) (let* ((epilogue (nconc (nreverse cl--loop-finally) - (list (or cl--loop-result-explicit + (list (or cl--loop-result-explicit cl--loop-result)))) - (ands (cl--loop-build-ands (nreverse cl--loop-body))) - (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) - (body (append - (nreverse cl--loop-initially) - (list (if cl--loop-iterator-function - `(cl-block --cl-finish-- + (ands (cl--loop-build-ands (nreverse cl--loop-body))) + (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) + (body (append + (nreverse cl--loop-initially) + (list (if cl--loop-iterator-function + `(cl-block --cl-finish-- ,(funcall cl--loop-iterator-function (if (eq (car ands) t) while-body (cons `(or ,(car ands) @@ -886,26 +886,26 @@ For more details, see Info node `(cl)Loop Facility'. --cl-finish-- nil)) while-body)))) - `(while ,(car ands) ,@while-body))) - (if cl--loop-finish-flag - (if (equal epilogue '(nil)) (list cl--loop-result-var) - `((if ,cl--loop-finish-flag - (progn ,@epilogue) ,cl--loop-result-var))) - epilogue)))) - (if cl--loop-result-var + `(while ,(car ands) ,@while-body))) + (if cl--loop-finish-flag + (if (equal epilogue '(nil)) (list cl--loop-result-var) + `((if ,cl--loop-finish-flag + (progn ,@epilogue) ,cl--loop-result-var))) + epilogue)))) + (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) - (while cl--loop-bindings - (if (cdar cl--loop-bindings) - (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) - (let ((lets nil)) - (while (and cl--loop-bindings - (not (cdar cl--loop-bindings))) - (push (car (pop cl--loop-bindings)) lets)) - (setq body (list (cl--loop-let lets body nil)))))) - (if cl--loop-symbol-macs - (setq body + (while cl--loop-bindings + (if (cdar cl--loop-bindings) + (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) + (let ((lets nil)) + (while (and cl--loop-bindings + (not (cdar cl--loop-bindings))) + (push (car (pop cl--loop-bindings)) lets)) + (setq body (list (cl--loop-let lets body nil)))))) + (if cl--loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) - `(cl-block ,cl--loop-name ,@body))))) + `(cl-block ,cl--loop-name ,@body))))) ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where @@ -930,8 +930,8 @@ For more details, see Info node `(cl)Loop Facility'. ;; loop-type-spec ;; [&optional ["=" form]] ;; &rest ["and" loop-var -;; loop-type-spec -;; [&optional ["=" form]]])) +;; loop-type-spec +;; [&optional ["=" form]]])) ;; (def-edebug-spec loop-for-as ;; ([&or "for" "as"] loop-for-as-subclause @@ -953,25 +953,25 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&or "of" "in" "of-ref"] form ;; &optional "using" ["index" symbolp]];; is this right? ;; [[&or "hash-key" "hash-keys" -;; "hash-value" "hash-values"] +;; "hash-value" "hash-values"] ;; [&or "of" "in"] ;; hash-table-p &optional ["using" ([&or "hash-value" "hash-values" -;; "hash-key" "hash-keys"] sexp)]] +;; "hash-key" "hash-keys"] sexp)]] ;; [[&or "symbol" "present-symbol" "external-symbol" -;; "symbols" "present-symbols" "external-symbols"] +;; "symbols" "present-symbols" "external-symbols"] ;; [&or "in" "of"] package-p] ;; ;; Extensions for Emacs Lisp, including Lucid Emacs. ;; [[&or "frame" "frames" -;; "screen" "screens" -;; "buffer" "buffers"]] +;; "screen" "screens" +;; "buffer" "buffers"]] ;; [[&or "window" "windows"] ;; [&or "of" "in"] form] ;; [[&or "overlay" "overlays" -;; "extent" "extents"] +;; "extent" "extents"] ;; [&or "of" "in"] form ;; &optional [[&or "from" "to"] form]] @@ -981,13 +981,13 @@ For more details, see Info node `(cl)Loop Facility'. ;; ["property" form]] ;; [[&or "key-code" "key-codes" -;; "key-seq" "key-seqs" -;; "key-binding" "key-bindings"] +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] ;; [&or "in" "of"] form ;; &optional ["using" ([&or "key-code" "key-codes" -;; "key-seq" "key-seqs" -;; "key-binding" "key-bindings"] -;; sexp)]] +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] +;; sexp)]] ;; ;; For arbitrary extensions, recognize anything else. ;; [symbolp &rest &or symbolp form] ;; ] @@ -1000,11 +1000,11 @@ For more details, see Info node `(cl)Loop Facility'. ;; (def-edebug-spec loop-initial-final ;; (&or ["initially" -;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. -;; &rest loop-non-atomic-expr] +;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. +;; &rest loop-non-atomic-expr] ;; ["finally" &or -;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] -;; ["return" form]])) +;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] +;; ["return" form]])) ;; (def-edebug-spec loop-and-clause ;; (loop-clause &rest ["and" loop-clause])) @@ -1014,17 +1014,17 @@ For more details, see Info node `(cl)Loop Facility'. ;; [[&or "while" "until" "always" "never" "thereis"] form] ;; [[&or "collect" "collecting" -;; "append" "appending" -;; "nconc" "nconcing" -;; "concat" "vconcat"] form -;; [&optional ["into" loop-var]]] +;; "append" "appending" +;; "nconc" "nconcing" +;; "concat" "vconcat"] form +;; [&optional ["into" loop-var]]] ;; [[&or "count" "counting" -;; "sum" "summing" -;; "maximize" "maximizing" -;; "minimize" "minimizing"] form -;; [&optional ["into" loop-var]] -;; loop-type-spec] +;; "sum" "summing" +;; "maximize" "maximizing" +;; "minimize" "minimizing"] form +;; [&optional ["into" loop-var]] +;; loop-type-spec] ;; [[&or "if" "when" "unless"] ;; form loop-and-clause @@ -1059,11 +1059,11 @@ For more details, see Info node `(cl)Loop Facility'. -(defun cl--parse-loop-clause () ; uses loop-* +(defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) - (hash-types '(hash-key hash-keys hash-value hash-values)) - (key-types '(key-code key-codes key-seq key-seqs - key-binding key-bindings))) + (hash-types '(hash-key hash-keys hash-value hash-values)) + (key-types '(key-code key-codes key-seq key-seqs + key-binding key-bindings))) (cond ((null cl--loop-args) @@ -1077,174 +1077,174 @@ For more details, see Info node `(cl)Loop Facility'. (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-initially))) + (push (pop cl--loop-args) cl--loop-initially))) ((eq word 'finally) (if (eq (car cl--loop-args) 'return) - (setq cl--loop-result-explicit + (setq cl--loop-result-explicit (or (cl--pop2 cl--loop-args) '(quote nil))) - (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) - (or (consp (car cl--loop-args)) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) - (setq cl--loop-result-explicit + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) - (while (consp (car cl--loop-args)) - (push (pop cl--loop-args) cl--loop-finally))))) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) - (ands nil)) - (while - ;; Use `cl-gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the macro-environment. - (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) - (setq word (pop cl--loop-args)) - (if (eq word 'being) (setq word (pop cl--loop-args))) - (if (memq word '(the each)) (setq word (pop cl--loop-args))) - (if (memq word '(buffer buffers)) - (setq word 'in + (ands nil)) + (while + ;; Use `cl-gensym' rather than `make-symbol'. It's important that + ;; (not (eq (symbol-name var1) (symbol-name var2))) because + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl--loop-args)) + (if (eq word 'being) (setq word (pop cl--loop-args))) + (if (memq word '(the each)) (setq word (pop cl--loop-args))) + (if (memq word '(buffer buffers)) + (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) - (cond - - ((memq word '(from downfrom upfrom to downto upto - above below by)) - (push word cl--loop-args) - (if (memq (car cl--loop-args) '(downto above)) - (error "Must specify `from' value for downward cl-loop")) - (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (cl-caddr cl--loop-args) + (cond + + ((memq word '(from downfrom upfrom to downto upto + above below by)) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (cl-caddr cl--loop-args) '(downto above)))) - (excl (or (memq (car cl--loop-args) '(above below)) - (memq (cl-caddr cl--loop-args) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (cl-caddr cl--loop-args) '(above below)))) - (start (and (memq (car cl--loop-args) + (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) - (cl--pop2 cl--loop-args))) - (end (and (memq (car cl--loop-args) - '(to upto downto above below)) - (cl--pop2 cl--loop-args))) - (step (and (eq (car cl--loop-args) 'by) + (cl--pop2 cl--loop-args))) + (end (and (memq (car cl--loop-args) + '(to upto downto above below)) + (cl--pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) (cl--pop2 cl--loop-args))) - (end-var (and (not (macroexp-const-p end)) - (make-symbol "--cl-var--"))) - (step-var (and (not (macroexp-const-p step)) - (make-symbol "--cl-var--")))) - (and step (numberp step) (<= step 0) - (error "Loop `by' value is not positive: %s" step)) - (push (list var (or start 0)) loop-for-bindings) - (if end-var (push (list end-var end) loop-for-bindings)) - (if step-var (push (list step-var step) - loop-for-bindings)) - (if end - (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) cl--loop-body)) - (push (list var (list (if down '- '+) var - (or step-var step 1))) - loop-for-steps))) - - ((memq word '(in in-ref on)) - (let* ((on (eq word 'on)) - (temp (if (and on (symbolp var)) - var (make-symbol "--cl-var--")))) - (push (list temp (pop cl--loop-args)) loop-for-bindings) - (push `(consp ,temp) cl--loop-body) - (if (eq word 'in-ref) - (push (list var `(car ,temp)) cl--loop-symbol-macs) - (or (eq temp var) - (progn - (push (list var nil) loop-for-bindings) - (push (list var (if on temp `(car ,temp))) - loop-for-sets)))) - (push (list temp - (if (eq (car cl--loop-args) 'by) - (let ((step (cl--pop2 cl--loop-args))) - (if (and (memq (car-safe step) - '(quote function - cl-function)) - (symbolp (nth 1 step))) - (list (nth 1 step) temp) - `(funcall ,step ,temp))) - `(cdr ,temp))) - loop-for-steps))) - - ((eq word '=) - (let* ((start (pop cl--loop-args)) - (then (if (eq (car cl--loop-args) 'then) + (end-var (and (not (macroexp-const-p end)) + (make-symbol "--cl-var--"))) + (step-var (and (not (macroexp-const-p step)) + (make-symbol "--cl-var--")))) + (and step (numberp step) (<= step 0) + (error "Loop `by' value is not positive: %s" step)) + (push (list var (or start 0)) loop-for-bindings) + (if end-var (push (list end-var end) loop-for-bindings)) + (if step-var (push (list step-var step) + loop-for-bindings)) + (if end + (push (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)) cl--loop-body)) + (push (list var (list (if down '- '+) var + (or step-var step 1))) + loop-for-steps))) + + ((memq word '(in in-ref on)) + (let* ((on (eq word 'on)) + (temp (if (and on (symbolp var)) + var (make-symbol "--cl-var--")))) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (push `(consp ,temp) cl--loop-body) + (if (eq word 'in-ref) + (push (list var `(car ,temp)) cl--loop-symbol-macs) + (or (eq temp var) + (progn + (push (list var nil) loop-for-bindings) + (push (list var (if on temp `(car ,temp))) + loop-for-sets)))) + (push (list temp + (if (eq (car cl--loop-args) 'by) + (let ((step (cl--pop2 cl--loop-args))) + (if (and (memq (car-safe step) + '(quote function + cl-function)) + (symbolp (nth 1 step))) + (list (nth 1 step) temp) + `(funcall ,step ,temp))) + `(cdr ,temp))) + loop-for-steps))) + + ((eq word '=) + (let* ((start (pop cl--loop-args)) + (then (if (eq (car cl--loop-args) 'then) (cl--pop2 cl--loop-args) start))) - (push (list var nil) loop-for-bindings) - (if (or ands (eq (car cl--loop-args) 'and)) - (progn - (push `(,var - (if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,var)) - loop-for-sets) - (push (list var then) loop-for-steps)) - (push (list var - (if (eq start then) start - `(if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,then))) - loop-for-sets)))) - - ((memq word '(across across-ref)) - (let ((temp-vec (make-symbol "--cl-vec--")) - (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) - (push (list temp-idx -1) loop-for-bindings) - (push `(< (setq ,temp-idx (1+ ,temp-idx)) + (push (list var nil) loop-for-bindings) + (if (or ands (eq (car cl--loop-args) 'and)) + (progn + (push `(,var + (if ,(or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))) + ,start ,var)) + loop-for-sets) + (push (list var then) loop-for-steps)) + (push (list var + (if (eq start then) start + `(if ,(or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))) + ,start ,then))) + loop-for-sets)))) + + ((memq word '(across across-ref)) + (let ((temp-vec (make-symbol "--cl-vec--")) + (temp-idx (make-symbol "--cl-idx--"))) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) + (push (list temp-idx -1) loop-for-bindings) + (push `(< (setq ,temp-idx (1+ ,temp-idx)) (length ,temp-vec)) cl--loop-body) - (if (eq word 'across-ref) - (push (list var `(aref ,temp-vec ,temp-idx)) - cl--loop-symbol-macs) - (push (list var nil) loop-for-bindings) - (push (list var `(aref ,temp-vec ,temp-idx)) - loop-for-sets)))) - - ((memq word '(element elements)) - (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) - (and (not (memq (car cl--loop-args) '(in of))) - (error "Expected `of'")))) - (seq (cl--pop2 cl--loop-args)) - (temp-seq (make-symbol "--cl-seq--")) - (temp-idx + (if (eq word 'across-ref) + (push (list var `(aref ,temp-vec ,temp-idx)) + cl--loop-symbol-macs) + (push (list var nil) loop-for-bindings) + (push (list var `(aref ,temp-vec ,temp-idx)) + loop-for-sets)))) + + ((memq word '(element elements)) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) + (error "Expected `of'")))) + (seq (cl--pop2 cl--loop-args)) + (temp-seq (make-symbol "--cl-seq--")) + (temp-idx (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) (eq (cl-caadr cl--loop-args) 'index)) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) - (push (list temp-seq seq) loop-for-bindings) - (push (list temp-idx 0) loop-for-bindings) - (if ref - (let ((temp-len (make-symbol "--cl-len--"))) - (push (list temp-len `(length ,temp-seq)) - loop-for-bindings) - (push (list var `(elt ,temp-seq ,temp-idx)) - cl--loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl--loop-body)) - (push (list var nil) loop-for-bindings) - (push `(and ,temp-seq - (or (consp ,temp-seq) + (push (list temp-seq seq) loop-for-bindings) + (push (list temp-idx 0) loop-for-bindings) + (if ref + (let ((temp-len (make-symbol "--cl-len--"))) + (push (list temp-len `(length ,temp-seq)) + loop-for-bindings) + (push (list var `(elt ,temp-seq ,temp-idx)) + cl--loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl--loop-body)) + (push (list var nil) loop-for-bindings) + (push `(and ,temp-seq + (or (consp ,temp-seq) (< ,temp-idx (length ,temp-seq)))) - cl--loop-body) - (push (list var `(if (consp ,temp-seq) + cl--loop-body) + (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) - loop-for-sets)) - (push (list temp-idx `(1+ ,temp-idx)) - loop-for-steps))) + loop-for-sets)) + (push (list temp-idx `(1+ ,temp-idx)) + loop-for-steps))) - ((memq word hash-types) - (or (memq (car cl--loop-args) '(in of)) + ((memq word hash-types) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl--pop2 cl--loop-args)) - (other + (let* ((table (cl--pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) (memq (cl-caadr cl--loop-args) hash-types) @@ -1252,62 +1252,62 @@ For more details, see Info node `(cl)Loop Facility'. (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) - (if (memq word '(hash-value hash-values)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function + (if (memq word '(hash-value hash-values)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function 'hash-tables (lambda (body) `(maphash (lambda (,var ,other) . ,body) ,table))))) - ((memq word '(symbol present-symbol external-symbol - symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl--loop-args) '(in of)) + ((memq word '(symbol present-symbol external-symbol + symbols present-symbols external-symbols)) + (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl--pop2 cl--loop-args)))) - (cl--loop-set-iterator-function + (cl--loop-set-iterator-function 'symbols (lambda (body) `(mapatoms (lambda (,var) . ,body) ,ob))))) - ((memq word '(overlay overlays extent extents)) - (let ((buf nil) (from nil) (to nil)) - (while (memq (car cl--loop-args) '(in of from to)) - (cond ((eq (car cl--loop-args) 'from) + ((memq word '(overlay overlays extent extents)) + (let ((buf nil) (from nil) (to nil)) + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) + ((eq (car cl--loop-args) 'to) (setq to (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (cl--loop-set-iterator-function + (t (setq buf (cl--pop2 cl--loop-args))))) + (cl--loop-set-iterator-function 'overlays (lambda (body) `(cl--map-overlays (lambda (,var ,(make-symbol "--cl-var--")) (progn . ,body) nil) ,buf ,from ,to))))) - ((memq word '(interval intervals)) - (let ((buf nil) (prop nil) (from nil) (to nil) - (var1 (make-symbol "--cl-var1--")) - (var2 (make-symbol "--cl-var2--"))) - (while (memq (car cl--loop-args) '(in of property from to)) - (cond ((eq (car cl--loop-args) 'from) + ((memq word '(interval intervals)) + (let ((buf nil) (prop nil) (from nil) (to nil) + (var1 (make-symbol "--cl-var1--")) + (var2 (make-symbol "--cl-var2--"))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'to) + ((eq (car cl--loop-args) 'to) (setq to (cl--pop2 cl--loop-args))) - ((eq (car cl--loop-args) 'property) - (setq prop (cl--pop2 cl--loop-args))) - (t (setq buf (cl--pop2 cl--loop-args))))) - (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) - (setq var1 (car var) var2 (cdr var)) - (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (cl--loop-set-iterator-function + ((eq (car cl--loop-args) 'property) + (setq prop (cl--pop2 cl--loop-args))) + (t (setq buf (cl--pop2 cl--loop-args))))) + (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) + (setq var1 (car var) var2 (cdr var)) + (push (list var `(cons ,var1 ,var2)) loop-for-sets)) + (cl--loop-set-iterator-function 'intervals (lambda (body) `(cl--map-intervals (lambda (,var1 ,var2) . ,body) ,buf ,prop ,from ,to))))) - ((memq word key-types) - (or (memq (car cl--loop-args) '(in of)) + ((memq word key-types) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) - (let ((cl-map (cl--pop2 cl--loop-args)) - (other + (let ((cl-map (cl--pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) (memq (cl-caadr cl--loop-args) key-types) @@ -1315,89 +1315,89 @@ For more details, see Info node `(cl)Loop Facility'. (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) - (if (memq word '(key-binding key-bindings)) - (setq var (prog1 other (setq other var)))) - (cl--loop-set-iterator-function + (if (memq word '(key-binding key-bindings)) + (setq var (prog1 other (setq other var)))) + (cl--loop-set-iterator-function 'keys (lambda (body) `(,(if (memq word '(key-seq key-seqs)) 'cl--map-keymap-recursively 'map-keymap) (lambda (,var ,other) . ,body) ,cl-map))))) - ((memq word '(frame frames screen screens)) - (let ((temp (make-symbol "--cl-var--"))) - (push (list var '(selected-frame)) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) + ((memq word '(frame frames screen screens)) + (let ((temp (make-symbol "--cl-var--"))) + (push (list var '(selected-frame)) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl--loop-body) - (push (list var `(next-frame ,var)) - loop-for-steps))) + cl--loop-body) + (push (list var `(next-frame ,var)) + loop-for-steps))) - ((memq word '(window windows)) - (let ((scr (and (memq (car cl--loop-args) '(in of)) + ((memq word '(window windows)) + (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl--pop2 cl--loop-args))) - (temp (make-symbol "--cl-var--")) - (minip (make-symbol "--cl-minip--"))) - (push (list var (if scr - `(frame-selected-window ,scr) - '(selected-window))) - loop-for-bindings) - ;; If we started in the minibuffer, we need to - ;; ensure that next-window will bring us back there - ;; at some point. (Bug#7492). - ;; (Consider using walk-windows instead of cl-loop if - ;; you care about such things.) - (push (list minip `(minibufferp (window-buffer ,var))) - loop-for-bindings) - (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) + (temp (make-symbol "--cl-var--")) + (minip (make-symbol "--cl-minip--"))) + (push (list var (if scr + `(frame-selected-window ,scr) + '(selected-window))) + loop-for-bindings) + ;; If we started in the minibuffer, we need to + ;; ensure that next-window will bring us back there + ;; at some point. (Bug#7492). + ;; (Consider using walk-windows instead of cl-loop if + ;; you care about such things.) + (push (list minip `(minibufferp (window-buffer ,var))) + loop-for-bindings) + (push (list temp nil) loop-for-bindings) + (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl--loop-body) - (push (list var `(next-window ,var ,minip)) - loop-for-steps))) - - (t - ;; This is an advertised interface: (info "(cl)Other Clauses"). - (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) - (if handler - (funcall handler var) - (error "Expected a `for' preposition, found %s" word))))) - (eq (car cl--loop-args) 'and)) - (setq ands t) - (pop cl--loop-args)) - (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl--loop-bindings))) - (if loop-for-sets - (push `(progn + cl--loop-body) + (push (list var `(next-window ,var ,minip)) + loop-for-steps))) + + (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). + (let ((handler (and (symbolp word) + (get word 'cl-loop-for-handler)))) + (if handler + (funcall handler var) + (error "Expected a `for' preposition, found %s" word))))) + (eq (car cl--loop-args) 'and)) + (setq ands t) + (pop cl--loop-args)) + (if (and ands loop-for-bindings) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl--loop-bindings))) + (if loop-for-sets + (push `(progn ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) t) cl--loop-body)) - (if loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - cl--loop-steps)))) + (if loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply 'append (nreverse loop-for-steps))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) ((memq word '(collect collecting)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (if (eq var cl--loop-accum-var) - (push `(progn (push ,what ,var) t) cl--loop-body) - (push `(progn + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) + (push `(progn (setq ,var (nconc ,var (list ,what))) t) cl--loop-body)))) ((memq word '(nconc nconcing append appending)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum nil 'nreverse))) - (push `(progn + (var (cl--loop-handle-accum nil 'nreverse))) + (push `(progn (setq ,var ,(if (eq var cl--loop-accum-var) `(nconc @@ -1411,44 +1411,44 @@ For more details, see Info node `(cl)Loop Facility'. ((memq word '(concat concating)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum ""))) - (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) ((memq word '(vconcat vconcating)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum []))) - (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) ((memq word '(sum summing)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) (let ((what (pop cl--loop-args)) - (var (cl--loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) (let* ((what (pop cl--loop-args)) - (temp (if (cl--simple-expr-p what) what + (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) - (var (cl--loop-handle-accum nil)) - (func (intern (substring (symbol-name word) 0 3))) - (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) - (push `(progn ,(if (eq temp what) set + (var (cl--loop-handle-accum nil)) + (func (intern (substring (symbol-name word) 0 3))) + (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + (push `(progn ,(if (eq temp what) set `(let ((,temp ,what)) ,set)) t) cl--loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop cl--loop-args) - (and (eq (car cl--loop-args) '=) + (while (progn (push (list (pop cl--loop-args) + (and (eq (car cl--loop-args) '=) (cl--pop2 cl--loop-args))) - bindings) - (eq (car cl--loop-args) 'and)) - (pop cl--loop-args)) - (push (nreverse bindings) cl--loop-bindings))) + bindings) + (eq (car cl--loop-args) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) ((eq word 'while) (push (pop cl--loop-args) cl--loop-body)) @@ -1466,7 +1466,7 @@ For more details, see Info node `(cl)Loop Facility'. (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) - cl--loop-body) + cl--loop-body) (setq cl--loop-result t)) ((eq word 'thereis) @@ -1476,32 +1476,32 @@ For more details, see Info node `(cl)Loop Facility'. (setq cl--loop-result-var (make-symbol "--cl-var--"))) (push `(setq ,cl--loop-finish-flag (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) - cl--loop-body)) + cl--loop-body)) ((memq word '(if when unless)) (let* ((cond (pop cl--loop-args)) - (then (let ((cl--loop-body nil)) - (cl--parse-loop-clause) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (else (let ((cl--loop-body nil)) - (if (eq (car cl--loop-args) 'else) - (progn (pop cl--loop-args) (cl--parse-loop-clause))) - (cl--loop-build-ands (nreverse cl--loop-body)))) - (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) - (if (eq word 'unless) (setq then (prog1 else (setq else then)))) - (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) - (if simple (nth 1 else) (list (nth 2 else)))))) - (setq form (if (cl--expr-contains form 'it) + (then (let ((cl--loop-body nil)) + (cl--parse-loop-clause) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (pop cl--loop-args) (cl--parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (simple (and (eq (car then) t) (eq (car else) t)))) + (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) + (if (eq word 'unless) (setq then (prog1 else (setq else then)))) + (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) + (if simple (nth 1 else) (list (nth 2 else)))))) + (setq form (if (cl--expr-contains form 'it) `(let ((it ,cond)) (if it ,@form)) `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) cl--loop-body)))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) (or cl--loop-finish-flag @@ -1514,10 +1514,10 @@ For more details, see Info node `(cl)Loop Facility'. (t ;; This is an advertised interface: (info "(cl)Other Clauses"). (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a cl-loop keyword, found %s" word)) - (funcall handler)))) + (or handler (error "Expected a cl-loop keyword, found %s" word)) + (funcall handler)))) (if (eq (car cl--loop-args) 'and) - (progn (pop cl--loop-args) (cl--parse-loop-clause))))) + (progn (pop cl--loop-args) (cl--parse-loop-clause))))) (defun cl--unused-var-p (sym) (or (null sym) (eq ?_ (aref (symbol-name sym) 0)))) @@ -1549,7 +1549,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (temp (last spec 0))) (if (and (cl--unused-var-p temp) (null expr)) nil ;; Don't bother declaring/setting `temp' since it won't - ;; be used when `expr' is nil, anyway. + ;; be used when `expr' is nil, anyway. (when (and (eq body 'setq) (cl--unused-var-p temp)) ;; Prefer a fresh uninterned symbol over "_to", to avoid ;; warnings that we set an unused variable. @@ -1564,28 +1564,28 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (setq specs (nconc (nreverse nspecs) specs))) (push binding new)))) (if (eq body 'setq) - (let ((set (cons (if par 'cl-psetq 'setq) + (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) - (if temps `(let* ,(nreverse temps) ,set) set)) + (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) (defun cl--loop-handle-accum (def &optional func) ; uses loop-* (if (eq (car cl--loop-args) 'into) (let ((var (cl--pop2 cl--loop-args))) - (or (memq var cl--loop-accum-vars) - (progn (push (list (list var def)) cl--loop-bindings) - (push var cl--loop-accum-vars))) - var) + (or (memq var cl--loop-accum-vars) + (progn (push (list (list var def)) cl--loop-bindings) + (push var cl--loop-accum-vars))) + var) (or cl--loop-accum-var - (progn - (push (list (list + (progn + (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) cl--loop-bindings) - (setq cl--loop-result (if func (list func cl--loop-accum-var) + (setq cl--loop-result (if func (list func cl--loop-accum-var) cl--loop-accum-var)) - cl--loop-accum-var)))) + cl--loop-accum-var)))) (defun cl--loop-build-ands (clauses) "Return various representations of (and . CLAUSES). @@ -1594,29 +1594,29 @@ CLAUSES is a list of Elisp expressions, where clauses of the form The return value has shape (COND BODY COMBO) such that COMBO is equivalent to (and . CLAUSES)." (let ((ands nil) - (body nil)) + (body nil)) ;; Look through `clauses', trying to optimize (progn ,@A t) (progn ,@B) ,@C ;; into (progn ,@A ,@B) ,@C. (while clauses (if (and (eq (car-safe (car clauses)) 'progn) - (eq (car (last (car clauses))) t)) - (if (cdr clauses) - (setq clauses (cons (nconc (butlast (car clauses)) - (if (eq (car-safe (cadr clauses)) - 'progn) - (cl-cdadr clauses) - (list (cadr clauses)))) - (cddr clauses))) + (eq (car (last (car clauses))) t)) + (if (cdr clauses) + (setq clauses (cons (nconc (butlast (car clauses)) + (if (eq (car-safe (cadr clauses)) + 'progn) + (cl-cdadr clauses) + (list (cadr clauses)))) + (cddr clauses))) ;; A final (progn ,@A t) is moved outside of the `and'. - (setq body (cdr (butlast (pop clauses))))) - (push (pop clauses) ands))) + (setq body (cdr (butlast (pop clauses))))) + (push (pop clauses) ands))) (setq ands (or (nreverse ands) (list t))) (list (if (cdr ands) (cons 'and ands) (car ands)) - body - (let ((full (if body - (append ands (list (cons 'progn (append body '(t))))) - ands))) - (if (cdr full) (cons 'and full) (car full)))))) + body + (let ((full (if body + (append ands (list (cons 'progn (append body '(t))))) + ands))) + (if (cdr full) (cons 'and full) (car full)))))) ;;; Other iteration control structures. @@ -1823,8 +1823,8 @@ Like `cl-labels' but the definitions are not recursive. (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) - (push (cons (car binding) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) `(lambda (&rest cl-labels-args) (cl-list* 'funcall ',var cl-labels-args))) @@ -1860,8 +1860,8 @@ in closures will only work if `lexical-binding' is in use. (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) - (push (cons (car binding) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) `(lambda (&rest cl-labels-args) (cl-list* 'funcall ',var cl-labels-args))) @@ -1888,9 +1888,9 @@ This is like `cl-flet', but for macros instead of functions. `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) - (res (cl--transform-lambda (cdar bindings) name))) - (eval (car res)) - (macroexpand-all (cons 'progn body) + (res (cl--transform-lambda (cdar bindings) name))) + (eval (car res)) + (macroexpand-all (cons 'progn body) (cons (cons name `(lambda ,@(cdr res))) macroexpand-all-environment)))))) @@ -2045,10 +2045,10 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" (declare (indent 1) (debug ((&rest symbolp) form))) (cond ((null vars) `(progn ,form nil)) - ((null (cdr vars)) `(setq ,(car vars) (car ,form))) - (t - (let* ((temp (make-symbol "--cl-var--")) (n 0)) - `(let ((,temp ,form)) + ((null (cdr vars)) `(setq ,(car vars) (car ,form))) + (t + (let* ((temp (make-symbol "--cl-var--")) (n 0)) + `(let ((,temp ,form)) (prog1 (setq ,(pop vars) (car ,temp)) (setq ,@(apply #'nconc (mapcar (lambda (v) @@ -2087,38 +2087,38 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (defun cl--do-proclaim (spec hist) (and hist (listp cl--proclaim-history) (push spec cl--proclaim-history)) (cond ((eq (car-safe spec) 'special) - (if (boundp 'byte-compile-bound-variables) - (setq byte-compile-bound-variables - (append (cdr spec) byte-compile-bound-variables)))) - - ((eq (car-safe spec) 'inline) - (while (setq spec (cdr spec)) - (or (memq (get (car spec) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error "%s already has a byte-optimizer, can't make it inline" - (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) - - ((eq (car-safe spec) 'notinline) - (while (setq spec (cdr spec)) - (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) - (put (car spec) 'byte-optimizer nil)))) - - ((eq (car-safe spec) 'optimize) - (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) - '((0 nil) (1 t) (2 t) (3 t)))) - (safety (assq (nth 1 (assq 'safety (cdr spec))) - '((0 t) (1 t) (2 t) (3 nil))))) - (if speed (setq cl--optimize-speed (car speed) - byte-optimize (nth 1 speed))) - (if safety (setq cl--optimize-safety (car safety) - byte-compile-delete-errors (nth 1 safety))))) - - ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) - (while (setq spec (cdr spec)) - (if (consp (car spec)) - (if (eq (cl-cadar spec) 0) + (if (boundp 'byte-compile-bound-variables) + (setq byte-compile-bound-variables + (append (cdr spec) byte-compile-bound-variables)))) + + ((eq (car-safe spec) 'inline) + (while (setq spec (cdr spec)) + (or (memq (get (car spec) 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error "%s already has a byte-optimizer, can't make it inline" + (car spec))) + (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) + + ((eq (car-safe spec) 'notinline) + (while (setq spec (cdr spec)) + (if (eq (get (car spec) 'byte-optimizer) + 'byte-compile-inline-expand) + (put (car spec) 'byte-optimizer nil)))) + + ((eq (car-safe spec) 'optimize) + (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) + '((0 nil) (1 t) (2 t) (3 t)))) + (safety (assq (nth 1 (assq 'safety (cdr spec))) + '((0 t) (1 t) (2 t) (3 nil))))) + (if speed (setq cl--optimize-speed (car speed) + byte-optimize (nth 1 speed))) + (if safety (setq cl--optimize-safety (car safety) + byte-compile-delete-errors (nth 1 safety))))) + + ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) + (while (setq spec (cdr spec)) + (if (consp (car spec)) + (if (eq (cl-cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -2140,8 +2140,8 @@ will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." (if (cl--compiling-file) (while specs - (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) - (cl--do-proclaim (pop specs) nil))) + (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) + (cl--do-proclaim (pop specs) nil))) nil) ;;; The standard modify macros. @@ -2159,19 +2159,19 @@ before assigning any PLACEs to the corresponding values. (let ((p args) (simple t) (vars nil)) (while p (if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars)) - (setq simple nil)) + (setq simple nil)) (if (memq (car p) vars) - (error "Destination duplicated in psetf: %s" (car p))) + (error "Destination duplicated in psetf: %s" (car p))) (push (pop p) vars) (or p (error "Odd number of arguments to cl-psetf")) (pop p)) (if simple - `(progn (setq ,@args) nil) + `(progn (setq ,@args) nil) (setq args (reverse args)) (let ((expr `(setf ,(cadr args) ,(car args)))) - (while (setq args (cddr args)) - (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr)))) - `(progn ,expr nil))))) + (while (setq args (cddr args)) + (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr)))) + `(progn ,expr nil))))) ;;;###autoload (defmacro cl-remf (place tag) @@ -2212,20 +2212,20 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (declare (debug (&rest place))) (if (not (memq nil (mapcar 'symbolp args))) (and (cdr args) - (let ((sets nil) - (first (car args))) - (while (cdr args) - (setq sets (nconc sets (list (pop args) (car args))))) - `(cl-psetf ,@sets ,(car args) ,first))) + (let ((sets nil) + (first (car args))) + (while (cdr args) + (setq sets (nconc sets (list (pop args) (car args))))) + `(cl-psetf ,@sets ,(car args) ,first))) (let* ((places (reverse args)) - (temp (make-symbol "--cl-rotatef--")) - (form temp)) + (temp (make-symbol "--cl-rotatef--")) + (form temp)) (while (cdr places) (setq form (gv-letplace (getter setter) (pop places) `(prog1 ,getter ,(funcall setter form))))) (gv-letplace (getter setter) (car places) - (macroexp-let* `((,temp ,getter)) + (macroexp-let* `((,temp ,getter)) `(progn ,(funcall setter form) nil)))))) ;; FIXME: `letf' is unsatisfactory because it does not really "restore" the @@ -2379,145 +2379,145 @@ non-nil value, that slot cannot be set via `setf'. &rest &or symbolp (symbolp def-form &optional ":read-only" sexp)))) (let* ((name (if (consp struct) (car struct) struct)) - (opts (cdr-safe struct)) - (slots nil) - (defaults nil) - (conc-name (concat (symbol-name name) "-")) - (constructor (intern (format "make-%s" name))) - (constrs nil) - (copier (intern (format "copy-%s" name))) - (predicate (intern (format "%s-p" name))) - (print-func nil) (print-auto nil) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) - (include nil) - (tag (intern (format "cl-struct-%s" name))) - (tag-symbol (intern (format "cl-struct-%s-tags" name))) - (include-descs nil) - (side-eff nil) - (type nil) - (named nil) - (forms nil) - pred-form pred-check) + (opts (cdr-safe struct)) + (slots nil) + (defaults nil) + (conc-name (concat (symbol-name name) "-")) + (constructor (intern (format "make-%s" name))) + (constrs nil) + (copier (intern (format "copy-%s" name))) + (predicate (intern (format "%s-p" name))) + (print-func nil) (print-auto nil) + (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (include nil) + (tag (intern (format "cl-struct-%s" name))) + (tag-symbol (intern (format "cl-struct-%s-tags" name))) + (include-descs nil) + (side-eff nil) + (type nil) + (named nil) + (forms nil) + pred-form pred-check) (if (stringp (car descs)) - (push `(put ',name 'structure-documentation + (push `(put ',name 'structure-documentation ,(pop descs)) forms)) (setq descs (cons '(cl-tag-slot) - (mapcar (function (lambda (x) (if (consp x) x (list x)))) - descs))) + (mapcar (function (lambda (x) (if (consp x) x (list x)))) + descs))) (while opts (let ((opt (if (consp (car opts)) (caar opts) (car opts))) - (args (cdr-safe (pop opts)))) - (cond ((eq opt :conc-name) - (if args - (setq conc-name (if (car args) - (symbol-name (car args)) "")))) - ((eq opt :constructor) - (if (cdr args) + (args (cdr-safe (pop opts)))) + (cond ((eq opt :conc-name) + (if args + (setq conc-name (if (car args) + (symbol-name (car args)) "")))) + ((eq opt :constructor) + (if (cdr args) (progn ;; If this defines a constructor of the same name as ;; the default one, don't define the default. (if (eq (car args) constructor) (setq constructor nil)) (push args constrs)) - (if args (setq constructor (car args))))) - ((eq opt :copier) - (if args (setq copier (car args)))) - ((eq opt :predicate) - (if args (setq predicate (car args)))) - ((eq opt :include) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) - ((eq opt :print-function) - (setq print-func (car args))) - ((eq opt :type) - (setq type (car args))) - ((eq opt :named) - (setq named t)) - ((eq opt :initial-offset) - (setq descs (nconc (make-list (car args) '(cl-skip-slot)) - descs))) - (t - (error "Slot option %s unrecognized" opt))))) + (if args (setq constructor (car args))))) + ((eq opt :copier) + (if args (setq copier (car args)))) + ((eq opt :predicate) + (if args (setq predicate (car args)))) + ((eq opt :include) + (setq include (car args) + include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) + ((eq opt :print-function) + (setq print-func (car args))) + ((eq opt :type) + (setq type (car args))) + ((eq opt :named) + (setq named t)) + ((eq opt :initial-offset) + (setq descs (nconc (make-list (car args) '(cl-skip-slot)) + descs))) + (t + (error "Slot option %s unrecognized" opt))))) (if print-func - (setq print-func + (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) (or type (and include (not (get include 'cl-struct-print))) - (setq print-auto t - print-func (and (or (not (or include type)) (null print-func)) - `(progn + (setq print-auto t + print-func (and (or (not (or include type)) (null print-func)) + `(progn (princ ,(format "#S(%s" name) cl-s)))))) (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) - (error ":type disagrees with :include for %s" name)) - (while include-descs - (setcar (memq (or (assq (caar include-descs) old-descs) - (error "No slot %s in included struct %s" - (caar include-descs) include)) - old-descs) - (pop include-descs))) - (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (push `(cl-pushnew ',tag + (let ((inc-type (get include 'cl-struct-type)) + (old-descs (get include 'cl-struct-slots))) + (or inc-type (error "%s is not a struct name" include)) + (and type (not (eq (car inc-type) type)) + (error ":type disagrees with :include for %s" name)) + (while include-descs + (setcar (memq (or (assq (caar include-descs) old-descs) + (error "No slot %s in included struct %s" + (caar include-descs) include)) + old-descs) + (pop include-descs))) + (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) + type (car inc-type) + named (assq 'cl-tag-slot descs)) + (if (cadr inc-type) (setq tag name named t)) + (let ((incl include)) + (while incl + (push `(cl-pushnew ',tag ,(intern (format "cl-struct-%s-tags" incl))) forms) - (setq incl (get incl 'cl-struct-include))))) + (setq incl (get incl 'cl-struct-include))))) (if type - (progn - (or (memq type '(vector list)) - (error "Invalid :type specifier: %s" type)) - (if named (setq tag name))) - (setq type 'vector named 'true))) + (progn + (or (memq type '(vector list)) + (error "Invalid :type specifier: %s" type)) + (if named (setq tag name))) + (setq type 'vector named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (push `(defvar ,tag-symbol) forms) (setq pred-form (and named - (let ((pos (- (length descs) - (length (memq (assq 'cl-tag-slot descs) - descs))))) - (if (eq type 'vector) - `(and (vectorp cl-x) - (>= (length cl-x) ,(length descs)) - (memq (aref cl-x ,pos) ,tag-symbol)) - (if (= pos 0) - `(memq (car-safe cl-x) ,tag-symbol) - `(and (consp cl-x) - (memq (nth ,pos cl-x) ,tag-symbol)))))) - pred-check (and pred-form (> safety 0) - (if (and (eq (cl-caadr pred-form) 'vectorp) - (= safety 1)) - (cons 'and (cl-cdddr pred-form)) pred-form))) + (let ((pos (- (length descs) + (length (memq (assq 'cl-tag-slot descs) + descs))))) + (if (eq type 'vector) + `(and (vectorp cl-x) + (>= (length cl-x) ,(length descs)) + (memq (aref cl-x ,pos) ,tag-symbol)) + (if (= pos 0) + `(memq (car-safe cl-x) ,tag-symbol) + `(and (consp cl-x) + (memq (nth ,pos cl-x) ,tag-symbol)))))) + pred-check (and pred-form (> safety 0) + (if (and (eq (cl-caadr pred-form) 'vectorp) + (= safety 1)) + (cons 'and (cl-cdddr pred-form)) pred-form))) (let ((pos 0) (descp descs)) (while descp - (let* ((desc (pop descp)) - (slot (car desc))) - (if (memq slot '(cl-tag-slot cl-skip-slot)) - (progn - (push nil slots) - (push (and (eq slot 'cl-tag-slot) `',tag) - defaults)) - (if (assq slot descp) - (error "Duplicate slots named %s in %s" slot name)) - (let ((accessor (intern (format "%s%s" conc-name slot)))) - (push slot slots) - (push (nth 1 desc) defaults) - (push `(cl-defsubst ,accessor (cl-x) + (let* ((desc (pop descp)) + (slot (car desc))) + (if (memq slot '(cl-tag-slot cl-skip-slot)) + (progn + (push nil slots) + (push (and (eq slot 'cl-tag-slot) `',tag) + defaults)) + (if (assq slot descp) + (error "Duplicate slots named %s in %s" slot name)) + (let ((accessor (intern (format "%s%s" conc-name slot)))) + (push slot slots) + (push (nth 1 desc) defaults) + (push `(cl-defsubst ,accessor (cl-x) ,@(and pred-check - (list `(or ,pred-check + (list `(or ,pred-check (error "%s accessing a non-%s" ',accessor ',name)))) ,(if (eq type 'vector) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) - (push (cons accessor t) side-eff) + (push (cons accessor t) side-eff) (if (cadr (memq :read-only (cddr desc))) (push `(gv-define-expander ,accessor (lambda (_cl-do _cl-x) @@ -2541,37 +2541,37 @@ non-nil value, that slot cannot be set via `setf'. ;; ,pos))) ;; forms) ) - (if print-auto - (nconc print-func - (list `(princ ,(format " %s" slot) cl-s) - `(prin1 (,accessor cl-x) cl-s))))))) - (setq pos (1+ pos)))) + (if print-auto + (nconc print-func + (list `(princ ,(format " %s" slot) cl-s) + `(prin1 (,accessor cl-x) cl-s))))))) + (setq pos (1+ pos)))) (setq slots (nreverse slots) - defaults (nreverse defaults)) + defaults (nreverse defaults)) (and predicate pred-form - (progn (push `(cl-defsubst ,predicate (cl-x) + (progn (push `(cl-defsubst ,predicate (cl-x) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) forms) - (push (cons predicate 'error-free) side-eff))) + (push (cons predicate 'error-free) side-eff))) (and copier - (progn (push `(defun ,copier (x) (copy-sequence x)) forms) - (push (cons copier t) side-eff))) + (progn (push `(defun ,copier (x) (copy-sequence x)) forms) + (push (cons copier t) side-eff))) (if constructor - (push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) + (push (list constructor + (cons '&key (delq nil (copy-sequence slots)))) + constrs)) (while constrs (let* ((name (caar constrs)) - (args (cadr (pop constrs))) - (anames (cl--arglist-args args)) - (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) - slots defaults))) - (push `(cl-defsubst ,name + (args (cadr (pop constrs))) + (anames (cl--arglist-args args)) + (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) + slots defaults))) + (push `(cl-defsubst ,name (&cl-defs '(nil ,@descs) ,@args) (,type ,@make)) forms) - (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) - (push (cons name t) side-eff)))) + (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) + (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used ;; by anything anyway! @@ -2638,44 +2638,44 @@ Of course, we really can't know that for sure, so it's just a heuristic." (defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) - (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((memq type '(nil t)) type) - ((eq type 'null) `(null ,val)) - ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(floatp ,val)) - ((eq type 'real) `(numberp ,val)) - ((eq type 'fixnum) `(integerp ,val)) - ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef - ((memq type '(character string-char)) `(characterp ,val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (cond + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) + ((memq type '(nil t)) type) + ((eq type 'null) `(null ,val)) + ((eq type 'atom) `(atom ,val)) + ((eq type 'float) `(floatp ,val)) + ((eq type 'real) `(numberp ,val)) + ((eq type 'fixnum) `(integerp ,val)) + ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef + ((memq type '(character string-char)) `(characterp ,val)) + (t + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (cond ((cl--macroexp-fboundp namep) (list namep val)) ((cl--macroexp-fboundp (setq namep (intern (concat name "-p")))) (list namep val)) (t (list type val)))))) (cond ((get (car type) 'cl-deftype-handler) - (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (delq t `(and ,(cl--make-type-test val (car type)) - ,(if (memq (cadr type) '(* nil)) t + (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) + (cdr type)))) + ((memq (car type) '(integer float real number)) + (delq t `(and ,(cl--make-type-test val (car type)) + ,(if (memq (cadr type) '(* nil)) t (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) `(>= ,val ,(cadr type)))) - ,(if (memq (cl-caddr type) '(* nil)) t + ,(if (memq (cl-caddr type) '(* nil)) t (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) `(<= ,val ,(cl-caddr type))))))) - ((memq (car type) '(and or not)) - (cons (car type) - (mapcar (function (lambda (x) (cl--make-type-test val x))) - (cdr type)))) - ((memq (car type) '(member cl-member)) - `(and (cl-member ,val ',(cdr type)) t)) - ((eq (car type) 'satisfies) (list (cadr type) val)) - (t (error "Bad type spec: %s" type))))) + ((memq (car type) '(and or not)) + (cons (car type) + (mapcar (function (lambda (x) (cl--make-type-test val x))) + (cdr type)))) + ((memq (car type) '(member cl-member)) + `(and (cl-member ,val ',(cdr type)) t)) + ((eq (car type) 'satisfies) (list (cadr type) val)) + (t (error "Bad type spec: %s" type))))) (defvar cl--object) ;;;###autoload @@ -2699,15 +2699,15 @@ TYPE is a Common Lisp-style type specifier." STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl--compiling-file)) - (< cl--optimize-speed 3) (= cl--optimize-safety 3)) + (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let* ((temp (if (cl--simple-expr-p form 3) - form (make-symbol "--cl-var--"))) - (body `(or ,(cl--make-type-test temp type) + form (make-symbol "--cl-var--"))) + (body `(or ,(cl--make-type-test temp type) (signal 'wrong-type-argument (list ,(or string `',type) ,temp ',form))))) - (if (eq temp form) `(progn ,body nil) - `(let ((,temp ,form)) ,body nil))))) + (if (eq temp form) `(progn ,body nil) + `(let ((,temp ,form)) ,body nil))))) ;;;###autoload (defmacro cl-assert (form &optional show-args string &rest args) @@ -2719,13 +2719,13 @@ They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (declare (debug (form &rest form))) (and (or (not (cl--compiling-file)) - (< cl--optimize-speed 3) (= cl--optimize-safety 3)) + (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar (lambda (x) (unless (macroexp-const-p x) x)) (cdr form)))))) - `(progn + `(progn (or ,form ,(if string `(error ,string ,@sargs ,@args) @@ -2767,14 +2767,14 @@ Returns FORM unchanged if it has no compiler macro, or if it has a macro that returns its `&whole' argument." (while (let ((func (car-safe form)) (handler nil)) - (while (and (symbolp func) - (not (setq handler (get func 'compiler-macro))) - (fboundp func) - (or (not (autoloadp (symbol-function func))) - (autoload-do-load (symbol-function func) func))) - (setq func (symbol-function func))) - (and handler - (not (eq form (setq form (apply handler form (cdr form)))))))) + (while (and (symbolp func) + (not (setq handler (get func 'compiler-macro))) + (fboundp func) + (or (not (autoloadp (symbol-function func))) + (autoload-do-load (symbol-function func) func))) + (setq func (symbol-function func))) + (and handler + (not (eq form (setq form (apply handler form (cdr form)))))))) form) ;; Optimize away unused block-wrappers. @@ -2866,23 +2866,23 @@ The function's arguments should be treated as immutable. (defun cl--compiler-macro-member (form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl--const-expr-val (nth 1 keys) + (cl--const-expr-val (nth 1 keys) macroexpand-all-environment)))) (cond ((eq test 'eq) `(memq ,a ,list)) - ((eq test 'equal) `(member ,a ,list)) - ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) - (t form)))) + ((eq test 'equal) `(member ,a ,list)) + ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) + (t form)))) (defun cl--compiler-macro-assoc (form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl--const-expr-val (nth 1 keys) + (cl--const-expr-val (nth 1 keys) macroexpand-all-environment)))) (cond ((eq test 'eq) `(assq ,a ,list)) - ((eq test 'equal) `(assoc ,a ,list)) - ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) - (if (floatp (cl--const-expr-val a macroexpand-all-environment)) - `(assoc ,a ,list) `(assq ,a ,list))) - (t form)))) + ((eq test 'equal) `(assoc ,a ,list)) + ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) + (if (floatp (cl--const-expr-val a macroexpand-all-environment)) + `(assoc ,a ,list) `(assq ,a ,list))) + (t form)))) ;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) |