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

Last change on this file since 12301 was 12301, checked in by gz, 10 years ago

Merge r12276 r12292 r12297 from trunk, plus some mods for other platforms

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