X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=3406f9b9bd41ac9bf64803bfd1941156f5b97ca4;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=0106059aa3fb5e5bf519b68a9f36a4fdf6a5887e;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 0106059..3406f9b 100644
--- 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,9 +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
@@ -117,8 +121,8 @@
             (intern (format nil
                             "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
                             char)))
-        (directive (gensym))
-        (directives (if lambda-list (car (last lambda-list)) (gensym))))
+        (directive (sb!xc:gensym "DIRECTIVE"))
+        (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
     `(progn
        (defun ,defun-name (stream ,directive ,directives orig-args args)
          (declare (ignorable stream orig-args args))
@@ -134,7 +138,7 @@
        (%set-format-directive-interpreter ,char #',defun-name))))
 
 (sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
-  (let ((directives (gensym)))
+  (let ((directives (sb!xc:gensym "DIRECTIVES")))
     `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
        ,@body
        ,directives)))
@@ -166,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)
@@ -222,18 +234,28 @@
 
 (def-format-interpreter #\C (colonp atsignp params)
   (interpret-bind-defaults () params
-    (if colonp
-        (format-print-named-character (next-arg) stream)
-        (if atsignp
-            (prin1 (next-arg) stream)
-            (write-char (next-arg) stream)))))
+    (let ((arg (next-arg)))
+      (unless (typep arg 'character)
+        (error 'format-error
+               :complaint "~s is not of type CHARACTER."
+               :args (list arg)))
+      (cond (colonp
+             (format-print-named-character arg stream))
+            (atsignp
+             (prin1 arg stream))
+            (t
+             (write-char arg stream))))))
+
+;;; "printing" as defined in the ANSI CL glossary, which is normative.
+(defun char-printing-p (char)
+  (and (not (eql char #\Space))
+       (graphic-char-p char)))
 
 (defun format-print-named-character (char stream)
-  (let* ((name (char-name char)))
-    (cond (name
-           (write-string (string-capitalize name) stream))
-          (t
-           (write-char char stream)))))
+  (cond ((not (char-printing-p char))
+         (write-string (string-capitalize (char-name char)) stream))
+        (t
+         (write-char char stream))))
 
 (def-format-interpreter #\W (colonp atsignp params)
   (interpret-bind-defaults () params
@@ -278,16 +300,19 @@
                    :start2 src :end2 (+ src commainterval)))
         new-string))))
 
-;;; FIXME: This is only needed in this file, could be defined with
-;;; SB!XC:DEFMACRO inside EVAL-WHEN
-(defmacro interpret-format-integer (base)
+(eval-when (:compile-toplevel :execute)
+(sb!xc:defmacro interpret-format-integer (base)
   `(if (or colonp atsignp params)
        (interpret-bind-defaults
            ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
            params
          (format-print-integer stream (next-arg) colonp atsignp ,base mincol
                                padchar commachar commainterval))
-       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
+       (let ((*print-base* ,base)
+             (*print-radix* nil)
+             (*print-escape* nil))
+         (output-object (next-arg) stream))))
+) ; EVAL-WHEN
 
 (def-format-interpreter #\D (colonp atsignp params)
   (interpret-format-integer 10))
@@ -307,6 +332,11 @@
        (commainterval 3))
       params
     (let ((arg (next-arg)))
+      (unless (or base
+                  (integerp arg))
+        (error 'format-error
+               :complaint "~s is not of type INTEGER."
+               :args (list arg)))
       (if base
           (format-print-integer stream arg colonp atsignp base mincol
                                 padchar commachar commainterval)
@@ -374,7 +404,7 @@
 
 (defun format-print-cardinal-aux (stream n period err)
   (multiple-value-bind (beyond here) (truncate n 1000)
-    (unless (<= period 20)
+    (unless (<= period 21)
       (error "number too large to print in English: ~:D" err))
     (unless (zerop beyond)
       (format-print-cardinal-aux stream beyond (1+ period) err))
@@ -479,62 +509,69 @@
     (format-fixed stream (next-arg) w d k ovf pad atsignp)))
 
 (defun format-fixed (stream number w d k ovf pad atsign)
-  (if (numberp number)
-      (if (floatp number)
-          (format-fixed-aux stream number w d k ovf pad atsign)
-          (if (rationalp number)
-              (format-fixed-aux stream
-                                (coerce number 'single-float)
-                                w d k ovf pad atsign)
-              (format-write-field stream
-                                  (decimal-string number)
-                                  w 1 0 #\space t)))
-      (format-princ stream number nil nil w 1 0 pad)))
+  (typecase number
+    (float
+     (format-fixed-aux stream number w d k ovf pad atsign))
+    (rational
+     (format-fixed-aux stream (coerce number 'single-float)
+                       w d k ovf pad atsign))
+    (number
+     (format-write-field stream (decimal-string number) w 1 0 #\space t))
+    (t
+     (format-princ stream number nil nil w 1 0 pad))))
 
 ;;; We return true if we overflowed, so that ~G can output the overflow char
 ;;; instead of spaces.
 (defun format-fixed-aux (stream number w d k ovf pad atsign)
   (declare (type float number))
   (cond
-   ((and (floatp number)
-         (or (float-infinity-p number)
-             (float-nan-p number)))
-    (prin1 number stream)
-    nil)
-   (t
-    (let ((spaceleft w))
-      (when (and w (or atsign (minusp (float-sign number))))
-        (decf spaceleft))
-      (multiple-value-bind (str len lpoint tpoint)
-          (sb!impl::flonum-to-string (abs number) spaceleft d k)
-        ;;if caller specifically requested no fraction digits, suppress the
-        ;;optional trailing zero
-        (when (and d (zerop d)) (setq tpoint nil))
-        (when w
-          (decf spaceleft len)
-          ;;optional leading zero
-          (when lpoint
-            (if (or (> spaceleft 0) tpoint) ;force at least one digit
-                (decf spaceleft)
-                (setq lpoint nil)))
-          ;;optional trailing zero
-          (when tpoint
-            (if (> spaceleft 0)
-                (decf spaceleft)
-                (setq tpoint nil))))
-        (cond ((and w (< spaceleft 0) ovf)
-               ;;field width overflow
-               (dotimes (i w) (write-char ovf stream))
-               t)
-              (t
-               (when w (dotimes (i spaceleft) (write-char pad stream)))
-               (if (minusp (float-sign number))
-                   (write-char #\- stream)
-                   (if atsign (write-char #\+ stream)))
-               (when lpoint (write-char #\0 stream))
-               (write-string str stream)
-               (when tpoint (write-char #\0 stream))
-               nil)))))))
+    ((or (float-infinity-p number)
+         (float-nan-p number))
+     (prin1 number stream)
+     nil)
+    (t
+     (sb!impl::string-dispatch (single-float double-float)
+         number
+       (let ((spaceleft w))
+         (when (and w (or atsign (minusp (float-sign number))))
+           (decf spaceleft))
+         (multiple-value-bind (str len lpoint tpoint)
+             (sb!impl::flonum-to-string (abs number) spaceleft d k)
+           ;; if caller specifically requested no fraction digits, suppress the
+           ;; optional trailing zero
+           (when (and d (zerop d))
+             (setq tpoint nil))
+           (when w
+             (decf spaceleft len)
+             ;; optional leading zero
+             (when lpoint
+               (if (or (> spaceleft 0) tpoint) ;force at least one digit
+                   (decf spaceleft)
+                   (setq lpoint nil)))
+             ;; optional trailing zero
+             (when tpoint
+               (if (> spaceleft 0)
+                   (decf spaceleft)
+                   (setq tpoint nil))))
+           (cond ((and w (< spaceleft 0) ovf)
+                  ;; field width overflow
+                  (dotimes (i w)
+                    (write-char ovf stream))
+                  t)
+                 (t
+                  (when w
+                    (dotimes (i spaceleft)
+                      (write-char pad stream)))
+                  (if (minusp (float-sign number))
+                      (write-char #\- stream)
+                      (when atsign
+                        (write-char #\+ stream)))
+                  (when lpoint
+                    (write-char #\0 stream))
+                  (write-string str stream)
+                  (when tpoint
+                    (write-char #\0 stream))
+                  nil))))))))
 
 (def-format-interpreter #\E (colonp atsignp params)
   (when colonp
@@ -586,52 +623,50 @@
           (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)))
-               (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
-               (fmin (if (minusp k) (- 1 k) nil))
-               (spaceleft (if w
-                              (- w 2 elen
-                                 (if (or atsign (minusp (float-sign number)))
-                                     1 0))
-                              nil)))
-          (if (and w ovf e (> elen e)) ;exponent overflow
+               spaceleft)
+          (when w
+            (setf spaceleft (- w 2 elen))
+            (when (or atsign (minusp (float-sign number)))
+              (decf spaceleft)))
+          (if (and w ovf e (> elen e))  ;exponent overflow
               (dotimes (i w) (write-char ovf stream))
-              (multiple-value-bind (fstr flen lpoint tpoint)
-                  (sb!impl::flonum-to-string num spaceleft fdig k fmin)
-                (when (and d (zerop d)) (setq tpoint nil))
-                (when w
-                  (decf spaceleft flen)
-                  (when lpoint
-                    (if (or (> spaceleft 0) tpoint)
-                        (decf spaceleft)
-                        (setq lpoint nil)))
-                  (when tpoint
-                    (if (> spaceleft 0)
-                        (decf spaceleft)
-                        (setq tpoint nil))))
-                (cond ((and w (< spaceleft 0) ovf)
-                       ;;significand overflow
-                       (dotimes (i w) (write-char ovf stream)))
-                      (t (when w
-                           (dotimes (i spaceleft) (write-char pad stream)))
-                         (if (minusp (float-sign number))
-                             (write-char #\- stream)
-                             (if atsign (write-char #\+ stream)))
-                         (when lpoint (write-char #\0 stream))
-                         (write-string fstr stream)
-                         (when tpoint (write-char #\0 stream))
-                         (write-char (if marker
-                                         marker
-                                         (format-exponent-marker number))
-                                     stream)
-                         (write-char (if (minusp expt) #\- #\+) stream)
-                         (when e
-                           ;;zero-fill before exponent if necessary
-                           (dotimes (i (- e (length estr)))
-                             (write-char #\0 stream)))
-                         (write-string estr stream)))))))))
+              (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
+                     (fmin (if (minusp k) 1 fdig)))
+                (multiple-value-bind (fstr flen lpoint tpoint)
+                    (sb!impl::flonum-to-string num spaceleft fdig k fmin)
+                  (when (and d (zerop d)) (setq tpoint nil))
+                  (when w
+                    (decf spaceleft flen)
+                    (when lpoint
+                      (if (or (> spaceleft 0) tpoint)
+                          (decf spaceleft)
+                          (setq lpoint nil)))
+                    (when (and tpoint (<= spaceleft 0))
+                      (setq tpoint nil)))
+                  (cond ((and w (< spaceleft 0) ovf)
+                         ;;significand overflow
+                         (dotimes (i w) (write-char ovf stream)))
+                        (t (when w
+                             (dotimes (i spaceleft) (write-char pad stream)))
+                           (if (minusp (float-sign number))
+                               (write-char #\- stream)
+                               (if atsign (write-char #\+ stream)))
+                           (when lpoint (write-char #\0 stream))
+                           (write-string fstr stream)
+                           (write-char (if marker
+                                           marker
+                                           (format-exponent-marker number))
+                                       stream)
+                           (write-char (if (minusp expt) #\- #\+) stream)
+                           (when e
+                             ;;zero-fill before exponent if necessary
+                             (dotimes (i (- e (length estr)))
+                               (write-char #\0 stream)))
+                           (write-string estr stream))))))))))
 
 (def-format-interpreter #\G (colonp atsignp params)
   (when colonp
@@ -736,9 +771,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)
@@ -1064,7 +1100,7 @@
   (multiple-value-bind (segments first-semi close remaining)
       (parse-format-justification directives)
     (setf args
-          (if (format-directive-colonp close)
+          (if (format-directive-colonp close) ; logical block vs. justification
               (multiple-value-bind (prefix per-line-p insides suffix)
                   (parse-format-logical-block segments colonp first-semi
                                               close params string end)
@@ -1079,6 +1115,16 @@
                          :complaint "~D illegal directive~:P found inside justification block"
                          :args (list count)
                          :references (list '(:ansi-cl :section (22 3 5 2)))))
+                ;; ANSI does not explicitly say that an error should
+                ;; be signalled, but the @ modifier is not explicitly
+                ;; allowed for ~> either.
+                (when (format-directive-atsignp close)
+                  (error 'format-error
+                         :complaint "@ modifier not allowed in close ~
+                         directive of justification ~
+                         block (i.e. ~~<...~~@>."
+                         :offset (1- (format-directive-end close))
+                         :references (list '(:ansi-cl :section (22 3 6 2)))))
                 (interpret-format-justification stream orig-args args
                                                 segments colonp atsignp
                                                 first-semi params))))