~ chicken-core (chicken-5) cabb7897b5111c4b91a77e09dafcd315d57fa651
commit cabb7897b5111c4b91a77e09dafcd315d57fa651
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 3 18:25:56 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 3 18:25:56 2009 +0100
heavy cleanup in fp-primitives; added more fp-specific operators; removed various library routines
diff --git a/c-platform.scm b/c-platform.scm
index 6823a363..d415a2d8 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -129,6 +129,7 @@
'(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod o
fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
+ fpfloor fpceiling fptruncate fpround
arithmetic-shift void flush-output thread-specific thread-specific-set!
not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
@@ -766,10 +767,6 @@
(rewrite 'string->number 13 "C_string_to_number" #t)
(rewrite 'number->string 13 "C_number_to_string" #t)
(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
-(rewrite '##sys#floor 13 "C_flonum_floor" #t)
-(rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t)
-(rewrite '##sys#truncate 13 "C_flonum_truncate" #t)
-(rewrite '##sys#round 13 "C_flonum_round" #t)
(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t)
(rewrite 'return-to-host 13 "C_return_to_host" #t)
@@ -786,10 +783,10 @@
(rewrite 'odd? 2 1 "C_i_oddp" #t #f)
(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f)
-(rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f)
-(rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f)
-(rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f)
-(rewrite 'round 15 'flonum 'fixnum '##sys#round #f)
+(rewrite 'floor 15 'flonum 'fixnum 'fpfloor #f)
+(rewrite 'ceiling 15 'flonum 'fixnum 'fpceiling #f)
+(rewrite 'truncate 15 'flonum 'fixnum 'fptruncate #f)
+(rewrite 'round 15 'flonum 'fixnum 'fpround #f)
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
@@ -894,6 +891,9 @@
(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f)
(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f)
+(rewrite 'f32vector-ref 16 2 "C_a_i_f32vector_ref" #f words-per-flonum)
+(rewrite 'f64vector-ref 16 2 "C_a_i_f64vector_ref" #f words-per-flonum)
+
(rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref")
(rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref")
diff --git a/chicken.h b/chicken.h
index 9f09e980..5235909f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1250,6 +1250,29 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_main_entry_point
#endif
+#define C_alloc_flonum C_word *___tmpflonum = C_alloc(WORDS_PER_FLONUM)
+#define C_kontinue_flonum(k, n) C_kontinue((k), C_flonum(&___tmpflonum, (n)))
+
+#define C_a_i_flonum_truncate(ptr, n, x) C_flonum(ptr, trunc(C_flonum_magnitude(x)))
+#define C_a_i_flonum_ceiling(ptr, n, x) C_flonum(ptr, trunc(C_flonum_magnitude(x)))
+#define C_a_i_flonum_floor(ptr, n, x) C_flonum(ptr, trunc(C_flonum_magnitude(x)))
+#define C_a_i_flonum_round(ptr, n, x) C_flonum(ptr, round(C_flonum_magnitude(x)))
+
+#define C_a_i_f32vector_ref(ptr, n, b, i) C_flonum(ptr, ((float *)C_data_pointer(b))[ C_unfix(i) ])
+#define C_a_i_f64vector_ref(ptr, n, b, i) C_flonum(ptr, ((double *)C_data_pointer(b))[ C_unfix(i) ])
+
+#define C_a_i_flonum_sin(ptr, c, x) C_flonum(ptr, C_sin(C_flonum_magnitude(x)))
+#define C_a_i_flonum_cos(ptr, c, x) C_flonum(ptr, C_cos(C_flonum_magnitude(x)))
+#define C_a_i_flonum_tan(ptr, c, x) C_flonum(ptr, C_tan(C_flonum_magnitude(x)))
+#define C_a_i_flonum_asin(ptr, c, x) C_flonum(ptr, C_asin(C_flonum_magnitude(x)))
+#define C_a_i_flonum_acos(ptr, c, x) C_flonum(ptr, C_acos(C_flonum_magnitude(x)))
+#define C_a_i_flonum_atan(ptr, c, x) C_flonum(ptr, C_atan(C_flonum_magnitude(x)))
+#define C_a_i_flonum_atan2(ptr, c, x, y) C_flonum(ptr, C_atan2(C_flonum_magnitude(x), C_flonum_magnitude(y)))
+#define C_a_i_flonum_exp(ptr, c, x) C_flonum(ptr, C_exp(C_flonum_magnitude(x)))
+#define C_a_i_flonum_expt(ptr, c, x, y) C_flonum(ptr, C_pow(C_flonum_magnitude(x), C_flonum_magnitude(y)))
+#define C_a_i_flonum_log(ptr, c, x) C_flonum(ptr, C_log(C_flonum_magnitude(x)))
+#define C_a_i_flonum_sqrt(ptr, c, x) C_flonum(ptr, C_sqrt(C_flonum_magnitude(x)))
+
/* Variables: */
@@ -1264,7 +1287,6 @@ C_varextern C_TLS long
C_varextern C_TLS C_byte
*C_fromspace_top,
*C_fromspace_limit;
-C_varextern C_TLS double C_temporary_flonum;
C_varextern C_TLS jmp_buf C_restart;
C_varextern C_TLS void *C_restart_address;
C_varextern C_TLS int C_entry_point_status;
@@ -1477,10 +1499,6 @@ C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_wo
C_fctexport void C_ccall C_cons_flonum(C_word c, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_noret;
C_fctexport void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_flonum_floor(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_flonum_ceiling(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_flonum_truncate(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_flonum_round(C_word c, C_word closure, C_word k, C_word n) C_noret;
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
C_fctexport void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...) C_noret;
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
@@ -1646,6 +1664,7 @@ C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm
C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
diff --git a/data-structures.scm b/data-structures.scm
index 23db1a00..eab96f5b 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -45,8 +45,8 @@ EOF
##sys#substring ##sys#for-each ##sys#map ##sys#setslot
##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
- ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
- ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#check-symbol ##sys#check-vector
+ ##sys#check-number
##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
##sys#print ##sys#check-structure ##sys#make-structure make-parameter
##sys#flush-output ##sys#write-char-0 ##sys#number->string
diff --git a/eval.scm b/eval.scm
index f2dd9034..7f539917 100644
--- a/eval.scm
+++ b/eval.scm
@@ -67,8 +67,8 @@
##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
##sys#load-library-0
##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
- ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
- ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
+ ##sys#check-symbol ##sys#check-vector
+ ##sys#check-number ##sys#copy-env-table
##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure
##sys#make-structure ##sys#feature?
##sys#error-handler ##sys#hash-symbol ##sys#check-syntax
diff --git a/extras.scm b/extras.scm
index a4075db0..d7ee5e8b 100644
--- a/extras.scm
+++ b/extras.scm
@@ -42,8 +42,7 @@
##sys#substring ##sys#for-each ##sys#map ##sys#setslot
##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
- ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
- ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#check-symbol ##sys#check-vector##sys#check-number
##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
##sys#print ##sys#check-structure ##sys#make-structure make-parameter
##sys#flush-output ##sys#write-char-0 ##sys#number->string
diff --git a/library.scm b/library.scm
index 3da58977..b725c2ae 100644
--- a/library.scm
+++ b/library.scm
@@ -62,7 +62,7 @@
#endif
#define C_close_file(p) (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
-#define C_f64peek(b, i) (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
+#define C_a_f64peek(ptr, c, b, i) C_flonum(ptr, ((double *)C_data_pointer(b))[ C_unfix(i) ])
#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)
#define C_free_mptr(p, i) (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)
@@ -70,7 +70,7 @@
#define C_direct_continuation(dummy) t1
-#define C_get_current_seconds(dummy) (C_temporary_flonum = time(NULL), C_SCHEME_UNDEFINED)
+#define C_a_get_current_seconds(ptr, c, dummy) C_flonum(ptr, time(NULL))
#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))
static C_word fast_read_line_from_file(C_word str, C_word port, C_word size) {
@@ -135,8 +135,8 @@ EOF
##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-port* ##sys#check-string ##sys#substring ##sys#check-port-mode
##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair
##sys#error-not-a-proper-list ##sys#error ##sys#warn ##sys#signal-hook
- ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
- ##sys#check-number ##sys#cons-flonum ##sys#check-integer ##sys#check-special
+ ##sys#check-symbol ##sys#check-vector
+ ##sys#check-number ##sys#check-integer ##sys#check-special
##sys#flonum-fraction ##sys#make-port ##sys#print
##sys#check-structure ##sys#make-structure ##sys#procedure->string
##sys#gcd ##sys#lcm ##sys#ensure-heap-reserve ##sys#check-list
@@ -264,8 +264,7 @@ EOF
(##sys#setslot x i y) )
(define (current-seconds)
- (##core#inline "C_get_current_seconds" #f)
- (##sys#cons-flonum) )
+ (##core#inline_allocate ("C_a_get_current_seconds" 4) #f))
(define (##sys#check-structure x y . loc)
(if (pair? loc)
@@ -888,6 +887,81 @@ EOF
(fp-check-flonums x y 'fpmin)
(##core#inline "C_i_flonum_min" x y) ] ) )
+(define (fpfloor x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpfloor)
+ (##core#inline_allocate ("C_a_i_flonum_floor" 4) x))
+
+(define (fptruncate x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fptruncate)
+ (##core#inline_allocate ("C_a_i_flonum_truncate" 4) x))
+
+(define (fpround x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpround)
+ (##core#inline_allocate ("C_a_i_flonum_round" 4) x))
+
+(define (fpceiling x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpceiling)
+ (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) x))
+
+(define (fpsin x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpsin)
+ (##core#inline_allocate ("C_a_i_flonum_sin" 4) x))
+
+(define (fpcos x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpcos)
+ (##core#inline_allocate ("C_a_i_flonum_cos" 4) x))
+
+(define (fptan x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fptan)
+ (##core#inline_allocate ("C_a_i_flonum_tan" 4) x))
+
+(define (fpasin x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpasin)
+ (##core#inline_allocate ("C_a_i_flonum_asin" 4) x))
+
+(define (fpacos x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpacos)
+ (##core#inline_allocate ("C_a_i_flonum_acos" 4) x))
+
+(define (fpatan x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpatan)
+ (##core#inline_allocate ("C_a_i_flonum_atan" 4) x))
+
+(define (fpatan2 x y)
+ #+(not unsafe)
+ (fp-check-flonums x y 'fpatan2)
+ (##core#inline_allocate ("C_a_i_flonum_atan2" 4) x y))
+
+(define (fpexp x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpexp)
+ (##core#inline_allocate ("C_a_i_flonum_exp" 4) x))
+
+(define (fpexpt x y)
+ #+(not unsafe)
+ (fp-check-flonums x y 'fpexpt)
+ (##core#inline_allocate ("C_a_i_flonum_expt" 4) x y))
+
+(define (fplog x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fplog)
+ (##core#inline_allocate ("C_a_i_flonum_log" 4) x))
+
+(define (fpsqrt x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpsqrt)
+ (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) x))
+
(define * (##core#primitive "C_times"))
(define - (##core#primitive "C_minus"))
(define + (##core#primitive "C_plus"))
@@ -901,12 +975,7 @@ EOF
(define add1 (lambda (n) (+ n 1)))
(define sub1 (lambda (n) (- n 1)))
-(define ##sys#floor (##core#primitive "C_flonum_floor"))
-(define ##sys#ceiling (##core#primitive "C_flonum_ceiling"))
-(define ##sys#truncate (##core#primitive "C_flonum_truncate"))
-(define ##sys#round (##core#primitive "C_flonum_round"))
(define quotient (##core#primitive "C_quotient"))
-(define ##sys#cons-flonum (##core#primitive "C_cons_flonum"))
(define (##sys#number? x) (##core#inline "C_i_numberp" x))
(define number? ##sys#number?)
(define complex? number?)
@@ -969,25 +1038,25 @@ EOF
(##sys#check-number x 'floor)
(if (##core#inline "C_fixnump" x)
x
- (##sys#floor x) ) )
+ (fpfloor x) ) )
(define (ceiling x)
(##sys#check-number x 'ceiling)
(if (##core#inline "C_fixnump" x)
x
- (##sys#ceiling x) ) )
+ (fpceiling x) ) )
(define (truncate x)
(##sys#check-number x 'truncate)
(if (##core#inline "C_fixnump" x)
x
- (##sys#truncate x) ) )
+ (fptruncate x) ) )
(define (round x)
(##sys#check-number x 'round)
(if (##core#inline "C_fixnump" x)
x
- (##sys#round x) ) )
+ (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x)))
(define remainder
(lambda (x y) (- x (* (quotient x y) y))) )
@@ -3806,8 +3875,7 @@ EOF
(define (##sys#vector->structure! vec) (##core#inline "C_vector_to_structure" vec))
(define (##sys#peek-double b i)
- (##core#inline "C_f64peek" b i)
- (##sys#cons-flonum) )
+ (##core#inline_allocate ("C_a_f64peek" 4) b i))
(define (##sys#peek-c-string b i)
(and (not (##sys#null-pointer? b))
diff --git a/manual/Unit library b/manual/Unit library
index bf1638eb..d652b406 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -106,6 +106,23 @@ in unsafe mode can crash the system.
<procedure>(fp< X Y)</procedure>
<procedure>(fp>= X Y)</procedure>
<procedure>(fp<= X Y)</procedure>
+<procedure>(fpfloor X)</procedure>
+<procedure>(fpceiling X)</procedure>
+<procedure>(fptruncate X)</procedure>
+<procedure>(fpround X)</procedure>
+<procedure>(fpsin X)</procedure>
+<procedure>(fpcos X)</procedure>
+<procedure>(fptan X)</procedure>
+<procedure>(fpasin X)</procedure>
+<procedure>(fpacos X)</procedure>
+<procedure>(fpatan X)</procedure>
+<procedure>(fpatan2 X Y)</procedure>
+<procedure>(fplog X)</procedure>
+<procedure>(fpexp X)</procedure>
+<procedure>(fpexpt X Y)</procedure>
+<procedure>(fpsqrt X)</procedure>
+
+Note: {{fpround}} implements POSIX, which is different from R5RS.
==== flonum?
diff --git a/manual/faq b/manual/faq
index 9563fb7d..a8b05ace 100644
--- a/manual/faq
+++ b/manual/faq
@@ -435,6 +435,7 @@ The following extended bindings are handled specially:
{{flonum?}} {{fp+}}
{{fp-}} {{fp*}} {{fp/}} {{atom?}}
{{fp=}} {{fp>}} {{fp>=}} {{fpneg}} {{fpmax}} {{fpmin}}
+{{fpfloor}} {{fpceiling}} {{fpround}} {{fptruncate}}
{{arithmetic-shift}} {{signum}} {{flush-output}} {{thread-specific}} {{thread-specific-set!}}
{{not-pair?}} {{null-list?}} {{print}} {{print*}} {{u8vector->blob/shared}}
{{s8vector->blob/shared}} {{u16vector->blob/shared}} {{s16vector->blob/shared}}
diff --git a/ports.scm b/ports.scm
index 60f05140..325e71d3 100644
--- a/ports.scm
+++ b/ports.scm
@@ -1,7 +1,7 @@
;;; ports.scm - Optional non-standard ports
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
@@ -51,8 +51,7 @@
##sys#substring ##sys#for-each ##sys#map ##sys#setslot
##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
- ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
- ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#check-symbol ##sys#check-vector ##sys#check-number
##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
##sys#print ##sys#check-structure ##sys#make-structure make-parameter
##sys#flush-output ##sys#write-char-0 ##sys#number->string
diff --git a/posixunix.scm b/posixunix.scm
index 04f3e594..4cc6fcf9 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -432,8 +432,8 @@ C_tm_get( C_word v )
#endif
#define C_asctime(v) (asctime(C_tm_set(v)))
-#define C_mktime(v) ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
-#define C_timegm(v) ((C_temporary_flonum = timegm(C_tm_set(v))) != -1)
+#define C_a_mktime(ptr, c, v) C_flonum(ptr, mktime(C_tm_set(v)))
+#define C_a_timegm(v) C_flonum(ptr, timegm(C_tm_set(v)))
#define TIME_STRING_MAXLENGTH 255
static char C_time_string [TIME_STRING_MAXLENGTH + 1];
@@ -491,7 +491,7 @@ EOF
pathname-file process-fork file-close duplicate-fileno process-execute get-environment-variable
make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
process-wait pathname-strip-directory pathname-directory ##sys#expand-home-path directory
- decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
+ decompose-pathname ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
current-directory ##sys#make-pointer port? ##sys#schedule ##sys#process
##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts
@@ -1994,15 +1994,17 @@ EOF
(define (local-time->seconds tm)
(check-time-vector 'local-time->seconds tm)
- (if (##core#inline "C_mktime" tm)
- (##sys#cons-flonum)
- (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
+ (let ((t (##core#inline_allocate ("C_a_mktime" 4) tm)))
+ (if (fp= -1.0 t)
+ (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)
+ t)))
(define (utc-time->seconds tm)
(check-time-vector 'utc-time->seconds tm)
- (if (##core#inline "C_timegm" tm)
- (##sys#cons-flonum)
- (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm) ) )
+ (let ((t (##core#inline_allocate ("C_a_timegm" 4) tm)))
+ (if (fp= -1.0 t)
+ (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)
+ t)))
(define local-timezone-abbreviation
(foreign-lambda* c-string ()
diff --git a/posixwin.scm b/posixwin.scm
index a551535b..5c091f34 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -342,7 +342,7 @@ C_free_arg_string(char **where) {
#define C_tm_set(v) (C_tm_set_08(v), &C_tm)
#define C_asctime(v) (asctime(C_tm_set(v)))
-#define C_mktime(v) ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
+#define C_a_mktime(ptr, c, v) C_flonum(ptr, mktime(C_tm_set(v)))
#define TIME_STRING_MAXLENGTH 255
static char C_time_string [TIME_STRING_MAXLENGTH + 1];
@@ -1728,9 +1728,10 @@ EOF
(define (local-time->seconds tm)
(check-time-vector 'local-time->seconds tm)
- (if (##core#inline "C_mktime" tm)
- (##sys#cons-flonum)
- (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
+ (let ((t (##core#inline_allocate ("C_mktime" 4) tm)))
+ (if (fp= t -1.0)
+ (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)
+ t)))
(define local-timezone-abbreviation
(foreign-lambda* c-string ()
diff --git a/runtime.c b/runtime.c
index 6cf97663..4235b844 100644
--- a/runtime.c
+++ b/runtime.c
@@ -25,6 +25,7 @@
; POSSIBILITY OF SUCH DAMAGE.
*/
+
#include "chicken.h"
#include <errno.h>
#include <signal.h>
@@ -328,7 +329,6 @@ C_TLS long
C_TLS C_byte
*C_fromspace_top,
*C_fromspace_limit;
-C_TLS double C_temporary_flonum;
C_TLS jmp_buf C_restart;
C_TLS void *C_restart_address;
C_TLS int C_entry_point_status;
@@ -493,7 +493,6 @@ static LF_LIST *find_module_handle(C_char *name);
static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
-static void cons_flonum_trampoline(void *dummy) C_noret;
static void gc_2(void *dummy) C_noret;
static void allocate_vector_2(void *dummy) C_noret;
static void get_argv_2(void *dummy) C_noret;
@@ -713,7 +712,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
static C_PTABLE_ENTRY *create_initial_ptable()
{
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 66);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 61); /* take note of this, it's subtle */
int i = 0;
if(pt == NULL)
@@ -750,12 +749,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_lessp);
C_pte(C_greater_or_equal_p);
C_pte(C_less_or_equal_p);
- C_pte(C_flonum_floor);
- C_pte(C_flonum_ceiling);
- C_pte(C_flonum_truncate);
- C_pte(C_flonum_round);
C_pte(C_quotient);
- C_pte(C_cons_flonum);
C_pte(C_flonum_fraction);
C_pte(C_expt);
C_pte(C_exact_to_inexact);
@@ -6442,6 +6436,7 @@ void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
C_word iresult = 1;
int fflag = 0;
double fresult = 1;
+ C_alloc_flonum;
va_start(v, k);
c -= 2;
@@ -6466,8 +6461,7 @@ void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
x = C_fix(iresult);
if(fflag || (double)C_unfix(x) != fresult) {
- C_temporary_flonum = fresult;
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, fresult);
}
C_kontinue(k, x);
@@ -6516,6 +6510,7 @@ void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
C_word iresult = 0;
int fflag = 0;
double fresult = 0;
+ C_alloc_flonum;
va_start(v, k);
c -= 2;
@@ -6540,8 +6535,7 @@ void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
x = C_fix(iresult);
if(fflag || (double)C_unfix(x) != fresult) {
- C_temporary_flonum = fresult;
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, fresult);
}
C_kontinue(k, x);
@@ -6583,21 +6577,13 @@ C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
}
-void cons_flonum_trampoline(void *dummy)
-{
- C_word k = C_restore,
- *a = C_alloc(WORDS_PER_FLONUM);
-
- C_kontinue(k, C_flonum(&a, C_temporary_flonum));
-}
-
-
void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
{
va_list v;
C_word iresult;
int fflag;
double fresult;
+ C_alloc_flonum;
if(c < 3) C_bad_min_argc(c, 3);
@@ -6643,8 +6629,7 @@ void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
n1 = C_fix(iresult);
if(fflag || (double)C_unfix(n1) != fresult) {
- C_temporary_flonum = fresult;
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, fresult);
}
C_kontinue(k, n1);
@@ -6693,6 +6678,7 @@ void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
C_word iresult;
int fflag;
double fresult, f2;
+ C_alloc_flonum;
if(c < 3) C_bad_min_argc(c, 3);
@@ -6766,8 +6752,7 @@ void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
cont:
if(fflag) {
- C_temporary_flonum = fresult;
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, fresult);
}
else n1 = C_fix(iresult);
@@ -7228,6 +7213,7 @@ void C_ccall C_expt(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
{
double m1, m2;
C_word r;
+ C_alloc_flonum;
if(c != 4) C_bad_argc(c, 4);
@@ -7247,8 +7233,7 @@ void C_ccall C_expt(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
if(r == m1 && (n1 & C_FIXNUM_BIT) && (n2 & C_FIXNUM_BIT) && modf(m1, &m2) == 0.0 && C_fitsinfixnump(r))
C_kontinue(k, C_fix(r));
- C_temporary_flonum = m1;
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, m1);
}
@@ -7440,19 +7425,20 @@ void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word strin
void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n)
{
double i, fn = C_flonum_magnitude(n);
+ C_alloc_flonum;
- C_temporary_flonum = modf(fn, &i);
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, modf(fn, &i));
}
void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n)
{
+ C_alloc_flonum;
+
if(c != 3) C_bad_argc(c, 3);
if(n & C_FIXNUM_BIT) {
- C_temporary_flonum = (double)C_unfix(n);
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ C_kontinue_flonum(k, (double)C_unfix(n));
}
else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact->inexact", n);
@@ -7461,57 +7447,38 @@ void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n)
}
-void C_ccall C_flonum_floor(C_word c, C_word closure, C_word k, C_word n)
-{
- C_temporary_flonum = floor(C_flonum_magnitude(n));
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
-}
-
-
-void C_ccall C_flonum_ceiling(C_word c, C_word closure, C_word k, C_word n)
-{
- C_temporary_flonum = ceil(C_flonum_magnitude(n));
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
-}
-
-
-void C_ccall C_flonum_truncate(C_word c, C_word closure, C_word k, C_word n)
+/* this is different from C_a_i_flonum_round, for R5RS compatibility */
+C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
{
- modf(C_flonum_magnitude(n), &C_temporary_flonum);
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
-}
-
-
-void C_ccall C_flonum_round(C_word c, C_word closure, C_word k, C_word n)
-{
- double fn, i, f, i2;
+ double fn, i, f, i2, r;
fn = C_flonum_magnitude(n);
if(fn < 0.0) {
f = modf(-fn, &i);
if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
- C_temporary_flonum = -i;
+ r = -i;
else
- C_temporary_flonum = -(i + 1.0);
+ r = -(i + 1.0);
}
else if(fn == 0.0/* || fn == -0.0*/)
- C_temporary_flonum = fn;
+ r = fn;
else {
f = modf(fn, &i);
if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
- C_temporary_flonum = i;
+ r = i;
else
- C_temporary_flonum = i + 1.0;
+ r = i + 1.0;
}
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ return C_flonum(ptr, r);
}
void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
{
- double f1, f2;
+ double f1, f2, r;
C_word result;
+ C_alloc_flonum;
if(c != 4) C_bad_argc(c, 4);
@@ -7543,16 +7510,8 @@ void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2
if(f2 == 0)
barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
- modf(f1 / f2, &C_temporary_flonum);
- C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
-}
-
-
-void C_ccall C_cons_flonum(C_word c, C_word closure, C_word k)
-{
- C_word *a = C_alloc(WORDS_PER_FLONUM);
-
- C_kontinue(k, C_flonum(&a, C_temporary_flonum));
+ modf(f1 / f2, &r);
+ C_kontinue_flonum(k, r);
}
@@ -8178,11 +8137,10 @@ void C_ccall C_context_switch(C_word c, C_word closure, C_word k, C_word state)
void C_ccall C_peek_signed_integer(C_word c, C_word closure, C_word k, C_word v, C_word index)
{
C_word x = C_block_item(v, C_unfix(index));
+ C_alloc_flonum;
if((x & C_INT_SIGN_BIT) != ((x << 1) & C_INT_SIGN_BIT)) {
- C_save(k);
- C_temporary_flonum = (double)x;
- cons_flonum_trampoline(NULL);
+ C_kontinue_flonum(k, (double)x);
}
C_kontinue(k, C_fix(x));
@@ -8194,9 +8152,7 @@ void C_ccall C_peek_unsigned_integer(C_word c, C_word closure, C_word k, C_word
C_word x = C_block_item(v, C_unfix(index));
if((x & C_INT_SIGN_BIT) || ((x << 1) & C_INT_SIGN_BIT)) {
- C_save(k);
- C_temporary_flonum = (double)(C_uword)x;
- cons_flonum_trampoline(NULL);
+ C_kontinue_flonum(k, (double)(C_uword)x);
}
C_kontinue(k, C_fix(x));
@@ -8766,6 +8722,7 @@ C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_w
void C_ccall C_locative_ref(C_word c, C_word closure, C_word k, C_word loc)
{
C_word *ptr, val;
+ C_alloc_flonum;
if(c != 3) C_bad_argc(c, 3);
@@ -8785,8 +8742,8 @@ void C_ccall C_locative_ref(C_word c, C_word closure, C_word k, C_word loc)
case C_S16_LOCATIVE: C_kontinue(k, C_fix(*((short *)ptr)));
case C_U32_LOCATIVE: C_peek_unsigned_integer(0, 0, k, (C_word)(ptr - 1), 0);
case C_S32_LOCATIVE: C_peek_signed_integer(0, 0, k, (C_word)(ptr - 1), 0);
- case C_F32_LOCATIVE: C_temporary_flonum = *((float *)ptr); C_cons_flonum(0, 0, k);
- case C_F64_LOCATIVE: C_temporary_flonum = *((double *)ptr); C_cons_flonum(0, 0, k);
+ case C_F32_LOCATIVE: C_kontinue_flonum(k, *((float *)ptr));
+ case C_F64_LOCATIVE: C_kontinue_flonum(k, *((double *)ptr));
default: panic(C_text("bad locative type"));
}
}
diff --git a/srfi-4.scm b/srfi-4.scm
index f6bdc0db..33d1c0d4 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -47,8 +47,6 @@
# define C_a_u32peek(ptr, d, b, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
# define C_a_s32peek(ptr, d, b, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
#endif
-#define C_f32peek(b, i) (C_temporary_flonum = ((float *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
-#define C_f64peek(b, i) (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
#define C_u8poke(b, i, x) ((((unsigned char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_s8poke(b, i, x) ((((char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_u16poke(b, i, x) ((((unsigned short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
@@ -76,7 +74,7 @@ EOF
##sys#s32vector-set! read list->f64vector list->s32vector list->u32vector list->u16vector list-s8vector
list->u8vector set-finalizer!
##sys#f32vector-ref ##sys#f32vector-set! ##sys#f64vector-ref ##sys#f64vector-set! ##sys#check-exact-interval
- ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#cons-flonum ##sys#check-list
+ ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#check-list
##sys#check-range ##sys#error ##sys#signal-hook
##sys#error-not-a-proper-list ##sys#print ##sys#allocate-vector) ) ] )
@@ -109,12 +107,10 @@ EOF
(define (##sys#s32vector-ref v i) (##core#inline_allocate ("C_a_s32peek" 4) (##core#inline "C_slot" v 1) i))
(define (##sys#f32vector-ref v i)
- (##core#inline "C_f32peek" (##core#inline "C_slot" v 1) i)
- (##sys#cons-flonum) )
+ (##core#inline_allocate ("C_a_i_f32vector_ref" 4) v i))
(define (##sys#f64vector-ref v i)
- (##core#inline "C_f64peek" (##core#inline "C_slot" v 1) i)
- (##sys#cons-flonum) )
+ (##core#inline_allocate ("C_a_i_f64vector_ref" 4) v i))
(define (##sys#u8vector-set! v i x) (##core#inline "C_u8poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#s8vector-set! v i x) (##core#inline "C_s8poke" (##core#inline "C_slot" v 1) i x))
diff --git a/types.db b/types.db
index 8ff5d57f..cc6edc79 100644
--- a/types.db
+++ b/types.db
@@ -1,6 +1,6 @@
;;;; types.db - Type-information for core library functions -*- Scheme -*-
;
-; Copyright (c 2009, The Chicken Team
+; Copyright (c)2009, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -298,9 +298,24 @@
(fp= (procedure fp= (float float) boolean))
(fp> (procedure fp> (float float) boolean))
(fp>= (procedure fp>= (float float) boolean))
+(fpacos (procedure fpacos (float) float))
+(fpasin (procedure fpasin (float) float))
+(fpatan (procedure fpatan (float) float))
+(fpatan2 (procedure fpatan2 (float float) float))
+(fpceiling (procedure fpceiling (float) float))
+(fpcos (procedure fpcos (float) float))
+(fpexp (procedure fpexp (float) float))
+(fpexpt (procedure fpexpt (float float) float))
+(fpfloot (procedure fpfloor (float) float))
+(fplog (procedure fplog (float) float))
(fpmax (procedure fpmax (float float) float))
(fpmin (procedure fpmin (float float) float))
(fpneg (procedure fpneg (float) float))
+(fpround (procedure fpround (float) float))
+(fpsin (procedure fpsin (float) float))
+(fpsqrt (procedure fpsqrt (float) float))
+(fptan (procedure fptan (float) float))
+(fptruncate (procedure fptruncate (float) float))
(fx- (procedure fx- (fixnum fixnum) fixnum))
(fx* (procedure fx* (fixnum fixnum) fixnum))
(fx/ (procedure fx/ (fixnum fixnum) fixnum))
Trap