exactness (or radix 10)
char))
((char=? #\. char)
- (and (or (not radix) (fix:= 10 radix))
- (parse-decimal-1 string start end
- (or exactness 'implicit-inexact) #f)))
+ (and (or (not radix) (fix:= 10 radix) (fix:= #x10 radix))
+ (parse-dotted-1 string start end
+ (or exactness 'implicit-inexact)
+ (or radix 10)
+ #f)))
((char->digit char (or radix 10))
=> (lambda (digit)
(parse-integer string start end digit
(parse-integer string start end digit
exactness radix sign)))
((char=? #\. char)
- (and (fix:= 10 radix)
- (parse-decimal-1 string start end
- (or exactness 'implicit-inexact) sign)))
+ (parse-dotted-1 string start end
+ (or exactness 'implicit-inexact)
+ radix
+ sign))
((i? char)
(and (fix:= start end)
(make-rectangular 0 (if (eq? #\- sign) -1 1))))
(parse-denominator-1 string start+1 end
integer exactness radix sign))
((char=? #\. char)
- (and (fix:= radix 10)
- (if sharp?
- (parse-decimal-3 string start+1 end
- integer 0 exactness sign)
- (parse-decimal-2 string start+1 end
- integer 0
- (or exactness 'implicit-inexact)
- sign))))
+ (if sharp?
+ (parse-dotted-3 string start+1 end
+ integer 0 exactness radix sign)
+ (parse-dotted-2 string start+1 end
+ integer 0
+ (or exactness 'implicit-inexact)
+ radix
+ sign)))
((exponent-marker? char)
+ ;; XXX Necessary to limit this to radix 10?
(and (fix:= radix 10)
(parse-exponent-1 string start+1 end
integer 0
(or exactness 'implicit-inexact)
- sign)))
+ radix sign 10)))
+ ((or (char=? #\p char) (char=? #\P char))
+ (parse-exponent-1 string start+1 end
+ integer 0
+ (or exactness 'implicit-inexact)
+ radix sign 2))
(else
(parse-complex string start end
(finish-integer integer exactness sign)
exactness radix sign))))
(finish-integer integer exactness sign)))))
-
+\f
(define (parse-digits string start end integer exactness radix k)
(let loop ((start start) (integer integer))
(if (fix:< start end)
(finish integer exactness sign)
exactness radix sign))))))
\f
-(define (parse-decimal-1 string start end exactness sign)
- ;; State: radix is 10, leading dot seen.
+(define (parse-dotted-1 string start end exactness radix sign)
+ ;; State: leading dot seen.
(and (fix:< start end)
- (let ((digit (char->digit (string-ref string start) 10))
+ (let ((digit (char->digit (string-ref string start) radix))
(start (fix:+ start 1)))
(and digit
- (parse-decimal-2 string start end digit -1 exactness sign)))))
+ (parse-dotted-2 string start end digit -1 exactness radix
+ sign)))))
-(define (parse-decimal-2 string start end integer exponent exactness sign)
- ;; State: radix is 10, dot seen.
- (let loop ((start start) (integer integer) (exponent exponent))
+(define (parse-dotted-2 string start end integer rexponent exactness radix
+ sign)
+ ;; State: dot seen.
+ (let loop ((start start) (integer integer) (rexponent rexponent))
(if (fix:< start end)
(let ((char (string-ref string start))
(start+1 (fix:+ start 1)))
- (cond ((char->digit char 10)
+ (cond ((char->digit char radix)
=> (lambda (digit)
(loop start+1
- (+ (* integer 10) digit)
- (- exponent 1))))
+ (+ (* integer radix) digit)
+ (- rexponent 1))))
((char=? #\# char)
- (parse-decimal-3 string start+1 end
- integer exponent exactness sign))
+ (parse-dotted-3 string start+1 end
+ integer rexponent exactness radix sign))
(else
- (parse-decimal-4 string start end
- integer exponent exactness sign))))
- (finish-real integer exponent exactness sign))))
+ (parse-dotted-4 string start end
+ integer rexponent exactness radix sign))))
+ (finish-real integer rexponent exactness radix sign 10 0))))
-(define (parse-decimal-3 string start end integer exponent exactness sign)
- ;; State: radix is 10, dot and # seen.
+(define (parse-dotted-3 string start end integer rexponent exactness radix
+ sign)
+ ;; State: dot and # seen.
(let loop ((start start))
(if (fix:< start end)
(let ((char (string-ref string start))
(start+1 (fix:+ start 1)))
(if (char=? #\# char)
(loop start+1)
- (parse-decimal-4 string start end
- integer exponent exactness sign)))
- (finish-real integer exponent exactness sign))))
-
-(define (parse-decimal-4 string start end integer exponent exactness sign)
- (if (exponent-marker? (string-ref string start))
- (parse-exponent-1 string (fix:+ start 1) end
- integer exponent exactness sign)
- (parse-decimal-5 string start end integer exponent exactness sign)))
-
-(define (parse-exponent-1 string start end integer exponent exactness sign)
- ;; State: radix is 10, exponent seen.
+ (parse-dotted-4 string start end
+ integer rexponent exactness radix sign)))
+ (finish-real integer rexponent exactness radix sign radix 0))))
+\f
+(define (parse-dotted-4 string start end integer rexponent exactness radix
+ sign)
+ (cond ((exponent-marker? (string-ref string start))
+ (and (fix:= radix 10)
+ (parse-exponent-1 string (fix:+ start 1) end
+ integer rexponent exactness radix sign 10)))
+ ((or (char=? #\p (string-ref string start))
+ (char=? #\P (string-ref string start)))
+ (and (fix:= radix #x10)
+ (parse-exponent-1 string (fix:+ start 1) end
+ integer rexponent exactness radix sign 2)))
+ (else
+ (parse-dotted-5 string start end integer rexponent exactness radix
+ sign))))
+
+(define (parse-exponent-1 string start end integer rexponent exactness radix
+ sign base)
+ ;; State: exponent seen.
(define (get-digits start esign)
(and (fix:< start end)
(let ((digit (char->digit (string-ref string start) 10)))
(continue start eint esign)))))))
(define (continue start eint esign)
- (let ((exponent (+ exponent (if (eq? #\- esign) (- eint) eint))))
+ (let ((bexponent (if (eq? #\- esign) (- eint) eint)))
(if (fix:= start end)
- (finish-real integer exponent exactness sign)
- (parse-decimal-5 string start end
- integer exponent exactness sign))))
+ (finish-real integer rexponent exactness radix sign base bexponent)
+ (parse-decimal-5 string start end integer rexponent exactness radix
+ sign base bexponent))))
(and (fix:< start end)
(let ((esign (string-ref string start)))
(get-digits (fix:+ start 1) esign)
(get-digits start #f)))))
-(define (parse-decimal-5 string start end integer exponent exactness sign)
+(define (parse-dotted-5 string start end integer rexponent exactness radix
+ sign)
(parse-complex string start end
- (finish-real integer exponent exactness sign)
- exactness 10 sign))
+ (finish-real integer rexponent exactness radix sign 10 0)
+ exactness radix sign))
\f
(define (parse-complex string start end real exactness radix sign)
(if (fix:< start end)
;; State: result is rational, apply exactness and sign.
(finish (/ numerator denominator) exactness sign))
\f
-;; (finish-real integer exponent exactness sign)
+;; (finish-real integer rexponent exactness radix sign base bexponent)
;;
-;; magnitude is (* INTEGER (EXPT 10 EXPONENT))
+;; magnitude is (* INTEGER (EXPT RADIX REXPONENT) (EXPT BASE BEXPONENT))
;;
;; In the general case for an inexact result, to obtain a correctly
;; rounded result, it is necessary to work with exact or high
;; the reciprocal is exact.
(define exact-flonum-powers-of-10) ; a vector, i -> 10.^i
-
-(define (finish-real integer exponent exactness sign)
+\f
+(define (finish-real integer rexponent exactness radix sign base bexponent)
;; State: result is integer, apply exactness and sign.
(define (high-precision-method)
- (apply-exactness exactness
- (* (apply-sign sign integer)
- (expt 10 exponent))))
-
- (if (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness))
- (let ((abs-exponent (if (< exponent 0) (- exponent) exponent))
- (powers-of-10 exact-flonum-powers-of-10))
+ (apply-sign sign
+ (apply-exactness exactness
+ (* integer
+ (expt radix rexponent)
+ (expt base bexponent)))))
+
+ (if (and (fix:= radix 10)
+ (fix:= base 10)
+ (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness)))
+ (let* ((exponent (+ rexponent bexponent))
+ (abs-exponent (if (< exponent 0) (- exponent) exponent))
+ (powers-of-10 exact-flonum-powers-of-10))
(define-integrable (finish-flonum x power-of-10)
(if (eq? #\- sign)
(if (eq? exponent abs-exponent)
(finish-flonum exact-flonum-integer
(vector-ref powers-of-10 abs-exponent))))
(else (high-precision-method))))
- (high-precision-method)))
+ (if (and (fix:power-of-two? radix)
+ (fix:power-of-two? base)
+ (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness)))
+ ;; x * r^re * b^be
+ ;; = x * 2^{log_2 r^re} * 2^{log_2 b^be}
+ ;; = x * 2^{re log_2 r + be log_2 b}
+ (let* ((log2r (fix:- (integer-length radix) 1))
+ (log2b (fix:- (integer-length base) 1)))
+ (let* ((e (fix:+ (fix:* rexponent log2r) (fix:* bexponent log2b)))
+ (x (flo:ldexp (int:->flonum integer) e)))
+ (if (eq? #\- sign)
+ (flo:negate x)
+ x)))
+ (high-precision-method))))
+
+(define-integrable (fix:power-of-two? x)
+ (fix:= 0 (fix:and x (fix:- x 1))))
(define flonum-parser-fast?
#f)
(define (finish number exactness sign)
(apply-sign sign (apply-exactness exactness number)))
+(define (apply-sign sign number)
+ (if (eq? #\- sign)
+ ;; Kludge to work around miscompilation of (- number).
+ (cond ((flo:flonum? number)
+ (flo:negate number))
+ ((and (complex? number) (not (real? number)))
+ (make-rectangular (apply-sign sign (real-part number))
+ (apply-sign sign (imag-part number))))
+ (else
+ (- number)))
+ number))
+
+#;
(define (apply-sign sign number)
(if (eq? #\- sign)
(- number)
(define-eqv-test "#o#e-100" -64)
(define-eqv-test "#d#e-100" -100)
(define-eqv-test "#x#e-100" -256)
+
+(define-eqv-test "#e#x1p10" (expt 2 10))
+(define-eqv-test "#e#x1.1p4" #x11)
+(define-eqv-test "#e#x1.1p-1" (* #x11 (expt 2 (- (+ 1 4)))))
+(define-eqv-test "#x1.1p-1" (exact->inexact (* #x11 (expt 2 (- (+ 1 4))))))
+
+(define-eqv-test "#b0." 0.)
+(define-eqv-test "#b0.+0.i" 0.+0.i)
+(define-eqv-test "#b0.-0.i" 0.-0.i)
+(define-eqv-test "#b0.+10.i" 0.+2.i)
+(define-eqv-test "#b0.-10.i" 0.-2.i)
+(define-eqv-test "#b-0." -0.)
+(define-eqv-test "#b-0.+0.i" -0.+0.i)
+(define-eqv-test "#b-0.-0.i" -0.-0.i)
+(define-eqv-test "#b-0.+10.i" -0.+2.i)
+(define-eqv-test "#b-0.-10.i" -0.-2.i)
+(define-eqv-test "#o0." 0.)
+(define-eqv-test "#o0.+0.i" 0.+0.i)
+(define-eqv-test "#o0.-0.i" 0.-0.i)
+(define-eqv-test "#o0.+10.i" 0.+8.i)
+(define-eqv-test "#o0.-10.i" 0.-8.i)
+(define-eqv-test "#o-0." -0.)
+(define-eqv-test "#o-0.+0.i" -0.+0.i)
+(define-eqv-test "#o-0.-0.i" -0.-0.i)
+(define-eqv-test "#o-0.+10.i" -0.+8.i)
+(define-eqv-test "#o-0.-10.i" -0.-8.i)
+(define-eqv-test "#x0." 0.)
+(define-eqv-test "#x0.+0.i" 0.+0.i)
+(define-eqv-test "#x0.-0.i" 0.-0.i)
+(define-eqv-test "#x0.+10.i" 0.+16.i)
+(define-eqv-test "#x0.-10.i" 0.-16.i)
+(define-eqv-test "#x-0." -0.)
+(define-eqv-test "#x-0.+0.i" -0.+0.i)
+(define-eqv-test "#x-0.-0.i" -0.-0.i)
+(define-eqv-test "#x-0.+10.i" -0.+16.i)
+(define-eqv-test "#x-0.-10.i" -0.-16.i)
projects / mit-scheme.git / commitdiff