/[cmucl]/src/code/macros.lisp
ViewVC logotype

Diff of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.35.1.1 by ram, Thu Feb 4 22:35:38 1993 UTC revision 1.35.1.2 by ram, Sat Feb 6 15:14:09 1993 UTC
# Line 542  Line 542 
542            ;;            ;;
543            ;; Local functions inhibit global setf methods...            ;; Local functions inhibit global setf methods...
544            ((and environment            ((and environment
545                  (c::leaf-p (cdr (assoc (car form)                  (let ((name (car form)))
546                                         (c::lexenv-functions environment)))))                    (dolist (x (c::lexenv-functions environment) nil)
547                        (when (and (eq (car x) name)
548                                   (not (c::defined-function-p (cdr x))))
549                          (return t)))))
550             (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))             (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
551            ((setq temp (info setf inverse (car form)))            ((setq temp (info setf inverse (car form)))
552             (get-setf-method-inverse form `(,temp) nil))             (get-setf-method-inverse form `(,temp) nil))
# Line 1041  Line 1044 
1044            ,v))            ,v))
1045    
1046    
1047  ;;; Evil hack invented by the gnomes of Vassar Street.  The function arg must  ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
1048  ;;; be constant.  Get a setf method for this function, pretending that the  ;;; it used to be.)  The function arg must be constant, and is converted to an
1049  ;;; final (list) arg to apply is just a normal arg.  If the setting and access  ;;; APPLY of ther SETF function, which ought to exist.
 ;;; 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.  
1050  ;;;  ;;;
1051  ;;; We special-case uses functions in the Lisp package so that APPLY AREF works  (define-setf-method apply (function &rest args)
 ;;; 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)  
1052    (unless (and (listp function)    (unless (and (listp function)
1053                 (= (list-length function) 2)                 (= (list-length function) 2)
1054                 (eq (first function) 'function)                 (eq (first function) 'function)
1055                 (symbolp (second function)))                 (symbolp (second function)))
1056      (error "Setf of Apply is only defined for function args like #'symbol."))      (error "Setf of Apply is only defined for function args like #'symbol."))
1057    (let ((function (second function)))    (let ((function (second function))
1058      (multiple-value-bind          (new-var (gensym))
1059          (dummies vals newval setter getter)          (vars nil))
1060          (if (eq (symbol-package function) (symbol-package 'aref))      (dolist (x args)
1061              (get-setf-method-inverse (cons function args) `((setf ,function)) t)        (declare (ignore x))
1062              (get-setf-method (cons function args) env))        (push (gensym) vars))
1063        (unless (and (eq (car (last args)) (car (last vals)))      (values vars args (list new-var)
1064                     (eq (car (last getter)) (car (last dummies)))              `(apply #'(setf ,function) ,new-var ,@vars)
1065                     (eq (car (last setter)) (car (last dummies))))              `(apply #',function ,@vars))))
         (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))))))  
1066    
1067    
1068  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.

Legend:
Removed from v.1.35.1.1  
changed lines
  Added in v.1.35.1.2

  ViewVC Help
Powered by ViewVC 1.1.5