* ikarus-fasl.c can now read bignums.

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

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)

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)

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]