/
format.lisp
2582 lines (2466 loc) · 123 KB
/
format.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
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
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
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
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
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
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
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
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
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
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;; FORMAT - and company.
;; Bruno Haible 22.06.1988
;; CLISP-Version 16.08.1988, 03.09.1988, 04.08.1989
;; Major revision by Bruno Haible 14.02.1990-15.02.1990
;; Further revised and wrote FORMATTER 9.4.1995-11.4.1995
;; German comments translated into English: Stefan Kain 2001-09-09
;; formatter pprint-logical-block ~:> support: John Boyland 2003
;; Sam Steingold 1999-2009
;; FORMAT is a mechanism for producing string output conveniently by,
;; basically, taking a pre-determined string with placeholders and
;; substituting computed values or strings for those placeholders --
;; though it became much more complex than this because the placeholders
;; included iteration primitives for producing lists of results,
;; plurals, and other such exotica. It may be loosely characterized as
;; FORTRAN FORMAT statements gone berserk.
;; -- Guy L. Steele Jr. and Richard P. Gabriel in "The Evolution of Lisp"
(in-package "SYSTEM")
;;; ---------------------------------------------------------------------------
;; data-structure of control-string-directives:
(defstruct (control-string-directive
(:copier nil)
(:conc-name "CSD-")
(:predicate nil)
(:constructor make-csd ()))
(type 0 :type fixnum)
(cs-index 0 :type fixnum)
(parm-list nil :type list)
(v-or-#-p nil :type symbol)
(colon-p nil :type symbol)
(atsign-p nil :type symbol)
(data nil)
(clause-chain nil))
;; Explanation:
;; type=0: directive ~<Newline>, nothing to print.
;; further components are meaningless
;; type=1: String to be printed,
;; from *FORMAT-CS* the portion :START cs-index :END data.
;; further components are meaningless
;; type=2: execute format-directive.
;; data = name of directive (Symbol),
;; colon-p states, if there was a ':' ,
;; atsign-p states, if there was a '@' ,
;; parm-list = parameter-list for the directive,
;; v-or-#-p states, if parm-list is to be processed before the call.
;; clause-chain is a chain of pointers: e.g. ~[...~;...~;...~]
;; pointer from the ~[-directive to the list at the first ~;-directive,
;; from there to the list at the next ~;-directive and so on.
;; until eventually to the list at the ~]-directive.
;; check whether the character is a whitespace character. -- see io.d
;; (defun whitespacep (char)
;; (member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
;; (case char
;; ((#\Space #\Newline #\Linefeed #\Tab #\Return #\Page) t)
;; (t nil)))
;; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
;; parses a control-string (exactly: (subseq control-string startindex))
;; and stores the resulting control-string-directive list in (cdr csdl) .
;; The parsing must end with the directive stop-at (a Character, or NIL
;; for the end of the String).
;; If stop-at /= NIL, a pointer to the sublist at the next separator is to
;; be stored in (csd-clause-chain (car csdl)). These pointers form
;; a simple list within csdl: from one Separator to the
;; next, finally to the end of the Clause.
(defun format-parse-cs (control-string startindex csdl stop-at)
(declare (fixnum startindex))
(macrolet ((errorstring ()
(TEXT "The control string terminates within a format directive.")))
(prog* ((index startindex) ; cs-index of the next character
ch ; current character
intparam ; Integer-Parameter
newcsd ; current CSD
(last-separator-csd (car csdl)))
(declare (type simple-string control-string) (type fixnum index))
(loop ; new directive altogether
(tagbody
(when (>= index (length control-string))
(go string-ended))
(setq ch (schar control-string index))
(unless (eql ch #\~)
;; possibly transform part of string into a separate directive,
(setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
(setf (csd-type newcsd) 1)
(setf (csd-cs-index newcsd) index)
(setq index (position #\~ control-string :start index))
(unless index
(setf (csd-data newcsd) (setq index (length control-string)))
(go string-ended))
(setf (csd-data newcsd) index))
(setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
(setf (csd-type newcsd) 2)
(setf (csd-cs-index newcsd) index)
(setf (csd-parm-list newcsd) nil)
(setf (csd-v-or-#-p newcsd) nil)
(setf (csd-colon-p newcsd) nil)
(setf (csd-atsign-p newcsd) nil)
(setf (csd-data newcsd) nil)
(setf (csd-clause-chain newcsd) nil)
param ; parameter of a directive may begin
(incf index)
(when (>= index (length control-string))
(format-error 'error control-string index (errorstring))
(go string-ended))
(setq ch (schar control-string index))
(when (digit-char-p ch) (go num-param))
(case ch
((#\+ #\-) (go num-param))
(#\' (go quote-param))
((#\V #\v #\#)
(push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
(csd-parm-list newcsd))
(setf (csd-v-or-#-p newcsd) T)
(go param-ok-1))
(#\, (push nil (csd-parm-list newcsd)) (go param))
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive)))
num-param ; numerical parameter
(multiple-value-setq (intparam index)
(parse-integer control-string :start index :junk-allowed t))
(unless intparam
(format-error 'error control-string index
(TEXT "~A must introduce a number.")
ch))
(push intparam (csd-parm-list newcsd))
(go param-ok-2)
quote-param ; Quote-Parameter-Treatment
(incf index)
(when (>= index (length control-string))
(format-error 'error control-string index
(TEXT "The control string terminates in the middle of a parameter."))
(go string-ended))
(setq ch (schar control-string index))
(push ch (csd-parm-list newcsd))
param-ok-1 ; Parameter OK
(incf index)
param-ok-2 ; Parameter OK
(when (>= index (length control-string))
(format-error 'error control-string index (errorstring))
(go string-ended))
(setq ch (schar control-string index))
(case ch
(#\, (go param))
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive)))
colon-modifier ; after :
(setf (csd-colon-p newcsd) T)
(go passed-modifier)
atsign-modifier ; after @
(setf (csd-atsign-p newcsd) T)
(go passed-modifier)
passed-modifier ; after : or @
(incf index)
(when (>= index (length control-string))
(format-error 'error control-string index (errorstring))
(go string-ended))
(setq ch (schar control-string index))
(case ch
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive)))
directive ; directive (its Name) reached
(setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
(let ((directive-name
(cdr (assoc (char-upcase ch)
; with function-definition ; without function-definition
'((#\A . FORMAT-ASCII)
(#\S . FORMAT-S-EXPRESSION)
(#\W . FORMAT-WRITE)
(#\D . FORMAT-DECIMAL)
(#\B . FORMAT-BINARY)
(#\O . FORMAT-OCTAL)
(#\X . FORMAT-HEXADECIMAL)
(#\R . FORMAT-RADIX)
(#\P . FORMAT-PLURAL)
(#\C . FORMAT-CHARACTER)
(#\F . FORMAT-FIXED-FLOAT)
(#\E . FORMAT-EXPONENTIAL-FLOAT)
(#\G . FORMAT-GENERAL-FLOAT)
(#\$ . FORMAT-DOLLARS-FLOAT)
(#\% . FORMAT-TERPRI)
(#\_ . FORMAT-PPRINT-NEWLINE)
(#\I . FORMAT-PPRINT-INDENT)
(#\& . FORMAT-FRESH-LINE) (#\Newline . #\Newline)
(#\| . FORMAT-PAGE)
(#\~ . FORMAT-TILDE)
(#\T . FORMAT-TABULATE)
(#\* . FORMAT-GOTO)
(#\? . FORMAT-INDIRECTION)
(#\/ . FORMAT-CALL-USER-FUNCTION)
(#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
(#\[ . FORMAT-CONDITIONAL) (#\] . FORMAT-CONDITIONAL-END)
(#\{ . FORMAT-ITERATION) (#\} . FORMAT-ITERATION-END)
(#\< . FORMAT-JUSTIFICATION) (#\> . FORMAT-JUSTIFICATION-END)
(#\^ . FORMAT-UP-AND-OUT) (#\; . FORMAT-SEPARATOR)
(#\! . FORMAT-CALL)
(#\. . FORMAT-ELASTIC-NEWLINE))))))
(if directive-name
(setf (csd-data newcsd) directive-name)
(format-error 'error control-string index
(TEXT "Non-existent format directive"))))
(incf index)
(case ch
(#\/
(let* ((start index)
(end (or (position #\/ control-string :start start)
(format-error 'error control-string index
(TEXT "Closing '/' is missing"))))
(pos (position #\: control-string :start start :end end))
(name (string-upcase
(subseq control-string
(if pos
(if (char= #\: (char control-string (1+ pos))) (+ 2 pos) (1+ pos))
start)
end)))
(pack (if pos
(let ((packname
(string-upcase
(subseq control-string start pos))))
(or (find-package packname)
(format-error 'error control-string index
(TEXT "There is no package with name ~S")
packname)))
*common-lisp-user-package*)))
(push (list (intern name pack)) (csd-parm-list newcsd))
(setq index (1+ end))))
(( #\( #\[ #\{)
(multiple-value-setq (index csdl)
(format-parse-cs control-string index csdl
(case ch (#\( #\)) (#\[ #\]) (#\{ #\}) ))))
(#\<
(multiple-value-setq (index csdl)
(format-parse-cs control-string index csdl #\>))
;; (assert (eq (csd-data (car csdl)) 'FORMAT-JUSTIFICATION-END))
(when (csd-colon-p (car csdl))
(setf (csd-data newcsd) 'FORMAT-LOGICAL-BLOCK)))
(( #\) #\] #\} #\> )
(unless stop-at
(format-error 'error control-string index
(TEXT "The closing format directive '~A' does not have a corresponding opening one.")
ch))
(unless (eql ch stop-at)
(format-error 'error control-string index
(TEXT "The closing format directive '~A' does not match the corresponding opening one. It should read '~A'.")
ch stop-at))
(setf (csd-clause-chain last-separator-csd) csdl)
(go end))
(#\;
(unless (or (eql stop-at #\]) (eql stop-at #\>))
(format-error 'error control-string index
(TEXT "The ~~; format directive is not allowed at this point.")))
(setf (csd-clause-chain last-separator-csd) csdl)
(setq last-separator-csd newcsd))
(#\Newline
(setf (csd-type newcsd) 0)
(if (csd-colon-p newcsd)
(if (csd-atsign-p newcsd)
(format-not-both-error "~newline")
nil) ; ~:<newline> -> ignore Newline, retain Whitespace
(progn
(when (csd-atsign-p newcsd)
;; ~@<newline> -> part of String with Newline for output
(setf (csd-type newcsd) 1)
(setf (csd-cs-index newcsd) (1- index))
(setf (csd-data newcsd) index))
(setq index
(or (position-if-not #'whitespacep control-string :start index)
(length control-string)))))))
) ; tagbody finished
) ; loop finished
string-ended
(when stop-at
(format-error 'error control-string index
(TEXT "An opening format directive is never closed; expecting '~A'.")
stop-at))
end
(return (values index csdl)))))
;;; ---------------------------------------------------------------------------
(defvar *FORMAT-CS*) ; control-string
(defvar *FORMAT-CSDL*) ; control-string directive list
(defvar *FORMAT-ARG-LIST*) ; argument-list
(defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
(defvar *FORMAT-NEXT-ARGLIST*) ; pointer to next sublist in ~:{ iteration
(defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out
;; (format-error type {keyword value}* control-string errorpos errorstring . arguments)
;; signals an Error of the given type, that occurred in FORMAT. The position
;; in the Control-string is marked with an arrow.
(defun format-error (type &rest arguments)
(let ((type-initargs '()))
(loop
(unless (keywordp (car arguments)) (return))
(push (pop arguments) type-initargs)
(push (pop arguments) type-initargs))
(let* ((control-string (pop arguments))
(errorpos (pop arguments))
(errorstring (pop arguments)))
(when control-string
(unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
(setq errorstring
(string-concat errorstring "~%"
(TEXT "Current point in control string:")))
(let ((pos1 0) (pos2 0))
(declare (simple-string errorstring) (fixnum pos1 pos2))
(loop
(setq pos2 (or (position #\Newline control-string :start pos1)
(length control-string)))
(setq errorstring (string-concat errorstring "~%~2T~S"))
(setq arguments
(nconc arguments (list (substring control-string pos1 pos2))))
(when (<= pos1 errorpos pos2)
(setq errorstring (string-concat errorstring "~%~VT|"))
(setq arguments (nconc arguments (list (+ (- errorpos pos1) 3)))))
(when (= pos2 (length control-string)) (return))
(setq pos1 (+ pos2 1)))))
(apply #'error-of-type
type (nreconc type-initargs (list* errorstring arguments))))))
(defun format-not-both-error (directive)
(format-error 'error *FORMAT-CS* nil
(TEXT "The ~A format directive cannot take both modifiers.")
directive))
;;; ---------------------------------------------------------------------------
(defun format (destination control-string &rest arguments)
(unless (or (stringp control-string) (functionp control-string))
(format-cs-error control-string))
(cond ((null destination)
(let ((stream (make-string-output-stream)))
(format-apply stream control-string arguments)
(get-output-stream-string stream)))
((eq destination 'T)
(format-apply *standard-output* control-string arguments)
nil)
((streamp destination)
(format-apply destination control-string arguments)
nil)
((stringp destination)
(if (array-has-fill-pointer-p destination)
(let ((stream (sys::make-string-push-stream destination)))
(format-apply stream control-string arguments))
(error-of-type 'error
(TEXT "The destination string ~S should have a fill pointer.")
destination))
nil)
(t (error-of-type 'type-error
:datum destination :expected-type '(or boolean stream string)
(TEXT "The destination argument ~S is invalid (not NIL or T or a stream or a string).")
destination))))
(defun format-apply (stream control-string arguments
&optional (whole-arguments arguments))
(cond ((stringp control-string)
;; possibly convert control-string into Simple-String ??
(let ((node (list control-string)))
(format-parse-cs control-string 0 node nil)
(let* ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
(*FORMAT-ARG-LIST* whole-arguments)
(*FORMAT-NEXT-ARG* arguments)
(*FORMAT-NEXT-ARGLIST* nil)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream)
*FORMAT-NEXT-ARG*)))
((functionp control-string)
(let ((*FORMAT-CS* nil)) ; format-error cannot point to the position anymore
(apply control-string stream arguments)))
(t (format-cs-error control-string))))
(defun format-cs-error (control-string)
(error-of-type 'type-error
:datum control-string :expected-type '(or string function)
(TEXT "~S: The control-string must be a string, not ~S")
'format control-string))
;;; ---------------------------------------------------------------------------
;; (next-arg) returns (and consumes) the next argument from the argument-
;; list *FORMAT-NEXT-ARG*.
(defun next-arg ()
(if (atom *FORMAT-NEXT-ARG*)
(if (null *FORMAT-NEXT-ARG*)
(format-error 'error *FORMAT-CS* nil
(TEXT "There are not enough arguments left for this format directive."))
(format-error 'type-error :datum *FORMAT-NEXT-ARG* :expected-type 'LIST
*FORMAT-CS* nil
(TEXT "The argument list is a dotted list: ~S")
*FORMAT-ARG-LIST*))
(pop *FORMAT-NEXT-ARG*)))
;; (format-interpret stream [endmarker]) interprets *FORMAT-CSDL* .
;; Fluid vars:
;; *FORMAT-ARG-LIST*
;; *FORMAT-NEXT-ARG*
;; *FORMAT-NEXT-ARGLIST*
;; *FORMAT-CS*
;; *FORMAT-CSDL*
;; *FORMAT-UP-AND-OUT*
;; Stop interpretation when arriving at the directive endmarker
;; or the directive ~; .
(defun format-interpret (stream &optional (endmarker nil))
(loop
(when *FORMAT-UP-AND-OUT* (return))
(when (endp *FORMAT-CSDL*) (return))
(let ((csd (car *FORMAT-CSDL*)))
(case (csd-type csd)
(0 )
(1 (write-string *FORMAT-CS* stream
:start (csd-cs-index csd) :end (csd-data csd)))
(2 (let ((directive-name (csd-data csd)))
(if (eq directive-name endmarker) (return))
(if (eq directive-name 'FORMAT-SEPARATOR) (return))
(apply directive-name
stream
(csd-colon-p csd)
(csd-atsign-p csd)
(format-resolve-parms csd))))))
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))))
;; returns the correct argument-list of a CSD, possibly with substituted
;; parameters: V (as :NEXT-ARG) and # (as :ARG-COUNT) are resolved.
(defun format-resolve-parms (csd)
(let ((arglist (csd-parm-list csd)))
(if (csd-v-or-#-p csd)
(mapcar #'(lambda (arg)
(case arg
(:NEXT-ARG (next-arg))
(:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
(T arg)))
arglist)
arglist)))
;; Defines a simple FORMAT-subfunction, i.e. a function that consumes
;; exactly one argument.
(defmacro defformat-simple (name (stream colon atsign . optionals-with-defaults)
(arg) &body body)
(multiple-value-bind (body-rest declarations) (sys::parse-body body)
(let ((name2 (concat-pnames "DO-" name)) ; in #<PACKAGE SYSTEM>
(optionals (mapcar #'(lambda (opt) (if (consp opt) (first opt) opt))
optionals-with-defaults)))
`(PROGN
(DEFUN ,name (,stream ,colon ,atsign &OPTIONAL ,@optionals)
(,name2 ,stream ,colon ,atsign ,@optionals (next-arg)))
(DEFUN ,name2 (,stream ,colon ,atsign ,@optionals ,arg)
,@(if declarations `((DECLARE ,@declarations)))
,@(mapcap #'(lambda (opt)
(if (and (consp opt) (not (null (second opt))))
`((IF (NULL ,(first opt))
(SETQ ,(first opt) ,(second opt))))
'()))
optionals-with-defaults)
,@body-rest)))))
;; Moves the value of "Pointers into the argument-list" in one direction.
(defun format-goto-new-arg (backwardp index)
(if backwardp
;; backwards
(setq *FORMAT-NEXT-ARG*
(nthcdr (max (- (list-length *FORMAT-ARG-LIST*)
(list-length *FORMAT-NEXT-ARG*)
index)
0)
*FORMAT-ARG-LIST*))
;; forwards is easier:
(setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))))
;; prints arg as old-Roman number to stream, e.g. 4 as IIII.
(defun format-old-roman (arg stream)
(unless (and (integerp arg) (<= 1 arg 4999))
(format-error 'type-error :datum arg :expected-type '(INTEGER 1 4999)
*FORMAT-CS* nil
(TEXT "The ~~:@R format directive requires an integer in the range 1 - 4999, not ~S")
arg))
(do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
(valuelistr '(1000 500 100 50 10 5 1) (cdr valuelistr))
(value arg (multiple-value-bind (multiplicity restvalue)
(floor value (first valuelistr))
(dotimes (i multiplicity)
(write-char (first charlistr) stream))
restvalue)))
((zerop value))))
;; prints arg as new-Roman number to stream, e.g. 4 as IV.
(defun format-new-roman (arg stream)
(unless (and (integerp arg) (<= 1 arg 3999))
(format-error 'type-error :datum arg :expected-type '(INTEGER 1 3999)
*FORMAT-CS* nil
(TEXT "The ~~@R format directive requires an integer in the range 1 - 3999, not ~S")
arg))
(do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
(valuelistr '(1000 500 100 50 10 5 1 ) (cdr valuelistr))
(lowercharlistr '(#\C #\C #\X #\X #\I #\I ) (cdr lowercharlistr))
(lowervaluelistr '(100 100 10 10 1 1 0 ) (cdr lowervaluelistr))
(value arg
(multiple-value-bind (multiplicity restvalue)
(floor value (first valuelistr))
(dotimes (i multiplicity) (write-char (first charlistr) stream))
(let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
(if (>= restvalue loweredvalue)
(progn
(write-char (first lowercharlistr) stream)
(write-char (first charlistr) stream)
(- restvalue loweredvalue))
restvalue)))))
((zerop value))))
(defconstant FORMAT-CARDINAL-ONES
'#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
"ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
"seventeen" "eighteen" "nineteen"))
(defconstant FORMAT-CARDINAL-TENS
'#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
"ninety"))
;; (format-small-cardinal arg stream) prints an 0< integer <1000 in
;; plain English to stream. (arg=0 -> on output.)
(defun format-small-cardinal (arg stream)
(multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
(when (> hundreds 0)
(write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
(write-string " hundred" stream))
(when (> tens-and-ones 0)
(when (> hundreds 0) (write-string " and " stream))
(multiple-value-bind (tens ones) (truncate tens-and-ones 10)
(if (< tens 2)
(write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
(progn
(write-string (svref FORMAT-CARDINAL-TENS tens) stream)
(when (> ones 0)
(write-char #\- stream)
(write-string (svref FORMAT-CARDINAL-ONES ones) stream))))))))
;; (format-cardinal arg stream) prints the integer arg in plain English
;; to stream.
(defun format-cardinal (arg stream) ; arg Integer
(if (zerop arg)
(write-string "zero" stream)
(progn
(when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
(labels ((blocks1000 (illions-list arg) ; decomposition in 1000er-Blocks
(when (null illions-list)
(format-error 'type-error :datum arg :expected-type '(INTEGER 0 999999999999999999999999999999999999999999999999999999999999999999)
*FORMAT-CS* nil
(TEXT "The argument for the ~~R format directive is too large.")))
(multiple-value-bind (thousands small) (truncate arg 1000)
(when (> thousands 0)
(blocks1000 (cdr illions-list) thousands))
(when (> small 0)
(when (> thousands 0)
(write-string ", " stream))
(format-small-cardinal small stream)
(write-string (car illions-list) stream)))))
(blocks1000
; American (billion=10^9)
'("" " thousand" " million" " billion" " trillion" " quadrillion"
" quintillion" " sextillion" " septillion" " octillion"
" nonillion" " decillion" " undecillion" " duodecillion"
" tredecillion" " quattuordecillion" " quindecillion"
" sexdecillion" " septendecillion" " octodecillion"
" novemdecillion" " vigintillion")
arg)))))
(defconstant FORMAT-ORDINAL-ONES
'#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
"ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
"fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"))
;; (format-ordinal arg stream) prints an integer arg as an ordinal number in
;; plain English to stream.
(defun format-ordinal (arg stream) ; arg Integer
(if (zerop arg)
(write-string "zeroth" stream)
(progn
(when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
(multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
(when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
(if (zerop tens-and-ones)
(write-string "th" stream)
(multiple-value-bind (tens ones) (floor tens-and-ones 10)
(when (> hundreds 0) (write-char #\Space stream))
(cond ((< tens 2)
(write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream))
((zerop ones)
(write-string
(svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth"
"fiftieth" "sixtieth" "seventieth" "eightieth"
"ninetieth")
tens)
stream))
(t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
(write-char #\- stream)
(write-string (svref FORMAT-ORDINAL-ONES ones)
stream)))))))))
;; (format-padding count char stream) prints count (a Fixnum >=0)
;; characters char to stream.
(defun format-padding (count char stream)
(dotimes (i count) (write-char char stream)))
;; prints to Stream stream:
;; the String str, possibly filled with padding characters padchar.
;; width is at least mincol. In order to achieve that,
;; at least minpad characters are inserted, possibly additional ones in
;; Blocks of colinc characters. if padleftflag, they are inserted on the left,
;; else right of the String.
(defun format-padded-string (mincol colinc minpad padchar padleftflag
str stream)
(let* ((need (+ (string-width str) minpad)) ; it least that number of columns
(auxpad (if (< need mincol)
(* (ceiling (- mincol need) colinc) colinc)
0))) ; this many additional characters
(unless padleftflag (write-string str stream))
(format-padding (+ minpad auxpad) padchar stream)
(when padleftflag (write-string str stream))))
;; prints the Integer arg to Stream:
;; in Base base, with sign (+ only if >=0 and positive-sign-flag), with
;; commaflag, every three digits are separated by the character
;; commachar. fill on the left with padchar's, so that the total width
;; is at least mincol.
(defun format-integer (base
mincol
padchar
commachar
commainterval
commaflag
positive-sign-flag
arg
stream)
(let* ((*print-base* base)
(*print-radix* nil)
(*print-readably* nil))
(if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
(princ arg stream) ; normal output does the job
(let* ((oldstring (princ-to-string arg))
(oldstring-length (length oldstring))
(number-of-digits
(if (minusp arg) (1- oldstring-length) oldstring-length) )
(number-of-commas
(if commaflag (floor (1- number-of-digits) commainterval) 0) )
(positive-sign (and positive-sign-flag (>= arg 0)))
(newstring-length
(+ (if positive-sign 1 0) ; sign
oldstring-length number-of-commas)) ; digits, commas
(newstring (make-string newstring-length)) )
;; first the sign +:
(when positive-sign (setf (schar newstring 0) #\+))
;; Then convert oldstring in newstring, skipping the commas:
(let ((oldpos oldstring-length) (newpos newstring-length))
(loop
(decf oldpos)
(when (minusp oldpos) (return))
(decf newpos)
(setf (schar newstring newpos) (schar oldstring oldpos))
(when (and (plusp number-of-commas) ; insert a comma?
(zerop (mod (- oldstring-length oldpos) commainterval)))
(decf newpos)
(setf (schar newstring newpos) commachar)
(decf number-of-commas))))
(if (zerop mincol)
(write-string newstring stream) ; faster
(format-padded-string mincol 1 0 padchar t newstring stream))))))
;; non-numeric argument for numeric format instruction is printed with ~A
(defun format-ascii-decimal (arg stream)
(let ((*print-base* 10.)
(*print-radix* nil)
(*print-readably* nil))
(princ arg stream)))
;; subroutine for ~D, ~B, ~O, ~X:
(defun format-base (base stream colon-modifier atsign-modifier
mincol padchar commachar commainterval
arg)
(if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
(not (integerp arg)))
(let ((*print-base* base)
(*print-radix* nil)
(*print-readably* nil))
(if (integerp arg)
(princ arg stream)
(format-padded-string mincol 1 0 padchar t
(princ-to-string arg) stream)))
(format-integer base mincol padchar commachar commainterval
colon-modifier atsign-modifier arg stream)))
;; (format-float-to-string arg width d k dmin)
;; returns a String for Floating-point arg:
;; it has the value of (* (abs arg) (expt 10 k)), with at least d digits behind
;; the decimal point and at most the length width (width=nil -> no limitation).
;; Nevertheless there is no rounding to less than dmin digits.
(let ((digit-string (make-array 20 :element-type 'character
:adjustable t :fill-pointer t)))
(defun format-float-to-string (arg width d k dmin)
(if (zerop arg)
(let ((places (max (or d 0) (or dmin 0))))
(when width ; width specified -> places := (min places (1- width))
(when (>= places width) (setq places (1- width))))
(values
(let ((str (make-string (1+ places) :initial-element #\0)))
(setf (schar str 0) #\.)
str) ; one decimal point and places zeros
(1+ places) ; number of digits
t ; decimal point in front
(zerop places) ; decimal point at the end?
0)) ; position of the decimal point
(multiple-value-bind (significand expon) (integer-decode-float arg)
;; significand : Integer >0
;; expon : Integer
;; mantprec : number of real Mantissa-bits of significand
;; (so 2^mantprec <= significand < 2^(mantprec+1))
;; width : number of digits, that the number (including decimal point)
;; is not to overshoot, or NIL
;; at least 2: a digit and the decimal point
(when width (setq width (max width 2)))
;; d : minimum number of digits behind the decimal point or NIL
;; k : scaling factor (ref. CLTL p.394)
;; dmin : minimum number of digits, that
;; may not be rounded (despite the specification of width or d).
;; (only interesting, if d <= dmin <= (precision of number).)
;; converts the number significand*2^expon into a decimal-string.
;; There is no exponent present.
(let* ((mantprec (1- (float-digits arg)))
(numerator significand)
(denominator 1)
(round-down-1 1) ; rounding-off unit:
;; rounding off by 1 in the last digit that can be rounded off
;; corresponds to the decrease of the numerator by round-down-1.
(round-up-1 1) ; rounding-up unit:
;; rounding up by 1 in the last digit that can be rounded up
;; corresponds to the increase of the numerator by round-up-1.
;; positions: 0 = 1st. digit in front of the decimal point,
;; -1 = 1st. digit behind the decimal point.
(posn 0) ; position of the next digit to be printed
(digit-count 0) ; number of the printed digits so far in
; digit-string (excluding the decimal point)
(point-pos 0) ; decimal-point-position = number of leading digits
; = number of digits in front of the decimal point
(last-pos nil) ; NIL or position of the last significant digit
; (if d or width were specified)
digit ; the current digit, >=0, <10
(round-down-p nil) ; T if last digit is to be rounded off
(round-up-p nil)) ; T if last digit is to be rounded up
(setf (fill-pointer digit-string) 0) ; empty the digit-string
(cond ((> expon 0)
(setq numerator (ash significand expon))
(setq round-up-1 (setq round-down-1 (ash 1 expon))))
((< expon 0) ; round-up-1 = round-down-1 = 1
(setq denominator (ash 1 (- expon)))))
;; number = numerator/denominator
(when (= significand (ash 1 mantprec))
;; If Significand=2^mantprec, round-down-1 can be halved.
;; Instead, the other three items can be doubled:
(setq round-up-1 (ash round-up-1 1))
(setq numerator (ash numerator 1))
(setq denominator (ash denominator 1)))
;; default behavior: rounding-unit = one unit in the last
;; BINARY-digit.
;; number = numerator/denominator
;; work scaling factor k into the number (ref. CLTL p.394)
;; k<0 -> divide mantissa by 10^(abs k)
;; k>0 -> multiply mantissa with 10^k
;; Retain ratio between round-up-1/round-down-1 and numerator.
(when k
(if (< k 0)
(let ((scal-factor (expt 10 (- k))))
(setq denominator (* denominator scal-factor)))
(let ((scal-factor (expt 10 k)))
(setq numerator (* numerator scal-factor))
(setq round-up-1 (* round-up-1 scal-factor))
(setq round-down-1 (* round-down-1 scal-factor)))))
;; adjust to >= 1/10 : (multiply numerator with 10 at a time and
;; plan for an additional leading 0)
(do ()
((>= (* numerator 10) denominator))
(setq posn (1- posn))
(setq numerator (* numerator 10))
(setq round-down-1 (* round-down-1 10))
(setq round-up-1 (* round-up-1 10)))
;; posn = position of the final leading 0
;; = 1 + position of the 1st. significant digit
;; or =0, if k>=0
;; implementation of the rounding:
(loop
;; so long as the result stays >= 1 even after rounding up,
;; plan for one more digit in front of the decimal point:
(do ()
((< (+ (ash numerator 1) round-up-1) (ash denominator 1)))
(setq denominator (* denominator 10))
(setq posn (1+ posn)))
;; if d or width is specified: calculate last-pos
(if d
;; if dmin is specified: (min (- d) (- dmin)) = (- (max d dmin)).
;; else (- d).
(progn
(setq last-pos (- d))
(when (and dmin (> last-pos (- dmin)))
(setq last-pos (- dmin))))
;; if not d, only specify width:
(when width
(if (< posn 0)
;; leading zeros behind the decimal point -> d:=(1- width)
(setq last-pos (- 1 width))
;; no leading zeros behind the decimal point -> there will
;; be posn digits in front of the point, d:=(- (1- width) posn)
(setq last-pos (1+ (- posn width))))
;; last-pos = (- (- (1- width) (max posn 0)))
;; take dmin into account again
(when (and dmin (> last-pos (- dmin)))
(setq last-pos (- dmin)))))
(when (or d width)
(let* ((ziffernzahl (- last-pos posn))
; = - number of significant digits or >=0.
(decimal-1 denominator))
; := (ceiling (* decimal-1 (expt 10 ziffernzahl)))
(if (>= ziffernzahl 0)
(dotimes (i ziffernzahl)
(setq decimal-1 (* decimal-1 10)))
(dotimes (i (- ziffernzahl))
(setq decimal-1 (ceiling decimal-1 10))))
;; decimal-1 = amount by which numerator has to be increased
;; resp. decreased, therewith the decimal representation is
;; changed by exactly 1 at the position last-pos
(setq round-down-1 (max decimal-1 round-down-1))
(setq round-up-1 (max decimal-1 round-up-1))
;; now rounding may take place by one (half) decimal-1.
))
(when (< (+ (ash numerator 1) round-up-1) (ash denominator 1))
(return)))
;; posn = position of the first significant digit + 1
;; print leading point and consecutive zeros:
(when (< posn 0)
(setq point-pos digit-count)
(vector-push-extend #\. digit-string)
(dotimes (i (- posn))
(incf digit-count)
(vector-push-extend #\0 digit-string)))
;; print digits of the mantissa:
(loop
(when (zerop posn)
(vector-push-extend #\. digit-string)
(setq point-pos digit-count))
(decf posn)
(multiple-value-setq (digit numerator)
(truncate (* numerator 10) denominator))
(setq round-down-1 (* round-down-1 10))
(setq round-up-1 (* round-up-1 10))
(setq round-down-p (< (ash numerator 1) round-down-1))
(setq round-up-p
(>= (ash numerator 1) (- (ash denominator 1) round-up-1)))
(when (or round-down-p round-up-p
(and last-pos (<= posn last-pos)))
(return))
(vector-push-extend (schar #1="0123456789" digit) digit-string)
(incf digit-count))
;; print last significant digit:
(when (or (null last-pos) (>= posn last-pos))
(vector-push-extend
(schar #1#
(cond ((and round-down-p (not round-up-p)) digit)
((and round-up-p (not round-down-p)) (1+ digit))
((<= (ash numerator 1) denominator) digit)
(t (1+ digit))))
digit-string)
(incf digit-count))
;; print consecutive zeros and point
(when (>= posn 0)
(dotimes (i posn)
(incf digit-count)
(vector-push-extend #\0 digit-string))
(vector-push-extend #\. digit-string)
(setq point-pos digit-count))
(when d
(dotimes (i (- d (- digit-count point-pos)))
(incf digit-count)
(vector-push-extend #\0 digit-string)))
(values ; 5 values
digit-string ; digits
(1+ digit-count) ; number of digits
(= point-pos 0) ; leading point?
(= point-pos digit-count) ; trailing point?
point-pos))))) ; position of the decimal point
) ; let
;; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
;; prints the Floating-Point-Number arg in Fix-Comma-Representation to stream.
(defun format-float-for-f (w d k overflowchar padchar plus-sign-flag
arg stream)
(let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
;; width = available characters without sign
(multiple-value-bind (digits digitslength leadingpoint trailingpoint)
(format-float-to-string arg width d k 0)
(when (eql d 0)
(setq trailingpoint nil)) ; d=0 -> no additional zero behind
(when w
(setq width (- width digitslength))
(when leadingpoint ; plan possibly additional zero ahead
(if (> width 0) (setq width (1- width)) (setq leadingpoint nil)))
(when trailingpoint ; plan possibly additional zero behind
(if (> width 0) (setq width (1- width)) (setq trailingpoint nil))))
;; width characters still remain.
(if (and overflowchar w (minusp width))
(format-padding w overflowchar stream) ; not enough room -> overflow
(progn
(when (and w (> width 0)) (format-padding width padchar stream))
(if (minusp arg)
(write-char #\- stream)
(if plus-sign-flag (write-char #\+ stream)))
(when leadingpoint (write-char #\0 stream))
(write-string digits stream)
(when trailingpoint (write-char #\0 stream)))))))
;; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
;; arg stream)
;; prints the Floating-Point-Number arg
;; in Exponential representation to stream.
;; (compare CLTL p.392-394)
;; partitioning of Mantissa:
;; if k<=0, first 1 zero (if fits in width), then the point,
;; then |k| zeros, then d-|k| significant digits;
;; which is d digits behind the point, altogether.
;; if k>0, first k significant digits, then the point,
;; then d-k+1 further significant digits;
;; which is d+1 significant digits, altogether.
;; no zeros in front.
;; (The default in FORMAT-EXPONENTIAL-FLOAT is k=1.)
;; the sign in front of the Mantissa (a + only if arg>=0 and plus-sign-flag).
;; then the Exponent, prefaced by exponentchar, then sign of the
;; Exponent (always + or -), then e digits for the Exponent.
;; Then fill the whole thing with padchars to w characters.
;; If this results (even after possible suppression of a leading zero) in
;; more than w characters, print w overflowchars instead, or
;; (if overflowchar = nil) print the number with as many digits
;; as necessary.
(defun format-float-for-e (w d e k
overflowchar padchar exponentchar plus-sign-flag arg stream)
(multiple-value-bind (oldexponent mantissa) (float-scale-exponent (abs arg))
(let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; Exponent to be printed
(expdigits (write-to-string (abs exponent) :base 10.
:radix nil :readably nil))
;; expdigitsneed = number of digits, that are necessary
;; for the Exponent.
(expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
;; mantd = number of Mantissa-Digits behind the point
(mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
;; no rounding takes place within the first (+ 1 (abs k)) digits.
(dmin (if (minusp k) (- 1 k) nil)) ; hereafter: demand, that
;; mantwidth = number of available characters (or nil)
;; for the Mantissa (incl. sign, point)
(mantwidth (if w (- w 2 expdigitsneed) nil)))
(declare (simple-string expdigits) (fixnum exponent expdigitsneed))
(if (and overflowchar w e (> expdigitsneed e))
;; if Overflowchar and w and e being stated, Exponent needs more room:
(format-padding w overflowchar stream)
(progn
(when (and w (or plus-sign-flag (minusp arg)))
(setq mantwidth (1- mantwidth)))
;; mantwidth = number of available characters (or nil)
;; for the Mantissa (without sign,including point)
(multiple-value-bind (mantdigits mantdigitslength
leadingpoint trailingpoint point-pos)
(format-float-to-string mantissa mantwidth mantd k dmin)
(when w
(setq mantwidth (- mantwidth mantdigitslength))
(when trailingpoint
(if (or (null mantd) (> mantd 0))
(setq mantwidth (- mantwidth 1))
(setq trailingpoint nil)))
(when leadingpoint
(if (> mantwidth 0)
(setq mantwidth (- mantwidth 1))
(setq leadingpoint nil))))
;; mantwidth characters remain.
(if (and overflowchar w (minusp mantwidth))
(format-padding w overflowchar stream) ; not enough room -> overflow
(progn
(when (and (plusp k) (< k point-pos))
;; format-float-to-string rounded the mantissa up above 1
;; so that all our assumptions are now wrong and we are
;; about to get (format nil "~8e" .999999d9) => " 10.0d+8"