From 14dbe4cc37ff6847e14ec90e9a75664bb281be3c Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Thu, 31 Mar 2011 15:33:40 -0400 Subject: [PATCH] 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. --- NEWS | 4 ++++ src/code/early-setf.lisp | 35 +++++++++++++++++++++-------------- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/NEWS b/NEWS index 846ce95..3ccabe7 100644 --- 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 --- 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)))) ;;;; 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)))))) ;;;; DEFSETF -- 1.7.10.4