Hi all, Now we have a bootstrapping tarball, we can finally (FINALLY!) drop all those unused C functions that have been lying around since the numeric tower integration.
The first patch is very large, but it just removes unused code, and it should be pretty straightforward. We don't need to remove much at the Scheme level because almost all these C functions are things used by rewrites in c-platform.scm (or types.db) in the old CHICKEN. I noticed that C_i_foreign_unsigned_ranged_integer_argumentp was incorrectly marked OBSOLETE, so I've removed the comment there. The second patch is to get rid of the "big fixnum" literal encoding special handling, which was necessary when compiling a program with fixnum literals on a 64-bit machine; if it was run on a 32-bit machine such a large fixnum literal could result in a flonum. This is no longer needed, because in such cases we now use bignums, instead. The third patch uses literals for +i, +2i and -i instead of jumping through hoops to cope with a compiler with a reader that doesn't support complex number literals. The final patch cleans up and prepares us for dropping the remaining OBSOLETE functions that I forgot to actually remove. After the next snapshot (pre2? rc1?), we can drop the matching C code. Cheers, Peter
From 7d98aaabf9ff90faa23fb26c70c1090d68c3c2dd Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 19 May 2017 13:05:46 +0200
Subject: [PATCH 1/4] Remove obsolete, unused numeric procedures
This just drops those primitives that have been unused but were only
still present for bootstrapping reasons.
---
c-platform.scm | 2 +-
chicken.h | 82 +------
library.scm | 10 +-
runtime.c | 702 +--------------------------------------------------------
4 files changed, 5 insertions(+), 791 deletions(-)
diff --git a/c-platform.scm b/c-platform.scm
index 49bbfc0..ee4f661 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -802,7 +802,7 @@
;; -> (##core#inline "C_fixnum_shift_right" <x> -<int>)
;; (arithmetic-shift <x> <+int>)
;; -> (##core#inline "C_fixnum_shift_left" <x> <int>)
- ;; _ -> (##core#inline "C_a_i_arithmetic_shift" <x> <y>)
+ ;; _ -> (##core#inline "C_i_fixnum_arithmetic_shift" <x> <y>)
;;
;; not in fixnum-mode:
;; _ -> (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) <x> <y>)
diff --git a/chicken.h b/chicken.h
index d9bcfab..6addd31 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1364,8 +1364,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_pointer_eqp(x, y) C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
#define C_a_int_to_num(ptr, n, i) C_int_to_num(ptr, i)
#define C_a_unsigned_int_to_num(ptr, n, i) C_unsigned_int_to_num(ptr, i)
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-backend.scm */
-#define C_a_double_to_num(ptr, n) C_double_to_number(C_flonum(ptr, n))
#define C_a_i_vector C_vector
#define C_list C_a_i_list
#define C_i_setslot(x, i, y) (C_mutate2(&C_block_item(x, C_unfix(i)), y), C_SCHEME_UNDEFINED)
@@ -1426,12 +1424,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_u_i_cdddar(x) C_u_i_cdr( C_u_i_cddar( x ) )
#define C_u_i_cddddr(x) C_u_i_cdr( C_u_i_cdddr( x ) )
-/* XXX TODO OBSOLETE: These 4 can be removed after recompiling c-platform.scm */
-#define C_a_i_times( ptr, n, x, y) C_2_times( ptr, x, y)
-#define C_a_i_plus( ptr, n, x, y) C_2_plus( ptr, x, y)
-#define C_a_i_minus( ptr, n, x, y) C_2_minus( ptr, x, y)
-#define C_a_i_divide(ptr, n, x, y) C_2_divide(ptr, x, y)
-
#ifdef HAVE_STATEMENT_EXPRESSIONS
# define C_i_not_pair_p(x) ({C_word tmp = (x); C_mk_bool(C_immediatep(tmp) || C_block_header(tmp) != C_PAIR_TAG);})
#else
@@ -1910,8 +1902,6 @@ C_fctexport C_cpsproc(C_u_call_with_values) C_noret;
C_fctexport C_cpsproc(C_times) C_noret;
C_fctexport C_cpsproc(C_plus) C_noret;
C_fctexport C_cpsproc(C_minus) C_noret;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_cpsproc(C_divide) C_noret;
C_fctexport C_cpsproc(C_quotient_and_remainder) C_noret;
C_fctexport C_cpsproc(C_u_integer_quotient_and_remainder) C_noret;
C_fctexport C_cpsproc(C_bitwise_and) C_noret;
@@ -1928,8 +1918,6 @@ C_fctexport C_cpsproc(C_open_file_port) C_noret;
C_fctexport C_cpsproc(C_allocate_vector) C_noret;
C_fctexport C_cpsproc(C_string_to_symbol) C_noret;
C_fctexport C_cpsproc(C_build_symbol) C_noret;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_cpsproc(C_quotient) C_noret;
C_fctexport C_cpsproc(C_number_to_string) C_noret;
C_fctexport C_cpsproc(C_fixnum_to_string) C_noret;
C_fctexport C_cpsproc(C_flonum_to_string) C_noret;
@@ -1973,8 +1961,6 @@ 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;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-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;
@@ -2030,8 +2016,6 @@ C_fctexport C_word C_fcall C_i_memv(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_member(C_word x, C_word lst) C_regparm;
C_fctexport C_word C_fcall C_i_length(C_word lst) C_regparm;
C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_i_inexact_to_exact(C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) C_regparm;
@@ -2048,14 +2032,6 @@ C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_port_2(C_word x, C_word in, C_word op, C_word loc) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_bignum_cmp(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_nequalp(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_integer_equalp(C_word x, C_word y) C_regparm;
@@ -2080,18 +2056,8 @@ C_fctexport C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc) C_r
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;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n1) C_regparm;
C_fctexport C_word C_fcall C_i_bit_setp(C_word n, C_word i) C_regparm;
C_fctexport C_word C_fcall C_i_integer_length(C_word x) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_log(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n) C_regparm;
@@ -2131,8 +2097,6 @@ C_fctexport C_word C_fcall C_i_tty_forcedp(void) C_regparm;
C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm;
C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
@@ -2173,12 +2137,6 @@ C_fctexport C_word C_fcall C_i_foreign_pointer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_foreign_integer_argumentp(C_word x) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_i_foreign_integer64_argumentp(C_word x) C_regparm;
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_fctexport C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
@@ -2282,25 +2240,6 @@ inline static C_word C_string_to_pbytevector(C_word s)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-inline static 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);
-}
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-backend.scm */
-inline static 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 && C_modf(f, &m) == 0.0)
- return C_fix(f);
- else return n;
-}
-
inline static C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
{
C_word *p = *ptr, *p0 = p;
@@ -2497,25 +2436,7 @@ inline static C_word C_i_bignump(C_word x)
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-inline static C_word C_fits_in_int_p(C_word x)
-{
- double n, m;
-
- if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
-
- if(C_truep(C_i_bignump(x))) {
- return C_mk_bool(C_bignum_size(x) == 1 &&
- (!C_bignum_negativep(x) ||
- !(C_bignum_digits(x)[0] & C_INT_SIGN_BIT)));
- }
-
- n = C_flonum_magnitude(x);
- return C_mk_bool(C_modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
-}
-
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
+/* XXX TODO OBSOLETE (but still used by C_flonum_to_string) */
inline static C_word C_fits_in_unsigned_int_p(C_word x)
{
double n, m;
@@ -2523,7 +2444,6 @@ inline static C_word C_fits_in_unsigned_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
if(C_truep(C_i_bignump(x))) return C_mk_bool(C_bignum_size(x) == 1);
- /* XXX OBSOLETE remove on the next round, remove check above */
n = C_flonum_magnitude(x);
return C_mk_bool(C_modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
}
diff --git a/library.scm b/library.scm
index d7a0580..5daada9 100644
--- a/library.scm
+++ b/library.scm
@@ -5017,15 +5017,9 @@ EOF
(define (##sys#foreign-symbol-argument x) (##core#inline "C_i_foreign_symbol_argumentp" x))
(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))
+
+;; OBSOLETE (but still used by "enum"
(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
-;; OBSOLETE
-(define (##sys#foreign-integer64-argument x) (##core#inline "C_i_foreign_integer64_argumentp" x))
-;; OBSOLETE
-(define (##sys#foreign-unsigned-integer-argument x)
- (##core#inline "C_i_foreign_unsigned_integer_argumentp" x))
-;; OBSOLETE
-(define (##sys#foreign-unsigned-integer64-argument x)
- (##core#inline "C_i_foreign_unsigned_integer64_argumentp" x))
(define (##sys#foreign-ranged-integer-argument obj size)
(##core#inline "C_i_foreign_ranged_integer_argumentp" obj size))
diff --git a/runtime.c b/runtime.c
index 1d6dede..c13115c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -246,36 +246,6 @@ static C_TLS int timezone;
else v = C_flonum_magnitude(x);
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-#ifdef BITWISE_UINT_ONLY
-#define C_check_uint(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
- else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
- barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
- else { double _m; \
- f = C_flonum_magnitude(x); \
- if(modf(f, &_m) != 0.0 || f < 0 || f > C_UWORD_MAX) \
- barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
- else n = (C_uword)f; \
- }
-#else
-#define C_check_uint(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
- else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
- barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
- else { double _m; \
- f = C_flonum_magnitude(x); \
- if(modf(f, &_m) != 0.0 || f > C_UWORD_MAX) \
- barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
- else n = (C_uword)f; \
- }
-#endif
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-#ifdef C_SIXTY_FOUR
-#define C_limit_fixnum(n) ((n) & C_MOST_POSITIVE_FIXNUM)
-#else
-#define C_limit_fixnum(n) (n)
-#endif
-
#define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;
#ifndef SIGBUS
@@ -549,8 +519,6 @@ static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regpar
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-static C_word C_fcall maybe_inexact_to_exact(C_word n) C_regparm;
static void C_fcall mark_system_globals(void) C_regparm;
static void C_fcall remark_system_globals(void) C_regparm;
static void C_fcall really_remark(C_word *x) C_regparm;
@@ -890,7 +858,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- 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) * 64);
int i = 0;
if(pt == NULL)
@@ -917,15 +885,12 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_times);
C_pte(C_minus);
C_pte(C_plus);
- /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
- C_pte(C_divide);
C_pte(C_nequalp);
C_pte(C_greaterp);
/* IMPORTANT: have you read the comments at the start and the end of this function? */
C_pte(C_lessp);
C_pte(C_greater_or_equal_p);
C_pte(C_less_or_equal_p);
- C_pte(C_quotient);
C_pte(C_number_to_string);
C_pte(C_make_symbol);
C_pte(C_string_to_symbol);
@@ -5748,38 +5713,6 @@ C_regparm C_word C_fcall C_u_i_length(C_word lst)
return C_fix(n);
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word maybe_inexact_to_exact(C_word n)
-{
- double m;
- C_word r;
-
- if(modf(C_flonum_magnitude(n), &m) == 0.0) {
- r = (C_word)m;
-
- if(r == m && C_fitsinfixnump(r))
- return C_fix(r);
- }
- return C_SCHEME_FALSE;
-}
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
-{
- C_word r;
-
- if(n & C_FIXNUM_BIT) return n;
- else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
-
- r = maybe_inexact_to_exact(n);
- if (r != C_SCHEME_FALSE) return r;
-
- barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
- return 0;
-}
-
-
C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
{
if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
@@ -5865,17 +5798,6 @@ void C_ccall C_signum(C_word c, C_word *av)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
-{
- if(x & C_FIXNUM_BIT) return C_fix(labs(C_unfix(x)));
-
- if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "abs", x);
-
- return C_flonum(a, fabs(C_flonum_magnitude(x)));
-}
-
/* The maximum this can allocate is a cplxnum which consists of two
* ratnums that consist of 2 fix bignums each. So that's
* C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!
@@ -5931,50 +5853,6 @@ C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-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;
- C_uword nn1, nn2;
-
- C_check_uint(n1, f1, nn1, "bitwise-and");
- C_check_uint(n2, f2, nn2, "bitwise-and");
- nn1 = C_limit_fixnum(nn1 & nn2);
-
- if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
- else return C_flonum(a, nn1);
-}
-
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2)
-{
- double f1, f2;
- C_uword nn1, nn2;
-
- C_check_uint(n1, f1, nn1, "bitwise-ior");
- C_check_uint(n2, f2, nn2, "bitwise-ior");
- nn1 = C_limit_fixnum(nn1 | nn2);
-
- if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
- else return C_flonum(a, nn1);
-}
-
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2)
-{
- double f1, f2;
- C_uword nn1, nn2;
-
- C_check_uint(n1, f1, nn1, "bitwise-xor");
- C_check_uint(n2, f2, nn2, "bitwise-xor");
- nn1 = C_limit_fixnum(nn1 ^ nn2);
-
- if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
- else return C_flonum(a, nn1);
-}
-
/* Faster version that ignores sign in bignums. TODO: Omit labs() too? */
inline static int integer_length_abs(C_word x)
{
@@ -6102,19 +5980,6 @@ C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
}
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
-{
- double f;
- C_uword nn;
-
- C_check_uint(n, f, nn, "bitwise-not");
- nn = C_limit_fixnum(~nn);
-
- if(C_ufitsinfixnump(nn)) return C_fix(nn);
- else return C_flonum(a, nn);
-}
-
C_regparm C_word C_fcall
C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
{
@@ -6353,65 +6218,6 @@ C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)
}
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2)
-{
- C_word nn;
- C_uword unn;
- C_word s;
- int sgn = 1;
-
- if((n1 & C_FIXNUM_BIT) != 0) {
- nn = C_unfix(n1);
-
- if((sgn = nn < 0 ? -1 : 1) >= 0) unn = nn;
- }
- else if(C_immediatep(n1) || C_block_header(n1) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "arithmetic-shift", n1);
- else {
- double m, f;
-
- f = C_flonum_magnitude(n1);
-
- if(C_isnan(f) || C_isinf(f) || C_modf(f, &m) != 0.0)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
-
- if(f < C_WORD_MIN || f > C_UWORD_MAX)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
- else if(f < 0) {
- if(f > C_WORD_MAX)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
- else {
- sgn = -1;
- nn = (C_word)f;
- }
- }
- else if(f > C_WORD_MAX) unn = (C_uword)f;
- else {
- nn = (C_word)f;
- sgn = -1;
- }
- }
-
- if((n2 & C_FIXNUM_BIT) != 0) s = C_unfix(n2);
- else barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", n2);
-
- if(sgn < 0) {
- if(s < 0) nn >>= -s;
- else nn = (C_word)((C_uword)nn << s);
-
- if(C_fitsinfixnump(nn)) return C_fix(nn);
- else return C_flonum(a, nn);
- }
- else {
- if(s < 0) unn >>= -s;
- else unn <<= s;
-
- if(C_ufitsinfixnump(unn)) return C_fix(unn);
- else return C_flonum(a, unn);
- }
-}
-
C_regparm C_word C_fcall
C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)
{
@@ -7033,7 +6839,6 @@ C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word b
}
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)
{
if((x & C_FIXNUM_BIT) != 0) {
@@ -7073,83 +6878,6 @@ C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
-{
- double m, r;
-
- if((x & C_FIXNUM_BIT) != 0) return x;
-
- if(C_truep(C_i_bignump(x))) {
-#ifdef C_SIXTY_FOUR
- if (C_bignum_size(x) == 1) return x;
-#else
- if (C_bignum_size(x) <= 2) return x;
-#endif
- else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
- }
-
- /* XXX OBSOLETE: This should be removed on the next round */
- if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- m = C_flonum_magnitude(x);
-
- if(m >= C_S64_MIN && m <= C_S64_MAX && C_modf(m, &r) == 0.0) return x;
- }
-
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
- return C_SCHEME_UNDEFINED;
-}
-
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
-{
- double m ,r;
-
- if((x & C_FIXNUM_BIT) != 0) return x;
-
- if(C_truep(C_i_bignump(x))) {
- if (C_bignum_size(x) == 1) return x;
- else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
- }
-
- if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- m = C_flonum_magnitude(x);
-
- if(m >= 0 && m <= C_UWORD_MAX && C_modf(m, &r) == 0.0) return x;
- }
-
- barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
- return C_SCHEME_UNDEFINED;
-}
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
-{
- double m, r;
-
- if((x & C_FIXNUM_BIT) != 0) return x;
-
- if(C_truep(C_i_bignump(x))) {
-#ifdef C_SIXTY_FOUR
- if (C_bignum_size(x) == 1) return x;
-#else
- if (C_bignum_size(x) <= 2) return x;
-#endif
- else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
- }
-
- if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- m = C_flonum_magnitude(x);
-
- if(m >= 0 && m <= C_U64_MAX && C_modf(m, &r) == 0.0) return x;
- }
-
- barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
- return C_SCHEME_UNDEFINED;
-}
-
-
/* I */
C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
{
@@ -7879,35 +7607,6 @@ void C_ccall C_times(C_word c, C_word *av)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
-{
- C_word iresult;
-
- if(x & C_FIXNUM_BIT) {
- if(y & C_FIXNUM_BIT) {
- iresult = C_i_o_fixnum_times(x, y);
-
- if(iresult == C_SCHEME_FALSE)
- return C_flonum(ptr, (double)C_unfix(x) * (double)C_unfix(y));
- else return iresult;
- }
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
- }
- else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- if(y & C_FIXNUM_BIT)
- return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, C_flonum_magnitude(x) * C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
- /* shutup compiler */
- return C_flonum(ptr, 0.0/0.0);
-}
-
static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)
{
C_word size, result;
@@ -8213,35 +7912,6 @@ void C_ccall C_plus(C_word c, C_word *av)
C_kontinue(k, result);
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
-{
- C_word iresult;
-
- if(x & C_FIXNUM_BIT) {
- if(y & C_FIXNUM_BIT) {
- iresult = C_i_o_fixnum_plus(x, y);
-
- if(iresult == C_SCHEME_FALSE)
- return C_flonum(ptr, (double)C_unfix(x) + (double)C_unfix(y));
- else return iresult;
- }
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
- }
- else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- if(y & C_FIXNUM_BIT)
- return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, C_flonum_magnitude(x) + C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
- /* shutup compiler */
- return C_flonum(ptr, 0.0/0.0);
-}
-
static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)
{
C_word res, size;
@@ -8459,131 +8129,6 @@ void C_ccall C_minus(C_word c, C_word *av)
}
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
-{
- C_word iresult;
-
- if(x & C_FIXNUM_BIT) {
- if(y & C_FIXNUM_BIT) {
- iresult = C_i_o_fixnum_difference(x, y);
-
- if(iresult == C_SCHEME_FALSE)
- return C_flonum(ptr, (double)C_unfix(x) - (double)C_unfix(y));
- else return iresult;
- }
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
- }
- else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- if(y & C_FIXNUM_BIT)
- return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
- return C_flonum(ptr, C_flonum_magnitude(x) - C_flonum_magnitude(y));
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", x);
- /* shutup compiler */
- return C_flonum(ptr, 0.0/0.0);
-}
-
-
-
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-void C_ccall C_divide(C_word c, C_word *av)
-{
- C_word
- /* closure = av[ 0 ] */
- k = av[ 1 ],
- n1, n2,
- iresult, n3;
- int fflag;
- double fresult, f2;
- C_alloc_flonum;
-
- if(c < 3) C_bad_min_argc(c, 3);
-
- n1 = av[ 2 ];
-
- if(n1 & C_FIXNUM_BIT) {
- iresult = C_unfix(n1);
- fflag = 0;
- }
- else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
- fresult = C_flonum_magnitude(n1);
- fflag = 1;
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
-
- if(c == 3) {
- if(fflag) {
- if(fresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = 1.0 / fresult;
- }
- else {
- if(iresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
- else if(iresult == 1) C_kontinue(k, C_fix(1));
-
- fresult = 1.0 / (double)iresult;
- fflag = 1;
- }
-
- goto cont;
- }
-
- c -= 3;
- av += 3;
-
- while(c--) {
- n1 = *(av++);
-
- if(n1 & C_FIXNUM_BIT) {
- if(fflag) {
- if((n1 = C_unfix(n1)) == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult /= n1;
- }
- else {
- if((n2 = C_unfix(n1)) == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- n3 = iresult / n2;
-
- if((fresult = (double)iresult / (double)n2) != n3)
- fflag = 1;
- else iresult = n3;
- }
- }
- else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
- if(fflag) {
- if((f2 = C_flonum_magnitude(n1)) == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult /= f2;
- }
- else {
- fflag = 1;
-
- if((f2 = C_flonum_magnitude(n1)) == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = (double)iresult / f2;
- }
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
- }
-
- cont:
- if(fflag) {
- C_kontinue_flonum(k, fresult);
- }
- else n1 = C_fix(iresult);
-
- C_kontinue(k, n1);
-}
static C_regparm void
integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
@@ -9183,52 +8728,6 @@ bignum_divide_unsigned(C_word **ptr, C_word num, C_word denom, C_word *q, C_word
}
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-C_regparm C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y)
-{
- C_word iresult;
- double fresult;
- int fflag = 0;
-
- if(x & C_FIXNUM_BIT) {
- if(y & C_FIXNUM_BIT) {
- if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = (double)C_unfix(x) / (double)iresult;
- iresult = C_unfix(x) / iresult;
- }
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
- if((fresult = C_flonum_magnitude(y)) == 0.0)
- barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = (double)C_unfix(x) / fresult;
- fflag = 1;
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
- }
- else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
- fflag = 1;
-
- if(y & C_FIXNUM_BIT) {
- fresult = C_flonum_magnitude(x);
-
- if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = fresult / (double)iresult;
- }
- else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
- if((fresult = C_flonum_magnitude(y)) == 0.0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
-
- fresult = C_flonum_magnitude(x) / fresult;
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", x);
-
- if(fflag || (double)iresult != fresult) return C_flonum(ptr, fresult);
- else return C_fix(iresult);
-}
-
/* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */
static C_word rat_cmp(C_word x, C_word y)
{
@@ -10695,205 +10194,6 @@ C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)
}
-/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
-void C_ccall C_quotient(C_word c, C_word *av)
-{
- C_word
- /* closure = av[ 0 ] */
- k = av[ 1 ],
- n1, n2;
- double f1, f2, r;
- C_word result;
- C_alloc_flonum;
-
- if(c != 4) C_bad_argc(c, 4);
-
- n1 = av[ 2 ];
- n2 = av[ 3 ];
-
- if(n1 &C_FIXNUM_BIT) {
- if(n2 &C_FIXNUM_BIT) {
- if((n2 = C_unfix(n2)) == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
-
- result = C_fix(C_unfix(n1) / n2);
- C_kontinue(k, result);
- }
- else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) {
- f1 = (double)C_unfix(n1);
- f2 = C_flonum_magnitude(n2);
- if(C_isnan(f2) || C_isinf(f2) || C_modf(f2, &r) != 0.0)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n2);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2);
- }
- else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
- f1 = C_flonum_magnitude(n1);
- if(C_isnan(f1) || C_isinf(f1) || C_modf(f1, &r) != 0.0)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n1);
-
- if(n2 &C_FIXNUM_BIT)
- f2 = (double)C_unfix(n2);
- else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) {
- f2 = C_flonum_magnitude(n2);
- if(C_isnan(f2) || C_isinf(f2) || C_modf(f2, &r) != 0.0)
- barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n2);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2);
- }
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n1);
-
- if(f2 == 0)
- barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
-
- modf(f1 / f2, &r);
- C_kontinue_flonum(k, r);
-}
-
-
-/* TODO OBSOLETE XXX: This needs to go, but still translated by c-platform */
-C_regparm C_word C_fcall
-C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
-{
- int radix, radixpf = 0, sharpf = 0, ratf = 0, exactf = 0, exactpf = 0, periodf = 0, expf = 0;
- C_word n1, n;
- C_char *sptr, *eptr, *rptr;
- double fn1, fn;
-
- if(radix0 & C_FIXNUM_BIT) radix = C_unfix(radix0);
- else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "string->number", radix0);
-
- if (radix < 2 || radix > 36) /* Makes no sense and isn't supported */
- barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "string->number", radix0);
-
- if(C_immediatep(str) || C_header_bits(str) != C_STRING_TYPE)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->number", str);
-
- if((n = C_header_size(str)) == 0) {
- fail:
- n = C_SCHEME_FALSE;
- goto fini;
- }
-
- if(n >= STRING_BUFFER_SIZE - 1) goto fail;
-
- C_memcpy(sptr = buffer, C_c_string(str), n > (STRING_BUFFER_SIZE - 1) ? STRING_BUFFER_SIZE : n);
- buffer[ n ] = '\0';
- if (n != strlen(buffer)) /* Don't barf; this is simply invalid number syntax */
- goto fail;
-
- while(*sptr == '#') {
- switch(C_tolower((int)*(++sptr))) {
- case 'b': if(radixpf) goto fail; else { radix = 2; radixpf = 1; } break;
- case 'o': if(radixpf) goto fail; else { radix = 8; radixpf = 1; } break;
- case 'd': if(radixpf) goto fail; else { radix = 10; radixpf = 1; } break;
- case 'x': if(radixpf) goto fail; else { radix = 16; radixpf = 1; } break;
- case 'e': if(exactpf) goto fail; else { exactf = 1; exactpf = 1; } break;
- case 'i': if(exactpf) goto fail; else { exactf = 0; exactpf = 1; } break;
- default: goto fail; /* Unknown prefix type */
- }
-
- ++sptr;
- }
-
- /* Scan for embedded special characters and do basic sanity checking: */
- for(eptr = sptr, rptr = sptr; *eptr != '\0'; ++eptr) {
- switch(C_tolower((int)*eptr)) {
- case '.':
- if(periodf || ratf || expf) goto fail;
-
- periodf = 1;
- break;
-
- case '#':
- if (expf || (eptr == rptr) ||
- (!sharpf && (eptr == rptr+1) && (C_strchr("+-.", *rptr) != NULL)))
- goto fail;
-
- sharpf = 1;
- *eptr = '0';
-
- break;
- case '/':
- if(periodf || ratf || expf || eptr == sptr) goto fail;
-
- sharpf = 0; /* Allow sharp signs in the denominator */
- ratf = 1;
- rptr = eptr+1;
- break;
- case 'e':
- case 'd':
- case 'f':
- case 'l':
- case 's':
- /* Don't set exp flag if we see the "f" in "inf.0" (preceded by 'n') */
- /* Other failure modes are handled elsewhere. */
- if(radix == 10 && eptr > sptr && C_tolower((int)*(eptr-1)) != 'n') {
- if (ratf) goto fail;
-
- expf = 1;
- sharpf = 0;
- *eptr = 'e'; /* strtod() normally only understands 'e', not dfls */
- }
- break;
- default:
- if(sharpf) goto fail;
- break;
- }
- }
- if (eptr == rptr) goto fail; /* Disallow "empty" numbers like "#x" and "1/" */
-
- /* check for rational representation: */
- if(rptr != sptr) {
- if (*(rptr) == '-' || *(rptr) == '+') {
- n = C_SCHEME_FALSE;
- goto fini;
- }
- *(rptr-1) = '\0';
-
- switch(convert_string_to_number(sptr, radix, &n1, &fn1)) {
- case 0:
- n = C_SCHEME_FALSE;
- goto fini;
-
- case 1:
- fn1 = (double)n1;
- break;
-
- /* case 2: nop */
- }
-
- sptr = rptr;
- }
-
- /* convert number and return result: */
- switch(convert_string_to_number(sptr, radix, &n, &fn)) {
- case 0: /* failed */
- n = C_SCHEME_FALSE;
- break;
-
- case 1: /* fixnum */
- if(sharpf || ratf || (exactpf && !exactf)) {
- n = C_flonum(a, ratf ? fn1 / (double)n : (double)n);
-
- if(exactpf && exactf) n = maybe_inexact_to_exact(n);
- }
- else n = C_fix(n);
-
- break;
-
- case 2: /* flonum */
- n = C_flonum(a, ratf ? fn1 / fn : fn);
-
- if(exactpf && exactf) n = maybe_inexact_to_exact(n);
-
- break;
- }
-
- fini:
- return n;
-}
-
C_regparm C_word C_fcall
C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp)
{
--
2.1.4
From d18487287885220e71b43b8140d6160060df66d9 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 19 May 2017 14:21:32 +0200
Subject: [PATCH 2/4] Replace convert_string_to_number with simpler flonum-only
decoder
Now that decode_literal() no longer needs to be able to deal with the
case that compile-time fixnums might decode at runtime to flonums when
going from a 64-bit machine to a 32-bit machine, we can simplify this
code a lot.
We now also get rid of the "radix" parameter, because string->number
no longer relies on convert_string_to_number. We could have removed
"radix" sooner, but it made more sense to postpone until now.
Similarly, because we only ever need to decode literals produced by
the compiler, rather than arbitrary user input, we can radically
simplify the parsing: just call strtod() and be done with it. We only
need to take care about parsing nan and inf syntax, because ours might
not coincide with libc's.
The decode_literal() code itself is also slightly restructured:
originally, a "large fixnum" would be encoded as \xff\xfe...\0 and a
proper flonum would be encoded as just \xfe...\0. Now, we only need
to process the latter encoding. Unfortunately, because size is not
encoded in the string, we have to special-case the flonum type a
little bit: instead of adding it to the final switch(), we have to do
an if() check before the size is decoded.
---
runtime.c | 134 +++++++++++---------------------------------------------------
1 file changed, 22 insertions(+), 112 deletions(-)
diff --git a/runtime.c b/runtime.c
index c13115c..1bade1c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -517,7 +517,7 @@ static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int
static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
-static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
+static double C_fcall decode_flonum_literal(C_char *str) C_regparm;
static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);
static void C_fcall mark_system_globals(void) C_regparm;
static void C_fcall remark_system_globals(void) C_regparm;
@@ -10297,93 +10297,32 @@ str_to_bignum(C_word bignum, char *str, char *str_end, int radix)
return C_bignum_simplify(bignum);
}
-static int from_n_nary(C_char *str, int base, double *r)
-{
- double n = 0;
- C_char *ptr = str;
-
- while(*ptr != '\0') {
- int c = C_tolower((int)(*(ptr++)));
-
- if(c < '0') return 0;
- else if(c >= '0' + base) {
- if(base < 10) return 0;
- else if(c < 'a') return 0;
- else if(c >= 'a' + base - 10) return 0;
- else n = n * base + c - 'a' + 10;
- }
- else n = n * base + c - '0';
- }
-
- *r = n;
- return 1;
-}
-
-/* TODO OBSOLETE XXX: This needs to go, but still used in decode_literal */
-C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo)
+static C_regparm double C_fcall decode_flonum_literal(C_char *str)
{
- C_ulong ln;
- C_word n;
- C_char *eptr, *eptr2;
- double fn;
+ C_char *eptr;
+ double flo;
int len = C_strlen(str);
- if(radix == 10) {
- if (len == 6) {
- if((*str == '+' || *str == '-') &&
- C_strchr("inIN", *(str+1)) != NULL &&
- C_strchr("naNA", *(str+2)) != NULL &&
- C_strchr("fnFN", *(str+3)) != NULL &&
- *(str+4) == '.' && *(str+5) == '0') {
- if (*(str+1) == 'i' || *(str+1) == 'I') /* Inf */
- *flo = 1.0/0.0;
- else /* NaN */
- *flo = 0.0/0.0;
- if (*str == '-')
- *flo *= -1.0;
- return 2;
- }
- }
- /* Prevent C parser from accepting things like "-inf" on its own... */
- for(n = 0; n < len; ++n) {
- if (C_strchr("+-0123456789e.", *(str+n)) == NULL)
- return 0;
- }
+ /* We only need to be able to parse what C_flonum_to_string() emits,
+ * so we avoid too much error checking.
+ */
+ if (len == 6) { /* Only perform comparisons when necessary */
+ if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;
+ if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;
+ if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;
}
- if(C_strpbrk(str, "xX\0") != NULL) return 0;
-
errno = 0;
- n = C_strtow(str, &eptr, radix);
-
- if(((n == C_LONG_MAX || n == C_LONG_MIN) && errno != 0) || *eptr != '\0') {
- if(radix != 10)
- return from_n_nary(str, radix, flo) ? 2 : 0;
-
- errno = 0;
- fn = C_strtod(str, &eptr2);
+ flo = C_strtod(str, &eptr);
- if((fn == HUGE_VAL && errno != 0) || fn == -HUGE_VAL) return 0;
- else if(eptr2 == str) return 0;
- else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr2, ".0", C_strlen(eptr2)))) {
- *flo = fn;
- return 2;
- }
-
- return 0;
- }
- else if((n & C_INT_SIGN_BIT) != (((C_uword)n << 1) & C_INT_SIGN_BIT)) { /* doesn't fit into fixnum? */
- if(*eptr == '\0' || !C_strncmp(eptr, ".0", C_strlen(eptr))) {
- *flo = (double)n;
- return 2;
- }
- else return 0;
- }
- else {
- *fix = n;
- return 1;
+ if((flo == HUGE_VAL && errno != 0) ||
+ (flo == -HUGE_VAL && errno != 0) ||
+ (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {
+ panic(C_text("could not decode flonum literal"));
}
+
+ return flo;
}
@@ -11941,14 +11880,6 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
return C_fix(val);
#ifdef C_SIXTY_FOUR
- case (C_FLONUM_TYPE >> (24 + 32)) & 0xff:
-#else
- case (C_FLONUM_TYPE >> 24) & 0xff:
-#endif
- bits = C_FLONUM_TYPE;
- break;
-
-#ifdef C_SIXTY_FOUR
case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:
#else
case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:
@@ -11970,36 +11901,15 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
val = (C_word)(*ptr);
- if(bits == C_FLONUM_TYPE) {
- C_word ln;
- double fn;
-
- switch (convert_string_to_number(*str, 10, &ln, &fn)) {
- case 0: /* failed */
- panic(C_text("invalid encoded numeric literal"));
- break;
-
- /* XXX OBSOLETE: remove when we get rid of convert_string_to_number,
- * which can be done after recompilation when we know bignums are
- * always encoded as bignums. Then this can be moved to the switch()
- * below.
- */
- case 1: /* fixnum */
- val = C_fix(ln);
- break;
-
- case 2: /* flonum */
- val = C_flonum(ptr, fn);
- break;
- }
+ if((bits & C_SPECIALBLOCK_BIT) != 0)
+ panic(C_text("literals with special bit cannot be decoded"));
+ if(bits == C_FLONUM_TYPE) {
+ val = C_flonum(ptr, decode_flonum_literal(*str));
while(*((*str)++) != '\0'); /* skip terminating '\0' */
return val;
}
- if((bits & C_SPECIALBLOCK_BIT) != 0)
- panic(C_text("literals with special bit cannot be decoded"));
-
size = decode_size(str);
switch(bits) {
--
2.1.4
From be44bb44243bc4d91a1a650330c1f2bf61f1de3e Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 19 May 2017 15:19:45 +0200
Subject: [PATCH 3/4] Replace explicit complex number construction with
literals
This construction was necessary when compiling with an older CHICKEN
whose reader didn't support cplxnums.
---
library.scm | 22 ++++++++--------------
1 file changed, 8 insertions(+), 14 deletions(-)
diff --git a/library.scm b/library.scm
index 5daada9..f4ee0cd 100644
--- a/library.scm
+++ b/library.scm
@@ -1396,23 +1396,17 @@ EOF
(define (log a #!optional b)
(if b (##sys#/-2 (##sys#log-1 a) (##sys#log-1 b)) (##sys#log-1 a)))
-;; OBSOLETE: These can be removed after integration into core and
-;; bootstrapping, when the compiler can write these objects natively.
-(define %i (make-complex 0 1))
-(define %-i (make-complex 0 -1))
-(define %i2 (make-complex 0 2))
-
(define (sin n)
(##sys#check-number n 'sin)
(if (cplxnum? n)
- (let ((in (* %i n)))
- (##sys#/-2 (- (exp in) (exp (- in))) %i2))
+ (let ((in (* +i n)))
+ (##sys#/-2 (- (exp in) (exp (- in))) +2i))
(##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact n))))
(define (cos n)
(##sys#check-number n 'cos)
(if (cplxnum? n)
- (let ((in (* %i n)))
+ (let ((in (* +i n)))
(##sys#/-2 (+ (exp in) (exp (- in))) 2) )
(##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact n))))
@@ -1432,9 +1426,9 @@ EOF
(##core#inline_allocate
("C_a_i_fix_to_flo" 4) n)))
;; General definition can return compnums
- (else (* %-i (##sys#log-1
- (+ (* %i n)
- (##sys#sqrt/loc 'asin (- 1 (* n n)))))))))
+ (else (* -i (##sys#log-1
+ (+ (* +i n)
+ (##sys#sqrt/loc 'asin (- 1 (* n n))) ) ))) ) )
;; General case:
;; cos^{-1}(z) = 1/2\pi + i\ln(iz + \sqrt{1-z^2}) = 1/2\pi - sin^{-1}(z) = sin(1) - sin(z)
@@ -1456,9 +1450,9 @@ EOF
(cond ((cplxnum? n)
(if b
(##sys#error-bad-real n 'atan)
- (let ((in (* %i n)))
+ (let ((in (* +i n)))
(##sys#/-2 (- (##sys#log-1 (+ 1 in))
- (##sys#log-1 (- 1 in))) %i2))))
+ (##sys#log-1 (- 1 in))) +2i))))
(b
(##core#inline_allocate
("C_a_i_atan2" 4) (exact->inexact n) (exact->inexact b)))
--
2.1.4
From 163b2ec5f46185d17f530ebd07073364c0063bb6 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 19 May 2017 15:49:59 +0200
Subject: [PATCH 4/4] Ensure some functions marked OBSOLETE are really unused
These were supposed to have been removed before, but they were still
used in the compiler.
C_u_i_positivep and C_u_i_evenp, as well as C_u_i_evenp and C_u_i_oddp
are supposed to be unsafe faster variants of their C_i_-prefixed
brethren, but because the type analysis is more complicated now that
we have more than 2 numeric types, the additional error check is not
worthwhile to leave off.
C_i_foreign_integer_argumentp and ##sys#foreign-integer-argument
(which is its Scheme procedure) were still used by the "enum" foreign
type specifier. This has now been replaced by a ranged integer check.
According to the C spec, enums are represented exactly as integers, so
we just use the same range as integers. The test suite was lacking a
test for the enum foreign type, so this patch adds that as well.
Finally, the rewrites for C_i_zerop and C_u_i_zerop were the wrong way
around. Our rewrites are applied in order, and a safe rewrite is
always allowed, so it would never get to the unsafe rewrite. We fix
this by swapping them. Now, the unsafe rewrite is considered first,
and if we're in safe mode, we reject it and try the safe one instead.
---
c-platform.scm | 8 +++-----
library.scm | 2 +-
support.scm | 7 ++++++-
tests/compiler-tests.scm | 6 ++++++
4 files changed, 16 insertions(+), 7 deletions(-)
diff --git a/c-platform.scm b/c-platform.scm
index ee4f661..b8b120c 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -596,16 +596,14 @@
(rewrite 'chicken.flonum#fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum)
(rewrite 'zero? 5 "C_eqp" 0 'fixnum)
-(rewrite 'zero? 2 1 "C_i_zerop" #t)
(rewrite 'zero? 2 1 "C_u_i_zerop" #f)
+(rewrite 'zero? 2 1 "C_i_zerop" #t)
(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum)
(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum)
(rewrite 'positive? 2 1 "C_i_positivep" #t)
-(rewrite 'positive? 2 1 "C_u_i_positivep" #f)
(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum)
(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum)
(rewrite 'negative? 2 1 "C_i_negativep" #t)
-(rewrite 'negative? 2 1 "C_u_i_negativep" #f)
(rewrite 'vector-length 6 "C_fix" "C_header_size" #f)
(rewrite 'string-length 6 "C_fix" "C_header_size" #f)
@@ -707,8 +705,8 @@
(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")
-(rewrite 'even? 17 1 "C_i_evenp" "C_u_i_evenp")
-(rewrite 'odd? 17 1 "C_i_oddp" "C_u_i_oddp")
+(rewrite 'even? 17 1 "C_i_evenp")
+(rewrite 'odd? 17 1 "C_i_oddp")
(rewrite 'chicken.fixnum#fxodd? 2 1 "C_i_fixnumoddp" #t)
(rewrite 'chicken.fixnum#fxeven? 2 1 "C_i_fixnumevenp" #t)
diff --git a/library.scm b/library.scm
index f4ee0cd..5bd22f5 100644
--- a/library.scm
+++ b/library.scm
@@ -5012,7 +5012,7 @@ EOF
(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))
-;; OBSOLETE (but still used by "enum"
+;; OBSOLETE
(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
(define (##sys#foreign-ranged-integer-argument obj size)
diff --git a/support.scm b/support.scm
index 0048836..6d6ed8a 100644
--- a/support.scm
+++ b/support.scm
@@ -1102,7 +1102,12 @@
`(slot-ref ,param 'this) )
((const) (repeat (cadr t)))
((enum)
- (if unsafe param `(##sys#foreign-integer-argument ,param)))
+ (if unsafe
+ param
+ `(##sys#foreign-ranged-integer-argument
+ ;; enums are integer size, according to
+ ;; the C standard.
+ ,param (foreign-value "sizeof(int) * CHAR_BIT" int))))
((nonnull-pointer nonnull-c-pointer)
`(##sys#foreign-pointer-argument ,param) )
(else param) ) )
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index a744449..9d92afc 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -107,6 +107,8 @@
;; Type specifiers and variable names in foreign-lambda in macros
;; are incorrectly renamed in modules, too.
(foreign-declare "void foo(void *abc) { printf(\"hi\\n\"); }")
+;; This is silly but at least it ensures we can represent enum values
+(foreign-declare "enum intlimits {min=INT_MIN, zero=0, max=INT_MAX};")
(module foo ()
(import chicken scheme foreign) ; "chicken" includes an export for "void"
@@ -345,6 +347,10 @@
integer signed (foreign-value "sizeof(int) * CHAR_BIT" int))
(test-ffi-type-limits
+ (enum intlimits) signed
+ (foreign-value "sizeof(enum intlimits) * CHAR_BIT" int))
+
+(test-ffi-type-limits
unsigned-long unsigned
(foreign-value "sizeof(unsigned long) * CHAR_BIT" int))
--
2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
