2023-09-01 23:10:52 +00:00
|
|
|
s" defs.jrt" loadfile
|
2023-09-02 01:51:22 +00:00
|
|
|
dbg" loading asm.jrt"
|
2023-09-01 23:10:52 +00:00
|
|
|
s" asm.jrt" loadfile
|
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
dbg" assembling..."
|
2023-09-01 23:10:52 +00:00
|
|
|
( tinyjort calling convention:
|
|
|
|
SP - data stack pointer, grows down
|
|
|
|
BP - return stack pointer, grows up
|
|
|
|
SI - instruction pointer
|
|
|
|
BX - W register - code pointer for current word
|
2023-09-01 23:10:52 +00:00
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
all other registers can and will be clobbered.
|
|
|
|
DF must be cleared before calling NEXT, as LODSW is used to
|
|
|
|
increment the instruction pointer.
|
2023-09-01 23:10:52 +00:00
|
|
|
)
|
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
JMP 9 @>
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
: NEXT
|
|
|
|
LODSW
|
|
|
|
MOV BX AX
|
|
|
|
JMP @[ BX] ;
|
|
|
|
|
|
|
|
( dictionary format:
|
|
|
|
DICTIONARY - an array of 16 pointers to linked lists of entries.
|
|
|
|
The dictlist for a given word is chosen by taking the
|
|
|
|
first character of the word and taking its first 4
|
|
|
|
bits.
|
|
|
|
Entry:
|
|
|
|
LINK - pointer to next word in the dictionary
|
2023-09-05 03:24:12 +00:00
|
|
|
META - word, made up of:
|
|
|
|
LENGTH - byte
|
|
|
|
FLAGS - byte
|
2023-09-01 23:10:52 +00:00
|
|
|
NAME - bytes ending in \0
|
|
|
|
CODE POINTER - pointer to machine code routine )
|
|
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
0x0f const BUCKETMASK
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: savelabel ( word -- )
|
2023-09-04 18:23:12 +00:00
|
|
|
dup type s" : " type
|
2023-09-01 23:10:52 +00:00
|
|
|
here swap begin dup b@ dup while b, 1 + repeat b, drop lastlabel ! ;
|
2023-09-05 03:24:12 +00:00
|
|
|
: DICTLIST ( word -- tptr ) b@ BUCKETMASK & cells [ L@ DICTIONARY lit ] + ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: 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 ;
|
2023-09-05 03:24:12 +00:00
|
|
|
: 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
|
2023-09-04 18:23:12 +00:00
|
|
|
target @ cell + .hex cr ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
: WORD= ( word len tptr -- f )
|
2023-09-05 03:24:12 +00:00
|
|
|
cell + dup b@t <rot != if 2drop 0 return then cell + ( word tword )
|
|
|
|
begin over b@ over b@t = while
|
2023-09-01 23:10:54 +00:00
|
|
|
over b@ not if 2drop 1 return then ( 0 byte, matched )
|
|
|
|
1 + swap 1 + swap
|
|
|
|
repeat 2drop 0 ;
|
2023-09-05 03:24:12 +00:00
|
|
|
: tlookup ( word -- tcp )
|
|
|
|
dup strlen over DICTLIST ( word len tptr-next-entry )
|
2023-09-01 23:10:54 +00:00
|
|
|
begin dup while 3dup WORD= if 5 + + swap drop return then @t repeat
|
2023-09-01 23:10:52 +00:00
|
|
|
drop drop drop 0 ;
|
2023-09-05 03:24:12 +00:00
|
|
|
: t' word tlookup ;
|
2023-09-02 01:51:22 +00:00
|
|
|
: t& t' cell + ;
|
2023-09-01 23:10:54 +00:00
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: :ASM DEF target @ 2 + w>t ;
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" core"
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
L: $$CONST
|
|
|
|
INC BX INC BX
|
|
|
|
PUSH @[ BX]
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
: CONST DEF [ L@ $$CONST lit ] w>t w>t ;
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
L@ $$CONST CONST $DOCONST
|
2023-09-01 23:10:52 +00:00
|
|
|
L@ DICTIONARY CONST dictionary
|
2023-09-02 01:51:22 +00:00
|
|
|
L@ LATEST CONST &latest
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
L: $$VAR
|
|
|
|
INC BX INC BX
|
|
|
|
PUSH BX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
: ARRAY DEF [ L@ $$VAR lit ] w>t ;
|
|
|
|
: VAR, ARRAY w>t ;
|
|
|
|
|
|
|
|
( "codepointer words" that evaluate to a pointer to the assembly -
|
|
|
|
useful to define things like $DOCOLON. )
|
|
|
|
: :CP ARRAY ;
|
|
|
|
L@ $$VAR CONST $DOVAR
|
|
|
|
|
|
|
|
:CP $DOCOLON
|
|
|
|
MOV @[ BP] SI
|
|
|
|
INC BP INC BP
|
|
|
|
INC BX INC BX
|
|
|
|
MOV SI BX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM return
|
|
|
|
DEC BP DEC BP
|
2023-09-04 18:23:12 +00:00
|
|
|
MOV SI @[ BP]
|
2023-09-01 23:10:52 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:CP $DODEFERRED
|
|
|
|
INC BX INC BX
|
|
|
|
MOV BX @[ BX]
|
|
|
|
JMP @[ BX]
|
|
|
|
|
|
|
|
:ASM LIT_
|
|
|
|
LODSW
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
( 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 ;
|
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM INLINEDATA_
|
|
|
|
LODSW
|
|
|
|
PUSH SI
|
|
|
|
MOV SI AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
:ASM BZ_
|
|
|
|
POP CX
|
|
|
|
JCXZ 0 @>
|
|
|
|
LODSW
|
|
|
|
NEXT
|
|
|
|
L: GOTO_IMPL 0 <:
|
2023-09-01 23:10:52 +00:00
|
|
|
LODSW
|
|
|
|
MOV SI AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
DEF GOTO_ L@ GOTO_IMPL w>t
|
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
:ASM drop
|
|
|
|
POP AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM dup
|
|
|
|
POP AX
|
|
|
|
PUSH AX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:ASM 2dup
|
2023-09-01 23:10:54 +00:00
|
|
|
POP AX
|
|
|
|
POP BX
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH BX
|
2023-09-01 23:10:54 +00:00
|
|
|
PUSH AX
|
|
|
|
PUSH BX
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH AX
|
2023-09-01 23:10:54 +00:00
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:ASM 3dup
|
2023-09-01 23:10:54 +00:00
|
|
|
POP AX
|
|
|
|
POP BX
|
2023-09-05 03:24:12 +00:00
|
|
|
POP CX
|
|
|
|
PUSH CX
|
|
|
|
PUSH BX
|
|
|
|
PUSH AX
|
|
|
|
PUSH CX
|
|
|
|
PUSH BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM swap
|
2023-09-01 23:10:54 +00:00
|
|
|
POP AX
|
|
|
|
POP BX
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH AX
|
|
|
|
PUSH BX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM over
|
|
|
|
( 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 )
|
2023-09-01 23:10:54 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM <rot
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
POP CX
|
|
|
|
PUSH BX
|
|
|
|
PUSH AX
|
|
|
|
PUSH CX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:ASM >rot
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
POP CX
|
|
|
|
PUSH AX
|
|
|
|
PUSH CX
|
|
|
|
PUSH BX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-01 23:10:54 +00:00
|
|
|
:ASM terminate
|
|
|
|
MOV AH 0x4c #
|
2023-09-05 03:24:12 +00:00
|
|
|
MOV AL 0 # ( todo: pop? )
|
2023-09-01 23:10:54 +00:00
|
|
|
INT 0x21 #
|
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM execute
|
|
|
|
POP BX
|
|
|
|
JMP @[ BX]
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" math"
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM +
|
|
|
|
POP AX POP BX
|
|
|
|
ADD AX BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM -
|
|
|
|
POP BX POP AX
|
|
|
|
SUB AX BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM *
|
|
|
|
POP BX POP AX
|
|
|
|
IMUL BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" comparisons"
|
2023-10-16 19:54:44 +00:00
|
|
|
L: TRUE 0xffff w>t
|
|
|
|
L: FALSE 0 w>t
|
|
|
|
L: RETTRUE
|
|
|
|
PUSH TRUE
|
|
|
|
NEXT
|
|
|
|
L: RETFALSE
|
|
|
|
PUSH FALSE
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM not
|
|
|
|
POP AX
|
|
|
|
CMP AX FALSE
|
|
|
|
JZ RETTRUE
|
|
|
|
JMP RETFALSE
|
|
|
|
|
|
|
|
:ASM =
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
CMP AX BX
|
|
|
|
JZ RETTRUE
|
|
|
|
JMP RETFALSE
|
|
|
|
|
|
|
|
:ASM <
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
CMP AX BX
|
|
|
|
JL RETTRUE
|
|
|
|
JMP RETFALSE
|
|
|
|
|
|
|
|
:ASM >
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
CMP AX BX
|
|
|
|
JG RETTRUE
|
|
|
|
JMP RETFALSE
|
|
|
|
|
|
|
|
:ASM and
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
CMP AX FALSE
|
|
|
|
JZ RETFALSE
|
|
|
|
CMP BX FALSE
|
|
|
|
JZ RETFALSE
|
|
|
|
JMP RETTRUE
|
|
|
|
|
|
|
|
:ASM or
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
OR AX BX
|
|
|
|
JZ RETFALSE
|
|
|
|
JMP RETTRUE
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:t != = not ;
|
|
|
|
:t <= > not ;
|
|
|
|
:t >= < not ;
|
2023-10-16 19:54:44 +00:00
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" bitwise"
|
2023-10-16 19:54:44 +00:00
|
|
|
:ASM &
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
AND AX BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM |
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
OR AX BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM ^
|
|
|
|
POP AX
|
|
|
|
POP BX
|
|
|
|
XOR AX BX
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM << ( val count )
|
|
|
|
POP CX
|
|
|
|
POP AX
|
|
|
|
SHL AX CL
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:ASM >> ( val count )
|
2023-10-16 19:54:44 +00:00
|
|
|
POP CX
|
|
|
|
POP AX
|
|
|
|
SHR AX CL
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" mem"
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM @
|
|
|
|
POP BX
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH @[ BX]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM b@
|
|
|
|
POP BX
|
|
|
|
MOV AL @[ BX]
|
|
|
|
CBW
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-10-16 19:54:44 +00:00
|
|
|
:ASM ub@
|
|
|
|
POP BX
|
|
|
|
MOV AL @[ BX]
|
|
|
|
XOR AH AH
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM @far
|
|
|
|
POP ES POP BX
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH @[ ES: BX]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM b@far
|
|
|
|
POP ES POP BX
|
|
|
|
MOV AL @[ ES: BX]
|
|
|
|
CBW
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM !
|
2023-09-05 03:24:12 +00:00
|
|
|
POP BX
|
|
|
|
POP @[ BX]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM b!
|
|
|
|
POP BX POP AX
|
|
|
|
MOV @[ BX] AL
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM !far
|
2023-09-05 03:24:12 +00:00
|
|
|
POP ES POP BX
|
|
|
|
POP @[ ES: BX]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM b!far
|
|
|
|
POP ES POP BX POP AX
|
|
|
|
MOV @[ ES: BX] AL
|
|
|
|
NEXT
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" return stack"
|
2023-09-02 01:51:22 +00:00
|
|
|
:ASM >r
|
2023-09-05 03:24:12 +00:00
|
|
|
POP @[ BP]
|
2023-09-02 01:51:22 +00:00
|
|
|
INC BP INC BP
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM <r
|
|
|
|
DEC BP DEC BP
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH @[ BP]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM r@
|
2023-09-05 03:24:12 +00:00
|
|
|
PUSH @[ -2 @+ BP]
|
2023-09-02 01:51:22 +00:00
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM rdrop
|
|
|
|
DEC BP DEC BP
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM rswap
|
|
|
|
MOV AX @[ -2 @+ BP]
|
|
|
|
MOV BX @[ -4 @+ BP]
|
|
|
|
MOV @[ -2 @+ BP] BX
|
|
|
|
MOV @[ -4 @+ BP] AX
|
|
|
|
NEXT
|
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" ASMEXEC"
|
|
|
|
( usage: push a CP onto the stack, then CALL ASMEXEC.
|
|
|
|
will execute the word and then return to your assembly code.
|
|
|
|
note that this will clobber AX and BX and possibly all other registers!! )
|
|
|
|
( does not work - I think LEA @> is broken
|
|
|
|
L: ASMEXEC
|
|
|
|
LEA BX 1 @> dbg" forward label?"
|
|
|
|
JMP @[ BX]
|
|
|
|
:ASM asmret
|
|
|
|
DEC BP DEC BP
|
|
|
|
MOV @[ BP] SI
|
|
|
|
RET
|
|
|
|
1 find-patch @ . 1 find-patch cell + @ .
|
|
|
|
1 <:
|
|
|
|
dbg" patched"
|
|
|
|
t& $DOCOLON w>t '>t >r '>t execute '>t <r '>t asmret
|
|
|
|
)
|
|
|
|
dbg" allocation"
|
2023-09-02 01:51:22 +00:00
|
|
|
0 VAR, &here
|
2023-09-05 03:24:12 +00:00
|
|
|
:t here &here @ ;
|
|
|
|
:t here! &here ! ;
|
2023-09-02 01:51:22 +00:00
|
|
|
0xffff CONST there
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
:t latest &latest @ ;
|
|
|
|
:t latest! &latest ! ;
|
2023-09-02 01:51:22 +00:00
|
|
|
|
|
|
|
0 VAR, lastseg
|
2023-09-05 03:24:12 +00:00
|
|
|
:t segalloc lastseg @ 4096 + dup lastseg ! ;
|
2023-09-02 01:51:22 +00:00
|
|
|
|
2023-10-16 19:54:44 +00:00
|
|
|
2 CONST cell
|
2023-09-05 03:24:12 +00:00
|
|
|
:t cells cell * ;
|
|
|
|
:t allot here + here! ;
|
|
|
|
:t , here ! cell allot ;
|
|
|
|
:t b, here b! 1 allot ;
|
2023-10-16 19:54:44 +00:00
|
|
|
|
2023-09-03 19:21:56 +00:00
|
|
|
dbg" i/o"
|
2023-10-16 19:54:44 +00:00
|
|
|
:ASM overwrite
|
|
|
|
MOV AH 0x3c #
|
|
|
|
XOR CX CX ( non-system, non-hidden )
|
|
|
|
POP DX ( filename ptr )
|
|
|
|
INT 0x21 #
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM open
|
|
|
|
MOV AH 0x3d #
|
|
|
|
MOV AL 2 # ( read/write access, allow child inheritance )
|
|
|
|
POP DX ( filename ptr )
|
|
|
|
INT 0x21 #
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM close
|
|
|
|
MOV AH 0x3e #
|
|
|
|
POP BX
|
|
|
|
INT 0x21 #
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
0 VAR, fcount
|
|
|
|
:ASM fread
|
|
|
|
MOV AH 0x3f #
|
|
|
|
POP BX ( fp )
|
|
|
|
POP DX ( buffer )
|
|
|
|
POP CX ( length )
|
|
|
|
INT 0x21 #
|
|
|
|
MOV t& fcount @+ AX ( save number of bytes read )
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
:ASM fwrite
|
|
|
|
MOV AH 0x40 #
|
|
|
|
POP BX ( fp )
|
|
|
|
POP DX ( buffer )
|
|
|
|
POP CX ( length )
|
|
|
|
INT 0x21 #
|
|
|
|
MOV t& fcount @+ AX ( save number of bytes written )
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
-1 CONST EOF
|
|
|
|
0 VAR, fbuffer
|
2023-09-05 03:24:12 +00:00
|
|
|
: 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 ;
|
2023-10-16 19:54:44 +00:00
|
|
|
|
|
|
|
:ASM console-emit
|
|
|
|
MOV AH 2 #
|
|
|
|
POP DX
|
|
|
|
INT 0x21 #
|
|
|
|
NEXT
|
|
|
|
DEFERRED emit console-emit
|
|
|
|
|
|
|
|
:ASM console-key
|
|
|
|
MOV AH 8 #
|
|
|
|
INT 0x21 #
|
|
|
|
XOR AH AH
|
|
|
|
PUSH AX
|
|
|
|
NEXT
|
|
|
|
|
|
|
|
0 VAR, infile ( 0 is a predefined file handle meaning stdin )
|
2023-09-05 03:24:12 +00:00
|
|
|
:t in-key infile @ dup BZ_ [ 3 skip>t ] drop console-key return fgetc ;
|
2023-10-16 19:54:44 +00:00
|
|
|
DEFERRED key in-key
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
dbg" parsing"
|
2023-09-03 19:21:56 +00:00
|
|
|
L: BASE 10 w>t L: ISNEG? 0 >t
|
|
|
|
:ASM number ( str -- num 1 | str 0 )
|
|
|
|
( AX - current number
|
|
|
|
BH - 0
|
|
|
|
BL - current character
|
|
|
|
CX - current digit count, used to detect 0x prefix
|
|
|
|
DX - clobbered by IMUL
|
|
|
|
SI - remainder of string to be parsed
|
|
|
|
DI - saved IP, as SI will be clobbered by LODSB )
|
|
|
|
MOV DI SI ( save IP )
|
|
|
|
POP SI
|
|
|
|
PUSH SI
|
|
|
|
MOV BASE 10 #
|
|
|
|
|
|
|
|
XOR AX AX
|
|
|
|
XOR BX BX
|
|
|
|
XOR CX CX
|
|
|
|
MOV BYTE ISNEG? AL
|
|
|
|
L: next-digit
|
|
|
|
MOV BL AL
|
|
|
|
LODSB
|
|
|
|
XCHG AL BL
|
|
|
|
CMP BL 0 #
|
|
|
|
JZ 1 @> ( string end )
|
|
|
|
JCXZ 3 @> ( starts with negative? )
|
|
|
|
L: parse-digit
|
|
|
|
CMP BL key 9 #
|
|
|
|
JG 2 @> ( hex or fail )
|
|
|
|
SUB BL key 0 #
|
|
|
|
JL 0 @> ( not a number )
|
|
|
|
L: parsed-digit
|
|
|
|
IMUL BASE
|
|
|
|
ADD AX BX
|
|
|
|
INC CX
|
|
|
|
JMP next-digit
|
|
|
|
L: fail-digit 0 <:
|
|
|
|
MOV SI DI
|
|
|
|
XOR CX CX
|
|
|
|
PUSH CX
|
|
|
|
NEXT
|
|
|
|
1 <: ( string end )
|
|
|
|
JCXZ fail-digit ( empty string is not zero )
|
|
|
|
CMP BYTE ISNEG? 0 #
|
|
|
|
JZ 1 @>
|
|
|
|
NEG AX
|
|
|
|
1 <:
|
|
|
|
MOV SI DI
|
|
|
|
POP DX
|
|
|
|
PUSH AX
|
|
|
|
PUSH CX ( we know cx is nonzero and will be treated as true )
|
|
|
|
NEXT
|
|
|
|
3 <: ( negative? )
|
|
|
|
CMP BL key - #
|
|
|
|
JNZ parse-digit
|
|
|
|
CMP BYTE ISNEG? 0 #
|
|
|
|
JNZ fail-digit ( only one negative sign allowed )
|
|
|
|
MOV BYTE ISNEG? BL ( any nonzero value will do )
|
|
|
|
JMP next-digit
|
|
|
|
2 <: ( hex or fail )
|
|
|
|
CMP BL key x # ( lowercase x )
|
|
|
|
JNZ 0 @>
|
|
|
|
CMP CX 1 # ( x is second character )
|
|
|
|
JNZ 1 @>
|
|
|
|
CMP AX 0 # ( first character was a 0 )
|
|
|
|
JNZ 2 @>
|
|
|
|
MOV BASE 16 #
|
|
|
|
JMP next-digit
|
|
|
|
0 <: 1 <: 2 <: ( actual parsing of hex digit )
|
|
|
|
SUB BL key A #
|
|
|
|
JL fail-digit
|
|
|
|
ADD BL 10 #
|
|
|
|
CMP BL BASE
|
|
|
|
JL parsed-digit
|
|
|
|
SUB BL key a key A - 10 - #
|
|
|
|
JL fail-digit
|
|
|
|
ADD BL 10 #
|
|
|
|
CMP BL BASE
|
|
|
|
JL parsed-digit
|
|
|
|
JMP fail-digit
|
|
|
|
|
2023-09-04 18:23:12 +00:00
|
|
|
L: DECDIVISORS 1 w>t 10 w>t 100 w>t 1000 w>t 10000 w>t
|
2023-09-03 19:21:56 +00:00
|
|
|
:ASM num>str
|
|
|
|
MOV DI t& &here @+
|
|
|
|
POP AX
|
2023-09-04 18:23:12 +00:00
|
|
|
CMP AX 0 #
|
|
|
|
JGE 0 @>
|
|
|
|
MOV BYTE @[ DI] key - #
|
|
|
|
NEG AX
|
|
|
|
INC DI
|
|
|
|
0 <:
|
|
|
|
PUSH SI
|
|
|
|
MOV SI 4 cells #
|
|
|
|
MOV BX L@ DECDIVISORS #
|
|
|
|
MOV CX 4 # ( CX=0 when we should write zeros )
|
2023-09-03 19:21:56 +00:00
|
|
|
L: write-next-digit
|
|
|
|
XOR DX DX
|
2023-09-04 18:23:12 +00:00
|
|
|
IDIV @[ BX+SI]
|
|
|
|
CMP AX 0 #
|
|
|
|
JNZ 1 @>
|
|
|
|
JCXZ 0 @> ( unconditionally write a zero )
|
|
|
|
DEC CX ( if we haven't written any digits this will hit 0 on the ones place )
|
|
|
|
JMP 2 @>
|
|
|
|
1 <: 0 <:
|
|
|
|
XOR CX CX
|
2023-09-03 19:21:56 +00:00
|
|
|
ADD AX key 0 #
|
|
|
|
STOSB
|
2023-09-04 18:23:12 +00:00
|
|
|
2 <:
|
|
|
|
MOV AX DX
|
|
|
|
DEC SI
|
|
|
|
DEC SI
|
|
|
|
JNS write-next-digit ( once SI decrements below zero the sign bit will set )
|
2023-09-03 19:21:56 +00:00
|
|
|
XOR AX AX
|
|
|
|
STOSB ( trailing 0 )
|
2023-09-04 18:23:12 +00:00
|
|
|
POP SI
|
2023-09-03 19:21:56 +00:00
|
|
|
PUSH t& &here @+
|
|
|
|
NEXT
|
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
: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 ;
|
|
|
|
|
|
|
|
: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
|
2023-09-03 19:21:56 +00:00
|
|
|
|
2023-09-05 03:24:12 +00:00
|
|
|
( 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 ;
|
2023-09-01 23:10:54 +00:00
|
|
|
|
|
|
|
9 <: ( actual entry point )
|
2023-09-05 03:24:12 +00:00
|
|
|
MOV SI t& tinyjort #
|
2023-09-02 01:51:22 +00:00
|
|
|
PUSH CS
|
|
|
|
POP AX
|
|
|
|
ADD AX 4096 #
|
|
|
|
MOV SS AX
|
|
|
|
MOV t& lastseg @+ AX
|
|
|
|
MOV SP 0xfe #
|
|
|
|
MOV BP 0x00 #
|
|
|
|
NEXT
|
2023-09-01 23:10:52 +00:00
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
target @ t& &here !t
|
2023-09-01 23:10:52 +00:00
|
|
|
|
2023-09-02 01:51:22 +00:00
|
|
|
dbg" Program assembled, saving tinyjort.com"
|
2023-09-01 23:10:52 +00:00
|
|
|
s" tinyjort.com" overwrite
|
2023-10-16 19:54:44 +00:00
|
|
|
0x100 target @ :noname for i tseg b@far over fputc next ; execute
|
2023-09-01 23:10:52 +00:00
|
|
|
close
|