The branch "master" has been updated in SBCL:
via 3c3006c51658323c44c3cec859838bde3ea6b565 (commit)
from 14dbe4cc37ff6847e14ec90e9a75664bb281be3c (commit)
- Log -----------------------------------------------------------------
commit 3c3006c51658323c44c3cec859838bde3ea6b565
Author: Alastair Bridgewater <nyef_sbcl@...>
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
|