diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 156 |
1 files changed, 87 insertions, 69 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5535100d4ae..f5311041cce 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -555,7 +555,7 @@ its argument list allows full Common Lisp conventions." (if (memq '&environment args) (error "&environment used incorrectly")) (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) - (keys nil) + (keys t) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) (setq restarg (if (listp (cadr restarg)) @@ -610,6 +610,7 @@ its argument list allows full Common Lisp conventions." (+ ,num (length ,restarg))))) cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) + (unless (listp keys) (setq keys nil)) (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) @@ -648,23 +649,32 @@ its argument list allows full Common Lisp conventions." `'(nil ,(cl--const-expr-val def)) `(list nil ,def)))))))) (push karg keys))))) - (setq keys (nreverse keys)) + (when (consp 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 - (cond - ((memq (car ,var) ',(append keys allow)) - (setq ,var (cdr (cdr ,var)))) - ((car (cdr (memq (quote ,@allow) ,restarg))) - (setq ,var nil)) - (t - (error - ,(format "Keyword argument %%s not one of %s" - keys) - (car ,var))))))) - (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) + (= safety 0) + (cond + ((eq keys t) nil) ;No &keys at all + ((null keys) ;A &key but no actual keys specified. + (push `(when ,restarg + (error ,(format "Keyword argument %%s not one of %s" + keys) + (car ,restarg))) + cl--bind-forms)) + (t + (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)))) + ((car (cdr (memq (quote ,@allow) ,restarg))) + (setq ,var nil)) + (t + (error + ,(format "Keyword argument %%s not one of %s" + keys) + (car ,var))))))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))))) (cl--do-&aux args) nil))) @@ -2088,60 +2098,65 @@ except that it additionally expands symbol macros." (setq exp (cons 'setq args)) ;; Don't loop further. nil))) - (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; CL's symbol-macrolet treats re-bindings as candidates for - ;; expansion (turning the let into a letf if needed), contrary to - ;; Common-Lisp where such re-bindings hide the symbol-macro. - (let ((letf nil) (found nil) (nbs ())) - (dolist (binding bindings) - (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq var venv))) - (push (if (not (cdr sm)) - binding - (let ((nexp (cadr sm))) - (setq found t) - (unless (symbolp nexp) (setq letf t)) - (cons nexp (cdr-safe binding)))) - nbs))) - (when found - (setq exp `(,(if letf - (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) - (car exp)) - ,(nreverse nbs) - ,@body))))) - ;; FIXME: The behavior of CL made sense in a dynamically scoped - ;; language, but for lexical scoping, Common-Lisp's behavior might - ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t - ;; lexical-let), so maybe we should adjust the behavior based on - ;; the use of lexical-binding. + ;; CL's symbol-macrolet used to treat re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + ;; Not sure if there actually is code out there which depends + ;; on this behavior (haven't found any yet). + ;; Such code should explicitly use `cl-letf' instead, I think. + ;; ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; (let ((nbs ()) (found nil)) + ;; (let ((letf nil) (found nil) (nbs ())) ;; (dolist (binding bindings) ;; (let* ((var (if (symbolp binding) binding (car binding))) - ;; (name (symbol-name var)) - ;; (val (and found (consp binding) (eq 'let* (car exp)) - ;; (list (macroexpand-all (cadr binding) - ;; env))))) - ;; (push (if (assq name env) - ;; ;; This binding should hide its symbol-macro, - ;; ;; but given the way macroexpand-all works, we - ;; ;; can't prevent application of `env' to the - ;; ;; sub-expressions, so we need to α-rename this - ;; ;; variable instead. - ;; (let ((nvar (make-symbol - ;; (copy-sequence name)))) - ;; (setq found t) - ;; (push (list name nvar) env) - ;; (cons nvar (or val (cdr-safe binding)))) - ;; (if val (cons var val) binding)) + ;; (sm (assq var venv))) + ;; (push (if (not (cdr sm)) + ;; binding + ;; (let ((nexp (cadr sm))) + ;; (setq found t) + ;; (unless (symbolp nexp) (setq letf t)) + ;; (cons nexp (cdr-safe binding)))) ;; nbs))) ;; (when found - ;; (setq exp `(,(car exp) + ;; (setq exp `(,(if letf + ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + ;; (car exp)) ;; ,(nreverse nbs) - ;; ,@(macroexp-unprogn - ;; (macroexpand-all (macroexp-progn body) - ;; env))))) - ;; nil)) + ;; ,@body))))) + ;; + ;; We implement the Common-Lisp behavior, instead (see bug#26073): + ;; The behavior of CL made sense in a dynamically scoped + ;; language, but nowadays, lexical scoping semantics is more often + ;; expected. + (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + (let ((nbs ()) (found nil)) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (val (and found (consp binding) (eq 'let* (car exp)) + (list (macroexpand-all (cadr binding) + env))))) + (push (if (assq var venv) + ;; This binding should hide its symbol-macro, + ;; but given the way macroexpand-all works + ;; (i.e. the `env' we receive as input will be + ;; (re)applied to the code we return), we can't + ;; prevent application of `env' to the + ;; sub-expressions, so we need to α-rename this + ;; variable instead. + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (cons nvar (or val (cdr-safe binding)))) + (if val (cons var val) binding)) + nbs))) + (when found + (setq exp `(,(car exp) + ,(nreverse nbs) + ,@(macroexp-unprogn + (macroexpand-all (macroexp-progn body) + env))))) + nil)) ))) exp)) @@ -2425,10 +2440,11 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) (funcall setter vold))) binds)))) - (let ((binding (car bindings))) - (gv-letplace (getter setter) (car binding) + (let* ((binding (car bindings)) + (place (macroexpand (car binding) macroexpand-all-environment))) + (gv-letplace (getter setter) place (macroexp-let2 nil vnew (cadr binding) - (if (symbolp (car binding)) + (if (symbolp place) ;; Special-case for simple variables. (cl--letf (cdr bindings) (cons `(,getter ,(if (cdr binding) vnew getter)) @@ -2455,7 +2471,9 @@ the PLACE is not modified before executing BODY. (declare (indent 1) (debug ((&rest [&or (symbolp form) (gate gv-place &optional form)]) body))) - (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)) + (not (assq (caar bindings) + (alist-get :cl-symbol-macros macroexpand-all-environment)))) `(let ,bindings ,@body) (cl--letf bindings () () body))) |