Skip to content
Snippets Groups Projects
Commit 82e48377 authored by gerd's avatar gerd
Browse files

* src/code/defmacro.lisp (parse-defmacro-lambda-list):

	Check for odd-length args if &key seen, instead of when a
	keyword variable was parsed.
parent 036041d2
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.25 2003/04/19 20:52:43 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.26 2003/05/03 21:15:38 gerd Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -85,6 +85,7 @@ ...@@ -85,6 +85,7 @@
(maximum 0) (maximum 0)
(minimum 0) (minimum 0)
(keys ()) (keys ())
(key-seen nil)
rest-name restp allow-other-keys-p env-arg-used) rest-name restp allow-other-keys-p env-arg-used)
;; This really strange way to test for '&whole is neccessary because member ;; This really strange way to test for '&whole is neccessary because member
;; does not have to work on dotted lists, and dotted lists are legal ;; does not have to work on dotted lists, and dotted lists are legal
...@@ -207,6 +208,7 @@ ...@@ -207,6 +208,7 @@
(setf rest-name (gensym "KEYWORDS-")) (setf rest-name (gensym "KEYWORDS-"))
(push rest-name *ignorable-vars*) (push rest-name *ignorable-vars*)
(setf restp t) (setf restp t)
(setq key-seen t)
(push-let-binding rest-name path t)) (push-let-binding rest-name path t))
((eq var '&allow-other-keys) ((eq var '&allow-other-keys)
(setf allow-other-keys-p t)) (setf allow-other-keys-p t))
...@@ -295,20 +297,20 @@ ...@@ -295,20 +297,20 @@
:minimum ,minimum :minimum ,minimum
,@(unless restp `(:maximum ,maximum)))))) ,@(unless restp `(:maximum ,maximum))))))
*arg-tests*)) *arg-tests*))
(if keys (when key-seen
(let ((problem (gensym "KEY-PROBLEM-")) (let ((problem (gensym "KEY-PROBLEM-"))
(info (gensym "INFO-"))) (info (gensym "INFO-")))
(push `(multiple-value-bind (push `(multiple-value-bind
(,problem ,info) (,problem ,info)
(verify-keywords ,rest-name ',keys ',allow-other-keys-p) (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
(when ,problem (when ,problem
(,error-fun (,error-fun
'defmacro-ll-broken-key-list-error 'defmacro-ll-broken-key-list-error
:kind ',error-kind :kind ',error-kind
,@(when name `(:name ',name)) ,@(when name `(:name ',name))
:problem ,problem :problem ,problem
:info ,info))) :info ,info)))
*arg-tests*))) *arg-tests*)))
(values env-arg-used minimum (if (null restp) maximum nil)))) (values env-arg-used minimum (if (null restp) maximum nil))))
;;; We save space in macro definitions by callig this function. ;;; We save space in macro definitions by callig this function.
......
...@@ -54,6 +54,8 @@ New in this release: ...@@ -54,6 +54,8 @@ New in this release:
now signals a TYPE-ERROR. now signals a TYPE-ERROR.
- DECLARE no longer being a special operator. - DECLARE no longer being a special operator.
- DEFINE-CONDITION accepts slot option :DOCUMENTATION. - DEFINE-CONDITION accepts slot option :DOCUMENTATION.
- Behavior of (... &KEY &ALLOW-OTHER-KEYS) fixed for
DESTRUCTURING-BIND and macros.
* Numerous bugfixes: * Numerous bugfixes:
- NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment