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).
     (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.
 
 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)
                                   &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 ((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)))))))
                  ,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)
 (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)))
     (let ((ind (gensym))
           (store (gensym))
           (stemp (first stores)))

@@ -517,7 +518,8 @@ GET-SETF-EXPANSION directly."
                 ,@vals)
               (list store)
               `(let ((,stemp
                 ,@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)))))
                  ,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)
   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))
     (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)
                   (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)))
                      ,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)
   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 ((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)))))
                  ,setter
                  ,gnuval)
               `(mask-field ,btemp ,getter)))))