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 | |
---|