(defvar *print-readably* nil
#!+sb-doc
- "If true, all objects will printed readably. If readable printing is
- impossible, an error will be signalled. This overrides the value of
+ "If true, all objects will be printed readably. If readable printing
+ is impossible, an error will be signalled. This overrides the value of
*PRINT-ESCAPE*.")
(defvar *print-escape* t
#!+sb-doc
"Should pretty printing be used?")
(defvar *print-base* 10.
#!+sb-doc
- "the output base for RATIONALs (including integers)")
+ "The output base for RATIONALs (including integers).")
(defvar *print-radix* nil
#!+sb-doc
"Should base be verified when printing RATIONALs?")
"Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
(defvar *print-lines* nil
#!+sb-doc
- "the maximum number of lines to print per object")
+ "The maximum number of lines to print per object.")
(defvar *print-right-margin* nil
#!+sb-doc
- "the position of the right margin in ems (for pretty-printing)")
+ "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
(defvar *print-pprint-dispatch*)
#!+sb-doc
(setf (fdocumentation '*print-pprint-dispatch* 'variable)
- "the pprint-dispatch-table that controls how to pretty-print objects")
+ "The pprint-dispatch-table that controls how to pretty-print objects.")
(defmacro with-standard-io-syntax (&body body)
#!+sb-doc
*PRINT-LEVEL* NIL
*PRINT-LINES* NIL
*PRINT-MISER-WIDTH* NIL
+ *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table
*PRINT-PRETTY* NIL
*PRINT-RADIX* NIL
*PRINT-READABLY* T
(*print-level* nil)
(*print-lines* nil)
(*print-miser-width* nil)
+ (*print-pprint-dispatch* sb!pretty::*standard-pprint-dispatch-table*)
(*print-pretty* nil)
(*print-radix* nil)
(*print-readably* t)
(*read-default-float-format* 'single-float)
(*read-eval* t)
(*read-suppress* nil)
- ;; FIXME: It doesn't seem like a good idea to expose our
- ;; 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
- "Output 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)
(push (list variable value) bind)))
(unless (assoc 'stream bind)
(push (list 'stream '*standard-output*) bind))
- `(let ,(nreverse bind)
- ,@(when ignore `((declare (ignore ,@ignore))))
- (output-object ,object stream))))
+ (once-only ((object object))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (output-object ,object (out-synonym-of stream))
+ ,object))))
(defun prin1 (object &optional stream)
#!+sb-doc
(push variable ignore))
(push (list variable value) bind)))
(if bind
- `(let ,(nreverse bind)
- ,@(when ignore `((declare (ignore ,@ignore))))
- (stringify-object ,object))
+ (once-only ((object object))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (stringify-object ,object)))
`(stringify-object ,object))))
(defun prin1-to-string (object)
(when type
(write (type-of object) :stream stream :circle nil
:level nil :length nil)
- (write-char #\space stream))
+ (write-char #\space stream)
+ (pprint-newline :fill stream))
(when body
(funcall body))
(when identity
(when (or body (not type))
(write-char #\space stream))
+ (pprint-newline :fill stream)
(write-char #\{ stream)
(write (get-lisp-obj-address object) :stream stream
:radix nil :base 16)
(pprint-logical-block (stream nil :prefix "#<" :suffix ">")
(print-description)))
(t
- (write-string "#<" stream)
- (print-description)
- (write-char #\> stream))))
+ (write-string "#<" stream)
+ (print-description)
+ (write-char #\> stream))))
nil)
\f
;;;; OUTPUT-OBJECT -- the main entry point
(output-float object stream))
(ratio
(output-ratio object stream))
- (ratio
- (output-ratio object stream))
(complex
(output-complex object stream))))
(character
;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with
;; possibly-negative X.
(setf x (abs x))
- (cond ((zerop x)
- ;; Zero is a special case which FLOAT-STRING cannot handle.
- (if fdigits
- (let ((s (make-string (1+ fdigits) :initial-element #\0)))
- (setf (schar s 0) #\.)
- (values s (length s) t (zerop fdigits) 0))
- (values "." 1 t t 0)))
- (t
- (multiple-value-bind (e string)
- (if fdigits
- (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
- (- (or fmin 0))))
- (if (and width (> width 1))
- (let ((w (multiple-value-list
- (flonum-to-digits x
- (max 1
- (+ (1- width)
- (if (and scale (minusp scale))
- scale 0)))
- t)))
- (f (multiple-value-list
- (flonum-to-digits x (- (+ (or fmin 0)
- (if scale scale 0)))))))
- (cond
- ((>= (length (cadr w)) (length (cadr f)))
- (values-list w))
- (t (values-list f))))
- (flonum-to-digits x)))
- (let ((e (+ e (or scale 0)))
- (stream (make-string-output-stream)))
- (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 fdigits
- (dotimes (i (- fdigits
- (- (length string)
- (min (length string) e))))
- (write-char #\0 stream))))
- (progn
- (write-string "." stream)
- (dotimes (i (- e))
- (write-char #\0 stream))
- (write-string string stream)
- (when fdigits
- (dotimes (i (+ fdigits e (- (length string))))
- (write-char #\0 stream)))))
- (let ((string (get-output-stream-string stream)))
- (values string (length string)
- (char= (char string 0) #\.)
- (char= (char string (1- (length string))) #\.)
- (position #\. string))))))))
-
-;;; implementation of figure 1 from Burger and Dybvig, 1996. As the
-;;; implementation of the Dragon from Classic CMUCL (and previously in
-;;; SBCL 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.
+ (multiple-value-bind (e string)
+ (if fdigits
+ (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
+ (- (or fmin 0))))
+ (if (and width (> width 1))
+ (let ((w (multiple-value-list
+ (flonum-to-digits x
+ (max 1
+ (+ (1- width)
+ (if (and scale (minusp scale))
+ scale 0)))
+ t)))
+ (f (multiple-value-list
+ (flonum-to-digits x (- (+ (or fmin 0)
+ (if scale scale 0)))))))
+ (cond
+ ((>= (length (cadr w)) (length (cadr f)))
+ (values-list w))
+ (t (values-list f))))
+ (flonum-to-digits x)))
+ (let ((e (+ e (or scale 0)))
+ (stream (make-string-output-stream)))
+ (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 fdigits
+ (dotimes (i (- fdigits
+ (- (length string)
+ (min (length string) e))))
+ (write-char #\0 stream))))
+ (progn
+ (write-string "." stream)
+ (dotimes (i (- e))
+ (write-char #\0 stream))
+ (write-string string stream)
+ (when fdigits
+ (dotimes (i (+ fdigits e (- (length string))))
+ (write-char #\0 stream)))))
+ (let ((string (get-output-stream-string stream)))
+ (values string (length string)
+ (char= (char string 0) #\.)
+ (char= (char string (1- (length string))) #\.)
+ (position #\. string))))))
+
+;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
+;;; extended in order to handle rounding.
+;;;
+;;; As the implementation of the Dragon from Classic CMUCL (and
+;;; previously in SBCL 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
;;; 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)))
+ (- 2 sb!vm:single-float-bias sb!vm:single-float-digits))
(defconstant double-float-min-e
- (nth-value 1 (decode-float least-positive-double-float)))
+ (- 2 sb!vm:double-float-bias sb!vm:double-float-digits))
#!+long-float
(defconstant long-float-min-e
(nth-value 1 (decode-float least-positive-long-float)))
(r r (* r print-base))
(m+ m+ (* m+ print-base))
(m- m- (* m- print-base)))
- ((not (or (< (* (+ r m+) print-base) s)
- (and (not high-ok)
- (= (* (+ r m+) print-base) s))))
+ ((not (and (plusp (- r m-)) ; Extension to handle zero
+ (or (< (* (+ r m+) print-base) s)
+ (and (not high-ok)
+ (= (* (+ r m+) print-base) s)))))
(values k (generate r s m+ m-)))))))
(generate (r s m+ m-)
(let (d tc1 tc2)
(values (float 0.0e0 original-x) 1)
(let* ((ex (locally (declare (optimize (safety 0)))
(the fixnum
- (round (* exponent (log 2e0 10))))))
+ (round (* exponent
+ ;; this is the closest double float
+ ;; to (log 2 10), but expressed so
+ ;; that we're not vulnerable to the
+ ;; host lisp's interpretation of
+ ;; arithmetic. (FIXME: it turns
+ ;; out that sbcl itself is off by 1
+ ;; ulp in this value, which is a
+ ;; little unfortunate.)
+ (load-time-value
+ #!-long-float
+ (sb!kernel:make-double-float 1070810131 1352628735)
+ #!+long-float
+ (error "(log 2 10) not computed")))))))
(x (if (minusp ex)
(if (float-denormalized-p x)
#!-long-float
projects / sbcl.git / blobdiff