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

Last change on this file since 10431 was 10431, checked in by gb, 11 years ago

Add FORMAT-TO-STRING.

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