src/code/target-format.lisp

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