From c3a38a27324501dc5261640cfb08dd6b2dee35c1 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 20 Apr 2003 10:53:42 +0000 Subject: [PATCH] 0.pre8.82: Fixed bugs caught by Paul Dietz' test suite: * CONVERT-MORE-CALL failed on ((LAMBDA (&KEY) 1) :ALLOW-OTHER-KEYS T) (fixed by Gerd Moellmann); * &WHOLE and &REST arguments in a macro lambda list may be patterns. --- BUGS | 4 + NEWS | 7 +- build-order.lisp-expr | 2 +- src/code/parse-defmacro.lisp | 223 ++++++++++++++++++++++-------------------- src/compiler/locall.lisp | 2 +- tests/compiler.pure.lisp | 4 + version.lisp-expr | 2 +- 7 files changed, 132 insertions(+), 112 deletions(-) diff --git a/BUGS b/BUGS index 3389897..efd3641 100644 --- a/BUGS +++ b/BUGS @@ -1315,6 +1315,10 @@ WORKAROUND: (When this is fixed, the ROOM entries in tests/smoke.impure.lisp should be uncommented.) +248: "reporting errors in type specifier syntax" + (TYPEP 1 '(SYMBOL NIL)) says something about "unknown type + specifier". + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/NEWS b/NEWS index db164bb..4ba4e2f 100644 --- a/NEWS +++ b/NEWS @@ -1658,9 +1658,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14 * bug fix: INTERACTIVE-STREAM-P now works on streams associated with Unix file descriptors, instead of blowing up. (thanks to Antonio Martinez) - * Experimental native threads support, on x86 Linux. This is not + * Experimental native threads support, on x86 Linux. This is not compiled in by default: you need to add :SB-THREAD to the target - features. See the "Beyond ANSI" chapter of the manual for + features. See the "Beyond ANSI" chapter of the manual for details. * sb-aclrepl module improvements: an integrated inspector, added repl features, and a bug fix to :trace command. @@ -1677,6 +1677,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14 causes an error; ** condition slots are now initialized once each, not multiple times; (thanks to Gerd Moellmann) + ** CONVERT-MORE-CALL failed on a lambda list (&KEY); (thanks to + Gerd Moellmann) + ** &WHOLE and &REST arguments in macro lambda lists are patterns; planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ed002e7..c31fc9b 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -96,9 +96,9 @@ ("src/compiler/target/parms") ("src/code/early-array") ; needs "early-vm" numbers + ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc. ("src/code/parse-body") ; on host for PARSE-BODY ("src/code/parse-defmacro") ; on host for PARSE-DEFMACRO - ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc. ("src/compiler/deftype") ; on host for SB!XC:DEFTYPE ("src/compiler/defconstant") ("src/code/early-alieneval") ; for vars needed both at build and run time diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index d6a13e3..edd9323 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -77,8 +77,8 @@ ;; considering at this point in the code. PATH-0 is the root of the ;; lambda list, which is the initial value of PATH. (path-0 (if toplevel - `(cdr ,arg-list-name) - arg-list-name)) + `(cdr ,arg-list-name) + arg-list-name)) (path path-0) ; (will change below) (now-processing :required) (maximum 0) @@ -92,117 +92,126 @@ (reversed-result nil)) ((atom in-pdll) (nreverse (if in-pdll - (list* in-pdll '&rest reversed-result) - reversed-result))) + (list* in-pdll '&rest reversed-result) + reversed-result))) (push (car in-pdll) reversed-result))) rest-name restp allow-other-keys-p env-arg-used) (when (member '&whole (rest lambda-list)) (error "&WHOLE may only appear first in ~S lambda-list." error-kind)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((null rest-of-args)) - (let ((var (car rest-of-args))) - (cond ((eq var '&whole) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setq rest-of-args (cdr rest-of-args)) - (push-let-binding (car rest-of-args) arg-list-name nil)) - (t - (defmacro-error "&WHOLE" error-kind name)))) - ((eq var '&environment) - (cond (env-illegal - (error "&ENVIRONMENT is not valid with ~S." error-kind)) - ((not toplevel) - (error "&ENVIRONMENT is only valid at top level of ~ - lambda-list."))) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setq rest-of-args (cdr rest-of-args)) - (push-let-binding (car rest-of-args) env-arg-name nil) - (setq env-arg-used t)) - (t - (defmacro-error "&ENVIRONMENT" error-kind name)))) - ((or (eq var '&rest) - (eq var '&body)) - (cond (restp - (defmacro-error (symbol-name var) error-kind name)) - ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setq rest-of-args (cdr rest-of-args)) - (setq restp t) - (push-let-binding (car rest-of-args) path nil)) - (t - (defmacro-error (symbol-name var) error-kind name)))) - ((eq var '&optional) - (setq now-processing :optionals)) - ((eq var '&key) - (setq now-processing :keywords) - (setq rest-name (gensym "KEYWORDS-")) - (push rest-name *ignorable-vars*) - (setq restp t) - (push-let-binding rest-name path t)) - ((eq var '&allow-other-keys) - (setq allow-other-keys-p t)) - ((eq var '&aux) - (setq now-processing :auxs)) - ((listp var) - (case now-processing - ((:required) - (when restp - (defmacro-error "required argument after &REST/&BODY" error-kind name)) - (let ((sub-list-name (gensym "SUBLIST-"))) - (push-sub-list-binding sub-list-name `(car ,path) var - name error-kind error-fun) - (parse-defmacro-lambda-list var sub-list-name name - error-kind error-fun)) - (setq path `(cdr ,path) - minimum (1+ minimum) - maximum (1+ maximum))) - ((:optionals) - (destructuring-bind (varname &optional initform supplied-p) - var - (push-optional-binding varname initform supplied-p - `(not (null ,path)) `(car ,path) - name error-kind error-fun)) - (setq path `(cdr ,path) - maximum (1+ maximum))) - ((:keywords) - (let* ((keyword-given (consp (car var))) - (variable (if keyword-given - (cadar var) - (car var))) - (keyword (if keyword-given - (caar var) - (keywordicate variable))) - (supplied-p (caddr var))) - (push-optional-binding variable (cadr var) supplied-p - `(keyword-supplied-p ',keyword - ,rest-name) - `(lookup-keyword ',keyword - ,rest-name) - name error-kind error-fun) - (push keyword keys))) - ((:auxs) - (push-let-binding (car var) (cadr var) nil)))) - ((symbolp var) - (case now-processing - ((:required) - (when restp - (defmacro-error "required argument after &REST/&BODY" error-kind name)) - (push-let-binding var `(car ,path) nil) - (setq minimum (1+ minimum) - maximum (1+ maximum) - path `(cdr ,path))) - ((:optionals) - (push-let-binding var `(car ,path) nil `(not (null ,path))) - (setq path `(cdr ,path) - maximum (1+ maximum))) - ((:keywords) - (let ((key (keywordicate var))) - (push-let-binding var - `(lookup-keyword ,key ,rest-name) - nil) - (push key keys))) - ((:auxs) - (push-let-binding var nil nil)))) - (t - (error "non-symbol in lambda-list: ~S" var))))) + (macrolet ((process-sublist (var sublist-name path) + (once-only ((var var)) + `(if (consp ,var) + (let ((sub-list-name (gensym ,sublist-name))) + (push-sub-list-binding sub-list-name ,path ,var + name error-kind error-fun) + (parse-defmacro-lambda-list ,var sub-list-name name + error-kind error-fun)) + (push-let-binding ,var ,path nil))))) + (let ((var (car rest-of-args))) + (typecase var + (list + (case now-processing + ((:required) + (when restp + (defmacro-error "required argument after &REST/&BODY" + error-kind name)) + (process-sublist var "SUBLIST-" `(car ,path)) + (setq path `(cdr ,path) + minimum (1+ minimum) + maximum (1+ maximum))) + ((:optionals) + (destructuring-bind (varname &optional initform supplied-p) + var + (push-optional-binding varname initform supplied-p + `(not (null ,path)) `(car ,path) + name error-kind error-fun)) + (setq path `(cdr ,path) + maximum (1+ maximum))) + ((:keywords) + (let* ((keyword-given (consp (car var))) + (variable (if keyword-given + (cadar var) + (car var))) + (keyword (if keyword-given + (caar var) + (keywordicate variable))) + (supplied-p (caddr var))) + (push-optional-binding variable (cadr var) supplied-p + `(keyword-supplied-p ',keyword + ,rest-name) + `(lookup-keyword ',keyword + ,rest-name) + name error-kind error-fun) + (push keyword keys))) + ((:auxs) + (push-let-binding (car var) (cadr var) nil)))) + ((and symbol (not (eql nil))) + (case var + (&whole + (cond ((cdr rest-of-args) + (setq rest-of-args (cdr rest-of-args)) + (process-sublist (car rest-of-args) + "WHOLE-LIST-" arg-list-name)) + (t + (defmacro-error "&WHOLE" error-kind name)))) + (&environment + (cond (env-illegal + (error "&ENVIRONMENT is not valid with ~S." error-kind)) + ((not toplevel) + (error "&ENVIRONMENT is only valid at top level of ~ + lambda-list."))) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setq rest-of-args (cdr rest-of-args)) + (push-let-binding (car rest-of-args) env-arg-name nil) + (setq env-arg-used t)) + (t + (defmacro-error "&ENVIRONMENT" error-kind name)))) + ((&rest &body) + (cond ((and (not restp) (cdr rest-of-args)) + (setq rest-of-args (cdr rest-of-args)) + (setq restp t) + (process-sublist (car rest-of-args) "REST-LIST-" path)) + (t + (defmacro-error (symbol-name var) error-kind name)))) + (&optional + (setq now-processing :optionals)) + (&key + (setq now-processing :keywords) + (setq rest-name (gensym "KEYWORDS-")) + (push rest-name *ignorable-vars*) + (setq restp t) + (push-let-binding rest-name path t)) + (&allow-other-keys + (setq allow-other-keys-p t)) + (&aux + (setq now-processing :auxs)) + ;; FIXME: Other lambda list keywords. + (t + (case now-processing + ((:required) + (when restp + (defmacro-error "required argument after &REST/&BODY" + error-kind name)) + (push-let-binding var `(car ,path) nil) + (setq minimum (1+ minimum) + maximum (1+ maximum) + path `(cdr ,path))) + ((:optionals) + (push-let-binding var `(car ,path) nil `(not (null ,path))) + (setq path `(cdr ,path) + maximum (1+ maximum))) + ((:keywords) + (let ((key (keywordicate var))) + (push-let-binding var + `(lookup-keyword ,key ,rest-name) + nil) + (push key keys))) + ((:auxs) + (push-let-binding var nil nil)))))) + (t + (error "non-symbol in lambda-list: ~S" var)))))) (let (;; common subexpression, suitable for passing to functions ;; which expect a MAXIMUM argument regardless of whether ;; there actually is a maximum number of arguments diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index ae4ad08..4f59a87 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -637,7 +637,7 @@ (collect ((call-args)) (do ((var arglist (cdr var)) (temp temps (cdr temp))) - (()) + ((null var)) (let ((info (lambda-var-arg-info (car var)))) (if info (ecase (arg-info-kind info) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 8154102..fb5d3e4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -337,3 +337,7 @@ (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y))) '(1 2)) '((2) 1))) + +;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd +;;; Moellmann: CONVERT-MORE-CALL failed on the following call +(assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u)) diff --git a/version.lisp-expr b/version.lisp-expr index 636210d..ac7c4c8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.81" +"0.pre8.82" -- 1.7.10.4