Hi all,
Attached is a patch to allow non-integral flonum arguments for the
numerator and denominator procedures. They are supposed to accept
rational numbers, and flonums, though inexact, can be rational (if
they're not Inf or NaN). This fixes #1016 for core and brings us
closer to R5RS compliance (yes, this is required by R5RS!)
This code is a more-or-less straightforward port to C (+ specialization)
of the Scheme code for the inexact->exact procedure from the numbers egg.
Unfortunately, it does not give the "precise" results the numbers egg
gives, because bignums are unavailable. OTOH, this precision is usually
kind of misleading anyway since the inputs are inexact numbers!
Cheers,
Peter
--
http://www.more-magic.net
>From a3e1baa26da50d511dab41520649d354ef7b1063 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter....@xs4all.nl>
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 <signal.h>
#include <assert.h>
#include <limits.h>
+#include <float.h>
#include <math.h>
#include <signal.h>
@@ -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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
