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