setf: pre-defined setf-expanders should handle multiple value places gracefully.

  * The GETF, LOGBITP, LDB and MASK-FIELD setf-expanders all take a
PLACE argument, the setf-expansion for which was being obtained via
GET-SETF-METHOD, which is the CLtL1 version of GET-SETF-EXPANSION, but
throws an error if a PLACE multiple values.  This also pre-dates the
adoption of VALUES places.

  * The most reasonable interpretation of the spec appears to be that
any values after the first are to be ignored upon reading and set to NIL
upon writing.

  * To do so, change each use to SB!XC:GET-SETF-EXPANSION instead of
GET-SETF-METHOD, and bind any symbols in the list of new value locations
to NIL before invoking the setter form.

diff --git a/NEWS b/NEWS
index 3ccabe7..69987ff 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -5,10 +5,10 @@ changes relative to sbcl-1.0.52:
     (signed-byte 63)) to 3 (fixnum = (signed-byte 61)) at build-time.
   * minor(?) incompatible(?) change: The default fixnum width on 64-bit
     targets is now 63 bits (up from 61).
-  * bug fix: PUSH, PUSHNEW, POP, REMF, INCF, DECF, and DEFINE-MODIFY-MACRO
-    now arrange for non-primary values of multiple-valued places to be set
-    to NIL, instead of signalling an error (per a careful reading of CLHS
-    5.1.2.3).
+  * bug fix: PUSH, PUSHNEW, POP, REMF, INCF, DECF, DEFINE-MODIFY-MACRO,
+    GETF, LOGBITP, LDB, and MASK-FIELD now arrange for non-primary values
+    of multiple-valued places to be set to NIL, instead of signalling an
+    error (per a careful reading of CLHS 5.1.2.3).
 
 changes in sbcl-1.0.52 relative to sbcl-1.0.51:
   * enhancement: ASDF has been updated to version 2.017.

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 7fe66bb..e3884e3 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -470,14 +470,15 @@ GET-SETF-EXPANSION directly."
                                   &environment env)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps values stores set get)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((newval (gensym))
           (ptemp (gensym))
           (def-temp (if default (gensym))))
       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
               `(,@values ,prop ,@(if default `(,default)))
               `(,newval)
-              `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
+              `(let ((,(car stores) (%putf ,get ,ptemp ,newval))
+                     ,@(cdr stores))
                  ,set
                  ,newval)
               `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
@@ -508,7 +509,7 @@ GET-SETF-EXPANSION directly."
 (sb!xc:define-setf-expander logbitp (index int &environment env)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps vals stores store-form access-form)
-      (get-setf-method int env)
+      (sb!xc:get-setf-expansion int env)
     (let ((ind (gensym))
           (store (gensym))
           (stemp (first stores)))
@@ -517,7 +518,8 @@ GET-SETF-EXPANSION directly."
                 ,@vals)
               (list store)
               `(let ((,stemp
-                      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
+                      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))
+                     ,@(cdr stores))
                  ,store-form
                  ,store)
               `(logbitp ,ind ,access-form)))))
@@ -552,7 +554,7 @@ GET-SETF-EXPANSION directly."
   place with bits from the low-order end of the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (if (and (consp bytespec) (eq (car bytespec) 'byte))
         (let ((n-size (gensym))
               (n-pos (gensym))
@@ -561,7 +563,8 @@ GET-SETF-EXPANSION directly."
                   (list* (second bytespec) (third bytespec) vals)
                   (list n-new)
                   `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
-                                             ,getter)))
+                                             ,getter))
+                         ,@(cdr newval))
                      ,setter
                      ,n-new)
                   `(ldb (byte ,n-size ,n-pos) ,getter)))
@@ -582,13 +585,14 @@ GET-SETF-EXPANSION directly."
   with bits from the corresponding position in the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((btemp (gensym))
           (gnuval (gensym)))
       (values (cons btemp dummies)
               (cons bytespec vals)
               (list gnuval)
-              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
+              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))
+                     ,@(cdr newval))
                  ,setter
                  ,gnuval)
               `(mask-field ,btemp ,getter)))))