complex numbers

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

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
 

library/cross-compiler.factor

@@ -134,6 +134,11 @@ IN: cross-compiler
         float?
         str>float
         unparse-float
+        complex?
+        real
+        imaginary
+        >rect
+        rect>
         +
         -
         *

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 ;

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

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"

library/platform/native/kernel.factor

@@ -73,19 +73,20 @@ USE: unparser
 
 : class-of ( obj -- name )
     [
-        [ fixnum? ] [ drop "fixnum" ]
+        [ fixnum?  ] [ drop "fixnum" ]
-        [ bignum? ] [ drop "bignum" ]
+        [ bignum?  ] [ drop "bignum" ]
-        [ ratio?  ] [ drop "ratio" ]
+        [ ratio?   ] [ drop "ratio" ]
-        [ float?  ] [ drop "float" ]
+        [ float?   ] [ drop "float" ]
-        [ cons?   ] [ drop "cons" ]
+        [ complex? ] [ drop "complex" ]
-        [ word?   ] [ drop "word" ]
+        [ cons?    ] [ drop "cons" ]
-        [ f =     ] [ drop "f" ]
+        [ word?    ] [ drop "word" ]
-        [ t =     ] [ drop "t" ]
+        [ f =      ] [ drop "f" ]
-        [ vector? ] [ drop "vector" ]
+        [ t =      ] [ drop "t" ]
-        [ string? ] [ drop "string" ]
+        [ vector?  ] [ drop "vector" ]
-        [ sbuf?   ] [ drop "sbuf" ]
+        [ string?  ] [ drop "string" ]
-        [ handle? ] [ drop "handle" ]
+        [ sbuf?    ] [ drop "sbuf" ]
-        [ drop t  ] [ drop "unknown" ]
+        [ handle?  ] [ drop "handle" ]
+        [ drop t   ] [ drop "unknown" ]
     ] cond ;
 
 : toplevel ( -- )

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(tagged))
-
-	switch(type_of(env.dt))
 	{
 	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 */
 	}
 }

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##_ratio(x,(CELL)fixnum_to_ratio(y)); \
-				return OP(to_integer(x),y); \
-			else \
-				return OP##_ratio(x,(CELL)fixnum_to_ratio(y)); \
 		case RATIO_TYPE: \
-			if(integerOnly) \
+			return OP##_ratio(x,y); \
-				return OP(to_integer(x),to_integer(y)); \
+		case COMPLEX_TYPE: \
-			else \
+			return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \
-				return OP##_ratio(x,y); \
 		case BIGNUM_TYPE: \
-			if(integerOnly) \
+			return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \
-				return OP(to_integer(x),y); \
-			else \
-				return OP##_ratio(x,(CELL)bignum_to_ratio(y)); \
 		case FLOAT_TYPE: \
-			if(integerOnly) \
+			return OP##_float((CELL)ratio_to_float(x),y); \
-				return OP(to_integer(x),to_integer(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##_float(x,(CELL)fixnum_to_float(y)); \
-				return OP(to_integer(x),y); \
-			else \
-				return OP##_float(x,(CELL)fixnum_to_float(y)); \
 		case RATIO_TYPE: \
-			if(integerOnly) \
+			return OP##_float(x,(CELL)ratio_to_float(y)); \
-				return OP(x,to_integer(y)); \
+		case COMPLEX_TYPE: \
-			else \
+			return OP##_complex((CELL)complex(x,tag_fixnum(0)),y); \
-				return OP##_float(x,(CELL)ratio_to_float(y)); \
 		case BIGNUM_TYPE: \
-			if(integerOnly) \
+			return OP##_float(x,(CELL)bignum_to_float(y)); \
-				return OP(to_integer(x),y); \
-			else \
-				return OP##_float(x,(CELL)bignum_to_float(y)); \
 		case FLOAT_TYPE: \
-			if(integerOnly) \
+			return OP##_float(x,y); \
-				return OP(to_integer(x),to_integer(y)); \
-			else \
-				return OP##_float(x,y); \
 		default: \
-			if(anytype) \
+			type_error(FLOAT_TYPE,y); \
-				return OP##_anytype(x,y); \
-			else \
-				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);

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"

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,

native/primitives.h

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

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

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)

native/types.h

@@ -10,8 +10,9 @@
 #define CONS_TYPE 2
 #define OBJECT_TYPE 3
 #define RATIO_TYPE 4
-#define HEADER_TYPE 5
+#define COMPLEX_TYPE 5
-#define GC_COLLECTED 6 /* See gc.c */
+#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);