summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/cl-macs.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
-rw-r--r--lisp/emacs-lisp/cl-macs.el273
1 files changed, 175 insertions, 98 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 9c47ceae18e..d7e4b4e611a 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)))
@@ -884,7 +894,7 @@ This is compatible with Common Lisp, but note that `defun' and
(defvar cl--loop-name)
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
(defvar cl--loop-result-var) (defvar cl--loop-steps)
-(defvar cl--loop-symbol-macs)
+(defvar cl--loop-symbol-macs) (defvar cl--loop-guard-cond)
(defun cl--loop-set-iterator-function (kind iterator)
(if cl--loop-iterator-function
@@ -953,7 +963,7 @@ For more details, see Info node `(cl)Loop Facility'.
(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))
+ (cl--loop-symbol-macs nil) (cl--loop-guard-cond nil))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
;;
@@ -988,7 +998,24 @@ For more details, see Info node `(cl)Loop Facility'.
(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)))
+ (while-body
+ (nconc
+ (cadr ands)
+ (if (or (not cl--loop-guard-cond) (not cl--loop-first-flag))
+ (nreverse cl--loop-steps)
+ ;; Right after update the loop variable ensure that the loop
+ ;; condition, i.e. (car ands), is still satisfied; otherwise,
+ ;; set `cl--loop-first-flag' nil and skip the remaining
+ ;; body forms (#Bug#29799).
+ ;;
+ ;; (last cl--loop-steps) updates the loop var
+ ;; (car (butlast cl--loop-steps)) sets `cl--loop-first-flag' nil
+ ;; (nreverse (cdr (butlast cl--loop-steps))) are the
+ ;; remaining body forms.
+ (append (last cl--loop-steps)
+ `((and ,(car ands)
+ ,@(nreverse (cdr (butlast cl--loop-steps)))))
+ `(,(car (butlast cl--loop-steps)))))))
(body (append
(nreverse cl--loop-initially)
(list (if cl--loop-iterator-function
@@ -1309,11 +1336,13 @@ For more details, see Info node `(cl)Loop Facility'.
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
+ (temp-len (make-symbol "--cl-len--"))
(temp-idx (make-symbol "--cl-idx--")))
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
+ (push (list temp-len `(length ,temp-vec)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push `(< (setq ,temp-idx (1+ ,temp-idx))
- (length ,temp-vec))
+ ,temp-len)
cl--loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
@@ -1328,6 +1357,7 @@ For more details, see Info node `(cl)Loop Facility'.
(error "Expected `of'"))))
(seq (cl--pop2 cl--loop-args))
(temp-seq (make-symbol "--cl-seq--"))
+ (temp-len (make-symbol "--cl-len--"))
(temp-idx
(if (eq (car cl--loop-args) 'using)
(if (and (= (length (cadr cl--loop-args)) 2)
@@ -1338,16 +1368,19 @@ For more details, see Info node `(cl)Loop Facility'.
(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--")))
+ (progn
(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))
+ ;; Evaluate seq length just if needed, that is, when seq is not a cons.
+ (push (list temp-len (or (consp seq) `(length ,temp-seq)))
+ loop-for-bindings)
(push (list var nil) loop-for-bindings)
(push `(and ,temp-seq
(or (consp ,temp-seq)
- (< ,temp-idx (length ,temp-seq))))
+ (< ,temp-idx ,temp-len)))
cl--loop-body)
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
@@ -1492,10 +1525,11 @@ For more details, see Info node `(cl)Loop Facility'.
,(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))))
+ (when loop-for-steps
+ (setq cl--loop-guard-cond t)
+ (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--")))
@@ -2057,23 +2091,15 @@ This is like `cl-flet', but for macros instead of functions.
(eval `(cl-function (lambda ,@(cdr res))) t))
macroexpand-all-environment))))))
-(defconst cl--old-macroexpand
- (if (and (boundp 'cl--old-macroexpand)
- (eq (symbol-function 'macroexpand)
- #'cl--sm-macroexpand))
- cl--old-macroexpand
- (symbol-function 'macroexpand)))
-
-(defun cl--sm-macroexpand (exp &optional env)
- "Special macro expander used inside `cl-symbol-macrolet'.
-This function replaces `macroexpand' during macro expansion
-of `cl-symbol-macrolet', and does the same thing as `macroexpand'
-except that it additionally expands symbol macros."
+(defun cl--sm-macroexpand (orig-fun exp &optional env)
+ "Special macro expander advice used inside `cl-symbol-macrolet'.
+This function extends `macroexpand' during macro expansion
+of `cl-symbol-macrolet' to additionally expand symbol macros."
(let ((macroexpand-all-environment env)
(venv (alist-get :cl-symbol-macros env)))
(while
(progn
- (setq exp (funcall cl--old-macroexpand exp env))
+ (setq exp (funcall orig-fun exp env))
(pcase exp
((pred symbolp)
;; Perform symbol-macro expansion.
@@ -2082,7 +2108,7 @@ except that it additionally expands symbol macros."
(setq exp (cadr symval)))))
(`(setq . ,_)
;; Convert setq to setf if required by symbol-macro expansion.
- (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env))
+ (let* ((args (mapcar (lambda (f) (macroexpand f env))
(cdr exp)))
(p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
@@ -2090,60 +2116,102 @@ 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" surrounding
+ ;; 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))
+ ;; Do the same as for `let' but for variables introduced
+ ;; via other means, such as `lambda' and `condition-case'.
+ (`(function (lambda ,args . ,body))
+ (let ((nargs ()) (found nil))
+ (dolist (var args)
+ (push (cond
+ ((memq var '(&optional &rest)) var)
+ ((assq var venv)
+ (let ((nvar (make-symbol (symbol-name var))))
+ (setq found t)
+ (push (list var nvar) venv)
+ (push (cons :cl-symbol-macros venv) env)
+ nvar))
+ (t var))
+ nargs))
+ (when found
+ (setq exp `(function
+ (lambda ,(nreverse nargs)
+ . ,(mapcar (lambda (exp)
+ (macroexpand-all exp env))
+ body)))))
+ nil))
+ ((and `(condition-case ,var ,exp . ,clauses)
+ (guard (assq var venv)))
+ (let ((nvar (make-symbol (symbol-name var))))
+ (push (list var nvar) venv)
+ (push (cons :cl-symbol-macros venv) env)
+ (setq exp
+ `(condition-case ,nvar ,(macroexpand-all exp env)
+ . ,(mapcar
+ (lambda (clause)
+ `(,(car clause)
+ . ,(mapcar (lambda (exp)
+ (macroexpand-all exp env))
+ (cdr clause))))
+ clauses)))
+ nil))
)))
exp))
@@ -2155,16 +2223,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body)))
- (let ((previous-macroexpand (symbol-function 'macroexpand))
- (malformed-bindings nil))
+ (let ((malformed-bindings nil)
+ (advised (advice-member-p #'cl--sm-macroexpand 'macroexpand)))
(dolist (binding bindings)
(unless (and (consp binding) (symbolp (car binding))
(consp (cdr binding)) (null (cddr binding)))
(push binding malformed-bindings)))
(unwind-protect
(progn
- (fset 'macroexpand #'cl--sm-macroexpand)
- (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment)))
+ (unless advised
+ (advice-add 'macroexpand :around #'cl--sm-macroexpand))
+ (let* ((venv (cdr (assq :cl-symbol-macros
+ macroexpand-all-environment)))
(expansion
(macroexpand-all (macroexp-progn body)
(cons (cons :cl-symbol-macros
@@ -2176,7 +2246,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(nreverse malformed-bindings))
expansion)
expansion)))
- (fset 'macroexpand previous-macroexpand))))
+ (unless advised
+ (advice-remove 'macroexpand #'cl--sm-macroexpand)))))
;;; Multiple values.
@@ -2427,10 +2498,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))
@@ -2457,7 +2529,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)))
@@ -2647,6 +2721,9 @@ non-nil value, that slot cannot be set via `setf'.
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
pred-form pred-check)
+ ;; Can't use `cl-check-type' yet.
+ (unless (cl--struct-name-p name)
+ (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name)))
(setq descs (cons '(cl-tag-slot)
(mapcar (function (lambda (x) (if (consp x) x (list x))))
descs)))
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-21 22:24:11 +0000