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