diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 67e3c3df23..2f131db0f0 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,6 @@ + native: +- typecases: type error reporting bad - image output - 32-bit and 64-bit "bignums" - floats diff --git a/factor/.FactorInterpreter.java.marks b/factor/.FactorInterpreter.java.marks deleted file mode 100644 index fcf0aa17fb..0000000000 Binary files a/factor/.FactorInterpreter.java.marks and /dev/null differ diff --git a/factor/.FactorNamespace.java.marks b/factor/.FactorNamespace.java.marks deleted file mode 100644 index c799802602..0000000000 Binary files a/factor/.FactorNamespace.java.marks and /dev/null differ diff --git a/factor/.FactorParser.java.marks b/factor/.FactorParser.java.marks deleted file mode 100644 index 9f0f5416ca..0000000000 --- a/factor/.FactorParser.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;7777;7777 diff --git a/factor/.FactorReader.java.marks b/factor/.FactorReader.java.marks deleted file mode 100644 index de07f09e88..0000000000 --- a/factor/.FactorReader.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;6964;6964 diff --git a/factor/.FactorReflectionForm.java.marks b/factor/.FactorReflectionForm.java.marks deleted file mode 100644 index aebb326895..0000000000 --- a/factor/.FactorReflectionForm.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;10514;10514 diff --git a/factor/.FactorScanner.java.marks b/factor/.FactorScanner.java.marks deleted file mode 100644 index 2e2e015160..0000000000 --- a/factor/.FactorScanner.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;4651;4651 diff --git a/factor/.FactorShuffleDefinition.java.marks b/factor/.FactorShuffleDefinition.java.marks deleted file mode 100644 index a731dfa4dc..0000000000 Binary files a/factor/.FactorShuffleDefinition.java.marks and /dev/null differ diff --git a/factor/.FactorWordDefinition.java.marks b/factor/.FactorWordDefinition.java.marks deleted file mode 100644 index 99f9204906..0000000000 Binary files a/factor/.FactorWordDefinition.java.marks and /dev/null differ diff --git a/factor/.NumberParser.java.marks b/factor/.NumberParser.java.marks deleted file mode 100644 index f3c886b3de..0000000000 Binary files a/factor/.NumberParser.java.marks and /dev/null differ diff --git a/factor/compiler/.FactorCompiler.java.marks b/factor/compiler/.FactorCompiler.java.marks deleted file mode 100644 index 54fc7603db..0000000000 Binary files a/factor/compiler/.FactorCompiler.java.marks and /dev/null differ diff --git a/factor/db/.Table.java.marks b/factor/db/.Table.java.marks deleted file mode 100644 index b84b6dd703..0000000000 --- a/factor/db/.Table.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;7980;7980 diff --git a/factor/httpd/.wiki-responder.factor.marks b/factor/httpd/.wiki-responder.factor.marks deleted file mode 100644 index 451822c761..0000000000 --- a/factor/httpd/.wiki-responder.factor.marks +++ /dev/null @@ -1 +0,0 @@ -!a;3422;3422 diff --git a/factor/primitives/.Bind.java.marks b/factor/primitives/.Bind.java.marks deleted file mode 100644 index cc69ebb1ca..0000000000 --- a/factor/primitives/.Bind.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1572;1572 diff --git a/factor/primitives/.Call.java.marks b/factor/primitives/.Call.java.marks deleted file mode 100644 index cc69ebb1ca..0000000000 --- a/factor/primitives/.Call.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1572;1572 diff --git a/factor/primitives/.Define.java.marks b/factor/primitives/.Define.java.marks deleted file mode 100644 index 98f08f8ae2..0000000000 --- a/factor/primitives/.Define.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1494;1494 diff --git a/factor/primitives/.Get.java.marks b/factor/primitives/.Get.java.marks deleted file mode 100644 index f732d3e713..0000000000 --- a/factor/primitives/.Get.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1516;1516 diff --git a/factor/primitives/.JVarGetStatic.java.marks b/factor/primitives/.JVarGetStatic.java.marks deleted file mode 100644 index cc69ebb1ca..0000000000 --- a/factor/primitives/.JVarGetStatic.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1572;1572 diff --git a/factor/primitives/.JVarSet.java.marks b/factor/primitives/.JVarSet.java.marks deleted file mode 100644 index cc69ebb1ca..0000000000 --- a/factor/primitives/.JVarSet.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1572;1572 diff --git a/factor/primitives/.JVarSetStatic.java.marks b/factor/primitives/.JVarSetStatic.java.marks deleted file mode 100644 index cc69ebb1ca..0000000000 --- a/factor/primitives/.JVarSetStatic.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1572;1572 diff --git a/factor/primitives/.Set.java.marks b/factor/primitives/.Set.java.marks deleted file mode 100644 index 6bb7c42b59..0000000000 --- a/factor/primitives/.Set.java.marks +++ /dev/null @@ -1 +0,0 @@ -!a;1477;1477 diff --git a/factor/test/.math.factor.marks b/factor/test/.math.factor.marks deleted file mode 100644 index 5c039f0a73..0000000000 --- a/factor/test/.math.factor.marks +++ /dev/null @@ -1 +0,0 @@ -!a;4056;4056 diff --git a/library/interpreter.factor b/library/interpreter.factor index 8a3d7b42b5..09e6ac4db5 100644 --- a/library/interpreter.factor +++ b/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 "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 "history" set + init-history [ "quit-flag" get not ] [ interpret ] while "quit-flag" off ; diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 43fa48fe0f..7907393328 100644 --- a/library/platform/native/kernel.factor +++ b/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" ] diff --git a/library/prettyprint.factor b/library/prettyprint.factor index d148e2fe12..552b797b6c 100644 --- a/library/prettyprint.factor +++ b/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 ]. diff --git a/native/bignum.c b/native/bignum.c new file mode 100644 index 0000000000..78d44ee17f --- /dev/null +++ b/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)); +} diff --git a/native/bignum.h b/native/bignum.h new file mode 100644 index 0000000000..c1083c57b4 --- /dev/null +++ b/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); diff --git a/native/factor.h b/native/factor.h index 0803f88efc..c929a70213 100644 --- a/native/factor.h +++ b/native/factor.h @@ -3,6 +3,7 @@ #include #include +#include #include #include #include @@ -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" diff --git a/native/fd.c b/native/fd.c index 29e6b97390..bb6cb1a0ee 100644 --- a/native/fd.c +++ b/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(); } diff --git a/native/fixnum.c b/native/fixnum.c index 12e3d9d79a..c2927f809f 100644 --- a/native/fixnum.c +++ b/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) diff --git a/native/fixnum.h b/native/fixnum.h index be26f5dd84..047db2b495 100644 --- a/native/fixnum.h +++ b/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) diff --git a/native/math.c b/native/math.c new file mode 100644 index 0000000000..6b4d02898b --- /dev/null +++ b/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) diff --git a/native/math.h b/native/math.h new file mode 100644 index 0000000000..256aa51bbe --- /dev/null +++ b/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); +} diff --git a/native/sbuf.c b/native/sbuf.c index ae1cc20b43..3b3bda6e03 100644 --- a/native/sbuf.c +++ b/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) diff --git a/native/string.c b/native/string.c index 592d286e55..553240a16f 100644 --- a/native/string.c +++ b/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; } diff --git a/native/types.c b/native/types.c index 352cd76b7b..2b4c58ed87 100644 --- a/native/types.c +++ b/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) diff --git a/native/types.h b/native/types.h index 462f133129..ca91b8e4cb 100644 --- a/native/types.h +++ b/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);