Changeset 9617

Timestamp:

May 28, 2008, 7:51:54 PM (17 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:

• compiler/optimizers.lisp (modified) (1 diff)
• lib/describe.lisp (modified) (1 diff)
• lib/setf.lisp (modified) (1 diff)

branches/working-0711/ccl/compiler/optimizers.lisp

@@ -1976 +1976 @@
                `(let ((,stream-var ,stream))
                   (if (or (null ,stream-var) (stringp ,stream-var))
-                    (format-to-string ,stream-var ,string ,obj ,@args)
+                    (format-to-string ,stream-var ,string ,@args)
                     (let ((,stream-var
                            (if (eq ,stream-var t) *standard-output* ,stream-var)))

branches/working-0711/ccl/lib/describe.lisp

@@ -1860 +1860 @@
   (let* ((level (inspector-ui-level ui))
          (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui))))))
+    (declare (special ccl::*default-integer-command*))
     (restart-case
      (ccl:with-terminal-input

branches/working-0711/ccl/lib/setf.lisp

@@ -483 +483 @@
     ;; Make sure the place is one that we can handle.
     ;;Mainly to insure against cases of ldb and mask-field and such creeping in.
-    (cond ((and (eq (car (last args)) (car (last vals)))
-                (eq (car (last getter)) (car (last dummies)))
-                newval
-                (null (cdr newval))
-                (eq (car (last setter)) (car newval))
-                (eq (car (last setter 2)) (car (last dummies))))
-           ; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
-           (values dummies vals newval
-                   `(apply+ (function ,(car setter))
-                            ,@(butlast dummies)
-                            ,@(last dummies)
-                            ,(car newval))
-                   `(apply (function ,(car getter)) ,@(cdr getter))))
-          ((and (eq (car (last args)) (car (last vals)))
-                (eq (car (last getter)) (car (last dummies)))
-                newval
-                (null (cdr newval))
-                (eq (car setter) 'funcall)
-                (eq (third setter) (car newval))
-                (eq (car (last setter)) (car (last dummies))))
-           ; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
-           (values dummies vals newval
-                   `(apply ,@(cdr setter))
-                   `(apply (function ,(car getter)) ,@(cdr getter))))
-          (t (error "Apply of ~S is not understood as a location for Setf."
-                    function)))))
+    (let* ((last-arg (car (last args)))
+           (last-val (car (last vals)))
+           (last-dummy (car (last dummies)))
+           (last-getter (car (last getter)))
+           (last2-setter (car (last setter 2)))
+           (last-setter (car (last setter))))
+      (cond ((and (or (and (eq last-arg last-val)
+                           (eq last-getter last-dummy))
+                      (eq last-arg last-getter))
+                  newval
+                  (null (cdr newval))
+                  (eq last-setter (car newval))
+                  (or (and (eq last-arg last-val)
+                           (eq last2-setter last-dummy))
+                      (eq last-arg last2-setter)))
+             ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar)
+             (values dummies vals newval
+                     `(apply+ (function ,(car setter)) ,@(cdr setter))
+                     `(apply (function ,(car getter)) ,@(cdr getter))))
+            ((and (or (and (eq last-arg last-val)
+                           (eq last-getter last-dummy))
+                      (eq last-arg last-getter))
+                  newval
+                  (null (cdr newval))
+                  (eq (car setter) 'funcall)
+                  (eq (third setter) (car newval))
+                  (or (and (eq last-arg last-val)
+                           (eq last-setter last-dummy))
+                      (eq last-arg last-setter)))
+             ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn)  [with bindings for evaluation order]
+             (values dummies vals newval
+                     `(apply ,@(cdr setter))
+                     `(apply (function ,(car getter)) ,@(cdr getter))))
+            (t (error "Apply of ~S is not understood as a location for Setf."
+                      function))))))
 
 ;;These are the supporting functions for the am-style hard-cases of setf.