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