The branch "master" has been updated in SBCL:
via 14dbe4cc37ff6847e14ec90e9a75664bb281be3c (commit)
from b910fe1f61d690adf706b78b79314dbe886becd3 (commit)
- Log -----------------------------------------------------------------
commit 14dbe4cc37ff6847e14ec90e9a75664bb281be3c
Author: Alastair Bridgewater <nyef_sbcl@...>
Date: Thu Mar 31 15:33:40 2011 -0400
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
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|