src/code/target-format.lisp

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