t3xforth
; T3XFORTH Primitive Words
; Nils M Holm, 2021
; Public domain / CC0 License
; Register usage:
; SI = instruction pointer
; DI = PFA pointer, loaded by NEXT
; SP = stack pointer
; BP = return stack pointer
.text $100
CELL: equ 2
IMMED: equ $80
COMP: equ $40
MASK: equ $1F
S0: equ $F000
TIB: equ $F000
R0: equ $F380
UP: equ $F380
BUF1: equ $F400
BUF2: equ $F800
MEMTOP: equ $FBFF
jmps cold
; Inner Interpreter
;
next: lodsw
mov bx,ax
mov di,bx
inc di
inc di
jmp [bx]
blockfile: db "T3XFORTH.BLK", 0
; CODE COLD ( -- )
;
wcold: db $04, "COLD " ; cold
dw 0
dw offset cold
cold: mov ax,cs
mov ds,ax
cli
mov ss,ax
mov sp,offset S0
sti
mov bp,offset R0
mov ax,$2523 ; DOS: set int vector 23
mov dx,offset ignore
int $21
mov ax,$3E00 ; DOS: close file
mov bx,blkdev
int $21
mov ax,$3D02 ; DOS: open file, R/W mode
mov dx,offset blockfile
int $21
jc cold1
mov blkdev,ax
cold1: cld
jmp reset
ignore: iret
; CODE BYE ( -- )
;
wbye: db $03, "BYE " ; bye
dw offset wcold
dw offset bye
bye: mov ax,$4C00
int $21
; CODE (LIT) ( -- w ) COMPILE-ONLY
; R> DUP CELL+ >R @
;
wdolit: db $45, "(LIT)" ; do-literal
dw offset wbye
dw offset dolit
dolit: lodsw
push ax
jmp next
; CODE (COLON) ( -- ; -- r ) COMPILE-ONLY
;
wdocolon:
db $47, "(COLO" ; do-colon
dw offset wdolit
dw offset docolon
docolon:
xchg bp,sp
push si
xchg bp,sp
mov si,di
jmp next
; CODE (VAR) ( -- a ) COMPILE-ONLY
;
wdovar: db $45, "(VAR)" ; do-variable
dw offset wdocolon
dw offset dovar
dovar: push di
jmp next
; CODE (CONST) ( -- a ) COMPILE-ONLY
;
wdoconst:
db $47, "(CONS" ; do-constant
dw offset wdovar
dw offset doconst
doconst:
push [di]
jmp next
; CODE (DOES>) ( -- a ) COMPILE-ONLY
;
wdodoes:
db $47, "(DOES" ; do-does
dw offset wdoconst
dw offset dodoes
dodoes: xchg bp,sp
push si
xchg bp,sp
mov bx,di
mov si,[bx]
inc di
inc di
push di
jmp next
; CODE EXECUTE ( a -- )
;
wexecute:
db $07, "EXECU" ; execute
dw offset wdodoes
dw offset execute
execute:
pop bx
mov di,bx
dec bx
dec bx
jmp [bx]
; CODE EXIT ( -- ; r -- )
;
wexit: db $04, "EXIT " ; exit
dw offset wexecute
dw offset exit
exit: xchg bp,sp
pop si
xchg bp,sp
jmp next
; CODE (BRANCH) ( -- ) COMPILE-ONLY
; R> @ >R
;
wbranch:
db $48, "(BRAN"
dw offset wexit
dw offset branch
branch: mov si,[si]
jmp next
; CODE (0BRANCH) ( f -- ) COMPILE-ONLY
; IF R> CELL+ >R ELSE R> @ >R THEN
;
wqbranch:
db $49, "(0BRA" ; question-branch
dw offset wbranch
dw offset qbranch
qbranch:
pop ax
or ax,ax
jnz skip
mov si,[si]
jmp next
skip: inc si
inc si
jmp next
; CODE (DO) ( n n -- ) COMPILE-ONLY
; R> -ROT >R >R >R
;
wdodo: db $44, "(DO) " ; do-do
dw offset wqbranch
dw offset dodo
dodo: pop ax
pop bx
xchg bp,sp
push bx
push ax
xchg bp,sp
jmp next
; CODE (+LOOP) ( n -- ) COMPILE-ONLY
; R> R> ROT R> + ( return limit i+n )
; 2DUP SWAP - XOR [HEX] 8000 AND IF
; SWAP >R >R @ >R ELSE
; 2DROP CELL+ >R THEN ;
;
wdoplusloop:
db $47, "(+LOO" ; do-plus-loop
dw offset wdodo
dw offset doplusloop
doplusloop:
; [bp+0] = index
; [bp+2] = limit
pop dx
loop1: add [bp],dx
mov ax,[bp]
sub ax,[bp+2]
xor ax,dx
js branch
exitdo: add bp,4
jmps skip
; CODE (LOOP) ( -- ) COMPILE-ONLY
; 1 (+LOOP)
;
wdoloop:
db $46, "(LOOP" ; do-loop
dw offset wdoplusloop
dw offset doloop
doloop: mov dx,1
jmps loop1
; CODE (/LOOP) ( -- ) COMPILE-ONLY
; R> R> ROT R> + ( return limit i+n )
; 2DUP U< IF SWAP >R >R @ >R ELSE
; 2DROP CELL+ >R THEN ;
;
wdouploop:
db $47, "(/LOO" ; do-up-loop
dw offset wdoloop
dw offset douploop
douploop:
; [bp+0] = index
; [bp+2] = limit
pop dx
add [bp],dx
mov ax,[bp]
cmp ax,[bp+2]
jb branch
jmps exitdo
; CODE ! ( w a -- )
;
wstore: db $01, "! " ; store
dw offset wdouploop
dw offset store
store: pop bx
pop [bx]
jmp next
; CODE @ ( a -- w )
;
wfetch: db $01, "@ " ; fetch
dw offset wstore
dw offset fetch
fetch: pop bx
push [bx]
jmp next
; CODE C! ( c a -- )
;
wcstore:
db $02, "C! " ; c-store
dw offset wfetch
dw offset cstore
cstore: pop bx
pop ax
mov [bx],al
jmp next
; CODE C@ ( a -- c )
;
wcfetch:
db $02, "C@ " ; c-fetch
dw offset wcstore
dw offset cfetch
cfetch: pop bx
xor ax,ax
mov al,[bx]
push ax
jmp next
; CODE RP! ( a -- )
;
wrpstore:
db $03, "RP! " ; r-p-store
dw offset wcfetch
dw offset rpstore
rpstore:
pop bp
jmp next
; CODE RP@ ( -- a )
;
wrpfetch:
db $03, "RP@ " ; r-p-fetch
dw offset wrpstore
dw offset rpfetch
rpfetch:
push bp
jmp next
; CODE >R ( w -- ; -- w )
;
wtor:
db $02, ">R " ; to-r
dw offset wrpfetch
dw offset tor
tor: dec bp
dec bp
pop [bp]
jmp next
; CODE R@ ( -- w )
;
wrfetch:
db $02, "R@ " ; r-fetch
dw offset wtor
dw offset rfetch
rfetch:
push [bp]
jmp next
; CODE I ( -- w )
; R@
;
wi: db $01, "I " ; I
dw offset wrfetch
dw offset rfetch
; uses code of R@
; CODE R> ( -- w ; w -- )
;
wrfrom: db $02, "R> " ; r-from
dw offset wi
dw offset rfrom
rfrom: push [bp]
inc bp
inc bp
jmp next
; CODE SP! ( a -- )
;
wspstore:
db $03, "SP! " ; s-p-store
dw offset wrfrom
dw offset spstore
spstore:
pop sp
jmp next
; CODE SP@ ( -- a )
;
wspfetch:
db $03, "SP@ " ; s-p-fetch
dw offset wspstore
dw offset spfetch
spfetch:
mov ax,sp
push ax
jmp next
; CODE DROP ( w -- )
;
wdrop: db $04, "DROP " ; drop
dw offset wspfetch
dw offset drop
drop: inc sp
inc sp
jmp next
; CODE DUP ( w -- w w )
;
wdup: db $03, "DUP " ; dupe
dw offset wdrop
dw offset dup
dup: mov bx,sp
push [bx]
jmp next
; CODE SWAP ( w1 w2 -- w2 w1 )
;
wswap: db $04, "SWAP " ; swap
dw offset wdup
dw offset swap
swap: pop ax
pop bx
push ax
push bx
jmp next
; CODE OVER ( w1 w2 -- w1 w2 w1 )
;
wover: db $04, "OVER " ; over
dw offset wswap
dw offset over
over: mov bx,sp
push [bx+2]
jmp next
; CODE 0< ( n -- f )
;
wzeroless:
db $02, "0< " ; zero-less
dw offset wover
dw offset zeroless
zeroless:
pop ax
cwd
push dx
jmp next
; CODE AND ( w w -- w )
;
wand: db $03, "AND " ; and
dw offset wzeroless
dw offset _and
_and: pop bx
pop ax
and ax,bx
push ax
jmp next
; CODE OR ( w w -- w )
;
wor: db $02, "OR " ; or
dw offset wand
dw offset _or
_or: pop bx
pop ax
or ax,bx
push ax
jmp next
; CODE XOR ( w w -- w )
wxor: db $03, "XOR " ; or
dw offset wor
dw offset _xor
_xor: pop bx
pop ax
xor ax,bx
push ax
jmp next
; CODE LSHIFT ( u u -- u )
;
wlshift:
db $06,"LSHIF" ; l-shift
dw offset wxor
dw offset lshift
lshift: pop cx
pop ax
shl ax,cl
push ax
jmp next
; CODE RSHIFT ( u u -- u )
;
wrshift:
db $06,"RSHIF" ; r-shift
dw offset wlshift
dw offset rshift
rshift: pop cx
pop ax
shr ax,cl
push ax
jmp next
; CODE UM+ ( u u -- ud )
;
wumplus:
db $03, "UM+ " ; u-m-plus
dw offset wrshift
dw offset umplus
umplus: xor cx,cx
pop bx
pop ax
add ax,bx
rcl cx,1
push ax
push cx
jmp next
; CODE ?SAME ( a1 a2 -- f )
;
wqsame: db $05, "?SAME" ; question-same
dw offset wumplus
dw offset qsame
qsame: mov dx,si
pop si
pop di
lodsb
and al,$1F
cmp al,[di]
jnz qs1
inc di
xor cx,cx
mov cl,al
cmp cx,6
jl qs0
mov cx,5
qs0: inc cx
repz
cmpsb
or cx,cx
jnz qs1
mov ax,-1
jmps qs2
qs1: xor ax,ax
qs2: push ax
mov si,dx
jmp next
; CODE TX! ( c -- )
;
wtxstore:
db $03, "TX! " ; t-x-store
dw offset wqsame
dw offset txstore
txstore:
pop dx
cmp dx,$FF
jnz tx1
mov dl,' '
tx1: mov ah,6
int $21
jmp next
; CODE RX? ( -- c T | F )
;
wrxquestion:
db $03, "RX? " ; r-x-question
dw offset wtxstore
dw offset rxquestion
rxquestion:
xor bx,bx
mov dl,$FF
mov ah,$06
int $21
jz rxq1
or al,al
jnz rxq2
int $21
mov bh,al
jmps rxq3
rxq2: mov bl,al
rxq3: push bx
mov bx,-1
rxq1: push bx
jmp next
blkdev: dw -1
blkop: dw 0
; ( a n -- T | F )
; Read block N to buffer at address A.
; Return -1 on succes, 0 on failure.
blockio:
pop ax
mov cx,1024
mul cx
mov cx,dx ; CX:DX = offset
mov dx,ax
mov ax,$4200 ; DOS: seek from beginning
mov bx,blkdev ; file handle
int $21
jc fail
mov ax,blkop
mov bx,blkdev
pop dx
mov di,-1
push di
mov cx,1024
int $21
jc fail
cmp ax,1024
jnz fail
jmp next
fail: pop dx
xor ax,ax
push ax
jmp next
; CODE READ-BLOCK ( a u -- T | F )
;
wreadblock:
db $0A, "READ-"
dw offset wrxquestion
dw offset readblock
readblock:
mov blkop,$3F00 ; DOS: read handle
jmps blockio
; CODE WRITE-BLOCK ( a u -- T | F )
;
wwriteblock:
db $0B, "WRITE"
dw offset wreadblock
dw offset writeblock
writeblock:
mov blkop,$4000 ; DOS: write handle
jmps blockio
reset: mov si,0 ; will be patched by TFCMP
jmp next
; End of dictionary so far
dw offset wwriteblock