0.8.16.6:

[sbcl.git] / src / code / early-setf.lisp

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index e4f43ed..4a9aecb 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -85,7 +85,7 @@ GET-SETF-EXPANSION directly."
       (sb!xc:get-setf-expansion form environment)
     (when (cdr store-vars)
       (error "GET-SETF-METHOD used for a form with multiple store ~
-             variables:~%  ~S"
+              variables:~%  ~S"
             form))
     (values temps value-forms store-vars store-form access-form)))
 
@@ -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
@@ -197,9 +213,10 @@ GET-SETF-EXPANSION directly."
 
 (defmacro-mundanely pushnew (obj place &rest keys &environment env)
   #!+sb-doc
-  "Takes an object and a location holding a list. If the object is already
-  in the list, does nothing. Else, conses the object onto the list. Returns
-  NIL. If there is a :TEST keyword, this is used for the comparison."
+  "Takes an object and a location holding a list. If the object is
+  already in the list, does nothing; otherwise, conses the object onto
+  the list. Returns the modified list. If there is a :TEST keyword, this
+  is used for the comparison."
   (multiple-value-bind (dummies vals newval setter getter)
       (get-setf-method place env)
     (let ((g (gensym)))
@@ -320,10 +337,12 @@ GET-SETF-EXPANSION directly."
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   ;;; Assign SETF macro information for NAME, making all appropriate checks.
   (defun assign-setf-macro (name expander inverse doc)
+    (with-single-package-locked-error
+       (:symbol name "defining a setf-expander for ~A"))
     (cond ((gethash name sb!c:*setf-assumed-fboundp*)
           (warn
            "defining setf macro for ~S when ~S was previously ~
-            treated as a function"
+             treated as a function"
            name
            `(setf ,name)))
          ((not (fboundp `(setf ,name)))