diff --git a/bin/ikarus b/bin/ikarus index 3eeb56f..eb4e821 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-fasl.c b/bin/ikarus-fasl.c index abc38f3..eb0eddc 100644 --- a/bin/ikarus-fasl.c +++ b/bin/ikarus-fasl.c @@ -529,6 +529,28 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ fasl_read_buf(p, &n, sizeof(int)); return int_to_scheme_char(n); } + else if(c == 'b'){ + int len; + int sign = 0; + fasl_read_buf(p, &len, sizeof(int)); + if(len < 0) { + sign = 1; + len = -len; + } + if(len & 3){ + fprintf(stderr, "Error in fasl-read: invalid bignum length %d\n", len); + exit(-1); + } + unsigned int tag = bignum_tag | (sign << bignum_sign_shift) | + ((len >> 2) << bignum_length_shift); + ikp x = ik_alloc(pcb, align(len + disp_bignum_data)) + vector_tag; + ref(x, -vector_tag) = (ikp) tag; + fasl_read_buf(p, x+off_bignum_data, len); + if(put_mark_index){ + p->marks[put_mark_index] = x; + } + return x; + } else { fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c); exit(-1); diff --git a/src/ikarus.boot b/src/ikarus.boot index f910c2c..c946902 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.bytevectors.ss b/src/ikarus.bytevectors.ss index c902219..04ccd60 100644 --- a/src/ikarus.bytevectors.ss +++ b/src/ikarus.bytevectors.ss @@ -119,6 +119,22 @@ (error 'bytevector-u16-native-ref "invalid index ~s" i)) (error 'bytevector-u16-native-ref "~s is not a bytevector" x)))) + (define bytevector-u32-native-ref ;;; HARDCODED + (lambda (x i) + (if (bytevector? x) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx< i ($fx- ($bytevector-length x) 3)) + ($fxzero? ($fxlogand i 3))) + (+ (* ($bytevector-u8-ref x i) #x1000000) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 16) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8) + ($bytevector-u8-ref x ($fx+ i 3))))) + (error 'bytevector-u32-native-ref "invalid index ~s" i)) + (error 'bytevector-u32-native-ref "~s is not a bytevector" x)))) + (define bytevector-u16-native-set! ;;; HARDCODED (lambda (x i n) (if (bytevector? x) @@ -133,9 +149,27 @@ ($bytevector-set! x i ($fxsra n 8)) ($bytevector-set! x ($fxadd1 i) n)) (error 'bytevector-u16-native-set! "invalid index ~s" i)) - (error 'bytevector-u8-native-set! "invalid value ~s" n)) + (error 'bytevector-u16-native-set! "invalid value ~s" n)) (error 'bytevector-u16-native-set! "~s is not a bytevector" x)))) + (define bytevector-u32-native-set! ;;; HARDCODED + (lambda (x i n) + (if (bytevector? x) + (if (and (or (fixnum? n) (bignum? n)) + (<= 0 n) + (<= n #xFFFFFFFF)) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx< i ($fx- ($bytevector-length x) 3)) + ($fxzero? ($fxlogand i 3))) + (begin + ($bytevector-set! x i (quotient n #x1000000)) + ($bytevector-set! x ($fx+ i 1) (quotient x #x10000)) + ($bytevector-set! x ($fx+ i 2) (quotient x #x100)) + ($bytevector-set! x ($fx+ i 3) (remainder n #x100))) + (error 'bytevector-u32-native-set! "invalid index ~s" i)) + (error 'bytevector-u32-native-set! "invalid value ~s" n)) + (error 'bytevector-u32-native-set! "~s is not a bytevector" x)))) (define bytevector-s16-native-set! ;;; HARDCODED (lambda (x i n) @@ -186,6 +220,31 @@ (error 'bytevector-u16-ref "invalid index ~s" i)) (error 'bytevector-u16-ref "~s is not a bytevector" x)))) + (define bytevector-u32-ref + (lambda (x i end) + (if (bytevector? x) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx< i ($fx- ($bytevector-length x) 3))) + (case end + [(big) + (+ (* ($bytevector-u8-ref x i) #x1000000) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 16) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 8) + ($bytevector-u8-ref x ($fx+ i 3)))))] + [(little) + (+ (* ($bytevector-u8-ref x ($fx+ i 3)) #x1000000) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 2)) 16) + ($fxlogor + ($fxsll ($bytevector-u8-ref x ($fx+ i 1)) 8) + ($bytevector-u8-ref x i))))] + [else (error 'bytevector-u32-ref "invalid endianness ~s" end)]) + (error 'bytevector-u32-ref "invalid index ~s" i)) + (error 'bytevector-u32-ref "~s is not a bytevector" x)))) + (define bytevector-u16-set! (lambda (x i n end) (if (bytevector? x) @@ -207,6 +266,29 @@ (error 'bytevector-u16-set! "invalid value ~s" n)) (error 'bytevector-u16-set! "~s is not a bytevector" x)))) + + (define bytevector-u32-set! + (lambda (x i n end) + (error 'bytevector-u32-set! "not yet") + (if (bytevector? x) + (if (and (fixnum? n) + ($fx<= 0 n) + ($fx<= n #xFFFFFFFF)) + (if (and (fixnum? i) + ($fx<= 0 i) + ($fx< i ($fx- ($bytevector-length x) 3))) + (case end + [(big) + ($bytevector-set! x i ($fxsra n 8)) + ($bytevector-set! x ($fxadd1 i) n)] + [(little) + ($bytevector-set! x i n) + ($bytevector-set! x ($fxadd1 i) (fxsra n 8))] + [else (error 'bytevector-u16-ref "invalid endianness ~s" end)]) + (error 'bytevector-u16-set! "invalid index ~s" i)) + (error 'bytevector-u16-set! "invalid value ~s" n)) + (error 'bytevector-u16-set! "~s is not a bytevector" x)))) + (define bytevector-s16-ref (lambda (x i end) (if (bytevector? x) @@ -248,6 +330,11 @@ (error 'bytevector-s16-set! "invalid value ~s" n)) (error 'bytevector-s16-set! "~s is not a bytevector" x)))) + + + + + (define bytevector->u8-list (lambda (x) (unless (bytevector? x) diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index 5c5c3a1..56367b3 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -309,7 +309,7 @@ (library (ikarus generic-arithmetic) (export + - * / zero? = < <= > >= add1 sub1 quotient remainder - modulo even? odd? + modulo even? odd? logand $two-bignums positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt quotient+remainder number->string string->number min max abs truncate fltruncate @@ -327,7 +327,7 @@ (only (ikarus flonums) $flonum->exact $flzero? $flnegative?) (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient remainder modulo even? odd? quotient+remainder number->string - positive? negative? + positive? negative? logand $two-bignums string->number expt gcd lcm numerator denominator exact->inexact inexact floor ceiling round log exact-integer-sqrt min max abs @@ -336,6 +336,12 @@ sin cos tan asin acos atan sqrt truncate fltruncate flround flmax random)) + (define ($two-bignums) + (list 1234567890 -1234567890 + 12345678901234567890 + -12345678901234567890 + 1234567890123456789012345678901234567890 + -1234567890123456789012345678901234567890)) ; (foreign-call "ikrt_fixnum_to_flonum" x)) (module (bignum->flonum) diff --git a/src/makefile.ss b/src/makefile.ss index 9b9434a..763b9aa 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -427,6 +427,7 @@ [string->utf8-bytevector i] [utf8-bytevector->string i] [native-endianness i] + [$two-bignums i] [for-each i r] [map i r] @@ -450,6 +451,7 @@ [fxsll i] [fxsra i] [fxlogand i] + [logand i] [fxlogxor i] [fxlogor i] [fxlognot i]