(multiple-value-bind (new-directives new-args)
(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
(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"))
(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