X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=b15183faba6a512c0ba51091298a81d1304f8ae3;hb=bb756e3d4b19c30d4a9cd4250b606c5969613ad9;hp=2e304516dd9bcc596c3e2e01796dfb14097b76ab;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 2e30451..b15183f 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -76,8 +76,11 @@ (multiple-value-bind (new-directives new-args) (let* ((character (format-directive-character directive)) (function + (typecase character + (base-char (svref *format-directive-interpreters* (char-code character))) + (character nil))) (*default-format-error-offset* (1- (format-directive-end directive)))) (unless function @@ -299,20 +302,21 @@ (interpret-format-integer 16)) (def-format-interpreter #\R (colonp atsignp params) - (if params - (interpret-bind-defaults - ((base 10) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - (format-print-integer stream (next-arg) colonp atsignp base mincol - padchar commachar commainterval)) - (if atsignp - (if colonp - (format-print-old-roman stream (next-arg)) - (format-print-roman stream (next-arg))) - (if colonp - (format-print-ordinal stream (next-arg)) - (format-print-cardinal stream (next-arg)))))) + (interpret-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((arg (next-arg))) + (if base + (format-print-integer stream arg colonp atsignp base mincol + padchar commachar commainterval) + (if atsignp + (if colonp + (format-print-old-roman stream arg) + (format-print-roman stream arg)) + (if colonp + (format-print-ordinal stream arg) + (format-print-cardinal stream arg))))))) (defparameter *cardinal-ones* #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) @@ -490,16 +494,17 @@ ;;; 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 - ((or (not (or w d)) - (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number)))) + ((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 number))) (decf spaceleft)) + (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 @@ -523,7 +528,7 @@ t) (t (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) + (if (minusp (float-sign number)) (write-char #\- stream) (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) @@ -576,9 +581,9 @@ ;;; silent here, so let's just print out infinities and NaN's instead ;;; of causing an error. (defun format-exp-aux (stream number w d e k ovf pad marker atsign) - (if (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (declare (type float number)) + (if (or (float-infinity-p number) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number)) (let* ((expt (- expt k)) @@ -588,29 +593,35 @@ (fmin (if (minusp k) (- 1 k) nil)) (spaceleft (if w (- w 2 elen - (if (or atsign (minusp number)) + (if (or atsign (minusp (float-sign number))) 1 0)) nil))) (if (and w ovf e (> elen e)) ;exponent overflow (dotimes (i w) (write-char ovf stream)) - (multiple-value-bind (fstr flen lpoint) + (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 lpoint nil)))) + (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 number) + (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)) @@ -647,9 +658,9 @@ ;;; Raymond Toy writes: same change as for format-exp-aux (defun format-general-aux (stream number w d e k ovf pad marker atsign) - (if (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (declare (type float number)) + (if (or (float-infinity-p number) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number)) (declare (ignore ignore)) @@ -688,7 +699,9 @@ ;; thing, and at least the user shouldn't be surprised. (setq number (coerce number 'single-float))) (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (let* ((signstr (if (minusp (float-sign number)) + "-" + (if atsign "+" ""))) (signlen (length signstr))) (multiple-value-bind (str strlen ig2 ig3 pointplace) (sb!impl::flonum-to-string number nil d nil) @@ -970,16 +983,13 @@ (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) - (when (case (length params) - (0 (if colonp - (null *outside-args*) - (null args))) - (1 (interpret-bind-defaults ((count 0)) params - (zerop count))) - (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params - (= arg1 arg2))) - (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params - (<= arg1 arg2 arg3)))) + (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + (cond (arg3 (<= arg1 arg2 arg3)) + (arg2 (eql arg1 arg2)) + (arg1 (eql arg1 0)) + (t (if colonp + (null *outside-args*) + (null args))))) (throw (if colonp 'up-up-and-out 'up-and-out) args)))