diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index bd13b96527..c545f615e8 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -26,7 +26,7 @@ + tests: - java factor: equal numbers have non-equal hashcodes! -- sbuf= +- sbuf-hashcode - vector-hashcode - clone-sbuf - FactorLib.equal() not very good @@ -78,8 +78,8 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable + misc: +- telnetd: needs own history - compiled stack traces broken -- should i -i inf -inf be parsing words? - namespace clone drops static var bindings - ditch map - ditch expand @@ -89,7 +89,6 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable + httpd: - multitasking -- inspect: always use inspect/ URL prefix, not responder name var - httpd: don't flush so much - log with date - log user agent diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index fe38f3e1bb..effe5715dc 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -59,6 +59,7 @@ DEFER: size-of IN: strings DEFER: str= DEFER: str-hashcode +DEFER: sbuf= IN: io-internals DEFER: open-file @@ -124,6 +125,7 @@ IN: cross-compiler set-sbuf-nth sbuf-append sbuf>str + sbuf= number? >fixnum >bignum diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 0e13b15f75..738853534f 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -64,11 +64,8 @@ USE: url-encoding #! Wrap a string in an HTML tag. <% dupd opening-tag swap % closing-tag %> ; -: responder-link% ( -- ) - "/" % "responder" get % "/" % ; - : link-attrs ( link -- attrs ) - <% "href=\"" % responder-link% % "\"" % %> ; + <% "href=\"/inspect/" % % "\"" % %> ; : link-tag ( string link -- string ) "a" swap link-attrs html-tag ; diff --git a/library/platform/jvm/kernel.factor b/library/platform/jvm/kernel.factor index 50c137bb7d..360e047026 100644 --- a/library/platform/jvm/kernel.factor +++ b/library/platform/jvm/kernel.factor @@ -58,14 +58,14 @@ IN: kernel [ ] "java.lang.Object" "getClass" jinvoke [ ] "java.lang.Class" "getName" jinvoke ; -: clone ( obj -- obj ) - [ ] "factor.PublicCloneable" "clone" jinvoke ; - : is ( obj class -- boolean ) ! Like "instanceof" in Java. [ "java.lang.Object" ] "java.lang.Class" "isInstance" jinvoke ; +: clone ( obj -- obj ) + [ ] "factor.PublicCloneable" "clone" jinvoke ; + : toplevel ( -- ) interpreter [ ] "factor.FactorInterpreter" "topLevel" jinvoke ; diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index aa18485748..7c740dbf40 100644 --- a/library/platform/native/kernel.factor +++ b/library/platform/native/kernel.factor @@ -61,6 +61,7 @@ USE: unparser [ cons? ] [ cons= ] [ vector? ] [ vector= ] [ string? ] [ str= ] + [ sbuf? ] [ sbuf= ] [ drop t ] [ 2drop f ] ] cond ] ifte ; diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index f08b376601..339862cb21 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -132,7 +132,7 @@ USE: unparser <% parse-string "pos" get %> swap "pos" set parsed ; parsing ! Char literal -: CHAR: ( -- ) skip-blank next-ch parse-ch parsed ; parsing +: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing ! Complex literal : #{ diff --git a/library/platform/native/parser.factor b/library/platform/native/parser.factor index 0f7280d426..8fce63dbe8 100644 --- a/library/platform/native/parser.factor +++ b/library/platform/native/parser.factor @@ -67,31 +67,54 @@ USE: unparser : ch ( -- ch ) "pos" get "line" get str-nth ; : advance ( -- ) "pos" succ@ ; -: ch-blank? ( -- ? ) end? [ f ] [ ch blank? ] ifte ; -: skip-blank ( -- ) [ ch-blank? ] [ advance ] while ; -: ch-word? ( -- ? ) end? [ f ] [ ch blank? not ] ifte ; -: skip-word ( -- ) [ ch-word? ] [ advance ] while ; +: skip ( n line quot -- n ) + #! Find the next character that satisfies the quotation, + #! which should have stack effect ( ch -- ? ). + >r 2dup str-length < [ + 2dup str-nth r> dup >r call [ + r> 2drop + ] [ + >r succ r> r> skip + ] ifte + ] [ + r> drop nip str-length + ] ifte ; -: ch-dispatch? ( -- ? ) +: skip-blank ( n line -- n ) + [ blank? not ] skip ; + +: skip-word ( n line -- n ) + [ blank? ] skip ; + +: denotation? ( ch -- ? ) #! Hard-coded for now. Make this customizable later. - #! A 'dispatch' is a character that is treated as its + #! A 'denotation' is a character that is treated as its #! own word, eg: #! #! "hello world" #! #! Will call the parsing word ". - ch "\"" str-contains? ; + "\"" str-contains? ; -: (scan) ( -- start end ) - skip-blank "pos" get - end? [ - dup +: (scan) ( n line -- start end ) + dup >r skip-blank dup r> + 2dup str-length < [ + 2dup str-nth denotation? [ + drop succ + ] [ + skip-word + ] ifte ] [ - ch-dispatch? [ advance ] [ skip-word ] ifte "pos" get + drop ] ifte ; -: scan ( -- str ) - (scan) 2dup = [ 2drop f ] [ "line" get substring ] ifte ; +: scan ( -- token ) + "pos" get "line" get dup >r (scan) dup "pos" set + 2dup = [ + r> 3drop f + ] [ + r> substring + ] ifte ; : parse-word ( str -- obj ) dup "use" get search dup [ @@ -146,3 +169,6 @@ USE: unparser : next-ch ( -- ch ) end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ; + +: next-word-ch ( -- ch ) + "pos" get "line" get skip-blank "pos" set next-ch ; diff --git a/library/sbuf.factor b/library/sbuf.factor index fb7ce2485e..3ec6d4ebe6 100644 --- a/library/sbuf.factor +++ b/library/sbuf.factor @@ -34,6 +34,9 @@ USE: namespaces USE: strings USE: stack +: str>sbuf ( str -- sbuf ) + dup str-length tuck sbuf-append ; + : string-buffer-size 80 ; : <% ( -- ) diff --git a/native/factor.c b/native/factor.c index db429a8a12..fdb3e8225e 100644 --- a/native/factor.c +++ b/native/factor.c @@ -12,7 +12,7 @@ int main(int argc, char** argv) init_arena(DEFAULT_ARENA); load_image(argv[1]); - init_environment(); + init_stacks(); init_io(); run(); diff --git a/native/gc.c b/native/gc.c index d692fda494..b366474ede 100644 --- a/native/gc.c +++ b/native/gc.c @@ -115,9 +115,8 @@ void copy_roots(void) { int i; - CELL ds_depth = env.ds - UNTAG(env.ds_bot); - CELL cs_depth = env.cs - UNTAG(env.cs_bot); - + CELL ptr; + gc_debug("collect_roots",scan); /* these three must be the first in the heap */ copy_object(&empty); @@ -127,13 +126,15 @@ void copy_roots(void) copy_object(&T); gc_debug("t",T); copy_object(&env.dt); - copy_object(&env.ds_bot); - env.ds = UNTAG(env.ds_bot) + ds_depth; - copy_object(&env.cs_bot); - env.cs = UNTAG(env.cs_bot) + cs_depth; copy_object(&env.cf); copy_object(&env.boot); - + + for(ptr = env.ds_bot; ptr < env.ds; ptr += CELLS) + copy_object((void*)ptr); + + for(ptr = env.cs_bot; ptr < env.cs; ptr += CELLS) + copy_object((void*)ptr); + for(i = 0; i < USER_ENV; i++) copy_object(&env.user[i]); } diff --git a/native/memory.c b/native/memory.c index 84f6f69cdb..68cd709f55 100644 --- a/native/memory.c +++ b/native/memory.c @@ -4,20 +4,20 @@ under/overflow. size must be a multiple of the page size */ void* alloc_guarded(CELL size) { - char* stack = mmap((void*)0,PAGE_SIZE + STACK_SIZE + PAGE_SIZE, + char* array = mmap((void*)0,PAGE_SIZE + size + PAGE_SIZE, PROT_READ | PROT_WRITE,MAP_ANON,-1,0); - if(mprotect(stack,PAGE_SIZE,PROT_NONE) == -1) - fatal_error("Cannot allocate low guard page",(CELL)stack); + if(mprotect(array,PAGE_SIZE,PROT_NONE) == -1) + fatal_error("Cannot allocate low guard page",(CELL)array); - if(mprotect(stack + PAGE_SIZE + STACK_SIZE,PAGE_SIZE,PROT_NONE) == -1) - fatal_error("Cannot allocate high guard page",(CELL)stack); + if(mprotect(array + PAGE_SIZE + size,PAGE_SIZE,PROT_NONE) == -1) + fatal_error("Cannot allocate high guard page",(CELL)array); - /* return bottom of actual stack */ - return stack + PAGE_SIZE; + /* return bottom of actual array */ + return array + PAGE_SIZE; } -static ZONE* zalloc(CELL size) +ZONE* zalloc(CELL size) { ZONE* z = (ZONE*)malloc(sizeof(ZONE)); if(z == 0) diff --git a/native/memory.h b/native/memory.h index a3096975a6..db41363a66 100644 --- a/native/memory.h +++ b/native/memory.h @@ -10,6 +10,8 @@ ZONE* z2; ZONE* active; /* either z1 or z2 */ ZONE* prior; /* if active==z1, z2; if active==z2, z1 */ +void* alloc_guarded(CELL size); +ZONE* zalloc(CELL size); void init_arena(CELL size); void flip_zones(); diff --git a/native/run.c b/native/run.c index 65752feddd..337e083cca 100644 --- a/native/run.c +++ b/native/run.c @@ -7,15 +7,6 @@ void clear_environment(void) env.user[i] = 0; } -void init_environment(void) -{ - env.ds_bot = tag_object(array(STACK_SIZE,empty)); - reset_datastack(); - env.cs_bot = tag_object(array(STACK_SIZE,empty)); - reset_callstack(); - env.cf = env.boot; -} - #define EXECUTE(w) ((XT)(w->xt))() void run(void) @@ -27,8 +18,6 @@ void run(void) for(;;) { - check_stacks(); - if(env.cf == F) { if(cpeek() == empty) diff --git a/native/run.h b/native/run.h index 65c408779e..8072c0662f 100644 --- a/native/run.h +++ b/native/run.h @@ -17,11 +17,11 @@ typedef struct { CELL dt; /* TAGGED currently executing quotation */ CELL cf; - /* TAGGED pointer to datastack bottom */ + /* raw pointer to datastack bottom */ CELL ds_bot; /* raw pointer to datastack top */ CELL ds; - /* TAGGED pointer to callstack bottom */ + /* raw pointer to callstack bottom */ CELL cs_bot; /* raw pointer to callstack top */ CELL cs; @@ -36,7 +36,6 @@ typedef struct { ENV env; void clear_environment(void); -void init_environment(void); void check_non_empty(CELL cell); INLINE CELL dpop(void) diff --git a/native/sbuf.c b/native/sbuf.c index d1652857e6..32565bb58d 100644 --- a/native/sbuf.c +++ b/native/sbuf.c @@ -124,7 +124,7 @@ void primitive_sbuf_to_string(void) bool sbuf_eq(SBUF* s1, SBUF* s2) { if(s1->top == s2->top) - return string_compare_head(s1->string,s2->string,s1->top); + return (string_compare_head(s1->string,s2->string,s1->top) == 0); else return false; } diff --git a/native/stack.c b/native/stack.c index f4b7115229..f15bc131a3 100644 --- a/native/stack.c +++ b/native/stack.c @@ -2,16 +2,25 @@ void reset_datastack(void) { - env.ds = UNTAG(env.ds_bot) + sizeof(ARRAY); + env.ds = env.ds_bot; env.dt = empty; } void reset_callstack(void) { - env.cs = UNTAG(env.cs_bot) + sizeof(ARRAY); + env.cs = env.cs_bot; cpush(empty); } +void init_stacks(void) +{ + env.ds_bot = (CELL)alloc_guarded(STACK_SIZE); + reset_datastack(); + env.cs_bot = (CELL)alloc_guarded(STACK_SIZE); + reset_callstack(); + env.cf = env.boot; +} + void primitive_drop(void) { check_non_empty(env.dt); @@ -99,12 +108,12 @@ void primitive_from_r(void) env.dt = cpop(); } -VECTOR* stack_to_vector(CELL top, CELL bottom) +VECTOR* stack_to_vector(CELL bottom, CELL top) { - CELL depth = (top - bottom - sizeof(ARRAY)) / CELLS - 1; + CELL depth = (top - bottom) / CELLS - 1; VECTOR* v = vector(depth); ARRAY* a = v->array; - memcpy(a + 1,(void*)(bottom + sizeof(ARRAY) + CELLS),depth * CELLS); + memcpy(a + 1,(char*)bottom + CELLS,depth * CELLS); v->top = depth; return v; } @@ -112,19 +121,19 @@ VECTOR* stack_to_vector(CELL top, CELL bottom) void primitive_datastack(void) { dpush(env.dt); - env.dt = tag_object(stack_to_vector(env.ds,UNTAG(env.ds_bot))); + env.dt = tag_object(stack_to_vector(env.ds_bot,env.ds)); } void primitive_callstack(void) { dpush(env.dt); - env.dt = tag_object(stack_to_vector(env.cs,UNTAG(env.cs_bot))); + env.dt = tag_object(stack_to_vector(env.cs_bot,env.cs)); } /* Returns top of stack */ CELL vector_to_stack(VECTOR* vector, CELL bottom) { - CELL start = bottom + sizeof(ARRAY) + CELLS; + CELL start = bottom + CELLS; CELL len = vector->top * CELLS; memcpy((void*)start,vector->array + 1,len); return start + len; @@ -132,12 +141,12 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom) void primitive_set_datastack(void) { - env.ds = vector_to_stack(untag_vector(env.dt),UNTAG(env.ds_bot)); + env.ds = vector_to_stack(untag_vector(env.dt),env.ds_bot); env.dt = dpop(); } void primitive_set_callstack(void) { - env.cs = vector_to_stack(untag_vector(env.dt),UNTAG(env.cs_bot)); + env.cs = vector_to_stack(untag_vector(env.dt),env.cs_bot); env.dt = dpop(); } diff --git a/native/stack.h b/native/stack.h index 8433e1c4e1..f6e2c4c25c 100644 --- a/native/stack.h +++ b/native/stack.h @@ -1,22 +1,9 @@ -#define STACK_UNDERFLOW_CHECKING - #define STACK_UNDERFLOW(stack,bot) ((stack) < UNTAG(bot) + sizeof(ARRAY)) #define STACK_OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + object_size(bot)) -INLINE void check_stacks(void) -{ - -#ifdef STACK_UNDERFLOW_CHECKING - if(STACK_OVERFLOW(env.ds,env.ds_bot)) - general_error(ERROR_OVERFLOW,F); - if(STACK_OVERFLOW(env.cs,env.cs_bot)) - general_error(ERROR_OVERFLOW,F); -#endif - -} - void reset_datastack(void); void reset_callstack(void); +void init_stacks(void); void primitive_drop(void); void primitive_dup(void); @@ -28,7 +15,7 @@ void primitive_tuck(void); void primitive_rot(void); void primitive_to_r(void); void primitive_from_r(void); -VECTOR* stack_to_vector(CELL top, CELL bottom); +VECTOR* stack_to_vector(CELL bottom, CELL top); void primitive_datastack(void); void primitive_callstack(void); CELL vector_to_stack(VECTOR* vector, CELL bottom); diff --git a/native/string.c b/native/string.c index a266e34019..082eb8d099 100644 --- a/native/string.c +++ b/native/string.c @@ -136,8 +136,8 @@ FIXNUM string_compare(STRING* s1, STRING* s2) void primitive_string_compare(void) { - STRING* s1 = untag_string(env.dt); - STRING* s2 = untag_string(dpop()); + STRING* s2 = untag_string(env.dt); + STRING* s1 = untag_string(dpop()); env.dt = tag_fixnum(string_compare(s1,s2)); }