#!+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"
+ *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)
#!+sb-doc
"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)
#!+sb-doc
"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)
#!+sb-doc
"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
"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.
(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))))
(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)
;; 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.
;;; 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-fun* 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
+ (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
(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.
(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)))
,(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*)
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))))
;;; :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*
(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))
(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))
(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)
;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
-(defvar *digits* "0123456789")
-
(defun flonum-to-string (x &optional width fdigits scale fmin)
(cond ((zerop x)
;; Zero is a special case which FLOAT-STRING cannot handle.
(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
;; 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*
+ (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)))))
;; all done
(values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
+;;; 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.
+;;;
+;;; 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
(declare (ignore sig))
(if (= x 0.0e0)
(values (float 0.0e0 original-x) 1)
- (let* ((ex (round (* exponent (log 2e0 10))))
+ (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
(z y (* y m))
(ex ex (1- ex)))
((>= z 0.1e0)
- (values (float z original-x) ex))))))))))
+ (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
;;; 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)
(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)))
projects / sbcl.git / blobdiff