Skip to content
Snippets Groups Projects
Commit 55c5b06f authored by gerd's avatar gerd
Browse files

(DESTRUCTURING-BIND (X . Y) () ...) did not signal an error.

	Reported by Edi Weitz on cmucl-help.

	* src/code/defmacro.lisp (restify-dotted-lambda-list): New
	function.
	(parse-defmacro-lambda-list): Use it to tranform dotted
	lambda-list to undotted lambda-lists with &rest.  Remove
	special handling of dotted lambda-lists.
parent 9d3ebe1c
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.29 2003/06/01 19:35:05 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.30 2003/07/15 13:39:02 gerd Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -76,32 +76,31 @@ ...@@ -76,32 +76,31 @@
minimum minimum
maximum))))) maximum)))))
(defun restify-dotted-lambda-list (lambda-list)
(collect ((new))
(do ((tail lambda-list (cdr tail)))
((atom tail) (progn
(unless (null tail) (new '&rest tail))
(new)))
(new (car tail)))))
(defun parse-defmacro-lambda-list (defun parse-defmacro-lambda-list
(lambda-list arg-list-name name error-kind error-fun (lambda-list arg-list-name name error-kind error-fun
&optional top-level env-illegal env-arg-name) &optional top-level env-illegal env-arg-name)
(let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
(lambda-list (restify-dotted-lambda-list lambda-list))
(now-processing :required) (now-processing :required)
(maximum 0) (maximum 0)
(minimum 0) (minimum 0)
(keys ()) (keys ())
(key-seen nil) (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 (when (and (member '&whole lambda-list)
;; does not have to work on dotted lists, and dotted lists are legal
;; in lambda-lists.
(when (and (do ((list lambda-list (cdr list)))
((atom list) nil)
(when (eq (car list) '&whole) (return t)))
(not (eq (car lambda-list) '&whole))) (not (eq (car lambda-list) '&whole)))
(simple-program-error "&Whole must appear first in ~S lambda-list." (simple-program-error "&Whole must appear first in ~S lambda-list."
error-kind)) error-kind))
(do ((rest-of-args lambda-list (cdr rest-of-args))) (do ((rest-of-args lambda-list (cdr rest-of-args)))
((atom rest-of-args) ((null rest-of-args))
(cond ((null rest-of-args) nil)
;; Varlist is dotted, treat as &rest arg and exit.
(t (push-let-binding rest-of-args path nil)
(setf restp :dotted))))
(let ((var (car rest-of-args))) (let ((var (car rest-of-args)))
(cond ((eq var '&whole) (cond ((eq var '&whole)
(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
...@@ -273,30 +272,27 @@ ...@@ -273,30 +272,27 @@
(push-let-binding var nil nil)))) (push-let-binding var nil nil))))
(t (t
(simple-program-error "Non-symbol in lambda-list - ~S." var))))) (simple-program-error "Non-symbol in lambda-list - ~S." var)))))
;; Generate code to check the number of arguments, unless dotted (push `(unless (<= ,minimum
;; in which case length will not work. (length (the list ,(if top-level
(unless (eq restp :dotted) `(cdr ,arg-list-name)
(push `(unless (<= ,minimum arg-list-name)))
(length (the list ,(if top-level ,@(unless restp
`(cdr ,arg-list-name) (list maximum)))
arg-list-name))) ,(let ((arg (if top-level
,@(unless restp `(cdr ,arg-list-name)
(list maximum))) arg-list-name)))
,(let ((arg (if top-level (if (eq error-fun 'error)
`(cdr ,arg-list-name) `(do-arg-count-error ',error-kind ',name ,arg
arg-list-name))) ',lambda-list ,minimum
(if (eq error-fun 'error) ,(unless restp maximum))
`(do-arg-count-error ',error-kind ',name ,arg `(,error-fun 'defmacro-ll-arg-count-error
',lambda-list ,minimum
,(unless restp maximum))
`(,error-fun 'defmacro-ll-arg-count-error
:kind ',error-kind :kind ',error-kind
,@(when name `(:name ',name)) ,@(when name `(:name ',name))
:argument ,arg :argument ,arg
:lambda-list ',lambda-list :lambda-list ',lambda-list
:minimum ,minimum :minimum ,minimum
,@(unless restp `(:maximum ,maximum)))))) ,@(unless restp `(:maximum ,maximum))))))
*arg-tests*)) *arg-tests*)
(when key-seen (when key-seen
(let ((problem (gensym "KEY-PROBLEM-")) (let ((problem (gensym "KEY-PROBLEM-"))
(info (gensym "INFO-"))) (info (gensym "INFO-")))
......
...@@ -129,6 +129,8 @@ New in this release: ...@@ -129,6 +129,8 @@ New in this release:
or SLOT-MISSING are called and return. or SLOT-MISSING are called and return.
- NTH and NTHCDR accepting bignums as first argument. - NTH and NTHCDR accepting bignums as first argument.
- First arg of CERROR may be a function. - First arg of CERROR may be a function.
- Lambda-lists of the form (X . Y) in DESTRUCTURING-BIND and macros
are now equivalent to (X &REST Y).
* 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