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