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