Changeset 9924


Ignore:
Timestamp:
Jul 7, 2008, 8:26:19 PM (11 years ago)
Author:
gz
Message:

Propagate r9603 (and followup from r9617) to trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/setf.lisp

    r2711 r9924  
    8484                    (vals nil))
    8585                (dolist (x (cdr form))
     86                  ;; Rebinding defeats optimizations, so avoid it if can.
     87                  (if (constantp x environment)
     88                    (push x args)
    8689                    (let ((var (gensym)))
    8790                      (push var vars)
    8891                      (push var args)
    89                       (push x vals)))
     92                      (push x vals))))
    9093                (setq args (nreverse args))
    9194                (values (nreverse vars)
     
    480483    ;; Make sure the place is one that we can handle.
    481484    ;;Mainly to insure against cases of ldb and mask-field and such creeping in.
    482     (cond ((and (eq (car (last args)) (car (last vals)))
    483                 (eq (car (last getter)) (car (last dummies)))
    484                 newval
    485                 (null (cdr newval))
    486                 (eq (car (last setter)) (car newval))
    487                 (eq (car (last setter 2)) (car (last dummies))))
    488            ; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
    489            (values dummies vals newval
    490                    `(apply+ (function ,(car setter))
    491                             ,@(butlast dummies)
    492                             ,@(last dummies)
    493                             ,(car newval))
    494                    `(apply (function ,(car getter)) ,@(cdr getter))))
    495           ((and (eq (car (last args)) (car (last vals)))
    496                 (eq (car (last getter)) (car (last dummies)))
    497                 newval
    498                 (null (cdr newval))
    499                 (eq (car setter) 'funcall)
    500                 (eq (third setter) (car newval))
    501                 (eq (car (last setter)) (car (last dummies))))
    502            ; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
    503            (values dummies vals newval
    504                    `(apply ,@(cdr setter))
    505                    `(apply (function ,(car getter)) ,@(cdr getter))))
    506           (t (error "Apply of ~S is not understood as a location for Setf."
    507                     function)))))
     485    (let* ((last-arg (car (last args)))
     486           (last-val (car (last vals)))
     487           (last-dummy (car (last dummies)))
     488           (last-getter (car (last getter)))
     489           (last2-setter (car (last setter 2)))
     490           (last-setter (car (last setter))))
     491      (cond ((and (or (and (eq last-arg last-val)
     492                           (eq last-getter last-dummy))
     493                      (eq last-arg last-getter))
     494                  newval
     495                  (null (cdr newval))
     496                  (eq last-setter (car newval))
     497                  (or (and (eq last-arg last-val)
     498                           (eq last2-setter last-dummy))
     499                      (eq last-arg last2-setter)))
     500             ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
     501             (values dummies vals newval
     502                     `(apply+ (function ,(car setter)) ,@(cdr setter))
     503                     `(apply (function ,(car getter)) ,@(cdr getter))))
     504            ((and (or (and (eq last-arg last-val)
     505                           (eq last-getter last-dummy))
     506                      (eq last-arg last-getter))
     507                  newval
     508                  (null (cdr newval))
     509                  (eq (car setter) 'funcall)
     510                  (eq (third setter) (car newval))
     511                  (or (and (eq last-arg last-val)
     512                           (eq last-setter last-dummy))
     513                      (eq last-arg last-setter)))
     514             ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
     515             (values dummies vals newval
     516                     `(apply ,@(cdr setter))
     517                     `(apply (function ,(car getter)) ,@(cdr getter))))
     518            (t (error "Apply of ~S is not understood as a location for Setf."
     519                      function))))))
    508520
    509521;;These are the supporting functions for the am-style hard-cases of setf.
Note: See TracChangeset for help on using the changeset viewer.