mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 18:40:39 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/cl-macs.el: Fix &key with no key arg

Browse source 
* test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-empty-keyargs): New test.
* lisp/emacs-lisp/cl-macs.el (cl--do-arglist): Fix it.
This commit is contained in:
Stefan Monnier 2017-11-27 12:45:16 -05:00
parent e896320f0e
commit cea0bca54f
2 changed files with 31 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

44
lisp/emacs-lisp/cl-macs.el
View file

@ -555,7 +555,7 @@ its argument list allows full Common Lisp conventions."
(if (memq '&environment args) (error "&environment used incorrectly")) (if (memq '&environment args) (error "&environment used incorrectly"))
(let ((restarg (memq '&rest args)) (let ((restarg (memq '&rest args))
(safety (if (cl--compiling-file) cl--optimize-safety 3)) (safety (if (cl--compiling-file) cl--optimize-safety 3))
(keys nil) (keys t)
(laterarg nil) (exactarg nil) minarg) (laterarg nil) (exactarg nil) minarg)
(or num (setq num 0)) (or num (setq num 0))
(setq restarg (if (listp (cadr restarg)) (setq restarg (if (listp (cadr restarg))
@ -610,6 +610,7 @@ its argument list allows full Common Lisp conventions."
(+ ,num (length ,restarg))))) (+ ,num (length ,restarg)))))
cl--bind-forms))) cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args)) (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))) (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args))) (let ((arg (pop args)))
(or (consp arg) (setq arg (list arg))) (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)) `'(nil ,(cl--const-expr-val def))
`(list nil ,def)))))))) `(list nil ,def))))))))
(push karg keys))))) (push karg keys)))))
(setq keys (nreverse keys)) (when (consp keys) (setq keys (nreverse keys)))
(or (and (eq (car args) '&allow-other-keys) (pop args)) (or (and (eq (car args) '&allow-other-keys) (pop args))
(null keys) (= safety 0) (= safety 0)
(let* ((var (make-symbol "--cl-keys--")) (cond
(allow '(:allow-other-keys)) ((eq keys t) nil) ;No &keys at all
(check `(while ,var ((null keys) ;A &key but no actual keys specified.
(cond (push `(when ,restarg
((memq (car ,var) ',(append keys allow)) (error ,(format "Keyword argument %%s not one of %s"
(setq ,var (cdr (cdr ,var)))) keys)
((car (cdr (memq (quote ,@allow) ,restarg))) (car ,restarg)))
(setq ,var nil)) cl--bind-forms))
(t (t
(error (let* ((var (make-symbol "--cl-keys--"))
,(format "Keyword argument %%s not one of %s" (allow '(:allow-other-keys))
keys) (check `(while ,var
(car ,var))))))) (cond
(push `(let ((,var ,restarg)) ,check) cl--bind-forms))) ((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) (cl--do-&aux args)
nil))) nil)))

4
test/lisp/emacs-lisp/cl-lib-tests.el
View file

@ -201,6 +201,10 @@
:b :a :a 42) :b :a :a 42)
'(42 :a)))) '(42 :a))))
(ert-deftest cl-lib-empty-keyargs ()
(should-error (funcall (cl-function (lambda (&key) 1))
:b 1)))
(cl-defstruct (mystruct (cl-defstruct (mystruct
(:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-1 (&aux (abc 1)))
(:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring."))