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

Last change on this file since 8177 was 8172, checked in by gb, 12 years ago

Y-OR-N-P fixes from trunk.

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