format.lisp 73.7 KB
Newer Older
1
;;; -*- Package: FORMAT -*-
ram's avatar
ram committed
2
3
;;;
;;; **********************************************************************
4
5
6
7
8
9
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
10
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.23 1992/02/12 16:10:36 ram Exp $")
11
;;;
ram's avatar
ram committed
12
13
;;; **********************************************************************
;;;
14
;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp.
ram's avatar
ram committed
15
;;;
16
17
18
;;; Written by William Lott, with lots of stuff stolen from the previous
;;; version by David Adam and later rewritten by Bill Maddox.
;;; 
ram's avatar
ram committed
19

20
21
(in-package "FORMAT")
(use-package "EXT")
22
(use-package "KERNEL")
ram's avatar
ram committed
23

24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(in-package "LISP")
(export '(format formatter))

(in-package "FORMAT")

(defstruct (format-directive
	    (:print-function %print-format-directive))
  (string (required-argument) :type simple-string)
  (start (required-argument) :type (and unsigned-byte fixnum))
  (end (required-argument) :type (and unsigned-byte fixnum))
  (character (required-argument) :type base-character)
  (colonp nil :type (member t nil))
  (atsignp nil :type (member t nil))
  (params nil :type list))

(defun %print-format-directive (struct stream depth)
  (declare (ignore depth))
41
42
43
44
  (print-unreadable-object (struct stream)
    (write-string (format-directive-string struct) stream
		  :start (format-directive-start struct)
		  :end (format-directive-end struct))))
45
46
47

(defvar *format-directive-expanders*
  (make-array char-code-limit :initial-element nil))
48
49
(defvar *format-directive-interpreters*
  (make-array char-code-limit :initial-element nil))
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

(defun %print-format-error (condition stream)
  (format stream
	  "~:[~;Error in format: ~]~
	   ~?~@[~%  ~A~%  ~V@T^~]"
	  (format-error-print-banner condition)
	  (format-error-complaint condition)
	  (format-error-arguments condition)
	  (format-error-control-string condition)
	  (format-error-offset condition)))

(defvar *default-format-error-control-string* nil)
(defvar *default-format-error-offset* nil)

(define-condition format-error (error)
  ((complaint (required-argument))
   (arguments nil)
   (control-string *default-format-error-control-string*)
   (offset *default-format-error-offset*)
   (print-banner t))
  (:report %print-format-error))
ram's avatar
ram committed
71
72


73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

;;;; TOKENIZE-CONTROL-STRING

(defun tokenize-control-string (string)
  (declare (simple-string string))
  (let ((index 0)
	(end (length string))
	(result nil))
    (loop
      (let ((next-directive (or (position #\~ string :start index) end)))
	(when (> next-directive index)
	  (push (subseq string index next-directive) result))
	(when (= next-directive end)
	  (return))
	(let ((directive (parse-directive string next-directive)))
	  (push directive result)
	  (setf index (format-directive-end directive)))))
    (nreverse result)))

(defun parse-directive (string start)
  (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
	(end (length string)))
    (flet ((get-char ()
	     (if (= posn end)
		 (error 'format-error
			:complaint "String ended before directive was found."
			:control-string string
			:offset start)
		 (schar string posn))))
      (loop
	(let ((char (get-char)))
	  (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
		 (multiple-value-bind
		     (param new-posn)
		     (parse-integer string :start posn :junk-allowed t)
108
		   (push (cons posn param) params)
109
110
111
112
113
114
115
116
		   (setf posn new-posn)
		   (case (get-char)
		     (#\,)
		     ((#\: #\@)
		      (decf posn))
		     (t
		      (return)))))
		((or (char= char #\v) (char= char #\V))
117
		 (push (cons posn :arg) params)
118
119
120
121
122
123
124
125
		 (incf posn)
		 (case (get-char)
		   (#\,)
		   ((#\: #\@)
		    (decf posn))
		   (t
		    (return))))
		((char= char #\#)
126
		 (push (cons posn :remaining) params)
127
128
129
130
131
132
133
134
135
		 (incf posn)
		 (case (get-char)
		   (#\,)
		   ((#\: #\@)
		    (decf posn))
		   (t
		    (return))))
		((char= char #\')
		 (incf posn)
136
		 (push (cons posn (get-char)) params))
137
		((char= char #\,)
138
		 (push (cons (1- posn) nil) params))
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
		((char= char #\:)
		 (if colonp
		     (error 'format-error
			    :complaint "Too many colons supplied."
			    :control-string string
			    :offset posn)
		     (setf colonp t)))
		((char= char #\@)
		 (if atsignp
		     (error 'format-error
			    :complaint "Too many at-signs supplied."
			    :control-string string
			    :offset posn)
		     (setf atsignp t)))
		(t
		 (when (char= (schar string (1- posn)) #\,)
155
		   (push (cons (1- posn) nil) params))
156
157
158
159
160
161
162
163
164
165
166
167
		 (return))))
	(incf posn))
      (let ((char (get-char)))
	(when (char= char #\/)
	  (let ((closing-slash (position #\/ string :start (1+ posn))))
	    (if closing-slash
		(setf posn closing-slash)
		(error 'format-error
		       :complaint "No matching closing slash."
		       :control-string string
		       :offset posn))))
	(make-format-directive
168
169
	    :string string :start start :end (1+ posn)
	    :character (char-upcase char)
170
171
	    :colonp colonp :atsignp atsignp
	    :params (nreverse params))))))
ram's avatar
ram committed
172

173
174
175
176
177
178
179
180
181

;;;; Specials used to communicate information.

;;; *UP-UP-AND-OUT-ALLOWED* -- internal.
;;;
;;; Used both by the expansion stuff and the interpreter stuff.  When it is
;;; non-NIL, up-up-and-out (~:^) is allowed.  Otherwise, ~:^ isn't allowed.
;;;
(defvar *up-up-and-out-allowed* nil)
ram's avatar
ram committed
182

183
184
185
186
187
188
189
;;; *LOGICAL-BLOCK-POPPER* -- internal.
;;;
;;; Used by the interpreter stuff.  When it non-NIL, its a function that will
;;; invoke PPRINT-POP in the right lexical environemnt.
;;;
(defvar *logical-block-popper* nil)

190
;;; *EXPANDER-NEXT-ARG-MACRO* -- internal.
191
;;;
192
;;; Used by the expander stuff.  This is bindable so that ~<...~:>
193
194
195
;;; can change it.
;;;
(defvar *expander-next-arg-macro* 'expander-next-arg)
ram's avatar
ram committed
196

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
;;; *ONLY-SIMPLE-ARGS* -- internal.
;;;
;;; Used by the expander stuff.  Initially starts as T, and gets set to NIL
;;; if someone needs to do something strange with the arg list (like use
;;; the rest, or something).
;;; 
(defvar *only-simple-args*)

;;; *ORIG-ARGS-AVAILABLE* -- internal.
;;;
;;; Used by the expander stuff.  We do an initial pass with this as NIL.
;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
;;; again with it bound to T.  If this is T, we don't try to do anything
;;; fancy with args.
;;; 
(defvar *orig-args-available* nil)

;;; *SIMPLE-ARGS* -- internal.
;;;
;;; Used by the expander stuff.  List of (symbol . offset) for simple args.
;;; 
(defvar *simple-args*)



ram's avatar
ram committed
222

223
224
;;;; FORMAT

225
(defun format (destination control-string &rest format-arguments)
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
  "Provides various facilities for formatting output.
  CONTROL-STRING contains a string to be output, possibly with embedded
  directives, which are flagged with the escape character \"~\".  Directives
  generally expand into additional text to be output, usually consuming one
  or more of the FORMAT-ARGUMENTS in the process.  A few useful directives
  are:
        ~A or ~nA     Prints one argument as if by PRINC
        ~S or ~nS     Prints one argument as if by PRIN1
        ~D or ~nD     Prints one argument as a decimal integer
        ~%            Does a TERPRI
        ~&            Does a FRESH-LINE

         where n is the width of the field in which the object is printed.
  
  DESTINATION controls where the result will go.  If DESTINATION is T, then
  the output is sent to the standard output stream.  If it is NIL, then the
  output is returned in a string as the value of the call.  Otherwise,
  DESTINATION must be a stream to which the output will be sent.

  Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"

  FORMAT has many additional capabilities not described here.  Consult the
  manual for details."
  (etypecase destination
250
251
    (null
     (with-output-to-string (stream)
252
       (%format stream control-string format-arguments)))
253
    (string
254
255
     (with-output-to-string (stream destination)
       (%format stream control-string format-arguments)))
256
    ((member t)
257
     (%format *standard-output* control-string format-arguments)
258
259
     nil)
    (stream
260
     (%format destination control-string format-arguments)
261
262
263
264
265
     nil)))

(defun %format (stream string-or-fun orig-args &optional (args orig-args))
  (if (functionp string-or-fun)
      (apply string-or-fun stream args)
266
267
268
269
270
271
      (catch 'up-and-out
	(let* ((string (etypecase string-or-fun
			 (simple-string
			  string-or-fun)
			 (string
			  (coerce string-or-fun 'simple-string))))
272
273
	       (*default-format-error-control-string* string)
	       (*logical-block-popper* nil))
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
	  (interpret-directive-list stream (tokenize-control-string string)
				    orig-args args)))))

(defun interpret-directive-list (stream directives orig-args args)
  (if directives
      (let ((directive (car directives)))
	(etypecase directive
	  (simple-string
	   (write-string directive stream)
	   (interpret-directive-list stream (cdr directives) orig-args args))
	  (format-directive
	   (multiple-value-bind
	       (new-directives new-args)
	       (let ((function
		      (svref *format-directive-interpreters*
			     (char-code (format-directive-character
					 directive))))
		     (*default-format-error-offset*
		      (1- (format-directive-end directive))))
		 (unless function
		   (error 'format-error
			  :complaint "Unknown format directive."))
		 (multiple-value-bind
		     (new-directives new-args)
		     (funcall function stream directive
			      (cdr directives) orig-args args)
		   (values new-directives new-args)))
	     (interpret-directive-list stream new-directives
				       orig-args new-args)))))
      args))
ram's avatar
ram committed
304
305


306
;;;; FORMATTER
ram's avatar
ram committed
307

308
309
(defmacro formatter (control-string)
  `#',(%formatter control-string))
ram's avatar
ram committed
310

311
(defun %formatter (control-string)
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
  (block nil
    (catch 'need-orig-args
      (let* ((*simple-args* nil)
	     (*only-simple-args* t)
	     (guts (expand-control-string control-string))
	     (args nil))
	(dolist (arg *simple-args*)
	  (push `(,(car arg)
		  (error
		   'format-error
		   :complaint "Required argument missing"
		   :control-string ,control-string
		   :offset ,(cdr arg)))
		args))
	(return `(lambda (stream &optional ,@args &rest args)
		   ,guts
		   args))))
    (let ((*orig-args-available* t)
	  (*only-simple-args* nil))
      `(lambda (stream &rest orig-args)
	 (let ((args orig-args))
	   ,(expand-control-string control-string)
	   args)))))
ram's avatar
ram committed
335

336
337
338
(defun expand-control-string (string)
  (let* ((string (etypecase string
		   (simple-string
ram's avatar
ram committed
339
		    string)
340
341
342
343
		   (string
		    (coerce string 'simple-string))))
	 (*default-format-error-control-string* string)
	 (directives (tokenize-control-string string)))
344
345
    `(block nil
       ,@(expand-directive-list directives))))
346
347
348
349
350
351
352

(defun expand-directive-list (directives)
  (let ((results nil)
	(remaining-directives directives))
    (loop
      (unless remaining-directives
	(return))
ram's avatar
ram committed
353
      (multiple-value-bind
354
355
356
357
358
359
360
361
362
363
364
365
	  (form new-directives)
	  (expand-directive (car remaining-directives)
			    (cdr remaining-directives))
	(push form results)
	(setf remaining-directives new-directives)))
    (reverse results)))

(defun expand-directive (directive more-directives)
  (etypecase directive
    (format-directive
     (let ((expander
	    (aref *format-directive-expanders*
366
367
368
		  (char-code (format-directive-character directive))))
	   (*default-format-error-offset*
	    (1- (format-directive-end directive))))
369
       (if expander
370
	   (funcall expander directive more-directives)
371
	   (error 'format-error
372
		  :complaint "Unknown directive."))))
373
374
375
    (simple-string
     (values `(write-string ,directive stream)
	     more-directives))))
376

377
(defun expand-next-arg (&optional offset)
378
379
380
381
382
383
384
385
386
387
388
389
  (if (or *orig-args-available* (not *only-simple-args*))
      `(,*expander-next-arg-macro*
	,*default-format-error-control-string*
	,(or offset *default-format-error-offset*))
      (let ((symbol (gensym "FORMAT-ARG-")))
	(push (cons symbol (or offset *default-format-error-offset*))
	      *simple-args*)
	symbol)))

(defun need-hairy-args ()
  (when *only-simple-args*
    ))
390

ram's avatar
ram committed
391

392
393
;;;; Format directive definition macros and runtime support.

394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
(defmacro expander-next-arg (string offset)
  `(if args
       (pop args)
       (error 'format-error
	      :complaint "No more arguments."
	      :control-string ,string
	      :offset ,offset)))

(defmacro expander-pprint-next-arg (string offset)
  `(progn
     (when (null args)
       (error 'format-error
	      :complaint "No more arguments."
	      :control-string ,string
	      :offset ,offset))
     (pprint-pop)
     (pop args)))

412
413
(eval-when (compile eval)

414
415
416
417
418
;;; NEXT-ARG -- internal.
;;;
;;; This macro is used to extract the next argument from the current arg list.
;;; This is the version used by format directive interpreters.
;;; 
419
(defmacro next-arg (&optional offset)
420
421
  `(progn
     (when (null args)
422
423
       (error 'format-error
	      :complaint "No more arguments."
424
425
426
427
428
	      ,@(when offset
		  `(:offset ,offset))))
     (when *logical-block-popper*
       (funcall *logical-block-popper*))
     (pop args)))
429

430
431
432
433
434
435
436
437
(defmacro def-complex-format-directive (char lambda-list &body body)
  (let ((defun-name (intern (format nil "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
				    char)))
	(directive (gensym))
	(directives (if lambda-list (car (last lambda-list)) (gensym))))
    `(progn
       (defun ,defun-name (,directive ,directives)
	 ,@(if lambda-list
438
439
440
441
442
443
444
445
446
447
448
449
	       `((let ,(mapcar #'(lambda (var)
				   `(,var
				     (,(intern (concatenate
						'string
						"FORMAT-DIRECTIVE-"
						(symbol-name var))
					       (symbol-package 'foo))
				      ,directive)))
			       (butlast lambda-list))
		   ,@body))
	       `((declare (ignore ,directive ,directives))
		 ,@body)))
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
       (%set-format-directive-expander ,char #',defun-name))))

(defmacro def-format-directive (char lambda-list &body body)
  (let ((directives (gensym))
	(declarations nil)
	(body-without-decls body))
    (loop
      (let ((form (car body-without-decls)))
	(unless (and (consp form) (eq (car form) 'declare))
	  (return))
	(push (pop body-without-decls) declarations)))
    (setf declarations (reverse declarations))
    `(def-complex-format-directive ,char (,@lambda-list ,directives)
       ,@declarations
       (values (progn ,@body-without-decls)
	       ,directives))))

467
(defmacro expand-bind-defaults (specs params &body body)
468
  (once-only ((params params))
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
    (if specs
	(collect ((expander-bindings) (runtime-bindings))
		 (dolist (spec specs)
		   (destructuring-bind (var default) spec
		     (let ((symbol (gensym)))
		       (expander-bindings
			`(,var ',symbol))
		       (runtime-bindings
			`(list ',symbol
			       (let* ((param-and-offset (pop ,params))
				      (offset (car param-and-offset))
				      (param (cdr param-and-offset)))
				 (case param
				   (:arg `(or ,(expand-next-arg offset)
					      ,,default))
484
485
486
				   (:remaining
				    (setf *only-simple-args* nil)
				    '(length args))
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
				   ((nil) ,default)
				   (t param))))))))
		 `(let ,(expander-bindings)
		    `(let ,(list ,@(runtime-bindings))
		       ,@(if ,params
			     (error 'format-error
				    :complaint
			    "Too many parameters, expected no more than ~D"
				    :arguments (list ,(length specs))
				    :offset (caar ,params)))
		       ,,@body)))
	`(progn
	   (when ,params
	     (error 'format-error
		    :complaint "Too many parameters, expected no more than 0"
		    :offset (caar ,params)))
	   ,@body))))
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555

(defmacro def-complex-format-interpreter (char lambda-list &body body)
  (let ((defun-name
	    (intern (format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
			    char)))
	(directive (gensym))
	(directives (if lambda-list (car (last lambda-list)) (gensym))))
    `(progn
       (defun ,defun-name (stream ,directive ,directives orig-args args)
	 (declare (ignorable stream orig-args args))
	 ,@(if lambda-list
	       `((let ,(mapcar #'(lambda (var)
				   `(,var
				     (,(intern (concatenate
						'string
						"FORMAT-DIRECTIVE-"
						(symbol-name var))
					       (symbol-package 'foo))
				      ,directive)))
			       (butlast lambda-list))
		   (values (progn ,@body) args)))
	       `((declare (ignore ,directive ,directives))
		 ,@body)))
       (%set-format-directive-interpreter ,char #',defun-name))))

(defmacro def-format-interpreter (char lambda-list &body body)
  (let ((directives (gensym)))
    `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
       ,@body
       ,directives)))

(defmacro interpret-bind-defaults (specs params &body body)
  (once-only ((params params))
    (collect ((bindings))
      (dolist (spec specs)
	(destructuring-bind (var default) spec
	  (bindings `(,var (let* ((param-and-offset (pop ,params))
				  (offset (car param-and-offset))
				  (param (cdr param-and-offset)))
			     (case param
			       (:arg (next-arg offset))
			       (:remaining (length args))
			       ((nil) ,default)
			       (t param)))))))
      `(let* ,(bindings)
	 (when ,params
	   (error 'format-error
		  :complaint
		  "Too many parameters, expected no more than ~D"
		  :arguments (list ,(length specs))
		  :offset (caar ,params)))
	 ,@body))))
556
557
558
559
560
561
562

); eval-when

(defun %set-format-directive-expander (char fn)
  (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
  char)

563
564
565
566
567
568
(defun %set-format-directive-interpreter (char fn)
  (setf (aref *format-directive-interpreters*
	      (char-code (char-upcase char)))
	fn)
  char)

569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
(defun find-directive (directives kind stop-at-semi)
  (if directives
      (let ((next (car directives)))
	(if (format-directive-p next)
	    (let ((char (format-directive-character next)))
	      (if (or (char= kind char)
		      (and stop-at-semi (char= char #\;)))
		  (car directives)
		  (find-directive
		   (cdr (flet ((after (char)
				 (member (find-directive (cdr directives)
							 char
							 nil)
					 directives)))
			  (case char
			    (#\( (after #\)))
			    (#\< (after #\>))
			    (#\[ (after #\]))
			    (#\{ (after #\}))
			    (t directives))))
		   kind stop-at-semi)))
	    (find-directive (cdr directives) kind stop-at-semi)))))

ram's avatar
ram committed
592

593
;;;; Simple outputting noise.
594
595
596
597
598
599
600
601
602
603
604
605

(defun format-write-field (stream string mincol colinc minpad padchar padleft)
  (unless padleft
    (write-string string stream))
  (dotimes (i minpad)
    (write-char padchar stream))
  (do ((chars (+ (length string) minpad) (+ chars colinc)))
      ((>= chars mincol))
    (dotimes (i colinc)
      (write-char padchar stream)))
  (when padleft
    (write-string string stream)))
ram's avatar
ram committed
606

607
608
609
610
611
612
613
614
615
(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
  (format-write-field stream
		      (if (or arg (not colonp))
			  (princ-to-string arg)
			  "()")
		      mincol colinc minpad padchar atsignp))

(def-format-directive #\A (colonp atsignp params)
  (if params
616
617
      (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
			     (padchar #\space))
618
		     params
619
	`(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
620
		       ,mincol ,colinc ,minpad ,padchar))
621
622
623
624
      `(princ ,(if colonp
		   `(or ,(expand-next-arg) "()")
		   (expand-next-arg))
	      stream)))
625
626
627

(def-format-interpreter #\A (colonp atsignp params)
  (if params
628
629
      (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
				(padchar #\space))
630
631
632
633
634
635
636
637
638
639
640
641
642
643
		     params
	(format-princ stream (next-arg) colonp atsignp
		      mincol colinc minpad padchar))
      (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))

(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
  (format-write-field stream
		      (if (or arg (not colonp))
			  (prin1-to-string arg)
			  "()")
		      mincol colinc minpad padchar atsignp))

(def-format-directive #\S (colonp atsignp params)
  (cond (params
644
645
	 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
				(padchar #\space))
646
			params
647
	   `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
648
649
			  ,mincol ,colinc ,minpad ,padchar)))
	(colonp
650
	 `(let ((arg ,(expand-next-arg)))
651
652
653
654
	    (if arg
		(prin1 arg stream)
		(princ "()" stream))))
	(t
655
	 `(prin1 ,(expand-next-arg) stream))))
656
657
658

(def-format-interpreter #\S (colonp atsignp params)
  (cond (params
659
660
	 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
				   (padchar #\space))
661
662
663
664
665
666
667
668
669
670
671
672
673
674
			params
	   (format-prin1 stream (next-arg) colonp atsignp
			 mincol colinc minpad padchar)))
	(colonp
	 (let ((arg (next-arg)))
	   (if arg
	       (prin1 arg stream)
	       (princ "()" stream))))
	(t
	 (prin1 (next-arg) stream))))

(def-format-directive #\C (colonp atsignp params)
  (expand-bind-defaults () params
    (if colonp
675
	`(format-print-named-character ,(expand-next-arg) stream)
676
	(if atsignp
677
678
	    `(prin1 ,(expand-next-arg) stream)
	    `(write-char ,(expand-next-arg) stream)))))
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700

(def-format-interpreter #\C (colonp atsignp params)
  (interpret-bind-defaults () params
    (if colonp
	(format-print-named-character (next-arg) stream)
	(if atsignp
	    (prin1 (next-arg) stream)
	    (write-char (next-arg) stream)))))

(defun format-print-named-character (char stream)
  (let* ((name (char-name char)))
    (cond (name
	   (write-string (string-capitalize name) stream))
	  ((<= 0 (char-code char) 31)
	   ;; Print control characters as "^"<char>
	   (write-char #\^ stream)
	   (write-char (code-char (+ 64 (char-code char))) stream))
	  (t
	   (write-char char stream)))))

(def-format-directive #\W (colonp atsignp params)
  (expand-bind-defaults () params
701
702
703
704
705
706
707
708
    (if (or colonp atsignp)
	`(let (,@(when colonp
		   '((*print-pretty* t)))
	       ,@(when atsignp
		   '((*print-level* nil)
		     (*print-length* nil))))
	   (output-object ,(expand-next-arg) stream))
	`(output-object ,(expand-next-arg) stream))))
709
710
711
712
713
714

(def-format-interpreter #\W (colonp atsignp params)
  (interpret-bind-defaults () params
    (let ((*print-pretty* (or colonp *print-pretty*))
	  (*print-level* (and atsignp *print-level*))
	  (*print-length* (and atsignp *print-length*)))
715
      (output-object (next-arg) stream))))
716
717
718
719


;;;; Integer outputting.

720
;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
ram's avatar
ram committed
721
;;; directives.  The parameters are interpreted as defined for ~D.
722
;;;
wlott's avatar
wlott committed
723
(defun format-print-integer (stream number print-commas-p print-sign-p
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
			     radix mincol padchar commachar commainterval)
  (let ((*print-base* radix)
	(*print-radix* nil))
    (if (integerp number)
	(let* ((text (princ-to-string (abs number)))
	       (commaed (if print-commas-p
			    (format-add-commas text commachar commainterval)
			    text))
	       (signed (cond ((minusp number)
			      (concatenate 'string "-" commaed))
			     (print-sign-p
			      (concatenate 'string "+" commaed))
			     (t commaed))))
	  ;; colinc = 1, minpad = 0, padleft = t
	  (format-write-field stream signed mincol 1 0 padchar t))
	(princ number))))

(defun format-add-commas (string commachar commainterval)
  (let ((length (length string)))
    (multiple-value-bind (commas extra)
			 (truncate (1- length) commainterval)
      (let ((new-string (make-string (+ length commas)))
	    (first-comma (1+ extra)))
	(replace new-string string :end1 first-comma :end2 first-comma)
	(do ((src first-comma (+ src commainterval))
	     (dst first-comma (+ dst commainterval 1)))
	    ((= src length))
	  (setf (schar new-string dst) commachar)
	  (replace new-string string :start1 (1+ dst)
		   :start2 src :end2 (+ src commainterval)))
	new-string))))
ram's avatar
ram committed
755

756
757
(defun expand-format-integer (base colonp atsignp params)
  (if (or colonp atsignp params)
758
      (expand-bind-defaults
759
760
	  ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
	  params
761
762
763
764
765
	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
			       ,base ,mincol ,padchar ,commachar
			       ,commainterval))
      `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
	      :escape nil)))
766
767
768
769
770
771
772
773
774

(defmacro interpret-format-integer (base)
  `(if (or colonp atsignp params)
       (interpret-bind-defaults
	   ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
	   params
	 (format-print-integer stream (next-arg) colonp atsignp ,base mincol
			       padchar commachar commainterval))
       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
ram's avatar
ram committed
775

776
777
778
(def-format-directive #\D (colonp atsignp params)
  (expand-format-integer 10 colonp atsignp params))

779
780
781
(def-format-interpreter #\D (colonp atsignp params)
  (interpret-format-integer 10))

782
783
784
(def-format-directive #\B (colonp atsignp params)
  (expand-format-integer 2 colonp atsignp params))

785
786
787
(def-format-interpreter #\B (colonp atsignp params)
  (interpret-format-integer 2))

788
789
790
(def-format-directive #\O (colonp atsignp params)
  (expand-format-integer 8 colonp atsignp params))

791
792
793
(def-format-interpreter #\O (colonp atsignp params)
  (interpret-format-integer 8))

794
795
796
(def-format-directive #\X (colonp atsignp params)
  (expand-format-integer 16 colonp atsignp params))

797
798
799
(def-format-interpreter #\X (colonp atsignp params)
  (interpret-format-integer 16))

800
801
(def-format-directive #\R (colonp atsignp params)
  (if params
802
      (expand-bind-defaults
803
804
805
	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
	   (commainterval 3))
	  params
806
807
	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
			       ,base ,mincol
808
809
810
			       ,padchar ,commachar ,commainterval))
      (if atsignp
	  (if colonp
811
812
	      `(format-print-old-roman stream ,(expand-next-arg))
	      `(format-print-roman stream ,(expand-next-arg)))
813
	  (if colonp
814
815
	      `(format-print-ordinal stream ,(expand-next-arg))
	      `(format-print-cardinal stream ,(expand-next-arg))))))
816

817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
(def-format-interpreter #\R (colonp atsignp params)
  (if params
      (interpret-bind-defaults
	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
	   (commainterval 3))
	  params
	(format-print-integer stream (next-arg) colonp atsignp base mincol
			      padchar commachar commainterval))
      (if atsignp
	  (if colonp
	      (format-print-old-roman stream (next-arg))
	      (format-print-roman stream (next-arg)))
	  (if colonp
	      (format-print-ordinal stream (next-arg))
	      (format-print-cardinal stream (next-arg))))))


(defconstant cardinal-ones
  #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))

(defconstant cardinal-tens
  #(nil nil "twenty" "thirty" "forty"
	"fifty" "sixty" "seventy" "eighty" "ninety"))

(defconstant cardinal-teens
  #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
    "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))

(defconstant cardinal-periods
  #("" " thousand" " million" " billion" " trillion" " quadrillion"
    " quintillion" " sextillion" " septillion" " octillion" " nonillion"
    " decillion"))

(defconstant ordinal-ones
  #(nil "first" "second" "third" "fourth"
	"fifth" "sixth" "seventh" "eighth" "ninth")
  "Table of ordinal ones-place digits in English")

(defconstant ordinal-tens 
  #(nil "tenth" "twentieth" "thirtieth" "fortieth"
	"fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
  "Table of ordinal tens-place digits in English")

(defun format-print-small-cardinal (stream n)
  (multiple-value-bind 
      (hundreds rem) (truncate n 100)
    (when (plusp hundreds)
      (write-string (svref cardinal-ones hundreds) stream)
      (write-string " hundred" stream)
      (when (plusp rem)
	(write-char #\space stream)))
    (when (plusp rem)
      (multiple-value-bind (tens ones)
			   (truncate rem 10)
       (cond ((< 1 tens)
	      (write-string (svref cardinal-tens tens) stream)
	      (when (plusp ones)
		(write-char #\- stream)
		(write-string (svref cardinal-ones ones) stream)))
	     ((= tens 1)
	      (write-string (svref cardinal-teens ones) stream))
	     ((plusp ones)
	      (write-string (svref cardinal-ones ones) stream)))))))

(defun format-print-cardinal (stream n)
  (cond ((minusp n)
	 (write-string "negative " stream)
	 (format-print-cardinal-aux stream (- n) 0 n))
	((zerop n)
	 (write-string "zero" stream))
	(t
	 (format-print-cardinal-aux stream n 0 n))))

(defun format-print-cardinal-aux (stream n period err)
  (multiple-value-bind (beyond here) (truncate n 1000)
    (unless (<= period 10)
      (error "Number too large to print in English: ~:D" err))
    (unless (zerop beyond)
      (format-print-cardinal-aux stream beyond (1+ period) err))
    (unless (zerop here)
      (unless (zerop beyond)
	(write-char #\space stream))
      (format-print-small-cardinal stream here)
      (write-string (svref cardinal-periods period) stream))))

(defun format-print-ordinal (stream n)
  (when (minusp n)
    (write-string "negative " stream))
  (let ((number (abs n)))
    (multiple-value-bind
	(top bot) (truncate number 100)
      (unless (zerop top)
	(format-print-cardinal stream (- number bot)))
      (when (and (plusp top) (plusp bot))
	(write-char #\space stream))
      (multiple-value-bind
	  (tens ones) (truncate bot 10)
	(cond ((= bot 12) (write-string "twelfth" stream))
	      ((= tens 1)
	       (write-string (svref cardinal-teens ones) stream);;;RAD
	       (write-string "th" stream))
	      ((and (zerop tens) (plusp ones))
	       (write-string (svref ordinal-ones ones) stream))
	      ((and (zerop ones)(plusp tens))
	       (write-string (svref ordinal-tens tens) stream))
	      ((plusp bot)
	       (write-string (svref cardinal-tens tens) stream)
	       (write-char #\- stream)
	       (write-string (svref ordinal-ones ones) stream))
	      ((plusp number)
	       (write-string "th" stream))
	      (t
	       (write-string "zeroeth" stream)))))))

;;; Print Roman numerals

(defun format-print-old-roman (stream n)
  (unless (< 0 n 5000)
    (error "Number too large to print in old Roman numerals: ~:D" n))
  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
       (val-list '(500 100 50 10 5 1) (cdr val-list))
       (cur-char #\M (car char-list))
       (cur-val 1000 (car val-list))
       (start n (do ((i start (progn
				(write-char cur-char stream)
				(- i cur-val))))
		    ((< i cur-val) i))))
      ((zerop start))))

(defun format-print-roman (stream n)
  (unless (< 0 n 4000)
    (error "Number too large to print in Roman numerals: ~:D" n))
  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
       (val-list '(500 100 50 10 5 1) (cdr val-list))
       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
       (cur-char #\M (car char-list))
       (cur-val 1000 (car val-list))
       (cur-sub-char #\C (car sub-chars))
       (cur-sub-val 100 (car sub-val))
       (start n (do ((i start (progn
				(write-char cur-char stream)
				(- i cur-val))))
		    ((< i cur-val)
		     (cond ((<= (- cur-val cur-sub-val) i)
			    (write-char cur-sub-char stream)
			    (write-char cur-char stream)
			    (- i (- cur-val cur-sub-val)))
			   (t i))))))
	  ((zerop start))))


;;;; Plural.

(def-format-directive #\P (colonp atsignp params end)
  (expand-bind-defaults () params
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
    (let ((arg (cond
		((not colonp)
		 (expand-next-arg))
		(*orig-args-available*
		 `(if (eq orig-args args)
		      (error 'format-error
			     :complaint "No previous argument."
			     :offset ,(1- end))
		      (do ((arg-ptr orig-args (cdr arg-ptr)))
			  ((eq (cdr arg-ptr) args)
			   (car arg-ptr)))))
		(*only-simple-args*
		 (unless *simple-args*
		   (error 'format-error
			  :complaint "No previous argument."))
		 (caar *simple-args*))
		(t
		 (throw 'need-orig-args nil)))))
991
992
993
994
      (if atsignp
	  `(write-string (if (eql ,arg 1) "y" "ies") stream)
	  `(unless (eql ,arg 1) (write-char #\s stream))))))

995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
(def-format-interpreter #\P (colonp atsignp params)
  (interpret-bind-defaults () params
    (let ((arg (if colonp
		   (if (eq orig-args args)
		       (error 'format-error
			      :complaint "No previous argument.")
		       (do ((arg-ptr orig-args (cdr arg-ptr)))
			   ((eq (cdr arg-ptr) args)
			    (car arg-ptr))))
		   (next-arg))))
      (if atsignp
	  (write-string (if (eql arg 1) "y" "ies") stream)
	  (unless (eql arg 1) (write-char #\s stream))))))
1008

1009
1010

;;;; Floating point noise.
1011

1012
1013
1014
(defun decimal-string (n)
  (write-to-string n :base 10 :radix nil :escape nil))

1015
1016
1017
1018
1019
(def-format-directive #\F (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
1020
  (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
1021
    `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
1022

1023
1024
1025
1026
1027
(def-format-interpreter #\F (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
1028
1029
  (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
			   params
1030
1031
    (format-fixed stream (next-arg) w d k ovf pad atsignp)))

1032
1033
1034
1035
1036
1037
1038
(defun format-fixed (stream number w d k ovf pad atsign)
  (if (floatp number)
      (format-fixed-aux stream number w d k ovf pad atsign)
      (if (rationalp number)
	  (format-fixed-aux stream
			    (coerce number 'single-float)
			    w d k ovf pad atsign)
1039
1040
1041
	  (format-write-field stream
			      (decimal-string number)
			      w 1 0 #\space t))))
ram's avatar
ram committed
1042

1043
1044
1045
;;; We return true if we overflowed, so that ~G can output the overflow char
;;; instead of spaces.
;;;
1046
(defun format-fixed-aux (stream number w d k ovf pad atsign)
1047
1048
  (cond
   ((not (or w d))
1049
    (prin1 number stream)
1050
1051
1052
1053
1054
1055
    nil)
   (t
    (let ((spaceleft w))
      (when (and w (or atsign (minusp number))) (decf spaceleft))
      (multiple-value-bind 
	  (str len lpoint tpoint)
1056
	  (lisp::flonum-to-string (abs number) spaceleft d k)
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
	;;if caller specifically requested no fraction digits, suppress the
	;;optional trailing zero
	(when (and d (zerop d)) (setq tpoint nil))
	(when w 
	  (decf spaceleft len)
	  ;;optional leading zero
	  (when lpoint
	    (if (or (> spaceleft 0) tpoint) ;force at least one digit
		(decf spaceleft)
		(setq lpoint nil)))
ram's avatar
ram committed
1067
	  ;;optional trailing zero
1068
1069
1070
1071
1072
1073
	  (when tpoint
	    (if (> spaceleft 0)
		(decf spaceleft)
		(setq tpoint nil))))
	(cond ((and w (< spaceleft 0) ovf)
	       ;;field width overflow
1074
	       (dotimes (i w) (write-char ovf stream))
1075
1076
	       t)
	      (t
1077
	       (when w (dotimes (i spaceleft) (write-char pad stream)))
1078
	       (if (minusp number)
1079
1080
1081
1082
1083
		   (write-char #\- stream)
		   (if atsign (write-char #\+ stream)))
	       (when lpoint (write-char #\0 stream))
	       (write-string str stream)
	       (when tpoint (write-char #\0 stream))
1084
	       nil)))))))
ram's avatar
ram committed
1085

1086
1087
1088
1089
1090
(def-format-directive #\E (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
1091
1092
1093
  (expand-bind-defaults
      ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
      params
1094
    `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
1095
1096
1097
1098
1099
1100
1101
1102
			 ,atsignp)))

(def-format-interpreter #\E (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
  (interpret-bind-defaults
1103
1104
      ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
      params
1105
    (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
1106
1107
1108
1109
1110
1111
1112
1113

(defun format-exponential (stream number w d e k ovf pad marker atsign)
  (if (floatp number)
      (format-exp-aux stream number w d e k ovf pad marker atsign)
      (if (rationalp number)
	  (format-exp-aux stream
			  (coerce number 'single-float)
			  w d e k ovf pad marker atsign)
1114
1115
1116
	  (format-write-field stream
			      (decimal-string number)
			      w 1 0 #\space t))))
ram's avatar
ram committed
1117
1118
1119

(defun format-exponent-marker (number)
  (if (typep number *read-default-float-format*)
1120
      #\e
ram's avatar
ram committed
1121
      (typecase number
1122
1123
1124
	(single-float #\f)
	(double-float #\d)
	(short-float #\s)
1125
	(long-float #\l))))
ram's avatar
ram committed
1126
1127
1128
1129
1130
1131
1132
1133

;;;Here we prevent the scale factor from shifting all significance out of
;;;a number to the right.  We allow insignificant zeroes to be shifted in
;;;to the left right, athough it is an error to specify k and d such that this
;;;occurs.  Perhaps we should detect both these condtions and flag them as
;;;errors.  As for now, we let the user get away with it, and merely guarantee
;;;that at least one significant digit will appear.

1134
(defun format-exp-aux (stream number w d e k ovf pad marker atsign)
ram's avatar
ram committed
1135
  (if (not (or w d))
1136
      (prin1 number stream)
ram's avatar
ram committed
1137
      (multiple-value-bind (num expt)
1138
			   (lisp::scale-exponent (abs number))
ram's avatar
ram committed
1139
	(let* ((expt (- expt k))
1140
	       (estr (decimal-string (abs expt)))
ram's avatar
ram committed
1141
1142
1143
1144
1145
	       (elen (if e (max (length estr) e) (length estr)))
	       (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
	       (fmin (if (minusp k) (- 1 k) nil))
	       (spaceleft (if w (- w 2 elen) nil)))
	  (when (or atsign (minusp number)) (decf spaceleft))
1146
	  (if (and w ovf e (> elen e)) ;exponent overflow
1147
1148
1149
1150
	      (dotimes (i w) (write-char ovf stream))
	      (multiple-value-bind
		  (fstr flen lpoint)
		  (lisp::flonum-to-string num spaceleft fdig k fmin)
ram's avatar
ram committed
1151
1152
1153
1154
1155
1156
1157
1158
		(when w 
		  (decf spaceleft flen)
		  (when lpoint
		    (if (> spaceleft 0)
			(decf spaceleft)
			(setq lpoint nil))))
		(cond ((and w (< spaceleft 0) ovf)
		       ;;significand overflow
1159
		       (dotimes (i w) (write-char ovf stream)))
ram's avatar
ram committed
1160
		      (t (when w
1161
			   (dotimes (i spaceleft) (write-char pad stream)))
ram's avatar
ram committed
1162
			 (if (minusp number)
1163
1164
1165
1166
			     (write-char #\- stream)
			     (if atsign (write-char #\+ stream)))
			 (when lpoint (write-char #\0 stream))
			 (write-string fstr stream)
ram's avatar
ram committed
1167
1168
			 (write-char (if marker
					 marker
1169
1170
1171
					 (format-exponent-marker number))
				     stream)
			 (write-char (if (minusp expt) #\- #\+) stream)
ram's avatar
ram committed
1172
1173
			 (when e 
			   ;;zero-fill before exponent if necessary
1174
1175
1176
1177
1178
1179
1180
1181
1182
			   (dotimes (i (- e (length estr)))
			     (write-char #\0 stream)))
			 (write-string estr stream)))))))))

(def-format-directive #\G (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
1183
  (expand-bind-defaults
1184
1185
      ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
      params
1186
    `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
1187

1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
(def-format-interpreter #\G (colonp atsignp params)
  (when colonp
    (error 'format-error
	   :complaint
	   "Cannot specify the colon modifier with this directive."))
  (interpret-bind-defaults
      ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
      params
    (format-general stream (next-arg) w d e k ovf pad mark atsignp)))

1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
(defun format-general (stream number w d e k ovf pad marker atsign)
  ;;The Excelsior edition does not say what to do if
  ;;the argument is not a float.  Here, we adopt the
  ;;conventions used by ~F and ~E.
  (if (floatp number)
      (format-general-aux stream number w d e k ovf pad marker atsign)
      (if (rationalp number)
	  (format-general-aux stream
			      (coerce number 'single-float)
			      w d e k ovf pad marker atsign)
1208
1209
1210
	  (format-write-field stream
			      (decimal-string number)
			      w 1 0 #\space t))))
ram's avatar
ram committed
1211

1212
(defun format-general-aux (stream number w d e k ovf pad marker atsign)
ram's avatar
ram committed
1213
  (multiple-value-bind (ignore n) 
1214
		       (lisp::scale-exponent (abs number))
ram's avatar
ram committed
1215
1216
1217
1218
1219
1220
1221
    (declare (ignore ignore))
    ;;Default d if omitted.  The procedure is taken directly
    ;;from the definition given in the manual, and is not
    ;;very efficient, since we generate the digits twice.
    ;;Future maintainers are encouraged to improve on this.
    (unless d
      (multiple-value-bind (str len) 
1222
			   (lisp::flonum-to-string (abs number))
ram's avatar
ram committed
1223
1224
1225
1226
1227
1228
1229
	(declare (ignore str))
	(let ((q (if (= len 1) 1 (1- len))))
	  (setq d (max q (min n 7))))))
    (let* ((ee (if e (+ e 2) 4))
	   (ww (if w (- w ee) nil))
	   (dd (- d n)))
      (cond ((<= 0 dd d)
1230
1231
	     (let ((char (if (format-fixed-aux stream number ww dd nil
					       ovf pad atsign)
1232
1233
			     ovf
			     #\space)))
1234
	       (dotimes (i ee) (write-char char stream))))
1235
	    (t
1236
1237
1238
1239
	     (format-exp-aux stream number w d e (or k 1)
			     ovf pad marker atsign))))))

(def-format-directive #\$ (colonp atsignp params)
1240
  (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
1241
1242
    `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
		     ,atsignp)))
1243

1244
1245
1246
1247
(def-format-interpreter #\$ (colonp atsignp params)
  (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
    (format-dollars stream (next-arg) d n w pad colonp atsignp)))

1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
(defun format-dollars (stream number d n w pad colon atsign)
  (if (rationalp number) (setq number (coerce number 'single-float)))
  (if (floatp number)
      (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
	     (signlen (length signstr)))
	(multiple-value-bind (str strlen ig2 ig3 pointplace)
			     (lisp::flonum-to-string number nil d nil)
	  (declare (ignore ig2 ig3))
	  (when colon (write-string signstr stream))
	  (dotimes (i (- w signlen (- n pointplace) strlen))
	    (write-char pad stream))
	  (unless colon (write-string signstr stream))
	  (dotimes (i (- n pointplace)) (write-char #\0 stream))
	  (write-string str stream)))
1262
1263
1264
      (format-write-field stream
			  (decimal-string number)
			  w 1 0 #\space t)))
1265

1266
1267
1268

;;;; line/page breaks and other stuff like that.

1269
1270
1271
1272
1273
1274
(def-format-directive #\% (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
1275
      (expand-bind-defaults ((count 1)) params
1276
1277
1278
1279
	`(dotimes (i ,count)
	   (terpri stream)))
      '(terpri stream)))

1280
1281
1282
1283
1284
1285
1286
1287
1288
(def-format-interpreter #\% (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (interpret-bind-defaults ((count 1)) params
    (dotimes (i count)
      (terpri stream))))

1289
1290
1291
1292
1293
1294
(def-format-directive #\& (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
1295
      (expand-bind-defaults ((count 1)) params
1296
1297
1298
1299
1300
1301
	`(progn
	   (fresh-line stream)
	   (dotimes (i (1- ,count))
	     (terpri stream))))
      '(fresh-line stream)))

1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
(def-format-interpreter #\& (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (interpret-bind-defaults ((count 1)) params
    (fresh-line stream)
    (dotimes (i (1- count))
      (terpri stream))))

1312
1313
1314
1315
1316
1317
(def-format-directive #\| (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
1318
      (expand-bind-defaults ((count 1)) params
1319
1320
1321
1322
	`(dotimes (i ,count)
	   (write-char #\page stream)))
      '(write-char #\page stream)))

1323
1324
1325
1326
1327
1328
1329
1330
1331
(def-format-interpreter #\| (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (interpret-bind-defaults ((count 1)) params
    (dotimes (i count)
      (write-char #\page stream))))

1332
1333
1334
1335
1336
1337
(def-format-directive #\~ (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (if params
1338
      (expand-bind-defaults ((count 1)) params
1339
1340
1341
1342
	`(dotimes (i ,count)
	   (write-char #\~ stream)))
      '(write-char #\~ stream)))

1343
1344
1345
1346
1347
1348
1349
1350
1351
(def-format-interpreter #\~ (colonp atsignp params)
  (when (or colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify either colon or atsign for this directive."))
  (interpret-bind-defaults ((count 1)) params
    (dotimes (i count)
      (write-char #\~ stream))))

1352
1353
1354
1355
1356
(def-complex-format-directive #\newline (colonp atsignp params directives)
  (when (and colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify both colon and atsign for this directive."))
1357
  (values (expand-bind-defaults () params
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
	    (if atsignp
		'(write-char #\newline stream)
		nil))
	  (if (and (not colonp)
		   directives
		   (simple-string-p (car directives)))
	      (cons (string-left-trim '(#\space #\newline #\tab)
				      (car directives))
		    (cdr directives))
	      directives)))

1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
(def-complex-format-interpreter #\newline (colonp atsignp params directives)
  (when (and colonp atsignp)
    (error 'format-error
	   :complaint
	   "Cannot specify both colon and atsign for this directive."))
  (interpret-bind-defaults () params
    (when atsignp
      (write-char #\newline stream)))
  (if (and (not colonp)
	   directives
	   (simple-string-p (car directives)))
      (cons (string-left-trim '(#\space #\newline #\tab)
			      (car directives))
	    (cdr directives))
      directives))


;;;; Tab and simple pretty-printing noise.

1388
1389
(def-format-directive #\T (colonp atsignp params)
  (if colonp
1390
      (expand-bind-defaults ((n 1) (m 1)) params
1391
1392
1393
	`(pprint-tab ,(if atsignp :section-relative :section)
		     ,n ,m stream))
      (if atsignp
1394
	  (expand-bind-defaults ((colrel 1) (colinc 1)) params
1395
	    `(format-relative-tab stream ,colrel ,colinc))
1396
	  (expand-bind-defaults ((colnum 1) (colinc 1)) params
1397
1398
	    `(format-absolute-tab stream ,colnum ,colinc)))))

1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
(def-format-interpreter #\T (colonp atsignp params)
  (if colonp
      (interpret-bind-defaults ((n 1) (m 1)) params
	(pprint-tab (if atsignp :section-relative :section) n m stream))
      (if atsignp
	  (interpret-bind-defaults ((colrel 1) (colinc 1)) params
	    (format-relative-tab stream colrel colinc))
	  (interpret-bind-defaults ((colnum 1) (colinc 1)) params
	    (format-absolute-tab stream colnum colinc)))))

(defun output-spaces (stream n)
  (let ((spaces #.(make-string 100 :initial-element #\space)))
    (loop
      (when (< n (length spaces))
	(return))
      (write-string spaces stream)
      (decf n (length spaces)))
    (write-string spaces stream :end n)))

(defun format-relative-tab (stream colrel colinc)
1419
1420
1421
1422
1423
1424
1425
  (if (pp:pretty-stream-p stream)
      (pprint-tab :line-relative colrel colinc stream)
      (let* ((cur (lisp::charpos stream))
	     (spaces (if (and cur (plusp colinc))
			 (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
			 colrel)))
	(output-spaces stream spaces))))
1426
1427

(defun format-absolute-tab (stream colnum colinc)
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
  (if (pp:pretty-stream-p stream)
      (pprint-tab :line colnum colinc stream)
      (let ((cur (lisp::charpos stream)))
	(cond ((null cur)
	       (write-string "  " stream))
	      ((< cur colnum)
	       (output-spaces stream (- colnum cur)))
	      (t
	       (unless (zerop colinc)
		 (output-spaces stream (- colinc (rem cur colinc)))))))))
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478

(def-format-directive #\_ (colonp atsignp params)
  (expand-bind-defaults () params
    `(pprint-newline ,(if colonp
			  (if atsignp
			      :mandatory
			      :fill)
			  (if atsignp
			      :miser
			      :linear))
		     stream)))

(def-format-interpreter #\_ (colonp atsignp params)
  (interpret-bind-defaults () params
    (pprint-newline (if colonp
			(if atsignp
			    :mandatory
			    :fill)
			(if atsignp
			    :miser
			    :linear))
		    stream)))

(def-format-directive #\I (colonp atsignp params)
  (when atsignp
    (error 'format-error
	   :complaint "Cannot specify the at-sign modifier."))
  (expand-bind-defaults ((n 0)) params
    `(pprint-indent ,(if colonp :current :block) ,n stream)))

(def-format-interpreter #\I (colonp atsignp params)
  (when atsignp
    (error 'format-error
	   :complaint "Cannot specify the at-sign modifier."))
  (interpret-bind-defaults ((n 0)) params
    (pprint-indent (if colonp :current :block) n stream)))


;;;; *

(def-format-directive #\* (colonp atsignp params end)
1479
1480
1481
1482
  (if atsignp
      (if colonp
	  (error 'format-error
		 :complaint "Cannot specify both colon and at-sign.")
1483
	  (expand-bind-defaults ((posn 0)) params
1484
1485
	    (unless *orig-args-available*
	      (throw 'need-orig-args nil))