steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

interpreter history now a vector, working on native write primitives

cvs
Slava Pestov 2004-07-28 01:12:22 +00:00
parent 9850e33cc5
commit 3e152b87f8
12 changed files with 129 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
library/interpreter.factor
View File

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

1
library/platform/native/cross-compiler.factor
View File

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

9
native/factor.h
View File

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

47
native/fd.c
View File

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

2
native/fd.h
View File

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

6
native/fixnum.c
View File

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

1
native/handle.c
View File

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

4
native/handle.h
View File

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

109
native/primitives.c
View File

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

2
native/primitives.h
View File

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

1
native/types.h
View File

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

3
native/vector.c
View File

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