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 (file)
--- 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 (file)
--- 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 <fun-name> was erroneously

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 4f7a94a..7f6dce7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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"