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