X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=561639372f06c52e5e87b2a58864e3cb59253c35;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=b4b6bf561f65c1569d65fe0fab60125facfdce4d;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index b4b6bf5..5616393 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -74,15 +74,16 @@ (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 + (svref *format-directive-interpreters* + (char-code character))) + (*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) @@ -153,7 +154,7 @@ (error 'format-error :complaint "too many parameters, expected no more than ~W" - :arguments (list ,(length specs)) + :args (list ,(length specs)) :offset (caar ,params))) ,@body)))) @@ -228,13 +229,6 @@ (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))))) @@ -265,7 +259,7 @@ (t commaed)))) ;; colinc = 1, minpad = 0, padleft = t (format-write-field stream signed mincol 1 0 padchar t)) - (princ number)))) + (princ number stream)))) (defun format-add-commas (string commachar commainterval) (let ((length (length string))) @@ -576,7 +570,7 @@ ;;; 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 @@ -651,7 +645,7 @@ 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) @@ -687,24 +681,32 @@ (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 "+" ""))) (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) @@ -834,7 +836,7 @@ (error 'format-error :complaint "Index ~W is out of bounds. (It should ~ have been between 0 and ~W.)" - :arguments (list posn (length orig-args)))))) + :args (list posn (length orig-args)))))) (if colonp (interpret-bind-defaults ((n 1)) params (do ((cur-posn 0 (1+ cur-posn)) @@ -847,7 +849,7 @@ :complaint "Index ~W is out of bounds. (It should have been between 0 and ~W.)" - :arguments + :args (list new-posn (length orig-args)))))))) (interpret-bind-defaults ((n 1)) params (dotimes (i n) @@ -866,7 +868,7 @@ (error 'format-error :complaint "~A~%while processing indirect format string:" - :arguments (list condition) + :args (list condition) :print-banner nil :control-string string :offset (1- end))))) @@ -1007,7 +1009,7 @@ 'format-error :complaint "~A~%while processing indirect format string:" - :arguments (list condition) + :args (list condition) :print-banner nil :control-string string :offset (1- end))))) @@ -1059,9 +1061,16 @@ (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 (apply #'+ (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))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) remaining)) (defun interpret-format-justification