~ chicken-core (chicken-5) 7df0ae11d7ea5e21f7e18832a57e53a0d844c1e9
commit 7df0ae11d7ea5e21f7e18832a57e53a0d844c1e9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jun 25 13:37:28 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jun 25 13:37:28 2011 +0200
allow unboxing fx/?; factored out div-by-zero generation and moved some fixnum and flonum operations into chicken.h
diff --git a/chicken.h b/chicken.h
index 2f5f0474..21d68ce3 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1555,6 +1555,7 @@ C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_stack_overflow(void) C_noret;
C_fctexport void C_unbound_error(C_word sym) C_noret;
C_fctexport void C_no_closure_error(C_word x) C_noret;
+C_fctexport void C_div_by_zero_error(char *loc) C_noret;
C_fctexport C_word C_closure(C_word **ptr, int cells, C_word proc, ...);
C_fctexport C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr) C_regparm;
C_fctexport C_word C_fcall C_h_pair(C_word car, C_word cdr) C_regparm;
@@ -1769,9 +1770,6 @@ C_fctexport C_word C_fcall C_i_not_pair_p_2(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_null_list_p(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_string_null_p(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm;
-C_fctexport C_word C_fcall C_fixnum_divide(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_fixnum_modulo(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm;
@@ -1799,7 +1797,6 @@ 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_a_i_flonum_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
@@ -2196,6 +2193,27 @@ C_inline C_word C_i_fixnum_max(C_word x, C_word y)
}
+C_inline C_word C_fixnum_divide(C_word x, C_word y)
+{
+ if(y == C_fix(0)) C_div_by_zero_error("fx/");
+ else return C_u_fixnum_divide(x, y);
+}
+
+
+C_inline C_word C_fixnum_modulo(C_word x, C_word y)
+{
+ if(y == C_fix(0)) C_div_by_zero_error("fxmod");
+ else return C_u_fixnum_modulo(x, y);
+}
+
+
+C_inline C_word C_i_fixnum_arithmetic_shift(C_word n, C_word c)
+{
+ if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
+ else return C_fixnum_shift_left(n, c);
+}
+
+
C_inline C_word C_i_flonum_min(C_word x, C_word y)
{
double
@@ -2216,6 +2234,24 @@ C_inline C_word C_i_flonum_max(C_word x, C_word y)
}
+C_inline C_word
+C_a_i_flonum_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2)
+{
+ double n3 = C_flonum_magnitude(n2);
+
+ if(n3 == 0.0) C_div_by_zero_error("fp/?");
+ else return C_flonum(ptr, C_flonum_magnitude(n1) / n3);
+}
+
+
+C_inline double
+C_ub_i_flonum_quotient_checked(double n1, double n2)
+{
+ if(n2 == 0.0) C_div_by_zero_error("fp/?");
+ else return n1 / n2;
+}
+
+
C_inline C_word C_i_safe_pointerp(C_word x)
{
if(C_immediatep(x)) return C_SCHEME_FALSE;
diff --git a/runtime.c b/runtime.c
index 9a45a44b..afc43a22 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2242,6 +2242,12 @@ void C_no_closure_error(C_word x)
}
+void C_div_by_zero_error(char *loc)
+{
+ barf(C_DIVISION_BY_ZERO_ERROR, loc);
+}
+
+
/* Allocate and initialize record: */
C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str)
@@ -5313,30 +5319,6 @@ C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
}
-/* I */
-C_regparm C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c)
-{
- if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
- else return C_fixnum_shift_left(n, c);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_fixnum_divide(C_word x, C_word y)
-{
- if(y == C_fix(0)) barf(C_DIVISION_BY_ZERO_ERROR, "fx/");
- else return C_u_fixnum_divide(x, y);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_fixnum_modulo(C_word x, C_word y)
-{
- if(y == C_fix(0)) barf(C_DIVISION_BY_ZERO_ERROR, "fxmod");
- else return C_u_fixnum_modulo(x, y);
-}
-
-
C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
{
C_word a;
@@ -9299,13 +9281,3 @@ C_filter_heap_objects(C_word c, C_word closure, C_word k, C_word func, C_word ve
C_fromspace_top = C_fromspace_limit; /* force major GC */
C_reclaim((void *)filter_heap_objects_2, NULL);
}
-
-
-C_regparm C_word C_fcall
-C_a_i_flonum_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2)
-{
- double n3 = C_flonum_magnitude(n2);
-
- if(n3 == 0.0) barf(C_DIVISION_BY_ZERO_ERROR, "fp/?");
- else return C_flonum(ptr, C_flonum_magnitude(n1) / n3);
-}
diff --git a/unboxing.scm b/unboxing.scm
index 174ede5d..83221d25 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -532,6 +532,7 @@
(C_a_i_flonum_difference (flonum flonum) flonum "C_ub_i_flonum_difference")
(C_a_i_flonum_times (flonum flonum) flonum "C_ub_i_flonum_times")
(C_a_i_flonum_quotient (flonum flonum) flonum "C_ub_i_flonum_quotient")
+ (C_a_i_flonum_quotient_checked (flonum flonum) flonum "C_ub_i_flonum_quotient_checked")
(C_u_i_fpintegerp (flonum) bool "C_ub_i_fpintegerp")
(C_flonum_equalp (flonum flonum) bool "C_ub_i_flonum_equalp")
(C_flonum_greaterp (flonum flonum) bool "C_ub_i_flonum_greaterp")
Trap