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

Last change on this file since 11158 was 11158, checked in by gz, 12 years ago

Small optimizations tweaks

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