dictionary words, limited "target" compiler

boot.jor

@@ -7,8 +7,7 @@
 13 const '\r'
 key  const sp
 
-128 const F_IMMEDIATE
+0x100 const F_IMMEDIATE
-0x100 const F_USERWORD
 
 : 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 + @ ;
 

defs.jrt

@@ -27,8 +27,8 @@
 
 : :noname here $DOCOLON , ] ;
 
-: array word new-word $DOVAR , ;
+: array new-word $DOVAR , ;
-: create word new-word $DOCREATE , 0 , ;
+: create new-word $DOCREATE , 0 , ;
 
 : finishcreate ( ipfirst -- )
   ( set cell after codepointer to first instruction of does> )

lookup.jrt

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

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

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_NAMELEN_MASK 0xff
-#define F_IMMEDIATE 0x80
+#define F_IMMEDIATE 0x100
 
 #define CELL_OFFSET(cp, b) ((cell*)(((char *)(cp)) + b))
 #define TOP() (*(stack - 1))

tinyjort.jrt

@@ -28,8 +28,9 @@ JMP 9 @>
                bits.
   Entry:
   LINK - pointer to next word in the dictionary
-  FLAGS - 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 ;
+: patch!t ( tptr -- ) target @ swap !t ;
-: DEF word dup savelabel dup DICTLIST link>t 0 >t dup strlen >t str>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 ;
-
+: tlookup ( word -- tcp )
-: t' word dup strlen over DICTLIST ( word len tptr-next-entry )
+  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
+  ( this costs 1 extra byte but should save 20 clock cycles )
-  POP BX
+  MOV BX SP
-  POP BX
+  PUSH @[ 4 @+ SS: BX]
-  POP AX
+(  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 != = not ;
-:t <= '>t > '>t not '>t return
+:t <= > not ;
-:t >= '>t < '>t not '>t return
+: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 @[ BX]
-  PUSH AX
   NEXT
 
 :ASM b@
@@ -311,8 +362,7 @@ dbg" mem"
 
 :ASM @far
   POP ES POP BX
-  MOV AX @[ ES: BX]
+  PUSH @[ ES: BX]
-  PUSH AX
   NEXT
 
 :ASM b@far
@@ -323,8 +373,8 @@ dbg" mem"
   NEXT
 
 :ASM !
-  POP BX POP AX
+  POP BX
-  MOV @[ BX] AX
+  POP @[ BX]
   NEXT
 
 :ASM b!
@@ -333,8 +383,8 @@ dbg" mem"
   NEXT
 
 :ASM !far
-  POP ES POP BX POP AX
+  POP ES POP BX
-  MOV @[ ES: BX] AX
+  POP @[ ES: BX]
   NEXT
 
 :ASM b!far
@@ -344,20 +394,17 @@ dbg" mem"
 
 dbg" return stack"
 :ASM >r
-  POP AX
+  POP @[ BP]
-  MOV @[ BP] AX
   INC BP INC BP
   NEXT
 
 :ASM <r
   DEC BP DEC BP
-  MOV AX @[ BP]
+  PUSH @[ BP]
-  PUSH AX
   NEXT
 
 :ASM r@
-  MOV AX @[ -2 @+ BP]
+  PUSH @[ -2 @+ BP]
-  PUSH AX
   NEXT
 
 :ASM rdrop
@@ -390,21 +437,21 @@ dbg" patched"
 )
 dbg" allocation"
 0 VAR, &here
-:t here '>t &here '>t @ '>t return
+:t here &here @ ;
-:t here! '>t &here '>t ! '>t return
+:t here! &here ! ;
 0xffff CONST there
 
-:t latest '>t &latest '>t @ '>t return
+:t latest &latest @ ;
-:t latest! '>t &latest '>t ! '>t return
+:t latest! &latest ! ;
 
 0 VAR, lastseg
-:t segalloc '>t lastseg '>t @ '>t LIT_ 4096 w>t '>t + 
+:t segalloc lastseg @ 4096 + dup lastseg ! ;
-   '>t dup '>t lastseg '>t ! '>t return
 
 2 CONST cell
-:t allot '>t here '>t + '>t here! '>t return
+:t cells cell * ;
-:t , '>t here '>t ! '>t cell '>t allot '>t return
+:t allot here + here! ;
-:t b, '>t here '>t b! '>t LIT_ 1 w>t '>t allot '>t return
+: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
+: skip>t 1 + cells target @ + w>t ;
-   '>t fbuffer '>t ub@
+:t fgetc ( fp -- c )
-   '>t fcount '>t @ '>t not '>t BZ_ target @ 3 cells + w>t
+  1 fbuffer <rot fread fbuffer ub@
-   '>t drop '>t EOF '>t return
+  fcount @ not BZ_ [ 2 skip>t ] drop EOF ;
-:t fputc '>t swap '>t fbuffer '>t b!
+:t fputc ( c fp -- ) swap fbuffer b! 1 fbuffer <rot fwrite ;
-   '>t LIT_ 1 w>t '>t fbuffer '>t <rot '>t fwrite '>t return
 
 :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 in-key infile @ dup BZ_ [ 3 skip>t ] drop console-key return fgetc ;
-   '>t drop '>t console-key '>t return
-   '>t fgetc '>t return
 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 type [ target @ ]
-   '>t emit '>t LIT_ 1 w>t '>t + '>t GOTO_ w>t '>t drop '>t drop '>t return
+   dup b@ dup BZ_ [ 6 skip>t ] 
-:t . '>t num>str '>t type '>t LIT_ key  w>t '>t emit '>t return
+   emit 1 + GOTO_ [ w>t ]
+   drop drop ;
+:t . num>str type LIT_ [ key  w>t ] emit ;
 
-dbg" test"
+:ASM whitespace?
-( test program )
+  POP AX
-ARRAY hex65 key - >t key 6 >t key 5 >t 0 >t   
+  CMP AX key  #
-L: test-word '>t hex65 '>t number '>t . '>t . '>t terminate
+  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 #