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

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

Require two clauses in ~:[

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