Index: /branches/working-0711/ccl/compiler/optimizers.lisp
===================================================================
--- /branches/working-0711/ccl/compiler/optimizers.lisp	(revision 9482)
+++ /branches/working-0711/ccl/compiler/optimizers.lisp	(revision 9483)
@@ -1883,10 +1883,10 @@
                     `(princ-to-string ,object))
                    ((or (eq stream t) (nx-form-typep stream 'stream env))
-                    `(princ ,object ,(and (neq stream t) stream)))
+                    `(progn (princ ,object ,(and (neq stream t) stream)) nil))
                    (t `(let ((stream ,stream)
                              (object ,object))
                          (if (or (null stream) (stringp stream))
                            (format-to-string stream ,string object)
-                           (princ object (and (neq stream t) stream))))))))
+                           (progn (princ object (and (neq stream t) stream)) nil)))))))
           ((string-equal string "~s")
            (destructuring-bind (object) args
@@ -1894,39 +1894,60 @@
                     `(prin1-to-string ,object))
                    ((or (eq stream t) (nx-form-typep stream 'stream env))
-                    `(prin1 ,object ,(and (neq stream t) stream)))
+                    `(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
                    (t `(let ((stream ,stream)
                              (object ,object))
                          (if (or (null stream) (stringp stream))
                            (format-to-string stream ,string object)
-                           (prin1 object (and (neq stream t) stream))))))))
+                           (progn (prin1 object (and (neq stream t) stream)) nil)))))))
           ((and (null (position #\~ string)) (null args))
            (cond ((null stream)
                   string)
                  ((or (eq stream t) (nx-form-typep stream 'stream env))
-                  `(write-string ,string ,(and (neq stream t) stream)))
+                  `(progn (write-string ,string ,(and (neq stream t) stream)) nil))
                  (t `(let ((stream ,stream))
                        (if (or (null stream) (stringp stream))
                          (format-to-string stream ,string)
-                         (write-string ,string (and (neq stream t) stream)))))))
-          ((and args (optimize-format-call stream string (car args) (%cdr args) env)))
+                         (progn (write-string ,string (and (neq stream t) stream)) nil))))))
+          ((optimize-format-call stream string args env))
           (t call))
     call))
 
-(defun optimize-format-call (stream string obj args env)
-  (let* ((start (or (search "~/" string) (return-from optimize-format-call nil)))
+(defun count-known-format-args (string start end)
+  (declare (fixnum start end))
+  (loop with count = 0
+        do (setq start (position #\~ string :start start :end end))
+        when (null start)
+          do (return count)
+        unless (< (incf start) end)
+          do (return nil)
+        do (let ((ch (aref string start)))
+             (cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
+                   ((memq ch '(#\~ #\% #\&)))
+                   (t (return nil)))
+             (incf start))))
+
+(defun optimize-format-call (stream string args env)
+  (let* ((start (or (search "~/" string)
+                    (return-from optimize-format-call nil)))
          (ipos (+ start 2))
-         (epos (or (position #\/ string :start ipos) (return-from optimize-format-call nil))))
+         (epos (or (position #\/ string :start ipos)
+                   (return-from optimize-format-call nil)))
+         (nargs (or (count-known-format-args string 0 start)
+                    (return-from optimize-format-call nil))))
     (when (and
-           ;; Must be first directive, since otherwise don't know how to split args.
-           (not (position #\~ string :end start))
+           ;; Must be able to split args
+           (< nargs (length args))
            ;; Don't deal with packages
            (not (position #\: string :start ipos :end epos)))
       (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
              (prev (and (< 0 start) (subseq string 0 start)))
+             (prev-args (subseq args 0 nargs))
              (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
+             (rest-args (nthcdr nargs args))
+             (obj (pop rest-args))
              (stream-var (gensym))
-             (body `(,@(and prev `((write-string ,prev ,stream-var)))
+             (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
                        (,func ,stream-var ,obj nil nil)
-                       ,@(and rest `((format ,stream-var ,rest ,@args))))))
+                       ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
         (cond ((null stream)
                `(with-output-to-string (,stream-var)
@@ -1941,6 +1962,10 @@
                   (if (or (null ,stream-var) (stringp ,stream-var))
                     (format-to-string ,stream-var ,string ,obj ,@args)
-                    (progn
-                      (when (eq ,stream-var t) (setq ,stream-var *standard-output*))
+                    (let ((,stream-var
+                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
+                      ;; For the purposes of body, it's ok to assume stream-var
+                      ;; is a stream. method dispatch will signal any errors
+                      ;; at runtime if it's not true...
+                      (declare (type stream ,stream-var))
                       ,@body)))))))))