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

Last change on this file since 16648 was 16648, checked in by rme, 5 years ago

In format-find-command, try not to get tripped up by #\~ directives.

Closes ticket:1330.

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