X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=4a9aecbaff2c2cda253c4c8b7bfe5881e085aee3;hb=063f2d867cfdfee8a7cbab17e6c5054d9c6f3ad1;hp=6549d414dfabe0ddde91ba67e98fd16b3d58b8df;hpb=47da3aec921176b189868519273b5bddb8bcc737;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 6549d41..4a9aecb 100644
--- 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)))