From d3918c494e250661df6ed753d2d6b9407d7e2bb9 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 6 Feb 1993 15:14:09 +0000
Subject: [PATCH] Tweaked the global set macros inhibition for local functions
 to work correctly now that INLINE/NOTINLINE declarations are represented in
 the LEXENV-FUNCTIONS. Also, this is inhibited if there is any enclosing local
 function *OR MACRO*, not merely if the currently apparent definition is a
 local function.

---
 code/macros.lisp | 45 +++++++++++++++++++--------------------------
 1 file changed, 19 insertions(+), 26 deletions(-)

diff --git a/code/macros.lisp b/code/macros.lisp
index d339ca86f..d0e13306d 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.35.1.1 1993/02/04 22:35:38 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.35.1.2 1993/02/06 15:14:09 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -542,8 +542,11 @@
 	  ;;
 	  ;; Local functions inhibit global setf methods...
 	  ((and environment
-		(c::leaf-p (cdr (assoc (car form)
-				       (c::lexenv-functions environment)))))
+		(let ((name (car form)))
+		  (dolist (x (c::lexenv-functions environment) nil)
+		    (when (and (eq (car x) name)
+			       (not (c::defined-function-p (cdr x))))
+		      (return t)))))
 	   (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
 	  ((setq temp (info setf inverse (car form)))
 	   (get-setf-method-inverse form `(,temp) nil))
@@ -1041,35 +1044,25 @@
 	  ,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 (though not as evil as
+;;; it used to be.)  The function arg must be constant, and is converted to an
+;;; APPLY of ther SETF function, which ought to exist.
 ;;;
-;;; 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)
+(define-setf-method apply (function &rest args)
   (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))))))
+  (let ((function (second function))
+	(new-var (gensym))
+	(vars nil))
+    (dolist (x args)
+      (declare (ignore x))
+      (push (gensym) vars))
+    (values vars args (list new-var)
+	    `(apply #'(setf ,function) ,new-var ,@vars)
+	    `(apply #',function ,@vars))))
 
 
 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
-- 
GitLab