diff --git a/library/interpreter.factor b/library/interpreter.factor index 030ea3ba43..8a3d7b42b5 100644 --- a/library/interpreter.factor +++ b/library/interpreter.factor @@ -40,6 +40,7 @@ USE: strings USE: styles USE: words USE: unparser +USE: vectors : exit ( -- ) t "quit-flag" set ; @@ -47,43 +48,36 @@ USE: unparser : print-banner ( -- ) "Factor " version cat2 print "Copyright (C) 2003, 2004 Slava Pestov" print - "Enter ``help'' for help." print "Enter ``exit'' to exit." print ; : history+ ( cmd -- ) - global [ "history" cons@ ] bind ; + "history" get vector-push ; -: history# ( -- number ) - global [ "history" get length ] bind ; +: print-numbered-entry ( index vector -- ) + dupd vector-nth ": " swap cat3 print ; -: print-numbered-list* ( number list -- ) - #! Print each element of the list with a number. - dup [ - uncons [ over pred ] dip print-numbered-list* - swap fixnum>str swap ": " swap cat3 print - ] [ - 2drop - ] ifte ; - -: print-numbered-list ( list -- ) - dup length pred swap print-numbered-list* ; +: print-numbered-vector ( list -- ) + dup vector-length [ over print-numbered-entry ] times* drop ; : history ( -- ) "X redo -- evaluate the expression with number X." print "X re-edit -- edit the expression with number X." print - "history" get print-numbered-list ; + "history" get print-numbered-vector ; : get-history ( index -- ) - "history" get reverse nth ; + "history" get vector-nth ; : redo ( index -- ) - get-history dup print eval ; + get-history dup " ( " write write " )" print eval ; : re-edit ( index -- ) get-history edit ; +: history# ( -- number ) + "history" get vector-length ; + : print-prompt ( -- ) - <% " " % history# fixnum>str % "] " % %> + <% " ( " % history# fixnum>str % " ) " % %> [ "prompt" ] get-style [ write-attr ] bind flush ; @@ -96,26 +90,6 @@ USE: unparser ] ifte ; : interpreter-loop ( -- ) + 64 "history" set [ "quit-flag" get not ] [ interpret ] while "quit-flag" off ; - -: help - "clear -- clear datastack." print - ".s -- print datastack." print - ". -- print top of datastack." print - "" print - "global describe -- list all global variables." print - "describe -- describe object at top of stack." print - "" print - "words. -- list all words." print - "\"word\" see -- show definition of \"word\"." print - "\"str\" apropos -- list all words whose name contains \"str\"." print - "\"word\" usages. -- list all words that call \"word\"." print - "" print - "[ expr ] balance . -- show stack effect of expression." print - "" print - "history -- list previously entered expressions." print - "X redo -- redo expression number X from history list." print - "" print - "exit -- exit the interpreter." print - "" print ; diff --git a/library/platform/native/cross-compiler.factor b/library/platform/native/cross-compiler.factor index a6c3489aec..067d9784d8 100644 --- a/library/platform/native/cross-compiler.factor +++ b/library/platform/native/cross-compiler.factor @@ -105,6 +105,7 @@ IN: cross-compiler sbuf-append sbuf>str fixnum? + bignum? + - * diff --git a/native/factor.h b/native/factor.h index 161eec0674..0803f88efc 100644 --- a/native/factor.h +++ b/native/factor.h @@ -18,17 +18,19 @@ #define INLINE inline static /* CELL must be 32 bits and your system must have 32-bit pointers */ -#define CELL unsigned int +typedef unsigned int CELL; #define CELLS sizeof(CELL) /* must always be 16 bits */ -#define CHAR unsigned short +typedef unsigned short CHAR; #define CHARS sizeof(CHAR) /* must always be 8 bits */ -#define BYTE unsigned char +typedef unsigned char BYTE; #define BYTES 1 +typedef long long DCELL; + /* Memory heap size */ #define DEFAULT_ARENA (4 * 1024 * 1024) #define STACK_SIZE 1024 @@ -40,6 +42,7 @@ #include "array.h" #include "handle.h" #include "fixnum.h" +#include "bignum.h" #include "string.h" #include "fd.h" #include "file.h" diff --git a/native/fd.c b/native/fd.c index c5c3c37996..29e6b97390 100644 --- a/native/fd.c +++ b/native/fd.c @@ -38,10 +38,13 @@ void primitive_read_line_fd_8(void) /* read ascii from fd */ STRING* buf; - if(h->buffer == F) + if(h->buf_mode != B_READ) + { + h->buf_mode = B_READ; h->buffer = tag_object(string(BUF_SIZE,'\0')); + } buf = untag_string(h->buffer); - + for(;;) { if(h->buf_pos >= h->buf_fill) @@ -82,17 +85,37 @@ void primitive_read_line_fd_8(void) } } -void primitive_write_fd_8(void) +void write_fd_char_8(HANDLE* h, FIXNUM ch) +{ + BYTE c = (BYTE)ch; + + int amount = write(h->object,&c,1); + + if(amount < 0) + io_error(__FUNCTION__); +} + +void write_fd_string_8(HANDLE* h, STRING* str) { - HANDLE* h = untag_handle(HANDLE_FD,env.dt); - int fd = h->object; - STRING* str = untag_string(dpop()); char* c_str = to_c_string(str); - int amount = write(fd,c_str,str->capacity); + int amount = write(h->object,c_str,str->capacity); if(amount < 0) io_error(__FUNCTION__); +} + +void primitive_write_fd_8(void) +{ + HANDLE* h = untag_handle(HANDLE_FD,env.dt); + + CELL text = dpop(); + if(typep(text,FIXNUM_TYPE)) + write_fd_char_8(h,untag_fixnum(text)); + else if(typep(text,STRING_TYPE)) + write_fd_string_8(h,untag_string(text)); + else + type_error(STRING_TYPE,text); env.dt = dpop(); } @@ -100,9 +123,15 @@ void primitive_write_fd_8(void) void primitive_flush_fd(void) { HANDLE* h = untag_handle(HANDLE_FD,env.dt); - int fd = h->object; - /* if(fsync(fd) < 0) + if(h->buf_mode == B_WRITE) + { + + } + + /* int fd = h->object; + + if(fsync(fd) < 0) io_error(__FUNCTION__); */ env.dt = dpop(); diff --git a/native/fd.h b/native/fd.h index 46f74d4532..82ee62800e 100644 --- a/native/fd.h +++ b/native/fd.h @@ -5,6 +5,8 @@ void init_io(void); void primitive_close_fd(void); int fill_buffer(HANDLE* h, int fd, STRING* buf); void primitive_read_line_fd_8(void); +void write_fd_char_8(HANDLE* h, FIXNUM ch); +void write_fd_string_8(HANDLE* h, STRING* str); void primitive_write_fd_8(void); void primitive_flush_fd(void); void primitive_shutdown_fd(void); diff --git a/native/fixnum.c b/native/fixnum.c index c11a64cf66..12e3d9d79a 100644 --- a/native/fixnum.c +++ b/native/fixnum.c @@ -46,10 +46,12 @@ void primitive_mod(void) void primitive_divmod(void) { + div_t q; BINARY_OP(x,y); - dpush(tag_fixnum(x / y)); + q = div(x,y); /* division takes common factor of 8 out. */ - env.dt = x % y; + dpush(tag_fixnum(q.quot)); + env.dt = q.rem; } void primitive_and(void) diff --git a/native/handle.c b/native/handle.c index 3ee9e9c694..81b15f6e1c 100644 --- a/native/handle.c +++ b/native/handle.c @@ -19,6 +19,7 @@ CELL handle(CELL type, CELL object) handle->type = type; handle->object = object; handle->buffer = F; + handle->buf_mode = B_NONE; handle->buf_fill = 0; handle->buf_pos = 0; return tag_object(handle); diff --git a/native/handle.h b/native/handle.h index 3dc9876cfc..e2a1f6be1d 100644 --- a/native/handle.h +++ b/native/handle.h @@ -3,11 +3,15 @@ typedef struct { CELL type; CELL object; CELL buffer; /* tagged */ + CELL buf_mode; CELL buf_fill; CELL buf_pos; } HANDLE; #define HANDLE_FD 1 +#define B_READ 0 +#define B_WRITE 1 +#define B_NONE 2 HANDLE* untag_handle(CELL type, CELL tagged); CELL handle(CELL type, CELL object); diff --git a/native/primitives.c b/native/primitives.c index 47d11c0211..8a4112ae33 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -35,60 +35,61 @@ XT primitives[] = { primitive_sbuf_append, /* 31 */ primitive_sbuf_to_string, /* 32 */ primitive_fixnump, /* 33 */ - primitive_add, /* 34 */ - primitive_subtract, /* 35 */ - primitive_multiply, /* 36 */ - primitive_divide, /* 37 */ - primitive_mod, /* 38 */ - primitive_divmod, /* 39 */ - primitive_and, /* 40 */ - primitive_or, /* 41 */ - primitive_xor, /* 42 */ - primitive_not, /* 43 */ - primitive_shiftleft, /* 44 */ - primitive_shiftright, /* 45 */ - primitive_less, /* 46 */ - primitive_lesseq, /* 47 */ - primitive_greater, /* 48 */ - primitive_greatereq, /* 49 */ - primitive_wordp, /* 50 */ - primitive_word, /* 51 */ - primitive_word_primitive, /* 52 */ - primitive_set_word_primitive, /* 53 */ - primitive_word_parameter, /* 54 */ - primitive_set_word_parameter, /* 55 */ - primitive_word_plist, /* 56 */ - primitive_set_word_plist, /* 57 */ - primitive_drop, /* 58 */ - primitive_dup, /* 59 */ - primitive_swap, /* 60 */ - primitive_over, /* 61 */ - primitive_pick, /* 62 */ - primitive_nip, /* 63 */ - primitive_tuck, /* 64 */ - primitive_rot, /* 65 */ - primitive_to_r, /* 66 */ - primitive_from_r, /* 67 */ - primitive_eq, /* 68 */ - primitive_getenv, /* 69 */ - primitive_setenv, /* 70 */ - primitive_open_file, /* 71 */ - primitive_gc, /* 72 */ - primitive_save_image, /* 73 */ - primitive_datastack, /* 74 */ - primitive_callstack, /* 75 */ - primitive_set_datastack, /* 76 */ - primitive_set_callstack, /* 77 */ - primitive_handlep, /* 78 */ - primitive_exit, /* 79 */ - primitive_server_socket, /* 80 */ - primitive_close_fd, /* 81 */ - primitive_accept_fd, /* 82 */ - primitive_read_line_fd_8, /* 83 */ - primitive_write_fd_8, /* 84 */ - primitive_flush_fd, /* 85 */ - primitive_shutdown_fd, /* 86 */ - primitive_room /* 87 */ + primitive_bignump, /* 34 */ + primitive_add, /* 35 */ + primitive_subtract, /* 36 */ + primitive_multiply, /* 37 */ + primitive_divide, /* 38 */ + primitive_mod, /* 39 */ + primitive_divmod, /* 40 */ + primitive_and, /* 41 */ + primitive_or, /* 42 */ + primitive_xor, /* 43 */ + primitive_not, /* 44 */ + primitive_shiftleft, /* 45 */ + primitive_shiftright, /* 46 */ + primitive_less, /* 47 */ + primitive_lesseq, /* 48 */ + primitive_greater, /* 49 */ + primitive_greatereq, /* 50 */ + primitive_wordp, /* 51 */ + primitive_word, /* 52 */ + primitive_word_primitive, /* 53 */ + primitive_set_word_primitive, /* 54 */ + primitive_word_parameter, /* 55 */ + primitive_set_word_parameter, /* 56 */ + primitive_word_plist, /* 57 */ + primitive_set_word_plist, /* 58 */ + primitive_drop, /* 59 */ + primitive_dup, /* 60 */ + primitive_swap, /* 61 */ + primitive_over, /* 62 */ + primitive_pick, /* 63 */ + primitive_nip, /* 64 */ + primitive_tuck, /* 65 */ + primitive_rot, /* 66 */ + primitive_to_r, /* 67 */ + primitive_from_r, /* 68 */ + primitive_eq, /* 69 */ + primitive_getenv, /* 70 */ + primitive_setenv, /* 71 */ + primitive_open_file, /* 72 */ + primitive_gc, /* 73 */ + primitive_save_image, /* 74 */ + primitive_datastack, /* 75 */ + primitive_callstack, /* 76 */ + primitive_set_datastack, /* 77 */ + primitive_set_callstack, /* 78 */ + primitive_handlep, /* 79 */ + primitive_exit, /* 80 */ + primitive_server_socket, /* 81 */ + primitive_close_fd, /* 82 */ + primitive_accept_fd, /* 83 */ + primitive_read_line_fd_8, /* 84 */ + primitive_write_fd_8, /* 85 */ + primitive_flush_fd, /* 86 */ + primitive_shutdown_fd, /* 87 */ + primitive_room /* 88 */ }; CELL primitive_to_xt(CELL primitive) diff --git a/native/primitives.h b/native/primitives.h index bbcb2d59e9..42d1f01859 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,5 +1,5 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 88 +#define PRIMITIVE_COUNT 89 CELL primitive_to_xt(CELL primitive); diff --git a/native/types.h b/native/types.h index fd3e52a261..462f133129 100644 --- a/native/types.h +++ b/native/types.h @@ -32,6 +32,7 @@ CELL empty; #define STRING_TYPE 11 #define SBUF_TYPE 12 #define HANDLE_TYPE 13 +#define BIGNUM_TYPE 14 bool typep(CELL type, CELL tagged); void type_check(CELL type, CELL tagged); diff --git a/native/vector.c b/native/vector.c index 358ba0a93c..77eeebabe6 100644 --- a/native/vector.c +++ b/native/vector.c @@ -76,7 +76,8 @@ void primitive_set_vector_nth(void) void fixup_vector(VECTOR* vector) { - vector->array = (CELL)vector->array + (active->base - relocation_base); + vector->array = (ARRAY*)((CELL)vector->array + + (active->base - relocation_base)); } void collect_vector(VECTOR* vector)