#!+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))))
;; 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.
;; 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 2001-11-25
- (fixnum
- (output-integer object stream))
(list
(if (null object)
(output-symbol object stream)
;;; 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))))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
+(defun %output-radix (base stream)
+ (write-char #\# stream)
+ (write-char (case base
+ (2 #\b)
+ (8 #\o)
+ (16 #\x)
+ (t (%output-fixnum-in-base base 10 stream)
+ #\r))
+ stream))
+
+(defun %output-fixnum-in-base (n base stream)
+ (multiple-value-bind (q r)
+ (truncate n base)
+ ;; Recurse until you have all the digits pushed on
+ ;; the stack.
+ (unless (zerop q)
+ (%output-fixnum-in-base q base stream))
+ ;; Then as each recursive call unwinds, turn the
+ ;; digit (in remainder) into a character and output
+ ;; the character.
+ (write-char
+ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
+ stream)))
+
+;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
+(defun %output-bignum-in-base (n base stream)
+ (declare (type bignum n) (type fixnum base))
+ (let ((power (make-array 10 :adjustable t :fill-pointer 0)))
+ ;; Here there be the bottleneck for big bignums, in the (* p p).
+ ;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan
+ ;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11:
+ ;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271.
+ ;; Reprinted as "More on Multiplying and Squaring Large Integers",
+ ;; IEEE Transactions on Computers, volume 43, number 8, August
+ ;; 1994, pp. 899-908.
+ (do ((p base (* p p)))
+ ((> p n))
+ (vector-push-extend p power))
+ ;; (aref power k) == (expt base (expt 2 k))
+ (labels ((bisect (n k exactp)
+ (declare (fixnum k))
+ ;; N is the number to bisect
+ ;; K on initial entry BASE^(2^K) > N
+ ;; EXACTP is true if 2^K is the exact number of digits
+ (cond ((zerop n)
+ (when exactp
+ (loop repeat (ash 1 k) do (write-char #\0 stream))))
+ ((zerop k)
+ (write-char
+ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)
+ stream))
+ (t
+ (setf k (1- k))
+ (multiple-value-bind (q r) (truncate n (aref power k))
+ ;; EXACTP is NIL only at the head of the
+ ;; initial number, as we don't know the number
+ ;; of digits there, but we do know that it
+ ;; doesn't get any leading zeros.
+ (bisect q k exactp)
+ (bisect r k (or exactp (plusp q))))))))
+ (bisect n (fill-pointer power) nil))))
+
+(defun %output-integer-in-base (integer base stream)
+ (when (minusp integer)
+ (write-char #\- stream)
+ (setf integer (- integer)))
+ (if (fixnump integer)
+ (%output-fixnum-in-base integer base stream)
+ (%output-bignum-in-base integer base stream)))
+
(defun output-integer (integer stream)
- ;; FIXME: This UNLESS form should be pulled out into something like
- ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
- ;; *PACKAGE* variable.
- (unless (and (fixnump *print-base*)
- (< 1 *print-base* 37))
- (let ((obase *print-base*))
- (setq *print-base* 10.)
- (error "~A is not a reasonable value for *PRINT-BASE*." obase)))
- (when (and (not (= *print-base* 10.))
- *print-radix*)
- ;; First print leading base information, if any.
- (write-char #\# stream)
- (write-char (case *print-base*
- (2. #\b)
- (8. #\o)
- (16. #\x)
- (T (let ((fixbase *print-base*)
- (*print-base* 10.)
- (*print-radix* ()))
- (sub-output-integer fixbase stream))
- #\r))
- stream))
- ;; Then output a minus sign if the number is negative, then output
- ;; the absolute value of the number.
- (cond ((bignump integer) (print-bignum integer stream))
- ((< integer 0)
- (write-char #\- stream)
- (sub-output-integer (- integer) stream))
- (t
- (sub-output-integer integer stream)))
- ;; Print any trailing base information, if any.
- (if (and (= *print-base* 10.) *print-radix*)
- (write-char #\. stream)))
-
-(defun sub-output-integer (integer stream)
- (let ((quotient ())
- (remainder ()))
- ;; Recurse until you have all the digits pushed on the stack.
- (if (not (zerop (multiple-value-setq (quotient remainder)
- (truncate integer *print-base*))))
- (sub-output-integer quotient stream))
- ;; Then as each recursive call unwinds, turn the digit (in remainder)
- ;; into a character and output the character.
- (write-char (code-char (if (and (> remainder 9.)
- (> *print-base* 10.))
- (+ (char-code #\A) (- remainder 10.))
- (+ (char-code #\0) remainder)))
- stream)))
-\f
-;;;; bignum printing
-
-;;; *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*.
-(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.
-(defun print-bignum (big stream)
- (unless (aref *base-power* *print-base*)
- (do ((power-1 -1 (1+ power-1))
- (new-divisor *print-base* (* new-divisor *print-base*))
- (divisor 1 new-divisor))
- ((not (fixnump new-divisor))
- (setf (aref *base-power* *print-base*) divisor)
- (setf (aref *fixnum-power--1* *print-base*) power-1))))
- (bignum-print-aux (cond ((minusp big)
- (write-char #\- stream)
- (- big))
- (t big))
- (aref *base-power* *print-base*)
- (aref *fixnum-power--1* *print-base*)
- stream)
- big)
-
-(defun bignum-print-aux (big divisor power-1 stream)
- (multiple-value-bind (newbig fix) (truncate big divisor)
- (if (fixnump newbig)
- (sub-output-integer newbig stream)
- (bignum-print-aux newbig divisor power-1 stream))
- (do ((zeros power-1 (1- zeros))
- (base-power *print-base* (* base-power *print-base*)))
- ((> base-power fix)
- (dotimes (i zeros) (write-char #\0 stream))
- (sub-output-integer fix stream)))))
+ (let ((base *print-base*))
+ (when (and (/= base 10) *print-radix*)
+ (%output-radix base stream))
+ (%output-integer-in-base integer base stream)
+ (when (and *print-radix* (= base 10))
+ (write-char #\. stream))))
(defun output-ratio (ratio stream)
- (when *print-radix*
- (write-char #\# stream)
- (case *print-base*
- (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))))
- (let ((*print-radix* nil))
- (output-integer (numerator ratio) stream)
+ (let ((base *print-base*))
+ (when *print-radix*
+ (%output-radix base stream))
+ (%output-integer-in-base (numerator ratio) base stream)
(write-char #\/ stream)
- (output-integer (denominator ratio) stream)))
+ (%output-integer-in-base (denominator ratio) base stream)))
(defun output-complex (complex stream)
(write-string "#C(" stream)
+ ;; FIXME: Could this just be OUTPUT-NUMBER?
(output-object (realpart complex) stream)
(write-char #\space stream)
(output-object (imagpart complex) stream)
;;;; float printing
;;; 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:
+;;; most of the work for all printing of floating point numbers 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.
;;; significance in the printed value due to a bogus choice of
;;; scale factor.
;;;
-;;; Most of the optional arguments are for the benefit for FORMAT and are not
-;;; used by the printer.
-;;;
;;; Returns:
;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
;;; where the results have the following interpretation:
;;; 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!
-
-(declaim (type (simple-array character (10)) *digits*))
-(defvar *digits* "0123456789")
+;;; FLOAT-DIGITS actually generates the digits for positive numbers;
+;;; see below for comments.
(defun flonum-to-string (x &optional width fdigits scale fmin)
+ (declare (type float x))
+ ;; 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
(values s (length s) t (zerop fdigits) 0))
(values "." 1 t t 0)))
(t
- (multiple-value-bind (sig exp) (integer-decode-float x)
- (let* ((precision (float-precision x))
- (digits (float-digits x))
- (fudge (- digits precision))
- (width (if width (max width 1) nil)))
- (float-string (ash sig (- fudge)) (+ exp fudge) precision width
- fdigits scale fmin))))))
-
-(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-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.
- (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.
- (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.
- (when scale
- (if (minusp scale)
- (let ((scale-factor (expt 10 (- scale))))
- (setq s (* s scale-factor)))
- (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.
- (do ()
- ((>= r (ceiling s 10)))
- (decf k)
- (setq r (* r 10))
- (setq m- (* m- 10))
- (setq m+ (* m+ 10)))
- (do ()(nil)
- (do ()
- ((< (+ (ash r 1) m+) (ash s 1)))
- (setq s (* s 10))
- (incf k))
- ;; Determine number of fraction digits to generate.
- (cond (fdigits
- ;; 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.
- (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.
- (when (or fdigits width)
- (let ((a (- cutoff k))
- (y s))
- (if (>= a 0)
- (dotimes (i a) (setq y (* y 10)))
- (dotimes (i (- a)) (setq y (ceiling y 10))))
- (setq m- (max y m-))
- (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.
- (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.
- (do ()(nil)
- (decf k)
- (when (= k -1)
- (vector-push-extend #\. digit-string)
- (setq decpnt digits))
- (multiple-value-setq (u r) (truncate (* r 10) s))
- (setq m- (* m- 10))
- (setq m+ (* m+ 10))
- (setq low (< (ash r 1) m-))
- (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.
- (when (or low high (and cutoff (<= k cutoff))) (return))
- (vector-push-extend (char *digits* 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*
- (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.
- (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.
- (when fdigits
- (dotimes (i (- fdigits (- digits decpnt)))
- (incf digits)
- (vector-push-extend #\0 digit-string)))
- ;; all done
- (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
+ (multiple-value-bind (e string)
+ (if fdigits
+ (flonum-to-digits x (min (- fdigits) (- (or fmin 0))))
+ (if (and width (> width 1))
+ (let ((w (multiple-value-list (flonum-to-digits x (1- width) t)))
+ (f (multiple-value-list (flonum-to-digits x (- (or fmin 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 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.
+;;; 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
-;;; 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).
+;;; an improved algorithm, but CSR ran out of energy.
;;;
;;; possible extension for the enthusiastic: printing floats in bases
;;; other than base 10.
(defconstant long-float-min-e
(nth-value 1 (decode-float least-positive-long-float)))
-(defun flonum-to-digits (v)
+(defun flonum-to-digits (v &optional position relativep)
(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)
(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))))
+ (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)
(and high-ok (= (+ r m+) s))))
(when (or tc1 tc2)
(go end))
- (vector-push-extend (char *digits* d) result)
+ (vector-push-extend (char digit-characters d) result)
(go loop)
end
(let ((d (cond
((and tc1 (not tc2)) d)
(t ; (and tc1 tc2)
(if (< (* r 2) s) d (1+ d))))))
- (vector-push-extend (char *digits* 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))))))))
+ (vector-push-extend (char digit-characters d) result)
+ (return-from generate result)))))
+ (initialize ()
+ (let (r s m+ m-)
+ (if (>= e 0)
+ (let* ((be (expt float-radix e))
+ (be1 (* be float-radix)))
+ (if (/= f (expt float-radix (1- float-digits)))
+ (setf r (* f be 2)
+ s 2
+ m+ be
+ m- be)
+ (setf r (* f be1 2)
+ s (* float-radix 2)
+ m+ be1
+ m- be)))
+ (if (or (= e min-e)
+ (/= f (expt float-radix (1- float-digits))))
+ (setf r (* f 2)
+ s (* (expt float-radix (- e)) 2)
+ m+ 1
+ m- 1)
+ (setf r (* f float-radix 2)
+ s (* (expt float-radix (- 1 e)) 2)
+ m+ float-radix
+ m- 1)))
+ (when position
+ (when relativep
+ (aver (> position 0))
+ (do ((k 0 (1+ k))
+ ;; running out of letters here
+ (l 1 (* l print-base)))
+ ((>= (* s l) (+ r m+))
+ ;; k is now \hat{k}
+ (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
+ (* s (expt print-base k)))
+ (setf position (- k position))
+ (setf position (- k position 1))))))
+ (let ((low (max m- (/ (* s (expt print-base position)) 2)))
+ (high (max m+ (/ (* s (expt print-base position)) 2))))
+ (when (<= m- low)
+ (setf m- low)
+ (setf low-ok t))
+ (when (<= m+ high)
+ (setf m+ high)
+ (setf high-ok t))))
+ (values r s m+ m-))))
+ (multiple-value-bind (r s m+ m-) (initialize)
+ (scale r s m+ m-)))))))
\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
nil)
(defun output-fun (object stream)
- (let* ((*print-length* 3) ; in case we have to..
- (*print-level* 3) ; ..print an interpreted function definition
- ;; 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))))
- (print-unreadable-object (object
- stream
- :identity (not identified-by-name-p))
- (prin1 'function stream)
- (unless (eq name 'no-name-available)
- (format stream " ~S" name)))))
+ (let* ((*print-length* 3) ; in case we have to..
+ (*print-level* 3) ; ..print an interpreted function definition
+ (name (%fun-name object))
+ (proper-name-p (and (legal-fun-name-p name) (fboundp name)
+ (eq (fdefinition name) object))))
+ (print-unreadable-object (object stream :identity (not proper-name-p))
+ (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
+ (closurep object)
+ name))))
\f
;;;; catch-all for unknown things
projects / sbcl.git / blobdiff