first cut at floats

diff --git a/build.sh b/build.sh
index 056f96997ce2a3a652a39442c364bd0543a82f60..78a8fc4c6ebfd065f969ee3c710a0e3d6e5adcf6 100644 (file)
--- 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 ee46b4e153d156e1f8161dc95c2c19f26b02d414..edcc8ff101921e9d870a887fc98a7698f7098037 100644 (file)
--- 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 d063923780ee4ebd62f8bb585cba21ed1a9d0588..9bd13db66ccf7ef8c9d5d05fabf637b3921128b0 100644 (file)
--- 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 f10a14703fb5a5bbd5e3513986ac3eaf15b2a180..2307c6e4c81f835c52d1b2c6c97750f1299b68d9 100644 (file)
--- 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 484b8367d161aaeae9098497c1b6f23e6d7e9b27..66ddf20d1b26bf7b0f45581c5399aba9e7f57200 100644 (file)
--- 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 bc8941134cc934e9cfea9d2a7cd604bb27288a92..e80c3f6b1ce17821fbc9bb327026d5bfc2ccc1e8 100644 (file)
--- 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 d3a128a7ac45b0c63270fb8f221837e5df00fbe2..c9ebf0a221c644027242d2b8bc718a50e3365dee 100644 (file)
--- 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 d57677ac155cc4a420358639ade4920641bbbf06..999aa1b80777fd5daad4149053d715a85681942d 100644 (file)
--- 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 c4d4285bb3c10efc2f46c5d36faf76386e767a6c..c03be42d43d420de282e9ddd3cdb2e7e870cf04c 100644 (file)
--- 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 54750d9eef7c09c2e3a02535387c9ab766208a2a..af0e86967f1de86bd499597fe3e2180c6b8e6c68 100644 (file)
--- 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 (file)
index 0000000..f8c81b0
--- /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 (file)
index 0000000..acdbc1f
--- /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 81b15f6e1c624979c656c34b815602baf2c2ae5c..6ef28b7a906ea26946c4fb862ef775f521a8d880 100644 (file)
--- 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 7c6abcc5dcc7dafd12393740f12c7b2fe1ce992b..964b7143afba2bf61cae5bc9f069a4224eb34f6e 100644 (file)
--- 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 53073fcf0a02007751b77130d1186d3cd48df9ce..cfb0d89cc118ed80079ddb64b21cdc526ac916b4 100644 (file)
--- 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 388c9aabac633f5406fd90b6cc01ce2640d5f62b..86f9a2f154051eb354fd83ab41ad46fd6c071dcc 100644 (file)
--- 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 254fb7c4eadf892b2a970fd39eb7b7c97ae0c1e9..9e1759d29be8daad8fb3652953ba488662194a28 100644 (file)
--- 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 915057e84aee76fb810e72482a6f6bd5128666d0..35d1d45a4dbd9d01e06d582b15add4ff93fa83c4 100644 (file)
--- 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 1ed7333a650b0696c28a2ee9adc91816279b0a23..bf51c0842f72bf1e9fe338873b75a7dd647be639 100644 (file)
--- 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 880e8e32ec918e6280bc59420b31b511a44ae639..5a64932b486430db8b6dc25eca8d9d4f80c80ee8 100644 (file)
--- 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 7a812938782be345b322144280ab0efcc5bef9e0..ebf765458d814f8f701a9fc4718eadc1fe0d03e6 100644 (file)
--- 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;