X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=2185a96e640675f4c023551f3f1f312048145c10;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=76a8c438983c1406f00fe52c9d765866f49b2278;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 76a8c43..2185a96 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -91,7 +91,8 @@ GET-SETF-EXPANSION directly."
 
 ;;; 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,6 +337,8 @@ 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 ~
@@ -372,8 +392,7 @@ GET-SETF-EXPANSION directly."
 		     (%defsetf ,access-form-var ,(length store-variables)
 			       (lambda (,arglist-var)
 				 ,@local-decs
-				 (block ,access-fn
-				   ,body))))
+                                 ,body)))
 		   nil
 		   ',doc))))))
 	(t
@@ -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)))))