From 63ee66a8e56da77730cbb01e5eb4a03ba6eaefb8 Mon Sep 17 00:00:00 2001
From: Jeremy Penner <jeremy@sporktania.com>
Date: Fri, 1 Sep 2023 19:10:54 -0400
Subject: [PATCH] Expanded Forth kernel with simple test program

---
 .gitignore   |   1 +
 tinyjort.com | Bin 236 -> 477 bytes
 tinyjort.jrt | 136 ++++++++++++++++++++++++++++++++++++++++++++++++---
 3 files changed, 130 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index c440dfc..7dab9df 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
 *.bak
 *.obj
 *.dsk
+errors.txt
 
diff --git a/tinyjort.com b/tinyjort.com
index c27890578ce93521375acf002f25abc8a1dd1485..7d8233d7c1d83403e370fe6ddaddd95858b9dcc8 100755
GIT binary patch
literal 477
zcmXw#JxBvV5QS$pmqTM`p`|E7ng~%)5h55jrwEA`W7PbBF`5$(OfH;z{(xv<<6&cA
zC5W|PKqMd*q7V@*VyT@LmSSaR6DJq5#V+&hzV~M5>lJ7{;vBnRCk)^N?`f~EJvzTp
zr=9cKaLKOJyhJ@YeMRU-A#3hHFES(~uV;m}A*k#@&S#yMeF$=INSzPH2&=e&&_X3w
z!|F7sXm5g|aBjahU1d`fmRW#fj6~?t!K(;uqzNe#N-U;?NXGe5SIs+yAcd#m8Mwnz
z)OmS;;2KY5;02SPa>+p@`>E;eo>b#%2Hwz9|CL;@^2?eDzi9s~&i6m`KOa^u10dQ1
zBm12`|E>!v!T-MO_f*5*k}PI{FDQ9@9g^pi@^hw9gi)4oG6op9a#j%{ED>!8C`a1Z
z$`)aXCDPHxMC#1gq+~%Xok%;<Yw`-1h5(yjayB~CY+BOtx`1<5cBiV{4&)44g=XgU
i0!<rkSvh<K)oyZiuW8#ugESt0{jl(vov|C{X#M~j{h2-h

literal 236
zcmaF)myZDmjxsVZ%m!ixh6i90#M%sJIXnM1U)y>3zdBHqD<w0zBr`uRv8a+km5~{w
zhAk(tB(=B%$W>-^b`A!s)MI2|Q*rSRa|{9s2QWr3GH?L7&i+3BehdMOon;KJuFlS#
z_h6>76{VJx7UeNaWc2j~N`i&c85y{NdR$!HT!VsKU4Yu0oxA1#t2;6>u=sd}#53$;
oTpIvZ*}}-c>=YHxaGo*pG22?O(Av&pFtb_R{X_iY8E!BF0G!1{C;$Ke

diff --git a/tinyjort.jrt b/tinyjort.jrt
index 9506631..0186fa6 100755
--- a/tinyjort.jrt
+++ b/tinyjort.jrt
@@ -7,10 +7,12 @@ s" asm.jrt" loadfile
   SI - instruction pointer
   BX - W register - code pointer for current word
 
-  all other registers can and will be clobbered
+  all other registers can and will be clobbered.
+  DF must be cleared before calling NEXT, as LODSW is used to
+  increment the instruction pointer.
 )
 
-JMP 0x1000 @+
+JMP 9 @>
 
 : NEXT 
   LODSW
@@ -42,11 +44,17 @@ L: LATEST 0 w>t
 : 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 ;
 
-: WORD= ( word len tptr -- f ) ;
-: t' word dup strlen over DICTLIST @t ( word len tptr )
-  begin dup @t while 3dup WORD= if 5 + + swap drop return then repeat
+: WORD= ( word len tptr -- f ) 
+  3 + dup b@t <rot != if 2drop 0 return then 1 + ( 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 )
+  begin dup while 3dup WORD= if 5 + + swap drop return then @t repeat
   drop drop drop 0 ;
-;
+
 : :ASM DEF target @ 2 + w>t ;
 
 L: $$CONST
@@ -107,7 +115,121 @@ L: GOTO_IMPL 0 <:
 
 DEF GOTO_ L@ GOTO_IMPL w>t
 
-( 0x1000 target ! )
+L: BASE 10 w>t
+:ASM number ( str -- num 1 | str 0 )
+  ( AX - current number
+    BX - saved IP, as SI will be clobbered by LODSB
+    CX - current digit count, used to detect 0x prefix
+    DX - clobbered by IMUL 
+    SI - remainder of string to be parsed )
+  MOV BX SI ( save IP )
+  POP SI
+  PUSH SI
+  MOV BASE 10 #
+  
+  XOR AX AX
+  XOR CX CX
+L: next-digit
+  IMUL BASE
+  MOV BL AL
+  LODSB
+  CMP AL 0 #
+  JZ 1 @> ( string end )
+  CMP AL key 9 #
+  JG 2 @> ( hex or fail )
+  SUB AL key 0 #
+  JL 0 @> ( not a number )
+L: parsed-digit
+  ADD BL AL
+  ADC AH 0 #
+  INC CX
+  JMP next-digit
+L: fail-digit 0 <:
+  MOV SI BX
+  PUSH 0 #
+  NEXT
+1 <: ( string end )
+  JCXZ fail-digit ( empty string is not zero )
+  MOV SI BX
+  POP DX
+  PUSH AX
+  PUSH 1 #
+  NEXT
+2 <: ( hex or fail )
+  CMP AL key x ( lowercase x )
+  JNZ 0 @>
+  CMP CX 1 # ( x is second character )
+  JNZ 1 @>
+  CMP BL 0 # ( first character was a 0 ) 
+  JNZ 2 @>
+  MOV BASE 16 #
+  JMP next-digit
+0 <: 1 <: 2 <: ( actual parsing of hex digit )
+  SUB AL key A #
+  JL fail-digit
+  ADD AL 10 #
+  CMP AL BASE
+  JL parsed-digit
+  SUB AL key a key A - 10 - #
+  JL fail-digit
+  ADD AL 10 #
+  CMP AL BASE
+  JL parsed-digit
+  JMP fail-digit
+
+:ASM drop
+  POP AX
+  NEXT
+
+:ASM dup
+  POP AX
+  PUSH AX
+  PUSH AX
+  NEXT
+
+:ASM swap
+  POP AX
+  POP BX
+  PUSH AX
+  PUSH BX
+  NEXT
+
+:ASM over
+  POP AX
+  POP BX
+  POP BX
+  POP AX
+  POP BX
+  NEXT
+
+:ASM <rot
+  POP AX
+  POP BX
+  POP CX
+  PUSH BX
+  PUSH AX
+  PUSH CX
+  NEXT
+
+:ASM emit
+  MOV AH 5 #
+  POP DX
+  INT 0x21 #
+  NEXT
+
+:ASM terminate
+  MOV AH 0x4c #
+  MOV AL 0 # ( todo: pop )
+  INT 0x21 #
+
+( test program )
+ARRAY hex65 key 0 >t key x >t key 6 >t key 5 >t 0 >t   
+L: test-word L@ $$COLON w>t t' hex65 w>t t' emit w>t t' terminate w>t
+
+9 <: ( actual entry point )
+  LEA SI test-word
+  ( TODO: configure stacks )
+  NEXT  
 
 .s