fix source information for functions from EVAL

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

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 792e610..7ed2b55 100644 (file)
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -51,6 +51,12 @@
      (%format destination control-string format-arguments)
      nil)))
 
+(define-compiler-macro format (&whole form destination control &rest args)
+  (declare (ignore control args))
+  (when (stringp destination)
+    (warn "Literal string as destination in FORMAT:~%  ~S" form))
+  form)
+
 (defun %format (stream string-or-fun orig-args &optional (args orig-args))
   (if (functionp string-or-fun)
       (apply string-or-fun stream args)
@@ -78,8 +84,7 @@
                       (function
                        (typecase character
                          (base-char
-                          (svref *format-directive-interpreters* (char-code character)))
-                         (character nil)))
+                          (svref *format-directive-interpreters* (char-code character)))))
                       (*default-format-error-offset*
                        (1- (format-directive-end directive))))
                  (unless function
@@ -165,6 +170,14 @@
 ;;;; format interpreters and support functions for simple output
 
 (defun format-write-field (stream string mincol colinc minpad padchar padleft)
+  (when (and colinc (<= colinc 0))
+    (error 'format-error
+           :complaint "The value of colinc is ~a, should be a positive integer"
+           :args (list colinc)))
+  (when (and mincol (< mincol 0))
+    (error 'format-error
+           :complaint "The value of mincol is ~a, should be a non-negative integer"
+           :args (list mincol)))
   (unless padleft
     (write-string string stream))
   (dotimes (i minpad)
@@ -599,7 +612,8 @@
           (float-nan-p number))
       (prin1 number stream)
       (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number))
-        (let* ((expt (- expt k))
+        (let* ((k (if (= num 1.0) (1- k) k))
+               (expt (- expt k))
                (estr (decimal-string (abs expt)))
                (elen (if e (max (length estr) e) (length estr)))
                spaceleft)
@@ -616,14 +630,6 @@
                   (when (and d (zerop d)) (setq tpoint nil))
                   (when w
                     (decf spaceleft flen)
-                    ;; See CLHS 22.3.3.2.  "If the parameter d is
-                    ;; omitted, ... [and] if the fraction to be
-                    ;; printed is zero then a single zero digit should
-                    ;; appear after the decimal point."  So we need to
-                    ;; subtract one from here because we're going to
-                    ;; add an extra 0 digit later. [rtoy]
-                    (when (and (zerop number) (null d))
-                      (decf spaceleft))
                     (when lpoint
                       (if (or (> spaceleft 0) tpoint)
                           (decf spaceleft)
@@ -640,10 +646,6 @@
                                (if atsign (write-char #\+ stream)))
                            (when lpoint (write-char #\0 stream))
                            (write-string fstr stream)
-                           (when (and (zerop number) (null d))
-                             ;; It's later and we're adding the zero
-                             ;; digit.
-                             (write-char #\0 stream))
                            (write-char (if marker
                                            marker
                                            (format-exponent-marker number))
@@ -758,9 +760,10 @@
            :complaint
            "cannot specify either colon or atsign for this directive"))
   (interpret-bind-defaults ((count 1)) params
-    (fresh-line stream)
-    (dotimes (i (1- count))
-      (terpri stream))))
+    (when (plusp count)
+      (fresh-line stream)
+      (dotimes (i (1- count))
+       (terpri stream)))))
 
 (def-format-interpreter #\| (colonp atsignp params)
   (when (or colonp atsignp)