diff --git a/code/macros.lisp b/code/macros.lisp index d339ca86f941f341afd8ab5614082ab87dd1885e..d0e13306d71897b099b55c28fa4bc560afc73ef1 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.