diff --git a/boot.jor b/boot.jor index 71f07ee..a63697f 100755 --- a/boot.jor +++ b/boot.jor @@ -7,8 +7,7 @@ 13 const '\r' key const sp -128 const F_IMMEDIATE -0x100 const F_USERWORD +0x100 const F_IMMEDIATE : cr '\n' emit ; : bl sp emit ; @@ -60,7 +59,7 @@ key const sp ( image loading ) : noop ; -: defer word new-word $DODEFERRED , ' noop , ; +: defer new-word $DODEFERRED , ' noop , ; : redefine ( cp cpdeferred ) cell + ! ; : definition ( cpdeferred ) cell + @ ; diff --git a/defs.jrt b/defs.jrt index 9585aaa..f0737f0 100755 --- a/defs.jrt +++ b/defs.jrt @@ -27,8 +27,8 @@ : :noname here $DOCOLON , ] ; -: array word new-word $DOVAR , ; -: create word new-word $DOCREATE , 0 , ; +: array new-word $DOVAR , ; +: create new-word $DOCREATE , 0 , ; : finishcreate ( ipfirst -- ) ( set cell after codepointer to first instruction of does> ) diff --git a/lookup.jrt b/lookup.jrt new file mode 100755 index 0000000..470c6c1 --- /dev/null +++ b/lookup.jrt @@ -0,0 +1,14 @@ +:t entry= ( name len entry -- f ) + dup wordname swap wordlen t ] + ( fail ) [ patch!t swap patch!t ] drop drop 0 return + ( success ) [ patch!t ] drop drop 1 ; + +:t lookup ( name -- cp meta | name 0 ) + dup strlen over dictbucket + [ target @ ] @ dup . dup BZ_ [ patchpt ] + 3dup entry= BZ_ [ swap w>t ] + ( entry found ) >rot drop drop dup codepointer swap wordflags @ return + ( end of list ) [ patch!t ] drop drop 0 ; diff --git a/minijort.c b/minijort.c index 267c2a3..1900834 100755 --- a/minijort.c +++ b/minijort.c @@ -345,7 +345,7 @@ void f_bcomma() { DROP(1); } -void f_create() { // name -- +void f_create() { // word -- int namelen; HERE->p = LATEST; LATEST = HERE; @@ -357,6 +357,10 @@ void f_create() { // name -- DROP(1); } +void f_newword() { + f_word(); + f_create(); +} void f_cdef() { // func name -- f_create(); f_comma(); @@ -765,7 +769,7 @@ void f_init() { CDEF("word", f_word); CDEF("immediate", f_immediate); CDEF("execute", f_execute); - CDEF("new-word", f_create); + CDEF("new-word", f_newword); CDEF("here", f_here); CDEF("here!", f_here_set); CDEF("there", f_there); diff --git a/minijort.exe b/minijort.exe index ca92ae2..f50beb6 100755 Binary files a/minijort.exe and b/minijort.exe differ diff --git a/minijort.h b/minijort.h index 924da7d..fec5f70 100755 --- a/minijort.h +++ b/minijort.h @@ -34,8 +34,8 @@ extern cell *rstack; extern cell *stack; extern FILE *IN_FILE; extern FILE *OUT_FILE; -#define F_NAMELEN_MASK 0x7f -#define F_IMMEDIATE 0x80 +#define F_NAMELEN_MASK 0xff +#define F_IMMEDIATE 0x100 #define CELL_OFFSET(cp, b) ((cell*)(((char *)(cp)) + b)) #define TOP() (*(stack - 1)) diff --git a/minijort.prj b/minijort.prj index 212ee0d..2e5e549 100755 Binary files a/minijort.prj and b/minijort.prj differ diff --git a/tinyjort.com b/tinyjort.com index a292488..c7570b1 100755 Binary files a/tinyjort.com and b/tinyjort.com differ diff --git a/tinyjort.jrt b/tinyjort.jrt index 9fae020..ef7c5e2 100755 --- a/tinyjort.jrt +++ b/tinyjort.jrt @@ -28,8 +28,9 @@ JMP 9 @> bits. Entry: LINK - pointer to next word in the dictionary - FLAGS - byte - LENGTH - byte + META - word, made up of: + LENGTH - byte + FLAGS - byte NAME - bytes ending in \0 CODE POINTER - pointer to machine code routine ) @@ -38,26 +39,30 @@ L: DICTIONARY 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t L: LATEST 0 w>t +0x0f const BUCKETMASK + : savelabel ( word -- ) dup type s" : " type here swap begin dup b@ dup while b, 1 + repeat b, drop lastlabel ! ; -: DICTLIST ( word -- tptr ) b@ 0x0f & cells [ L@ DICTIONARY lit ] + ; +: DICTLIST ( word -- tptr ) b@ BUCKETMASK & cells [ L@ DICTIONARY lit ] + ; : strlen ( word -- len ) 0 swap begin dup b@ while swap 1 + swap 1 + repeat drop ; : str>t ( word -- ) begin dup b@ dup while >t 1 + repeat >t drop ; -: link>t ( tptr-head -- ) dup @t swap target @ swap !t w>t ; -: DEF word dup savelabel dup DICTLIST link>t 0 >t dup strlen >t str>t +: patch!t ( tptr -- ) target @ swap !t ; +: link>t ( tptr-head -- ) dup @t swap patch!t w>t ; +: DEF word dup savelabel dup DICTLIST link>t dup strlen w>t str>t target @ cell + .hex cr ; : WORD= ( word len tptr -- f ) - 3 + dup b@t t ; @@ -71,6 +76,7 @@ L: $$CONST : CONST DEF [ L@ $$CONST lit ] w>t w>t ; +L@ $$CONST CONST $DOCONST L@ DICTIONARY CONST dictionary L@ LATEST CONST &latest @@ -99,22 +105,35 @@ L@ $$VAR CONST $DOVAR MOV SI @[ BP] NEXT -( some helpers for making manually defining colon words slightly less ugly ) -: '>t t' w>t ; -: :t DEF [ t& $DOCOLON lit ] w>t ; - :CP $DODEFERRED INC BX INC BX MOV BX @[ BX] JMP @[ BX] -: DEFERRED DEF [ t& $DODEFERRED lit ] w>t '>t ; - :ASM LIT_ LODSW PUSH AX NEXT +( some helpers for making manually defining colon words less ugly ) +: '>t t' w>t ; + +: stch? ( str -- f ) ' @ , key lit ' = , ; immediate +( DOES NOT SUPPORT ARBITRARY IMMEDIATE WORDS. + Supports [], comments, ; and numeric literals ONLY. + You must use [ for anything fancy. ) +: :t DEF [ t& $DOCOLON lit ] w>t ] + begin word dup stch? ; not while + state if dup stch? [ if drop [ ' [ , ] else + dup stch? ( if drop [ ' ( , ] else + dup tlookup dup if w>t drop else drop + number if [ t' LIT_ lit ] w>t w>t else + type s" ?" type cr then then then then else + compileword then + repeat drop [ t' return lit ] w>t [ ' [ , ] ; + +: DEFERRED DEF [ t& $DODEFERRED lit ] w>t '>t ; + :ASM INLINEDATA_ LODSW PUSH SI @@ -143,6 +162,27 @@ DEF GOTO_ L@ GOTO_IMPL w>t PUSH AX NEXT +:ASM 2dup + POP AX + POP BX + PUSH BX + PUSH AX + PUSH BX + PUSH AX + NEXT + +:ASM 3dup + POP AX + POP BX + POP CX + PUSH CX + PUSH BX + PUSH AX + PUSH CX + PUSH BX + PUSH AX + NEXT + :ASM swap POP AX POP BX @@ -151,11 +191,14 @@ DEF GOTO_ L@ GOTO_IMPL w>t NEXT :ASM over - POP AX - POP BX - POP BX - POP AX + ( this costs 1 extra byte but should save 20 clock cycles ) + MOV BX SP + PUSH @[ 4 @+ SS: BX] +( POP AX POP BX + PUSH BX + PUSH AX + PUSH BX ) NEXT :ASM t PUSH CX NEXT +:ASM >rot + POP AX + POP BX + POP CX + PUSH AX + PUSH CX + PUSH BX + NEXT + :ASM terminate MOV AH 0x4c # - MOV AL 0 # ( todo: pop ) + MOV AL 0 # ( todo: pop? ) INT 0x21 # :ASM execute @@ -248,9 +300,9 @@ L: RETFALSE JZ RETFALSE JMP RETTRUE -:t != '>t = '>t not '>t return -:t <= '>t > '>t not '>t return -:t >= '>t < '>t not '>t return +:t != = not ; +:t <= > not ; +:t >= < not ; dbg" bitwise" :ASM & @@ -281,7 +333,7 @@ dbg" bitwise" PUSH AX NEXT -:ASM >> +:ASM >> ( val count ) POP CX POP AX SHR AX CL @@ -291,8 +343,7 @@ dbg" bitwise" dbg" mem" :ASM @ POP BX - MOV AX @[ BX] - PUSH AX + PUSH @[ BX] NEXT :ASM b@ @@ -311,8 +362,7 @@ dbg" mem" :ASM @far POP ES POP BX - MOV AX @[ ES: BX] - PUSH AX + PUSH @[ ES: BX] NEXT :ASM b@far @@ -323,8 +373,8 @@ dbg" mem" NEXT :ASM ! - POP BX POP AX - MOV @[ BX] AX + POP BX + POP @[ BX] NEXT :ASM b! @@ -333,8 +383,8 @@ dbg" mem" NEXT :ASM !far - POP ES POP BX POP AX - MOV @[ ES: BX] AX + POP ES POP BX + POP @[ ES: BX] NEXT :ASM b!far @@ -344,20 +394,17 @@ dbg" mem" dbg" return stack" :ASM >r - POP AX - MOV @[ BP] AX + POP @[ BP] INC BP INC BP NEXT :ASM t &here '>t @ '>t return -:t here! '>t &here '>t ! '>t return +:t here &here @ ; +:t here! &here ! ; 0xffff CONST there -:t latest '>t &latest '>t @ '>t return -:t latest! '>t &latest '>t ! '>t return +:t latest &latest @ ; +:t latest! &latest ! ; 0 VAR, lastseg -:t segalloc '>t lastseg '>t @ '>t LIT_ 4096 w>t '>t + - '>t dup '>t lastseg '>t ! '>t return +:t segalloc lastseg @ 4096 + dup lastseg ! ; 2 CONST cell -:t allot '>t here '>t + '>t here! '>t return -:t , '>t here '>t ! '>t cell '>t allot '>t return -:t b, '>t here '>t b! '>t LIT_ 1 w>t '>t allot '>t return +:t cells cell * ; +:t allot here + here! ; +:t , here ! cell allot ; +:t b, here b! 1 allot ; dbg" i/o" :ASM overwrite @@ -450,12 +497,11 @@ dbg" i/o" -1 CONST EOF 0 VAR, fbuffer -:t fgetc '>t LIT_ 1 w>t '>t fbuffer '>t t fread - '>t fbuffer '>t ub@ - '>t fcount '>t @ '>t not '>t BZ_ target @ 3 cells + w>t - '>t drop '>t EOF '>t return -:t fputc '>t swap '>t fbuffer '>t b! - '>t LIT_ 1 w>t '>t fbuffer '>t t fwrite '>t return +: skip>t 1 + cells target @ + w>t ; +:t fgetc ( fp -- c ) + 1 fbuffer t ] drop EOF ; +:t fputc ( c fp -- ) swap fbuffer b! 1 fbuffer t infile '>t @ '>t dup '>t BZ_ target @ 4 cells + w>t - '>t drop '>t console-key '>t return - '>t fgetc '>t return +:t in-key infile @ dup BZ_ [ 3 skip>t ] drop console-key return fgetc ; DEFERRED key in-key -dbg" number" +dbg" parsing" L: BASE 10 w>t L: ISNEG? 0 >t :ASM number ( str -- num 1 | str 0 ) ( AX - current number @@ -595,17 +639,163 @@ L: write-next-digit PUSH t& &here @+ NEXT -:t type target @ '>t dup '>t b@ '>t dup '>t BZ_ target @ 7 cells + w>t - '>t emit '>t LIT_ 1 w>t '>t + '>t GOTO_ w>t '>t drop '>t drop '>t return -:t . '>t num>str '>t type '>t LIT_ key w>t '>t emit '>t return +:t type [ target @ ] + dup b@ dup BZ_ [ 6 skip>t ] + emit 1 + GOTO_ [ w>t ] + drop drop ; +:t . num>str type LIT_ [ key w>t ] emit ; -dbg" test" -( test program ) -ARRAY hex65 key - >t key 6 >t key 5 >t 0 >t -L: test-word '>t hex65 '>t number '>t . '>t . '>t terminate +:ASM whitespace? + POP AX + CMP AX key # + JZ 0 @> + CMP AX 13 # ( newline ) + JZ 1 @> + CMP AX 10 # ( linefeed ) + JZ 2 @> + CMP AX 9 # ( tab ) + JNZ 3 @> +0 <: 1 <: 2 <: + PUSH TRUE + NEXT +3 <: + PUSH FALSE + NEXT + +:ASM eoi? ( end of input ) + POP AX + CMP AX 0 # ( null ) + JZ 0 @> + CMP AX -1 # ( EOF ) + JNZ 1 @> +0 <: + PUSH TRUE + NEXT +1 <: + PUSH FALSE + NEXT + +:t word, + ( consume leading whitespace ) + 0 [ target @ ] drop key dup whitespace? not BZ_ [ w>t ] + ( consume non-whitespace / eoi characters ) + [ target @ ] dup whitespace? over eoi? or + ( if whitespace or eoi, end ) BZ_ [ 5 skip>t ] drop 0 b, return + ( otherwise, write byte and continue ) b, key GOTO_ [ w>t ] ; + +:t word here word, dup here! ; + +dbg" compiler" +:t wordflags cell + ; +:t wordname 2 cells + ; +:t wordlen wordflags ub@ ; +:t codepointer dup wordname swap wordlen + ( trailing null ) 1 + ; +:t dictbucket ( word -- p ) ub@ LIT_ [ BUCKETMASK w>t ] & cells dictionary + ; +:t new-word + ( set latest ) here latest! + ( create entry ) 0 dup , , + ( save word + calc length ) here word, here swap - + ( save length ) latest wordflags ! + ( find bucket ) latest wordname dictbucket + ( link to prev ) dup @ latest ! + ( link bucket to new ) latest swap ! ; +:t 2inc ( x y -- x+1 y+1 ) 1 + swap 1 + swap ; +:t strlen ( name -- len ) + 0 swap [ target @ ] dup b@ BZ_ [ 3 skip>t ] + 2inc GOTO_ [ w>t ] drop ; + +: patchpt target @ 0 w>t ; + +:ASM dict-lookup ( name dict -- cp meta | name 0 ) + POP BX ( dictionary ) + POP DI ( name ) + ( strlen - in DI: str, out CX: len, clobbers AX ) + XOR CX CX DEC CX ( start CX at -1 so we search until we find the 0 ) + XOR AX AX ( search for 0 ) + REPNZ SCASB + NEG CX DEC CX + SUB DI CX ( restore DI ) + DEC CX ( ignore trailing zero ) + + ( keeping CX + DI, find the next entry pointer and store in BX ) + MOV AL @[ DI] + AND AL BUCKETMASK # + SHL AX 1 # + ADD BX AX + + ( save SI ) + MOV DX SI + +L: check-next-entry + MOV BX @[ BX] + CMP BX 0 # + JZ 0 @> + CMP CL @[ 2 @+ BX] + JNZ check-next-entry + + ( we have a matching length; compare the string ) + PUSH CX + PUSH DI + MOV SI BX + ADD SI 4 # + REPZ CMPSB + POP DI + POP CX + JNZ check-next-entry + + ( we have a matching word! return success ) + MOV AX @[ 2 @+ BX] ( read flag word ) + ADD BX CX ( strlen ) + ADD BX 5 # ( header + null byte ) + PUSH BX + PUSH AX + MOV SI DX ( restore SI ) + NEXT + +0 <: ( failure; we've hit a null pointer in our linked list ) + PUSH DI ( push word pointer back onto the stack ) + PUSH FALSE + MOV SI DX ( restore SI ) + NEXT + +:t lookup dictionary dict-lookup ; + +0x100 CONST F_IMMEDIATE +:t immediate latest wordflags dup @ F_IMMEDIATE | swap ! ; +: IMMEDIATE [ L@ LATEST lit ] @t cell + dup @t 0x100 | swap !t ; + +0 VAR, &state +:t state &state @ ; +:t ] 1 &state ! ; +:t [ 0 &state ! ; IMMEDIATE +:t : new-word $DOCOLON , ] ; +:t ; LIT_ return , [ '>t [ ] ; IMMEDIATE +:t const new-word $DOCONST , , ; +:t var new-word $DOVAR , 0 , ; +:t interpretword ( cp meta -- ) F_IMMEDIATE & state not or + BZ_ [ patchpt ] execute return [ patch!t ] , ; +:t interpretnumber ( n -- n? ) state BZ_ [ patchpt ] LIT_ , , [ patch!t ] ; +:t ?err ( word -- ) type LIT_ [ key ? w>t ] emit 13 emit ; +DEFERRED err ?err +:t compileword ( word -- ) + lookup dup BZ_ [ patchpt ] interpretword return [ patch!t ] + drop number BZ_ [ patchpt ] interpretnumber return [ patch!t ] + err ; +:t interpreter + [ target @ ] word dup b@ BZ_ [ patchpt ] compileword GOTO_ [ swap w>t ] + [ patch!t ] drop ; + +dbg" boot stub" +:ASM debug NEXT +: t" begin key dup [ key " lit ] != while >t repeat drop 0 >t ; +ARRAY input t" +" +t& input VAR, inptr +:t keyinput inptr @ b@ dup BZ_ [ patchpt ] inptr @ 1 + inptr ! [ patch!t ] ; +t' keyinput t& key !t +:t tinyjort 1 2 word lookup drop execute . terminate ; 9 <: ( actual entry point ) - LEA SI test-word + MOV SI t& tinyjort # PUSH CS POP AX ADD AX 4096 #