From: Nikodemus Siivola Date: Sat, 15 May 2004 12:09:19 +0000 (+0000) Subject: 0.8.10.24: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9ef5be5321618ef470f17d274c1a64b2b487d54f;p=sbcl.git 0.8.10.24: Fixed bug 316: SHIFTF of VALUES ... Filched the CMUCL SHIFT, which some adaptions. ... Regression test. ... Note to self: remove BUGS entries fully unless the last one. --- diff --git a/BUGS b/BUGS index 15c55b5..c848583 100644 --- a/BUGS +++ b/BUGS @@ -1380,17 +1380,6 @@ WORKAROUND: the heap and certainly confuses the world if that string is used by C code. -316: "SHIFTF and multiple values" - reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP - test suite. - (shiftf (values x y) (values y x)) - gives an error in sbcl-0.8.10. - - Parts of the explanation of SHIFTF in ANSI CL talk about multiple - store variables, and the X3J13 vote - SETF-MULTIPLE-STORE-VARIABLES:ALLOW also says that SHIFTF should - support multiple value places. - 317: "FORMAT of floating point numbers" reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP test suite. @@ -1456,9 +1445,6 @@ WORKAROUND: (vector-push-extend (list 'string p1 p2) s)) (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s))) -322: "DEFSTRUCT :TYPE LIST predicate and improper lists" - (fixed in sbcl-0.8.10.23) - 323: "REPLACE, BIT-BASH and large strings" The transform for REPLACE on simple-base-strings uses BIT-BASH, which at present has an upper limit in size. Consequently, in sbcl-0.8.10 diff --git a/NEWS b/NEWS index b2579e9..2fc9a8f 100644 --- a/NEWS +++ b/NEWS @@ -2398,6 +2398,8 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: to Bruno Haible) changes in sbcl-0.8.11 relative to sbcl-0.8.10: + * fixed bug 316: SHIFTF now accepts VALUES forms. (reported by Bruno + Haible) * fixed bug 322: DEFSTRUCT :TYPE LIST type predicates now handle improper lists correctly. (reported by Bruno Haible) * fixed bug 313: source-transform for was erroneously diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 4f7a94a..7f6dce7 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -165,23 +165,39 @@ GET-SETF-EXPANSION directly." returning the value of the leftmost." (when (< (length args) 2) (error "~S called with too few arguments: ~S" 'shiftf form)) - (let ((resultvar (gensym))) - (do ((arglist args (cdr arglist)) - (bindlist nil) - (storelist nil) - (lastvar resultvar)) - ((atom (cdr arglist)) - (push `(,lastvar ,(first arglist)) bindlist) - `(let* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar)) - (multiple-value-bind (sm1 sm2 sm3 sm4 sm5) - (get-setf-method (first arglist) env) - (mapc (lambda (var val) - (push `(,var ,val) bindlist)) - sm1 - sm2) - (push `(,lastvar ,sm5) bindlist) - (push sm4 storelist) - (setq lastvar (first sm3)))))) + (let (let*-bindings mv-bindings setters getters) + (dolist (arg (butlast args)) + (multiple-value-bind (temps subforms store-vars setter getter) + (sb!xc:get-setf-expansion arg env) + (mapc (lambda (tmp form) + (push `(,tmp ,form) let*-bindings)) + temps + subforms) + (push store-vars mv-bindings) + (push setter setters) + (push getter getters))) + ;; Handle the last arg specially here. The getter is just the last + ;; arg itself. + (push (car (last args)) getters) + + ;; Reverse the collected lists so last bit looks nicer. + (setf let*-bindings (nreverse let*-bindings) + mv-bindings (nreverse mv-bindings) + setters (nreverse setters) + getters (nreverse getters)) + + (labels ((thunk (mv-bindings getters) + (if mv-bindings + `((multiple-value-bind + ,(car mv-bindings) + ,(car getters) + ,@(thunk (cdr mv-bindings) (cdr getters)))) + `(,@setters)))) + `(let ,let*-bindings + (multiple-value-bind ,(car mv-bindings) + ,(car getters) + ,@(thunk mv-bindings (cdr getters)) + (values ,@(car mv-bindings))))))) (defmacro-mundanely push (obj place &environment env) #!+sb-doc diff --git a/tests/setf.impure.lisp b/tests/setf.impure.lisp index 77c4ac5..bc4f011 100644 --- a/tests/setf.impure.lisp +++ b/tests/setf.impure.lisp @@ -23,5 +23,11 @@ ;;; environment object. (assert (multiple-value-list (get-setf-expansion '(foo)))) +;;; Regression test for SHIFTF of values. +(let ((x (list 1)) + (y (list 2))) + (shiftf (values (car x) (car y)) (values (car y) (car x))) + (assert (equal (list x y) '((2) (1))))) + ;;; success -(quit :unix-status 104) \ No newline at end of file +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index e5666ca..466d441 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.10.23" +"0.8.10.24"