X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=52c5b07d36a75e96190ddf0401d3ad0a33abb3a1;hb=625c9493a8a7b5186144d21302437cf4f4f3571c;hp=df74380e35f2e42e23d7e22b9e980cc2375c472c;hpb=8fee0ba99cd1b1038072bd3fc8f5d5338d80d2de;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index df74380..52c5b07 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,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 @@ -116,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)) @@ -133,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))) @@ -281,16 +286,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)) @@ -377,7 +385,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)) @@ -482,62 +490,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 @@ -589,7 +604,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) @@ -606,14 +622,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) @@ -630,10 +638,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)) @@ -748,9 +752,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)