X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=b15183faba6a512c0ba51091298a81d1304f8ae3;hb=cd0975b46e46cf6edcbec977616a475df9768bf9;hp=610d64569f251b6fd45b7d363443db9649019677;hpb=78789912bae99e45b4c1a89be08164a5cac5b0ec;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 610d645..b15183f 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -74,15 +74,19 @@ (interpret-directive-list stream (cdr directives) orig-args args)) (format-directive (multiple-value-bind (new-directives new-args) - (let ((function - (svref *format-directive-interpreters* - (char-code (format-directive-character - directive)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) + (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 (error 'format-error - :complaint "unknown format directive")) + :complaint "unknown format directive ~@[(character: ~A)~]" + :args (list (char-name character)))) (multiple-value-bind (new-directives new-args) (funcall function stream directive (cdr directives) orig-args args) @@ -144,7 +148,7 @@ (offset (car param-and-offset)) (param (cdr param-and-offset))) (case param - (:arg (next-arg offset)) + (:arg (or (next-arg offset) ,default)) (:remaining (length args)) ((nil) ,default) (t param))))))) @@ -171,7 +175,7 @@ ;; we're supposed to soldier on bravely, and so we have to deal with ;; the unsupplied-MINCOL-and-COLINC case without blowing up. (when (and mincol colinc) - (do ((chars (+ (length string) minpad) (+ chars colinc))) + (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc))) ((>= chars mincol)) (dotimes (i colinc) (write-char padchar stream)))) @@ -228,21 +232,14 @@ (let* ((name (char-name char))) (cond (name (write-string (string-capitalize name) stream)) - ((<= 0 (char-code char) 31) - ;; Print control characters as "^". (This seems to be - ;; old pre-ANSI behavior, but ANSI just says that the "#^" - ;; sequence is undefined and not reserved for the user, so - ;; this behavior should be ANSI-compliant.) - (write-char #\^ stream) - (write-char (code-char (+ 64 (char-code char))) stream)) (t (write-char char stream))))) (def-format-interpreter #\W (colonp atsignp params) (interpret-bind-defaults () params (let ((*print-pretty* (or colonp *print-pretty*)) - (*print-level* (and atsignp *print-level*)) - (*print-length* (and atsignp *print-length*))) + (*print-level* (unless atsignp *print-level*)) + (*print-length* (unless atsignp *print-length*))) (output-object (next-arg) stream)))) ;;;; format interpreters and support functions for integer output @@ -305,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")) @@ -496,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 @@ -529,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,15 +575,15 @@ ;;; errors. As for now, we let the user get away with it, and merely guarantee ;;; that at least one significant digit will appear. -;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent +;;; Raymond Toy writes: The Hyperspec seems to say that the exponent ;;; marker is always printed. Make it so. Also, the original version ;;; causes errors when printing infinities or NaN's. The Hyperspec is ;;; 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)) @@ -594,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)) @@ -651,11 +656,11 @@ w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) -;;; toy@rtp.ericsson.se: Same change as for format-exp-aux. +;;; 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)) @@ -687,24 +692,34 @@ (format-dollars stream (next-arg) d n w pad colonp atsignp))) (defun format-dollars (stream number d n w pad colon atsign) - (if (rationalp number) (setq number (coerce number 'single-float))) + (when (rationalp number) + ;; This coercion to SINGLE-FLOAT seems as though it gratuitously + ;; loses precision (why not LONG-FLOAT?) but it's the default + ;; behavior in the ANSI spec, so in some sense it's the right + ;; 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) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr stream)) - (dotimes (i (- w signlen (- n pointplace) strlen)) + (sb!impl::flonum-to-string number nil d nil) + (declare (ignore ig2 ig3 strlen)) + (when colon + (write-string signstr stream)) + (dotimes (i (- w signlen (max n pointplace) 1 d)) (write-char pad stream)) - (unless colon (write-string signstr stream)) - (dotimes (i (- n pointplace)) (write-char #\0 stream)) + (unless colon + (write-string signstr stream)) + (dotimes (i (- n pointplace)) + (write-char #\0 stream)) (write-string str stream))) (format-write-field stream (decimal-string number) w 1 0 #\space t))) -;;;; format interpreters and support functions for line/page breaks etc. +;;;; FORMAT interpreters and support functions for line/page breaks etc. (def-format-interpreter #\% (colonp atsignp params) (when (or colonp atsignp) @@ -833,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 @@ -846,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 @@ -968,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))) @@ -1020,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) @@ -1059,9 +1071,17 @@ (interpret-format-logical-block stream orig-args args prefix per-line-p insides suffix atsignp)) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params))) + (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :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)))) remaining)) (defun interpret-format-justification @@ -1103,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))) @@ -1115,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)