0.7.3.1:

[sbcl.git] / src / code / target-format.lisp

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 8a69dab..b5e23c5 100644 (file)
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -153,7 +153,7 @@
           (error 'format-error
                  :complaint
                  "too many parameters, expected no more than ~W"
-                 :arguments (list ,(length specs))
+                 :args (list ,(length specs))
                  :offset (caar ,params)))
         ,@body))))
 
@@ -265,7 +265,7 @@
                             (t commaed))))
          ;; colinc = 1, minpad = 0, padleft = t
          (format-write-field stream signed mincol 1 0 padchar t))
-       (princ number))))
+       (princ number stream))))
 
 (defun format-add-commas (string commachar commainterval)
   (let ((length (length string)))
@@ -687,24 +687,32 @@
     (format-dollars stream (next-arg) d n w pad colonp atsignp)))
 
 (defun format-dollars (stream number d n w pad colon atsign)
-  (if (rationalp number) (setq number (coerce number 'single-float)))
+  (when (rationalp number)
+    ;; This coercion to SINGLE-FLOAT seems as though it gratuitously
+    ;; loses precision (why not LONG-FLOAT?) but it's the default
+    ;; behavior in the ANSI spec, so in some sense it's the right
+    ;; thing, and at least the user shouldn't be surprised.
+    (setq number (coerce number 'single-float)))
   (if (floatp number)
       (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
             (signlen (length signstr)))
        (multiple-value-bind (str strlen ig2 ig3 pointplace)
-           (sb!impl::flonum-to-string number nil d nil)
-         (declare (ignore ig2 ig3))
-         (when colon (write-string signstr stream))
-         (dotimes (i (- w signlen (- n pointplace) strlen))
+            (sb!impl::flonum-to-string number nil d nil)
+         (declare (ignore ig2 ig3 strlen))
+         (when colon
+           (write-string signstr stream))
+         (dotimes (i (- w signlen (max n pointplace) 1 d))
            (write-char pad stream))
-         (unless colon (write-string signstr stream))
-         (dotimes (i (- n pointplace)) (write-char #\0 stream))
+         (unless colon
+           (write-string signstr stream))
+         (dotimes (i (- n pointplace))
+           (write-char #\0 stream))
          (write-string str stream)))
       (format-write-field stream
                          (decimal-string number)
                          w 1 0 #\space t)))
 \f
-;;;; format interpreters and support functions for line/page breaks etc.
+;;;; FORMAT interpreters and support functions for line/page breaks etc.
 
 (def-format-interpreter #\% (colonp atsignp params)
   (when (or colonp atsignp)
@@ -834,7 +842,7 @@
                (error 'format-error
                       :complaint "Index ~W is out of bounds. (It should ~
                                   have been between 0 and ~W.)"
-                      :arguments (list posn (length orig-args))))))
+                      :args (list posn (length orig-args))))))
       (if colonp
          (interpret-bind-defaults ((n 1)) params
            (do ((cur-posn 0 (1+ cur-posn))
@@ -847,7 +855,7 @@
                              :complaint
                              "Index ~W is out of bounds. (It should 
                               have been between 0 and ~W.)"
-                             :arguments
+                             :args
                              (list new-posn (length orig-args))))))))
          (interpret-bind-defaults ((n 1)) params
            (dotimes (i n)
@@ -862,14 +870,14 @@
   (interpret-bind-defaults () params
     (handler-bind
        ((format-error
-         #'(lambda (condition)
-             (error 'format-error
-                    :complaint
-                    "~A~%while processing indirect format string:"
-                    :arguments (list condition)
-                    :print-banner nil
-                    :control-string string
-                    :offset (1- end)))))
+         (lambda (condition)
+           (error 'format-error
+                  :complaint
+                  "~A~%while processing indirect format string:"
+                  :args (list condition)
+                  :print-banner nil
+                  :control-string string
+                  :offset (1- end)))))
       (if atsignp
          (setf args (%format stream (next-arg) orig-args args))
          (%format stream (next-arg) (next-arg))))))
@@ -1002,14 +1010,15 @@
               (if (zerop posn)
                   (handler-bind
                       ((format-error
-                        #'(lambda (condition)
-                            (error 'format-error
-                                   :complaint
+                        (lambda (condition)
+                          (error
+                           'format-error
+                           :complaint
                            "~A~%while processing indirect format string:"
-                                   :arguments (list condition)
-                                   :print-banner nil
-                                   :control-string string
-                                   :offset (1- end)))))
+                           :args (list condition)
+                           :print-banner nil
+                           :control-string string
+                           :offset (1- end)))))
                     (%format stream insides orig-args args))
                   (interpret-directive-list stream insides
                                             orig-args args)))
@@ -1141,13 +1150,13 @@
     (if per-line-p
        (pprint-logical-block
            (stream arg :per-line-prefix prefix :suffix suffix)
-         (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+         (let ((*logical-block-popper* (lambda () (pprint-pop))))
            (catch 'up-and-out
              (interpret-directive-list stream insides
                                        (if atsignp orig-args arg)
                                        arg))))
        (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
-         (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+         (let ((*logical-block-popper* (lambda () (pprint-pop))))
            (catch 'up-and-out
              (interpret-directive-list stream insides
                                        (if atsignp orig-args arg)