~ chicken-core (chicken-5) ffd5cfbe120bf57206b21362998560927b0df28c
commit ffd5cfbe120bf57206b21362998560927b0df28c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Dec 6 14:07:17 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Dec 6 14:07:17 2009 +0100
converted some runtime C functions to inline versions and moved them to chicken.h
diff --git a/chicken.h b/chicken.h
index cc7e6b89..05c2de27 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1,7 +1,7 @@
/* chicken.h - General headerfile for compiler generated executables
;
-; 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 modification, are permitted provided that the following
@@ -776,6 +776,8 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
#define C_align8(n) (((n) + 7) & ~7)
#define C_align16(n) (((n) + 15) & ~15)
+#define C_aligned8(n) ((((C_word)(n)) & 7) == 0)
+
/* This is word-size dependent: */
#ifdef C_SIXTY_FOUR
# define C_align(n) C_align8(n)
@@ -953,6 +955,9 @@ extern double trunc(double);
#define C_c_f64vector(x) ((double *)C_data_pointer(C_u_i_cdr(x)))
#define C_c_f64vector_or_null(x) ((double *)C_srfi_4_vector_or_null(x))
+#define C_isnan(f) (!((f) == (f)))
+#define C_isinf(f) ((f) == (f) + (f) && (f) != 0.0)
+
#ifdef C_STRESS_TEST
# define C_STRESS_FAILURE 3
# define C_stress (rand() % C_STRESS_FAILURE)
@@ -1003,6 +1008,9 @@ extern double trunc(double);
#define C_eqp(x, y) C_mk_bool((x) == (y))
#define C_vemptyp(x) C_mk_bool(C_header_size(x) == 0)
#define C_notvemptyp(x) C_mk_bool(C_header_size(x) > 0)
+#define C_u_i_exactp(x) C_mk_bool((x) & C_FIXNUM_BIT)
+#define C_u_i_inexactp(x) C_mk_bool(((x) & C_FIXNUM_BIT) == 0)
+
#define C_slot(x, i) (((C_SCHEME_BLOCK *)(x))->data[ C_unfix(i) ])
#define C_slot0(x) (((C_SCHEME_BLOCK *)(x))->data[ 0 ])
#define C_subbyte(x, i) C_fix(((C_byte *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ] & 0xff)
@@ -1043,10 +1051,18 @@ extern double trunc(double);
#define C_flonum_greater_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) >= C_flonum_magnitude(n2))
#define C_flonum_less_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) <= C_flonum_magnitude(n2))
+#define C_a_i_flonum_plus(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) + C_flonum_magnitude(n2))
+#define C_a_i_flonum_difference(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) - C_flonum_magnitude(n2))
+#define C_a_i_flonum_times(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) * C_flonum_magnitude(n2))
+#define C_a_i_flonum_quotient(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) / C_flonum_magnitude(n2))
+#define C_a_i_flonum_negate(ptr, c, n) C_flonum(ptr, -C_flonum_magnitude(n))
+
#define C_display_fixnum(p, n) (C_fprintf(C_port_file(p), C_text("%d"), C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_display_char(p, c) (C_fputc(C_character_code(c), C_port_file(p)), C_SCHEME_UNDEFINED)
#define C_display_string(p, s) (C_fwrite(((C_SCHEME_BLOCK *)(s))->data, sizeof(C_char), C_header_size(s), \
C_port_file(p)), C_SCHEME_UNDEFINED)
+#define C_flush_output(port) (C_fflush(C_port_file(port)), 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_substring_copy(s1, s2, start1, end1, start2) \
@@ -1127,6 +1143,10 @@ extern double trunc(double);
# define C_check_for_interrupt
#endif
+#define C_set_initial_timer_interrupt_period(n) \
+ (C_initial_timer_interrupt_period = C_unfix(n), C_SCHEME_UNDEFINED)
+
+
#if defined(__GNUC__) || defined(__INTEL_COMPILER)
# define C_a_i(a, n) ({C_word *tmp = *a; *a += (n); tmp;})
# define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TYPE | 2; *a += 3; \
@@ -1373,25 +1393,6 @@ C_fctexport void C_fcall C_toplevel_entry(C_char *name) C_regparm;
C_fctexport C_word C_fcall C_enable_interrupts(void) C_regparm;
C_fctexport C_word C_fcall C_disable_interrupts(void) C_regparm;
C_fctexport void C_fcall C_paranoid_check_for_interrupt(void) C_regparm;
-C_fctexport double C_fcall C_c_double(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_num_to_int(C_word x) C_regparm;
-C_fctexport C_s64 C_fcall C_num_to_int64(C_word x) C_regparm;
-C_fctexport C_uword C_fcall C_num_to_unsigned_int(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_int_to_num(C_word **ptr, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n) C_regparm;
-C_fctexport C_word C_fcall C_long_to_num(C_word **ptr, long n) C_regparm;
-C_fctexport C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n) C_regparm;
-C_fctexport long C_fcall C_num_to_long(C_word x) C_regparm;
-C_fctexport unsigned long C_fcall C_num_to_unsigned_long(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_flonum_in_int_range_p(C_word n) C_regparm;
-C_fctexport C_word C_fcall C_flonum_in_uint_range_p(C_word n) C_regparm;
-C_fctexport C_word C_fcall C_double_to_number(C_word n) C_regparm;
-C_fctexport char *C_fcall C_string_or_null(C_word x) C_regparm;
-C_fctexport void *C_fcall C_data_pointer_or_null(C_word x) C_regparm;
-C_fctexport void *C_fcall C_srfi_4_vector_or_null(C_word x) C_regparm;
-C_fctexport void *C_fcall C_c_pointer_or_null(C_word x) C_regparm;
-C_fctexport void *C_fcall C_scheme_or_c_pointer(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_flonum_in_fixnum_range_p(C_word n) C_regparm;
C_fctexport void C_zap_strings(C_word str);
C_fctexport void C_set_or_change_heap_size(C_word heap, int reintern);
C_fctexport void C_do_resize_stack(C_word stack);
@@ -1431,7 +1432,6 @@ C_fctexport void C_no_closure_error(C_word x) 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;
-C_fctexport C_word C_fcall C_flonum(C_word **ptr, double n) C_regparm;
C_fctexport C_word C_fcall C_number(C_word **ptr, double n) C_regparm;
C_fctexport C_word C_fcall C_mpointer(C_word **ptr, void *mp) C_regparm;
C_fctexport C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp) C_regparm;
@@ -1454,7 +1454,6 @@ C_fctexport C_word C_fcall C_retrieve2(C_word val, char *name) C_regparm;
C_fctexport void *C_fcall C_retrieve_proc(C_word closure) C_regparm;
C_fctexport void *C_fcall C_retrieve_symbol_proc(C_word sym) C_regparm;
C_fctexport void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name) C_regparm;
-C_fctexport C_word C_fcall C_permanentp(C_word x) C_regparm;
C_fctexport int C_in_stackp(C_word x) C_regparm;
C_fctexport int C_fcall C_in_heapp(C_word x) C_regparm;
C_fctexport int C_fcall C_in_fromspacep(C_word x) C_regparm;
@@ -1476,13 +1475,9 @@ C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
-C_fctexport C_word C_fcall C_flush_output(C_word port) C_regparm;
C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
-C_fctexport C_word C_fcall C_set_initial_timer_interrupt_period(C_word n) C_regparm;
C_fctexport C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason) C_regparm;
-C_fctexport C_word C_fcall C_fits_in_int_p(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_fits_in_unsigned_int_p(C_word x) C_regparm;
C_fctexport C_word C_fcall C_copy_block(C_word from, C_word to) C_regparm;
C_fctexport C_word C_fcall C_evict_block(C_word from, C_word ptr) C_regparm;
C_fctexport void C_fcall C_gc_protect(C_word **addr, int n) C_regparm;
@@ -1569,35 +1564,15 @@ C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
C_fctexport C_word C_a_i_port(C_word **a, int c);
C_fctexport C_word C_fcall C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_eqvp(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_symbolp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_pairp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_closurep(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_portp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_stringp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_numberp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_rationalp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_integerp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_flonump(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_finitep(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_locativep(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_fixnum_min(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_fixnum_max(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_flonum_min(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_flonum_max(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_a_i_abs(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_listp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_string_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_set_car(C_word p, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_set_cdr(C_word p, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_exactp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_u_i_exactp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_inexactp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_u_i_inexactp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_zerop(C_word x) C_regparm;
C_fctexport C_word C_fcall C_u_i_zerop(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_positivep(C_word x) C_regparm;
@@ -1658,17 +1633,11 @@ C_fctexport C_word C_fcall C_i_less_or_equalp(C_word x, C_word y) C_regparm;
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_string_to_pbytevector(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_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;
-C_fctexport C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-C_fctexport C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-C_fctexport C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-C_fctexport C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-C_fctexport C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n1) C_regparm;
C_fctexport C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n1) C_regparm;
@@ -1733,6 +1702,337 @@ C_fctexport int CHICKEN_yield();
C_fctexport void C_default_stub_toplevel(C_word c,C_word d,C_word k) C_noret;
+
+/* Inline functions: */
+
+C_inline C_word C_permanentp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && !C_in_stackp(x) && !C_in_heapp(x));
+}
+
+
+C_inline C_word C_flonum(C_word **ptr, double n)
+{
+ C_word
+ *p = *ptr,
+ *p0;
+
+#ifndef C_SIXTY_FOUR
+#ifndef C_DOUBLE_IS_32_BITS
+ /* Align double on 8-byte boundary: */
+ if(C_aligned8(p)) ++p;
+#endif
+#endif
+
+ p0 = p;
+ *(p++) = C_FLONUM_TAG;
+ *((double *)p) = n;
+ *ptr = p + sizeof(double) / sizeof(C_word);
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_string_to_pbytevector(C_word s)
+{
+ return C_pbytevector(C_header_size(s), C_data_pointer(s));
+}
+
+
+C_inline C_word C_flonum_in_fixnum_range_p(C_word n)
+{
+ double f = C_flonum_magnitude(n);
+
+ return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
+}
+
+
+C_inline C_word C_double_to_number(C_word n)
+{
+ double m, f = C_flonum_magnitude(n);
+
+ if(f <= (double)C_MOST_POSITIVE_FIXNUM
+ && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
+ return C_fix(f);
+ else return n;
+}
+
+
+C_inline C_word C_fits_in_int_p(C_word x)
+{
+ double n, m;
+
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ n = C_flonum_magnitude(x);
+ return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
+}
+
+
+C_inline C_word C_fits_in_unsigned_int_p(C_word x)
+{
+ double n, m;
+
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ n = C_flonum_magnitude(x);
+ return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
+}
+
+
+C_inline double C_c_double(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
+ else return C_flonum_magnitude(x);
+}
+
+
+C_inline C_word C_num_to_int(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (int)C_flonum_magnitude(x);
+}
+
+
+C_inline C_s64 C_num_to_int64(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
+ else return (C_s64)C_flonum_magnitude(x);
+}
+
+
+C_inline C_uword C_num_to_unsigned_int(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (unsigned int)C_flonum_magnitude(x);
+}
+
+
+C_inline C_word C_int_to_num(C_word **ptr, C_word n)
+{
+ if(C_fitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_inline C_word C_unsigned_int_to_num(C_word **ptr, C_uword n)
+{
+ if(C_ufitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_inline C_word C_long_to_num(C_word **ptr, long n)
+{
+ if(C_fitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_inline C_word C_unsigned_long_to_num(C_word **ptr, unsigned long n)
+{
+ if(C_ufitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_inline C_word C_flonum_in_int_range_p(C_word n)
+{
+ double m = C_flonum_magnitude(n);
+
+ return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
+}
+
+
+C_inline C_word C_flonum_in_uint_range_p(C_word n)
+{
+ double m = C_flonum_magnitude(n);
+
+ return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
+}
+
+
+C_inline char *C_string_or_null(C_word x)
+{
+ return C_truep(x) ? C_c_string(x) : NULL;
+}
+
+
+C_inline void *C_data_pointer_or_null(C_word x)
+{
+ return C_truep(x) ? C_data_pointer(x) : NULL;
+}
+
+
+C_inline void *C_srfi_4_vector_or_null(C_word x)
+{
+ return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
+}
+
+
+C_inline void *C_c_pointer_or_null(C_word x)
+{
+ return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
+}
+
+
+C_inline void *C_scheme_or_c_pointer(C_word x)
+{
+ return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
+}
+
+
+C_inline long C_num_to_long(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (long)C_flonum_magnitude(x);
+}
+
+
+C_inline unsigned long C_num_to_unsigned_long(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (unsigned long)C_flonum_magnitude(x);
+}
+
+
+C_inline C_word C_u_i_string_equal_p(C_word x, C_word y)
+{
+ C_word n;
+
+ n = C_header_size(x);
+ return C_mk_bool(n == C_header_size(y)
+ && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
+}
+
+
+C_inline C_word C_i_eqvp(C_word x, C_word y)
+{
+ return
+ C_mk_bool(x == y ||
+ (!C_immediatep(x) && !C_immediatep(y) &&
+ C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
+ C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
+}
+
+
+C_inline C_word C_i_symbolp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
+}
+
+
+C_inline C_word C_i_pairp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
+}
+
+
+C_inline C_word C_i_stringp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
+}
+
+
+C_inline C_word C_i_locativep(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
+}
+
+
+C_inline C_word C_i_vectorp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
+}
+
+
+C_inline C_word C_i_portp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
+}
+
+
+C_inline C_word C_i_closurep(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
+}
+
+
+C_inline C_word C_i_numberp(C_word x)
+{
+ return C_mk_bool((x & C_FIXNUM_BIT)
+ || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
+}
+
+
+C_inline C_word C_i_rationalp(C_word x)
+{
+ if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
+
+ if((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)) {
+ double n = C_flonum_magnitude(x);
+
+ if(!C_isinf(n) && !C_isnan(n)) return C_SCHEME_TRUE;
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_inline C_word C_i_integerp(C_word x)
+{
+ double dummy;
+
+ return C_mk_bool((x & C_FIXNUM_BIT) ||
+ ((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
+ modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
+}
+
+
+C_inline C_word C_i_flonump(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
+}
+
+
+C_inline C_word C_i_finitep(C_word x)
+{
+ if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
+ else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
+}
+
+
+C_inline C_word C_i_fixnum_min(C_word x, C_word y)
+{
+ return ((C_word)x < (C_word)y) ? x : y;
+}
+
+
+C_inline C_word C_i_fixnum_max(C_word x, C_word y)
+{
+ return ((C_word)x > (C_word)y) ? x : y;
+}
+
+
+C_inline C_word C_i_flonum_min(C_word x, C_word y)
+{
+ double
+ xf = C_flonum_magnitude(x),
+ yf = C_flonum_magnitude(y);
+
+ return xf < yf ? x : y;
+}
+
+
+C_inline C_word C_i_flonum_max(C_word x, C_word y)
+{
+ double
+ xf = C_flonum_magnitude(x),
+ yf = C_flonum_magnitude(y);
+
+ return xf > yf ? x : y;
+}
+
+
C_END_C_DECLS
#endif /* ___CHICKEN */
diff --git a/runtime.c b/runtime.c
index 74712304..3d21a2f6 100644
--- a/runtime.c
+++ b/runtime.c
@@ -209,7 +209,6 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
# define check_alignment(p)
#endif
-#define aligned8(n) ((((C_word)(n)) & 7) == 0)
#define nmax(x, y) ((x) > (y) ? (x) : (y))
#define nmin(x, y) ((x) < (y) ? (x) : (y))
#define percentage(n, p) ((long)(((double)(n) * (double)p) / 100))
@@ -232,9 +231,6 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
else v = C_flonum_magnitude(x);
#endif
-#define C_isnan(f) (!((f) == (f)))
-#define C_isinf(f) ((f) == (f) + (f) && (f) != 0.0)
-
/* these could be shorter in unsafe mode: */
#define C_check_int(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
@@ -2092,15 +2088,6 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl
}
-/* Check block allocation: */
-
-/* I */
-C_regparm C_word C_fcall C_permanentp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && !C_in_stackp(x) && !C_in_heapp(x));
-}
-
-
C_regparm int C_in_stackp(C_word x)
{
C_word *ptr = (C_word *)(C_uword)x;
@@ -2292,7 +2279,7 @@ C_regparm C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str)
#ifndef C_SIXTY_FOUR
/* Align on 8-byte boundary: */
- if(aligned8(p)) ++p;
+ if(C_aligned8(p)) ++p;
#endif
p0 = p;
@@ -2388,28 +2375,6 @@ C_regparm C_word C_fcall C_h_pair(C_word car, C_word cdr)
}
-/* I */
-C_regparm C_word C_fcall C_flonum(C_word **ptr, double n)
-{
- C_word
- *p = *ptr,
- *p0;
-
-#ifndef C_SIXTY_FOUR
-#ifndef C_DOUBLE_IS_32_BITS
- /* Align double on 8-byte boundary: */
- if(aligned8(p)) ++p;
-#endif
-#endif
-
- p0 = p;
- *(p++) = C_FLONUM_TAG;
- *((double *)p) = n;
- *ptr = p + sizeof(double) / sizeof(C_word);
- return (C_word)p0;
-}
-
-
C_regparm C_word C_fcall C_number(C_word **ptr, double n)
{
C_word
@@ -2425,7 +2390,7 @@ C_regparm C_word C_fcall C_number(C_word **ptr, double n)
#ifndef C_SIXTY_FOUR
#ifndef C_DOUBLE_IS_32_BITS
/* Align double on 8-byte boundary: */
- if(aligned8(p)) ++p;
+ if(C_aligned8(p)) ++p;
#endif
#endif
@@ -3007,7 +2972,7 @@ C_regparm void C_fcall mark(C_word *x)
p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);
#ifndef C_SIXTY_FOUR
- if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
+ if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
*((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
}
@@ -3062,7 +3027,7 @@ C_regparm void C_fcall mark(C_word *x)
p2 = (C_SCHEME_BLOCK *)C_align((C_uword)tospace_top);
#ifndef C_SIXTY_FOUR
- if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < tospace_limit) {
+ if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tospace_limit) {
*((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
}
@@ -3337,7 +3302,7 @@ C_regparm void C_fcall remark(C_word *x)
p2 = (C_SCHEME_BLOCK *)C_align((C_uword)new_tospace_top);
#ifndef C_SIXTY_FOUR
- if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < new_tospace_limit) {
+ if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < new_tospace_limit) {
*((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
}
@@ -3965,7 +3930,6 @@ C_regparm C_word C_fcall C_display_flonum(C_word port, C_word n)
}
-/* I */
C_regparm C_word C_fcall C_read_char(C_word port)
{
int c = C_getc(C_port_file(port));
@@ -3974,7 +3938,6 @@ C_regparm C_word C_fcall C_read_char(C_word port)
}
-/* I */
C_regparm C_word C_fcall C_peek_char(C_word port)
{
C_FILEPTR fp = C_port_file(port);
@@ -4010,13 +3973,6 @@ C_regparm C_word C_fcall C_execute_shell_command(C_word string)
}
-/* I */
-C_regparm C_word C_fcall C_string_to_pbytevector(C_word s)
-{
- return C_pbytevector(C_header_size(s), C_data_pointer(s));
-}
-
-
C_regparm C_word C_fcall C_char_ready_p(C_word port)
{
#if !defined(C_NONUNIX)
@@ -4034,14 +3990,6 @@ C_regparm C_word C_fcall C_char_ready_p(C_word port)
}
-/* M */
-C_regparm C_word C_fcall C_flush_output(C_word port)
-{
- C_fflush(C_port_file(port));
- return C_SCHEME_UNDEFINED;
-}
-
-
C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
{
int i, j;
@@ -4240,7 +4188,6 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
}
-/* M */
C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
{
if(--C_timer_interrupt_counter <= 0)
@@ -4265,15 +4212,6 @@ C_regparm void C_fcall C_raise_interrupt(int reason)
}
-/* M */
-C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
-{
- C_initial_timer_interrupt_period = C_unfix(n);
- return C_SCHEME_UNDEFINED;
-}
-
-
-/* M */
C_regparm C_word C_fcall C_enable_interrupts(void)
{
C_timer_interrupt_counter = C_initial_timer_interrupt_period;
@@ -4283,7 +4221,6 @@ C_regparm C_word C_fcall C_enable_interrupts(void)
}
-/* M */
C_regparm C_word C_fcall C_disable_interrupts(void)
{
C_interrupts_enabled = 0;
@@ -4305,51 +4242,6 @@ C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason
}
-/* I */
-C_regparm C_word C_fcall C_flonum_in_fixnum_range_p(C_word n)
-{
- double f = C_flonum_magnitude(n);
-
- return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_double_to_number(C_word n)
-{
- double m, f = C_flonum_magnitude(n);
-
- if(f <= (double)C_MOST_POSITIVE_FIXNUM
- && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
- return C_fix(f);
- else return n;
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_fits_in_int_p(C_word x)
-{
- double n, m;
-
- if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
-
- n = C_flonum_magnitude(x);
- return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_fits_in_unsigned_int_p(C_word x)
-{
- double n, m;
-
- if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
-
- n = C_flonum_magnitude(x);
- return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
-}
-
-
/* Copy blocks into collected or static memory: */
C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
@@ -4384,141 +4276,6 @@ C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
}
-/* Conversion routines: */
-
-/* I */
-C_regparm double C_fcall C_c_double(C_word x)
-{
- if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
- else return C_flonum_magnitude(x);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_num_to_int(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (int)C_flonum_magnitude(x);
-}
-
-
-/* I */
-C_regparm C_s64 C_fcall C_num_to_int64(C_word x)
-{
- if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
- else return (C_s64)C_flonum_magnitude(x);
-}
-
-
-/* I */
-C_regparm C_uword C_fcall C_num_to_unsigned_int(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (unsigned int)C_flonum_magnitude(x);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_int_to_num(C_word **ptr, C_word n)
-{
- if(C_fitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n)
-{
- if(C_ufitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_long_to_num(C_word **ptr, long n)
-{
- if(C_fitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n)
-{
- if(C_ufitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_flonum_in_int_range_p(C_word n)
-{
- double m = C_flonum_magnitude(n);
-
- return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_flonum_in_uint_range_p(C_word n)
-{
- double m = C_flonum_magnitude(n);
-
- return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
-}
-
-
-/* I */
-C_regparm char *C_fcall C_string_or_null(C_word x)
-{
- return C_truep(x) ? C_c_string(x) : NULL;
-}
-
-
-/* I */
-C_regparm void *C_fcall C_data_pointer_or_null(C_word x)
-{
- return C_truep(x) ? C_data_pointer(x) : NULL;
-}
-
-
-/* I */
-C_regparm void *C_fcall C_srfi_4_vector_or_null(C_word x)
-{
- return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
-}
-
-
-/* I */
-C_regparm void *C_fcall C_c_pointer_or_null(C_word x)
-{
- return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
-}
-
-
-/* I */
-C_regparm void *C_fcall C_scheme_or_c_pointer(C_word x)
-{
- return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
-}
-
-
-/* I */
-C_regparm long C_fcall C_num_to_long(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (long)C_flonum_magnitude(x);
-}
-
-
-/* I */
-C_regparm unsigned long C_fcall C_num_to_unsigned_long(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (unsigned long)C_flonum_magnitude(x);
-}
-
-
/* Inline versions of some standard procedures: */
C_regparm C_word C_fcall C_i_listp(C_word x)
@@ -4561,17 +4318,6 @@ C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
}
-/* I */
-C_regparm C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y)
-{
- C_word n;
-
- n = C_header_size(x);
- return C_mk_bool(n == C_header_size(y)
- && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
-}
-
-
C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
{
C_word n;
@@ -4597,151 +4343,6 @@ C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
}
-/* I */
-C_regparm C_word C_fcall C_i_eqvp(C_word x, C_word y)
-{
- return
- C_mk_bool(x == y ||
- (!C_immediatep(x) && !C_immediatep(y) &&
- C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
- C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_symbolp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_pairp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_stringp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_locativep(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_vectorp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_portp(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_closurep(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_numberp(C_word x)
-{
- return C_mk_bool((x & C_FIXNUM_BIT)
- || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_rationalp(C_word x)
-{
- if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
-
- if((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)) {
- double n = C_flonum_magnitude(x);
-
- if(!C_isinf(n) && !C_isnan(n)) return C_SCHEME_TRUE;
- }
-
- return C_SCHEME_FALSE;
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_integerp(C_word x)
-{
- double dummy;
-
- return C_mk_bool((x & C_FIXNUM_BIT) ||
- ((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
- modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_flonump(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_finitep(C_word x)
-{
- if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
- else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_fixnum_min(C_word x, C_word y)
-{
- return ((C_word)x < (C_word)y) ? x : y;
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_fixnum_max(C_word x, C_word y)
-{
- return ((C_word)x > (C_word)y) ? x : y;
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_flonum_min(C_word x, C_word y)
-{
- double
- xf = C_flonum_magnitude(x),
- yf = C_flonum_magnitude(y);
-
- return xf < yf ? x : y;
-}
-
-
-/* I */
-C_regparm C_word C_fcall C_i_flonum_max(C_word x, C_word y)
-{
- double
- xf = C_flonum_magnitude(x),
- yf = C_flonum_magnitude(y);
-
- return xf > yf ? x : y;
-}
-
-
#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
C_word *C_a_i(C_word **a, int n)
@@ -4870,7 +4471,7 @@ C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
#ifndef C_SIXTY_FOUR
/* Align on 8-byte boundary: */
- if(aligned8(p)) ++p;
+ if(C_aligned8(p)) ++p;
#endif
p0 = p;
@@ -4909,15 +4510,6 @@ C_regparm C_word C_fcall C_i_exactp(C_word x)
}
-/* M */
-C_regparm C_word C_fcall C_u_i_exactp(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
-
- return C_SCHEME_FALSE;
-}
-
-
C_regparm C_word C_fcall C_i_inexactp(C_word x)
{
if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
@@ -4929,15 +4521,6 @@ C_regparm C_word C_fcall C_i_inexactp(C_word x)
}
-/* M */
-C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
-
- return C_SCHEME_TRUE;
-}
-
-
C_regparm C_word C_fcall C_i_zerop(C_word x)
{
if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
@@ -5390,41 +4973,6 @@ 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));
-}
-
-
-/* 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));
-}
-
-
-/* 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));
-}
-
-
-/* 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));
-}
-
-
-/* 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));
-}
-
-
C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
{
double f1, f2;
@@ -7383,7 +6931,7 @@ void allocate_vector_2(void *dummy)
else v0 = C_alloc(C_bytestowords(bytes));
#ifndef C_SIXTY_FOUR
- if(C_truep(align8) && aligned8(v0)) ++v0;
+ if(C_truep(align8) && C_aligned8(v0)) ++v0;
#endif
v = (C_word)v0;
@@ -9113,7 +8661,7 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
#ifndef C_SIXTY_FOUR
if((bits & C_8ALIGN_BIT) != 0) {
/* Align _data_ on 8-byte boundary: */
- if(aligned8(*ptr)) ++(*ptr);
+ if(C_aligned8(*ptr)) ++(*ptr);
}
#endif
Trap