~ chicken-core (chicken-5) 02e278cd174810aa28bfc027588d0117ba9295e1

commit 02e278cd174810aa28bfc027588d0117ba9295e1
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jun 15 14:22:38 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jun 15 14:22:38 2010 +0200

    srfi-4 tweaks, C_a_i_... macro for faster unsafe exact->inexact

diff --git a/chicken.h b/chicken.h
index 2ca22927..0d1f4a66 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1190,6 +1190,7 @@ extern double trunc(double);
 
 #define C_a_i_flonum(ptr, i, n)         C_flonum(ptr, n)
 #define C_a_i_data_mpointer(ptr, n, x)  C_mpointer(ptr, C_data_pointer(x))
+#define C_a_i_fix_to_flo(p, n, f)       C_flonum(p, C_unfix(f))
 #define C_a_i_mpointer(ptr, n, x)       C_mpointer(ptr, (x))
 #define C_a_u_i_pointer_inc(ptr, n, p, i) C_mpointer(ptr, (C_char *)(p) + C_unfix(i))
 #define C_pointer_eqp(x, y)             C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
diff --git a/library.scm b/library.scm
index 1a8514ab..fed10809 100644
--- a/library.scm
+++ b/library.scm
@@ -966,7 +966,7 @@ EOF
 (define max)
 (define min)
 
-(let ([> >]
+(let ([> >]				;XXX could use faster versions
       [< <] )
   (letrec ([maxmin
 	    (lambda (n1 ns pred)
@@ -978,7 +978,7 @@ EOF
 				(if (and (##core#inline "C_blockp" nbest) 
 					 (##core#inline "C_flonump" nbest) 
 					 (not (##core#inline "C_blockp" ni)) )
-				    (exact->inexact ni)
+				    (##core#inline_allocate ("C_a_i_fix_to_flo" 4) ni)
 				    ni)
 				nbest)
 			    (##sys#slot ns 1) ) ) ) ) ) ] )
@@ -4541,9 +4541,10 @@ EOF
 (define setter ##sys#setter)
 
 (define (getter-with-setter get set #!optional info)
-  (let ((getdec (if info
-		    (##sys#make-lambda-info info)
-		    (##sys#lambda-info get)))
+  (let ((getdec (cond (info
+		       (##sys#check-string info 'getter-with-setter)
+		       (##sys#make-lambda-info info))
+		      (else (##sys#lambda-info get))))
 	(p1 (##sys#decorate-lambda
 	     get
 	     setter?
diff --git a/srfi-18.scm b/srfi-18.scm
index 2c247641..9fcd5497 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -91,7 +91,9 @@ EOF
 (define (seconds->time n)
   (##sys#check-number n 'seconds->time)
   (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
-	 [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
+	 [ms (truncate 
+	      (* 1000
+		 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
 	 [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
     (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )
 
diff --git a/srfi-4.scm b/srfi-4.scm
index c60c3983..0b09c162 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -50,7 +50,7 @@ EOF
 	    (##core#inline "C_fixnum_greaterp" n to) )
 	(##sys#error loc "numeric value is not in expected range" n from to) ) ) )
 
-(define-inline (check-range i from to)
+(define-inline (check-range i from to loc)
   (##sys#check-exact i loc)
   (unless (and (fx<= from i) (fx< i to))
     (##sys#error-hook
@@ -157,7 +157,7 @@ EOF
      x i 
      (if (##core#inline "C_blockp" y)
 	 y
-	 (##sys#exact->inexact y)))))	;XXX use faster unsafe variant
+	 (##core#inline_allocate ("C_a_i_fix_to_flo" 4) y)))))
 
 (define (f64vector-set! x i y)
   (##sys#check-structure x 'f64vector 'f64vector-set!)
@@ -169,7 +169,7 @@ EOF
      x i 
      (if (##core#inline "C_blockp" y)
 	 y
-	 (##sys#exact->inexact y)))))	;XXX as above
+	 (##core#inline_allocate ("C_a_i_fix_to_flo" 4) y)))))
 
 (define u8vector-ref
   (getter-with-setter
@@ -370,7 +370,7 @@ EOF
 	    (begin
 	      (##sys#check-number init 'make-f32vector)
 	      (unless (##core#inline "C_blockp" init)
-		(set! init (exact->inexact init)) )
+		(set! init (##core#inline_allocate ("C_a_i_fix_to_flo" 4) init)) )
 	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
 		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
 		(##sys#f32vector-set! v i init) ) ) ) ) ) )
@@ -387,7 +387,7 @@ EOF
 	    (begin
 	      (##sys#check-number init 'make-f64vector)
 	      (unless (##core#inline "C_blockp" init)
-		(set! init (exact->inexact init)) )
+		(set! init (##core#inline_allocate ("C_a_i_fix_to_flo" 4) init)) )
 	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
 		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
 		(##core#inline "C_u_i_f64vector_set" v i init) ) ) ) ) ) ) )