;;;; files for more information.
(in-package "SB!FORMAT")
-
-(file-comment
- "$Header$")
\f
;;;; FORMAT
generally expand into additional text to be output, usually consuming one
or more of the FORMAT-ARGUMENTS in the process. A few useful directives
are:
- ~A or ~nA Prints one argument as if by PRINC
- ~S or ~nS Prints one argument as if by PRIN1
- ~D or ~nD Prints one argument as a decimal integer
- ~% Does a TERPRI
- ~& Does a FRESH-LINE
-
- where n is the width of the field in which the object is printed.
+ ~A or ~nA Prints one argument as if by PRINC
+ ~S or ~nS Prints one argument as if by PRIN1
+ ~D or ~nD Prints one argument as a decimal integer
+ ~% Does a TERPRI
+ ~& Does a FRESH-LINE
+ where n is the width of the field in which the object is printed.
DESTINATION controls where the result will go. If DESTINATION is T, then
the output is sent to the standard output stream. If it is NIL, then the
(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)
(defun ,defun-name (stream ,directive ,directives orig-args args)
(declare (ignorable stream orig-args args))
,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
(butlast lambda-list))
(values (progn ,@body) args)))
`((declare (ignore ,directive ,directives))
(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)))))))
(when ,params
(error 'format-error
:complaint
- "too many parameters, expected no more than ~D"
- :arguments (list ,(length specs))
+ "too many parameters, expected no more than ~W"
+ :args (list ,(length specs))
:offset (caar ,params)))
,@body))))
(write-string string stream))
(dotimes (i minpad)
(write-char padchar stream))
- (do ((chars (+ (length string) minpad) (+ chars colinc)))
- ((>= chars mincol))
- (dotimes (i colinc)
- (write-char padchar stream)))
+ ;; As of sbcl-0.6.12.34, we could end up here when someone tries to
+ ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says
+ ;; 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) (max minpad 0)) (+ chars colinc)))
+ ((>= chars mincol))
+ (dotimes (i colinc)
+ (write-char padchar stream))))
(when padleft
(write-string string stream)))
(let* ((name (char-name char)))
(cond (name
(write-string (string-capitalize name) stream))
- ((<= 0 (char-code char) 31)
- ;; Print control characters as "^"<char>
- (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))))
\f
;;;; format interpreters and support functions for integer output
(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)))
(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))))))
-
-(defconstant cardinal-ones
+ (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"))
-(defconstant cardinal-tens
+(defparameter *cardinal-tens*
#(nil nil "twenty" "thirty" "forty"
"fifty" "sixty" "seventy" "eighty" "ninety"))
-(defconstant cardinal-teens
+(defparameter *cardinal-teens*
#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
"fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
-(defconstant cardinal-periods
+(defparameter *cardinal-periods*
#("" " thousand" " million" " billion" " trillion" " quadrillion"
" quintillion" " sextillion" " septillion" " octillion" " nonillion"
" decillion" " undecillion" " duodecillion" " tredecillion"
" quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
" octodecillion" " novemdecillion" " vigintillion"))
-(defconstant ordinal-ones
+(defparameter *ordinal-ones*
#(nil "first" "second" "third" "fourth"
- "fifth" "sixth" "seventh" "eighth" "ninth")
- #!+sb-doc
- "Table of ordinal ones-place digits in English")
+ "fifth" "sixth" "seventh" "eighth" "ninth"))
-(defconstant ordinal-tens
+(defparameter *ordinal-tens*
#(nil "tenth" "twentieth" "thirtieth" "fortieth"
- "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
- #!+sb-doc
- "Table of ordinal tens-place digits in English")
+ "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
(defun format-print-small-cardinal (stream n)
(multiple-value-bind (hundreds rem) (truncate n 100)
(when (plusp hundreds)
- (write-string (svref cardinal-ones hundreds) stream)
+ (write-string (svref *cardinal-ones* hundreds) stream)
(write-string " hundred" stream)
(when (plusp rem)
(write-char #\space stream)))
(when (plusp rem)
(multiple-value-bind (tens ones) (truncate rem 10)
(cond ((< 1 tens)
- (write-string (svref cardinal-tens tens) stream)
+ (write-string (svref *cardinal-tens* tens) stream)
(when (plusp ones)
(write-char #\- stream)
- (write-string (svref cardinal-ones ones) stream)))
+ (write-string (svref *cardinal-ones* ones) stream)))
((= tens 1)
- (write-string (svref cardinal-teens ones) stream))
+ (write-string (svref *cardinal-teens* ones) stream))
((plusp ones)
- (write-string (svref cardinal-ones ones) stream)))))))
+ (write-string (svref *cardinal-ones* ones) stream)))))))
(defun format-print-cardinal (stream n)
(cond ((minusp n)
(unless (zerop beyond)
(write-char #\space stream))
(format-print-small-cardinal stream here)
- (write-string (svref cardinal-periods period) stream))))
+ (write-string (svref *cardinal-periods* period) stream))))
(defun format-print-ordinal (stream n)
(when (minusp n)
(multiple-value-bind (tens ones) (truncate bot 10)
(cond ((= bot 12) (write-string "twelfth" stream))
((= tens 1)
- (write-string (svref cardinal-teens ones) stream);;;RAD
+ (write-string (svref *cardinal-teens* ones) stream);;;RAD
(write-string "th" stream))
((and (zerop tens) (plusp ones))
- (write-string (svref ordinal-ones ones) stream))
+ (write-string (svref *ordinal-ones* ones) stream))
((and (zerop ones)(plusp tens))
- (write-string (svref ordinal-tens tens) stream))
+ (write-string (svref *ordinal-tens* tens) stream))
((plusp bot)
- (write-string (svref cardinal-tens tens) stream)
+ (write-string (svref *cardinal-tens* tens) stream)
(write-char #\- stream)
- (write-string (svref ordinal-ones ones) stream))
+ (write-string (svref *ordinal-ones* ones) stream))
((plusp number)
(write-string "th" stream))
(t
;;; 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
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))
;;; 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))
(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))
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))
(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)))
\f
-;;;; 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)
(if (<= 0 posn (length orig-args))
(setf args (nthcdr posn orig-args))
(error 'format-error
- :complaint "Index ~D is out of bounds. (It should ~
- have been between 0 and ~D.)"
- :arguments (list posn (length orig-args))))))
+ :complaint "Index ~W is out of bounds. (It should ~
+ have been between 0 and ~W.)"
+ :args (list posn (length orig-args))))))
(if colonp
(interpret-bind-defaults ((n 1)) params
(do ((cur-posn 0 (1+ cur-posn))
(setf args (nthcdr new-posn orig-args))
(error 'format-error
:complaint
- "Index ~D is out of bounds. (It should
- have been between 0 and ~D.)"
- :arguments
+ "Index ~W is out of bounds. (It should
+ have been between 0 and ~W.)"
+ :args
(list new-posn (length orig-args))))))))
(interpret-bind-defaults ((n 1)) params
(dotimes (i n)
(interpret-bind-defaults () params
(handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :args (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
(if atsignp
(setf args (%format stream (next-arg) orig-args args))
(%format stream (next-arg) (next-arg))))))
(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)))
\f
(if (zerop posn)
(handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
+ (lambda (condition)
+ (error
+ 'format-error
+ :complaint
"~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
+ :args (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
(%format stream insides orig-args args))
(interpret-directive-list stream insides
orig-args args)))
(*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)
(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
(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)))
(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)
(if per-line-p
(pprint-logical-block
(stream arg :per-line-prefix prefix :suffix suffix)
- (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (let ((*logical-block-popper* (lambda () (pprint-pop))))
(catch 'up-and-out
(interpret-directive-list stream insides
(if atsignp orig-args arg)
arg))))
(pprint-logical-block (stream arg :prefix prefix :suffix suffix)
- (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (let ((*logical-block-popper* (lambda () (pprint-pop))))
(catch 'up-and-out
(interpret-directive-list stream insides
(if atsignp orig-args arg)
;;;; format interpreter and support functions for user-defined method
(def-format-interpreter #\/ (string start end colonp atsignp params)
- (let ((symbol (extract-user-function-name string start end)))
+ (let ((symbol (extract-user-fun-name string start end)))
(collect ((args))
(dolist (param-and-offset params)
(let ((param (cdr param-and-offset)))
projects / sbcl.git / blobdiff