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
+ (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)
(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)))
;;; 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
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)
(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)))
\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))))))
(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