From cca6915901ef29ada74859eefa147f6ea553fe4e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 13 Sep 2004 15:25:08 +0000 Subject: [PATCH] =?utf8?q?0.8.14.16:=20Zipper=20Up=20=20=20=20=20=20=20=20=20?= =?utf8?q?=20=20=20=20*=20Fix=20deftype=20lambda-list=20parsing=20to=20bind=20?= =?utf8?q?unsupplied=20=20=20=20=20=20=20=20=20=20=20=20=20=20=20=20keyword=20?= =?utf8?q?parameters=20to=20*=20instead=20of=20NIL=20if=20no=20initform=20=20?= =?utf8?q?=20=20=20=20=20=20=20=20=20=20=20=20=20=20was=20supplied=20--=20on?= =?utf8?q?ly=20one=20of=20the=20four=20cases=20used=20to=20be=20=20=20=20=20?= =?utf8?q?=20=20=20=20=20=20=20=20=20=20=20handled=20correctly.=20Reported=20?= =?utf8?q?by=20Johan=20Bockg=E5rd=20on=20#lisp=20=20=20=20=20=20=20=20=20=20?= =?utf8?q?=20=20=20*=20Fix=20#347:=20define-compiler-macro=20lambda-list=20p?= =?utf8?q?arsing=20=20=20=20=20=20=20=20=20=20=20=20=20=20=20=20binds=20corr?= =?utf8?q?ectly=20when=20FUNCALL=20appears=20as=20the=20car=20of=20the=20=20?= =?utf8?q?=20=20=20=20=20=20=20=20=20=20=20=20=20=20form=20(port=20of=20Raym?= =?utf8?q?ond=20Toy's=20fix=20for=20the=20same=20from=20=20=20=20=20=20=20=20?= =?utf8?q?=20=20=20=20=20=20=20=20CMUCL).=20Also=20reported=20by=20Johan=20B?= =?utf8?q?ockg=E5rd.=20=20=20=20=20=20=20=20=20=20=20=20=20*=20In=20course=20?= =?utf8?q?of=20fixing=20the=20latter,=20make=20simple=20but=20=20=20=20=20=20?= =?utf8?q?=20=20=20=20=20=20=20=20=20=20philosophically=20profound=20change=20?= =?utf8?q?to=20parse-defmacro:=20what=20=20=20=20=20=20=20=20=20=20=20=20=20?= =?utf8?q?=20=20=20was=20error-kind=20is=20now=20thought=20of=20as=20a=20con?= =?utf8?q?text=20marker.=20=20=20=20=20=20=20=20=20=20=20=20=20*=20Tests,=20?= =?utf8?q?tests,=20tests?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- BUGS | 8 ---- NEWS | 28 +++++++---- src/code/parse-defmacro.lisp | 79 +++++++++++++++++++------------ tests/define-compiler-macro.impure.lisp | 42 ++++++++++++++++ tests/deftype.impure.lisp | 30 ++++++++++++ version.lisp-expr | 2 +- 6 files changed, 140 insertions(+), 49 deletions(-) create mode 100644 tests/define-compiler-macro.impure.lisp create mode 100644 tests/deftype.impure.lisp diff --git a/BUGS b/BUGS index 57305af..70b8d3e 100644 --- a/BUGS +++ b/BUGS @@ -1589,14 +1589,6 @@ WORKAROUND: In sbcl-0.8.13, all backtraces from errors caused by internal errors on the alpha seem to have a "bogus stack frame". -347: FUNCALL forms and compiler-macros - (reported by Johan Bockgård on #lisp) - The example - (funcall (compiler-macro-function 'square) '(funcall #'square x) nil) - => (EXPT X 2) - from CLHS entry for DEFINE-COMPILER-MACRO fails in 0.8.13.41 with an - error. Fixed in CMUCL 19a. - 348: Structure slot setters do not preserve evaluation order: diff --git a/NEWS b/NEWS index e7a9cc0..4ebeb4b 100644 --- a/NEWS +++ b/NEWS @@ -1,20 +1,28 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14: * incompatible change: SB-INT:*BEFORE-SAVE-INITIALIZATIONS* and SB-INT:*AFTER-SAVE-INITIALIZATIONS* have been renamed - SB-EXT:*SAVE-HOOKS* and SB-EXT:*INIT-HOOKS*, and are now - part of the supported interface. - * new feature: Single-stepping of code compiled with DEBUG 2 or higher - and (> DEBUG (MAX SPACE SPEED)) is now possible. + SB-EXT:*SAVE-HOOKS* and SB-EXT:*INIT-HOOKS*, and are now part of + the supported interface. + * new feature: Single-stepping of code compiled with DEBUG 2 or + higher and (> DEBUG (MAX SPACE SPEED)) is now possible. * new feature: saving cores with foreign code loaded is now - supported on x86/FreeBSD, x86/Linux, and sparc/SunOS. (based - on Timothy Moore's work for CMUCL) + supported on x86/FreeBSD, x86/Linux, and sparc/SunOS. (based on + Timothy Moore's work for CMUCL) + * bug fix: DEFTYPE lambda-list parsing now binds unsupplied keyword + parameters to * instead of NIL if no initform is supplied. + (reported by Johan Bockgård) + * bug fix: DEFINE-COMPILER-MACRO lambda-list parsing now binds + correctly when FUNCALL appears as the car of the form. Note: + despite this FUNCALL forms are not currently subject to + compiler-macro expansion. (port of Raymond Toy's fix for the + same from CMUCL, reported by Johan Bockgård) * bug fix: FOR ... ON ... -clauses in LOOP now work on dotted lists (thanks for Teemu Kalvas) * bug fix: in FORMAT ~^ inside ~:{ now correctly steps to the next - case instead of terminating the iteration (thanks for Julian Squires, - Sean Champ and Raymond Toy) - * bug fix: incorrect expansion of defgeneric that caused - a style warning. (thanks for Zach Beane) + case instead of terminating the iteration (thanks for Julian + Squires, Sean Champ and Raymond Toy) + * bug fix: incorrect expansion of defgeneric that caused a style + warning. (thanks for Zach Beane) * on x86 compiler supports stack allocation of results of LIST and LIST*, bound to variables, declared DYNAMIC-EXTENT. (based on CMUCL implementation by Gerd Moellmann) diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index af0c7ba..d963671 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -31,7 +31,7 @@ ;;; Return, as multiple values, a body, possibly a DECLARE form to put ;;; where this code is inserted, the documentation for the parsed ;;; body, and bounds on the number of arguments. -(defun parse-defmacro (lambda-list arg-list-name body name error-kind +(defun parse-defmacro (lambda-list arg-list-name body name context &key (anonymousp nil) (doc-string-allowed t) @@ -48,7 +48,7 @@ (*env-var* nil)) (multiple-value-bind (env-arg-used minimum maximum) (parse-defmacro-lambda-list lambda-list arg-list-name name - error-kind error-fun (not anonymousp) + context error-fun (not anonymousp) nil) (values `(let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) @@ -75,7 +75,7 @@ (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list arg-list-name name - error-kind + context error-fun &optional toplevel @@ -105,7 +105,7 @@ (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)) + (error "&WHOLE may only appear first in ~S lambda-list." context)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((null rest-of-args)) (macrolet ((process-sublist (var sublist-name path) @@ -113,10 +113,13 @@ `(if (listp ,var) (let ((sub-list-name (gensym ,sublist-name))) (push-sub-list-binding sub-list-name ,path ,var - name error-kind error-fun) + name context error-fun) (parse-defmacro-lambda-list ,var sub-list-name name - error-kind error-fun)) - (push-let-binding ,var ,path nil))))) + context error-fun)) + (push-let-binding ,var ,path nil)))) + (normalize-singleton (var) + `(when (null (cdr ,var)) + (setf (cdr ,var) (list *default-default*))))) (let ((var (car rest-of-args))) (typecase var (list @@ -124,20 +127,22 @@ ((:required) (when restp (defmacro-error "required argument after &REST/&BODY" - error-kind name)) + context name)) (process-sublist var "SUBLIST-" `(car ,path)) (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) + (normalize-singleton var) (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)) + name context error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) + (normalize-singleton var) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -151,7 +156,7 @@ ,rest-name) `(lookup-keyword ',keyword ,rest-name) - name error-kind error-fun) + name context error-fun) (push keyword keys))) ((:auxs) (push-let-binding (car var) (cadr var) nil)))) @@ -160,13 +165,25 @@ (&whole (cond ((cdr rest-of-args) (setq rest-of-args (cdr rest-of-args)) + ;; Special case for compiler-macros: if car of + ;; the form is FUNCALL skip over it for + ;; destructuring, pretending cdr of the form is + ;; the actual form. + (when (eq context 'define-compiler-macro) + (push-let-binding + arg-list-name + arg-list-name + t + `(not (and (listp ,arg-list-name) + (eq 'funcall (car ,arg-list-name)))) + `(setf ,arg-list-name (cdr ,arg-list-name)))) (process-sublist (car rest-of-args) "WHOLE-LIST-" arg-list-name)) (t - (defmacro-error "&WHOLE" error-kind name)))) + (defmacro-error "&WHOLE" context name)))) (&environment (cond (env-illegal - (error "&ENVIRONMENT is not valid with ~S." error-kind)) + (error "&ENVIRONMENT is not valid with ~S." context)) ((not toplevel) (error "&ENVIRONMENT is only valid at top level of ~ lambda-list.")) @@ -178,14 +195,14 @@ (setq *env-var* (car rest-of-args)) (setq env-arg-used t)) (t - (defmacro-error "&ENVIRONMENT" error-kind name)))) + (defmacro-error "&ENVIRONMENT" context 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)))) + (defmacro-error (symbol-name var) context name)))) (&optional (setq now-processing :optionals)) (&key @@ -205,7 +222,7 @@ ((:required) (when restp (defmacro-error "required argument after &REST/&BODY" - error-kind name)) + context name)) (push-let-binding var `(car ,path) nil) (setq minimum (1+ minimum) maximum (1+ maximum) @@ -216,9 +233,11 @@ maximum (1+ maximum))) ((:keywords) (let ((key (keywordicate var))) - (push-let-binding var - `(lookup-keyword ,key ,rest-name) - nil) + (push-let-binding + var + `(lookup-keyword ,key ,rest-name) + nil + `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) (push-let-binding var nil nil)))))) @@ -237,11 +256,11 @@ `(list-of-length-at-least-p ,path-0 ,minimum) `(proper-list-of-length-p ,path-0 ,minimum ,maximum)) ,(if (eq error-fun 'error) - `(arg-count-error ',error-kind ',name ,path-0 + `(arg-count-error ',context ',name ,path-0 ',lambda-list ,minimum ,explicit-maximum) `(,error-fun 'arg-count-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :args ,path-0 :lambda-list ',lambda-list @@ -258,7 +277,7 @@ (when ,problem (,error-fun 'defmacro-lambda-list-broken-key-list-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :problem ,problem :info ,info))) @@ -266,18 +285,18 @@ (values env-arg-used minimum explicit-maximum)))) ;;; We save space in macro definitions by calling this function. -(defun arg-count-error (error-kind name args lambda-list minimum maximum) +(defun arg-count-error (context name args lambda-list minimum maximum) (let (#-sb-xc-host (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error 'arg-count-error - :kind error-kind + :kind context :name name :args args :lambda-list lambda-list :minimum minimum :maximum maximum))) -(defun push-sub-list-binding (variable path object name error-kind error-fun) +(defun push-sub-list-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable @@ -285,7 +304,7 @@ (if (listp ,var) ,var (,error-fun 'defmacro-bogus-sublist-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :object ,var :lambda-list ',object)))) @@ -302,7 +321,7 @@ (push let-form *user-lets*)))) (defun push-optional-binding (value-var init-form supplied-var condition path - name error-kind error-fun) + name context error-fun) (unless supplied-var (setq supplied-var (gensym "SUPPLIEDP-"))) (push-let-binding supplied-var condition t) @@ -310,17 +329,17 @@ (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) (push-sub-list-binding whole-thing `(if ,supplied-var ,path ,init-form) - value-var name error-kind error-fun) + value-var name context error-fun) (parse-defmacro-lambda-list value-var whole-thing name - error-kind error-fun))) + context error-fun))) ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t (error "illegal optional variable name: ~S" value-var)))) -(defun defmacro-error (problem kind name) +(defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem kind name)) + problem context name)) (defun check-defmacro-arg (arg) (when (or (and *env-var* (eq arg *env-var*)) diff --git a/tests/define-compiler-macro.impure.lisp b/tests/define-compiler-macro.impure.lisp new file mode 100644 index 0000000..50c4fe2 --- /dev/null +++ b/tests/define-compiler-macro.impure.lisp @@ -0,0 +1,42 @@ +;;;; Compiler-macro tests + +;;; taken from CLHS example +(defun square (x) + (expt x 2)) + +(define-compiler-macro square (&whole form arg) + (if (atom arg) + `(expt ,arg 2) + (case (car arg) + (square (if (= (length arg) 2) + `(expt ,(nth 1 arg) 4) + form)) + (expt (if (= (length arg) 3) + (if (numberp (nth 2 arg)) + `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg))) + `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg)))) + form)) + (otherwise `(expt ,arg 2))))) + +(assert (eql 81 (square (square 3)))) + +(multiple-value-bind (expansion expanded-p) (macroexpand '(square x)) + (assert (equal '(square x) expansion)) + (assert (not expanded-p))) + +(assert (equal '(expt x 2) + (funcall (compiler-macro-function 'square) + '(square x) + nil))) + +(assert (equal '(expt x 4) + (funcall (compiler-macro-function 'square) + '(square (square x)) + nil))) + +(assert (equal '(expt x 2) + (funcall (compiler-macro-function 'square) + '(funcall #'square x) + nil))) + +(quit :unix-status 104) diff --git a/tests/deftype.impure.lisp b/tests/deftype.impure.lisp new file mode 100644 index 0000000..b1eef79 --- /dev/null +++ b/tests/deftype.impure.lisp @@ -0,0 +1,30 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(load "assertoid.lisp") +(use-package "ASSERTOID") + +;;; Check for correct defaulting of unsupplied parameters to * +(deftype opt (&optional arg) + `(integer 0 ,arg)) +(deftype opt-singleton (&optional (arg)) + `(integer 0 ,arg)) +(deftype key (&key arg) + `(integer 0 ,arg)) +(deftype key-singleton (&key (arg)) + `(integer 0 ,arg)) + +(assert (typep 1 'opt)) +(assert (typep 1 'opt-singleton)) +(assert (typep 1 'key)) +(assert (typep 1 'key-singleton)) + +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 26442b4..2268647 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.8.14.15" +"0.8.14.16" -- 1.7.10.4