setf: read-modify-write macros should deal with multi-value places gracefully.

  * In PUSH, PUSHNEW, POP, REMF, INCF, DECF and DEFINE-MODIFY-MACRO the
setf-expansion was being obtained via GET-SETF-METHOD, which is the
CLtL1 version of GET-SETF-EXPANSION, but throws an error if a PLACE has
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 846ce95..3ccabe7 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -5,6 +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).
 
 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 4b7271d..7fe66bb 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -212,11 +212,12 @@ GET-SETF-EXPANSION directly."
   "Takes an object and a location holding a list. Conses the object onto
   the list, returning the modified list. OBJ is evaluated before PLACE."
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)
-              (,(car newval) (cons ,g ,getter)))
+              (,(car newval) (cons ,g ,getter))
+              ,@(cdr newval))
          ,setter))))
 
 (defmacro-mundanely pushnew (obj place &rest keys
@@ -228,11 +229,12 @@ GET-SETF-EXPANSION directly."
   is used for the comparison."
   (declare (ignore key test test-not))
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)
-              (,(car newval) (adjoin ,g ,getter ,@keys)))
+              (,(car newval) (adjoin ,g ,getter ,@keys))
+              ,@(cdr newval))
          ,setter))))
 
 (defmacro-mundanely pop (place &environment env)
@@ -240,11 +242,12 @@ GET-SETF-EXPANSION directly."
   "The argument is a location holding a list. Pops one item off the front
   of the list and returns it."
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((list-head (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,list-head ,getter)
-              (,(car newval) (cdr ,list-head)))
+              (,(car newval) (cdr ,list-head))
+              ,@(cdr newval))
          ,setter
          (car ,list-head)))))
 
@@ -255,14 +258,15 @@ GET-SETF-EXPANSION directly."
   remove the property specified by the indicator. Returns T if such a
   property was present, NIL if not."
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((ind-temp (gensym))
           (local1 (gensym))
           (local2 (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               ;; See ANSI 5.1.3 for why we do out-of-order evaluation
               (,ind-temp ,indicator)
-              (,(car newval) ,getter))
+              (,(car newval) ,getter)
+              ,@(cdr newval))
          (do ((,local1 ,(car newval) (cddr ,local1))
               (,local2 nil ,local1))
              ((atom ,local1) nil)
@@ -282,11 +286,12 @@ GET-SETF-EXPANSION directly."
   "The first argument is some location holding a number. This number is
   incremented by the second argument, DELTA, which defaults to 1."
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((d (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,d ,delta)
-              (,(car newval) (+ ,getter ,d)))
+              (,(car newval) (+ ,getter ,d))
+              ,@(cdr newval))
          ,setter))))
 
 (defmacro-mundanely decf (place &optional (delta 1) &environment env)
@@ -294,11 +299,12 @@ GET-SETF-EXPANSION directly."
   "The first argument is some location holding a number. This number is
   decremented by the second argument, DELTA, which defaults to 1."
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)
     (let ((d (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,d ,delta)
-              (,(car newval) (- ,getter ,d)))
+              (,(car newval) (- ,getter ,d))
+              ,@(cdr newval))
          ,setter))))
 \f
 ;;;; DEFINE-MODIFY-MACRO stuff
@@ -337,13 +343,14 @@ GET-SETF-EXPANSION directly."
          ,name (,reference ,@lambda-list &environment ,env)
        ,doc-string
        (multiple-value-bind (dummies vals newval setter getter)
-           (get-setf-method ,reference ,env)
+           (sb!xc:get-setf-expansion ,reference ,env)
          (let ()
              `(let* (,@(mapcar #'list dummies vals)
                      (,(car newval)
                       ,,(if rest-arg
                           `(list* ',function getter ,@other-args ,rest-arg)
-                          `(list ',function getter ,@other-args))))
+                          `(list ',function getter ,@other-args)))
+                     ,@(cdr newval))
                 ,setter))))))
 \f
 ;;;; DEFSETF