From e45fc3c0f0cf8f99efc96a6bb129fa7187f11a7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Aug 2004 20:49:55 +0000 Subject: [PATCH] first cut at floats --- build.sh | 2 +- library/test/math/rational.factor | 21 ++++ native/arithmetic.c | 19 +++- native/arithmetic.h | 165 ++++++++++++++++-------------- native/array.c | 2 +- native/bignum.c | 17 ++- native/bignum.h | 8 +- native/factor.h | 1 + native/fixnum.c | 19 +++- native/fixnum.h | 1 + native/float.c | 90 ++++++++++++++++ native/float.h | 31 ++++++ native/handle.c | 2 +- native/ratio.c | 29 +++++- native/ratio.h | 1 + native/sbuf.c | 2 +- native/string.c | 2 +- native/types.c | 4 +- native/types.h | 3 +- native/vector.c | 2 +- native/word.c | 2 +- 21 files changed, 322 insertions(+), 101 deletions(-) create mode 100644 native/float.c create mode 100644 native/float.h diff --git a/build.sh b/build.sh index 056f96997c..78a8fc4c6e 100644 --- a/build.sh +++ b/build.sh @@ -1,5 +1,5 @@ export CC=gcc34 -export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer" +export CFLAGS="-pedantic -Wall -Winline -O2 -march=pentium4 -fomit-frame-pointer" $CC $CFLAGS -o f native/*.c diff --git a/library/test/math/rational.factor b/library/test/math/rational.factor index ee46b4e153..edcc8ff101 100644 --- a/library/test/math/rational.factor +++ b/library/test/math/rational.factor @@ -42,6 +42,13 @@ USE: test [ t ] [ 1 3 / 1 3 / = ] unit-test +[ -10 ] [ -100 10 /i ] unit-test +[ 10 ] [ -100 -10 /i ] unit-test +[ -10 ] [ 100 -10 /i ] unit-test +[ -10 ] [ -100 >bignum 10 >bignum /i ] unit-test +[ 10 ] [ -100 >bignum -10 >bignum /i ] unit-test +[ -10 ] [ 100 >bignum -10 >bignum /i ] unit-test + [ 3/2 ] [ 1 1/2 + ] unit-test [ 3/2 ] [ 1 >bignum 1/2 + ] unit-test [ -1/2 ] [ 1/2 1 - ] unit-test @@ -50,3 +57,17 @@ USE: test [ 1 ] [ 1/2 1/2 / ] unit-test [ 27/4 ] [ 3/2 2/9 / ] unit-test + +[ t ] [ 5768 476343 < ] unit-test +[ t ] [ 5768 476343 <= ] unit-test +[ f ] [ 5768 476343 > ] unit-test +[ f ] [ 5768 476343 >= ] unit-test +[ t ] [ 3434 >bignum 3434 >= ] unit-test +[ t ] [ 3434 3434 >bignum <= ] unit-test + +[ t ] [ 1 1/3 > ] unit-test +[ t ] [ 2/3 3/4 <= ] unit-test +[ f ] [ -2/3 1/3 > ] unit-test + +[ 3 ] [ 10/3 >integer ] unit-test +[ -3 ] [ -10/3 >integer ] unit-test diff --git a/native/arithmetic.c b/native/arithmetic.c index d063923780..9bd13db66c 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -10,9 +10,14 @@ RATIO* fixnum_to_ratio(CELL n) return ratio(n,tag_fixnum(1)); } +FLOAT* fixnum_to_float(CELL n) +{ + return make_float((double)untag_fixnum_fast(n)); +} + FIXNUM bignum_to_fixnum(CELL tagged) { - return (FIXNUM)(untag_bignum(tagged)->n); + return (FIXNUM)(((BIGNUM*)UNTAG(tagged))->n); } RATIO* bignum_to_ratio(CELL n) @@ -20,6 +25,17 @@ RATIO* bignum_to_ratio(CELL n) return ratio(n,tag_fixnum(1)); } +FLOAT* bignum_to_float(CELL tagged) +{ + return make_float((double)((BIGNUM*)UNTAG(tagged))->n); +} + +FLOAT* ratio_to_float(CELL tagged) +{ + RATIO* r = (RATIO*)UNTAG(tagged); + return (FLOAT*)UNTAG(divfloat(r->numerator,r->denominator)); +} + void primitive_numberp(void) { check_non_empty(env.dt); @@ -73,6 +89,7 @@ BINARY_OP(subtract, false, false) BINARY_OP(multiply, false, false) BINARY_OP(divide, false, false) BINARY_OP(divint, false, true) +BINARY_OP(divfloat, false, false) BINARY_OP(divmod, false, true) BINARY_OP(mod, false, true) BINARY_OP(and, false, true) diff --git a/native/arithmetic.h b/native/arithmetic.h index f10a14703f..2307c6e4c8 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -2,52 +2,49 @@ BIGNUM* fixnum_to_bignum(CELL n); RATIO* fixnum_to_ratio(CELL n); +FLOAT* fixnum_to_float(CELL n); FIXNUM bignum_to_fixnum(CELL tagged); RATIO* bignum_to_ratio(CELL n); +FLOAT* bignum_to_float(CELL n); +FLOAT* ratio_to_float(CELL n); #define CELL_TO_INTEGER(result) \ FIXNUM _result = (result); \ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \ - return tag_bignum(fixnum_to_bignum(_result)); \ + return tag_object(fixnum_to_bignum(_result)); \ else \ return tag_fixnum(_result); #define BIGNUM_2_TO_INTEGER(result) \ BIGNUM_2 _result = (result); \ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \ - return tag_bignum(bignum(_result)); \ + return tag_object(bignum(_result)); \ else \ return tag_fixnum(_result); #define BINARY_OP(OP,anytype,integerOnly) \ CELL OP(CELL x, CELL y) \ { \ - switch(TAG(x)) \ + switch(type_of(x)) \ { \ case FIXNUM_TYPE: \ \ - switch(TAG(y)) \ + switch(type_of(y)) \ { \ case FIXNUM_TYPE: \ return OP##_fixnum(x,y); \ - case OBJECT_TYPE: \ - switch(object_type(y)) \ - { \ - case BIGNUM_TYPE: \ - return OP##_bignum((CELL)fixnum_to_bignum(x),y); \ - default: \ - if(anytype) \ - return OP##_anytype(x,y); \ - else \ - type_error(FIXNUM_TYPE,y); \ - return F; \ - } \ - break; \ case RATIO_TYPE: \ if(integerOnly) \ return OP(x,to_integer(y)); \ else \ return OP##_ratio((CELL)fixnum_to_ratio(x),y); \ + case BIGNUM_TYPE: \ + return OP##_bignum((CELL)fixnum_to_bignum(x),y); \ + case FLOAT_TYPE: \ + if(integerOnly) \ + return OP(x,to_integer(y)); \ + else \ + return OP##_float((CELL)fixnum_to_float(x),y); \ default: \ if(anytype) \ return OP##_anytype(x,y); \ @@ -56,84 +53,93 @@ CELL OP(CELL x, CELL y) \ return F; \ } \ \ - case OBJECT_TYPE: \ + case RATIO_TYPE: \ \ - switch(object_type(x)) \ + switch(type_of(y)) \ { \ - \ + case FIXNUM_TYPE: \ + if(integerOnly) \ + return OP(to_integer(x),y); \ + else \ + return OP##_ratio(x,(CELL)fixnum_to_ratio(y)); \ + case RATIO_TYPE: \ + if(integerOnly) \ + return OP(to_integer(x),to_integer(y)); \ + else \ + return OP##_ratio(x,y); \ case BIGNUM_TYPE: \ - \ - switch(TAG(y)) \ - { \ - case FIXNUM_TYPE: \ - return OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \ - case OBJECT_TYPE: \ -\ - switch(object_type(y)) \ - { \ - case BIGNUM_TYPE: \ - return OP##_bignum(x,y); \ - default: \ - type_error(BIGNUM_TYPE,y); \ - return F; \ - } \ - case RATIO_TYPE: \ - if(integerOnly) \ - return OP(x,to_integer(y)); \ - else \ - return OP##_ratio((CELL)bignum_to_ratio(x),y); \ - default: \ - if(anytype) \ - return OP##_anytype(x,y); \ - else \ - type_error(BIGNUM_TYPE,y); \ - return F; \ - } \ -\ + if(integerOnly) \ + return OP(to_integer(x),y); \ + else \ + return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \ + case FLOAT_TYPE: \ + if(integerOnly) \ + return OP(to_integer(x),to_integer(y)); \ + else \ + return OP##_float((CELL)ratio_to_float(x),y); \ default: \ -\ if(anytype) \ return OP##_anytype(x,y); \ else \ - type_error(FIXNUM_TYPE,x); \ + type_error(FIXNUM_TYPE,y); \ return F; \ } \ \ - case RATIO_TYPE: \ + case BIGNUM_TYPE: \ + \ + switch(type_of(y)) \ + { \ + case FIXNUM_TYPE: \ + return OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \ + case RATIO_TYPE: \ + if(integerOnly) \ + return OP(x,to_integer(y)); \ + else \ + return OP##_ratio((CELL)bignum_to_ratio(x),y); \ + case BIGNUM_TYPE: \ + return OP##_bignum(x,y); \ + case FLOAT_TYPE: \ + if(integerOnly) \ + return OP(x,to_integer(y)); \ + else \ + return OP##_float((CELL)bignum_to_float(x),y); \ + default: \ + if(anytype) \ + return OP##_anytype(x,y); \ + else \ + type_error(BIGNUM_TYPE,y); \ + return F; \ + } \ \ - switch(TAG(y)) \ + case FLOAT_TYPE: \ + \ + switch(type_of(y)) \ { \ case FIXNUM_TYPE: \ if(integerOnly) \ return OP(to_integer(x),y); \ else \ - return OP##_ratio(x,(CELL)fixnum_to_ratio(y)); \ - case OBJECT_TYPE: \ - switch(object_type(y)) \ - { \ - case BIGNUM_TYPE: \ - if(integerOnly) \ - return OP(to_integer(x),y); \ - else \ - return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \ - default: \ - if(anytype) \ - return OP##_anytype(x,y); \ - else \ - type_error(FIXNUM_TYPE,y); \ - return F; \ - } \ - break; \ + return OP##_float(x,(CELL)fixnum_to_float(y)); \ case RATIO_TYPE: \ + if(integerOnly) \ + return OP(x,to_integer(y)); \ + else \ + return OP##_float(x,(CELL)ratio_to_float(y)); \ + case BIGNUM_TYPE: \ + if(integerOnly) \ + return OP(to_integer(x),y); \ + else \ + return OP##_float(x,(CELL)bignum_to_float(y)); \ + case FLOAT_TYPE: \ if(integerOnly) \ return OP(to_integer(x),to_integer(y)); \ else \ - return OP##_ratio(x,y); \ + return OP##_float(x,y); \ default: \ if(anytype) \ return OP##_anytype(x,y); \ else \ - type_error(FIXNUM_TYPE,y); \ + type_error(FLOAT_TYPE,y); \ return F; \ } \ \ @@ -157,16 +163,12 @@ void primitive_numberp(void); FIXNUM to_fixnum(CELL tagged); void primitive_to_fixnum(void); - BIGNUM* to_bignum(CELL tagged); void primitive_to_bignum(void); - CELL to_integer(CELL tagged); void primitive_to_integer(void); - CELL number_eq(CELL x, CELL y); void primitive_number_eq(void); - CELL add(CELL x, CELL y); void primitive_add(void); CELL subtract(CELL x, CELL y); @@ -177,14 +179,27 @@ CELL divide(CELL x, CELL y); void primitive_divmod(void); CELL divint(CELL x, CELL y); void primitive_divint(void); +CELL divfloat(CELL x, CELL y); +void primitive_divfloat(void); +CELL divide(CELL x, CELL y); void primitive_divide(void); +CELL less(CELL x, CELL y); void primitive_less(void); +CELL lesseq(CELL x, CELL y); void primitive_lesseq(void); +CELL greater(CELL x, CELL y); void primitive_greater(void); +CELL greatereq(CELL x, CELL y); void primitive_greatereq(void); +CELL mod(CELL x, CELL y); void primitive_mod(void); +CELL and(CELL x, CELL y); void primitive_and(void); +CELL or(CELL x, CELL y); void primitive_or(void); +CELL xor(CELL x, CELL y); void primitive_xor(void); +CELL shiftleft(CELL x, CELL y); void primitive_shiftleft(void); +CELL shiftright(CELL x, CELL y); void primitive_shiftright(void); diff --git a/native/array.c b/native/array.c index 484b8367d1..66ddf20d1b 100644 --- a/native/array.c +++ b/native/array.c @@ -3,7 +3,7 @@ /* untagged */ ARRAY* allot_array(CELL capacity) { - ARRAY* array = (ARRAY*)allot_object(ARRAY_TYPE, + ARRAY* array = allot_object(ARRAY_TYPE, sizeof(ARRAY) + capacity * CELLS); array->capacity = capacity; return array; diff --git a/native/bignum.c b/native/bignum.c index bc8941134c..e80c3f6b1c 100644 --- a/native/bignum.c +++ b/native/bignum.c @@ -9,6 +9,7 @@ void primitive_bignump(void) BIGNUM* to_bignum(CELL tagged) { RATIO* r; + FLOAT* f; switch(type_of(tagged)) { @@ -19,6 +20,9 @@ BIGNUM* to_bignum(CELL tagged) case RATIO_TYPE: r = (RATIO*)UNTAG(tagged); return to_bignum(divint(r->numerator,r->denominator)); + case FLOAT_TYPE: + f = (FLOAT*)UNTAG(tagged); + return bignum((BIGNUM_2)f->n); default: type_error(BIGNUM_TYPE,tagged); return NULL; /* can't happen */ @@ -27,7 +31,7 @@ BIGNUM* to_bignum(CELL tagged) void primitive_to_bignum(void) { - env.dt = tag_bignum(to_bignum(env.dt)); + env.dt = tag_object(to_bignum(env.dt)); } CELL number_eq_bignum(CELL x, CELL y) @@ -110,8 +114,8 @@ CELL divide_bignum(CELL x, CELL y) else { return tag_ratio(ratio( - tag_bignum(bignum(_x)), - tag_bignum(bignum(_y)))); + tag_object(bignum(_x)), + tag_object(bignum(_y)))); } } @@ -121,6 +125,13 @@ CELL divint_bignum(CELL x, CELL y) / ((BIGNUM*)UNTAG(y))->n)); } +CELL divfloat_bignum(CELL x, CELL y) +{ + BIGNUM_2 _x = ((BIGNUM*)UNTAG(x))->n; + BIGNUM_2 _y = ((BIGNUM*)UNTAG(y))->n; + return tag_object(make_float((double)_x / (double)_y)); +} + CELL divmod_bignum(CELL x, CELL y) { dpush(tag_object(bignum(((BIGNUM*)UNTAG(x))->n diff --git a/native/bignum.h b/native/bignum.h index d3a128a7ac..c9ebf0a221 100644 --- a/native/bignum.h +++ b/native/bignum.h @@ -8,7 +8,7 @@ typedef struct { /* untagged */ INLINE BIGNUM* allot_bignum() { - return (BIGNUM*)allot_object(BIGNUM_TYPE,sizeof(BIGNUM)); + return allot_object(BIGNUM_TYPE,sizeof(BIGNUM)); } /* untagged */ @@ -25,11 +25,6 @@ INLINE BIGNUM* untag_bignum(CELL tagged) return (BIGNUM*)UNTAG(tagged); } -INLINE CELL tag_bignum(BIGNUM* untagged) -{ - return RETAG(untagged,OBJECT_TYPE); -} - void primitive_bignump(void); BIGNUM* to_bignum(CELL tagged); void primitive_to_bignum(void); @@ -40,6 +35,7 @@ CELL multiply_bignum(CELL x, CELL y); BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y); CELL divide_bignum(CELL x, CELL y); CELL divint_bignum(CELL x, CELL y); +CELL divfloat_bignum(CELL x, CELL y); CELL divmod_bignum(CELL x, CELL y); CELL mod_bignum(CELL x, CELL y); CELL and_bignum(CELL x, CELL y); diff --git a/native/factor.h b/native/factor.h index d57677ac15..999aa1b807 100644 --- a/native/factor.h +++ b/native/factor.h @@ -46,6 +46,7 @@ typedef unsigned char BYTE; #include "fixnum.h" #include "bignum.h" #include "ratio.h" +#include "float.h" #include "arithmetic.h" #include "misc.h" #include "string.h" diff --git a/native/fixnum.c b/native/fixnum.c index c4d4285bb3..c03be42d43 100644 --- a/native/fixnum.c +++ b/native/fixnum.c @@ -15,6 +15,7 @@ void primitive_not(void) FIXNUM to_fixnum(CELL tagged) { RATIO* r; + FLOAT* f; switch(type_of(tagged)) { @@ -25,6 +26,9 @@ FIXNUM to_fixnum(CELL tagged) case RATIO_TYPE: r = (RATIO*)UNTAG(tagged); return to_fixnum(divint(r->numerator,r->denominator)); + case FLOAT_TYPE: + f = (FLOAT*)UNTAG(tagged); + return (FIXNUM)f->n; default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ @@ -60,7 +64,17 @@ CELL multiply_fixnum(CELL x, CELL y) CELL divint_fixnum(CELL x, CELL y) { /* division takes common factor of 8 out. */ - return tag_fixnum(x / y); + /* we have to do SIGNED division here */ + return tag_fixnum((FIXNUM)x / (FIXNUM)y); +} + +CELL divfloat_fixnum(CELL x, CELL y) +{ + /* division takes common factor of 8 out. */ + /* we have to do SIGNED division here */ + FIXNUM _x = (FIXNUM)x; + FIXNUM _y = (FIXNUM)y; + return tag_object(make_float((double)_x / (double)_y)); } CELL divmod_fixnum(CELL x, CELL y) @@ -107,6 +121,7 @@ CELL divide_fixnum(CELL x, CELL y) { FIXNUM _x = untag_fixnum_fast(x); FIXNUM _y = untag_fixnum_fast(y); + FIXNUM gcd; if(_y == 0) { @@ -119,7 +134,7 @@ CELL divide_fixnum(CELL x, CELL y) _y = -_y; } - FIXNUM gcd = gcd_fixnum(_x,_y); + gcd = gcd_fixnum(_x,_y); if(gcd != 1) { _x /= gcd; diff --git a/native/fixnum.h b/native/fixnum.h index 54750d9eef..af0e86967f 100644 --- a/native/fixnum.h +++ b/native/fixnum.h @@ -26,6 +26,7 @@ CELL multiply_fixnum(CELL x, CELL y); FIXNUM gcd_fixnum(FIXNUM x, FIXNUM y); CELL divide_fixnum(CELL x, CELL y); CELL divint_fixnum(CELL x, CELL y); +CELL divfloat_fixnum(CELL x, CELL y); CELL divmod_fixnum(CELL x, CELL y); CELL mod_fixnum(CELL x, CELL y); CELL and_fixnum(CELL x, CELL y); diff --git a/native/float.c b/native/float.c new file mode 100644 index 0000000000..f8c81b0ccf --- /dev/null +++ b/native/float.c @@ -0,0 +1,90 @@ +#include "factor.h" + +void primitive_floatp(void) +{ + check_non_empty(env.dt); + env.dt = tag_boolean(typep(FLOAT_TYPE,env.dt)); +} + +FLOAT* to_float(CELL tagged) +{ + switch(type_of(tagged)) + { + case FIXNUM_TYPE: + return fixnum_to_float(tagged); + case BIGNUM_TYPE: + return bignum_to_float(tagged); + case RATIO_TYPE: + return ratio_to_float(tagged); + case FLOAT_TYPE: + return (FLOAT*)UNTAG(tagged); + default: + type_error(FLOAT_TYPE,tagged); + return NULL; /* can't happen */ + } +} + +void primitive_to_float(void) +{ + env.dt = tag_object(to_float(env.dt)); +} + +CELL number_eq_float(CELL x, CELL y) +{ + return tag_boolean(((FLOAT*)UNTAG(x))->n + == ((FLOAT*)UNTAG(y))->n); +} + +CELL add_float(CELL x, CELL y) +{ + return tag_object(make_float(((FLOAT*)UNTAG(x))->n + + ((FLOAT*)UNTAG(y))->n)); +} + +CELL subtract_float(CELL x, CELL y) +{ + return tag_object(make_float(((FLOAT*)UNTAG(x))->n + - ((FLOAT*)UNTAG(y))->n)); +} + +CELL multiply_float(CELL x, CELL y) +{ + return tag_object(make_float(((FLOAT*)UNTAG(x))->n + * ((FLOAT*)UNTAG(y))->n)); +} + +CELL divide_float(CELL x, CELL y) +{ + return tag_object(make_float(((FLOAT*)UNTAG(x))->n + / ((FLOAT*)UNTAG(y))->n)); +} + +CELL divfloat_float(CELL x, CELL y) +{ + return tag_object(make_float(((FLOAT*)UNTAG(x))->n + / ((FLOAT*)UNTAG(y))->n)); +} + +CELL less_float(CELL x, CELL y) +{ + return tag_boolean(((FLOAT*)UNTAG(x))->n + < ((FLOAT*)UNTAG(y))->n); +} + +CELL lesseq_float(CELL x, CELL y) +{ + return tag_boolean(((FLOAT*)UNTAG(x))->n + <= ((FLOAT*)UNTAG(y))->n); +} + +CELL greater_float(CELL x, CELL y) +{ + return tag_boolean(((FLOAT*)UNTAG(x))->n + > ((FLOAT*)UNTAG(y))->n); +} + +CELL greatereq_float(CELL x, CELL y) +{ + return tag_boolean(((FLOAT*)UNTAG(x))->n + >= ((FLOAT*)UNTAG(y))->n); +} diff --git a/native/float.h b/native/float.h new file mode 100644 index 0000000000..acdbc1faee --- /dev/null +++ b/native/float.h @@ -0,0 +1,31 @@ +typedef struct { + CELL header; + double n; +} FLOAT; + +INLINE FLOAT* make_float(double n) +{ + FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(FLOAT)); + flo->n = n; + return flo; +} + +INLINE FLOAT* untag_float(CELL tagged) +{ + type_check(FLOAT_TYPE,tagged); + return (FLOAT*)UNTAG(tagged); +} + +void primitive_floatp(void); +FLOAT* to_float(CELL tagged); +void primitive_to_float(void); +CELL number_eq_float(CELL x, CELL y); +CELL add_float(CELL x, CELL y); +CELL subtract_float(CELL x, CELL y); +CELL multiply_float(CELL x, CELL y); +CELL divide_float(CELL x, CELL y); +CELL divfloat_float(CELL x, CELL y); +CELL less_float(CELL x, CELL y); +CELL lesseq_float(CELL x, CELL y); +CELL greater_float(CELL x, CELL y); +CELL greatereq_float(CELL x, CELL y); diff --git a/native/handle.c b/native/handle.c index 81b15f6e1c..6ef28b7a90 100644 --- a/native/handle.c +++ b/native/handle.c @@ -15,7 +15,7 @@ HANDLE* untag_handle(CELL type, CELL tagged) CELL handle(CELL type, CELL object) { - HANDLE* handle = (HANDLE*)allot_object(HANDLE_TYPE,sizeof(HANDLE)); + HANDLE* handle = allot_object(HANDLE_TYPE,sizeof(HANDLE)); handle->type = type; handle->object = object; handle->buffer = F; diff --git a/native/ratio.c b/native/ratio.c index 7c6abcc5dc..964b7143af 100644 --- a/native/ratio.c +++ b/native/ratio.c @@ -93,22 +93,43 @@ CELL divide_ratio(CELL x, CELL y) multiply(rx->denominator,ry->numerator)); } +CELL divfloat_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return divfloat( + multiply(rx->numerator,ry->denominator), + multiply(rx->denominator,ry->numerator)); +} + CELL less_ratio(CELL x, CELL y) { - return F; + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return less(multiply(rx->numerator,ry->denominator), + multiply(ry->numerator,rx->denominator)); } CELL lesseq_ratio(CELL x, CELL y) { - return F; + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return lesseq(multiply(rx->numerator,ry->denominator), + multiply(ry->numerator,rx->denominator)); } CELL greater_ratio(CELL x, CELL y) { - return F; + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return greater(multiply(rx->numerator,ry->denominator), + multiply(ry->numerator,rx->denominator)); } CELL greatereq_ratio(CELL x, CELL y) { - return F; + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return greatereq(multiply(rx->numerator,ry->denominator), + multiply(ry->numerator,rx->denominator)); } diff --git a/native/ratio.h b/native/ratio.h index 53073fcf0a..cfb0d89cc1 100644 --- a/native/ratio.h +++ b/native/ratio.h @@ -24,6 +24,7 @@ CELL add_ratio(CELL x, CELL y); CELL subtract_ratio(CELL x, CELL y); CELL multiply_ratio(CELL x, CELL y); CELL divide_ratio(CELL x, CELL y); +CELL divfloat_ratio(CELL x, CELL y); CELL less_ratio(CELL x, CELL y); CELL lesseq_ratio(CELL x, CELL y); CELL greater_ratio(CELL x, CELL y); diff --git a/native/sbuf.c b/native/sbuf.c index 388c9aabac..86f9a2f154 100644 --- a/native/sbuf.c +++ b/native/sbuf.c @@ -2,7 +2,7 @@ SBUF* sbuf(FIXNUM capacity) { - SBUF* sbuf = (SBUF*)allot_object(SBUF_TYPE,sizeof(SBUF)); + SBUF* sbuf = allot_object(SBUF_TYPE,sizeof(SBUF)); sbuf->top = 0; sbuf->string = string(capacity,'\0'); return sbuf; diff --git a/native/string.c b/native/string.c index 254fb7c4ea..9e1759d29b 100644 --- a/native/string.c +++ b/native/string.c @@ -3,7 +3,7 @@ /* untagged */ STRING* allot_string(CELL capacity) { - STRING* string = (STRING*)allot_object(STRING_TYPE, + STRING* string = allot_object(STRING_TYPE, sizeof(STRING) + capacity * CHARS); string->capacity = capacity; return string; diff --git a/native/types.c b/native/types.c index 915057e84a..35d1d45a4d 100644 --- a/native/types.c +++ b/native/types.c @@ -51,11 +51,11 @@ void type_check(CELL type, CELL tagged) * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ -CELL allot_object(CELL type, CELL length) +void* allot_object(CELL type, CELL length) { CELL* object = allot(length); *object = tag_header(type); - return (CELL)object; + return object; } CELL object_size(CELL pointer) diff --git a/native/types.h b/native/types.h index 1ed7333a65..bf51c0842f 100644 --- a/native/types.h +++ b/native/types.h @@ -33,6 +33,7 @@ CELL empty; #define SBUF_TYPE 12 #define HANDLE_TYPE 13 #define BIGNUM_TYPE 14 +#define FLOAT_TYPE 15 bool typep(CELL type, CELL tagged); CELL type_of(CELL tagged); @@ -77,6 +78,6 @@ INLINE CELL object_type(CELL tagged) return untag_header(get(UNTAG(tagged))); } -CELL allot_object(CELL type, CELL length); +void* allot_object(CELL type, CELL length); CELL untagged_object_size(CELL pointer); CELL object_size(CELL pointer); diff --git a/native/vector.c b/native/vector.c index 880e8e32ec..5a64932b48 100644 --- a/native/vector.c +++ b/native/vector.c @@ -2,7 +2,7 @@ VECTOR* vector(FIXNUM capacity) { - VECTOR* vector = (VECTOR*)allot_object(VECTOR_TYPE,sizeof(VECTOR)); + VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(VECTOR)); vector->top = 0; vector->array = array(capacity,F); return vector; diff --git a/native/word.c b/native/word.c index 7a81293878..ebf765458d 100644 --- a/native/word.c +++ b/native/word.c @@ -2,7 +2,7 @@ WORD* word(CELL primitive, CELL parameter, CELL plist) { - WORD* word = (WORD*)allot_object(WORD_TYPE,sizeof(WORD)); + WORD* word = allot_object(WORD_TYPE,sizeof(WORD)); word->xt = primitive_to_xt(primitive); word->primitive = primitive; word->parameter = parameter; -- 2.34.1