Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-19 05:39:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #520 from justinethier/issue-519

Browse source 
Resolve Issue 519
This commit is contained in:
Justin Ethier 2024-01-10 22:40:36 -05:00 • committed by GitHub
commit fc5a737476
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
6 changed files with 101 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -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.

2
README.md
View file

@ -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)

66
runtime.c
View file

@ -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);

21
scheme/base.sld
View file

@ -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)

9
srfi/143.sld
View file

@ -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)

33
tests/base.scm
View file

@ -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