dictionary words, limited "target" compiler

This commit is contained in:
Jeremy Penner 2023-09-04 23:24:12 -04:00
parent 8d5fbe0143
commit 74171670b2
9 changed files with 281 additions and 74 deletions

View file

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

View file

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

14
lookup.jrt Executable file
View file

@ -0,0 +1,14 @@
:t entry= ( name len entry -- f )
dup wordname swap wordlen <rot = BZ_ [ ( p1 - fail ) patchpt ]
[ ( l1 ) target @ ] over b@ dup BZ_ [ ( p2 - success ) patchpt ]
over b@ = BZ_ [ ( p3 - fail ) patchpt ]
2inc GOTO_ [ ( l1 ) <rot w>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 ;

View file

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

Binary file not shown.

View file

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

Binary file not shown.

Binary file not shown.

View file

@ -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 <rot != if 2drop 0 return then 1 + ( word tword )
cell + dup b@t <rot != if 2drop 0 return then cell + ( word tword )
begin over b@ over b@t = while
over b@ not if 2drop 1 return then ( 0 byte, matched )
1 + swap 1 + swap
repeat 2drop 0 ;
: t' word dup strlen over DICTLIST ( word len tptr-next-entry )
: tlookup ( word -- tcp )
dup strlen over DICTLIST ( word len tptr-next-entry )
begin dup while 3dup WORD= if 5 + + swap drop return then @t repeat
drop drop drop 0 ;
: t' word tlookup ;
: t& t' cell + ;
: :ASM DEF target @ 2 + w>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 <rot
@ -167,9 +210,18 @@ DEF GOTO_ L@ GOTO_IMPL w>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 <r
DEC BP DEC BP
MOV AX @[ BP]
PUSH AX
PUSH @[ BP]
NEXT
:ASM r@
MOV AX @[ -2 @+ BP]
PUSH AX
PUSH @[ -2 @+ BP]
NEXT
:ASM rdrop
@ -390,21 +437,21 @@ dbg" patched"
)
dbg" allocation"
0 VAR, &here
:t here '>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 <rot '>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 <rot '>t fwrite '>t return
: skip>t 1 + cells target @ + w>t ;
:t fgetc ( fp -- c )
1 fbuffer <rot fread fbuffer ub@
fcount @ not BZ_ [ 2 skip>t ] drop EOF ;
:t fputc ( c fp -- ) swap fbuffer b! 1 fbuffer <rot fwrite ;
:ASM console-emit
MOV AH 2 #
@ -472,12 +518,10 @@ DEFERRED emit console-emit
NEXT
0 VAR, infile ( 0 is a predefined file handle meaning stdin )
:t in-key '>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 #