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

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index da208b9..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
@@ -393,7 +393,7 @@ GET-SETF-EXPANSION directly."
   #!+sb-doc
   "Associates a SETF update function or macro with the specified access
   function or macro. The format is complex. See the manual for details."
-  (cond ((not (listp (car rest)))
+  (cond ((and (not (listp (car rest))) (symbolp (car rest)))
          `(eval-when (:load-toplevel :compile-toplevel :execute)
             (assign-setf-macro ',access-fn
                                nil
@@ -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))