~ chicken-core (chicken-5) 38c5af40478da43d72502402b94d9d42ea5cf2a8
commit 38c5af40478da43d72502402b94d9d42ea5cf2a8
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Jun 16 21:03:19 2013 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sat Jun 29 15:39:15 2013 +0200
Accept flonums in numerator and denominator procedures (fixes #1016)
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/NEWS b/NEWS
index fd436872..09f65b41 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 fb7418e3..6d5d7f95 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1783,6 +1783,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 87c6e838..11350ac0 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 6baf57f4..d7d79f2c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -31,6 +31,7 @@
#include <signal.h>
#include <assert.h>
#include <limits.h>
+#include <float.h>
#include <math.h>
#include <signal.h>
@@ -784,7 +785,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)
@@ -821,6 +822,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);
@@ -7353,6 +7355,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 7cfca2cd..24bbc1d1 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))
Trap