Changeset 9617


Ignore:
Timestamp:
May 29, 2008, 2:51:54 AM (11 years ago)
Author:
gz
Message:

Fix assorted problems in my recent checkins:

  • remove extra arg in format optimizer introduced in r9486
  • fix apply's setf method to not assume all args have dummies, fixing bug introduced in r9603
  • add missing special declaration for r9602
Location:
branches/working-0711/ccl
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r9578 r9617  
    19761976               `(let ((,stream-var ,stream))
    19771977                  (if (or (null ,stream-var) (stringp ,stream-var))
    1978                     (format-to-string ,stream-var ,string ,obj ,@args)
     1978                    (format-to-string ,stream-var ,string ,@args)
    19791979                    (let ((,stream-var
    19801980                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
  • branches/working-0711/ccl/lib/describe.lisp

    r9602 r9617  
    18601860  (let* ((level (inspector-ui-level ui))
    18611861         (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui))))))
     1862    (declare (special ccl::*default-integer-command*))
    18621863    (restart-case
    18631864     (ccl:with-terminal-input
  • branches/working-0711/ccl/lib/setf.lisp

    r9603 r9617  
    483483    ;; Make sure the place is one that we can handle.
    484484    ;;Mainly to insure against cases of ldb and mask-field and such creeping in.
    485     (cond ((and (eq (car (last args)) (car (last vals)))
    486                 (eq (car (last getter)) (car (last dummies)))
    487                 newval
    488                 (null (cdr newval))
    489                 (eq (car (last setter)) (car newval))
    490                 (eq (car (last setter 2)) (car (last dummies))))
    491            ; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
    492            (values dummies vals newval
    493                    `(apply+ (function ,(car setter))
    494                             ,@(butlast dummies)
    495                             ,@(last dummies)
    496                             ,(car newval))
    497                    `(apply (function ,(car getter)) ,@(cdr getter))))
    498           ((and (eq (car (last args)) (car (last vals)))
    499                 (eq (car (last getter)) (car (last dummies)))
    500                 newval
    501                 (null (cdr newval))
    502                 (eq (car setter) 'funcall)
    503                 (eq (third setter) (car newval))
    504                 (eq (car (last setter)) (car (last dummies))))
    505            ; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
    506            (values dummies vals newval
    507                    `(apply ,@(cdr setter))
    508                    `(apply (function ,(car getter)) ,@(cdr getter))))
    509           (t (error "Apply of ~S is not understood as a location for Setf."
    510                     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))))))
    511520
    512521;;These are the supporting functions for the am-style hard-cases of setf.
Note: See TracChangeset for help on using the changeset viewer.