From a7a4ca961ef0f587a2549bd9433eef7ddb845ab7 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 28 May 2011 12:27:36 +0000 Subject: [PATCH] 1.0.48.28: make TRULY-THE macroexpandable lp#771673 * MACRO-FUNCTION no longer checks :FUNCTION :KIND, allowing us to have special operators with macro-expansions in the first place. * Add %MACROEXPAND and %MACROEXPAND which are careful not to expand special forms, and use them in place of SB!XC:MACROEXPAND. * Set the :FUNCTION :MACRO-FUNCTION into an expander that just converts it to THE. This only happens when someone explicitly calls MACROEXPAND or uses MACRO-FUNCTION directly -- never in the compiler. * Also add a SETF-expander. --- NEWS | 2 ++ package-data-list.lisp-expr | 4 ++++ src/code/defboot.lisp | 2 +- src/code/early-setf.lisp | 16 +++++++++++----- src/code/host-alieneval.lisp | 4 ++-- src/code/loop.lisp | 8 ++++---- src/code/macroexpand.lisp | 18 ++++++++++++++++++ src/code/macros.lisp | 2 +- src/compiler/assem.lisp | 2 +- src/compiler/constantp.lisp | 4 ++-- src/compiler/fndb.lisp | 3 ++- src/compiler/fopcompile.lisp | 8 ++++---- src/compiler/info-functions.lisp | 13 +++++-------- src/compiler/ir1-translators.lisp | 14 +++++++++++++- src/compiler/main.lisp | 2 +- src/pcl/slots-boot.lisp | 2 +- src/pcl/time.lisp | 8 ++------ src/pcl/vector.lisp | 2 +- src/pcl/walk.lisp | 4 ++-- tests/compiler.pure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 21 files changed, 88 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index aaabe97..319822c 100644 --- a/NEWS +++ b/NEWS @@ -34,6 +34,8 @@ changes relative to sbcl-1.0.48: * bug fix: miscompilation of MULTIPLE-VALUE-CALL when asserting derived types from a function defined in the same file. (regression from 1.0.43.57) + * bug fix: TRULY-THE forms are now macroexpandable and setf-expandable. + (lp#771673) changes in sbcl-1.0.48 relative to sbcl-1.0.47: * incompatible change: SB!KERNEL:INSTANCE-LAMBDA, deprecated for over five diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4cfabd1..1dc2002 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -898,6 +898,10 @@ possibly temporariliy, because it might be used internally." ;; hash mixing operations "MIX" "MIXF" + ;; Macroexpansion that doesn't touch special forms + "%MACROEXPAND" + "%MACROEXPAND-1" + ;; I'm not convinced that FDEFINITIONs are the ideal ;; solution, so exposing ways to peek into the system ;; seems undesirable, since it makes it harder to get diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 85f00c5..385402e 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -448,7 +448,7 @@ evaluated as a PROGN." ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if ;;; appropriate. Gross, but it's what the book seems to say... (defun munge-restart-case-expression (expression env) - (let ((exp (sb!xc:macroexpand expression env))) + (let ((exp (%macroexpand expression env))) (if (consp exp) (let* ((name (car exp)) (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index ddd4755..0c20fef 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -38,7 +38,7 @@ (let (temp) (cond ((symbolp form) (multiple-value-bind (expansion expanded) - (sb!xc:macroexpand-1 form environment) + (%macroexpand-1 form environment) (if expanded (sb!xc:get-setf-expansion expansion environment) (let ((new-var (sb!xc:gensym "NEW"))) @@ -95,7 +95,7 @@ GET-SETF-EXPANSION directly." expand-or-get-setf-inverse)) (defun expand-or-get-setf-inverse (form environment) (multiple-value-bind (expansion expanded) - (sb!xc:macroexpand-1 form environment) + (%macroexpand-1 form environment) (if expanded (sb!xc:get-setf-expansion expansion environment) (get-setf-method-inverse form @@ -599,12 +599,18 @@ GET-SETF-EXPANSION directly." ,gnuval) `(mask-field ,btemp ,getter))))) -(sb!xc:define-setf-expander the (type place &environment env) +(defun setf-expand-the (the type place env) (declare (type sb!c::lexenv env)) (multiple-value-bind (temps subforms store-vars setter getter) (sb!xc:get-setf-expansion place env) (values temps subforms store-vars `(multiple-value-bind ,store-vars - (the ,type (values ,@store-vars)) + (,the ,type (values ,@store-vars)) ,setter) - `(the ,type ,getter)))) + `(,the ,type ,getter)))) + +(sb!xc:define-setf-expander the (type place &environment env) + (setf-expand-the 'the type place env)) + +(sb!xc:define-setf-expander truly-the (type place &environment env) + (setf-expand-the 'truly-the type place env)) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 85859ab..0009b68 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -160,7 +160,7 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) - (sb!xc:macroexpand '&auxiliary-type-definitions& env) + (%macroexpand '&auxiliary-type-definitions& env) (if expanded-p result ;; This is like having the global symbol-macro definition be @@ -1202,7 +1202,7 @@ #!+sb-doc "Return an Alien pointer to the data addressed by Expr, which must be a call to SLOT or DEREF, or a reference to an Alien variable." - (let ((form (sb!xc:macroexpand expr env))) + (let ((form (%macroexpand expr env))) (or (typecase form (cons (case (car form) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 969475a..e4ad5e9 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -98,7 +98,7 @@ (sb!int:defmacro-mundanely loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) - (setq form (sb!xc:macroexpand form env)) + (setq form (sb!int:%macroexpand form env)) (flet ((cdr-wrap (form n) (declare (fixnum n)) (do () ((<= n 4) (setq form `(,(case n @@ -349,7 +349,7 @@ code to be loaded. (and (consp x) (or (not (eq (car x) 'car)) (not (symbolp (cadr x))) - (not (symbolp (setq x (sb!xc:macroexpand x env))))) + (not (symbolp (setq x (sb!int:%macroexpand x env))))) (cons x nil))) (cdr val)) `(,val)))) @@ -657,7 +657,7 @@ code to be loaded. ;;@@@@ ???? (declare (function list-size (list) fixnum)) (cond ((constantp x) 1) ((symbolp x) (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) + (sb!int:%macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) 1))) @@ -703,7 +703,7 @@ code to be loaded. (member fn *estimate-code-size-punt*)) (throw 'estimate-code-size nil)) (t (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) + (sb!int:%macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) (f 3)))))))) diff --git a/src/code/macroexpand.lisp b/src/code/macroexpand.lisp index 4b7a1a2..cb60c38 100644 --- a/src/code/macroexpand.lisp +++ b/src/code/macroexpand.lisp @@ -88,3 +88,21 @@ (frob new-form t) (values new-form expanded))))) (frob form nil))) + +;;; Like MACROEXPAND-1, but takes care not to expand special forms. +(defun %macroexpand-1 (form &optional env) + (if (or (atom form) + (let ((op (car form))) + (not (and (symbolp op) (sb!xc:special-operator-p op))))) + (sb!xc:macroexpand-1 form env) + (values form nil))) + +;;; Like MACROEXPAND, but takes care not to expand special forms. +(defun %macroexpand (form &optional env) + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded-p) + (%macroexpand-1 form env) + (if newly-expanded-p + (frob new-form t) + (values new-form expanded))))) + (frob form nil))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index b886d20..7525fbf 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -73,7 +73,7 @@ invoked. In that case it will store into PLACE and start over." ;; variable to work around Python's blind spot in type derivation. ;; For more complex places getting the type derived should not ;; matter so much anyhow. - (let ((expanded (sb!xc:macroexpand place env))) + (let ((expanded (%macroexpand place env))) (if (symbolp expanded) `(do () ((typep ,place ',type)) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 5fa14f2..7cdc688 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1201,7 +1201,7 @@ body))))))))) (def sb!int:def!macro macroexpand) #+sb-xc-host - (def sb!xc:defmacro sb!xc:macroexpand)) + (def sb!xc:defmacro %macroexpand)) (defmacro inst (&whole whole instruction &rest args &environment env) #!+sb-doc diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp index 1468534..d06d226 100644 --- a/src/compiler/constantp.lisp +++ b/src/compiler/constantp.lisp @@ -29,7 +29,7 @@ (defun %constantp (form environment envp) (let ((form (if envp - (sb!xc:macroexpand form environment) + (%macroexpand form environment) form))) (typecase form ;; This INFO test catches KEYWORDs as well as explicitly @@ -45,7 +45,7 @@ (defun %constant-form-value (form environment envp) (let ((form (if envp - (sb!xc:macroexpand form environment) + (%macroexpand form environment) form))) (typecase form (symbol diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 75f0e00..2086cf4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -142,7 +142,8 @@ (defknown macro-function (symbol &optional lexenv-designator) (or function null) (flushable)) -(defknown (macroexpand macroexpand-1) (t &optional lexenv-designator) +(defknown (macroexpand macroexpand-1 %macroexpand %macroexpand-1) + (t &optional lexenv-designator) (values form &optional boolean)) (defknown compiler-macro-function (t &optional lexenv-designator) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 7a4c332..2ac2385 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -42,7 +42,7 @@ (constant-fopcompilable-p form)) (and (symbolp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form *lexenv*) + (%macroexpand form *lexenv*) (if macroexpanded-p (fopcompilable-p macroexpansion) ;; Punt on :ALIEN variables @@ -51,7 +51,7 @@ (and (listp form) (ignore-errors (list-length form)) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form *lexenv*) + (%macroexpand form *lexenv*) (if macroexpanded-p (fopcompilable-p macroexpansion) (destructuring-bind (operator &rest args) form @@ -244,7 +244,7 @@ (fopcompile-constant form for-value-p)) ((symbolp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (sb!xc:macroexpand form *lexenv*) + (%macroexpand form *lexenv*) (if macroexpanded-p ;; Symbol macro (fopcompile macroexpansion path for-value-p) @@ -276,7 +276,7 @@ for-value-p)))))))))) ((listp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (sb!xc:macroexpand form *lexenv*) + (%macroexpand form *lexenv*) (if macroexpanded-p (fopcompile macroexpansion path for-value-p) (destructuring-bind (operator &rest args) form diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index d4cb02a..e0c29bf 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -141,14 +141,11 @@ only." (declare (symbol symbol)) (let* ((fenv (when env (lexenv-funs env))) (local-def (cdr (assoc symbol fenv)))) - (cond (local-def - (if (and (consp local-def) (eq (car local-def) 'macro)) - (cdr local-def) - nil)) - ((eq (info :function :kind symbol) :macro) - (values (info :function :macro-function symbol))) - (t - nil)))) + (if local-def + (if (and (consp local-def) (eq (car local-def) 'macro)) + (cdr local-def) + nil) + (values (info :function :macro-function symbol))))) (defun (setf sb!xc:macro-function) (function symbol &optional environment) (declare (symbol symbol) (type function function)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index fc33980..9409482 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -597,7 +597,7 @@ be a lambda expression." (def-ir1-translator %funcall ((function &rest args) start next result) ;; MACROEXPAND so that (LAMBDA ...) forms arriving here don't get an ;; extra cast inserted for them. - (let* ((function (sb!xc:macroexpand function *lexenv*)) + (let* ((function (%macroexpand function *lexenv*)) (op (when (consp function) (car function)))) (cond ((eq op 'function) (compiler-destructuring-bind (thing) (cdr function) @@ -916,6 +916,12 @@ is unable to derive from other declared types." ;;; whatever you tell it. It will never generate a type check, but ;;; will cause a warning if the compiler can prove the assertion is ;;; wrong. +;;; +;;; For the benefit of code-walkers we also add a macro-expansion. (Using INFO +;;; directly to get around safeguards for adding a macro-expansion for special +;;; operator.) Because :FUNCTION :KIND remains :SPECIAL-FORM, the compiler +;;; never uses the macro -- but manually calling its MACRO-FUNCTION or +;;; MACROEXPANDing TRULY-THE forms does. (def-ir1-translator truly-the ((value-type form) start next result) #!+sb-doc "Specifies that the values returned by FORM conform to the @@ -926,6 +932,12 @@ Consequences are undefined if any result is not of the declared type -- typical symptoms including memory corruptions. Use with great care." (the-in-policy value-type form '((type-check . 0)) start next result)) + +#-sb-xc-host +(setf (info :function :macro-function 'truly-the) + (lambda (whole env) + (declare (ignore env)) + `(the ,@(cdr whole)))) ;;;; SETQ diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index eae1bd6..84bfea7 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1014,7 +1014,7 @@ Examples: ;;; We only expand one level, so that we retain all the intervening ;;; forms in the source path. (defun preprocessor-macroexpand-1 (form) - (handler-case (sb!xc:macroexpand-1 form *lexenv*) + (handler-case (%macroexpand-1 form *lexenv*) (error (condition) (compiler-error "(during macroexpansion of ~A)~%~A" (let ((*print-level* 2) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 092ad6c..8a5993b 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -74,7 +74,7 @@ (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (aver (constantp slot-name env)) - (setq object (macroexpand object env)) + (setq object (%macroexpand object env)) (let* ((slot-name (constant-form-value slot-name env)) (bind-object (unless (or (constantp new-value env) (atom new-value)) (let* ((object-var (gensym)) diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index 6f21f7c..98a6b89 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -99,12 +99,8 @@ (defun expand-all-macros (form) (walk-form form nil (lambda (form context env) - (if (and (eq context :eval) - (consp form) - (symbolp (car form)) - (not (special-form-p (car form))) - (macro-function (car form))) - (values (macroexpand form env)) + (if (eq context :eval) + (values (%macroexpand form env)) form)))) (push (cons "Macroexpand meth-structure-slot-value" diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index f703f94..6a000b4 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -198,7 +198,7 @@ ;;; Check whether the binding of the named variable is modified in the ;;; method body. (defun parameter-modified-p (parameter-name env) - (let ((modified-variables (macroexpand '%parameter-binding-modified env))) + (let ((modified-variables (%macroexpand '%parameter-binding-modified env))) (memq parameter-name modified-variables))) (defun optimize-slot-value (form slots required-parameters env) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index d56dcb5..4f93a74 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -492,7 +492,7 @@ (multiple-value-bind (newnewform macrop) (walker-environment-bind (new-env env :walk-form newform) - (sb-xc:macroexpand-1 newform new-env)) + (%macroexpand-1 newform new-env)) (cond (macrop (let ((newnewnewform (walk-form-internal newnewform @@ -654,7 +654,7 @@ (null (get-walker-template (car form) form)) (progn (multiple-value-setq (new-form macrop) - (sb-xc:macroexpand-1 form env)) + (%macroexpand-1 form env)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 3ff8d01..b8643a1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3882,3 +3882,13 @@ '(lambda () (eql (make-array 6) (list unbound-variable-1 unbound-variable-2)))))))) + +(with-test (:name :bug-771673) + (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar)))) + ;; Make sure the compiler doesn't use THE, and check that setf-expansions + ;; work. + (let ((f (compile nil `(lambda (x y) + (setf (truly-the fixnum (car x)) y))))) + (let* ((cell (cons t t))) + (funcall f cell :ok) + (assert (equal '(:ok . t) cell))))) diff --git a/version.lisp-expr b/version.lisp-expr index 979193a..76f3bbd 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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".) -"1.0.48.27" +"1.0.48.28" -- 1.7.10.4