/[cmucl]/src/code/format.lisp
ViewVC logotype

Contents of /src/code/format.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.97 - (show annotations)
Tue Nov 16 19:15:38 2010 UTC (3 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, HEAD
Branch point for: cross-sol-x86-branch
Changes since 1.96: +8 -4 lines
Signal a warning if ~:[ directive includes ~:;.  From a message by
Didier Verna, cmucl-imp, 2010-11-11.
1 ;;; -*- Package: FORMAT -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/format.lisp,v 1.97 2010/11/16 19:15:38 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp.
13 ;;;
14 ;;; Written by William Lott, with lots of stuff stolen from the previous
15 ;;; version by David Adam and later rewritten by Bill Maddox.
16 ;;;
17
18 (in-package "FORMAT")
19 (use-package "EXT")
20 (use-package "KERNEL")
21
22 (intl:textdomain "cmucl")
23
24 (in-package "LISP")
25 (export '(format formatter))
26
27 (in-package "FORMAT")
28
29 (defstruct (format-directive
30 (:print-function %print-format-directive))
31 (string (required-argument) :type simple-string)
32 (start (required-argument) :type (and unsigned-byte fixnum))
33 (end (required-argument) :type (and unsigned-byte fixnum))
34 (character (required-argument) :type base-char)
35 (colonp nil :type (member t nil))
36 (atsignp nil :type (member t nil))
37 (params nil :type list))
38
39 (defun %print-format-directive (struct stream depth)
40 (declare (ignore depth))
41 (print-unreadable-object (struct stream)
42 (write-string (format-directive-string struct) stream
43 :start (format-directive-start struct)
44 :end (format-directive-end struct))))
45
46 (defvar *format-directive-expanders*
47 (make-array char-code-limit :initial-element nil))
48 (defvar *format-directive-interpreters*
49 (make-array char-code-limit :initial-element nil))
50
51 (defun %print-format-error (condition stream)
52 (cl:format stream
53 (intl:gettext "~:[~;Error in format: ~]~
54 ~?~@[~% ~A~% ~V@T^~]")
55 (format-error-print-banner condition)
56 (format-error-complaint condition)
57 (format-error-arguments condition)
58 (format-error-control-string condition)
59 (format-error-offset condition)))
60
61 (defvar *default-format-error-control-string* nil)
62 (defvar *default-format-error-offset* nil)
63
64 (define-condition format-error (error)
65 ((complaint :reader format-error-complaint :initarg :complaint)
66 (arguments :reader format-error-arguments :initarg :arguments :initform nil)
67 (control-string :reader format-error-control-string
68 :initarg :control-string
69 :initform *default-format-error-control-string*)
70 (offset :reader format-error-offset :initarg :offset
71 :initform *default-format-error-offset*)
72 (print-banner :reader format-error-print-banner :initarg :print-banner
73 :initform t))
74 (:report %print-format-error))
75
76
77 ;;;; TOKENIZE-CONTROL-STRING
78
79 (defun tokenize-control-string (string)
80 (declare (simple-string string))
81 (let ((index 0)
82 (end (length string))
83 (result nil)
84 (in-block nil)
85 (pprint nil)
86 (semi nil)
87 (justification-semi 0))
88 (loop
89 (let ((next-directive (or (position #\~ string :start index) end)))
90 (when (> next-directive index)
91 (push (subseq string index next-directive) result))
92 (when (= next-directive end)
93 (return))
94 (let* ((directive (parse-directive string next-directive))
95 (directive-char (format-directive-character directive)))
96 ;; We are looking for illegal combinations of format
97 ;; directives in the control string. See the last paragraph
98 ;; of CLHS 22.3.5.2: "an error is also signaled if the
99 ;; ~<...~:;...~> form of ~<...~> is used in the same format
100 ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T."
101 (cond ((char= #\< directive-char)
102 ;; Found a justification or logical block
103 (setf in-block t))
104 ((and in-block (char= #\; directive-char))
105 ;; Found a semi colon in a justification or logical block
106 (setf semi t))
107 ((char= #\> directive-char)
108 ;; End of justification or logical block. Figure out which.
109 (setf in-block nil)
110 (cond ((format-directive-colonp directive)
111 ;; A logical-block directive. Note that fact, and also
112 ;; note that we don't care if we found any ~;
113 ;; directives in the block.
114 (setf pprint t)
115 (setf semi nil))
116 (semi
117 ;; A justification block with a ~; directive in it.
118 (incf justification-semi))))
119 ((and (not in-block)
120 (or (and (char= #\T directive-char) (format-directive-colonp directive))
121 (char= #\W directive-char)
122 (char= #\_ directive-char)
123 (char= #\I directive-char)))
124 (setf pprint t)))
125 (push directive result)
126 (setf index (format-directive-end directive)))))
127 (when (and pprint (plusp justification-semi))
128 (error 'format-error
129 :complaint (intl:gettext "A justification directive cannot be in the same format string~%~
130 as ~~W, ~~I, ~~:T, or a logical-block directive.")
131 :control-string string
132 :offset 0))
133 (nreverse result)))
134
135 (defun parse-directive (string start)
136 (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
137 (end (length string)))
138 (flet ((get-char ()
139 (if (= posn end)
140 (error 'format-error
141 :complaint (intl:gettext "String ended before directive was found.")
142 :control-string string
143 :offset start)
144 (schar string posn))))
145 (loop
146 (let ((char (get-char)))
147 (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
148 (multiple-value-bind
149 (param new-posn)
150 (parse-integer string :start posn :junk-allowed t)
151 (push (cons posn param) params)
152 (setf posn new-posn)
153 (case (get-char)
154 (#\,)
155 ((#\: #\@)
156 (decf posn))
157 (t
158 (return)))))
159 ((or (char= char #\v) (char= char #\V))
160 (push (cons posn :arg) params)
161 (incf posn)
162 (case (get-char)
163 (#\,)
164 ((#\: #\@)
165 (decf posn))
166 (t
167 (return))))
168 ((char= char #\#)
169 (push (cons posn :remaining) params)
170 (incf posn)
171 (case (get-char)
172 (#\,)
173 ((#\: #\@)
174 (decf posn))
175 (t
176 (return))))
177 ((char= char #\')
178 (incf posn)
179 (push (cons posn (get-char)) params)
180 (incf posn)
181 (unless (char= (get-char) #\,)
182 (decf posn)))
183 ((char= char #\,)
184 (push (cons posn nil) params))
185 ((char= char #\:)
186 (if colonp
187 (error 'format-error
188 :complaint (intl:gettext "Too many colons supplied.")
189 :control-string string
190 :offset posn)
191 (setf colonp t)))
192 ((char= char #\@)
193 (if atsignp
194 (error 'format-error
195 :complaint (intl:gettext "Too many at-signs supplied.")
196 :control-string string
197 :offset posn)
198 (setf atsignp t)))
199 (t
200 (return))))
201 (incf posn))
202 (let ((char (get-char)))
203 (when (char= char #\/)
204 (let ((closing-slash (position #\/ string :start (1+ posn))))
205 (if closing-slash
206 (setf posn closing-slash)
207 (error 'format-error
208 :complaint (intl:gettext "No matching closing slash.")
209 :control-string string
210 :offset posn))))
211 (make-format-directive
212 :string string :start start :end (1+ posn)
213 :character (char-upcase char)
214 :colonp colonp :atsignp atsignp
215 :params (nreverse params))))))
216
217
218 ;;;; Specials used to communicate information.
219
220 ;;; *UP-UP-AND-OUT-ALLOWED* -- internal.
221 ;;;
222 ;;; Used both by the expansion stuff and the interpreter stuff. When it is
223 ;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed.
224 ;;;
225 (defvar *up-up-and-out-allowed* nil)
226
227 ;;; *LOGICAL-BLOCK-POPPER* -- internal.
228 ;;;
229 ;;; Used by the interpreter stuff. When it non-NIL, its a function that will
230 ;;; invoke PPRINT-POP in the right lexical environemnt.
231 ;;;
232 (defvar *logical-block-popper* nil)
233
234 ;;; *EXPANDER-NEXT-ARG-MACRO* -- internal.
235 ;;;
236 ;;; Used by the expander stuff. This is bindable so that ~<...~:>
237 ;;; can change it.
238 ;;;
239 (defvar *expander-next-arg-macro* 'expander-next-arg)
240
241 ;;; *ONLY-SIMPLE-ARGS* -- internal.
242 ;;;
243 ;;; Used by the expander stuff. Initially starts as T, and gets set to NIL
244 ;;; if someone needs to do something strange with the arg list (like use
245 ;;; the rest, or something).
246 ;;;
247 (defvar *only-simple-args*)
248
249 ;;; *ORIG-ARGS-AVAILABLE* -- internal.
250 ;;;
251 ;;; Used by the expander stuff. We do an initial pass with this as NIL.
252 ;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
253 ;;; again with it bound to T. If this is T, we don't try to do anything
254 ;;; fancy with args.
255 ;;;
256 (defvar *orig-args-available* nil)
257
258 ;;; *SIMPLE-ARGS* -- internal.
259 ;;;
260 ;;; Used by the expander stuff. List of (symbol . offset) for simple args.
261 ;;;
262 (defvar *simple-args*)
263
264
265
266
267 ;;;; FORMAT
268
269 (defun format (destination control-string &rest format-arguments)
270 "Provides various facilities for formatting output.
271 CONTROL-STRING contains a string to be output, possibly with embedded
272 directives, which are flagged with the escape character \"~\". Directives
273 generally expand into additional text to be output, usually consuming one
274 or more of the FORMAT-ARGUMENTS in the process. A few useful directives
275 are:
276 ~A or ~nA Prints one argument as if by PRINC
277 ~S or ~nS Prints one argument as if by PRIN1
278 ~D or ~nD Prints one argument as a decimal integer
279 ~% Does a TERPRI
280 ~& Does a FRESH-LINE
281
282 where n is the width of the field in which the object is printed.
283
284 DESTINATION controls where the result will go. If DESTINATION is T, then
285 the output is sent to the standard output stream. If it is NIL, then the
286 output is returned in a string as the value of the call. Otherwise,
287 DESTINATION must be a stream to which the output will be sent.
288
289 Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
290
291 FORMAT has many additional capabilities not described here. Consult
292 Section 22.3 (Formatted Output) of the ANSI Common Lisp standard for
293 details."
294 (etypecase destination
295 (null
296 (with-output-to-string (stream)
297 (%format stream control-string format-arguments)))
298 (string
299 (with-output-to-string (stream destination)
300 (%format stream control-string format-arguments)))
301 ((member t)
302 (%format *standard-output* control-string format-arguments)
303 nil)
304 (stream
305 (%format destination control-string format-arguments)
306 nil)))
307
308 (defun %format (stream string-or-fun orig-args &optional (args orig-args))
309 (if (functionp string-or-fun)
310 (apply string-or-fun stream args)
311 (catch 'up-and-out
312 (let* ((string (etypecase string-or-fun
313 (simple-string
314 string-or-fun)
315 (string
316 (coerce string-or-fun 'simple-string))))
317 (*default-format-error-control-string* string)
318 (*logical-block-popper* nil))
319 (interpret-directive-list stream (tokenize-control-string string)
320 orig-args args)))))
321
322 (defun interpret-directive-list (stream directives orig-args args)
323 (if directives
324 (let ((directive (car directives)))
325 (etypecase directive
326 (simple-string
327 (write-string directive stream)
328 (interpret-directive-list stream (cdr directives) orig-args args))
329 (format-directive
330 (multiple-value-bind
331 (new-directives new-args)
332 (let ((function
333 (svref *format-directive-interpreters*
334 (char-code (format-directive-character
335 directive))))
336 (*default-format-error-offset*
337 (1- (format-directive-end directive))))
338 (unless function
339 (error 'format-error
340 :complaint (intl:gettext "Unknown format directive.")))
341 (multiple-value-bind
342 (new-directives new-args)
343 (funcall function stream directive
344 (cdr directives) orig-args args)
345 (values new-directives new-args)))
346 (interpret-directive-list stream new-directives
347 orig-args new-args)))))
348 args))
349
350
351 ;;;; FORMATTER
352
353 (defmacro formatter (control-string)
354 `#',(%formatter control-string))
355
356 (defun %formatter (control-string)
357 (block nil
358 (catch 'need-orig-args
359 (let* ((*simple-args* nil)
360 (*only-simple-args* t)
361 (guts (expand-control-string control-string))
362 (args nil))
363 (dolist (arg *simple-args*)
364 (push `(,(car arg)
365 (error
366 'format-error
367 :complaint (intl:gettext "Required argument missing")
368 :control-string ,control-string
369 :offset ,(cdr arg)))
370 args))
371 (return `(lambda (stream &optional ,@args &rest args)
372 ,guts
373 args))))
374 (let ((*orig-args-available* t)
375 (*only-simple-args* nil))
376 `(lambda (stream &rest orig-args)
377 (let ((args orig-args))
378 ,(expand-control-string control-string)
379 args)))))
380
381 (defun expand-control-string (string)
382 (let* ((string (etypecase string
383 (simple-string
384 string)
385 (string
386 (coerce string 'simple-string))))
387 (*default-format-error-control-string* string)
388 (directives (tokenize-control-string string)))
389 `(block nil
390 ,@(expand-directive-list directives))))
391
392 (defun expand-directive-list (directives)
393 (let ((results nil)
394 (remaining-directives directives))
395 (loop
396 (unless remaining-directives
397 (return))
398 (multiple-value-bind
399 (form new-directives)
400 (expand-directive (car remaining-directives)
401 (cdr remaining-directives))
402 (push form results)
403 (setf remaining-directives new-directives)))
404 (reverse results)))
405
406 (defun expand-directive (directive more-directives)
407 (etypecase directive
408 (format-directive
409 (let ((expander
410 (aref *format-directive-expanders*
411 (char-code (format-directive-character directive))))
412 (*default-format-error-offset*
413 (1- (format-directive-end directive))))
414 (if expander
415 (funcall expander directive more-directives)
416 (error 'format-error
417 :complaint (intl:gettext "Unknown directive.")))))
418 (simple-string
419 (values `(write-string ,directive stream)
420 more-directives))))
421
422 (defun expand-next-arg (&optional offset)
423 (if (or *orig-args-available* (not *only-simple-args*))
424 `(,*expander-next-arg-macro*
425 ,*default-format-error-control-string*
426 ,(or offset *default-format-error-offset*))
427 (let ((symbol (gensym "FORMAT-ARG-")))
428 (push (cons symbol (or offset *default-format-error-offset*))
429 *simple-args*)
430 symbol)))
431
432 (defun need-hairy-args ()
433 (when *only-simple-args*
434 ))
435
436
437 ;;;; Format directive definition macros and runtime support.
438
439 (defmacro expander-next-arg (string offset)
440 `(if args
441 (pop args)
442 (error 'format-error
443 :complaint (intl:gettext "No more arguments.")
444 :control-string ,string
445 :offset ,offset)))
446
447 (defmacro expander-pprint-next-arg (string offset)
448 `(progn
449 (when (null args)
450 (error 'format-error
451 :complaint (intl:gettext "No more arguments.")
452 :control-string ,string
453 :offset ,offset))
454 (pprint-pop)
455 (pop args)))
456
457 (eval-when (:compile-toplevel :execute)
458
459 ;;; NEXT-ARG -- internal.
460 ;;;
461 ;;; This macro is used to extract the next argument from the current arg list.
462 ;;; This is the version used by format directive interpreters.
463 ;;;
464 (defmacro next-arg (&optional offset)
465 `(progn
466 (when (null args)
467 (error 'format-error
468 :complaint (intl:gettext "No more arguments.")
469 ,@(when offset
470 `(:offset ,offset))))
471 (when *logical-block-popper*
472 (funcall *logical-block-popper*))
473 (pop args)))
474
475 (defmacro def-complex-format-directive (char lambda-list &body body)
476 (let ((defun-name (intern (cl:format nil
477 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
478 char)))
479 (directive (gensym))
480 (directives (if lambda-list (car (last lambda-list)) (gensym))))
481 `(progn
482 (defun ,defun-name (,directive ,directives)
483 ,@(if lambda-list
484 `((let ,(mapcar #'(lambda (var)
485 `(,var
486 (,(intern (concatenate
487 'string
488 "FORMAT-DIRECTIVE-"
489 (symbol-name var))
490 (symbol-package 'foo))
491 ,directive)))
492 (butlast lambda-list))
493 ,@body))
494 `((declare (ignore ,directive ,directives))
495 ,@body)))
496 (%set-format-directive-expander ,char #',defun-name))))
497
498 (defmacro def-format-directive (char lambda-list &body body)
499 (let ((directives (gensym))
500 (declarations nil)
501 (body-without-decls body))
502 (loop
503 (let ((form (car body-without-decls)))
504 (unless (and (consp form) (eq (car form) 'declare))
505 (return))
506 (push (pop body-without-decls) declarations)))
507 (setf declarations (reverse declarations))
508 `(def-complex-format-directive ,char (,@lambda-list ,directives)
509 ,@declarations
510 (values (progn ,@body-without-decls)
511 ,directives))))
512
513 (defmacro expand-bind-defaults (specs params &body body)
514 (once-only ((params params))
515 (if specs
516 (collect ((expander-bindings) (runtime-bindings))
517 (dolist (spec specs)
518 (destructuring-bind (var default) spec
519 (let ((symbol (gensym)))
520 (expander-bindings
521 `(,var ',symbol))
522 (runtime-bindings
523 `(list ',symbol
524 (let* ((param-and-offset (pop ,params))
525 (offset (car param-and-offset))
526 (param (cdr param-and-offset)))
527 (case param
528 (:arg `(or ,(expand-next-arg offset)
529 ,,default))
530 (:remaining
531 (setf *only-simple-args* nil)
532 '(length args))
533 ((nil) ,default)
534 (t param))))))))
535 `(let ,(expander-bindings)
536 `(let ,(list ,@(runtime-bindings))
537 ,@(if ,params
538 (error 'format-error
539 :complaint
540 (intl:gettext "Too many parameters, expected no more than ~D")
541 :arguments (list ,(length specs))
542 :offset (caar ,params)))
543 ,,@body)))
544 `(progn
545 (when ,params
546 (error 'format-error
547 :complaint (intl:gettext "Too many parameters, expected no more than 0")
548 :offset (caar ,params)))
549 ,@body))))
550
551 (defmacro def-complex-format-interpreter (char lambda-list &body body)
552 (let ((defun-name
553 (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
554 char)))
555 (directive (gensym))
556 (directives (if lambda-list (car (last lambda-list)) (gensym))))
557 `(progn
558 (defun ,defun-name (stream ,directive ,directives orig-args args)
559 (declare (ignorable stream orig-args args))
560 ,@(if lambda-list
561 `((let ,(mapcar #'(lambda (var)
562 `(,var
563 (,(intern (concatenate
564 'string
565 "FORMAT-DIRECTIVE-"
566 (symbol-name var))
567 (symbol-package 'foo))
568 ,directive)))
569 (butlast lambda-list))
570 (values (progn ,@body) args)))
571 `((declare (ignore ,directive ,directives))
572 ,@body)))
573 (%set-format-directive-interpreter ,char #',defun-name))))
574
575 (defmacro def-format-interpreter (char lambda-list &body body)
576 (let ((directives (gensym)))
577 `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
578 ,@body
579 ,directives)))
580
581 (defmacro interpret-bind-defaults (specs params &body body)
582 (once-only ((params params))
583 (collect ((bindings))
584 (dolist (spec specs)
585 (destructuring-bind (var default) spec
586 (bindings `(,var (let* ((param-and-offset (pop ,params))
587 (offset (car param-and-offset))
588 (param (cdr param-and-offset)))
589 (case param
590 (:arg
591 ;; If the value of ~V is NIL, it's the
592 ;; same as if it weren't given at all.
593 ;; See CLHS 22.3.
594 (or (next-arg offset) ,default))
595 (:remaining (length args))
596 ((nil) ,default)
597 (t param)))))))
598 `(let* ,(bindings)
599 (when ,params
600 (error 'format-error
601 :complaint
602 (intl:gettext "Too many parameters, expected no more than ~D")
603 :arguments (list ,(length specs))
604 :offset (caar ,params)))
605 ,@body))))
606
607 ); eval-when
608
609 (defun %set-format-directive-expander (char fn)
610 (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
611 char)
612
613 (defun %set-format-directive-interpreter (char fn)
614 (setf (aref *format-directive-interpreters*
615 (char-code (char-upcase char)))
616 fn)
617 char)
618
619 (defun find-directive (directives kind stop-at-semi)
620 (if directives
621 (let ((next (car directives)))
622 (if (format-directive-p next)
623 (let ((char (format-directive-character next)))
624 (if (or (char= kind char)
625 (and stop-at-semi (char= char #\;)))
626 (car directives)
627 (find-directive
628 (cdr (flet ((after (char)
629 (member (find-directive (cdr directives)
630 char
631 nil)
632 directives)))
633 (case char
634 (#\( (after #\)))
635 (#\< (after #\>))
636 (#\[ (after #\]))
637 (#\{ (after #\}))
638 (t directives))))
639 kind stop-at-semi)))
640 (find-directive (cdr directives) kind stop-at-semi)))))
641
642
643 ;;;; Simple outputting noise.
644
645 (defun format-write-field (stream string mincol colinc minpad padchar padleft)
646 (unless padleft
647 (write-string string stream))
648 (dotimes (i minpad)
649 (write-char padchar stream))
650 (and mincol minpad colinc
651 (do ((chars (+ (length string) (max 0 minpad)) (+ chars colinc)))
652 ((>= chars mincol))
653 (dotimes (i colinc)
654 (write-char padchar stream))))
655 (when padleft
656 (write-string string stream)))
657
658 (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
659 (format-write-field stream
660 (if (or arg (not colonp))
661 (princ-to-string arg)
662 "()")
663 mincol colinc minpad padchar atsignp))
664
665 (def-format-directive #\A (colonp atsignp params)
666 (if params
667 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
668 (padchar #\space))
669 params
670 `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
671 ,mincol ,colinc ,minpad ,padchar))
672 `(princ ,(if colonp
673 `(or ,(expand-next-arg) "()")
674 (expand-next-arg))
675 stream)))
676
677 (def-format-interpreter #\A (colonp atsignp params)
678 (if params
679 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
680 (padchar #\space))
681 params
682 (format-princ stream (next-arg) colonp atsignp
683 mincol colinc minpad padchar))
684 (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
685
686 (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
687 (format-write-field stream
688 (if (or arg (not colonp))
689 (prin1-to-string arg)
690 "()")
691 mincol colinc minpad padchar atsignp))
692
693 (def-format-directive #\S (colonp atsignp params)
694 (cond (params
695 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
696 (padchar #\space))
697 params
698 `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
699 ,mincol ,colinc ,minpad ,padchar)))
700 (colonp
701 `(let ((arg ,(expand-next-arg)))
702 (if arg
703 (prin1 arg stream)
704 (princ "()" stream))))
705 (t
706 `(prin1 ,(expand-next-arg) stream))))
707
708 (def-format-interpreter #\S (colonp atsignp params)
709 (cond (params
710 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
711 (padchar #\space))
712 params
713 (format-prin1 stream (next-arg) colonp atsignp
714 mincol colinc minpad padchar)))
715 (colonp
716 (let ((arg (next-arg)))
717 (if arg
718 (prin1 arg stream)
719 (princ "()" stream))))
720 (t
721 (prin1 (next-arg) stream))))
722
723 (def-format-directive #\C (colonp atsignp params)
724 (expand-bind-defaults () params
725 (if colonp
726 `(format-print-named-character ,(expand-next-arg) stream)
727 (if atsignp
728 `(prin1 ,(expand-next-arg) stream)
729 `(write-char ,(expand-next-arg) stream)))))
730
731 (def-format-interpreter #\C (colonp atsignp params)
732 (interpret-bind-defaults () params
733 (if colonp
734 (format-print-named-character (next-arg) stream)
735 (if atsignp
736 (prin1 (next-arg) stream)
737 (write-char (next-arg) stream)))))
738
739 #-unicode
740 (defun format-print-named-character (char stream)
741 (let* ((name (char-name char)))
742 (cond (name
743 (write-string name stream))
744 ((<= 0 (char-code char) 31)
745 ;; Print control characters as "^"<char>
746 (write-char #\^ stream)
747 (write-char (code-char (+ 64 (char-code char))) stream))
748 (t
749 (write-char char stream)))))
750
751 #+unicode
752 (defun format-print-named-character (char stream)
753 (cond ((and (graphic-char-p char)
754 (char/= char #\space))
755 ;; Graphic characters (except space) print the same as ~C.
756 (write-char char stream))
757 (t
758 (let* ((name (char-name char)))
759 (write-string name stream)))))
760
761 (def-format-directive #\W (colonp atsignp params)
762 (expand-bind-defaults () params
763 (if (or colonp atsignp)
764 `(let (,@(when colonp
765 '((*print-pretty* t)))
766 ,@(when atsignp
767 '((*print-level* nil)
768 (*print-length* nil))))
769 (output-object ,(expand-next-arg) stream))
770 `(output-object ,(expand-next-arg) stream))))
771
772 (def-format-interpreter #\W (colonp atsignp params)
773 (interpret-bind-defaults () params
774 (let ((*print-pretty* (or colonp *print-pretty*))
775 (*print-level* (and atsignp *print-level*))
776 (*print-length* (and atsignp *print-length*)))
777 (output-object (next-arg) stream))))
778
779
780 ;;;; Integer outputting.
781
782 ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
783 ;;; directives. The parameters are interpreted as defined for ~D.
784 ;;;
785 (defun format-print-integer (stream number print-commas-p print-sign-p
786 radix mincol padchar commachar commainterval)
787 (let ((*print-base* radix)
788 (*print-radix* nil))
789 (if (integerp number)
790 (let* ((text (princ-to-string (abs number)))
791 (commaed (if print-commas-p
792 (format-add-commas text commachar commainterval)
793 text))
794 (signed (cond ((minusp number)
795 (concatenate 'string "-" commaed))
796 (print-sign-p
797 (concatenate 'string "+" commaed))
798 (t commaed))))
799 ;; colinc = 1, minpad = 0, padleft = t
800 (format-write-field stream signed mincol 1 0 padchar t))
801 (princ number stream))))
802
803 (defun format-add-commas (string commachar commainterval)
804 (let ((length (length string)))
805 (multiple-value-bind (commas extra)
806 (truncate (1- length) commainterval)
807 (let ((new-string (make-string (+ length commas)))
808 (first-comma (1+ extra)))
809 (replace new-string string :end1 first-comma :end2 first-comma)
810 (do ((src first-comma (+ src commainterval))
811 (dst first-comma (+ dst commainterval 1)))
812 ((= src length))
813 (setf (schar new-string dst) commachar)
814 (replace new-string string :start1 (1+ dst)
815 :start2 src :end2 (+ src commainterval)))
816 new-string))))
817
818 (defun expand-format-integer (base colonp atsignp params)
819 (if (or colonp atsignp params)
820 (expand-bind-defaults
821 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
822 params
823 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
824 ,base ,mincol ,padchar ,commachar
825 ,commainterval))
826 `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
827 :escape nil)))
828
829 (defmacro interpret-format-integer (base)
830 `(if (or colonp atsignp params)
831 (interpret-bind-defaults
832 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
833 params
834 (format-print-integer stream (next-arg) colonp atsignp ,base mincol
835 padchar commachar commainterval))
836 (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
837
838 (def-format-directive #\D (colonp atsignp params)
839 (expand-format-integer 10 colonp atsignp params))
840
841 (def-format-interpreter #\D (colonp atsignp params)
842 (interpret-format-integer 10))
843
844 (def-format-directive #\B (colonp atsignp params)
845 (expand-format-integer 2 colonp atsignp params))
846
847 (def-format-interpreter #\B (colonp atsignp params)
848 (interpret-format-integer 2))
849
850 (def-format-directive #\O (colonp atsignp params)
851 (expand-format-integer 8 colonp atsignp params))
852
853 (def-format-interpreter #\O (colonp atsignp params)
854 (interpret-format-integer 8))
855
856 (def-format-directive #\X (colonp atsignp params)
857 (expand-format-integer 16 colonp atsignp params))
858
859 (def-format-interpreter #\X (colonp atsignp params)
860 (interpret-format-integer 16))
861
862 (def-format-directive #\R (colonp atsignp params)
863 (if params
864 (expand-bind-defaults
865 ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
866 (commainterval 3))
867 params
868 (let ((r-arg (gensym "R-ARG-")))
869 `(let ((,r-arg ,(expand-next-arg)))
870 (if ,base
871 (format-print-integer stream ,r-arg ,colonp ,atsignp
872 ,base ,mincol
873 ,padchar ,commachar ,commainterval)
874 (format-print-cardinal stream ,r-arg)))))
875 (if atsignp
876 (if colonp
877 `(format-print-old-roman stream ,(expand-next-arg))
878 `(format-print-roman stream ,(expand-next-arg)))
879 (if colonp
880 `(format-print-ordinal stream ,(expand-next-arg))
881 `(format-print-cardinal stream ,(expand-next-arg))))))
882
883 (def-format-interpreter #\R (colonp atsignp params)
884 (if params
885 (interpret-bind-defaults
886 ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
887 (commainterval 3))
888 params
889 (if base
890 (format-print-integer stream (next-arg) colonp atsignp base mincol
891 padchar commachar commainterval)
892 (format-print-cardinal stream (next-arg))))
893 (if atsignp
894 (if colonp
895 (format-print-old-roman stream (next-arg))
896 (format-print-roman stream (next-arg)))
897 (if colonp
898 (format-print-ordinal stream (next-arg))
899 (format-print-cardinal stream (next-arg))))))
900
901
902 (defconstant cardinal-ones
903 #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
904
905 (defconstant cardinal-tens
906 #(nil nil "twenty" "thirty" "forty"
907 "fifty" "sixty" "seventy" "eighty" "ninety"))
908
909 (defconstant cardinal-teens
910 #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
911 "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
912
913 ;; See http://en.wikipedia.org/wiki/Names_of_large_numbers and also
914 ;; http://home.hetnet.nl/~vanadovv/BignumbyN.html. This list comes
915 ;; from the latter link.
916 ;;
917 ;; Leading spaces are required to get everything printed out
918 ;; correctly.
919 (defconstant cardinal-periods
920 #("" " thousand" " million" " billion" " trillion" " quadrillion"
921 " quintillion" " sextillion" " septillion" " octillion" " nonillion"
922 " decillion" " undecillion" " duodecillion" " tredecillion"
923 " quattuordecillion" " quinquadecillion" " sedecillion" " septendecillion"
924 " octodecillion" " novendecillion" " vigintillion" " unvigintillion"
925 " duovigintillion" " tresvigintillion" " quattuorvigintillion"
926 " quinquavigintillion" " sesvigintillion" " septemvigintillion"
927 " octovigintillion" " novemvigintillion" " trigintillion"
928 " untrigintillion" " duotrigintillion" " trestrigintillion"
929 " quattuortrigintillion" " quinquatrigintillion" " sestrigintillion"
930 " septentrigintillion" " octotrigintillion" " noventrigintillion"
931 " quadragintillion" " unquadragintillion" " duoquadragintillion"
932 " tresquadragintillion" " quattuorquadragintillion"
933 " quinquaquadragintillion" " sesquadragintillion" " septenquadragintillion"
934 " octoquadragintillion" " novenquadragintillion" " quinquagintillion"
935 " unquinquagintillion" " duoquinquagintillion" " tresquinquagintillion"
936 " quattuorquinquagintillion" " quinquaquinquagintillion"
937 " sesquinquagintillion" " septenquinquagintillion" " octoquinquagintillion"
938 " novenquinquagintillion" " sexagintillion" " unsexagintillion"
939 " duosexagintillion" " tresexagintillion" " quattuorsexagintillion"
940 " quinquasexagintillion" " sesexagintillion" " septensexagintillion"
941 " octosexagintillion" " novensexagintillion" " septuagintillion"
942 " unseptuagintillion" " duoseptuagintillion" " treseptuagintillion"
943 " quattuorseptuagintillion" " quinquaseptuagintillion"
944 " seseptuagintillion" " septenseptuagintillion" " octoseptuagintillion"
945 " novenseptuagintillion" " octogintillion" " unoctogintillion"
946 " duooctogintillion" " tresoctogintillion" " quattuoroctogintillion"
947 " quinquaoctogintillion" " sexoctogintillion" " septemoctogintillion"
948 " octooctogintillion" " novemoctogintillion" " nonagintillion"
949 " unnonagintillion" " duononagintillion" " trenonagintillion"
950 " quattuornonagintillion" " quinquanonagintillion" " senonagintillion"
951 " septenonagintillion" " octononagintillion" " novenonagintillion"
952 " centillion" " uncentillion" " duocentillion" " trescentillion"
953 " quattuorcentillion" " quinquacentillion" " sexcentillion"
954 " septencentillion" " octocentillion" " novencentillion" " decicentillion"
955 " undecicentillion" " duodecicentillion" " tredecicentillion"
956 " quattuordecicentillion" " quinquadecicentillion" " sedecicentillion"
957 " septendecicentillion" " octodecicentillion" " novendecicentillion"
958 " viginticentillion" " unviginticentillion" " duoviginticentillion"
959 " tresviginticentillion" " quattuorviginticentillion"
960 " quinquaviginticentillion" " sesviginticentillion"
961 " septemviginticentillion" " octoviginticentillion"
962 " novemviginticentillion" " trigintacentillion" " untrigintacentillion"
963 " duotrigintacentillion" " trestrigintacentillion"
964 " quattuortrigintacentillion" " quinquatrigintacentillion"
965 " sestrigintacentillion" " septentrigintacentillion"
966 " octotrigintacentillion" " noventrigintacentillion"
967 " quadragintacentillion" " unquadragintacentillion"
968 " duoquadragintacentillion" " tresquadragintacentillion"
969 " quattuorquadragintacentillion" " quinquaquadragintacentillion"
970 " sesquadragintacentillion" " septenquadragintacentillion"
971 " octoquadragintacentillion" " novenquadragintacentillion"
972 " quinquagintacentillion" " unquinquagintacentillion"
973 " duoquinquagintacentillion" " tresquinquagintacentillion"
974 " quattuorquinquagintacentillion" " quinquaquinquagintacentillion"
975 " sesquinquagintacentillion" " septenquinquagintacentillion"
976 " octoquinquagintacentillion" " novenquinquagintacentillion"
977 " sexagintacentillion" " unsexagintacentillion" " duosexagintacentillion"
978 " tresexagintacentillion" " quattuorsexagintacentillion"
979 " quinquasexagintacentillion" " sesexagintacentillion"
980 " septensexagintacentillion" " octosexagintacentillion"
981 " novensexagintacentillion" " septuagintacentillion"
982 " unseptuagintacentillion" " duoseptuagintacentillion"
983 " treseptuagintacentillion" " quattuorseptuagintacentillion"
984 " quinquaseptuagintacentillion" " seseptuagintacentillion"
985 " septenseptuagintacentillion" " octoseptuagintacentillion"
986 " novenseptuagintacentillion" " octogintacentillion"
987 " unoctogintacentillion" " duooctogintacentillion"
988 " tresoctogintacentillion" " quattuoroctogintacentillion"
989 " quinquaoctogintacentillion" " sexoctogintacentillion"
990 " septemoctogintacentillion" " octooctogintacentillion"
991 " novemoctogintacentillion" " nonagintacentillion" " unnonagintacentillion"
992 " duononagintacentillion" " trenonagintacentillion"
993 " quattuornonagintacentillion" " quinquanonagintacentillion"
994 " senonagintacentillion" " septenonagintacentillion"
995 " octononagintacentillion" " novenonagintacentillion" " ducentillion"
996 " unducentillion" " duoducentillion" " treducentillion"
997 " quattuorducentillion" " quinquaducentillion" " seducentillion"
998 " septenducentillion" " octoducentillion" " novenducentillion"
999 " deciducentillion" " undeciducentillion" " duodeciducentillion"
1000 " tredeciducentillion" " quattuordeciducentillion"
1001 " quinquadeciducentillion" " sedeciducentillion" " septendeciducentillion"
1002 " octodeciducentillion" " novendeciducentillion" " vigintiducentillion"
1003 " unvigintiducentillion" " duovigintiducentillion"
1004 " tresvigintiducentillion" " quattuorvigintiducentillion"
1005 " quinquavigintiducentillion" " sesvigintiducentillion"
1006 " septemvigintiducentillion" " octovigintiducentillion"
1007 " novemvigintiducentillion" " trigintaducentillion"
1008 " untrigintaducentillion" " duotrigintaducentillion"
1009 " trestrigintaducentillion" " quattuortrigintaducentillion"
1010 " quinquatrigintaducentillion" " sestrigintaducentillion"
1011 " septentrigintaducentillion" " octotrigintaducentillion"
1012 " noventrigintaducentillion" " quadragintaducentillion"
1013 " unquadragintaducentillion" " duoquadragintaducentillion"
1014 " tresquadragintaducentillion" " quattuorquadragintaducentillion"
1015 " quinquaquadragintaducentillion" " sesquadragintaducentillion"
1016 " septenquadragintaducentillion" " octoquadragintaducentillion"
1017 " novenquadragintaducentillion" " quinquagintaducentillion"
1018 " unquinquagintaducentillion" " duoquinquagintaducentillion"
1019 " tresquinquagintaducentillion" " quattuorquinquagintaducentillion"
1020 " quinquaquinquagintaducentillion" " sesquinquagintaducentillion"
1021 " septenquinquagintaducentillion" " octoquinquagintaducentillion"
1022 " novenquinquagintaducentillion" " sexagintaducentillion"
1023 " unsexagintaducentillion" " duosexagintaducentillion"
1024 " tresexagintaducentillion" " quattuorsexagintaducentillion"
1025 " quinquasexagintaducentillion" " sesexagintaducentillion"
1026 " septensexagintaducentillion" " octosexagintaducentillion"
1027 " novensexagintaducentillion" " septuagintaducentillion"
1028 " unseptuagintaducentillion" " duoseptuagintaducentillion"
1029 " treseptuagintaducentillion" " quattuorseptuagintaducentillion"
1030 " quinquaseptuagintaducentillion" " seseptuagintaducentillion"
1031 " septenseptuagintaducentillion" " octoseptuagintaducentillion"
1032 " novenseptuagintaducentillion" " octogintaducentillion"
1033 " unoctogintaducentillion" " duooctogintaducentillion"
1034 " tresoctogintaducentillion" " quattuoroctogintaducentillion"
1035 " quinquaoctogintaducentillion" " sexoctogintaducentillion"
1036 " septemoctogintaducentillion" " octooctogintaducentillion"
1037 " novemoctogintaducentillion" " nonagintaducentillion"
1038 " unnonagintaducentillion" " duononagintaducentillion"
1039 " trenonagintaducentillion" " quattuornonagintaducentillion"
1040 " quinquanonagintaducentillion" " senonagintaducentillion"
1041 " septenonagintaducentillion" " octononagintaducentillion"
1042 " novenonagintaducentillion" " trecentillion" " untrecentillion"
1043 " duotrecentillion" " trestrecentillion" " quattuortrecentillion"
1044 " quinquatrecentillion" " sestrecentillion" " septentrecentillion"
1045 " octotrecentillion" " noventrecentillion" " decitrecentillion"
1046 " undecitrecentillion" " duodecitrecentillion" " tredecitrecentillion"
1047 " quattuordecitrecentillion" " quinquadecitrecentillion"
1048 " sedecitrecentillion" " septendecitrecentillion" " octodecitrecentillion"
1049 " novendecitrecentillion" " vigintitrecentillion" " unvigintitrecentillion"
1050 " duovigintitrecentillion" " tresvigintitrecentillion"
1051 " quattuorvigintitrecentillion" " quinquavigintitrecentillion"
1052 " sesvigintitrecentillion" " septemvigintitrecentillion"
1053 " octovigintitrecentillion" " novemvigintitrecentillion"
1054 " trigintatrecentillion" " untrigintatrecentillion"
1055 " duotrigintatrecentillion" " trestrigintatrecentillion"
1056 " quattuortrigintatrecentillion" " quinquatrigintatrecentillion"
1057 " sestrigintatrecentillion" " septentrigintatrecentillion"
1058 " octotrigintatrecentillion" " noventrigintatrecentillion"
1059 " quadragintatrecentillion" " unquadragintatrecentillion"
1060 " duoquadragintatrecentillion" " tresquadragintatrecentillion"
1061 " quattuorquadragintatrecentillion" " quinquaquadragintatrecentillion"
1062 " sesquadragintatrecentillion" " septenquadragintatrecentillion"
1063 " octoquadragintatrecentillion" " novenquadragintatrecentillion"
1064 " quinquagintatrecentillion" " unquinquagintatrecentillion"
1065 " duoquinquagintatrecentillion" " tresquinquagintatrecentillion"
1066 " quattuorquinquagintatrecentillion" " quinquaquinquagintatrecentillion"
1067 " sesquinquagintatrecentillion" " septenquinquagintatrecentillion"
1068 " octoquinquagintatrecentillion" " novenquinquagintatrecentillion"
1069 " sexagintatrecentillion" " unsexagintatrecentillion"
1070 " duosexagintatrecentillion" " tresexagintatrecentillion"
1071 " quattuorsexagintatrecentillion" " quinquasexagintatrecentillion"
1072 " sesexagintatrecentillion" " septensexagintatrecentillion"
1073 " octosexagintatrecentillion" " novensexagintatrecentillion"
1074 " septuagintatrecentillion" " unseptuagintatrecentillion"
1075 " duoseptuagintatrecentillion" " treseptuagintatrecentillion"
1076 " quattuorseptuagintatrecentillion" " quinquaseptuagintatrecentillion"
1077 " seseptuagintatrecentillion" " septenseptuagintatrecentillion"
1078 " octoseptuagintatrecentillion" " novenseptuagintatrecentillion"
1079 " octogintatrecentillion" " unoctogintatrecentillion"
1080 " duooctogintatrecentillion" " tresoctogintatrecentillion"
1081 " quattuoroctogintatrecentillion" " quinquaoctogintatrecentillion"
1082 " sexoctogintatrecentillion" " septemoctogintatrecentillion"
1083 " octooctogintatrecentillion" " novemoctogintatrecentillion"
1084 " nonagintatrecentillion" " unnonagintatrecentillion"
1085 " duononagintatrecentillion" " trenonagintatrecentillion"
1086 " quattuornonagintatrecentillion" " quinquanonagintatrecentillion"
1087 " senonagintatrecentillion" " septenonagintatrecentillion"
1088 " octononagintatrecentillion" " novenonagintatrecentillion"
1089 " quadringentillion" " unquadringentillion" " duoquadringentillion"
1090 " tresquadringentillion" " quattuorquadringentillion"
1091 " quinquaquadringentillion" " sesquadringentillion"
1092 " septenquadringentillion" " octoquadringentillion"
1093 " novenquadringentillion" " deciquadringentillion"
1094 " undeciquadringentillion" " duodeciquadringentillion"
1095 " tredeciquadringentillion" " quattuordeciquadringentillion"
1096 " quinquadeciquadringentillion" " sedeciquadringentillion"
1097 " septendeciquadringentillion" " octodeciquadringentillion"
1098 " novendeciquadringentillion" " vigintiquadringentillion"
1099 " unvigintiquadringentillion" " duovigintiquadringentillion"
1100 " tresvigintiquadringentillion" " quattuorvigintiquadringentillion"
1101 " quinquavigintiquadringentillion" " sesvigintiquadringentillion"
1102 " septemvigintiquadringentillion" " octovigintiquadringentillion"
1103 " novemvigintiquadringentillion" " trigintaquadringentillion"
1104 " untrigintaquadringentillion" " duotrigintaquadringentillion"
1105 " trestrigintaquadringentillion" " quattuortrigintaquadringentillion"
1106 " quinquatrigintaquadringentillion" " sestrigintaquadringentillion"
1107 " septentrigintaquadringentillion" " octotrigintaquadringentillion"
1108 " noventrigintaquadringentillion" " quadragintaquadringentillion"
1109 " unquadragintaquadringentillion" " duoquadragintaquadringentillion"
1110 " tresquadragintaquadringentillion" " quattuorquadragintaquadringentillion"
1111 " quinquaquadragintaquadringentillion" " sesquadragintaquadringentillion"
1112 " septenquadragintaquadringentillion" " octoquadragintaquadringentillion"
1113 " novenquadragintaquadringentillion" " quinquagintaquadringentillion"
1114 " unquinquagintaquadringentillion" " duoquinquagintaquadringentillion"
1115 " tresquinquagintaquadringentillion"
1116 " quattuorquinquagintaquadringentillion"
1117 " quinquaquinquagintaquadringentillion" " sesquinquagintaquadringentillion"
1118 " septenquinquagintaquadringentillion" " octoquinquagintaquadringentillion"
1119 " novenquinquagintaquadringentillion" " sexagintaquadringentillion"
1120 " unsexagintaquadringentillion" " duosexagintaquadringentillion"
1121 " tresexagintaquadringentillion" " quattuorsexagintaquadringentillion"
1122 " quinquasexagintaquadringentillion" " sesexagintaquadringentillion"
1123 " septensexagintaquadringentillion" " octosexagintaquadringentillion"
1124 " novensexagintaquadringentillion" " septuagintaquadringentillion"
1125 " unseptuagintaquadringentillion" " duoseptuagintaquadringentillion"
1126 " treseptuagintaquadringentillion" " quattuorseptuagintaquadringentillion"
1127 " quinquaseptuagintaquadringentillion" " seseptuagintaquadringentillion"
1128 " septenseptuagintaquadringentillion" " octoseptuagintaquadringentillion"
1129 " novenseptuagintaquadringentillion" " octogintaquadringentillion"
1130 " unoctogintaquadringentillion" " duooctogintaquadringentillion"
1131 " tresoctogintaquadringentillion" " quattuoroctogintaquadringentillion"
1132 " quinquaoctogintaquadringentillion" " sexoctogintaquadringentillion"
1133 " septemoctogintaquadringentillion" " octooctogintaquadringentillion"
1134 " novemoctogintaquadringentillion" " nonagintaquadringentillion"
1135 " unnonagintaquadringentillion" " duononagintaquadringentillion"
1136 " trenonagintaquadringentillion" " quattuornonagintaquadringentillion"
1137 " quinquanonagintaquadringentillion" " senonagintaquadringentillion"
1138 " septenonagintaquadringentillion" " octononagintaquadringentillion"
1139 " novenonagintaquadringentillion" " quingentillion" " unquingentillion"
1140 " duoquingentillion" " tresquingentillion" " quattuorquingentillion"
1141 " quinquaquingentillion" " sesquingentillion" " septenquingentillion"
1142 " octoquingentillion" " novenquingentillion" " deciquingentillion"
1143 " undeciquingentillion" " duodeciquingentillion" " tredeciquingentillion"
1144 " quattuordeciquingentillion" " quinquadeciquingentillion"
1145 " sedeciquingentillion" " septendeciquingentillion"
1146 " octodeciquingentillion" " novendeciquingentillion"
1147 " vigintiquingentillion" " unvigintiquingentillion"
1148 " duovigintiquingentillion" " tresvigintiquingentillion"
1149 " quattuorvigintiquingentillion" " quinquavigintiquingentillion"
1150 " sesvigintiquingentillion" " septemvigintiquingentillion"
1151 " octovigintiquingentillion" " novemvigintiquingentillion"
1152 " trigintaquingentillion" " untrigintaquingentillion"
1153 " duotrigintaquingentillion" " trestrigintaquingentillion"
1154 " quattuortrigintaquingentillion" " quinquatrigintaquingentillion"
1155 " sestrigintaquingentillion" " septentrigintaquingentillion"
1156 " octotrigintaquingentillion" " noventrigintaquingentillion"
1157 " quadragintaquingentillion" " unquadragintaquingentillion"
1158 " duoquadragintaquingentillion" " tresquadragintaquingentillion"
1159 " quattuorquadragintaquingentillion" " quinquaquadragintaquingentillion"
1160 " sesquadragintaquingentillion" " septenquadragintaquingentillion"
1161 " octoquadragintaquingentillion" " novenquadragintaquingentillion"
1162 " quinquagintaquingentillion" " unquinquagintaquingentillion"
1163 " duoquinquagintaquingentillion" " tresquinquagintaquingentillion"
1164 " quattuorquinquagintaquingentillion" " quinquaquinquagintaquingentillion"
1165 " sesquinquagintaquingentillion" " septenquinquagintaquingentillion"
1166 " octoquinquagintaquingentillion" " novenquinquagintaquingentillion"
1167 " sexagintaquingentillion" " unsexagintaquingentillion"
1168 " duosexagintaquingentillion" " tresexagintaquingentillion"
1169 " quattuorsexagintaquingentillion" " quinquasexagintaquingentillion"
1170 " sesexagintaquingentillion" " septensexagintaquingentillion"
1171 " octosexagintaquingentillion" " novensexagintaquingentillion"
1172 " septuagintaquingentillion" " unseptuagintaquingentillion"
1173 " duoseptuagintaquingentillion" " treseptuagintaquingentillion"
1174 " quattuorseptuagintaquingentillion" " quinquaseptuagintaquingentillion"
1175 " seseptuagintaquingentillion" " septenseptuagintaquingentillion"
1176 " octoseptuagintaquingentillion" " novenseptuagintaquingentillion"
1177 " octogintaquingentillion" " unoctogintaquingentillion"
1178 " duooctogintaquingentillion" " tresoctogintaquingentillion"
1179 " quattuoroctogintaquingentillion" " quinquaoctogintaquingentillion"
1180 " sexoctogintaquingentillion" " septemoctogintaquingentillion"
1181 " octooctogintaquingentillion" " novemoctogintaquingentillion"
1182 " nonagintaquingentillion" " unnonagintaquingentillion"
1183 " duononagintaquingentillion" " trenonagintaquingentillion"
1184 " quattuornonagintaquingentillion" " quinquanonagintaquingentillion"
1185 " senonagintaquingentillion" " septenonagintaquingentillion"
1186 " octononagintaquingentillion" " novenonagintaquingentillion"
1187 " sescentillion" " unsescentillion" " duosescentillion" " tresescentillion"
1188 " quattuorsescentillion" " quinquasescentillion" " sesescentillion"
1189 " septensescentillion" " octosescentillion" " novensescentillion"
1190 " decisescentillion" " undecisescentillion" " duodecisescentillion"
1191 " tredecisescentillion" " quattuordecisescentillion"
1192 " quinquadecisescentillion" " sedecisescentillion"
1193 " septendecisescentillion" " octodecisescentillion"
1194 " novendecisescentillion" " vigintisescentillion" " unvigintisescentillion"
1195 " duovigintisescentillion" " tresvigintisescentillion"
1196 " quattuorvigintisescentillion" " quinquavigintisescentillion"
1197 " sesvigintisescentillion" " septemvigintisescentillion"
1198 " octovigintisescentillion" " novemvigintisescentillion"
1199 " trigintasescentillion" " untrigintasescentillion"
1200 " duotrigintasescentillion" " trestrigintasescentillion"
1201 " quattuortrigintasescentillion" " quinquatrigintasescentillion"
1202 " sestrigintasescentillion" " septentrigintasescentillion"
1203 " octotrigintasescentillion" " noventrigintasescentillion"
1204 " quadragintasescentillion" " unquadragintasescentillion"
1205 " duoquadragintasescentillion" " tresquadragintasescentillion"
1206 " quattuorquadragintasescentillion" " quinquaquadragintasescentillion"
1207 " sesquadragintasescentillion" " septenquadragintasescentillion"
1208 " octoquadragintasescentillion" " novenquadragintasescentillion"
1209 " quinquagintasescentillion" " unquinquagintasescentillion"
1210 " duoquinquagintasescentillion" " tresquinquagintasescentillion"
1211 " quattuorquinquagintasescentillion" " quinquaquinquagintasescentillion"
1212 " sesquinquagintasescentillion" " septenquinquagintasescentillion"
1213 " octoquinquagintasescentillion" " novenquinquagintasescentillion"
1214 " sexagintasescentillion" " unsexagintasescentillion"
1215 " duosexagintasescentillion" " tresexagintasescentillion"
1216 " quattuorsexagintasescentillion" " quinquasexagintasescentillion"
1217 " sesexagintasescentillion" " septensexagintasescentillion"
1218 " octosexagintasescentillion" " novensexagintasescentillion"
1219 " septuagintasescentillion" " unseptuagintasescentillion"
1220 " duoseptuagintasescentillion" " treseptuagintasescentillion"
1221 " quattuorseptuagintasescentillion" " quinquaseptuagintasescentillion"
1222 " seseptuagintasescentillion" " septenseptuagintasescentillion"
1223 " octoseptuagintasescentillion" " novenseptuagintasescentillion"
1224 " octogintasescentillion" " unoctogintasescentillion"
1225 " duooctogintasescentillion" " tresoctogintasescentillion"
1226 " quattuoroctogintasescentillion" " quinquaoctogintasescentillion"
1227 " sexoctogintasescentillion" " septemoctogintasescentillion"
1228 " octooctogintasescentillion" " novemoctogintasescentillion"
1229 " nonagintasescentillion" " unnonagintasescentillion"
1230 " duononagintasescentillion" " trenonagintasescentillion"
1231 " quattuornonagintasescentillion" " quinquanonagintasescentillion"
1232 " senonagintasescentillion" " septenonagintasescentillion"
1233 " octononagintasescentillion" " novenonagintasescentillion"
1234 " septingentillion" " unseptingentillion" " duoseptingentillion"
1235 " treseptingentillion" " quattuorseptingentillion"
1236 " quinquaseptingentillion" " seseptingentillion" " septenseptingentillion"
1237 " octoseptingentillion" " novenseptingentillion" " deciseptingentillion"
1238 " undeciseptingentillion" " duodeciseptingentillion"
1239 " tredeciseptingentillion" " quattuordeciseptingentillion"
1240 " quinquadeciseptingentillion" " sedeciseptingentillion"
1241 " septendeciseptingentillion" " octodeciseptingentillion"
1242 " novendeciseptingentillion" " vigintiseptingentillion"
1243 " unvigintiseptingentillion" " duovigintiseptingentillion"
1244 " tresvigintiseptingentillion" " quattuorvigintiseptingentillion"
1245 " quinquavigintiseptingentillion" " sesvigintiseptingentillion"
1246 " septemvigintiseptingentillion" " octovigintiseptingentillion"
1247 " novemvigintiseptingentillion" " trigintaseptingentillion"
1248 " untrigintaseptingentillion" " duotrigintaseptingentillion"
1249 " trestrigintaseptingentillion" " quattuortrigintaseptingentillion"
1250 " quinquatrigintaseptingentillion" " sestrigintaseptingentillion"
1251 " septentrigintaseptingentillion" " octotrigintaseptingentillion"
1252 " noventrigintaseptingentillion" " quadragintaseptingentillion"
1253 " unquadragintaseptingentillion" " duoquadragintaseptingentillion"
1254 " tresquadragintaseptingentillion" " quattuorquadragintaseptingentillion"
1255 " quinquaquadragintaseptingentillion" " sesquadragintaseptingentillion"
1256 " septenquadragintaseptingentillion" " octoquadragintaseptingentillion"
1257 " novenquadragintaseptingentillion" " quinquagintaseptingentillion"
1258 " unquinquagintaseptingentillion" " duoquinquagintaseptingentillion"
1259 " tresquinquagintaseptingentillion" " quattuorquinquagintaseptingentillion"
1260 " quinquaquinquagintaseptingentillion" " sesquinquagintaseptingentillion"
1261 " septenquinquagintaseptingentillion" " octoquinquagintaseptingentillion"
1262 " novenquinquagintaseptingentillion" " sexagintaseptingentillion"
1263 " unsexagintaseptingentillion" " duosexagintaseptingentillion"
1264 " tresexagintaseptingentillion" " quattuorsexagintaseptingentillion"
1265 " quinquasexagintaseptingentillion" " sesexagintaseptingentillion"
1266 " septensexagintaseptingentillion" " octosexagintaseptingentillion"
1267 " novensexagintaseptingentillion" " septuagintaseptingentillion"
1268 " unseptuagintaseptingentillion" " duoseptuagintaseptingentillion"
1269 " treseptuagintaseptingentillion" " quattuorseptuagintaseptingentillion"
1270 " quinquaseptuagintaseptingentillion" " seseptuagintaseptingentillion"
1271 " septenseptuagintaseptingentillion" " octoseptuagintaseptingentillion"
1272 " novenseptuagintaseptingentillion" " octogintaseptingentillion"
1273 " unoctogintaseptingentillion" " duooctogintaseptingentillion"
1274 " tresoctogintaseptingentillion" " quattuoroctogintaseptingentillion"
1275 " quinquaoctogintaseptingentillion" " sexoctogintaseptingentillion"
1276 " septemoctogintaseptingentillion" " octooctogintaseptingentillion"
1277 " novemoctogintaseptingentillion" " nonagintaseptingentillion"
1278 " unnonagintaseptingentillion" " duononagintaseptingentillion"
1279 " trenonagintaseptingentillion" " quattuornonagintaseptingentillion"
1280 " quinquanonagintaseptingentillion" " senonagintaseptingentillion"
1281 " septenonagintaseptingentillion" " octononagintaseptingentillion"
1282 " novenonagintaseptingentillion" " octingentillion" " unoctingentillion"
1283 " duooctingentillion" " tresoctingentillion" " quattuoroctingentillion"
1284 " quinquaoctingentillion" " sexoctingentillion" " septemoctingentillion"
1285 " octooctingentillion" " novemoctingentillion" " decioctingentillion"
1286 " undecioctingentillion" " duodecioctingentillion"
1287 " tredecioctingentillion" " quattuordecioctingentillion"
1288 " quinquadecioctingentillion" " sedecioctingentillion"
1289 " septendecioctingentillion" " octodecioctingentillion"
1290 " novendecioctingentillion" " vigintioctingentillion"
1291 " unvigintioctingentillion" " duovigintioctingentillion"
1292 " tresvigintioctingentillion" " quattuorvigintioctingentillion"
1293 " quinquavigintioctingentillion" " sesvigintioctingentillion"
1294 " septemvigintioctingentillion" " octovigintioctingentillion"
1295 " novemvigintioctingentillion" " trigintaoctingentillion"
1296 " untrigintaoctingentillion" " duotrigintaoctingentillion"
1297 " trestrigintaoctingentillion" " quattuortrigintaoctingentillion"
1298 " quinquatrigintaoctingentillion" " sestrigintaoctingentillion"
1299 " septentrigintaoctingentillion" " octotrigintaoctingentillion"
1300 " noventrigintaoctingentillion" " quadragintaoctingentillion"
1301 " unquadragintaoctingentillion" " duoquadragintaoctingentillion"
1302 " tresquadragintaoctingentillion" " quattuorquadragintaoctingentillion"
1303 " quinquaquadragintaoctingentillion" " sesquadragintaoctingentillion"
1304 " septenquadragintaoctingentillion" " octoquadragintaoctingentillion"
1305 " novenquadragintaoctingentillion" " quinquagintaoctingentillion"
1306 " unquinquagintaoctingentillion" " duoquinquagintaoctingentillion"
1307 " tresquinquagintaoctingentillion" " quattuorquinquagintaoctingentillion"
1308 " quinquaquinquagintaoctingentillion" " sesquinquagintaoctingentillion"
1309 " septenquinquagintaoctingentillion" " octoquinquagintaoctingentillion"
1310 " novenquinquagintaoctingentillion" " sexagintaoctingentillion"
1311 " unsexagintaoctingentillion" " duosexagintaoctingentillion"
1312 " tresexagintaoctingentillion" " quattuorsexagintaoctingentillion"
1313 " quinquasexagintaoctingentillion" " sesexagintaoctingentillion"
1314 " septensexagintaoctingentillion" " octosexagintaoctingentillion"
1315 " novensexagintaoctingentillion" " septuagintaoctingentillion"
1316 " unseptuagintaoctingentillion" " duoseptuagintaoctingentillion"
1317 " treseptuagintaoctingentillion" " quattuorseptuagintaoctingentillion"
1318 " quinquaseptuagintaoctingentillion" " seseptuagintaoctingentillion"
1319 " septenseptuagintaoctingentillion" " octoseptuagintaoctingentillion"
1320 " novenseptuagintaoctingentillion" " octogintaoctingentillion"
1321 " unoctogintaoctingentillion" " duooctogintaoctingentillion"
1322 " tresoctogintaoctingentillion" " quattuoroctogintaoctingentillion"
1323 " quinquaoctogintaoctingentillion" " sexoctogintaoctingentillion"
1324 " septemoctogintaoctingentillion" " octooctogintaoctingentillion"
1325 " novemoctogintaoctingentillion" " nonagintaoctingentillion"
1326 " unnonagintaoctingentillion" " duononagintaoctingentillion"
1327 " trenonagintaoctingentillion" " quattuornonagintaoctingentillion"
1328 " quinquanonagintaoctingentillion" " senonagintaoctingentillion"
1329 " septenonagintaoctingentillion" " octononagintaoctingentillion"
1330 " novenonagintaoctingentillion" " nongentillion" " unnongentillion"
1331 " duonongentillion" " trenongentillion" " quattuornongentillion"
1332 " quinquanongentillion" " senongentillion" " septenongentillion"
1333 " octonongentillion" " novenongentillion" " decinongentillion"
1334 " undecinongentillion" " duodecinongentillion" " tredecinongentillion"
1335 " quattuordecinongentillion" " quinquadecinongentillion"
1336 " sedecinongentillion" " septendecinongentillion" " octodecinongentillion"
1337 " novendecinongentillion" " vigintinongentillion" " unvigintinongentillion"
1338 " duovigintinongentillion" " tresvigintinongentillion"
1339 " quattuorvigintinongentillion" " quinquavigintinongentillion"
1340 " sesvigintinongentillion" " septemvigintinongentillion"
1341 " octovigintinongentillion" " novemvigintinongentillion"
1342 " trigintanongentillion" " untrigintanongentillion"
1343 " duotrigintanongentillion" " trestrigintanongentillion"
1344 " quattuortrigintanongentillion" " quinquatrigintanongentillion"
1345 " sestrigintanongentillion" " septentrigintanongentillion"
1346 " octotrigintanongentillion" " noventrigintanongentillion"
1347 " quadragintanongentillion" " unquadragintanongentillion"
1348 " duoquadragintanongentillion" " tresquadragintanongentillion"
1349 " quattuorquadragintanongentillion" " quinquaquadragintanongentillion"
1350 " sesquadragintanongentillion" " septenquadragintanongentillion"
1351 " octoquadragintanongentillion" " novenquadragintanongentillion"
1352 " quinquagintanongentillion" " unquinquagintanongentillion"
1353 " duoquinquagintanongentillion" " tresquinquagintanongentillion"
1354 " quattuorquinquagintanongentillion" " quinquaquinquagintanongentillion"
1355 " sesquinquagintanongentillion" " septenquinquagintanongentillion"
1356 " octoquinquagintanongentillion" " novenquinquagintanongentillion"
1357 " sexagintanongentillion" " unsexagintanongentillion"
1358 " duosexagintanongentillion" " tresexagintanongentillion"
1359 " quattuorsexagintanongentillion" " quinquasexagintanongentillion"
1360 " sesexagintanongentillion" " septensexagintanongentillion"
1361 " octosexagintanongentillion" " novensexagintanongentillion"
1362 " septuagintanongentillion" " unseptuagintanongentillion"
1363 " duoseptuagintanongentillion" " treseptuagintanongentillion"
1364 " quattuorseptuagintanongentillion" " quinquaseptuagintanongentillion"
1365 " seseptuagintanongentillion" " septenseptuagintanongentillion"
1366 " octoseptuagintanongentillion" " novenseptuagintanongentillion"
1367 " octogintanongentillion" " unoctogintanongentillion"
1368 " duooctogintanongentillion" " tresoctogintanongentillion"
1369 " quattuoroctogintanongentillion" " quinquaoctogintanongentillion"
1370 " sexoctogintanongentillion" " septemoctogintanongentillion"
1371 " octooctogintanongentillion" " novemoctogintanongentillion"
1372 " nonagintanongentillion" " unnonagintanongentillion"
1373 " duononagintanongentillion" " trenonagintanongentillion"
1374 " quattuornonagintanongentillion" " quinquanonagintanongentillion"
1375 " senonagintanongentillion" " septenonagintanongentillion"
1376 " octononagintanongentillion" " novenonagintanongentillion"))
1377
1378 (defconstant ordinal-ones
1379 #(nil "first" "second" "third" "fourth"
1380 "fifth" "sixth" "seventh" "eighth" "ninth")
1381 "Table of ordinal ones-place digits in English")
1382
1383 (defconstant ordinal-tens
1384 #(nil "tenth" "twentieth" "thirtieth" "fortieth"
1385 "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
1386 "Table of ordinal tens-place digits in English")
1387
1388 (defun format-print-small-cardinal (stream n)
1389 (multiple-value-bind
1390 (hundreds rem) (truncate n 100)
1391 (when (plusp hundreds)
1392 (write-string (svref cardinal-ones hundreds) stream)
1393 (write-string " hundred" stream)
1394 (when (plusp rem)
1395 (write-char #\space stream)))
1396 (when (plusp rem)
1397 (multiple-value-bind (tens ones)
1398 (truncate rem 10)
1399 (cond ((< 1 tens)
1400 (write-string (svref cardinal-tens tens) stream)
1401 (when (plusp ones)
1402 (write-char #\- stream)
1403 (write-string (svref cardinal-ones ones) stream)))
1404 ((= tens 1)
1405 (write-string (svref cardinal-teens ones) stream))
1406 ((plusp ones)
1407 (write-string (svref cardinal-ones ones) stream)))))))
1408
1409 (defun format-print-cardinal (stream n)
1410 (cond ((minusp n)
1411 (write-string "negative " stream)
1412 (format-print-cardinal-aux stream (- n) 0 n))
1413 ((zerop n)
1414 (write-string "zero" stream))
1415 (t
1416 (format-print-cardinal-aux stream n 0 n))))
1417
1418 (defun format-print-cardinal-aux (stream n period err)
1419 (multiple-value-bind (beyond here) (truncate n 1000)
1420 (unless (< period (length cardinal-periods))
1421 (error "Number too large to print in English: ~:D" err))
1422 (unless (zerop beyond)
1423 (format-print-cardinal-aux stream beyond (1+ period) err))
1424 (unless (zerop here)
1425 (unless (zerop beyond)
1426 (write-char #\space stream))
1427 (format-print-small-cardinal stream here)
1428 (write-string (svref cardinal-periods period) stream))))
1429
1430 (defun format-print-ordinal (stream n)
1431 (when (minusp n)
1432 (write-string "negative " stream))
1433 (let ((number (abs n)))
1434 (multiple-value-bind
1435 (top bot) (truncate number 100)
1436 (unless (zerop top)
1437 (format-print-cardinal stream (- number bot)))
1438 (when (and (plusp top) (plusp bot))
1439 (write-char #\space stream))
1440 (multiple-value-bind
1441 (tens ones) (truncate bot 10)
1442 (cond ((= bot 12) (write-string "twelfth" stream))
1443 ((= tens 1)
1444 (write-string (svref cardinal-teens ones) stream);;;RAD
1445 (write-string "th" stream))
1446 ((and (zerop tens) (plusp ones))
1447 (write-string (svref ordinal-ones ones) stream))
1448 ((and (zerop ones)(plusp tens))
1449 (write-string (svref ordinal-tens tens) stream))
1450 ((plusp bot)
1451 (write-string (svref cardinal-tens tens) stream)
1452 (write-char #\- stream)
1453 (write-string (svref ordinal-ones ones) stream))
1454 ((plusp number)
1455 (write-string "th" stream))
1456 (t
1457 (write-string "zeroth" stream)))))))
1458
1459 ;;; Print Roman numerals
1460
1461 (defun format-print-old-roman (stream n)
1462 (unless (< 0 n 5000)
1463 (error (intl:gettext "Number too large to print in old Roman numerals: ~:D") n))
1464 (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1465 (val-list '(500 100 50 10 5 1) (cdr val-list))
1466 (cur-char #\M (car char-list))
1467 (cur-val 1000 (car val-list))
1468 (start n (do ((i start (progn
1469 (write-char cur-char stream)
1470 (- i cur-val))))
1471 ((< i cur-val) i))))
1472 ((zerop start))))
1473
1474 (defun format-print-roman (stream n)
1475 (unless (< 0 n 4000)
1476 (error (intl:gettext "Number too large to print in Roman numerals: ~:D") n))
1477 (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1478 (val-list '(500 100 50 10 5 1) (cdr val-list))
1479 (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
1480 (sub-val '(100 10 10 1 1 0) (cdr sub-val))
1481 (cur-char #\M (car char-list))
1482 (cur-val 1000 (car val-list))
1483 (cur-sub-char #\C (car sub-chars))
1484 (cur-sub-val 100 (car sub-val))
1485 (start n (do ((i start (progn
1486 (write-char cur-char stream)
1487 (- i cur-val))))
1488 ((< i cur-val)
1489 (cond ((<= (- cur-val cur-sub-val) i)
1490 (write-char cur-sub-char stream)
1491 (write-char cur-char stream)
1492 (- i (- cur-val cur-sub-val)))
1493 (t i))))))
1494 ((zerop start))))
1495
1496
1497 ;;;; Plural.
1498
1499 (def-format-directive #\P (colonp atsignp params end)
1500 (expand-bind-defaults () params
1501 (let ((arg (cond
1502 ((not colonp)
1503 (expand-next-arg))
1504 (*orig-args-available*
1505 `(if (eq orig-args args)
1506 (error 'format-error
1507 :complaint (intl:gettext "No previous argument.")
1508 :offset ,(1- end))
1509 (do ((arg-ptr orig-args (cdr arg-ptr)))
1510 ((eq (cdr arg-ptr) args)
1511 (car arg-ptr)))))
1512 (*only-simple-args*
1513 (unless *simple-args*
1514 (error 'format-error
1515 :complaint (intl:gettext "No previous argument.")))
1516 (caar *simple-args*))
1517 (t
1518 (throw 'need-orig-args nil)))))
1519 (if atsignp
1520 `(write-string (if (eql ,arg 1) "y" "ies") stream)
1521 `(unless (eql ,arg 1) (write-char #\s stream))))))
1522
1523 (def-format-interpreter #\P (colonp atsignp params)
1524 (interpret-bind-defaults () params
1525 (let ((arg (if colonp
1526 (if (eq orig-args args)
1527 (error 'format-error
1528 :complaint "No previous argument.")
1529 (do ((arg-ptr orig-args (cdr arg-ptr)))
1530 ((eq (cdr arg-ptr) args)
1531 (car arg-ptr))))
1532 (next-arg))))
1533 (if atsignp
1534 (write-string (if (eql arg 1) "y" "ies") stream)
1535 (unless (eql arg 1) (write-char #\s stream))))))
1536
1537
1538 ;;;; Floating point noise.
1539
1540 (defun decimal-string (n)
1541 (write-to-string n :base 10 :radix nil :escape nil))
1542
1543 (def-format-directive #\F (colonp atsignp params)
1544 (when colonp
1545 (error 'format-error
1546 :complaint
1547 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1548 (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
1549 `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
1550
1551 (def-format-interpreter #\F (colonp atsignp params)
1552 (when colonp
1553 (error 'format-error
1554 :complaint
1555 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1556 (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
1557 params
1558 (format-fixed stream (next-arg) w d k ovf pad atsignp)))
1559
1560 (defun format-fixed (stream number w d k ovf pad atsign)
1561 (if (numberp number)
1562 (if (floatp number)
1563 (format-fixed-aux stream number w d k ovf pad atsign)
1564 (if (rationalp number)
1565 (format-fixed-aux stream
1566 (coerce number 'single-float)
1567 w d k ovf pad atsign)
1568 (format-write-field stream
1569 (decimal-string number)
1570 w 1 0 #\space t)))
1571 (format-princ stream number nil nil w 1 0 pad)))
1572
1573
1574 ;;; We return true if we overflowed, so that ~G can output the overflow char
1575 ;;; instead of spaces.
1576 ;;;
1577 (defun format-fixed-aux (stream number w d k ovf pad atsign)
1578 (declare (type float number))
1579 (cond
1580 ((and (floatp number)
1581 (or (float-infinity-p number)
1582 (float-nan-p number)))
1583 (prin1 number stream)
1584 nil)
1585 (t
1586 (let ((spaceleft w))
1587 (when (and w (or atsign (minusp (float-sign number))))
1588 (decf spaceleft))
1589 (multiple-value-bind (str len lpoint tpoint)
1590 (lisp::flonum-to-string (abs number) :width spaceleft :fdigits d
1591 :scale k :allow-overflow-p nil)
1592 ;;if caller specifically requested no fraction digits, suppress the
1593 ;;optional trailing zero
1594 (when (and d (zerop d)) (setq tpoint nil))
1595 (when w
1596 (decf spaceleft len)
1597 ;;optional leading zero
1598 (when lpoint
1599 (if (or (> spaceleft 0) tpoint) ;force at least one digit
1600 (decf spaceleft)
1601 (setq lpoint nil)))
1602 ;;optional trailing zero
1603 (when tpoint
1604 (if (> spaceleft 0)
1605 (decf spaceleft)
1606 (setq tpoint nil))))
1607 (cond ((and w (< spaceleft 0) ovf)
1608 ;;field width overflow
1609 (dotimes (i w) (write-char ovf stream))
1610 t)
1611 (t
1612 (when w (dotimes (i spaceleft) (write-char pad stream)))
1613 (if (minusp (float-sign number))
1614 (write-char #\- stream)
1615 (if atsign (write-char #\+ stream)))
1616 (when lpoint (write-char #\0 stream))
1617 (write-string str stream)
1618 (when tpoint (write-char #\0 stream))
1619 nil)))))))
1620
1621 (def-format-directive #\E (colonp atsignp params)
1622 (when colonp
1623 (error 'format-error
1624 :complaint
1625 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1626 (expand-bind-defaults
1627 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
1628 params
1629 `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
1630 ,atsignp)))
1631
1632 (def-format-interpreter #\E (colonp atsignp params)
1633 (when colonp
1634 (error 'format-error
1635 :complaint
1636 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1637 (interpret-bind-defaults
1638 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
1639 params
1640 (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
1641
1642 (defun format-exponential (stream number w d e k ovf pad marker atsign)
1643 (if (numberp number)
1644 (if (floatp number)
1645 (format-exp-aux stream number w d e k ovf pad marker atsign)
1646 (if (rationalp number)
1647 (format-exp-aux stream
1648 (coerce number 'single-float)
1649 w d e k ovf pad marker atsign)
1650 (format-write-field stream
1651 (decimal-string number)
1652 w 1 0 #\space t)))
1653 (format-princ stream number nil nil w 1 0 pad)))
1654
1655
1656 (defun format-exponent-marker (number)
1657 (if (typep number *read-default-float-format*)
1658 #\e
1659 (typecase number
1660 (single-float #\f)
1661 (double-float #\d)
1662 (short-float #\s)
1663 (long-float #\l)
1664 #+double-double
1665 (double-double-float #\w))))
1666
1667 ;; This is a modified version of scale in FLONUM-TO-DIGITS. We only
1668 ;; want the exponent, so most things not needed for the computation of
1669 ;; the exponent has been removed. We also implemented the
1670 ;; floating-point log approximation given in Burger and Dybvig. This
1671 ;; is very noticeably faster for large and small numbers. It is
1672 ;; slower for intermediate sized numbers.
1673 (defun accurate-scale-exponent (v)
1674 (declare (type float v))
1675 (if (zerop v)
1676 1
1677 (let ((float-radix 2) ; b
1678 (float-digits (float-digits v)) ; p
1679 (min-e
1680 (etypecase v
1681 (single-float lisp::single-float-min-e)
1682 (double-float lisp::double-float-min-e)
1683 #+double-double
1684 (double-double-float lisp::double-double-float-min-e))))
1685 (multiple-value-bind (f e)
1686 (integer-decode-float v)
1687 (let ( ;; FIXME: these even tests assume normal IEEE rounding
1688 ;; mode. I wonder if we should cater for non-normal?
1689 (high-ok (evenp f)))
1690 ;; This scale function is basically the same as the one in
1691 ;; FLONUM-TO-DIGITS, except we don't return the computed
1692 ;; digits. We only want the exponent.
1693 (labels ((flog (x)
1694 (declare (type (float (0.0)) x))
1695 (let ((xd (etypecase x
1696 (single-float
1697 (float x 1d0))
1698 (double-float
1699 x)
1700 #+double-double
1701 (double-double-float
1702 (double-double-hi x)))))
1703 (ceiling (- (the (double-float -400d0 400d0) (log xd 10d0))
1704 1d-10))))
1705 (fixup (r s m+ k)
1706 (if (if high-ok
1707 (>= (+ r m+) s)
1708 (> (+ r m+) s))
1709 (+ k 1)
1710 k))
1711 (scale (r s m+)
1712 (let* ((est (flog v))
1713 (scale (the integer (aref lisp::*powers-of-ten* (abs est)))))
1714 (if (>= est 0)
1715 (fixup r (* s scale) m+ est)
1716 (fixup (* r scale) s (* m+ scale) est)))))
1717 (let (r s m+)
1718 (if (>= e 0)
1719 (let* ((be (expt float-radix e))
1720 (be1 (* be float-radix)))
1721 (if (/= f (expt float-radix (1- float-digits)))
1722 (setf r (* f be 2)
1723 s 2
1724 m+ be)
1725 (setf r (* f be1 2)
1726 s (* float-radix 2)
1727 m+ be1)))
1728 (if (or (= e min-e)
1729 (/= f (expt float-radix (1- float-digits))))
1730 (setf r (* f 2)
1731 s (* (expt float-radix (- e)) 2)
1732 m+ 1)
1733 (setf r (* f float-radix 2)
1734 s (* (expt float-radix (- 1 e)) 2)
1735 m+ float-radix)))
1736 (scale r s m+))))))))
1737
1738 ;;;Here we prevent the scale factor from shifting all significance out of
1739 ;;;a number to the right. We allow insignificant zeroes to be shifted in
1740 ;;;to the left right, athough it is an error to specify k and d such that this
1741 ;;;occurs. Perhaps we should detect both these conditions and flag them as
1742 ;;;errors. As for now, we let the user get away with it, and merely guarantee
1743 ;;;that at least one significant digit will appear.
1744
1745 ;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent
1746 ;;; marker is always printed. Make it so. Also, the original version
1747 ;;; causes errors when printing infinities or NaN's. The Hyperspec is
1748 ;;; silent here, so let's just print out infinities and NaN's instead
1749 ;;; of causing an error.
1750 (defun format-exp-aux (stream number w d e k ovf pad marker atsign)
1751 (if (and (floatp number)
1752 (or (float-infinity-p number)
1753 (float-nan-p number)))
1754 (prin1 number stream)
1755 (let* ((num-expt (accurate-scale-exponent (abs number)))
1756 (expt (if (zerop number)
1757 0
1758 (- num-expt k)))
1759 (estr (decimal-string (abs expt)))
1760 (elen (if e (max (length estr) e) (length estr)))
1761 (add-zero-p nil))
1762 (if (and w ovf e (> elen e)) ;exponent overflow
1763 (dotimes (i w)
1764 (write-char ovf stream))
1765 ;; The hairy case
1766 (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
1767 (fmin (if (minusp k)
1768 1
1769 fdig))
1770 (spaceleft (if w
1771 (- w 2 elen
1772 (if (or atsign (minusp (float-sign number)))
1773 1 0))
1774 nil)))
1775 #+(or)
1776 (progn
1777 (format t "fdig = ~A~%" fdig)
1778 (format t "fmin = ~A~%" fmin)
1779 (format t "spaceleft = ~A~%" spaceleft)
1780 (format t "expt = ~S~%" expt))
1781
1782 (multiple-value-bind (fstr flen lpoint tpoint point-pos roundoff)
1783 (lisp::flonum-to-string (abs number)
1784 :width spaceleft
1785 :fdigits fdig
1786 :scale k
1787 :fmin fmin
1788 :num-expt num-expt)
1789 (declare (ignore point-pos))
1790 #+(or)
1791 (progn
1792 (format t "fstr = ~S~%" fstr)
1793 (format t "flen = ~S~%" flen)
1794 (format t "lp = ~S~%" lpoint)
1795 (format t "tp = ~S~%" tpoint))
1796
1797 (when (and d (zerop d)) (setq tpoint nil))
1798 (when w
1799 (decf spaceleft flen)
1800 ;; See CLHS 22.3.3.2. "If the parameter d is
1801 ;; omitted, ... [and] if the fraction to be
1802 ;; printed is zero then a single zero digit should
1803 ;; appear after the decimal point." So we need to
1804 ;; subtract one from here because we're going to
1805 ;; add an extra 0 digit later.
1806 (when (and (null d) (char= (aref fstr (1- flen)) #\.))
1807 (setf add-zero-p t)
1808 (decf spaceleft))
1809 (when lpoint
1810 (if (or (> spaceleft 0) tpoint)
1811 (decf spaceleft)
1812 (setq lpoint nil)))
1813 (when (and tpoint (<= spaceleft 0))
1814 (setq tpoint nil)))
1815 (cond ((and w (< spaceleft 0) ovf)
1816 ;;significand overflow
1817 (dotimes (i w) (write-char ovf stream)))
1818 (t (when w
1819 (dotimes (i spaceleft)
1820 (write-char pad stream)))
1821 (if (minusp (float-sign number))
1822 (write-char #\- stream)
1823 (if atsign (write-char #\+ stream)))
1824 (when lpoint (write-char #\0 stream))
1825 (write-string fstr stream)
1826 ;; Add a zero if we need it. Which means
1827 ;; we figured out we need one above, or
1828 ;; another condition. Basically, append a
1829 ;; zero if there are no width constraints
1830 ;; and if the last char to print was a
1831 ;; decimal (so the trailing fraction is
1832 ;; zero.)
1833 (when (or add-zero-p
1834 (and (null w)
1835 (char= (aref fstr (1- flen)) #\.)))
1836 ;; It's later and we're adding the zero
1837 ;; digit.
1838 (write-char #\0 stream))
1839 (write-char (if marker
1840 marker
1841 (format-exponent-marker number))
1842 stream)
1843 (when roundoff
1844 ;; Printed result has rounded the number up
1845 ;; so that the exponent is one too small.
1846 ;; Increase our printed exponent.
1847 (incf expt)
1848 (setf estr (decimal-string (abs expt))))
1849 (write-char (if (minusp expt) #\- #\+) stream)
1850 (when e
1851 ;;zero-fill before exponent if necessary
1852 (dotimes (i (- e (length estr)))
1853 (write-char #\0 stream)))
1854 (write-string estr stream))))))))
1855 (values))
1856
1857 (def-format-directive #\G (colonp atsignp params)
1858 (when colonp
1859 (error 'format-error
1860 :complaint
1861 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1862 (expand-bind-defaults
1863 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
1864 params
1865 `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
1866
1867 (def-format-interpreter #\G (colonp atsignp params)
1868 (when colonp
1869 (error 'format-error
1870 :complaint
1871 (intl:gettext "Cannot specify the colon modifier with this directive.")))
1872 (interpret-bind-defaults
1873 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
1874 params
1875 (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
1876
1877 (defun format-general (stream number w d e k ovf pad marker atsign)
1878 (if (numberp number)
1879 (if (floatp number)
1880 (format-general-aux stream number w d e k ovf pad marker atsign)
1881 (if (rationalp number)
1882 (format-general-aux stream
1883 (coerce number 'single-float)
1884 w d e k ovf pad marker atsign)
1885 (format-write-field stream
1886 (decimal-string number)
1887 w 1 0 #\space t)))
1888 (format-princ stream number nil nil w 1 0 pad)))
1889
1890
1891 ;;; toy@rtp.ericsson.se: Same change as for format-exp-aux.
1892 (defun format-general-aux (stream number w d e k ovf pad marker atsign)
1893 (if (and (floatp number)
1894 (or (float-infinity-p number)
1895 (float-nan-p number)))
1896 (prin1 number stream)
1897 (let* ((n (accurate-scale-exponent (abs number)))
1898 (orig-d d))
1899 ;; Default d if omitted. The procedure is taken directly from
1900 ;; the definition given in the manual (CLHS 22.3.3.3), and is
1901 ;; not very efficient, since we generate the digits twice.
1902 ;; Future maintainers are encouraged to improve on this.
1903 ;;
1904 ;; It's also not very clear whether q in the spec is the
1905 ;; number of significant digits or not. I (rtoy) think it
1906 ;; makes more sense if q is the number of significant digits.
1907 ;; That way 1d300 isn't printed as 1 followed by 300 zeroes.
1908 ;; Exponential notation would be used instead.
1909
1910 (unless d
1911 ;; flonum-to-digits doesn't like 0.0, so handle the special
1912 ;; case here. Set d to n so that dd = 0 <= d to use ~F
1913 ;; format.
1914 (if (zerop number)
1915 (setq d n)
1916 (let* ((q (length (nth-value 1 (lisp::flonum-to-digits (abs number))))))
1917 (setq d (max q (min n 7))))))
1918 (let* ((ee (if e (+ e 2) 4))
1919 (ww (if w (- w ee) nil))
1920 (dd (- d n)))
1921 #+(or)
1922 (progn
1923 (format t "d = ~A~%" d)
1924 (format t "ee = ~A~%" ee)
1925 (format t "ww = ~A~%" ww)
1926 (format t "dd = ~A~%" dd))
1927 (cond ((<= 0 dd d)
1928 ;; Use dd fraction digits, even if that would cause
1929 ;; the width to be exceeded. We choose accuracy over
1930 ;; width in this case.
1931 (let* ((fill-char (if (format-fixed-aux stream number ww
1932 dd
1933 nil
1934 ovf pad atsign)
1935 ovf
1936 #\space)))
1937 (dotimes (i ee) (write-char fill-char stream))))
1938 (t
1939 (format-exp-aux stream number w
1940 orig-d
1941 e (or k 1)
1942 ovf pad marker atsign)))))))
1943
1944 (def-format-directive #\$ (colonp atsignp params)
1945 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
1946 `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
1947 ,atsignp)))
1948
1949 (def-format-interpreter #\$ (colonp atsignp params)
1950 (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
1951 (format-dollars stream (next-arg) d n w pad colonp atsignp)))
1952
1953 (defun format-dollars (stream number d n w pad colon atsign)
1954 (if (rationalp number) (setq number (coerce number 'single-float)))
1955 (if (floatp number)
1956 (let* ((signstr (if (minusp (float-sign number)) "-" (if atsign "+" "")))
1957 (signlen (length signstr)))
1958 (multiple-value-bind (str strlen ig2 ig3 pointplace)
1959 (lisp::flonum-to-string number :width nil :fdigits d :scale nil)
1960 (declare (ignore ig2 ig3))
1961 (when colon (write-string signstr stream))
1962 (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen))
1963 (write-char pad stream))
1964 (unless colon (write-string signstr stream))
1965 (dotimes (i (- n pointplace)) (write-char #\0 stream))
1966 (write-string str stream)))
1967 (format-write-field stream
1968 (decimal-string number)
1969 w 1 0 #\space t)))
1970
1971
1972 ;;;; line/page breaks and other stuff like that.
1973
1974 (def-format-directive #\% (colonp atsignp params)
1975 (when (or colonp atsignp)
1976 (error 'format-error
1977 :complaint
1978 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
1979 (if params
1980 (expand-bind-defaults ((count 1)) params
1981 `(dotimes (i ,count)
1982 (terpri stream)))
1983 '(terpri stream)))
1984
1985 (def-format-interpreter #\% (colonp atsignp params)
1986 (when (or colonp atsignp)
1987 (error 'format-error
1988 :complaint
1989 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
1990 (interpret-bind-defaults ((count 1)) params
1991 (dotimes (i count)
1992 (terpri stream))))
1993
1994 (def-format-directive #\& (colonp atsignp params)
1995 (when (or colonp atsignp)
1996 (error 'format-error
1997 :complaint
1998 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
1999 (if params
2000 (expand-bind-defaults ((count 1)) params
2001 `(progn
2002 (fresh-line stream)
2003 (dotimes (i (1- ,count))
2004 (terpri stream))))
2005 '(fresh-line stream)))
2006
2007 (def-format-interpreter #\& (colonp atsignp params)
2008 (when (or colonp atsignp)
2009 (error 'format-error
2010 :complaint
2011 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
2012 (interpret-bind-defaults ((count 1)) params
2013 (fresh-line stream)
2014 (dotimes (i (1- count))
2015 (terpri stream))))
2016
2017 (def-format-directive #\| (colonp atsignp params)
2018 (when (or colonp atsignp)
2019 (error 'format-error
2020 :complaint
2021 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
2022 (if params
2023 (expand-bind-defaults ((count 1)) params
2024 `(dotimes (i ,count)
2025 (write-char #\page stream)))
2026 '(write-char #\page stream)))
2027
2028 (def-format-interpreter #\| (colonp atsignp params)
2029 (when (or colonp atsignp)
2030 (error 'format-error
2031 :complaint
2032 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
2033 (interpret-bind-defaults ((count 1)) params
2034 (dotimes (i count)
2035 (write-char #\page stream))))
2036
2037 (def-format-directive #\~ (colonp atsignp params)
2038 (when (or colonp atsignp)
2039 (error 'format-error
2040 :complaint
2041 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
2042 (if params
2043 (expand-bind-defaults ((count 1)) params
2044 `(dotimes (i ,count)
2045 (write-char #\~ stream)))
2046 '(write-char #\~ stream)))
2047
2048 (def-format-interpreter #\~ (colonp atsignp params)
2049 (when (or colonp atsignp)
2050 (error 'format-error
2051 :complaint
2052 (intl:gettext "Cannot specify either colon or atsign for this directive.")))
2053 (interpret-bind-defaults ((count 1)) params
2054 (dotimes (i count)
2055 (write-char #\~ stream))))
2056
2057 (def-complex-format-directive #\newline (colonp atsignp params directives)
2058 (when (and colonp atsignp)
2059 (error 'format-error
2060 :complaint
2061 (intl:gettext "Cannot specify both colon and atsign for this directive.")))
2062 (values (expand-bind-defaults () params
2063 (if atsignp
2064 '(write-char #\newline stream)
2065 nil))
2066 (if (and (not colonp)
2067 directives
2068 (simple-string-p (car directives)))
2069 (cons (string-left-trim '(#\space #\newline #\tab)
2070 (car directives))
2071 (cdr directives))
2072 directives)))
2073
2074 (def-complex-format-interpreter #\newline (colonp atsignp params directives)
2075 (when (and colonp atsignp)
2076 (error 'format-error
2077 :complaint
2078 (intl:gettext "Cannot specify both colon and atsign for this directive.")))
2079 (interpret-bind-defaults () params
2080 (when atsignp
2081 (write-char #\newline stream)))
2082 (if (and (not colonp)
2083 directives
2084 (simple-string-p (car directives)))
2085 (cons (string-left-trim '(#\space #\newline #\tab)
2086 (car directives))
2087 (cdr directives))
2088 directives))
2089
2090
2091 ;;;; Tab and simple pretty-printing noise.
2092
2093 (def-format-directive #\T (colonp atsignp params)
2094 (if colonp
2095 (expand-bind-defaults ((n 1) (m 1)) params
2096 `(pprint-tab ,(if atsignp :section-relative :section)
2097 ,n ,m stream))
2098 (if atsignp
2099 (expand-bind-defaults ((colrel 1) (colinc 1)) params
2100 `(format-relative-tab stream ,colrel ,colinc))
2101 (expand-bind-defaults ((colnum 1) (colinc 1)) params
2102 `(format-absolute-tab stream ,colnum ,colinc)))))
2103
2104 (def-format-interpreter #\T (colonp atsignp params)
2105 (if colonp
2106 (interpret-bind-defaults ((n 1) (m 1)) params
2107 (pprint-tab (if atsignp :section-relative :section) n m stream))
2108 (if atsignp
2109 (interpret-bind-defaults ((colrel 1) (colinc 1)) params
2110 (format-relative-tab stream colrel colinc))
2111 (interpret-bind-defaults ((colnum 1) (colinc 1)) params
2112 (format-absolute-tab stream colnum colinc)))))
2113
2114 (defun output-spaces (stream n)
2115 (let ((spaces #.(make-string 100 :initial-element #\space)))
2116 (loop
2117 (when (< n (length spaces))
2118 (return))
2119 (write-string spaces stream)
2120 (decf n (length spaces)))
2121 (write-string spaces stream :end n)))
2122
2123 (defun format-relative-tab (stream colrel colinc)
2124 (if (pp:pretty-stream-p stream)
2125 (pprint-tab :line-relative colrel colinc stream)
2126 (let* ((cur (lisp::charpos stream))
2127 (spaces (if (and cur (plusp colinc))
2128 (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
2129 colrel)))
2130 (output-spaces stream spaces))))
2131
2132 (defun format-absolute-tab (stream colnum colinc)
2133 (if (pp:pretty-stream-p stream)
2134 (pprint-tab :line colnum colinc stream)
2135 (let ((cur (lisp::charpos stream)))
2136 (cond ((null cur)
2137 (write-string " " stream))
2138 ((< cur colnum)
2139 (output-spaces stream (- colnum cur)))
2140 (t
2141 (unless (zerop colinc)
2142 (output-spaces stream
2143 (- colinc (rem (- cur colnum) colinc)))))))))
2144
2145 (def-format-directive #\_ (colonp atsignp params)
2146 (expand-bind-defaults () params
2147 `(pprint-newline ,(if colonp
2148 (if atsignp
2149 :mandatory
2150 :fill)
2151 (if atsignp
2152 :miser
2153 :linear))
2154 stream)))
2155
2156 (def-format-interpreter #\_ (colonp atsignp params)
2157 (interpret-bind-defaults () params
2158 (pprint-newline (if colonp
2159 (if atsignp
2160 :mandatory
2161 :fill)
2162 (if atsignp
2163 :miser
2164 :linear))
2165 stream)))
2166
2167 (def-format-directive #\I (colonp atsignp params)
2168 (when atsignp
2169 (error 'format-error
2170 :complaint (intl:gettext "Cannot specify the at-sign modifier.")))
2171 (expand-bind-defaults ((n 0)) params
2172 `(pprint-indent ,(if colonp :current :block) ,n stream)))
2173
2174 (def-format-interpreter #\I (colonp atsignp params)
2175 (when atsignp
2176 (error 'format-error
2177 :complaint (intl:gettext "Cannot specify the at-sign modifier.")))
2178 (interpret-bind-defaults ((n 0)) params
2179 (pprint-indent (if colonp :current :block) n stream)))
2180
2181
2182 ;;;; *
2183
2184 (def-format-directive #\* (colonp atsignp params end)
2185 (if atsignp
2186 (if colonp
2187 (error 'format-error
2188 :complaint (intl:gettext "Cannot specify both colon and at-sign."))
2189 (expand-bind-defaults ((posn 0)) params
2190 (unless *orig-args-available*
2191 (throw 'need-orig-args nil))
2192 `(if (<= 0 ,posn (length orig-args))
2193 (setf args (nthcdr ,posn orig-args))
2194 (error 'format-error
2195 :complaint (intl:gettext "Index ~D out of bounds. Should have been ~
2196 between 0 and ~D.")
2197 :arguments (list ,posn (length orig-args))
2198 :offset ,(1- end)))))
2199 (if colonp
2200 (expand-bind-defaults ((n 1)) params
2201 (unless *orig-args-available*
2202 (throw 'need-orig-args nil))
2203 `(do ((cur-posn 0 (1+ cur-posn))
2204 (arg-ptr orig-args (cdr arg-ptr)))
2205 ((eq arg-ptr args)
2206 (let ((new-posn (- cur-posn ,n)))
2207 (if (<= 0 new-posn (length orig-args))
2208 (setf args (nthcdr new-posn orig-args))
2209 (error 'format-error
2210 :complaint
2211 (intl:gettext "Index ~D out of bounds. Should have been ~
2212 between 0 and ~D.")
2213 :arguments
2214 (list new-posn (length orig-args))
2215 :offset ,(1- end)))))))
2216 (if params
2217 (expand-bind-defaults ((n 1)) params
2218 (setf *only-simple-args* nil)
2219 `(dotimes (i ,n)
2220 ,(expand-next-arg)))
2221 (expand-next-arg)))))
2222
2223 (def-format-interpreter #\* (colonp atsignp params)
2224 (if atsignp
2225 (if colonp
2226 (error 'format-error
2227 :complaint (intl:gettext "Cannot specify both colon and at-sign."))
2228 (interpret-bind-defaults ((posn 0)) params
2229 (if (<= 0 posn (length orig-args))
2230 (setf args (nthcdr posn orig-args))
2231 (error 'format-error
2232 :complaint (intl:gettext "Index ~D out of bounds. Should have been ~
2233 between 0 and ~D.")
2234 :arguments (list posn (length orig-args))))))
2235 (if colonp
2236 (interpret-bind-defaults ((n 1)) params
2237 (do ((cur-posn 0 (1+ cur-posn))
2238 (arg-ptr orig-args (cdr arg-ptr)))
2239 ((eq arg-ptr args)
2240 (let ((new-posn (- cur-posn n)))
2241 (if (<= 0 new-posn (length orig-args))
2242 (setf args (nthcdr new-posn orig-args))
2243 (error 'format-error
2244 :complaint
2245 (intl:gettext "Index ~D out of bounds. Should have been ~
2246 between 0 and ~D.")
2247 :arguments
2248 (list new-posn (length orig-args))))))))
2249 (interpret-bind-defaults ((n 1)) params
2250 (dotimes (i n)
2251 (next-arg))))))
2252
2253
2254 ;;;; Indirection.
2255
2256 (def-format-directive #\? (colonp atsignp params string end)
2257 (when colonp
2258 (error 'format-error
2259 :complaint (intl:gettext "Cannot specify the colon modifier.")))
2260 (expand-bind-defaults () params
2261 `(handler-bind
2262 ((format-error
2263 #'(lambda (condition)
2264 (error 'format-error
2265 :complaint
2266 (intl:gettext "~A~%while processing indirect format string:")
2267 :arguments (list condition)
2268 :print-banner nil
2269 :control-string ,string
2270 :offset ,(1- end)))))
2271 ,(if atsignp
2272 (if *orig-args-available*
2273 `(setf args (%format stream ,(expand-next-arg) orig-args args))
2274 (throw 'need-orig-args nil))
2275 `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
2276
2277 (def-format-interpreter #\? (colonp atsignp params string end)
2278 (when colonp
2279 (error 'format-error
2280 :complaint (intl:gettext "Cannot specify the colon modifier.")))
2281 (interpret-bind-defaults () params
2282 (handler-bind
2283 ((format-error
2284 #'(lambda (condition)
2285 (error 'format-error
2286 :complaint
2287 (intl:gettext "~A~%while processing indirect format string:")
2288 :arguments (list condition)
2289 :print-banner nil
2290 :control-string string
2291 :offset (1- end)))))
2292 (if atsignp
2293 (setf args (%format stream (next-arg) orig-args args))
2294 (%format stream (next-arg) (next-arg))))))
2295
2296
2297 ;;;; Capitalization.
2298
2299 (def-complex-format-directive #\( (colonp atsignp params directives)
2300 (let ((close (find-directive directives #\) nil)))
2301 (unless close
2302 (error 'format-error
2303 :complaint (intl:gettext "No corresponding close paren.")))
2304 (let* ((posn (position close directives))
2305 (before (subseq directives 0 posn))
2306 (after (nthcdr (1+ posn) directives)))
2307 (values
2308 (expand-bind-defaults () params
2309 `(let ((stream (make-case-frob-stream stream
2310 ,(if colonp
2311 (if atsignp
2312 :upcase
2313 :capitalize)
2314 (if atsignp
2315 :capitalize-first
2316 :downcase)))))
2317 ,@(expand-directive-list before)))
2318 after))))
2319
2320 (def-complex-format-interpreter #\( (colonp atsignp params directives)
2321 (let ((close (find-directive directives #\) nil)))
2322 (unless close
2323 (error 'format-error
2324 :complaint (intl:gettext "No corresponding close paren.")))
2325 (interpret-bind-defaults () params
2326 (let* ((posn (position close directives))
2327 (before (subseq directives 0 posn))
2328 (after (nthcdr (1+ posn) directives))
2329 (stream (make-case-frob-stream stream
2330 (if colonp
2331 (if atsignp
2332 :upcase
2333 :capitalize)
2334 (if atsignp
2335 :capitalize-first
2336 :downcase)))))
2337 (setf args (interpret-directive-list stream before orig-args args))
2338 after))))
2339
2340 (def-complex-format-directive #\) ()
2341 (error 'format-error
2342 :complaint (intl:gettext "No corresponding open paren.")))
2343
2344 (def-complex-format-interpreter #\) ()
2345 (error 'format-error
2346 :complaint (intl:gettext "No corresponding open paren.")))
2347
2348
2349 ;;;; Conditionals
2350
2351 (defun parse-conditional-directive (directives)
2352 (let ((sublists nil)
2353 (last-semi-with-colon-p nil)
2354 (remaining directives))
2355 (loop
2356 (let ((close-or-semi (find-directive remaining #\] t)))
2357 (unless close-or-semi
2358 (error 'format-error
2359 :complaint (intl:gettext "No corresponding close bracket.")))
2360 (let ((posn (position close-or-semi remaining)))
2361 (push (subseq remaining 0 posn) sublists)
2362 (setf remaining (nthcdr (1+ posn) remaining))
2363 (when (char= (format-directive-character close-or-semi) #\])
2364 (return))
2365 (setf last-semi-with-colon-p
2366 (format-directive-colonp close-or-semi)))))
2367 (values sublists last-semi-with-colon-p remaining)))
2368
2369 (def-complex-format-directive #\[ (colonp atsignp params directives)
2370 (multiple-value-bind
2371 (sublists last-semi-with-colon-p remaining)
2372 (parse-conditional-directive directives)
2373 (values
2374 (if atsignp
2375 (if colonp
2376 (error 'format-error
2377 :complaint
2378 (intl:gettext "Cannot specify both the colon and at-sign modifiers."))
2379 (if (cdr sublists)
2380 (error 'format-error
2381 :complaint
2382 (intl:gettext "Can only specify one section"))
2383 (expand-bind-defaults () params
2384 (expand-maybe-conditional (car sublists)))))
2385 (if colonp
2386 (if (= (length sublists) 2)
2387 (progn
2388 (when last-semi-with-colon-p
2389 (error 'format-error
2390 :complaint (intl:gettext "~~:; directive not effective in ~~:[")))
2391 (expand-bind-defaults () params
2392 (expand-true-false-conditional (car sublists)
2393 (cadr sublists))))
2394 (error 'format-error
2395 :complaint
2396 (intl:gettext "Must specify exactly two sections.")))
2397 (expand-bind-defaults ((index nil)) params
2398 (setf *only-simple-args* nil)
2399 (let ((clauses nil)
2400 (case `(or ,index ,(expand-next-arg))))
2401 (when last-semi-with-colon-p
2402 (push `(t ,@(expand-directive-list (pop sublists)))
2403 clauses))
2404 (let ((count (length sublists)))
2405 (dolist (sublist sublists)
2406 (push `(,(decf count)
2407 ,@(expand-directive-list sublist))
2408 clauses)))
2409 `(case ,case ,@clauses)))))
2410 remaining)))
2411
2412 (defun expand-maybe-conditional (sublist)
2413 (flet ((hairy ()
2414 `(let ((prev-args args)
2415 (arg ,(expand-next-arg)))
2416 (when arg
2417 (setf args prev-args)
2418 ,@(expand-directive-list sublist)))))
2419 (if *only-simple-args*
2420 (multiple-value-bind
2421 (guts new-args)
2422 (let ((*simple-args* *simple-args*))
2423 (values (expand-directive-list sublist)
2424 *simple-args*))
2425 (cond ((and new-args (eq *simple-args* (cdr new-args)))
2426 (setf *simple-args* new-args)
2427 `(when ,(caar new-args)
2428 ,@guts))
2429 (t
2430 (setf *only-simple-args* nil)
2431 (hairy))))
2432 (hairy))))
2433
2434 (defun expand-true-false-conditional (true false)
2435 (let ((arg (expand-next-arg)))
2436 (flet ((hairy ()
2437 `(if ,arg
2438 (progn
2439 ,@(expand-directive-list true))
2440 (progn
2441 ,@(expand-directive-list false)))))
2442 (if *only-simple-args*
2443 (multiple-value-bind
2444 (true-guts true-args true-simple)
2445 (let ((*simple-args* *simple-args*)
2446 (*only-simple-args* t))
2447 (values (expand-directive-list true)
2448 *simple-args*
2449 *only-simple-args*))
2450 (multiple-value-bind
2451 (false-guts false-args false-simple)
2452 (let ((*simple-args* *simple-args*)
2453 (*only-simple-args* t))
2454 (values (expand-directive-list false)
2455 *simple-args*
2456 *only-simple-args*))
2457 (if (= (length true-args) (length false-args))
2458 `(if ,arg
2459 (progn
2460 ,@true-guts)
2461 ,(do ((false false-args (cdr false))
2462 (true true-args (cdr true))
2463 (bindings nil (cons `(,(caar false) ,(caar true))
2464 bindings)))
2465 ((eq true *simple-args*)
2466 (setf *simple-args* true-args)
2467 (setf *only-simple-args*
2468 (and true-simple false-simple))
2469 (if bindings
2470 `(let ,bindings
2471 ,@false-guts)
2472 `(progn
2473 ,@false-guts)))))
2474 (progn
2475 (setf