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

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index c55cf6a..b1d583f 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -41,7 +41,7 @@
                (sb!xc:macroexpand-1 form environment)
              (if expanded
                  (sb!xc:get-setf-expansion expansion environment)
-                 (let ((new-var (gensym)))
+                 (let ((new-var (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
@@ -100,21 +100,29 @@ GET-SETF-EXPANSION directly."
         (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 (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
 
@@ -211,12 +219,14 @@ GET-SETF-EXPANSION directly."
               (,(car newval) (cons ,g ,getter)))
          ,setter))))
 
-(defmacro-mundanely pushnew (obj place &rest keys &environment env)
+(defmacro-mundanely pushnew (obj place &rest keys
+                             &key key test test-not &environment env)
   #!+sb-doc
   "Takes an object and a location holding a list. If the object is
   already in the list, does nothing; otherwise, conses the object onto
   the list. Returns the modified list. If there is a :TEST keyword, this
   is used for the comparison."
+  (declare (ignore key test test-not))
   (multiple-value-bind (dummies vals newval setter getter)
       (get-setf-method place env)
     (let ((g (gensym)))
@@ -307,8 +317,9 @@ GET-SETF-EXPANSION directly."
   "Creates a new read-modify-write macro like PUSH or INCF."
   (let ((other-args nil)
         (rest-arg nil)
-        (env (gensym))
-        (reference (gensym)))
+        (env (make-symbol "ENV"))          ; To beautify resulting arglist.
+        (reference (make-symbol "PLACE"))) ; Note that these will be nonexistent
+                                           ;  in the final expansion anyway.
     ;; Parse out the variable names and &REST arg from the lambda list.
     (do ((ll lambda-list (cdr ll))
          (arg nil))
@@ -393,21 +404,21 @@ GET-SETF-EXPANSION directly."
          (destructuring-bind
              (lambda-list (&rest store-variables) &body body)
              rest
-           (let ((arglist-var (gensym "ARGS-"))
+           (let ((whole-var (gensym "WHOLE-"))
                  (access-form-var (gensym "ACCESS-FORM-"))
                  (env-var (gensym "ENVIRONMENT-")))
              (multiple-value-bind (body local-decs doc)
                  (parse-defmacro `(,lambda-list ,@store-variables)
-                                 arglist-var body access-fn 'defsetf
+                                 whole-var body access-fn 'defsetf
+                                 :environment env-var
                                  :anonymousp t)
                `(eval-when (:compile-toplevel :load-toplevel :execute)
                   (assign-setf-macro
                    ',access-fn
                    (lambda (,access-form-var ,env-var)
-                     (declare (ignore ,env-var))
+                     ,@local-decs
                      (%defsetf ,access-form-var ,(length store-variables)
-                               (lambda (,arglist-var)
-                                 ,@local-decs
+                               (lambda (,whole-var)
                                  ,body)))
                    nil
                    ',doc))))))