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