diff --git a/BUGS b/BUGS index 8cc773c..1904baa 100644 --- a/BUGS +++ b/BUGS @@ -1,3 +1,19 @@ +Email Will Clinger regarding: + +Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD +Unix:unified) + + +> (exact->inexact #xFFFFFFFFFFFFFFFF) +9.223372036854776e18 + +> #xFFFFFFFFFFFFFFFF +18446744073709551615 + +====================================================================== + + + * FIX: Error in generate-code: BUG: unhandles single rv. @@ -13,6 +29,7 @@ Not applicable anymore: + Fixed: * Investigate what happens when an interrupt occurs during a write. @@ -28,3 +45,5 @@ Fixed: Two displays occurred at the end. + + diff --git a/src/ikarus.boot b/src/ikarus.boot index 2756dc1..9f0cab8 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index 4934c57..6e3bd73 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -71,6 +71,7 @@ exact->inexact floor ceiling log) (import (ikarus system $fx) + (ikarus system $flonums) (ikarus system $ratnums) (ikarus system $bignums) (ikarus system $chars) @@ -84,8 +85,189 @@ (define (fixnum->flonum x) (foreign-call "ikrt_fixnum_to_flonum" x)) - (define (bignum->flonum x) - (foreign-call "ikrt_bignum_to_flonum" x)) + (module (bignum->flonum) + ; sbe f6 f5 f4 f3 f2 f1 f0 + ;SEEEEEEE|EEEEmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm + ; | | | | | | | + ; v0 v1 v2 v3 v4 v5 v6 v7 + (define ($flonum pos? e f6 f5 f4 f3 f2 f1 f0) + (let ([v ($make-flonum)]) + (let ([be (fx+ e 1075)]) + (let ([sbe (if pos? be (fxlogor be (fxsll 1 11)))]) + ($flonum-set! v 0 (fxsra sbe 4)) + ($flonum-set! v 1 (fxlogor (fxsll sbe 4) (fxlogand f6 #b1111))) + ($flonum-set! v 2 f5) + ($flonum-set! v 3 f4) + ($flonum-set! v 4 f3) + ($flonum-set! v 5 f2) + ($flonum-set! v 6 f1) + ($flonum-set! v 7 f0))) + v)) + (define ($flonum/c0 pos? e f6 f5 f4 f3 f2 f1 f0 c) + (define ($fxeven? x) + (fxzero? (fxlogand x 1))) + (define-syntax cond* + (syntax-rules (else) + [(_ [test conseq] [else val]) + (if test conseq val)] + [(_ [test conseq] [var val] rest ...) + (if test conseq (let ([var val]) (cond* rest ...)))])) + (cond* + [($fxeven? c) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)] + [f0 (fx+ (fxlogand f0 255) 1)] + [(fx< f0 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)] + [f1 (fx+ (fxlogand f1 255) 1)] + [(fx< f1 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 0)] + [f2 (fx+ (fxlogand f2 255) 1)] + [(fx< f2 256) ($flonum pos? e f6 f5 f4 f3 f2 0 0)] + [f3 (fx+ (fxlogand f3 255) 1)] + [(fx< f3 256) ($flonum pos? e f6 f5 f4 f3 0 0 0)] + [f4 (fx+ (fxlogand f4 255) 1)] + [(fx< f4 256) ($flonum pos? e f6 f5 f4 0 0 0 0)] + [f5 (fx+ (fxlogand f5 255) 1)] + [(fx< f5 256) ($flonum pos? e f6 f5 0 0 0 0 0)] + [f6 (fx+ (fxlogand f6 #b1111) 1)] + [(fx< f6 16) ($flonum pos? e f6 0 0 0 0 0 0)] + [else ($flonum pos? (+ e 1) 0 0 0 0 0 0 0)])) + (define ($flonum/aux pos? e b7 b6 b5 b4 b3 b2 b1 b0) + (cond + [(fx>= b7 #x80) + ($flonum/c0 pos? (fx+ e 3) + (fxsra b7 3) + (fxlogor (fxsll b7 5) (fxsra b6 3)) + (fxlogor (fxsll b6 5) (fxsra b5 3)) + (fxlogor (fxsll b5 5) (fxsra b4 3)) + (fxlogor (fxsll b4 5) (fxsra b3 3)) + (fxlogor (fxsll b3 5) (fxsra b2 3)) + (fxlogor (fxsll b2 5) (fxsra b1 3)) + (fxsra b1 2))] + [(fx>= b7 #x40) + ($flonum/c0 pos? (fx+ e 2) + (fxsra b7 2) + (fxlogor (fxsll b7 6) (fxsra b6 2)) + (fxlogor (fxsll b6 6) (fxsra b5 2)) + (fxlogor (fxsll b5 6) (fxsra b4 2)) + (fxlogor (fxsll b4 6) (fxsra b3 2)) + (fxlogor (fxsll b3 6) (fxsra b2 2)) + (fxlogor (fxsll b2 6) (fxsra b1 2)) + (fxsra b1 1))] + [(fx>= b7 #x20) + ($flonum/c0 pos? (fx+ e 1) + (fxsra b7 1) + (fxlogor (fxsll b7 7) (fxsra b6 1)) + (fxlogor (fxsll b6 7) (fxsra b5 1)) + (fxlogor (fxsll b5 7) (fxsra b4 1)) + (fxlogor (fxsll b4 7) (fxsra b3 1)) + (fxlogor (fxsll b3 7) (fxsra b2 1)) + (fxlogor (fxsll b2 7) (fxsra b1 1)) + b1)] + [(fx>= b7 #x10) + ($flonum/c0 pos? e b7 b6 b5 b4 b3 b2 b1 + (fxsra b0 7))] + [(fx>= b7 #x08) + ($flonum/c0 pos? (fx- e 1) + (fxlogor (fxsll b7 1) (fxsra b6 7)) + (fxlogor (fxsll b6 1) (fxsra b5 7)) + (fxlogor (fxsll b5 1) (fxsra b4 7)) + (fxlogor (fxsll b4 1) (fxsra b3 7)) + (fxlogor (fxsll b3 1) (fxsra b2 7)) + (fxlogor (fxsll b2 1) (fxsra b1 7)) + (fxlogor (fxsll b1 1) (fxsra b0 7)) + (fxsra b0 6))] + [(fx>= b7 #x04) + ($flonum/c0 pos? (fx- e 2) + (fxlogor (fxsll b7 2) (fxsra b6 6)) + (fxlogor (fxsll b6 2) (fxsra b5 6)) + (fxlogor (fxsll b5 2) (fxsra b4 6)) + (fxlogor (fxsll b4 2) (fxsra b3 6)) + (fxlogor (fxsll b3 2) (fxsra b2 6)) + (fxlogor (fxsll b2 2) (fxsra b1 6)) + (fxlogor (fxsll b1 2) (fxsra b0 6)) + (fxsra b0 5))] + [(fx>= b7 #x02) + ($flonum/c0 pos? (fx- e 3) + (fxlogor (fxsll b7 3) (fxsra b6 5)) + (fxlogor (fxsll b6 3) (fxsra b5 5)) + (fxlogor (fxsll b5 3) (fxsra b4 5)) + (fxlogor (fxsll b4 3) (fxsra b3 5)) + (fxlogor (fxsll b3 3) (fxsra b2 5)) + (fxlogor (fxsll b2 3) (fxsra b1 5)) + (fxlogor (fxsll b1 3) (fxsra b0 5)) + (fxsra b0 4))] + [(fx>= b7 #x01) + ($flonum/c0 pos? (fx- e 4) + (fxlogor (fxsll b7 4) (fxsra b6 4)) + (fxlogor (fxsll b6 4) (fxsra b5 4)) + (fxlogor (fxsll b5 4) (fxsra b4 4)) + (fxlogor (fxsll b4 4) (fxsra b3 4)) + (fxlogor (fxsll b3 4) (fxsra b2 4)) + (fxlogor (fxsll b2 4) (fxsra b1 4)) + (fxlogor (fxsll b1 4) (fxsra b0 4)) + (fxsra b0 3))] + [else (error '$float/aux "invalid b7=~s" b7)])) + (define (bignum->flonum x) + (define (bignum/4->flonum x) + ($flonum/aux ($bignum-positive? x) -24 + ($bignum-byte-ref x 3) + ($bignum-byte-ref x 2) + ($bignum-byte-ref x 1) + ($bignum-byte-ref x 0) + 0 0 0 0)) + (define (bignum/8->flonum x) + ;;; bignum: [b0 b1 b2 b3 b4 b5 b6 b7] + (let ([b0 ($bignum-byte-ref x 0)] + [b1 ($bignum-byte-ref x 1)] + [b2 ($bignum-byte-ref x 2)] + [b3 ($bignum-byte-ref x 3)] + [b4 ($bignum-byte-ref x 4)] + [b5 ($bignum-byte-ref x 5)] + [b6 ($bignum-byte-ref x 6)] + [b7 ($bignum-byte-ref x 7)] + [pos? ($bignum-positive? x)]) + (if (fx= b7 0) + (if (fx= b6 0) + (if (fx= b5 0) + (if (fx= b4 0) + (error 'bignum8->flonum "malformed bignum") + ($flonum/aux pos? -16 b4 b3 b2 b1 b0 0 0 0)) + ($flonum/aux pos? -8 b5 b4 b3 b2 b1 b0 0 0)) + ($flonum/aux pos? 0 b6 b5 b4 b3 b2 b1 b0 0)) + ($flonum/aux pos? 8 b7 b6 b5 b4 b3 b2 b1 b0)))) + (define (bignum/n->flonum x bytes) + (define (aux x b7 bytes) + ($flonum/aux ($bignum-positive? x) (+ (* bytes 8) -48) + b7 + ($bignum-byte-ref x (fx- bytes 1)) + ($bignum-byte-ref x (fx- bytes 2)) + ($bignum-byte-ref x (fx- bytes 3)) + ($bignum-byte-ref x (fx- bytes 4)) + ($bignum-byte-ref x (fx- bytes 5)) + ($bignum-byte-ref x (fx- bytes 6)) + ($bignum-byte-ref x (fx- bytes 7)))) + ;;; bignum: [b0 b1 b2 b3 ... b_{bytes-1}] + (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)]) + (if (fx= bn 0) + (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)]) + (if (fx= bn 0) + (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)]) + (if (fx= bn 0) + (let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)]) + (if (fx= bn 0) + (error 'bignum/n->flonum "malformed bignum") + (aux x bn bytes))) + (aux x bn bytes))) + (aux x bn bytes))) + (aux x bn bytes)))) + + (unless (bignum? x) + (error 'bignum->flonum "~s is not a bignum" x)) + (let ([bytes ($bignum-size x)]) + (case bytes + [(4) (bignum/4->flonum x)] + [(8) (bignum/8->flonum x)] + [else (bignum/n->flonum x bytes)])))) + ;(define (bignum->flonum x) + ; (foreign-call "ikrt_bignum_to_flonum" x)) (define (ratnum->flonum x) (binary/ (exact->inexact ($ratnum-n x)) (exact->inexact ($ratnum-d x)))) diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index c3bb6f1..0b7eca9 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -756,7 +756,7 @@ (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7)) (interrupt)) (prm 'bset/h (T x) - (K (+ (- 7 i) (- disp-bytevector-data bytevector-tag))) + (K (+ (- 7 i) (- disp-flonum-data vector-tag))) (prm 'sll (T v) (K (- 8 fx-shift))))] [else (interrupt)])])