X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=6549d414dfabe0ddde91ba67e98fd16b3d58b8df;hb=1e9966d5f24709d227e20911b4e1ddd27c87a00e;hp=709ba8ee059a31a0cbb954d10be3782550209eeb;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 709ba8e..6549d41 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -47,7 +47,7 @@
 	  ;; 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-fun-p (cdr x))))
 		      (return t)))))
@@ -186,54 +186,43 @@ GET-SETF-EXPANSION directly."
   #!+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)))))
+  (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
@@ -383,14 +372,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
@@ -424,8 +413,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
@@ -434,7 +422,7 @@ GET-SETF-EXPANSION directly."
 	 (assign-setf-macro ',access-fn
 			    (lambda (,whole ,environment)
 			      ,@local-decs
-			      (block ,access-fn ,body))
+			      ,body)
 			    nil
 			    ',doc)))))