X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=3406f9b9bd41ac9bf64803bfd1941156f5b97ca4;hb=ced29bbb5c5575ed9f71a4bdd79e222216a63e73;hp=5a29fbad05467f9dd5dff02786ffd20cd2691a7e;hpb=01d3afd8254db54a95552d6e4d09f54a9c970449;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 5a29fba..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,11 +234,17 @@ (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) @@ -282,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)) @@ -311,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) @@ -378,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)) @@ -483,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 @@ -590,7 +623,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) @@ -607,14 +641,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) @@ -631,10 +657,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)) @@ -749,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) @@ -1077,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) @@ -1092,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))))