source: trunk/source/lib/format.lisp @ 11805

Last change on this file since 11805 was 11805, checked in by gz, 11 years ago

Make the compiler scan format strings for possible errors. ccl::*format-arg-functions* is the alist of functions that should be scanned (so setting this to nil is a way to disable the scanning). The code to actually do the scanning is in format.lisp. It doesn't seem to slow down the compiler in any noticable way. It finds some cases of insufficient args in format strings in ccl sources, I'll fix those in a separate checkin later.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 108.0 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; Functions to implement FORMAT.
18;;;
19
20(in-package "CCL")
21
22;;; Special variables local to FORMAT
23;;; why do these have top-level bindings ????? - seems wrong or at least unnecessary
24
25(defvar *format-control-string* ""
26  "The current FORMAT control string")
27
28(defvar *format-index* 0
29  "The current index into *format-control-string*")
30
31(defvar *format-length* 0
32  "The length of the current FORMAT control string")
33
34(defvar *format-arguments* ()
35  "Arguments to the current call of FORMAT")
36
37(defvar *format-original-arguments* ()
38  "Saved arglist from top-level FORMAT call for ~* and ~@*")
39
40(defvar *format-arguments-variance* nil
41  "Non-NIL only during compile-time scanning of a format string, in which case it is the
42number of additional elements at the front of *format-arguments* that may be already used
43up at runtime.  I.e. the actual *format-arguments* may be anything between *format-arguments*
44and (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          ((< 127 code)
1458           (write-char char stream)
1459           (when (and atsign
1460                      (neq #\Null (setq char (code-char (logand 127 code)))))
1461             (princ " (Meta " stream)
1462             (write-char char stream)
1463             (write-char #\) stream)))
1464          ((not (or atsign colon))
1465           (write-char char stream))
1466          ((and (< code 32) atsign)
1467           (setq char (code-char (logxor code 64)))
1468           (if (or colon (%str-member char "@CGHIJKLM[\\]^_"))
1469               (princ name stream)
1470               (progn
1471                 (write-char #\^ stream)
1472                 (write-char char stream)))
1473           (princ " (" stream)
1474           (princ "Control " stream)
1475           (write-char char stream)
1476           (write-char #\) stream))
1477          (name (princ name stream))
1478          (t (write-char char stream)))))
1479
1480
1481;;; NUMERIC PRINTING
1482
1483
1484
1485;;; Output a string in a field at MINCOL wide, padding with PADCHAR.
1486;;; Pads on the left if PADLEFT is true, else on the right.  If the
1487;;; length of the string plus the minimum permissible padding, MINPAD,
1488;;; is greater than MINCOL, the actual field size is rounded up to
1489;;; MINCOL + k * COLINC for the smallest possible positive integer k.
1490
1491(defun format-write-field (stream string mincol colinc minpad padchar padleft)
1492  (unless (or (null mincol)
1493              (integerp mincol))
1494    (format-error "Mincol must be an integer - ~S" mincol))
1495  (unless (and (integerp colinc) (plusp colinc))
1496    (format-error "Colinc must be a positive integer - ~S" colinc))
1497  (unless (integerp minpad)
1498    (format-error "Minpad must be an integer - ~S" minpad))
1499  (unless (characterp padchar)
1500    (if (typep padchar `(integer 0 #.char-code-limit))
1501      (setq padchar (code-char padchar))
1502      (format-error "Padchar must be a character or integer from 0 to ~a - ~S"
1503                    char-code-limit padchar)))
1504  (let* ((strlen (length (the string string)))
1505         (strwid (+ strlen minpad))
1506         (width (if mincol
1507                  (format-round-columns strwid mincol colinc)
1508                  strwid)))
1509    (if padleft
1510      (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream)))
1511    (write-string string stream :start  0 :end strlen)
1512    (unless padleft
1513      (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream)))))
1514
1515
1516;;; This functions does most of the work for the numeric printing
1517;;; directives.  The parameters are interpreted as defined for ~D.
1518
1519(defun format-print-number (stream number radix print-commas-p print-sign-p parms)
1520  (declare (dynamic-extent parms))
1521  (declare (type t number) (type fixnum radix))
1522  #+wrong
1523  (when (> (length parms) 2) (setq print-commas-p t)) ; print commas if char or interval provided
1524  (if (not (integerp number))
1525      (let ((*print-base* radix)
1526            (*print-escape* nil)
1527            (*print-radix* nil))
1528        (declare (special *print-base* *print-radix*))
1529        (princ number stream))
1530    (with-format-parameters parms
1531          ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
1532      ; look out for ",0D" - should be ",'0D"
1533      (unless (characterp padchar)
1534        (error "Use '~A instead of ~A for padchar in format directive" padchar padchar))
1535       (setq print-sign-p 
1536             (cond ((and print-sign-p (>= number 0)) #\+)
1537                   ((< number 0) #\-)))
1538       (setq number (abs number))
1539       (block HAIRY
1540         (block SIMPLE
1541           (if (and (not print-commas-p) (eql 0 mincol))
1542             (return-from SIMPLE))
1543           (let ((lg 0)
1544                 (commas 0))
1545             (declare (type fixnum lg commas))
1546             (do ((n (abs number) (floor n radix)))
1547                 ((%i< n radix))
1548               (declare (type integer n))
1549               (setq lg (%i+ lg 1))) ; lg is 1- significant digits             
1550             (setq commas (if print-commas-p
1551                              (floor lg commainterval)
1552                              0))
1553             (when print-sign-p
1554               (setq lg (1+ lg)))
1555             (when (and (eq commas 0)
1556                        (%i<= mincol lg))
1557               (return-from SIMPLE))
1558             ;; Cons-o-rama no more !
1559             (let* ((s (make-string-output-stream)))
1560               (when  (neq padchar #\space)
1561                 (dotimes (i (- mincol (+ lg commas) 1))
1562                   (write-char padchar s)))
1563               (when print-sign-p (write-char print-sign-p s))
1564               (%pr-integer  number radix s)                           
1565               (dotimes (i (the fixnum commas)) (write-char commachar s))
1566               (let ((text (get-output-stream-string s)))
1567                 (declare (type string text))
1568                 ;; -1234567,, => -1,234,567
1569                 (when (%i> commas 0)
1570                   (do* ((dest (%i- (length text) 1))
1571                         (source (%i- dest commas)))
1572                        ((= source dest))
1573                     (declare (type fixnum dest source))
1574                     (dotimes (i (the fixnum commainterval))
1575                       (setf (char text dest) (char text source)
1576                             dest (1- dest) 
1577                             source (1- source)))
1578                     (setf (char text dest) commachar
1579                           dest (1- dest))))
1580                 (format-write-field stream text mincol 1 0 padchar t)
1581                 (return-from HAIRY)))))
1582         ;; SIMPLE case         
1583         (when print-sign-p (write-char print-sign-p stream))
1584         (%pr-integer number radix stream))))
1585  nil)
1586
1587;;; Print a cardinal number in English
1588
1589(eval-when (:compile-toplevel :execute)
1590(defmacro cardinal-ones ()
1591  "Table of cardinal ones-place digits in English"
1592        '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
1593(defmacro cardinal-tens ()
1594  "Table of cardinal tens-place digits in English"
1595        '#(nil nil "twenty" "thirty" "forty"
1596           "fifty" "sixty" "seventy" "eighty" "ninety"))
1597(defmacro cardinal-teens ()
1598        '#("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
1599           "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
1600)
1601
1602
1603(defun format-print-small-cardinal (stream n)
1604  (multiple-value-bind (hundreds rem) (truncate n 100)
1605    (when (plusp hundreds)
1606      (write-string (svref (cardinal-ones) hundreds) stream)
1607      (write-string " hundred" stream)
1608      (when (plusp rem) (write-char #\space stream)))    ; ; ; RAD
1609    (when (plusp rem)
1610      (multiple-value-bind (tens ones) (truncate rem 10)
1611        (cond ((< 1 tens)
1612               (write-string (svref (cardinal-tens) tens) stream)
1613               (when (plusp ones)
1614                 (write-char #\- stream)
1615                 (write-string (svref (cardinal-ones) ones) stream)))
1616              ((= tens 1)
1617               (write-string (svref (cardinal-teens) ones) stream))
1618              ((plusp ones)
1619               (write-string (svref (cardinal-ones) ones) stream)))))))
1620
1621(eval-when (:compile-toplevel :execute)
1622  (defmacro cardinal-periods ()
1623    "Table of cardinal 'teens' digits in English"
1624    '#("" " thousand" " million" " billion" " trillion" " quadrillion"
1625       " quintillion" " sextillion" " septillion" " octillion" " nonillion" 
1626       " decillion"))
1627)
1628
1629
1630(defun format-print-cardinal (stream n)
1631  (cond ((minusp n)
1632         (stream-write-entire-string stream "negative ")
1633         (format-print-cardinal-aux stream (- n) 0 n))
1634        ((zerop n)
1635         (stream-write-entire-string stream "zero"))
1636        (t (format-print-cardinal-aux stream n 0 n))))
1637
1638(defun format-print-cardinal-aux (stream n period err)
1639  (multiple-value-bind (beyond here) (truncate n 1000)
1640    (unless (<= period 10)
1641      (format-error "Number too large to print in English: ~:D" err))
1642    (unless (zerop beyond)
1643      (format-print-cardinal-aux stream beyond (1+ period) err))
1644    (unless (zerop here)
1645      (unless (zerop beyond) (write-char #\space stream))
1646      (format-print-small-cardinal stream here)
1647      (stream-write-entire-string stream (svref (cardinal-periods) period)))))
1648
1649
1650;;; Print an ordinal number in English
1651
1652
1653(eval-when (:compile-toplevel :execute)
1654(defmacro ordinal-ones ()
1655  "Table of ordinal ones-place digits in English"
1656  '#(nil "first" "second" "third" "fourth"
1657         "fifth" "sixth" "seventh" "eighth" "ninth"))
1658(defmacro ordinal-tens ()
1659  "Table of ordinal tens-place digits in English"
1660  '#(nil "tenth" "twentieth" "thirtieth" "fortieth"
1661         "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
1662)
1663
1664(defun format-print-ordinal (stream n)
1665  (when (minusp n)
1666    (stream-write-entire-string stream "negative "))
1667  (let ((number (abs n)))
1668    (multiple-value-bind (top bot) (truncate number 100)
1669      (unless (zerop top) (format-print-cardinal stream (- number bot)))
1670      (when (and (plusp top) (plusp bot)) (write-char #\space stream))
1671      (multiple-value-bind (tens ones) (truncate bot 10)
1672        (cond ((= bot 12) (stream-write-entire-string stream "twelfth"))
1673              ((= tens 1)
1674               (stream-write-entire-string stream (svref (cardinal-teens) ones));;;RAD
1675               (stream-write-entire-string stream "th"))
1676              ((and (zerop tens) (plusp ones))
1677               (stream-write-entire-string stream (svref (ordinal-ones) ones)))
1678              ((and (zerop ones)(plusp tens))
1679               (stream-write-entire-string stream (svref (ordinal-tens) tens)))
1680              ((plusp bot)
1681               (stream-write-entire-string stream (svref (cardinal-tens) tens))
1682               (write-char #\- stream)
1683               (stream-write-entire-string stream (svref (ordinal-ones) ones)))
1684              ((plusp number) (write-string "th" stream :start  0 :end 2))
1685              (t (stream-write-entire-string stream "zeroth")))))))
1686
1687
1688;;; Print Roman numerals
1689
1690(defun format-print-old-roman (stream n)
1691  (unless (< 0 n 5000)
1692          (format-error "Number out of range for old Roman numerals: ~:D" n))
1693  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1694       (val-list '(500 100 50 10 5 1) (cdr val-list))
1695       (cur-char #\M (car char-list))
1696       (cur-val 1000 (car val-list))
1697       (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val))))
1698                    ((< i cur-val) i))))
1699      ((zerop start))))
1700
1701
1702(defun format-print-roman (stream n)
1703  (unless (< 0 n 4000)
1704          (format-error "Number out of range for Roman numerals: ~:D" n))
1705  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
1706       (val-list '(500 100 50 10 5 1) (cdr val-list))
1707       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
1708       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
1709       (cur-char #\M (car char-list))
1710       (cur-val 1000 (car val-list))
1711       (cur-sub-char #\C (car sub-chars))
1712       (cur-sub-val 100 (car sub-val))
1713       (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val))))
1714                    ((< i cur-val)
1715                     (cond ((<= (- cur-val cur-sub-val) i)
1716                            (write-char cur-sub-char stream)
1717                            (write-char cur-char stream)
1718                            (- i (- cur-val cur-sub-val)))
1719                           (t i))))))
1720      ((zerop start))))
1721
1722
1723;;; Decimal  ~D
1724
1725(defformat #\D format-print-decimal (stream colon atsign &rest parms)
1726  (declare (dynamic-extent parms))
1727  (format-print-number stream (pop-format-arg) 10 colon atsign parms))
1728
1729
1730;;; Binary  ~B
1731
1732(defformat #\B format-print-binary (stream colon atsign &rest parms)
1733  (declare (dynamic-extent parms))
1734  (format-print-number stream (pop-format-arg) 2 colon atsign parms))
1735
1736
1737;;; Octal  ~O
1738
1739(defformat #\O format-print-octal (stream colon atsign &rest parms)
1740  (declare (dynamic-extent parms))
1741  (format-print-number stream (pop-format-arg) 8 colon atsign parms))
1742
1743
1744;;; Hexadecimal  ~X
1745
1746(defformat #\X format-print-hexadecimal (stream colon atsign &rest parms)
1747  (declare (dynamic-extent parms))
1748  (format-print-number stream (pop-format-arg) 16 colon atsign parms))
1749
1750
1751;;; Radix  ~R
1752
1753(defformat #\R format-print-radix (stream colon atsign &rest parms)
1754  (declare (dynamic-extent parms))
1755  (let ((number (pop-format-arg))
1756        (parm (if parms (pop parms) nil)))
1757    (if parm
1758        (format-print-number stream number parm colon atsign parms)
1759        (if atsign
1760            (if colon
1761                (format-print-old-roman stream number)
1762                (format-print-roman stream number))
1763            (if colon
1764                (format-print-ordinal stream number)
1765                (format-print-cardinal stream number))))))
1766
1767;;; FLOATING-POINT NUMBERS
1768
1769
1770;;; Fixed-format floating point  ~F
1771
1772(defformat #\F format-fixed (stream colon atsign &rest parms)
1773  (declare (dynamic-extent parms))
1774  (when colon
1775    (format-error "Colon flag not allowed"))
1776  (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
1777    ;;Note that the scale factor k defaults to nil.  This is interpreted as
1778    ;;zero by flonum-to-string, but more efficiently.
1779    (let ((number (pop-format-arg))(*print-escape* nil))
1780      (if (floatp number)
1781        (format-fixed-aux stream number w d k ovf pad atsign)
1782        (if (rationalp number)
1783          (format-fixed-aux stream (coerce number 'float) w d k ovf pad atsign)
1784          (let ((*print-base* 10))
1785            (format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
1786
1787; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1))
1788; called with w = 11 d = 16 - dont do it after all.
1789
1790(defun format-fixed-aux (stream number w d k ovf pad atsign)
1791  (and w (<= w 0) (setq w nil))  ; if width is unreasonable, ignore it.
1792  (if (not (or w d))  ; perhaps put this back when prin1 is better
1793    (prin1 number stream)
1794    (let ((spaceleft w)
1795          (abs-number (abs number))
1796          strlen zsuppress flonum-to-string-width)
1797      (when (and w (or atsign (minusp number)))
1798        (decf spaceleft))
1799      (when (and d w (<= w (+ 1 d (if atsign 1 0))))
1800        (setq zsuppress t))
1801      (when (and d (minusp d))
1802          (format-error "Illegal value for d"))
1803      (setq flonum-to-string-width
1804            (and w
1805                 (if (and (< abs-number 1) (not zsuppress))
1806                   (1- spaceleft)   ; room for leading 0
1807                   spaceleft)))
1808      (when (and w (not (plusp flonum-to-string-width)))
1809        (if ovf 
1810          (progn
1811            (dotimes (i w) (write-char ovf stream))
1812            (return-from format-fixed-aux))
1813          (setq spaceleft nil w nil)))
1814      (multiple-value-bind (str before-pt after-pt)
1815                           (flonum-to-string abs-number
1816                                             flonum-to-string-width
1817                                             d k)
1818        (setq strlen (length str))
1819        (cond (w (decf spaceleft (+ (max before-pt 0) 1))
1820                 (when (and (< before-pt 1) (not zsuppress))
1821                   (decf spaceleft))
1822                 (if d
1823                   (decf spaceleft d)
1824                   (setq d (max (min spaceleft (- after-pt))
1825                                (if (> spaceleft 0) 1 0))
1826                         spaceleft (- spaceleft d))))
1827              ((null d) (setq d (max (- after-pt) 1))))
1828        (cond ((and w (< spaceleft 0) ovf)
1829               ;;field width overflow
1830               (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)))
1831              (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream)))
1832                 (if (minusp (float-sign number)) ; 5/25
1833                   (write-char #\- stream)
1834                   (if atsign (write-char #\+ stream)))
1835                 (cond
1836                  ((> before-pt 0)
1837                   (cond ((> strlen before-pt)
1838                          (write-string str stream :start  0 :end before-pt)
1839                          (write-char #\. stream)
1840                          (write-string str stream :start  before-pt :end strlen)
1841                          (dotimes (i (- d (- strlen before-pt)))
1842                            (write-char #\0 stream)))
1843                         (t ; 0's after
1844                          (stream-write-entire-string stream str)
1845                          (dotimes (i (-  before-pt strlen))
1846                            (write-char #\0 stream))
1847                          (write-char #\. stream)
1848                          (dotimes (i d)
1849                            (write-char #\0 stream)))))
1850                  (t (unless zsuppress (write-char #\0 stream))
1851                     (write-char #\. stream)
1852                     (dotimes (i (- before-pt)) 
1853                       (write-char #\0 stream))
1854                     (stream-write-entire-string stream str)
1855                     (dotimes (i (+ d after-pt)) 
1856                      (write-char #\0 stream))))))))))
1857#|
1858; (format t "~7,3,-2f" 8.88)
1859; (format t "~10,5,2f" 8.88)
1860; (format t "~10,5,-2f" 8.88)
1861; (format t "~10,5,2f" 0.0)
1862; (format t "~10,5,2f" 9.999999999)
1863; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ??
1864; (format t "~10,,2f" 8.88)
1865; (format t "~10,,-2f" 8.88)
1866; (format t "~10,,2f" 0.0)
1867; (format t "~10,,2f" 0.123454)
1868; (format t "~10,,2f" 9.9999999)
1869 (defun foo (x)
1870    (format nil "~6,2f|~6,2,1,'*f|~6,2,,'?f|~6f|~,2f|~F"
1871     x x x x x x))
1872
1873|#
1874
1875                 
1876
1877;;; Exponential-format floating point  ~E
1878
1879
1880(defformat #\E format-exponential (stream colon atsign &rest parms)
1881  (declare (dynamic-extent parms))
1882  (when colon
1883    (format-error "Colon flag not allowed"))
1884  (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
1885    (let ((number (pop-format-arg)))
1886      (if (floatp number)
1887        (format-exp-aux stream number w d e k ovf pad marker atsign)
1888        (if (rationalp number)
1889          (format-exp-aux stream (coerce number 'float) w d e k ovf pad marker atsign)
1890          (let ((*print-base* 10))
1891            (format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
1892#|
1893(defun format-exponent-marker (number)
1894  (if (typep number *read-default-float-format*)
1895      #\E
1896      (cond ((double-floatp) #\D)
1897            ((short-floatp number) #\S)
1898            ((single-floatp number) #\F)
1899            ((long-floatp) #\L))))
1900|#
1901(eval-when (eval compile #-bccl load)
1902  (defmacro format-exponent-marker (number)
1903    `(float-exponent-char ,number))
1904)
1905
1906;;;Here we prevent the scale factor from shifting all significance out of
1907;;;a number to the right.  We allow insignificant zeroes to be shifted in
1908;;;to the left right, athough it is an error to specify k and d such that this
1909;;;occurs.  Perhaps we should detect both these condtions and flag them as
1910;;;errors.  As for now, we let the user get away with it, and merely guarantee
1911;;;that at least one significant digit will appear.
1912;;; THE ABOVE COMMENT no longer applies
1913
1914(defun format-exp-aux (stream number w d e k ovf pad marker atsign &optional string exp)
1915  (when (not k) (setq k 1))
1916  (if (not (or w d e marker (neq k 1)))
1917    (print-a-float number stream t)
1918    (prog () 
1919      (when d
1920        (when (or (minusp d)
1921                  (and (plusp k)(>= k (+ d 2)))
1922                  (and (minusp k)(< k (- d))))
1923          (format-error "incompatible values for k and d")))
1924      (when (not exp) (setq exp (scale-exponent  number)))
1925      AGAIN
1926      (let* ((expt (- exp k))
1927             (estr (let ((*print-base* 10))
1928                     (princ-to-string (abs expt))))
1929             (elen (max (length estr) (or e 0)))
1930             (spaceleft (if w (- w 2 elen) nil))
1931             (fwidth) scale)
1932        (when (and w (or atsign (minusp (float-sign number)))) ; 5/25
1933          (setq spaceleft (1- spaceleft)))
1934        (if w
1935          (progn 
1936          (setq fwidth (if d 
1937                         (if (> k 0)(+ d 2)(+ d k 1))
1938                         (if (> k 0) spaceleft (+ spaceleft k))))
1939          (when (minusp exp) ; i don't claim to understand this
1940            (setq fwidth (- fwidth exp))
1941            (when (< k 0) (setq fwidth (1- fwidth)))))         
1942          (when (and d  (not (zerop number))) ; d and no w
1943            (setq scale (- 2  k exp))))  ; 2 used to be 1  - 5/31
1944        (when (or (and w e ovf (> elen e))(and w fwidth (not (plusp fwidth))))
1945          ;;exponent overflow
1946          (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))
1947          (if (plusp fwidth)
1948            (return-from format-exp-aux nil)
1949            (setq fwidth nil)))
1950        (when (not string)
1951          (multiple-value-bind (new-string before-pt) (flonum-to-string number fwidth 
1952                                                                        (if (not fwidth) d)
1953                                                                        (if (not fwidth) scale))
1954            (setq string new-string)
1955            (when scale (setq before-pt (- (+ 1 before-pt) k scale))) ; sign right?           
1956            (when (neq exp before-pt)
1957              ;(print (list 'agn exp before-pt))
1958              ;(setq string new-string)
1959              (setq exp before-pt)
1960              (go again))))
1961          (let ((strlen (length string)))
1962            (when w
1963              (if d 
1964                (setq spaceleft (- spaceleft (+ d 2)))
1965                (if (< k 1)
1966                  (setq spaceleft (- spaceleft (+ 2 (- k)(max strlen 1))))
1967                  (setq spaceleft (- spaceleft (+ 1 k (max 1 (- strlen k))))))))
1968            (when (and w (< spaceleft 0))
1969              (if (and ovf (or (plusp k)(< spaceleft -1)))           
1970                (progn (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))
1971                       (return-from format-exp-aux nil))))
1972            (when w
1973              (dotimes (i  spaceleft)
1974                (declare (fixnum i))
1975                (write-char pad stream)))
1976            (if (minusp (float-sign number)) ; 5/25
1977              (write-char #\- stream)
1978              (if atsign (write-char #\+ stream)))
1979            (cond 
1980             ((< k 1)
1981              (when (not (minusp spaceleft))(write-char #\0 stream))
1982              (write-char #\. stream)
1983              (dotimes (i (- k))
1984                (write-char #\0 stream))
1985              (if (and (eq strlen 0)(not d))
1986                (write-char #\0 stream)
1987                (stream-write-entire-string stream string))
1988              (if d
1989                (dotimes (i (- (+ d k) strlen))
1990                  (write-char #\0 stream))))
1991             (t 
1992              (write-string string stream :start 0 :end (min k strlen))
1993              (dotimes (i (- k strlen))
1994                (write-char #\0 stream))                   
1995              (write-char #\. stream)
1996              (when (> strlen k)
1997                (write-string string stream :start k :end strlen))
1998              (if (not d) 
1999                (when (<= strlen k)(write-char #\0 stream))
2000                (dotimes (i (1+ (- d k (max 0 (- strlen k)))))
2001                  (write-char #\0 stream)))))
2002            (write-char (if marker
2003                          marker
2004                          (format-exponent-marker number))
2005                        stream)
2006            (write-char (if (minusp expt) #\- #\+) stream)
2007            (when e 
2008              ;;zero-fill before exponent if necessary
2009              (dotimes (i (- e (length estr)))
2010                (declare (fixnum i))
2011                (write-char #\0 stream)))
2012            (stream-write-entire-string stream estr))))))
2013#|
2014; (format t "~7,3,,-2e" 8.88) s.b. .009e+3
2015; (format t "~10,5,,2e" 8.888888888) ; "88.8889E-1"
2016; (format t "~10,5,,-2e" 8.88)   "0.00888E+3"
2017; (format t "~10,5,,-2e" .00123445) ; "0.00123E+0"
2018; (format t "~10,5,,-3e" .00123445) ; "0.00012E+1"
2019; (format t "~10,,,-2e" .123445)
2020; (format t "~10,5,,2e" .0012349999e-4)
2021; (format t "~10,5,,2e" 9.9999999)
2022; (format t "~10,5,,2e" 0.0)
2023; (format t "~10,5,,0e" 40000000.0)
2024; (format t "~10,5,,2e" 9.9999999)
2025; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ??
2026; (format t "~10,,,2e" 8.888888)
2027; (format t "~10,,,-2e" 8.88)
2028; (format t "~10,,,-2e" 0.0)
2029; (format t "~10,,,2e" 0.0)
2030; (format t "~10,,,2e" 9.9999999)
2031; (format t "~10,,,2e" 9.9999999e100)
2032; (format t "~10,5,3,2,'xe" 10e100)
2033; (format t "~9,3,2,-2e" 1100.0)
2034(defun foo (x)
2035  (format nil
2036          "~9,2,1,,'*e|~10,3,2,2,'?,,'$e|~9,3,2,-2,'%@e|~9,2e"
2037          x x x x))
2038|#
2039
2040
2041;;; General Floating Point -  ~G
2042
2043(defformat #\G format-general-float (stream colon atsign &rest parms)
2044  (declare (dynamic-extent parms))
2045  (when colon
2046    (format-error "Colon flag not allowed"))
2047  (with-format-parameters parms ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil))
2048    (let ((number (pop-format-arg)))
2049      ;;The Excelsior edition does not say what to do if
2050      ;;the argument is not a float.  Here, we adopt the
2051      ;;conventions used by ~F and ~E.
2052      (if (floatp number)
2053        (format-general-aux stream number w d e k ovf pad marker atsign)
2054        (if (rationalp number)
2055          (format-general-aux stream (coerce number 'float) w d e k ovf pad marker atsign)
2056          (let ((*print-base* 10))
2057            (format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
2058
2059#|
2060; completely broken
2061(defun foo (x)
2062  (format nil
2063          "~9,2,1,,'*g|~10,3,2,2,'?,,'$g|~9,3,2,-2,'%@g|~9,2g"
2064          x x x x))
2065|#
2066
2067
2068(defun format-general-aux (stream number w d e k ovf pad marker atsign)
2069  (multiple-value-bind (str n #|after-pt|#)(flonum-to-string number)
2070    ;;Default d if omitted.  The procedure is taken directly
2071    ;;from the definition given in the manual, and is not
2072    ;;very efficient, since we generate the digits twice.
2073    ;;Future maintainers are encouraged to improve on this.
2074    (let* ((d2 (or d (max (length str) (min n 7))))
2075           (ee (if e (+ e 2) 4))
2076           (ww (if w (- w ee) nil))
2077           (dd (- d2 n)))
2078      (cond ((<= 0 dd d2)
2079             ; this causes us to print 1.0 as 1. - seems weird
2080             (format-fixed-aux stream number ww dd nil ovf pad atsign)
2081             (dotimes (i ee) (declare (fixnum i)) (write-char #\space stream)))
2082            (t (format-exp-aux stream number w d e (or k 1) ovf pad marker atsign nil n))))))
2083
2084
2085;;; Dollars floating-point format  ~$
2086
2087(defformat #\$ format-dollars (stream colon atsign &rest parms)
2088  (declare (dynamic-extent parms))
2089  (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
2090    (let* ((number (float (pop-format-arg)))
2091           (signstr (if (minusp (float-sign number)) "-" (if atsign "+" "")))
2092           (spaceleft)
2093           strlen)
2094      (multiple-value-bind (str before-pt after-pt) (flonum-to-string number nil d)
2095        (setq strlen (length str))
2096        (setq spaceleft (- w (+ (length signstr) (max before-pt n) 1 d)))
2097        (when colon (stream-write-entire-string stream signstr))
2098        (dotimes (i spaceleft) (write-char pad stream))
2099        (unless colon (stream-write-entire-string stream signstr))
2100        (cond
2101         ((> before-pt 0)
2102          (cond ((> strlen before-pt)
2103                 (dotimes (i (- n before-pt))
2104                   (write-char #\0 stream))
2105                 (write-string str stream :start 0 :end before-pt)
2106                 (write-char #\. stream)
2107                 (write-string str stream :start before-pt :end strlen)
2108                 (dotimes (i (- d (- strlen before-pt)))
2109                   (write-char #\0 stream)))
2110                (t ; 0's after
2111                 (stream-write-entire-string stream str)
2112                 (dotimes (i (-  before-pt strlen))
2113                   (write-char #\0 stream))
2114                 (write-char #\. stream)
2115                 (dotimes (i d)
2116                   (write-char #\0 stream)))))
2117         (t (dotimes (i n)
2118              (write-char #\0 stream))
2119            (write-char #\. stream)
2120            (dotimes (i (- before-pt))
2121              (write-char #\0 stream))
2122            (stream-write-entire-string stream str)
2123            (dotimes (i (+ d after-pt))
2124              (write-char #\0 stream))))))))
2125
2126(defun y-or-n-p (&optional format-string &rest arguments &aux response)
2127  "Y-OR-N-P prints the message, if any, and reads characters from
2128   *QUERY-IO* until the user enters y or Y as an affirmative, or either
2129   n or N as a negative answer. It asks again if you enter any other
2130   characters."
2131  (declare (dynamic-extent arguments))
2132  (with-terminal-input
2133      (clear-input *query-io*)
2134      (loop
2135        (when format-string
2136          (fresh-line *query-io*)
2137          (apply 'format *query-io* format-string arguments))
2138        (princ " (y or n)  " *query-io*)
2139        (setq response (read-char *query-io*))
2140        ;; Consume input up to trailing newline
2141        (when (peek-char #\NewLine *query-io* nil)
2142          ;; And consume the #\newline
2143          (read-char *query-io*))
2144        (clear-input *query-io*)
2145        (if (char-equal response #\y) (return t))
2146        (if (char-equal response #\n) (return nil))
2147        (format *query-io* "Please answer y or n."))))
2148
2149(defun yes-or-no-p (&optional format-string &rest arguments &aux response)
2150  "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
2151   input buffer, beeps, and uses READ-LINE to get the strings
2152   YES or NO."
2153  (declare (dynamic-extent arguments))
2154  (with-terminal-input
2155      (loop
2156        (when format-string
2157          (fresh-line *query-io*)
2158          (apply 'format *query-io* format-string arguments))
2159        (princ " (yes or no)  " *query-io*)
2160        (format *query-io* "~A" #\Bell)
2161        (setq response (read-line *query-io*))
2162        (clear-input *query-io*)
2163        (when response
2164          (setq response (string-trim wsp response))
2165          (if (string-equal response "yes") (return t))
2166          (if (string-equal response "no") (return nil))
2167          (format *query-io* "Please answer yes or no.")))))
2168
2169
2170;; Compile-time format-scanning support.
2171;;
2172;; All this assumes it's called from the compiler, but it has to be kept in sync with code
2173;; here more than with the code in the compiler, so keep it in here.
2174
2175(defun note-format-scan-option (cell)
2176  (when cell
2177    (if (null (cdr cell))
2178      (setf (car cell) *format-arguments* (cdr cell) *format-arguments-variance*)
2179      (let* ((new-args *format-arguments*)
2180             (new-var *format-arguments-variance*)
2181             (new-max (length new-args))
2182             (old-args (car cell))
2183             (old-var (cdr cell))
2184             (old-max (length old-args))
2185             (min (min (- new-max new-var) (- old-max old-var))))
2186        (if (>= new-max old-max)
2187          (setf (car cell) new-args (cdr cell) (- new-max min))
2188          (setf (cdr cell) (- old-max min))))))
2189  cell)
2190
2191(defmacro with-format-scan-options ((var) &body body)
2192  (let ((cell (gensym)))
2193    ;; CELL is used to record range of arg variations that should be deferred til the end
2194    ;; of BODY because they represent possible non-local exits.
2195    `(let* ((,cell (cons nil nil))
2196            (,var ,cell))
2197       (declare (dynamic-extent ,cell))
2198       (prog1
2199           (progn
2200             ,@body)
2201         (setq *format-arguments* (car ,cell)
2202               *format-arguments-variance* (cdr ,cell))))))
2203
2204(defvar *format-escape-options* nil)
2205
2206(defun nx1-check-format-call (control-string format-arguments &optional (env *nx-lexical-environment*))
2207  "Format-arguments are expressions that will evaluate to the actual arguments.
2208  Pre-scan process the format string, nx1-whine if find errors"
2209  (let* ((*nx-lexical-environment* env)
2210         (*format-top-level* t)
2211         (*logical-block-xp* nil)
2212         (*format-pprint* nil)
2213         (*format-justification-semi* nil))
2214    (let ((error (catch 'format-error
2215                   (format-scan control-string format-arguments 0)
2216                   nil)))
2217      (when error
2218        (setf (cadar error) (concatenate 'string (cadar error) " in format string:"))
2219        (nx1-whine :format-error (nreverse error))
2220        t))))
2221
2222(defun format-scan (string args var)
2223  (let ((*format-original-arguments* args)
2224        (*format-arguments* args)
2225        (*format-arguments-variance* var)
2226        (*format-colon-rest* 'error)
2227        (*format-control-string* (ensure-simple-string string)))
2228    (with-format-scan-options (*format-escape-options*)
2229      (catch 'format-escape
2230        (sub-format-scan 0 (length *format-control-string*))
2231        (note-format-scan-option *format-escape-options*)))
2232    #+no
2233    (when (> (length *format-arguments*) *format-arguments-variance*)
2234      (format-error "Too many format arguments"))))
2235
2236(defun sub-format-scan (i end)
2237  (let ((*format-index* i)
2238        (*format-length* end)
2239        (string *format-control-string*))
2240    (loop while (setq *format-index* (position #\~ string :start *format-index* :end end)) do
2241      (multiple-value-bind (params colon atsign char) (parse-format-operation t)
2242        (setq char (char-upcase char))
2243        (let ((code (%char-code char)))
2244          (unless (and (< -1 code (length *format-char-table*))
2245                       (svref *format-char-table* code))
2246            (format-error "Unknown directive ~c" char)))
2247        (format-scan-directive char colon atsign params)
2248        (incf *format-index*)))))
2249
2250(defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*))
2251  (unless transformed (setq form (nx-transform form env)))
2252  (if (constantp form)
2253    (typep (eval-constant form) type env)
2254    (multiple-value-bind (win-p sure-p) (subtypep (nx-form-type form env) `(not ,type) env)
2255      (not (and win-p sure-p)))))
2256
2257(defun format-require-type (form type &optional description)
2258  (unless (nx-could-be-type form type)
2259    (format-error "~a must be of type ~s" (or description form) type)))
2260
2261
2262(defun format-scan-directive (char colon atsign parms)
2263  (ecase char
2264    ((#\% #\& #\~ #\|)
2265     (with-format-parameters parms ((repeat-count 1))
2266       (format-no-flags colon atsign)
2267       (format-require-type repeat-count '(integer 0))))
2268    ((#\newline #\return)
2269     (with-format-parameters parms ()
2270       (when (and atsign colon) (format-error "~:@<newline> is undefined"))
2271       (unless colon
2272         (format-eat-whitespace))))
2273    ((#\P)
2274     (with-format-parameters parms ()
2275       (when colon
2276         (loop with end = *format-arguments*
2277            for list on *format-original-arguments*
2278            when (eq (cdr list) end) return (setq *format-arguments* list)
2279            finally (if (> (or *format-arguments-variance* 0) 0)
2280                        (decf *format-arguments-variance*)
2281                        (format-error "No previous argument"))))
2282       (pop-format-arg)))
2283    ((#\A #\S)
2284     (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
2285       (format-require-type mincol 'integer "mincol (first parameter)")
2286       (format-require-type colinc '(integer 1) "colinc (second parameter)")
2287       (format-require-type minpad 'integer "minpad (third parameter)")
2288       (format-require-type padchar '(or (integer 0 #.char-code-limit) character) "padchar (fourth parameter)"))
2289     (pop-format-arg))
2290    ((#\I)
2291     (with-format-parameters parms ((n 0))
2292       (format-no-flags nil atsign)
2293       (format-no-semi char)
2294       (format-require-type n 'real)))
2295    ((#\_)
2296     (with-format-parameters parms ()
2297       (format-no-semi char)))
2298    ((#\T)
2299     (with-format-parameters parms ((colnum 1) (colinc 1))
2300       (when colon
2301         (format-no-semi char t))
2302       (format-require-type colnum 'integer "colnum (first parameter)")
2303       (format-require-type colinc 'integer "colinc (second parameter)")))
2304    ((#\W)
2305     (with-format-parameters parms ()
2306       (format-no-semi #\W))
2307     (pop-format-arg))
2308    ((#\C)
2309     (with-format-parameters parms ())
2310     (format-require-type (pop-format-arg) '(or character fixnum (string 1))))
2311    ((#\D #\B #\O #\X #\R)
2312     (when (eql char #\R)
2313       (let ((radix (pop parms)))
2314         (when radix
2315           (format-require-type radix '(integer 2 36)))))
2316     (with-format-parameters parms ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
2317       (format-require-type mincol 'integer "mincol (first parameter)")
2318       (format-require-type padchar 'character "padchar (second parameter)")
2319       (format-require-type commachar 'character "comma char (third parameter)")
2320       (format-require-type commainterval 'integer "comma interval (fourth parameter)"))
2321     (pop-format-arg))
2322    ((#\F)
2323     (format-no-flags colon nil)
2324     (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
2325       (format-require-type w '(or null (integer 0)) "w (first parameter)")
2326       (format-require-type d '(or null (integer 0)) "d (second parameter)")
2327       (format-require-type k '(or null (integer 0)) "k (third parameter)")
2328       (format-require-type ovf '(or null character) "ovf (fourth parameter)")
2329       (format-require-type pad '(or null character) "pad (fifth parameter)"))
2330     (pop-format-arg))
2331    ((#\E #\G)
2332     (format-no-flags colon nil)
2333     (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
2334       (format-require-type w '(or null (integer 0)) "w (first parameter)")
2335       (format-require-type d '(or null (integer 0)) "d (second parameter)")
2336       (format-require-type e '(or null (integer 0)) "d (third parameter)")
2337       (format-require-type k '(or null (integer 0)) "k (fourth parameter)")
2338       (format-require-type ovf '(or null character) "ovf (fifth parameter)")
2339       (format-require-type pad '(or null character) "pad (sixth parameter)")
2340       (format-require-type marker '(or null character) "marker (seventh parameter)"))
2341     (pop-format-arg))
2342    ((#\$)
2343     (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
2344       (format-require-type d '(or null (integer 0)) "d (first parameter)")
2345       (format-require-type n '(or null (integer 0)) "n (second parameter)")
2346       (format-require-type w '(or null (integer 0)) "w (third parameter)")
2347       (format-require-type pad '(or null character) "pad (fourth parameter)"))
2348     (format-require-type (pop-format-arg) 'real))
2349    ((#\*)
2350     (with-format-parameters parms ((count nil))
2351       (when count
2352         (format-require-type count 'integer "count parameter"))
2353       (if (typep (setq count (nx-transform count)) '(or null integer))
2354         (format-scan-goto colon atsign count)
2355         ;; Else can't tell how much going back or forth, could be anywhere.
2356         (setq *format-arguments* *format-original-arguments*
2357               *format-arguments-variance* (length *format-arguments*)))))
2358    ((#\?)
2359     (with-format-parameters parms ()
2360       (format-no-flags colon nil))
2361     (let ((string (pop-format-arg)))
2362       (format-require-type string '(or string function))
2363       (if atsign
2364         (setq *format-arguments-variance* (length *format-arguments*))
2365         (let ((arg (pop-format-arg)))
2366           (format-require-type arg 'list)))))
2367    ((#\/)
2368     (let* ((string *format-control-string*)
2369            (ipos (1+ *format-index*))
2370            (epos (format-find-char #\/ ipos *format-length*)))
2371       (when (not epos) (format-error "Unmatched ~~/"))
2372       (let* ((cpos (format-find-char #\: ipos epos))
2373              (name (if cpos
2374                      (prog1
2375                          (string-upcase (%substr string ipos cpos))
2376                        (when (eql #\: (schar string (%i+ 1 cpos)))
2377                          (setq cpos (%i+ cpos 1)))
2378                        (setq ipos (%i+ cpos 1)))
2379                      "CL-USER"))
2380              (package (find-package name))
2381              (sym (and package (find-symbol (string-upcase (%substr string ipos epos)) package)))
2382              (arg (pop-format-arg)))
2383         (setq *format-index* epos) ; or 1+ epos?
2384         ;; TODO: should we complain if the symbol doesn't exit?  Perhaps it will be defined
2385         ;; later, and to detect that would need to intern it.  What if the package doesn't exist?
2386         ;; Would need to extend :undefined-function warnings to handle previously-undefined package.
2387         (when sym
2388           (when (nth-value 1 (nx1-call-result-type sym (list* '*standard-output* arg colon atsign parms)))
2389             ;; Whined, just get out now.
2390             (throw 'format-error nil))))))
2391    ((#\[)
2392     (when (and colon atsign) (format-error  "~~:@[ undefined"))
2393     (format-nextchar)
2394     (cond (colon
2395            (format-scan-boolean-condition parms))
2396           (atsign
2397            (format-scan-funny-condition parms))
2398           (t (format-scan-untagged-condition parms))))
2399    ((#\()
2400     (with-format-parameters parms ()
2401       (format-nextchar)
2402       (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\)))
2403         (with-format-parameters parms () (format-no-flags colon atsign))
2404         (sub-format-scan prev tilde))))
2405    ((#\^)
2406     (format-no-flags nil atsign)
2407     (with-format-parameters parms ((p1 nil) (p2 nil) (p3 nil))
2408       (let ((val (nx-transform (cond (p3
2409                                       (if (every (lambda (p) (nx-could-be-type p 'real)) parms)
2410                                         ;; If the params could also be chars, don't know enough to constant fold
2411                                         ;; anyway, so this test will do.
2412                                         `(< ,p1 ,p2 ,p3)
2413                                         (if (every (lambda (p) (nx-could-be-type p 'character)) parms)
2414                                           `(char< ,p1 ,p2 ,p3)
2415                                           ;; At least one can't be real, at least one can't be char.
2416                                           (format-error "Wrong type of parameters for three-way comparison"))))
2417                                      (p2 `(equal ,p1 ,p2))
2418                                      (p1 `(eq ,p1 0))
2419                                      (t (null (if colon *format-colon-rest* *format-arguments*)))))))
2420         (when val
2421           (note-format-scan-option *format-escape-options*)
2422           (unless (nx-could-be-type val 'null t)
2423             (throw 'format-escape t))))))
2424    ((#\{)
2425     (with-format-parameters parms ((max-iter -1))
2426       (format-require-type max-iter 'integer "max-iter parameter")
2427       (format-nextchar)
2428       (multiple-value-bind (prev tilde end-parms end-colon end-atsign) (format-find-command '(#\}))
2429         (declare (ignore end-colon))
2430         (with-format-parameters end-parms () (format-no-flags nil end-atsign))
2431         (when (= prev tilde)
2432           ;; Use an argument as the control string if ~{~} is empty
2433           (let ((string (pop-format-arg)))
2434             (unless (nx-could-be-type string '(or string function))
2435               (format-error "Control string is not a string or function"))))
2436         ;; Could try to actually scan the iteration if string is a compile-time string,
2437         ;; by that seems unlikely.
2438         (if atsign
2439           (setq *format-arguments-variance* (length *format-arguments*))
2440           (format-require-type (pop-format-arg) 'list)))))
2441    ((#\<)
2442     (multiple-value-bind (start tilde eparms ecolon eatsign) (format-find-command '(#\>))
2443       (declare (ignore tilde eparms eatsign))
2444       (setq *format-index* start)
2445       (if ecolon
2446         (format-logical-block-scan colon atsign parms)
2447         (format-justification-scan colon atsign parms))))
2448    ))
2449
2450(defun format-justification-scan (colon atsign parms)
2451  (declare (ignore colon atsign))
2452  (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
2453    (format-require-type mincol 'integer "mincol (first parameter)")
2454    (format-require-type colinc '(integer 1) "colinc (second parameter)")
2455    (format-require-type minpad 'integer "minpad (third parameter)")
2456    (format-require-type padchar `(or character (integer 0 #.char-code-limit)) "padchar (fourth parameter)"))
2457  (let ((first-parms nil) (first-colon nil) (count 0))
2458    (with-format-scan-options (*format-escape-options*)
2459      (loop
2460         (format-nextchar)
2461         (multiple-value-bind (prev tilde parms colon atsign cmd)
2462             (format-find-command '(#\; #\>) nil T)
2463           (if (and (eql count 0) (eql cmd #\;) colon)
2464             (progn
2465               (format-no-flags nil atsign)
2466               (setq first-colon t)
2467               (setq *format-index* tilde)
2468               (setq first-parms (nth-value 2 (format-find-command '(#\; #\>) t T))))
2469             (with-format-parameters parms ()
2470               (format-no-flags colon atsign)))
2471           (when (catch 'format-escape
2472                   (sub-format-scan prev tilde)
2473                   nil)
2474             (unless (eq cmd #\>) (format-find-command '(#\>) nil t))
2475             (return))
2476           (incf count)
2477           (when (eq cmd #\>)
2478             (return))))
2479      (note-format-scan-option *format-escape-options*))
2480    (when first-colon
2481      (when *format-pprint*
2482        (format-error "Justification illegal in this context"))
2483      (setq *format-justification-semi* t)
2484      (with-format-parameters first-parms ((spare 0) (linel 0))
2485        (format-require-type spare 'integer "spare (first parameter)")
2486        (format-require-type linel 'integer "line length (second parameter)")))))
2487     
2488
2489
2490(defun format-logical-block-scan (colon atsign params)
2491  (declare (ignore colon))
2492  (with-format-parameters params ()
2493    (format-no-semi #\<))
2494    ;; First section can be termined by ~@;
2495  (let ((format-string *format-control-string*)
2496        (prefix "")
2497        (suffix "")
2498        (body-string nil))
2499    (multiple-value-bind (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command  '(#\; #\>))
2500      (setq body-string (%substr format-string (1+ start1) tilde))
2501      (with-format-parameters parms1 ())
2502      (when (eq cmd #\;)
2503        (format-no-flags colon1 nil)
2504        (setq prefix body-string)
2505        (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)))
2506        (with-format-parameters parms1 ())
2507        (setq body-string (%substr format-string (1+ start1) tilde))
2508        (when (eq cmd #\;)
2509          (format-no-flags colon1 atsign1)
2510          (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command  '(#\; #\>)))
2511          (with-format-parameters parms1 ())
2512          (setq suffix (%substr format-string (1+ start1) tilde))
2513          (when (eq cmd #\;)
2514            (format-error "Too many sections")))))
2515    (flet ((format-check-simple (str where)
2516             (when (and str (or (%str-member #\~ str) (%str-member #\newline str)))
2517               (format-error "~A must be simple" where))))
2518      (format-check-simple prefix "Prefix")
2519      (format-check-simple suffix "Suffix"))
2520    (if atsign
2521      (let ((*logical-block-p* t))
2522        (format-scan body-string *format-arguments* *format-arguments-variance*)
2523        (setq *format-arguments* nil *format-arguments-variance* 0))
2524      ;; If no atsign, we just use up an arg.  Don't bother trying to scan it, unlikely to be a constant.
2525      (when *format-arguments*
2526        (pop-format-arg)))))
2527
2528
2529(defun format-scan-untagged-condition (parms)
2530  (with-format-parameters parms ((index nil))
2531    (unless index (setq index (pop-format-arg)))
2532    (format-require-type index 'integer)
2533    (with-format-scan-options (cond-options)
2534      (loop with default = nil do
2535           (multiple-value-bind (prev tilde parms colon atsign cmd)
2536               (format-find-command '(#\; #\]))
2537             (when (and default (eq cmd #\;))
2538               (format-error "~:; must be the last clause"))
2539             (with-format-parameters parms ()
2540               (format-no-flags (if (eq cmd #\]) colon) atsign)
2541               (when colon (setq default t)))
2542             (format-scan-optional-clause prev tilde cond-options)
2543             (when (eq cmd #\])
2544               (unless default    ;; Could just skip the whole thing
2545                 (note-format-scan-option cond-options))
2546               (return))
2547             (format-nextchar))))))
2548
2549(defun format-scan-funny-condition (parms)
2550  (with-format-parameters parms ())
2551  (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
2552    (with-format-parameters parms ()
2553      (format-no-flags colon atsign))
2554    (when (null *format-arguments*) (pop-format-arg)) ;; invoke std error
2555    (with-format-scan-options (cond-options)
2556      (let ((arg (nx-transform (car *format-arguments*))))
2557        (when (nx-could-be-type arg 'null t)
2558          (let ((*format-arguments* *format-arguments*)
2559                (*format-arguments-variance* *format-arguments-variance*))
2560            (when (eql *format-arguments-variance* (length *format-arguments*))
2561              (decf *format-arguments-variance*))
2562            (pop *format-arguments*)
2563            (note-format-scan-option cond-options)))
2564        (when arg
2565          (format-scan-optional-clause prev tilde cond-options))))))
2566
2567
2568(defun format-scan-boolean-condition (parms)
2569  (with-format-parameters parms ())
2570  (multiple-value-bind (prev tilde parms colon atsign cmd) (format-find-command '(#\; #\]))
2571    (when (eq cmd #\])
2572      (format-error "Two clauses separated by ~~; are required for ~~:["))
2573    (with-format-parameters parms () (format-no-flags colon atsign))
2574    (format-nextchar)
2575    (with-format-scan-options (cond-options)
2576      (let ((arg (nx-transform (pop-format-arg))))
2577        (when (nx-could-be-type arg 'null t)
2578          (format-scan-optional-clause prev tilde cond-options))
2579        (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
2580          (with-format-parameters parms () (format-no-flags colon atsign))
2581          (when arg
2582            (format-scan-optional-clause prev tilde cond-options)))))))
2583
2584
2585(defun format-scan-optional-clause (start end cond-option)
2586  (let ((*format-arguments* *format-arguments*)
2587        (*format-arguments-variance* *format-arguments-variance*))
2588    ;; Let the branch points collect in outer *format-escape-options*, but don't
2589    ;; throw there because need to consider the other clauses.
2590    (catch 'format-escape
2591      (sub-format-scan start end)
2592      (note-format-scan-option cond-option)
2593      nil)))
2594
2595(defun format-scan-goto (colon atsign count)
2596  (if atsign 
2597    (progn
2598      (format-no-flags colon nil)
2599      (setq *format-arguments*
2600            (nthcdr-no-overflow (or count 0) *format-original-arguments*))
2601      (setq *format-arguments-variance* 0))
2602    (progn
2603      (when (null count)(setq count 1))
2604      (when colon (setq count (- count)))
2605      (cond ((> count 0)
2606             (when (> count (length *format-arguments*))
2607               (format-error "Target position for ~~* out of bounds"))
2608             (setq *format-arguments* (nthcdr count *format-arguments*))
2609             (when *format-arguments-variance*
2610               (setq *format-arguments-variance*
2611                     (min *format-arguments-variance* (length *format-arguments*)))))
2612            ((< count 0)
2613             (let* ((orig *format-original-arguments*)
2614                    (pos (+ (- (length orig) (length *format-arguments*)) count))
2615                    (max-pos (+ pos (or *format-arguments-variance* 0))))
2616               (when (< max-pos 0)
2617                 (format-error "Target position for ~~* out of bounds"))
2618               (if (< pos 0)
2619                 (setq *format-arguments* orig
2620                       *format-arguments-variance* max-pos)
2621                 (setq *format-arguments* (nthcdr pos orig)))))))))
2622
Note: See TracBrowser for help on using the repository browser.