src/code/target-format.lisp

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