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-vector (vector stream)
995 (declare (vector vector))
996 (cond ((stringp vector)
997 (cond ((and *print-readably*
998 (not (eq (array-element-type vector)
1001 (make-array 0 :element-type 'character))))))
1002 (print-not-readable-error vector stream))
1003 ((or *print-escape* *print-readably*)
1004 (write-char #\" stream)
1005 (quote-string vector stream)
1006 (write-char #\" stream))
1008 (write-string vector stream))))
1009 ((not (or *print-array* *print-readably*))
1010 (output-terse-array vector stream))
1011 ((bit-vector-p vector)
1012 (write-string "#*" stream)
1013 (dovector (bit vector)
1014 ;; (Don't use OUTPUT-OBJECT here, since this code
1015 ;; has to work for all possible *PRINT-BASE* values.)
1016 (write-char (if (zerop bit) #\0 #\1) stream)))
1018 (when (and *print-readably*
1019 (not (array-readably-printable-p vector)))
1020 (return-from output-vector
1021 (print-not-readable-error vector stream)))
1022 (descend-into (stream)
1023 (write-string "#(" stream)
1024 (dotimes (i (length vector))
1026 (write-char #\space stream))
1027 (punt-print-if-too-long i stream)
1028 (output-object (aref vector i) stream))
1029 (write-string ")" stream)))))
1031 ;;; This function outputs a string quoting characters sufficiently
1032 ;;; so that someone can read it in again. Basically, put a slash in
1033 ;;; front of an character satisfying NEEDS-SLASH-P.
1034 (defun quote-string (string stream)
1035 (macrolet ((needs-slash-p (char)
1036 ;; KLUDGE: We probably should look at the readtable, but just do
1037 ;; this for now. [noted by anonymous long ago] -- WHN 19991130
1038 `(or (char= ,char #\\)
1039 (char= ,char #\"))))
1040 (with-array-data ((data string) (start) (end)
1041 :check-fill-pointer t)
1042 (do ((index start (1+ index)))
1044 (let ((char (schar data index)))
1045 (when (needs-slash-p char) (write-char #\\ stream))
1046 (write-char char stream))))))
1048 (defun array-readably-printable-p (array)
1049 (and (eq (array-element-type array) t)
1050 (let ((zero (position 0 (array-dimensions array)))
1051 (number (position 0 (array-dimensions array)
1052 :test (complement #'eql)
1054 (or (null zero) (null number) (> zero number)))))
1056 ;;; Output the printed representation of any array in either the #< or #A
1058 (defun output-array (array stream)
1059 (if (or *print-array* *print-readably*)
1060 (output-array-guts array stream)
1061 (output-terse-array array stream)))
1063 ;;; Output the abbreviated #< form of an array.
1064 (defun output-terse-array (array stream)
1065 (let ((*print-level* nil)
1066 (*print-length* nil))
1067 (print-unreadable-object (array stream :type t :identity t))))
1069 ;;; Output the readable #A form of an array.
1070 (defun output-array-guts (array stream)
1071 (when (and *print-readably*
1072 (not (array-readably-printable-p array)))
1073 (return-from output-array-guts
1074 (print-not-readable-error array stream)))
1075 (write-char #\# stream)
1076 (let ((*print-base* 10)
1077 (*print-radix* nil))
1078 (output-integer (array-rank array) stream))
1079 (write-char #\A stream)
1080 (with-array-data ((data array) (start) (end))
1081 (declare (ignore end))
1082 (sub-output-array-guts data (array-dimensions array) stream start)))
1084 (defun sub-output-array-guts (array dimensions stream index)
1085 (declare (type (simple-array * (*)) array) (fixnum index))
1086 (cond ((null dimensions)
1087 (output-object (aref array index) stream))
1089 (descend-into (stream)
1090 (write-char #\( stream)
1091 (let* ((dimension (car dimensions))
1092 (dimensions (cdr dimensions))
1093 (count (reduce #'* dimensions)))
1094 (dotimes (i dimension)
1096 (write-char #\space stream))
1097 (punt-print-if-too-long i stream)
1098 (sub-output-array-guts array dimensions stream index)
1099 (incf index count)))
1100 (write-char #\) stream)))))
1102 ;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
1103 ;;; use until CLOS is set up (at which time it will be replaced with
1104 ;;; the real generic function implementation)
1105 (defun print-object (instance stream)
1106 (default-structure-print instance stream *current-level-in-print*))
1108 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
1110 (defun %output-radix (base stream)
1111 (write-char #\# stream)
1112 (write-char (case base
1116 (t (%output-reasonable-integer-in-base base 10 stream)
1120 (defun %output-reasonable-integer-in-base (n base stream)
1121 (multiple-value-bind (q r)
1123 ;; Recurse until you have all the digits pushed on
1126 (%output-reasonable-integer-in-base q base stream))
1127 ;; Then as each recursive call unwinds, turn the
1128 ;; digit (in remainder) into a character and output
1131 (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
1134 ;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is
1135 ;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called
1136 ;;; always prior a GC to drop overly large bignums from the cache.
1138 ;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or
1139 ;;; POWERS-FOR-BASE, see that you don't break the assumptions!
1140 (defvar *power-cache* nil)
1142 (defconstant +power-cache-integer-length-limit+ 2048)
1144 (defun scrub-power-cache ()
1145 (let ((cache *power-cache*))
1146 (dolist (cell cache)
1147 (let ((powers (cdr cell)))
1148 (declare (simple-vector powers))
1149 (let ((too-big (position-if
1151 (>= (integer-length x)
1152 +power-cache-integer-length-limit+))
1155 (setf (cdr cell) (subseq powers 0 too-big))))))
1156 ;; Since base 10 is overwhelmingly common, make sure it's at head.
1157 ;; Try to keep other bases in a hopefully sensible order as well.
1158 (if (eql 10 (caar cache))
1159 (setf *power-cache* cache)
1160 ;; If we modify the list destructively we need to copy it, otherwise
1161 ;; an alist lookup in progress might be screwed.
1162 (setf *power-cache* (sort (copy-list cache)
1164 (declare (fixnum a b))
1174 ;;; Compute (and cache) a power vector for a BASE and LIMIT:
1175 ;;; the vector holds integers for which
1176 ;;; (aref powers k) == (expt base (expt 2 k))
1178 (defun powers-for-base (base limit)
1179 (flet ((compute-powers (from)
1181 (do ((p from (* p p)))
1183 ;; We don't actually need this, but we also
1184 ;; prefer not to cons it up a second time...
1187 (nreverse powers))))
1188 ;; Grab a local reference so that we won't stuff consed at the
1189 ;; head by other threads -- or sorting by SCRUB-POWER-CACHE.
1190 (let ((cache *power-cache*))
1191 (let ((cell (assoc base cache)))
1193 (let* ((powers (cdr cell))
1194 (len (length powers))
1195 (max (svref powers (1- len))))
1199 (concatenate 'vector powers
1200 (compute-powers (* max max)))))
1201 (setf (cdr cell) new)
1203 (let ((powers (coerce (compute-powers base) 'vector)))
1204 ;; Add new base to head: SCRUB-POWER-CACHE will later
1205 ;; put it to a better place.
1206 (setf *power-cache* (acons base powers cache))
1209 ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
1210 (defun %output-huge-integer-in-base (n base stream)
1211 (declare (type bignum n) (type fixnum base))
1212 ;; POWER is a vector for which the following holds:
1213 ;; (aref power k) == (expt base (expt 2 k))
1214 (let* ((power (powers-for-base base n))
1215 (k-start (or (position-if (lambda (x) (> x n)) power)
1216 (bug "power-vector too short"))))
1217 (labels ((bisect (n k exactp)
1218 (declare (fixnum k))
1219 ;; N is the number to bisect
1220 ;; K on initial entry BASE^(2^K) > N
1221 ;; EXACTP is true if 2^K is the exact number of digits
1224 (loop repeat (ash 1 k) do (write-char #\0 stream))))
1227 (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)
1231 (multiple-value-bind (q r) (truncate n (aref power k))
1232 ;; EXACTP is NIL only at the head of the
1233 ;; initial number, as we don't know the number
1234 ;; of digits there, but we do know that it
1235 ;; doesn't get any leading zeros.
1237 (bisect r k (or exactp (plusp q))))))))
1238 (bisect n k-start nil))))
1240 (defun %output-integer-in-base (integer base stream)
1241 (when (minusp integer)
1242 (write-char #\- stream)
1243 (setf integer (- integer)))
1244 ;; The ideal cutoff point between these two algorithms is almost
1245 ;; certainly quite platform dependent: this gives 87 for 32 bit
1246 ;; SBCL, which is about right at least for x86/Darwin.
1247 (if (or (fixnump integer)
1248 (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits)))
1249 (%output-reasonable-integer-in-base integer base stream)
1250 (%output-huge-integer-in-base integer base stream)))
1252 (defun output-integer (integer stream)
1253 (let ((base *print-base*))
1254 (when (and (/= base 10) *print-radix*)
1255 (%output-radix base stream))
1256 (%output-integer-in-base integer base stream)
1257 (when (and *print-radix* (= base 10))
1258 (write-char #\. stream))))
1260 (defun output-ratio (ratio stream)
1261 (let ((base *print-base*))
1263 (%output-radix base stream))
1264 (%output-integer-in-base (numerator ratio) base stream)
1265 (write-char #\/ stream)
1266 (%output-integer-in-base (denominator ratio) base stream)))
1268 (defun output-complex (complex stream)
1269 (write-string "#C(" stream)
1270 ;; FIXME: Could this just be OUTPUT-NUMBER?
1271 (output-object (realpart complex) stream)
1272 (write-char #\space stream)
1273 (output-object (imagpart complex) stream)
1274 (write-char #\) stream))
1278 ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
1279 ;;; most of the work for all printing of floating point numbers in
1280 ;;; FORMAT. It converts a floating point number to a string in a free
1281 ;;; or fixed format with no exponent. The interpretation of the
1282 ;;; arguments is as follows:
1284 ;;; X - The floating point number to convert, which must not be
1286 ;;; WIDTH - The preferred field width, used to determine the number
1287 ;;; of fraction digits to produce if the FDIGITS parameter
1288 ;;; is unspecified or NIL. If the non-fraction digits and the
1289 ;;; decimal point alone exceed this width, no fraction digits
1290 ;;; will be produced unless a non-NIL value of FDIGITS has been
1291 ;;; specified. Field overflow is not considerd an error at this
1293 ;;; FDIGITS - The number of fractional digits to produce. Insignificant
1294 ;;; trailing zeroes may be introduced as needed. May be
1295 ;;; unspecified or NIL, in which case as many digits as possible
1296 ;;; are generated, subject to the constraint that there are no
1297 ;;; trailing zeroes.
1298 ;;; SCALE - If this parameter is specified or non-NIL, then the number
1299 ;;; printed is (* x (expt 10 scale)). This scaling is exact,
1300 ;;; and cannot lose precision.
1301 ;;; FMIN - This parameter, if specified or non-NIL, is the minimum
1302 ;;; number of fraction digits which will be produced, regardless
1303 ;;; of the value of WIDTH or FDIGITS. This feature is used by
1304 ;;; the ~E format directive to prevent complete loss of
1305 ;;; significance in the printed value due to a bogus choice of
1309 ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
1310 ;;; where the results have the following interpretation:
1312 ;;; DIGIT-STRING - The decimal representation of X, with decimal point.
1313 ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
1314 ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
1316 ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
1318 ;;; POINT-POS - The position of the digit preceding the decimal
1319 ;;; point. Zero indicates point before first digit.
1321 ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
1322 ;;; accuracy. Specifically, the decimal number printed is the closest
1323 ;;; possible approximation to the true value of the binary number to
1324 ;;; be printed from among all decimal representations with the same
1325 ;;; number of digits. In free-format output, i.e. with the number of
1326 ;;; digits unconstrained, it is guaranteed that all the information is
1327 ;;; preserved, so that a properly- rounding reader can reconstruct the
1328 ;;; original binary number, bit-for-bit, from its printed decimal
1329 ;;; representation. Furthermore, only as many digits as necessary to
1330 ;;; satisfy this condition will be printed.
1332 ;;; FLOAT-DIGITS actually generates the digits for positive numbers;
1333 ;;; see below for comments.
1335 (defun flonum-to-string (x &optional width fdigits scale fmin)
1336 (declare (type float x))
1337 ;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with
1338 ;; possibly-negative X.
1340 (multiple-value-bind (e string)
1342 (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
1344 (if (and width (> width 1))
1345 (let ((w (multiple-value-list
1349 (if (and scale (minusp scale))
1352 (f (multiple-value-list
1353 (flonum-to-digits x (- (+ (or fmin 0)
1354 (if scale scale 0)))))))
1356 ((>= (length (cadr w)) (length (cadr f)))
1358 (t (values-list f))))
1359 (flonum-to-digits x)))
1360 (let ((e (if (zerop x)
1362 (+ e (or scale 0))))
1363 (stream (make-string-output-stream)))
1366 (write-string string stream :end (min (length string) e))
1367 (dotimes (i (- e (length string)))
1368 (write-char #\0 stream))
1369 (write-char #\. stream)
1370 (write-string string stream :start (min (length string) e))
1372 (dotimes (i (- fdigits
1374 (min (length string) e))))
1375 (write-char #\0 stream))))
1377 (write-string "." stream)
1379 (write-char #\0 stream))
1380 (write-string string stream :end (when fdigits
1381 (min (length string)
1385 (dotimes (i (+ fdigits e (- (length string))))
1386 (write-char #\0 stream)))))
1387 (let ((string (get-output-stream-string stream)))
1388 (values string (length string)
1389 (char= (char string 0) #\.)
1390 (char= (char string (1- (length string))) #\.)
1391 (position #\. string))))))
1393 ;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
1394 ;;; extended in order to handle rounding.
1396 ;;; As the implementation of the Dragon from Classic CMUCL (and
1397 ;;; previously in SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN
1398 ;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE
1399 ;;; PAPER!", and in this case we have to add that even reading the
1400 ;;; paper might not bring immediate illumination as CSR has attempted
1401 ;;; to turn idiomatic Scheme into idiomatic Lisp.
1403 ;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
1404 ;;; algorithm, noticeably slow at finding the exponent. Figure 2 has
1405 ;;; an improved algorithm, but CSR ran out of energy.
1407 ;;; possible extension for the enthusiastic: printing floats in bases
1408 ;;; other than base 10.
1409 (defconstant single-float-min-e
1410 (- 2 sb!vm:single-float-bias sb!vm:single-float-digits))
1411 (defconstant double-float-min-e
1412 (- 2 sb!vm:double-float-bias sb!vm:double-float-digits))
1414 (defconstant long-float-min-e
1415 (nth-value 1 (decode-float least-positive-long-float)))
1417 (defun flonum-to-digits (v &optional position relativep)
1418 (let ((print-base 10) ; B
1420 (float-digits (float-digits v)) ; p
1421 (digit-characters "0123456789")
1424 (single-float single-float-min-e)
1425 (double-float double-float-min-e)
1427 (long-float long-float-min-e))))
1428 (multiple-value-bind (f e)
1429 (integer-decode-float v)
1430 (let (;; FIXME: these even tests assume normal IEEE rounding
1431 ;; mode. I wonder if we should cater for non-normal?
1434 (with-push-char (:element-type base-char)
1435 (labels ((scale (r s m+ m-)
1437 (s s (* s print-base)))
1438 ((not (or (> (+ r m+) s)
1439 (and high-ok (= (+ r m+) s))))
1441 (r r (* r print-base))
1442 (m+ m+ (* m+ print-base))
1443 (m- m- (* m- print-base)))
1444 ((not (and (plusp (- r m-)) ; Extension to handle zero
1445 (or (< (* (+ r m+) print-base) s)
1447 (= (* (+ r m+) print-base) s)))))
1448 (values k (generate r s m+ m-)))))))
1449 (generate (r s m+ m-)
1453 (setf (values d r) (truncate (* r print-base) s))
1454 (setf m+ (* m+ print-base))
1455 (setf m- (* m- print-base))
1456 (setf tc1 (or (< r m-) (and low-ok (= r m-))))
1457 (setf tc2 (or (> (+ r m+) s)
1458 (and high-ok (= (+ r m+) s))))
1461 (push-char (char digit-characters d))
1465 ((and (not tc1) tc2) (1+ d))
1466 ((and tc1 (not tc2)) d)
1468 (if (< (* r 2) s) d (1+ d))))))
1469 (push-char (char digit-characters d))
1470 (return-from generate (get-pushed-string))))))
1474 (let* ((be (expt float-radix e))
1475 (be1 (* be float-radix)))
1476 (if (/= f (expt float-radix (1- float-digits)))
1486 (/= f (expt float-radix (1- float-digits))))
1488 s (* (expt float-radix (- e)) 2)
1491 (setf r (* f float-radix 2)
1492 s (* (expt float-radix (- 1 e)) 2)
1497 (aver (> position 0))
1499 ;; running out of letters here
1500 (l 1 (* l print-base)))
1501 ((>= (* s l) (+ r m+))
1503 (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
1504 (* s (expt print-base k)))
1505 (setf position (- k position))
1506 (setf position (- k position 1))))))
1507 (let ((low (max m- (/ (* s (expt print-base position)) 2)))
1508 (high (max m+ (/ (* s (expt print-base position)) 2))))
1515 (values r s m+ m-))))
1516 (multiple-value-bind (r s m+ m-) (initialize)
1517 (scale r s m+ m-))))))))
1519 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
1520 ;;; a new floating point number Z in the range (0.1, 1.0] and an
1521 ;;; exponent E such that Z * 10^E is (approximately) equal to the
1522 ;;; original number. There may be some loss of precision due the
1523 ;;; floating point representation. The scaling is always done with
1524 ;;; long float arithmetic, which helps printing of lesser precisions
1525 ;;; as well as avoiding generic arithmetic.
1527 ;;; When computing our initial scale factor using EXPT, we pull out
1528 ;;; part of the computation to avoid over/under flow. When
1529 ;;; denormalized, we must pull out a large factor, since there is more
1530 ;;; negative exponent range than positive range.
1532 (eval-when (:compile-toplevel :execute)
1533 (setf *read-default-float-format*
1534 #!+long-float 'long-float #!-long-float 'double-float))
1535 (defun scale-exponent (original-x)
1536 (let* ((x (coerce original-x 'long-float)))
1537 (multiple-value-bind (sig exponent) (decode-float x)
1538 (declare (ignore sig))
1540 (values (float 0.0e0 original-x) 1)
1541 (let* ((ex (locally (declare (optimize (safety 0)))
1544 ;; this is the closest double float
1545 ;; to (log 2 10), but expressed so
1546 ;; that we're not vulnerable to the
1547 ;; host lisp's interpretation of
1548 ;; arithmetic. (FIXME: it turns
1549 ;; out that sbcl itself is off by 1
1550 ;; ulp in this value, which is a
1551 ;; little unfortunate.)
1554 (sb!kernel:make-double-float 1070810131 1352628735)
1556 (error "(log 2 10) not computed")))))))
1558 (if (float-denormalized-p x)
1560 (* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
1562 (* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
1563 (* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
1564 (/ x 10.0e0 (expt 10.0e0 (1- ex))))))
1565 (do ((d 10.0e0 (* d 10.0e0))
1569 (do ((m 10.0e0 (* m 10.0e0))
1573 (values (float z original-x) ex))
1574 (declare (long-float m) (integer ex))))
1575 (declare (long-float d))))))))
1576 (eval-when (:compile-toplevel :execute)
1577 (setf *read-default-float-format* 'single-float))
1579 ;;;; entry point for the float printer
1581 ;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
1582 ;;; argument is printed free-format, in either exponential or
1583 ;;; non-exponential notation, depending on its magnitude.
1585 ;;; NOTE: When a number is to be printed in exponential format, it is
1586 ;;; scaled in floating point. Since precision may be lost in this
1587 ;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
1588 ;;; are lost. The difficulty is that FLONUM-TO-STRING performs
1589 ;;; extensive computations with integers of similar magnitude to that
1590 ;;; of the number being printed. For large exponents, the bignums
1591 ;;; really get out of hand. If bignum arithmetic becomes reasonably
1592 ;;; fast and the exponent range is not too large, then it might become
1593 ;;; attractive to handle exponential notation with the same accuracy
1594 ;;; as non-exponential notation, using the method described in the
1595 ;;; Steele and White paper.
1597 ;;; NOTE II: this has been bypassed slightly by implementing Burger
1598 ;;; and Dybvig, 1996. When someone has time (KLUDGE) they can
1599 ;;; probably (a) implement the optimizations suggested by Burger and
1600 ;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
1601 ;;; fixed-format printing.
1603 ;;; Print the appropriate exponent marker for X and the specified exponent.
1604 (defun print-float-exponent (x exp stream)
1605 (declare (type float x) (type integer exp) (type stream stream))
1606 (let ((*print-radix* nil))
1607 (if (typep x *read-default-float-format*)
1609 (format stream "e~D" exp))
1610 (format stream "~C~D"
1618 (defun output-float-infinity (x stream)
1619 (declare (float x) (stream stream))
1621 (write-string "#." stream))
1623 (return-from output-float-infinity
1624 (print-not-readable-error x stream)))
1626 (write-string "#<" stream)))
1627 (write-string "SB-EXT:" stream)
1628 (write-string (symbol-name (float-format-name x)) stream)
1629 (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
1631 (write-string "INFINITY" stream)
1633 (write-string ">" stream)))
1635 (defun output-float-nan (x stream)
1636 (print-unreadable-object (x stream)
1637 (princ (float-format-name x) stream)
1638 (write-string (if (float-trapping-nan-p x) " trapping" " quiet") stream)
1639 (write-string " NaN" stream)))
1641 ;;; the function called by OUTPUT-OBJECT to handle floats
1642 (defun output-float (x stream)
1644 ((float-infinity-p x)
1645 (output-float-infinity x stream))
1647 (output-float-nan x stream))
1649 (let ((x (cond ((minusp (float-sign x))
1650 (write-char #\- stream)
1656 (write-string "0.0" stream)
1657 (print-float-exponent x 0 stream))
1659 (output-float-aux x stream -3 8)))))))
1661 (defun output-float-aux (x stream e-min e-max)
1662 (multiple-value-bind (e string)
1663 (flonum-to-digits x)
1668 (write-string string stream :end (min (length string) e))
1669 (dotimes (i (- e (length string)))
1670 (write-char #\0 stream))
1671 (write-char #\. stream)
1672 (write-string string stream :start (min (length string) e))
1673 (when (<= (length string) e)
1674 (write-char #\0 stream))
1675 (print-float-exponent x 0 stream))
1677 (write-string "0." stream)
1679 (write-char #\0 stream))
1680 (write-string string stream)
1681 (print-float-exponent x 0 stream))))
1682 (t (write-string string stream :end 1)
1683 (write-char #\. stream)
1684 (write-string string stream :start 1)
1685 (print-float-exponent x (1- e) stream)))))
1687 ;;;; other leaf objects
1689 ;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
1690 ;;; the character name or the character in the #\char format.
1691 (defun output-character (char stream)
1692 (if (or *print-escape* *print-readably*)
1693 (let ((graphicp (and (graphic-char-p char)
1694 (standard-char-p char)))
1695 (name (char-name char)))
1696 (write-string "#\\" stream)
1697 (if (and name (not graphicp))
1698 (quote-string name stream)
1699 (write-char char stream)))
1700 (write-char char stream)))
1702 (defun output-sap (sap stream)
1703 (declare (type system-area-pointer sap))
1705 (format stream "#.(~S #X~8,'0X)" 'int-sap (sap-int sap)))
1707 (print-unreadable-object (sap stream)
1708 (format stream "system area pointer: #X~8,'0X" (sap-int sap))))))
1710 (defun output-weak-pointer (weak-pointer stream)
1711 (declare (type weak-pointer weak-pointer))
1712 (print-unreadable-object (weak-pointer stream)
1713 (multiple-value-bind (value validp) (weak-pointer-value weak-pointer)
1715 (write-string "weak pointer: " stream)
1716 (write value :stream stream))
1718 (write-string "broken weak pointer" stream))))))
1720 (defun output-code-component (component stream)
1721 (print-unreadable-object (component stream :identity t)
1722 (let ((dinfo (%code-debug-info component)))
1723 (cond ((eq dinfo :bogus-lra)
1724 (write-string "bogus code object" stream))
1726 (write-string "code object" stream)
1728 (write-char #\space stream)
1729 (output-object (sb!c::debug-info-name dinfo) stream)))))))
1731 (defun output-lra (lra stream)
1732 (print-unreadable-object (lra stream :identity t)
1733 (write-string "return PC object" stream)))
1735 (defun output-fdefn (fdefn stream)
1736 (print-unreadable-object (fdefn stream)
1737 (write-string "FDEFINITION object for " stream)
1738 (output-object (fdefn-name fdefn) stream)))
1742 ;;; Output OBJECT as using PRINT-OBJECT if it's a
1743 ;;; FUNCALLABLE-STANDARD-CLASS, or return NIL otherwise.
1745 ;;; The definition here is a simple temporary placeholder. It will be
1746 ;;; overwritten by a smarter version (capable of calling generic
1747 ;;; PRINT-OBJECT when appropriate) when CLOS is installed.
1748 (defun printed-as-funcallable-standard-class (object stream)
1749 (declare (ignore object stream))
1752 (defun output-fun (object stream)
1753 (let* ((*print-length* 4) ; in case we have to..
1754 (*print-level* 3) ; ..print an interpreted function definition
1755 (name (%fun-name object))
1756 (proper-name-p (and (legal-fun-name-p name) (fboundp name)
1757 (eq (fdefinition name) object))))
1758 (print-unreadable-object (object stream :identity (not proper-name-p))
1759 (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
1763 ;;;; catch-all for unknown things
1765 (defun output-random (object stream)
1766 (print-unreadable-object (object stream :identity t)
1767 (let ((lowtag (lowtag-of object)))
1769 (#.sb!vm:other-pointer-lowtag
1770 (let ((widetag (widetag-of object)))
1772 (#.sb!vm:value-cell-header-widetag
1773 (write-string "value cell " stream)
1774 (output-object (value-cell-ref object) stream))
1776 (write-string "unknown pointer object, widetag=" stream)
1777 (let ((*print-base* 16) (*print-radix* t))
1778 (output-integer widetag stream))))))
1779 ((#.sb!vm:fun-pointer-lowtag
1780 #.sb!vm:instance-pointer-lowtag
1781 #.sb!vm:list-pointer-lowtag)
1782 (write-string "unknown pointer object, lowtag=" stream)
1783 (let ((*print-base* 16) (*print-radix* t))
1784 (output-integer lowtag stream)))
1786 (case (widetag-of object)
1787 (#.sb!vm:unbound-marker-widetag
1788 (write-string "unbound marker" stream))
1790 (write-string "unknown immediate object, lowtag=" stream)
1791 (let ((*print-base* 2) (*print-radix* t))
1792 (output-integer lowtag stream))
1793 (write-string ", widetag=" stream)
1794 (let ((*print-base* 16) (*print-radix* t))
1795 (output-integer (widetag-of object) stream)))))))))