From 3cc600e17a0f8598e173a658af8a2bdc0709a4cc Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Mon, 8 Aug 2016 22:33:41 +0200 Subject: [PATCH 2/2] Change ratnum and cplxnum representation to also use custom types. Same change as bignums. This eats up two more reserved type tags, resulting in more pre-allocation savings, about as much as with the bignum change. The performance gains on code that *doesn't* use these numeric types are minimal, but it really cleans up the code; the numeric ops are now much less branchy, and it changes 2 checks to 1 check for every case where a ratnum or a cplxnum is involved. In total, this is a net removal of 100 lines of code. While at it, this also replaces direct C_block_item(x, n) calls with more opaque/abstract C_u_i_ratnum_{num,denom} and C_u_i_cplxnum_{real,imag} helper macros. This would make it easier to change the representation in the future. Currently only the eqv? implementation directly accesses the slots to keep the code simpler. --- c-backend.scm | 7 + c-platform.scm | 6 +- chicken.h | 96 +++++---- library.scm | 18 +- runtime.c | 649 ++++++++++++++++++++++++--------------------------------- types.db | 45 ++-- 6 files changed, 361 insertions(+), 460 deletions(-) diff --git a/c-backend.scm b/c-backend.scm index f58d3d4..9b09312 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -690,6 +690,13 @@ (if (>= i n) s (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) ) + ;; We could access rat/cplx slots directly, but let's not. + ((ratnum? lit) (+ (##sys#size lit) + (literal-size (numerator lit)) + (literal-size (denominator lit)))) + ((cplxnum? lit) (+ (##sys#size lit) + (literal-size (real-part lit)) + (literal-size (imag-part lit)))) (else (bad-literal lit))) ) (define (gen-lit lit to) diff --git a/c-platform.scm b/c-platform.scm index d929651..25098e4 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -674,9 +674,9 @@ (rewrite 'lcm 18 1) (rewrite 'list 18 '()) -(rewrite '+ 16 2 "C_s_a_i_plus" #t 32) -(rewrite '- 16 2 "C_s_a_i_minus" #t 32) -(rewrite '* 16 2 "C_s_a_i_times" #t 36) +(rewrite '+ 16 2 "C_s_a_i_plus" #t 29) +(rewrite '- 16 2 "C_s_a_i_minus" #t 29) +(rewrite '* 16 2 "C_s_a_i_times" #t 33) (rewrite 'quotient 16 2 "C_s_a_i_quotient" #t 5) (rewrite 'remainder 16 2 "C_s_a_i_remainder" #t 5) (rewrite 'modulo 16 2 "C_s_a_i_modulo" #t 5) diff --git a/chicken.h b/chicken.h index 96a03ea..2740d91 100644 --- a/chicken.h +++ b/chicken.h @@ -470,9 +470,9 @@ static inline int isinf_ld (long double x) # define C_POINTER_TYPE (0x0900000000000000L | C_SPECIALBLOCK_BIT) # define C_LOCATIVE_TYPE (0x0a00000000000000L | C_SPECIALBLOCK_BIT) # define C_TAGGED_POINTER_TYPE (0x0b00000000000000L | C_SPECIALBLOCK_BIT) -/* unused (0x0c00000000000000L ...) */ +# define C_RATNUM_TYPE (0x0c00000000000000L) # define C_LAMBDA_INFO_TYPE (0x0d00000000000000L | C_BYTEBLOCK_BIT) -/* unused (0x0e00000000000000L ...) */ +# define C_CPLXNUM_TYPE (0x0e00000000000000L) /* unused (0x0f00000000000000L ...) */ #else # define C_INT_SIGN_BIT 0x80000000 @@ -500,9 +500,9 @@ static inline int isinf_ld (long double x) # define C_POINTER_TYPE (0x09000000 | C_SPECIALBLOCK_BIT) # define C_LOCATIVE_TYPE (0x0a000000 | C_SPECIALBLOCK_BIT) # define C_TAGGED_POINTER_TYPE (0x0b000000 | C_SPECIALBLOCK_BIT) -/* unused (0x0c000000 ...) */ +# define C_RATNUM_TYPE (0x0c000000) # define C_LAMBDA_INFO_TYPE (0x0d000000 | C_BYTEBLOCK_BIT) -/* unused (0x0e000000 ...) */ +# define C_CPLXNUM_TYPE (0x0e000000) /* unused (0x0f000000 ...) */ #endif #define C_VECTOR_TYPE 0x00000000 @@ -523,6 +523,8 @@ static inline int isinf_ld (long double x) #define C_SIZEOF_VECTOR(n) ((n) + 1) #define C_SIZEOF_LOCATIVE 5 #define C_SIZEOF_PORT 16 +#define C_SIZEOF_RATNUM 3 +#define C_SIZEOF_CPLXNUM 3 #define C_SIZEOF_STRUCTURE(n) ((n)+1) #define C_SIZEOF_CLOSURE(n) ((n)+1) #define C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n) (C_SIZEOF_VECTOR((n)+1)) @@ -542,8 +544,8 @@ static inline int isinf_ld (long double x) #define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1)) #define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double)) #define C_BIGNUM_TAG (C_BIGNUM_TYPE | 1) -#define C_STRUCTURE3_TAG (C_STRUCTURE_TYPE | 3) -#define C_STRUCTURE2_TAG (C_STRUCTURE_TYPE | 2) +#define C_RATNUM_TAG (C_RATNUM_TYPE | 2) +#define C_CPLXNUM_TAG (C_CPLXNUM_TYPE | 2) /* Locative subtypes */ #define C_SLOT_LOCATIVE 0 @@ -1307,6 +1309,10 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_block_size(x) C_fix(C_header_size(x)) #define C_u_i_bignum_size(b) C_fix(C_bignum_size(b)) #define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b)) +#define C_u_i_ratnum_num(r) C_block_item((r), 0) +#define C_u_i_ratnum_denom(r) C_block_item((r), 1) +#define C_u_i_cplxnum_real(c) C_block_item((c), 0) +#define C_u_i_cplxnum_imag(c) C_block_item((c), 1) #define C_pointer_address(x) ((C_byte *)C_block_item((x), 0)) #define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x) #define C_offset_pointer(x, y) (C_pointer_address(x) + (y)) @@ -1378,7 +1384,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; # define C_a_i_cons(a, n, car, cdr) C_a_pair(a, car, cdr) #endif /* HAVE_STATEMENT_EXPRESSIONS */ -#define C_a_i_flonum(ptr, i, n) C_flonum(ptr, n) +#define C_a_i_flonum(ptr, c, n) C_flonum(ptr, n) +#define C_a_i_ratnum(ptr, c, n, d) C_ratnum(ptr, n, d) +#define C_a_i_cplxnum(ptr, c, r, i) C_cplxnum(ptr, r, i) #define C_a_i_data_mpointer(ptr, n, x) C_mpointer(ptr, C_data_pointer(x)) #define C_a_i_fix_to_flo(p, n, f) C_flonum(p, C_unfix(f)) #define C_cast_to_flonum(n) ((double)(n)) @@ -1735,9 +1743,7 @@ C_varextern C_TLS C_word *C_scratchspace_start, *C_scratchspace_top, *C_scratchspace_limit, - C_scratch_usage, - C_ratnum_type_tag, - C_cplxnum_type_tag; + C_scratch_usage; C_varextern C_TLS C_long C_timer_interrupt_counter, C_initial_timer_interrupt_period; @@ -2428,14 +2434,26 @@ C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word return (C_word)p0; } -C_inline C_word C_cplxnum(C_word **ptr, C_word x, C_word y) +C_inline C_word C_cplxnum(C_word **ptr, C_word r, C_word i) { - return C_a_i_record3(ptr, 2, C_cplxnum_type_tag, x, y); + C_word *p = *ptr, *p0 = p; + + *(p++) = C_CPLXNUM_TAG; + *(p++) = r; + *(p++) = i; + *ptr = p; + return (C_word)p0; } -C_inline C_word C_ratnum(C_word **ptr, C_word x, C_word y) +C_inline C_word C_ratnum(C_word **ptr, C_word n, C_word d) { - return C_a_i_record3(ptr, 2, C_ratnum_type_tag, x, y); + C_word *p = *ptr, *p0 = p; + + *(p++) = C_RATNUM_TAG; + *(p++) = n; + *(p++) = d; + *ptr = p; + return (C_word)p0; } C_inline C_word C_a_i_bignum_wrapper(C_word **ptr, C_word vec) @@ -2766,12 +2784,10 @@ C_inline C_word C_i_eqvp(C_word x, C_word y) return C_mk_bool(basic_eqvp(x, y) || (!C_immediatep(x) && !C_immediatep(y) && C_block_header(x) == C_block_header(y) && - C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag || - C_block_item(x, 0) == C_cplxnum_type_tag) && - C_block_item(x, 0) == C_block_item(y, 0) && - basic_eqvp(C_block_item(x, 1), C_block_item(y, 1)) && - basic_eqvp(C_block_item(x, 2), C_block_item(y, 2)))); + (C_block_header(x) == C_RATNUM_TAG || + C_block_header(x) == C_CPLXNUM_TAG) && + basic_eqvp(C_block_item(x, 0), C_block_item(y, 0)) && + basic_eqvp(C_block_item(x, 1), C_block_item(y, 1)))); } C_inline C_word C_i_symbolp(C_word x) @@ -2828,9 +2844,8 @@ C_inline C_word C_i_numberp(C_word x) (!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG || C_block_header(x) == C_BIGNUM_TAG || - (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag || - C_block_item(x, 0) == C_cplxnum_type_tag))))); + C_block_header(x) == C_RATNUM_TAG || + C_block_header(x) == C_CPLXNUM_TAG))); } /* All numbers are real, except for cplxnums */ @@ -2840,8 +2855,7 @@ C_inline C_word C_i_realp(C_word x) (!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG || C_block_header(x) == C_BIGNUM_TAG || - (C_block_header(x) == C_STRUCTURE3_TAG && - C_block_item(x, 0) == C_ratnum_type_tag)))); + C_block_header(x) == C_RATNUM_TAG))); } /* All finite real numbers are rational */ @@ -2856,8 +2870,7 @@ C_inline C_word C_i_rationalp(C_word x) return C_mk_bool(!C_isinf(n) && !C_isnan(n)); } else { return C_mk_bool(C_block_header(x) == C_BIGNUM_TAG || - (C_block_header(x) == C_STRUCTURE3_TAG && - C_block_item(x, 0) == C_ratnum_type_tag)); + C_block_header(x) == C_RATNUM_TAG); } } @@ -2892,18 +2905,16 @@ C_inline C_word C_u_i_exactp(C_word x) return C_SCHEME_TRUE; } else if (C_block_header(x) == C_FLONUM_TAG) { return C_SCHEME_FALSE; - } else if (C_block_header(x) != C_STRUCTURE3_TAG) { - return C_SCHEME_FALSE; - } else if (C_block_item(x, 0) == C_ratnum_type_tag) { + } else if (C_block_header(x) == C_RATNUM_TAG) { return C_SCHEME_TRUE; - } else if (C_block_item(x, 0) != C_cplxnum_type_tag) { - return C_SCHEME_FALSE; - } else { - x = C_block_item(x, 1); + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + x = C_u_i_cplxnum_real(x); /* r and i are always the same exactness, and we assume they * always store a number. */ return C_mk_bool(C_immediatep(x) || (C_block_header(x) != C_FLONUM_TAG)); + } else { + return C_SCHEME_FALSE; } } @@ -2913,12 +2924,11 @@ C_inline C_word C_u_i_inexactp(C_word x) return C_SCHEME_FALSE; } else if (C_block_header(x) == C_FLONUM_TAG) { return C_SCHEME_TRUE; - } else if (C_block_header(x) != C_STRUCTURE3_TAG || - C_block_item(x, 0) != C_cplxnum_type_tag) { - return C_SCHEME_FALSE; - } else { - x = C_block_item(x, 1); /* r and i are always the same exactness */ + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + x = C_u_i_cplxnum_real(x); /* r and i are always the same exactness */ return C_mk_bool(!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG)); + } else { + return C_SCHEME_FALSE; } } @@ -2945,16 +2955,12 @@ C_inline C_word C_i_flonump(C_word x) C_inline C_word C_i_cplxnump(C_word x) { - return C_mk_bool(!C_immediatep(x) && - C_block_header(x) == C_STRUCTURE3_TAG && - C_block_item(x, 0) == C_cplxnum_type_tag); + return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_CPLXNUM_TAG); } C_inline C_word C_i_ratnump(C_word x) { - return C_mk_bool(!C_immediatep(x) && - C_block_header(x) == C_STRUCTURE3_TAG && - C_block_item(x, 0) == C_ratnum_type_tag); + return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_RATNUM_TAG); } /* TODO: Is this correctly named? Shouldn't it accept an argcount? */ diff --git a/library.scm b/library.scm index 81622bb..2b976b4 100644 --- a/library.scm +++ b/library.scm @@ -1016,15 +1016,15 @@ EOF ;;; Complex numbers -(define-inline (%cplxnum-real c) (##sys#slot c 1)) -(define-inline (%cplxnum-imag c) (##sys#slot c 2)) +(define-inline (%cplxnum-real c) (##core#inline "C_u_i_cplxnum_real" c)) +(define-inline (%cplxnum-imag c) (##core#inline "C_u_i_cplxnum_imag" c)) (define (make-complex r i) (if (or (eq? i 0) (and (##core#inline "C_i_flonump" i) (fp= i 0.0))) r - (##sys#make-structure '##sys#cplxnum - (if (inexact? i) (exact->inexact r) r) - (if (inexact? r) (exact->inexact i) i)) ) ) + (##core#inline_allocate ("C_a_i_cplxnum" 3) + (if (inexact? i) (exact->inexact r) r) + (if (inexact? r) (exact->inexact i) i)) ) ) (define (make-rectangular r i) (##sys#check-real r 'make-rectangular) @@ -1066,9 +1066,9 @@ EOF ;;; Rational numbers -(define-inline (%ratnum-numerator c) (##sys#slot c 1)) -(define-inline (%ratnum-denominator c) (##sys#slot c 2)) -(define-inline (%make-ratnum r i) (##sys#make-structure '##sys#ratnum r i)) +(define-inline (%ratnum-numerator r) (##core#inline "C_u_i_ratnum_num" r)) +(define-inline (%ratnum-denominator r) (##core#inline "C_u_i_ratnum_denom" r)) +(define-inline (%make-ratnum n d) (##core#inline_allocate ("C_a_i_ratnum" 3) n d)) (define (ratnum m n) (cond @@ -1173,7 +1173,7 @@ EOF (define-inline (%integer-gcd a b) (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) a b)) -(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 9) x)) +(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 7) x)) (define (/ arg1 . args) (if (null? args) diff --git a/runtime.c b/runtime.c index ee84a20..0bc2a15 100644 --- a/runtime.c +++ b/runtime.c @@ -339,9 +339,7 @@ C_TLS C_word *C_scratchspace_start, *C_scratchspace_top, *C_scratchspace_limit, - C_scratch_usage, - C_ratnum_type_tag, - C_cplxnum_type_tag; + C_scratch_usage; C_TLS C_long C_timer_interrupt_counter, C_initial_timer_interrupt_period; @@ -1125,8 +1123,6 @@ void initialize_symbol_table(void) for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST); /* Obtain reference to hooks for later: */ - C_ratnum_type_tag = C_intern2(C_heaptop, C_text("\003sysratnum")); - C_cplxnum_type_tag = C_intern2(C_heaptop, C_text("\003syscplxnum")); core_provided_symbol = C_intern2(C_heaptop, C_text("\004coreprovided")); interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook")); error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook")); @@ -3607,8 +3603,6 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c) C_regparm void C_fcall mark_system_globals(void) { - mark(&C_ratnum_type_tag); - mark(&C_cplxnum_type_tag); mark(&core_provided_symbol); mark(&interrupt_hook_symbol); mark(&error_hook_symbol); @@ -3941,8 +3935,6 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize) C_regparm void C_fcall remark_system_globals(void) { - remark(&C_ratnum_type_tag); - remark(&C_cplxnum_type_tag); remark(&core_provided_symbol); remark(&interrupt_hook_symbol); remark(&error_hook_symbol); @@ -5322,14 +5314,11 @@ C_regparm C_word C_fcall C_i_nanp(C_word x) return C_u_i_flonum_nanp(x); } else if (C_truep(C_bignump(x))) { return C_SCHEME_FALSE; - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) - return C_SCHEME_FALSE; - else if (C_block_item(x, 0) == C_cplxnum_type_tag) - return C_mk_bool(C_truep(C_i_nanp(C_block_item(x, 1))) || - C_truep(C_i_nanp(C_block_item(x, 2)))); - else - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_SCHEME_FALSE; + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) || + C_truep(C_i_nanp(C_u_i_cplxnum_imag(x)))); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x); } @@ -5345,14 +5334,11 @@ C_regparm C_word C_fcall C_i_finitep(C_word x) return C_u_i_flonum_finitep(x); } else if (C_truep(C_bignump(x))) { return C_SCHEME_TRUE; - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) - return C_SCHEME_TRUE; - else if (C_block_item(x, 0) == C_cplxnum_type_tag) - return C_and(C_i_finitep(C_block_item(x, 1)), - C_i_finitep(C_block_item(x, 2))); - else - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_SCHEME_TRUE; + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_and(C_i_finitep(C_u_i_cplxnum_real(x)), + C_i_finitep(C_u_i_cplxnum_imag(x))); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x); } @@ -5368,14 +5354,11 @@ C_regparm C_word C_fcall C_i_infinitep(C_word x) return C_u_i_flonum_infinitep(x); } else if (C_truep(C_bignump(x))) { return C_SCHEME_FALSE; - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) - return C_SCHEME_FALSE; - else if (C_block_item(x, 0) == C_cplxnum_type_tag) - return C_mk_bool(C_truep(C_i_infinitep(C_block_item(x, 1))) || - C_truep(C_i_infinitep(C_block_item(x, 2)))); - else - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_SCHEME_FALSE; + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) || + C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x)))); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x); } @@ -5391,13 +5374,10 @@ C_regparm C_word C_fcall C_i_exactp(C_word x) return C_SCHEME_FALSE; } else if (C_truep(C_bignump(x))) { return C_SCHEME_TRUE; - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) - return C_SCHEME_TRUE; - else if (C_block_item(x, 0) == C_cplxnum_type_tag) - return C_i_exactp(C_block_item(x, 1)); /* Exactness of i and r matches */ - else - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_SCHEME_TRUE; + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */ } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x); } @@ -5414,13 +5394,10 @@ C_regparm C_word C_fcall C_i_inexactp(C_word x) return C_SCHEME_TRUE; } else if (C_truep(C_bignump(x))) { return C_SCHEME_FALSE; - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) - return C_SCHEME_FALSE; - else if (C_block_item(x, 0) == C_cplxnum_type_tag) - return C_i_inexactp(C_block_item(x, 1)); /* Exactness of i and r matches */ - else - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_SCHEME_FALSE; + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */ } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x); } @@ -5435,10 +5412,9 @@ C_regparm C_word C_fcall C_i_zerop(C_word x) barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x); } else if (C_block_header(x) == C_FLONUM_TAG) { return C_mk_bool(C_flonum_magnitude(x) == 0.0); - } else if (C_truep(C_bignump(x)) || - (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag || - C_block_item(x, 0) == C_cplxnum_type_tag))) { + } else if (C_block_header(x) == C_BIGNUM_TAG || + C_block_header(x) == C_RATNUM_TAG || + C_block_header(x) == C_CPLXNUM_TAG) { return C_SCHEME_FALSE; } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x); @@ -5465,11 +5441,9 @@ C_regparm C_word C_fcall C_i_positivep(C_word x) return C_mk_bool(C_flonum_magnitude(x) > 0.0); else if (C_truep(C_bignump(x))) return C_mk_nbool(C_bignum_negativep(x)); - else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag)) - return C_i_integer_positivep(C_block_item(x, 1)); - else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_cplxnum_type_tag)) + else if (C_block_header(x) == C_RATNUM_TAG) + return C_i_integer_positivep(C_u_i_ratnum_num(x)); + else if (C_block_header(x) == C_CPLXNUM_TAG) barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x); else barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x); @@ -5498,11 +5472,9 @@ C_regparm C_word C_fcall C_i_negativep(C_word x) return C_mk_bool(C_flonum_magnitude(x) < 0.0); else if (C_truep(C_bignump(x))) return C_mk_bool(C_bignum_negativep(x)); - else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag)) - return C_i_integer_negativep(C_block_item(x, 1)); - else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_cplxnum_type_tag)) + else if (C_block_header(x) == C_RATNUM_TAG) + return C_i_integer_negativep(C_u_i_ratnum_num(x)); + else if (C_block_header(x) == C_CPLXNUM_TAG) barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x); else barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x); @@ -5974,7 +5946,7 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x) return C_SCHEME_UNDEFINED; } -/* This needs at most C_SIZEOF_FIX_BIGNUM + C_SIZEOF_STRUCTURE(3) so 9 words */ +/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */ C_regparm C_word C_fcall C_s_a_i_abs(C_word **ptr, C_word n, C_word x) { @@ -5986,12 +5958,10 @@ C_s_a_i_abs(C_word **ptr, C_word n, C_word x) return C_a_i_flonum_abs(ptr, 1, x); } else if (C_truep(C_bignump(x))) { return C_s_a_u_i_integer_abs(ptr, 1, x); - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag)) { - return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_block_item(x, 1)), - C_block_item(x, 2)); - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_cplxnum_type_tag)) { + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)), + C_u_i_ratnum_denom(x)); + } else if (C_block_header(x) == C_CPLXNUM_TAG) { barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x); @@ -6035,7 +6005,7 @@ C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word 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_STRUCTURE(3) * 3 + C_SIZEOF_FIX_BIGNUM * 4 = 32 words! + * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words! */ C_regparm C_word C_fcall C_s_a_i_negate(C_word **ptr, C_word n, C_word x) @@ -6048,14 +6018,12 @@ C_s_a_i_negate(C_word **ptr, C_word n, C_word x) return C_a_i_flonum_negate(ptr, 1, x); } else if (C_truep(C_bignump(x))) { return C_s_a_u_i_integer_negate(ptr, 1, x); - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag)) { - return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_block_item(x, 1)), - C_block_item(x, 2)); - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_cplxnum_type_tag)) { - return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_block_item(x, 1)), - C_s_a_i_negate(ptr, 1, C_block_item(x, 2))); + } else if (C_block_header(x) == C_RATNUM_TAG) { + return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)), + C_u_i_ratnum_denom(x)); + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)), + C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x))); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); } @@ -7669,13 +7637,13 @@ static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i) case C_fix(0): return C_fix(0); case C_fix(1): return rat; case C_fix(-1): - num = C_s_a_u_i_integer_negate(ptr, 1, C_block_item(rat, 1)); - return C_ratnum(ptr, num , C_block_item(rat, 2)); + num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat)); + return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat)); /* default: CONTINUE BELOW */ } - num = C_block_item(rat, 1); - denom = C_block_item(rat, 2); + num = C_u_i_ratnum_num(rat); + denom = C_u_i_ratnum_denom(rat); /* a/b * c/d = a*c / b*d [with b = 1] */ /* = ((a / g) * c) / (d / g) */ @@ -7711,10 +7679,10 @@ static C_word rat_times_rat(C_word **ptr, C_word x, C_word y) num, denom, xnum, xdenom, ynum, ydenom, g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1; - xnum = C_block_item(x, 1); - xdenom = C_block_item(x, 2); - ynum = C_block_item(y, 1); - ydenom = C_block_item(y, 2); + xnum = C_u_i_ratnum_num(x); + xdenom = C_u_i_ratnum_denom(x); + ynum = C_u_i_ratnum_num(y); + ydenom = C_u_i_ratnum_denom(y); /* a/b * c/d = a*c / b*d [generic] */ /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */ @@ -7761,9 +7729,9 @@ cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy) { /* Allocation here is kind of tricky: Each intermediate result can * be at most a ratnum consisting of two bignums (2 digits), so - * C_SIZEOF_STRUCTURE(3) + C_SIZEOF_BIGNUM(2) = 10 words + * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words */ - C_word ab[(C_SIZEOF_STRUCTURE(3) + C_SIZEOF_BIGNUM(2))*6], *a = ab, + C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab, r1, r2, i1, i2, r, i; /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */ @@ -7792,7 +7760,7 @@ cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy) * number result, where both real and imag parts consist of ratnums. * The maximum size of those ratnums is if they consist of two bignums * from a fixnum multiplication (2 digits each), so we're looking at - * C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_BIGNUM(2) * 4 = 36 words! + * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words! */ C_regparm C_word C_fcall C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) @@ -7806,15 +7774,11 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_times(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_times_integer(ptr, y, x); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - return cplx_times(ptr, x, C_fix(0), - C_block_item(y, 1), C_block_item(y, 2)); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_times_integer(ptr, y, x); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + return cplx_times(ptr, x, C_fix(0), + C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); } @@ -7829,16 +7793,12 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) return C_a_i_flonum_times(ptr, 2, x, y); } else if (C_truep(C_bignump(y))) { return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y)); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word ab[C_SIZEOF_FLONUM], *a = ab; - return cplx_times(ptr, x, C_flonum(&a, 0.0), - C_block_item(y, 1), C_block_item(y, 2)); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word ab[C_SIZEOF_FLONUM], *a = ab; + return cplx_times(ptr, x, C_flonum(&a, 0.0), + C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); } @@ -7851,52 +7811,39 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_times(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_times_integer(ptr, y, x); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - return cplx_times(ptr, x, C_fix(0), - C_block_item(y, 1), C_block_item(y, 2)); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_times_integer(ptr, y, x); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + return cplx_times(ptr, x, C_fix(0), + C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); } - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) { - if (y & C_FIXNUM_BIT) { - return rat_times_integer(ptr, x, y); - } else if (C_immediatep(y)) { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } else if (C_block_header(y) == C_FLONUM_TAG) { - return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); - } else if (C_truep(C_bignump(y))) { - return rat_times_integer(ptr, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_times_rat(ptr, x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - return cplx_times(ptr, x, C_fix(0), - C_block_item(y, 1),C_block_item(y, 2)); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); - } - } else if (C_block_item(x, 0) == C_cplxnum_type_tag) { - if (!C_immediatep(y) && C_block_header(y) == C_STRUCTURE3_TAG && - C_block_item(y, 0) == C_cplxnum_type_tag) { - return cplx_times(ptr, C_block_item(x, 1), C_block_item(x, 2), - C_block_item(y, 1), C_block_item(y, 2)); - } else { - C_word ab[C_SIZEOF_FLONUM], *a = ab, yi; - yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0); - return cplx_times(ptr, C_block_item(x, 1), C_block_item(x, 2), y, yi); - } + } else if (C_block_header(x) == C_RATNUM_TAG) { + if (y & C_FIXNUM_BIT) { + return rat_times_integer(ptr, x, y); + } else if (C_immediatep(y)) { + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); + } else if (C_block_header(y) == C_FLONUM_TAG) { + return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); + } else if (C_truep(C_bignump(y))) { + return rat_times_integer(ptr, x, y); + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_times_rat(ptr, x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + return cplx_times(ptr, x, C_fix(0), + C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x); + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); + } + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { + return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x), + C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); + } else { + C_word ab[C_SIZEOF_FLONUM], *a = ab, yi; + yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0); + return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi); } } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x); @@ -8041,7 +7988,7 @@ void C_ccall C_times(C_word c, C_word *av) C_word next_val, result = C_fix(1), prev_result = result; - C_word ab[2][C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_BIGNUM(2) * 4], *a; + C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a; c -= 2; av += 2; @@ -8146,15 +8093,15 @@ static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_pl if (i == C_fix(0)) return rat; - num = C_block_item(rat, 1); - denom = C_block_item(rat, 2); + num = C_u_i_ratnum_num(rat); + denom = C_u_i_ratnum_denom(rat); /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */ tmp = C_s_a_u_i_integer_times(&a, 2, denom, i); res = plusmin_op(&a, 2, num, tmp); res = move_buffer_object(ptr, ab, res); clear_buffer_object(ab, tmp); - return C_ratnum(ptr, res, C_block_item(rat, 2)); + return C_ratnum(ptr, res, denom); } /* This is needed only for minus: plus is commutative but minus isn't. */ @@ -8163,8 +8110,8 @@ static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat) C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab, num, denom, tmp, res; - num = C_block_item(rat, 1); - denom = C_block_item(rat, 2); + num = C_u_i_ratnum_num(rat); + denom = C_u_i_ratnum_denom(rat); if (i == C_fix(0)) return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom); @@ -8174,15 +8121,15 @@ static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat) res = C_s_a_u_i_integer_minus(&a, 2, tmp, num); res = move_buffer_object(ptr, ab, res); clear_buffer_object(ab, tmp); - return C_ratnum(ptr, res, C_block_item(rat, 2)); + return C_ratnum(ptr, res, denom); } /* This is pretty braindead and ugly */ static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op) { C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab, - xnum = C_block_item(x, 1), ynum = C_block_item(y, 1), - xdenom = C_block_item(x, 2), ydenom = C_block_item(y, 2), + xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y), + xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y), xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len, res_num, res_denom; @@ -8236,8 +8183,8 @@ static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_ /* The maximum size this needs is that required to store a complex * number result, where both real and imag parts consist of ratnums. * The maximum size of those ratnums is if they consist of two "fix - * bignums", so we're looking at C_SIZEOF_STRUCTURE(3) * 3 + - * C_SIZEOF_FIX_BIGNUM * 4 = 32 words! + * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * + * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words! */ C_regparm C_word C_fcall C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) @@ -8251,18 +8198,14 @@ C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_plus(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_block_item(y, 1)), - imag = C_block_item(y, 2); - if (C_truep(C_u_i_inexactp(real_sum))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_sum, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_u_i_cplxnum_imag(y); + if (C_truep(C_u_i_inexactp(real_sum))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_sum, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); } @@ -8277,18 +8220,14 @@ C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) return C_a_i_flonum_plus(ptr, 2, x, y); } else if (C_truep(C_bignump(y))) { return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y)); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_block_item(y, 1)), - imag = C_block_item(y, 2); - if (C_truep(C_u_i_inexactp(real_sum))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_sum, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_u_i_cplxnum_imag(y); + if (C_truep(C_u_i_inexactp(real_sum))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_sum, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); } @@ -8301,63 +8240,50 @@ C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_plus(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_block_item(y, 1)), - imag = C_block_item(y, 2); - if (C_truep(C_u_i_inexactp(real_sum))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_sum, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_u_i_cplxnum_imag(y); + if (C_truep(C_u_i_inexactp(real_sum))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_sum, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); } - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) { - if (y & C_FIXNUM_BIT) { - return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); - } else if (C_immediatep(y)) { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } else if (C_block_header(y) == C_FLONUM_TAG) { - return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); - } else if (C_truep(C_bignump(y))) { - return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_block_item(y, 1)), - imag = C_block_item(y, 2); - if (C_truep(C_u_i_inexactp(real_sum))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_sum, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); - } - } else if (C_block_item(x, 0) == C_cplxnum_type_tag) { - if (!C_immediatep(y) && C_block_header(y) == C_STRUCTURE3_TAG && - C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_sum, imag_sum; - real_sum = C_s_a_i_plus(ptr, 2, C_block_item(x, 1), C_block_item(y, 1)); - imag_sum = C_s_a_i_plus(ptr, 2, C_block_item(x, 2), C_block_item(y, 2)); - if (C_truep(C_u_i_zerop(imag_sum))) return real_sum; - else return C_cplxnum(ptr, real_sum, imag_sum); - } else { - C_word real_sum = C_s_a_i_plus(ptr, 2, C_block_item(x, 1), y), - imag = C_block_item(x, 2); - if (C_truep(C_u_i_inexactp(real_sum))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_sum, imag); - } + } else if (C_block_header(x) == C_RATNUM_TAG) { + if (y & C_FIXNUM_BIT) { + return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); + } else if (C_immediatep(y)) { + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); + } else if (C_block_header(y) == C_FLONUM_TAG) { + return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); + } else if (C_truep(C_bignump(y))) { + return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_u_i_cplxnum_imag(y); + if (C_truep(C_u_i_inexactp(real_sum))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_sum, imag); } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x); + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); + } + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_sum, imag_sum; + real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)); + imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_zerop(imag_sum))) return real_sum; + else return C_cplxnum(ptr, real_sum, imag_sum); + } else { + C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y), + imag = C_u_i_cplxnum_imag(x); + if (C_truep(C_u_i_inexactp(real_sum))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_sum, imag); } } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x); @@ -8397,7 +8323,7 @@ void C_ccall C_plus(C_word c, C_word *av) C_word next_val, result = C_fix(0), prev_result = result; - C_word ab[2][C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_FIX_BIGNUM * 4], *a; + C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a; c -= 2; av += 2; @@ -8499,7 +8425,7 @@ static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y) return C_bignum_simplify(res); } -/* Like C_s_a_i_plus, this needs at most 32 words */ +/* Like C_s_a_i_plus, this needs at most 29 words */ C_regparm C_word C_fcall C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) { @@ -8512,18 +8438,14 @@ C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_minus(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return integer_minus_rat(ptr, x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_block_item(y, 1)), - imag = C_s_a_i_negate(ptr, 1, C_block_item(y, 2)); - if (C_truep(C_u_i_inexactp(real_diff))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_diff, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return integer_minus_rat(ptr, x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_inexactp(real_diff))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_diff, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); } @@ -8538,18 +8460,14 @@ C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) return C_a_i_flonum_difference(ptr, 2, x, y); } else if (C_truep(C_bignump(y))) { return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y)); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_block_item(y, 1)), - imag = C_s_a_i_negate(ptr, 1, C_block_item(y, 2)); - if (C_truep(C_u_i_inexactp(real_diff))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_diff, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_inexactp(real_diff))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_diff, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); } @@ -8562,63 +8480,50 @@ C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y)); } else if (C_truep(C_bignump(y))) { return C_s_a_u_i_integer_minus(ptr, 2, x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return integer_minus_rat(ptr, x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_block_item(y, 1)), - imag = C_s_a_i_negate(ptr, 1, C_block_item(y, 2)); - if (C_truep(C_u_i_inexactp(real_diff))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_diff, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return integer_minus_rat(ptr, x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_inexactp(real_diff))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_diff, imag); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); } - } else if (C_block_header(x) == C_STRUCTURE3_TAG) { - if (C_block_item(x, 0) == C_ratnum_type_tag) { - if (y & C_FIXNUM_BIT) { - return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); - } else if (C_immediatep(y)) { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } else if (C_block_header(y) == C_FLONUM_TAG) { - return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); - } else if (C_truep(C_bignump(y))) { - return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_block_item(y, 1)), - imag = C_s_a_i_negate(ptr, 1, C_block_item(y, 2)); - if (C_truep(C_u_i_inexactp(real_diff))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_diff, imag); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); - } - } else if (C_block_item(x, 0) == C_cplxnum_type_tag) { - if (!C_immediatep(y) && C_block_header(y) == C_STRUCTURE3_TAG && - C_block_item(y, 0) == C_cplxnum_type_tag) { - C_word real_diff, imag_diff; - real_diff = C_s_a_i_minus(ptr,2,C_block_item(x, 1),C_block_item(y, 1)); - imag_diff = C_s_a_i_minus(ptr,2,C_block_item(x, 2),C_block_item(y, 2)); - if (C_truep(C_u_i_zerop(imag_diff))) return real_diff; - else return C_cplxnum(ptr, real_diff, imag_diff); - } else { - C_word real_diff = C_s_a_i_minus(ptr, 2, C_block_item(x, 1), y), - imag = C_block_item(x, 2); - if (C_truep(C_u_i_inexactp(real_diff))) - imag = C_a_i_exact_to_inexact(ptr, 1, imag); - return C_cplxnum(ptr, real_diff, imag); - } + } else if (C_block_header(x) == C_RATNUM_TAG) { + if (y & C_FIXNUM_BIT) { + return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); + } else if (C_immediatep(y)) { + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); + } else if (C_block_header(y) == C_FLONUM_TAG) { + return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); + } else if (C_truep(C_bignump(y))) { + return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); + } else if (C_block_header(y) == C_RATNUM_TAG) { + return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), + imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_inexactp(real_diff))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_diff, imag); + } else { + barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); + } + } else if (C_block_header(x) == C_CPLXNUM_TAG) { + if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { + C_word real_diff, imag_diff; + real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y)); + imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y)); + if (C_truep(C_u_i_zerop(imag_diff))) return real_diff; + else return C_cplxnum(ptr, real_diff, imag_diff); } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); + C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y), + imag = C_u_i_cplxnum_imag(x); + if (C_truep(C_u_i_inexactp(real_diff))) + imag = C_a_i_exact_to_inexact(ptr, 1, imag); + return C_cplxnum(ptr, real_diff, imag); } } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); @@ -8656,7 +8561,7 @@ void C_ccall C_minus(C_word c, C_word *av) /* C_word closure = av[ 0 ]; */ C_word k = av[ 1 ]; C_word next_val, result, prev_result; - C_word ab[2][C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_FIX_BIGNUM * 4], *a; + C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a; if (c < 3) { C_bad_min_argc(c, 3); @@ -9460,13 +9365,13 @@ static C_word rat_cmp(C_word x, C_word y) /* Check for 1 or 0; if x or y is this, the other must be the ratnum */ if (x == C_fix(0)) { /* Only the sign of y1 matters */ - return basic_cmp(x, C_block_item(y, 1), "ratcmp", 0); + return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0); } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */ - return basic_cmp(C_block_item(y, 2), C_block_item(y, 1), "ratcmp", 0); + return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0); } else if (y == C_fix(0)) { /* Only the sign of x1 matters */ - return basic_cmp(C_block_item(x, 1), y, "ratcmp", 0); + return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0); } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */ - return basic_cmp(C_block_item(x, 1), C_block_item(x, 2), "ratcmp", 0); + return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0); } /* Extract components x=x1/x2 and y=y1/y2 */ @@ -9474,16 +9379,16 @@ static C_word rat_cmp(C_word x, C_word y) x1 = x; x2 = C_fix(1); } else { - x1 = C_block_item(x, 1); - x2 = C_block_item(x, 2); + x1 = C_u_i_ratnum_num(x); + x2 = C_u_i_ratnum_denom(x); } if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) { y1 = y; y2 = C_fix(1); } else { - y1 = C_block_item(y, 1); - y2 = C_block_item(y, 2); + y1 = C_u_i_ratnum_num(y); + y2 = C_u_i_ratnum_denom(y); } /* We only want to deal with bignums (this is tricky enough) */ @@ -9656,7 +9561,7 @@ static C_word rat_flo_cmp(C_word ratnum, C_word flonum) i = f; /* TODO: split i and f so it'll work for denormalized flonums */ - num = C_block_item(ratnum, 1); + num = C_u_i_ratnum_num(ratnum); negp = C_i_negativep(num); if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */ @@ -9664,7 +9569,7 @@ static C_word rat_flo_cmp(C_word ratnum, C_word flonum) } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */ return C_fix(1); } else { - denom = C_block_item(ratnum, 2); + denom = C_u_i_ratnum_denom(ratnum); i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i)); /* Multiply the scaled flonum integer by the denominator, and @@ -9711,16 +9616,12 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) } else if (C_truep(C_bignump(y))) { C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab; return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - if (eqp) return C_SCHEME_FALSE; - else return rat_cmp(x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - if (eqp) return C_SCHEME_FALSE; - else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + if (eqp) return C_SCHEME_FALSE; + else return rat_cmp(x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + if (eqp) return C_SCHEME_FALSE; + else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); } @@ -9737,15 +9638,11 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0)); } else if (C_truep(C_bignump(y))) { return flo_int_cmp(x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - return flo_rat_cmp(x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - if (eqp) return C_SCHEME_FALSE; - else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + return flo_rat_cmp(x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + if (eqp) return C_SCHEME_FALSE; + else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); } @@ -9759,21 +9656,16 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) return int_flo_cmp(x, y); } else if (C_truep(C_bignump(y))) { return C_i_bignum_cmp(x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG) { - if (C_block_item(y, 0) == C_ratnum_type_tag) { - if (eqp) return C_SCHEME_FALSE; - else return rat_cmp(x, y); - } else if (C_block_item(y, 0) == C_cplxnum_type_tag) { - if (eqp) return C_SCHEME_FALSE; - else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); - } else { - barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); - } + } else if (C_block_header(y) == C_RATNUM_TAG) { + if (eqp) return C_SCHEME_FALSE; + else return rat_cmp(x, y); + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + if (eqp) return C_SCHEME_FALSE; + else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); } - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_ratnum_type_tag)) { + } else if (C_block_header(x) == C_RATNUM_TAG) { if (y & C_FIXNUM_BIT) { if (eqp) return C_SCHEME_FALSE; else return rat_cmp(x, y); @@ -9784,26 +9676,23 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) } else if (C_truep(C_bignump(y))) { if (eqp) return C_SCHEME_FALSE; else return rat_cmp(x, y); - } else if (C_block_header(y) == C_STRUCTURE3_TAG && - (C_block_item(y, 0) == C_ratnum_type_tag)) { + } else if (C_block_header(y) == C_RATNUM_TAG) { if (eqp) { - return C_and(C_and(C_i_integer_equalp(C_block_item(x, 1), - C_block_item(y, 1)), - C_i_integer_equalp(C_block_item(x, 2), - C_block_item(y, 2))), + return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x), + C_u_i_ratnum_num(y)), + C_i_integer_equalp(C_u_i_ratnum_denom(x), + C_u_i_ratnum_denom(y))), C_fix(0)); } else { return rat_cmp(x, y); } - } else if (C_block_header(y) == C_STRUCTURE3_TAG && - (C_block_item(y, 0) == C_cplxnum_type_tag)) { + } else if (C_block_header(y) == C_CPLXNUM_TAG) { if (eqp) return C_SCHEME_FALSE; else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); } - } else if (C_block_header(x) == C_STRUCTURE3_TAG && - (C_block_item(x, 0) == C_cplxnum_type_tag)) { + } else if (C_block_header(x) == C_CPLXNUM_TAG) { if (!eqp) { barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x); } else if (y & C_FIXNUM_BIT) { @@ -9812,13 +9701,11 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); } else if (C_block_header(y) == C_FLONUM_TAG || C_truep(C_bignump(x)) || - (C_block_header(y) == C_STRUCTURE3_TAG && - C_block_item(y, 0) == C_ratnum_type_tag)) { + C_block_header(y) == C_RATNUM_TAG) { return C_SCHEME_FALSE; - } else if (C_block_header(y) == C_STRUCTURE3_TAG && - (C_block_item(y, 0) == C_cplxnum_type_tag)) { - return C_and(C_and(C_i_nequalp(C_block_item(x, 1), C_block_item(y, 1)), - C_i_nequalp(C_block_item(x, 2), C_block_item(y, 2))), + } else if (C_block_header(y) == C_CPLXNUM_TAG) { + return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)), + C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))), C_fix(0)); } else { barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); @@ -10665,7 +10552,7 @@ void C_ccall C_string_to_symbol(C_word c, C_word *av) } /* This will usually return a flonum, but it may also return a cplxnum - * consisting of two flonums, making for a total of 12 words. + * consisting of two flonums, making for a total of 11 words. */ C_regparm C_word C_fcall C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n) @@ -10678,19 +10565,17 @@ C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n) return n; } else if (C_truep(C_bignump(n))) { return C_a_u_i_big_to_flo(ptr, c, n); - } else if (C_block_header(n) == C_STRUCTURE3_TAG && - (C_block_item(n, 0) == C_cplxnum_type_tag)) { - return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_block_item(n, 1)), - C_a_i_exact_to_inexact(ptr, 1, C_block_item(n, 2))); + } else if (C_block_header(n) == C_CPLXNUM_TAG) { + return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)), + C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n))); /* The horribly painful case: ratnums */ - } else if (C_block_header(n) == C_STRUCTURE3_TAG && - (C_block_item(n, 0) == C_ratnum_type_tag)) { + } else if (C_block_header(n) == C_RATNUM_TAG) { /* This tries to keep the numbers within representable ranges and * tries to drop as few significant digits as possible by bringing * the two numbers to within the same powers of two. See * algorithms M & N in Knuth, 4.2.1. */ - C_word num = C_block_item(n, 1), denom = C_block_item(n, 2), + C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n), /* e = approx. distance between the numbers in powers of 2. * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)? diff --git a/types.db b/types.db index 0d970d5..4ac0c07 100644 --- a/types.db +++ b/types.db @@ -264,7 +264,7 @@ (zero? (#(procedure #:clean #:enforce #:foldable) zero? (number) boolean) ((integer) (eq? #(1) '0)) - (((or cplxnum ratnum)) '#f) + (((or cplxnum ratnum)) (let ((#(tmp) #(1))) '#f)) ((number) (##core#inline "C_u_i_zerop" #(1))) ((*) (##core#inline "C_i_zerop" #(1)))) @@ -321,14 +321,14 @@ ((integer integer) (integer) (##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) #(2))) ((* *) (number) - (##core#inline_allocate ("C_s_a_i_plus" 32) #(1) #(2)))) + (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) #(2)))) (- (#(procedure #:clean #:enforce #:foldable) - (number #!rest number) number) ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 5) #(1))) ((integer) (integer) (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) #(1))) ((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))) - ((*) (*) (##core#inline_allocate ("C_s_a_i_negate" 32) #(1))) + ((*) (*) (##core#inline_allocate ("C_s_a_i_negate" 29) #(1))) ((float fixnum) (float) (##core#inline_allocate ("C_a_i_flonum_difference" 4) @@ -346,7 +346,7 @@ ((integer integer) (integer) (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) #(2))) ((* *) (number) - (##core#inline_allocate ("C_s_a_i_minus" 32) #(1) #(2)))) + (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) #(2)))) (* (#(procedure #:clean #:enforce #:foldable) * (#!rest number) number) (() (fixnum) '1) @@ -374,7 +374,7 @@ ((integer integer) (integer) (##core#inline_allocate ("C_s_a_u_i_integer_times" 5) #(1) #(2))) ((* *) (number) - (##core#inline_allocate ("C_s_a_i_times" 36) #(1) #(2)))) + (##core#inline_allocate ("C_s_a_i_times" 33) #(1) #(2)))) (/ (#(procedure #:clean #:enforce #:foldable) / (number #!rest number) number) ((float fixnum) (float) @@ -515,7 +515,7 @@ ((integer) (integer) (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) ((*) (*) - (##core#inline_allocate ("C_s_a_i_abs" 9) #(1)))) + (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) (floor (#(procedure #:clean #:enforce #:foldable) floor ((or integer ratnum float)) (or integer ratnum float)) ((fixnum) (fixnum) #(1)) @@ -544,7 +544,7 @@ (exact->inexact (#(procedure #:clean #:enforce #:foldable) exact->inexact (number) (or float cplxnum)) ((float) (float) #(1)) ((fixnum) (float) (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))) - ((number) (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) #(1)))) + ((number) (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) #(1)))) (inexact->exact (#(procedure #:clean #:enforce #:foldable) inexact->exact (number) (or integer ratnum)) ((fixnum) (fixnum) #(1)) @@ -810,19 +810,19 @@ (real-part (#(procedure #:clean #:enforce #:foldable) real-part (number) (or integer float ratnum)) (((or fixnum float bignum ratnum)) #(1)) - ((cplxnum) (##sys#slot #(1) '1))) + ((cplxnum) (##core#inline "C_u_i_cplxnum_real" #(1)))) (imag-part (#(procedure #:clean #:enforce #:foldable) imag-part (number) (or integer float ratnum)) (((or fixnum bignum ratnum)) (let ((#(tmp) #(1))) '0)) ((float) (let ((#(tmp) #(1))) '0.0)) - ((cplxnum) (##sys#slot #(1) '2))) + ((cplxnum) (##core#inline "C_u_i_cplxnum_imag" #(1)))) (magnitude (#(procedure #:clean #:enforce #:foldable) magnitude (number) number) ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 5) #(1))) ((integer) (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))) (((or fixnum float bignum ratnum)) - (##core#inline_allocate ("C_s_a_i_abs" 9) #(1)))) + (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) (angle (#(procedure #:clean #:enforce #:foldable) angle (number) float) ((float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) '0.0 #(1))) @@ -830,22 +830,24 @@ ("C_a_i_flonum_atan2" 4) '0.0 (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)))) - ((cplxnum) (##core#inline_allocate - ("C_a_i_flonum_atan2" 4) - (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) - (##sys#slot #(1) '2)) - (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) - (##sys#slot #(1) '1))))) + ((cplxnum) + (let ((#(tmp) #(1))) + (##core#inline_allocate + ("C_a_i_flonum_atan2" 4) + (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) + (##core#inline "C_u_i_cplxnum_imag" #(tmp))) + (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) + (##core#inline "C_u_i_cplxnum_real" #(tmp))))))) (numerator (#(procedure #:clean #:enforce #:foldable) numerator ((or float integer ratnum)) (or float integer)) ((fixnum) (fixnum) #(1)) ((bignum) (bignum) #(1)) ((integer) (integer) #(1)) - ((ratnum) (integer) (##sys#slot #(1) '1))) + ((ratnum) (integer) (##core#inline "C_u_i_ratnum_num" #(1)))) (denominator (#(procedure #:clean #:enforce #:foldable) denominator ((or float integer ratnum)) (or float integer)) ((integer) (fixnum) (let ((#(tmp) #(1))) '1)) - ((ratnum) (integer) (##sys#slot #(1) '2))) + ((ratnum) (integer) (##core#inline "C_u_i_ratnum_denom" #(1)))) ;; eval @@ -885,7 +887,7 @@ ((float) (float) (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) '1.0)) ((*) (number) - (##core#inline_allocate ("C_s_a_i_plus" 32) #(1) '1))) + (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) '1))) (argc+argv (#(procedure #:clean) argc+argv () fixnum pointer)) (argv (#(procedure #:clean) argv () (list-of string))) @@ -1308,7 +1310,8 @@ ((float) (float) (##core#inline_allocate ("C_a_u_i_flonum_signum" 4) #(1))) ((ratnum) (fixnum) - (##core#inline "C_u_i_integer_signum" (##sys#slot #(1) '1))) + (##core#inline "C_u_i_integer_signum" + (##core#inline "C_u_i_ratnum_num" #(1)))) ((cplxnum) ((or float cplxnum)) (##sys#extended-signum #(1)))) (sleep (#(procedure #:clean #:enforce) sleep (fixnum) undefined)) @@ -1326,7 +1329,7 @@ ((float) (float) (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) '1.0)) ((*) (number) - (##core#inline_allocate ("C_s_a_i_minus" 32) #(1) '1))) + (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) '1))) (subvector (forall (a) (#(procedure #:clean #:enforce) subvector ((vector-of a) fixnum #!optional fixnum) (vector-of a)))) (symbol-escape (#(procedure #:clean) symbol-escape (#!optional *) *)) -- 2.1.4