* 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
;; 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
;;; 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))))
(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")))
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
,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))
(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
#!+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)
(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
(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))))
;;@@@@ ???? (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)))
(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))))))))
(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)))
;; 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))
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
(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
(defun %constant-form-value (form environment envp)
(let ((form (if envp
- (sb!xc:macroexpand form environment)
+ (%macroexpand form environment)
form)))
(typecase form
(symbol
(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)
(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
(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
(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)
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
(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))
(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)
;;; 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
-- 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))))
\f
;;;; SETQ
;;; 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)
(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))
(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"
;;; 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)
(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
(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.
'(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)))))
;;; 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"
projects / sbcl.git / commitdiff