;;; [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")
-
(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)))))
(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)
(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)
+ (vector-push-extend (char digit-characters d) result)
(return-from generate result))))))
(if (>= e 0)
(if (/= f (expt float-radix (1- float-digits)))