From ba77598f0d071c76cbf406d1738391f08b549e51 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Aug 2004 02:43:58 +0000 Subject: [PATCH] ratios --- TODO.FACTOR.txt | 2 +- library/cross-compiler.factor | 7 + library/image.factor | 11 +- library/interpreter.factor | 4 +- library/platform/jvm/arithmetic.factor | 6 + library/platform/native/kernel.factor | 1 + library/platform/native/parse-numbers.factor | 21 +- library/platform/native/parser.factor | 4 +- library/platform/native/unparser.factor | 8 + library/test/math.factor | 16 -- library/test/math/rational.factor | 52 ++++ native/arithmetic.c | 285 ++++++++++++++++++- native/arithmetic.h | 77 ++++- native/array.c | 6 +- native/cons.c | 2 +- native/factor.h | 1 + native/fixnum.c | 14 - native/fixnum.h | 1 - native/gc.c | 8 +- native/gc.h | 2 +- native/memory.c | 4 +- native/memory.h | 2 +- native/primitives.c | 201 ++++++------- native/primitives.h | 2 +- native/ratio.c | 49 ++++ native/ratio.h | 21 ++ native/relocate.c | 6 +- native/sbuf.c | 7 +- native/stack.c | 4 +- native/string.c | 5 +- native/types.c | 8 +- native/types.h | 5 +- 32 files changed, 653 insertions(+), 189 deletions(-) create mode 100644 library/test/math/rational.factor create mode 100644 native/ratio.c create mode 100644 native/ratio.h diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 563a8815fc..815c0b83b1 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -2,12 +2,12 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ] +- handle division by zero - prettyprinter: space after #<>, space after ~<< foo - fixup-words is crusty - decide if overflow is a fatal error - f >n: crashes - typecases: type error reporting bad -- floats - {...} vectors in java factor - parsing should be parsing - describe-word diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 685a0a57f9..e59dc1e34d 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -41,6 +41,8 @@ USE: words IN: arithmetic DEFER: number= +DEFER: >integer +DEFER: /i IN: kernel DEFER: getenv @@ -115,12 +117,17 @@ IN: cross-compiler number? >fixnum >bignum + >integer number= fixnum? bignum? + ratio? + numerator + denominator + - * + /i / mod /mod diff --git a/library/image.factor b/library/image.factor index 53aa9995f9..b129645ac8 100644 --- a/library/image.factor +++ b/library/image.factor @@ -63,11 +63,12 @@ USE: words : untag ( cell tag -- ) tag-mask bitnot bitand ; : tag ( cell -- tag ) tag-mask bitand ; -: fixnum-tag BIN: 000 ; -: word-tag BIN: 001 ; -: cons-tag BIN: 010 ; -: object-tag BIN: 011 ; -: header-tag BIN: 100 ; +: fixnum-tag BIN: 000 ; +: word-tag BIN: 001 ; +: cons-tag BIN: 010 ; +: object-tag BIN: 011 ; +: rational-tag BIN: 100 ; +: header-tag BIN: 101 ; : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ; : >header ( id -- tagged ) header-tag immediate ; diff --git a/library/interpreter.factor b/library/interpreter.factor index 51beb01377..cfdf8117c0 100644 --- a/library/interpreter.factor +++ b/library/interpreter.factor @@ -100,8 +100,8 @@ USE: vectors : room. ( -- ) room - 1024 / unparse write " KB total, " write - 1024 / unparse write " KB free" print ; + 1024 /i unparse write " KB total, " write + 1024 /i unparse write " KB free" print ; : help ( -- ) "SESSION:" print diff --git a/library/platform/jvm/arithmetic.factor b/library/platform/jvm/arithmetic.factor index 01247fede4..a09e90f673 100644 --- a/library/platform/jvm/arithmetic.factor +++ b/library/platform/jvm/arithmetic.factor @@ -51,6 +51,12 @@ USE: stack "factor.math.FactorMath" "divide" jinvoke-static ; inline +: /i ( a b -- a/b ) + #! Truncating division. + [ "java.lang.Number" "java.lang.Number" ] + "factor.math.FactorMath" "_divide" + jinvoke-static ; inline + : mod ( a b -- a%b ) [ "java.lang.Number" "java.lang.Number" ] "factor.math.FactorMath" "mod" diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 1458c6cc53..0a0c59da07 100644 --- a/library/platform/native/kernel.factor +++ b/library/platform/native/kernel.factor @@ -76,6 +76,7 @@ USE: unparser [ [ fixnum? ] [ drop "fixnum" ] [ bignum? ] [ drop "bignum" ] + [ ratio? ] [ drop "ratio" ] [ cons? ] [ drop "cons" ] [ word? ] [ drop "word" ] [ f = ] [ drop "f" ] diff --git a/library/platform/native/parse-numbers.factor b/library/platform/native/parse-numbers.factor index c10a4d8fa4..8430865c44 100644 --- a/library/platform/native/parse-numbers.factor +++ b/library/platform/native/parse-numbers.factor @@ -61,20 +61,31 @@ USE: unparser not-a-number ] ifte ; -: (str>fixnum) ( str -- num ) +: (str>integer) ( str -- num ) 0 swap [ digit> digit ] str-each ; -: str>fixnum ( str -- num ) +: str>integer ( str -- num ) #! Parse a string representation of an integer. dup str-length 0 = [ drop not-a-number ] [ dup "-" str-head? dup [ - nip str>fixnum neg + nip str>integer neg ] [ - drop (str>fixnum) + drop (str>integer) ] ifte ] ifte ; +: str>ratio ( str -- num ) + dup CHAR: / index-of str// + swap str>integer swap str>integer / ; + +: str>number ( str -- num ) + "/" over str-contains? [ + str>ratio + ] [ + str>integer + ] ifte ; + : parse-number ( str -- num/f ) - [ str>fixnum ] [ [ drop f ] when ] catch ; + [ str>number ] [ [ drop f ] when ] catch ; diff --git a/library/platform/native/parser.factor b/library/platform/native/parser.factor index 11f9e34a22..4e7462f954 100644 --- a/library/platform/native/parser.factor +++ b/library/platform/native/parser.factor @@ -97,7 +97,7 @@ USE: unparser dup "use" get search dup [ nip ] [ - drop str>fixnum + drop str>number ] ifte ; : parsed| ( obj -- ) @@ -111,7 +111,7 @@ USE: unparser over "|" = [ nip parsed| expect-] ] [ swons ] ifte ; : number, ( num -- ) - str>fixnum parsed ; + str>number parsed ; : word, ( str -- ) [ diff --git a/library/platform/native/unparser.factor b/library/platform/native/unparser.factor index cd260d1fdd..741c5e9584 100644 --- a/library/platform/native/unparser.factor +++ b/library/platform/native/unparser.factor @@ -53,6 +53,13 @@ USE: vocabularies : unparse-integer ( num -- str ) <% integer- integer% %> ; +: unparse-ratio ( num -- str ) + <% dup + numerator integer- integer% + CHAR: / % + denominator integer- integer% + %> ; + : >base ( num radix -- string ) #! Convert a number to a string in a certain base. [ "base" set unparse-integer ] bind ; @@ -104,6 +111,7 @@ USE: vocabularies [ f eq? ] [ drop "f" ] [ word? ] [ unparse-word ] [ integer? ] [ unparse-integer ] + [ ratio? ] [ unparse-ratio ] [ string? ] [ unparse-str ] [ drop t ] [ <% "#<" % class-of % ">" % %> ] ] cond ; diff --git a/library/test/math.factor b/library/test/math.factor index ba1220bbdb..d1c13e9dbc 100644 --- a/library/test/math.factor +++ b/library/test/math.factor @@ -17,23 +17,7 @@ USE: test [ 4 ] [ 132 -64 ] [ gcd ] test-word [ 4 ] [ -132 -64 ] [ gcd ] test-word -! Some ratio tests. - -[ t ] [ 10 3 ] [ / ratio? ] test-word -[ f ] [ 10 2 ] [ / ratio? ] test-word -[ 10 ] [ 10 ] [ numerator ] test-word -[ 1 ] [ 10 ] [ denominator ] test-word -[ 12 ] [ -12 -13 ] [ / numerator ] test-word -[ 13 ] [ -12 -13 ] [ / denominator ] test-word -[ 1 ] [ -1 -1 ] [ / numerator ] test-word -[ 1 ] [ -1 -1 ] [ / denominator ] test-word - -[ -1 ] [ 2 -2 ] [ / ] test-word -[ -1 ] [ -2 2 ] [ / ] test-word - ! Make sure computation results are sane types. - -[ t ] [ 1 3 / 1 3 / ] [ = ] test-word [ t ] [ 30 2^ ] [ fixnum? ] test-word [ t ] [ 32 2^ ] [ bignum? ] test-word diff --git a/library/test/math/rational.factor b/library/test/math/rational.factor new file mode 100644 index 0000000000..ee46b4e153 --- /dev/null +++ b/library/test/math/rational.factor @@ -0,0 +1,52 @@ +IN: scratchpad +USE: arithmetic +USE: kernel +USE: stack +USE: test + +[ t ] [ 0 fixnum? ] unit-test +[ t ] [ 2345621 fixnum? ] unit-test + +[ t ] [ 2345621 dup >bignum >fixnum = ] unit-test + +[ t ] [ 0 >fixnum 0 >bignum = ] unit-test +[ f ] [ 0 >fixnum 1 >bignum = ] unit-test +[ f ] [ 1 >bignum 0 >bignum = ] unit-test +[ t ] [ 0 >bignum 0 >fixnum = ] unit-test + +[ t ] [ 0 >bignum bignum? ] unit-test +[ f ] [ 0 >fixnum bignum? ] unit-test +[ f ] [ 0 >fixnum bignum? ] unit-test +[ t ] [ 0 >fixnum fixnum? ] unit-test + +[ -1 ] [ 1 neg ] unit-test +[ -1 ] [ 1 >bignum neg ] unit-test + +[ 9 3 ] [ 93 10 /mod ] unit-test +[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test + +[ 5 ] [ 2 >bignum 3 >bignum + ] unit-test + +[ 1/2 ] [ 1 >bignum 2 >bignum / ] unit-test +[ t ] [ 10 3 / ratio? ] unit-test +[ f ] [ 10 2 / ratio? ] unit-test +[ 10 ] [ 10 numerator ] unit-test +[ 1 ] [ 10 denominator ] unit-test +[ 12 ] [ -12 -13 / numerator ] unit-test +[ 13 ] [ -12 -13 / denominator ] unit-test +[ 1 ] [ -1 -1 / numerator ] unit-test +[ 1 ] [ -1 -1 / denominator ] unit-test + +[ -1 ] [ 2 -2 / ] unit-test +[ -1 ] [ -2 2 / ] unit-test + +[ t ] [ 1 3 / 1 3 / = ] unit-test + +[ 3/2 ] [ 1 1/2 + ] unit-test +[ 3/2 ] [ 1 >bignum 1/2 + ] unit-test +[ -1/2 ] [ 1/2 1 - ] unit-test +[ -1/2 ] [ 1/2 1 >bignum - ] unit-test +[ 41/20 ] [ 5/4 4/5 + ] unit-test + +[ 1 ] [ 1/2 1/2 / ] unit-test +[ 27/4 ] [ 3/2 2/9 / ] unit-test diff --git a/native/arithmetic.c b/native/arithmetic.c index eb1a02fdb8..16dfc96e15 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -8,22 +8,28 @@ void primitive_numberp(void) { case FIXNUM_TYPE: case BIGNUM_TYPE: - return T; + case RATIO_TYPE: + env.dt = T; break; default: - return F; + env.dt = F; break; } } FIXNUM to_fixnum(CELL tagged) { + RATIO* r; + switch(type_of(tagged)) { case FIXNUM_TYPE: return untag_fixnum_fast(tagged); case BIGNUM_TYPE: return bignum_to_fixnum(tagged); + case RATIO_TYPE: + r = (RATIO*)UNTAG(tagged); + return to_fixnum(divint(r->numerator,r->denominator)); default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ @@ -32,26 +38,54 @@ FIXNUM to_fixnum(CELL tagged) void primitive_to_fixnum(void) { - return tag_fixnum(to_fixnum(env.dt)); + env.dt = tag_fixnum(to_fixnum(env.dt)); } BIGNUM* to_bignum(CELL tagged) { + RATIO* r; + switch(type_of(tagged)) { case FIXNUM_TYPE: return fixnum_to_bignum(tagged); case BIGNUM_TYPE: - return tagged; + return (BIGNUM*)UNTAG(tagged); + case RATIO_TYPE: + r = (RATIO*)UNTAG(tagged); + return to_bignum(divint(r->numerator,r->denominator)); default: type_error(BIGNUM_TYPE,tagged); - return -1; /* can't happen */ + return NULL; /* can't happen */ } } void primitive_to_bignum(void) { - return tag_bignum(to_bignum(env.dt)); + env.dt = tag_bignum(to_bignum(env.dt)); +} + +CELL to_integer(CELL tagged) +{ + RATIO* r; + + switch(type_of(tagged)) + { + case FIXNUM_TYPE: + case BIGNUM_TYPE: + return tagged; + case RATIO_TYPE: + r = (RATIO*)UNTAG(tagged); + return divint(r->numerator,r->denominator); + default: + type_error(FIXNUM_TYPE,tagged); + return NULL; /* can't happen */ + } +} + +void primitive_to_integer(void) +{ + env.dt = to_integer(env.dt); } /* EQUALITY */ @@ -66,6 +100,15 @@ CELL number_eq_bignum(CELL x, CELL y) == ((BIGNUM*)UNTAG(y))->n); } +CELL number_eq_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return tag_boolean( + untag_boolean(number_eq(rx->numerator,ry->numerator)) && + untag_boolean(number_eq(rx->denominator,ry->denominator))); +} + CELL number_eq_anytype(CELL x, CELL y) { return F; @@ -85,6 +128,15 @@ CELL add_bignum(CELL x, CELL y) + ((BIGNUM*)UNTAG(y))->n)); } +CELL add_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return divide(add(multiply(rx->numerator,ry->denominator), + multiply(rx->denominator,ry->numerator)), + multiply(rx->denominator,ry->denominator)); +} + BINARY_OP(add,false) /* SUBTRACTION */ @@ -99,6 +151,15 @@ CELL subtract_bignum(CELL x, CELL y) - ((BIGNUM*)UNTAG(y))->n)); } +CELL subtract_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return divide(subtract(multiply(rx->numerator,ry->denominator), + multiply(rx->denominator,ry->numerator)), + multiply(rx->denominator,ry->denominator)); +} + BINARY_OP(subtract,false) /* MULTIPLICATION */ @@ -114,8 +175,165 @@ CELL multiply_bignum(CELL x, CELL y) * ((BIGNUM*)UNTAG(y))->n)); } +CELL multiply_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return divide( + multiply(rx->numerator,ry->numerator), + multiply(rx->denominator,ry->denominator)); +} + BINARY_OP(multiply,false) +FIXNUM gcd_fixnum(FIXNUM x, FIXNUM y) +{ + FIXNUM t; + + if(x < 0) + x = -x; + if(y < 0) + y = -y; + + if(x > y) + { + t = x; + x = y; + y = t; + } + + for(;;) + { + if(x == 0) + return y; + + t = y % x; + y = x; + x = t; + } +} + +BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y) +{ + BIGNUM_2 t; + + if(x < 0) + x = -x; + if(y < 0) + y = -y; + + if(x > y) + { + t = x; + x = y; + y = t; + } + + for(;;) + { + if(x == 0) + return y; + + t = y % x; + y = x; + x = t; + } +} + +/* DIVISION */ +INLINE CELL divide_fixnum(CELL x, CELL y) +{ + FIXNUM _x = untag_fixnum_fast(x); + FIXNUM _y = untag_fixnum_fast(y); + + if(_y == 0) + { + /* FIXME */ + abort(); + } + else if(_y < 0) + { + _x = -_x; + _y = -_y; + } + + FIXNUM gcd = gcd_fixnum(_x,_y); + if(gcd != 1) + { + _x /= gcd; + _y /= gcd; + } + + if(_y == 1) + return tag_fixnum(_x); + else + return tag_ratio(ratio(tag_fixnum(_x),tag_fixnum(_y))); +} + +CELL divide_bignum(CELL x, CELL y) +{ + BIGNUM_2 _x = ((BIGNUM*)UNTAG(x))->n; + BIGNUM_2 _y = ((BIGNUM*)UNTAG(y))->n; + + if(_y == 0) + { + /* FIXME */ + abort(); + } + else if(_y < 0) + { + _x = -_x; + _y = -_y; + } + + BIGNUM_2 gcd = gcd_bignum(_x,_y); + if(gcd != 1) + { + _x /= gcd; + _y /= gcd; + } + + if(_y == 1) + return tag_object(bignum(_x)); + else + { + return tag_ratio(ratio( + tag_bignum(bignum(_x)), + tag_bignum(bignum(_y)))); + } +} + +CELL divide_ratio(CELL x, CELL y) +{ + RATIO* rx = (RATIO*)UNTAG(x); + RATIO* ry = (RATIO*)UNTAG(y); + return divide( + multiply(rx->numerator,ry->denominator), + multiply(rx->denominator,ry->numerator)); +} + +BINARY_OP(divide,false) + +/* DIVINT */ +INLINE CELL divint_fixnum(CELL x, CELL y) +{ + /* division takes common factor of 8 out. */ + return tag_fixnum(x / y); +} + +CELL divint_bignum(CELL x, CELL y) +{ + return tag_object(bignum(((BIGNUM*)UNTAG(x))->n + / ((BIGNUM*)UNTAG(y))->n)); +} + +CELL divint_ratio(CELL x, CELL y) +{ + return F; +} + +BINARY_OP(divint,false) + /* DIVMOD */ INLINE CELL divmod_fixnum(CELL x, CELL y) { @@ -133,6 +351,11 @@ CELL divmod_bignum(CELL x, CELL y) % ((BIGNUM*)UNTAG(y))->n)); } +CELL divmod_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(divmod,false) /* MOD */ @@ -147,6 +370,11 @@ CELL mod_bignum(CELL x, CELL y) % ((BIGNUM*)UNTAG(y))->n)); } +CELL mod_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(mod,false) /* AND */ @@ -161,6 +389,11 @@ CELL and_bignum(CELL x, CELL y) & ((BIGNUM*)UNTAG(y))->n)); } +CELL and_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(and,false) /* OR */ @@ -175,6 +408,11 @@ CELL or_bignum(CELL x, CELL y) | ((BIGNUM*)UNTAG(y))->n)); } +CELL or_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(or,false) /* XOR */ @@ -189,6 +427,11 @@ CELL xor_bignum(CELL x, CELL y) ^ ((BIGNUM*)UNTAG(y))->n)); } +CELL xor_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(xor,false) /* SHIFTLEFT */ @@ -204,6 +447,11 @@ CELL shiftleft_bignum(CELL x, CELL y) << ((BIGNUM*)UNTAG(y))->n)); } +CELL shiftleft_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(shiftleft,false) /* SHIFTRIGHT */ @@ -219,6 +467,11 @@ CELL shiftright_bignum(CELL x, CELL y) >> ((BIGNUM*)UNTAG(y))->n)); } +CELL shiftright_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(shiftright,false) /* LESS */ @@ -233,6 +486,11 @@ CELL less_bignum(CELL x, CELL y) < ((BIGNUM*)UNTAG(y))->n); } +CELL less_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(less,false) /* LESSEQ */ @@ -247,6 +505,11 @@ CELL lesseq_bignum(CELL x, CELL y) <= ((BIGNUM*)UNTAG(y))->n); } +CELL lesseq_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(lesseq,false) /* GREATER */ @@ -261,6 +524,11 @@ CELL greater_bignum(CELL x, CELL y) > ((BIGNUM*)UNTAG(y))->n); } +CELL greater_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(greater,false) /* GREATEREQ */ @@ -275,4 +543,9 @@ CELL greatereq_bignum(CELL x, CELL y) >= ((BIGNUM*)UNTAG(y))->n); } +CELL greatereq_ratio(CELL x, CELL y) +{ + return F; +} + BINARY_OP(greatereq,false) diff --git a/native/arithmetic.h b/native/arithmetic.h index 5c0ffd2d91..6b38ab320a 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -5,11 +5,21 @@ INLINE BIGNUM* fixnum_to_bignum(CELL n) return bignum((BIGNUM_2)untag_fixnum_fast(n)); } +INLINE RATIO* fixnum_to_ratio(CELL n) +{ + return ratio(n,tag_fixnum(1)); +} + INLINE FIXNUM bignum_to_fixnum(CELL tagged) { return (FIXNUM)(untag_bignum(tagged)->n); } +INLINE RATIO* bignum_to_ratio(CELL n) +{ + return ratio(n,tag_fixnum(1)); +} + #define CELL_TO_INTEGER(result) \ FIXNUM _result = (result); \ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \ @@ -45,18 +55,18 @@ CELL OP(CELL x, CELL y) \ return OP##_anytype(x,y); \ else \ type_error(FIXNUM_TYPE,y); \ - break; \ + return F; \ } \ break; \ + case RATIO_TYPE: \ + return OP##_ratio((CELL)fixnum_to_ratio(x),y); \ default: \ if(anytype) \ return OP##_anytype(x,y); \ else \ type_error(FIXNUM_TYPE,y); \ - break; \ + return F; \ } \ -\ - break; \ \ case OBJECT_TYPE: \ \ @@ -75,20 +85,19 @@ CELL OP(CELL x, CELL y) \ { \ case BIGNUM_TYPE: \ return OP##_bignum(x,y); \ - break; \ default: \ type_error(BIGNUM_TYPE,y); \ - break; \ + return F; \ } \ - break; \ + case RATIO_TYPE: \ + return OP##_ratio((CELL)bignum_to_ratio(x),y); \ default: \ if(anytype) \ return OP##_anytype(x,y); \ else \ type_error(BIGNUM_TYPE,y); \ - break; \ + return F; \ } \ - break; \ \ default: \ \ @@ -96,10 +105,37 @@ CELL OP(CELL x, CELL y) \ return OP##_anytype(x,y); \ else \ type_error(FIXNUM_TYPE,x); \ - break; \ + return F; \ } \ \ - break; \ + case RATIO_TYPE: \ +\ + switch(TAG(y)) \ + { \ + case FIXNUM_TYPE: \ + return OP##_ratio(x,(CELL)fixnum_to_ratio(y)); \ + case OBJECT_TYPE: \ + switch(object_type(y)) \ + { \ + case BIGNUM_TYPE: \ + 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; \ + case RATIO_TYPE: \ + return OP##_ratio(x,y); \ + default: \ + if(anytype) \ + return OP##_anytype(x,y); \ + else \ + type_error(FIXNUM_TYPE,y); \ + return F; \ + } \ \ default: \ \ @@ -107,7 +143,7 @@ CELL OP(CELL x, CELL y) \ return OP##_anytype(x,y); \ else \ type_error(FIXNUM_TYPE,x); \ - break; \ + return F; \ } \ } \ \ @@ -118,16 +154,25 @@ void primitive_##OP(void) \ } 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); + void primitive_add(void); void primitive_subtract(void); void primitive_multiply(void); void primitive_divmod(void); +void primitive_divint(void); +void primitive_divide(void); void primitive_less(void); void primitive_lesseq(void); void primitive_greater(void); @@ -138,3 +183,11 @@ void primitive_or(void); void primitive_xor(void); void primitive_shiftleft(void); void primitive_shiftright(void); + +CELL add(CELL x, CELL y); +CELL subtract(CELL x, CELL y); +CELL multiply(CELL x, CELL y); +CELL divide(CELL x, CELL y); +CELL divint(CELL x, CELL y); + +FIXNUM gcd_fixnum(FIXNUM x, FIXNUM y); diff --git a/native/array.c b/native/array.c index cafce2ec46..484b8367d1 100644 --- a/native/array.c +++ b/native/array.c @@ -41,18 +41,18 @@ void fixup_array(ARRAY* array) { int i = 0; for(i = 0; i < array->capacity; i++) - fixup(AREF(array,i)); + fixup((void*)AREF(array,i)); } void collect_array(ARRAY* array) { int i = 0; for(i = 0; i < array->capacity; i++) - copy_object(AREF(array,i)); + copy_object((void*)AREF(array,i)); } /* copy an array to newspace */ ARRAY* copy_array(ARRAY* array) { - return (ARRAY*)copy_untagged_object(array,ASIZE(array)); + return copy_untagged_object(array,ASIZE(array)); } diff --git a/native/cons.c b/native/cons.c index 809cd27fd6..757cb9c41d 100644 --- a/native/cons.c +++ b/native/cons.c @@ -2,7 +2,7 @@ CONS* cons(CELL car, CELL cdr) { - CONS* cons = (CONS*)allot(sizeof(CONS)); + CONS* cons = allot(sizeof(CONS)); cons->car = car; cons->cdr = cdr; return cons; diff --git a/native/factor.h b/native/factor.h index 33770f175e..7a667467d5 100644 --- a/native/factor.h +++ b/native/factor.h @@ -43,6 +43,7 @@ typedef unsigned char BYTE; #include "handle.h" #include "fixnum.h" #include "bignum.h" +#include "ratio.h" #include "arithmetic.h" #include "misc.h" #include "string.h" diff --git a/native/fixnum.c b/native/fixnum.c index 81d3bd32fa..2097f7387e 100644 --- a/native/fixnum.c +++ b/native/fixnum.c @@ -1,25 +1,11 @@ #include "factor.h" -#define BINARY_OP(x,y) \ - FIXNUM x, y; \ - y = env.dt; \ - type_check(FIXNUM_TYPE,y); \ - x = dpop(); \ - type_check(FIXNUM_TYPE,x); - void primitive_fixnump(void) { check_non_empty(env.dt); env.dt = tag_boolean(TAG(env.dt) == FIXNUM_TYPE); } -void primitive_divide(void) -{ - BINARY_OP(x,y); - /* division takes common factor of 8 out. */ - env.dt = tag_fixnum(x / y); -} - void primitive_not(void) { type_check(FIXNUM_TYPE,env.dt); diff --git a/native/fixnum.h b/native/fixnum.h index a76c74b761..0e294d02ae 100644 --- a/native/fixnum.h +++ b/native/fixnum.h @@ -14,5 +14,4 @@ INLINE CELL tag_fixnum(FIXNUM untagged) } void primitive_fixnump(void); -void primitive_divide(void); void primitive_not(void); diff --git a/native/gc.c b/native/gc.c index 13f64d9e22..653622b699 100644 --- a/native/gc.c +++ b/native/gc.c @@ -11,9 +11,9 @@ INLINE void gc_debug(char* msg, CELL x) { } /* Given a pointer to a pointer to oldspace, copy it to newspace. */ -CELL copy_untagged_object(CELL pointer, CELL size) +void* copy_untagged_object(void* pointer, CELL size) { - CELL newpointer = allot(size); + void* newpointer = allot(size); memcpy(newpointer,pointer,size); return newpointer; @@ -51,7 +51,7 @@ void copy_object(CELL* handle) else { gc_debug("copy_object",pointer); - newpointer = copy_untagged_object(UNTAG(pointer), + newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer), object_size(pointer)); put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); } @@ -100,7 +100,7 @@ void collect_next(void) collect_object(); break; default: - copy_object(scan); + copy_object((CELL*)scan); scan += CELLS; break; } diff --git a/native/gc.h b/native/gc.h index 4c21edd868..9059c8412e 100644 --- a/native/gc.h +++ b/native/gc.h @@ -1,6 +1,6 @@ CELL scan; -CELL copy_untagged_object(CELL pointer, CELL size); +void* copy_untagged_object(void* pointer, CELL size); void copy_object(CELL* handle); void collect_object(void); void collect_next(void); diff --git a/native/memory.c b/native/memory.c index e3193ccabc..c3a178cccb 100644 --- a/native/memory.c +++ b/native/memory.c @@ -21,7 +21,7 @@ void init_arena(CELL size) active = z1; } -CELL allot(CELL a) +void* allot(CELL a) { CELL h = active->here; active->here = align8(active->here + a); @@ -43,7 +43,7 @@ CELL allot(CELL a) env.cf = env.user[GC_ENV]; } - return h; + return (void*)h; } void flip_zones() diff --git a/native/memory.h b/native/memory.h index 0538b64479..e193ecafe9 100644 --- a/native/memory.h +++ b/native/memory.h @@ -13,7 +13,7 @@ ZONE* prior; /* if active==z1, z2; if active==z2, z1 */ void init_arena(CELL size); void flip_zones(); -CELL allot(CELL a); +void* allot(CELL a); INLINE CELL align8(CELL a) { diff --git a/native/primitives.c b/native/primitives.c index fb20259a13..faa282ab3c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -1,109 +1,114 @@ #include "factor.h" XT primitives[] = { - undefined, /* 0 */ - call, /* 1 */ - primitive_execute, /* 2 */ - primitive_call, /* 3 */ - primitive_ifte, /* 4 */ - primitive_consp, /* 5 */ - primitive_cons, /* 6 */ - primitive_car, /* 7 */ - primitive_cdr, /* 8 */ - primitive_set_car, /* 9 */ - primitive_set_cdr, /* 10 */ - primitive_vectorp, /* 11 */ - primitive_vector, /* 12 */ - primitive_vector_length, /* 13 */ - primitive_set_vector_length, /* 14 */ - primitive_vector_nth, /* 15 */ - primitive_set_vector_nth, /* 16 */ - primitive_stringp, /* 17 */ - primitive_string_length, /* 18 */ - primitive_string_nth, /* 19 */ - primitive_string_compare, /* 20 */ - primitive_string_eq, /* 21 */ - primitive_string_hashcode, /* 22 */ - primitive_index_of, /* 23 */ - primitive_substring, /* 24 */ - primitive_sbufp, /* 25 */ - primitive_sbuf, /* 26 */ - primitive_sbuf_length, /* 27 */ - primitive_set_sbuf_length, /* 28 */ - primitive_sbuf_nth, /* 29 */ - primitive_set_sbuf_nth, /* 30 */ - primitive_sbuf_append, /* 31 */ - primitive_sbuf_to_string, /* 32 */ - primitive_numberp, /* 33 */ - primitive_to_fixnum, /* 34 */ - primitive_to_bignum, /* 35 */ - primitive_number_eq, /* 36 */ - primitive_fixnump, /* 37 */ - primitive_bignump, /* 38 */ - primitive_add, /* 39 */ - primitive_subtract, /* 40 */ - primitive_multiply, /* 41 */ - primitive_divide, /* 42 */ - primitive_mod, /* 43 */ - primitive_divmod, /* 44 */ - primitive_and, /* 45 */ - primitive_or, /* 46 */ - primitive_xor, /* 47 */ - primitive_not, /* 48 */ - primitive_shiftleft, /* 49 */ - primitive_shiftright, /* 50 */ - primitive_less, /* 51 */ - primitive_lesseq, /* 52 */ - primitive_greater, /* 53 */ - primitive_greatereq, /* 54 */ - primitive_wordp, /* 55 */ - primitive_word, /* 56 */ - primitive_word_primitive, /* 57 */ - primitive_set_word_primitive, /* 58 */ - primitive_word_parameter, /* 59 */ - primitive_set_word_parameter, /* 60 */ - primitive_word_plist, /* 61 */ - primitive_set_word_plist, /* 62 */ - primitive_drop, /* 63 */ - primitive_dup, /* 64 */ - primitive_swap, /* 65 */ - primitive_over, /* 66 */ - primitive_pick, /* 67 */ - primitive_nip, /* 68 */ - primitive_tuck, /* 69 */ - primitive_rot, /* 70 */ - primitive_to_r, /* 71 */ - primitive_from_r, /* 72 */ - primitive_eq, /* 73 */ - primitive_getenv, /* 74 */ - primitive_setenv, /* 75 */ - primitive_open_file, /* 76 */ - primitive_gc, /* 77 */ - primitive_save_image, /* 78 */ - primitive_datastack, /* 79 */ - primitive_callstack, /* 80 */ - primitive_set_datastack, /* 81 */ - primitive_set_callstack, /* 82 */ - primitive_handlep, /* 83 */ - primitive_exit, /* 84 */ - primitive_server_socket, /* 85 */ - primitive_close_fd, /* 86 */ - primitive_accept_fd, /* 87 */ - primitive_read_line_fd_8, /* 88 */ - primitive_write_fd_8, /* 89 */ - primitive_flush_fd, /* 90 */ - primitive_shutdown_fd, /* 91 */ - primitive_room, /* 92 */ - primitive_os_env, /* 93 */ - primitive_millis, /* 94 */ - primitive_init_random, /* 95 */ - primitive_random_int /* 96 */ + undefined, + call, + primitive_execute, + primitive_call, + primitive_ifte, + primitive_consp, + primitive_cons, + primitive_car, + primitive_cdr, + primitive_set_car, + primitive_set_cdr, + primitive_vectorp, + primitive_vector, + primitive_vector_length, + primitive_set_vector_length, + primitive_vector_nth, + primitive_set_vector_nth, + primitive_stringp, + primitive_string_length, + primitive_string_nth, + primitive_string_compare, + primitive_string_eq, + primitive_string_hashcode, + primitive_index_of, + primitive_substring, + primitive_sbufp, + primitive_sbuf, + primitive_sbuf_length, + primitive_set_sbuf_length, + primitive_sbuf_nth, + primitive_set_sbuf_nth, + primitive_sbuf_append, + primitive_sbuf_to_string, + primitive_numberp, + primitive_to_fixnum, + primitive_to_bignum, + primitive_to_integer, + primitive_number_eq, + primitive_fixnump, + primitive_bignump, + primitive_ratiop, + primitive_numerator, + primitive_denominator, + primitive_add, + primitive_subtract, + primitive_multiply, + primitive_divint, + primitive_divide, + primitive_mod, + primitive_divmod, + primitive_and, + primitive_or, + primitive_xor, + primitive_not, + primitive_shiftleft, + primitive_shiftright, + primitive_less, + primitive_lesseq, + primitive_greater, + primitive_greatereq, + primitive_wordp, + primitive_word, + primitive_word_primitive, + primitive_set_word_primitive, + primitive_word_parameter, + primitive_set_word_parameter, + primitive_word_plist, + primitive_set_word_plist, + primitive_drop, + primitive_dup, + primitive_swap, + primitive_over, + primitive_pick, + primitive_nip, + primitive_tuck, + primitive_rot, + primitive_to_r, + primitive_from_r, + primitive_eq, + primitive_getenv, + primitive_setenv, + primitive_open_file, + primitive_gc, + primitive_save_image, + primitive_datastack, + primitive_callstack, + primitive_set_datastack, + primitive_set_callstack, + primitive_handlep, + primitive_exit, + primitive_server_socket, + primitive_close_fd, + primitive_accept_fd, + primitive_read_line_fd_8, + primitive_write_fd_8, + primitive_flush_fd, + primitive_shutdown_fd, + primitive_room, + primitive_os_env, + primitive_millis, + primitive_init_random, + primitive_random_int }; CELL primitive_to_xt(CELL primitive) { if(primitive < 0 || primitive >= PRIMITIVE_COUNT) general_error(ERROR_BAD_PRIMITIVE,tag_fixnum(primitive)); - + return (CELL)primitives[primitive]; } diff --git a/native/primitives.h b/native/primitives.h index ed832dadb4..8d32ff1680 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 97 +#define PRIMITIVE_COUNT 102 CELL primitive_to_xt(CELL primitive); diff --git a/native/ratio.c b/native/ratio.c new file mode 100644 index 0000000000..720fd9dac8 --- /dev/null +++ b/native/ratio.c @@ -0,0 +1,49 @@ +#include "factor.h" + +RATIO* ratio(CELL numerator, CELL denominator) +{ + RATIO* ratio = (RATIO*)allot(sizeof(RATIO)); + ratio->numerator = numerator; + ratio->denominator = denominator; + return ratio; +} + +void primitive_ratiop(void) +{ + check_non_empty(env.dt); + env.dt = tag_boolean(typep(RATIO_TYPE,env.dt)); +} + +void primitive_numerator(void) +{ + switch(type_of(env.dt)) + { + case FIXNUM_TYPE: + case BIGNUM_TYPE: + /* No op */ + break; + case RATIO_TYPE: + env.dt = untag_ratio(env.dt)->numerator; + break; + default: + type_error(RATIO_TYPE,env.dt); + break; + } +} + +void primitive_denominator(void) +{ + switch(type_of(env.dt)) + { + case FIXNUM_TYPE: + case BIGNUM_TYPE: + env.dt = tag_fixnum(1); + break; + case RATIO_TYPE: + env.dt = untag_ratio(env.dt)->denominator; + break; + default: + type_error(RATIO_TYPE,env.dt); + break; + } +} diff --git a/native/ratio.h b/native/ratio.h new file mode 100644 index 0000000000..836f243c49 --- /dev/null +++ b/native/ratio.h @@ -0,0 +1,21 @@ +typedef struct { + CELL numerator; + CELL denominator; +} RATIO; + +INLINE RATIO* untag_ratio(CELL tagged) +{ + type_check(RATIO_TYPE,tagged); + return (RATIO*)UNTAG(tagged); +} + +INLINE CELL tag_ratio(RATIO* ratio) +{ + return RETAG(ratio,RATIO_TYPE); +} + +RATIO* ratio(CELL numerator, CELL denominator); + +void primitive_ratiop(void); +void primitive_numerator(void); +void primitive_denominator(void); diff --git a/native/relocate.c b/native/relocate.c index 7d29c20176..8d7b8b0d44 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -57,17 +57,17 @@ void relocate(CELL r) EMPTY, F, T */ if(untag_header(get(relocating)) != EMPTY_TYPE) fatal_error("Not empty",get(relocating)); - empty = tag_object(relocating); + empty = tag_object((CELL*)relocating); relocate_next(); if(untag_header(get(relocating)) != F_TYPE) fatal_error("Not F",get(relocating)); - F = tag_object(relocating); + F = tag_object((CELL*)relocating); relocate_next(); if(untag_header(get(relocating)) != T_TYPE) fatal_error("Not T",get(relocating)); - T = tag_object(relocating); + T = tag_object((CELL*)relocating); relocate_next(); for(;;) diff --git a/native/sbuf.c b/native/sbuf.c index 03cf879a6c..388c9aabac 100644 --- a/native/sbuf.c +++ b/native/sbuf.c @@ -83,8 +83,8 @@ void sbuf_append_string(SBUF* sbuf, STRING* string) CELL top = sbuf->top; CELL strlen = string->capacity; sbuf_ensure_capacity(sbuf,top + strlen); - memcpy((CELL)sbuf->string + sizeof(STRING) + top * CHARS, - (CELL)string + sizeof(STRING),strlen * CHARS); + memcpy((void*)((CELL)sbuf->string + sizeof(STRING) + top * CHARS), + (void*)((CELL)string + sizeof(STRING)),strlen * CHARS); } void primitive_sbuf_append(void) @@ -123,7 +123,8 @@ void primitive_sbuf_to_string(void) void fixup_sbuf(SBUF* sbuf) { - sbuf->string = (CELL)sbuf->string + (active->base - relocation_base); + sbuf->string = (STRING*)((CELL)sbuf->string + + (active->base - relocation_base)); } void collect_sbuf(SBUF* sbuf) diff --git a/native/stack.c b/native/stack.c index d42f4bbef0..f4b7115229 100644 --- a/native/stack.c +++ b/native/stack.c @@ -104,7 +104,7 @@ VECTOR* stack_to_vector(CELL top, CELL bottom) CELL depth = (top - bottom - sizeof(ARRAY)) / CELLS - 1; VECTOR* v = vector(depth); ARRAY* a = v->array; - memcpy(a + 1,bottom + sizeof(ARRAY) + CELLS,depth * CELLS); + memcpy(a + 1,(void*)(bottom + sizeof(ARRAY) + CELLS),depth * CELLS); v->top = depth; return v; } @@ -126,7 +126,7 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom) { CELL start = bottom + sizeof(ARRAY) + CELLS; CELL len = vector->top * CELLS; - memcpy(start,vector->array + 1,len); + memcpy((void*)start,vector->array + 1,len); return start + len; } diff --git a/native/string.c b/native/string.c index 5b851bb6c0..254fb7c4ea 100644 --- a/native/string.c +++ b/native/string.c @@ -215,7 +215,10 @@ void primitive_index_of(void) string = untag_string(dpop()); index = to_fixnum(dpop()); if(index < 0 || index > string->capacity) + { range_error(tag_object(string),index,string->capacity); + result = -1; /* can't happen */ + } else if(TAG(ch) == FIXNUM_TYPE) result = index_of_ch(index,string,to_fixnum(ch)); else @@ -235,7 +238,7 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string) result = allot_string(end - start); memcpy(result + 1, - (CELL)(string + 1) + CHARS * start, + (void*)((CELL)(string + 1) + CHARS * start), CHARS * (end - start)); hash_string(result); diff --git a/native/types.c b/native/types.c index cc86afa567..915057e84a 100644 --- a/native/types.c +++ b/native/types.c @@ -53,9 +53,9 @@ void type_check(CELL type, CELL tagged) */ CELL allot_object(CELL type, CELL length) { - CELL object = allot(length); - put(object,tag_header(type)); - return object; + CELL* object = allot(length); + *object = tag_header(type); + return (CELL)object; } CELL object_size(CELL pointer) @@ -66,6 +66,8 @@ CELL object_size(CELL pointer) return align8(sizeof(CONS)); case WORD_TYPE: return align8(sizeof(WORD)); + case RATIO_TYPE: + return align8(sizeof(RATIO)); case OBJECT_TYPE: return untagged_object_size(UNTAG(pointer)); default: diff --git a/native/types.h b/native/types.h index 1da17611da..1ed7333a65 100644 --- a/native/types.h +++ b/native/types.h @@ -9,8 +9,9 @@ #define WORD_TYPE 1 #define CONS_TYPE 2 #define OBJECT_TYPE 3 -#define HEADER_TYPE 4 -#define GC_COLLECTED 5 /* See gc.c */ +#define RATIO_TYPE 4 +#define HEADER_TYPE 5 +#define GC_COLLECTED 6 /* See gc.c */ /*** Header types ***/