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 8c5235a..4a9aecb 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -85,13 +85,14 @@ 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)))
 
 ;;; If a macro, expand one level and try again. If not, go for the
 ;;; SETF function.
-(declaim (ftype (function (t sb!c::lexenv)) expand-or-get-setf-inverse))
+(declaim (ftype (function (t (or null sb!c::lexenv)))
+               expand-or-get-setf-inverse))
 (defun expand-or-get-setf-inverse (form environment)
   (multiple-value-bind (expansion expanded)
       (sb!xc:macroexpand-1 form environment)
@@ -164,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
@@ -196,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)))
@@ -319,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)))
@@ -372,14 +392,14 @@ GET-SETF-EXPANSION directly."
                     (%defsetf ,access-form-var ,(length store-variables)
                               (lambda (,arglist-var)
                                 ,@local-decs
-                                (block ,access-fn
-                                  ,body))))
+                                 ,body)))
                   nil
                   ',doc))))))
        (t
         (error "ill-formed DEFSETF for ~S" access-fn))))
 
 (defun %defsetf (orig-access-form num-store-vars expander)
+  (declare (type function expander))
   (let (subforms
        subform-vars
        subform-exprs
@@ -413,8 +433,7 @@ GET-SETF-EXPANSION directly."
   (unless (symbolp access-fn)
     (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
           access-fn))
-  (let ((whole (gensym "WHOLE-"))
-       (environment (gensym "ENV-")))
+  (with-unique-names (whole environment)
     (multiple-value-bind (body local-decs doc)
        (parse-defmacro lambda-list whole body access-fn
                        'sb!xc:define-setf-expander
@@ -423,7 +442,7 @@ GET-SETF-EXPANSION directly."
         (assign-setf-macro ',access-fn
                            (lambda (,whole ,environment)
                              ,@local-decs
-                             (block ,access-fn ,body))
+                             ,body)
                            nil
                            ',doc)))))