Merge pull request #520 from justinethier/issue-519

Resolve Issue 519

CHANGELOG.md

@@ -5,9 +5,11 @@
 Features
 
 - Enhanced the reader to parse rationals and store them as inexact numbers.
+- Add a stub for `(rationalize x y)` to `(scheme base)`.
 
 Bug Fixes
 
+- Updated various numeric functions to properly handle numeric type conversions, including `quotient`, `remainder`, `numerator`, `denominator`, `truncate`, `truncate-quotient`, and `/`.
 - Fix `exact` to properly handle complex numbers, including raising an error when passed `nan` or `inf` double values.
 - Ensure the runtime properly differentiates between `+inf.0` and `-inf.0`. Thanks to jpellegrini for the bug report.
 - jpellegrini reported that Cyclone returns `#f` when comparing complex numbers using operators other than `=`. Instead it is better to raise an error in these situations.

README.md

@@ -1,7 +1,5 @@
 ![Cyclone Scheme](docs/images/cyclone-logo-04-header.png "Cyclone Scheme")
 
-[![Travis CI](https://travis-ci.org/justinethier/cyclone.svg?branch=master)](https://travis-ci.org/justinethier/cyclone)
-
 [![Github CI - Linux](https://github.com/justinethier/cyclone-bootstrap/workflows/Ubuntu%20Linux%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)
 
 [![Github CI - MacOS](https://github.com/justinethier/cyclone-bootstrap/workflows/MacOS%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)

runtime.c

@@ -4139,10 +4139,15 @@ object Cyc_fast_div(void *data, object ptr, object x, object y) {
     if (obj_is_int(y)){
       if (obj_obj2int(y) == 0) { goto divbyzero; }
       // Overflow can occur if y = 0 || (x = 0x80000000 && y = -1)
-      // We already check for 0 above and the value of x above is a
-      // bignum, so no futher checks are required.
-      assign_double(ptr, (double)(obj_obj2int(x)) / obj_obj2int(y));
-      return ptr;
+      // We already check for 0 above and the invalid value of x would
+      // be a bignum, so no futher checks are required.
+      double result = (double)(obj_obj2int(x)) / obj_obj2int(y);
+      if (result == round(result)) {
+        return obj_int2obj(result);
+      } else {
+        assign_double(ptr, result);
+        return ptr;
+      }
     } else if (is_object_type(y) && type_of(y) == double_tag) {
       assign_double(ptr, (double)(obj_obj2int(x)) / double_value(y));
       return ptr;
@@ -4241,12 +4246,23 @@ object Cyc_div_op(void *data, common_type * x, object y)
     }
     x->double_t.tag = double_tag;
     x->double_t.value = ((double)x->integer_t.value) / (obj_obj2int(y));
+
+    if (x->double_t.value == round(x->double_t.value)) {
+      int tmp = x->double_t.value;
+      x->integer_t.tag = integer_tag;
+      x->integer_t.value = tmp;
+    }
   } else if (tx == double_tag && ty == -1) {
     x->double_t.value = x->double_t.value / (obj_obj2int(y));
   } else if (tx == integer_tag && ty == integer_tag) {
     x->double_t.tag = double_tag;
     x->double_t.value =
         ((double)x->integer_t.value) / ((integer_type *) y)->value;
+    if (x->double_t.value == round(x->double_t.value)) {
+      int tmp = x->double_t.value;
+      x->integer_t.tag = integer_tag;
+      x->integer_t.value = tmp;
+    }
   } else if (tx == double_tag && ty == integer_tag) {
     x->double_t.value = x->double_t.value / ((integer_type *) y)->value;
   } else if (tx == integer_tag && ty == double_tag) {
@@ -4613,6 +4629,7 @@ void Cyc_bignum_remainder(void *data, object cont, object num1, object num2, obj
 void Cyc_remainder(void *data, object cont, object num1, object num2)
 {
   int i = 0, j = 0;
+  double ii = 0, jj = 0;
   object result;
   if (obj_is_int(num1)) {
     if (obj_is_int(num2)){
@@ -4625,8 +4642,9 @@ void Cyc_remainder(void *data, object cont, object num1, object num2)
       Cyc_bignum_remainder(data, cont, bn, num2, bn);
     }
     else if (is_object_type(num2) && type_of(num2) == double_tag){
-      i = obj_obj2int(num1);
-      j = ((double_type *)num2)->value; 
+      ii = obj_obj2int(num1);
+      jj = ((double_type *)num2)->value; 
+      goto handledouble;
     }
     else {
       goto typeerror;
@@ -4642,28 +4660,28 @@ void Cyc_remainder(void *data, object cont, object num1, object num2)
       Cyc_bignum_remainder(data, cont, num1, num2, rem);
     }
     else if (is_object_type(num2) && type_of(num2) == double_tag){
-      j = ((double_type *)num2)->value; 
-      alloc_bignum(data, bn);
-      Cyc_int2bignum(obj_obj2int(j), &(bn->bn));
-      Cyc_bignum_remainder(data, cont, num1, bn, bn);
+      ii = mp_get_double(&bignum_value(num1));
+      jj = ((double_type *)num2)->value; 
+      goto handledouble;
     }
     else {
       goto typeerror;
     }
   } else if (is_object_type(num1) && type_of(num1) == double_tag){
     if (obj_is_int(num2)){
-      i = ((double_type *)num1)->value; 
-      j = obj_obj2int(num2);
+      ii = ((double_type *)num1)->value; 
+      jj = obj_obj2int(num2);
+      goto handledouble;
     }
     else if (is_object_type(num2) && type_of(num2) == bignum_tag){
-      i = ((double_type *)num1)->value; 
-      alloc_bignum(data, bn);
-      Cyc_int2bignum(obj_obj2int(i), &(bn->bn));
-      Cyc_bignum_remainder(data, cont, bn, num2, bn);
+      ii = ((double_type *)num1)->value; 
+      jj = mp_get_double(&bignum_value(num2));
+      goto handledouble;
     }
     else if (is_object_type(num2) && type_of(num2) == double_tag){
-      i = ((double_type *)num1)->value; 
-      j = ((double_type *)num2)->value; 
+      ii = ((double_type *)num1)->value; 
+      jj = ((double_type *)num2)->value; 
+      goto handledouble;
     } 
     else {
       goto typeerror;
@@ -4674,6 +4692,12 @@ void Cyc_remainder(void *data, object cont, object num1, object num2)
   if (j == 0) { Cyc_rt_raise_msg(data, "Divide by zero"); }
   result = obj_int2obj(i % j);
   return_closcall1(data, cont, result); 
+handledouble:
+  {
+    if (jj == 0) { Cyc_rt_raise_msg(data, "Divide by zero"); }
+    make_double(dresult, fmod(ii, jj));
+    return_closcall1(data, cont, &dresult); 
+  }
 typeerror:
   {
     make_string(s, "Bad argument type");
@@ -8620,6 +8644,12 @@ void Cyc_get_ratio(void *data, object cont, object n, int numerator)
     // Special case
     make_double(val, 1.0);
     return_closcall1(data, cont, &val);
+  } else if (obj_is_int(n) || type_of(n) == bignum_tag) {
+    if (numerator) {
+      return_closcall1(data, cont, n);
+    } else {
+      return_closcall1(data, cont, obj_int2obj((1)));
+    }
   } else {
     double numer, denom;
     make_double(val, 0.0);

scheme/base.sld

@@ -205,15 +205,10 @@
     write-u8
     binary-port?
     textual-port?
-
+    rationalize
 ;;;;
 ; Possibly missing functions:
-;
 ;    u8-ready?
-;
-;    ; No complex or rational numbers at this time
-;    rationalize
-;
 ;    ;; syntax-rules
 ;;;;
   )
@@ -1483,6 +1478,9 @@
     "(void *data, object ptr, object z)"
     " return Cyc_is_complex(z); ")
   (define rational? number?)
+  ;; Stub, doesn't do much now because rationals are not supported
+  (define (rationalize x y)
+    (/ x y))
   (define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))
   (define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))
   ; Implementations of gcd and lcm using Euclid's algorithm
@@ -1525,8 +1523,17 @@
     "(void *data, int argc, closure _, object k, object n)"
     " Cyc_get_ratio(data, k, n, 0);")
 
+  (define-c fixnum?
+    "(void *data, int argc, closure _, object k, object obj)"
+    " return_closcall1(data, k, 
+        obj_is_int(obj) ? boolean_t : boolean_f); "
+    "(void *data, object ptr, object obj)"
+    " return obj_is_int(obj) ? boolean_t : boolean_f; ")
+
   (define (quotient x y)
-    (truncate (/ x y)))
+    (if (and (fixnum? x) (fixnum? y))
+        (exact (truncate (/ x y)))
+        (truncate (/ x y))))
 
   (define truncate-quotient quotient)
   (define truncate-remainder remainder)

srfi/143.sld

@@ -158,10 +158,11 @@
          return_closcall1(data, k, obj_int2obj(count));")
 
     (define (fxlength  i)
-      (ceiling (/ (log (if (fxnegative? i)
-                           (fxneg i)
-                           (fx+ 1 i)))
-                  (log 2))))
+      (exact 
+        (ceiling (/ (log (if (fxnegative? i)
+                             (fxneg i)
+                             (fx+ 1 i)))
+                    (log 2)))))
 
     (define (fxif mask n0 n1)
       (fxior (fxand mask n0)

tests/base.scm

@@ -60,12 +60,43 @@
 )
 
 (test-group
-  "truncate"
+  "numeric operations - floor, truncate, "
   (test -1 (truncate -1))
   (test -1.0 (truncate -1.0))
   (test -1.0 (truncate -1.1))
   (test -1.0 (truncate -1.1))
   (test +inf.0 (truncate +inf.0))
+
+  (test (values 2 1) (floor/ 5 2))
+  (test (values -3 1) (floor/ -5 2))
+  (test (values -3 -1) (floor/ 5 -2))
+  (test (values 2 -1) (floor/ -5 -2))
+  (test (values 2 1) (truncate/ 5 2))
+  (test (values -2 -1) (truncate/ -5 2))
+  (test (values -2 1) (truncate/ 5 -2))
+  (test (values 2 -1) (truncate/ -5 -2))
+  (test (values 2.0 -1.0) (truncate/ -5.0 -2))
+
+  (test 4 (gcd 32 -36))
+  (test 0 (gcd))
+  (test 288 (lcm 32 -36))
+  (test 288.0 (lcm 32.0 -36))
+  (test 1 (lcm))
+
+  (test -5.0 (floor -4.3))
+  (test -4.0 (ceiling -4.3))
+  (test -4.0 (truncate -4.3))
+  (test -4.0 (round -4.3))
+  (test 3.0  (floor 3.5))
+  (test 4.0  (ceiling 3.5))
+  (test 3.0  (truncate 3.5))
+  (test 4.0  (round 3.5))
+  (test 4.0  (round 7/2)) ;; Rationals not supported, so result is inexact
+  (test 7    (round 7))
+
+  (test 3.0 (numerator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (inexact (/ 6 4))))
 )
 
 (test-group