interpreter history now a vector, working on native write primitives

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 )
+: print-numbered-entry ( index vector -- )
-    global [ "history" get length ] bind ;
+    dupd vector-nth ": " swap cat3 print ;
 
-: print-numbered-list* ( number list -- )
+: print-numbered-vector ( list -- )
-    #! Print each element of the list with a number.
+    dup vector-length [ over print-numbered-entry ] times* drop ;
-    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* ;
 
 : 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 <vector> "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 ;

library/platform/native/cross-compiler.factor

@@ -105,6 +105,7 @@ IN: cross-compiler
         sbuf-append
         sbuf>str
         fixnum?
+        bignum?
         +
         -
         *

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"

native/fd.c

@@ -38,8 +38,11 @@ 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(;;)
@@ -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)
 {
-	HANDLE* h = untag_handle(HANDLE_FD,env.dt);
+	BYTE c = (BYTE)ch;
-	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,1);
 
 	if(amount < 0)
 		io_error(__FUNCTION__);
+}
+
+void write_fd_string_8(HANDLE* h, STRING* str)
+{
+	char* c_str = to_c_string(str);
+	
+	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();

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

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)

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

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

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_bignump,                      /* 34 */
-	primitive_subtract,                     /* 35 */
+	primitive_add,                          /* 35 */
-	primitive_multiply,                     /* 36 */
+	primitive_subtract,                     /* 36 */
-	primitive_divide,                       /* 37 */
+	primitive_multiply,                     /* 37 */
-	primitive_mod,                          /* 38 */
+	primitive_divide,                       /* 38 */
-	primitive_divmod,                       /* 39 */
+	primitive_mod,                          /* 39 */
-	primitive_and,                          /* 40 */
+	primitive_divmod,                       /* 40 */
-	primitive_or,                           /* 41 */
+	primitive_and,                          /* 41 */
-	primitive_xor,                          /* 42 */
+	primitive_or,                           /* 42 */
-	primitive_not,                          /* 43 */
+	primitive_xor,                          /* 43 */
-	primitive_shiftleft,                    /* 44 */
+	primitive_not,                          /* 44 */
-	primitive_shiftright,                   /* 45 */
+	primitive_shiftleft,                    /* 45 */
-	primitive_less,                         /* 46 */
+	primitive_shiftright,                   /* 46 */
-	primitive_lesseq,                       /* 47 */
+	primitive_less,                         /* 47 */
-	primitive_greater,                      /* 48 */
+	primitive_lesseq,                       /* 48 */
-	primitive_greatereq,                    /* 49 */
+	primitive_greater,                      /* 49 */
-	primitive_wordp,                        /* 50 */
+	primitive_greatereq,                    /* 50 */
-	primitive_word,                         /* 51 */
+	primitive_wordp,                        /* 51 */
-	primitive_word_primitive,               /* 52 */
+	primitive_word,                         /* 52 */
-	primitive_set_word_primitive,           /* 53 */
+	primitive_word_primitive,               /* 53 */
-	primitive_word_parameter,               /* 54 */
+	primitive_set_word_primitive,           /* 54 */
-	primitive_set_word_parameter,           /* 55 */
+	primitive_word_parameter,               /* 55 */
-	primitive_word_plist,                   /* 56 */
+	primitive_set_word_parameter,           /* 56 */
-	primitive_set_word_plist,               /* 57 */
+	primitive_word_plist,                   /* 57 */
-	primitive_drop,                         /* 58 */
+	primitive_set_word_plist,               /* 58 */
-	primitive_dup,                          /* 59 */
+	primitive_drop,                         /* 59 */
-	primitive_swap,                         /* 60 */
+	primitive_dup,                          /* 60 */
-	primitive_over,                         /* 61 */
+	primitive_swap,                         /* 61 */
-	primitive_pick,                         /* 62 */
+	primitive_over,                         /* 62 */
-	primitive_nip,                          /* 63 */
+	primitive_pick,                         /* 63 */
-	primitive_tuck,                         /* 64 */
+	primitive_nip,                          /* 64 */
-	primitive_rot,                          /* 65 */
+	primitive_tuck,                         /* 65 */
-	primitive_to_r,                         /* 66 */
+	primitive_rot,                          /* 66 */
-	primitive_from_r,                       /* 67 */
+	primitive_to_r,                         /* 67 */
-	primitive_eq,                           /* 68 */
+	primitive_from_r,                       /* 68 */
-	primitive_getenv,                       /* 69 */
+	primitive_eq,                           /* 69 */
-	primitive_setenv,                       /* 70 */
+	primitive_getenv,                       /* 70 */
-	primitive_open_file,                    /* 71 */
+	primitive_setenv,                       /* 71 */
-	primitive_gc,                           /* 72 */
+	primitive_open_file,                    /* 72 */
-	primitive_save_image,                   /* 73 */
+	primitive_gc,                           /* 73 */
-	primitive_datastack,                    /* 74 */
+	primitive_save_image,                   /* 74 */
-	primitive_callstack,                    /* 75 */
+	primitive_datastack,                    /* 75 */
-	primitive_set_datastack,                /* 76 */
+	primitive_callstack,                    /* 76 */
-	primitive_set_callstack,                /* 77 */
+	primitive_set_datastack,                /* 77 */
-	primitive_handlep,                      /* 78 */
+	primitive_set_callstack,                /* 78 */
-	primitive_exit,                         /* 79 */
+	primitive_handlep,                      /* 79 */
-	primitive_server_socket,                /* 80 */
+	primitive_exit,                         /* 80 */
-	primitive_close_fd,                     /* 81 */
+	primitive_server_socket,                /* 81 */
-	primitive_accept_fd,                    /* 82 */
+	primitive_close_fd,                     /* 82 */
-	primitive_read_line_fd_8,               /* 83 */
+	primitive_accept_fd,                    /* 83 */
-	primitive_write_fd_8,                   /* 84 */
+	primitive_read_line_fd_8,               /* 84 */
-	primitive_flush_fd,                     /* 85 */
+	primitive_write_fd_8,                   /* 85 */
-	primitive_shutdown_fd,                  /* 86 */
+	primitive_flush_fd,                     /* 86 */
-	primitive_room                          /* 87 */
+	primitive_shutdown_fd,                  /* 87 */
+	primitive_room                          /* 88 */
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

@@ -1,5 +1,5 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 88
+#define PRIMITIVE_COUNT 89
 
 CELL primitive_to_xt(CELL primitive);
 

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

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)