~ chicken-core (chicken-5) fcc7e346c63e24be91337df9a3ad30d0c5360144
commit fcc7e346c63e24be91337df9a3ad30d0c5360144
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 3 19:21:29 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 3 19:21:29 2009 +0100
fpmath fixes; added tests for fp-ops
diff --git a/chicken.h b/chicken.h
index 5235909f..338c6a8a 100644
--- a/chicken.h
+++ b/chicken.h
@@ -85,6 +85,7 @@
#include <setjmp.h>
#include <limits.h>
#include <time.h>
+#include <math.h>
#if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
# include <unistd.h>
@@ -862,6 +863,26 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_isspace isspace
# define C_islower islower
# define C_isupper isupper
+# define C_sin sin
+# define C_cos cos
+# define C_tan tan
+# define C_asin asin
+# define C_acos acos
+# define C_atan atan
+# define C_atan2 atan2
+# define C_log log
+# define C_exp exp
+# define C_pow pow
+# define C_sqrt sqrt
+# define C_ceil ceil
+# define C_floor floor
+# define C_round round
+# define C_trunc trunc
+# ifdef __GNUC__
+/* this is stupid */
+extern double round(double);
+extern double trunc(double);
+# endif
#else
# include "chicken-libc-stubs.h"
#endif
@@ -1023,7 +1044,6 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
C_port_file(p)), C_SCHEME_UNDEFINED)
#define C_fix_to_char(x) (C_make_character(C_unfix(x)))
#define C_char_to_fix(x) (C_fix(C_character_code(x)))
-#define C_math_result(x) (C_temporary_flonum = (x), C_SCHEME_UNDEFINED)
#define C_substring_copy(s1, s2, start1, end1, start2) \
(C_memcpy((C_char *)C_data_pointer(s2) + C_unfix(start2), \
(C_char *)C_data_pointer(s1) + C_unfix(start1), \
@@ -1253,10 +1273,10 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
#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_flonum_truncate(ptr, n, x) C_flonum(ptr, C_trunc(C_flonum_magnitude(x)))
+#define C_a_i_flonum_ceiling(ptr, n, x) C_flonum(ptr, C_ceil(C_flonum_magnitude(x)))
+#define C_a_i_flonum_floor(ptr, n, x) C_flonum(ptr, C_floor(C_flonum_magnitude(x)))
+#define C_a_i_flonum_round(ptr, n, x) C_flonum(ptr, C_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) ])
@@ -1496,7 +1516,6 @@ C_fctexport void C_ccall C_open_file_port(C_word c, C_word closure, C_word k, C_
C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C_word size, C_word type, C_word init, C_word align8) C_noret;
C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
-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_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
diff --git a/defaults.make b/defaults.make
index b439a184..720a5cd8 100644
--- a/defaults.make
+++ b/defaults.make
@@ -1,7 +1,7 @@
# defaults.make - default settings -*- Makefile -*-
#
-# Copyright (c) 2007, Felix L. Winkelmann
# Copyright (c) 2008-2009, The Chicken Team
+# Copyright (c) 2007, Felix L. Winkelmann
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -27,7 +27,7 @@
# basic parameters
-BINARYVERSION = 4
+BINARYVERSION = 5
STACKDIRECTION ?= 1
CROSS_CHICKEN ?= 0
diff --git a/posixunix.scm b/posixunix.scm
index 4cc6fcf9..c729e8b6 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -433,7 +433,7 @@ C_tm_get( C_word v )
#define C_asctime(v) (asctime(C_tm_set(v)))
#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 C_a_timegm(ptr, c, v) C_flonum(ptr, timegm(C_tm_set(v)))
#define TIME_STRING_MAXLENGTH 255
static char C_time_string [TIME_STRING_MAXLENGTH + 1];
diff --git a/runtime.c b/runtime.c
index 4235b844..8c8a5c6c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4031,7 +4031,7 @@ C_regparm C_word C_fcall C_char_ready_p(C_word port)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_flush_output(C_word port)
{
C_fflush(C_port_file(port));
@@ -4237,7 +4237,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
}
-/* I */
+/* M */
C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
{
if(--C_timer_interrupt_counter <= 0)
@@ -4262,7 +4262,7 @@ C_regparm void C_fcall C_raise_interrupt(int reason)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
{
C_initial_timer_interrupt_period = C_unfix(n);
@@ -4270,7 +4270,7 @@ C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_enable_interrupts(void)
{
C_timer_interrupt_counter = C_initial_timer_interrupt_period;
@@ -4280,7 +4280,7 @@ C_regparm C_word C_fcall C_enable_interrupts(void)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_disable_interrupts(void)
{
C_interrupts_enabled = 0;
@@ -4906,7 +4906,7 @@ C_regparm C_word C_fcall C_i_exactp(C_word x)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_u_i_exactp(C_word x)
{
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
@@ -4926,7 +4926,7 @@ C_regparm C_word C_fcall C_i_inexactp(C_word x)
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
{
if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
@@ -5387,34 +5387,35 @@ C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
}
+/* M */
C_regparm C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2)
{
return C_flonum(a, C_flonum_magnitude(n1) + C_flonum_magnitude(n2));
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2)
{
return C_flonum(a, C_flonum_magnitude(n1) - C_flonum_magnitude(n2));
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2)
{
return C_flonum(a, C_flonum_magnitude(n1) * C_flonum_magnitude(n2));
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2)
{
return C_flonum(a, C_flonum_magnitude(n1) / C_flonum_magnitude(n2));
}
-/* I */
+/* M */
C_regparm C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n)
{
return C_flonum(a, -C_flonum_magnitude(n));
@@ -7448,7 +7449,7 @@ void C_ccall C_exact_to_inexact(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)
+C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
{
double fn, i, f, i2, r;
@@ -8150,6 +8151,7 @@ void C_ccall C_peek_signed_integer(C_word c, C_word closure, C_word k, C_word v,
void C_ccall C_peek_unsigned_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_kontinue_flonum(k, (double)(C_uword)x);
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 9055fe44..38d7e34f 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -1,3 +1,8 @@
+;;;; library-tests.scm
+
+
+;; numbers
+
(assert (= -4.0 (round -4.3)))
(assert (= 4.0 (round 3.5)))
(assert (= 4 (round (string->number "7/2"))))
@@ -12,3 +17,27 @@
(assert (rational? 1.0))
(assert (not (rational? +inf.)))
(assert (not (rational? 'foo)))
+
+
+;; fp-math
+
+(assert (= (sin 42.0) (fpsin 42.0)))
+(assert (= (cos 42.0) (fpcos 42.0)))
+(assert (= (tan 42.0) (fptan 42.0)))
+(assert (= (asin 0.5) (fpasin 0.5)))
+(assert (= (acos 0.5) (fpacos 0.5)))
+(assert (= (atan 0.5) (fpatan 0.5)))
+(assert (= (atan 42.0 1.2) (fpatan2 42.0 1.2)))
+(assert (= (exp 42.0) (fpexp 42.0)))
+(assert (= (log 42.0) (fplog 42.0)))
+(assert (= (expt 42.0 3.5) (fpexpt 42.0 3.5)))
+(assert (= (sqrt 42.0) (fpsqrt 42.0)))
+(assert (= 43.0 (fpround 42.5)))
+(assert (= -43.0 (fpround -42.5)))
+(assert (= 42.0 (fpround 42.2)))
+(assert (= 42.0 (fptruncate 42.5)))
+(assert (= -42.0 (fptruncate -42.5)))
+(assert (= 42.0 (fpfloor 42.2)))
+(assert (= -43.0 (fpfloor -42.5)))
+(assert (= 43.0 (fpceiling 42.5)))
+(assert (= -42.0 (fpceiling -42.2)))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 057b3dd8..236b6b98 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -208,7 +208,7 @@ $compile -e embedded2.scm
./a.out
echo "======================================== timing compilation ..."
-time $compile compiler.scm -t -S -O5 -debug pbo -vv
+time $compile compiler.scm -t -S -O5 -debug pb -vv
time ./a.out
echo "======================================== running floating-point benchmark ..."
Trap