From: Nikodemus Siivola Date: Fri, 11 Aug 2006 08:08:39 +0000 (+0000) Subject: 0.9.15.26: compiler-macro lambda-list parsing and FUNCALL forms X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8bcffb407835ff680d5ee2ba1f7ce97839bbae3e;p=sbcl.git 0.9.15.26: compiler-macro lambda-list parsing and FUNCALL forms * We previously handled only the &WHOLE case, and also failed to handle the argument count checking correct. Now things should work, but FUNCALL forms are not still subject to compiler-macroexpansion -- yet. (Reported by James Y Knight) * Refactor the macro-lambda-list parsing code slightly for easier comprehension. --- diff --git a/NEWS b/NEWS index 788c122..6ff459b 100644 --- a/NEWS +++ b/NEWS @@ -29,6 +29,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: * bug fix: specifying an output-file without a pathname-type for COMPILE-FILE or COMPILE-FILE-PATHNAME resulted in using the type of input-file instead of "fasl". (reported by Robert Dodier) + * bug fix: compiler-macro lambda-list parsing of FUNCALL forms. + (reported by James Y Knight). changes in sbcl-0.9.15 relative to sbcl-0.9.14: * added support for the ucs-2 external format. (contributed by Ivan diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp index 58bc4c0..4ea6b48 100644 --- a/src/code/destructuring-bind.lisp +++ b/src/code/destructuring-bind.lisp @@ -9,15 +9,16 @@ (in-package "SB!IMPL") -(defmacro-mundanely destructuring-bind (lambda-list arg-list &rest body) +(defmacro-mundanely destructuring-bind (lambda-list expression &rest body) #!+sb-doc - "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." - (let ((arg-list-name (gensym "ARG-LIST-"))) + "Bind the variables in LAMBDA-LIST to the corresponding values in the +tree structure resulting from the evaluation of EXPRESSION." + (let ((whole-name (gensym "WHOLE"))) (multiple-value-bind (body local-decls) - (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind + (parse-defmacro lambda-list whole-name body nil 'destructuring-bind :anonymousp t :doc-string-allowed nil :wrap-block nil) - `(let ((,arg-list-name ,arg-list)) + `(let ((,whole-name ,expression)) ,@local-decls ,body)))) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index c55cf6a..ee7cc7d 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -393,12 +393,12 @@ GET-SETF-EXPANSION directly." (destructuring-bind (lambda-list (&rest store-variables) &body body) rest - (let ((arglist-var (gensym "ARGS-")) + (let ((whole-var (gensym "WHOLE-")) (access-form-var (gensym "ACCESS-FORM-")) (env-var (gensym "ENVIRONMENT-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro `(,lambda-list ,@store-variables) - arglist-var body access-fn 'defsetf + whole-var body access-fn 'defsetf :anonymousp t) `(eval-when (:compile-toplevel :load-toplevel :execute) (assign-setf-macro @@ -406,7 +406,7 @@ GET-SETF-EXPANSION directly." (lambda (,access-form-var ,env-var) (declare (ignore ,env-var)) (%defsetf ,access-form-var ,(length store-variables) - (lambda (,arglist-var) + (lambda (,whole-var) ,@local-decs ,body))) nil diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index d9fc853..225c2f7 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -31,14 +31,14 @@ ;;; 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 context - &key - (anonymousp nil) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error) - (wrap-block t)) +(defun parse-defmacro (lambda-list whole-var body name context + &key + (anonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + ((:default-default *default-default*)) + (error-fun 'error) + (wrap-block t)) (multiple-value-bind (forms declarations documentation) (parse-body body :doc-string-allowed doc-string-allowed) (let ((*arg-tests* ()) @@ -47,9 +47,9 @@ (*ignorable-vars* ()) (*env-var* nil)) (multiple-value-bind (env-arg-used minimum maximum) - (parse-defmacro-lambda-list lambda-list arg-list-name name - context error-fun (not anonymousp) - nil) + (parse-defmacro-lambda-list lambda-list whole-var name context + :error-fun error-fun + :anonymousp anonymousp) (values `(let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) ,@(nreverse *system-lets*)) @@ -68,25 +68,21 @@ minimum maximum))))) -;;; partial reverse-engineered documentation: -;;; TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and -;;; DESTRUCTURING-BIND, false otherwise. -;;; -- WHN 19990620 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list - arg-list-name + whole-var name context + &key error-fun - &optional - toplevel - env-illegal) + anonymousp + env-illegal + sublist) (let* (;; PATH is a sort of pointer into the part of the lambda list we're ;; 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)) - (path path-0) ; (will change below) + (path-0 (if (or anonymousp sublist) whole-var `(cdr ,whole-var))) + (path path-0) ; will change below + (compiler-macro-whole (gensym "CMACRO-&WHOLE")) (now-processing :required) (maximum 0) (minimum 0) @@ -108,39 +104,57 @@ 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." context)) - (do ((rest-of-args lambda-list (cdr rest-of-args))) - ((null rest-of-args)) - (macrolet ((process-sublist (var sublist-name path) + ;; Special case compiler-macros: if car of the form is FUNCALL, + ;; skip over it for destructuring, pretending cdr of the form is + ;; the actual form. Save original for &whole + (when (eq context 'define-compiler-macro) + (push-let-binding compiler-macro-whole whole-var :system t) + (push compiler-macro-whole *ignorable-vars*) + (push-let-binding whole-var whole-var + :system t + :when `(not (eq 'funcall (car ,whole-var))) + ;; do we need to SETF too? + :else `(setf ,whole-var (cdr ,whole-var)))) + (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list))) + ((null rest-of-lambda-list)) + (macrolet ((process-sublist (var kind path) (once-only ((var var)) `(if (listp ,var) - (let ((sub-list-name (gensym ,sublist-name))) - (push-sub-list-binding sub-list-name ,path ,var - name context error-fun) - (parse-defmacro-lambda-list ,var sub-list-name name - context error-fun)) - (push-let-binding ,var ,path nil)))) + (let ((sublist-name (gensym ,kind))) + (push-sublist-binding sublist-name ,path ,var + name context error-fun) + (parse-defmacro-lambda-list ,var sublist-name name + context + :error-fun error-fun + :sublist t)) + (push-let-binding ,var ,path)))) (normalize-singleton (var) `(when (null (cdr ,var)) (setf (cdr ,var) (list *default-default*))))) - (let ((var (car rest-of-args))) + (let ((var (car rest-of-lambda-list))) (typecase var (list (case now-processing ((:required) (when restp - (defmacro-error (format nil "required argument after ~A" restp) + (defmacro-error (format nil "required argument after ~A" + restp) context name)) - (process-sublist var "SUBLIST-" `(car ,path)) + (process-sublist var "REQUIRED-" `(car ,path)) (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) (normalize-singleton var) - (destructuring-bind (varname &optional initform supplied-p) + (destructuring-bind + (varname &optional default-form suppliedp-name) var - (push-optional-binding varname initform supplied-p - `(not (null ,path)) `(car ,path) - name context error-fun)) + (push-optional-binding varname default-form suppliedp-name + :is-supplied-p `(not (null ,path)) + :path `(car ,path) + :name name + :context context + :error-fun error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) @@ -152,64 +166,63 @@ (keyword (if keyword-given (caar var) (keywordicate variable))) - (supplied-p (caddr var))) - (push-optional-binding variable (cadr var) supplied-p + (default-form (cadr var)) + (suppliedp-name (caddr var))) + (push-optional-binding variable default-form suppliedp-name + :is-supplied-p `(keyword-supplied-p ',keyword ,rest-name) - `(lookup-keyword ',keyword - ,rest-name) - name context error-fun) + :path + `(lookup-keyword ',keyword ,rest-name) + :name name + :context context + :error-fun error-fun) (push keyword keys))) ((:auxs) - (push-let-binding (car var) (cadr var) nil)))) + (push-let-binding (car var) (cadr var))))) ((and symbol (not (eql nil))) (case var (&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)) + (cond ((cdr rest-of-lambda-list) + (pop rest-of-lambda-list) + (process-sublist (car rest-of-lambda-list) + "WHOLE-LIST-" + (if (eq 'define-compiler-macro context) + compiler-macro-whole + whole-var))) (t (defmacro-error "&WHOLE" context name)))) (&environment (cond (env-illegal (error "&ENVIRONMENT is not valid with ~S." context)) - ((not toplevel) + (sublist (error "&ENVIRONMENT is only valid at top level of ~ lambda-list.")) (env-arg-used (error "Repeated &ENVIRONMENT."))) - (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) - (setq rest-of-args (cdr rest-of-args)) - (check-defmacro-arg (car rest-of-args)) - (setq *env-var* (car rest-of-args) + (cond ((and (cdr rest-of-lambda-list) + (symbolp (cadr rest-of-lambda-list))) + (setq rest-of-lambda-list (cdr rest-of-lambda-list)) + (check-defmacro-arg (car rest-of-lambda-list)) + (setq *env-var* (car rest-of-lambda-list) env-arg-used t)) (t (defmacro-error "&ENVIRONMENT" context name)))) ((&rest &body) (cond ((or key-seen aux-seen) - (error "~A after ~A in ~A" var (or key-seen aux-seen) context)) - ((and (not restp) (cdr rest-of-args)) - (setq rest-of-args (cdr rest-of-args) + (error "~A after ~A in ~A" + var (or key-seen aux-seen) context)) + ((and (not restp) (cdr rest-of-lambda-list)) + (setq rest-of-lambda-list (cdr rest-of-lambda-list) restp var) - (process-sublist (car rest-of-args) "REST-LIST-" path)) + (process-sublist (car rest-of-lambda-list) + "REST-LIST-" path)) (t (defmacro-error (symbol-name var) context name)))) (&optional (when (or key-seen aux-seen restp) - (error "~A after ~A in ~A lambda-list." var (or key-seen aux-seen restp) context)) + (error "~A after ~A in ~A lambda-list." + var (or key-seen aux-seen restp) context)) (when optional-seen (error "Multiple ~A in ~A lambda list." var context)) (setq now-processing :optionals @@ -224,10 +237,11 @@ restp var key-seen var) (push rest-name *ignorable-vars*) - (push-let-binding rest-name path t)) + (push-let-binding rest-name path :system t)) (&allow-other-keys (unless (eq now-processing :keywords) - (error "~A outside ~A section of lambda-list in ~A." var '&key context)) + (error "~A outside ~A section of lambda-list in ~A." + var '&key context)) (when allow-other-keys-p (error "Multiple ~A in ~A lambda-list." var context)) (setq allow-other-keys-p t)) @@ -241,14 +255,16 @@ (case now-processing ((:required) (when restp - (defmacro-error (format nil "required argument after ~A" restp) + (defmacro-error (format nil "required argument after ~A" + restp) context name)) - (push-let-binding var `(car ,path) nil) + (push-let-binding var `(car ,path)) (setq minimum (1+ minimum) maximum (1+ maximum) path `(cdr ,path))) ((:optionals) - (push-let-binding var `(car ,path) nil `(not (null ,path))) + (push-let-binding var `(car ,path) + :when `(not (null ,path))) (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) @@ -256,11 +272,10 @@ (push-let-binding var `(lookup-keyword ,key ,rest-name) - nil - `(keyword-supplied-p ,key ,rest-name)) + :when `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) - (push-let-binding var nil nil)))))) + (push-let-binding var nil)))))) (t (error "non-symbol in lambda-list: ~S" var)))))) (let (;; common subexpression, suitable for passing to functions @@ -269,23 +284,32 @@ ;; (expecting MAXIMUM=NIL when there is no maximum) (explicit-maximum (and (not restp) maximum))) (unless (and restp (zerop minimum)) - (push `(unless ,(if restp - ;; (If RESTP, then the argument list might be - ;; dotted, in which case ordinary LENGTH won't - ;; work.) - `(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 ',context ',name ,path-0 - ',lambda-list ,minimum - ,explicit-maximum) - `(,error-fun 'arg-count-error - :kind ',context - ,@(when name `(:name ',name)) - :args ,path-0 - :lambda-list ',lambda-list - :minimum ,minimum - :maximum ,explicit-maximum))) + (push (let ((args-form (if (eq 'define-compiler-macro context) + `(if (eq 'funcall (car ,whole-var)) + (cdr ,path-0) + ,path-0) + path-0))) + (with-unique-names (args) + `(let ((,args ,args-form)) + (unless ,(if restp + ;; (If RESTP, then the argument list + ;; might be dotted, in which case + ;; ordinary LENGTH won't work.) + `(list-of-length-at-least-p ,args ,minimum) + `(proper-list-of-length-p ,args + ,minimum + ,maximum)) + ,(if (eq error-fun 'error) + `(arg-count-error ',context ',name ,args + ',lambda-list ,minimum + ,explicit-maximum) + `(,error-fun 'arg-count-error + :kind ',context + ,@(when name `(:name ',name)) + :args ,args + :lambda-list ',lambda-list + :minimum ,minimum + :maximum ,explicit-maximum)))))) *arg-tests*)) (when key-seen (let ((problem (gensym "KEY-PROBLEM-")) @@ -316,7 +340,7 @@ :minimum minimum :maximum maximum))) -(defun push-sub-list-binding (variable path object name context error-fun) +(defun push-sublist-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable @@ -330,30 +354,32 @@ :lambda-list ',object)))) *system-lets*))) -(defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) +(defun push-let-binding (variable form + &key system when (else *default-default*)) (check-defmacro-arg variable) - (let ((let-form (if condition - `(,variable (if ,condition ,path ,init-form)) - `(,variable ,path)))) - (if systemp - (push let-form *system-lets*) - (push let-form *user-lets*)))) + (let ((let-form (if when + `(,variable (if ,when ,form ,else)) + `(,variable ,form)))) + (if system + (push let-form *system-lets*) + (push let-form *user-lets*)))) -(defun push-optional-binding (value-var init-form supplied-var condition path - name context error-fun) - (unless supplied-var - (setq supplied-var (gensym "SUPPLIEDP-"))) - (push-let-binding supplied-var condition t) +(defun push-optional-binding (value-var init-form suppliedp-name + &key is-supplied-p path name context error-fun) + (unless suppliedp-name + (setq suppliedp-name (gensym "SUPPLIEDP-"))) + (push-let-binding suppliedp-name is-supplied-p :system t) (cond ((consp value-var) (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sub-list-binding whole-thing - `(if ,supplied-var ,path ,init-form) - value-var name context error-fun) + (push-sublist-binding whole-thing + `(if ,suppliedp-name ,path ,init-form) + value-var name context error-fun) (parse-defmacro-lambda-list value-var whole-thing name - context error-fun))) + context + :error-fun error-fun + :sublist t))) ((symbolp value-var) - (push-let-binding value-var path nil supplied-var init-form)) + (push-let-binding value-var path :when suppliedp-name :else init-form)) (t (error "illegal optional variable name: ~S" value-var)))) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 2e6fd3e..724af2f 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1683,10 +1683,7 @@ (defmacro define-instruction-macro (name lambda-list &body body) (with-unique-names (whole env) (multiple-value-bind (body local-defs) - (sb!kernel:parse-defmacro lambda-list - whole - body - name + (sb!kernel:parse-defmacro lambda-list whole body name 'instruction-macro :environment env) `(eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index ede723a..015768c 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -40,42 +40,41 @@ ;;; kind to associate with NAME. (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var) &body body) - (let ((fn-name (symbolicate "IR1-CONVERT-" name)) - (n-form (gensym)) - (n-env (gensym))) - (multiple-value-bind (body decls doc) - (parse-defmacro lambda-list n-form body name "special form" - :environment n-env - :error-fun 'compiler-error - :wrap-block nil) - `(progn - (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) - ,fn-name)) - (defun ,fn-name (,start-var ,next-var ,result-var ,n-form - &aux (,n-env *lexenv*)) - (declare (ignorable ,start-var ,next-var ,result-var)) - ,@decls - ,body - (values)) - ,@(when doc - `((setf (fdocumentation ',name 'function) ,doc))) - ;; FIXME: Evidently "there can only be one!" -- we overwrite any - ;; other :IR1-CONVERT value. This deserves a warning, I think. - (setf (info :function :ir1-convert ',name) #',fn-name) - ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to - ;; the 1990s? - (setf (info :function :kind ',name) :special-form) - ;; It's nice to do this for error checking in the target - ;; SBCL, but it's not nice to do this when we're running in - ;; the cross-compilation host Lisp, which owns the - ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. - #-sb-xc-host - (let ((fun (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function :name ',name)))) - (setf (%simple-fun-arglist fun) ',lambda-list) - (setf (symbol-function ',name) fun)) - ',name)))) + (let ((fn-name (symbolicate "IR1-CONVERT-" name))) + (with-unique-names (whole-var n-env) + (multiple-value-bind (body decls doc) + (parse-defmacro lambda-list whole-var body name "special form" + :environment n-env + :error-fun 'compiler-error + :wrap-block nil) + `(progn + (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) + ,fn-name)) + (defun ,fn-name (,start-var ,next-var ,result-var ,whole-var + &aux (,n-env *lexenv*)) + (declare (ignorable ,start-var ,next-var ,result-var)) + ,@decls + ,body + (values)) + ,@(when doc + `((setf (fdocumentation ',name 'function) ,doc))) + ;; FIXME: Evidently "there can only be one!" -- we overwrite any + ;; other :IR1-CONVERT value. This deserves a warning, I think. + (setf (info :function :ir1-convert ',name) #',fn-name) + ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to + ;; the 1990s? + (setf (info :function :kind ',name) :special-form) + ;; It's nice to do this for error checking in the target + ;; SBCL, but it's not nice to do this when we're running in + ;; the cross-compilation host Lisp, which owns the + ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. + #-sb-xc-host + (let ((fun (lambda (&rest rest) + (declare (ignore rest)) + (error 'special-form-function :name ',name)))) + (setf (%simple-fun-arglist fun) ',lambda-list) + (setf (symbol-function ',name) fun)) + ',name))))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -97,18 +96,16 @@ ;;; OPTIMIZE parameters, then the POLICY macro should be used to ;;; determine when to pass. (defmacro source-transform-lambda (lambda-list &body body) - (let ((n-form (gensym)) - (n-env (gensym)) - (name (gensym))) + (with-unique-names (whole-var n-env name) (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body "source transform" "form" + (parse-defmacro lambda-list whole-var body "source transform" "form" :environment n-env :error-fun `(lambda (&rest stuff) (declare (ignore stuff)) (return-from ,name (values nil t))) :wrap-block nil) - `(lambda (,n-form &aux (,n-env *lexenv*)) + `(lambda (,whole-var &aux (,n-env *lexenv*)) ,@decls (block ,name ,body))))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 5ec5e1c..cb75fe1 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1262,4 +1262,21 @@ (type-error (c) (assert (eq (type-error-expected-type c) 'integer))) (:no-error (&rest vals) (error "no error")))) +;;; FUNCALL forms in compiler macros +(define-compiler-macro test-cmacro-1 + (&whole whole a &optional b &rest c &key d) + (list whole a b c d)) + +(macrolet ((test (form a b c d) + `(let ((form ',form)) + (destructuring-bind (whole a b c d) + (funcall (compiler-macro-function 'test-cmacro-1) form nil) + (assert (equal whole form)) + (assert (eql a ,a)) + (assert (eql b ,b)) + (assert (equal c ,c)) + (assert (eql d ,d))))) ) + (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3) + (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13)) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index fcc68b6..d771f49 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.9.15.25" +"0.9.15.26"