X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=8478a221fb1afc119d85e3528f4ba8031718d281;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=5a29fbad05467f9dd5dff02786ffd20cd2691a7e;hpb=01d3afd8254db54a95552d6e4d09f54a9c970449;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 5a29fba..8478a22 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -78,9 +78,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 +115,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 +132,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))) @@ -282,16 +280,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)) @@ -378,7 +379,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 +484,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