X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=0c20fefcc8d93d22de5ec53e1a0ffa578f6d28ee;hb=dafa18aa6bd65fe2129a32b0e827141684bb159a;hp=ddd47550aca2dc962c3043553d837bbad264aab6;hpb=cc24446c5ba765a69c0465832f1ed43227fccd47;p=sbcl.git

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))