Skip to content
Browse files

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.
  • Loading branch information...
1 parent 545603e commit c3a38a27324501dc5261640cfb08dd6b2dee35c1 Alexey Dejneka committed
Showing with 132 additions and 112 deletions.
  1. +4 −0 BUGS
  2. +5 −2 NEWS
  3. +1 −1 build-order.lisp-expr
  4. +116 −107 src/code/parse-defmacro.lisp
  5. +1 −1 src/compiler/locall.lisp
  6. +4 −0 tests/compiler.pure.lisp
  7. +1 −1 version.lisp-expr
View
4 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.
View
7 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
View
2 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
View
223 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
View
2 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)
View
4 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))
View
2 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"

0 comments on commit c3a38a2

Please sign in to comment.
Something went wrong with that request. Please try again.