From: Slava Pestov Date: Fri, 6 Aug 2004 00:29:52 +0000 (+0000) Subject: complex numbers X-Git-Tag: release-0-61~19 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=2740c77a1094800655db3a41b895fbac2bf814d8 complex numbers --- diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 791979ccff..1c66319c13 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,8 @@ + native: +- printing floats: append .0 always +- vector= +- make-image: take a parameter, include le & be images in dist - do something about "base" variable -- too fragile ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ] - errors: don't show .factor-rc diff --git a/build.sh b/build.sh index 78a8fc4c6e..056f96997c 100644 --- a/build.sh +++ b/build.sh @@ -1,5 +1,5 @@ export CC=gcc34 -export CFLAGS="-pedantic -Wall -Winline -O2 -march=pentium4 -fomit-frame-pointer" +export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer" $CC $CFLAGS -o f native/*.c diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index bbe6582448..89d61b4e0e 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -134,6 +134,11 @@ IN: cross-compiler float? str>float unparse-float + complex? + real + imaginary + >rect + rect> + - * diff --git a/library/image.factor b/library/image.factor index b129645ac8..a6566cd8b7 100644 --- a/library/image.factor +++ b/library/image.factor @@ -68,7 +68,9 @@ USE: words : cons-tag BIN: 010 ; : object-tag BIN: 011 ; : rational-tag BIN: 100 ; -: header-tag BIN: 101 ; +: complex-tag BIN: 101 ; +: header-tag BIN: 110 ; +: gc-fwd-ptr BIN: 111 ; ( we don't output these ) : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ; : >header ( id -- tagged ) header-tag immediate ; diff --git a/library/platform/jvm/arithmetic.factor b/library/platform/jvm/arithmetic.factor index a09e90f673..34a7ee3a4b 100644 --- a/library/platform/jvm/arithmetic.factor +++ b/library/platform/jvm/arithmetic.factor @@ -63,7 +63,7 @@ USE: stack jinvoke-static ; inline : /mod ( a b -- a/b a%b ) - 2dup / >fixnum -rot mod ; + 2dup /i -rot mod ; : > ( a b -- boolean ) [ "java.lang.Number" "java.lang.Number" ] diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor index eb5e241bd2..d1d7976b10 100644 --- a/library/platform/native/boot.factor +++ b/library/platform/native/boot.factor @@ -79,6 +79,7 @@ primitives, "/library/vocabulary-style.factor" "/library/words.factor" "/library/math/math-combinators.factor" + "/library/math/list-math.factor" "/library/math/namespace-math.factor" "/library/test/test.factor" "/library/platform/native/arithmetic.factor" diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 8d16c30eb4..28fea86585 100644 --- a/library/platform/native/kernel.factor +++ b/library/platform/native/kernel.factor @@ -73,19 +73,20 @@ USE: unparser : class-of ( obj -- name ) [ - [ fixnum? ] [ drop "fixnum" ] - [ bignum? ] [ drop "bignum" ] - [ ratio? ] [ drop "ratio" ] - [ float? ] [ drop "float" ] - [ cons? ] [ drop "cons" ] - [ word? ] [ drop "word" ] - [ f = ] [ drop "f" ] - [ t = ] [ drop "t" ] - [ vector? ] [ drop "vector" ] - [ string? ] [ drop "string" ] - [ sbuf? ] [ drop "sbuf" ] - [ handle? ] [ drop "handle" ] - [ drop t ] [ drop "unknown" ] + [ fixnum? ] [ drop "fixnum" ] + [ bignum? ] [ drop "bignum" ] + [ ratio? ] [ drop "ratio" ] + [ float? ] [ drop "float" ] + [ complex? ] [ drop "complex" ] + [ cons? ] [ drop "cons" ] + [ word? ] [ drop "word" ] + [ f = ] [ drop "f" ] + [ t = ] [ drop "t" ] + [ vector? ] [ drop "vector" ] + [ string? ] [ drop "string" ] + [ sbuf? ] [ drop "sbuf" ] + [ handle? ] [ drop "handle" ] + [ drop t ] [ drop "unknown" ] ] cond ; : toplevel ( -- ) diff --git a/native/arithmetic.c b/native/arithmetic.c index 8cc8670273..a28fbeace2 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -36,24 +36,51 @@ FLOAT* ratio_to_float(CELL tagged) return (FLOAT*)UNTAG(divfloat(r->numerator,r->denominator)); } -void primitive_numberp(void) +bool realp(CELL tagged) { - check_non_empty(env.dt); - - switch(type_of(env.dt)) + switch(type_of(tagged)) { case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE: - env.dt = T; + return true; break; default: - env.dt = F; + return false; break; } } +bool numberp(CELL tagged) +{ + return realp(tagged) || type_of(tagged) == COMPLEX_TYPE; +} + +void primitive_numberp(void) +{ + check_non_empty(env.dt); + env.dt = tag_boolean(numberp(env.dt)); +} + +bool zerop(CELL tagged) +{ + switch(type_of(tagged)) + { + case FIXNUM_TYPE: + return tagged == 0; + case BIGNUM_TYPE: + return ((BIGNUM*)UNTAG(tagged))->n == 0; + case FLOAT_TYPE: + return ((FLOAT*)UNTAG(tagged))->n == 0.0; + case RATIO_TYPE: + return false; + default: + critical_error("Bad parameter to zerop",tagged); + return false; /* Can't happen */ + } +} + CELL to_integer(CELL tagged) { RATIO* r; @@ -67,7 +94,7 @@ CELL to_integer(CELL tagged) r = (RATIO*)UNTAG(tagged); return divint(r->numerator,r->denominator); default: - type_error(FIXNUM_TYPE,tagged); + type_error(INTEGER_TYPE,tagged); return NULL; /* can't happen */ } } diff --git a/native/arithmetic.h b/native/arithmetic.h index 2307c6e4c8..bb65d94085 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -35,14 +35,28 @@ CELL OP(CELL x, CELL y) \ return OP##_fixnum(x,y); \ case RATIO_TYPE: \ if(integerOnly) \ - return OP(x,to_integer(y)); \ + { \ + type_error(FIXNUM_TYPE,y); \ + return F; \ + } \ else \ return OP##_ratio((CELL)fixnum_to_ratio(x),y); \ + case COMPLEX_TYPE: \ + if(integerOnly) \ + { \ + type_error(FIXNUM_TYPE,y); \ + return F; \ + } \ + else \ + return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \ case BIGNUM_TYPE: \ return OP##_bignum((CELL)fixnum_to_bignum(x),y); \ case FLOAT_TYPE: \ if(integerOnly) \ - return OP(x,to_integer(y)); \ + { \ + type_error(FIXNUM_TYPE,y); \ + return F; \ + } \ else \ return OP##_float((CELL)fixnum_to_float(x),y); \ default: \ @@ -54,29 +68,53 @@ CELL OP(CELL x, CELL y) \ } \ \ case RATIO_TYPE: \ +\ + if(integerOnly) \ + { \ + type_error(FIXNUM_TYPE,x); \ + return F; \ + } \ \ 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)); \ + 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); \ + return OP##_ratio(x,y); \ + case COMPLEX_TYPE: \ + return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \ case BIGNUM_TYPE: \ - if(integerOnly) \ - return OP(to_integer(x),y); \ - else \ - return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \ + return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \ case FLOAT_TYPE: \ - if(integerOnly) \ - return OP(to_integer(x),to_integer(y)); \ + return OP##_float((CELL)ratio_to_float(x),y); \ + default: \ + if(anytype) \ + return OP##_anytype(x,y); \ else \ - return OP##_float((CELL)ratio_to_float(x),y); \ + type_error(FIXNUM_TYPE,y); \ + return F; \ + } \ +\ + case COMPLEX_TYPE: \ +\ + if(integerOnly) \ + { \ + type_error(FIXNUM_TYPE,x); \ + return F; \ + } \ +\ + switch(type_of(y)) \ + { \ + case FIXNUM_TYPE: \ + return OP##_complex(x,(CELL)complex(y,tag_fixnum(0))); \ + case RATIO_TYPE: \ + return OP##_complex(x,(CELL)complex(y,tag_fixnum(0))); \ + case COMPLEX_TYPE: \ + return OP##_complex(x,y); \ + case BIGNUM_TYPE: \ + return OP##_complex(x,(CELL)complex(y,tag_fixnum(0))); \ + case FLOAT_TYPE: \ + return OP##_complex(x,(CELL)complex(y,tag_fixnum(0))); \ default: \ if(anytype) \ return OP##_anytype(x,y); \ @@ -93,14 +131,28 @@ CELL OP(CELL x, CELL y) \ return OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \ case RATIO_TYPE: \ if(integerOnly) \ - return OP(x,to_integer(y)); \ + { \ + type_error(BIGNUM_TYPE,y); \ + return F; \ + } \ else \ return OP##_ratio((CELL)bignum_to_ratio(x),y); \ + case COMPLEX_TYPE: \ + if(integerOnly) \ + { \ + type_error(BIGNUM_TYPE,y); \ + return F; \ + } \ + else \ + return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \ case BIGNUM_TYPE: \ return OP##_bignum(x,y); \ case FLOAT_TYPE: \ if(integerOnly) \ - return OP(x,to_integer(y)); \ + { \ + type_error(BIGNUM_TYPE,y); \ + return F; \ + } \ else \ return OP##_float((CELL)bignum_to_float(x),y); \ default: \ @@ -112,34 +164,27 @@ CELL OP(CELL x, CELL y) \ } \ \ case FLOAT_TYPE: \ - \ +\ + if(integerOnly) \ + { \ + type_error(FIXNUM_TYPE,x); \ + return F; \ + } \ +\ switch(type_of(y)) \ { \ case FIXNUM_TYPE: \ - if(integerOnly) \ - return OP(to_integer(x),y); \ - else \ - return OP##_float(x,(CELL)fixnum_to_float(y)); \ + 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)); \ + return OP##_float(x,(CELL)ratio_to_float(y)); \ + case COMPLEX_TYPE: \ + return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \ case BIGNUM_TYPE: \ - if(integerOnly) \ - return OP(to_integer(x),y); \ - else \ - return OP##_float(x,(CELL)bignum_to_float(y)); \ + 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##_float(x,y); \ + return OP##_float(x,y); \ default: \ - if(anytype) \ - return OP##_anytype(x,y); \ - else \ - type_error(FLOAT_TYPE,y); \ + type_error(FLOAT_TYPE,y); \ return F; \ } \ \ @@ -159,8 +204,12 @@ void primitive_##OP(void) \ env.dt = OP(x,y); \ } +bool realp(CELL tagged); +bool numberp(CELL tagged); void primitive_numberp(void); +bool zerop(CELL tagged); + FIXNUM to_fixnum(CELL tagged); void primitive_to_fixnum(void); BIGNUM* to_bignum(CELL tagged); diff --git a/native/factor.h b/native/factor.h index 999aa1b807..a0f63db657 100644 --- a/native/factor.h +++ b/native/factor.h @@ -47,6 +47,7 @@ typedef unsigned char BYTE; #include "bignum.h" #include "ratio.h" #include "float.h" +#include "complex.h" #include "arithmetic.h" #include "misc.h" #include "string.h" diff --git a/native/primitives.c b/native/primitives.c index 2d15625eef..e963313916 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -48,6 +48,11 @@ XT primitives[] = { primitive_floatp, primitive_str_to_float, primitive_float_to_str, + primitive_complexp, + primitive_real, + primitive_imaginary, + primitive_to_rect, + primitive_from_rect, primitive_add, primitive_subtract, primitive_multiply, diff --git a/native/primitives.h b/native/primitives.h index 8146fe1669..3847b25c06 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 107 +#define PRIMITIVE_COUNT 112 CELL primitive_to_xt(CELL primitive); diff --git a/native/ratio.c b/native/ratio.c index 964b7143af..4b7bba4297 100644 --- a/native/ratio.c +++ b/native/ratio.c @@ -2,7 +2,7 @@ RATIO* ratio(CELL numerator, CELL denominator) { - RATIO* ratio = (RATIO*)allot(sizeof(RATIO)); + RATIO* ratio = allot(sizeof(RATIO)); ratio->numerator = numerator; ratio->denominator = denominator; return ratio; @@ -26,7 +26,7 @@ void primitive_numerator(void) env.dt = untag_ratio(env.dt)->numerator; break; default: - type_error(RATIO_TYPE,env.dt); + type_error(RATIONAL_TYPE,env.dt); break; } } @@ -43,7 +43,7 @@ void primitive_denominator(void) env.dt = untag_ratio(env.dt)->denominator; break; default: - type_error(RATIO_TYPE,env.dt); + type_error(RATIONAL_TYPE,env.dt); break; } } diff --git a/native/types.c b/native/types.c index a549d3b6f5..ec7899abb0 100644 --- a/native/types.c +++ b/native/types.c @@ -60,20 +60,32 @@ void* allot_object(CELL type, CELL length) CELL object_size(CELL pointer) { + CELL size; + switch(TAG(pointer)) { case CONS_TYPE: - return align8(sizeof(CONS)); + size = sizeof(CONS); + break; case WORD_TYPE: - return align8(sizeof(WORD)); + size = sizeof(WORD); + break; case RATIO_TYPE: - return align8(sizeof(RATIO)); + size = sizeof(RATIO); + break; + case COMPLEX_TYPE: + size = sizeof(COMPLEX); + break; case OBJECT_TYPE: - return untagged_object_size(UNTAG(pointer)); + size = untagged_object_size(UNTAG(pointer)); + break; default: critical_error("Cannot determine size",pointer); - return -1; + size = 0; /* Can't happen */ + break; } + + return align8(size); } CELL untagged_object_size(CELL pointer) diff --git a/native/types.h b/native/types.h index bf51c0842f..5f12ce5c64 100644 --- a/native/types.h +++ b/native/types.h @@ -10,8 +10,9 @@ #define CONS_TYPE 2 #define OBJECT_TYPE 3 #define RATIO_TYPE 4 -#define HEADER_TYPE 5 -#define GC_COLLECTED 6 /* See gc.c */ +#define COMPLEX_TYPE 5 +#define HEADER_TYPE 6 +#define GC_COLLECTED 7 /* See gc.c */ /*** Header types ***/ @@ -35,6 +36,11 @@ CELL empty; #define BIGNUM_TYPE 14 #define FLOAT_TYPE 15 +/* Pseudo-types. For error reporting only. */ +#define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */ +#define RATIONAL_TYPE 101 /* INTEGER or RATIO */ +#define REAL_TYPE 102 /* RATIONAL or FLOAT */ + bool typep(CELL type, CELL tagged); CELL type_of(CELL tagged); void type_check(CELL type, CELL tagged);