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

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

Propagate r10938:r10941 (duplicate definition warnings) to trunk

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