*PRINT-ESCAPE*.")
(defvar *print-escape* T
#!+sb-doc
- "Flag which indicates that slashification is on. See the manual")
+ "Should we print in a reasonably machine-readable way? (possibly
+ overridden by *PRINT-READABLY*)")
(defvar *print-pretty* nil ; (set later when pretty-printer is initialized)
#!+sb-doc
- "Flag which indicates that pretty printing is to be used")
+ "Should pretty printing be used?")
(defvar *print-base* 10.
#!+sb-doc
- "The output base for integers and rationals.")
+ "the output base for RATIONALs (including integers)")
(defvar *print-radix* nil
#!+sb-doc
- "This flag requests to verify base when printing rationals.")
+ "Should base be verified when printing RATIONALs?")
(defvar *print-level* nil
#!+sb-doc
- "How many levels deep to print. Unlimited if null.")
+ "How many levels should be printed before abbreviating with \"#\"?")
(defvar *print-length* nil
#!+sb-doc
- "How many elements to print on each level. Unlimited if null.")
+ "How many elements at any level should be printed before abbreviating
+ with \"...\"?")
(defvar *print-circle* nil
#!+sb-doc
- "Whether to worry about circular list structures. See the manual.")
+ "Should we use #n= and #n# notation to preserve uniqueness in general (and
+ circularity in particular) when printing?")
(defvar *print-case* :upcase
#!+sb-doc
- "What kind of case the printer should use by default")
+ "What case should the printer should use default?")
(defvar *print-array* t
#!+sb-doc
- "Whether the array should print its guts out")
+ "Should the contents of arrays be printed?")
(defvar *print-gensym* t
#!+sb-doc
- "If true, symbols with no home package are printed with a #: prefix.
- If false, no prefix is printed.")
+ "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
(defvar *print-lines* nil
#!+sb-doc
- "The maximum number of lines to print. If NIL, unlimited.")
+ "the maximum number of lines to print per object")
(defvar *print-right-margin* nil
#!+sb-doc
- "The position of the right margin in ems. If NIL, try to determine this
- from the stream in use.")
+ "the position of the right margin in ems (for pretty-printing)")
(defvar *print-miser-width* nil
#!+sb-doc
"If the remaining space between the current column and the right margin
is less than this, then print using ``miser-style'' output. Miser
style conditional newlines are turned on, and all indentations are
turned off. If NIL, never use miser mode.")
-(defvar *print-pprint-dispatch* nil
- #!+sb-doc
- "The pprint-dispatch-table that controls how to pretty print objects. See
- COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.")
+(defvar *print-pprint-dispatch*)
+#!+sb-doc
+(setf (fdocumentation '*print-pprint-dispatch* 'variable)
+ "the pprint-dispatch-table that controls how to pretty-print objects")
(defmacro with-standard-io-syntax (&body body)
#!+sb-doc
"Bind the reader and printer control variables to values that enable READ
to reliably read the results of PRINT. These values are:
- *PACKAGE* the COMMON-LISP-USER package
- *PRINT-ARRAY* T
- *PRINT-BASE* 10
- *PRINT-CASE* :UPCASE
- *PRINT-CIRCLE* NIL
- *PRINT-ESCAPE* T
- *PRINT-GENSYM* T
- *PRINT-LENGTH* NIL
- *PRINT-LEVEL* NIL
- *PRINT-LINES* NIL
- *PRINT-MISER-WIDTH* NIL
- *PRINT-PRETTY* NIL
- *PRINT-RADIX* NIL
- *PRINT-READABLY* T
- *PRINT-RIGHT-MARGIN* NIL
- *READ-BASE* 10
- *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
- *READ-EVAL* T
- *READ-SUPPRESS* NIL
- *READTABLE* the standard readtable."
- `(%with-standard-io-syntax #'(lambda () ,@body)))
+ *PACKAGE* the COMMON-LISP-USER package
+ *PRINT-ARRAY* T
+ *PRINT-BASE* 10
+ *PRINT-CASE* :UPCASE
+ *PRINT-CIRCLE* NIL
+ *PRINT-ESCAPE* T
+ *PRINT-GENSYM* T
+ *PRINT-LENGTH* NIL
+ *PRINT-LEVEL* NIL
+ *PRINT-LINES* NIL
+ *PRINT-MISER-WIDTH* NIL
+ *PRINT-PRETTY* NIL
+ *PRINT-RADIX* NIL
+ *PRINT-READABLY* T
+ *PRINT-RIGHT-MARGIN* NIL
+ *READ-BASE* 10
+ *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
+ *READ-EVAL* T
+ *READ-SUPPRESS* NIL
+ *READTABLE* the standard readtable"
+ `(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
+ (declare (type function function))
(let ((*package* (find-package "COMMON-LISP-USER"))
(*print-array* t)
(*print-base* 10)
(*read-eval* t)
(*read-suppress* nil)
;; FIXME: It doesn't seem like a good idea to expose our
- ;; disaster-recovery *STANDARD-READTABLE* here. Perhaps we
- ;; should do a COPY-READTABLE? The consing would be unfortunate,
- ;; though.
+ ;; disaster-recovery *STANDARD-READTABLE* here. What if some
+ ;; enterprising user corrupts the disaster-recovery readtable
+ ;; by doing destructive readtable operations within
+ ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
+ ;; COPY-READTABLE? The consing would be unfortunate, though.
(*readtable* *standard-readtable*))
(funcall function)))
\f
((:pprint-dispatch *print-pprint-dispatch*)
*print-pprint-dispatch*))
#!+sb-doc
- "Outputs OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
+ "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
(output-object object (out-synonym-of stream))
object)
(defun prin1 (object &optional stream)
#!+sb-doc
- "Outputs a mostly READable printed representation of OBJECT on the specified
+ "Output a mostly READable printed representation of OBJECT on the specified
STREAM."
- (let ((*print-escape* T))
+ (let ((*print-escape* t))
(output-object object (out-synonym-of stream)))
object)
(defun princ (object &optional stream)
#!+sb-doc
- "Outputs an aesthetic but not necessarily READable printed representation
+ "Output an aesthetic but not necessarily READable printed representation
of OBJECT on the specified STREAM."
- (let ((*print-escape* NIL)
- (*print-readably* NIL))
+ (let ((*print-escape* nil)
+ (*print-readably* nil))
(output-object object (out-synonym-of stream)))
object)
(defun print (object &optional stream)
#!+sb-doc
- "Outputs a terpri, the mostly READable printed represenation of OBJECT, and
+ "Output a newline, the mostly READable printed representation of OBJECT, and
space to the specified STREAM."
(let ((stream (out-synonym-of stream)))
(terpri stream)
(defun pprint (object &optional stream)
#!+sb-doc
- "Prettily outputs OBJECT preceded by a newline."
+ "Prettily output OBJECT preceded by a newline."
(let ((*print-pretty* t)
(*print-escape* t)
(stream (out-synonym-of stream)))
((:pprint-dispatch *print-pprint-dispatch*)
*print-pprint-dispatch*))
#!+sb-doc
- "Returns the printed representation of OBJECT as a string."
+ "Return the printed representation of OBJECT as a string."
(stringify-object object))
(defun prin1-to-string (object)
#!+sb-doc
- "Returns the printed representation of OBJECT as a string with
+ "Return the printed representation of OBJECT as a string with
slashification on."
- (stringify-object object t))
+ (let ((*print-escape* t))
+ (stringify-object object)))
(defun princ-to-string (object)
#!+sb-doc
- "Returns the printed representation of OBJECT as a string with
+ "Return the printed representation of OBJECT as a string with
slashification off."
- (stringify-object object nil))
+ (let ((*print-escape* nil)
+ (*print-readably* nil))
+ (stringify-object object)))
-;;; This produces the printed representation of an object as a string. The
-;;; few ...-TO-STRING functions above call this.
+;;; This produces the printed representation of an object as a string.
+;;; The few ...-TO-STRING functions above call this.
(defvar *string-output-streams* ())
-(defun stringify-object (object &optional (*print-escape* *print-escape*))
+(defun stringify-object (object)
(let ((stream (if *string-output-streams*
(pop *string-output-streams*)
(make-string-output-stream))))
;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
+ (declare (type (or null function) body))
(when *print-readably*
(error 'print-not-readable :object object))
(flet ((print-description ()
(when type
(write (type-of object) :stream stream :circle nil
:level nil :length nil)
- (when (or body identity)
- (write-char #\space stream)
- (pprint-newline :fill stream)))
+ (write-char #\space stream))
(when body
(funcall body))
(when identity
- (when body
- (write-char #\space stream)
- (pprint-newline :fill stream))
+ (when (or body (not type))
+ (write-char #\space stream))
(write-char #\{ stream)
(write (get-lisp-obj-address object) :stream stream
:radix nil :base 16)
(write-char #\> stream))))
nil)
\f
-;;;; WHITESPACE-CHAR-P
-
-;;; This is used in other files, but is defined in this one for some reason.
-
-(defun whitespace-char-p (char)
- #!+sb-doc
- "Determines whether or not the character is considered whitespace."
- (or (char= char #\space)
- (char= char (code-char tab-char-code))
- (char= char (code-char return-char-code))
- (char= char #\linefeed)))
-\f
;;;; circularity detection stuff
-;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that (eventually)
-;;; ends up with entries for every object printed. When we are initially
-;;; looking for circularities, we enter a T when we find an object for the
-;;; first time, and a 0 when we encounter an object a second time around.
-;;; When we are actually printing, the 0 entries get changed to the actual
-;;; marker value when they are first printed.
+;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
+;;; (eventually) ends up with entries for every object printed. When
+;;; we are initially looking for circularities, we enter a T when we
+;;; find an object for the first time, and a 0 when we encounter an
+;;; object a second time around. When we are actually printing, the 0
+;;; entries get changed to the actual marker value when they are first
+;;; printed.
(defvar *circularity-hash-table* nil)
-;;; When NIL, we are just looking for circularities. After we have found them
-;;; all, this gets bound to 0. Then whenever we need a new marker, it is
-;;; incremented.
+;;; When NIL, we are just looking for circularities. After we have
+;;; found them all, this gets bound to 0. Then whenever we need a new
+;;; marker, it is incremented.
(defvar *circularity-counter* nil)
+;;; Check to see whether OBJECT is a circular reference, and return
+;;; something non-NIL if it is. If ASSIGN is T, then the number to use
+;;; in the #n= and #n# noise is assigned at this time.
+;;; If ASSIGN is true, reference bookkeeping will only be done for
+;;; existing entries, no new references will be recorded!
+;;;
+;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
+;;; ASSIGN true, or the circularity detection noise will get confused
+;;; about when to use #n= and when to use #n#. If this returns non-NIL
+;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
+;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
+;;; you need to initiate the circularity detection noise, e.g. bind
+;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
+;;; (see #'OUTPUT-OBJECT for an example).
(defun check-for-circularity (object &optional assign)
- #!+sb-doc
- "Check to see whether OBJECT is a circular reference, and return something
- non-NIL if it is. If ASSIGN is T, then the number to use in the #n= and
- #n# noise is assigned at this time. Note: CHECK-FOR-CIRCULARITY must
- be called *EXACTLY* once with ASSIGN T, or the circularity detection noise
- will get confused about when to use #n= and when to use #n#. If this
- returns non-NIL when ASSIGN is T, then you must call HANDLE-CIRCULARITY
- on it. If you are not using this inside a WITH-CIRCULARITY-DETECTION,
- then you have to be prepared to handle a return value of :INITIATE which
- means it needs to initiate the circularity detection noise. See the
- source for info on how to do that."
(cond ((null *print-circle*)
;; Don't bother, nobody cares.
nil)
((null *circularity-hash-table*)
- :initiate)
+ (values nil :initiate))
((null *circularity-counter*)
(ecase (gethash object *circularity-hash-table*)
((nil)
- ;; First encounter.
+ ;; first encounter
(setf (gethash object *circularity-hash-table*) t)
;; We need to keep looking.
nil)
((t)
- ;; Second encounter.
+ ;; second encounter
(setf (gethash object *circularity-hash-table*) 0)
;; It's a circular reference.
t)
(let ((value (gethash object *circularity-hash-table*)))
(case value
((nil t)
- ;; If NIL, we found an object that wasn't there the first time
- ;; around. If T, exactly one occurance of this object appears.
- ;; Either way, just print the thing without any special
- ;; processing. Note: you might argue that finding a new object
- ;; means that something is broken, but this can happen. If
- ;; someone uses the ~@<...~:> format directive, it conses a
- ;; new list each time though format (i.e. the &REST list), so
- ;; we will have different cdrs.
+ ;; If NIL, we found an object that wasn't there the
+ ;; first time around. If T, this object appears exactly
+ ;; once. Either way, just print the thing without any
+ ;; special processing. Note: you might argue that
+ ;; finding a new object means that something is broken,
+ ;; but this can happen. If someone uses the ~@<...~:>
+ ;; format directive, it conses a new list each time
+ ;; though format (i.e. the &REST list), so we will have
+ ;; different cdrs.
nil)
(0
(if assign
(let ((value (incf *circularity-counter*)))
- ;; First occurance of this object. Set the counter.
+ ;; first occurrence of this object: Set the counter.
(setf (gethash object *circularity-hash-table*) value)
value)
t))
(t
- ;; Second or later occurance.
+ ;; second or later occurrence
(- value)))))))
+;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
+;;; you should go ahead and print the object. If it returns NIL, then
+;;; you should blow it off.
(defun handle-circularity (marker stream)
- #!+sb-doc
- "Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
- you should go ahead and print the object. If it returns NIL, then
- you should blow it off."
(case marker
(:initiate
;; Someone forgot to initiate circularity detection.
(let ((*print-circle* nil))
(error "trying to use CHECK-FOR-CIRCULARITY when ~
- circularity checking isn't initiated")))
+ circularity checking isn't initiated")))
((t)
;; It's a second (or later) reference to the object while we are
;; just looking. So don't bother groveling it again.
\f
;;;; OUTPUT-OBJECT -- the main entry point
-(defvar *pretty-printer* nil
- #!+sb-doc
- "The current pretty printer. Should be either a function that takes two
- arguments (the object and the stream) or NIL to indicate that there is
- no pretty printer installed.")
+;;; Objects whose print representation identifies them EQLly don't
+;;; need to be checked for circularity.
+(defun uniquely-identified-by-print-p (x)
+ (or (numberp x)
+ (characterp x)
+ (and (symbolp x)
+ (symbol-package x))))
+;;; Output OBJECT to STREAM observing all printer control variables.
(defun output-object (object stream)
- #!+sb-doc
- "Output OBJECT to STREAM observing all printer control variables."
(labels ((print-it (stream)
(if *print-pretty*
- (if *pretty-printer*
- (funcall *pretty-printer* object stream)
- (let ((*print-pretty* nil))
- (output-ugly-object object stream)))
+ (sb!pretty:output-pretty-object object stream)
(output-ugly-object object stream)))
(check-it (stream)
- (let ((marker (check-for-circularity object t)))
- (case marker
- (:initiate
- (let ((*circularity-hash-table*
- (make-hash-table :test 'eq)))
- (check-it (make-broadcast-stream))
- (let ((*circularity-counter* 0))
- (check-it stream))))
- ((nil)
- (print-it stream))
- (t
- (when (handle-circularity marker stream)
- (print-it stream)))))))
- (cond ((or (not *print-circle*)
- (numberp object)
- (characterp object)
- (and (symbolp object) (symbol-package object) t))
- ;; If it a number, character, or interned symbol, we do not want
- ;; to check for circularity/sharing.
+ (multiple-value-bind (marker initiate)
+ (check-for-circularity object t)
+ ;; initialization of the circulation detect noise ...
+ (if (eq initiate :initiate)
+ (let ((*circularity-hash-table*
+ (make-hash-table :test 'eq)))
+ (check-it (make-broadcast-stream))
+ (let ((*circularity-counter* 0))
+ (check-it stream)))
+ ;; otherwise
+ (if marker
+ (when (handle-circularity marker stream)
+ (print-it stream))
+ (print-it stream))))))
+ (cond (;; Maybe we don't need to bother with circularity detection.
+ (or (not *print-circle*)
+ (uniquely-identified-by-print-p object))
(print-it stream))
- ((or *circularity-hash-table*
- (consp object)
- (typep object 'instance)
- (typep object '(array t *)))
- ;; If we have already started circularity detection, this object
- ;; might be a sharded reference. If we have not, then if it is
- ;; a cons, a instance, or an array of element type t it might
- ;; contain a circular reference to itself or multiple shared
- ;; references.
+ (;; If we have already started circularity detection, this
+ ;; object might be a shared reference. If we have not, then
+ ;; if it is a compound object it might contain a circular
+ ;; reference to itself or multiple shared references.
+ (or *circularity-hash-table*
+ (compound-object-p object))
(check-it stream))
(t
(print-it stream)))))
+;;; a hack to work around recurring gotchas with printing while
+;;; DEFGENERIC PRINT-OBJECT is being built
+;;;
+;;; (hopefully will go away naturally when CLOS moves into cold init)
+(defvar *print-object-is-disabled-p*)
+
+;;; Output OBJECT to STREAM observing all printer control variables
+;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL,
+;;; then the pretty printer will be used for any components of OBJECT,
+;;; just not for OBJECT itself.
(defun output-ugly-object (object stream)
- #!+sb-doc
- "Output OBJECT to STREAM observing all printer control variables except
- for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, then the pretty
- printer will be used for any components of OBJECT, just not for OBJECT
- itself."
(typecase object
;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
;; PRINT-OBJECT says it provides printing and we're supposed to provide
;; a method on an external symbol in the CL package which is
;; applicable to arg lists containing only direct instances of
;; standardized classes.
- ;; Thus, in order for the user to detect our sleaziness, he has to do
- ;; something relatively obscure like
+ ;; Thus, in order for the user to detect our sleaziness in conforming
+ ;; code, he has to do something relatively obscure like
;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
;; methods, or
;; (2) define a PRINT-OBJECT method which is specialized on the stream
;; value (e.g. a Gray stream object).
;; As long as no one comes up with a non-obscure way of detecting this
;; sleaziness, fixing this nonconformity will probably have a low
- ;; priority. -- WHN 20000121
+ ;; priority. -- WHN 2001-11-25
(fixnum
(output-integer object stream))
(list
(output-symbol object stream)
(output-list object stream)))
(instance
- (print-object object stream))
+ (cond ((not (and (boundp '*print-object-is-disabled-p*)
+ *print-object-is-disabled-p*))
+ (print-object object stream))
+ ((typep object 'structure-object)
+ (default-structure-print object stream *current-level-in-print*))
+ (t
+ (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
(function
(unless (and (funcallable-instance-p object)
(printed-as-funcallable-standard-class object stream))
- (output-function object stream)))
+ (output-fun object stream)))
(symbol
(output-symbol object stream))
(number
\f
;;;; symbols
-;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last time the
-;;; printer was called.
+;;; values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last
+;;; time the printer was called
(defvar *previous-case* nil)
(defvar *previous-readtable-case* nil)
-;;; This variable contains the current definition of one of three symbol
-;;; printers. SETUP-PRINTER-STATE sets this variable.
-(defvar *internal-symbol-output-function* nil)
+;;; This variable contains the current definition of one of three
+;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
+(defvar *internal-symbol-output-fun* nil)
;;; This function sets the internal global symbol
-;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending
-;;; on the value of *PRINT-CASE*. See the manual for details. The
-;;; print buffer stream is also reset.
+;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
+;;; the value of *PRINT-CASE*. See the manual for details. The print
+;;; buffer stream is also reset.
(defun setup-printer-state ()
(unless (and (eq *print-case* *previous-case*)
(eq (readtable-case *readtable*) *previous-readtable-case*))
(setf (readtable-case *readtable*) :upcase)
(error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*))
- (setq *internal-symbol-output-function*
+ (setq *internal-symbol-output-fun*
(case *previous-readtable-case*
(:upcase
(case *print-case*
(output-symbol-name name stream))
(output-symbol-name (symbol-name object) stream nil)))
-;;; Output the string NAME as if it were a symbol name. In other words,
-;;; diddle its case according to *PRINT-CASE* and READTABLE-CASE.
+;;; Output the string NAME as if it were a symbol name. In other
+;;; words, diddle its case according to *PRINT-CASE* and
+;;; READTABLE-CASE.
(defun output-symbol-name (name stream &optional (maybe-quote t))
- (declare (type simple-base-string name))
- (setup-printer-state)
- (if (and maybe-quote (symbol-quotep name))
- (output-quoted-symbol-name name stream)
- (funcall *internal-symbol-output-function* name stream)))
+ (declare (type simple-string name))
+ (let ((*readtable* (if *print-readably* *standard-readtable* *readtable*)))
+ (setup-printer-state)
+ (if (and maybe-quote (symbol-quotep name))
+ (output-quoted-symbol-name name stream)
+ (funcall *internal-symbol-output-fun* name stream))))
\f
;;;; escaping symbols
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit :element-type '(unsigned-byte 16)
+ (make-array 160 ; FIXME
+ :element-type '(unsigned-byte 16)
:initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
*character-attributes*))
-;;; Constants which are a bit-mask for each interesting character attribute.
+;;; constants which are a bit-mask for each interesting character attribute
(defconstant other-attribute (ash 1 0)) ; Anything else legal.
(defconstant number-attribute (ash 1 1)) ; A numeric digit.
(defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter.
(set-bit #\/ slash-attribute)
;; Mark anything not explicitly allowed as funny.
- (dotimes (i char-code-limit)
+ (dotimes (i 160) ; FIXME
(when (zerop (aref *character-attributes* i))
(setf (aref *character-attributes* i) funny-attribute))))
-;;; For each character, the value of the corresponding element is the lowest
-;;; base in which that character is a digit.
+;;; For each character, the value of the corresponding element is the
+;;; lowest base in which that character is a digit.
(defvar *digit-bases*
- (make-array char-code-limit
+ (make-array 128 ; FIXME
:element-type '(unsigned-byte 8)
:initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
*digit-bases*))
-
(dotimes (i 36)
(let ((char (digit-char i 36)))
(setf (aref *digit-bases* (char-code char)) i)))
,(if at-end '(go TEST-SIGN) '(return nil)))
(setq current (schar name index)
code (char-code current)
- bits (aref attributes code))
+ bits (cond ; FIXME
+ ((< code 160) (aref attributes code))
+ ((upper-case-p current) uppercase-attribute)
+ ((lower-case-p current) lowercase-attribute)
+ (t other-attribute)))
(incf index)
(go ,tag)))
(test (&rest attributes)
attributes))
bits)))))
(digitp ()
- `(< (the fixnum (aref bases code)) base)))
+ `(and (< code 128) ; FIXME
+ (< (the fixnum (aref bases code)) base))))
(prog ((len (length name))
(attributes *character-attributes*)
TEST-SIGN ; At end, see whether it is a sign...
(return (not (test sign)))
- OTHER ; Not potential number, see whether funny chars...
+ OTHER ; not potential number, see whether funny chars...
(let ((mask (logxor (logior lowercase-attribute uppercase-attribute
funny-attribute)
letter-attribute)))
(do ((i (1- index) (1+ i)))
((= i len) (return-from symbol-quotep nil))
- (unless (zerop (logand (aref attributes (char-code (schar name i)))
+ (unless (zerop (logand (let* ((char (schar name i))
+ (code (char-code char)))
+ (cond
+ ((< code 160) (aref attributes code))
+ ((upper-case-p char) uppercase-attribute)
+ ((lower-case-p char) lowercase-attribute)
+ (t other-attribute)))
mask))
(return-from symbol-quotep t))))
(when (test sign extension) (advance START-STUFF nil))
(return t)
- DOT-FOUND ; Leading dots...
+ DOT-FOUND ; leading dots...
(when (test letter) (advance START-DOT-MARKER nil))
(when (digitp) (advance DOT-DIGIT))
(when (test number other) (advance OTHER nil))
(when (char= current #\.) (advance DOT-FOUND))
(return t)
- START-STUFF ; Leading stuff before any dot or digit.
+ START-STUFF ; leading stuff before any dot or digit
(when (digitp)
(if (test letter)
(advance LAST-DIGIT-ALPHA)
(when (test sign extension slash) (advance START-STUFF nil))
(return t)
- START-MARKER ; Number marker in leading stuff...
+ START-MARKER ; number marker in leading stuff...
(when (test letter) (advance OTHER nil))
(go START-STUFF)
- START-DOT-STUFF ; Leading stuff containing dot w/o digit...
+ START-DOT-STUFF ; leading stuff containing dot without digit...
(when (test letter) (advance START-DOT-STUFF nil))
(when (digitp) (advance DOT-DIGIT))
(when (test sign extension dot slash) (advance START-DOT-STUFF nil))
(when (test number other) (advance OTHER nil))
(return t)
- START-DOT-MARKER ; Number marker in leading stuff w/ dot..
- ;; Leading stuff containing dot w/o digit followed by letter...
+ START-DOT-MARKER ; number marker in leading stuff with dot..
+ ;; leading stuff containing dot without digit followed by letter...
(when (test letter) (advance OTHER nil))
(go START-DOT-STUFF)
- DOT-DIGIT ; In a thing with dots...
+ DOT-DIGIT ; in a thing with dots...
(when (test letter) (advance DOT-MARKER))
(when (digitp) (advance DOT-DIGIT))
(when (test number other) (advance OTHER nil))
(when (test sign extension dot slash) (advance DOT-DIGIT))
(return t)
- DOT-MARKER ; Number maker in number with dot...
+ DOT-MARKER ; number marker in number with dot...
(when (test letter) (advance OTHER nil))
(go DOT-DIGIT)
- LAST-DIGIT-ALPHA ; Previous char is a letter digit...
+ LAST-DIGIT-ALPHA ; previous char is a letter digit...
(when (or (digitp) (test sign slash))
(advance ALPHA-DIGIT))
(when (test letter number other dot) (advance OTHER nil))
(return t)
- ALPHA-DIGIT ; Seen a digit which is a letter...
+ ALPHA-DIGIT ; seen a digit which is a letter...
(when (or (digitp) (test sign slash))
(if (test letter)
(advance LAST-DIGIT-ALPHA)
(when (test number other dot) (advance OTHER nil))
(return t)
- ALPHA-MARKER ; Number marker in number with alpha digit...
+ ALPHA-MARKER ; number marker in number with alpha digit...
(when (test letter) (advance OTHER nil))
(go ALPHA-DIGIT)
- DIGIT ; Seen only real numeric digits...
+ DIGIT ; seen only ordinary (non-alphabetic) numeric digits...
(when (digitp)
(if (test letter)
(advance ALPHA-DIGIT)
(when (char= current #\.) (advance DOT-DIGIT))
(return t)
- MARKER ; Number marker in a numeric number...
+ MARKER ; number marker in a numeric number...
+ ;; ("What," you may ask, "is a 'number marker'?" It's something
+ ;; that a conforming implementation might use in number syntax.
+ ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".)
(when (test letter) (advance OTHER nil))
(go DIGIT))))
\f
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
;;;;
-;;;; Case hackery. These functions are stored in
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of *PRINT-CASE*
-;;;; and READTABLE-CASE.
-
-;; Called when:
-;; READTABLE-CASE *PRINT-CASE*
-;; :UPCASE :UPCASE
-;; :DOWNCASE :DOWNCASE
-;; :PRESERVE any
+;;;; case hackery: These functions are stored in
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
+;;;; *PRINT-CASE* and READTABLE-CASE.
+
+;;; called when:
+;;; READTABLE-CASE *PRINT-CASE*
+;;; :UPCASE :UPCASE
+;;; :DOWNCASE :DOWNCASE
+;;; :PRESERVE any
(defun output-preserve-symbol (pname stream)
(declare (simple-string pname))
(write-string pname stream))
-;; Called when:
-;; READTABLE-CASE *PRINT-CASE*
-;; :UPCASE :DOWNCASE
+;;; called when:
+;;; READTABLE-CASE *PRINT-CASE*
+;;; :UPCASE :DOWNCASE
(defun output-lowercase-symbol (pname stream)
(declare (simple-string pname))
(dotimes (index (length pname))
(let ((char (schar pname index)))
(write-char (char-downcase char) stream))))
-;; Called when:
-;; READTABLE-CASE *PRINT-CASE*
-;; :DOWNCASE :UPCASE
+;;; called when:
+;;; READTABLE-CASE *PRINT-CASE*
+;;; :DOWNCASE :UPCASE
(defun output-uppercase-symbol (pname stream)
(declare (simple-string pname))
(dotimes (index (length pname))
(let ((char (schar pname index)))
(write-char (char-upcase char) stream))))
-;; Called when:
-;; READTABLE-CASE *PRINT-CASE*
-;; :UPCASE :CAPITALIZE
-;; :DOWNCASE :CAPITALIZE
+;;; called when:
+;;; READTABLE-CASE *PRINT-CASE*
+;;; :UPCASE :CAPITALIZE
+;;; :DOWNCASE :CAPITALIZE
(defun output-capitalize-symbol (pname stream)
(declare (simple-string pname))
- (let ((prev-not-alpha t)
+ (let ((prev-not-alphanum t)
(up (eq (readtable-case *readtable*) :upcase)))
(dotimes (i (length pname))
(let ((char (char pname i)))
(write-char (if up
- (if (or prev-not-alpha (lower-case-p char))
+ (if (or prev-not-alphanum (lower-case-p char))
char
(char-downcase char))
- (if prev-not-alpha
+ (if prev-not-alphanum
(char-upcase char)
char))
stream)
- (setq prev-not-alpha (not (alpha-char-p char)))))))
+ (setq prev-not-alphanum (not (alphanumericp char)))))))
-;; Called when:
-;; READTABLE-CASE *PRINT-CASE*
-;; :INVERT any
+;;; called when:
+;;; READTABLE-CASE *PRINT-CASE*
+;;; :INVERT any
(defun output-invert-symbol (pname stream)
(declare (simple-string pname))
(let ((all-upper t)
(output-object (pop list) stream)
(unless list
(return))
- (when (or (atom list) (check-for-circularity list))
+ (when (or (atom list)
+ (check-for-circularity list))
(write-string " . " stream)
(output-object list stream)
(return))
(defun output-vector (vector stream)
(declare (vector vector))
(cond ((stringp vector)
- (cond ((or *print-escape* *print-readably*)
+ (cond ((and *print-readably*
+ (not (eq (array-element-type vector)
+ (load-time-value
+ (array-element-type
+ (make-array 0 :element-type 'character))))))
+ (error 'print-not-readable :object vector))
+ ((or *print-escape* *print-readably*)
(write-char #\" stream)
(quote-string vector stream)
(write-char #\" stream))
(output-terse-array vector stream))
((bit-vector-p vector)
(write-string "#*" stream)
- (dotimes (i (length vector))
- (output-object (aref vector i) stream)))
+ (dovector (bit vector)
+ ;; (Don't use OUTPUT-OBJECT here, since this code
+ ;; has to work for all possible *PRINT-BASE* values.)
+ (write-char (if (zerop bit) #\0 #\1) stream)))
(t
(when (and *print-readably*
- (not (eq (array-element-type vector) 't)))
+ (not (array-readably-printable-p vector)))
(error 'print-not-readable :object vector))
(descend-into (stream)
(write-string "#(" stream)
(write-string ")" stream)))))
;;; This function outputs a string quoting characters sufficiently
-;;; that so someone can read it in again. Basically, put a slash in
+;;; so that someone can read it in again. Basically, put a slash in
;;; front of an character satisfying NEEDS-SLASH-P.
(defun quote-string (string stream)
(macrolet ((needs-slash-p (char)
(when (needs-slash-p char) (write-char #\\ stream))
(write-char char stream))))))
+(defun array-readably-printable-p (array)
+ (and (eq (array-element-type array) t)
+ (let ((zero (position 0 (array-dimensions array)))
+ (number (position 0 (array-dimensions array)
+ :test (complement #'eql)
+ :from-end t)))
+ (or (null zero) (null number) (> zero number)))))
+
+;;; Output the printed representation of any array in either the #< or #A
+;;; form.
(defun output-array (array stream)
- #!+sb-doc
- "Outputs the printed representation of any array in either the #< or #A
- form."
(if (or *print-array* *print-readably*)
(output-array-guts array stream)
(output-terse-array array stream)))
-;;; to output the abbreviated #< form of an array
+;;; Output the abbreviated #< form of an array.
(defun output-terse-array (array stream)
(let ((*print-level* nil)
(*print-length* nil))
(print-unreadable-object (array stream :type t :identity t))))
-;;; to output the readable #A form of an array
+;;; Output the readable #A form of an array.
(defun output-array-guts (array stream)
(when (and *print-readably*
- (not (eq (array-element-type array) t)))
+ (not (array-readably-printable-p array)))
(error 'print-not-readable :object array))
(write-char #\# stream)
- (let ((*print-base* 10))
+ (let ((*print-base* 10)
+ (*print-radix* nil))
(output-integer (array-rank array) stream))
(write-char #\A stream)
(with-array-data ((data array) (start) (end))
;;; use until CLOS is set up (at which time it will be replaced with
;;; the real generic function implementation)
(defun print-object (instance stream)
- (default-structure-print instance stream *current-level*))
+ (default-structure-print instance stream *current-level-in-print*))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
stream)))
\f
;;;; bignum printing
-;;;;
-;;;; written by Steven Handerson (based on Skef's idea)
-;;;;
-;;;; rewritten to remove assumptions about the length of fixnums for the
-;;;; MIPS port by William Lott
-;;; *BASE-POWER* holds the number that we keep dividing into the bignum for
-;;; each *print-base*. We want this number as close to *most-positive-fixnum*
-;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)).
+;;; *BASE-POWER* holds the number that we keep dividing into the
+;;; bignum for each *print-base*. We want this number as close to
+;;; *most-positive-fixnum* as possible, i.e. (floor (log
+;;; most-positive-fixnum *print-base*)).
(defparameter *base-power* (make-array 37 :initial-element nil))
-;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that
-;;; fit in the corresponding *base-power*.
+;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
+;;; that fit in the corresponding *base-power*.
(defparameter *fixnum-power--1* (make-array 37 :initial-element nil))
-;;; Print the bignum to the stream. We first generate the correct value for
-;;; *base-power* and *fixnum-power--1* if we have not already. Then we call
-;;; bignum-print-aux to do the printing.
+;;; Print the bignum to the stream. We first generate the correct
+;;; value for *base-power* and *fixnum-power--1* if we have not
+;;; already. Then we call bignum-print-aux to do the printing.
(defun print-bignum (big stream)
(unless (aref *base-power* *print-base*)
(do ((power-1 -1 (1+ power-1))
(2 (write-char #\b stream))
(8 (write-char #\o stream))
(16 (write-char #\x stream))
- (t (write *print-base* :stream stream :radix nil :base 10)))
- (write-char #\r stream))
+ (t (write *print-base* :stream stream :radix nil :base 10)
+ (write-char #\r stream))))
(let ((*print-radix* nil))
(output-integer (numerator ratio) stream)
(write-char #\/ stream)
(write-char #\) stream))
\f
;;;; float printing
-;;;;
-;;;; written by Bill Maddox
-;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of
-;;; the work for all printing of floating point numbers in the printer and in
-;;; FORMAT. It converts a floating point number to a string in a free or
-;;; fixed format with no exponent. The interpretation of the arguments is as
-;;; follows:
+;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
+;;; most of the work for all printing of floating point numbers in the
+;;; printer and in FORMAT. It converts a floating point number to a
+;;; string in a free or fixed format with no exponent. The
+;;; interpretation of the arguments is as follows:
;;;
;;; X - The floating point number to convert, which must not be
;;; negative.
;;; POINT-POS - The position of the digit preceding the decimal
;;; point. Zero indicates point before first digit.
;;;
-;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
-;;; Specifically, the decimal number printed is the closest possible
-;;; approximation to the true value of the binary number to be printed from
-;;; among all decimal representations with the same number of digits. In
-;;; free-format output, i.e. with the number of digits unconstrained, it is
-;;; guaranteed that all the information is preserved, so that a properly-
-;;; rounding reader can reconstruct the original binary number, bit-for-bit,
-;;; from its printed decimal representation. Furthermore, only as many digits
-;;; as necessary to satisfy this condition will be printed.
+;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
+;;; accuracy. Specifically, the decimal number printed is the closest
+;;; possible approximation to the true value of the binary number to
+;;; be printed from among all decimal representations with the same
+;;; number of digits. In free-format output, i.e. with the number of
+;;; digits unconstrained, it is guaranteed that all the information is
+;;; preserved, so that a properly- rounding reader can reconstruct the
+;;; original binary number, bit-for-bit, from its printed decimal
+;;; representation. Furthermore, only as many digits as necessary to
+;;; satisfy this condition will be printed.
;;;
-;;; FLOAT-STRING actually generates the digits for positive numbers. The
-;;; algorithm is essentially that of algorithm Dragon4 in "How to Print
-;;; Floating-Point Numbers Accurately" by Steele and White. The current
-;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press.
-;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING
-;;; THE PAPER!
-
-(defvar *digits* "0123456789")
+;;; FLOAT-STRING actually generates the digits for positive numbers.
+;;; The algorithm is essentially that of algorithm Dragon4 in "How to
+;;; Print Floating-Point Numbers Accurately" by Steele and White. The
+;;; current (draft) version of this paper may be found in
+;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
+;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
(defun flonum-to-string (x &optional width fdigits scale fmin)
(cond ((zerop x)
(defun float-string (fraction exponent precision width fdigits scale fmin)
(let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high
+ (digit-characters "0123456789")
(digit-string (make-array 50
:element-type 'base-char
:fill-pointer 0
:adjustable t)))
;; Represent fraction as r/s, error bounds as m+/s and m-/s.
- ;; Rational arithmetic avoids loss of precision in subsequent calculations.
+ ;; Rational arithmetic avoids loss of precision in subsequent
+ ;; calculations.
(cond ((> exponent 0)
(setq r (ash fraction exponent))
(setq m- (ash 1 exponent))
(setq m+ m-))
((< exponent 0)
(setq s (ash 1 (- exponent)))))
- ;;adjust the error bounds m+ and m- for unequal gaps
+ ;; Adjust the error bounds m+ and m- for unequal gaps.
(when (= fraction (ash 1 precision))
(setq m+ (ash m+ 1))
(setq r (ash r 1))
(setq s (ash s 1)))
- ;;scale value by requested amount, and update error bounds
+ ;; Scale value by requested amount, and update error bounds.
(when scale
(if (minusp scale)
(let ((scale-factor (expt 10 (- scale))))
(setq r (* r scale-factor))
(setq m+ (* m+ scale-factor))
(setq m- (* m- scale-factor)))))
- ;;scale r and s and compute initial k, the base 10 logarithm of r
+ ;; Scale r and s and compute initial k, the base 10 logarithm of r.
(do ()
((>= r (ceiling s 10)))
(decf k)
((< (+ (ash r 1) m+) (ash s 1)))
(setq s (* s 10))
(incf k))
- ;;determine number of fraction digits to generate
+ ;; Determine number of fraction digits to generate.
(cond (fdigits
- ;;use specified number of fraction digits
+ ;; Use specified number of fraction digits.
(setq cutoff (- fdigits))
;;don't allow less than fmin fraction digits
(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
(width
- ;;use as many fraction digits as width will permit
- ;;but force at least fmin digits even if width will be exceeded
+ ;; Use as many fraction digits as width will permit but
+ ;; force at least fmin digits even if width will be
+ ;; exceeded.
(if (< k 0)
(setq cutoff (- 1 width))
(setq cutoff (1+ (- k width))))
(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
- ;;If we decided to cut off digit generation before precision has
- ;;been exhausted, rounding the last digit may cause a carry propagation.
- ;;We can prevent this, preserving left-to-right digit generation, with
- ;;a few magical adjustments to m- and m+. Of course, correct rounding
- ;;is also preserved.
+ ;; If we decided to cut off digit generation before precision
+ ;; has been exhausted, rounding the last digit may cause a carry
+ ;; propagation. We can prevent this, preserving left-to-right
+ ;; digit generation, with a few magical adjustments to m- and
+ ;; m+. Of course, correct rounding is also preserved.
(when (or fdigits width)
(let ((a (- cutoff k))
(y s))
(setq m+ (max y m+))
(when (= m+ y) (setq roundup t))))
(when (< (+ (ash r 1) m+) (ash s 1)) (return)))
- ;;zero-fill before fraction if no integer part
+ ;; Zero-fill before fraction if no integer part.
(when (< k 0)
(setq decpnt digits)
(vector-push-extend #\. digit-string)
(dotimes (i (- k))
(incf digits) (vector-push-extend #\0 digit-string)))
- ;;generate the significant digits
+ ;; Generate the significant digits.
(do ()(nil)
(decf k)
(when (= k -1)
(if roundup
(setq high (>= (ash r 1) (- (ash s 1) m+)))
(setq high (> (ash r 1) (- (ash s 1) m+))))
- ;;stop when either precision is exhausted or we have printed as many
- ;;fraction digits as permitted
+ ;; Stop when either precision is exhausted or we have printed as
+ ;; many fraction digits as permitted.
(when (or low high (and cutoff (<= k cutoff))) (return))
- (vector-push-extend (char *digits* u) digit-string)
+ (vector-push-extend (char digit-characters u) digit-string)
(incf digits))
;; If cutoff occurred before first digit, then no digits are
;; generated at all.
(when (or (not cutoff) (>= k cutoff))
- ;;last digit may need rounding
- (vector-push-extend (char *digits*
+ ;; Last digit may need rounding
+ (vector-push-extend (char digit-characters
(cond ((and low (not high)) u)
((and high (not low)) (1+ u))
(t (if (<= (ash r 1) s) u (1+ u)))))
digit-string)
(incf digits))
- ;;zero-fill after integer part if no fraction
+ ;; Zero-fill after integer part if no fraction.
(when (>= k 0)
(dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string))
(vector-push-extend #\. digit-string)
(setq decpnt digits))
- ;;add trailing zeroes to pad fraction if fdigits specified
+ ;; Add trailing zeroes to pad fraction if fdigits specified.
(when fdigits
(dotimes (i (- fdigits (- digits decpnt)))
(incf digits)
(vector-push-extend #\0 digit-string)))
- ;;all done
+ ;; all done
(values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
-;;; Given a non-negative floating point number, SCALE-EXPONENT returns a new
-;;; floating point number Z in the range (0.1, 1.0] and an exponent E such
-;;; that Z * 10^E is (approximately) equal to the original number. There may
-;;; be some loss of precision due the floating point representation. The
-;;; scaling is always done with long float arithmetic, which helps printing of
-;;; lesser precisions as well as avoiding generic arithmetic.
+;;; implementation of figure 1 from Burger and Dybvig, 1996. As the
+;;; implementation of the Dragon from Classic CMUCL (and above,
+;;; FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF ATTEMPTING TO
+;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", and in this case
+;;; we have to add that even reading the paper might not bring
+;;; immediate illumination as CSR has attempted to turn idiomatic
+;;; Scheme into idiomatic Lisp.
;;;
-;;; When computing our initial scale factor using EXPT, we pull out part of
-;;; the computation to avoid over/under flow. When denormalized, we must pull
-;;; out a large factor, since there is more negative exponent range than
-;;; positive range.
+;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
+;;; algorithm, noticeably slow at finding the exponent. Figure 2 has
+;;; an improved algorithm, but CSR ran out of energy
+;;;
+;;; FIXME: Burger and Dybvig also provide an algorithm for
+;;; fixed-format floating point printing. If it were implemented,
+;;; then we could delete the Dragon altogether (see FLONUM-TO-STRING).
+;;;
+;;; possible extension for the enthusiastic: printing floats in bases
+;;; other than base 10.
+(defconstant single-float-min-e
+ (nth-value 1 (decode-float least-positive-single-float)))
+(defconstant double-float-min-e
+ (nth-value 1 (decode-float least-positive-double-float)))
+#!+long-float
+(defconstant long-float-min-e
+ (nth-value 1 (decode-float least-positive-long-float)))
+
+(defun flonum-to-digits (v)
+ (let ((print-base 10) ; B
+ (float-radix 2) ; b
+ (float-digits (float-digits v)) ; p
+ (digit-characters "0123456789")
+ (min-e
+ (etypecase v
+ (single-float single-float-min-e)
+ (double-float double-float-min-e)
+ #!+long-float
+ (long-float long-float-min-e))))
+ (multiple-value-bind (f e)
+ (integer-decode-float v)
+ (let (;; FIXME: these even tests assume normal IEEE rounding
+ ;; mode. I wonder if we should cater for non-normal?
+ (high-ok (evenp f))
+ (low-ok (evenp f))
+ (result (make-array 50 :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (labels ((scale (r s m+ m-)
+ (do ((k 0 (1+ k))
+ (s s (* s print-base)))
+ ((not (or (> (+ r m+) s)
+ (and high-ok (= (+ r m+) s))))
+ (do ((k k (1- k))
+ (r r (* r print-base))
+ (m+ m+ (* m+ print-base))
+ (m- m- (* m- print-base)))
+ ((not (or (< (* (+ r m+) print-base) s)
+ (and high-ok (= (* (+ r m+) print-base) s))))
+ (values k (generate r s m+ m-)))))))
+ (generate (r s m+ m-)
+ (let (d tc1 tc2)
+ (tagbody
+ loop
+ (setf (values d r) (truncate (* r print-base) s))
+ (setf m+ (* m+ print-base))
+ (setf m- (* m- print-base))
+ (setf tc1 (or (< r m-) (and low-ok (= r m-))))
+ (setf tc2 (or (> (+ r m+) s)
+ (and high-ok (= (+ r m+) s))))
+ (when (or tc1 tc2)
+ (go end))
+ (vector-push-extend (char digit-characters d) result)
+ (go loop)
+ end
+ (let ((d (cond
+ ((and (not tc1) tc2) (1+ d))
+ ((and tc1 (not tc2)) d)
+ (t ; (and tc1 tc2)
+ (if (< (* r 2) s) d (1+ d))))))
+ (vector-push-extend (char digit-characters d) result)
+ (return-from generate result))))))
+ (if (>= e 0)
+ (if (/= f (expt float-radix (1- float-digits)))
+ (let ((be (expt float-radix e)))
+ (scale (* f be 2) 2 be be))
+ (let* ((be (expt float-radix e))
+ (be1 (* be float-radix)))
+ (scale (* f be1 2) (* float-radix 2) be1 be)))
+ (if (or (= e min-e) (/= f (expt float-radix (1- float-digits))))
+ (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1)
+ (scale (* f float-radix 2)
+ (* (expt float-radix (- 1 e)) 2) float-radix 1))))))))
+\f
+;;; Given a non-negative floating point number, SCALE-EXPONENT returns
+;;; a new floating point number Z in the range (0.1, 1.0] and an
+;;; exponent E such that Z * 10^E is (approximately) equal to the
+;;; original number. There may be some loss of precision due the
+;;; floating point representation. The scaling is always done with
+;;; long float arithmetic, which helps printing of lesser precisions
+;;; as well as avoiding generic arithmetic.
+;;;
+;;; When computing our initial scale factor using EXPT, we pull out
+;;; part of the computation to avoid over/under flow. When
+;;; denormalized, we must pull out a large factor, since there is more
+;;; negative exponent range than positive range.
+
+(eval-when (:compile-toplevel :execute)
+ (setf *read-default-float-format*
+ #!+long-float 'long-float #!-long-float 'double-float))
(defun scale-exponent (original-x)
(let* ((x (coerce original-x 'long-float)))
(multiple-value-bind (sig exponent) (decode-float x)
(declare (ignore sig))
- (if (= x 0.0l0)
- (values (float 0.0l0 original-x) 1)
- (let* ((ex (round (* exponent (log 2l0 10))))
+ (if (= x 0.0e0)
+ (values (float 0.0e0 original-x) 1)
+ (let* ((ex (locally (declare (optimize (safety 0)))
+ (the fixnum
+ (round (* exponent (log 2e0 10))))))
(x (if (minusp ex)
(if (float-denormalized-p x)
#!-long-float
- (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+ (* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
#!+long-float
- (* x 1.0l18 (expt 10.0l0 (- (- ex) 18)))
- (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
- (/ x 10.0l0 (expt 10.0l0 (1- ex))))))
- (do ((d 10.0l0 (* d 10.0l0))
+ (* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
+ (* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
+ (/ x 10.0e0 (expt 10.0e0 (1- ex))))))
+ (do ((d 10.0e0 (* d 10.0e0))
(y x (/ x d))
(ex ex (1+ ex)))
- ((< y 1.0l0)
- (do ((m 10.0l0 (* m 10.0l0))
+ ((< y 1.0e0)
+ (do ((m 10.0e0 (* m 10.0e0))
(z y (* y m))
(ex ex (1- ex)))
- ((>= z 0.1l0)
- (values (float z original-x) ex))))))))))
+ ((>= z 0.1e0)
+ (values (float z original-x) ex))
+ (declare (long-float m) (integer ex))))
+ (declare (long-float d))))))))
+(eval-when (:compile-toplevel :execute)
+ (setf *read-default-float-format* 'single-float))
\f
;;;; entry point for the float printer
-;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
-;;; etc. The argument is printed free-format, in either exponential or
+;;; the float printer as called by PRINT, PRIN1, PRINC, etc. The
+;;; argument is printed free-format, in either exponential or
;;; non-exponential notation, depending on its magnitude.
;;;
-;;; NOTE: When a number is to be printed in exponential format, it is scaled in
-;;; floating point. Since precision may be lost in this process, the
-;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The
-;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
-;;; integers of similar magnitude to that of the number being printed. For
-;;; large exponents, the bignums really get out of hand. If bignum arithmetic
-;;; becomes reasonably fast and the exponent range is not too large, then it
-;;; might become attractive to handle exponential notation with the same
-;;; accuracy as non-exponential notation, using the method described in the
+;;; NOTE: When a number is to be printed in exponential format, it is
+;;; scaled in floating point. Since precision may be lost in this
+;;; process, the guaranteed accuracy properties of FLONUM-TO-STRING
+;;; are lost. The difficulty is that FLONUM-TO-STRING performs
+;;; extensive computations with integers of similar magnitude to that
+;;; of the number being printed. For large exponents, the bignums
+;;; really get out of hand. If bignum arithmetic becomes reasonably
+;;; fast and the exponent range is not too large, then it might become
+;;; attractive to handle exponential notation with the same accuracy
+;;; as non-exponential notation, using the method described in the
;;; Steele and White paper.
+;;;
+;;; NOTE II: this has been bypassed slightly by implementing Burger
+;;; and Dybvig, 1996. When someone has time (KLUDGE) they can
+;;; probably (a) implement the optimizations suggested by Burger and
+;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
+;;; fixed-format printing.
;;; Print the appropriate exponent marker for X and the specified exponent.
(defun print-float-exponent (x exp stream)
(long-float #\L))
plusp exp))))
-;;; Write out an infinity using #. notation, or flame out if
-;;; *PRINT-READABLY* is true and *READ-EVAL* is false.
(defun output-float-infinity (x stream)
- (declare (type float x) (type stream stream))
+ (declare (float x) (stream stream))
(cond (*read-eval*
- (write-string "#." stream))
- (*print-readably*
- (error 'print-not-readable :object x))
- (t
- (write-string "#<" stream)))
- (write-string "EXT:" stream)
- (princ (float-format-name x) stream)
+ (write-string "#." stream))
+ (*print-readably*
+ (error 'print-not-readable :object x))
+ (t
+ (write-string "#<" stream)))
+ (write-string "SB-EXT:" stream)
+ (write-string (symbol-name (float-format-name x)) stream)
(write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
- stream)
+ stream)
(write-string "INFINITY" stream)
(unless *read-eval*
(write-string ">" stream)))
-;;; Output a #< NaN or die trying.
(defun output-float-nan (x stream)
(print-unreadable-object (x stream)
(princ (float-format-name x) stream)
(write-string "0.0" stream)
(print-float-exponent x 0 stream))
(t
- (output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))))
+ (output-float-aux x stream -3 8)))))))
(defun output-float-aux (x stream e-min e-max)
- (if (and (>= x e-min) (< x e-max))
- ;; free format
- (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x)
- (declare (ignore len))
- (when lpoint (write-char #\0 stream))
- (write-string str stream)
- (when tpoint (write-char #\0 stream))
- (print-float-exponent x 0 stream))
- ;; exponential format
- (multiple-value-bind (f ex) (scale-exponent x)
- (multiple-value-bind (str len lpoint tpoint)
- (flonum-to-string f nil nil 1)
- (declare (ignore len))
- (when lpoint (write-char #\0 stream))
- (write-string str stream)
- (when tpoint (write-char #\0 stream))
- ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
- (print-float-exponent x (1- ex) stream)))))
+ (multiple-value-bind (e string)
+ (flonum-to-digits x)
+ (cond
+ ((< e-min e e-max)
+ (if (plusp e)
+ (progn
+ (write-string string stream :end (min (length string) e))
+ (dotimes (i (- e (length string)))
+ (write-char #\0 stream))
+ (write-char #\. stream)
+ (write-string string stream :start (min (length string) e))
+ (when (<= (length string) e)
+ (write-char #\0 stream))
+ (print-float-exponent x 0 stream))
+ (progn
+ (write-string "0." stream)
+ (dotimes (i (- e))
+ (write-char #\0 stream))
+ (write-string string stream)
+ (print-float-exponent x 0 stream))))
+ (t (write-string string stream :end 1)
+ (write-char #\. stream)
+ (write-string string stream :start 1)
+ (when (= (length string) 1)
+ (write-char #\0 stream))
+ (print-float-exponent x (1- e) stream)))))
\f
;;;; other leaf objects
;;; the character name or the character in the #\char format.
(defun output-character (char stream)
(if (or *print-escape* *print-readably*)
- (let ((name (char-name char)))
+ (let ((graphicp (graphic-char-p char))
+ (name (char-name char)))
(write-string "#\\" stream)
- (if name
+ (if (and name (not graphicp))
(quote-string name stream)
(write-char char stream)))
(write-char char stream)))
(declare (ignore object stream))
nil)
-(defun output-function (object stream)
+(defun output-fun (object stream)
(let* ((*print-length* 3) ; in case we have to..
(*print-level* 3) ; ..print an interpreted function definition
- (name (cond ((find (function-subtype object)
- #(#.sb!vm:closure-header-type
- #.sb!vm:byte-code-closure-type))
- "CLOSURE")
- ((sb!eval::interpreted-function-p object)
- (or (sb!eval::interpreted-function-%name object)
- (sb!eval:interpreted-function-lambda-expression
- object)))
- ((find (function-subtype object)
- #(#.sb!vm:function-header-type
- #.sb!vm:closure-function-header-type))
- (%function-name object))
- (t 'no-name-available)))
+ ;; FIXME: This find-the-function-name idiom ought to be
+ ;; encapsulated in a function somewhere.
+ (name (case (fun-subtype object)
+ (#.sb!vm:closure-header-widetag "CLOSURE")
+ (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
+ (t 'no-name-available)))
(identified-by-name-p (and (symbolp name)
(fboundp name)
(eq (fdefinition name) object))))
(defun output-random (object stream)
(print-unreadable-object (object stream :identity t)
- (let ((lowtag (get-lowtag object)))
+ (let ((lowtag (lowtag-of object)))
(case lowtag
- (#.sb!vm:other-pointer-type
- (let ((type (get-type object)))
- (case type
- (#.sb!vm:value-cell-header-type
+ (#.sb!vm:other-pointer-lowtag
+ (let ((widetag (widetag-of object)))
+ (case widetag
+ (#.sb!vm:value-cell-header-widetag
(write-string "value cell " stream)
- (output-object (sb!c:value-cell-ref object) stream))
+ (output-object (value-cell-ref object) stream))
(t
- (write-string "unknown pointer object, type=" stream)
+ (write-string "unknown pointer object, widetag=" stream)
(let ((*print-base* 16) (*print-radix* t))
- (output-integer type stream))))))
- ((#.sb!vm:function-pointer-type
- #.sb!vm:instance-pointer-type
- #.sb!vm:list-pointer-type)
- (write-string "unknown pointer object, type=" stream))
+ (output-integer widetag stream))))))
+ ((#.sb!vm:fun-pointer-lowtag
+ #.sb!vm:instance-pointer-lowtag
+ #.sb!vm:list-pointer-lowtag)
+ (write-string "unknown pointer object, lowtag=" stream)
+ (let ((*print-base* 16) (*print-radix* t))
+ (output-integer lowtag stream)))
(t
- (case (get-type object)
- (#.sb!vm:unbound-marker-type
+ (case (widetag-of object)
+ (#.sb!vm:unbound-marker-widetag
(write-string "unbound marker" stream))
(t
(write-string "unknown immediate object, lowtag=" stream)
(let ((*print-base* 2) (*print-radix* t))
(output-integer lowtag stream))
- (write-string ", type=" stream)
+ (write-string ", widetag=" stream)
(let ((*print-base* 16) (*print-radix* t))
- (output-integer (get-type object) stream)))))))))
+ (output-integer (widetag-of object) stream)))))))))
projects / sbcl.git / blobdiff