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

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 1487215..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)))
+                 (let ((new-var (sb!xc:gensym "NEW")))
                    (values nil nil (list new-var)
                            `(setq ,form ,new-var) form)))))
           ;; Local functions inhibit global SETF methods.
@@ -53,7 +53,7 @@
                       (return t)))))
            (expand-or-get-setf-inverse form environment))
           ((setq temp (info :setf :inverse (car form)))
-           (get-setf-method-inverse form `(,temp) nil))
+           (get-setf-method-inverse form `(,temp) nil environment))
           ((setq temp (info :setf :expander (car form)))
            ;; KLUDGE: It may seem as though this should go through
            ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
@@ -95,26 +95,34 @@ 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
                                  `(funcall #'(setf ,(car form)))
-                                 t))))
+                                 t
+                                 environment))))
 
-(defun get-setf-method-inverse (form inverse setf-fun)
-  (let ((new-var (gensym))
+(defun get-setf-method-inverse (form inverse setf-fun environment)
+  (let ((new-var (sb!xc:gensym "NEW"))
         (vars nil)
-        (vals nil))
-    (dolist (x (cdr form))
-      (push (gensym) vars)
-      (push x vals))
-    (setq vals (nreverse vals))
-    (values vars vals (list new-var)
+        (vals nil)
+        (args nil))
+    (dolist (x (reverse (cdr form)))
+      (cond ((sb!xc:constantp x environment)
+             (push x args))
+            (t
+             (let ((temp (gensym "TMP")))
+               (push temp args)
+               (push temp vars)
+               (push x vals)))))
+    (values vars
+            vals
+            (list new-var)
             (if setf-fun
-                `(,@inverse ,new-var ,@vars)
-                `(,@inverse ,@vars ,new-var))
-            `(,(car form) ,@vars))))
+                `(,@inverse ,new-var ,@args)
+                `(,@inverse ,@args ,new-var))
+            `(,(car form) ,@args))))
 
 ;;;; SETF itself
 
@@ -385,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
@@ -396,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))))))
@@ -593,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))