From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 2 Jan 2009 11:14:27 +0000 (+0000)
Subject: 1.0.24.2: CONSTANTP aware GET-SETF-EXPANDER
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ce223c3d45046521db9e835fe043b7e9d2c8c3cf;p=sbcl.git

1.0.24.2: CONSTANTP aware GET-SETF-EXPANDER

 * Or rather GET-SETF-METHOD-INVERSE -- check for constant arguments,
   which don't need to be rebound. This allows compiler macros for
   SETF-functions to see their constant arguments.

 * This exposes a small thinko in ACCESSOR-VALUES-INTERNAL (something
   gets optimized during PCL build which wasn't before): EARLY-P there
   doesn't mean the method is early.
---

diff --git a/NEWS b/NEWS
index 6b3c2b9..ef00da9 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,10 @@ changes in sbcl-1.0.25 relative to 1.0.24:
   * improvement: reading from a TWO-WAY-STREAM does not touch the output
     stream anymore making it thread safe to have a concurrent reader and
     a writer, for instance, in a pipe.
+  * improvement: GET-SETF-EXPANDER avoids adding bindings for constant
+    arguments, making compiler-macros for SETF-functions able to inspect
+    their constant arguments.
+
 changes in sbcl-1.0.24 relative to 1.0.23:
   * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data
     vector of a multidimensional SIMPLE-ARRAY.
diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 1487215..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
 
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index c9bdfc3..37002f9 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1235,13 +1235,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                            (class-precedence-list
                                             accessor-class))
                                        :test #'eq)
-                               (if early-p
-                                   (not (eq *the-class-standard-method*
-                                            (early-method-class meth)))
-                                   (accessor-method-p meth))
-                               (if early-p
-                                   (early-accessor-method-slot-name meth)
-                                   (accessor-method-slot-name meth))))))
+                               (accessor-method-p meth)
+                               (accessor-method-slot-name meth)))))
          (slotd (and accessor-class
                      (if early-p
                          (dolist (slot (early-class-slotds accessor-class) nil)
diff --git a/tests/setf.impure.lisp b/tests/setf.impure.lisp
index 0b8a867..cd13d8d 100644
--- a/tests/setf.impure.lisp
+++ b/tests/setf.impure.lisp
@@ -90,4 +90,14 @@
                    (declare (ignore env))
                    `(set-foo ,foo ,new)))))
 
+;;; Not required by the spec, but allowes compiler-macros for SETF-functiosn
+;;; to see their constant argument forms.
+(with-test (:name constantp-aware-get-setf-expansion)
+  (multiple-value-bind (temps values stores set get)
+      (get-setf-expansion '(foo 1 2 3))
+    (assert (not temps))
+    (assert (not values))
+    (assert (equal `(funcall #'(setf foo) ,@stores 1 2 3) set))
+    (assert (equal '(foo 1 2 3) get))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 61bdc6d..1ee247d 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.1"
+"1.0.24.2"