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