src/code/target-format.lisp

   1 ;;;; functions to implement FORMAT and FORMATTER
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!FORMAT")
  13
  14 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; FORMAT
  18
  19 (defun format (destination control-string &rest format-arguments)
  20   #!+sb-doc
  21   "Provides various facilities for formatting output.
  22   CONTROL-STRING contains a string to be output, possibly with embedded
  23   directives, which are flagged with the escape character \"~\". Directives
  24   generally expand into additional text to be output, usually consuming one
  25   or more of the FORMAT-ARGUMENTS in the process. A few useful directives
  26   are:
  27         ~A or ~nA     Prints one argument as if by PRINC
  28         ~S or ~nS     Prints one argument as if by PRIN1
  29         ~D or ~nD     Prints one argument as a decimal integer
  30         ~%          Does a TERPRI
  31         ~&          Does a FRESH-LINE
  32
  33          where n is the width of the field in which the object is printed.
  34
  35   DESTINATION controls where the result will go. If DESTINATION is T, then
  36   the output is sent to the standard output stream. If it is NIL, then the
  37   output is returned in a string as the value of the call. Otherwise,
  38   DESTINATION must be a stream to which the output will be sent.
  39
  40   Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
  41
  42   FORMAT has many additional capabilities not described here. Consult the
  43   manual for details."
  44   (etypecase destination
  45     (null
  46      (with-output-to-string (stream)
  47        (%format stream control-string format-arguments)))
  48     (string
  49      (with-output-to-string (stream destination)
  50        (%format stream control-string format-arguments)))
  51     ((member t)
  52      (%format *standard-output* control-string format-arguments)
  53      nil)
  54     (stream
  55      (%format destination control-string format-arguments)
  56      nil)))
  57
  58 (defun %format (stream string-or-fun orig-args &optional (args orig-args))
  59   (if (functionp string-or-fun)
  60       (apply string-or-fun stream args)
  61       (catch 'up-and-out
  62         (let* ((string (etypecase string-or-fun
  63                          (simple-string
  64                           string-or-fun)
  65                          (string
  66                           (coerce string-or-fun 'simple-string))))
  67                (*default-format-error-control-string* string)
  68                (*logical-block-popper* nil))
  69           (interpret-directive-list stream (tokenize-control-string string)
  70                                     orig-args args)))))
  71
  72 (defun interpret-directive-list (stream directives orig-args args)
  73   (if directives
  74       (let ((directive (car directives)))
  75         (etypecase directive
  76           (simple-string
  77            (write-string directive stream)
  78            (interpret-directive-list stream (cdr directives) orig-args args))
  79           (format-directive
  80            (multiple-value-bind (new-directives new-args)
  81                (let ((function
  82                       (svref *format-directive-interpreters*
  83                              (char-code (format-directive-character
  84                                          directive))))
  85                      (*default-format-error-offset*
  86                       (1- (format-directive-end directive))))
  87                  (unless function
  88                    (error 'format-error
  89                           :complaint "unknown format directive"))
  90                  (multiple-value-bind (new-directives new-args)
  91                      (funcall function stream directive
  92                               (cdr directives) orig-args args)
  93                    (values new-directives new-args)))
  94              (interpret-directive-list stream new-directives
  95                                        orig-args new-args)))))
  96       args))
  97 \f
  98 ;;;; FORMAT directive definition macros and runtime support
  99
 100 (eval-when (:compile-toplevel :execute)
 101
 102 ;;; This macro is used to extract the next argument from the current arg list.
 103 ;;; This is the version used by format directive interpreters.
 104 (sb!xc:defmacro next-arg (&optional offset)
 105   `(progn
 106      (when (null args)
 107        (error 'format-error
 108               :complaint "no more arguments"
 109               ,@(when offset
 110                   `(:offset ,offset))))
 111      (when *logical-block-popper*
 112        (funcall *logical-block-popper*))
 113      (pop args)))
 114
 115 (sb!xc:defmacro def-complex-format-interpreter (char lambda-list &body body)
 116   (let ((defun-name
 117             (intern (format nil
 118                             "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
 119                             char)))
 120         (directive (gensym))
 121         (directives (if lambda-list (car (last lambda-list)) (gensym))))
 122     `(progn
 123        (defun ,defun-name (stream ,directive ,directives orig-args args)
 124          (declare (ignorable stream orig-args args))
 125          ,@(if lambda-list
 126                `((let ,(mapcar #'(lambda (var)
 127                                    `(,var
 128                                      (,(intern (concatenate
 129                                                 'string
 130                                                 "FORMAT-DIRECTIVE-"
 131                                                 (symbol-name var))
 132                                                (symbol-package 'foo))
 133                                       ,directive)))
 134                                (butlast lambda-list))
 135                    (values (progn ,@body) args)))
 136                `((declare (ignore ,directive ,directives))
 137                  ,@body)))
 138        (%set-format-directive-interpreter ,char #',defun-name))))
 139
 140 (sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
 141   (let ((directives (gensym)))
 142     `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
 143        ,@body
 144        ,directives)))
 145
 146 (sb!xc:defmacro interpret-bind-defaults (specs params &body body)
 147   (once-only ((params params))
 148     (collect ((bindings))
 149       (dolist (spec specs)
 150         (destructuring-bind (var default) spec
 151           (bindings `(,var (let* ((param-and-offset (pop ,params))
 152                                   (offset (car param-and-offset))
 153                                   (param (cdr param-and-offset)))
 154                              (case param
 155                                (:arg (next-arg offset))
 156                                (:remaining (length args))
 157                                ((nil) ,default)
 158                                (t param)))))))
 159       `(let* ,(bindings)
 160          (when ,params
 161            (error 'format-error
 162                   :complaint
 163                   "too many parameters, expected no more than ~D"
 164                   :arguments (list ,(length specs))
 165                   :offset (caar ,params)))
 166          ,@body))))
 167
 168 ) ; EVAL-WHEN
 169 \f
 170 ;;;; format interpreters and support functions for simple output
 171
 172 (defun format-write-field (stream string mincol colinc minpad padchar padleft)
 173   (unless padleft
 174     (write-string string stream))
 175   (dotimes (i minpad)
 176     (write-char padchar stream))
 177   (do ((chars (+ (length string) minpad) (+ chars colinc)))
 178       ((>= chars mincol))
 179     (dotimes (i colinc)
 180       (write-char padchar stream)))
 181   (when padleft
 182     (write-string string stream)))
 183
 184 (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
 185   (format-write-field stream
 186                       (if (or arg (not colonp))
 187                           (princ-to-string arg)
 188                           "()")
 189                       mincol colinc minpad padchar atsignp))
 190
 191 (def-format-interpreter #\A (colonp atsignp params)
 192   (if params
 193       (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
 194                                 (padchar #\space))
 195                      params
 196         (format-princ stream (next-arg) colonp atsignp
 197                       mincol colinc minpad padchar))
 198       (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
 199
 200 (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
 201   (format-write-field stream
 202                       (if (or arg (not colonp))
 203                           (prin1-to-string arg)
 204                           "()")
 205                       mincol colinc minpad padchar atsignp))
 206
 207 (def-format-interpreter #\S (colonp atsignp params)
 208   (cond (params
 209          (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
 210                                    (padchar #\space))
 211                         params
 212            (format-prin1 stream (next-arg) colonp atsignp
 213                          mincol colinc minpad padchar)))
 214         (colonp
 215          (let ((arg (next-arg)))
 216            (if arg
 217                (prin1 arg stream)
 218                (princ "()" stream))))
 219         (t
 220          (prin1 (next-arg) stream))))
 221
 222 (def-format-interpreter #\C (colonp atsignp params)
 223   (interpret-bind-defaults () params
 224     (if colonp
 225         (format-print-named-character (next-arg) stream)
 226         (if atsignp
 227             (prin1 (next-arg) stream)
 228             (write-char (next-arg) stream)))))
 229
 230 (defun format-print-named-character (char stream)
 231   (let* ((name (char-name char)))
 232     (cond (name
 233            (write-string (string-capitalize name) stream))
 234           ((<= 0 (char-code char) 31)
 235            ;; Print control characters as "^"<char>
 236            (write-char #\^ stream)
 237            (write-char (code-char (+ 64 (char-code char))) stream))
 238           (t
 239            (write-char char stream)))))
 240
 241 (def-format-interpreter #\W (colonp atsignp params)
 242   (interpret-bind-defaults () params
 243     (let ((*print-pretty* (or colonp *print-pretty*))
 244           (*print-level* (and atsignp *print-level*))
 245           (*print-length* (and atsignp *print-length*)))
 246       (output-object (next-arg) stream))))
 247 \f
 248 ;;;; format interpreters and support functions for integer output
 249
 250 ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
 251 ;;; directives. The parameters are interpreted as defined for ~D.
 252 (defun format-print-integer (stream number print-commas-p print-sign-p
 253                              radix mincol padchar commachar commainterval)
 254   (let ((*print-base* radix)
 255         (*print-radix* nil))
 256     (if (integerp number)
 257         (let* ((text (princ-to-string (abs number)))
 258                (commaed (if print-commas-p
 259                             (format-add-commas text commachar commainterval)
 260                             text))
 261                (signed (cond ((minusp number)
 262                               (concatenate 'string "-" commaed))
 263                              (print-sign-p
 264                               (concatenate 'string "+" commaed))
 265                              (t commaed))))
 266           ;; colinc = 1, minpad = 0, padleft = t
 267           (format-write-field stream signed mincol 1 0 padchar t))
 268         (princ number))))
 269
 270 (defun format-add-commas (string commachar commainterval)
 271   (let ((length (length string)))
 272     (multiple-value-bind (commas extra) (truncate (1- length) commainterval)
 273       (let ((new-string (make-string (+ length commas)))
 274             (first-comma (1+ extra)))
 275         (replace new-string string :end1 first-comma :end2 first-comma)
 276         (do ((src first-comma (+ src commainterval))
 277              (dst first-comma (+ dst commainterval 1)))
 278             ((= src length))
 279           (setf (schar new-string dst) commachar)
 280           (replace new-string string :start1 (1+ dst)
 281                    :start2 src :end2 (+ src commainterval)))
 282         new-string))))
 283
 284 ;;; FIXME: This is only needed in this file, could be defined with
 285 ;;; SB!XC:DEFMACRO inside EVAL-WHEN
 286 (defmacro interpret-format-integer (base)
 287   `(if (or colonp atsignp params)
 288        (interpret-bind-defaults
 289            ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
 290            params
 291          (format-print-integer stream (next-arg) colonp atsignp ,base mincol
 292                                padchar commachar commainterval))
 293        (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
 294
 295 (def-format-interpreter #\D (colonp atsignp params)
 296   (interpret-format-integer 10))
 297
 298 (def-format-interpreter #\B (colonp atsignp params)
 299   (interpret-format-integer 2))
 300
 301 (def-format-interpreter #\O (colonp atsignp params)
 302   (interpret-format-integer 8))
 303
 304 (def-format-interpreter #\X (colonp atsignp params)
 305   (interpret-format-integer 16))
 306
 307 (def-format-interpreter #\R (colonp atsignp params)
 308   (if params
 309       (interpret-bind-defaults
 310           ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
 311            (commainterval 3))
 312           params
 313         (format-print-integer stream (next-arg) colonp atsignp base mincol
 314                               padchar commachar commainterval))
 315       (if atsignp
 316           (if colonp
 317               (format-print-old-roman stream (next-arg))
 318               (format-print-roman stream (next-arg)))
 319           (if colonp
 320               (format-print-ordinal stream (next-arg))
 321               (format-print-cardinal stream (next-arg))))))
 322
 323 (defconstant cardinal-ones
 324   #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
 325
 326 (defconstant cardinal-tens
 327   #(nil nil "twenty" "thirty" "forty"
 328         "fifty" "sixty" "seventy" "eighty" "ninety"))
 329
 330 (defconstant cardinal-teens
 331   #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
 332     "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
 333
 334 (defconstant cardinal-periods
 335   #("" " thousand" " million" " billion" " trillion" " quadrillion"
 336     " quintillion" " sextillion" " septillion" " octillion" " nonillion"
 337     " decillion" " undecillion" " duodecillion" " tredecillion"
 338     " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
 339     " octodecillion" " novemdecillion" " vigintillion"))
 340
 341 (defconstant ordinal-ones
 342   #(nil "first" "second" "third" "fourth"
 343         "fifth" "sixth" "seventh" "eighth" "ninth")
 344   #!+sb-doc
 345   "Table of ordinal ones-place digits in English")
 346
 347 (defconstant ordinal-tens
 348   #(nil "tenth" "twentieth" "thirtieth" "fortieth"
 349         "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
 350   #!+sb-doc
 351   "Table of ordinal tens-place digits in English")
 352
 353 (defun format-print-small-cardinal (stream n)
 354   (multiple-value-bind (hundreds rem) (truncate n 100)
 355     (when (plusp hundreds)
 356       (write-string (svref cardinal-ones hundreds) stream)
 357       (write-string " hundred" stream)
 358       (when (plusp rem)
 359         (write-char #\space stream)))
 360     (when (plusp rem)
 361       (multiple-value-bind (tens ones) (truncate rem 10)
 362         (cond ((< 1 tens)
 363               (write-string (svref cardinal-tens tens) stream)
 364               (when (plusp ones)
 365                 (write-char #\- stream)
 366                 (write-string (svref cardinal-ones ones) stream)))
 367              ((= tens 1)
 368               (write-string (svref cardinal-teens ones) stream))
 369              ((plusp ones)
 370               (write-string (svref cardinal-ones ones) stream)))))))
 371
 372 (defun format-print-cardinal (stream n)
 373   (cond ((minusp n)
 374          (write-string "negative " stream)
 375          (format-print-cardinal-aux stream (- n) 0 n))
 376         ((zerop n)
 377          (write-string "zero" stream))
 378         (t
 379          (format-print-cardinal-aux stream n 0 n))))
 380
 381 (defun format-print-cardinal-aux (stream n period err)
 382   (multiple-value-bind (beyond here) (truncate n 1000)
 383     (unless (<= period 20)
 384       (error "number too large to print in English: ~:D" err))
 385     (unless (zerop beyond)
 386       (format-print-cardinal-aux stream beyond (1+ period) err))
 387     (unless (zerop here)
 388       (unless (zerop beyond)
 389         (write-char #\space stream))
 390       (format-print-small-cardinal stream here)
 391       (write-string (svref cardinal-periods period) stream))))
 392
 393 (defun format-print-ordinal (stream n)
 394   (when (minusp n)
 395     (write-string "negative " stream))
 396   (let ((number (abs n)))
 397     (multiple-value-bind (top bot) (truncate number 100)
 398       (unless (zerop top)
 399         (format-print-cardinal stream (- number bot)))
 400       (when (and (plusp top) (plusp bot))
 401         (write-char #\space stream))
 402       (multiple-value-bind (tens ones) (truncate bot 10)
 403         (cond ((= bot 12) (write-string "twelfth" stream))
 404               ((= tens 1)
 405                (write-string (svref cardinal-teens ones) stream);;;RAD
 406                (write-string "th" stream))
 407               ((and (zerop tens) (plusp ones))
 408                (write-string (svref ordinal-ones ones) stream))
 409               ((and (zerop ones)(plusp tens))
 410                (write-string (svref ordinal-tens tens) stream))
 411               ((plusp bot)
 412                (write-string (svref cardinal-tens tens) stream)
 413                (write-char #\- stream)
 414                (write-string (svref ordinal-ones ones) stream))
 415               ((plusp number)
 416                (write-string "th" stream))
 417               (t
 418                (write-string "zeroth" stream)))))))
 419
 420 ;;; Print Roman numerals
 421
 422 (defun format-print-old-roman (stream n)
 423   (unless (< 0 n 5000)
 424     (error "Number too large to print in old Roman numerals: ~:D" n))
 425   (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
 426        (val-list '(500 100 50 10 5 1) (cdr val-list))
 427        (cur-char #\M (car char-list))
 428        (cur-val 1000 (car val-list))
 429        (start n (do ((i start (progn
 430                                 (write-char cur-char stream)
 431                                 (- i cur-val))))
 432                     ((< i cur-val) i))))
 433       ((zerop start))))
 434
 435 (defun format-print-roman (stream n)
 436   (unless (< 0 n 4000)
 437     (error "Number too large to print in Roman numerals: ~:D" n))
 438   (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
 439        (val-list '(500 100 50 10 5 1) (cdr val-list))
 440        (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
 441        (sub-val '(100 10 10 1 1 0) (cdr sub-val))
 442        (cur-char #\M (car char-list))
 443        (cur-val 1000 (car val-list))
 444        (cur-sub-char #\C (car sub-chars))
 445        (cur-sub-val 100 (car sub-val))
 446        (start n (do ((i start (progn
 447                                 (write-char cur-char stream)
 448                                 (- i cur-val))))
 449                     ((< i cur-val)
 450                      (cond ((<= (- cur-val cur-sub-val) i)
 451                             (write-char cur-sub-char stream)
 452                             (write-char cur-char stream)
 453                             (- i (- cur-val cur-sub-val)))
 454                            (t i))))))
 455           ((zerop start))))
 456 \f
 457 ;;;; plural
 458
 459 (def-format-interpreter #\P (colonp atsignp params)
 460   (interpret-bind-defaults () params
 461     (let ((arg (if colonp
 462                    (if (eq orig-args args)
 463                        (error 'format-error
 464                               :complaint "no previous argument")
 465                        (do ((arg-ptr orig-args (cdr arg-ptr)))
 466                            ((eq (cdr arg-ptr) args)
 467                             (car arg-ptr))))
 468                    (next-arg))))
 469       (if atsignp
 470           (write-string (if (eql arg 1) "y" "ies") stream)
 471           (unless (eql arg 1) (write-char #\s stream))))))
 472 \f
 473 ;;;; format interpreters and support functions for floating point output
 474
 475 (defun decimal-string (n)
 476   (write-to-string n :base 10 :radix nil :escape nil))
 477
 478 (def-format-interpreter #\F (colonp atsignp params)
 479   (when colonp
 480     (error 'format-error
 481            :complaint
 482            "cannot specify the colon modifier with this directive"))
 483   (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
 484                            params
 485     (format-fixed stream (next-arg) w d k ovf pad atsignp)))
 486
 487 (defun format-fixed (stream number w d k ovf pad atsign)
 488   (if (numberp number)
 489       (if (floatp number)
 490           (format-fixed-aux stream number w d k ovf pad atsign)
 491           (if (rationalp number)
 492               (format-fixed-aux stream
 493                                 (coerce number 'single-float)
 494                                 w d k ovf pad atsign)
 495               (format-write-field stream
 496                                   (decimal-string number)
 497                                   w 1 0 #\space t)))
 498       (format-princ stream number nil nil w 1 0 pad)))
 499
 500 ;;; We return true if we overflowed, so that ~G can output the overflow char
 501 ;;; instead of spaces.
 502 (defun format-fixed-aux (stream number w d k ovf pad atsign)
 503   (cond
 504    ((or (not (or w d))
 505         (and (floatp number)
 506              (or (float-infinity-p number)
 507                  (float-nan-p number))))
 508     (prin1 number stream)
 509     nil)
 510    (t
 511     (let ((spaceleft w))
 512       (when (and w (or atsign (minusp number))) (decf spaceleft))
 513       (multiple-value-bind (str len lpoint tpoint)
 514           (sb!impl::flonum-to-string (abs number) spaceleft d k)
 515         ;;if caller specifically requested no fraction digits, suppress the
 516         ;;optional trailing zero
 517         (when (and d (zerop d)) (setq tpoint nil))
 518         (when w
 519           (decf spaceleft len)
 520           ;;optional leading zero
 521           (when lpoint
 522             (if (or (> spaceleft 0) tpoint) ;force at least one digit
 523                 (decf spaceleft)
 524                 (setq lpoint nil)))
 525           ;;optional trailing zero
 526           (when tpoint
 527             (if (> spaceleft 0)
 528                 (decf spaceleft)
 529                 (setq tpoint nil))))
 530         (cond ((and w (< spaceleft 0) ovf)
 531                ;;field width overflow
 532                (dotimes (i w) (write-char ovf stream))
 533                t)
 534               (t
 535                (when w (dotimes (i spaceleft) (write-char pad stream)))
 536                (if (minusp number)
 537                    (write-char #\- stream)
 538                    (if atsign (write-char #\+ stream)))
 539                (when lpoint (write-char #\0 stream))
 540                (write-string str stream)
 541                (when tpoint (write-char #\0 stream))
 542                nil)))))))
 543
 544 (def-format-interpreter #\E (colonp atsignp params)
 545   (when colonp
 546     (error 'format-error
 547            :complaint
 548            "cannot specify the colon modifier with this directive"))
 549   (interpret-bind-defaults
 550       ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
 551       params
 552     (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
 553
 554 (defun format-exponential (stream number w d e k ovf pad marker atsign)
 555   (if (numberp number)
 556       (if (floatp number)
 557           (format-exp-aux stream number w d e k ovf pad marker atsign)
 558           (if (rationalp number)
 559               (format-exp-aux stream
 560                               (coerce number 'single-float)
 561                               w d e k ovf pad marker atsign)
 562               (format-write-field stream
 563                                   (decimal-string number)
 564                                   w 1 0 #\space t)))
 565       (format-princ stream number nil nil w 1 0 pad)))
 566
 567 (defun format-exponent-marker (number)
 568   (if (typep number *read-default-float-format*)
 569       #\e
 570       (typecase number
 571         (single-float #\f)
 572         (double-float #\d)
 573         (short-float #\s)
 574         (long-float #\l))))
 575
 576 ;;; Here we prevent the scale factor from shifting all significance out of
 577 ;;; a number to the right. We allow insignificant zeroes to be shifted in
 578 ;;; to the left right, athough it is an error to specify k and d such that this
 579 ;;; occurs. Perhaps we should detect both these condtions and flag them as
 580 ;;; errors. As for now, we let the user get away with it, and merely guarantee
 581 ;;; that at least one significant digit will appear.
 582
 583 ;;; toy@rtp.ericsson.se:  The Hyperspec seems to say that the exponent
 584 ;;; marker is always printed. Make it so. Also, the original version
 585 ;;; causes errors when printing infinities or NaN's. The Hyperspec is
 586 ;;; silent here, so let's just print out infinities and NaN's instead
 587 ;;; of causing an error.
 588 (defun format-exp-aux (stream number w d e k ovf pad marker atsign)
 589   (if (and (floatp number)
 590            (or (float-infinity-p number)
 591                (float-nan-p number)))
 592       (prin1 number stream)
 593       (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number))
 594         (let* ((expt (- expt k))
 595                (estr (decimal-string (abs expt)))
 596                (elen (if e (max (length estr) e) (length estr)))
 597                (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
 598                (fmin (if (minusp k) (- 1 k) nil))
 599                (spaceleft (if w
 600                               (- w 2 elen
 601                                  (if (or atsign (minusp number))
 602                                      1 0))
 603                               nil)))
 604           (if (and w ovf e (> elen e)) ;exponent overflow
 605               (dotimes (i w) (write-char ovf stream))
 606               (multiple-value-bind (fstr flen lpoint)
 607                   (sb!impl::flonum-to-string num spaceleft fdig k fmin)
 608                 (when w
 609                   (decf spaceleft flen)
 610                   (when lpoint
 611                     (if (> spaceleft 0)
 612                         (decf spaceleft)
 613                         (setq lpoint nil))))
 614                 (cond ((and w (< spaceleft 0) ovf)
 615                        ;;significand overflow
 616                        (dotimes (i w) (write-char ovf stream)))
 617                       (t (when w
 618                            (dotimes (i spaceleft) (write-char pad stream)))
 619                          (if (minusp number)
 620                              (write-char #\- stream)
 621                              (if atsign (write-char #\+ stream)))
 622                          (when lpoint (write-char #\0 stream))
 623                          (write-string fstr stream)
 624                          (write-char (if marker
 625                                          marker
 626                                          (format-exponent-marker number))
 627                                      stream)
 628                          (write-char (if (minusp expt) #\- #\+) stream)
 629                          (when e
 630                            ;;zero-fill before exponent if necessary
 631                            (dotimes (i (- e (length estr)))
 632                              (write-char #\0 stream)))
 633                          (write-string estr stream)))))))))
 634
 635 (def-format-interpreter #\G (colonp atsignp params)
 636   (when colonp
 637     (error 'format-error
 638            :complaint
 639            "cannot specify the colon modifier with this directive"))
 640   (interpret-bind-defaults
 641       ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
 642       params
 643     (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
 644
 645 (defun format-general (stream number w d e k ovf pad marker atsign)
 646   (if (numberp number)
 647       (if (floatp number)
 648           (format-general-aux stream number w d e k ovf pad marker atsign)
 649           (if (rationalp number)
 650               (format-general-aux stream
 651                                   (coerce number 'single-float)
 652                                   w d e k ovf pad marker atsign)
 653               (format-write-field stream
 654                                   (decimal-string number)
 655                                   w 1 0 #\space t)))
 656       (format-princ stream number nil nil w 1 0 pad)))
 657
 658 ;;; toy@rtp.ericsson.se:  Same change as for format-exp-aux.
 659 (defun format-general-aux (stream number w d e k ovf pad marker atsign)
 660   (if (and (floatp number)
 661            (or (float-infinity-p number)
 662                (float-nan-p number)))
 663       (prin1 number stream)
 664       (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number))
 665         (declare (ignore ignore))
 666         ;; KLUDGE: Default d if omitted. The procedure is taken directly from
 667         ;; the definition given in the manual, and is not very efficient, since
 668         ;; we generate the digits twice. Future maintainers are encouraged to
 669         ;; improve on this. -- rtoy?? 1998??
 670         (unless d
 671           (multiple-value-bind (str len)
 672               (sb!impl::flonum-to-string (abs number))
 673             (declare (ignore str))
 674             (let ((q (if (= len 1) 1 (1- len))))
 675               (setq d (max q (min n 7))))))
 676         (let* ((ee (if e (+ e 2) 4))
 677                (ww (if w (- w ee) nil))
 678                (dd (- d n)))
 679           (cond ((<= 0 dd d)
 680                  (let ((char (if (format-fixed-aux stream number ww dd nil
 681                                                    ovf pad atsign)
 682                                  ovf
 683                                  #\space)))
 684                    (dotimes (i ee) (write-char char stream))))
 685                 (t
 686                  (format-exp-aux stream number w d e (or k 1)
 687                                  ovf pad marker atsign)))))))
 688
 689 (def-format-interpreter #\$ (colonp atsignp params)
 690   (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
 691     (format-dollars stream (next-arg) d n w pad colonp atsignp)))
 692
 693 (defun format-dollars (stream number d n w pad colon atsign)
 694   (if (rationalp number) (setq number (coerce number 'single-float)))
 695   (if (floatp number)
 696       (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
 697              (signlen (length signstr)))
 698         (multiple-value-bind (str strlen ig2 ig3 pointplace)
 699             (sb!impl::flonum-to-string number nil d nil)
 700           (declare (ignore ig2 ig3))
 701           (when colon (write-string signstr stream))
 702           (dotimes (i (- w signlen (- n pointplace) strlen))
 703             (write-char pad stream))
 704           (unless colon (write-string signstr stream))
 705           (dotimes (i (- n pointplace)) (write-char #\0 stream))
 706           (write-string str stream)))
 707       (format-write-field stream
 708                           (decimal-string number)
 709                           w 1 0 #\space t)))
 710 \f
 711 ;;;; format interpreters and support functions for line/page breaks etc.
 712
 713 (def-format-interpreter #\% (colonp atsignp params)
 714   (when (or colonp atsignp)
 715     (error 'format-error
 716            :complaint
 717            "cannot specify either colon or atsign for this directive"))
 718   (interpret-bind-defaults ((count 1)) params
 719     (dotimes (i count)
 720       (terpri stream))))
 721
 722 (def-format-interpreter #\& (colonp atsignp params)
 723   (when (or colonp atsignp)
 724     (error 'format-error
 725            :complaint
 726            "cannot specify either colon or atsign for this directive"))
 727   (interpret-bind-defaults ((count 1)) params
 728     (fresh-line stream)
 729     (dotimes (i (1- count))
 730       (terpri stream))))
 731
 732 (def-format-interpreter #\| (colonp atsignp params)
 733   (when (or colonp atsignp)
 734     (error 'format-error
 735            :complaint
 736            "cannot specify either colon or atsign for this directive"))
 737   (interpret-bind-defaults ((count 1)) params
 738     (dotimes (i count)
 739       (write-char (code-char form-feed-char-code) stream))))
 740
 741 (def-format-interpreter #\~ (colonp atsignp params)
 742   (when (or colonp atsignp)
 743     (error 'format-error
 744            :complaint
 745            "cannot specify either colon or atsign for this directive"))
 746   (interpret-bind-defaults ((count 1)) params
 747     (dotimes (i count)
 748       (write-char #\~ stream))))
 749
 750 (def-complex-format-interpreter #\newline (colonp atsignp params directives)
 751   (when (and colonp atsignp)
 752     (error 'format-error
 753            :complaint
 754            "cannot specify both colon and atsign for this directive"))
 755   (interpret-bind-defaults () params
 756     (when atsignp
 757       (write-char #\newline stream)))
 758   (if (and (not colonp)
 759            directives
 760            (simple-string-p (car directives)))
 761       (cons (string-left-trim *format-whitespace-chars*
 762                               (car directives))
 763             (cdr directives))
 764       directives))
 765 \f
 766 ;;;; format interpreters and support functions for tabs and simple pretty
 767 ;;;; printing
 768
 769 (def-format-interpreter #\T (colonp atsignp params)
 770   (if colonp
 771       (interpret-bind-defaults ((n 1) (m 1)) params
 772         (pprint-tab (if atsignp :section-relative :section) n m stream))
 773       (if atsignp
 774           (interpret-bind-defaults ((colrel 1) (colinc 1)) params
 775             (format-relative-tab stream colrel colinc))
 776           (interpret-bind-defaults ((colnum 1) (colinc 1)) params
 777             (format-absolute-tab stream colnum colinc)))))
 778
 779 (defun output-spaces (stream n)
 780   (let ((spaces #.(make-string 100 :initial-element #\space)))
 781     (loop
 782       (when (< n (length spaces))
 783         (return))
 784       (write-string spaces stream)
 785       (decf n (length spaces)))
 786     (write-string spaces stream :end n)))
 787
 788 (defun format-relative-tab (stream colrel colinc)
 789   (if (sb!pretty:pretty-stream-p stream)
 790       (pprint-tab :line-relative colrel colinc stream)
 791       (let* ((cur (sb!impl::charpos stream))
 792              (spaces (if (and cur (plusp colinc))
 793                          (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
 794                          colrel)))
 795         (output-spaces stream spaces))))
 796
 797 (defun format-absolute-tab (stream colnum colinc)
 798   (if (sb!pretty:pretty-stream-p stream)
 799       (pprint-tab :line colnum colinc stream)
 800       (let ((cur (sb!impl::charpos stream)))
 801         (cond ((null cur)
 802                (write-string "  " stream))
 803               ((< cur colnum)
 804                (output-spaces stream (- colnum cur)))
 805               (t
 806                (unless (zerop colinc)
 807                  (output-spaces stream
 808                                 (- colinc (rem (- cur colnum) colinc)))))))))
 809
 810 (def-format-interpreter #\_ (colonp atsignp params)
 811   (interpret-bind-defaults () params
 812     (pprint-newline (if colonp
 813                         (if atsignp
 814                             :mandatory
 815                             :fill)
 816                         (if atsignp
 817                             :miser
 818                             :linear))
 819                     stream)))
 820
 821 (def-format-interpreter #\I (colonp atsignp params)
 822   (when atsignp
 823     (error 'format-error
 824            :complaint "cannot specify the at-sign modifier"))
 825   (interpret-bind-defaults ((n 0)) params
 826     (pprint-indent (if colonp :current :block) n stream)))
 827 \f
 828 ;;;; format interpreter for ~*
 829
 830 (def-format-interpreter #\* (colonp atsignp params)
 831   (if atsignp
 832       (if colonp
 833           (error 'format-error
 834                  :complaint "cannot specify both colon and at-sign")
 835           (interpret-bind-defaults ((posn 0)) params
 836             (if (<= 0 posn (length orig-args))
 837                 (setf args (nthcdr posn orig-args))
 838                 (error 'format-error
 839                        :complaint "Index ~D is out of bounds. (It should ~
 840                                    have been between 0 and ~D.)"
 841                        :arguments (list posn (length orig-args))))))
 842       (if colonp
 843           (interpret-bind-defaults ((n 1)) params
 844             (do ((cur-posn 0 (1+ cur-posn))
 845                  (arg-ptr orig-args (cdr arg-ptr)))
 846                 ((eq arg-ptr args)
 847                  (let ((new-posn (- cur-posn n)))
 848                    (if (<= 0 new-posn (length orig-args))
 849                        (setf args (nthcdr new-posn orig-args))
 850                        (error 'format-error
 851                               :complaint
 852                               "Index ~D is out of bounds. (It should
 853                                have been between 0 and ~D.)"
 854                               :arguments
 855                               (list new-posn (length orig-args))))))))
 856           (interpret-bind-defaults ((n 1)) params
 857             (dotimes (i n)
 858               (next-arg))))))
 859 \f
 860 ;;;; format interpreter for indirection
 861
 862 (def-format-interpreter #\? (colonp atsignp params string end)
 863   (when colonp
 864     (error 'format-error
 865            :complaint "cannot specify the colon modifier"))
 866   (interpret-bind-defaults () params
 867     (handler-bind
 868         ((format-error
 869           #'(lambda (condition)
 870               (error 'format-error
 871                      :complaint
 872                      "~A~%while processing indirect format string:"
 873                      :arguments (list condition)
 874                      :print-banner nil
 875                      :control-string string
 876                      :offset (1- end)))))
 877       (if atsignp
 878           (setf args (%format stream (next-arg) orig-args args))
 879           (%format stream (next-arg) (next-arg))))))
 880 \f
 881 ;;;; format interpreters for capitalization
 882
 883 (def-complex-format-interpreter #\( (colonp atsignp params directives)
 884   (let ((close (find-directive directives #\) nil)))
 885     (unless close
 886       (error 'format-error
 887              :complaint "no corresponding close paren"))
 888     (interpret-bind-defaults () params
 889       (let* ((posn (position close directives))
 890              (before (subseq directives 0 posn))
 891              (after (nthcdr (1+ posn) directives))
 892              (stream (make-case-frob-stream stream
 893                                             (if colonp
 894                                                 (if atsignp
 895                                                     :upcase
 896                                                     :capitalize)
 897                                                 (if atsignp
 898                                                     :capitalize-first
 899                                                     :downcase)))))
 900         (setf args (interpret-directive-list stream before orig-args args))
 901         after))))
 902
 903 (def-complex-format-interpreter #\) ()
 904   (error 'format-error
 905          :complaint "no corresponding open paren"))
 906 \f
 907 ;;;; format interpreters and support functions for conditionalization
 908
 909 (def-complex-format-interpreter #\[ (colonp atsignp params directives)
 910   (multiple-value-bind (sublists last-semi-with-colon-p remaining)
 911       (parse-conditional-directive directives)
 912     (setf args
 913           (if atsignp
 914               (if colonp
 915                   (error 'format-error
 916                          :complaint
 917                      "cannot specify both the colon and at-sign modifiers")
 918                   (if (cdr sublists)
 919                       (error 'format-error
 920                              :complaint
 921                              "can only specify one section")
 922                       (interpret-bind-defaults () params
 923                         (let ((prev-args args)
 924                               (arg (next-arg)))
 925                           (if arg
 926                               (interpret-directive-list stream
 927                                                         (car sublists)
 928                                                         orig-args
 929                                                         prev-args)
 930                               args)))))
 931               (if colonp
 932                   (if (= (length sublists) 2)
 933                       (interpret-bind-defaults () params
 934                         (if (next-arg)
 935                             (interpret-directive-list stream (car sublists)
 936                                                       orig-args args)
 937                             (interpret-directive-list stream (cadr sublists)
 938                                                       orig-args args)))
 939                       (error 'format-error
 940                              :complaint
 941                              "must specify exactly two sections"))
 942                   (interpret-bind-defaults ((index (next-arg))) params
 943                     (let* ((default (and last-semi-with-colon-p
 944                                          (pop sublists)))
 945                            (last (1- (length sublists)))
 946                            (sublist
 947                             (if (<= 0 index last)
 948                                 (nth (- last index) sublists)
 949                                 default)))
 950                       (interpret-directive-list stream sublist orig-args
 951                                                 args))))))
 952     remaining))
 953
 954 (def-complex-format-interpreter #\; ()
 955   (error 'format-error
 956          :complaint
 957          "~~; not contained within either ~~[...~~] or ~~<...~~>"))
 958
 959 (def-complex-format-interpreter #\] ()
 960   (error 'format-error
 961          :complaint
 962          "no corresponding open bracket"))
 963 \f
 964 ;;;; format interpreter for up-and-out
 965
 966 (defvar *outside-args*)
 967
 968 (def-format-interpreter #\^ (colonp atsignp params)
 969   (when atsignp
 970     (error 'format-error
 971            :complaint "cannot specify the at-sign modifier"))
 972   (when (and colonp (not *up-up-and-out-allowed*))
 973     (error 'format-error
 974            :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
 975   (when (case (length params)
 976           (0 (if colonp
 977                  (null *outside-args*)
 978                  (null args)))
 979           (1 (interpret-bind-defaults ((count 0)) params
 980                (zerop count)))
 981           (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
 982                (= arg1 arg2)))
 983           (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
 984                (<= arg1 arg2 arg3))))
 985     (throw (if colonp 'up-up-and-out 'up-and-out)
 986            args)))
 987 \f
 988 ;;;; format interpreters for iteration
 989
 990 (def-complex-format-interpreter #\{
 991                                 (colonp atsignp params string end directives)
 992   (let ((close (find-directive directives #\} nil)))
 993     (unless close
 994       (error 'format-error
 995              :complaint
 996              "no corresponding close brace"))
 997     (interpret-bind-defaults ((max-count nil)) params
 998       (let* ((closed-with-colon (format-directive-colonp close))
 999              (posn (position close directives))
1000              (insides (if (zerop posn)
1001                           (next-arg)
1002                           (subseq directives 0 posn)))
1003              (*up-up-and-out-allowed* colonp))
1004         (labels
1005             ((do-guts (orig-args args)
1006                (if (zerop posn)
1007                    (handler-bind
1008                        ((format-error
1009                          #'(lambda (condition)
1010                              (error 'format-error
1011                                     :complaint
1012                             "~A~%while processing indirect format string:"
1013                                     :arguments (list condition)
1014                                     :print-banner nil
1015                                     :control-string string
1016                                     :offset (1- end)))))
1017                      (%format stream insides orig-args args))
1018                    (interpret-directive-list stream insides
1019                                              orig-args args)))
1020              (bind-args (orig-args args)
1021                (if colonp
1022                    (let* ((arg (next-arg))
1023                           (*logical-block-popper* nil)
1024                           (*outside-args* args))
1025                      (catch 'up-and-out
1026                        (do-guts arg arg)
1027                        args))
1028                    (do-guts orig-args args)))
1029              (do-loop (orig-args args)
1030                (catch (if colonp 'up-up-and-out 'up-and-out)
1031                  (loop
1032                    (when (and (not closed-with-colon) (null args))
1033                      (return))
1034                    (when (and max-count (minusp (decf max-count)))
1035                      (return))
1036                    (setf args (bind-args orig-args args))
1037                    (when (and closed-with-colon (null args))
1038                      (return)))
1039                  args)))
1040           (if atsignp
1041               (setf args (do-loop orig-args args))
1042               (let ((arg (next-arg))
1043                     (*logical-block-popper* nil))
1044                 (do-loop arg arg)))
1045           (nthcdr (1+ posn) directives))))))
1046
1047 (def-complex-format-interpreter #\} ()
1048   (error 'format-error
1049          :complaint "no corresponding open brace"))
1050 \f
1051 ;;;; format interpreters and support functions for justification
1052
1053 (def-complex-format-interpreter #\<
1054                                 (colonp atsignp params string end directives)
1055   (multiple-value-bind (segments first-semi close remaining)
1056       (parse-format-justification directives)
1057     (setf args
1058           (if (format-directive-colonp close)
1059               (multiple-value-bind (prefix per-line-p insides suffix)
1060                   (parse-format-logical-block segments colonp first-semi
1061                                               close params string end)
1062                 (interpret-format-logical-block stream orig-args args
1063                                                 prefix per-line-p insides
1064                                                 suffix atsignp))
1065               (interpret-format-justification stream orig-args args
1066                                               segments colonp atsignp
1067                                               first-semi params)))
1068     remaining))
1069
1070 (defun interpret-format-justification
1071        (stream orig-args args segments colonp atsignp first-semi params)
1072   (interpret-bind-defaults
1073       ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1074       params
1075     (let ((newline-string nil)
1076           (strings nil)
1077           (extra-space 0)
1078           (line-len 0))
1079       (setf args
1080             (catch 'up-and-out
1081               (when (and first-semi (format-directive-colonp first-semi))
1082                 (interpret-bind-defaults
1083                     ((extra 0)
1084                      (len (or (sb!impl::line-length stream) 72)))
1085                     (format-directive-params first-semi)
1086                   (setf newline-string
1087                         (with-output-to-string (stream)
1088                           (setf args
1089                                 (interpret-directive-list stream
1090                                                           (pop segments)
1091                                                           orig-args
1092                                                           args))))
1093                   (setf extra-space extra)
1094                   (setf line-len len)))
1095               (dolist (segment segments)
1096                 (push (with-output-to-string (stream)
1097                         (setf args
1098                               (interpret-directive-list stream segment
1099                                                         orig-args args)))
1100                       strings))
1101               args))
1102       (format-justification stream newline-string extra-space line-len strings
1103                             colonp atsignp mincol colinc minpad padchar)))
1104   args)
1105
1106 (defun format-justification (stream newline-prefix extra-space line-len strings
1107                              pad-left pad-right mincol colinc minpad padchar)
1108   (setf strings (reverse strings))
1109   (when (and (not pad-left) (not pad-right) (null (cdr strings)))
1110     (setf pad-left t))
1111   (let* ((num-gaps (+ (1- (length strings))
1112                       (if pad-left 1 0)
1113                       (if pad-right 1 0)))
1114          (chars (+ (* num-gaps minpad)
1115                    (loop
1116                      for string in strings
1117                      summing (length string))))
1118          (length (if (> chars mincol)
1119                      (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
1120                      mincol))
1121          (padding (- length chars)))
1122     (when (and newline-prefix
1123                (> (+ (or (sb!impl::charpos stream) 0)
1124                      length extra-space)
1125                   line-len))
1126       (write-string newline-prefix stream))
1127     (flet ((do-padding ()
1128              (let ((pad-len (truncate padding num-gaps)))
1129                (decf padding pad-len)
1130                (decf num-gaps)
1131                (dotimes (i pad-len) (write-char padchar stream)))))
1132       (when pad-left
1133         (do-padding))
1134       (when strings
1135         (write-string (car strings) stream)
1136         (dolist (string (cdr strings))
1137           (do-padding)
1138           (write-string string stream)))
1139       (when pad-right
1140         (do-padding)))))
1141
1142 (defun interpret-format-logical-block
1143        (stream orig-args args prefix per-line-p insides suffix atsignp)
1144   (let ((arg (if atsignp args (next-arg))))
1145     (if per-line-p
1146         (pprint-logical-block
1147             (stream arg :per-line-prefix prefix :suffix suffix)
1148           (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
1149             (catch 'up-and-out
1150               (interpret-directive-list stream insides
1151                                         (if atsignp orig-args arg)
1152                                         arg))))
1153         (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
1154           (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
1155             (catch 'up-and-out
1156               (interpret-directive-list stream insides
1157                                         (if atsignp orig-args arg)
1158                                         arg))))))
1159   (if atsignp nil args))
1160 \f
1161 ;;;; format interpreter and support functions for user-defined method
1162
1163 (def-format-interpreter #\/ (string start end colonp atsignp params)
1164   (let ((symbol (extract-user-function-name string start end)))
1165     (collect ((args))
1166       (dolist (param-and-offset params)
1167         (let ((param (cdr param-and-offset)))
1168           (case param
1169             (:arg (args (next-arg)))
1170             (:remaining (args (length args)))
1171             (t (args param)))))
1172       (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))