From 3c3006c51658323c44c3cec859838bde3ea6b565 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Thu, 31 Mar 2011 16:00:48 -0400 Subject: [PATCH] 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))))) -- 1.7.10.4