X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=4a9aecbaff2c2cda253c4c8b7bfe5881e085aee3;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=86968cfe812cb552eb98ece83163b8062a031be4;hpb=db55ad022ec7cc7a2f251918579fdeba7f17dbe0;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 86968cf..4a9aecb 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -47,9 +47,9 @@
 	  ;; Local functions inhibit global SETF methods.
 	  ((and environment
 		(let ((name (car form)))
-		  (dolist (x (sb!c::lexenv-functions environment))
+		  (dolist (x (sb!c::lexenv-funs environment))
 		    (when (and (eq (car x) name)
-			       (not (sb!c::defined-function-p (cdr x))))
+			       (not (sb!c::defined-fun-p (cdr x))))
 		      (return t)))))
 	   (expand-or-get-setf-inverse form environment))
 	  ((setq temp (info :setf :inverse (car form)))
@@ -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)
@@ -101,7 +102,7 @@ GET-SETF-EXPANSION directly."
 				 `(funcall #'(setf ,(car form)))
 				 t))))
 
-(defun get-setf-method-inverse (form inverse setf-function)
+(defun get-setf-method-inverse (form inverse setf-fun)
   (let ((new-var (gensym))
 	(vars nil)
 	(vals nil))
@@ -110,7 +111,7 @@ GET-SETF-EXPANSION directly."
       (push x vals))
     (setq vals (nreverse vals))
     (values vars vals (list new-var)
-	    (if setf-function
+	    (if setf-fun
 		`(,@inverse ,new-var ,@vars)
 		`(,@inverse ,@vars ,new-var))
 	    `(,(car form) ,@vars))))
@@ -164,76 +165,82 @@ 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
   "Takes an object and a location holding a list. Conses the object onto
   the list, returning the modified list. OBJ is evaluated before PLACE."
-  (if (symbolp place)
-      `(setq ,place (cons ,obj ,place))
-      (multiple-value-bind
-	  (dummies vals newval setter getter)
-	  (get-setf-method place env)
-	(let ((g (gensym)))
-	  `(let* ((,g ,obj)
-		  ,@(mapcar #'list dummies vals)
-		  (,(car newval) (cons ,g ,getter)))
-	    ,setter)))))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (let ((g (gensym)))
+      `(let* ((,g ,obj)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (cons ,g ,getter)))
+         ,setter))))
 
 (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."
-  (if (symbolp place)
-      `(setq ,place (adjoin ,obj ,place ,@keys))
-      (multiple-value-bind (dummies vals newval setter getter)
-	  (get-setf-method place env)
-	(do* ((d dummies (cdr d))
-	      (v vals (cdr v))
-	      (let-list nil))
-	     ((null d)
-	      (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
-		    let-list)
-	      `(let* ,(nreverse let-list)
-		 ,setter))
-	  (push (list (car d) (car v)) let-list)))))
+  "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)))
+      `(let* ((,g ,obj)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (adjoin ,g ,getter ,@keys)))
+         ,setter))))
 
 (defmacro-mundanely pop (place &environment env)
   #!+sb-doc
   "The argument is a location holding a list. Pops one item off the front
   of the list and returns it."
-  (if (symbolp place)
-      `(prog1 (car ,place) (setq ,place (cdr ,place)))
-      (multiple-value-bind (dummies vals newval setter getter)
-	  (get-setf-method place env)
-	(do* ((d dummies (cdr d))
-	      (v vals (cdr v))
-	      (let-list nil))
-	     ((null d)
-	      (push (list (car newval) getter) let-list)
-	      `(let* ,(nreverse let-list)
-		 (prog1 (car ,(car newval))
-			(setq ,(car newval) (cdr ,(car newval)))
-			,setter)))
-	  (push (list (car d) (car v)) let-list)))))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (do* ((d dummies (cdr d))
+          (v vals (cdr v))
+          (let-list nil))
+         ((null d)
+          (push (list (car newval) getter) let-list)
+          `(let* ,(nreverse let-list)
+             (prog1 (car ,(car newval))
+               (setq ,(car newval) (cdr ,(car newval)))
+               ,setter)))
+      (push (list (car d) (car v)) let-list))))
 
 (defmacro-mundanely remf (place indicator &environment env)
   #!+sb-doc
@@ -330,20 +337,17 @@ 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)))
 	   ;; All is well, we don't need any warnings.
 	   (values))
-	  ((info :function :accessor-for name)
-	   (warn "defining SETF macro for DEFSTRUCT slot ~
-		 accessor; redefining as a normal function: ~S"
-		 name)
-	   (proclaim-as-function-name name))
 	  ((not (eq (symbol-package name) (symbol-package 'aref)))
 	   (style-warn "defining setf macro for ~S when ~S is fbound"
 		       name `(setf ,name))))
@@ -383,19 +387,19 @@ GET-SETF-EXPANSION directly."
 	       `(eval-when (:compile-toplevel :load-toplevel :execute)
 		  (assign-setf-macro
 		   ',access-fn
-		   #'(lambda (,access-form-var ,env-var)
-		       (declare (ignore ,env-var))
-		       (%defsetf ,access-form-var ,(length store-variables)
-				 #'(lambda (,arglist-var)
-				     ,@local-decs
-				     (block ,access-fn
-				       ,body))))
+		   (lambda (,access-form-var ,env-var)
+		     (declare (ignore ,env-var))
+		     (%defsetf ,access-form-var ,(length store-variables)
+			       (lambda (,arglist-var)
+				 ,@local-decs
+                                 ,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
@@ -429,17 +433,16 @@ 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
 			:environment environment)
       `(eval-when (:compile-toplevel :load-toplevel :execute)
 	 (assign-setf-macro ',access-fn
-			    #'(lambda (,whole ,environment)
-				,@local-decs
-				(block ,access-fn ,body))
+			    (lambda (,whole ,environment)
+			      ,@local-decs
+			      ,body)
 			    nil
 			    ',doc)))))