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

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index b1d583f..0c20fef 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -38,10 +38,10 @@
   (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 (gensym "NEW")))
+                 (let ((new-var (sb!xc:gensym "NEW")))
                    (values nil nil (list new-var)
                            `(setq ,form ,new-var) form)))))
           ;; Local functions inhibit global SETF methods.
@@ -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
@@ -104,7 +104,7 @@ GET-SETF-EXPANSION directly."
                                  environment))))
 
 (defun get-setf-method-inverse (form inverse setf-fun environment)
-  (let ((new-var (gensym "NEW"))
+  (let ((new-var (sb!xc:gensym "NEW"))
         (vars nil)
         (vals nil)
         (args nil))
@@ -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
@@ -404,21 +404,19 @@ GET-SETF-EXPANSION directly."
          (destructuring-bind
              (lambda-list (&rest store-variables) &body body)
              rest
-           (let ((whole-var (gensym "WHOLE-"))
-                 (access-form-var (gensym "ACCESS-FORM-"))
-                 (env-var (gensym "ENVIRONMENT-")))
+           (with-unique-names (whole access-form environment)
              (multiple-value-bind (body local-decs doc)
                  (parse-defmacro `(,lambda-list ,@store-variables)
-                                 whole-var body access-fn 'defsetf
-                                 :environment env-var
+                                 whole body access-fn 'defsetf
+                                 :environment environment
                                  :anonymousp t)
                `(eval-when (:compile-toplevel :load-toplevel :execute)
                   (assign-setf-macro
                    ',access-fn
-                   (lambda (,access-form-var ,env-var)
+                   (lambda (,access-form ,environment)
                      ,@local-decs
-                     (%defsetf ,access-form-var ,(length store-variables)
-                               (lambda (,whole-var)
+                     (%defsetf ,access-form ,(length store-variables)
+                               (lambda (,whole)
                                  ,body)))
                    nil
                    ',doc))))))
@@ -601,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))