(%format destination control-string format-arguments)
nil)))
+(define-compiler-macro format (&whole form destination control &rest args)
+ (declare (ignore control args))
+ (when (stringp destination)
+ (warn "Literal string as destination in FORMAT:~% ~S" form))
+ form)
+
(defun %format (stream string-or-fun orig-args &optional (args orig-args))
(if (functionp string-or-fun)
(apply string-or-fun stream args)
(function
(typecase character
(base-char
- (svref *format-directive-interpreters*
- (char-code character)))
- (character nil)))
+ (svref *format-directive-interpreters* (char-code character)))))
(*default-format-error-offset*
(1- (format-directive-end directive))))
(unless function
(intern (format nil
"~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
char)))
- (directive (gensym))
- (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ (directive (sb!xc:gensym "DIRECTIVE"))
+ (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
`(progn
(defun ,defun-name (stream ,directive ,directives orig-args args)
(declare (ignorable stream orig-args args))
(%set-format-directive-interpreter ,char #',defun-name))))
(sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
- (let ((directives (gensym)))
+ (let ((directives (sb!xc:gensym "DIRECTIVES")))
`(def-complex-format-interpreter ,char (,@lambda-list ,directives)
,@body
,directives)))
(prin1 (next-arg) stream)
(write-char (next-arg) stream)))))
+;;; "printing" as defined in the ANSI CL glossary, which is normative.
+(defun char-printing-p (char)
+ (and (not (eql char #\Space))
+ (graphic-char-p char)))
+
(defun format-print-named-character (char stream)
- (let* ((name (char-name char)))
- (cond (name
- (write-string (string-capitalize name) stream))
- (t
- (write-char char stream)))))
+ (cond ((not (char-printing-p char))
+ (write-string (string-capitalize (char-name char)) stream))
+ (t
+ (write-char char stream))))
(def-format-interpreter #\W (colonp atsignp params)
(interpret-bind-defaults () params
:start2 src :end2 (+ src commainterval)))
new-string))))
-;;; FIXME: This is only needed in this file, could be defined with
-;;; SB!XC:DEFMACRO inside EVAL-WHEN
-(defmacro interpret-format-integer (base)
+(eval-when (:compile-toplevel :execute)
+(sb!xc:defmacro interpret-format-integer (base)
`(if (or colonp atsignp params)
(interpret-bind-defaults
((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
params
(format-print-integer stream (next-arg) colonp atsignp ,base mincol
padchar commachar commainterval))
- (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
+ (let ((*print-base* ,base)
+ (*print-radix* nil)
+ (*print-escape* nil))
+ (output-object (next-arg) stream))))
+) ; EVAL-WHEN
(def-format-interpreter #\D (colonp atsignp params)
(interpret-format-integer 10))
(defun format-print-cardinal-aux (stream n period err)
(multiple-value-bind (beyond here) (truncate n 1000)
- (unless (<= period 20)
+ (unless (<= period 21)
(error "number too large to print in English: ~:D" err))
(unless (zerop beyond)
(format-print-cardinal-aux stream beyond (1+ period) err))
(format-fixed stream (next-arg) w d k ovf pad atsignp)))
(defun format-fixed (stream number w d k ovf pad atsign)
- (if (numberp number)
- (if (floatp number)
- (format-fixed-aux stream number w d k ovf pad atsign)
- (if (rationalp number)
- (format-fixed-aux stream
- (coerce number 'single-float)
- w d k ovf pad atsign)
- (format-write-field stream
- (decimal-string number)
- w 1 0 #\space t)))
- (format-princ stream number nil nil w 1 0 pad)))
+ (typecase number
+ (float
+ (format-fixed-aux stream number w d k ovf pad atsign))
+ (rational
+ (format-fixed-aux stream (coerce number 'single-float)
+ w d k ovf pad atsign))
+ (number
+ (format-write-field stream (decimal-string number) w 1 0 #\space t))
+ (t
+ (format-princ stream number nil nil w 1 0 pad))))
;;; 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
- ((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 (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
- ;;optional trailing zero
- (when (and d (zerop d)) (setq tpoint nil))
- (when w
- (decf spaceleft len)
- ;;optional leading zero
- (when lpoint
- (if (or (> spaceleft 0) tpoint) ;force at least one digit
- (decf spaceleft)
- (setq lpoint nil)))
- ;;optional trailing zero
- (when tpoint
- (if (> spaceleft 0)
- (decf spaceleft)
- (setq tpoint nil))))
- (cond ((and w (< spaceleft 0) ovf)
- ;;field width overflow
- (dotimes (i w) (write-char ovf stream))
- t)
- (t
- (when w (dotimes (i spaceleft) (write-char pad stream)))
- (if (minusp (float-sign number))
- (write-char #\- stream)
- (if atsign (write-char #\+ stream)))
- (when lpoint (write-char #\0 stream))
- (write-string str stream)
- (when tpoint (write-char #\0 stream))
- nil)))))))
+ ((or (float-infinity-p number)
+ (float-nan-p number))
+ (prin1 number stream)
+ nil)
+ (t
+ (sb!impl::string-dispatch (single-float double-float)
+ number
+ (let ((spaceleft w))
+ (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
+ ;; optional trailing zero
+ (when (and d (zerop d))
+ (setq tpoint nil))
+ (when w
+ (decf spaceleft len)
+ ;; optional leading zero
+ (when lpoint
+ (if (or (> spaceleft 0) tpoint) ;force at least one digit
+ (decf spaceleft)
+ (setq lpoint nil)))
+ ;; optional trailing zero
+ (when tpoint
+ (if (> spaceleft 0)
+ (decf spaceleft)
+ (setq tpoint nil))))
+ (cond ((and w (< spaceleft 0) ovf)
+ ;; field width overflow
+ (dotimes (i w)
+ (write-char ovf stream))
+ t)
+ (t
+ (when w
+ (dotimes (i spaceleft)
+ (write-char pad stream)))
+ (if (minusp (float-sign number))
+ (write-char #\- stream)
+ (when atsign
+ (write-char #\+ stream)))
+ (when lpoint
+ (write-char #\0 stream))
+ (write-string str stream)
+ (when tpoint
+ (write-char #\0 stream))
+ nil))))))))
(def-format-interpreter #\E (colonp atsignp params)
(when colonp
(float-nan-p number))
(prin1 number stream)
(multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number))
- (let* ((expt (- expt k))
+ (let* ((k (if (= num 1.0) (1- k) k))
+ (expt (- expt k))
(estr (decimal-string (abs expt)))
(elen (if e (max (length estr) e) (length estr)))
- (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
- (fmin (if (minusp k) (- 1 k) nil))
- (spaceleft (if w
- (- w 2 elen
- (if (or atsign (minusp (float-sign number)))
- 1 0))
- nil)))
- (if (and w ovf e (> elen e)) ;exponent overflow
+ spaceleft)
+ (when w
+ (setf spaceleft (- w 2 elen))
+ (when (or atsign (minusp (float-sign number)))
+ (decf spaceleft)))
+ (if (and w ovf e (> elen e)) ;exponent overflow
(dotimes (i w) (write-char ovf stream))
- (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 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 (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))
- stream)
- (write-char (if (minusp expt) #\- #\+) stream)
- (when e
- ;;zero-fill before exponent if necessary
- (dotimes (i (- e (length estr)))
- (write-char #\0 stream)))
- (write-string estr stream)))))))))
+ (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
+ (fmin (if (minusp k) 1 fdig)))
+ (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 (and tpoint (<= spaceleft 0))
+ (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 (float-sign number))
+ (write-char #\- stream)
+ (if atsign (write-char #\+ stream)))
+ (when lpoint (write-char #\0 stream))
+ (write-string fstr stream)
+ (write-char (if marker
+ marker
+ (format-exponent-marker number))
+ stream)
+ (write-char (if (minusp expt) #\- #\+) stream)
+ (when e
+ ;;zero-fill before exponent if necessary
+ (dotimes (i (- e (length estr)))
+ (write-char #\0 stream)))
+ (write-string estr stream))))))))))
(def-format-interpreter #\G (colonp atsignp params)
(when colonp
:complaint
"cannot specify either colon or atsign for this directive"))
(interpret-bind-defaults ((count 1)) params
- (fresh-line stream)
- (dotimes (i (1- count))
- (terpri stream))))
+ (when (plusp count)
+ (fresh-line stream)
+ (dotimes (i (1- count))
+ (terpri stream)))))
(def-format-interpreter #\| (colonp atsignp params)
(when (or colonp atsignp)
projects / sbcl.git / blobdiff