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