>From a3e1baa26da50d511dab41520649d354ef7b1063 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 16 Jun 2013 21:03:19 +0200 Subject: [PATCH] Accept flonums in numerator and denominator procedures (fixes #1016) --- NEWS | 2 ++ chicken.h | 1 + library.scm | 21 +++++++++++++++------ runtime.c | 49 ++++++++++++++++++++++++++++++++++++++++++++++++- tests/library-tests.scm | 20 ++++++++++++++++++++ 5 files changed, 86 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index fd43687..09f65b4 100644 --- a/NEWS +++ b/NEWS @@ -37,6 +37,8 @@ (thanks to Florian Zumbiehl) - posix: memory-mapped file support for Windows (thanks to "rivo") - posix: find-file's test argument now also accepts SRE forms. + - numerator and denominator now accept inexact numbers, as per R5RS + (reported by John Cowan). - Runtime system - Special events in poll() are now handled, avoiding hangs in threaded apps. diff --git a/chicken.h b/chicken.h index ce54b3c..559d077 100644 --- a/chicken.h +++ b/chicken.h @@ -1779,6 +1779,7 @@ C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret; C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret; C_fctexport void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_noret; +C_fctexport void C_ccall C_flonum_rat(C_word c, C_word closure, C_word k, C_word n) C_noret; C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret; C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret; C_fctexport void C_ccall C_fixnum_to_string(C_word c, C_word closure, C_word k, C_word num) C_noret; diff --git a/library.scm b/library.scm index 31ee708..75e8bbd 100644 --- a/library.scm +++ b/library.scm @@ -901,6 +901,7 @@ EOF (define real? number?) (define (rational? n) (##core#inline "C_i_rationalp" n)) (define ##sys#flonum-fraction (##core#primitive "C_flonum_fraction")) +(define ##sys#fprat (##core#primitive "C_flonum_rat")) (define (##sys#integer? x) (##core#inline "C_i_integerp" x)) (define integer? ##sys#integer?) (define (##sys#exact? x) (##core#inline "C_i_exactp" x)) @@ -930,15 +931,23 @@ EOF (define (numerator n) (##sys#check-number n 'numerator) - (if (##core#inline "C_i_integerp" n) - n - (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) ) + (cond + ((##core#inline "C_u_i_exactp" n) n) + ((##core#inline "C_i_finitep" n) + (receive (num denom) (##sys#fprat n) num)) + (else + (##sys#signal-hook + #:type-error 'numerator "bad argument type - not a rational number" n)) ) ) (define (denominator n) (##sys#check-number n 'denominator) - (if (##core#inline "C_i_integerp" n) - 1 - (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) ) + (cond + ((##core#inline "C_u_i_exactp" n) 1) + ((##core#inline "C_i_finitep" n) + (receive (num denom) (##sys#fprat n) denom)) + (else + (##sys#signal-hook + #:type-error 'denominator "bad argument type - not a rational number" n)) ) ) (define magnitude abs) diff --git a/runtime.c b/runtime.c index 5ce267e..b28b35c 100644 --- a/runtime.c +++ b/runtime.c @@ -31,6 +31,7 @@ #include #include #include +#include #include #include @@ -776,7 +777,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel) static C_PTABLE_ENTRY *create_initial_ptable() { /* IMPORTANT: hardcoded table size - this must match the number of C_pte calls! */ - C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 57); + C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 58); int i = 0; if(pt == NULL) @@ -813,6 +814,7 @@ static C_PTABLE_ENTRY *create_initial_ptable() C_pte(C_less_or_equal_p); C_pte(C_quotient); C_pte(C_flonum_fraction); + C_pte(C_flonum_rat); C_pte(C_expt); C_pte(C_number_to_string); C_pte(C_make_symbol); @@ -7341,6 +7343,51 @@ void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_kontinue_flonum(k, modf(fn, &i)); } +void C_ccall C_flonum_rat(C_word c, C_word closure, C_word k, C_word n) +{ + double frac, tmp, numer, denom, factor, fn = C_flonum_magnitude(n); + double r1a, r1b; + double ga, gb; + C_word ab[WORDS_PER_FLONUM * 2], *ap = ab; + int i = 0; + + if (n < 1 && n > -1) { + factor = pow(2, DBL_MANT_DIG); + fn *= factor; + } else { + factor = 1; + } + + /* Calculate bit-length of the fractional part (ie, after decimal point) */ + frac = fn; + while(!C_isnan(frac) && !C_isinf(frac) && C_modf(frac, &tmp) != 0.0) { + frac *= 2; + if (i++ > 3000) /* should this be flonum-maximum-exponent? */ + barf(C_CANT_REPRESENT_INEXACT_ERROR, "fprat", n); + } + + /* r1a and r1b are integral and form the rational number r1 = r1a/r1b. */ + r1b = pow(2, i); + r1a = fn*r1b; + + /* + * We "multiply" r1 with r2 given that r2 = 1/factor. + * result = (r1a * (factor / g)) / abs(r1b / g) | g = gcd(r1b, factor) + */ + ga = r1b; + gb = factor; + while(gb != 0.0) { + tmp = fmod(ga, gb); + ga = gb; + gb = tmp; + } + /* ga now holds gcd(r1b, factor), and r1b and ga are absolute already */ + numer = r1a * (factor / ga); + denom = r1b / ga; + + C_values(4, C_SCHEME_UNDEFINED, k, C_flonum(&ap, numer), C_flonum(&ap, denom)); +} + C_regparm C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) diff --git a/tests/library-tests.scm b/tests/library-tests.scm index 7cfca2c..24bbc1d 100644 --- a/tests/library-tests.scm +++ b/tests/library-tests.scm @@ -74,6 +74,26 @@ (assert (= 2.5 (/ 5 2))) +;; Use equal? instead of = to check equality and exactness in one go +(assert (equal? 0 (numerator 0))) +(assert (equal? 1 (denominator 0))) +(assert (equal? 3 (numerator 3))) +(assert (equal? 1 (denominator 3))) +(assert (equal? -3 (numerator -3))) +(assert (equal? 1 (denominator -3))) +(assert (equal? 1.0 (numerator 0.5))) +(assert (equal? 2.0 (denominator 0.5))) +(assert (equal? 5.0 (numerator 1.25))) +(assert (equal? 4.0 (denominator 1.25))) +(assert (equal? -5.0 (numerator -1.25))) +(assert (equal? 4.0 (denominator -1.25))) +(assert (equal? 1e10 (numerator 1e10))) +(assert (equal? 1.0 (denominator 1e10))) +(assert-fail (numerator +inf.0)) +(assert-fail (numerator +nan.0)) +(assert-fail (denominator +inf.0)) +(assert-fail (denominator +nan.0)) + (assert (even? 2)) (assert (even? 2.0)) (assert (even? 0)) -- 1.8.2.3