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 be printed readably. If readable printing
22 is impossible, an error will be signalled. This overrides the value of
24 (defvar *print-escape* t
26 "Should we print in a reasonably machine-readable way? (possibly
27 overridden by *PRINT-READABLY*)")
28 (defvar *print-pretty* nil ; (set later when pretty-printer is initialized)
30 "Should pretty printing be used?")
31 (defvar *print-base* 10.
33 "The output base for RATIONALs (including integers).")
34 (defvar *print-radix* nil
36 "Should base be verified when printing RATIONALs?")
37 (defvar *print-level* nil
39 "How many levels should be printed before abbreviating with \"#\"?")
40 (defvar *print-length* nil
42 "How many elements at any level should be printed before abbreviating
44 (defvar *print-circle* nil
46 "Should we use #n= and #n# notation to preserve uniqueness in general (and
47 circularity in particular) when printing?")
48 (defvar *print-case* :upcase
50 "What case should the printer should use default?")
51 (defvar *print-array* t
53 "Should the contents of arrays be printed?")
54 (defvar *print-gensym* t
56 "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
57 (defvar *print-lines* nil
59 "The maximum number of lines to print per object.")
60 (defvar *print-right-margin* nil
62 "The position of the right margin in ems (for pretty-printing).")
63 (defvar *print-miser-width* nil
65 "If the remaining space between the current column and the right margin
66 is less than this, then print using ``miser-style'' output. Miser
67 style conditional newlines are turned on, and all indentations are
68 turned off. If NIL, never use miser mode.")
69 (defvar *print-pprint-dispatch*)
71 (setf (fdocumentation '*print-pprint-dispatch* 'variable)
72 "The pprint-dispatch-table that controls how to pretty-print objects.")
73 (defvar *suppress-print-errors* nil
75 "Suppress printer errors when the condition is of the type designated by this
76 variable: an unreadable object representing the error is printed instead.")
78 (defmacro with-standard-io-syntax (&body body)
80 "Bind the reader and printer control variables to values that enable READ
81 to reliably read the results of PRINT. These values are:
83 *PACKAGE* the COMMON-LISP-USER package
93 *PRINT-MISER-WIDTH* NIL
94 *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table
98 *PRINT-RIGHT-MARGIN* NIL
100 *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
103 *READTABLE* the standard readtable
104 SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL
106 `(%with-standard-io-syntax (lambda () ,@body)))
108 (defun %with-standard-io-syntax (function)
109 (declare (type function function))
110 (let ((*package* (find-package "COMMON-LISP-USER"))
113 (*print-case* :upcase)
120 (*print-miser-width* nil)
121 (*print-pprint-dispatch* sb!pretty::*standard-pprint-dispatch-table*)
125 (*print-right-margin* nil)
127 (*read-default-float-format* 'single-float)
129 (*read-suppress* nil)
130 (*readtable* *standard-readtable*)
131 (*suppress-print-errors* nil))
134 ;;;; routines to print objects
137 ;;; keyword variables shared by WRITE and WRITE-TO-STRING, and
138 ;;; the bindings they map to.
139 (eval-when (:compile-toplevel :load-toplevel)
140 (defvar *printer-keyword-variables*
141 '(:escape *print-escape*
144 :circle *print-circle*
145 :pretty *print-pretty*
147 :length *print-length*
150 :gensym *print-gensym*
151 :readably *print-readably*
152 :right-margin *print-right-margin*
153 :miser-width *print-miser-width*
155 :pprint-dispatch *print-pprint-dispatch*
156 :suppress-errors *suppress-print-errors*)))
158 (defun write (object &key
159 ((:stream stream) *standard-output*)
160 ((:escape *print-escape*) *print-escape*)
161 ((:radix *print-radix*) *print-radix*)
162 ((:base *print-base*) *print-base*)
163 ((:circle *print-circle*) *print-circle*)
164 ((:pretty *print-pretty*) *print-pretty*)
165 ((:level *print-level*) *print-level*)
166 ((:length *print-length*) *print-length*)
167 ((:case *print-case*) *print-case*)
168 ((:array *print-array*) *print-array*)
169 ((:gensym *print-gensym*) *print-gensym*)
170 ((:readably *print-readably*) *print-readably*)
171 ((:right-margin *print-right-margin*)
172 *print-right-margin*)
173 ((:miser-width *print-miser-width*)
175 ((:lines *print-lines*) *print-lines*)
176 ((:pprint-dispatch *print-pprint-dispatch*)
177 *print-pprint-dispatch*)
178 ((:suppress-errors *suppress-print-errors*)
179 *suppress-print-errors*))
181 "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*."
182 (output-object object (out-synonym-of stream))
185 ;;; Optimize common case of constant keyword arguments
186 (define-compiler-macro write (&whole form object &rest keys)
190 ;; Odd number of keys, punt
192 (return-from write form)))
193 (let* ((key (pop keys))
195 (variable (or (getf *printer-keyword-variables* key)
196 (when (eq :stream key)
198 (return-from write form))))
199 (when (assoc variable bind)
200 ;; First key has precedence, but we still need to execute the
201 ;; argument, and in the right order.
202 (setf variable (gensym "IGNORE"))
203 (push variable ignore))
204 (push (list variable value) bind)))
205 (unless (assoc 'stream bind)
206 (push (list 'stream '*standard-output*) bind))
207 (once-only ((object object))
208 `(let ,(nreverse bind)
209 ,@(when ignore `((declare (ignore ,@ignore))))
210 (output-object ,object (out-synonym-of stream))
213 (defun prin1 (object &optional stream)
215 "Output a mostly READable printed representation of OBJECT on the specified
217 (let ((*print-escape* t))
218 (output-object object (out-synonym-of stream)))
221 (defun princ (object &optional stream)
223 "Output an aesthetic but not necessarily READable printed representation
224 of OBJECT on the specified STREAM."
225 (let ((*print-escape* nil)
226 (*print-readably* nil))
227 (output-object object (out-synonym-of stream)))
230 (defun print (object &optional stream)
232 "Output a newline, the mostly READable printed representation of OBJECT, and
233 space to the specified STREAM."
234 (let ((stream (out-synonym-of stream)))
236 (prin1 object stream)
237 (write-char #\space stream)
240 (defun pprint (object &optional stream)
242 "Prettily output OBJECT preceded by a newline."
243 (let ((*print-pretty* t)
245 (stream (out-synonym-of stream)))
247 (output-object object stream))
250 (defun write-to-string
252 ((:escape *print-escape*) *print-escape*)
253 ((:radix *print-radix*) *print-radix*)
254 ((:base *print-base*) *print-base*)
255 ((:circle *print-circle*) *print-circle*)
256 ((:pretty *print-pretty*) *print-pretty*)
257 ((:level *print-level*) *print-level*)
258 ((:length *print-length*) *print-length*)
259 ((:case *print-case*) *print-case*)
260 ((:array *print-array*) *print-array*)
261 ((:gensym *print-gensym*) *print-gensym*)
262 ((:readably *print-readably*) *print-readably*)
263 ((:right-margin *print-right-margin*) *print-right-margin*)
264 ((:miser-width *print-miser-width*) *print-miser-width*)
265 ((:lines *print-lines*) *print-lines*)
266 ((:pprint-dispatch *print-pprint-dispatch*)
267 *print-pprint-dispatch*)
268 ((:suppress-errors *suppress-print-errors*)
269 *suppress-print-errors*))
271 "Return the printed representation of OBJECT as a string."
272 (stringify-object object))
274 ;;; Optimize common case of constant keyword arguments
275 (define-compiler-macro write-to-string (&whole form object &rest keys)
279 ;; Odd number of keys, punt
281 (return-from write-to-string form)))
282 (let* ((key (pop keys))
284 (variable (or (getf *printer-keyword-variables* key)
285 (return-from write-to-string form))))
286 (when (assoc variable bind)
287 ;; First key has precedence, but we still need to execute the
288 ;; argument, and in the right order.
289 (setf variable (gensym "IGNORE"))
290 (push variable ignore))
291 (push (list variable value) bind)))
293 (once-only ((object object))
294 `(let ,(nreverse bind)
295 ,@(when ignore `((declare (ignore ,@ignore))))
296 (stringify-object ,object)))
297 `(stringify-object ,object))))
299 (defun prin1-to-string (object)
301 "Return the printed representation of OBJECT as a string with
303 (let ((*print-escape* t))
304 (stringify-object object)))
306 (defun princ-to-string (object)
308 "Return the printed representation of OBJECT as a string with
310 (let ((*print-escape* nil)
311 (*print-readably* nil))
312 (stringify-object object)))
314 ;;; This produces the printed representation of an object as a string.
315 ;;; The few ...-TO-STRING functions above call this.
316 (defun stringify-object (object)
317 (let ((stream (make-string-output-stream)))
318 (setup-printer-state)
319 (output-object object stream)
320 (get-output-stream-string stream)))
322 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
324 (defun print-not-readable-error (object stream)
326 (error 'print-not-readable :object object)
328 :report "Print unreadably."
329 (let ((*print-readably* nil))
330 (output-object object stream)
333 :report "Supply an object to be printed instead."
336 (read-evaluated-form "~@<Enter an object (evaluated): ~@:>"))
337 (output-object o stream)
340 ;;; guts of PRINT-UNREADABLE-OBJECT
341 (defun %print-unreadable-object (object stream type identity body)
342 (declare (type (or null function) body))
344 (print-not-readable-error object stream)
345 (flet ((print-description ()
347 (write (type-of object) :stream stream :circle nil
348 :level nil :length nil)
349 (write-char #\space stream)
350 (pprint-newline :fill stream))
354 (when (or body (not type))
355 (write-char #\space stream))
356 (pprint-newline :fill stream)
357 (write-char #\{ stream)
358 (write (get-lisp-obj-address object) :stream stream
360 (write-char #\} stream))))
361 (cond ((print-pretty-on-stream-p stream)
362 ;; Since we're printing prettily on STREAM, format the
363 ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
364 ;; not rebind the stream when it is already a pretty stream,
365 ;; so output from the body will go to the same stream.
366 (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
367 (print-description)))
369 (write-string "#<" stream)
371 (write-char #\> stream)))))
374 ;;;; OUTPUT-OBJECT -- the main entry point
376 ;;; Objects whose print representation identifies them EQLly don't
377 ;;; need to be checked for circularity.
378 (defun uniquely-identified-by-print-p (x)
382 (symbol-package x))))
384 (defvar *in-print-error* nil)
386 ;;; Output OBJECT to STREAM observing all printer control variables.
387 (defun output-object (object stream)
388 (labels ((print-it (stream)
390 (sb!pretty:output-pretty-object object stream)
391 (output-ugly-object object stream)))
393 (if *suppress-print-errors*
394 (handler-bind ((condition
395 (lambda (condition) nil
396 (when (typep condition *suppress-print-errors*)
397 (cond (*in-print-error*
398 (write-string "(error printing " stream)
399 (write-string *in-print-error* stream)
400 (write-string ")" stream))
402 ;; Give outer handlers a chance.
404 (continue "Suppress the error.")
406 (let ((*print-readably* nil)
409 "#<error printing a " stream)
410 (let ((*in-print-error* "type"))
411 (output-object (type-of object) stream))
412 (write-string ": " stream)
413 (let ((*in-print-error* "condition"))
414 (output-object condition stream))
415 (write-string ">" stream))))
416 (return-from handle-it object)))))
420 (multiple-value-bind (marker initiate)
421 (check-for-circularity object t)
422 (if (eq initiate :initiate)
423 (let ((*circularity-hash-table*
424 (make-hash-table :test 'eq)))
425 (check-it (make-broadcast-stream))
426 (let ((*circularity-counter* 0))
430 (when (handle-circularity marker stream)
432 (handle-it stream))))))
433 (cond (;; Maybe we don't need to bother with circularity detection.
434 (or (not *print-circle*)
435 (uniquely-identified-by-print-p object))
437 (;; If we have already started circularity detection, this
438 ;; object might be a shared reference. If we have not, then
439 ;; if it is a compound object it might contain a circular
440 ;; reference to itself or multiple shared references.
441 (or *circularity-hash-table*
442 (compound-object-p object))
445 (handle-it stream)))))
447 ;;; a hack to work around recurring gotchas with printing while
448 ;;; DEFGENERIC PRINT-OBJECT is being built
450 ;;; (hopefully will go away naturally when CLOS moves into cold init)
451 (defvar *print-object-is-disabled-p*)
453 ;;; Output OBJECT to STREAM observing all printer control variables
454 ;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
455 ;;; then the pretty printer will be used for any components of OBJECT,
456 ;;; just not for OBJECT itself.
457 (defun output-ugly-object (object stream)
459 ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
460 ;; PRINT-OBJECT says it provides printing and we're supposed to provide
461 ;; PRINT-OBJECT methods covering all classes. We deviate from this
462 ;; by using PRINT-OBJECT only when we print instance values. However,
463 ;; ANSI makes it hard to tell that we're deviating from this:
464 ;; (1) ANSI specifies that the user isn't supposed to call PRINT-OBJECT
466 ;; (2) ANSI (section 11.1.2.1.2) says it's undefined to define
467 ;; a method on an external symbol in the CL package which is
468 ;; applicable to arg lists containing only direct instances of
469 ;; standardized classes.
470 ;; Thus, in order for the user to detect our sleaziness in conforming
471 ;; code, he has to do something relatively obscure like
472 ;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
474 ;; (2) define a PRINT-OBJECT method which is specialized on the stream
475 ;; value (e.g. a Gray stream object).
476 ;; As long as no one comes up with a non-obscure way of detecting this
477 ;; sleaziness, fixing this nonconformity will probably have a low
478 ;; priority. -- WHN 2001-11-25
481 (output-symbol object stream)
482 (output-list object stream)))
484 (cond ((not (and (boundp '*print-object-is-disabled-p*)
485 *print-object-is-disabled-p*))
486 (print-object object stream))
487 ((typep object 'structure-object)
488 (default-structure-print object stream *current-level-in-print*))
490 (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
491 (funcallable-instance
493 ((not (and (boundp '*print-object-is-disabled-p*)
494 *print-object-is-disabled-p*))
495 (print-object object stream))
496 (t (output-fun object stream))))
498 (output-fun object stream))
500 (output-symbol object stream))
504 (output-integer object stream))
506 (output-float object stream))
508 (output-ratio object stream))
510 (output-complex object stream))))
512 (output-character object stream))
514 (output-vector object stream))
516 (output-array object stream))
518 (output-sap object stream))
520 (output-weak-pointer object stream))
522 (output-lra object stream))
524 (output-code-component object stream))
526 (output-fdefn object stream))
528 (output-random object stream))))
532 ;;; values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last
533 ;;; time the printer was called
534 (defvar *previous-case* nil)
535 (defvar *previous-readtable-case* nil)
537 ;;; This variable contains the current definition of one of three
538 ;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
539 (defvar *internal-symbol-output-fun* nil)
541 ;;; This function sets the internal global symbol
542 ;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
543 ;;; the value of *PRINT-CASE*. See the manual for details. The print
544 ;;; buffer stream is also reset.
545 (defun setup-printer-state ()
546 (unless (and (eq *print-case* *previous-case*)
547 (eq (readtable-case *readtable*) *previous-readtable-case*))
548 (setq *previous-case* *print-case*)
549 (setq *previous-readtable-case* (readtable-case *readtable*))
550 (unless (member *print-case* '(:upcase :downcase :capitalize))
551 (setq *print-case* :upcase)
552 (error "invalid *PRINT-CASE* value: ~S" *previous-case*))
553 (unless (member *previous-readtable-case*
554 '(:upcase :downcase :invert :preserve))
555 (setf (readtable-case *readtable*) :upcase)
556 (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*))
558 (setq *internal-symbol-output-fun*
559 (case *previous-readtable-case*
562 (:upcase #'output-preserve-symbol)
563 (:downcase #'output-lowercase-symbol)
564 (:capitalize #'output-capitalize-symbol)))
567 (:upcase #'output-uppercase-symbol)
568 (:downcase #'output-preserve-symbol)
569 (:capitalize #'output-capitalize-symbol)))
570 (:preserve #'output-preserve-symbol)
571 (:invert #'output-invert-symbol)))))
573 ;;; Output PNAME (a symbol-name or package-name) surrounded with |'s,
574 ;;; and with any embedded |'s or \'s escaped.
575 (defun output-quoted-symbol-name (pname stream)
576 (write-char #\| stream)
577 (dotimes (index (length pname))
578 (let ((char (schar pname index)))
579 (when (or (char= char #\\) (char= char #\|))
580 (write-char #\\ stream))
581 (write-char char stream)))
582 (write-char #\| stream))
584 (defun output-symbol (object stream)
585 (if (or *print-escape* *print-readably*)
586 (let ((package (symbol-package object))
587 (name (symbol-name object)))
589 ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
590 ;; requires that keywords be printed with preceding colons
591 ;; always, regardless of the value of *PACKAGE*.
592 ((eq package *keyword-package*)
593 (write-char #\: stream))
594 ;; Otherwise, if the symbol's home package is the current
595 ;; one, then a prefix is never necessary.
596 ((eq package (sane-package)))
597 ;; Uninterned symbols print with a leading #:.
599 (when (or *print-gensym* *print-readably*)
600 (write-string "#:" stream)))
602 (multiple-value-bind (symbol accessible)
603 (find-symbol name (sane-package))
604 ;; If we can find the symbol by looking it up, it need not
605 ;; be qualified. This can happen if the symbol has been
606 ;; inherited from a package other than its home package.
607 (unless (and accessible (eq symbol object))
608 (output-symbol-name (package-name package) stream)
609 (multiple-value-bind (symbol externalp)
610 (find-external-symbol name package)
611 (declare (ignore symbol))
613 (write-char #\: stream)
614 (write-string "::" stream)))))))
615 (output-symbol-name name stream))
616 (output-symbol-name (symbol-name object) stream nil)))
618 ;;; Output the string NAME as if it were a symbol name. In other
619 ;;; words, diddle its case according to *PRINT-CASE* and
621 (defun output-symbol-name (name stream &optional (maybe-quote t))
622 (declare (type simple-string name))
623 (let ((*readtable* (if *print-readably* *standard-readtable* *readtable*)))
624 (setup-printer-state)
625 (if (and maybe-quote (symbol-quotep name))
626 (output-quoted-symbol-name name stream)
627 (funcall *internal-symbol-output-fun* name stream))))
629 ;;;; escaping symbols
631 ;;; When we print symbols we have to figure out if they need to be
632 ;;; printed with escape characters. This isn't a whole lot easier than
633 ;;; reading symbols in the first place.
635 ;;; For each character, the value of the corresponding element is a
636 ;;; fixnum with bits set corresponding to attributes that the
637 ;;; character has. At characters have at least one bit set, so we can
638 ;;; search for any character with a positive test.
639 (defvar *character-attributes*
640 (make-array 160 ; FIXME
641 :element-type '(unsigned-byte 16)
643 (declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
644 *character-attributes*))
646 ;;; constants which are a bit-mask for each interesting character attribute
647 (defconstant other-attribute (ash 1 0)) ; Anything else legal.
648 (defconstant number-attribute (ash 1 1)) ; A numeric digit.
649 (defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter.
650 (defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter.
651 (defconstant sign-attribute (ash 1 4)) ; +-
652 (defconstant extension-attribute (ash 1 5)) ; ^_
653 (defconstant dot-attribute (ash 1 6)) ; .
654 (defconstant slash-attribute (ash 1 7)) ; /
655 (defconstant funny-attribute (ash 1 8)) ; Anything illegal.
657 (eval-when (:compile-toplevel :load-toplevel :execute)
659 ;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
660 ;;; that don't need to be escaped (according to READTABLE-CASE.)
661 (defparameter *attribute-names*
662 `((number . number-attribute) (lowercase . lowercase-attribute)
663 (uppercase . uppercase-attribute) (letter . letter-attribute)
664 (sign . sign-attribute) (extension . extension-attribute)
665 (dot . dot-attribute) (slash . slash-attribute)
666 (other . other-attribute) (funny . funny-attribute)))
670 (flet ((set-bit (char bit)
671 (let ((code (char-code char)))
672 (setf (aref *character-attributes* code)
673 (logior bit (aref *character-attributes* code))))))
675 (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\}
677 (set-bit char other-attribute))
680 (set-bit (digit-char i) number-attribute))
682 (do ((code (char-code #\A) (1+ code))
683 (end (char-code #\Z)))
685 (declare (fixnum code end))
686 (set-bit (code-char code) uppercase-attribute)
687 (set-bit (char-downcase (code-char code)) lowercase-attribute))
689 (set-bit #\- sign-attribute)
690 (set-bit #\+ sign-attribute)
691 (set-bit #\^ extension-attribute)
692 (set-bit #\_ extension-attribute)
693 (set-bit #\. dot-attribute)
694 (set-bit #\/ slash-attribute)
696 ;; Mark anything not explicitly allowed as funny.
697 (dotimes (i 160) ; FIXME
698 (when (zerop (aref *character-attributes* i))
699 (setf (aref *character-attributes* i) funny-attribute))))
701 ;;; For each character, the value of the corresponding element is the
702 ;;; lowest base in which that character is a digit.
703 (defvar *digit-bases*
704 (make-array 128 ; FIXME
705 :element-type '(unsigned-byte 8)
706 :initial-element 36))
707 (declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
710 (let ((char (digit-char i 36)))
711 (setf (aref *digit-bases* (char-code char)) i)))
713 ;;; A FSM-like thingie that determines whether a symbol is a potential
714 ;;; number or has evil characters in it.
715 (defun symbol-quotep (name)
716 (declare (simple-string name))
717 (macrolet ((advance (tag &optional (at-end t))
720 ,(if at-end '(go TEST-SIGN) '(return nil)))
721 (setq current (schar name index)
722 code (char-code current)
724 ((< code 160) (aref attributes code))
725 ((upper-case-p current) uppercase-attribute)
726 ((lower-case-p current) lowercase-attribute)
727 (t other-attribute)))
730 (test (&rest attributes)
742 `(and (< code 128) ; FIXME
743 (< (the fixnum (aref bases code)) base))))
745 (prog ((len (length name))
746 (attributes *character-attributes*)
747 (bases *digit-bases*)
750 (case (readtable-case *readtable*)
751 (:upcase uppercase-attribute)
752 (:downcase lowercase-attribute)
753 (t (logior lowercase-attribute uppercase-attribute))))
758 (declare (fixnum len base index bits code))
761 TEST-SIGN ; At end, see whether it is a sign...
762 (return (not (test sign)))
764 OTHER ; not potential number, see whether funny chars...
765 (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
768 (do ((i (1- index) (1+ i)))
769 ((= i len) (return-from symbol-quotep nil))
770 (unless (zerop (logand (let* ((char (schar name i))
771 (code (char-code char)))
773 ((< code 160) (aref attributes code))
774 ((upper-case-p char) uppercase-attribute)
775 ((lower-case-p char) lowercase-attribute)
776 (t other-attribute)))
778 (return-from symbol-quotep t))))
783 (advance LAST-DIGIT-ALPHA)
785 (when (test letter number other slash) (advance OTHER nil))
786 (when (char= current #\.) (advance DOT-FOUND))
787 (when (test sign extension) (advance START-STUFF nil))
790 DOT-FOUND ; leading dots...
791 (when (test letter) (advance START-DOT-MARKER nil))
792 (when (digitp) (advance DOT-DIGIT))
793 (when (test number other) (advance OTHER nil))
794 (when (test extension slash sign) (advance START-DOT-STUFF nil))
795 (when (char= current #\.) (advance DOT-FOUND))
798 START-STUFF ; leading stuff before any dot or digit
801 (advance LAST-DIGIT-ALPHA)
803 (when (test number other) (advance OTHER nil))
804 (when (test letter) (advance START-MARKER nil))
805 (when (char= current #\.) (advance START-DOT-STUFF nil))
806 (when (test sign extension slash) (advance START-STUFF nil))
809 START-MARKER ; number marker in leading stuff...
810 (when (test letter) (advance OTHER nil))
813 START-DOT-STUFF ; leading stuff containing dot without digit...
814 (when (test letter) (advance START-DOT-STUFF nil))
815 (when (digitp) (advance DOT-DIGIT))
816 (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
817 (when (test number other) (advance OTHER nil))
820 START-DOT-MARKER ; number marker in leading stuff with dot..
821 ;; leading stuff containing dot without digit followed by letter...
822 (when (test letter) (advance OTHER nil))
825 DOT-DIGIT ; in a thing with dots...
826 (when (test letter) (advance DOT-MARKER))
827 (when (digitp) (advance DOT-DIGIT))
828 (when (test number other) (advance OTHER nil))
829 (when (test sign extension dot slash) (advance DOT-DIGIT))
832 DOT-MARKER ; number marker in number with dot...
833 (when (test letter) (advance OTHER nil))
836 LAST-DIGIT-ALPHA ; previous char is a letter digit...
837 (when (or (digitp) (test sign slash))
838 (advance ALPHA-DIGIT))
839 (when (test letter number other dot) (advance OTHER nil))
842 ALPHA-DIGIT ; seen a digit which is a letter...
843 (when (or (digitp) (test sign slash))
845 (advance LAST-DIGIT-ALPHA)
846 (advance ALPHA-DIGIT)))
847 (when (test letter) (advance ALPHA-MARKER))
848 (when (test number other dot) (advance OTHER nil))
851 ALPHA-MARKER ; number marker in number with alpha digit...
852 (when (test letter) (advance OTHER nil))
855 DIGIT ; seen only ordinary (non-alphabetic) numeric digits...
858 (advance ALPHA-DIGIT)
860 (when (test number other) (advance OTHER nil))
861 (when (test letter) (advance MARKER))
862 (when (test extension slash sign) (advance DIGIT))
863 (when (char= current #\.) (advance DOT-DIGIT))
866 MARKER ; number marker in a numeric number...
867 ;; ("What," you may ask, "is a 'number marker'?" It's something
868 ;; that a conforming implementation might use in number syntax.
869 ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".)
870 (when (test letter) (advance OTHER nil))
873 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
875 ;;;; case hackery: These functions are stored in
876 ;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
877 ;;;; *PRINT-CASE* and READTABLE-CASE.
880 ;;; READTABLE-CASE *PRINT-CASE*
882 ;;; :DOWNCASE :DOWNCASE
884 (defun output-preserve-symbol (pname stream)
885 (declare (simple-string pname))
886 (write-string pname stream))
889 ;;; READTABLE-CASE *PRINT-CASE*
890 ;;; :UPCASE :DOWNCASE
891 (defun output-lowercase-symbol (pname stream)
892 (declare (simple-string pname))
893 (dotimes (index (length pname))
894 (let ((char (schar pname index)))
895 (write-char (char-downcase char) stream))))
898 ;;; READTABLE-CASE *PRINT-CASE*
899 ;;; :DOWNCASE :UPCASE
900 (defun output-uppercase-symbol (pname stream)
901 (declare (simple-string pname))
902 (dotimes (index (length pname))
903 (let ((char (schar pname index)))
904 (write-char (char-upcase char) stream))))
907 ;;; READTABLE-CASE *PRINT-CASE*
908 ;;; :UPCASE :CAPITALIZE
909 ;;; :DOWNCASE :CAPITALIZE
910 (defun output-capitalize-symbol (pname stream)
911 (declare (simple-string pname))
912 (let ((prev-not-alphanum t)
913 (up (eq (readtable-case *readtable*) :upcase)))
914 (dotimes (i (length pname))
915 (let ((char (char pname i)))
917 (if (or prev-not-alphanum (lower-case-p char))
919 (char-downcase char))
920 (if prev-not-alphanum
924 (setq prev-not-alphanum (not (alphanumericp char)))))))
927 ;;; READTABLE-CASE *PRINT-CASE*
929 (defun output-invert-symbol (pname stream)
930 (declare (simple-string pname))
933 (dotimes (i (length pname))
934 (let ((ch (schar pname i)))
935 (when (both-case-p ch)
936 (if (upper-case-p ch)
938 (setq all-upper nil)))))
939 (cond (all-upper (output-lowercase-symbol pname stream))
940 (all-lower (output-uppercase-symbol pname stream))
942 (write-string pname stream)))))
946 (let ((*readtable* (copy-readtable nil)))
947 (format t "READTABLE-CASE Input Symbol-name~@
948 ----------------------------------~%")
949 (dolist (readtable-case '(:upcase :downcase :preserve :invert))
950 (setf (readtable-case *readtable*) readtable-case)
951 (dolist (input '("ZEBRA" "Zebra" "zebra"))
952 (format t "~&:~A~16T~A~24T~A"
953 (string-upcase readtable-case)
955 (symbol-name (read-from-string input)))))))
958 (let ((*readtable* (copy-readtable nil)))
959 (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@
960 --------------------------------------------------------~%")
961 (dolist (readtable-case '(:upcase :downcase :preserve :invert))
962 (setf (readtable-case *readtable*) readtable-case)
963 (dolist (*print-case* '(:upcase :downcase :capitalize))
964 (dolist (symbol '(|ZEBRA| |Zebra| |zebra|))
965 (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A"
966 (string-upcase readtable-case)
967 (string-upcase *print-case*)
969 (prin1-to-string symbol)
970 (princ-to-string symbol)))))))
973 ;;;; recursive objects
975 (defun output-list (list stream)
976 (descend-into (stream)
977 (write-char #\( stream)
981 (punt-print-if-too-long length stream)
982 (output-object (pop list) stream)
985 (when (or (atom list)
986 (check-for-circularity list))
987 (write-string " . " stream)
988 (output-object list stream)
990 (write-char #\space stream)
992 (write-char #\) stream)))
994 (defun output-unreadable-vector-readably (vector stream)
995 (declare (vector vector))
996 (write-string "#." stream)
997 (write `(coerce ,(coerce vector '(vector t))
998 '(simple-array ,(array-element-type vector) (*)))
1001 (defun output-vector (vector stream)
1002 (declare (vector vector))
1003 (cond ((stringp vector)
1004 (cond ((and *print-readably*
1005 (not (eq (array-element-type vector)
1008 (make-array 0 :element-type 'character))))))
1009 (print-not-readable-error vector stream))
1010 ((or *print-escape* *print-readably*)
1011 (write-char #\" stream)
1012 (quote-string vector stream)
1013 (write-char #\" stream))
1015 (write-string vector stream))))
1016 ((not (or *print-array* *print-readably*))
1017 (output-terse-array vector stream))
1018 ((bit-vector-p vector)
1019 (write-string "#*" stream)
1020 (dovector (bit vector)
1021 ;; (Don't use OUTPUT-OBJECT here, since this code
1022 ;; has to work for all possible *PRINT-BASE* values.)
1023 (write-char (if (zerop bit) #\0 #\1) stream)))
1024 ((or (not *print-readably*)
1025 (array-readably-printable-p vector))
1026 (descend-into (stream)
1027 (write-string "#(" stream)
1028 (dotimes (i (length vector))
1030 (write-char #\space stream))
1031 (punt-print-if-too-long i stream)
1032 (output-object (aref vector i) stream))
1033 (write-string ")" stream)))
1035 (output-unreadable-vector-readably vector stream))
1037 (print-not-readable-error vector stream))))
1039 ;;; This function outputs a string quoting characters sufficiently
1040 ;;; so that someone can read it in again. Basically, put a slash in
1041 ;;; front of an character satisfying NEEDS-SLASH-P.
1042 (defun quote-string (string stream)
1043 (macrolet ((needs-slash-p (char)
1044 ;; KLUDGE: We probably should look at the readtable, but just do
1045 ;; this for now. [noted by anonymous long ago] -- WHN 19991130
1046 `(or (char= ,char #\\)
1047 (char= ,char #\"))))
1048 (with-array-data ((data string) (start) (end)
1049 :check-fill-pointer t)
1050 (do ((index start (1+ index)))
1052 (let ((char (schar data index)))
1053 (when (needs-slash-p char) (write-char #\\ stream))
1054 (write-char char stream))))))
1056 (defun array-readably-printable-p (array)
1057 (and (eq (array-element-type array) t)
1058 (let ((zero (position 0 (array-dimensions array)))
1059 (number (position 0 (array-dimensions array)
1060 :test (complement #'eql)
1062 (or (null zero) (null number) (> zero number)))))
1064 ;;; Output the printed representation of any array in either the #< or #A
1066 (defun output-array (array stream)
1067 (if (or *print-array* *print-readably*)
1068 (output-array-guts array stream)
1069 (output-terse-array array stream)))
1071 ;;; Output the abbreviated #< form of an array.
1072 (defun output-terse-array (array stream)
1073 (let ((*print-level* nil)
1074 (*print-length* nil))
1075 (print-unreadable-object (array stream :type t :identity t))))
1077 ;;; Convert an array into a list that can be used with MAKE-ARRAY's
1078 ;;; :INITIAL-CONTENTS keyword argument.
1079 (defun listify-array (array)
1080 (with-array-data ((data array) (start) (end))
1081 (declare (ignore end))
1082 (labels ((listify (dimensions index)
1083 (if (null dimensions)
1085 (let* ((dimension (car dimensions))
1086 (dimensions (cdr dimensions))
1087 (count (reduce #'* dimensions)))
1088 (loop for i below dimension
1089 collect (listify dimensions index)
1090 do (incf index count))))))
1091 (listify (array-dimensions array) start))))
1093 (defun output-unreadable-array-readably (array stream)
1094 (write-string "#." stream)
1095 (write `(make-array ',(array-dimensions array)
1096 :element-type ',(array-element-type array)
1097 :initial-contents ',(listify-array array))
1100 ;;; Output the readable #A form of an array.
1101 (defun output-array-guts (array stream)
1102 (cond ((or (not *print-readably*)
1103 (array-readably-printable-p array))
1104 (write-char #\# stream)
1105 (let ((*print-base* 10)
1106 (*print-radix* nil))
1107 (output-integer (array-rank array) stream))
1108 (write-char #\A stream)
1109 (with-array-data ((data array) (start) (end))
1110 (declare (ignore end))
1111 (sub-output-array-guts data (array-dimensions array) stream start)))
1113 (output-unreadable-array-readably array stream))
1115 (print-not-readable-error array stream))))
1117 (defun sub-output-array-guts (array dimensions stream index)
1118 (declare (type (simple-array * (*)) array) (fixnum index))
1119 (cond ((null dimensions)
1120 (output-object (aref array index) stream))
1122 (descend-into (stream)
1123 (write-char #\( stream)
1124 (let* ((dimension (car dimensions))
1125 (dimensions (cdr dimensions))
1126 (count (reduce #'* dimensions)))
1127 (dotimes (i dimension)
1129 (write-char #\space stream))
1130 (punt-print-if-too-long i stream)
1131 (sub-output-array-guts array dimensions stream index)
1132 (incf index count)))
1133 (write-char #\) stream)))))
1135 ;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
1136 ;;; use until CLOS is set up (at which time it will be replaced with
1137 ;;; the real generic function implementation)
1138 (defun print-object (instance stream)
1139 (default-structure-print instance stream *current-level-in-print*))
1141 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
1143 (defun %output-radix (base stream)
1144 (write-char #\# stream)
1145 (write-char (case base
1149 (t (%output-reasonable-integer-in-base base 10 stream)
1153 (defun %output-reasonable-integer-in-base (n base stream)
1154 (multiple-value-bind (q r)
1156 ;; Recurse until you have all the digits pushed on
1159 (%output-reasonable-integer-in-base q base stream))
1160 ;; Then as each recursive call unwinds, turn the
1161 ;; digit (in remainder) into a character and output
1164 (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
1167 ;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is
1168 ;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called
1169 ;;; always prior a GC to drop overly large bignums from the cache.
1171 ;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or
1172 ;;; POWERS-FOR-BASE, see that you don't break the assumptions!
1173 (defvar *power-cache* nil)
1175 (defconstant +power-cache-integer-length-limit+ 2048)
1177 (defun scrub-power-cache ()
1178 (let ((cache *power-cache*))
1179 (dolist (cell cache)
1180 (let ((powers (cdr cell)))
1181 (declare (simple-vector powers))
1182 (let ((too-big (position-if
1184 (>= (integer-length x)
1185 +power-cache-integer-length-limit+))
1188 (setf (cdr cell) (subseq powers 0 too-big))))))
1189 ;; Since base 10 is overwhelmingly common, make sure it's at head.
1190 ;; Try to keep other bases in a hopefully sensible order as well.
1191 (if (eql 10 (caar cache))
1192 (setf *power-cache* cache)
1193 ;; If we modify the list destructively we need to copy it, otherwise
1194 ;; an alist lookup in progress might be screwed.
1195 (setf *power-cache* (sort (copy-list cache)
1197 (declare (fixnum a b))
1207 ;;; Compute (and cache) a power vector for a BASE and LIMIT:
1208 ;;; the vector holds integers for which
1209 ;;; (aref powers k) == (expt base (expt 2 k))
1211 (defun powers-for-base (base limit)
1212 (flet ((compute-powers (from)
1214 (do ((p from (* p p)))
1216 ;; We don't actually need this, but we also
1217 ;; prefer not to cons it up a second time...
1220 (nreverse powers))))
1221 ;; Grab a local reference so that we won't stuff consed at the
1222 ;; head by other threads -- or sorting by SCRUB-POWER-CACHE.
1223 (let ((cache *power-cache*))
1224 (let ((cell (assoc base cache)))
1226 (let* ((powers (cdr cell))
1227 (len (length powers))
1228 (max (svref powers (1- len))))
1232 (concatenate 'vector powers
1233 (compute-powers (* max max)))))
1234 (setf (cdr cell) new)
1236 (let ((powers (coerce (compute-powers base) 'vector)))
1237 ;; Add new base to head: SCRUB-POWER-CACHE will later
1238 ;; put it to a better place.
1239 (setf *power-cache* (acons base powers cache))
1242 ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
1243 (defun %output-huge-integer-in-base (n base stream)
1244 (declare (type bignum n) (type fixnum base))
1245 ;; POWER is a vector for which the following holds:
1246 ;; (aref power k) == (expt base (expt 2 k))
1247 (let* ((power (powers-for-base base n))
1248 (k-start (or (position-if (lambda (x) (> x n)) power)
1249 (bug "power-vector too short"))))
1250 (labels ((bisect (n k exactp)
1251 (declare (fixnum k))
1252 ;; N is the number to bisect
1253 ;; K on initial entry BASE^(2^K) > N
1254 ;; EXACTP is true if 2^K is the exact number of digits
1257 (loop repeat (ash 1 k) do (write-char #\0 stream))))
1260 (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)
1264 (multiple-value-bind (q r) (truncate n (aref power k))
1265 ;; EXACTP is NIL only at the head of the
1266 ;; initial number, as we don't know the number
1267 ;; of digits there, but we do know that it
1268 ;; doesn't get any leading zeros.
1270 (bisect r k (or exactp (plusp q))))))))
1271 (bisect n k-start nil))))
1273 (defun %output-integer-in-base (integer base stream)
1274 (when (minusp integer)
1275 (write-char #\- stream)
1276 (setf integer (- integer)))
1277 ;; The ideal cutoff point between these two algorithms is almost
1278 ;; certainly quite platform dependent: this gives 87 for 32 bit
1279 ;; SBCL, which is about right at least for x86/Darwin.
1280 (if (or (fixnump integer)
1281 (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits)))
1282 (%output-reasonable-integer-in-base integer base stream)
1283 (%output-huge-integer-in-base integer base stream)))
1285 (defun output-integer (integer stream)
1286 (let ((base *print-base*))
1287 (when (and (/= base 10) *print-radix*)
1288 (%output-radix base stream))
1289 (%output-integer-in-base integer base stream)
1290 (when (and *print-radix* (= base 10))
1291 (write-char #\. stream))))
1293 (defun output-ratio (ratio stream)
1294 (let ((base *print-base*))
1296 (%output-radix base stream))
1297 (%output-integer-in-base (numerator ratio) base stream)
1298 (write-char #\/ stream)
1299 (%output-integer-in-base (denominator ratio) base stream)))
1301 (defun output-complex (complex stream)
1302 (write-string "#C(" stream)
1303 ;; FIXME: Could this just be OUTPUT-NUMBER?
1304 (output-object (realpart complex) stream)
1305 (write-char #\space stream)
1306 (output-object (imagpart complex) stream)
1307 (write-char #\) stream))
1311 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
1312 ;;; most of the work for all printing of floating point numbers in
1313 ;;; FORMAT. It converts a floating point number to a string in a free
1314 ;;; or fixed format with no exponent. The interpretation of the
1315 ;;; arguments is as follows:
1317 ;;; X - The floating point number to convert, which must not be
1319 ;;; WIDTH - The preferred field width, used to determine the number
1320 ;;; of fraction digits to produce if the FDIGITS parameter
1321 ;;; is unspecified or NIL. If the non-fraction digits and the
1322 ;;; decimal point alone exceed this width, no fraction digits
1323 ;;; will be produced unless a non-NIL value of FDIGITS has been
1324 ;;; specified. Field overflow is not considerd an error at this
1326 ;;; FDIGITS - The number of fractional digits to produce. Insignificant
1327 ;;; trailing zeroes may be introduced as needed. May be
1328 ;;; unspecified or NIL, in which case as many digits as possible
1329 ;;; are generated, subject to the constraint that there are no
1330 ;;; trailing zeroes.
1331 ;;; SCALE - If this parameter is specified or non-NIL, then the number
1332 ;;; printed is (* x (expt 10 scale)). This scaling is exact,
1333 ;;; and cannot lose precision.
1334 ;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1335 ;;; number of fraction digits which will be produced, regardless
1336 ;;; of the value of WIDTH or FDIGITS. This feature is used by
1337 ;;; the ~E format directive to prevent complete loss of
1338 ;;; significance in the printed value due to a bogus choice of
1342 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1343 ;;; where the results have the following interpretation:
1345 ;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1346 ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1347 ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1349 ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1351 ;;; POINT-POS - The position of the digit preceding the decimal
1352 ;;; point. Zero indicates point before first digit.
1354 ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
1355 ;;; accuracy. Specifically, the decimal number printed is the closest
1356 ;;; possible approximation to the true value of the binary number to
1357 ;;; be printed from among all decimal representations with the same
1358 ;;; number of digits. In free-format output, i.e. with the number of
1359 ;;; digits unconstrained, it is guaranteed that all the information is
1360 ;;; preserved, so that a properly- rounding reader can reconstruct the
1361 ;;; original binary number, bit-for-bit, from its printed decimal
1362 ;;; representation. Furthermore, only as many digits as necessary to
1363 ;;; satisfy this condition will be printed.
1365 ;;; FLOAT-DIGITS actually generates the digits for positive numbers;
1366 ;;; see below for comments.
1368 (defun flonum-to-string (x &optional width fdigits scale fmin)
1369 (declare (type float x))
1370 ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with
1371 ;; possibly-negative X.
1373 (multiple-value-bind (e string)
1375 (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
1377 (if (and width (> width 1))
1378 (let ((w (multiple-value-list
1382 (if (and scale (minusp scale))
1385 (f (multiple-value-list
1386 (flonum-to-digits x (- (+ (or fmin 0)
1387 (if scale scale 0)))))))
1389 ((>= (length (cadr w)) (length (cadr f)))
1391 (t (values-list f))))
1392 (flonum-to-digits x)))
1393 (let ((e (if (zerop x)
1395 (+ e (or scale 0))))
1396 (stream (make-string-output-stream)))
1399 (write-string string stream :end (min (length string) e))
1400 (dotimes (i (- e (length string)))
1401 (write-char #\0 stream))
1402 (write-char #\. stream)
1403 (write-string string stream :start (min (length string) e))
1405 (dotimes (i (- fdigits
1407 (min (length string) e))))
1408 (write-char #\0 stream))))
1410 (write-string "." stream)
1412 (write-char #\0 stream))
1413 (write-string string stream :end (when fdigits
1414 (min (length string)
1418 (dotimes (i (+ fdigits e (- (length string))))
1419 (write-char #\0 stream)))))
1420 (let ((string (get-output-stream-string stream)))
1421 (values string (length string)
1422 (char= (char string 0) #\.)
1423 (char= (char string (1- (length string))) #\.)
1424 (position #\. string))))))
1426 ;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
1427 ;;; extended in order to handle rounding.
1429 ;;; As the implementation of the Dragon from Classic CMUCL (and
1430 ;;; previously in SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN
1431 ;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE
1432 ;;; PAPER!", and in this case we have to add that even reading the
1433 ;;; paper might not bring immediate illumination as CSR has attempted
1434 ;;; to turn idiomatic Scheme into idiomatic Lisp.
1436 ;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
1437 ;;; algorithm, noticeably slow at finding the exponent. Figure 2 has
1438 ;;; an improved algorithm, but CSR ran out of energy.
1440 ;;; possible extension for the enthusiastic: printing floats in bases
1441 ;;; other than base 10.
1442 (defconstant single-float-min-e
1443 (- 2 sb!vm:single-float-bias sb!vm:single-float-digits))
1444 (defconstant double-float-min-e
1445 (- 2 sb!vm:double-float-bias sb!vm:double-float-digits))
1447 (defconstant long-float-min-e
1448 (nth-value 1 (decode-float least-positive-long-float)))
1450 (defun flonum-to-digits (v &optional position relativep)
1451 (let ((print-base 10) ; B
1453 (float-digits (float-digits v)) ; p
1454 (digit-characters "0123456789")
1457 (single-float single-float-min-e)
1458 (double-float double-float-min-e)
1460 (long-float long-float-min-e))))
1461 (multiple-value-bind (f e)
1462 (integer-decode-float v)
1463 (let (;; FIXME: these even tests assume normal IEEE rounding
1464 ;; mode. I wonder if we should cater for non-normal?
1467 (with-push-char (:element-type base-char)
1468 (labels ((scale (r s m+ m-)
1470 (s s (* s print-base)))
1471 ((not (or (> (+ r m+) s)
1472 (and high-ok (= (+ r m+) s))))
1474 (r r (* r print-base))
1475 (m+ m+ (* m+ print-base))
1476 (m- m- (* m- print-base)))
1477 ((not (and (plusp (- r m-)) ; Extension to handle zero
1478 (or (< (* (+ r m+) print-base) s)
1480 (= (* (+ r m+) print-base) s)))))
1481 (values k (generate r s m+ m-)))))))
1482 (generate (r s m+ m-)
1486 (setf (values d r) (truncate (* r print-base) s))
1487 (setf m+ (* m+ print-base))
1488 (setf m- (* m- print-base))
1489 (setf tc1 (or (< r m-) (and low-ok (= r m-))))
1490 (setf tc2 (or (> (+ r m+) s)
1491 (and high-ok (= (+ r m+) s))))
1494 (push-char (char digit-characters d))
1498 ((and (not tc1) tc2) (1+ d))
1499 ((and tc1 (not tc2)) d)
1501 (if (< (* r 2) s) d (1+ d))))))
1502 (push-char (char digit-characters d))
1503 (return-from generate (get-pushed-string))))))
1507 (let* ((be (expt float-radix e))
1508 (be1 (* be float-radix)))
1509 (if (/= f (expt float-radix (1- float-digits)))
1519 (/= f (expt float-radix (1- float-digits))))
1521 s (* (expt float-radix (- e)) 2)
1524 (setf r (* f float-radix 2)
1525 s (* (expt float-radix (- 1 e)) 2)
1530 (aver (> position 0))
1532 ;; running out of letters here
1533 (l 1 (* l print-base)))
1534 ((>= (* s l) (+ r m+))
1536 (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
1537 (* s (expt print-base k)))
1538 (setf position (- k position))
1539 (setf position (- k position 1))))))
1540 (let ((low (max m- (/ (* s (expt print-base position)) 2)))
1541 (high (max m+ (/ (* s (expt print-base position)) 2))))
1548 (values r s m+ m-))))
1549 (multiple-value-bind (r s m+ m-) (initialize)
1550 (scale r s m+ m-))))))))
1552 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
1553 ;;; a new floating point number Z in the range (0.1, 1.0] and an
1554 ;;; exponent E such that Z * 10^E is (approximately) equal to the
1555 ;;; original number. There may be some loss of precision due the
1556 ;;; floating point representation. The scaling is always done with
1557 ;;; long float arithmetic, which helps printing of lesser precisions
1558 ;;; as well as avoiding generic arithmetic.
1560 ;;; When computing our initial scale factor using EXPT, we pull out
1561 ;;; part of the computation to avoid over/under flow. When
1562 ;;; denormalized, we must pull out a large factor, since there is more
1563 ;;; negative exponent range than positive range.
1565 (eval-when (:compile-toplevel :execute)
1566 (setf *read-default-float-format*
1567 #!+long-float 'long-float #!-long-float 'double-float))
1568 (defun scale-exponent (original-x)
1569 (let* ((x (coerce original-x 'long-float)))
1570 (multiple-value-bind (sig exponent) (decode-float x)
1571 (declare (ignore sig))
1573 (values (float 0.0e0 original-x) 1)
1574 (let* ((ex (locally (declare (optimize (safety 0)))
1577 ;; this is the closest double float
1578 ;; to (log 2 10), but expressed so
1579 ;; that we're not vulnerable to the
1580 ;; host lisp's interpretation of
1581 ;; arithmetic. (FIXME: it turns
1582 ;; out that sbcl itself is off by 1
1583 ;; ulp in this value, which is a
1584 ;; little unfortunate.)
1587 (sb!kernel:make-double-float 1070810131 1352628735)
1589 (error "(log 2 10) not computed")))))))
1591 (if (float-denormalized-p x)
1593 (* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
1595 (* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
1596 (* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
1597 (/ x 10.0e0 (expt 10.0e0 (1- ex))))))
1598 (do ((d 10.0e0 (* d 10.0e0))
1602 (do ((m 10.0e0 (* m 10.0e0))
1606 (values (float z original-x) ex))
1607 (declare (long-float m) (integer ex))))
1608 (declare (long-float d))))))))
1609 (eval-when (:compile-toplevel :execute)
1610 (setf *read-default-float-format* 'single-float))
1612 ;;;; entry point for the float printer
1614 ;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
1615 ;;; argument is printed free-format, in either exponential or
1616 ;;; non-exponential notation, depending on its magnitude.
1618 ;;; NOTE: When a number is to be printed in exponential format, it is
1619 ;;; scaled in floating point. Since precision may be lost in this
1620 ;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
1621 ;;; are lost. The difficulty is that FLONUM-TO-STRING performs
1622 ;;; extensive computations with integers of similar magnitude to that
1623 ;;; of the number being printed. For large exponents, the bignums
1624 ;;; really get out of hand. If bignum arithmetic becomes reasonably
1625 ;;; fast and the exponent range is not too large, then it might become
1626 ;;; attractive to handle exponential notation with the same accuracy
1627 ;;; as non-exponential notation, using the method described in the
1628 ;;; Steele and White paper.
1630 ;;; NOTE II: this has been bypassed slightly by implementing Burger
1631 ;;; and Dybvig, 1996. When someone has time (KLUDGE) they can
1632 ;;; probably (a) implement the optimizations suggested by Burger and
1633 ;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
1634 ;;; fixed-format printing.
1636 ;;; Print the appropriate exponent marker for X and the specified exponent.
1637 (defun print-float-exponent (x exp stream)
1638 (declare (type float x) (type integer exp) (type stream stream))
1639 (let ((*print-radix* nil))
1640 (if (typep x *read-default-float-format*)
1642 (format stream "e~D" exp))
1643 (format stream "~C~D"
1651 (defun output-float-infinity (x stream)
1652 (declare (float x) (stream stream))
1654 (write-string "#." stream))
1656 (return-from output-float-infinity
1657 (print-not-readable-error x stream)))
1659 (write-string "#<" stream)))
1660 (write-string "SB-EXT:" stream)
1661 (write-string (symbol-name (float-format-name x)) stream)
1662 (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
1664 (write-string "INFINITY" stream)
1666 (write-string ">" stream)))
1668 (defun output-float-nan (x stream)
1669 (print-unreadable-object (x stream)
1670 (princ (float-format-name x) stream)
1671 (write-string (if (float-trapping-nan-p x) " trapping" " quiet") stream)
1672 (write-string " NaN" stream)))
1674 ;;; the function called by OUTPUT-OBJECT to handle floats
1675 (defun output-float (x stream)
1677 ((float-infinity-p x)
1678 (output-float-infinity x stream))
1680 (output-float-nan x stream))
1682 (let ((x (cond ((minusp (float-sign x))
1683 (write-char #\- stream)
1689 (write-string "0.0" stream)
1690 (print-float-exponent x 0 stream))
1692 (output-float-aux x stream -3 8)))))))
1694 (defun output-float-aux (x stream e-min e-max)
1695 (multiple-value-bind (e string)
1696 (flonum-to-digits x)
1701 (write-string string stream :end (min (length string) e))
1702 (dotimes (i (- e (length string)))
1703 (write-char #\0 stream))
1704 (write-char #\. stream)
1705 (write-string string stream :start (min (length string) e))
1706 (when (<= (length string) e)
1707 (write-char #\0 stream))
1708 (print-float-exponent x 0 stream))
1710 (write-string "0." stream)
1712 (write-char #\0 stream))
1713 (write-string string stream)
1714 (print-float-exponent x 0 stream))))
1715 (t (write-string string stream :end 1)
1716 (write-char #\. stream)
1717 (write-string string stream :start 1)
1718 (print-float-exponent x (1- e) stream)))))
1720 ;;;; other leaf objects
1722 ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
1723 ;;; the character name or the character in the #\char format.
1724 (defun output-character (char stream)
1725 (if (or *print-escape* *print-readably*)
1726 (let ((graphicp (and (graphic-char-p char)
1727 (standard-char-p char)))
1728 (name (char-name char)))
1729 (write-string "#\\" stream)
1730 (if (and name (not graphicp))
1731 (quote-string name stream)
1732 (write-char char stream)))
1733 (write-char char stream)))
1735 (defun output-sap (sap stream)
1736 (declare (type system-area-pointer sap))
1738 (format stream "#.(~S #X~8,'0X)" 'int-sap (sap-int sap)))
1740 (print-unreadable-object (sap stream)
1741 (format stream "system area pointer: #X~8,'0X" (sap-int sap))))))
1743 (defun output-weak-pointer (weak-pointer stream)
1744 (declare (type weak-pointer weak-pointer))
1745 (print-unreadable-object (weak-pointer stream)
1746 (multiple-value-bind (value validp) (weak-pointer-value weak-pointer)
1748 (write-string "weak pointer: " stream)
1749 (write value :stream stream))
1751 (write-string "broken weak pointer" stream))))))
1753 (defun output-code-component (component stream)
1754 (print-unreadable-object (component stream :identity t)
1755 (let ((dinfo (%code-debug-info component)))
1756 (cond ((eq dinfo :bogus-lra)
1757 (write-string "bogus code object" stream))
1759 (write-string "code object" stream)
1761 (write-char #\space stream)
1762 (output-object (sb!c::debug-info-name dinfo) stream)))))))
1764 (defun output-lra (lra stream)
1765 (print-unreadable-object (lra stream :identity t)
1766 (write-string "return PC object" stream)))
1768 (defun output-fdefn (fdefn stream)
1769 (print-unreadable-object (fdefn stream)
1770 (write-string "FDEFINITION object for " stream)
1771 (output-object (fdefn-name fdefn) stream)))
1775 ;;; Output OBJECT as using PRINT-OBJECT if it's a
1776 ;;; FUNCALLABLE-STANDARD-CLASS, or return NIL otherwise.
1778 ;;; The definition here is a simple temporary placeholder. It will be
1779 ;;; overwritten by a smarter version (capable of calling generic
1780 ;;; PRINT-OBJECT when appropriate) when CLOS is installed.
1781 (defun printed-as-funcallable-standard-class (object stream)
1782 (declare (ignore object stream))
1785 (defun output-fun (object stream)
1786 (let* ((*print-length* 4) ; in case we have to..
1787 (*print-level* 3) ; ..print an interpreted function definition
1788 (name (%fun-name object))
1789 (proper-name-p (and (legal-fun-name-p name) (fboundp name)
1790 (eq (fdefinition name) object))))
1791 (print-unreadable-object (object stream :identity (not proper-name-p))
1792 (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
1796 ;;;; catch-all for unknown things
1798 (defun output-random (object stream)
1799 (print-unreadable-object (object stream :identity t)
1800 (let ((lowtag (lowtag-of object)))
1802 (#.sb!vm:other-pointer-lowtag
1803 (let ((widetag (widetag-of object)))
1805 (#.sb!vm:value-cell-header-widetag
1806 (write-string "value cell " stream)
1807 (output-object (value-cell-ref object) stream))
1809 (write-string "unknown pointer object, widetag=" stream)
1810 (let ((*print-base* 16) (*print-radix* t))
1811 (output-integer widetag stream))))))
1812 ((#.sb!vm:fun-pointer-lowtag
1813 #.sb!vm:instance-pointer-lowtag
1814 #.sb!vm:list-pointer-lowtag)
1815 (write-string "unknown pointer object, lowtag=" stream)
1816 (let ((*print-base* 16) (*print-radix* t))
1817 (output-integer lowtag stream)))
1819 (case (widetag-of object)
1820 (#.sb!vm:unbound-marker-widetag
1821 (write-string "unbound marker" stream))
1823 (write-string "unknown immediate object, lowtag=" stream)
1824 (let ((*print-base* 2) (*print-radix* t))
1825 (output-integer lowtag stream))
1826 (write-string ", widetag=" stream)
1827 (let ((*print-base* 16) (*print-radix* t))
1828 (output-integer (widetag-of object) stream)))))))))