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