working on bignums in native factor; removed .marks files from CVS

TODO.FACTOR.txt

@@ -1,5 +1,6 @@
 + native:
 
+- typecases: type error reporting bad
 - image output
 - 32-bit and 64-bit "bignums"
 - floats

factor/.FactorParser.java.marks

@@ -1 +0,0 @@
-!a;7777;7777

factor/.FactorReader.java.marks

@@ -1 +0,0 @@
-!a;6964;6964

factor/.FactorReflectionForm.java.marks

@@ -1 +0,0 @@
-!a;10514;10514

factor/.FactorScanner.java.marks

@@ -1 +0,0 @@
-!a;4651;4651

factor/db/.Table.java.marks

@@ -1 +0,0 @@
-!a;7980;7980

factor/httpd/.wiki-responder.factor.marks

@@ -1 +0,0 @@
-!a;3422;3422

factor/primitives/.Bind.java.marks

@@ -1 +0,0 @@
-!a;1572;1572

factor/primitives/.Call.java.marks

@@ -1 +0,0 @@
-!a;1572;1572

factor/primitives/.Define.java.marks

@@ -1 +0,0 @@
-!a;1494;1494

factor/primitives/.Get.java.marks

@@ -1 +0,0 @@
-!a;1516;1516

factor/primitives/.JVarGetStatic.java.marks

@@ -1 +0,0 @@
-!a;1572;1572

factor/primitives/.JVarSet.java.marks

@@ -1 +0,0 @@
-!a;1572;1572

factor/primitives/.JVarSetStatic.java.marks

@@ -1 +0,0 @@
-!a;1572;1572

factor/primitives/.Set.java.marks

@@ -1 +0,0 @@
-!a;1477;1477

factor/test/.math.factor.marks

@@ -1 +0,0 @@
-!a;4056;4056

library/interpreter.factor

@@ -42,19 +42,19 @@ USE: words
 USE: unparser
 USE: vectors
 
-: exit ( -- )
-    t "quit-flag" set ;
-
 : print-banner ( -- )
     "Factor " version cat2 print
     "Copyright (C) 2003, 2004 Slava Pestov" print
     "Enter ``exit'' to exit." print ;
 
+: init-history ( -- )
+    "history" get [ 64 <vector> "history" set ] unless ;
+
 : history+ ( cmd -- )
     "history" get vector-push ;
 
 : print-numbered-entry ( index vector -- )
-    dupd vector-nth ": " swap cat3 print ;
+    <% over fixnum>str % ": " % vector-nth % %> print ;
 
 : print-numbered-vector ( list -- )
     dup vector-length [ over print-numbered-entry ] times* drop ;
@@ -82,14 +82,17 @@ USE: vectors
     [ write-attr ] bind
     flush ;
 
+: exit ( -- )
+    "quit-flag" on ;
+
 : interpret ( -- )
     print-prompt read dup [
         dup history+ eval
     ] [
-        drop "quit-flag" on
+        drop exit
     ] ifte ;
 
 : interpreter-loop ( -- )
-    64 <vector> "history" set
+    init-history
     [ "quit-flag" get not ] [ interpret ] while
     "quit-flag" off ;

library/platform/native/kernel.factor

@@ -73,6 +73,7 @@ USE: unparser
 : class-of ( obj -- name )
     [
         [ fixnum? ] [ drop "fixnum" ]
+        [ bignum? ] [ drop "bignum" ]
         [ cons?   ] [ drop "cons" ]
         [ word?   ] [ drop "word" ]
         [ f =     ] [ drop "f" ]

library/prettyprint.factor

@@ -103,14 +103,16 @@ DEFER: prettyprint*
     prettyprint> "]" write ;
 
 : (prettyprint-list) ( indent list -- indent )
-    uncons >r prettyprint-element r>
-    dup cons? [
-        (prettyprint-list)
-    ] [
-        [
-            "|" write prettyprint-space prettyprint-element
-        ] when*
-    ] ifte ;
+    [
+        uncons >r prettyprint-element r>
+        dup cons? [
+            (prettyprint-list)
+        ] [
+            [
+                "|" write prettyprint-space prettyprint-element
+            ] when*
+        ] ifte
+    ] when* ;
 
 : prettyprint-list ( indent list -- indent )
     #! Pretty-print a list, without [ and ].

native/bignum.c

@@ -0,0 +1,7 @@
+#include "factor.h"
+
+void primitive_bignump(void)
+{
+	check_non_empty(env.dt);
+	env.dt = tag_boolean(typep(env.dt,BIGNUM_TYPE));
+}

native/bignum.h

@@ -0,0 +1,33 @@
+typedef struct {
+	CELL header;
+	DCELL n;
+} BIGNUM;
+
+/* untagged */
+INLINE BIGNUM* allot_bignum()
+{
+	return (BIGNUM*)allot_object(BIGNUM_TYPE,sizeof(BIGNUM));
+}
+
+/* untagged */
+INLINE BIGNUM* bignum(DCELL n)
+{
+	BIGNUM* bignum = allot_bignum();
+	bignum->n = n;
+	return bignum;
+}
+
+INLINE BIGNUM* untag_bignum(CELL tagged)
+{
+	type_check(BIGNUM_TYPE,tagged);
+	return (BIGNUM*)UNTAG(tagged);
+}
+
+INLINE CELL tag_bignum(BIGNUM* untagged)
+{
+	return RETAG(untagged,OBJECT_TYPE);
+}
+
+BIGNUM* allot_bignum();
+BIGNUM* bignum(DCELL n);
+void primitive_bignump(void);

native/factor.h

@@ -3,6 +3,7 @@
 
 #include <errno.h>
 #include <fcntl.h>
+#include <limits.h>
 #include <setjmp.h>
 #include <stdbool.h>
 #include <stdio.h>
@@ -21,6 +22,9 @@
 typedef unsigned int CELL;
 #define CELLS sizeof(CELL)
 
+#define CELL_MAX INT_MAX
+#define CELL_MIN INT_MIN
+
 /* must always be 16 bits */
 typedef unsigned short CHAR;
 #define CHARS sizeof(CHAR)
@@ -43,6 +47,7 @@ typedef long long DCELL;
 #include "handle.h"
 #include "fixnum.h"
 #include "bignum.h"
+#include "math.h"
 #include "string.h"
 #include "fd.h"
 #include "file.h"

native/fd.c

@@ -110,12 +110,20 @@ void primitive_write_fd_8(void)
 	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
 
 	CELL text = dpop();
-	if(typep(text,FIXNUM_TYPE))
+	CELL type = type_of(text);
+
+	switch(type)
+	{
+	case FIXNUM_TYPE:
 		write_fd_char_8(h,untag_fixnum(text));
-	else if(typep(text,STRING_TYPE))
+		break;
+	case STRING_TYPE:
 		write_fd_string_8(h,untag_string(text));
-	else
+		break;
+	default:
 		type_error(STRING_TYPE,text);
+		break;
+	}
 
 	env.dt = dpop();
 }
@@ -142,8 +150,8 @@ void primitive_shutdown_fd(void)
 	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
 	int fd = h->object;
 
-	if(shutdown(fd,SHUT_RDWR) < 0)
-		io_error(__FUNCTION__);
+	/* if(shutdown(fd,SHUT_RDWR) < 0)
+		io_error(__FUNCTION__); */
 
 	env.dt = dpop();
 }

native/fixnum.c

@@ -13,12 +13,6 @@ void primitive_fixnump(void)
 	env.dt = tag_boolean(TAG(env.dt) == FIXNUM_TYPE);
 }
 
-void primitive_add(void)
-{
-	BINARY_OP(x,y);
-	env.dt = x + y;
-}
-
 void primitive_subtract(void)
 {
 	BINARY_OP(x,y);
@@ -75,7 +69,7 @@ void primitive_xor(void)
 void primitive_not(void)
 {
 	type_check(FIXNUM_TYPE,env.dt);
-	env.dt = RETAG(~env.dt,FIXNUM_TYPE);
+	env.dt = RETAG(UNTAG(~env.dt),FIXNUM_TYPE);
 }
 
 void primitive_shiftleft(void)

native/fixnum.h

@@ -1,9 +1,15 @@
 #define FIXNUM int /* unboxed */
+#define FIXNUM_MASK 0x1fffffff
+
+INLINE FIXNUM untag_fixnum_fast(CELL tagged)
+{
+	return ((FIXNUM)tagged) >> TAG_BITS;
+}
 
 INLINE FIXNUM untag_fixnum(CELL tagged)
 {
 	type_check(FIXNUM_TYPE,tagged);
-	return ((FIXNUM)tagged) >> TAG_BITS;
+	return untag_fixnum_fast(tagged);
 }
 
 INLINE CELL tag_fixnum(FIXNUM untagged)

native/math.c

@@ -0,0 +1,93 @@
+#include "factor.h"
+
+#define BINARY_OP(OP) \
+void primitive_##OP(void) \
+{ \
+	CELL x = dpop(), y = env.dt; \
+\
+	switch(TAG(x)) \
+	{ \
+	case FIXNUM_TYPE: \
+\
+		switch(TAG(y)) \
+		{ \
+		case FIXNUM_TYPE: \
+			env.dt = OP##_fixnum(x,y); \
+			break; \
+		case OBJECT_TYPE: \
+			switch(object_type(y)) \
+			{ \
+			case BIGNUM_TYPE: \
+				env.dt = OP##_bignum(fixnum_to_bignum(x),y); \
+				break; \
+			default: \
+				type_error(y,FIXNUM_TYPE); \
+				break; \
+			} \
+			break; \
+		default: \
+			type_error(y,FIXNUM_TYPE); \
+			break; \
+		} \
+\
+		break; \
+\
+	case OBJECT_TYPE: \
+\
+		switch(object_type(x)) \
+		{ \
+	 \
+		case BIGNUM_TYPE: \
+		 \
+			switch(TAG(y)) \
+			{ \
+			case FIXNUM_TYPE: \
+				env.dt = OP##_bignum(x,fixnum_to_bignum(y)); \
+				break; \
+			case OBJECT_TYPE: \
+\
+				switch(object_type(y)) \
+				{ \
+				case BIGNUM_TYPE: \
+					env.dt = OP##_bignum(x,y); \
+					break; \
+				default: \
+					type_error(y,BIGNUM_TYPE); \
+					break; \
+				} \
+				break; \
+			default: \
+				type_error(y,BIGNUM_TYPE); \
+				break; \
+			} \
+			break; \
+\
+		default: \
+\
+			type_error(x,FIXNUM_TYPE); \
+			break; \
+		} \
+\
+	default: \
+\
+		type_error(x,FIXNUM_TYPE); \
+	} \
+}
+
+/* ADDITION */
+INLINE CELL add_fixnum(CELL x, CELL y)
+{
+	CELL result = untag_fixnum_fast(x) + untag_fixnum_fast(y);
+	if(result & ~FIXNUM_MASK)
+		return tag_bignum(fixnum_to_bignum(result));
+	else
+		return tag_fixnum(result);
+}
+
+INLINE CELL add_bignum(CELL x, CELL y)
+{
+	return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
+		+ ((BIGNUM*)UNTAG(y))->n));
+}
+
+BINARY_OP(add)

native/math.h

@@ -0,0 +1,11 @@
+#include "factor.h"
+
+INLINE BIGNUM* fixnum_to_bignum(CELL n)
+{
+	return bignum((DCELL)untag_fixnum_fast(n));
+}
+
+INLINE FIXNUM bignum_to_fixnum(CELL tagged)
+{
+	return (FIXNUM)(untag_bignum(tagged)->n);
+}

native/sbuf.c

@@ -93,10 +93,18 @@ void primitive_sbuf_append(void)
 	CELL object = dpop();
 	check_non_empty(object);
 	env.dt = dpop();
-	if(TAG(object) == FIXNUM_TYPE)
+	switch(type_of(object))
+	{
+	case FIXNUM_TYPE:
 		set_sbuf_nth(sbuf,sbuf->top,untag_fixnum(object));
-	else
+		break;
+	case STRING_TYPE:
 		sbuf_append_string(sbuf,untag_string(object));
+		break;
+	default:
+		type_error(STRING_TYPE,object);
+		break;
+	}
 }
 
 STRING* sbuf_to_string(SBUF* sbuf)

native/string.c

@@ -212,7 +212,7 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
 		(CELL)(string + 1) + CHARS * start,
 		CHARS * (end - start));
 	hash_string(result);
-	
+
 	return result;
 }
 

native/types.c

@@ -19,6 +19,15 @@ bool typep(CELL type, CELL tagged)
 	return false;
 }
 
+CELL type_of(CELL tagged)
+{
+	CELL tag = TAG(tagged);
+	if(tag != OBJECT_TYPE)
+		return tag;
+	else
+		return untag_header(get(UNTAG(tagged)));
+}
+
 void type_check(CELL type, CELL tagged)
 {
 	if(type < HEADER_TYPE)

native/types.h

@@ -35,6 +35,7 @@ CELL empty;
 #define BIGNUM_TYPE 14
 
 bool typep(CELL type, CELL tagged);
+CELL type_of(CELL tagged);
 void type_check(CELL type, CELL tagged);
 
 INLINE void check_non_empty(CELL cell)
@@ -71,6 +72,11 @@ INLINE CELL tag_object(void* cell)
 	return RETAG(cell,OBJECT_TYPE);
 }
 
+INLINE CELL object_type(CELL tagged)
+{
+	return untag_header(get(UNTAG(tagged)));
+}
+
 CELL allot_object(CELL type, CELL length);
 CELL untagged_object_size(CELL pointer);
 CELL object_size(CELL pointer);