source: branches/working-0711/ccl/lib/format.lisp @ 9117

Last change on this file since 9117 was 9117, checked in by gz, 13 years ago

Add CCL:TEST-CCL - runs the gcl test suite (checking it out into ccl:tests;
if necessary). This will print out a bunch of warnings early on (for now),
then sit there for a while (about 3 mins on a MacBook? Pro) and finally
report "No tests failed".

Propagate assorted small fixes from trunk:

r8996 - fix case of spurious defvar warning
r9027 - check arg count before deciding to use builtin-call
r9046 - small fix for ~@:C
r9047 - report a TYPE-ERROR when make-broadcast-stream is given a non-output-stream
r9048 - Make make-file-stream rejected wildcarded pathnames. Various tweaks to make

meta-. work when using pathnames relative to the file system's "current directory".

r9049 - make defclass check for illegal class options
r9052 - Don't constant-fold if arg count is obviously wrong.
r9059 - Try harder to do function calls as function calls when (OPTIMIZE (SAFETY 3))

is in effect.

r9060, r9061 - CTYPE-SUBTYPE: try harder in some cases.
r9068, r9069, r9103, r9104 - PPC2-REF-SYMBOL-VALUE: force boundp checks unless

*ppc2-reckless* (same policy as x86; the per-thread binding lookup is generally
more expensive than boundp trap these days.). Unless skipping boundp check, don't
ignore unused result (so we can error when safety is 3, mostly.)

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