X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=b5e23c589cea7b22b38d2363a110798765818e55;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=8a69dab33a32cf303812a1193e223c12d5a39e03;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 8a69dab..b5e23c5 100644
--- 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)))
 
-;;;; 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)