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 (defvar *print-readably
* nil
17 "If true, all objects will be printed readably. If readable printing
18 is impossible, an error will be signalled. This overrides the value of
20 (defvar *print-escape
* t
21 "Should we print in a reasonably machine-readable way? (possibly
22 overridden by *PRINT-READABLY*)")
23 (defvar *print-pretty
* nil
; (set later when pretty-printer is initialized)
24 "Should pretty printing be used?")
25 (defvar *print-base
* 10.
26 "The output base for RATIONALs (including integers).")
27 (defvar *print-radix
* nil
28 "Should base be verified when printing RATIONALs?")
29 (defvar *print-level
* nil
30 "How many levels should be printed before abbreviating with \"#\"?")
31 (defvar *print-length
* nil
32 "How many elements at any level should be printed before abbreviating
34 (defvar *print-vector-length
* nil
35 "Like *PRINT-LENGTH* but works on strings and bit-vectors.
36 Does not affect the cases that are already controlled by *PRINT-LENGTH*")
37 (defvar *print-circle
* nil
38 "Should we use #n= and #n# notation to preserve uniqueness in general (and
39 circularity in particular) when printing?")
40 (defvar *print-case
* :upcase
41 "What case should the printer should use default?")
42 (defvar *print-array
* t
43 "Should the contents of arrays be printed?")
44 (defvar *print-gensym
* t
45 "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
46 (defvar *print-lines
* nil
47 "The maximum number of lines to print per object.")
48 (defvar *print-right-margin
* nil
49 "The position of the right margin in ems (for pretty-printing).")
50 (defvar *print-miser-width
* nil
51 "If the remaining space between the current column and the right margin
52 is less than this, then print using ``miser-style'' output. Miser
53 style conditional newlines are turned on, and all indentations are
54 turned off. If NIL, never use miser mode.")
55 (defvar *print-pprint-dispatch
*
56 (sb-pretty::make-pprint-dispatch-table
#() nil nil
)
57 "The pprint-dispatch-table that controls how to pretty-print objects.")
58 (defvar *suppress-print-errors
* nil
59 "Suppress printer errors when the condition is of the type designated by this
60 variable: an unreadable object representing the error is printed instead.")
62 (define-load-time-global sb-pretty
::*standard-pprint-dispatch-table
* nil
)
63 (defun %with-standard-io-syntax
(function)
64 (declare (type function function
))
65 (declare (dynamic-extent function
))
66 (let ((*package
* #.
(find-package "COMMON-LISP-USER"))
69 (*print-case
* :upcase
)
76 (*print-miser-width
* nil
)
77 (*print-pprint-dispatch
* sb-pretty
::*standard-pprint-dispatch-table
*)
81 (*print-right-margin
* nil
)
83 (*read-default-float-format
* 'single-float
)
86 (*readtable
* *standard-readtable
*)
87 (*suppress-print-errors
* nil
)
88 (*print-vector-length
* nil
))
91 ;;;; routines to print objects
93 (macrolet ((def (fn doc
&rest forms
)
97 ,@(if (eq fn
'write
) '(stream))
98 ((:escape
*print-escape
*) *print-escape
*)
99 ((:radix
*print-radix
*) *print-radix
*)
100 ((:base
*print-base
*) *print-base
*)
101 ((:circle
*print-circle
*) *print-circle
*)
102 ((:pretty
*print-pretty
*) *print-pretty
*)
103 ((:level
*print-level
*) *print-level
*)
104 ((:length
*print-length
*) *print-length
*)
105 ((:case
*print-case
*) *print-case
*)
106 ((:array
*print-array
*) *print-array
*)
107 ((:gensym
*print-gensym
*) *print-gensym
*)
108 ((:readably
*print-readably
*) *print-readably
*)
109 ((:right-margin
*print-right-margin
*)
110 *print-right-margin
*)
111 ((:miser-width
*print-miser-width
*)
113 ((:lines
*print-lines
*) *print-lines
*)
114 ((:pprint-dispatch
*print-pprint-dispatch
*)
115 *print-pprint-dispatch
*)
116 ((:suppress-errors
*suppress-print-errors
*)
117 *suppress-print-errors
*))
119 (declare (explicit-check))
122 "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*."
123 (output-object object
(out-stream-from-designator stream
))
126 "Return the printed representation of OBJECT as a string."
127 (stringify-object object
)))
129 ;;; Same as a call to (WRITE OBJECT :STREAM STREAM), but returning OBJECT.
130 (defun %write
(object stream
)
131 (declare (explicit-check))
132 (output-object object
(out-stream-from-designator stream
))
135 (defun prin1 (object &optional stream
)
136 "Output a mostly READable printed representation of OBJECT on the specified
138 (declare (explicit-check))
139 (let ((*print-escape
* t
))
140 (output-object object
(out-stream-from-designator stream
)))
143 (defun princ (object &optional stream
)
144 "Output an aesthetic but not necessarily READable printed representation
145 of OBJECT on the specified STREAM."
146 (declare (explicit-check))
147 (let ((*print-escape
* nil
)
148 (*print-readably
* nil
))
149 (output-object object
(out-stream-from-designator stream
)))
152 (defun print (object &optional stream
)
153 "Output a newline, the mostly READable printed representation of OBJECT, and
154 space to the specified STREAM."
155 (declare (explicit-check))
156 (let ((stream (out-stream-from-designator stream
)))
158 (prin1 object stream
)
159 (write-char #\space stream
)
162 (defun pprint (object &optional stream
)
163 "Prettily output OBJECT preceded by a newline."
164 (declare (explicit-check))
165 (let ((*print-pretty
* t
)
167 (stream (out-stream-from-designator stream
)))
169 (output-object object stream
))
172 (defun prin1-to-string (object)
173 "Return the printed representation of OBJECT as a string with
175 (let ((*print-escape
* t
))
176 (stringify-object object
)))
178 (defun princ-to-string (object)
179 "Return the printed representation of OBJECT as a string with
181 (let ((*print-escape
* nil
)
182 (*print-readably
* nil
))
183 (stringify-object object
)))
185 ;;; This produces the printed representation of an object as a string.
186 ;;; The few ...-TO-STRING functions above call this.
187 (defun stringify-object (object)
190 (multiple-value-bind (fun pretty
)
191 (and *print-pretty
* (pprint-dispatch object
))
193 (%with-output-to-string
(stream)
194 (sb-pretty:output-pretty-object stream fun object
))
195 (let ((buffer-size (approx-chars-in-repr object
)))
196 (let* ((string (make-string buffer-size
:element-type
'base-char
197 :initial-element
(code-char 0)))
198 (stream (%make-finite-base-string-output-stream string
)))
199 (declare (inline %make-finite-base-string-output-stream
))
200 (declare (dynamic-extent stream
))
201 (output-integer object stream
*print-base
* *print-radix
*)
202 ;; ASSUMPTION: we use pre-zeroed memory for unboxed objects.
203 ;; So we can avoid calling %SHRINK-VECTOR, and instead directly
205 (setf (%array-fill-pointer string
)
206 (finite-base-string-output-stream-pointer stream
))
208 ;; Could do something for other numeric types, symbols, ...
210 (%with-output-to-string
(stream)
211 (output-object object stream
)))))
213 ;;; Estimate the number of chars in the printed representation of OBJECT.
214 ;;; The answer must be an overestimate or exact; never an underestimate.
215 (defun approx-chars-in-repr (object)
216 (declare (integer object
))
217 ;; Round *PRINT-BASE* down to the nearest lower power-of-2, call that N,
218 ;; and "guess" that the one character can represent N bits.
219 ;; This is exact for bases which are exactly a power-of-2, or an overestimate
220 ;; otherwise, as mandated by the finite output stream.
223 ;; base 2 or base 3 = 1 bit per character
224 ;; base 4 .. base 7 = 2 bits per character
225 ;; base 8 .. base 15 = 3 bits per character, etc
226 #(1 1 2 2 2 2 3 3 3 3 3 3 3 3
227 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 5 5 5 5 5)
228 '(vector (unsigned-byte 8)))
229 (- *print-base
* 2))))
230 (+ (if (minusp object
) 1 0) ; leading sign
231 (if *print-radix
* 4 0) ; #rNN or trailing decimal
232 (ceiling (if (fixnump object
)
233 sb-vm
:n-positive-fixnum-bits
234 (* (%bignum-length object
) sb-bignum
::digit-size
))
237 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
239 (defun print-not-readable-error (object stream
)
241 (error 'print-not-readable
:object object
)
243 :report
"Print unreadably."
244 (let ((*print-readably
* nil
))
245 (output-object object stream
)
248 :report
"Supply an object to be printed instead."
251 (read-evaluated-form "~@<Enter an object (evaluated): ~@:>"))
252 (output-object o stream
)
255 ;;; guts of PRINT-UNREADABLE-OBJECT
256 (defun %print-unreadable-object
(object stream flags
&optional body
)
257 (declare (type (or null function
) body
))
259 (print-not-readable-error object stream
)
260 (flet ((print-description (&aux
(type (logbitp 0 (truly-the (mod 4) flags
)))
261 (identity (logbitp 1 flags
)))
263 (write (type-of object
) :stream stream
:circle nil
264 :level nil
:length nil
)
265 ;; Do NOT insert a pprint-newline here.
266 ;; See ba34717602d80e5fd74d10e61f4729fb0d019a0c
267 (write-char #\space stream
))
271 (when (or body
(not type
))
272 (write-char #\space stream
))
274 (write-char #\
{ stream
)
275 (%output-integer-in-base
(get-lisp-obj-address object
) 16 stream
)
276 (write-char #\
} stream
))))
277 (cond ((print-pretty-on-stream-p stream
)
278 ;; Since we're printing prettily on STREAM, format the
279 ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
280 ;; not rebind the stream when it is already a pretty stream,
281 ;; so output from the body will go to the same stream.
282 (pprint-logical-block (stream nil
:prefix
"#<" :suffix
">")
283 (print-description)))
285 (write-string "#<" stream
)
287 (write-char #\
> stream
)))))
291 ;;;; circularity detection stuff
293 ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
294 ;;; (eventually) ends up with entries for every object printed. When
295 ;;; we are initially looking for circularities, we enter a T when we
296 ;;; find an object for the first time, and a 0 when we encounter an
297 ;;; object a second time around. When we are actually printing, the 0
298 ;;; entries get changed to the actual marker value when they are first
300 (defvar *circularity-hash-table
* nil
)
302 ;;; When NIL, we are just looking for circularities. After we have
303 ;;; found them all, this gets bound to 0. Then whenever we need a new
304 ;;; marker, it is incremented.
305 (defvar *circularity-counter
* nil
)
307 ;;; Check to see whether OBJECT is a circular reference, and return
308 ;;; something non-NIL if it is. If ASSIGN is true, reference
309 ;;; bookkeeping will only be done for existing entries, no new
310 ;;; references will be recorded. If ASSIGN is true, then the number to
311 ;;; use in the #n= and #n# noise is assigned at this time.
313 ;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
314 ;;; ASSIGN true, or the circularity detection noise will get confused
315 ;;; about when to use #n= and when to use #n#. If this returns non-NIL
316 ;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
317 ;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
318 ;;; you need to initiate the circularity detection noise, e.g. bind
319 ;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
320 ;;; (see #'OUTPUT-OBJECT for an example).
322 ;;; Circularity detection is done in two places, OUTPUT-OBJECT and
323 ;;; WITH-CIRCULARITY-DETECTION (which is used from PPRINT-LOGICAL-BLOCK).
324 ;;; These checks aren't really redundant (at least I can't really see
325 ;;; a clean way of getting by with the checks in only one of the places).
326 ;;; This causes problems when mixed with pprint-dispatching; an object is
327 ;;; marked as visited in OUTPUT-OBJECT, dispatched to a pretty printer
328 ;;; that uses PPRINT-LOGICAL-BLOCK (directly or indirectly), leading to
329 ;;; output like #1=#1#. The MODE parameter is used for detecting and
330 ;;; correcting this problem.
331 (defun check-for-circularity (object &optional assign
(mode t
))
332 (when (null *print-circle
*)
333 ;; Don't bother, nobody cares.
334 (return-from check-for-circularity nil
))
335 (let ((circularity-hash-table *circularity-hash-table
*))
337 ((null circularity-hash-table
)
338 (values nil
:initiate
))
339 ((null *circularity-counter
*)
340 (ecase (gethash object circularity-hash-table
)
343 (setf (gethash object circularity-hash-table
) mode
)
344 ;; We need to keep looking.
347 (setf (gethash object circularity-hash-table
)
348 :logical-block-circular
)
351 (cond ((eq mode
:logical-block
)
352 ;; We've seen the object before in output-object, and now
353 ;; a second time in a PPRINT-LOGICAL-BLOCK (for example
354 ;; via pprint-dispatch). Don't mark it as circular yet.
355 (setf (gethash object circularity-hash-table
)
360 (setf (gethash object circularity-hash-table
) 0)
361 ;; It's a circular reference.
363 ((0 :logical-block-circular
)
364 ;; It's a circular reference.
367 (let ((value (gethash object circularity-hash-table
)))
369 ((nil t
:logical-block
)
370 ;; If NIL, we found an object that wasn't there the
371 ;; first time around. If T or :LOGICAL-BLOCK, this
372 ;; object appears exactly once. Either way, just print
373 ;; the thing without any special processing. Note: you
374 ;; might argue that finding a new object means that
375 ;; something is broken, but this can happen. If someone
376 ;; uses the ~@<...~:> format directive, it conses a new
377 ;; list each time though format (i.e. the &REST list),
378 ;; so we will have different cdrs.
380 ;; A circular reference to something that will be printed
381 ;; as a logical block. Wait until we're called from
382 ;; PPRINT-LOGICAL-BLOCK with ASSIGN true before assigning the
385 ;; If mode is :LOGICAL-BLOCK and assign is false, return true
386 ;; to indicate that this object is circular, but don't assign
387 ;; it a number yet. This is necessary for cases like
388 ;; #1=(#2=(#2# . #3=(#1# . #3#))))).
389 (:logical-block-circular
390 (cond ((and (not assign
)
391 (eq mode
:logical-block
))
394 (eq mode
:logical-block
))
395 (let ((value (incf *circularity-counter
*)))
396 ;; first occurrence of this object: Set the counter.
397 (setf (gethash object circularity-hash-table
) value
)
403 (let ((value (incf *circularity-counter
*)))
404 ;; first occurrence of this object: Set the counter.
405 (setf (gethash object circularity-hash-table
) value
)
409 ;; second or later occurrence
412 ;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
413 ;;; you should go ahead and print the object. If it returns NIL, then
414 ;;; you should blow it off.
415 (defun handle-circularity (marker stream
)
418 ;; Someone forgot to initiate circularity detection.
419 (let ((*print-circle
* nil
))
420 (error "trying to use CHECK-FOR-CIRCULARITY when ~
421 circularity checking isn't initiated")))
423 ;; It's a second (or later) reference to the object while we are
424 ;; just looking. So don't bother groveling it again.
427 (write-char #\
# stream
)
428 (output-integer (abs marker
) stream
10 nil
)
429 (cond ((minusp marker
)
430 (write-char #\
# stream
)
433 (write-char #\
= stream
)
436 (defmacro with-circularity-detection
((object stream
) &body body
)
437 (with-unique-names (marker body-name
)
438 `(labels ((,body-name
()
440 (cond ((or (not *print-circle
*)
441 (uniquely-identified-by-print-p ,object
))
443 (*circularity-hash-table
*
444 (let ((,marker
(check-for-circularity ,object t
:logical-block
)))
446 (when (handle-circularity ,marker
,stream
)
450 (let ((*circularity-hash-table
* (make-hash-table :test
'eq
)))
451 (output-object ,object
*null-broadcast-stream
*)
452 (let ((*circularity-counter
* 0))
453 (let ((,marker
(check-for-circularity ,object t
456 (handle-circularity ,marker
,stream
)))
459 ;;;; level and length abbreviations
461 ;;; The current level we are printing at, to be compared against
462 ;;; *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to
463 ;;; depth abbreviation.
464 (defvar *current-level-in-print
* 0)
465 (declaim (index *current-level-in-print
*))
467 ;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too
468 ;;; deep, then a #\# is printed to STREAM and BODY is ignored.
469 (defmacro descend-into
((stream) &body body
)
470 (let ((flet-name (gensym "DESCEND")))
471 `(flet ((,flet-name
()
473 (cond ((and (null *print-readably
*)
474 (let ((level *print-level
*))
475 (and level
(>= *current-level-in-print
* level
))))
476 (write-char #\
# ,stream
))
478 (let ((*current-level-in-print
* (1+ *current-level-in-print
*)))
481 ;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and
482 ;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from
483 ;;; the block named NIL.
484 (defmacro punt-print-if-too-long
(index stream
)
485 `(when (and (not *print-readably
*)
486 (let ((len *print-length
*))
487 (and len
(>= ,index len
))))
488 (write-string "..." ,stream
)
492 ;;;; OUTPUT-OBJECT -- the main entry point
494 ;;; Objects whose print representation identifies them EQLly don't
495 ;;; need to be checked for circularity.
496 (defun uniquely-identified-by-print-p (x)
500 (sb-xc:symbol-package x
))))
502 (defvar *in-print-error
* nil
)
504 ;;; Output OBJECT to STREAM observing all printer control variables.
505 (defun output-object (object stream
)
506 ;; FIXME: this function is declared EXPLICIT-CHECK, so it allows STREAM
507 ;; to be T or NIL (a stream-designator), which is not really right
508 ;; if eventually the call will be to a PRINT-OBJECT method,
509 ;; since the generic function should always receive a stream.
510 (declare (explicit-check))
511 (labels ((print-it (stream)
512 (multiple-value-bind (fun pretty
)
513 (and *print-pretty
* (pprint-dispatch object
))
515 (sb-pretty:output-pretty-object stream fun object
)
516 (output-ugly-object stream object
))))
518 (if *suppress-print-errors
*
522 (when (typep condition
*suppress-print-errors
*)
523 (cond (*in-print-error
*
524 (write-string "(error printing " stream
)
525 (write-string *in-print-error
* stream
)
526 (write-string ")" stream
))
528 (let ((*print-readably
* nil
)
531 "#<error printing a " stream
)
532 (let ((*in-print-error
* "type"))
533 (output-object (type-of object
) stream
))
534 (write-string ": " stream
)
535 (let ((*in-print-error
* "condition"))
536 (output-object condition stream
))
537 (write-string ">" stream
))))
538 (return-from handle-it object
)))))
542 (multiple-value-bind (marker initiate
)
543 (check-for-circularity object t
)
544 (if (eq initiate
:initiate
)
545 (let ((*circularity-hash-table
*
546 (make-hash-table :test
'eq
)))
547 (check-it *null-broadcast-stream
*)
548 (let ((*circularity-counter
* 0))
552 (when (handle-circularity marker stream
)
554 (handle-it stream
))))))
555 (cond (;; Maybe we don't need to bother with circularity detection.
556 (or (not *print-circle
*)
557 (uniquely-identified-by-print-p object
))
559 (;; If we have already started circularity detection, this
560 ;; object might be a shared reference. If we have not, then
561 ;; if it is a compound object it might contain a circular
562 ;; reference to itself or multiple shared references.
563 (or *circularity-hash-table
*
564 (compound-object-p object
))
567 (handle-it stream
)))))
569 ;;; Output OBJECT to STREAM observing all printer control variables
570 ;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
571 ;;; then the pretty printer will be used for any components of OBJECT,
572 ;;; just not for OBJECT itself.
573 (defun output-ugly-object (stream object
)
574 (when (%instancep object
)
575 (let ((layout (%instance-layout object
)))
576 ;; If an instance has no layout, do something sensible. Can't compare layout
577 ;; to 0 using EQ or EQL because that would be tautologically NIL as per fndb.
578 ;; This is better than declaring EQ or %INSTANCE-LAYOUT notinline.
579 (unless (logtest (get-lisp-obj-address layout
) sb-vm
:widetag-mask
)
580 (return-from output-ugly-object
581 (print-unreadable-object (object stream
:identity t
)
582 (prin1 'instance stream
))))
583 (let ((classoid (layout-classoid layout
)))
584 ;; Additionally, don't crash if the object is an obsolete thing with
585 ;; no update protocol.
586 (when (or (sb-kernel::undefined-classoid-p classoid
)
587 (and (layout-invalid layout
)
588 (logtest (layout-flags layout
)
589 (logior +structure-layout-flag
+
590 +condition-layout-flag
+))))
591 (return-from output-ugly-object
592 (print-unreadable-object (object stream
:identity t
)
593 (format stream
"UNPRINTABLE instance of ~W" classoid
)))))))
594 (when (funcallable-instance-p object
)
595 (let ((layout (%fun-layout object
)))
596 (unless (logtest (get-lisp-obj-address layout
) sb-vm
:widetag-mask
)
597 (return-from output-ugly-object
598 (print-unreadable-object (object stream
:identity t
)
599 (prin1 'funcallable-instance stream
))))))
600 (print-object object stream
))
604 (defmethod print-object ((object symbol
) stream
)
605 (if (or *print-escape
* *print-readably
*)
606 ;; Write so that reading back works
607 (output-symbol object
(sb-xc:symbol-package object
) stream
)
608 ;; Write only the characters of the name, never the package
609 (let ((rt *readtable
*))
610 (output-symbol-case-dispatch *print-case
* (readtable-case rt
)
611 (symbol-name object
) stream rt
))))
613 (defun output-symbol (symbol package stream
)
614 (let* ((readably *print-readably
*)
615 (readtable (if readably
*standard-readtable
* *readtable
*))
616 (print-case *print-case
*)
617 (readtable-case (readtable-case readtable
)))
618 (flet ((output-token (name)
619 (declare (type simple-string name
))
620 (cond ((or (and (readtable-normalization readtable
)
621 (not (sb-unicode:normalized-p name
:nfkc
)))
622 (symbol-quotep name readtable
))
623 ;; Output NAME surrounded with |'s,
624 ;; and with any embedded |'s or \'s escaped.
625 (write-char #\| stream
)
626 (dotimes (index (length name
))
627 (let ((char (char name index
)))
628 ;; Hmm. Should these depend on what characters
629 ;; are actually escapes in the readtable ?
630 ;; (See similar remark at DEFUN QUOTE-STRING)
631 (when (or (char= char
#\\) (char= char
#\|
))
632 (write-char #\\ stream
))
633 (write-char char stream
)))
634 (write-char #\| stream
))
636 (output-symbol-case-dispatch print-case readtable-case
637 name stream readtable
)))))
638 (let ((name (symbol-name symbol
))
639 (current (sane-package)))
641 ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
642 ;; requires that keywords be printed with preceding colons
643 ;; always, regardless of the value of *PACKAGE*.
644 ((eq package
*keyword-package
*)
645 (write-char #\
: stream
))
646 ;; Otherwise, if the symbol's home package is the current
647 ;; one, then a prefix is never necessary.
648 ((eq package current
))
649 ;; Uninterned symbols print with a leading #:.
651 (when (or *print-gensym
* readably
)
652 (write-string "#:" stream
)))
654 (multiple-value-bind (found accessible
) (find-symbol name current
)
655 ;; If we can find the symbol by looking it up, it need not
656 ;; be qualified. This can happen if the symbol has been
657 ;; inherited from a package other than its home package.
659 ;; To preserve print-read consistency, use the local nickname if
661 (unless (and accessible
(eq found symbol
))
662 (output-token (or (package-local-nickname package current
)
663 (package-name package
)))
664 (write-string (if (symbol-externalp symbol package
) ":" "::")
666 (output-token name
)))))
668 ;;;; escaping symbols
670 ;;; When we print symbols we have to figure out if they need to be
671 ;;; printed with escape characters. This isn't a whole lot easier than
672 ;;; reading symbols in the first place.
674 ;;; For each character, the value of the corresponding element is a
675 ;;; fixnum with bits set corresponding to attributes that the
676 ;;; character has. All characters have at least one bit set, so we can
677 ;;; search for any character with a positive test.
679 ;;; constants which are a bit-mask for each interesting character attribute
680 (defconstant other-attribute
(ash 1 0)) ; Anything else legal.
681 (defconstant number-attribute
(ash 1 1)) ; A numeric digit.
682 (defconstant uppercase-attribute
(ash 1 2)) ; An uppercase letter.
683 (defconstant lowercase-attribute
(ash 1 3)) ; A lowercase letter.
684 (defconstant sign-attribute
(ash 1 4)) ; +-
685 (defconstant extension-attribute
(ash 1 5)) ; ^_
686 (defconstant dot-attribute
(ash 1 6)) ; .
687 (defconstant slash-attribute
(ash 1 7)) ; /
688 (defconstant funny-attribute
(ash 1 8)) ; Anything illegal.
690 ;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
691 ;;; that don't need to be escaped (according to READTABLE-CASE.)
692 (defconstant-eqx +attribute-names
+
693 '((number . number-attribute
) (lowercase . lowercase-attribute
)
694 (uppercase . uppercase-attribute
) (letter . letter-attribute
)
695 (sign . sign-attribute
) (extension . extension-attribute
)
696 (dot . dot-attribute
) (slash . slash-attribute
)
697 (other . other-attribute
) (funny . funny-attribute
))
700 ;;; For each character, the value of the corresponding element is the
701 ;;; lowest base in which that character is a digit.
702 (defconstant-eqx +digit-bases
+
703 #.
(let ((a (sb-xc:make-array base-char-code-limit
704 :retain-specialization-for-after-xc-core t
705 :element-type
'(unsigned-byte 8)
706 :initial-element
36)))
708 (let ((char (digit-char i
36)))
709 (setf (aref a
(char-code char
)) i
))))
712 (defconstant-eqx +character-attributes
+
713 #.
(let ((a (sb-xc:make-array
160 ; FIXME
714 :retain-specialization-for-after-xc-core t
715 :element-type
'(unsigned-byte 16)
716 :initial-element
0)))
717 (flet ((set-bit (char bit
)
718 (let ((code (char-code char
)))
719 (setf (aref a code
) (logior bit
(aref a code
))))))
721 (dolist (char '(#\
! #\
@ #\$
#\%
#\
& #\
* #\
= #\~
#\
[ #\
] #\
{ #\
}
723 (set-bit char other-attribute
))
726 (set-bit (digit-char i
) number-attribute
))
728 (do ((code (char-code #\A
) (1+ code
))
729 (end (char-code #\Z
)))
731 (declare (fixnum code end
))
732 (set-bit (code-char code
) uppercase-attribute
)
733 (set-bit (char-downcase (code-char code
)) lowercase-attribute
))
735 (set-bit #\- sign-attribute
)
736 (set-bit #\
+ sign-attribute
)
737 (set-bit #\^ extension-attribute
)
738 (set-bit #\_ extension-attribute
)
739 (set-bit #\. dot-attribute
)
740 (set-bit #\
/ slash-attribute
)
742 ;; Mark anything not explicitly allowed as funny.
743 (dotimes (i 160) ; FIXME
744 (when (zerop (aref a i
))
745 (setf (aref a i
) funny-attribute
))))
749 ;;; A FSM-like thingie that determines whether a symbol is a potential
750 ;;; number or has evil characters in it.
751 (defun symbol-quotep (name readtable
)
752 (declare (simple-string name
))
753 (macrolet ((advance (tag &optional
(at-end t
))
756 ,(if at-end
'(go TEST-SIGN
) '(return nil
)))
757 (setq current
(schar name index
)
758 code
(char-code current
)
760 ((< code
160) (aref attributes code
))
761 ((upper-case-p current
) uppercase-attribute
)
762 ((lower-case-p current
) lowercase-attribute
)
763 (t other-attribute
)))
766 (test (&rest attributes
)
778 `(and (< code
128) ; FIXME
779 (< (the fixnum
(aref bases code
)) base
))))
781 (prog ((len (length name
))
782 (attributes #.
+character-attributes
+)
783 (bases #.
+digit-bases
+)
786 (case (readtable-case readtable
)
787 (:upcase uppercase-attribute
)
788 (:downcase lowercase-attribute
)
789 (t (logior lowercase-attribute uppercase-attribute
))))
794 (declare (fixnum len base index bits code
))
797 TEST-SIGN
; At end, see whether it is a sign...
798 (return (not (test sign
)))
800 OTHER
; not potential number, see whether funny chars...
801 (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
804 (do ((i (1- index
) (1+ i
)))
805 ((= i len
) (return-from symbol-quotep nil
))
806 (unless (zerop (logand (let* ((char (schar name i
))
807 (code (char-code char
)))
809 ((< code
160) (aref attributes code
))
810 ((upper-case-p char
) uppercase-attribute
)
811 ((lower-case-p char
) lowercase-attribute
)
812 (t other-attribute
)))
814 (return-from symbol-quotep t
))))
819 (advance LAST-DIGIT-ALPHA
)
821 (when (test letter number other slash
) (advance OTHER nil
))
822 (when (char= current
#\.
) (advance DOT-FOUND
))
823 (when (test sign extension
) (advance START-STUFF nil
))
826 DOT-FOUND
; leading dots...
827 (when (test letter
) (advance START-DOT-MARKER nil
))
828 (when (digitp) (advance DOT-DIGIT
))
829 (when (test number other
) (advance OTHER nil
))
830 (when (test extension slash sign
) (advance START-DOT-STUFF nil
))
831 (when (char= current
#\.
) (advance DOT-FOUND
))
834 START-STUFF
; leading stuff before any dot or digit
837 (advance LAST-DIGIT-ALPHA
)
839 (when (test number other
) (advance OTHER nil
))
840 (when (test letter
) (advance START-MARKER nil
))
841 (when (char= current
#\.
) (advance START-DOT-STUFF nil
))
842 (when (test sign extension slash
) (advance START-STUFF nil
))
845 START-MARKER
; number marker in leading stuff...
846 (when (test letter
) (advance OTHER nil
))
849 START-DOT-STUFF
; leading stuff containing dot without digit...
850 (when (test letter
) (advance START-DOT-STUFF nil
))
851 (when (digitp) (advance DOT-DIGIT
))
852 (when (test sign extension dot slash
) (advance START-DOT-STUFF nil
))
853 (when (test number other
) (advance OTHER nil
))
856 START-DOT-MARKER
; number marker in leading stuff with dot..
857 ;; leading stuff containing dot without digit followed by letter...
858 (when (test letter
) (advance OTHER nil
))
861 DOT-DIGIT
; in a thing with dots...
862 (when (test letter
) (advance DOT-MARKER
))
863 (when (digitp) (advance DOT-DIGIT
))
864 (when (test number other
) (advance OTHER nil
))
865 (when (test sign extension dot slash
) (advance DOT-DIGIT
))
868 DOT-MARKER
; number marker in number with dot...
869 (when (test letter
) (advance OTHER nil
))
872 LAST-DIGIT-ALPHA
; previous char is a letter digit...
873 (when (or (digitp) (test sign slash
))
874 (advance ALPHA-DIGIT
))
875 (when (test letter number other dot
) (advance OTHER nil
))
878 ALPHA-DIGIT
; seen a digit which is a letter...
879 (when (or (digitp) (test sign slash
))
881 (advance LAST-DIGIT-ALPHA
)
882 (advance ALPHA-DIGIT
)))
883 (when (test letter
) (advance ALPHA-MARKER
))
884 (when (test number other dot
) (advance OTHER nil
))
887 ALPHA-MARKER
; number marker in number with alpha digit...
888 (when (test letter
) (advance OTHER nil
))
891 DIGIT
; seen only ordinary (non-alphabetic) numeric digits...
894 (advance ALPHA-DIGIT
)
896 (when (test number other
) (advance OTHER nil
))
897 (when (test letter
) (advance MARKER
))
898 (when (test extension slash sign
) (advance DIGIT
))
899 (when (char= current
#\.
) (advance DOT-DIGIT
))
902 MARKER
; number marker in a numeric number...
903 ;; ("What," you may ask, "is a 'number marker'?" It's something
904 ;; that a conforming implementation might use in number syntax.
905 ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".)
906 (when (test letter
) (advance OTHER nil
))
909 ;;;; case hackery: One of these functions is chosen to output symbol
910 ;;;; names according to the values of *PRINT-CASE* and READTABLE-CASE.
912 (declaim (start-block output-symbol-case-dispatch
))
915 ;;; READTABLE-CASE *PRINT-CASE*
917 ;;; :DOWNCASE :DOWNCASE
919 (defun output-preserve-symbol (pname stream readtable
)
920 (declare (ignore readtable
))
921 (write-string pname stream
))
924 ;;; READTABLE-CASE *PRINT-CASE*
925 ;;; :UPCASE :DOWNCASE
926 (defun output-lowercase-symbol (pname stream readtable
)
927 (declare (simple-string pname
) (ignore readtable
))
928 (dotimes (index (length pname
))
929 (let ((char (schar pname index
)))
930 (write-char (char-downcase char
) stream
))))
933 ;;; READTABLE-CASE *PRINT-CASE*
934 ;;; :DOWNCASE :UPCASE
935 (defun output-uppercase-symbol (pname stream readtable
)
936 (declare (simple-string pname
) (ignore readtable
))
937 (dotimes (index (length pname
))
938 (let ((char (schar pname index
)))
939 (write-char (char-upcase char
) stream
))))
942 ;;; READTABLE-CASE *PRINT-CASE*
943 ;;; :UPCASE :CAPITALIZE
944 ;;; :DOWNCASE :CAPITALIZE
945 (defun output-capitalize-symbol (pname stream readtable
)
946 (declare (simple-string pname
))
947 (let ((prev-not-alphanum t
)
948 (up (eq (readtable-case readtable
) :upcase
)))
949 (dotimes (i (length pname
))
950 (let ((char (char pname i
)))
952 (if (or prev-not-alphanum
(lower-case-p char
))
954 (char-downcase char
))
955 (if prev-not-alphanum
959 (setq prev-not-alphanum
(not (alphanumericp char
)))))))
962 ;;; READTABLE-CASE *PRINT-CASE*
964 (defun output-invert-symbol (pname stream readtable
)
965 (declare (simple-string pname
) (ignore readtable
))
968 (dotimes (i (length pname
))
969 (let ((ch (schar pname i
)))
970 (when (both-case-p ch
)
971 (if (upper-case-p ch
)
973 (setq all-upper nil
)))))
974 (cond (all-upper (output-lowercase-symbol pname stream nil
))
975 (all-lower (output-uppercase-symbol pname stream nil
))
977 (write-string pname stream
)))))
979 ;;; Call an output function based on PRINT-CASE and READTABLE-CASE.
980 (defun output-symbol-case-dispatch (print-case readtable-case name stream readtable
)
981 (ecase readtable-case
984 (:upcase
(output-preserve-symbol name stream readtable
))
985 (:downcase
(output-lowercase-symbol name stream readtable
))
986 (:capitalize
(output-capitalize-symbol name stream readtable
))))
989 (:upcase
(output-uppercase-symbol name stream readtable
))
990 (:downcase
(output-preserve-symbol name stream readtable
))
991 (:capitalize
(output-capitalize-symbol name stream readtable
))))
992 (:preserve
(output-preserve-symbol name stream readtable
))
993 (:invert
(output-invert-symbol name stream readtable
))))
995 (declaim (end-block))
997 ;;;; recursive objects
999 (defmethod print-object ((list cons
) stream
)
1000 (descend-into (stream)
1001 (write-char #\
( stream
)
1005 (punt-print-if-too-long length stream
)
1006 (output-object (pop list
) stream
)
1009 (when (or (atom list
)
1010 (check-for-circularity list
))
1011 (write-string " . " stream
)
1012 (output-object list stream
)
1014 (write-char #\space stream
)
1016 (write-char #\
) stream
)))
1018 (defmethod print-object ((vector vector
) stream
)
1019 (let ((readably *print-readably
*))
1020 (flet ((cut-length ()
1021 (when (and (not readably
)
1022 *print-vector-length
*
1023 (> (length vector
) *print-vector-length
*))
1024 (print-unreadable-object (vector stream
:type t
:identity t
)
1025 (format stream
"~A..."
1026 (make-array *print-vector-length
*
1027 :element-type
(array-element-type vector
)
1028 :displaced-to vector
)))
1030 (cond ((stringp vector
)
1031 (cond ((and readably
(not (typep vector
'(vector character
))))
1032 (output-unreadable-array-readably vector stream
))
1033 ((and *print-escape
*
1035 ((or *print-escape
* readably
)
1036 (write-char #\" stream
)
1037 (quote-string vector stream
)
1038 (write-char #\" stream
))
1040 (write-string vector stream
))))
1041 ((or (null (array-element-type vector
))
1042 (not (or *print-array
* readably
)))
1043 (output-terse-array vector stream
))
1044 ((bit-vector-p vector
)
1045 (cond ((cut-length))
1047 (write-string "#*" stream
)
1048 (dovector (bit vector
)
1049 ;; (Don't use OUTPUT-OBJECT here, since this code
1050 ;; has to work for all possible *PRINT-BASE* values.)
1051 (write-char (if (zerop bit
) #\
0 #\
1) stream
)))))
1052 ((or (not readably
) (array-readably-printable-p vector
))
1053 (descend-into (stream)
1054 (write-string "#(" stream
)
1055 (dotimes (i (length vector
))
1057 (write-char #\space stream
))
1058 (punt-print-if-too-long i stream
)
1059 (output-object (aref vector i
) stream
))
1060 (write-string ")" stream
)))
1063 (output-unreadable-array-readably vector stream
))))))
1065 ;;; Output a string, quoting characters to be readable by putting a slash in front
1066 ;;; of any character satisfying NEEDS-SLASH-P.
1067 (defun quote-string (string stream
)
1068 (macrolet ((needs-slash-p (char)
1069 ;; KLUDGE: We probably should look at the readtable, but just do
1070 ;; this for now. [noted by anonymous long ago] -- WHN 19991130
1071 `(let ((c ,char
)) (or (char= c
#\\) (char= c
#\"))))
1073 ;; Pre-test for any escaping, and if needed, do char-at-a-time output.
1074 ;; For 1 or 0 characters, always take the WRITE-CHAR branch.
1075 `(let ((data (truly-the ,type data
)))
1076 (declare (optimize (sb-c:insert-array-bounds-checks
0)))
1077 (when (or (<= (- end start
) 1)
1078 (do ((index start
(1+ index
)))
1080 (when (needs-slash-p (schar data index
)) (return t
))))
1081 (do ((index start
(1+ index
)))
1082 ((>= index end
) (return-from quote-string
))
1083 (let ((char (schar data index
)))
1084 (when (needs-slash-p char
) (write-char #\\ stream
))
1085 (write-char char stream
)))))))
1086 (with-array-data ((data string
) (start) (end)
1087 :check-fill-pointer t
)
1088 (if (simple-base-string-p data
)
1089 (scan simple-base-string
)
1090 #+sb-unicode
(scan simple-character-string
)))
1091 ;; If no escaping needed, WRITE-STRING is way faster, up to 2x in my testing,
1092 ;; than WRITE-CHAR because the stream layer will get so many fewer calls.
1093 (write-string string stream
)))
1095 (defun array-readably-printable-p (array)
1096 (and (eq (array-element-type array
) t
)
1097 (let ((zero (position 0 (array-dimensions array
)))
1098 (number (position 0 (array-dimensions array
)
1099 :test
(complement #'eql
)
1101 (or (null zero
) (null number
) (> zero number
)))))
1103 ;;; Output the printed representation of any array in either the #< or #A
1105 (defmethod print-object ((array array
) stream
)
1106 (if (and (or *print-array
* *print-readably
*) (array-element-type array
))
1107 (output-array-guts array stream
)
1108 (output-terse-array array stream
)))
1110 ;;; Output the abbreviated #< form of an array.
1111 (defun output-terse-array (array stream
)
1112 (let ((*print-level
* nil
)
1113 (*print-length
* nil
))
1114 (if (and (not (array-element-type array
)) *print-readably
* *read-eval
*)
1115 (format stream
"#.(~S '~D :ELEMENT-TYPE ~S)"
1116 'make-array
(array-dimensions array
) nil
)
1117 (print-unreadable-object (array stream
:type t
:identity t
)))))
1119 ;;; Convert an array into a list that can be used with MAKE-ARRAY's
1120 ;;; :INITIAL-CONTENTS keyword argument.
1121 (defun listify-array (array)
1122 (flet ((compact (seq)
1125 (coerce seq
'(simple-array character
(*))))
1127 (coerce seq
'bit-vector
))
1130 (if (typep array
'(or string bit-vector
))
1132 (with-array-data ((data array
) (start) (end))
1133 (declare (ignore end
))
1134 (labels ((listify (dimensions index
)
1135 (if (null dimensions
)
1137 (let* ((dimension (car dimensions
))
1138 (dimensions (cdr dimensions
))
1139 (count (reduce #'* dimensions
)))
1140 (loop for i below dimension
1141 for list
= (listify dimensions index
)
1142 collect
(if (and dimensions
1143 (null (cdr dimensions
)))
1146 do
(incf index count
))))))
1147 (listify (array-dimensions array
) start
))))))
1149 ;;; Use nonstandard #A(dimensions element-type contents)
1150 ;;; to avoid using #.
1151 (defun output-unreadable-array-readably (array stream
)
1152 (let ((array (list* (array-dimensions array
)
1153 (array-element-type array
)
1154 (listify-array array
))))
1155 (write-string "#A" stream
)
1156 (write array
:stream stream
)
1159 ;;; Output the readable #A form of an array.
1160 (defun output-array-guts (array stream
)
1161 (cond ((or (not *print-readably
*)
1162 (array-readably-printable-p array
))
1163 (write-char #\
# stream
)
1164 (output-integer (array-rank array
) stream
10 nil
)
1165 (write-char #\A stream
)
1166 (with-array-data ((data array
) (start) (end))
1167 (declare (ignore end
))
1168 (sub-output-array-guts data
(array-dimensions array
) stream start
)))
1170 (output-unreadable-array-readably array stream
))))
1172 (defun sub-output-array-guts (array dimensions stream index
)
1173 (declare (type (simple-array * (*)) array
) (fixnum index
))
1174 (cond ((null dimensions
)
1175 (output-object (aref array index
) stream
))
1177 (descend-into (stream)
1178 (write-char #\
( stream
)
1179 (let* ((dimension (car dimensions
))
1180 (dimensions (cdr dimensions
))
1181 (count (reduce #'* dimensions
)))
1182 (dotimes (i dimension
)
1184 (write-char #\space stream
))
1185 (punt-print-if-too-long i stream
)
1186 (sub-output-array-guts array dimensions stream index
)
1187 (incf index count
)))
1188 (write-char #\
) stream
)))))
1191 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
1193 (defun %output-radix
(base stream
)
1194 (write-char #\
# stream
)
1195 (write-char (case base
1199 (t (%output-integer-in-base base
10 stream
) #\r))
1202 ;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is
1203 ;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called
1204 ;;; always prior a GC to drop overly large bignums from the cache.
1206 ;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or
1207 ;;; POWERS-FOR-BASE, see that you don't break the assumptions!
1208 (define-load-time-global *power-cache
* (make-array 37 :initial-element nil
))
1209 (declaim (type (simple-vector 37) *power-cache
*))
1211 (defconstant +power-cache-integer-length-limit
+ 2048)
1213 (defun scrub-power-cache (&aux
(cache *power-cache
*))
1214 (dotimes (i (length cache
))
1215 (let ((powers (aref cache i
)))
1217 (let ((too-big (position-if
1219 (>= (integer-length x
)
1220 +power-cache-integer-length-limit
+))
1221 (the simple-vector powers
))))
1223 (setf (aref cache i
) (subseq powers
0 too-big
))))))))
1225 ;;; Compute (and cache) a power vector for a BASE and LIMIT:
1226 ;;; the vector holds integers for which
1227 ;;; (aref powers k) == (expt base (expt 2 k))
1229 (defun powers-for-base (base limit
)
1230 (flet ((compute-powers (from)
1232 (do ((p from
(* p p
)))
1234 ;; We don't actually need this, but we also
1235 ;; prefer not to cons it up a second time...
1238 (nreverse powers
))))
1239 (let* ((cache *power-cache
*)
1240 (powers (aref cache base
)))
1241 (setf (aref cache base
)
1242 (concatenate 'vector powers
1245 (let* ((len (length powers
))
1246 (max (svref powers
(1- len
))))
1248 (return-from powers-for-base powers
)
1252 ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
1253 (defun %output-huge-integer-in-base
(n base stream
)
1254 (declare (type bignum n
) (type fixnum base
))
1255 ;; POWER is a vector for which the following holds:
1256 ;; (aref power k) == (expt base (expt 2 k))
1257 (let* ((power (powers-for-base base n
))
1258 (k-start (or (position-if (lambda (x) (> x n
)) power
)
1259 (bug "power-vector too short"))))
1260 (labels ((bisect (n k exactp
)
1261 (declare (fixnum k
))
1262 ;; N is the number to bisect
1263 ;; K on initial entry BASE^(2^K) > N
1264 ;; EXACTP is true if 2^K is the exact number of digits
1267 (loop repeat
(ash 1 k
) do
(write-char #\
0 stream
))))
1270 (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n
)
1274 (multiple-value-bind (q r
) (truncate n
(aref power k
))
1275 ;; EXACTP is NIL only at the head of the
1276 ;; initial number, as we don't know the number
1277 ;; of digits there, but we do know that it
1278 ;; doesn't get any leading zeros.
1280 (bisect r k
(or exactp
(plusp q
))))))))
1281 (bisect n k-start nil
))))
1283 ;;; Not all architectures can stack-allocate lisp strings,
1284 ;;; but we can fake it using aliens.
1285 ;;; %output-integer-in-base always needs 8 lispwords:
1286 ;;; if n-word-bytes = 4 then 8 * 4 = 32 characters
1287 ;;; if n-word-bytes = 8 then 8 * 8 = 64 characters
1288 ;;; This allows for output in base 2 worst case.
1289 ;;; We don't need a trailing null.
1290 (defmacro with-lisp-string-on-alien-stack
((string size-in-chars
) &body body
)
1291 (let ((size-in-lispwords ; +2 words for lisp string header
1292 (+ 2 (align-up (ceiling (symbol-value size-in-chars
) sb-vm
:n-word-bytes
)
1296 ;; +1 is for alignment if needed
1297 `(with-alien ((,alien
(array unsigned
,(1+ size-in-lispwords
))))
1298 (let ((,sap
(alien-sap ,alien
)))
1299 (when (logtest (sap-int ,sap
) sb-vm
:lowtag-mask
)
1300 (setq ,sap
(sap+ ,sap sb-vm
:n-word-bytes
)))
1301 (setf (sap-ref-word ,sap
0) sb-vm
:simple-base-string-widetag
1302 (sap-ref-word ,sap sb-vm
:n-word-bytes
) (ash sb-vm
:n-word-bits
1303 sb-vm
:n-fixnum-tag-bits
))
1305 (truly-the simple-base-string
1306 (%make-lisp-obj
(logior (sap-int ,sap
)
1307 sb-vm
:other-pointer-lowtag
)))))
1310 ;;; Using specialized routines for the various cases seems to work nicely.
1312 ;;; Testing with 100,000 random integers, output to a sink stream, x86-64:
1313 ;;; word-sized integers, base >= 10
1314 ;;; old=.062 sec, 4MiB consed; new=.031 sec, 0 bytes consed
1315 ;;; word-sized integers, base < 10
1316 ;;; old=.104 sec, 4MiB consed; new=.075 sec, 0 bytes consed
1317 ;;; bignums in base 16:
1318 ;;; old=.125 sec, 20 MiB consed; new=.08 sec, 0 bytes consed
1320 ;;; Not sure why this didn't reduce consing on ppc64 when I tried it.
1321 (defun %output-integer-in-base
(integer base stream
)
1322 (declare (type (integer 2 36) base
))
1323 (when (minusp integer
)
1324 (write-char #\- stream
)
1325 (setf integer
(- integer
)))
1326 ;; Grrr - a LET binding here causes a constant-folding problem
1327 ;; "The function SB-KERNEL:SIMPLE-CHARACTER-STRING-P is undefined."
1328 ;; but a symbol-macrolet is ok. This is a FIXME except I don't care.
1329 (symbol-macrolet ((chars "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
1330 (declare (optimize (sb-c:insert-array-bounds-checks
0) speed
))
1331 (macrolet ((iterative-algorithm ()
1332 `(loop (multiple-value-bind (q r
)
1333 (truncate (truly-the word integer
) base
)
1335 (setf (aref buffer ptr
) (schar chars r
))
1336 (when (zerop (setq integer q
)) (return)))))
1337 (recursive-algorithm (dividend-type)
1338 `(named-let recurse
((n integer
))
1339 (multiple-value-bind (q r
) (truncate (truly-the ,dividend-type n
) base
)
1340 ;; Recurse until you have all the digits pushed on
1342 (unless (zerop q
) (recurse q
))
1343 ;; Then as each recursive call unwinds, turn the
1344 ;; digit (in remainder) into a character and output
1346 (write-char (schar chars r
) stream
)))))
1347 (cond ((typep integer
'word
) ; Division vops can handle this all inline.
1348 #+c-stack-is-control-stack
; strings can be DX-allocated
1349 ;; For bases exceeding 10 we know how many characters (at most)
1350 ;; will be output. This allows for a single %WRITE-STRING call.
1351 ;; There's diminishing payback for other bases because the fixed array
1352 ;; size increases, and we don't have a way to elide initial 0-fill.
1353 ;; Calling APPROX-CHARS-IN-REPL doesn't help much - we still 0-fill.
1355 (recursive-algorithm word
)
1356 (let* ((ptr #.
(length (write-to-string sb-ext
:most-positive-word
1358 (buffer (make-array ptr
:element-type
'base-char
)))
1359 (declare (dynamic-extent buffer
))
1360 (iterative-algorithm)
1361 (%write-string buffer stream ptr
(length buffer
))))
1362 #-c-stack-is-control-stack
; strings can't be DX-allocated
1363 ;; Use the alien stack, which is not as fast as using the control stack
1364 ;; (when we can). Even the absence of 0-fill doesn't make up for it.
1365 ;; Since we've no choice in the matter, might as well allow
1366 ;; any value of BASE - it's just a few more words of storage.
1367 (let ((ptr sb-vm
:n-word-bits
))
1368 (with-lisp-string-on-alien-stack (buffer sb-vm
:n-word-bits
)
1369 (iterative-algorithm)
1370 (%write-string buffer stream ptr sb-vm
:n-word-bits
))))
1372 ;; No division is involved at all.
1373 ;; could also specialize for bases 32, 8, 4, and 2 if desired
1374 (loop for pos from
(* 4 (1- (ceiling (integer-length integer
) 4)))
1376 do
(write-char (schar chars
(sb-bignum::ldb-bignum
=>fixnum
4 pos
1379 ;; The ideal cutoff point between this and the "huge" algorithm
1380 ;; might be platform-specific, and it also could depend on the output base.
1381 ;; Nobody has cared to tweak it in so many years that I think we can
1382 ;; arbitrarily say 3 bigdigits is fine.
1383 ((<= (sb-bignum:%bignum-length
(truly-the bignum integer
)) 3)
1384 (recursive-algorithm integer
))
1386 (%output-huge-integer-in-base integer base stream
)))))
1389 ;;; This gets both a method and a specifically named function
1390 ;;; since the latter is called from a few places.
1391 (defmethod print-object ((object integer
) stream
)
1392 (output-integer object stream
*print-base
* *print-radix
*))
1393 (defun output-integer (integer stream base radixp
)
1395 (unless (= base
10) (%output-radix base stream
))
1396 (%output-integer-in-base integer base stream
)
1397 (when (= base
10) (write-char #\. stream
)))
1399 (%output-integer-in-base integer base stream
))))
1401 (defmethod print-object ((ratio ratio
) stream
)
1402 (let ((base *print-base
*))
1404 (%output-radix base stream
))
1405 (%output-integer-in-base
(numerator ratio
) base stream
)
1406 (write-char #\
/ stream
)
1407 (%output-integer-in-base
(denominator ratio
) base stream
)))
1409 (defmethod print-object ((complex complex
) stream
)
1410 (write-string "#C(" stream
)
1411 (output-object (realpart complex
) stream
)
1412 (write-char #\space stream
)
1413 (output-object (imagpart complex
) stream
)
1414 (write-char #\
) stream
))
1418 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
1419 ;;; most of the work for all printing of floating point numbers in
1420 ;;; FORMAT. It converts a floating point number to a string in a free
1421 ;;; or fixed format with no exponent. The interpretation of the
1422 ;;; arguments is as follows:
1424 ;;; X - The floating point number to convert, which must not be
1426 ;;; WIDTH - The preferred field width, used to determine the number
1427 ;;; of fraction digits to produce if the FDIGITS parameter
1428 ;;; is unspecified or NIL. If the non-fraction digits and the
1429 ;;; decimal point alone exceed this width, no fraction digits
1430 ;;; will be produced unless a non-NIL value of FDIGITS has been
1431 ;;; specified. Field overflow is not considerd an error at this
1433 ;;; FDIGITS - The number of fractional digits to produce. Insignificant
1434 ;;; trailing zeroes may be introduced as needed. May be
1435 ;;; unspecified or NIL, in which case as many digits as possible
1436 ;;; are generated, subject to the constraint that there are no
1437 ;;; trailing zeroes.
1438 ;;; SCALE - If this parameter is specified or non-NIL, then the number
1439 ;;; printed is (* x (expt 10 scale)). This scaling is exact,
1440 ;;; and cannot lose precision.
1441 ;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1442 ;;; number of fraction digits which will be produced, regardless
1443 ;;; of the value of WIDTH or FDIGITS. This feature is used by
1444 ;;; the ~E format directive to prevent complete loss of
1445 ;;; significance in the printed value due to a bogus choice of
1449 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1450 ;;; where the results have the following interpretation:
1452 ;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1453 ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1454 ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1456 ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1458 ;;; POINT-POS - The position of the digit preceding the decimal
1459 ;;; point. Zero indicates point before first digit.
1461 ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
1462 ;;; accuracy. Specifically, the decimal number printed is the closest
1463 ;;; possible approximation to the true value of the binary number to
1464 ;;; be printed from among all decimal representations with the same
1465 ;;; number of digits. In free-format output, i.e. with the number of
1466 ;;; digits unconstrained, it is guaranteed that all the information is
1467 ;;; preserved, so that a properly- rounding reader can reconstruct the
1468 ;;; original binary number, bit-for-bit, from its printed decimal
1469 ;;; representation. Furthermore, only as many digits as necessary to
1470 ;;; satisfy this condition will be printed.
1472 ;;; FLOAT-DIGITS actually generates the digits for positive numbers;
1473 ;;; see below for comments.
1475 (defun flonum-to-string (x &optional width fdigits scale fmin
)
1476 (declare (type float x
))
1477 (multiple-value-bind (e string
)
1479 (flonum-to-digits x
(min (- (+ fdigits
(or scale
0)))
1481 (if (and width
(> width
1))
1482 (let ((w (multiple-value-list
1486 (if (and scale
(minusp scale
))
1489 (f (multiple-value-list
1490 (flonum-to-digits x
(- (+ (or fmin
0)
1491 (if scale scale
0)))))))
1493 ((>= (length (cadr w
)) (length (cadr f
)))
1495 (t (values-list f
))))
1496 (flonum-to-digits x
)))
1497 (let ((e (if (zerop x
)
1499 (+ e
(or scale
0))))
1500 (stream (make-string-output-stream)))
1503 (write-string string stream
:end
(min (length string
) e
))
1504 (dotimes (i (- e
(length string
)))
1505 (write-char #\
0 stream
))
1506 (write-char #\. stream
)
1507 (write-string string stream
:start
(min (length string
) e
))
1509 (dotimes (i (- fdigits
1511 (min (length string
) e
))))
1512 (write-char #\
0 stream
))))
1514 (write-string "." stream
)
1516 (write-char #\
0 stream
))
1517 (write-string string stream
:end
(when fdigits
1518 (min (length string
)
1522 (dotimes (i (+ fdigits e
(- (length string
))))
1523 (write-char #\
0 stream
)))))
1524 (let ((string (get-output-stream-string stream
)))
1525 (values string
(length string
)
1526 (char= (char string
0) #\.
)
1527 (char= (char string
(1- (length string
))) #\.
)
1528 (position #\. string
))))))
1530 ;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
1531 ;;; extended in order to handle rounding.
1533 ;;; As the implementation of the Dragon from Classic CMUCL (and
1534 ;;; previously in SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN
1535 ;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE
1536 ;;; PAPER!", and in this case we have to add that even reading the
1537 ;;; paper might not bring immediate illumination as CSR has attempted
1538 ;;; to turn idiomatic Scheme into idiomatic Lisp.
1540 ;;; possible extension for the enthusiastic: printing floats in bases
1541 ;;; other than base 10.
1542 (defconstant single-float-min-e
1543 (- 2 sb-vm
:single-float-bias sb-vm
:single-float-digits
))
1544 (defconstant double-float-min-e
1545 (- 2 sb-vm
:double-float-bias sb-vm
:double-float-digits
))
1547 (defconstant long-float-min-e
1548 (nth-value 1 (decode-float least-positive-long-float
)))
1550 ;;; Call CHAR-FUN with the digits of FLOAT
1551 ;;; PROLOGUE-FUN and EPILOGUE-FUN are called with the exponent before
1552 ;;; and after printing to set up the state.
1553 (declaim (inline %flonum-to-digits
))
1554 (defun %flonum-to-digits
(char-fun
1557 float
&optional position relativep
)
1558 (let ((print-base 10) ; B
1560 (float-digits (float-digits float
)) ; p
1563 (single-float single-float-min-e
)
1564 (double-float double-float-min-e
)
1566 (long-float long-float-min-e
))))
1567 (multiple-value-bind (f e
) (integer-decode-float float
)
1568 ;; An extra step became necessary here for subnormals because the
1569 ;; algorithm assumes that the fraction is left-aligned in a field
1570 ;; that is FLOAT-DIGITS wide.
1571 (when (< (float-precision float
) float-digits
)
1572 (let ((shift (- float-digits
(integer-length f
))))
1573 (setq f
(ash f shift
)
1575 (let (;; FIXME: these even tests assume normal IEEE rounding
1576 ;; mode. I wonder if we should cater for non-normal?
1580 (svref #.
(coerce (loop for i from
0 to
972 collect
(expt 2 i
))
1583 (svref #.
(coerce (loop for i from
0 to
323 collect
(expt 10 i
))
1586 (let ((est (truly-the (integer -
323 309)
1587 (ceiling (- (* (+ e
(integer-length (truly-the sb-kernel
:double-float-significand f
)) -
1)
1591 (fixup r
(* s
(expt10 est
)) m
+ m- est
)
1592 (let ((scale (expt10 (- est
))))
1594 s
(* m
+ scale
) (* m- scale
) est
)))))
1596 (fixup (r s m
+ m- k
)
1597 (let ((r+m
+ (+ r m
+)))
1603 (funcall prologue-fun k
)
1604 (generate r s m
+ m-
)
1605 (funcall epilogue-fun k
)))
1606 (generate (r s m
+ m-
)
1610 (setf (values d r
) (truncate (* r print-base
) s
))
1611 (setf m
+ (* m
+ print-base
))
1612 (setf m-
(* m- print-base
))
1613 (setf tc1
(or (< r m-
) (and low-ok
(= r m-
))))
1614 (setf tc2
(let ((r+m
+ (+ r m
+)))
1616 (and high-ok
(= r
+m
+ s
)))))
1619 (funcall char-fun d
)
1623 ((and (not tc1
) tc2
) (1+ d
))
1624 ((and tc1
(not tc2
)) d
)
1629 (funcall char-fun d
)))))
1630 (scale-p (r s m
+ m-
)
1632 (aver (> position
0))
1634 ;; running out of letters here
1635 (l 1 (* l print-base
)))
1636 ((>= (* s l
) (+ r m
+))
1638 (if (< (+ r
(* s
(/ (expt print-base
(- k position
)) 2)))
1640 (setf position
(- k position
))
1641 (setf position
(- k position
1))))))
1642 (let* ((x (/ (* s
(expt print-base position
)) 2))
1651 (do ((r+m
+ (+ r m
+))
1653 (s s
(* s print-base
)))
1654 ((not (or (> r
+m
+ s
)
1655 (and high-ok
(= r
+m
+ s
))))
1657 (r r
(* r print-base
))
1658 (m+ m
+ (* m
+ print-base
))
1659 (m- m-
(* m- print-base
)))
1660 ((not (and (> r m-
) ; Extension to handle zero
1661 (let ((x (* (+ r m
+) print-base
)))
1665 (funcall prologue-fun k
)
1666 (generate r s m
+ m-
)
1667 (funcall epilogue-fun k
)))))))
1670 (let ((be (expt2 e
)))
1672 (if (/= f
(expt float-radix
(1- float-digits
)))
1673 (setf r
(ash f
(+ e
1))
1676 (setf m
+ (expt2 (1+ e
))
1678 s
(* float-radix
2)))))
1680 (/= f
(expt float-radix
(1- float-digits
))))
1682 s
(expt float-radix
(- 1 e
))
1686 (setf r
(* f float-radix
2)
1687 s
(expt float-radix
(- 2 e
))
1692 (scale r s m
+ m-
))))))))
1694 (defun flonum-to-digits (float &optional position relativep
)
1697 (let ((digit-characters "0123456789"))
1698 (with-push-char (:element-type base-char
)
1701 (push-char (char digit-characters d
)))
1703 (lambda (k) (values k
(get-pushed-string)))
1704 float position relativep
)))))
1706 (defun print-float (float stream
)
1709 (digit-characters "0123456789")
1714 (when (= position dot-position
)
1715 (write-char #\. stream
))
1716 (write-char (char digit-characters d
) stream
)
1719 (cond ((not (< e-min k e-max
))
1720 (setf dot-position
1))
1722 (setf dot-position k
))
1724 (setf dot-position -
1)
1725 (write-char #\
0 stream
)
1726 (write-char #\. stream
)
1727 (loop for i below
(- k
)
1728 do
(write-char #\
0 stream
)))))
1730 (when (<= position dot-position
)
1731 (loop for i below
(- dot-position position
)
1732 do
(write-char #\
0 stream
))
1733 (write-char #\. stream
)
1734 (write-char #\
0 stream
))
1735 (if (< e-min k e-max
)
1736 (print-float-exponent float
0 stream
)
1737 (print-float-exponent float
(1- k
) stream
)))
1740 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
1741 ;;; a new floating point number Z in the range (0.1, 1.0] and an
1742 ;;; exponent E such that Z * 10^E is (approximately) equal to the
1743 ;;; original number. There may be some loss of precision due the
1744 ;;; floating point representation. The scaling is always done with
1745 ;;; long float arithmetic, which helps printing of lesser precisions
1746 ;;; as well as avoiding generic arithmetic.
1748 ;;; When computing our initial scale factor using EXPT, we pull out
1749 ;;; part of the computation to avoid over/under flow. When
1750 ;;; denormalized, we must pull out a large factor, since there is more
1751 ;;; negative exponent range than positive range.
1753 (defun scale-exponent (original-x)
1754 (let* ((x (coerce original-x
'long-float
)))
1755 (multiple-value-bind (sig exponent
) (decode-float x
)
1756 (declare (ignore sig
))
1758 (values (float 0.0l0 original-x
) 1)
1759 (let* ((ex (locally (declare (optimize (safety 0)))
1761 (round (* exponent
(log 2l0 10))))))
1763 (if (float-denormalized-p x
)
1765 (* x
1.0l16 (expt 10.0l0 (- (- ex
) 16)))
1767 (* x
1.0l18 (expt 10.0l0 (- (- ex
) 18)))
1768 (* x
10.0l0 (expt 10.0l0 (- (- ex
) 1))))
1769 (/ x
10.0l0 (expt 10.0l0 (1- ex
))))))
1770 (do ((d 10.0l0 (* d
10.0l0))
1774 (do ((m 10.0l0 (* m
10.0l0))
1778 (values (float z original-x
) ex
))
1779 (declare (long-float m
) (integer ex
))))
1780 (declare (long-float d
))))))))
1782 ;;;; entry point for the float printer
1784 ;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
1785 ;;; argument is printed free-format, in either exponential or
1786 ;;; non-exponential notation, depending on its magnitude.
1788 ;;; NOTE: When a number is to be printed in exponential format, it is
1789 ;;; scaled in floating point. Since precision may be lost in this
1790 ;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
1791 ;;; are lost. The difficulty is that FLONUM-TO-STRING performs
1792 ;;; extensive computations with integers of similar magnitude to that
1793 ;;; of the number being printed. For large exponents, the bignums
1794 ;;; really get out of hand. If bignum arithmetic becomes reasonably
1795 ;;; fast and the exponent range is not too large, then it might become
1796 ;;; attractive to handle exponential notation with the same accuracy
1797 ;;; as non-exponential notation, using the method described in the
1798 ;;; Steele and White paper.
1800 ;;; NOTE II: this has been bypassed slightly by implementing Burger
1801 ;;; and Dybvig, 1996. When someone has time (KLUDGE) they can
1802 ;;; probably (a) implement the optimizations suggested by Burger and
1803 ;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
1804 ;;; fixed-format printing.
1806 ;;; Print the appropriate exponent marker for X and the specified exponent.
1807 (defun print-float-exponent (x exp stream
)
1808 (declare (type float x
) (type integer exp
) (type stream stream
))
1809 (cond ((case *read-default-float-format
*
1810 ((short-float single-float
)
1811 (typep x
'single-float
))
1812 ((double-float #-long-float long-float
)
1813 (typep x
'double-float
))
1816 (typep x
'long-float
)))
1818 (write-char #\e stream
)
1819 (%output-integer-in-base exp
10 stream
)))
1828 (%output-integer-in-base exp
10 stream
))))
1830 (defmethod print-object ((x float
) stream
)
1832 ((float-infinity-or-nan-p x
)
1833 (if (float-infinity-p x
)
1834 (let ((symbol (etypecase x
1835 (single-float (if (minusp x
)
1836 'single-float-negative-infinity
1837 'single-float-positive-infinity
))
1838 (double-float (if (minusp x
)
1839 'double-float-negative-infinity
1840 'double-float-positive-infinity
)))))
1842 (write-string "#." stream
)
1843 (output-symbol symbol
(sb-xc:symbol-package symbol
) stream
))
1845 (print-unreadable-object (x stream
)
1846 (output-symbol symbol
(sb-xc:symbol-package symbol
) stream
)))))
1847 (print-unreadable-object (x stream
)
1848 (princ (float-format-name x
) stream
)
1849 (write-string (if (float-trapping-nan-p x
) " trapping" " quiet") stream
)
1850 (write-string " NaN" stream
))))
1852 (when (float-sign-bit-set-p x
)
1853 (write-char #\- stream
))
1856 (write-string "0.0" stream
)
1857 (print-float-exponent x
0 stream
))
1859 (print-float x stream
))))))
1861 ;;;; other leaf objects
1863 ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
1864 ;;; the character name or the character in the #\char format.
1865 (defmethod print-object ((char character
) stream
)
1866 (if (or *print-escape
* *print-readably
*)
1867 (let ((graphicp (and (graphic-char-p char
)
1868 (standard-char-p char
)))
1869 (name (char-name char
)))
1870 (write-string "#\\" stream
)
1872 ((and name
(or (not graphicp
) *print-readably
*)) (quote-string name stream
))
1874 (write-char char stream
)
1875 ;; KLUDGE: arguably this should be in an :AROUND method
1876 ;; specialized on ((EQL #\SPACE) T).
1877 (when (and (eql char
#\Space
))
1878 (sb-pretty:note-significant-space stream
)))))
1879 (write-char char stream
)))
1881 (defmethod print-object ((sap system-area-pointer
) stream
)
1883 (format stream
"#.(~S #X~8,'0X)" 'int-sap
(sap-int sap
)))
1885 (print-unreadable-object (sap stream
)
1886 (format stream
"system area pointer: #X~8,'0X" (sap-int sap
))))))
1888 #+weak-vector-readbarrier
1889 (defmethod print-object ((self weak-pointer
) stream
)
1890 (let ((vectorp (weak-vector-p self
)))
1891 (print-unreadable-object (self stream
:identity vectorp
)
1893 (format stream
"weak array [~d]" (weak-vector-len self
))
1894 (multiple-value-bind (value validp
) (weak-pointer-value self
)
1896 (write-string "weak pointer: " stream
)
1897 (write value
:stream stream
))
1899 (write-string "broken weak pointer" stream
))))))))
1901 #-weak-vector-readbarrier
1902 (defmethod print-object ((weak-pointer weak-pointer
) stream
)
1903 (print-unreadable-object (weak-pointer stream
)
1904 (multiple-value-bind (value validp
) (weak-pointer-value weak-pointer
)
1906 (write-string "weak pointer: " stream
)
1907 (write value
:stream stream
))
1909 (write-string "broken weak pointer" stream
))))))
1911 (defmethod print-object ((component code-component
) stream
)
1912 (print-unreadable-object (component stream
)
1914 (cond ((eq (setq dinfo
(%code-debug-info component
)) :bpt-lra
)
1915 (write-string "bpt-trap-return" stream
))
1917 (format stream
"code~@[ id=~x~] [~D]"
1918 (%code-serialno component
)
1919 (code-n-entries component
))
1920 (let ((fun-name (awhen (%code-entry-point component
0)
1921 (%simple-fun-name it
))))
1923 (write-char #\Space stream
)
1924 (write fun-name
:stream stream
))
1925 (cond ((not (typep dinfo
'sb-c
::debug-info
)))
1926 ((neq (sb-c::debug-info-name dinfo
) fun-name
)
1927 (write-string ", " stream
)
1928 (output-object (sb-c::debug-info-name dinfo
) stream
)))))))
1929 (let ((a (get-lisp-obj-address component
)))
1930 (format stream
" {~X..~X}"
1931 a
(+ (logandc2 a sb-vm
:lowtag-mask
) (code-object-size component
))))))
1933 #-
(or x86 x86-64 arm64 riscv
)
1934 (defmethod print-object ((lra lra
) stream
)
1935 (print-unreadable-object (lra stream
:identity t
)
1936 (write-string "return PC object" stream
)))
1938 (defmethod print-object ((fdefn fdefn
) stream
)
1939 (print-unreadable-object (fdefn stream
:type t
)
1940 ;; As fdefn names are particularly relevant to those hacking on the compiler
1941 ;; and disassembler, be maximally helpful by neither abbreviating (SETF ...)
1942 ;; due to length cutoff, nor failing to print a package if needed.
1943 ;; Some folks seem to love same-named symbols way too much.
1944 (let ((*print-length
* 20)) ; arbitrary
1945 (prin1 (fdefn-name fdefn
) stream
))))
1948 (defmethod print-object ((pack simd-pack
) stream
)
1949 (cond ((and *print-readably
* *read-eval
*)
1950 (format stream
"#.(~S #b~3,'0b #x~16,'0X #x~16,'0X)"
1952 (%simd-pack-tag pack
)
1953 (%simd-pack-low pack
)
1954 (%simd-pack-high pack
)))
1956 (print-not-readable-error pack stream
))
1958 (print-unreadable-object (pack stream
)
1960 ((simd-pack double-float
)
1961 (multiple-value-call #'format stream
"~S~@{ ~,13E~}" 'simd-pack
1962 (%simd-pack-doubles pack
)))
1963 ((simd-pack single-float
)
1964 (multiple-value-call #'format stream
"~S~@{ ~,7E~}" 'simd-pack
1965 (%simd-pack-singles pack
)))
1966 ((simd-pack (unsigned-byte 8))
1967 (multiple-value-call #'format stream
"~S~@{ ~3D~}" 'simd-pack
1968 (%simd-pack-ub8s pack
)))
1969 ((simd-pack (unsigned-byte 16))
1970 (multiple-value-call #'format stream
"~S~@{ ~5D~}" 'simd-pack
1971 (%simd-pack-ub16s pack
)))
1972 ((simd-pack (unsigned-byte 32))
1973 (multiple-value-call #'format stream
"~S~@{ ~10D~}" 'simd-pack
1974 (%simd-pack-ub32s pack
)))
1975 ((simd-pack (unsigned-byte 64))
1976 (multiple-value-call #'format stream
"~S~@{ ~20D~}" 'simd-pack
1977 (%simd-pack-ub64s pack
)))
1978 ((simd-pack (signed-byte 8))
1979 (multiple-value-call #'format stream
"~S~@{ ~4,@D~}" 'simd-pack
1980 (%simd-pack-sb8s pack
)))
1981 ((simd-pack (signed-byte 16))
1982 (multiple-value-call #'format stream
"~S~@{ ~6,@D~}" 'simd-pack
1983 (%simd-pack-sb16s pack
)))
1984 ((simd-pack (signed-byte 32))
1985 (multiple-value-call #'format stream
"~S~@{ ~11@D~}" 'simd-pack
1986 (%simd-pack-sb32s pack
)))
1987 ((simd-pack (signed-byte 64))
1988 (multiple-value-call #'format stream
"~S~@{ ~20@D~}" 'simd-pack
1989 (%simd-pack-sb64s pack
))))))))
1992 (defmethod print-object ((pack simd-pack-256
) stream
)
1993 (cond ((and *print-readably
* *read-eval
*)
1994 (format stream
"#.(~S #b~3,'0B #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D)"
1995 '%make-simd-pack-256
1996 (%simd-pack-256-tag pack
)
1997 (%simd-pack-256-0 pack
)
1998 (%simd-pack-256-1 pack
)
1999 (%simd-pack-256-2 pack
)
2000 (%simd-pack-256-3 pack
)))
2002 (print-not-readable-error pack stream
))
2004 (print-unreadable-object (pack stream
)
2006 ((simd-pack-256 double-float
)
2007 (multiple-value-call #'format stream
"~S~@{ ~,13E~}" 'simd-pack-256
2008 (%simd-pack-256-doubles pack
)))
2009 ((simd-pack-256 single-float
)
2010 (multiple-value-call #'format stream
"~S~@{ ~,7E~}" 'simd-pack-256
2011 (%simd-pack-256-singles pack
)))
2012 ((simd-pack-256 (unsigned-byte 8))
2013 (multiple-value-call #'format stream
"~S~@{ ~3D~}" 'simd-pack-256
2014 (%simd-pack-256-ub8s pack
)))
2015 ((simd-pack-256 (unsigned-byte 16))
2016 (multiple-value-call #'format stream
"~S~@{ ~5D~}" 'simd-pack-256
2017 (%simd-pack-256-ub16s pack
)))
2018 ((simd-pack-256 (unsigned-byte 32))
2019 (multiple-value-call #'format stream
"~S~@{ ~10D~}" 'simd-pack-256
2020 (%simd-pack-256-ub32s pack
)))
2021 ((simd-pack-256 (unsigned-byte 64))
2022 (multiple-value-call #'format stream
"~S~@{ ~20D~}" 'simd-pack-256
2023 (%simd-pack-256-ub64s pack
)))
2024 ((simd-pack-256 (signed-byte 8))
2025 (multiple-value-call #'format stream
"~S~@{ ~4@D~}" 'simd-pack-256
2026 (%simd-pack-256-sb8s pack
)))
2027 ((simd-pack-256 (signed-byte 16))
2028 (multiple-value-call #'format stream
"~S~@{ ~6@D~}" 'simd-pack-256
2029 (%simd-pack-256-sb16s pack
)))
2030 ((simd-pack-256 (signed-byte 32))
2031 (multiple-value-call #'format stream
"~S~@{ ~11@D~}" 'simd-pack-256
2032 (%simd-pack-256-sb32s pack
)))
2033 ((simd-pack-256 (signed-byte 64))
2034 (multiple-value-call #'format stream
"~S~@{ ~20@D~}" 'simd-pack-256
2035 (%simd-pack-256-sb64s pack
))))))))
2039 (defmethod print-object ((object function
) stream
)
2040 (macrolet ((unprintable-instance-p (x)
2041 ;; Guard against calling %FUN-FUN if it would return 0.
2042 ;; %FUNCALLABLE-INSTANCE-FUN is known to return FUNCTION so determining
2043 ;; whether it is actually assigned requires a low-level trick.
2044 (let ((s (sb-vm::primitive-object-slot
2045 (sb-vm:primitive-object
'funcallable-instance
)
2047 `(and (funcallable-instance-p ,x
)
2048 (eql 0 (%primitive sb-alien
:slot
,x
'function
,(sb-vm:slot-offset s
)
2049 ,sb-vm
:fun-pointer-lowtag
))))))
2050 (when (unprintable-instance-p object
)
2051 (return-from print-object
2052 (print-unreadable-object (object stream
:type t
:identity t
)))))
2053 (let* ((name (%fun-name object
))
2054 (proper-name-p (and (legal-fun-name-p name
) (fboundp name
)
2055 (eq (fdefinition name
) object
))))
2056 ;; ":TYPE T" is no good, since CLOSURE doesn't have full-fledged status.
2057 (print-unreadable-object (object stream
:identity
(not proper-name-p
))
2058 (format stream
"~A~@[ ~S~]"
2059 ;; CLOSURE and SIMPLE-FUN should print as #<FUNCTION>
2060 ;; but anything else prints as its exact type.
2061 (if (funcallable-instance-p object
) (type-of object
) 'function
)
2064 ;;;; catch-all for unknown things
2066 (defmethod print-object ((object t
) stream
)
2067 (when (eq object sb-pcl
:+slot-unbound
+)
2068 ;; If specifically the unbound marker with 0 data,
2069 ;; as opposed to any other unbound marker.
2070 (print-unreadable-object (object stream
) (write-string "unbound" stream
))
2071 (return-from print-object
))
2072 ;; NO-TLS-VALUE was added here as a printable object type for #+ubsan which,
2073 ;; among other things, detects read-before-write on a per-array-element basis.
2074 ;; Git rev 22d8038118 caused uninitialized SIMPLE-VECTORs to get prefilled
2075 ;; with NO_TLS_VALUE_MARKER, but a better choice would be
2076 ;; (logior (mask-field (byte (- n-word-bits 8) 8) -1) unbound-marker-widetag).
2077 ;; #+ubsan has probably bitrotted for other reasons, so this is untested.
2079 (when (eql (get-lisp-obj-address object
) unwritten-vector-element-marker
)
2080 (print-unreadable-object (object stream
) (write-string "novalue" stream
))
2081 (return-from print-object
))
2082 (print-unreadable-object (object stream
:identity t
)
2083 (let ((lowtag (lowtag-of object
)))
2085 (#.sb-vm
:other-pointer-lowtag
2086 (let ((widetag (widetag-of object
)))
2088 (#.sb-vm
:value-cell-widetag
2089 (write-string "value-cell " stream
)
2090 (output-object (value-cell-ref object
) stream
))
2092 (#.sb-vm
:filler-widetag
2093 (write-string "pad " stream
)
2094 (write (1+ (get-header-data object
)) :stream stream
)
2095 (write-string "w" stream
)) ; words
2097 (write-string "unknown pointer object, widetag=" stream
)
2098 (output-integer widetag stream
16 t
)))))
2099 ((#.sb-vm
:fun-pointer-lowtag
2100 #.sb-vm
:instance-pointer-lowtag
2101 #.sb-vm
:list-pointer-lowtag
)
2102 (write-string "unknown pointer object, lowtag=" stream
)
2103 (output-integer lowtag stream
16 t
))
2105 (case (widetag-of object
)
2106 (#.sb-vm
:unbound-marker-widetag
2107 (write-string "unbound marker" stream
))
2109 (write-string "unknown immediate object, lowtag=" stream
)
2110 (output-integer lowtag stream
2 t
)
2111 (write-string ", widetag=" stream
)
2112 (output-integer (widetag-of object
) stream
16 t
))))))))