From 7d98aaabf9ff90faa23fb26c70c1090d68c3c2dd Mon Sep 17 00:00:00 2001 From: Peter Bex 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" -) ;; (arithmetic-shift <+int>) ;; -> (##core#inline "C_fixnum_shift_left" ) - ;; _ -> (##core#inline "C_a_i_arithmetic_shift" ) + ;; _ -> (##core#inline "C_i_fixnum_arithmetic_shift" ) ;; ;; not in fixnum-mode: ;; _ -> (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) ) 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