(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)
(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)))))))
;; 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))))
(let* ((name (char-name char)))
(cond (name
(write-string (string-capitalize name) stream))
- ((<= 0 (char-code char) 31)
- ;; Print control characters as "^"<char>. (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))))
\f
;;;; format interpreters and support functions for integer output
(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"))
;;; 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))
;; 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)
(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
(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
(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
(*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))
- (let ((count (apply #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
+ (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)))
+ :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))))
(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)
projects / sbcl.git / blobdiff