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
* nil
71 "the pprint-dispatch-table that controls how to pretty-print objects")
73 (defmacro with-standard-io-syntax
(&body body
)
75 "Bind the reader and printer control variables to values that enable READ
76 to reliably read the results of PRINT. These values are:
77 *PACKAGE* the COMMON-LISP-USER package
87 *PRINT-MISER-WIDTH* NIL
91 *PRINT-RIGHT-MARGIN* NIL
93 *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
96 *READTABLE* the standard readtable"
97 `(%with-standard-io-syntax
(lambda () ,@body
)))
99 (defun %with-standard-io-syntax
(function)
100 (let ((*package
* (find-package "COMMON-LISP-USER"))
103 (*print-case
* :upcase
)
110 (*print-miser-width
* nil
)
114 (*print-right-margin
* nil
)
116 (*read-default-float-format
* 'single-float
)
118 (*read-suppress
* nil
)
119 ;; FIXME: It doesn't seem like a good idea to expose our
120 ;; disaster-recovery *STANDARD-READTABLE* here. What if some
121 ;; enterprising user corrupts the disaster-recovery readtable
122 ;; by doing destructive readtable operations within
123 ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
124 ;; COPY-READTABLE? The consing would be unfortunate, though.
125 (*readtable
* *standard-readtable
*))
128 ;;;; routines to print objects
130 (defun write (object &key
131 ((:stream stream
) *standard-output
*)
132 ((:escape
*print-escape
*) *print-escape
*)
133 ((:radix
*print-radix
*) *print-radix
*)
134 ((:base
*print-base
*) *print-base
*)
135 ((:circle
*print-circle
*) *print-circle
*)
136 ((:pretty
*print-pretty
*) *print-pretty
*)
137 ((:level
*print-level
*) *print-level
*)
138 ((:length
*print-length
*) *print-length
*)
139 ((:case
*print-case
*) *print-case
*)
140 ((:array
*print-array
*) *print-array
*)
141 ((:gensym
*print-gensym
*) *print-gensym
*)
142 ((:readably
*print-readably
*) *print-readably
*)
143 ((:right-margin
*print-right-margin
*)
144 *print-right-margin
*)
145 ((:miser-width
*print-miser-width
*)
147 ((:lines
*print-lines
*) *print-lines
*)
148 ((:pprint-dispatch
*print-pprint-dispatch
*)
149 *print-pprint-dispatch
*))
151 "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
152 (output-object object
(out-synonym-of stream
))
155 (defun prin1 (object &optional stream
)
157 "Output a mostly READable printed representation of OBJECT on the specified
159 (let ((*print-escape
* T
))
160 (output-object object
(out-synonym-of stream
)))
163 (defun princ (object &optional stream
)
165 "Output an aesthetic but not necessarily READable printed representation
166 of OBJECT on the specified STREAM."
167 (let ((*print-escape
* NIL
)
168 (*print-readably
* NIL
))
169 (output-object object
(out-synonym-of stream
)))
172 (defun print (object &optional stream
)
174 "Output a newline, the mostly READable printed representation of OBJECT, and
175 space to the specified STREAM."
176 (let ((stream (out-synonym-of stream
)))
178 (prin1 object stream
)
179 (write-char #\space stream
)
182 (defun pprint (object &optional stream
)
184 "Prettily output OBJECT preceded by a newline."
185 (let ((*print-pretty
* t
)
187 (stream (out-synonym-of stream
)))
189 (output-object object stream
))
192 (defun write-to-string
194 ((:escape
*print-escape
*) *print-escape
*)
195 ((:radix
*print-radix
*) *print-radix
*)
196 ((:base
*print-base
*) *print-base
*)
197 ((:circle
*print-circle
*) *print-circle
*)
198 ((:pretty
*print-pretty
*) *print-pretty
*)
199 ((:level
*print-level
*) *print-level
*)
200 ((:length
*print-length
*) *print-length
*)
201 ((:case
*print-case
*) *print-case
*)
202 ((:array
*print-array
*) *print-array
*)
203 ((:gensym
*print-gensym
*) *print-gensym
*)
204 ((:readably
*print-readably
*) *print-readably
*)
205 ((:right-margin
*print-right-margin
*) *print-right-margin
*)
206 ((:miser-width
*print-miser-width
*) *print-miser-width
*)
207 ((:lines
*print-lines
*) *print-lines
*)
208 ((:pprint-dispatch
*print-pprint-dispatch
*)
209 *print-pprint-dispatch
*))
211 "Return the printed representation of OBJECT as a string."
212 (stringify-object object
))
214 (defun prin1-to-string (object)
216 "Return the printed representation of OBJECT as a string with
218 (stringify-object object t
))
220 (defun princ-to-string (object)
222 "Return the printed representation of OBJECT as a string with
224 (stringify-object object nil
))
226 ;;; This produces the printed representation of an object as a string.
227 ;;; The few ...-TO-STRING functions above call this.
228 (defvar *string-output-streams
* ())
229 (defun stringify-object (object &optional
(*print-escape
* *print-escape
*))
230 (let ((stream (if *string-output-streams
*
231 (pop *string-output-streams
*)
232 (make-string-output-stream))))
233 (setup-printer-state)
234 (output-object object stream
)
236 (get-output-stream-string stream
)
237 (push stream
*string-output-streams
*))))
239 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
241 ;;; guts of PRINT-UNREADABLE-OBJECT
242 (defun %print-unreadable-object
(object stream type identity body
)
243 (when *print-readably
*
244 (error 'print-not-readable
:object object
))
245 (flet ((print-description ()
247 (write (type-of object
) :stream stream
:circle nil
248 :level nil
:length nil
)
249 (when (or body identity
)
250 (write-char #\space stream
)
251 (pprint-newline :fill stream
)))
256 (write-char #\space stream
)
257 (pprint-newline :fill stream
))
258 (write-char #\
{ stream
)
259 (write (get-lisp-obj-address object
) :stream stream
261 (write-char #\
} stream
))))
262 (cond ((print-pretty-on-stream-p stream
)
263 ;; Since we're printing prettily on STREAM, format the
264 ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
265 ;; not rebind the stream when it is already a pretty stream,
266 ;; so output from the body will go to the same stream.
267 (pprint-logical-block (stream nil
:prefix
"#<" :suffix
">")
268 (print-description)))
270 (write-string "#<" stream
)
272 (write-char #\
> stream
))))
275 ;;;; circularity detection stuff
277 ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
278 ;;; (eventually) ends up with entries for every object printed. When
279 ;;; we are initially looking for circularities, we enter a T when we
280 ;;; find an object for the first time, and a 0 when we encounter an
281 ;;; object a second time around. When we are actually printing, the 0
282 ;;; entries get changed to the actual marker value when they are first
284 (defvar *circularity-hash-table
* nil
)
286 ;;; When NIL, we are just looking for circularities. After we have
287 ;;; found them all, this gets bound to 0. Then whenever we need a new
288 ;;; marker, it is incremented.
289 (defvar *circularity-counter
* nil
)
291 ;;; Check to see whether OBJECT is a circular reference, and return
292 ;;; something non-NIL if it is. If ASSIGN is T, then the number to use
293 ;;; in the #n= and #n# noise is assigned at this time.
294 ;;; If ASSIGN is true, reference bookkeeping will only be done for
295 ;;; existing entries, no new references will be recorded!
297 ;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
298 ;;; ASSIGN true, or the circularity detection noise will get confused
299 ;;; about when to use #n= and when to use #n#. If this returns non-NIL
300 ;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
301 ;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
302 ;;; you need to initiate the circularity detection noise, e.g. bind
303 ;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
304 ;;; (see #'OUTPUT-OBJECT for an example).
305 (defun check-for-circularity (object &optional assign
)
306 (cond ((null *print-circle
*)
307 ;; Don't bother, nobody cares.
309 ((null *circularity-hash-table
*)
310 (values nil
:initiate
))
311 ((null *circularity-counter
*)
312 (ecase (gethash object
*circularity-hash-table
*)
315 (setf (gethash object
*circularity-hash-table
*) t
)
316 ;; We need to keep looking.
320 (setf (gethash object
*circularity-hash-table
*) 0)
321 ;; It's a circular reference.
324 ;; It's a circular reference.
327 (let ((value (gethash object
*circularity-hash-table
*)))
330 ;; If NIL, we found an object that wasn't there the
331 ;; first time around. If T, this object appears exactly
332 ;; once. Either way, just print the thing without any
333 ;; special processing. Note: you might argue that
334 ;; finding a new object means that something is broken,
335 ;; but this can happen. If someone uses the ~@<...~:>
336 ;; format directive, it conses a new list each time
337 ;; though format (i.e. the &REST list), so we will have
342 (let ((value (incf *circularity-counter
*)))
343 ;; first occurrence of this object: Set the counter.
344 (setf (gethash object
*circularity-hash-table
*) value
)
348 ;; second or later occurrence
351 ;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
352 ;;; you should go ahead and print the object. If it returns NIL, then
353 ;;; you should blow it off.
354 (defun handle-circularity (marker stream
)
357 ;; Someone forgot to initiate circularity detection.
358 (let ((*print-circle
* nil
))
359 (error "trying to use CHECK-FOR-CIRCULARITY when ~
360 circularity checking isn't initiated")))
362 ;; It's a second (or later) reference to the object while we are
363 ;; just looking. So don't bother groveling it again.
366 (write-char #\
# stream
)
367 (let ((*print-base
* 10) (*print-radix
* nil
))
368 (cond ((minusp marker
)
369 (output-integer (- marker
) stream
)
370 (write-char #\
# stream
)
373 (output-integer marker stream
)
374 (write-char #\
= stream
)
377 ;;;; OUTPUT-OBJECT -- the main entry point
379 ;;; Objects whose print representation identifies them EQLly don't
380 ;;; need to be checked for circularity.
381 (defun uniquely-identified-by-print-p (x)
385 (symbol-package x
))))
387 ;;; Output OBJECT to STREAM observing all printer control variables.
388 (defun output-object (object stream
)
389 (labels ((print-it (stream)
391 (sb!pretty
:output-pretty-object object stream
)
392 (output-ugly-object object stream
)))
394 (multiple-value-bind (marker initiate
)
395 (check-for-circularity object t
)
396 ;; initialization of the circulation detect noise ...
397 (if (eq initiate
:initiate
)
398 (let ((*circularity-hash-table
*
399 (make-hash-table :test
'eq
)))
400 (check-it (make-broadcast-stream))
401 (let ((*circularity-counter
* 0))
405 (when (handle-circularity marker stream
)
407 (print-it stream
))))))
408 (cond (;; Maybe we don't need to bother with circularity detection.
409 (or (not *print-circle
*)
410 (uniquely-identified-by-print-p object
))
412 (;; If we have already started circularity detection, this
413 ;; object might be a shared reference. If we have not, then
414 ;; if it is a compound object it might contain a circular
415 ;; reference to itself or multiple shared references.
416 (or *circularity-hash-table
*
417 (compound-object-p object
))
420 (print-it stream
)))))
422 ;;; a hack to work around recurring gotchas with printing while
423 ;;; DEFGENERIC PRINT-OBJECT is being built
425 ;;; (hopefully will go away naturally when CLOS moves into cold init)
426 (defvar *print-object-is-disabled-p
*)
428 ;;; Output OBJECT to STREAM observing all printer control variables
429 ;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
430 ;;; then the pretty printer will be used for any components of OBJECT,
431 ;;; just not for OBJECT itself.
432 (defun output-ugly-object (object stream
)
434 ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
435 ;; PRINT-OBJECT says it provides printing and we're supposed to provide
436 ;; PRINT-OBJECT methods covering all classes. We deviate from this
437 ;; by using PRINT-OBJECT only when we print instance values. However,
438 ;; ANSI makes it hard to tell that we're deviating from this:
439 ;; (1) ANSI specifies that the user isn't supposed to call PRINT-OBJECT
441 ;; (2) ANSI (section 11.1.2.1.2) says it's undefined to define
442 ;; a method on an external symbol in the CL package which is
443 ;; applicable to arg lists containing only direct instances of
444 ;; standardized classes.
445 ;; Thus, in order for the user to detect our sleaziness in conforming
446 ;; code, he has to do something relatively obscure like
447 ;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
449 ;; (2) define a PRINT-OBJECT method which is specialized on the stream
450 ;; value (e.g. a Gray stream object).
451 ;; As long as no one comes up with a non-obscure way of detecting this
452 ;; sleaziness, fixing this nonconformity will probably have a low
453 ;; priority. -- WHN 2001-11-25
455 (output-integer object stream
))
458 (output-symbol object stream
)
459 (output-list object stream
)))
461 (cond ((not (and (boundp '*print-object-is-disabled-p
*)
462 *print-object-is-disabled-p
*))
463 (print-object object stream
))
464 ((typep object
'structure-object
)
465 (default-structure-print object stream
*current-level-in-print
*))
467 (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream
))))
469 (unless (and (funcallable-instance-p object
)
470 (printed-as-funcallable-standard-class object stream
))
471 (output-fun object stream
)))
473 (output-symbol object stream
))
477 (output-integer object stream
))
479 (output-float object stream
))
481 (output-ratio object stream
))
483 (output-ratio object stream
))
485 (output-complex object stream
))))
487 (output-character object stream
))
489 (output-vector object stream
))
491 (output-array object stream
))
493 (output-sap object stream
))
495 (output-weak-pointer object stream
))
497 (output-lra object stream
))
499 (output-code-component object stream
))
501 (output-fdefn object stream
))
503 (output-random object stream
))))
507 ;;; values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last
508 ;;; time the printer was called
509 (defvar *previous-case
* nil
)
510 (defvar *previous-readtable-case
* nil
)
512 ;;; This variable contains the current definition of one of three
513 ;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
514 (defvar *internal-symbol-output-fun
* nil
)
516 ;;; This function sets the internal global symbol
517 ;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
518 ;;; the value of *PRINT-CASE*. See the manual for details. The print
519 ;;; buffer stream is also reset.
520 (defun setup-printer-state ()
521 (unless (and (eq *print-case
* *previous-case
*)
522 (eq (readtable-case *readtable
*) *previous-readtable-case
*))
523 (setq *previous-case
* *print-case
*)
524 (setq *previous-readtable-case
* (readtable-case *readtable
*))
525 (unless (member *print-case
* '(:upcase
:downcase
:capitalize
))
526 (setq *print-case
* :upcase
)
527 (error "invalid *PRINT-CASE* value: ~S" *previous-case
*))
528 (unless (member *previous-readtable-case
*
529 '(:upcase
:downcase
:invert
:preserve
))
530 (setf (readtable-case *readtable
*) :upcase
)
531 (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case
*))
533 (setq *internal-symbol-output-fun
*
534 (case *previous-readtable-case
*
537 (:upcase
#'output-preserve-symbol
)
538 (:downcase
#'output-lowercase-symbol
)
539 (:capitalize
#'output-capitalize-symbol
)))
542 (:upcase
#'output-uppercase-symbol
)
543 (:downcase
#'output-preserve-symbol
)
544 (:capitalize
#'output-capitalize-symbol
)))
545 (:preserve
#'output-preserve-symbol
)
546 (:invert
#'output-invert-symbol
)))))
548 ;;; Output PNAME (a symbol-name or package-name) surrounded with |'s,
549 ;;; and with any embedded |'s or \'s escaped.
550 (defun output-quoted-symbol-name (pname stream
)
551 (write-char #\| stream
)
552 (dotimes (index (length pname
))
553 (let ((char (schar pname index
)))
554 (when (or (char= char
#\\) (char= char
#\|
))
555 (write-char #\\ stream
))
556 (write-char char stream
)))
557 (write-char #\| stream
))
559 (defun output-symbol (object stream
)
560 (if (or *print-escape
* *print-readably
*)
561 (let ((package (symbol-package object
))
562 (name (symbol-name object
)))
564 ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
565 ;; requires that keywords be printed with preceding colons
566 ;; always, regardless of the value of *PACKAGE*.
567 ((eq package
*keyword-package
*)
568 (write-char #\
: stream
))
569 ;; Otherwise, if the symbol's home package is the current
570 ;; one, then a prefix is never necessary.
571 ((eq package
(sane-package)))
572 ;; Uninterned symbols print with a leading #:.
574 (when (or *print-gensym
* *print-readably
*)
575 (write-string "#:" stream
)))
577 (multiple-value-bind (symbol accessible
)
578 (find-symbol name
(sane-package))
579 ;; If we can find the symbol by looking it up, it need not
580 ;; be qualified. This can happen if the symbol has been
581 ;; inherited from a package other than its home package.
582 (unless (and accessible
(eq symbol object
))
583 (output-symbol-name (package-name package
) stream
)
584 (multiple-value-bind (symbol externalp
)
585 (find-external-symbol name package
)
586 (declare (ignore symbol
))
588 (write-char #\
: stream
)
589 (write-string "::" stream
)))))))
590 (output-symbol-name name stream
))
591 (output-symbol-name (symbol-name object
) stream nil
)))
593 ;;; Output the string NAME as if it were a symbol name. In other
594 ;;; words, diddle its case according to *PRINT-CASE* and
596 (defun output-symbol-name (name stream
&optional
(maybe-quote t
))
597 (declare (type simple-base-string name
))
598 (setup-printer-state)
599 (if (and maybe-quote
(symbol-quotep name
))
600 (output-quoted-symbol-name name stream
)
601 (funcall *internal-symbol-output-fun
* name stream
)))
603 ;;;; escaping symbols
605 ;;; When we print symbols we have to figure out if they need to be
606 ;;; printed with escape characters. This isn't a whole lot easier than
607 ;;; reading symbols in the first place.
609 ;;; For each character, the value of the corresponding element is a
610 ;;; fixnum with bits set corresponding to attributes that the
611 ;;; character has. At characters have at least one bit set, so we can
612 ;;; search for any character with a positive test.
613 (defvar *character-attributes
*
614 (make-array char-code-limit
615 :element-type
'(unsigned-byte 16)
617 (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit
))
618 *character-attributes
*))
620 ;;; constants which are a bit-mask for each interesting character attribute
621 (defconstant other-attribute
(ash 1 0)) ; Anything else legal.
622 (defconstant number-attribute
(ash 1 1)) ; A numeric digit.
623 (defconstant uppercase-attribute
(ash 1 2)) ; An uppercase letter.
624 (defconstant lowercase-attribute
(ash 1 3)) ; A lowercase letter.
625 (defconstant sign-attribute
(ash 1 4)) ; +-
626 (defconstant extension-attribute
(ash 1 5)) ; ^_
627 (defconstant dot-attribute
(ash 1 6)) ; .
628 (defconstant slash-attribute
(ash 1 7)) ; /
629 (defconstant funny-attribute
(ash 1 8)) ; Anything illegal.
631 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
633 ;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
634 ;;; that don't need to be escaped (according to READTABLE-CASE.)
635 (defparameter *attribute-names
*
636 `((number . number-attribute
) (lowercase . lowercase-attribute
)
637 (uppercase . uppercase-attribute
) (letter . letter-attribute
)
638 (sign . sign-attribute
) (extension . extension-attribute
)
639 (dot . dot-attribute
) (slash . slash-attribute
)
640 (other . other-attribute
) (funny . funny-attribute
)))
644 (flet ((set-bit (char bit
)
645 (let ((code (char-code char
)))
646 (setf (aref *character-attributes
* code
)
647 (logior bit
(aref *character-attributes
* code
))))))
649 (dolist (char '(#\
! #\
@ #\$
#\%
#\
& #\
* #\
= #\~
#\
[ #\
] #\
{ #\
}
651 (set-bit char other-attribute
))
654 (set-bit (digit-char i
) number-attribute
))
656 (do ((code (char-code #\A
) (1+ code
))
657 (end (char-code #\Z
)))
659 (declare (fixnum code end
))
660 (set-bit (code-char code
) uppercase-attribute
)
661 (set-bit (char-downcase (code-char code
)) lowercase-attribute
))
663 (set-bit #\- sign-attribute
)
664 (set-bit #\
+ sign-attribute
)
665 (set-bit #\^ extension-attribute
)
666 (set-bit #\_ extension-attribute
)
667 (set-bit #\. dot-attribute
)
668 (set-bit #\
/ slash-attribute
)
670 ;; Mark anything not explicitly allowed as funny.
671 (dotimes (i char-code-limit
)
672 (when (zerop (aref *character-attributes
* i
))
673 (setf (aref *character-attributes
* i
) funny-attribute
))))
675 ;;; For each character, the value of the corresponding element is the
676 ;;; lowest base in which that character is a digit.
677 (defvar *digit-bases
*
678 (make-array char-code-limit
679 :element-type
'(unsigned-byte 8)
680 :initial-element
36))
681 (declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit
))
685 (let ((char (digit-char i
36)))
686 (setf (aref *digit-bases
* (char-code char
)) i
)))
688 ;;; A FSM-like thingie that determines whether a symbol is a potential
689 ;;; number or has evil characters in it.
690 (defun symbol-quotep (name)
691 (declare (simple-string name
))
692 (macrolet ((advance (tag &optional
(at-end t
))
695 ,(if at-end
'(go TEST-SIGN
) '(return nil
)))
696 (setq current
(schar name index
)
697 code
(char-code current
)
698 bits
(aref attributes code
))
701 (test (&rest attributes
)
713 `(< (the fixnum
(aref bases code
)) base
)))
715 (prog ((len (length name
))
716 (attributes *character-attributes
*)
717 (bases *digit-bases
*)
720 (case (readtable-case *readtable
*)
721 (:upcase uppercase-attribute
)
722 (:downcase lowercase-attribute
)
723 (t (logior lowercase-attribute uppercase-attribute
))))
728 (declare (fixnum len base index bits code
))
731 TEST-SIGN
; At end, see whether it is a sign...
732 (return (not (test sign
)))
734 OTHER
; not potential number, see whether funny chars...
735 (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
738 (do ((i (1- index
) (1+ i
)))
739 ((= i len
) (return-from symbol-quotep nil
))
740 (unless (zerop (logand (aref attributes
(char-code (schar name i
)))
742 (return-from symbol-quotep t
))))
747 (advance LAST-DIGIT-ALPHA
)
749 (when (test letter number other slash
) (advance OTHER nil
))
750 (when (char= current
#\.
) (advance DOT-FOUND
))
751 (when (test sign extension
) (advance START-STUFF nil
))
754 DOT-FOUND
; leading dots...
755 (when (test letter
) (advance START-DOT-MARKER nil
))
756 (when (digitp) (advance DOT-DIGIT
))
757 (when (test number other
) (advance OTHER nil
))
758 (when (test extension slash sign
) (advance START-DOT-STUFF nil
))
759 (when (char= current
#\.
) (advance DOT-FOUND
))
762 START-STUFF
; leading stuff before any dot or digit
765 (advance LAST-DIGIT-ALPHA
)
767 (when (test number other
) (advance OTHER nil
))
768 (when (test letter
) (advance START-MARKER nil
))
769 (when (char= current
#\.
) (advance START-DOT-STUFF nil
))
770 (when (test sign extension slash
) (advance START-STUFF nil
))
773 START-MARKER
; number marker in leading stuff...
774 (when (test letter
) (advance OTHER nil
))
777 START-DOT-STUFF
; leading stuff containing dot without digit...
778 (when (test letter
) (advance START-DOT-STUFF nil
))
779 (when (digitp) (advance DOT-DIGIT
))
780 (when (test sign extension dot slash
) (advance START-DOT-STUFF nil
))
781 (when (test number other
) (advance OTHER nil
))
784 START-DOT-MARKER
; number marker in leading stuff with dot..
785 ;; leading stuff containing dot without digit followed by letter...
786 (when (test letter
) (advance OTHER nil
))
789 DOT-DIGIT
; in a thing with dots...
790 (when (test letter
) (advance DOT-MARKER
))
791 (when (digitp) (advance DOT-DIGIT
))
792 (when (test number other
) (advance OTHER nil
))
793 (when (test sign extension dot slash
) (advance DOT-DIGIT
))
796 DOT-MARKER
; number marker in number with dot...
797 (when (test letter
) (advance OTHER nil
))
800 LAST-DIGIT-ALPHA
; previous char is a letter digit...
801 (when (or (digitp) (test sign slash
))
802 (advance ALPHA-DIGIT
))
803 (when (test letter number other dot
) (advance OTHER nil
))
806 ALPHA-DIGIT
; seen a digit which is a letter...
807 (when (or (digitp) (test sign slash
))
809 (advance LAST-DIGIT-ALPHA
)
810 (advance ALPHA-DIGIT
)))
811 (when (test letter
) (advance ALPHA-MARKER
))
812 (when (test number other dot
) (advance OTHER nil
))
815 ALPHA-MARKER
; number marker in number with alpha digit...
816 (when (test letter
) (advance OTHER nil
))
819 DIGIT
; seen only ordinary (non-alphabetic) numeric digits...
822 (advance ALPHA-DIGIT
)
824 (when (test number other
) (advance OTHER nil
))
825 (when (test letter
) (advance MARKER
))
826 (when (test extension slash sign
) (advance DIGIT
))
827 (when (char= current
#\.
) (advance DOT-DIGIT
))
830 MARKER
; number marker in a numeric number...
831 (when (test letter
) (advance OTHER nil
))
834 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
836 ;;;; case hackery: These functions are stored in
837 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
838 ;;;; *PRINT-CASE* and READTABLE-CASE.
841 ;;; READTABLE-CASE *PRINT-CASE*
843 ;;; :DOWNCASE :DOWNCASE
845 (defun output-preserve-symbol (pname stream
)
846 (declare (simple-string pname
))
847 (write-string pname stream
))
850 ;;; READTABLE-CASE *PRINT-CASE*
851 ;;; :UPCASE :DOWNCASE
852 (defun output-lowercase-symbol (pname stream
)
853 (declare (simple-string pname
))
854 (dotimes (index (length pname
))
855 (let ((char (schar pname index
)))
856 (write-char (char-downcase char
) stream
))))
859 ;;; READTABLE-CASE *PRINT-CASE*
860 ;;; :DOWNCASE :UPCASE
861 (defun output-uppercase-symbol (pname stream
)
862 (declare (simple-string pname
))
863 (dotimes (index (length pname
))
864 (let ((char (schar pname index
)))
865 (write-char (char-upcase char
) stream
))))
868 ;;; READTABLE-CASE *PRINT-CASE*
869 ;;; :UPCASE :CAPITALIZE
870 ;;; :DOWNCASE :CAPITALIZE
871 (defun output-capitalize-symbol (pname stream
)
872 (declare (simple-string pname
))
873 (let ((prev-not-alpha t
)
874 (up (eq (readtable-case *readtable
*) :upcase
)))
875 (dotimes (i (length pname
))
876 (let ((char (char pname i
)))
878 (if (or prev-not-alpha
(lower-case-p char
))
880 (char-downcase char
))
885 (setq prev-not-alpha
(not (alpha-char-p char
)))))))
888 ;;; READTABLE-CASE *PRINT-CASE*
890 (defun output-invert-symbol (pname stream
)
891 (declare (simple-string pname
))
894 (dotimes (i (length pname
))
895 (let ((ch (schar pname i
)))
896 (when (both-case-p ch
)
897 (if (upper-case-p ch
)
899 (setq all-upper nil
)))))
900 (cond (all-upper (output-lowercase-symbol pname stream
))
901 (all-lower (output-uppercase-symbol pname stream
))
903 (write-string pname stream
)))))
907 (let ((*readtable
* (copy-readtable nil
)))
908 (format t
"READTABLE-CASE Input Symbol-name~@
909 ----------------------------------~%")
910 (dolist (readtable-case '(:upcase
:downcase
:preserve
:invert
))
911 (setf (readtable-case *readtable
*) readtable-case
)
912 (dolist (input '("ZEBRA" "Zebra" "zebra"))
913 (format t
"~&:~A~16T~A~24T~A"
914 (string-upcase readtable-case
)
916 (symbol-name (read-from-string input
)))))))
919 (let ((*readtable
* (copy-readtable nil
)))
920 (format t
"READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@
921 --------------------------------------------------------~%")
922 (dolist (readtable-case '(:upcase
:downcase
:preserve
:invert
))
923 (setf (readtable-case *readtable
*) readtable-case
)
924 (dolist (*print-case
* '(:upcase
:downcase
:capitalize
))
925 (dolist (symbol '(|ZEBRA| |Zebra| |zebra|
))
926 (format t
"~&:~A~15T:~A~29T~A~42T~A~50T~A"
927 (string-upcase readtable-case
)
928 (string-upcase *print-case
*)
930 (prin1-to-string symbol
)
931 (princ-to-string symbol
)))))))
934 ;;;; recursive objects
936 (defun output-list (list stream
)
937 (descend-into (stream)
938 (write-char #\
( stream
)
942 (punt-print-if-too-long length stream
)
943 (output-object (pop list
) stream
)
946 (when (or (atom list
)
947 (check-for-circularity list
))
948 (write-string " . " stream
)
949 (output-object list stream
)
951 (write-char #\space stream
)
953 (write-char #\
) stream
)))
955 (defun output-vector (vector stream
)
956 (declare (vector vector
))
957 (cond ((stringp vector
)
958 (cond ((or *print-escape
* *print-readably
*)
959 (write-char #\" stream
)
960 (quote-string vector stream
)
961 (write-char #\" stream
))
963 (write-string vector stream
))))
964 ((not (or *print-array
* *print-readably
*))
965 (output-terse-array vector stream
))
966 ((bit-vector-p vector
)
967 (write-string "#*" stream
)
968 (dovector (bit vector
)
969 ;; (Don't use OUTPUT-OBJECT here, since this code
970 ;; has to work for all possible *PRINT-BASE* values.)
971 (write-char (if (zerop bit
) #\
0 #\
1) stream
)))
973 (when (and *print-readably
*
974 (not (eq (array-element-type vector
) t
)))
975 (error 'print-not-readable
:object vector
))
976 (descend-into (stream)
977 (write-string "#(" stream
)
978 (dotimes (i (length vector
))
980 (write-char #\space stream
))
981 (punt-print-if-too-long i stream
)
982 (output-object (aref vector i
) stream
))
983 (write-string ")" stream
)))))
985 ;;; This function outputs a string quoting characters sufficiently
986 ;;; so that someone can read it in again. Basically, put a slash in
987 ;;; front of an character satisfying NEEDS-SLASH-P.
988 (defun quote-string (string stream
)
989 (macrolet ((needs-slash-p (char)
990 ;; KLUDGE: We probably should look at the readtable, but just do
991 ;; this for now. [noted by anonymous long ago] -- WHN 19991130
992 `(or (char= ,char
#\\)
994 (with-array-data ((data string
) (start) (end (length string
)))
995 (do ((index start
(1+ index
)))
997 (let ((char (schar data index
)))
998 (when (needs-slash-p char
) (write-char #\\ stream
))
999 (write-char char stream
))))))
1001 ;;; Output the printed representation of any array in either the #< or #A
1003 (defun output-array (array stream
)
1004 (if (or *print-array
* *print-readably
*)
1005 (output-array-guts array stream
)
1006 (output-terse-array array stream
)))
1008 ;;; Output the abbreviated #< form of an array.
1009 (defun output-terse-array (array stream
)
1010 (let ((*print-level
* nil
)
1011 (*print-length
* nil
))
1012 (print-unreadable-object (array stream
:type t
:identity t
))))
1014 ;;; Output the readable #A form of an array.
1015 (defun output-array-guts (array stream
)
1016 (when (and *print-readably
*
1017 (not (eq (array-element-type array
) t
)))
1018 (error 'print-not-readable
:object array
))
1019 (write-char #\
# stream
)
1020 (let ((*print-base
* 10))
1021 (output-integer (array-rank array
) stream
))
1022 (write-char #\A stream
)
1023 (with-array-data ((data array
) (start) (end))
1024 (declare (ignore end
))
1025 (sub-output-array-guts data
(array-dimensions array
) stream start
)))
1027 (defun sub-output-array-guts (array dimensions stream index
)
1028 (declare (type (simple-array * (*)) array
) (fixnum index
))
1029 (cond ((null dimensions
)
1030 (output-object (aref array index
) stream
))
1032 (descend-into (stream)
1033 (write-char #\
( stream
)
1034 (let* ((dimension (car dimensions
))
1035 (dimensions (cdr dimensions
))
1036 (count (reduce #'* dimensions
)))
1037 (dotimes (i dimension
)
1039 (write-char #\space stream
))
1040 (punt-print-if-too-long i stream
)
1041 (sub-output-array-guts array dimensions stream index
)
1042 (incf index count
)))
1043 (write-char #\
) stream
)))))
1045 ;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
1046 ;;; use until CLOS is set up (at which time it will be replaced with
1047 ;;; the real generic function implementation)
1048 (defun print-object (instance stream
)
1049 (default-structure-print instance stream
*current-level-in-print
*))
1051 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
1053 (defun output-integer (integer stream
)
1054 ;; FIXME: This UNLESS form should be pulled out into something like
1055 ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
1056 ;; *PACKAGE* variable.
1057 (unless (and (fixnump *print-base
*)
1058 (< 1 *print-base
* 37))
1059 (let ((obase *print-base
*))
1060 (setq *print-base
* 10.
)
1061 (error "~A is not a reasonable value for *PRINT-BASE*." obase
)))
1062 (when (and (not (= *print-base
* 10.
))
1064 ;; First print leading base information, if any.
1065 (write-char #\
# stream
)
1066 (write-char (case *print-base
*
1070 (T (let ((fixbase *print-base
*)
1073 (sub-output-integer fixbase stream
))
1076 ;; Then output a minus sign if the number is negative, then output
1077 ;; the absolute value of the number.
1078 (cond ((bignump integer
) (print-bignum integer stream
))
1080 (write-char #\- stream
)
1081 (sub-output-integer (- integer
) stream
))
1083 (sub-output-integer integer stream
)))
1084 ;; Print any trailing base information, if any.
1085 (if (and (= *print-base
* 10.
) *print-radix
*)
1086 (write-char #\. stream
)))
1088 (defun sub-output-integer (integer stream
)
1091 ;; Recurse until you have all the digits pushed on the stack.
1092 (if (not (zerop (multiple-value-setq (quotient remainder
)
1093 (truncate integer
*print-base
*))))
1094 (sub-output-integer quotient stream
))
1095 ;; Then as each recursive call unwinds, turn the digit (in remainder)
1096 ;; into a character and output the character.
1097 (write-char (code-char (if (and (> remainder
9.
)
1098 (> *print-base
* 10.
))
1099 (+ (char-code #\A
) (- remainder
10.
))
1100 (+ (char-code #\
0) remainder
)))
1103 ;;;; bignum printing
1105 ;;; *BASE-POWER* holds the number that we keep dividing into the
1106 ;;; bignum for each *print-base*. We want this number as close to
1107 ;;; *most-positive-fixnum* as possible, i.e. (floor (log
1108 ;;; most-positive-fixnum *print-base*)).
1109 (defparameter *base-power
* (make-array 37 :initial-element nil
))
1111 ;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
1112 ;;; that fit in the corresponding *base-power*.
1113 (defparameter *fixnum-power--1
* (make-array 37 :initial-element nil
))
1115 ;;; Print the bignum to the stream. We first generate the correct
1116 ;;; value for *base-power* and *fixnum-power--1* if we have not
1117 ;;; already. Then we call bignum-print-aux to do the printing.
1118 (defun print-bignum (big stream
)
1119 (unless (aref *base-power
* *print-base
*)
1120 (do ((power-1 -
1 (1+ power-1
))
1121 (new-divisor *print-base
* (* new-divisor
*print-base
*))
1122 (divisor 1 new-divisor
))
1123 ((not (fixnump new-divisor
))
1124 (setf (aref *base-power
* *print-base
*) divisor
)
1125 (setf (aref *fixnum-power--1
* *print-base
*) power-1
))))
1126 (bignum-print-aux (cond ((minusp big
)
1127 (write-char #\- stream
)
1130 (aref *base-power
* *print-base
*)
1131 (aref *fixnum-power--1
* *print-base
*)
1135 (defun bignum-print-aux (big divisor power-1 stream
)
1136 (multiple-value-bind (newbig fix
) (truncate big divisor
)
1137 (if (fixnump newbig
)
1138 (sub-output-integer newbig stream
)
1139 (bignum-print-aux newbig divisor power-1 stream
))
1140 (do ((zeros power-1
(1- zeros
))
1141 (base-power *print-base
* (* base-power
*print-base
*)))
1143 (dotimes (i zeros
) (write-char #\
0 stream
))
1144 (sub-output-integer fix stream
)))))
1146 (defun output-ratio (ratio stream
)
1148 (write-char #\
# stream
)
1150 (2 (write-char #\b stream
))
1151 (8 (write-char #\o stream
))
1152 (16 (write-char #\x stream
))
1153 (t (write *print-base
* :stream stream
:radix nil
:base
10)))
1154 (write-char #\r stream
))
1155 (let ((*print-radix
* nil
))
1156 (output-integer (numerator ratio
) stream
)
1157 (write-char #\
/ stream
)
1158 (output-integer (denominator ratio
) stream
)))
1160 (defun output-complex (complex stream
)
1161 (write-string "#C(" stream
)
1162 (output-object (realpart complex
) stream
)
1163 (write-char #\space stream
)
1164 (output-object (imagpart complex
) stream
)
1165 (write-char #\
) stream
))
1169 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
1170 ;;; most of the work for all printing of floating point numbers in the
1171 ;;; printer and in FORMAT. It converts a floating point number to a
1172 ;;; string in a free or fixed format with no exponent. The
1173 ;;; interpretation of the arguments is as follows:
1175 ;;; X - The floating point number to convert, which must not be
1177 ;;; WIDTH - The preferred field width, used to determine the number
1178 ;;; of fraction digits to produce if the FDIGITS parameter
1179 ;;; is unspecified or NIL. If the non-fraction digits and the
1180 ;;; decimal point alone exceed this width, no fraction digits
1181 ;;; will be produced unless a non-NIL value of FDIGITS has been
1182 ;;; specified. Field overflow is not considerd an error at this
1184 ;;; FDIGITS - The number of fractional digits to produce. Insignificant
1185 ;;; trailing zeroes may be introduced as needed. May be
1186 ;;; unspecified or NIL, in which case as many digits as possible
1187 ;;; are generated, subject to the constraint that there are no
1188 ;;; trailing zeroes.
1189 ;;; SCALE - If this parameter is specified or non-NIL, then the number
1190 ;;; printed is (* x (expt 10 scale)). This scaling is exact,
1191 ;;; and cannot lose precision.
1192 ;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1193 ;;; number of fraction digits which will be produced, regardless
1194 ;;; of the value of WIDTH or FDIGITS. This feature is used by
1195 ;;; the ~E format directive to prevent complete loss of
1196 ;;; significance in the printed value due to a bogus choice of
1199 ;;; Most of the optional arguments are for the benefit for FORMAT and are not
1200 ;;; used by the printer.
1203 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1204 ;;; where the results have the following interpretation:
1206 ;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1207 ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1208 ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1210 ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1212 ;;; POINT-POS - The position of the digit preceding the decimal
1213 ;;; point. Zero indicates point before first digit.
1215 ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
1216 ;;; accuracy. Specifically, the decimal number printed is the closest
1217 ;;; possible approximation to the true value of the binary number to
1218 ;;; be printed from among all decimal representations with the same
1219 ;;; number of digits. In free-format output, i.e. with the number of
1220 ;;; digits unconstrained, it is guaranteed that all the information is
1221 ;;; preserved, so that a properly- rounding reader can reconstruct the
1222 ;;; original binary number, bit-for-bit, from its printed decimal
1223 ;;; representation. Furthermore, only as many digits as necessary to
1224 ;;; satisfy this condition will be printed.
1226 ;;; FLOAT-STRING actually generates the digits for positive numbers.
1227 ;;; The algorithm is essentially that of algorithm Dragon4 in "How to
1228 ;;; Print Floating-Point Numbers Accurately" by Steele and White. The
1229 ;;; current (draft) version of this paper may be found in
1230 ;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
1231 ;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
1233 (defvar *digits
* "0123456789")
1235 (defun flonum-to-string (x &optional width fdigits scale fmin
)
1237 ;; Zero is a special case which FLOAT-STRING cannot handle.
1239 (let ((s (make-string (1+ fdigits
) :initial-element
#\
0)))
1240 (setf (schar s
0) #\.
)
1241 (values s
(length s
) t
(zerop fdigits
) 0))
1242 (values "." 1 t t
0)))
1244 (multiple-value-bind (sig exp
) (integer-decode-float x
)
1245 (let* ((precision (float-precision x
))
1246 (digits (float-digits x
))
1247 (fudge (- digits precision
))
1248 (width (if width
(max width
1) nil
)))
1249 (float-string (ash sig
(- fudge
)) (+ exp fudge
) precision width
1250 fdigits scale fmin
))))))
1252 (defun float-string (fraction exponent precision width fdigits scale fmin
)
1253 (let ((r fraction
) (s 1) (m- 1) (m+ 1) (k 0)
1254 (digits 0) (decpnt 0) (cutoff nil
) (roundup nil
) u low high
1255 (digit-string (make-array 50
1256 :element-type
'base-char
1259 ;; Represent fraction as r/s, error bounds as m+/s and m-/s.
1260 ;; Rational arithmetic avoids loss of precision in subsequent
1262 (cond ((> exponent
0)
1263 (setq r
(ash fraction exponent
))
1264 (setq m-
(ash 1 exponent
))
1267 (setq s
(ash 1 (- exponent
)))))
1268 ;; Adjust the error bounds m+ and m- for unequal gaps.
1269 (when (= fraction
(ash 1 precision
))
1270 (setq m
+ (ash m
+ 1))
1273 ;; Scale value by requested amount, and update error bounds.
1276 (let ((scale-factor (expt 10 (- scale
))))
1277 (setq s
(* s scale-factor
)))
1278 (let ((scale-factor (expt 10 scale
)))
1279 (setq r
(* r scale-factor
))
1280 (setq m
+ (* m
+ scale-factor
))
1281 (setq m-
(* m- scale-factor
)))))
1282 ;; Scale r and s and compute initial k, the base 10 logarithm of r.
1284 ((>= r
(ceiling s
10)))
1288 (setq m
+ (* m
+ 10)))
1291 ((< (+ (ash r
1) m
+) (ash s
1)))
1294 ;; Determine number of fraction digits to generate.
1296 ;; Use specified number of fraction digits.
1297 (setq cutoff
(- fdigits
))
1298 ;;don't allow less than fmin fraction digits
1299 (if (and fmin
(> cutoff
(- fmin
))) (setq cutoff
(- fmin
))))
1301 ;; Use as many fraction digits as width will permit but
1302 ;; force at least fmin digits even if width will be
1305 (setq cutoff
(- 1 width
))
1306 (setq cutoff
(1+ (- k width
))))
1307 (if (and fmin
(> cutoff
(- fmin
))) (setq cutoff
(- fmin
)))))
1308 ;; If we decided to cut off digit generation before precision
1309 ;; has been exhausted, rounding the last digit may cause a carry
1310 ;; propagation. We can prevent this, preserving left-to-right
1311 ;; digit generation, with a few magical adjustments to m- and
1312 ;; m+. Of course, correct rounding is also preserved.
1313 (when (or fdigits width
)
1314 (let ((a (- cutoff k
))
1317 (dotimes (i a
) (setq y
(* y
10)))
1318 (dotimes (i (- a
)) (setq y
(ceiling y
10))))
1319 (setq m-
(max y m-
))
1320 (setq m
+ (max y m
+))
1321 (when (= m
+ y
) (setq roundup t
))))
1322 (when (< (+ (ash r
1) m
+) (ash s
1)) (return)))
1323 ;; Zero-fill before fraction if no integer part.
1325 (setq decpnt digits
)
1326 (vector-push-extend #\. digit-string
)
1328 (incf digits
) (vector-push-extend #\
0 digit-string
)))
1329 ;; Generate the significant digits.
1333 (vector-push-extend #\. digit-string
)
1334 (setq decpnt digits
))
1335 (multiple-value-setq (u r
) (truncate (* r
10) s
))
1338 (setq low
(< (ash r
1) m-
))
1340 (setq high
(>= (ash r
1) (- (ash s
1) m
+)))
1341 (setq high
(> (ash r
1) (- (ash s
1) m
+))))
1342 ;; Stop when either precision is exhausted or we have printed as
1343 ;; many fraction digits as permitted.
1344 (when (or low high
(and cutoff
(<= k cutoff
))) (return))
1345 (vector-push-extend (char *digits
* u
) digit-string
)
1347 ;; If cutoff occurred before first digit, then no digits are
1348 ;; generated at all.
1349 (when (or (not cutoff
) (>= k cutoff
))
1350 ;; Last digit may need rounding
1351 (vector-push-extend (char *digits
*
1352 (cond ((and low
(not high
)) u
)
1353 ((and high
(not low
)) (1+ u
))
1354 (t (if (<= (ash r
1) s
) u
(1+ u
)))))
1357 ;; Zero-fill after integer part if no fraction.
1359 (dotimes (i k
) (incf digits
) (vector-push-extend #\
0 digit-string
))
1360 (vector-push-extend #\. digit-string
)
1361 (setq decpnt digits
))
1362 ;; Add trailing zeroes to pad fraction if fdigits specified.
1364 (dotimes (i (- fdigits
(- digits decpnt
)))
1366 (vector-push-extend #\
0 digit-string
)))
1368 (values digit-string
(1+ digits
) (= decpnt
0) (= decpnt digits
) decpnt
)))
1370 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
1371 ;;; a new floating point number Z in the range (0.1, 1.0] and an
1372 ;;; exponent E such that Z * 10^E is (approximately) equal to the
1373 ;;; original number. There may be some loss of precision due the
1374 ;;; floating point representation. The scaling is always done with
1375 ;;; long float arithmetic, which helps printing of lesser precisions
1376 ;;; as well as avoiding generic arithmetic.
1378 ;;; When computing our initial scale factor using EXPT, we pull out
1379 ;;; part of the computation to avoid over/under flow. When
1380 ;;; denormalized, we must pull out a large factor, since there is more
1381 ;;; negative exponent range than positive range.
1382 (defun scale-exponent (original-x)
1383 (let* ((x (coerce original-x
'long-float
)))
1384 (multiple-value-bind (sig exponent
) (decode-float x
)
1385 (declare (ignore sig
))
1387 (values (float 0.0l0 original-x
) 1)
1388 (let* ((ex (round (* exponent
(log 2l0 10))))
1390 (if (float-denormalized-p x
)
1392 (* x
1.0l16 (expt 10.0l0 (- (- ex
) 16)))
1394 (* x
1.0l18 (expt 10.0l0 (- (- ex
) 18)))
1395 (* x
10.0l0 (expt 10.0l0 (- (- ex
) 1))))
1396 (/ x
10.0l0 (expt 10.0l0 (1- ex
))))))
1397 (do ((d 10.0l0 (* d
10.0l0))
1401 (do ((m 10.0l0 (* m
10.0l0))
1405 (values (float z original-x
) ex
))))))))))
1407 ;;;; entry point for the float printer
1409 ;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
1410 ;;; argument is printed free-format, in either exponential or
1411 ;;; non-exponential notation, depending on its magnitude.
1413 ;;; NOTE: When a number is to be printed in exponential format, it is
1414 ;;; scaled in floating point. Since precision may be lost in this
1415 ;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
1416 ;;; are lost. The difficulty is that FLONUM-TO-STRING performs
1417 ;;; extensive computations with integers of similar magnitude to that
1418 ;;; of the number being printed. For large exponents, the bignums
1419 ;;; really get out of hand. If bignum arithmetic becomes reasonably
1420 ;;; fast and the exponent range is not too large, then it might become
1421 ;;; attractive to handle exponential notation with the same accuracy
1422 ;;; as non-exponential notation, using the method described in the
1423 ;;; Steele and White paper.
1425 ;;; Print the appropriate exponent marker for X and the specified exponent.
1426 (defun print-float-exponent (x exp stream
)
1427 (declare (type float x
) (type integer exp
) (type stream stream
))
1428 (let ((*print-radix
* nil
)
1429 (plusp (plusp exp
)))
1430 (if (typep x
*read-default-float-format
*)
1432 (format stream
"e~:[~;+~]~D" plusp exp
))
1433 (format stream
"~C~:[~;+~]~D"
1441 (defun output-float-infinity (x stream
)
1442 (declare (float x
) (stream stream
))
1444 (write-string "#." stream
))
1446 (error 'print-not-readable
:object x
))
1448 (write-string "#<" stream
)))
1449 (write-string "SB-EXT:" stream
)
1450 (write-string (symbol-name (float-format-name x
)) stream
)
1451 (write-string (if (plusp x
) "-POSITIVE-" "-NEGATIVE-")
1453 (write-string "INFINITY" stream
)
1455 (write-string ">" stream
)))
1457 (defun output-float-nan (x stream
)
1458 (print-unreadable-object (x stream
)
1459 (princ (float-format-name x
) stream
)
1460 (write-string (if (float-trapping-nan-p x
) " trapping" " quiet") stream
)
1461 (write-string " NaN" stream
)))
1463 ;;; the function called by OUTPUT-OBJECT to handle floats
1464 (defun output-float (x stream
)
1466 ((float-infinity-p x
)
1467 (output-float-infinity x stream
))
1469 (output-float-nan x stream
))
1471 (let ((x (cond ((minusp (float-sign x
))
1472 (write-char #\- stream
)
1478 (write-string "0.0" stream
)
1479 (print-float-exponent x
0 stream
))
1481 (output-float-aux x stream
(float 1/1000 x
) (float 10000000 x
))))))))
1482 (defun output-float-aux (x stream e-min e-max
)
1483 (if (and (>= x e-min
) (< x e-max
))
1485 (multiple-value-bind (str len lpoint tpoint
) (flonum-to-string x
)
1486 (declare (ignore len
))
1487 (when lpoint
(write-char #\
0 stream
))
1488 (write-string str stream
)
1489 (when tpoint
(write-char #\
0 stream
))
1490 (print-float-exponent x
0 stream
))
1491 ;; exponential format
1492 (multiple-value-bind (f ex
) (scale-exponent x
)
1493 (multiple-value-bind (str len lpoint tpoint
)
1494 (flonum-to-string f nil nil
1)
1495 (declare (ignore len
))
1496 (when lpoint
(write-char #\
0 stream
))
1497 (write-string str stream
)
1498 (when tpoint
(write-char #\
0 stream
))
1499 ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
1500 (print-float-exponent x
(1- ex
) stream
)))))
1502 ;;;; other leaf objects
1504 ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
1505 ;;; the character name or the character in the #\char format.
1506 (defun output-character (char stream
)
1507 (if (or *print-escape
* *print-readably
*)
1508 (let ((name (char-name char
)))
1509 (write-string "#\\" stream
)
1511 (quote-string name stream
)
1512 (write-char char stream
)))
1513 (write-char char stream
)))
1515 (defun output-sap (sap stream
)
1516 (declare (type system-area-pointer sap
))
1518 (format stream
"#.(~S #X~8,'0X)" 'int-sap
(sap-int sap
)))
1520 (print-unreadable-object (sap stream
)
1521 (format stream
"system area pointer: #X~8,'0X" (sap-int sap
))))))
1523 (defun output-weak-pointer (weak-pointer stream
)
1524 (declare (type weak-pointer weak-pointer
))
1525 (print-unreadable-object (weak-pointer stream
)
1526 (multiple-value-bind (value validp
) (weak-pointer-value weak-pointer
)
1528 (write-string "weak pointer: " stream
)
1529 (write value
:stream stream
))
1531 (write-string "broken weak pointer" stream
))))))
1533 (defun output-code-component (component stream
)
1534 (print-unreadable-object (component stream
:identity t
)
1535 (let ((dinfo (%code-debug-info component
)))
1536 (cond ((eq dinfo
:bogus-lra
)
1537 (write-string "bogus code object" stream
))
1539 (write-string "code object" stream
)
1541 (write-char #\space stream
)
1542 (output-object (sb!c
::debug-info-name dinfo
) stream
)))))))
1544 (defun output-lra (lra stream
)
1545 (print-unreadable-object (lra stream
:identity t
)
1546 (write-string "return PC object" stream
)))
1548 (defun output-fdefn (fdefn stream
)
1549 (print-unreadable-object (fdefn stream
)
1550 (write-string "FDEFINITION object for " stream
)
1551 (output-object (fdefn-name fdefn
) stream
)))
1555 ;;; Output OBJECT as using PRINT-OBJECT if it's a
1556 ;;; FUNCALLABLE-STANDARD-CLASS, or return NIL otherwise.
1558 ;;; The definition here is a simple temporary placeholder. It will be
1559 ;;; overwritten by a smarter version (capable of calling generic
1560 ;;; PRINT-OBJECT when appropriate) when CLOS is installed.
1561 (defun printed-as-clos-funcallable-standard-class (object stream
)
1562 (declare (ignore object stream
))
1565 (defun output-fun (object stream
)
1566 (let* ((*print-length
* 3) ; in case we have to..
1567 (*print-level
* 3) ; ..print an interpreted function definition
1568 ;; FIXME: This find-the-function-name idiom ought to be
1569 ;; encapsulated in a function somewhere.
1570 (name (case (fun-subtype object
)
1571 (#.sb
!vm
:closure-header-widetag
"CLOSURE")
1572 (#.sb
!vm
:simple-fun-header-widetag
(%simple-fun-name object
))
1573 (t 'no-name-available
)))
1574 (identified-by-name-p (and (symbolp name
)
1576 (eq (fdefinition name
) object
))))
1577 (print-unreadable-object (object
1579 :identity
(not identified-by-name-p
))
1580 (prin1 'function stream
)
1581 (unless (eq name
'no-name-available
)
1582 (format stream
" ~S" name
)))))
1584 ;;;; catch-all for unknown things
1586 (defun output-random (object stream
)
1587 (print-unreadable-object (object stream
:identity t
)
1588 (let ((lowtag (lowtag-of object
)))
1590 (#.sb
!vm
:other-pointer-lowtag
1591 (let ((widetag (widetag-of object
)))
1593 (#.sb
!vm
:value-cell-header-widetag
1594 (write-string "value cell " stream
)
1595 (output-object (value-cell-ref object
) stream
))
1597 (write-string "unknown pointer object, widetag=" stream
)
1598 (let ((*print-base
* 16) (*print-radix
* t
))
1599 (output-integer widetag stream
))))))
1600 ((#.sb
!vm
:fun-pointer-lowtag
1601 #.sb
!vm
:instance-pointer-lowtag
1602 #.sb
!vm
:list-pointer-lowtag
)
1603 (write-string "unknown pointer object, lowtag=" stream
)
1604 (let ((*print-base
* 16) (*print-radix
* t
))
1605 (output-integer lowtag stream
)))
1607 (case (widetag-of object
)
1608 (#.sb
!vm
:unbound-marker-widetag
1609 (write-string "unbound marker" stream
))
1611 (write-string "unknown immediate object, lowtag=" stream
)
1612 (let ((*print-base
* 2) (*print-radix
* t
))
1613 (output-integer lowtag stream
))
1614 (write-string ", widetag=" stream
)
1615 (let ((*print-base
* 16) (*print-radix
* t
))
1616 (output-integer (widetag-of object
) stream
)))))))))