steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ratios

cvs
Slava Pestov 2004-08-05 02:43:58 +00:00
parent faa6913759
commit ba77598f0d
32 changed files with 653 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

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

7
library/cross-compiler.factor
View File

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

3
library/image.factor
View File

@ -67,7 +67,8 @@ USE: words
: word-tag BIN: 001 ;
: cons-tag BIN: 010 ;
: object-tag BIN: 011 ;
: header-tag BIN: 100 ;
: rational-tag BIN: 100 ;
: header-tag BIN: 101 ;
: immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
: >header ( id -- tagged ) header-tag immediate ;

4
library/interpreter.factor
View File

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

6
library/platform/jvm/arithmetic.factor
View File

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

1
library/platform/native/kernel.factor
View File

@ -76,6 +76,7 @@ USE: unparser
[
[ fixnum? ] [ drop "fixnum" ]
[ bignum? ] [ drop "bignum" ]
[ ratio? ] [ drop "ratio" ]
[ cons? ] [ drop "cons" ]
[ word? ] [ drop "word" ]
[ f = ] [ drop "f" ]

21
library/platform/native/parse-numbers.factor
View File

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

4
library/platform/native/parser.factor
View File

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

8
library/platform/native/unparser.factor
View File

@ -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.
<namespace> [ "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 ;

16
library/test/math.factor
View File

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

52
library/test/math/rational.factor Normal file
View File

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

285
native/arithmetic.c
View File

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

75
native/arithmetic.h
View File

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

6
native/array.c
View File

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

2
native/cons.c
View File

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

1
native/factor.h
View File

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

14
native/fixnum.c
View File

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

1
native/fixnum.h
View File

@ -14,5 +14,4 @@ INLINE CELL tag_fixnum(FIXNUM untagged)
}
void primitive_fixnump(void);
void primitive_divide(void);
void primitive_not(void);

8
native/gc.c
View File

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

2
native/gc.h
View File

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

4
native/memory.c
View File

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

2
native/memory.h
View File

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

199
native/primitives.c
View File

@ -1,103 +1,108 @@
#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)

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 97
#define PRIMITIVE_COUNT 102
CELL primitive_to_xt(CELL primitive);

49
native/ratio.c Normal file
View File

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

21
native/ratio.h Normal file
View File

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

6
native/relocate.c
View File

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

7
native/sbuf.c
View File

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

4
native/stack.c
View File

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

5
native/string.c
View File

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

8
native/types.c
View File

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

5
native/types.h
View File

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