Context Navigation

source: branches/working-0711/ccl/lib/format.lisp @ 12301

Visit:

Last change on this file since 12301 was 12301, checked in by gz, 10 years ago
Merge r12276 r12292 r12297 from trunk, plus some mods for other platforms
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 107.9 KB

Line
1	;;; -- Mode: Lisp; Package: CCL --
2	;;;
3	;;; Copyright (C) 1994-2001 Digitool, Inc
4	;;; This file is part of OpenMCL.
5	;;;
6	;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7	;;; License , known as the LLGPL and distributed with OpenMCL as the
8	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
9	;;; which is distributed with OpenMCL as the file "LGPL". Where these
10	;;; conflict, the preamble takes precedence.
11	;;;
12	;;; OpenMCL is referenced in the preamble as the "LIBRARY."
13	;;;
14	;;; The LLGPL is also available online at
15	;;; http://opensource.franz.com/preamble.html
16
17	;;; Functions to implement FORMAT.
18	;;;
19
20	(in-package "CCL")
21
22	;;; Special variables local to FORMAT
23	;;; why do these have top-level bindings ????? - seems wrong or at least unnecessary
24
25	(defvar format-control-string ""
26	"The current FORMAT control string")
27
28	(defvar format-index 0
29	"The current index into format-control-string")
30
31	(defvar format-length 0
32	"The length of the current FORMAT control string")
33
34	(defvar format-arguments ()
35	"Arguments to the current call of FORMAT")
36
37	(defvar format-original-arguments ()
38	"Saved arglist from top-level FORMAT call for ~* and ~@*")
39
40	(defvar format-arguments-variance nil
41	"Non-NIL only during compile-time scanning of a format string, in which case it is the
42	number of additional elements at the front of format-arguments that may be already used
43	up at runtime. I.e. the actual format-arguments may be anything between format-arguments
44	and (nthcdr format-arguments-variance format-arguments)")
45
46	(def-standard-initial-binding format-stream-stack nil "A stack of string streams for collecting FORMAT output")
47
48	(defvar format-pprint nil
49	"Has a pprint format directive (~W ~I ~_ ~:T) or logical-block directive been seen?")
50
51	(defvar format-justification-semi nil
52	"Has a ~<...~:;...~> been seen?")
53
54	(defvar format-colon-rest nil
55	)
56
57	;;; prevent circle checking rest args. Really EVIL when dynamic-extent
58	(def-standard-initial-binding format-top-level nil)
59
60
61	;;; ERRORS
62
63	;;; Since errors may occur while an indirect control string is being
64	;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary
65	;;; in order to indicate the location in the control string where the
66	;;; error was detected. To this end, errors detected by format are
67	;;; signalled by throwing a list of the form ((control-string args))
68	;;; to the tag FORMAT-ERROR. This throw will be caught at each level
69	;;; of indirection, and the list of error messages re-thrown with an
70	;;; additional message indicating that indirection was present CONSed
71	;;; onto it. Ultimately, the last throw will be caught by the top level
72	;;; FORMAT function, which will then signal an error to the Slisp error
73	;;; system in such a way that all the errror messages will be displayed
74	;;; in reverse order.
75
76	(defun format-error (complaint &rest args)
77	(throw 'format-error
78	(list (list "~1{~:}~%~S~%~V@T^" complaint args
79	format-control-string (1+ format-index)))))
80
81
82	;;; MACROS
83
84	;;; This macro establishes the correct environment for processing
85	;;; an indirect control string. CONTROL-STRING is the string to
86	;;; process, and FORMS are the forms to do the processing. They
87	;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING
88	;;; is guaranteed to be evaluated exactly once.
89	(eval-when (compile eval #-bccl load)
90
91	; does this need to exist?????
92	#\|\| ; put it out of its misery
93	(defmacro format-with-control-string (control-string &rest forms)
94	`(let ((string (if (simple-string-p ,control-string)
95	,control-string
96	(coerce ,control-string 'simple-base-string))))
97	(declare (simple-string string))
98	(let ((error (catch 'format-error
99	(let ((format-control-string string)
100	(format-length (length string))
101	(format-index 0))
102	,@forms
103	nil))))
104
105	(when error
106	(throw 'format-error
107	(cons (list "While processing indirect control string~%~S~%~V@T^"
108	format-control-string
109	(1+ format-index))
110	error))))))
111	\|\|#
112	(defmacro format-indirect-error (error)
113	`(throw 'format-error
114	(cons (list "While processing indirect control string~%~S~%~V@T^"
115	format-control-string
116	(1+ format-index))
117	,error)))
118
119
120	(defmacro get-a-format-string-stream ()
121	'(or (pop format-stream-stack) (make-string-output-stream :element-type 'base-char))) ; ??
122
123	;;; This macro rebinds collects output to the standard output stream
124	;;; in a string. For efficiency, we avoid consing a new stream on
125	;;; every call. A stack of string streams is maintained in order to
126	;;; guarantee re-entrancy.
127
128	(defmacro with-format-string-output (stream-sym &rest forms)
129	`(let ((,stream-sym nil))
130	(unwind-protect
131	(progn
132	(setq ,stream-sym (get-a-format-string-stream))
133	,@forms
134	(prog1
135	(get-output-stream-string ,stream-sym)
136	(push ,stream-sym format-stream-stack)))
137	(when ,stream-sym (file-position ,stream-sym 0)))))
138
139	;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION.
140	;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form
141	;;; (<var> <default>). The FORMS are evaluated in an environment where each
142	;;; <var> is bound to either the value of the parameter supplied in the
143	;;; parameter list, or to its <default> value if the parameter was omitted or
144	;;; explicitly defaulted.
145
146	(defmacro with-format-parameters (parmvar parmdefs &body body &environment env)
147	(do ((parmdefs parmdefs (cdr parmdefs))
148	(bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar))
149	,(cadar parmdefs)))
150	bindings)))
151	((null parmdefs)
152	(multiple-value-bind (forms decls) (parse-body body env)
153	`(let ,(nreverse bindings)
154	,@decls
155	(when ,parmvar
156	(format-error "Too many parameters"))
157	,@forms)))))
158
159
160
161	;;; Returns the index of the first occurrence of the specified character
162	;;; between indices START (inclusive) and END (exclusive) in the control
163	;;; string.
164
165
166	(defmacro format-find-char (char start end)
167	`(%str-member ,char format-control-string
168	,start ,end))
169
170
171	) ;end of eval-when for macros
172
173	;;; CONTROL STRING PARSING
174
175	;;; The current control string is kept in format-control-string.
176	;;; The variable format-index is the position of the last character
177	;;; processed, indexing from zero. The variable format-length is the
178	;;; length of the control string, which is one greater than the maximum
179	;;; value of format-index.
180
181
182	;;; Gets the next character from the current control string. It is an
183	;;; error if there is none. Leave format-index pointing to the
184	;;; character returned.
185
186	(defun format-nextchar ()
187	(let ((index (%i+ 1 format-index)))
188	(if (%i< (setq format-index index) format-length)
189	(schar format-control-string index)
190	(format-error "Syntax error"))))
191
192
193
194	;;; Returns the current character, i.e. the one pointed to by format-index.
195
196	(defmacro format-peek ()
197	`(schar format-control-string format-index))
198
199
200
201
202	;;; Attempts to parse a parameter, starting at the current index.
203	;;; Returns the value of the parameter, or NIL if none is found.
204	;;; On exit, format-index points to the first character which is
205	;;; not a part of the recognized parameter.
206
207	(defun format-get-parameter (ch)
208	(case ch
209	(#\# (format-nextchar)
210	(let ((n (or format-arguments-variance 0))
211	(len (length format-arguments)))
212	(declare (fixnum n len))
213	(if (eql n 0)
214	len
215	`(the (integer ,(- len n) ,len) (length format-arguments)))))
216	((#\V #\v)
217	(prog1 (pop-format-arg) (format-nextchar)))
218	(#\' (prog1 (format-nextchar) (format-nextchar)))
219	(t (cond ((or (eq ch #\-) (eq ch #\+) (digit-char-p ch))
220	(let ((neg-parm (eq ch #\-)))
221	(unless (setq ch (digit-char-p ch))
222	(unless (setq ch (digit-char-p (format-nextchar)))
223	(format-error "Illegal parameter")))
224	(do ((number ch (+ ch (* number 10))))
225	((not (setq ch (digit-char-p (format-nextchar))))
226	(if neg-parm (- number) number)))))
227	(t nil)))))
228
229	(defun format-skip-parameter (ch) ; only caller is parse-format-operation
230	"Might someday want to add proper format error checking for negative
231	parameters"
232	(let ()
233	(case ch
234	((#\V #\v #\#)
235	(format-nextchar))
236	(#\' (format-nextchar) (format-nextchar))
237	(#\,)
238	(t (when (or (eq ch #\-) (eq ch #\+)) (format-nextchar))
239	(while (digit-char-p (format-nextchar)))))))
240
241	(defun format-no-semi (char &optional colon atsign)
242	(when format-justification-semi
243	(format-error "~~~:[~;:~]~:[~;@~]~c illegal in this context" colon atsign char))
244	(setq format-pprint t))
245
246	;;; Parses a format directive, including flags and parameters. On entry,
247	;;; format-index should point to the "~" preceding the command. On
248	;;; exit, format-index points to the command character itself.
249	;;; Returns the list of parameters, the ":" flag, the "@" flag, and the
250	;;; command character as multiple values. Explicitly defaulted parameters
251	;;; appear in the list of parameters as NIL. Omitted parameters are simply
252	;;; not included in the list at all.
253
254	(defun parse-format-operation (&optional get-params) ; only caller is format-find-command
255	(let ((ch (format-nextchar)) parms colon atsign)
256	(when (or (digit-char-p ch)
257	;(%str-member ch ",#Vv'"))
258	(memq ch '(#\- #\, #\# #\V #\v #\')))
259	(cond (get-params
260	(setq parms (list (format-get-parameter ch)))
261	(until (neq (setq ch (format-peek)) #\,)
262	(setq ch (format-nextchar))
263	(push (format-get-parameter ch) parms)))
264	(t (setq parms t) ; tell caller there were some so we get correct error msgs
265	(format-skip-parameter ch)
266	(until (neq (setq ch (format-peek)) #\,)
267	(setq ch (format-nextchar))
268	(format-skip-parameter ch)))))
269	; allow either order
270	(case ch
271	(#\: (setq colon t ch (format-nextchar))
272	(when (eq ch #\@)
273	(setq atsign t ch (format-nextchar))))
274	(#\@ (setq atsign t ch (format-nextchar))
275	(when (eq ch #\:)
276	(setq colon t ch (format-nextchar)))))
277	(values (if (consp parms) (nreverse parms) parms)
278	colon
279	atsign
280	ch)))
281
282
283	;;; Starting at the current value of format-index, finds the first
284	;;; occurrence of one of the specified directives. Embedded constructs,
285	;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is
286	;;; signalled if no satisfactory command is found. Otherwise, the
287	;;; following are returned as multiple values:
288	;;;
289	;;; The value of format-index at the start of the search
290	;;; The index of the "~" character preceding the command
291	;;; The parameter list of the command
292	;;; The ":" flag
293	;;; The "@" flag
294	;;; The command character
295	;;;
296	;;; Implementation note: The present implementation is not particulary
297	;;; careful with storage allocation. It would be a good idea to have
298	;;; a separate function for skipping embedded constructs which did not
299	;;; bother to cons parameter lists and then throw them away. This issue has been addressed. (akh)
300	;;;
301	;;; We go to some trouble here to use POSITION for most of the searching.
302	;;; God only knows why!!!!
303
304	;; and interesting note - the only caller who wants parameters is format-get-segments for
305	;; ~< .... ~n:; ...~>
306	(defun format-find-command (command-list &optional get-params evil-commands)
307	(let* ((start format-index)
308	(length format-length)
309	tilde)
310	(loop
311	(setq tilde (format-find-char #\~ format-index length))
312	(if (not tilde) (format-error "Expecting one of ~S" command-list))
313	(setq format-index tilde)
314	(multiple-value-bind (parms colon atsign command)
315	(parse-format-operation get-params)
316	(when (memq command command-list)
317	(return (values start tilde parms colon atsign command)))
318	(when (and evil-commands
319	(or (memq command '(#\w #\_ #\i #\W #\I))
320	(and colon (memq command '(#\t #\T)))))
321	(format-error "Illegal in this context"))
322	(case command
323	(#\{ (format-nextchar) (format-find-command '(#\})))
324	(#\( (format-nextchar) (format-find-command '(#\))))
325	(#\[ (format-nextchar) (format-find-command '(#\])))
326	(#\< (format-nextchar)
327	(multiple-value-bind (prev tilde parms colon atsign cmd)
328	(format-find-command '(#\>))
329	(declare (ignore prev tilde parms atsign cmd))
330	(if (and evil-commands colon)
331	(format-error "Logical-block directive not allowed inside justification directive"))))
332	((#\} #\> #\) #\])
333	(format-error "No matching bracket")))))))
334
335	(defun format-find-command-no-params (command-list &key (colon t) (atsign t))
336	(multiple-value-bind (prev tilde parms colon-flag atsign-flag command)
337	(format-find-command command-list)
338	(with-format-parameters parms ()
339	(format-no-flags (and (not colon) colon-flag) (and (not atsign) atsign-flag)))
340	(values prev tilde command colon-flag atsign-flag)))
341
342	;;; This is the FORMAT top-level function.
343
344	(defun format (stream control-string &rest format-arguments)
345	(declare (dynamic-extent format-arguments))
346	(if (null stream)
347	(with-output-to-string (s)
348	(apply #'format s control-string format-arguments))
349	(if (stringp stream)
350	(with-output-to-string (s stream)
351	(apply #'format s control-string format-arguments))
352	(let ((format-top-level t))
353	(when (xp-structure-p stream)(setq stream (xp-stream-stream stream))) ; for xp tests only! They call format on a structure
354	(setq stream (if (eq stream t)
355	standard-output
356	(require-type stream 'stream)))
357	(if (functionp control-string)
358	(apply control-string stream format-arguments)
359	(let* ((control-string (ensure-simple-string control-string))
360	(format-control-string control-string)
361	(format-pprint nil)
362	(format-justification-semi nil))
363	(declare (type simple-string control-string))
364	(cond
365	;; Try to avoid pprint overhead in this case.
366	((not (position #\~ control-string))
367	(write-string control-string stream))
368	((and (or print-pretty print-circle)
369	(not (typep stream 'xp-stream)))
370	(maybe-initiate-xp-printing
371	#'(lambda (s o)
372	(do-sub-format-1 s o))
373	stream format-arguments))
374	(t
375	(let ((format-original-arguments format-arguments)
376	(format-arguments format-arguments)
377	(format-colon-rest 'error)) ; what should this be??
378	(do-sub-format stream))))))
379	nil))))
380
381	(defun format-to-string (string control-string &rest format-arguments)
382	(declare (dynamic-extent format-arguments))
383	(if string
384	(with-output-to-string (stream string)
385	(apply #'format stream control-string format-arguments))
386	(with-output-to-string (stream)
387	(apply #'format stream control-string format-arguments))))
388
389	(defun do-sub-format (stream)
390	(let (errorp)
391	(setq errorp
392	(catch 'format-error
393	(catch 'format-escape
394	(sub-format stream 0 (length format-control-string)))
395	nil))
396	(when errorp
397	(error "~%~:{~@?~%~}" (nreverse errorp)))))
398
399
400
401	;;; This function does the real work of format. The segment of the control
402	;;; string between indiced START (inclusive) and END (exclusive) is processed
403	;;; as follows: Text not part of a directive is output without further
404	;;; processing. Directives are parsed along with their parameters and flags,
405	;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and
406	;;; PARMS.
407	;;;
408
409	;;; POP-FORMAT-ARG also defined in l1-format
410
411	; in l1-format
412	(def-standard-initial-binding logical-block-xp nil)
413
414	(without-duplicate-definition-warnings
415	(defun pop-format-arg (&aux (args format-arguments) (xp logical-block-xp) (av format-arguments-variance))
416	(when (and (null args) (null xp))
417	(format-error "Missing argument"))
418	(when xp
419	(if (null av)
420	(when (pprint-pop-check+ args xp) ; gets us level and length stuff in logical block
421	(throw 'logical-block nil))
422	;; Could record that might exit here, but nobody cares.
423	#+no (note-format-scan-option logical-block-options)))
424	(if (or (null av) (eql av 0))
425	(progn
426	(setq format-arguments (cdr args))
427	(%car args))
428	(let ((types (loop for x in args as i from 0 below av
429	collect (nx-form-type x))))
430	(when (eql av (length args))
431	(setq format-arguments-variance (1- av)))
432	(setq format-arguments (cdr args))
433	`(the (or ,@types) (car format-arguments))))))
434
435	; SUB-FORMAT is now defined in L1-format.lisp
436	; DEFFORMAT is also defined there.
437
438	;;;;;;;;;;;;;;;;;;;;;;;;;;
439	;;; pretty-printing stuff
440	;;;
441
442	(defformat #\W format-write (stream colon atsign)
443	(format-no-semi #\W)
444	(let ((arg (pop-format-arg)))
445	(cond (atsign
446	(let ((print-level nil)
447	(print-length nil))
448	(if colon
449	(let ((print-pretty t))
450	(write-1 arg stream))
451	(write-1 arg stream))))
452	(t (if colon
453	(let ((print-pretty t))
454	(write-1 arg stream))
455	(write-1 arg stream))))))
456
457	(defformat #\I format-indent (stream colon atsign &rest parms)
458	(declare (dynamic-extent parms))
459	(declare (ignore atsign))
460	(format-no-semi #\I)
461	(with-format-parameters parms ((n 0))
462	(pprint-indent (if colon :current :block) n stream)))
463
464	(defformat #\_ format-conditional-newline (stream colon atsign)
465	(format-no-semi #\_)
466	(let ((option
467	(cond (atsign
468	(cond (colon :mandatory)
469	(t :miser)))
470	(colon :fill)
471	(t :linear))))
472	(pprint-newline option stream)))
473
474	;;; Tabulation ~T
475
476	(defformat #\T format-tab (stream colon atsign &rest parms)
477	(declare (dynamic-extent parms))
478	(when colon
479	(format-no-semi #\T t))
480	(with-format-parameters parms ((colnum 1) (colinc 1))
481	(cond ((or (typep stream 'xp-stream) (xp-structure-p stream))
482	(let ((kind (if colon
483	(if atsign :section-relative :section)
484	(if atsign :line-relative :line))))
485	(cond ((xp-structure-p stream)
486	(pprint-tab+ kind colnum colinc stream))
487	((typep stream 'xp-stream)
488	(pprint-tab+ kind colnum colinc
489	(slot-value stream 'xp-structure))))))
490	((not colon)
491	(pprint-tab-not-pretty stream colnum colinc atsign)))))
492
493	(defun pprint-tab-not-pretty (stream colnum colinc &optional atsign)
494	(let* ((position (column stream))
495	(count (if atsign
496	(if position
497	(if (zerop colinc)
498	colnum (+ colnum (mod (- (+ position colnum)) colinc)))
499	colnum)
500	(if position
501	(if (<= colnum position)
502	(if (zerop colinc)
503	0 (- colinc (mod (- position colnum) colinc)))
504	(- colnum position))
505	2))))
506	(while (> count 0)
507	(write-string " "
508	stream :start
509	0 :end (min count 80))
510	(setq count (- count 80)))))
511
512
513	;;; ~/ call function
514	(defformat #\/ format-call-function (stream colon atsign &rest parms)
515	(let* ((string format-control-string)
516	(ipos (1+ format-index))
517	(epos (format-find-char #\/ ipos format-length)))
518	; the spec is DUMB here - it requires that : and :: be treated the same
519	(when (not epos) (format-error "Unmatched ~~/"))
520	(let ((cpos (format-find-char #\: ipos epos))
521	package)
522	(cond (cpos
523	(setq package (or (find-package (string-upcase (%substr string ipos cpos)))
524	(format-error "Unknown package")))
525	(when (eql #\: (schar string (%i+ 1 cpos)))
526	(setq cpos (%i+ cpos 1)))
527	(setq ipos (%i+ cpos 1)))
528	(t (setq package (find-package "CL-USER"))))
529	(let ((thing (intern (string-upcase (%substr string ipos epos)) package)))
530	(setq format-index epos) ; or 1+ epos?
531	(apply thing stream (pop-format-arg) colon atsign parms)))))
532
533	;;; Conditional case conversion ~( ... ~)
534
535	#\| coral's old version
536	(defformat #\( format-capitalization (stream colon atsign)
537	(format-nextchar)
538	(multiple-value-bind (prev tilde) (format-find-command-no-params '(#\)))
539	(let* (finished
540	(string (with-format-string-output stream
541	(setq finished (catch 'format-escape (sub-format stream prev tilde) t)))))
542	(write-string
543	(cond ((and atsign colon)
544	(nstring-upcase string))
545	(colon
546	(nstring-capitalize string))
547	(atsign
548	(let ((strlen (length string)))
549	;; Capitalize the first word only
550	(nstring-downcase string)
551	(do ((i 0 (1+ i)))
552	((or (<= strlen i) (alpha-char-p (char string i)))
553	(setf (char string i) (char-upcase (char string i)))
554	string))))
555	(t (nstring-downcase string)))
556	stream :start
557	0 :end (length string))
558	(unless finished (throw 'format-escape nil)))))
559
560	\|#
561
562	(defformat #\( format-capitalization (stream colon atsign)
563	(format-nextchar)
564	(multiple-value-bind (prev tilde) (format-find-command-no-params '(#\)))
565	(let (catchp)
566	(cond ((typep stream 'xp-stream)
567	(let ((xp (slot-value stream 'xp-structure)))
568	(push-char-mode xp (cond ((and colon atsign) :UP)
569	(colon :CAP1)
570	(atsign :CAP0)
571	(T :DOWN)))
572	(setq catchp
573	(catch 'format-escape
574	(sub-format stream prev tilde)
575	nil))
576	(pop-char-mode xp)))
577	(t
578	(let* ((string (with-format-string-output stream
579	(setq catchp (catch 'format-escape
580	(sub-format stream prev tilde)
581	nil)))))
582	(write-string
583	(cond ((and atsign colon)
584	(nstring-upcase string))
585	(colon
586	(nstring-capitalize string))
587	(atsign
588	;; Capitalize the first word only
589	(nstring-downcase string)
590	(dotimes (i (length string) string)
591	(let ((ch (char string i)))
592	(when (alpha-char-p ch)
593	(setf (char string i) (char-upcase ch))
594	(return string)))))
595	(t (nstring-downcase string)))
596	stream :start
597	0 :end (length string)))))
598	(when catchp
599	(throw 'format-escape catchp))
600	)))
601
602	;;; Up and Out (Escape) ~^
603
604	(defformat #\^ format-escape (stream colon atsign &optional p1 p2 p3)
605	(declare (ignore stream))
606	(when atsign
607	(format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon))
608	(when (cond (p3 (etypecase p2
609	(real
610	(<= p1 p2 p3))
611	(character
612	(char< p1 p2 p3))))
613	(p2 (equal p1 p2))
614	(p1 (eql p1 0))
615	(t (null (if colon format-colon-rest format-arguments))))
616	(throw 'format-escape (if colon 'format-colon-escape t))))
617
618	;;; Conditional expression ~[ ... ]
619
620
621	;;; ~[ - Maybe these guys should deal with ~^ too - i.e. catch format-escape etc.
622	;;; but I cant think of a case where just throwing to the { catcher fails
623
624	(defun format-untagged-condition (stream)
625	(let ((test (pop-format-arg)))
626	(unless (integerp test)
627	(format-error "Argument to ~~[ must be integer - ~S" test))
628	(do ((count 0 (1+ count)))
629	((= count test)
630	(multiple-value-bind (prev tilde cmd colon atsign)
631	(format-find-command-no-params '(#\; #\]) :atsign nil)
632	(declare (ignore colon atsign))
633	(sub-format stream prev tilde)
634	(unless (eq cmd #\])
635	(format-find-command '(#\])))))
636	(multiple-value-bind (prev tilde cmd colon atsign)
637	(format-find-command-no-params '(#\; #\]) :atsign nil)
638	(declare (ignore prev tilde atsign))
639	(when (eq cmd #\]) (return))
640	(format-nextchar)
641	(when colon
642	(multiple-value-bind (prev tilde cmd colon atsign)
643	(format-find-command-no-params '(#\; #\]))
644	(declare (ignore colon atsign))
645	(sub-format stream prev tilde)
646	(unless (eq cmd #\])
647	(format-find-command-no-params '(#\]))))
648	(return))))))
649
650
651	;;; ~@[
652
653	(defun format-funny-condition (stream)
654	(multiple-value-bind (prev tilde) (format-find-command-no-params '(#\]))
655	(if format-arguments
656	(if (car format-arguments)
657	(sub-format stream prev tilde)
658	(pop format-arguments))
659	(format-error "Missing argument"))))
660
661
662	;;; ~:[
663
664	(defun format-boolean-condition (stream)
665	(multiple-value-bind (prev tilde command) (format-find-command-no-params '(#\; #\]))
666	(when (eq command #\])
667	(format-error "Two clauses separated by ~~; are required for ~~:["))
668	(format-nextchar)
669	(if (pop-format-arg)
670	(multiple-value-bind (prev tilde)
671	(format-find-command-no-params '(#\]) :colon nil :atsign nil)
672	(sub-format stream prev tilde))
673	(progn
674	(sub-format stream prev tilde)
675	(format-find-command-no-params '(#\]))))))
676
677
678	(defformat #\[ format-condition (stream colon atsign &optional p)
679	(when p (push p format-arguments))
680	(format-nextchar)
681	(cond (colon
682	(when atsign
683	(format-error "~~:@[ undefined"))
684	(format-boolean-condition stream))
685	(atsign
686	(format-funny-condition stream))
687	(t (format-untagged-condition stream))))
688
689
690	;;; Iteration ~{ ... ~}
691
692	(defformat #\{ format-iteration (stream colon atsign &rest parms)
693	(declare (dynamic-extent parms))
694	(with-format-parameters parms ((max-iter -1))
695	(format-nextchar)
696	(multiple-value-bind (prev tilde end-cmd end-colon end-atsign)
697	(format-find-command-no-params '(#\}) :atsign nil)
698	(declare (ignore end-cmd end-atsign))
699	(if (= prev tilde)
700	;; Use an argument as the control string if ~{~} is empty
701	(let ((string (pop-format-arg)))
702	(cond ((stringp string)
703	(when (not (simple-string-p string)) ; fix here too
704	(setq string (coerce string 'simple-string))))
705	((not (functionp string))
706	(format-error "Control string is not a string or function")))
707	(let ((error
708	(catch 'format-error
709	(cond
710	((stringp string)
711	(let* ((length (length (the simple-string string)))
712	(format-control-string string)
713	(format-length length)
714	(format-index 0))
715	(format-do-iteration stream 0 length
716	max-iter colon atsign end-colon)))
717	(t ;(functionp string)
718	(format-do-iteration stream string nil
719	max-iter colon atsign end-colon)))
720	nil)))
721	(when error (format-indirect-error error))))
722	(format-do-iteration stream prev tilde
723	max-iter colon atsign end-colon)))))
724
725
726	;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here
727	;;; to correctly implement ~^ and ~:^. The former aborts only the current
728	;;; iteration, but the latter aborts the entire iteration process.
729	;;; ~{ arg is a list ~:{ arg is list of sublists, ~@{ arg is spread ~:@{ spread lists
730	;;; We have nuked two catch tags. Instead throw two different values:
731	;;; T if ~^ and 'format-colon-escape if ~:^
732
733	(defun format-do-iteration (stream start end max-iter colon atsign at-least-once-p)
734	(flet ((do-iteration-1 (stream start end colon at-least-once-p)
735	(let (catchp)
736	(do* ((count 0 (1+ count)))
737	((or (= count max-iter)
738	(and (null format-arguments)
739	(if (= count 0) (not at-least-once-p) t))))
740	(setq catchp
741	(catch 'format-escape
742	(if colon
743	(let* ((args (unless (and at-least-once-p (null format-arguments))
744	(pop-format-arg)))
745	(format-top-level nil)
746	(format-colon-rest format-arguments)
747	(format-arguments args)
748	(format-original-arguments args))
749	(unless (listp format-arguments)
750	(report-bad-arg format-arguments 'list))
751	(if (functionp start)
752	(apply start stream args)
753	(sub-format stream start end)))
754	(let ((format-original-arguments format-arguments))
755	(if (functionp start)
756	(setq format-arguments (apply start stream format-arguments))
757	(sub-format stream start end))))
758	nil))
759	(when (or (eq catchp 'format-colon-escape)
760	(and catchp (null colon)))
761	(return-from do-iteration-1 nil))))))
762	(if atsign
763	(do-iteration-1 stream start end colon at-least-once-p)
764	; no atsign - munch on first arg
765	(let* ((format-arguments (pop-format-arg))
766	(format-top-level nil)
767	(format-original-arguments format-arguments))
768	(unless (listp format-arguments)
769	(report-bad-arg format-arguments 'list))
770	(do-iteration-1 stream start end colon at-least-once-p)))))
771
772
773	;;; Justification ~< ... ~>
774
775	;;; Parses a list of clauses delimited by ~; and terminated by ~>.
776	;;; Recursively invoke SUB-FORMAT to process them, and return a list
777	;;; of the results, the length of this list, and the total number of
778	;;; characters in the strings composing the list.
779
780
781	(defun format-get-trailing-segments ()
782	(format-nextchar)
783	(multiple-value-bind (prev tilde parms colon atsign cmd)
784	(format-find-command '(#\; #\>) nil T)
785	(with-format-parameters parms ()
786	(when colon
787	(format-error "~~:; allowed only after first segment in ~~<"))
788	(format-no-flags nil atsign))
789	(let ((str (catch 'format-escape
790	(with-format-string-output stream
791	(sub-format stream prev tilde)))))
792	(if (stringp str)
793	(if (eq cmd #\;)
794	(multiple-value-bind
795	(segments numsegs numchars)
796	(format-get-trailing-segments)
797	(values (cons str segments)
798	(1+ numsegs)
799	(+ numchars
800	(length str))))
801	(values (list str)
802	1
803	(length str)))
804	(progn
805	(unless (eq cmd #\>) (format-find-command '(#\>) nil T))
806	(values () 0 0))))))
807
808
809	;;; Gets the first segment, which is treated specially. Call
810	;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest.
811
812	(defun format-get-segments ()
813	(let (ignore)
814	(declare (ignore-if-unused ignore)) ; why??
815	(multiple-value-bind (prev tilde parms colon atsign cmd)
816	(format-find-command '(#\; #\>) nil T) ; skipping
817	(when atsign
818	(format-error "Atsign flag not allowed"))
819	;(setq format-arguments blech)
820	(let ((first-seg (catch 'format-escape
821	(with-format-string-output stream
822	(sub-format stream prev tilde)))))
823	(if (stringp first-seg)
824	(if (eq cmd #\;)
825	(progn
826	(when parms
827	(setq format-index tilde)
828	; now get the parameters if any - do this way cause of the V thingies
829	; maybe only necessary in the : case
830	(multiple-value-setq (ignore ignore parms)
831	(format-find-command '(#\; #\>) t T)))
832	(multiple-value-bind
833	(segments numsegs numchars)
834	(format-get-trailing-segments)
835	(if colon
836	(values first-seg parms segments numsegs numchars)
837	(values nil nil (cons first-seg segments)
838	(1+ numsegs)
839	(+ (length first-seg) numchars)))))
840	(values nil nil (list first-seg) 1 (length first-seg)))
841	(progn
842	(unless (eq cmd #\>) (format-find-command '(#\>) nil T))
843	(values nil nil () 0 0)))))))
844
845
846	#\|
847	;;; Given the total number of SPACES needed for padding, and the number
848	;;; of padding segments needed (PADDINGS), returns a list of such segments.
849	;;; We try to allocate the spaces equally to each segment. When this is
850	;;; not possible, we allocate the left-over spaces randomly, to improve the
851	;;; appearance of many successive lines of justified text.
852	;;;
853	;;; Query: Is this right? Perhaps consistency might be better for the kind
854	;;; of applications ~<~> is used for.
855
856	(defun make-pad-segs (spaces paddings)
857	(do* ((extra-space () (and (plusp extra-spaces)
858	(< (random (float 1)) (/ segs extra-spaces))))
859	(result () (cons (if extra-space (1+ min-space) min-space) result))
860	(min-space (truncate spaces paddings))
861	(extra-spaces (- spaces (* paddings min-space))
862	(if extra-space (1- extra-spaces) extra-spaces))
863	(segs paddings (1- segs)))
864	((zerop segs) result)))
865	\|#
866	(defun make-pad-segs (spaces segments)
867	(multiple-value-bind (min-space extra-spaces) (truncate spaces segments)
868	(declare (fixnum min-space extra-spaces))
869	(let* ((result (make-list segments :initial-element min-space))
870	(res result))
871	(setq min-space (1+ min-space))
872	(dotimes (i extra-spaces)
873	(rplaca res min-space)
874	(setq res (%cdr res)))
875	result)))
876
877	;;; Determine the actual width to be used for a field requiring WIDTH
878	;;; characters according to the following rule: If WIDTH is less than or
879	;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up
880	;;; to MINCOL + k * COLINC for the smallest possible positive integer k.
881
882	(defun format-round-columns (width mincol colinc)
883	(if (< width mincol)
884	(+ width (* colinc (ceiling (- mincol width) colinc)))
885	width))
886
887	(defun format-justification-round-columns (width mincol colinc)
888	(if (< width mincol)
889	mincol
890	(+ mincol (* colinc (ceiling (- width mincol) colinc)))))
891
892	(defformat #\< format-justification (stream colon atsign &rest parms)
893	(declare (dynamic-extent parms))
894	(multiple-value-bind (start tilde ecmd ecolon eatsign)
895	(format-find-command-no-params '(#\>)) ; bumps format-index
896	(declare (ignore tilde ecmd))
897	(cond
898	(ecolon
899	(format-logical-block stream colon atsign eatsign start format-index parms))
900	(t (setq format-index start)
901	(with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
902	(unless (integerp mincol)
903	(format-error "Mincol must be an integer - ~S" mincol))
904	(unless (and (integerp colinc) (plusp colinc))
905	(format-error "Colinc must be a positive integer - ~S" colinc))
906	(unless (integerp minpad)
907	(format-error "Minpad must be an integer - ~S" minpad))
908	(unless (characterp padchar)
909	(if (typep padchar `(integer 0 #.char-code-limit))
910	(setq padchar (code-char padchar))
911	(format-error "Padchar must be a character or integer from 0 to ~a - ~S"
912	char-code-limit padchar)))
913	(format-nextchar)
914	(multiple-value-bind (special-arg special-parms segments numsegs numchars)
915	(format-get-segments)
916	(when (= numsegs 1) (setq minpad 0))
917	(when segments
918	(let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0)
919	(1- numsegs)
920	(if atsign 1 0)))
921	(width (format-justification-round-columns (+ numchars (* minpad padsegs))
922	mincol colinc))
923	(spaces (if (and atsign (not colon) (= numsegs 1)) ;dirty but works
924	(list 0 (- width numchars))
925	(append (if (or colon (= numsegs 1)) () '(0))
926	(make-pad-segs (- width numchars) padsegs)
927	(if atsign () '(0))))))
928	(when special-arg
929	(if format-pprint
930	(format-error "Justification illegal in this context"))
931	(setq format-justification-semi t)
932	(with-format-parameters special-parms ((spare 0)
933	(linel (stream-line-length stream)))
934
935	(let ((pos (column stream)))
936	(when (> (+ pos width spare) linel)
937	(stream-write-entire-string stream special-arg)))))
938	(do ((segs segments (cdr segs))
939	(spcs spaces (cdr spcs)))
940	((null segs) (dotimes (i (car spcs)) (write-char padchar stream)))
941	(dotimes (i (car spcs)) (write-char padchar stream))
942	(stream-write-entire-string stream (car segs)))))))))))
943
944
945	(defun format-logical-block (stream colon atsign end-atsign start end &rest parms)
946	(declare (ignore parms))
947	(flet ((format-check-simple (str)
948	(when (and str (or (%str-member #\~ str) (%str-member #\newline str)))
949	(format-error "Suffix and prefix must be simple")))
950	(first-block-p (start)
951	(let* ((format-index 0))
952	(loop
953	(parse-format-operation)
954	(when (eq (format-peek) #\<)
955	(cond ((eq format-index start)
956	(return t))
957	(t (return nil))))))))
958	(format-no-semi #\<)
959	(let ((format-string format-control-string)
960	(prefix (if colon "(" ""))
961	(suffix (if colon ")" ""))
962	body-string start1 tilde ignore colon1 atsign1 per-line-p)
963	(declare (ignore-if-unused ignore colon1))
964	(setq format-index start)
965	(multiple-value-setq (start1 tilde ignore colon1 atsign1)
966	(format-find-command '(#\; #\>)))
967	(setq body-string (%substr format-string (1+ start) tilde))
968	(when (not (eql format-index end)) ; > 1 segment
969	(setq prefix body-string)
970	(if atsign1 (setq per-line-p t))
971	(multiple-value-setq (start1 tilde)
972	(format-find-command '(#\; #\>)))
973	(setq body-string (%substr format-string (1+ start1) tilde))
974	(when (neq format-index end)
975	(multiple-value-setq (start1 tilde)(format-find-command '(#\; #\>)))
976	(setq suffix (%substr format-string (1+ start1) tilde))
977	(when (neq format-index end)
978	(format-error "Too many chunks"))))
979	(when end-atsign (setq body-string (format-fill-transform body-string)))
980	(format-check-simple prefix)
981	(format-check-simple suffix)
982	(let ((args (if (not atsign)
983	; This piece of garbage is needed to avoid double length counting from (formatter ...) things
984	; but also to allow (flet . t) not to barf.
985	; Was formerly simply (if format-arguments (pop-format-arg))
986	; Actually wanna not count the arg iff the ~< is at the top level
987	; in a format string i.e. "is this the first ~< in THIS string?"
988	(when format-arguments
989	(if (and (listp format-arguments)
990	(first-block-p start))
991	(pop format-arguments) ; dont count
992	(pop-format-arg))) ; unless not listp or not first
993	(prog1 format-arguments
994	(setq format-arguments nil))))
995	(format-control-string body-string)
996	(format-top-level (and atsign format-top-level)))
997	(let ((logical-block-p t)
998	(xp-struct (cond ((xp-structure-p stream) stream)
999	((typep stream 'xp-stream)
1000	(slot-value stream 'xp-structure)))))
1001	; lets avoid unnecessary closures
1002	(cond (xp-struct (logical-block-sub xp-struct args prefix suffix per-line-p atsign))
1003	(t (maybe-initiate-xp-printing
1004	#'(lambda (s o)
1005	(logical-block-sub s o prefix suffix per-line-p atsign))
1006	stream args))))))))
1007
1008
1009
1010	; flet?
1011	(defun logical-block-sub (stream args prefix suffix per-line-p atsign)
1012	;(push (list args body-string) barf)
1013	(let ((circle-chk (not (or format-top-level (and atsign (eq current-length -1)))))) ; i.e. ~<~@<
1014	(let ((current-level (1+ current-level)) ; these are for pprint
1015	(current-length -1))
1016	(declare (special current-level current-length))
1017	(unless (check-block-abbreviation stream args circle-chk) ;(neq args format-original-arguments)) ;??
1018	(start-block stream prefix per-line-p suffix)
1019	(let ((logical-block-xp stream) ; for pop-format-arg
1020	(my-stream (if (xp-structure-p stream) (get-xp-stream stream) stream)))
1021	(catch 'logical-block
1022	(do-sub-format-1 my-stream args)))
1023	(end-block stream suffix)))))
1024
1025	; bash in fill conditional newline after white space (except blanks after ~<newline>)
1026	; I think this is silly!
1027	(defun format-fill-transform (string)
1028	(let ((pos 0)(end (length (the string string)))(result "") ch)
1029	(while (%i< pos end)
1030	(let ((wsp-pos (min (or (%str-member #\space string pos) end)
1031	(or (%str-member #\tab string pos) end)))
1032	(yes nil))
1033	(when (%i< wsp-pos end)
1034	(when (not (and (%i> wsp-pos 1)
1035	(eq (schar string (%i- wsp-pos 1)) #\newline)
1036	(or (eq (setq ch (schar string (%i- wsp-pos 2))) #\~)
1037	(and (%i> wsp-pos 2)
1038	(memq ch '(#\: #\@))
1039	(eq (schar string (%i- wsp-pos 3)) #\~)))))
1040	(setq yes t))
1041	(loop
1042	(while (%i< wsp-pos end)
1043	(setq ch (schar string wsp-pos))
1044	(when (Not (%str-member ch wsp)) (return))
1045	(setq wsp-pos (%i+ 1 wsp-pos)))
1046	(return)))
1047	(setq result (%str-cat result (%substr string pos wsp-pos) (if yes "~:_" "")))
1048	(setq pos wsp-pos)))
1049	result))
1050
1051
1052	;;;;some functions needed for dealing with floats
1053
1054	;;;; Floating Point printing
1055	;;;
1056	;;; Written by Bill Maddox
1057	;;;
1058	;;;
1059	;;;
1060	;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of
1061	;;; the work for all printing of floating point numbers in the printer and in
1062	;;; FORMAT. It converts a floating point number to a string in a free or
1063	;;; fixed format with no exponent. The interpretation of the arguments is as
1064	;;; follows:
1065	;;;
1066	;;; X - The floating point number to convert, which must not be
1067	;;; negative.
1068	;;; WIDTH - The preferred field width, used to determine the number
1069	;;; of fraction digits to produce if the FDIGITS parameter
1070	;;; is unspecified or NIL. If the non-fraction digits and the
1071	;;; decimal point alone exceed this width, no fraction digits
1072	;;; will be produced unless a non-NIL value of FDIGITS has been
1073	;;; specified. Field overflow is not considerd an error at this
1074	;;; level.
1075	;;; FDIGITS - The number of fractional digits to produce. Insignificant
1076	;;; trailing zeroes may be introduced as needed. May be
1077	;;; unspecified or NIL, in which case as many digits as possible
1078	;;; are generated, subject to the constraint that there are no
1079	;;; trailing zeroes.
1080	;;; SCALE - If this parameter is specified or non-NIL, then the number
1081	;;; printed is (* x (expt 10 scale)). This scaling is exact,
1082	;;; and cannot lose precision.
1083	;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1084	;;; number of fraction digits which will be produced, regardless
1085	;;; of the value of WIDTH or FDIGITS. This feature is used by
1086	;;; the ~E format directive to prevent complete loss of
1087	;;; significance in the printed value due to a bogus choice of
1088	;;; scale factor.
1089	;;;
1090	;;; Most of the optional arguments are for the benefit for FORMAT and are not
1091	;;; used by the printer.
1092	;;;
1093	;;; Returns:
1094	;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1095	;;; where the results have the following interpretation:
1096	;;;
1097	;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1098	;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1099	;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1100	;;; decimal point.
1101	;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1102	;;; decimal point.
1103	;;; POINT-POS - The position of the digit preceding the decimal
1104	;;; point. Zero indicates point before first digit.
1105	;;; NZEROS - number of zeros after point
1106	;;;
1107	;;; WARNING: For efficiency, there is a single string object digit-string
1108	;;; which is modified destructively and returned as the value of
1109	;;; FLONUM-TO-STRING. Thus the returned value is not valid across multiple
1110	;;; calls.
1111	;;;
1112	;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
1113	;;; Specifically, the decimal number printed is the closest possible
1114	;;; approximation to the true value of the binary number to be printed from
1115	;;; among all decimal representations with the same number of digits. In
1116	;;; free-format output, i.e. with the number of digits unconstrained, it is
1117	;;; guaranteed that all the information is preserved, so that a properly-
1118	;;; rounding reader can reconstruct the original binary number, bit-for-bit,
1119	;;; from its printed decimal representation. Furthermore, only as many digits
1120	;;; as necessary to satisfy this condition will be printed.
1121	;;;
1122	;;;
1123	;;; FLOAT-STRING actually generates the digits for positive numbers. The
1124	;;; algorithm is essentially that of algorithm Dragon4 in "How to Print
1125	;;; Floating-Point Numbers Accurately" by Steele and White. The current
1126	;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press.
1127	;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING
1128	;;; THE PAPER!
1129
1130
1131
1132
1133	(defun flonum-to-string (n &optional width fdigits scale)
1134	(let ((print-radix nil))
1135	(cond ((zerop n)(values "" 0 0))
1136	((and (not (or width fdigits scale))
1137	(double-float-p n)
1138	; cheat for the only (?) number that fails to be aesthetically pleasing
1139	(= n 1e23))
1140	(values "1" 24 23))
1141	(t (let ((string (make-array 12 :element-type 'base-char
1142	:fill-pointer 0 :adjustable t)))
1143	(multiple-value-bind (sig exp)(integer-decode-float n)
1144	(float-string string sig exp (integer-length sig) width fdigits scale)))))))
1145
1146	;;; if width given and fdigits nil then if exponent is >= 0 returns at
1147	;;; most width-1 digits if exponent is < 0 returns (- width (- exp) 1)
1148	;;; digits if fdigits given width is ignored, returns fdigits after
1149	;;; (implied) point The Steele/White algorithm can produce a leading
1150	;;; zero for 1e23 which lies exactly between two double floats -
1151	;;; rounding picks the float whose rational is
1152	;;; 99999999999999991611392. This guy wants to print as
1153	;;; 9.999999999999999E+22. The untweaked algorithm generates a leading
1154	;;; zero in this case. (actually wants to print as 1e23!) If we
1155	;;; choose s such that r < s - m/2, and r = s/10 - m/2 (which it does
1156	;;; in this case) then r * 10 < s => first digit is zero and
1157	;;; (remainder (* r 10) s) is r * 10 = new-r, 10 * m = new-m new-r = s
1158	;;; - new-m/2 so high will be false and she won't round up we do r *
1159	;;; (expt 2 (- e (- scale))) and s * (expt 5 (- scale)) i.e. both less
1160	;;; by (expt 2 (- scale))
1161
1162	(defun float-string (string f e p &optional width fdigits scale)
1163	(macrolet ((nth-digit (n) `(%code-char (%i+ ,n (%char-code #\0)))))
1164	(let ((r f)(s 1)(m- 1)(m+ 1)(k 0) cutoff roundup (mm nil))
1165	(when (= f (if (eql p 53) #.(ash 1 52) (ash 1 (1- p))))
1166	(setq mm t))
1167	(when (or (null scale)(zerop scale))
1168	; approximate k
1169	(let ((fudge 0))
1170	(setq fudge (truncate (* (%i+ e p) .301)))
1171	(when (neq fudge 0)
1172	(setq k fudge)
1173	(setq scale (- k)))))
1174	(when (and scale (not (eql scale 0)))
1175	(if (minusp scale)
1176	(setq s (* s (5-to-e (- scale))))
1177	(let ((scale-factor (5-to-e scale)))
1178	(setq r (* r scale-factor))
1179	(setq m+ scale-factor)
1180	(when mm (setq m- scale-factor)))))
1181	(let ((shift (- e (if scale (- scale) 0))))
1182	(declare (fixnum shift))
1183	;(print (list e scale shift))
1184	(cond ((> shift 0)
1185	(setq r (ash f shift))
1186	(setq m+ (ash m+ shift))
1187	(when mm (setq m- (ash m- shift))))
1188	((< shift 0)
1189	(setq s (ash s (- shift))))))
1190	(when mm
1191	(setq m+ (+ m+ m+))
1192	(setq r (+ r r))
1193	(setq s (+ s s)))
1194	(let ((ceil (ceiling s 10))(fudge 1))
1195	(while (< r ceil)
1196	(setq k (1- k))
1197	(setq r (* r 10))
1198	(setq fudge (* fudge 10)))
1199	(when (> fudge 1)
1200	(setq m+ (* m+ fudge))
1201	(when mm (setq m- (* m- fudge)))))
1202	(let ((2r (+ r r)))
1203	(loop
1204	(let ((2rm+ (+ 2r m+)))
1205	(while
1206	(if (not roundup) ; guarantee no leading zero
1207	(> 2rm+ (+ s s))
1208	(>= 2rm+ (+ s s)))
1209	(setq s (* s 10))
1210	(setq k (1+ k))))
1211	(when (not (or fdigits width))(return))
1212	(cond
1213	(fdigits (setq cutoff (- fdigits)))
1214	(width
1215	(setq cutoff
1216	(if (< k 0) (- 1 width)(1+ (- k width))))
1217	;(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))
1218	))
1219	(let ((a (if cutoff (- cutoff k) 0))
1220	(y s))
1221	(DECLARE (FIXNUM A))
1222	(if (>= a 0)
1223	(when (> a 0)(setq y (* y (10-to-e a))))
1224	(setq y (ceiling y (10-to-e (the fixnum (- a))))))
1225	(when mm (setq m- (max y m-)))
1226	(setq m+ (max y m+))
1227	(when (= m+ y) (setq roundup t)))
1228	(when (if (not roundup) ; tweak as above
1229	(<= (+ 2r m+)(+ s s))
1230	(< (+ 2r m+)(+ s s)))
1231	(return))))
1232	(let* ((h k)
1233	(half-m+ (* m+ 5)) ; 10 * m+/2
1234	(half-m- (if mm (* m- 5)))
1235	u high low
1236	)
1237	;(print (list r s m+ roundup))
1238	(unless (and fdigits (>= (- k) fdigits))
1239	(loop
1240	(setq k (1- k))
1241	(multiple-value-setq (u r) (truncate (* r 10) s))
1242	(setq low (< r (if mm half-m- half-m+)))
1243	(setq high
1244	(if (not roundup)
1245	(> r (- s half-m+))
1246	(>= r (- s half-m+))))
1247	(if (or low high)
1248	(return)
1249	(progn
1250	(vector-push-extend (nth-digit u) string)))
1251	(when mm (setq half-m- (* half-m- 10) ))
1252	(setq half-m+ (* half-m+ 10)))
1253	;(print (list r s high low h k))
1254	(vector-push-extend
1255	(nth-digit (cond
1256	((and low (not high)) u)
1257	((and high (not low))(+ u 1))
1258
1259	(t ;(and high low)
1260	(if (<= (+ r r) s) u (1+ u)))))
1261	string))
1262	; second value is exponent, third is exponent - # digits generated
1263	(values string h k)))))
1264
1265
1266	(defparameter integer-powers-of-10 (make-array (+ 12 (floor 324 12))))
1267
1268	; e better be positive
1269	(defun 10-to-e (e)
1270	(declare (fixnum e)(optimize (speed 3)(safety 0)))
1271	(if (> e 335)
1272	(* (10-to-e 334) (10-to-e (%i- e 334)))
1273	(if (< e 12)
1274	(svref integer-powers-of-10 e)
1275	(multiple-value-bind (q r) (truncate e 12)
1276	(declare (fixnum q r))
1277	(if (eql r 0)
1278	(svref integer-powers-of-10 (%i+ q 11))
1279	(* (svref integer-powers-of-10 r)
1280	(svref integer-powers-of-10 (%i+ q 11))))))))
1281
1282
1283	(let ((array integer-powers-of-10))
1284	(dotimes (i 12)
1285	(setf (svref array i) (expt 10 i)))
1286	(dotimes (i (floor 324 12))
1287	(setf (svref array (+ i 12)) (expt 10 (* 12 (1+ i))))))
1288	#\|
1289	(defun 10-to-e (e)
1290	(ash (5-to-e e) e))
1291	\|#
1292
1293
1294
1295
1296	;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
1297	;;; new floating point number Z in the range (0.1, 1.0] and and exponent
1298	;;; E such that Z * 10^E is (approximately) equal to the original number.
1299	;;; There may be some loss of precision due the floating point representation.
1300	;;; JUST do the EXPONENT since thats all we use
1301
1302
1303	(defconstant long-log10-of-2 0.30103d0)
1304
1305	#\|
1306	(defun scale-exponent (x)
1307	(if (floatp x )
1308	(scale-expt-aux (abs x) 0.0d0 1.0d0 1.0d1 1.0d-1 long-log10-of-2)
1309	(report-bad-arg x 'float)))
1310
1311	#\|this is the slisp code that was in the place of the error call above.
1312	before floatp was put in place of shortfloatp.
1313	;(scale-expt-aux x (%sp-l-float 0) (%sp-l-float 1) %long-float-ten
1314	; %long-float-one-tenth long-log10-of-2)))
1315	\|#
1316
1317	; this dies with floating point overflow (?) if fed least-positive-double-float
1318
1319	(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
1320	(let ((exponent (nth-value 1 (decode-float x))))
1321	(if (= x zero)
1322	(values zero 1)
1323	(let* ((e (round (* exponent log10-of-2)))
1324	(x (if (minusp e) ;For the end ranges.
1325	(* x ten (expt ten (- -1 e)))
1326	(/ x ten (expt ten (1- e))))))
1327	(do ((d ten (* d ten))
1328	(y x (/ x d))
1329	(e e (1+ e)))
1330	((< y one)
1331	(do ((m ten (* m ten))
1332	(z y (* z m))
1333	(e e (1- e)))
1334	((>= z one-tenth) (values x e)))))))))
1335	\|#
1336
1337	(defun scale-exponent (n)
1338	(let ((exp (nth-value 1 (decode-float n))))
1339	(values (round (* exp long-log10-of-2)))))
1340
1341
1342	;;; Page ~\|
1343
1344	(defformat #\\| format-page (stream colon atsign &rest parms)
1345	(declare (dynamic-extent parms))
1346	(format-no-flags colon atsign)
1347	(with-format-parameters parms ((repeat-count 1))
1348	(declare (fixnum repeat-count))
1349	(dotimes (i repeat-count) (write-char #\page stream))))
1350
1351
1352	(defun format-eat-whitespace ()
1353	(do* ((i format-index (1+ i))
1354	(s format-control-string)
1355	(n format-length))
1356	((or (= i n)
1357	(not (whitespacep (schar s i))))
1358	(setq format-index (1- i)))))
1359
1360	(defun format-newline (stream colon atsign parms)
1361	(with-format-parameters parms ()
1362	(cond (colon
1363	(when atsign
1364	(format-error "~:@<newline> is undefined")))
1365	(atsign (terpri stream) (format-eat-whitespace))
1366	(t (format-eat-whitespace)))))
1367
1368	(defformat #\newline format-newline (stream colon atsign &rest parms)
1369	(declare (dynamic-extent parms))
1370	(format-newline stream colon atsign parms))
1371
1372	(defformat #\return format-newline (stream colon atsign &rest parms)
1373	(declare (dynamic-extent parms))
1374	(format-newline stream colon atsign parms))
1375
1376	;;; Indirection ~?
1377
1378	(defformat #\? format-indirection (stream colon atsign)
1379	(format-no-flags colon nil)
1380	(let ((string (pop-format-arg)))
1381	(unless (or (stringp string)(functionp string))
1382	(format-error "Indirected control string is not a string or function"))
1383	; fix so 3.1 doesn't make an extended-string here! for which %str-member was busted
1384	; it didn't fail in 3.0 cause the setq was erroneously missing
1385	; should really fix the compiler macro to not do that! - done
1386	(when (AND (stringp string)(NOT (SIMPLE-STRING-P STRING)))
1387	(setq string (coerce string 'simple-string)))
1388	(catch 'format-escape
1389	(let ((error
1390	(catch 'format-error
1391	(cond
1392	((stringp string)
1393	(let* ((length (length (the simple-string string)))
1394	(format-control-string string)
1395	(format-length length)
1396	(format-index 0))
1397	(if atsign
1398	(sub-format stream 0 length)
1399	(let ((args (pop-format-arg)))
1400	(let ((format-top-level nil)
1401	(format-arguments args)
1402	(format-original-arguments args))
1403	(sub-format stream 0 length))))))
1404	(T ;(functionp string)
1405	(if (not atsign)
1406	(apply string stream (pop-format-arg))
1407	; account for the args it eats
1408	(setq format-arguments (apply string stream format-arguments)))))
1409	nil)))
1410	(when error (format-indirect-error error))))))
1411
1412
1413
1414
1415	;;; Ascii ~A
1416
1417	(defformat #\A format-princ (stream colon atsign &rest parms)
1418	(declare (dynamic-extent parms))
1419	(let ((arg (pop-format-arg)))
1420	(if (null parms)
1421	(princ (or arg (if colon "()" nil)) stream)
1422	(with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1423	(format-write-field
1424	stream
1425	(if (or arg (not colon))
1426	(princ-to-string arg)
1427	"()")
1428	mincol colinc minpad padchar atsign)))))
1429
1430
1431
1432	;;; S-expression ~S
1433
1434	(defformat #\S format-prin1 (stream colon atsign &rest parms)
1435	(declare (dynamic-extent parms))
1436	(let ((arg (pop-format-arg)))
1437	(if (null parms)
1438	(if (or arg (not colon)) (prin1 arg stream) (princ "()" stream))
1439	(with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1440	(format-write-field
1441	stream
1442	(if (or arg (not colon))
1443	(prin1-to-string arg)
1444	"()")
1445	mincol colinc minpad padchar atsign)))))
1446
1447
1448
1449	;;; Character ~C
1450
1451	(defformat #\C format-print-character (stream colon atsign)
1452	(let* ((char (character (pop-format-arg)))
1453	(code (char-code char))
1454	(name (char-name char)))
1455	(cond ((and atsign (not colon))
1456	(prin1 char stream))
1457	(colon
1458	(if (or (eql char #\space)
1459	(not (graphic-char-p char)))
1460	(princ name stream)
1461	(write-char char stream)))
1462	((not (or atsign colon))
1463	(write-char char stream))
1464	((and (< code 32) atsign)
1465	(setq char (code-char (logxor code 64)))
1466	(if (or colon (%str-member char "@CGHIJKLM[\\]^_"))
1467	(princ name stream)
1468	(progn
1469	(write-char #\^ stream)
1470	(write-char char stream)))
1471	(princ " (" stream)
1472	(princ "Control " stream)
1473	(write-char char stream)
1474	(write-char #\) stream))
1475	(name (princ name stream))
1476	(t (write-char char stream)))))
1477
1478
1479	;;; NUMERIC PRINTING
1480
1481
1482
1483	;;; Output a string in a field at MINCOL wide, padding with PADCHAR.
1484	;;; Pads on the left if PADLEFT is true, else on the right. If the
1485	;;; length of the string plus the minimum permissible padding, MINPAD,
1486	;;; is greater than MINCOL, the actual field size is rounded up to
1487	;;; MINCOL + k * COLINC for the smallest possible positive integer k.
1488
1489	(defun format-write-field (stream string mincol colinc minpad padchar padleft)
1490	(unless (or (null mincol)
1491	(integerp mincol))
1492	(format-error "Mincol must be an integer - ~S" mincol))
1493	(unless (and (integerp colinc) (plusp colinc))
1494	(format-error "Colinc must be a positive integer - ~S" colinc))
1495	(unless (integerp minpad)
1496	(format-error "Minpad must be an integer - ~S" minpad))
1497	(unless (characterp padchar)
1498	(if (typep padchar `(integer 0 #.char-code-limit))
1499	(setq padchar (code-char padchar))
1500	(format-error "Padchar must be a character or integer from 0 to ~a - ~S"
1501	char-code-limit padchar)))
1502	(let* ((strlen (length (the string string)))
1503	(strwid (+ strlen minpad))
1504	(width (if mincol
1505	(format-round-columns strwid mincol colinc)
1506	strwid)))
1507	(if padleft
1508	(dotimes (i (the fixnum (- width strlen))) (write-char padchar stream)))
1509	(write-string string stream :start 0 :end strlen)
1510	(unless padleft
1511	(dotimes (i (the fixnum (- width strlen))) (write-char padchar stream)))))
1512
1513
1514	;;; This functions does most of the work for the numeric printing
1515	;;; directives. The parameters are interpreted as defined for ~D.
1516
1517	(defun format-print-number (stream number radix print-commas-p print-sign-p parms)
1518	(declare (dynamic-extent parms))
1519	(declare (type t number) (type fixnum radix))
1520	#+wrong
1521	(when (> (length parms) 2) (setq print-commas-p t)) ; print commas if char or interval provided
1522	(if (not (integerp number))
1523	(let ((print-base radix)
1524	(print-escape nil)
1525	(print-radix nil))
1526	(declare (special print-base print-radix))
1527	(princ number stream))
1528	(with-format-parameters parms
1529	((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
1530	; look out for ",0D" - should be ",'0D"
1531	(unless (characterp padchar)
1532	(error "Use '~A instead of ~A for padchar in format directive" padchar padchar))
1533	(setq print-sign-p
1534	(cond ((and print-sign-p (>= number 0)) #\+)
1535	((< number 0) #\-)))
1536	(setq number (abs number))
1537	(block HAIRY
1538	(block SIMPLE
1539	(if (and (not print-commas-p) (eql 0 mincol))
1540	(return-from SIMPLE))
1541	(let ((lg 0)
1542	(commas 0))
1543	(declare (type fixnum lg commas))
1544	(do ((n (abs number) (floor n radix)))
1545	((%i< n radix))
1546	(declare (type integer n))
1547	(setq lg (%i+ lg 1))) ; lg is 1- significant digits
1548	(setq commas (if print-commas-p
1549	(floor lg commainterval)
1550	0))
1551	(when print-sign-p
1552	(setq lg (1+ lg)))
1553	(when (and (eq commas 0)
1554	(%i<= mincol lg))
1555	(return-from SIMPLE))
1556	;; Cons-o-rama no more !
1557	(let* ((s (make-string-output-stream)))
1558	(when (neq padchar #\space)
1559	(dotimes (i (- mincol (+ lg commas) 1))
1560	(write-char padchar s)))
1561	(when print-sign-p (write-char print-sign-p s))
1562	(%pr-integer number radix s)
1563	(dotimes (i (the fixnum commas)) (write-char commachar s))
1564	(let ((text (get-output-stream-string s)))
1565	(declare (type string text))
1566	;; -1234567,, => -1,234,567
1567	(when (%i> commas 0)
1568	(do* ((dest (%i- (length text) 1))
1569	(source (%i- dest commas)))
1570	((= source dest))
1571	(declare (type fixnum dest source))
1572	(dotimes (i (the fixnum commainterval))
1573	(setf (char text dest) (char text source)
1574	dest (1- dest)
1575	source (1- source)))
1576	(setf (char text dest) commachar
1577	dest (1- dest))))
1578	(format-write-field stream text mincol 1 0 padchar t)
1579	(return-from HAIRY)))))
1580	;; SIMPLE case
1581	(when print-sign-p (write-char print-sign-p stream))
1582	(%pr-integer number radix stream))))
1583	nil)
1584
1585	;;; Print a cardinal number in English
1586
1587	(eval-when (:compile-toplevel :execute)
1588	(defmacro cardinal-ones ()
1589	"Table of cardinal ones-place digits in English"
1590	'#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
1591	(defmacro cardinal-tens ()
1592	"Table of cardinal tens-place digits in English"
1593	'#(nil nil "twenty" "thirty" "forty"
1594	"fifty" "sixty" "seventy" "eighty" "ninety"))
1595	(defmacro cardinal-teens ()
1596	'#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
1597	"fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
1598	)
1599
1600
1601	(defun format-print-small-cardinal (stream n)
1602	(multiple-value-bind (hundreds rem) (truncate n 100)
1603	(when (plusp hundreds)
1604	(write-string (svref (cardinal-ones) hundreds) stream)
1605	(write-string " hundred" stream)
1606	(when (plusp rem) (write-char #\space stream))) ; ; ; RAD
1607	(when (plusp rem)
1608	(multiple-value-bind (tens ones) (truncate rem 10)
1609	(cond ((< 1 tens)
1610	(write-string (svref (cardinal-tens) tens) stream)
1611	(when (plusp ones)
1612	(write-char #\- stream)
1613	(write-string (svref (cardinal-ones) ones) stream)))
1614	((= tens 1)
1615	(write-string (svref (cardinal-teens) ones) stream))
1616	((plusp ones)
1617	(write-string (svref (cardinal-ones) ones) stream)))))))
1618
1619	(eval-when (:compile-toplevel :execute)
1620	(defmacro cardinal-periods ()
1621	"Table of cardinal 'teens' digits in English"
1622	'#("" " thousand" " million" " billion" " trillion" " quadrillion"
1623	" quintillion" " sextillion" " septillion" " octillion" " nonillion"
1624	" decillion"))
1625	)
1626
1627
1628	(defun format-print-cardinal (stream n)
1629	(cond ((minusp n)
1630	(stream-write-entire-string stream "negative ")
1631	(format-print-cardinal-aux stream (- n) 0 n))
1632	((zerop n)
1633	(stream-write-entire-string stream "zero"))
1634	(t (format-print-cardinal-aux stream n 0 n))))
1635
1636	(defun format-print-cardinal-aux (stream n period err)
1637	(multiple-value-bind (beyond here) (truncate n 1000)
1638	(unless (<= period 10)
1639	(format-error "Number too large to print in English: ~:D" err))
1640	(unless (zerop beyond)
1641	(format-print-cardinal-aux stream beyond (1+ period) err))
1642	(unless (zerop here)
1643	(unless (zerop beyond) (write-char #\space stream))
1644	(format-print-small-cardinal stream here)
1645	(stream-write-entire-string stream (svref (cardinal-periods) period)))))
1646
1647
1648	;;; Print an ordinal number in English
1649
1650
1651	(eval-when (:compile-toplevel :execute)
1652	(defmacro ordinal-ones ()
1653	"Table of ordinal ones-place digits in English"
1654	'#(nil "first" "second" "third" "fourth"
1655	"fifth" "sixth" "seventh" "eighth" "ninth"))
1656	(defmacro ordinal-tens ()
1657	"Table of ordinal tens-place digits in English"
1658	'#(nil "tenth" "twentieth" "thirtieth" "fortieth"
1659	"fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
1660	)
1661
1662	(defun format-print-ordinal (stream n)
1663	(when (minusp n)
1664	(stream-write-entire-string stream "negative "))
1665	(let ((number (abs n)))
1666	(multiple-value-bind (top bot) (truncate number 100)
1667	(unless (zerop top) (format-print-cardinal stream (- number bot)))
1668	(when (and (plusp top) (plusp bot)) (write-char #\space stream))
1669	(multiple-value-bind (tens ones) (truncate bot 10)
1670	(cond ((= bot 12) (stream-write-entire-string stream "twelfth"))
1671	((= tens 1)
1672	(stream-write-entire-string stream (svref (cardinal-teens) ones));;;RAD
1673	(stream-write-entire-string stream "th"))
1674	((and (zerop tens) (plusp ones))
1675	(stream-write-entire-string stream (svref (ordinal-ones) ones)))
1676	((and (zerop ones)(plusp tens))
1677	(stream-write-entire-string stream (svref (ordinal-tens) tens)))
1678	((plusp bot)
1679	(stream-write-entire-string stream (svref (cardinal-tens) tens))
1680	(write-char #\- stream)
1681	(stream-write-entire-string stream (svref (ordinal-ones) ones)))
1682	((plusp number) (write-string "th" stream :start 0 :end 2))
1683	(t (stream-write-entire-string stream "zeroth")))))))
1684
1685
1686	;;; Print Roman numerals
1687
1688	(defun format-print-old-roman (stream n)
1689	(unless (< 0 n 5000)
1690	(format-error "Number out of range for old Roman numerals: ~:D" n))
1691	(do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1692	(val-list '(500 100 50 10 5 1) (cdr val-list))
1693	(cur-char #\M (car char-list))
1694	(cur-val 1000 (car val-list))
1695	(start n (do ((i start (progn (write-char cur-char stream) (- i cur-val))))
1696	((< i cur-val) i))))
1697	((zerop start))))
1698
1699
1700	(defun format-print-roman (stream n)
1701	(unless (< 0 n 4000)
1702	(format-error "Number out of range for Roman numerals: ~:D" n))
1703	(do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1704	(val-list '(500 100 50 10 5 1) (cdr val-list))
1705	(sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
1706	(sub-val '(100 10 10 1 1 0) (cdr sub-val))
1707	(cur-char #\M (car char-list))
1708	(cur-val 1000 (car val-list))
1709	(cur-sub-char #\C (car sub-chars))
1710	(cur-sub-val 100 (car sub-val))
1711	(start n (do ((i start (progn (write-char cur-char stream) (- i cur-val))))
1712	((< i cur-val)
1713	(cond ((<= (- cur-val cur-sub-val) i)
1714	(write-char cur-sub-char stream)
1715	(write-char cur-char stream)
1716	(- i (- cur-val cur-sub-val)))
1717	(t i))))))
1718	((zerop start))))
1719
1720
1721	;;; Decimal ~D
1722
1723	(defformat #\D format-print-decimal (stream colon atsign &rest parms)
1724	(declare (dynamic-extent parms))
1725	(format-print-number stream (pop-format-arg) 10 colon atsign parms))
1726
1727
1728	;;; Binary ~B
1729
1730	(defformat #\B format-print-binary (stream colon atsign &rest parms)
1731	(declare (dynamic-extent parms))
1732	(format-print-number stream (pop-format-arg) 2 colon atsign parms))
1733
1734
1735	;;; Octal ~O
1736
1737	(defformat #\O format-print-octal (stream colon atsign &rest parms)
1738	(declare (dynamic-extent parms))
1739	(format-print-number stream (pop-format-arg) 8 colon atsign parms))
1740
1741
1742	;;; Hexadecimal ~X
1743
1744	(defformat #\X format-print-hexadecimal (stream colon atsign &rest parms)
1745	(declare (dynamic-extent parms))
1746	(format-print-number stream (pop-format-arg) 16 colon atsign parms))
1747
1748
1749	;;; Radix ~R
1750
1751	(defformat #\R format-print-radix (stream colon atsign &rest parms)
1752	(declare (dynamic-extent parms))
1753	(let ((number (pop-format-arg))
1754	(parm (if parms (pop parms) nil)))
1755	(if parm
1756	(format-print-number stream number parm colon atsign parms)
1757	(if atsign
1758	(if colon
1759	(format-print-old-roman stream number)
1760	(format-print-roman stream number))
1761	(if colon
1762	(format-print-ordinal stream number)
1763	(format-print-cardinal stream number))))))
1764
1765	;;; FLOATING-POINT NUMBERS
1766
1767
1768	;;; Fixed-format floating point ~F
1769
1770	(defformat #\F format-fixed (stream colon atsign &rest parms)
1771	(declare (dynamic-extent parms))
1772	(when colon
1773	(format-error "Colon flag not allowed"))
1774	(with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
1775	;;Note that the scale factor k defaults to nil. This is interpreted as
1776	;;zero by flonum-to-string, but more efficiently.
1777	(let ((number (pop-format-arg))(print-escape nil))
1778	(if (floatp number)
1779	(format-fixed-aux stream number w d k ovf pad atsign)
1780	(if (rationalp number)
1781	(format-fixed-aux stream (coerce number 'float) w d k ovf pad atsign)
1782	(let ((print-base 10))
1783	(format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
1784
1785	; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1))
1786	; called with w = 11 d = 16 - dont do it after all.
1787
1788	(defun format-fixed-aux (stream number w d k ovf pad atsign)
1789	(and w (<= w 0) (setq w nil)) ; if width is unreasonable, ignore it.
1790	(if (not (or w d)) ; perhaps put this back when prin1 is better
1791	(prin1 number stream)
1792	(let ((spaceleft w)
1793	(abs-number (abs number))
1794	strlen zsuppress flonum-to-string-width)
1795	(when (and w (or atsign (minusp number)))
1796	(decf spaceleft))
1797	(when (and d w (<= w (+ 1 d (if atsign 1 0))))
1798	(setq zsuppress t))
1799	(when (and d (minusp d))
1800	(format-error "Illegal value for d"))
1801	(setq flonum-to-string-width
1802	(and w
1803	(if (and (< abs-number 1) (not zsuppress))
1804	(1- spaceleft) ; room for leading 0
1805	spaceleft)))
1806	(when (and w (not (plusp flonum-to-string-width)))
1807	(if ovf
1808	(progn
1809	(dotimes (i w) (write-char ovf stream))
1810	(return-from format-fixed-aux))
1811	(setq spaceleft nil w nil)))
1812	(multiple-value-bind (str before-pt after-pt)
1813	(flonum-to-string abs-number
1814	flonum-to-string-width
1815	d k)
1816	(setq strlen (length str))
1817	(cond (w (decf spaceleft (+ (max before-pt 0) 1))
1818	(when (and (< before-pt 1) (not zsuppress))
1819	(decf spaceleft))
1820	(if d
1821	(decf spaceleft d)
1822	(setq d (max (min spaceleft (- after-pt))
1823	(if (> spaceleft 0) 1 0))
1824	spaceleft (- spaceleft d))))
1825	((null d) (setq d (max (- after-pt) 1))))
1826	(cond ((and w (< spaceleft 0) ovf)
1827	;;field width overflow
1828	(dotimes (i w) (declare (fixnum i)) (write-char ovf stream)))
1829	(t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream)))
1830	(if (minusp (float-sign number)) ; 5/25
1831	(write-char #\- stream)
1832	(if atsign (write-char #\+ stream)))
1833	(cond
1834	((> before-pt 0)
1835	(cond ((> strlen before-pt)
1836	(write-string str stream :start 0 :end before-pt)
1837	(write-char #\. stream)
1838	(write-string str stream :start before-pt :end strlen)
1839	(dotimes (i (- d (- strlen before-pt)))
1840	(write-char #\0 stream)))
1841	(t ; 0's after
1842	(stream-write-entire-string stream str)
1843	(dotimes (i (- before-pt strlen))
1844	(write-char #\0 stream))
1845	(write-char #\. stream)
1846	(dotimes (i d)
1847	(write-char #\0 stream)))))
1848	(t (unless zsuppress (write-char #\0 stream))
1849	(write-char #\. stream)
1850	(dotimes (i (- before-pt))
1851	(write-char #\0 stream))
1852	(stream-write-entire-string stream str)
1853	(dotimes (i (+ d after-pt))
1854	(write-char #\0 stream))))))))))
1855	#\|
1856	; (format t "~7,3,-2f" 8.88)
1857	; (format t "~10,5,2f" 8.88)
1858	; (format t "~10,5,-2f" 8.88)
1859	; (format t "~10,5,2f" 0.0)
1860	; (format t "~10,5,2f" 9.999999999)
1861	; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ??
1862	; (format t "~10,,2f" 8.88)
1863	; (format t "~10,,-2f" 8.88)
1864	; (format t "~10,,2f" 0.0)
1865	; (format t "~10,,2f" 0.123454)
1866	; (format t "~10,,2f" 9.9999999)
1867	(defun foo (x)
1868	(format nil "~6,2f\|~6,2,1,'*f\|~6,2,,'?f\|~6f\|~,2f\|~F"
1869	x x x x x x))
1870
1871	\|#
1872
1873
1874
1875	;;; Exponential-format floating point ~E
1876
1877
1878	(defformat #\E format-exponential (stream colon atsign &rest parms)
1879	(declare (dynamic-extent parms))
1880	(when colon
1881	(format-error "Colon flag not allowed"))
1882	(with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
1883	(let ((number (pop-format-arg)))
1884	(if (floatp number)
1885	(format-exp-aux stream number w d e k ovf pad marker atsign)
1886	(if (rationalp number)
1887	(format-exp-aux stream (coerce number 'float) w d e k ovf pad marker atsign)
1888	(let ((print-base 10))
1889	(format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
1890	#\|
1891	(defun format-exponent-marker (number)
1892	(if (typep number read-default-float-format)
1893	#\E
1894	(cond ((double-floatp) #\D)
1895	((short-floatp number) #\S)
1896	((single-floatp number) #\F)
1897	((long-floatp) #\L))))
1898	\|#
1899	(eval-when (eval compile #-bccl load)
1900	(defmacro format-exponent-marker (number)
1901	`(float-exponent-char ,number))
1902	)
1903
1904	;;;Here we prevent the scale factor from shifting all significance out of
1905	;;;a number to the right. We allow insignificant zeroes to be shifted in
1906	;;;to the left right, athough it is an error to specify k and d such that this
1907	;;;occurs. Perhaps we should detect both these condtions and flag them as
1908	;;;errors. As for now, we let the user get away with it, and merely guarantee
1909	;;;that at least one significant digit will appear.
1910	;;; THE ABOVE COMMENT no longer applies
1911
1912	(defun format-exp-aux (stream number w d e k ovf pad marker atsign &optional string exp)
1913	(when (not k) (setq k 1))
1914	(if (not (or w d e marker (neq k 1)))
1915	(print-a-float number stream t)
1916	(prog ()
1917	(when d
1918	(when (or (minusp d)
1919	(and (plusp k)(>= k (+ d 2)))
1920	(and (minusp k)(< k (- d))))
1921	(format-error "incompatible values for k and d")))
1922	(when (not exp) (setq exp (scale-exponent number)))
1923	AGAIN
1924	(let* ((expt (- exp k))
1925	(estr (let ((print-base 10))
1926	(princ-to-string (abs expt))))
1927	(elen (max (length estr) (or e 0)))
1928	(spaceleft (if w (- w 2 elen) nil))
1929	(fwidth) scale)
1930	(when (and w (or atsign (minusp (float-sign number)))) ; 5/25
1931	(setq spaceleft (1- spaceleft)))
1932	(if w
1933	(progn
1934	(setq fwidth (if d
1935	(if (> k 0)(+ d 2)(+ d k 1))
1936	(if (> k 0) spaceleft (+ spaceleft k))))
1937	(when (minusp exp) ; i don't claim to understand this
1938	(setq fwidth (- fwidth exp))
1939	(when (< k 0) (setq fwidth (1- fwidth)))))
1940	(when (and d (not (zerop number))) ; d and no w
1941	(setq scale (- 2 k exp)))) ; 2 used to be 1 - 5/31
1942	(when (or (and w e ovf (> elen e))(and w fwidth (not (plusp fwidth))))
1943	;;exponent overflow
1944	(dotimes (i w) (declare (fixnum i)) (write-char ovf stream))
1945	(if (plusp fwidth)
1946	(return-from format-exp-aux nil)
1947	(setq fwidth nil)))
1948	(when (not string)
1949	(multiple-value-bind (new-string before-pt) (flonum-to-string number fwidth
1950	(if (not fwidth) d)
1951	(if (not fwidth) scale))
1952	(setq string new-string)
1953	(when scale (setq before-pt (- (+ 1 before-pt) k scale))) ; sign right?
1954	(when (neq exp before-pt)
1955	;(print (list 'agn exp before-pt))
1956	;(setq string new-string)
1957	(setq exp before-pt)
1958	(go again))))
1959	(let ((strlen (length string)))
1960	(when w
1961	(if d
1962	(setq spaceleft (- spaceleft (+ d 2)))
1963	(if (< k 1)
1964	(setq spaceleft (- spaceleft (+ 2 (- k)(max strlen 1))))
1965	(setq spaceleft (- spaceleft (+ 1 k (max 1 (- strlen k))))))))
1966	(when (and w (< spaceleft 0))
1967	(if (and ovf (or (plusp k)(< spaceleft -1)))
1968	(progn (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))
1969	(return-from format-exp-aux nil))))
1970	(when w
1971	(dotimes (i spaceleft)
1972	(declare (fixnum i))
1973	(write-char pad stream)))
1974	(if (minusp (float-sign number)) ; 5/25
1975	(write-char #\- stream)
1976	(if atsign (write-char #\+ stream)))
1977	(cond
1978	((< k 1)
1979	(when (not (minusp spaceleft))(write-char #\0 stream))
1980	(write-char #\. stream)
1981	(dotimes (i (- k))
1982	(write-char #\0 stream))
1983	(if (and (eq strlen 0)(not d))
1984	(write-char #\0 stream)
1985	(stream-write-entire-string stream string))
1986	(if d
1987	(dotimes (i (- (+ d k) strlen))
1988	(write-char #\0 stream))))
1989	(t
1990	(write-string string stream :start 0 :end (min k strlen))
1991	(dotimes (i (- k strlen))
1992	(write-char #\0 stream))
1993	(write-char #\. stream)
1994	(when (> strlen k)
1995	(write-string string stream :start k :end strlen))
1996	(if (not d)
1997	(when (<= strlen k)(write-char #\0 stream))
1998	(dotimes (i (1+ (- d k (max 0 (- strlen k)))))
1999	(write-char #\0 stream)))))
2000	(write-char (if marker
2001	marker
2002	(format-exponent-marker number))
2003	stream)
2004	(write-char (if (minusp expt) #\- #\+) stream)
2005	(when e
2006	;;zero-fill before exponent if necessary
2007	(dotimes (i (- e (length estr)))
2008	(declare (fixnum i))
2009	(write-char #\0 stream)))
2010	(stream-write-entire-string stream estr))))))
2011	#\|
2012	; (format t "~7,3,,-2e" 8.88) s.b. .009e+3
2013	; (format t "~10,5,,2e" 8.888888888) ; "88.8889E-1"
2014	; (format t "~10,5,,-2e" 8.88) "0.00888E+3"
2015	; (format t "~10,5,,-2e" .00123445) ; "0.00123E+0"
2016	; (format t "~10,5,,-3e" .00123445) ; "0.00012E+1"
2017	; (format t "~10,,,-2e" .123445)
2018	; (format t "~10,5,,2e" .0012349999e-4)
2019	; (format t "~10,5,,2e" 9.9999999)
2020	; (format t "~10,5,,2e" 0.0)
2021	; (format t "~10,5,,0e" 40000000.0)
2022	; (format t "~10,5,,2e" 9.9999999)
2023	; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ??
2024	; (format t "~10,,,2e" 8.888888)
2025	; (format t "~10,,,-2e" 8.88)
2026	; (format t "~10,,,-2e" 0.0)
2027	; (format t "~10,,,2e" 0.0)
2028	; (format t "~10,,,2e" 9.9999999)
2029	; (format t "~10,,,2e" 9.9999999e100)
2030	; (format t "~10,5,3,2,'xe" 10e100)
2031	; (format t "~9,3,2,-2e" 1100.0)
2032	(defun foo (x)
2033	(format nil
2034	"~9,2,1,,'*e\|~10,3,2,2,'?,,'$e\|~9,3,2,-2,'%@e\|~9,2e"
2035	x x x x))
2036	\|#
2037
2038
2039	;;; General Floating Point - ~G
2040
2041	(defformat #\G format-general-float (stream colon atsign &rest parms)
2042	(declare (dynamic-extent parms))
2043	(when colon
2044	(format-error "Colon flag not allowed"))
2045	(with-format-parameters parms ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil))
2046	(let ((number (pop-format-arg)))
2047	;;The Excelsior edition does not say what to do if
2048	;;the argument is not a float. Here, we adopt the
2049	;;conventions used by ~F and ~E.
2050	(if (floatp number)
2051	(format-general-aux stream number w d e k ovf pad marker atsign)
2052	(if (rationalp number)
2053	(format-general-aux stream (coerce number 'float) w d e k ovf pad marker atsign)
2054	(let ((print-base 10))
2055	(format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
2056
2057	#\|
2058	; completely broken
2059	(defun foo (x)
2060	(format nil
2061	"~9,2,1,,'*g\|~10,3,2,2,'?,,'$g\|~9,3,2,-2,'%@g\|~9,2g"
2062	x x x x))
2063	\|#
2064
2065
2066	(defun format-general-aux (stream number w d e k ovf pad marker atsign)
2067	(multiple-value-bind (str n #\|after-pt\|#)(flonum-to-string number)
2068	;;Default d if omitted. The procedure is taken directly
2069	;;from the definition given in the manual, and is not
2070	;;very efficient, since we generate the digits twice.
2071	;;Future maintainers are encouraged to improve on this.
2072	(let* ((d2 (or d (max (length str) (min n 7))))
2073	(ee (if e (+ e 2) 4))
2074	(ww (if w (- w ee) nil))
2075	(dd (- d2 n)))
2076	(cond ((<= 0 dd d2)
2077	; this causes us to print 1.0 as 1. - seems weird
2078	(format-fixed-aux stream number ww dd nil ovf pad atsign)
2079	(dotimes (i ee) (declare (fixnum i)) (write-char #\space stream)))
2080	(t (format-exp-aux stream number w d e (or k 1) ovf pad marker atsign nil n))))))
2081
2082
2083	;;; Dollars floating-point format ~$
2084
2085	(defformat #\$ format-dollars (stream colon atsign &rest parms)
2086	(declare (dynamic-extent parms))
2087	(with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
2088	(let* ((number (float (pop-format-arg)))
2089	(signstr (if (minusp (float-sign number)) "-" (if atsign "+" "")))
2090	(spaceleft)
2091	strlen)
2092	(multiple-value-bind (str before-pt after-pt) (flonum-to-string number nil d)
2093	(setq strlen (length str))
2094	(setq spaceleft (- w (+ (length signstr) (max before-pt n) 1 d)))
2095	(when colon (stream-write-entire-string stream signstr))
2096	(dotimes (i spaceleft) (write-char pad stream))
2097	(unless colon (stream-write-entire-string stream signstr))
2098	(cond
2099	((> before-pt 0)
2100	(cond ((> strlen before-pt)
2101	(dotimes (i (- n before-pt))
2102	(write-char #\0 stream))
2103	(write-string str stream :start 0 :end before-pt)
2104	(write-char #\. stream)
2105	(write-string str stream :start before-pt :end strlen)
2106	(dotimes (i (- d (- strlen before-pt)))
2107	(write-char #\0 stream)))
2108	(t ; 0's after
2109	(stream-write-entire-string stream str)
2110	(dotimes (i (- before-pt strlen))
2111	(write-char #\0 stream))
2112	(write-char #\. stream)
2113	(dotimes (i d)
2114	(write-char #\0 stream)))))
2115	(t (dotimes (i n)
2116	(write-char #\0 stream))
2117	(write-char #\. stream)
2118	(dotimes (i (- before-pt))
2119	(write-char #\0 stream))
2120	(stream-write-entire-string stream str)
2121	(dotimes (i (+ d after-pt))
2122	(write-char #\0 stream))))))))
2123
2124	(defun y-or-n-p (&optional format-string &rest arguments &aux response)
2125	"Y-OR-N-P prints the message, if any, and reads characters from
2126	QUERY-IO until the user enters y or Y as an affirmative, or either
2127	n or N as a negative answer. It asks again if you enter any other
2128	characters."
2129	(declare (dynamic-extent arguments))
2130	(with-terminal-input
2131	(clear-input query-io)
2132	(loop
2133	(when format-string
2134	(fresh-line query-io)
2135	(apply 'format query-io format-string arguments))
2136	(princ " (y or n) " query-io)
2137	(setq response (read-char query-io))
2138	;; Consume input up to trailing newline
2139	(when (peek-char #\NewLine query-io nil)
2140	;; And consume the #\newline
2141	(read-char query-io))
2142	(clear-input query-io)
2143	(if (char-equal response #\y) (return t))
2144	(if (char-equal response #\n) (return nil))
2145	(format query-io "Please answer y or n."))))
2146
2147	(defun yes-or-no-p (&optional format-string &rest arguments &aux response)
2148	"YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
2149	input buffer, beeps, and uses READ-LINE to get the strings
2150	YES or NO."
2151	(declare (dynamic-extent arguments))
2152	(with-terminal-input
2153	(loop
2154	(when format-string
2155	(fresh-line query-io)
2156	(apply 'format query-io format-string arguments))
2157	(princ " (yes or no) " query-io)
2158	(format query-io "~A" #\Bell)
2159	(setq response (read-line query-io))
2160	(clear-input query-io)
2161	(when response
2162	(setq response (string-trim wsp response))
2163	(if (string-equal response "yes") (return t))
2164	(if (string-equal response "no") (return nil))
2165	(format query-io "Please answer yes or no.")))))
2166
2167
2168	;; Compile-time format-scanning support.
2169	;;
2170	;; All this assumes it's called from the compiler, but it has to be kept in sync with code
2171	;; here more than with the code in the compiler, so keep it in here.
2172
2173	(defun note-format-scan-option (cell)
2174	(when cell
2175	(if (null (cdr cell))
2176	(setf (car cell) format-arguments (cdr cell) format-arguments-variance)
2177	(let* ((new-args format-arguments)
2178	(new-var format-arguments-variance)
2179	(new-max (length new-args))
2180	(old-args (car cell))
2181	(old-var (cdr cell))
2182	(old-max (length old-args))
2183	(min (min (- new-max new-var) (- old-max old-var))))
2184	(if (>= new-max old-max)
2185	(setf (car cell) new-args (cdr cell) (- new-max min))
2186	(setf (cdr cell) (- old-max min))))))
2187	cell)
2188
2189	(defmacro with-format-scan-options ((var) &body body)
2190	(let ((cell (gensym)))
2191	;; CELL is used to record range of arg variations that should be deferred til the end
2192	;; of BODY because they represent possible non-local exits.
2193	`(let* ((,cell (cons nil nil))
2194	(,var ,cell))
2195	(declare (dynamic-extent ,cell))
2196	(prog1
2197	(progn
2198	,@body)
2199	(setq format-arguments (car ,cell)
2200	format-arguments-variance (cdr ,cell))))))
2201
2202	(defvar format-escape-options nil)
2203
2204	(defun nx1-check-format-call (control-string format-arguments &optional (env nx-lexical-environment))
2205	"Format-arguments are expressions that will evaluate to the actual arguments.
2206	Pre-scan process the format string, nx1-whine if find errors"
2207	(let* ((nx-lexical-environment env)
2208	(format-top-level t)
2209	(logical-block-xp nil)
2210	(format-pprint nil)
2211	(format-justification-semi nil))
2212	(let ((error (catch 'format-error
2213	(format-scan control-string format-arguments 0)
2214	nil)))
2215	(when error
2216	(setf (cadar error) (concatenate 'string (cadar error) " in format string:"))
2217	(nx1-whine :format-error (nreverse error))
2218	t))))
2219
2220	(defun format-scan (string args var)
2221	(let ((format-original-arguments args)
2222	(format-arguments args)
2223	(format-arguments-variance var)
2224	(format-colon-rest 'error)
2225	(format-control-string (ensure-simple-string string)))
2226	(with-format-scan-options (format-escape-options)
2227	(catch 'format-escape
2228	(sub-format-scan 0 (length format-control-string))
2229	(note-format-scan-option format-escape-options)))
2230	#+no
2231	(when (> (length format-arguments) format-arguments-variance)
2232	(format-error "Too many format arguments"))))
2233
2234	(defun sub-format-scan (i end)
2235	(let ((format-index i)
2236	(format-length end)
2237	(string format-control-string))
2238	(loop while (setq format-index (position #\~ string :start format-index :end end)) do
2239	(multiple-value-bind (params colon atsign char) (parse-format-operation t)
2240	(setq char (char-upcase char))
2241	(let ((code (%char-code char)))
2242	(unless (and (< -1 code (length format-char-table))
2243	(svref format-char-table code))
2244	(format-error "Unknown directive ~c" char)))
2245	(format-scan-directive char colon atsign params)
2246	(incf format-index)))))
2247
2248	(defun nx-could-be-type (form type &optional transformed &aux (env nx-lexical-environment))
2249	(unless transformed (setq form (nx-transform form env)))
2250	(if (constantp form)
2251	(typep (eval-constant form) type env)
2252	(multiple-value-bind (win-p sure-p) (subtypep (nx-form-type form env) `(not ,type) env)
2253	(not (and win-p sure-p)))))
2254
2255	(defun format-require-type (form type &optional description)
2256	(unless (nx-could-be-type form type)
2257	(format-error "~a must be of type ~s" (or description form) type)))
2258
2259
2260	(defun format-scan-directive (char colon atsign parms)
2261	(ecase char
2262	((#\% #\& #\~ #\\|)
2263	(with-format-parameters parms ((repeat-count 1))
2264	(format-no-flags colon atsign)
2265	(format-require-type repeat-count '(integer 0))))
2266	((#\newline #\return)
2267	(with-format-parameters parms ()
2268	(when (and atsign colon) (format-error "~:@<newline> is undefined"))
2269	(unless colon
2270	(format-eat-whitespace))))
2271	((#\P)
2272	(with-format-parameters parms ()
2273	(when colon
2274	(loop with end = format-arguments
2275	for list on format-original-arguments
2276	when (eq (cdr list) end) return (setq format-arguments list)
2277	finally (if (> (or format-arguments-variance 0) 0)
2278	(decf format-arguments-variance)
2279	(format-error "No previous argument"))))
2280	(pop-format-arg)))
2281	((#\A #\S)
2282	(with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
2283	(format-require-type mincol 'integer "mincol (first parameter)")
2284	(format-require-type colinc '(integer 1) "colinc (second parameter)")
2285	(format-require-type minpad 'integer "minpad (third parameter)")
2286	(format-require-type padchar '(or (integer 0 #.char-code-limit) character) "padchar (fourth parameter)"))
2287	(pop-format-arg))
2288	((#\I)
2289	(with-format-parameters parms ((n 0))
2290	(format-no-flags nil atsign)
2291	(format-no-semi char)
2292	(format-require-type n 'real)))
2293	((#\_)
2294	(with-format-parameters parms ()
2295	(format-no-semi char)))
2296	((#\T)
2297	(with-format-parameters parms ((colnum 1) (colinc 1))
2298	(when colon
2299	(format-no-semi char t))
2300	(format-require-type colnum 'integer "colnum (first parameter)")
2301	(format-require-type colinc 'integer "colinc (second parameter)")))
2302	((#\W)
2303	(with-format-parameters parms ()
2304	(format-no-semi #\W))
2305	(pop-format-arg))
2306	((#\C)
2307	(with-format-parameters parms ())
2308	(format-require-type (pop-format-arg) '(or character fixnum (string 1))))
2309	((#\D #\B #\O #\X #\R)
2310	(when (eql char #\R)
2311	(let ((radix (pop parms)))
2312	(when radix
2313	(format-require-type radix '(integer 2 36)))))
2314	(with-format-parameters parms ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
2315	(format-require-type mincol 'integer "mincol (first parameter)")
2316	(format-require-type padchar 'character "padchar (second parameter)")
2317	(format-require-type commachar 'character "comma char (third parameter)")
2318	(format-require-type commainterval 'integer "comma interval (fourth parameter)"))
2319	(pop-format-arg))
2320	((#\F)
2321	(format-no-flags colon nil)
2322	(with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
2323	(format-require-type w '(or null (integer 0)) "w (first parameter)")
2324	(format-require-type d '(or null (integer 0)) "d (second parameter)")
2325	(format-require-type k '(or null integer) "k (third parameter)")
2326	(format-require-type ovf '(or null character) "overflowchar (fourth parameter)")
2327	(format-require-type pad '(or null character) "padchar (fifth parameter)"))
2328	(pop-format-arg))
2329	((#\E #\G)
2330	(format-no-flags colon nil)
2331	(with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
2332	(format-require-type w '(or null (integer 0)) "w (first parameter)")
2333	(format-require-type d '(or null (integer 0)) "d (second parameter)")
2334	(format-require-type e '(or null (integer 0)) "e (third parameter)")
2335	(format-require-type k '(or null integer) "k (fourth parameter)")
2336	(format-require-type ovf '(or null character) "overflowchar (fifth parameter)")
2337	(format-require-type pad '(or null character) "padchar (sixth parameter)")
2338	(format-require-type marker '(or null character) "exponentchar (seventh parameter)"))
2339	(pop-format-arg))
2340	((#\$)
2341	(with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
2342	(format-require-type d '(or null (integer 0)) "d (first parameter)")
2343	(format-require-type n '(or null (integer 0)) "n (second parameter)")
2344	(format-require-type w '(or null (integer 0)) "w (third parameter)")
2345	(format-require-type pad '(or null character) "pad (fourth parameter)"))
2346	(format-require-type (pop-format-arg) 'real))
2347	((#\*)
2348	(with-format-parameters parms ((count nil))
2349	(when count
2350	(format-require-type count 'integer "count parameter"))
2351	(if (typep (setq count (nx-transform count)) '(or null integer))
2352	(format-scan-goto colon atsign count)
2353	;; Else can't tell how much going back or forth, could be anywhere.
2354	(setq format-arguments format-original-arguments
2355	format-arguments-variance (length format-arguments)))))
2356	((#\?)
2357	(with-format-parameters parms ()
2358	(format-no-flags colon nil))
2359	(let ((string (pop-format-arg)))
2360	(format-require-type string '(or string function))
2361	(if atsign
2362	(setq format-arguments-variance (length format-arguments))
2363	(let ((arg (pop-format-arg)))
2364	(format-require-type arg 'list)))))
2365	((#\/)
2366	(let* ((string format-control-string)
2367	(ipos (1+ format-index))
2368	(epos (format-find-char #\/ ipos format-length)))
2369	(when (not epos) (format-error "Unmatched ~~/"))
2370	(let* ((cpos (format-find-char #\: ipos epos))
2371	(name (if cpos
2372	(prog1
2373	(string-upcase (%substr string ipos cpos))
2374	(when (eql #\: (schar string (%i+ 1 cpos)))
2375	(setq cpos (%i+ cpos 1)))
2376	(setq ipos (%i+ cpos 1)))
2377	"CL-USER"))
2378	(package (find-package name))
2379	(sym (and package (find-symbol (string-upcase (%substr string ipos epos)) package)))
2380	(arg (pop-format-arg)))
2381	(setq format-index epos) ; or 1+ epos?
2382	;; TODO: should we complain if the symbol doesn't exit? Perhaps it will be defined
2383	;; later, and to detect that would need to intern it. What if the package doesn't exist?
2384	;; Would need to extend :undefined-function warnings to handle previously-undefined package.
2385	(when sym
2386	(when (nth-value 1 (nx1-call-result-type sym (list* 'standard-output arg colon atsign parms)))
2387	;; Whined, just get out now.
2388	(throw 'format-error nil))))))
2389	((#\[)
2390	(when (and colon atsign) (format-error "~~:@[ undefined"))
2391	(format-nextchar)
2392	(cond (colon
2393	(format-scan-boolean-condition parms))
2394	(atsign
2395	(format-scan-funny-condition parms))
2396	(t (format-scan-untagged-condition parms))))
2397	((#\()
2398	(with-format-parameters parms ()
2399	(format-nextchar)
2400	(multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\)))
2401	(with-format-parameters parms () (format-no-flags colon atsign))
2402	(sub-format-scan prev tilde))))
2403	((#\^)
2404	(format-no-flags nil atsign)
2405	(with-format-parameters parms ((p1 nil) (p2 nil) (p3 nil))
2406	(let ((val (nx-transform (cond (p3
2407	(if (every (lambda (p) (nx-could-be-type p 'real)) parms)
2408	;; If the params could also be chars, don't know enough to constant fold
2409	;; anyway, so this test will do.
2410	`(< ,p1 ,p2 ,p3)
2411	(if (every (lambda (p) (nx-could-be-type p 'character)) parms)
2412	`(char< ,p1 ,p2 ,p3)
2413	;; At least one can't be real, at least one can't be char.
2414	(format-error "Wrong type of parameters for three-way comparison"))))
2415	(p2 `(equal ,p1 ,p2))
2416	(p1 `(eq ,p1 0))
2417	(t (null (if colon format-colon-rest format-arguments)))))))
2418	(when val
2419	(note-format-scan-option format-escape-options)
2420	(unless (nx-could-be-type val 'null t)
2421	(throw 'format-escape t))))))
2422	((#\{)
2423	(with-format-parameters parms ((max-iter -1))
2424	(format-require-type max-iter 'integer "max-iter parameter")
2425	(format-nextchar)
2426	(multiple-value-bind (prev tilde end-parms end-colon end-atsign) (format-find-command '(#\}))
2427	(declare (ignore end-colon))
2428	(with-format-parameters end-parms () (format-no-flags nil end-atsign))
2429	(when (= prev tilde)
2430	;; Use an argument as the control string if ~{~} is empty
2431	(let ((string (pop-format-arg)))
2432	(unless (nx-could-be-type string '(or string function))
2433	(format-error "Control string is not a string or function"))))
2434	;; Could try to actually scan the iteration if string is a compile-time string,
2435	;; by that seems unlikely.
2436	(if atsign
2437	(setq format-arguments-variance (length format-arguments))
2438	(format-require-type (pop-format-arg) 'list)))))
2439	((#\<)
2440	(multiple-value-bind (start tilde eparms ecolon eatsign) (format-find-command '(#\>))
2441	(declare (ignore tilde eparms eatsign))
2442	(setq format-index start)
2443	(if ecolon
2444	(format-logical-block-scan colon atsign parms)
2445	(format-justification-scan colon atsign parms))))
2446	))
2447
2448	(defun format-justification-scan (colon atsign parms)
2449	(declare (ignore colon atsign))
2450	(with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
2451	(format-require-type mincol 'integer "mincol (first parameter)")
2452	(format-require-type colinc '(integer 1) "colinc (second parameter)")
2453	(format-require-type minpad 'integer "minpad (third parameter)")
2454	(format-require-type padchar `(or character (integer 0 #.char-code-limit)) "padchar (fourth parameter)"))
2455	(let ((first-parms nil) (first-colon nil) (count 0))
2456	(with-format-scan-options (format-escape-options)
2457	(loop
2458	(format-nextchar)
2459	(multiple-value-bind (prev tilde parms colon atsign cmd)
2460	(format-find-command '(#\; #\>) nil T)
2461	(if (and (eql count 0) (eql cmd #\;) colon)
2462	(progn
2463	(format-no-flags nil atsign)
2464	(setq first-colon t)
2465	(setq format-index tilde)
2466	(setq first-parms (nth-value 2 (format-find-command '(#\; #\>) t T))))
2467	(with-format-parameters parms ()
2468	(format-no-flags colon atsign)))
2469	(when (catch 'format-escape
2470	(sub-format-scan prev tilde)
2471	nil)
2472	(unless (eq cmd #\>) (format-find-command '(#\>) nil t))
2473	(return))
2474	(incf count)
2475	(when (eq cmd #\>)
2476	(return))))
2477	(note-format-scan-option format-escape-options))
2478	(when first-colon
2479	(when format-pprint
2480	(format-error "Justification illegal in this context"))
2481	(setq format-justification-semi t)
2482	(with-format-parameters first-parms ((spare 0) (linel 0))
2483	(format-require-type spare 'integer "spare (first parameter)")
2484	(format-require-type linel 'integer "line length (second parameter)")))))
2485
2486
2487
2488	(defun format-logical-block-scan (colon atsign params)
2489	(declare (ignore colon))
2490	(with-format-parameters params ()
2491	(format-no-semi #\<))
2492	;; First section can be termined by ~@;
2493	(let ((format-string format-control-string)
2494	(prefix "")
2495	(suffix "")
2496	(body-string nil))
2497	(multiple-value-bind (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>))
2498	(setq body-string (%substr format-string (1+ start1) tilde))
2499	(with-format-parameters parms1 ())
2500	(when (eq cmd #\;)
2501	(format-no-flags colon1 nil)
2502	(setq prefix body-string)
2503	(multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)))
2504	(with-format-parameters parms1 ())
2505	(setq body-string (%substr format-string (1+ start1) tilde))
2506	(when (eq cmd #\;)
2507	(format-no-flags colon1 atsign1)
2508	(multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)))
2509	(with-format-parameters parms1 ())
2510	(setq suffix (%substr format-string (1+ start1) tilde))
2511	(when (eq cmd #\;)
2512	(format-error "Too many sections")))))
2513	(flet ((format-check-simple (str where)
2514	(when (and str (or (%str-member #\~ str) (%str-member #\newline str)))
2515	(format-error "~A must be simple" where))))
2516	(format-check-simple prefix "Prefix")
2517	(format-check-simple suffix "Suffix"))
2518	(if atsign
2519	(let ((logical-block-p t))
2520	(format-scan body-string format-arguments format-arguments-variance)
2521	(setq format-arguments nil format-arguments-variance 0))
2522	;; If no atsign, we just use up an arg. Don't bother trying to scan it, unlikely to be a constant.
2523	(when format-arguments
2524	(pop-format-arg)))))
2525
2526
2527	(defun format-scan-untagged-condition (parms)
2528	(with-format-parameters parms ((index nil))
2529	(unless index (setq index (pop-format-arg)))
2530	(format-require-type index 'integer)
2531	(with-format-scan-options (cond-options)
2532	(loop with default = nil do
2533	(multiple-value-bind (prev tilde parms colon atsign cmd)
2534	(format-find-command '(#\; #\]))
2535	(when (and default (eq cmd #\;))
2536	(format-error "~:; must be the last clause"))
2537	(with-format-parameters parms ()
2538	(format-no-flags (if (eq cmd #\]) colon) atsign)
2539	(when colon (setq default t)))
2540	(format-scan-optional-clause prev tilde cond-options)
2541	(when (eq cmd #\])
2542	(unless default ;; Could just skip the whole thing
2543	(note-format-scan-option cond-options))
2544	(return))
2545	(format-nextchar))))))
2546
2547	(defun format-scan-funny-condition (parms)
2548	(with-format-parameters parms ())
2549	(multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
2550	(with-format-parameters parms ()
2551	(format-no-flags colon atsign))
2552	(when (null format-arguments) (pop-format-arg)) ;; invoke std error
2553	(with-format-scan-options (cond-options)
2554	(let ((arg (nx-transform (car format-arguments))))
2555	(when (nx-could-be-type arg 'null t)
2556	(let ((format-arguments format-arguments)
2557	(format-arguments-variance format-arguments-variance))
2558	(when (eql format-arguments-variance (length format-arguments))
2559	(decf format-arguments-variance))
2560	(pop format-arguments)
2561	(note-format-scan-option cond-options)))
2562	(when arg
2563	(format-scan-optional-clause prev tilde cond-options))))))
2564
2565
2566	(defun format-scan-boolean-condition (parms)
2567	(with-format-parameters parms ())
2568	(multiple-value-bind (prev tilde parms colon atsign cmd) (format-find-command '(#\; #\]))
2569	(when (eq cmd #\])
2570	(format-error "Two clauses separated by ~~; are required for ~~:["))
2571	(with-format-parameters parms () (format-no-flags colon atsign))
2572	(format-nextchar)
2573	(with-format-scan-options (cond-options)
2574	(let ((arg (nx-transform (pop-format-arg))))
2575	(when (nx-could-be-type arg 'null t)
2576	(format-scan-optional-clause prev tilde cond-options))
2577	(multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
2578	(with-format-parameters parms () (format-no-flags colon atsign))
2579	(when arg
2580	(format-scan-optional-clause prev tilde cond-options)))))))
2581
2582
2583	(defun format-scan-optional-clause (start end cond-option)
2584	(let ((format-arguments format-arguments)
2585	(format-arguments-variance format-arguments-variance))
2586	;; Let the branch points collect in outer format-escape-options, but don't
2587	;; throw there because need to consider the other clauses.
2588	(catch 'format-escape
2589	(sub-format-scan start end)
2590	(note-format-scan-option cond-option)
2591	nil)))
2592
2593	(defun format-scan-goto (colon atsign count)
2594	(if atsign
2595	(progn
2596	(format-no-flags colon nil)
2597	(setq format-arguments
2598	(nthcdr-no-overflow (or count 0) format-original-arguments))
2599	(setq format-arguments-variance 0))
2600	(progn
2601	(when (null count)(setq count 1))
2602	(when colon (setq count (- count)))
2603	(cond ((> count 0)
2604	(when (> count (length format-arguments))
2605	(format-error "Target position for ~~* out of bounds"))
2606	(setq format-arguments (nthcdr count format-arguments))
2607	(when format-arguments-variance
2608	(setq format-arguments-variance
2609	(min format-arguments-variance (length format-arguments)))))
2610	((< count 0)
2611	(let* ((orig format-original-arguments)
2612	(pos (+ (- (length orig) (length format-arguments)) count))
2613	(max-pos (+ pos (or format-arguments-variance 0))))
2614	(when (< max-pos 0)
2615	(format-error "Target position for ~~* out of bounds"))
2616	(if (< pos 0)
2617	(setq format-arguments orig
2618	format-arguments-variance max-pos)
2619	(setq format-arguments (nthcdr pos orig)))))))))
2620

Note: See TracBrowser for help on using the repository browser.

Download in other formats: