diff --git a/code/macros.lisp b/code/macros.lisp
index 3fce31ac6a93ea20b2d5fbd9e4dfa9d752fed4d9..0b2fb33f2d4dd624b8c1c02f33c92e092847424c 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -7,17 +7,15 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.21 1991/04/20 14:20:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.22 1991/05/08 16:30:04 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.21 1991/04/20 14:20:06 ram Exp $
-;;;
 ;;; This file contains the macros that are part of the standard
 ;;; Spice Lisp environment.
 ;;;
 ;;; Written by Scott Fahlman and Rob MacLachlan.
-;;; Modified by Bill Chiles to adhere to
+;;; Modified by Bill Chiles to adhere to the wall.
 ;;;
 (in-package "LISP")
 (export '(defvar defparameter defconstant when unless setf
@@ -169,15 +167,37 @@
 					 'define-setf-method
 					 :environment environment)
       `(eval-when (load compile eval)
-	 (setf (info setf inverse ',access-fn) nil)
-	 (setf (info setf expander ',access-fn)
-	       #'(lambda (,whole ,environment)
-		   ,@local-decs
-		   (block ,access-fn ,body)))
-	 ,@(when doc
-	     `((setf (documentation ',access-fn 'setf) ,doc)))
-	 ',access-fn))))
+	 (%define-setf-macro
+	  ',access-fn
+	  #'(lambda (,whole ,environment)
+	      ,@local-decs
+	      (block ,access-fn ,body))
+	  nil
+	  ',doc)))))
+
 
+;;; %DEFINE-SETF-MACRO  --  Internal
+;;;
+;;;    Do stuff for defining a setf macro.
+;;;
+(defun %define-setf-macro (name expander inverse doc)
+  (cond ((not (fboundp `(setf ,name))))
+	((info function accessor-for name)
+	 (warn "Defining setf macro for destruct slot accessor; redefining as ~
+	        a normal function:~%  ~S"
+	       name)
+	 (c::define-function-name name))
+	((not (eq (symbol-package name) (symbol-package 'aref)))
+	 (warn "Defining setf macro for ~S, but ~S is fbound."
+	       name `(setf ,name))))
+  (when (or inverse (info setf inverse name))
+    (setf (info setf inverse name) inverse))
+  (when (or expander (info setf expander name))
+    (setf (info setf expander name) expander))
+  (when doc
+    (setf (documentation name 'setf) doc))
+  name)
+  
 
 ;;;; Destructuring-bind
 
@@ -470,8 +490,9 @@
     (cond ((symbolp form)
 	   (let ((new-var (gensym)))
 	     (values nil nil (list new-var) `(setq ,form ,new-var) form)))
-	  ((atom form)
-	   (error "~S illegal atomic form for GET-SETF-METHOD." form))
+	  ((and environment
+		(assoc (car form) (c::lexenv-functions environment)))
+	   (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
 	  ;;
 	  ;; ### Bootstrap hack...
 	  ;; Ignore any DEFSETF info for structure accessors.
@@ -531,12 +552,9 @@
   details."
   (cond ((not (listp (car rest)))
 	 `(eval-when (load compile eval)
-	    (setf (info setf inverse ',access-fn) ',(car rest))
-	    (setf (info setf expander ',access-fn) nil)
-	    ,@(if (and (car rest) (stringp (cadr rest)))
-		  `((eval-when (load eval)
-		      (%put ',access-fn '%setf-documentation ,(cadr rest)))))
-	    ',access-fn))
+	    (%define-setf-macro ',access-fn nil ',(car rest)
+				,(when (and (car rest) (stringp (cadr rest)))
+				   `',(cadr rest)))))
 	((and (listp (car rest)) (cdr rest) (listp (cadr rest)))
 	 (if (not (= (length (cadr rest)) 1))
 	     (cerror "Ignore the extra items in the list."
@@ -544,32 +562,26 @@
 	 (multiple-value-bind (setting-form-generator doc)
 			      (defsetter access-fn rest)
 	   `(eval-when (load compile eval)
-	      (setf (info setf inverse ',access-fn) nil)
-	      (setf (info setf expander ',access-fn)
-		    #'(lambda (access-form environment)
-			(declare (ignore environment))
-			(do* ((args (cdr access-form) (cdr args))
-			      (dummies nil (cons (gensym) dummies))
-			      (newval-var (gensym))
-			      (new-access-form nil))
-			     ((atom args)
-			      (setq new-access-form 
-				    (cons (car access-form) dummies))
-			      (values
-			       dummies
-			       (cdr access-form)
-			       (list newval-var)
-			       (funcall (function ,setting-form-generator)
-					new-access-form newval-var)
-			       new-access-form)))))
-	      ,@(if doc
-		    `((eval-when (load eval)
-			(setf (info setf documentation ',access-fn) ',doc)))
-		    `((eval-when (load eval)
-			(or (clear-info setf documentation ',access-fn)
-			    (setf (info setf documentation ',access-fn)
-				  nil)))))
-	      ',access-fn)))
+	      (%define-setf-macro
+	       ',access-fn
+	       #'(lambda (access-form environment)
+		   (declare (ignore environment))
+		   (do* ((args (cdr access-form) (cdr args))
+			 (dummies nil (cons (gensym) dummies))
+			 (newval-var (gensym))
+			 (new-access-form nil))
+			((atom args)
+			 (setq new-access-form 
+			       (cons (car access-form) dummies))
+			 (values
+			  dummies
+			  (cdr access-form)
+			  (list newval-var)
+			  (funcall (function ,setting-form-generator)
+				   new-access-form newval-var)
+			  new-access-form))))
+	       nil
+	       ',doc))))
 	(t (error "Ill-formed DEFSETF for ~S." access-fn))))
 
 (defmacro setf (&rest args &environment env)
@@ -577,33 +589,31 @@
   is the value that is supposed to go into that place.  Returns the last
   value.  The place argument may be any of the access forms for which SETF
   knows a corresponding setting form."
-  (let ((temp (length args)))
-    (cond ((= temp 2)
-	   (cond ((atom (car args))
-		  `(setq ,(car args) ,(cadr args)))
-		 ((info function accessor-for (caar args))
-		  `(funcall #'(setf ,(caar args)) ,(cadr args) ,@(cdar args)))
-		 ((setq temp (info setf inverse (caar args)))
-		  `(,temp ,@(cdar args) ,(cadr args)))
-		 (t (multiple-value-bind (dummies vals newval setter getter)
-					 (get-setf-method (car args) env)
-		      (declare (ignore getter))
-		      (do* ((d dummies (cdr d))
-			    (v vals (cdr v))
-			    (let-list nil))
-			   ((null d)
-			    (setq let-list
-				  (nreverse (cons (list (car newval)
-							(cadr args))
-						  let-list)))
-			    `(let* ,let-list ,setter))
-			(setq let-list
-			      (cons (list (car d) (car v)) let-list)))))))
-	  ((oddp temp) 
-	   (error "Odd number of args to SETF."))
-	  (t (do ((a args (cddr a)) (l nil))
-		 ((null a) `(progn ,@(nreverse l)))
-	       (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
+  (let ((nargs (length args)))
+    (cond
+     ((= nargs 2)
+      (if (atom (car args))
+	  `(setq ,(car args) ,(cadr args))
+	  (multiple-value-bind (dummies vals newval setter getter)
+			       (get-setf-method (car args) env)
+	    (declare (ignore getter))
+	    (do* ((d dummies (cdr d))
+		  (v vals (cdr v))
+		  (let-list nil))
+		 ((null d)
+		  (setq let-list
+			(nreverse (cons (list (car newval)
+					      (cadr args))
+					let-list)))
+		  `(let* ,let-list ,setter))
+	      (setq let-list
+		    (cons (list (car d) (car v)) let-list))))))
+     ((oddp nargs) 
+      (error "Odd number of args to SETF."))
+     (t
+      (do ((a args (cddr a)) (l nil))
+	  ((null a) `(progn ,@(nreverse l)))
+	(setq l (cons (list 'setf (car a) (cadr a)) l)))))))
 
 
 (defmacro psetf (&rest args &environment env)
@@ -947,39 +957,35 @@
 	  ,v))
 
 
-;;; Evil hack invented by the gnomes of Vassar Street.  The function
-;;; arg must be constant.  Get a setf method for this function, pretending
-;;; that the final (list) arg to apply is just a normal arg.  If the
-;;; setting and access forms produced in this way reference this arg at
-;;; the end, then just splice the APPLY back onto the front and the right
-;;; thing happens.
-
+;;; Evil hack invented by the gnomes of Vassar Street.  The function arg must
+;;; be constant.  Get a setf method for this function, pretending that the
+;;; final (list) arg to apply is just a normal arg.  If the setting and access
+;;; forms produced in this way reference this arg at the end, then just splice
+;;; the APPLY back onto the front and the right thing happens.
+;;;
+;;; We special-case uses functions in the Lisp package so that APPLY AREF works
+;;; even though %ASET takes the new-value last.  (there is (SETF AREF) as well
+;;; as a setf method, etc.)
+;;;
 (define-setf-method apply (function &rest args &environment env)
-  (if (and (listp function)
-	   (= (list-length function) 2)
-	   (eq (first function) 'function)
-	   (symbolp (second function)))
-      (setq function (second function))
-      (error
-       "Setf of Apply is only defined for function args of form #'symbol."))
-  (multiple-value-bind (dummies vals newval setter getter)
-		       (get-setf-method (cons function args) env)
-    ;; Special case aref and svref.
-    (cond ((or (eq function 'aref) (eq function 'svref))
-	   (let ((nargs (subseq setter 0 (1- (length setter))))
-		 (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset)))
-	     (values dummies vals newval
-		     `(apply (function ,fcn) ,(car newval) ,@(cdr nargs))
-		     `(apply (function ,function) ,@(cdr getter)))))
-	  ;; Make sure the place is one that we can handle.
-	  (T (unless (and (eq (car (last args)) (car (last vals)))
-			  (eq (car (last getter)) (car (last dummies)))
-			  (eq (car (last setter)) (car (last dummies))))
-	       (error "Apply of ~S not understood as a location for Setf."
-		      function))
-	     (values dummies vals newval
-		     `(apply (function ,(car setter)) ,@(cdr setter))
-		     `(apply (function ,(car getter)) ,@(cdr getter)))))))
+  (unless (and (listp function)
+	       (= (list-length function) 2)
+	       (eq (first function) 'function)
+	       (symbolp (second function)))
+    (error "Setf of Apply is only defined for function args like #'symbol."))
+  (let ((function (second function)))
+    (multiple-value-bind
+	(dummies vals newval setter getter)
+	(if (eq (symbol-package function) (symbol-package 'aref))
+	    (get-setf-method-inverse (cons function args) `((setf ,function)) t)
+	    (get-setf-method (cons function args) env))
+      (unless (and (eq (car (last args)) (car (last vals)))
+		   (eq (car (last getter)) (car (last dummies)))
+		   (eq (car (last setter)) (car (last dummies))))
+	(error "Apply of ~S not understood as a location for Setf." function))
+      (values dummies vals newval
+	      `(apply (function ,(car setter)) ,@(cdr setter))
+	      `(apply (function ,(car getter)) ,@(cdr getter))))))
 
 
 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.