* Added floor/ceiling.

bin/ikarus-collect.c

@@ -1100,6 +1100,17 @@ add_object_proc(gc_t* gc, ikp x)
       ref(x, wordsize-vector_tag) = new;
       return new;
     }
+    else if(fst == ratnum_tag){
+      ikp y = gc_alloc_new_data(ratnum_size, gen, gc) + vector_tag;
+      ikp num = ref(x, disp_ratnum_num-vector_tag);
+      ikp den = ref(x, disp_ratnum_den-vector_tag);
+      ref(x, -vector_tag) = forward_ptr;
+      ref(x, wordsize-vector_tag) = y;
+      ref(y, -vector_tag) = fst;
+      ref(y, disp_ratnum_num-vector_tag) = add_object(gc, num, "num");
+      ref(y, disp_ratnum_den-vector_tag) = add_object(gc, den, "den");
+      return y;
+    }
     else {
       fprintf(stderr, "unhandled vector with fst=0x%08x\n", (int)fst);
       assert(0);
@@ -1109,12 +1120,12 @@ add_object_proc(gc_t* gc, ikp x)
   else if(tag == string_tag){
     if(is_fixnum(fst)){
       int strlen = unfix(fst);
-      int memreq = align(strlen*string_char_size + disp_string_data + 1);
+      int memreq = align(strlen*string_char_size + disp_string_data);
       ikp new_str = gc_alloc_new_data(memreq, gen, gc) + string_tag;
       ref(new_str, off_string_length) = fst;
       memcpy(new_str+off_string_data,
              x + off_string_data,
-             strlen*string_char_size + 1);
+             strlen*string_char_size);
       ref(x, -string_tag) = forward_ptr;
       ref(x, wordsize-string_tag) = new_str;
 #if accounting

bin/ikarus-data.h

@@ -234,4 +234,10 @@
 #define off_flonum_data (disp_flonum_data - vector_tag)
 #define flonum_data(x) (*((double*)(((ikp)(x))+off_flonum_data)))
 
+#define ratnum_tag  ((ikp) 0x27)
+#define ratnum_size        16
+#define disp_ratnum_num     4
+#define disp_ratnum_den     8
+#define disp_ratnum_unused 12
+
 #endif

bin/ikarus-flonums.c

@@ -186,13 +186,17 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
   ref(r, -vector_tag) = (ikp)flonum_tag;
   unsigned int fst = (unsigned int) ref(x, -vector_tag);
   int limbs = (fst >> bignum_length_shift);
+  fprintf(stderr, "limbs=%d\n", limbs);
   double fl;
   if(limbs == 1){
     fl = ((unsigned int)ref(x, disp_bignum_data - vector_tag));
   } else if(limbs == 2){
     fl = ((unsigned int)ref(x, wordsize+disp_bignum_data - vector_tag));
+    fprintf(stderr, "fl=%f\t", fl);
     fl *= exp2(32);
+    fprintf(stderr, "fl=%f\t", fl);
     fl += ((unsigned int)ref(x, disp_bignum_data - vector_tag));
+    fprintf(stderr, "fl=%f\n", fl);
   } else {
     fl = 
       ((unsigned int)ref(x, limbs * wordsize - wordsize + 
@@ -209,6 +213,14 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
     fl = -fl;
   }
   flonum_data(r) = fl;
+  {
+    int i;
+    unsigned char* p = (unsigned char*)(r+disp_flonum_data-vector_tag);
+    for(i=0; i<8; i++){
+      fprintf(stderr, "%02x ", p[7-i]);
+    }
+    fprintf(stderr, "\n");
+  }
   return r;
 }
 

bin/verify-integrity.c

@@ -102,7 +102,10 @@ verify_code_page(unsigned char* p, unsigned int s, unsigned int d,
     unsigned char* base, unsigned int* svec, unsigned int* dvec){
   ikp fst = ref(p, 0);
   fst += 0;
-  assert (fst == code_tag);
+  if(fst != code_tag){
+    fprintf(stderr, "non code object with tag %p found\n", fst);
+    exit(-1);
+  }
   int code_size = unfix(ref(p, disp_code_code_size));
   assert(code_size >= 0);
   int obj_size = align(code_size + disp_code_data);

src/ikarus.numerics.ss

@@ -5,9 +5,10 @@
 
 
 (library (ikarus flonums)
-  (export string->flonum flonum->string)
+  (export string->flonum flonum->string $flonum->exact)
   (import 
     (ikarus system $bytevectors)
+    (ikarus system $flonums)
     (except (ikarus) flonum->string string->flonum))
   
   (define (flonum->string x)
@@ -22,7 +23,49 @@
        (foreign-call "ikrt_bytevector_to_flonum" 
          (string->utf8-bytevector x))]
       [else 
-       (error 'string->flonum "~s is not a string" x)])))
+       (error 'string->flonum "~s is not a string" x)]))
+  
+  (define (flonum-bytes f)
+    (unless (flonum? f) 
+      (error 'flonum-bytes "~s is not a flonum" f))
+    (values 
+      ($flonum-u8-ref f 0)
+      ($flonum-u8-ref f 1)
+      ($flonum-u8-ref f 2)
+      ($flonum-u8-ref f 3)
+      ($flonum-u8-ref f 4)
+      ($flonum-u8-ref f 5)
+      ($flonum-u8-ref f 6)
+      ($flonum-u8-ref f 7)))
+  
+  (define (flonum-parts x)
+    (unless (flonum? x) 
+      (error 'flonum-parts "~s is not a flonum" x))
+    (let-values ([(b0 b1 b2 b3 b4 b5 b6 b7) (flonum-bytes x)])
+      (values 
+        (zero? (fxlogand b0 128)) 
+        (+ (fxsll (fxlogand b0 127) 4)
+           (fxsra b1 4))
+        (+ (+ b7 (fxsll b6 8) (fxsll b5 16))
+           (* (+ b4
+                 (fxsll b3 8)
+                 (fxsll b2 16)
+                 (fxsll (fxlogand b1 #b1111) 24))
+              (expt 2 24))))))
+ 
+  (define ($flonum->exact x)
+    (let-values ([(pos? be m) (flonum-parts x)])
+      (cond
+        [(<= 1 be 2046) ; normalized flonum
+         (* (if pos? 1 -1)
+            (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
+        [(= be 0) 
+         (* (if pos? 1 -1) 
+            (* m (expt 2 -1074)))]
+        [else #f])))
+  
+  
+  )
 
 
 
@@ -30,17 +73,18 @@
   (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
           positive? expt gcd lcm numerator denominator exact-integer-sqrt
           quotient+remainder number->string string->number max
-          exact->inexact)
+          exact->inexact floor ceiling)
   (import 
     (ikarus system $fx)
     (ikarus system $ratnums)
     (ikarus system $bignums)
     (ikarus system $chars)
     (ikarus system $strings)
+    (only (ikarus flonums) $flonum->exact)
     (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
             remainder quotient+remainder number->string positive?
             string->number expt gcd lcm numerator denominator
-            exact->inexact
+            exact->inexact floor ceiling
             exact-integer-sqrt max))
 
   (define (fixnum->flonum x)
@@ -943,7 +987,7 @@
         [(fixnum? m) 
          (if ($fx>= m 0)
              (fxexpt n m)
-             (error 'expt "power should be positive, got ~s" m))]
+             (/ 1 (expt n (- m))))]
         [(bignum? m) 
          (cond
            [(eq? n 0) 0]
@@ -953,11 +997,9 @@
                 (if (even-bignum? m)
                     1
                     -1)
-                (error 'expt "power should be positive, got ~s" m))]
+                (/ 1 (expt n (- m))))]
            [else 
-            (if (positive-bignum? m)
+            (error 'expt "(expt ~s ~s) is too big to compute" n m)])]
-                (error 'expt "(expt ~s ~s) is too big to compute" n m)
-                (error 'expt "power should be positive, got ~s" m))])]
         [else (error 'expt "~s is not a number" m)])))
 
   (define quotient
@@ -1091,6 +1133,41 @@
         [(or (fixnum? x) (bignum? x)) 1]
         [else (error 'denominator "~s is not an exact integer" x)])))
 
+
+  (define (floor x)
+    (define (ratnum-floor x)
+      (let ([n (numerator x)] [d (denominator x)])
+        (let ([q (quotient n d)])
+          (if (>= n 0) q (- q 1)))))
+    (cond
+      [(flonum? x) 
+       (let ([e (or ($flonum->exact x)
+                    (error 'floor "~s has no real value" x))])
+         (cond
+           [(ratnum? e) (ratnum-floor e)] 
+           [else e]))]
+      [(ratnum? x) (ratnum-floor x)]
+      [(or (fixnum? x) (bignum? x)) x]
+      [else (error 'floor "~s is not a number" x)]))
+  
+  (define (ceiling x)
+    (define (ratnum-ceiling x)
+      (let ([n (numerator x)] [d (denominator x)])
+        (let ([q (quotient n d)])
+          (if (< n 0) q (+ q 1)))))
+    (cond
+      [(flonum? x) 
+       (let ([e (or ($flonum->exact x)
+                    (error 'ceiling "~s has no real value" x))])
+         (cond
+           [(ratnum? e) (ratnum-ceiling e)] 
+           [else e]))]
+      [(ratnum? x) (ratnum-ceiling x)]
+      [(or (fixnum? x) (bignum? x)) x]
+      [else (error 'ceiling "~s is not a number" x)]))
+
+
+
   (define string->number
     (lambda (x)
       (define (convert-data str len pos? idx ac)

src/ikarus.transcoders.ss

@@ -104,7 +104,8 @@
                            [(eq? mode 'replace) 
                             (f x i j ($fxadd1 n) mode)]
                            [else
-                            (error who "invalid byte sequence ~s ~s" b0 b1)]))]
+                            (error who "invalid byte sequence ~s ~s
+                                   in idx ~s of ~s" b0 b1 i bv)]))]
                       [(eq? mode 'ignore) n]
                       [(eq? mode 'replace) ($fxadd1 n)]
                       [else

src/makefile.ss

@@ -395,6 +395,8 @@
     [max                     i r]
     [numerator               i r]
     [denominator             i r]
+    [floor                   i r]
+    [ceiling                 i r]
     [exact-integer-sqrt      i r]
     [exact->inexact          i r]
     [symbol?                 i r symbols]

src/pass-specify-rep-primops.ss

@@ -1166,36 +1166,6 @@
   [(P s i) (K #t)]
   [(E s i) (nop)])
 
-#;
-(define (assert-fixnum x)
-  (record-case x
-    [(constant i) 
-     (if (fixnum? i) (nop) (interrupt))]
-    [else (interrupt-unless (cogen-pred-fixnum? x))]))
-#;
-(define (assert-string x)
-  (record-case x
-    [(constant s) (if (string? s) (nop) (interrupt))]
-    [else (interrupt-unless (cogen-pred-string? x))]))
-#;
-(define-primop string-ref safe
-  [(V s i)
-   (seq*
-     (assert-fixnum i)
-     (assert-string s)
-     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
-     (cogen-value-$string-ref s i))]
-  [(P s i)
-   (seq*
-     (assert-fixnum i)
-     (assert-string s)
-     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
-     (K #t))]
-  [(E s i)
-   (seq*
-     (assert-fixnum i)
-     (assert-string s)
-     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
 
 (define-primop $bytevector-set! unsafe
   [(E x i c)