3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;;; exported printer control variables
16 ;;; FIXME: Many of these have nontrivial types, e.g. *PRINT-LEVEL*,
17 ;;; *PRINT-LENGTH*, and *PRINT-LINES* are (OR NULL UNSIGNED-BYTE).
19 (defvar *print-readably
* nil
21 "If true, all objects will printed readably. If readable printing is
22 impossible, an error will be signalled. This overrides the value of
24 (defvar *print-escape
* T
26 "Should we print in a reasonably machine-readable way? (possibly
27 overridden by *PRINT-READABLY*)")
28 (defvar *print-pretty
* nil
; (set later when pretty-printer is initialized)
30 "Should pretty printing be used?")
31 (defvar *print-base
* 10.
33 "the output base for RATIONALs (including integers)")
34 (defvar *print-radix
* nil
36 "Should base be verified when printing RATIONALs?")
37 (defvar *print-level
* nil
39 "How many levels should be printed before abbreviating with \"#\"?")
40 (defvar *print-length
* nil
42 "How many elements at any level should be printed before abbreviating
44 (defvar *print-circle
* nil
46 "Should we use #n= and #n# notation to preserve uniqueness in general (and
47 circularity in particular) when printing?")
48 (defvar *print-case
* :upcase
50 "What case should the printer should use default?")
51 (defvar *print-array
* t
53 "Should the contents of arrays be printed?")
54 (defvar *print-gensym
* t
56 "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
57 (defvar *print-lines
* nil
59 "the maximum number of lines to print per object")
60 (defvar *print-right-margin
* nil
62 "the position of the right margin in ems (for pretty-printing)")
63 (defvar *print-miser-width
* nil
65 "If the remaining space between the current column and the right margin
66 is less than this, then print using ``miser-style'' output. Miser
67 style conditional newlines are turned on, and all indentations are
68 turned off. If NIL, never use miser mode.")
69 (defvar *print-pprint-dispatch
*)
71 (setf (fdocumentation '*print-pprint-dispatch
* 'variable
)
72 "the pprint-dispatch-table that controls how to pretty-print objects")
74 (defmacro with-standard-io-syntax
(&body body
)
76 "Bind the reader and printer control variables to values that enable READ
77 to reliably read the results of PRINT. These values are:
78 *PACKAGE* the COMMON-LISP-USER package
88 *PRINT-MISER-WIDTH* NIL
92 *PRINT-RIGHT-MARGIN* NIL
94 *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
97 *READTABLE* the standard readtable"
98 `(%with-standard-io-syntax
(lambda () ,@body
)))
100 (defun %with-standard-io-syntax
(function)
101 (declare (type function function
))
102 (let ((*package
* (find-package "COMMON-LISP-USER"))
105 (*print-case
* :upcase
)
112 (*print-miser-width
* nil
)
116 (*print-right-margin
* nil
)
118 (*read-default-float-format
* 'single-float
)
120 (*read-suppress
* nil
)
121 ;; FIXME: It doesn't seem like a good idea to expose our
122 ;; disaster-recovery *STANDARD-READTABLE* here. What if some
123 ;; enterprising user corrupts the disaster-recovery readtable
124 ;; by doing destructive readtable operations within
125 ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
126 ;; COPY-READTABLE? The consing would be unfortunate, though.
127 (*readtable
* *standard-readtable
*))
130 ;;;; routines to print objects
132 (defun write (object &key
133 ((:stream stream
) *standard-output
*)
134 ((:escape
*print-escape
*) *print-escape
*)
135 ((:radix
*print-radix
*) *print-radix
*)
136 ((:base
*print-base
*) *print-base
*)
137 ((:circle
*print-circle
*) *print-circle
*)
138 ((:pretty
*print-pretty
*) *print-pretty
*)
139 ((:level
*print-level
*) *print-level
*)
140 ((:length
*print-length
*) *print-length
*)
141 ((:case
*print-case
*) *print-case
*)
142 ((:array
*print-array
*) *print-array
*)
143 ((:gensym
*print-gensym
*) *print-gensym
*)
144 ((:readably
*print-readably
*) *print-readably
*)
145 ((:right-margin
*print-right-margin
*)
146 *print-right-margin
*)
147 ((:miser-width
*print-miser-width
*)
149 ((:lines
*print-lines
*) *print-lines
*)
150 ((:pprint-dispatch
*print-pprint-dispatch
*)
151 *print-pprint-dispatch
*))
153 "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
154 (output-object object
(out-synonym-of stream
))
157 (defun prin1 (object &optional stream
)
159 "Output a mostly READable printed representation of OBJECT on the specified
161 (let ((*print-escape
* T
))
162 (output-object object
(out-synonym-of stream
)))
165 (defun princ (object &optional stream
)
167 "Output an aesthetic but not necessarily READable printed representation
168 of OBJECT on the specified STREAM."
169 (let ((*print-escape
* NIL
)
170 (*print-readably
* NIL
))
171 (output-object object
(out-synonym-of stream
)))
174 (defun print (object &optional stream
)
176 "Output a newline, the mostly READable printed representation of OBJECT, and
177 space to the specified STREAM."
178 (let ((stream (out-synonym-of stream
)))
180 (prin1 object stream
)
181 (write-char #\space stream
)
184 (defun pprint (object &optional stream
)
186 "Prettily output OBJECT preceded by a newline."
187 (let ((*print-pretty
* t
)
189 (stream (out-synonym-of stream
)))
191 (output-object object stream
))
194 (defun write-to-string
196 ((:escape
*print-escape
*) *print-escape
*)
197 ((:radix
*print-radix
*) *print-radix
*)
198 ((:base
*print-base
*) *print-base
*)
199 ((:circle
*print-circle
*) *print-circle
*)
200 ((:pretty
*print-pretty
*) *print-pretty
*)
201 ((:level
*print-level
*) *print-level
*)
202 ((:length
*print-length
*) *print-length
*)
203 ((:case
*print-case
*) *print-case
*)
204 ((:array
*print-array
*) *print-array
*)
205 ((:gensym
*print-gensym
*) *print-gensym
*)
206 ((:readably
*print-readably
*) *print-readably
*)
207 ((:right-margin
*print-right-margin
*) *print-right-margin
*)
208 ((:miser-width
*print-miser-width
*) *print-miser-width
*)
209 ((:lines
*print-lines
*) *print-lines
*)
210 ((:pprint-dispatch
*print-pprint-dispatch
*)
211 *print-pprint-dispatch
*))
213 "Return the printed representation of OBJECT as a string."
214 (stringify-object object
))
216 (defun prin1-to-string (object)
218 "Return the printed representation of OBJECT as a string with
220 (stringify-object object t
))
222 (defun princ-to-string (object)
224 "Return the printed representation of OBJECT as a string with
226 (stringify-object object nil
))
228 ;;; This produces the printed representation of an object as a string.
229 ;;; The few ...-TO-STRING functions above call this.
230 (defvar *string-output-streams
* ())
231 (defun stringify-object (object &optional
(*print-escape
* *print-escape
*))
232 (let ((stream (if *string-output-streams
*
233 (pop *string-output-streams
*)
234 (make-string-output-stream))))
235 (setup-printer-state)
236 (output-object object stream
)
238 (get-output-stream-string stream
)
239 (push stream
*string-output-streams
*))))
241 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
243 ;;; guts of PRINT-UNREADABLE-OBJECT
244 (defun %print-unreadable-object
(object stream type identity body
)
245 (declare (type (or null function
) body
))
246 (when *print-readably
*
247 (error 'print-not-readable
:object object
))
248 (flet ((print-description ()
250 (write (type-of object
) :stream stream
:circle nil
251 :level nil
:length nil
)
252 (when (or body identity
)
253 (write-char #\space stream
)
254 (pprint-newline :fill stream
)))
259 (write-char #\space stream
)
260 (pprint-newline :fill stream
))
261 (write-char #\
{ stream
)
262 (write (get-lisp-obj-address object
) :stream stream
264 (write-char #\
} stream
))))
265 (cond ((print-pretty-on-stream-p stream
)
266 ;; Since we're printing prettily on STREAM, format the
267 ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
268 ;; not rebind the stream when it is already a pretty stream,
269 ;; so output from the body will go to the same stream.
270 (pprint-logical-block (stream nil
:prefix
"#<" :suffix
">")
271 (print-description)))
273 (write-string "#<" stream
)
275 (write-char #\
> stream
))))
278 ;;;; circularity detection stuff
280 ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
281 ;;; (eventually) ends up with entries for every object printed. When
282 ;;; we are initially looking for circularities, we enter a T when we
283 ;;; find an object for the first time, and a 0 when we encounter an
284 ;;; object a second time around. When we are actually printing, the 0
285 ;;; entries get changed to the actual marker value when they are first
287 (defvar *circularity-hash-table
* nil
)
289 ;;; When NIL, we are just looking for circularities. After we have
290 ;;; found them all, this gets bound to 0. Then whenever we need a new
291 ;;; marker, it is incremented.
292 (defvar *circularity-counter
* nil
)
294 ;;; Check to see whether OBJECT is a circular reference, and return
295 ;;; something non-NIL if it is. If ASSIGN is T, then the number to use
296 ;;; in the #n= and #n# noise is assigned at this time.
297 ;;; If ASSIGN is true, reference bookkeeping will only be done for
298 ;;; existing entries, no new references will be recorded!
300 ;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
301 ;;; ASSIGN true, or the circularity detection noise will get confused
302 ;;; about when to use #n= and when to use #n#. If this returns non-NIL
303 ;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
304 ;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
305 ;;; you need to initiate the circularity detection noise, e.g. bind
306 ;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
307 ;;; (see #'OUTPUT-OBJECT for an example).
308 (defun check-for-circularity (object &optional assign
)
309 (cond ((null *print-circle
*)
310 ;; Don't bother, nobody cares.
312 ((null *circularity-hash-table
*)
313 (values nil
:initiate
))
314 ((null *circularity-counter
*)
315 (ecase (gethash object
*circularity-hash-table
*)
318 (setf (gethash object
*circularity-hash-table
*) t
)
319 ;; We need to keep looking.
323 (setf (gethash object
*circularity-hash-table
*) 0)
324 ;; It's a circular reference.
327 ;; It's a circular reference.
330 (let ((value (gethash object
*circularity-hash-table
*)))
333 ;; If NIL, we found an object that wasn't there the
334 ;; first time around. If T, this object appears exactly
335 ;; once. Either way, just print the thing without any
336 ;; special processing. Note: you might argue that
337 ;; finding a new object means that something is broken,
338 ;; but this can happen. If someone uses the ~@<...~:>
339 ;; format directive, it conses a new list each time
340 ;; though format (i.e. the &REST list), so we will have
345 (let ((value (incf *circularity-counter
*)))
346 ;; first occurrence of this object: Set the counter.
347 (setf (gethash object
*circularity-hash-table
*) value
)
351 ;; second or later occurrence
354 ;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
355 ;;; you should go ahead and print the object. If it returns NIL, then
356 ;;; you should blow it off.
357 (defun handle-circularity (marker stream
)
360 ;; Someone forgot to initiate circularity detection.
361 (let ((*print-circle
* nil
))
362 (error "trying to use CHECK-FOR-CIRCULARITY when ~
363 circularity checking isn't initiated")))
365 ;; It's a second (or later) reference to the object while we are
366 ;; just looking. So don't bother groveling it again.
369 (write-char #\
# stream
)
370 (let ((*print-base
* 10) (*print-radix
* nil
))
371 (cond ((minusp marker
)
372 (output-integer (- marker
) stream
)
373 (write-char #\
# stream
)
376 (output-integer marker stream
)
377 (write-char #\
= stream
)
380 ;;;; OUTPUT-OBJECT -- the main entry point
382 ;;; Objects whose print representation identifies them EQLly don't
383 ;;; need to be checked for circularity.
384 (defun uniquely-identified-by-print-p (x)
388 (symbol-package x
))))
390 ;;; Output OBJECT to STREAM observing all printer control variables.
391 (defun output-object (object stream
)
392 (labels ((print-it (stream)
394 (sb!pretty
:output-pretty-object object stream
)
395 (output-ugly-object object stream
)))
397 (multiple-value-bind (marker initiate
)
398 (check-for-circularity object t
)
399 ;; initialization of the circulation detect noise ...
400 (if (eq initiate
:initiate
)
401 (let ((*circularity-hash-table
*
402 (make-hash-table :test
'eq
)))
403 (check-it (make-broadcast-stream))
404 (let ((*circularity-counter
* 0))
408 (when (handle-circularity marker stream
)
410 (print-it stream
))))))
411 (cond (;; Maybe we don't need to bother with circularity detection.
412 (or (not *print-circle
*)
413 (uniquely-identified-by-print-p object
))
415 (;; If we have already started circularity detection, this
416 ;; object might be a shared reference. If we have not, then
417 ;; if it is a compound object it might contain a circular
418 ;; reference to itself or multiple shared references.
419 (or *circularity-hash-table
*
420 (compound-object-p object
))
423 (print-it stream
)))))
425 ;;; a hack to work around recurring gotchas with printing while
426 ;;; DEFGENERIC PRINT-OBJECT is being built
428 ;;; (hopefully will go away naturally when CLOS moves into cold init)
429 (defvar *print-object-is-disabled-p
*)
431 ;;; Output OBJECT to STREAM observing all printer control variables
432 ;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
433 ;;; then the pretty printer will be used for any components of OBJECT,
434 ;;; just not for OBJECT itself.
435 (defun output-ugly-object (object stream
)
437 ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
438 ;; PRINT-OBJECT says it provides printing and we're supposed to provide
439 ;; PRINT-OBJECT methods covering all classes. We deviate from this
440 ;; by using PRINT-OBJECT only when we print instance values. However,
441 ;; ANSI makes it hard to tell that we're deviating from this:
442 ;; (1) ANSI specifies that the user isn't supposed to call PRINT-OBJECT
444 ;; (2) ANSI (section 11.1.2.1.2) says it's undefined to define
445 ;; a method on an external symbol in the CL package which is
446 ;; applicable to arg lists containing only direct instances of
447 ;; standardized classes.
448 ;; Thus, in order for the user to detect our sleaziness in conforming
449 ;; code, he has to do something relatively obscure like
450 ;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
452 ;; (2) define a PRINT-OBJECT method which is specialized on the stream
453 ;; value (e.g. a Gray stream object).
454 ;; As long as no one comes up with a non-obscure way of detecting this
455 ;; sleaziness, fixing this nonconformity will probably have a low
456 ;; priority. -- WHN 2001-11-25
458 (output-integer object stream
))
461 (output-symbol object stream
)
462 (output-list object stream
)))
464 (cond ((not (and (boundp '*print-object-is-disabled-p
*)
465 *print-object-is-disabled-p
*))
466 (print-object object stream
))
467 ((typep object
'structure-object
)
468 (default-structure-print object stream
*current-level-in-print
*))
470 (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream
))))
472 (unless (and (funcallable-instance-p object
)
473 (printed-as-funcallable-standard-class object stream
))
474 (output-fun object stream
)))
476 (output-symbol object stream
))
480 (output-integer object stream
))
482 (output-float object stream
))
484 (output-ratio object stream
))
486 (output-ratio object stream
))
488 (output-complex object stream
))))
490 (output-character object stream
))
492 (output-vector object stream
))
494 (output-array object stream
))
496 (output-sap object stream
))
498 (output-weak-pointer object stream
))
500 (output-lra object stream
))
502 (output-code-component object stream
))
504 (output-fdefn object stream
))
506 (output-random object stream
))))
510 ;;; values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last
511 ;;; time the printer was called
512 (defvar *previous-case
* nil
)
513 (defvar *previous-readtable-case
* nil
)
515 ;;; This variable contains the current definition of one of three
516 ;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
517 (defvar *internal-symbol-output-fun
* nil
)
519 ;;; This function sets the internal global symbol
520 ;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
521 ;;; the value of *PRINT-CASE*. See the manual for details. The print
522 ;;; buffer stream is also reset.
523 (defun setup-printer-state ()
524 (unless (and (eq *print-case
* *previous-case
*)
525 (eq (readtable-case *readtable
*) *previous-readtable-case
*))
526 (setq *previous-case
* *print-case
*)
527 (setq *previous-readtable-case
* (readtable-case *readtable
*))
528 (unless (member *print-case
* '(:upcase
:downcase
:capitalize
))
529 (setq *print-case
* :upcase
)
530 (error "invalid *PRINT-CASE* value: ~S" *previous-case
*))
531 (unless (member *previous-readtable-case
*
532 '(:upcase
:downcase
:invert
:preserve
))
533 (setf (readtable-case *readtable
*) :upcase
)
534 (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case
*))
536 (setq *internal-symbol-output-fun
*
537 (case *previous-readtable-case
*
540 (:upcase
#'output-preserve-symbol
)
541 (:downcase
#'output-lowercase-symbol
)
542 (:capitalize
#'output-capitalize-symbol
)))
545 (:upcase
#'output-uppercase-symbol
)
546 (:downcase
#'output-preserve-symbol
)
547 (:capitalize
#'output-capitalize-symbol
)))
548 (:preserve
#'output-preserve-symbol
)
549 (:invert
#'output-invert-symbol
)))))
551 ;;; Output PNAME (a symbol-name or package-name) surrounded with |'s,
552 ;;; and with any embedded |'s or \'s escaped.
553 (defun output-quoted-symbol-name (pname stream
)
554 (write-char #\| stream
)
555 (dotimes (index (length pname
))
556 (let ((char (schar pname index
)))
557 (when (or (char= char
#\\) (char= char
#\|
))
558 (write-char #\\ stream
))
559 (write-char char stream
)))
560 (write-char #\| stream
))
562 (defun output-symbol (object stream
)
563 (if (or *print-escape
* *print-readably
*)
564 (let ((package (symbol-package object
))
565 (name (symbol-name object
)))
567 ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
568 ;; requires that keywords be printed with preceding colons
569 ;; always, regardless of the value of *PACKAGE*.
570 ((eq package
*keyword-package
*)
571 (write-char #\
: stream
))
572 ;; Otherwise, if the symbol's home package is the current
573 ;; one, then a prefix is never necessary.
574 ((eq package
(sane-package)))
575 ;; Uninterned symbols print with a leading #:.
577 (when (or *print-gensym
* *print-readably
*)
578 (write-string "#:" stream
)))
580 (multiple-value-bind (symbol accessible
)
581 (find-symbol name
(sane-package))
582 ;; If we can find the symbol by looking it up, it need not
583 ;; be qualified. This can happen if the symbol has been
584 ;; inherited from a package other than its home package.
585 (unless (and accessible
(eq symbol object
))
586 (output-symbol-name (package-name package
) stream
)
587 (multiple-value-bind (symbol externalp
)
588 (find-external-symbol name package
)
589 (declare (ignore symbol
))
591 (write-char #\
: stream
)
592 (write-string "::" stream
)))))))
593 (output-symbol-name name stream
))
594 (output-symbol-name (symbol-name object
) stream nil
)))
596 ;;; Output the string NAME as if it were a symbol name. In other
597 ;;; words, diddle its case according to *PRINT-CASE* and
599 (defun output-symbol-name (name stream
&optional
(maybe-quote t
))
600 (declare (type simple-string name
))
601 (let ((*readtable
* (if *print-readably
* *standard-readtable
* *readtable
*)))
602 (setup-printer-state)
603 (if (and maybe-quote
(symbol-quotep name
))
604 (output-quoted-symbol-name name stream
)
605 (funcall *internal-symbol-output-fun
* name stream
))))
607 ;;;; escaping symbols
609 ;;; When we print symbols we have to figure out if they need to be
610 ;;; printed with escape characters. This isn't a whole lot easier than
611 ;;; reading symbols in the first place.
613 ;;; For each character, the value of the corresponding element is a
614 ;;; fixnum with bits set corresponding to attributes that the
615 ;;; character has. At characters have at least one bit set, so we can
616 ;;; search for any character with a positive test.
617 (defvar *character-attributes
*
618 (make-array char-code-limit
619 :element-type
'(unsigned-byte 16)
621 (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit
))
622 *character-attributes
*))
624 ;;; constants which are a bit-mask for each interesting character attribute
625 (defconstant other-attribute
(ash 1 0)) ; Anything else legal.
626 (defconstant number-attribute
(ash 1 1)) ; A numeric digit.
627 (defconstant uppercase-attribute
(ash 1 2)) ; An uppercase letter.
628 (defconstant lowercase-attribute
(ash 1 3)) ; A lowercase letter.
629 (defconstant sign-attribute
(ash 1 4)) ; +-
630 (defconstant extension-attribute
(ash 1 5)) ; ^_
631 (defconstant dot-attribute
(ash 1 6)) ; .
632 (defconstant slash-attribute
(ash 1 7)) ; /
633 (defconstant funny-attribute
(ash 1 8)) ; Anything illegal.
635 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
637 ;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
638 ;;; that don't need to be escaped (according to READTABLE-CASE.)
639 (defparameter *attribute-names
*
640 `((number . number-attribute
) (lowercase . lowercase-attribute
)
641 (uppercase . uppercase-attribute
) (letter . letter-attribute
)
642 (sign . sign-attribute
) (extension . extension-attribute
)
643 (dot . dot-attribute
) (slash . slash-attribute
)
644 (other . other-attribute
) (funny . funny-attribute
)))
648 (flet ((set-bit (char bit
)
649 (let ((code (char-code char
)))
650 (setf (aref *character-attributes
* code
)
651 (logior bit
(aref *character-attributes
* code
))))))
653 (dolist (char '(#\
! #\
@ #\$
#\%
#\
& #\
* #\
= #\~
#\
[ #\
] #\
{ #\
}
655 (set-bit char other-attribute
))
658 (set-bit (digit-char i
) number-attribute
))
660 (do ((code (char-code #\A
) (1+ code
))
661 (end (char-code #\Z
)))
663 (declare (fixnum code end
))
664 (set-bit (code-char code
) uppercase-attribute
)
665 (set-bit (char-downcase (code-char code
)) lowercase-attribute
))
667 (set-bit #\- sign-attribute
)
668 (set-bit #\
+ sign-attribute
)
669 (set-bit #\^ extension-attribute
)
670 (set-bit #\_ extension-attribute
)
671 (set-bit #\. dot-attribute
)
672 (set-bit #\
/ slash-attribute
)
674 ;; Mark anything not explicitly allowed as funny.
675 (dotimes (i char-code-limit
)
676 (when (zerop (aref *character-attributes
* i
))
677 (setf (aref *character-attributes
* i
) funny-attribute
))))
679 ;;; For each character, the value of the corresponding element is the
680 ;;; lowest base in which that character is a digit.
681 (defvar *digit-bases
*
682 (make-array char-code-limit
683 :element-type
'(unsigned-byte 8)
684 :initial-element
36))
685 (declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit
))
688 (let ((char (digit-char i
36)))
689 (setf (aref *digit-bases
* (char-code char
)) i
)))
691 ;;; A FSM-like thingie that determines whether a symbol is a potential
692 ;;; number or has evil characters in it.
693 (defun symbol-quotep (name)
694 (declare (simple-string name
))
695 (macrolet ((advance (tag &optional
(at-end t
))
698 ,(if at-end
'(go TEST-SIGN
) '(return nil
)))
699 (setq current
(schar name index
)
700 code
(char-code current
)
701 bits
(aref attributes code
))
704 (test (&rest attributes
)
716 `(< (the fixnum
(aref bases code
)) base
)))
718 (prog ((len (length name
))
719 (attributes *character-attributes
*)
720 (bases *digit-bases
*)
723 (case (readtable-case *readtable
*)
724 (:upcase uppercase-attribute
)
725 (:downcase lowercase-attribute
)
726 (t (logior lowercase-attribute uppercase-attribute
))))
731 (declare (fixnum len base index bits code
))
734 TEST-SIGN
; At end, see whether it is a sign...
735 (return (not (test sign
)))
737 OTHER
; not potential number, see whether funny chars...
738 (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
741 (do ((i (1- index
) (1+ i
)))
742 ((= i len
) (return-from symbol-quotep nil
))
743 (unless (zerop (logand (aref attributes
(char-code (schar name i
)))
745 (return-from symbol-quotep t
))))
750 (advance LAST-DIGIT-ALPHA
)
752 (when (test letter number other slash
) (advance OTHER nil
))
753 (when (char= current
#\.
) (advance DOT-FOUND
))
754 (when (test sign extension
) (advance START-STUFF nil
))
757 DOT-FOUND
; leading dots...
758 (when (test letter
) (advance START-DOT-MARKER nil
))
759 (when (digitp) (advance DOT-DIGIT
))
760 (when (test number other
) (advance OTHER nil
))
761 (when (test extension slash sign
) (advance START-DOT-STUFF nil
))
762 (when (char= current
#\.
) (advance DOT-FOUND
))
765 START-STUFF
; leading stuff before any dot or digit
768 (advance LAST-DIGIT-ALPHA
)
770 (when (test number other
) (advance OTHER nil
))
771 (when (test letter
) (advance START-MARKER nil
))
772 (when (char= current
#\.
) (advance START-DOT-STUFF nil
))
773 (when (test sign extension slash
) (advance START-STUFF nil
))
776 START-MARKER
; number marker in leading stuff...
777 (when (test letter
) (advance OTHER nil
))
780 START-DOT-STUFF
; leading stuff containing dot without digit...
781 (when (test letter
) (advance START-DOT-STUFF nil
))
782 (when (digitp) (advance DOT-DIGIT
))
783 (when (test sign extension dot slash
) (advance START-DOT-STUFF nil
))
784 (when (test number other
) (advance OTHER nil
))
787 START-DOT-MARKER
; number marker in leading stuff with dot..
788 ;; leading stuff containing dot without digit followed by letter...
789 (when (test letter
) (advance OTHER nil
))
792 DOT-DIGIT
; in a thing with dots...
793 (when (test letter
) (advance DOT-MARKER
))
794 (when (digitp) (advance DOT-DIGIT
))
795 (when (test number other
) (advance OTHER nil
))
796 (when (test sign extension dot slash
) (advance DOT-DIGIT
))
799 DOT-MARKER
; number marker in number with dot...
800 (when (test letter
) (advance OTHER nil
))
803 LAST-DIGIT-ALPHA
; previous char is a letter digit...
804 (when (or (digitp) (test sign slash
))
805 (advance ALPHA-DIGIT
))
806 (when (test letter number other dot
) (advance OTHER nil
))
809 ALPHA-DIGIT
; seen a digit which is a letter...
810 (when (or (digitp) (test sign slash
))
812 (advance LAST-DIGIT-ALPHA
)
813 (advance ALPHA-DIGIT
)))
814 (when (test letter
) (advance ALPHA-MARKER
))
815 (when (test number other dot
) (advance OTHER nil
))
818 ALPHA-MARKER
; number marker in number with alpha digit...
819 (when (test letter
) (advance OTHER nil
))
822 DIGIT
; seen only ordinary (non-alphabetic) numeric digits...
825 (advance ALPHA-DIGIT
)
827 (when (test number other
) (advance OTHER nil
))
828 (when (test letter
) (advance MARKER
))
829 (when (test extension slash sign
) (advance DIGIT
))
830 (when (char= current
#\.
) (advance DOT-DIGIT
))
833 MARKER
; number marker in a numeric number...
834 ;; ("What," you may ask, "is a 'number marker'?" It's something
835 ;; that a conforming implementation might use in number syntax.
836 ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".)
837 (when (test letter
) (advance OTHER nil
))
840 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
842 ;;;; case hackery: These functions are stored in
843 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
844 ;;;; *PRINT-CASE* and READTABLE-CASE.
847 ;;; READTABLE-CASE *PRINT-CASE*
849 ;;; :DOWNCASE :DOWNCASE
851 (defun output-preserve-symbol (pname stream
)
852 (declare (simple-string pname
))
853 (write-string pname stream
))
856 ;;; READTABLE-CASE *PRINT-CASE*
857 ;;; :UPCASE :DOWNCASE
858 (defun output-lowercase-symbol (pname stream
)
859 (declare (simple-string pname
))
860 (dotimes (index (length pname
))
861 (let ((char (schar pname index
)))
862 (write-char (char-downcase char
) stream
))))
865 ;;; READTABLE-CASE *PRINT-CASE*
866 ;;; :DOWNCASE :UPCASE
867 (defun output-uppercase-symbol (pname stream
)
868 (declare (simple-string pname
))
869 (dotimes (index (length pname
))
870 (let ((char (schar pname index
)))
871 (write-char (char-upcase char
) stream
))))
874 ;;; READTABLE-CASE *PRINT-CASE*
875 ;;; :UPCASE :CAPITALIZE
876 ;;; :DOWNCASE :CAPITALIZE
877 (defun output-capitalize-symbol (pname stream
)
878 (declare (simple-string pname
))
879 (let ((prev-not-alphanum t
)
880 (up (eq (readtable-case *readtable
*) :upcase
)))
881 (dotimes (i (length pname
))
882 (let ((char (char pname i
)))
884 (if (or prev-not-alphanum
(lower-case-p char
))
886 (char-downcase char
))
887 (if prev-not-alphanum
891 (setq prev-not-alphanum
(not (alphanumericp char
)))))))
894 ;;; READTABLE-CASE *PRINT-CASE*
896 (defun output-invert-symbol (pname stream
)
897 (declare (simple-string pname
))
900 (dotimes (i (length pname
))
901 (let ((ch (schar pname i
)))
902 (when (both-case-p ch
)
903 (if (upper-case-p ch
)
905 (setq all-upper nil
)))))
906 (cond (all-upper (output-lowercase-symbol pname stream
))
907 (all-lower (output-uppercase-symbol pname stream
))
909 (write-string pname stream
)))))
913 (let ((*readtable
* (copy-readtable nil
)))
914 (format t
"READTABLE-CASE Input Symbol-name~@
915 ----------------------------------~%")
916 (dolist (readtable-case '(:upcase
:downcase
:preserve
:invert
))
917 (setf (readtable-case *readtable
*) readtable-case
)
918 (dolist (input '("ZEBRA" "Zebra" "zebra"))
919 (format t
"~&:~A~16T~A~24T~A"
920 (string-upcase readtable-case
)
922 (symbol-name (read-from-string input
)))))))
925 (let ((*readtable
* (copy-readtable nil
)))
926 (format t
"READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@
927 --------------------------------------------------------~%")
928 (dolist (readtable-case '(:upcase
:downcase
:preserve
:invert
))
929 (setf (readtable-case *readtable
*) readtable-case
)
930 (dolist (*print-case
* '(:upcase
:downcase
:capitalize
))
931 (dolist (symbol '(|ZEBRA| |Zebra| |zebra|
))
932 (format t
"~&:~A~15T:~A~29T~A~42T~A~50T~A"
933 (string-upcase readtable-case
)
934 (string-upcase *print-case
*)
936 (prin1-to-string symbol
)
937 (princ-to-string symbol
)))))))
940 ;;;; recursive objects
942 (defun output-list (list stream
)
943 (descend-into (stream)
944 (write-char #\
( stream
)
948 (punt-print-if-too-long length stream
)
949 (output-object (pop list
) stream
)
952 (when (or (atom list
)
953 (check-for-circularity list
))
954 (write-string " . " stream
)
955 (output-object list stream
)
957 (write-char #\space stream
)
959 (write-char #\
) stream
)))
961 (defun output-vector (vector stream
)
962 (declare (vector vector
))
963 (cond ((stringp vector
)
964 (cond ((or *print-escape
* *print-readably
*)
965 (write-char #\" stream
)
966 (quote-string vector stream
)
967 (write-char #\" stream
))
969 (write-string vector stream
))))
970 ((not (or *print-array
* *print-readably
*))
971 (output-terse-array vector stream
))
972 ((bit-vector-p vector
)
973 (write-string "#*" stream
)
974 (dovector (bit vector
)
975 ;; (Don't use OUTPUT-OBJECT here, since this code
976 ;; has to work for all possible *PRINT-BASE* values.)
977 (write-char (if (zerop bit
) #\
0 #\
1) stream
)))
979 (when (and *print-readably
*
980 (not (array-readably-printable-p vector
)))
981 (error 'print-not-readable
:object vector
))
982 (descend-into (stream)
983 (write-string "#(" stream
)
984 (dotimes (i (length vector
))
986 (write-char #\space stream
))
987 (punt-print-if-too-long i stream
)
988 (output-object (aref vector i
) stream
))
989 (write-string ")" stream
)))))
991 ;;; This function outputs a string quoting characters sufficiently
992 ;;; so that someone can read it in again. Basically, put a slash in
993 ;;; front of an character satisfying NEEDS-SLASH-P.
994 (defun quote-string (string stream
)
995 (macrolet ((needs-slash-p (char)
996 ;; KLUDGE: We probably should look at the readtable, but just do
997 ;; this for now. [noted by anonymous long ago] -- WHN 19991130
998 `(or (char= ,char
#\\)
1000 (with-array-data ((data string
) (start) (end (length string
)))
1001 (do ((index start
(1+ index
)))
1003 (let ((char (schar data index
)))
1004 (when (needs-slash-p char
) (write-char #\\ stream
))
1005 (write-char char stream
))))))
1007 (defun array-readably-printable-p (array)
1008 (and (eq (array-element-type array
) t
)
1009 (let ((zero (position 0 (array-dimensions array
)))
1010 (number (position 0 (array-dimensions array
)
1011 :test
(complement #'eql
)
1013 (or (null zero
) (null number
) (> zero number
)))))
1015 ;;; Output the printed representation of any array in either the #< or #A
1017 (defun output-array (array stream
)
1018 (if (or *print-array
* *print-readably
*)
1019 (output-array-guts array stream
)
1020 (output-terse-array array stream
)))
1022 ;;; Output the abbreviated #< form of an array.
1023 (defun output-terse-array (array stream
)
1024 (let ((*print-level
* nil
)
1025 (*print-length
* nil
))
1026 (print-unreadable-object (array stream
:type t
:identity t
))))
1028 ;;; Output the readable #A form of an array.
1029 (defun output-array-guts (array stream
)
1030 (when (and *print-readably
*
1031 (not (array-readably-printable-p array
)))
1032 (error 'print-not-readable
:object array
))
1033 (write-char #\
# stream
)
1034 (let ((*print-base
* 10))
1035 (output-integer (array-rank array
) stream
))
1036 (write-char #\A stream
)
1037 (with-array-data ((data array
) (start) (end))
1038 (declare (ignore end
))
1039 (sub-output-array-guts data
(array-dimensions array
) stream start
)))
1041 (defun sub-output-array-guts (array dimensions stream index
)
1042 (declare (type (simple-array * (*)) array
) (fixnum index
))
1043 (cond ((null dimensions
)
1044 (output-object (aref array index
) stream
))
1046 (descend-into (stream)
1047 (write-char #\
( stream
)
1048 (let* ((dimension (car dimensions
))
1049 (dimensions (cdr dimensions
))
1050 (count (reduce #'* dimensions
)))
1051 (dotimes (i dimension
)
1053 (write-char #\space stream
))
1054 (punt-print-if-too-long i stream
)
1055 (sub-output-array-guts array dimensions stream index
)
1056 (incf index count
)))
1057 (write-char #\
) stream
)))))
1059 ;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
1060 ;;; use until CLOS is set up (at which time it will be replaced with
1061 ;;; the real generic function implementation)
1062 (defun print-object (instance stream
)
1063 (default-structure-print instance stream
*current-level-in-print
*))
1065 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
1067 (defun output-integer (integer stream
)
1068 ;; FIXME: This UNLESS form should be pulled out into something like
1069 ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
1070 ;; *PACKAGE* variable.
1071 (unless (and (fixnump *print-base
*)
1072 (< 1 *print-base
* 37))
1073 (let ((obase *print-base
*))
1074 (setq *print-base
* 10.
)
1075 (error "~A is not a reasonable value for *PRINT-BASE*." obase
)))
1076 (when (and (not (= *print-base
* 10.
))
1078 ;; First print leading base information, if any.
1079 (write-char #\
# stream
)
1080 (write-char (case *print-base
*
1084 (T (let ((fixbase *print-base
*)
1087 (sub-output-integer fixbase stream
))
1090 ;; Then output a minus sign if the number is negative, then output
1091 ;; the absolute value of the number.
1092 (cond ((bignump integer
) (print-bignum integer stream
))
1094 (write-char #\- stream
)
1095 (sub-output-integer (- integer
) stream
))
1097 (sub-output-integer integer stream
)))
1098 ;; Print any trailing base information, if any.
1099 (if (and (= *print-base
* 10.
) *print-radix
*)
1100 (write-char #\. stream
)))
1102 (defun sub-output-integer (integer stream
)
1105 ;; Recurse until you have all the digits pushed on the stack.
1106 (if (not (zerop (multiple-value-setq (quotient remainder
)
1107 (truncate integer
*print-base
*))))
1108 (sub-output-integer quotient stream
))
1109 ;; Then as each recursive call unwinds, turn the digit (in remainder)
1110 ;; into a character and output the character.
1111 (write-char (code-char (if (and (> remainder
9.
)
1112 (> *print-base
* 10.
))
1113 (+ (char-code #\A
) (- remainder
10.
))
1114 (+ (char-code #\
0) remainder
)))
1117 ;;;; bignum printing
1119 ;;; *BASE-POWER* holds the number that we keep dividing into the
1120 ;;; bignum for each *print-base*. We want this number as close to
1121 ;;; *most-positive-fixnum* as possible, i.e. (floor (log
1122 ;;; most-positive-fixnum *print-base*)).
1123 (defparameter *base-power
* (make-array 37 :initial-element nil
))
1125 ;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
1126 ;;; that fit in the corresponding *base-power*.
1127 (defparameter *fixnum-power--1
* (make-array 37 :initial-element nil
))
1129 ;;; Print the bignum to the stream. We first generate the correct
1130 ;;; value for *base-power* and *fixnum-power--1* if we have not
1131 ;;; already. Then we call bignum-print-aux to do the printing.
1132 (defun print-bignum (big stream
)
1133 (unless (aref *base-power
* *print-base
*)
1134 (do ((power-1 -
1 (1+ power-1
))
1135 (new-divisor *print-base
* (* new-divisor
*print-base
*))
1136 (divisor 1 new-divisor
))
1137 ((not (fixnump new-divisor
))
1138 (setf (aref *base-power
* *print-base
*) divisor
)
1139 (setf (aref *fixnum-power--1
* *print-base
*) power-1
))))
1140 (bignum-print-aux (cond ((minusp big
)
1141 (write-char #\- stream
)
1144 (aref *base-power
* *print-base
*)
1145 (aref *fixnum-power--1
* *print-base
*)
1149 (defun bignum-print-aux (big divisor power-1 stream
)
1150 (multiple-value-bind (newbig fix
) (truncate big divisor
)
1151 (if (fixnump newbig
)
1152 (sub-output-integer newbig stream
)
1153 (bignum-print-aux newbig divisor power-1 stream
))
1154 (do ((zeros power-1
(1- zeros
))
1155 (base-power *print-base
* (* base-power
*print-base
*)))
1157 (dotimes (i zeros
) (write-char #\
0 stream
))
1158 (sub-output-integer fix stream
)))))
1160 (defun output-ratio (ratio stream
)
1162 (write-char #\
# stream
)
1164 (2 (write-char #\b stream
))
1165 (8 (write-char #\o stream
))
1166 (16 (write-char #\x stream
))
1167 (t (write *print-base
* :stream stream
:radix nil
:base
10)
1168 (write-char #\r stream
))))
1169 (let ((*print-radix
* nil
))
1170 (output-integer (numerator ratio
) stream
)
1171 (write-char #\
/ stream
)
1172 (output-integer (denominator ratio
) stream
)))
1174 (defun output-complex (complex stream
)
1175 (write-string "#C(" stream
)
1176 (output-object (realpart complex
) stream
)
1177 (write-char #\space stream
)
1178 (output-object (imagpart complex
) stream
)
1179 (write-char #\
) stream
))
1183 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
1184 ;;; most of the work for all printing of floating point numbers in the
1185 ;;; printer and in FORMAT. It converts a floating point number to a
1186 ;;; string in a free or fixed format with no exponent. The
1187 ;;; interpretation of the arguments is as follows:
1189 ;;; X - The floating point number to convert, which must not be
1191 ;;; WIDTH - The preferred field width, used to determine the number
1192 ;;; of fraction digits to produce if the FDIGITS parameter
1193 ;;; is unspecified or NIL. If the non-fraction digits and the
1194 ;;; decimal point alone exceed this width, no fraction digits
1195 ;;; will be produced unless a non-NIL value of FDIGITS has been
1196 ;;; specified. Field overflow is not considerd an error at this
1198 ;;; FDIGITS - The number of fractional digits to produce. Insignificant
1199 ;;; trailing zeroes may be introduced as needed. May be
1200 ;;; unspecified or NIL, in which case as many digits as possible
1201 ;;; are generated, subject to the constraint that there are no
1202 ;;; trailing zeroes.
1203 ;;; SCALE - If this parameter is specified or non-NIL, then the number
1204 ;;; printed is (* x (expt 10 scale)). This scaling is exact,
1205 ;;; and cannot lose precision.
1206 ;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1207 ;;; number of fraction digits which will be produced, regardless
1208 ;;; of the value of WIDTH or FDIGITS. This feature is used by
1209 ;;; the ~E format directive to prevent complete loss of
1210 ;;; significance in the printed value due to a bogus choice of
1213 ;;; Most of the optional arguments are for the benefit for FORMAT and are not
1214 ;;; used by the printer.
1217 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1218 ;;; where the results have the following interpretation:
1220 ;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1221 ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1222 ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1224 ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1226 ;;; POINT-POS - The position of the digit preceding the decimal
1227 ;;; point. Zero indicates point before first digit.
1229 ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
1230 ;;; accuracy. Specifically, the decimal number printed is the closest
1231 ;;; possible approximation to the true value of the binary number to
1232 ;;; be printed from among all decimal representations with the same
1233 ;;; number of digits. In free-format output, i.e. with the number of
1234 ;;; digits unconstrained, it is guaranteed that all the information is
1235 ;;; preserved, so that a properly- rounding reader can reconstruct the
1236 ;;; original binary number, bit-for-bit, from its printed decimal
1237 ;;; representation. Furthermore, only as many digits as necessary to
1238 ;;; satisfy this condition will be printed.
1240 ;;; FLOAT-STRING actually generates the digits for positive numbers.
1241 ;;; The algorithm is essentially that of algorithm Dragon4 in "How to
1242 ;;; Print Floating-Point Numbers Accurately" by Steele and White. The
1243 ;;; current (draft) version of this paper may be found in
1244 ;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
1245 ;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
1247 (defvar *digits
* "0123456789")
1249 (defun flonum-to-string (x &optional width fdigits scale fmin
)
1251 ;; Zero is a special case which FLOAT-STRING cannot handle.
1253 (let ((s (make-string (1+ fdigits
) :initial-element
#\
0)))
1254 (setf (schar s
0) #\.
)
1255 (values s
(length s
) t
(zerop fdigits
) 0))
1256 (values "." 1 t t
0)))
1258 (multiple-value-bind (sig exp
) (integer-decode-float x
)
1259 (let* ((precision (float-precision x
))
1260 (digits (float-digits x
))
1261 (fudge (- digits precision
))
1262 (width (if width
(max width
1) nil
)))
1263 (float-string (ash sig
(- fudge
)) (+ exp fudge
) precision width
1264 fdigits scale fmin
))))))
1266 (defun float-string (fraction exponent precision width fdigits scale fmin
)
1267 (let ((r fraction
) (s 1) (m- 1) (m+ 1) (k 0)
1268 (digits 0) (decpnt 0) (cutoff nil
) (roundup nil
) u low high
1269 (digit-string (make-array 50
1270 :element-type
'base-char
1273 ;; Represent fraction as r/s, error bounds as m+/s and m-/s.
1274 ;; Rational arithmetic avoids loss of precision in subsequent
1276 (cond ((> exponent
0)
1277 (setq r
(ash fraction exponent
))
1278 (setq m-
(ash 1 exponent
))
1281 (setq s
(ash 1 (- exponent
)))))
1282 ;; Adjust the error bounds m+ and m- for unequal gaps.
1283 (when (= fraction
(ash 1 precision
))
1284 (setq m
+ (ash m
+ 1))
1287 ;; Scale value by requested amount, and update error bounds.
1290 (let ((scale-factor (expt 10 (- scale
))))
1291 (setq s
(* s scale-factor
)))
1292 (let ((scale-factor (expt 10 scale
)))
1293 (setq r
(* r scale-factor
))
1294 (setq m
+ (* m
+ scale-factor
))
1295 (setq m-
(* m- scale-factor
)))))
1296 ;; Scale r and s and compute initial k, the base 10 logarithm of r.
1298 ((>= r
(ceiling s
10)))
1302 (setq m
+ (* m
+ 10)))
1305 ((< (+ (ash r
1) m
+) (ash s
1)))
1308 ;; Determine number of fraction digits to generate.
1310 ;; Use specified number of fraction digits.
1311 (setq cutoff
(- fdigits
))
1312 ;;don't allow less than fmin fraction digits
1313 (if (and fmin
(> cutoff
(- fmin
))) (setq cutoff
(- fmin
))))
1315 ;; Use as many fraction digits as width will permit but
1316 ;; force at least fmin digits even if width will be
1319 (setq cutoff
(- 1 width
))
1320 (setq cutoff
(1+ (- k width
))))
1321 (if (and fmin
(> cutoff
(- fmin
))) (setq cutoff
(- fmin
)))))
1322 ;; If we decided to cut off digit generation before precision
1323 ;; has been exhausted, rounding the last digit may cause a carry
1324 ;; propagation. We can prevent this, preserving left-to-right
1325 ;; digit generation, with a few magical adjustments to m- and
1326 ;; m+. Of course, correct rounding is also preserved.
1327 (when (or fdigits width
)
1328 (let ((a (- cutoff k
))
1331 (dotimes (i a
) (setq y
(* y
10)))
1332 (dotimes (i (- a
)) (setq y
(ceiling y
10))))
1333 (setq m-
(max y m-
))
1334 (setq m
+ (max y m
+))
1335 (when (= m
+ y
) (setq roundup t
))))
1336 (when (< (+ (ash r
1) m
+) (ash s
1)) (return)))
1337 ;; Zero-fill before fraction if no integer part.
1339 (setq decpnt digits
)
1340 (vector-push-extend #\. digit-string
)
1342 (incf digits
) (vector-push-extend #\
0 digit-string
)))
1343 ;; Generate the significant digits.
1347 (vector-push-extend #\. digit-string
)
1348 (setq decpnt digits
))
1349 (multiple-value-setq (u r
) (truncate (* r
10) s
))
1352 (setq low
(< (ash r
1) m-
))
1354 (setq high
(>= (ash r
1) (- (ash s
1) m
+)))
1355 (setq high
(> (ash r
1) (- (ash s
1) m
+))))
1356 ;; Stop when either precision is exhausted or we have printed as
1357 ;; many fraction digits as permitted.
1358 (when (or low high
(and cutoff
(<= k cutoff
))) (return))
1359 (vector-push-extend (char *digits
* u
) digit-string
)
1361 ;; If cutoff occurred before first digit, then no digits are
1362 ;; generated at all.
1363 (when (or (not cutoff
) (>= k cutoff
))
1364 ;; Last digit may need rounding
1365 (vector-push-extend (char *digits
*
1366 (cond ((and low
(not high
)) u
)
1367 ((and high
(not low
)) (1+ u
))
1368 (t (if (<= (ash r
1) s
) u
(1+ u
)))))
1371 ;; Zero-fill after integer part if no fraction.
1373 (dotimes (i k
) (incf digits
) (vector-push-extend #\
0 digit-string
))
1374 (vector-push-extend #\. digit-string
)
1375 (setq decpnt digits
))
1376 ;; Add trailing zeroes to pad fraction if fdigits specified.
1378 (dotimes (i (- fdigits
(- digits decpnt
)))
1380 (vector-push-extend #\
0 digit-string
)))
1382 (values digit-string
(1+ digits
) (= decpnt
0) (= decpnt digits
) decpnt
)))
1384 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
1385 ;;; a new floating point number Z in the range (0.1, 1.0] and an
1386 ;;; exponent E such that Z * 10^E is (approximately) equal to the
1387 ;;; original number. There may be some loss of precision due the
1388 ;;; floating point representation. The scaling is always done with
1389 ;;; long float arithmetic, which helps printing of lesser precisions
1390 ;;; as well as avoiding generic arithmetic.
1392 ;;; When computing our initial scale factor using EXPT, we pull out
1393 ;;; part of the computation to avoid over/under flow. When
1394 ;;; denormalized, we must pull out a large factor, since there is more
1395 ;;; negative exponent range than positive range.
1397 (eval-when (:compile-toplevel
:execute
)
1398 (setf *read-default-float-format
*
1399 #!+long-float
'long-float
#!-long-float
'double-float
))
1400 (defun scale-exponent (original-x)
1401 (let* ((x (coerce original-x
'long-float
)))
1402 (multiple-value-bind (sig exponent
) (decode-float x
)
1403 (declare (ignore sig
))
1405 (values (float 0.0e0 original-x
) 1)
1406 (let* ((ex (locally (declare (optimize (safety 0)))
1408 (round (* exponent
(log 2e0
10))))))
1410 (if (float-denormalized-p x
)
1412 (* x
1.0e16
(expt 10.0e0
(- (- ex
) 16)))
1414 (* x
1.0e18
(expt 10.0e0
(- (- ex
) 18)))
1415 (* x
10.0e0
(expt 10.0e0
(- (- ex
) 1))))
1416 (/ x
10.0e0
(expt 10.0e0
(1- ex
))))))
1417 (do ((d 10.0e0
(* d
10.0e0
))
1421 (do ((m 10.0e0
(* m
10.0e0
))
1425 (values (float z original-x
) ex
))
1426 (declare (long-float m
) (integer ex
))))
1427 (declare (long-float d
))))))))
1428 (eval-when (:compile-toplevel
:execute
)
1429 (setf *read-default-float-format
* 'single-float
))
1431 ;;;; entry point for the float printer
1433 ;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
1434 ;;; argument is printed free-format, in either exponential or
1435 ;;; non-exponential notation, depending on its magnitude.
1437 ;;; NOTE: When a number is to be printed in exponential format, it is
1438 ;;; scaled in floating point. Since precision may be lost in this
1439 ;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
1440 ;;; are lost. The difficulty is that FLONUM-TO-STRING performs
1441 ;;; extensive computations with integers of similar magnitude to that
1442 ;;; of the number being printed. For large exponents, the bignums
1443 ;;; really get out of hand. If bignum arithmetic becomes reasonably
1444 ;;; fast and the exponent range is not too large, then it might become
1445 ;;; attractive to handle exponential notation with the same accuracy
1446 ;;; as non-exponential notation, using the method described in the
1447 ;;; Steele and White paper.
1449 ;;; Print the appropriate exponent marker for X and the specified exponent.
1450 (defun print-float-exponent (x exp stream
)
1451 (declare (type float x
) (type integer exp
) (type stream stream
))
1452 (let ((*print-radix
* nil
)
1453 (plusp (plusp exp
)))
1454 (if (typep x
*read-default-float-format
*)
1456 (format stream
"e~:[~;+~]~D" plusp exp
))
1457 (format stream
"~C~:[~;+~]~D"
1465 (defun output-float-infinity (x stream
)
1466 (declare (float x
) (stream stream
))
1468 (write-string "#." stream
))
1470 (error 'print-not-readable
:object x
))
1472 (write-string "#<" stream
)))
1473 (write-string "SB-EXT:" stream
)
1474 (write-string (symbol-name (float-format-name x
)) stream
)
1475 (write-string (if (plusp x
) "-POSITIVE-" "-NEGATIVE-")
1477 (write-string "INFINITY" stream
)
1479 (write-string ">" stream
)))
1481 (defun output-float-nan (x stream
)
1482 (print-unreadable-object (x stream
)
1483 (princ (float-format-name x
) stream
)
1484 (write-string (if (float-trapping-nan-p x
) " trapping" " quiet") stream
)
1485 (write-string " NaN" stream
)))
1487 ;;; the function called by OUTPUT-OBJECT to handle floats
1488 (defun output-float (x stream
)
1490 ((float-infinity-p x
)
1491 (output-float-infinity x stream
))
1493 (output-float-nan x stream
))
1495 (let ((x (cond ((minusp (float-sign x
))
1496 (write-char #\- stream
)
1502 (write-string "0.0" stream
)
1503 (print-float-exponent x
0 stream
))
1505 (output-float-aux x stream
(float 1/1000 x
) (float 10000000 x
))))))))
1506 (defun output-float-aux (x stream e-min e-max
)
1507 (if (and (>= x e-min
) (< x e-max
))
1509 (multiple-value-bind (str len lpoint tpoint
) (flonum-to-string x
)
1510 (declare (ignore len
))
1511 (when lpoint
(write-char #\
0 stream
))
1512 (write-string str stream
)
1513 (when tpoint
(write-char #\
0 stream
))
1514 (print-float-exponent x
0 stream
))
1515 ;; exponential format
1516 (multiple-value-bind (f ex
) (scale-exponent x
)
1517 (multiple-value-bind (str len lpoint tpoint
)
1518 (flonum-to-string f nil nil
1)
1519 (declare (ignore len
))
1520 (when lpoint
(write-char #\
0 stream
))
1521 (write-string str stream
)
1522 (when tpoint
(write-char #\
0 stream
))
1523 ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
1524 (print-float-exponent x
(1- ex
) stream
)))))
1526 ;;;; other leaf objects
1528 ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
1529 ;;; the character name or the character in the #\char format.
1530 (defun output-character (char stream
)
1531 (if (or *print-escape
* *print-readably
*)
1532 (let ((graphicp (graphic-char-p char
))
1533 (name (char-name char
)))
1534 (write-string "#\\" stream
)
1535 (if (and name
(not graphicp
))
1536 (quote-string name stream
)
1537 (write-char char stream
)))
1538 (write-char char stream
)))
1540 (defun output-sap (sap stream
)
1541 (declare (type system-area-pointer sap
))
1543 (format stream
"#.(~S #X~8,'0X)" 'int-sap
(sap-int sap
)))
1545 (print-unreadable-object (sap stream
)
1546 (format stream
"system area pointer: #X~8,'0X" (sap-int sap
))))))
1548 (defun output-weak-pointer (weak-pointer stream
)
1549 (declare (type weak-pointer weak-pointer
))
1550 (print-unreadable-object (weak-pointer stream
)
1551 (multiple-value-bind (value validp
) (weak-pointer-value weak-pointer
)
1553 (write-string "weak pointer: " stream
)
1554 (write value
:stream stream
))
1556 (write-string "broken weak pointer" stream
))))))
1558 (defun output-code-component (component stream
)
1559 (print-unreadable-object (component stream
:identity t
)
1560 (let ((dinfo (%code-debug-info component
)))
1561 (cond ((eq dinfo
:bogus-lra
)
1562 (write-string "bogus code object" stream
))
1564 (write-string "code object" stream
)
1566 (write-char #\space stream
)
1567 (output-object (sb!c
::debug-info-name dinfo
) stream
)))))))
1569 (defun output-lra (lra stream
)
1570 (print-unreadable-object (lra stream
:identity t
)
1571 (write-string "return PC object" stream
)))
1573 (defun output-fdefn (fdefn stream
)
1574 (print-unreadable-object (fdefn stream
)
1575 (write-string "FDEFINITION object for " stream
)
1576 (output-object (fdefn-name fdefn
) stream
)))
1580 ;;; Output OBJECT as using PRINT-OBJECT if it's a
1581 ;;; FUNCALLABLE-STANDARD-CLASS, or return NIL otherwise.
1583 ;;; The definition here is a simple temporary placeholder. It will be
1584 ;;; overwritten by a smarter version (capable of calling generic
1585 ;;; PRINT-OBJECT when appropriate) when CLOS is installed.
1586 (defun printed-as-clos-funcallable-standard-class (object stream
)
1587 (declare (ignore object stream
))
1590 (defun output-fun (object stream
)
1591 (let* ((*print-length
* 3) ; in case we have to..
1592 (*print-level
* 3) ; ..print an interpreted function definition
1593 ;; FIXME: This find-the-function-name idiom ought to be
1594 ;; encapsulated in a function somewhere.
1595 (name (case (fun-subtype object
)
1596 (#.sb
!vm
:closure-header-widetag
"CLOSURE")
1597 (#.sb
!vm
:simple-fun-header-widetag
(%simple-fun-name object
))
1598 (t 'no-name-available
)))
1599 (identified-by-name-p (and (symbolp name
)
1601 (eq (fdefinition name
) object
))))
1602 (print-unreadable-object (object
1604 :identity
(not identified-by-name-p
))
1605 (prin1 'function stream
)
1606 (unless (eq name
'no-name-available
)
1607 (format stream
" ~S" name
)))))
1609 ;;;; catch-all for unknown things
1611 (defun output-random (object stream
)
1612 (print-unreadable-object (object stream
:identity t
)
1613 (let ((lowtag (lowtag-of object
)))
1615 (#.sb
!vm
:other-pointer-lowtag
1616 (let ((widetag (widetag-of object
)))
1618 (#.sb
!vm
:value-cell-header-widetag
1619 (write-string "value cell " stream
)
1620 (output-object (value-cell-ref object
) stream
))
1622 (write-string "unknown pointer object, widetag=" stream
)
1623 (let ((*print-base
* 16) (*print-radix
* t
))
1624 (output-integer widetag stream
))))))
1625 ((#.sb
!vm
:fun-pointer-lowtag
1626 #.sb
!vm
:instance-pointer-lowtag
1627 #.sb
!vm
:list-pointer-lowtag
)
1628 (write-string "unknown pointer object, lowtag=" stream
)
1629 (let ((*print-base
* 16) (*print-radix
* t
))
1630 (output-integer lowtag stream
)))
1632 (case (widetag-of object
)
1633 (#.sb
!vm
:unbound-marker-widetag
1634 (write-string "unbound marker" stream
))
1636 (write-string "unknown immediate object, lowtag=" stream
)
1637 (let ((*print-base
* 2) (*print-radix
* t
))
1638 (output-integer lowtag stream
))
1639 (write-string ", widetag=" stream
)
1640 (let ((*print-base
* 16) (*print-radix
* t
))
1641 (output-integer (widetag-of object
) stream
)))))))))