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
contact |
privacy