[Sbcl-commits] master: setf: pre-defined setf-expanders should handle multiple value places gracefully.

[Alastair B. <lis...@us...>]

The branch "master" has been updated in SBCL:
       via  3c3006c51658323c44c3cec859838bde3ea6b565 (commit)
      from  14dbe4cc37ff6847e14ec90e9a75664bb281be3c (commit)

- Log -----------------------------------------------------------------
commit 3c3006c51658323c44c3cec859838bde3ea6b565
Author: Alastair Bridgewater <nye...@li...>
Date:   Thu Mar 31 16:00:48 2011 -0400

    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.
---
 NEWS                     |    8 ++++----
 src/code/early-setf.lisp |   20 ++++++++++++--------
 2 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/NEWS b/NEWS
index 3ccabe7..69987ff 100644
--- 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
--- 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)))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL