conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* ikarus-fasl.c can now read bignums.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-12 16:59:21 -04:00
parent 888833f686
commit 9d32ae5767
6 changed files with 120 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
bin/ikarus
View File

Binary file not shown.

22
bin/ikarus-fasl.c
View File

@ -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);

BIN
src/ikarus.boot
View File

Binary file not shown.

89
src/ikarus.bytevectors.ss
View File

@ -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)

10
src/ikarus.numerics.ss
View File

@ -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)

2
src/makefile.ss
View File

@ -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]