X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=76a8c438983c1406f00fe52c9d765866f49b2278;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=e532da630405d1f31ec49bb9bf433b0cee49d239;hpb=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index e532da6..76a8c43 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)))))
@@ -101,7 +101,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 +110,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))))
@@ -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
@@ -391,6 +380,7 @@ GET-SETF-EXPANSION directly."
 	 (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 +414,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