X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=b15183faba6a512c0ba51091298a81d1304f8ae3;hb=cd0975b46e46cf6edcbec977616a475df9768bf9;hp=e3c44757ab8c38fa2befc1ccf5390ea1de1b5884;hpb=2f5aeff1d09f7a5a8a354ce71a9844bbbe0dffdd;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index e3c4475..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) @@ -835,7 +848,7 @@ (setf args (nthcdr posn orig-args)) (error 'format-error :complaint "Index ~W is out of bounds. (It should ~ - have been between 0 and ~W.)" + have been between 0 and ~W.)" :args (list posn (length orig-args)))))) (if colonp (interpret-bind-defaults ((n 1)) params @@ -848,7 +861,7 @@ (error 'format-error :complaint "Index ~W is out of bounds. (It should - have been between 0 and ~W.)" + have been between 0 and ~W.)" :args (list new-posn (length orig-args)))))))) (interpret-bind-defaults ((n 1)) params @@ -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))) @@ -1022,8 +1032,8 @@ (*logical-block-popper* nil) (*outside-args* args)) (catch 'up-and-out - (do-guts arg arg) - args)) + (do-guts arg arg)) + args) (do-guts orig-args args))) (do-loop (orig-args args) (catch (if colonp 'up-up-and-out 'up-and-out) @@ -1067,7 +1077,8 @@ ;; situation. (error 'format-error :complaint "~D illegal directive~:P found inside justification block" - :args (list count))) + :args (list count) + :references (list '(:ansi-cl :section (22 3 5 2))))) (interpret-format-justification stream orig-args args segments colonp atsignp first-semi params)))) @@ -1112,8 +1123,6 @@ (defun format-justification (stream newline-prefix extra-space line-len strings pad-left pad-right mincol colinc minpad padchar) (setf strings (reverse strings)) - (when (and (not pad-left) (not pad-right) (null (cdr strings))) - (setf pad-left t)) (let* ((num-gaps (+ (1- (length strings)) (if pad-left 1 0) (if pad-right 1 0))) @@ -1124,18 +1133,19 @@ (length (if (> chars mincol) (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) mincol)) - (padding (- length chars))) + (padding (+ (- length chars) (* num-gaps minpad)))) (when (and newline-prefix (> (+ (or (sb!impl::charpos stream) 0) length extra-space) line-len)) (write-string newline-prefix stream)) (flet ((do-padding () - (let ((pad-len (truncate padding num-gaps))) + (let ((pad-len + (if (zerop num-gaps) padding (truncate padding num-gaps)))) (decf padding pad-len) (decf num-gaps) (dotimes (i pad-len) (write-char padchar stream))))) - (when pad-left + (when (or pad-left (and (not pad-right) (null (cdr strings)))) (do-padding)) (when strings (write-string (car strings) stream)