My Nasm not working version of miniforth
dufrp@oricom.ca
dufrp@oricom.ca
Thu, 24 Apr 1997 07:00:27 -0400
; This is my translation of simtelnet/msdos/forth/min4th25.zip from
; A86 to NASM.
; NOT WORKING YET!!! Work only if all you do is pressing enter key. :)
; If you finds bugs, e-mail me at dufrp@oricom.ca
; The simtel archive contains other important stuff, get it.
; MINIFORTH - Copyright 1988 by Ted Beach
; 5112 Williamsburg Blvd.
; Arlington VA, 22207
; 703-237-0295
; This is a VERY minimum version of FORTH that has several innovations -
; First, mini makes extensive use of TO variables, particularly as USER
; variables : BASE, >IN, COMPILING (STATE), S0, R0, BLK, BLOCK, etc.
; Second, there is incorporated a mechanism whereby conditionals (IF, THEN
; ELSE, BEGIN, UNTIL, etc.) can be executed directly from the keyboard with-
; out having to create a word (sometimes a dummy word) to compile them in.
; Simply key in the words as needed, then add a semicolon. The structure
; will execute at HERE then be discarded. Should you ever make an error whil
; compiling from the keyboard, your mistake will be automatically erased --
; you won't find the dictionary garbaged up with a partially compiled word.
; Source code MUST BE ASSEMBLED WITH A86 - make needed changes if you
; want to use MASM (ugh!).
; The file named MINI.MIN has certain needed structures. You will have to
; enter these from the keyboard. In order to save the extended version, run
; mini under DEBUG. Then, just before leaving mini, enter "HERE .H"
; Note the number printed, type "BYE", then from DEBUG change CX to the numb
; printed. Use DEBUG's W command to Write the program to disk.
; ***************** NOTE *******************
; You are free to use this copyrighted material for your own personal
; needs. Commercial use is prohibited without the consent of the copyright
; holder. Contact the author at the address above for additional information
; There is already available version 1.5 which adds a second (short) machine
; stack to help certain operations. Tutorial material is available on learni
; how to use miniforth. For those used to FORTH, this listing and the MINI.M
; file should provide adequate information on how to extend miniforth.
; *******************************************
;HEAD MACRO
; DW LINK
; LINK=$-2
; DB #1+0x80
; DB #2
;#EM
;
;HEADI MACRO
; DW LINK
; LINK=$-2
; DB #1+0xC0
; DB #2
;#EM
;
;COLON MACRO
; CALL DOCOLON
;#EM
;NEXT MACRO
; LODSW
; JMP AX
;#EM
;
;VARI MACRO
; JMP DOVAR
;#EM
;
;CONST MACRO
; JMP DOCON
;#EM
;
;TOVAR MACRO
; JMP DOTOVAR
;#EM
;
;VOCAB MACRO
; JMP DOVOC
;#EM
;
;X MACRO
; XCHG SP,BP
;#EM
[ORG 0x100]
JMP INIT
; STORAGE LOCATIONS FOR USER VARIABLES
CHERE DW DP
CTOIN DW 0
CBLOCK DW 0
CBASE DW 10
CBLK DW 0
CSPAN DW 0
CCOMP DW 0
CTDP DW ABORT-6
CS0 DW -256
CRZERO DW 0
CDBL DW 0
TFL DW 0
CSP DW 0
BUF: DB 80 ; TIB FOR KEYBOARD
CNT TIMES 81 DB 0 ; was CNT DB 81 DUP (0)
; HEADERLESS EXECUTION CODE GOES HERE
DOCOLON: ; PUSH SI ON BP STACK AND FROM THE SP STACK IN SI
XCHG SP,BP
PUSH SI
XCHG SP,BP
POP SI
LODSW
JMP AX
DOTOVAR:
PUSH BX
ADD AX,3
MOV BX,AX
MOV BX,[BX]
MOV CX,[TFL]
JCXZ FETCH
OR CX,CX
MOV WORD [TFL],0
JNS XSTORE
XPSTORE:
POP AX
ADD [BX],AX
POP BX
LODSW
JMP AX
XSTORE:
POP AX
MOV [BX],AX
POP BX
LODSW
JMP AX
DOCON:
PUSH BX
ADD AX,3
MOV BX,AX
FETCH:
MOV BX,[BX]
LODSW
JMP AX
DOVAR:
PUSH BX
ADD AX,3
MOV BX,AX
LODSW
JMP AX
DOVOC:
ADD AX,3
MOV WORD [CONT],AX
LODSW
JMP AX
XEXEC: MOV AX,BX
POP BX
JMP AX
XEXIT:
XCHG SP,BP
POP SI
XCHG SP,BP
LODSW
JMP AX
XTOR: XCHG SP,BP
PUSH BX
XCHG SP,BP
POP BX
LODSW
JMP AX
XRFR: PUSH BX
XCHG SP,BP
POP BX
XCHG SP,BP
LODSW
JMP AX
XTOR2: POP AX
XCHG SP,BP
PUSH BX
PUSH AX
XCHG SP,BP
POP BX
LODSW
JMP AX
XRFR2: PUSH BX
XCHG SP,BP
POP AX
POP BX
XCHG SP,BP
PUSH AX
LODSW
JMP AX
XTO: INC WORD [TFL]
LODSW
JMP AX
XPTO: DEC WORD [TFL]
LODSW
JMP AX
XDUP: PUSH BX
LODSW
JMP AX
XQDUP: OR BX,BX
JNZ XDUP
LSW
JMP AX
XDROP: POP BX
LODSW
JMP AX
XSWAP: POP AX
PUSH BX
MOV BX,AX
LODSW
JMP AX
XOVER: POP AX
PUSH AX
PUSH BX
MOV BX,AX
LODSW
JMP AX
XROT: POP CX
POP DX
PUSH CX
PUSH BX
MOV BX,DX
LODSW
JMP AX
XCAT: MOV BL,[BX]
MOV BH,0
LODSW
JMP AX
XCSTORE:POP AX
MOV [BX],AL
POP BX
LODSW
JMP AX
XDUP2: PUSH BX
MOV DI,SP
PUSH WORD [DI+2] ; ???? I WRITE WORD
LODSW
JMP AX
XDROP2: POP BX
POP BX
LODSW
JMP AX
XSWAP2: POP AX
POP CX
POP DX
PUSH AX
PUSH BX
PUSH DX
MOV BX,CX
LODSW
JMP AX
XPLUS: POP AX
ADD BX,AX
LODSW
JMP AX
XSUBT: POP AX
NEG BX
ADD BX,AX
LODSW
JMP AX
XZEQ: XOR AX,AX
OR BX,BX
JNZ X1
X2: DEC AX
X1: XCHG AX,BX
LODSW
JMP AX
XZLESS: XOR AX,AX
OR BX,BX
JNS X1
JS X2
XZGRT: XOR AX,AX
OR BX,BX
JZ X1
JS X1
JMP X2
XZNE: MOV AX,-1
OR BX,BX
JZ .L0
MOV BX,AX
.L0: LODSW
JMP AX
XPLOOP: XCHG SP,BP
POP AX
POP CX
INC AX
INC CX
JO EXLP
.L1: PUSH CX
PUSH AX
XCHG SP,BP
XBRAN: MOV SI,[SI]
LODSW
JMP AX
XPPLOOP:
POP DI
XCHG SP,BP
POP AX
POP CX
ADD AX,BX
ADD CX,BX
MOV BX,DI
JNO XPLOOP.L1
EXLP: XCHG SP,BP
.L3: ADD SI,2
LODSW
JMP AX
XZBRAN: OR BX,BX
POP BX
JZ XBRAN
JNZ EXLP.L3
XI:
XRAT: PUSH BX
XCHG SP,BP
POP BX
PUSH BX
XCHG SP,BP
LODSW
JMP AX
XOF: POP AX
CMP AX,BX
JZ .L1
MOV BX,AX
JMP XBRAN
.L1: POP BX
ADD SI,2
LODSW
JMP AX
XOVER2: POP AX
POP CX
POP DX
PUSH DX
PUSH CX
PUSH AX
PUSH BX
PUSH DX
MOV BX,CX
LODSW
JMP AX
XONEPL: INC BX
LODSW
JMP AX
XTWOPL: ADD BX,2
LODSW
JMP AX
XTHREEPL:
ADD BX,3
LODSW
JMP AX
XONEMI: DEC BX
LODSW
JMP AX
XTWOMI: SUB BX,2
LODSW
JMP AX
XTHREEMI:SUB BX,3
LODSW
JMP AX
XTWOSLS:SAR BX,1
LODSW
JMP AX
XTWOSTAR:
SHL BX,1
LODSW
JMP AX
XUMSTAR:POP AX
MUL BX
PUSH AX
MOV BX,DX
LODSW
JMP AX
XUMSLSM:POP DX
XOR AX,AX
CMP DX,BX
JNB .L0
POP AX
DIV BX
PUSH DX
.L0: MOV BX,AX
LODSW
JMP AX
XDPLUS: POP AX
POP CX
POP DX
ADD DX,AX
PUSH DX
ADC BX,CX
LODSW
JMP AX
XDNEGATE:POP AX
NEG AX
PUSH AX
XCHG AX,BX
MOV BX,0
SBB BX,AX
LODSW
JMP AX
XNEGATE:NEG BX
LODSW
JMP AX
XAND: POP AX
AND BX,AX
LODSW
JMP AX
XORE: POP AX
OR BX,AX
LODSW
JMP AX
XXORX: POP AX
XOR BX,AX
LODSW
JMP AX
XLIT: PUSH BX
LODSW
MOV BX,AX
LODSW
JMP AX
XULESS: POP AX
SUB AX,BX
MOV BX,-1
JB .L0
INC BX
.L0: LODSW
JMP AX
XLESS: POP AX
SUB AX,BX
MOV BX,-1
JL .L0
INC BX
.L0: LODSW
JMP AX
XTWOAT: PUSH WORD [BX+2] ; ????? I WRITE WORD
MOV BX,[BX]
LODSW
JMP AX
XTWOSTORE: POP WORD [BX] ; ???? I WRITE WORD
POP WORD [BX+2] ; ???? I WRITE WORD
POP BX
LODSW
JMP AX
XPICK: SHL BX,1
ADD BX,SP
MOV BX,[BX]
LODSW
JMP AX
XEQUAL: POP AX
CMP BX,AX
MOV BX,-1
JZ .L0
INC BX
.L0: LODSW
JMP AX
XCR: MOV DL,0xD
MOV AH,2
INT 0x21
MOV DL,0xA
INT 0x21
LODSW
JMP AX
XQKEY: PUSH BX
MOV AH,0xB
INT 0x21
CBW
MOV BX,AX
LODSW
JMP AX
XKEY: PUSH BX
MOV AH,7
INT 0x21
XOR AH,AH
MOV BX,AX
LODSW
JMP AX
XEMIT: MOV DL,BL
MOV AH,2
INT 0x21
POP BX
LODSW
JMP AX
XTYPE: POP DX
MOV CX,BX
JCXZ .L0
MOV AH,0x40
MOV BX,1
INT 0x21
.L0: POP BX
LODSW
JMP AX
LINK equ 0
; START OF MINIFORTH WITH ITS HEADERS
MINE: DW LINK
DB 0xE4,'MINI' ; BIT 6 SET FOR IMMEDIATE, BIT 5 FOR VOCABULARY
MINI: JMP DOVOC
RUTE: DW LAST ; HOLDER FOR LAST
LAMINE: DW MINE ; VOCABULARY STOPPER
;LINK EQU $-2 ; WORDS LINK INTO ROOT VOCABULARY, 'MINI'.
H_EXIT DW LAMINE
DB 0x84, 'EXIT' ; ( 0/0)
EXIT: JMP XEXIT
H_STORE DW H_EXIT
DB 0x81, '!' ; (2/0)
STORE: JMP XSTORE
H_PSTOR DW H_STORE
DB 0x82
DB '+!' ; (2/0)
PSTOR: JMP XPSTORE
H_ATT DW H_PSTOR
DB 0x81,'@' ; (1/1)
ATT: JMP FETCH
H_TOR DW H_ATT
DB 0x82,'>R' ; (1/0)
TOR: JMP XTOR
H_RFR DW H_TOR
DB 0x82,'R>' ; (0/1)
RFR: JMP XRFR
H_TOR2 DW H_RFR
DB 0x83,'2>R' ; (2/0)
TOR2: JMP XTOR2
H_RFR2 DW H_TOR2
DB 0x83,'2R>' ; (0/2)
RFR2: JMP XRFR2
H_TO DW H_RFR2
DB 0x82,'to' ; (1/0)
TOU: JMP XTO
H_PTO DW H_TO
DB 0x83,'+to' ; (1/0)
PTO: JMP XPTO
H_DUPE DW H_PTO
DB 0x83,'DUP' ; (1/2)
DUPE: JMP XDUP
H_QDUP DW H_DUPE
DB 0x84,'?DUP' ; (1/2/0)
QDUP: JMP XQDUP
H_DROP DW H_QDUP
DB 0x84,'DROP' ; (1/0)
DROP: JMP XDROP
H_SWAP DW H_DROP
DB 0x84,'SWAP' ; (2/2)
SWAP: JMP XSWAP
H_OVER DW H_SWAP
DB 0x84,'OVER' ; (2/3)
OVER: JMP XOVER
H_ROT DW H_OVER
DB 0x83,'ROT' ; (3/3)
ROT: JMP XROT
H_CAT DW H_ROT
DB 0x82,'C@' ; (1/1)
CAT: JMP XCAT
H_CSTORE DW H_CAT
DB 0x82,'C!' ; (2/0)
CSTORE: JMP XCSTORE
H_DUP2 DW H_CSTORE
DB 0x84,'2DUP' ; (2/4)
DUP2: JMP XDUP2
H_DROP2 DW H_DUP2
DB 0x85,'2DROP' ; (2/0)
DROP2: JMP XDROP2
H_SWAP2 DW H_DROP2
DB 0x85,'2SWAP' ; (4/4)
SWAP2: JMP XSWAP2
H_OVER2 DW H_SWAP2
DB 0x85,'2OVER' ; (4/6)
OVER2: JMP XOVER2
H_PLUS DW H_OVER2
DB 0x81,'+' ; (2/1)
PLUS: JMP XPLUS
H_SUBT DW H_PLUS
DB 0x81,'-' ; (2/1)
SUBT: JMP XSUBT
H_ZEQ DW H_SUBT
DB 0x82,'0=' ; (1/1)
ZEQ: JMP XZEQ
H_ZLESS DW H_ZEQ
DB 0x82,'0<' ; (1/1)
ZLESS: JMP XZLESS
H_ZGRT DW H_ZLESS
DB 0x82,'0>' ; (1/1)
ZGRT: JMP XZGRT
H_ZNE DW H_ZGRT
DB 0x83,'0<>' ; (1/1)
ZNE: JMP XZNE
H_EQUAL DW H_ZNE
DB 0x81,'=' ; (2/1)
EQUAL: JMP XEQUAL
H_ZBRAN DW H_EQUAL
DB 0x83,'0br' ; (1/0)
ZBRAN: JMP XZBRAN
H_BRAN DW H_ZBRAN
DB 0x82,'br' ; (0/0)
BRAN: JMP XBRAN
H_PLOOP DW H_BRAN
DB 0x82,'lp' ; (0/0)
PLOOP: JMP XPLOOP
H_PPLOOP DW H_PLOOP
DB 0x83,'+lp' ; (1/0)
PPLOOP: JMP XPPLOOP
H_I DW H_PPLOOP
DB 0x81,'I' ; (0/1)
I: JMP XI
H_RAT DW H_I
DB 0x82,'R@' ; (0/1)
RAT: JMP XRAT
H_OF DW H_RAT
DB 0x82,'of' ; (2/0/1)
OF: JMP XOF
H_ONEPL DW H_OF
DB 0x82,'1+' ; (1/1)
ONEPL: JMP XONEPL
H_TWOPL DW H_ONEPL
DB 0x82,'2+' ; (1/1)
TWOPL: JMP XTWOPL
H_THREEPL DW H_TWOPL
DB 0x82,'3+' ; (1/1)
THREEPL:JMP XTHREEPL
H_ONEMI DW H_THREEPL
DB 0x82,'1-' ; (1/1)
ONEMI: JMP XONEMI
H_TWOMI DW H_ONEMI
DB 0x82,'2-' ; (1/1)
TWOMI: JMP XTWOMI
H_THREEMI DW H_TWOMI
DB 0x82,'3-' ; (1/1)
THREEMI:JMP XTHREEMI
H_TWOSLS DW H_THREEMI
DB 0x82,'2/' ; (1/1)
TWOSLS: JMP XTWOSLS
H_TWOSTAR DW H_TWOSLS
DB 0x82,'2*' ; (1/1)
TWOSTAR:JMP XTWOSTAR
H_UMSTAR DW H_TWOSTAR
DB 0x83,'UM*' ; (2/2)
UMSTAR: JMP XUMSTAR
H_UMSLSM DW H_UMSTAR
DB 0x86,'UM/MOD' ; (3/2)
UMSLSM: JMP XUMSLSM
H_DPLUS DW H_UMSLSM
DB 0x82,'D+' ; (4/2)
DPLUS: JMP XDPLUS
H_DNEGATE DW H_DPLUS
DB 0x87,'DNEGATE'; (2/2)
DNEGATE:JMP XDNEGATE
H_NEGATE DW H_DNEGATE
DB 0x86,'NEGATE' ; (1/1)
NEGATE: JMP XNEGATE
H_ANDD DW H_NEGATE
DB 0x83,'AND' ; (2/1)
ANDD: JMP XAND
H_ORE DW H_ANDD
DB 0x82,'OR' ; (2/1)
ORE: JMP XORE
H_XORX DW H_ORE
DB 0x83,'XOR' ; (2/1)
XORX: JMP XXORX
H_LIT DW H_XORX
DB 0x83,'LIT' ; (1/0)
LIT: JMP XLIT
H_ULESS DW H_LIT
DB 0x82,'U<' ; (2/1)
ULESS: JMP XULESS
H_LESS DW H_ULESS
DB 0x81,'<' ; (2/1)
LESS: JMP XLESS
H_TWOAT DW H_LESS
DB 0x82,'2@' ; (1/2)
TWOAT: JMP XTWOAT
H_TWOSTORE DW H_TWOAT
DB 0x82,'2!' ; (3/0)
TWOSTORE:JMP XTWOSTORE
H_PICK DW H_TWOSTORE
DB 0x84,'PICK' ; (1/1)
PICK: JMP XPICK
H_CR DW H_PICK
DB 0x82,'CR' ; (0/0)
CR: JMP XCR
H_QKEY DW H_CR
DB 0x84,'?KEY' ; (0/1)
QKEY: JMP XQKEY
H_KEY DW H_QKEY
DB 0x83,'KEY' ; (0/1)
KEY: JMP XKEY
H_EMIT DW H_KEY
DB 0x84,'EMIT' ; (1/0)
EMIT: JMP XEMIT
H_TYPEE DW H_EMIT
DB 0x84,'TYPE' ; (2/0)
TYPEE: JMP XTYPE
H_NEQ DW H_TYPEE
DB 0x82,'<>' ; (2/1)
NEQ: CALL DOCOLON
DW EQUAL,ZEQ,EXIT
H_CMOVE DW H_NEQ
DB 0x85,'CMOVE'
C_MOVE:
JMP CM_UN ; (3/0) ??????????? removed LONG replace far ... C
DW CM2
CM_UN: POP DI
POP AX
PUSH SI
MOV SI,AX
MOV CX,BX
JCXZ .L0
REP MOVSB
.L0: POP SI
POP BX
LODSW
JMP AX
CM2 equ $-CM_UN
H_ZERO DW H_CMOVE
DB 0x81,'0'
ZERO: JMP DOCON ; (0/1)
DW 0
H_ONE DW H_ZERO
DB 0x81,'1'
ONE: JMP DOCON ; (0/1)
DW 1
H_TWO DW H_ONE
DB 0x81,'2'
TWO: JMP DOCON ; (0/1)
DW 2
H_MIONE DW H_TWO
DB 0x82,'-1'
MIONE: JMP DOCON ; (0/1)
DW -1
H_H40 DW H_MIONE
DB 0x83,'$40'
H40: JMP DOCON ; (0/1)
DW 0x40
H_H80 DW H_H40
DB 0x83,'$80'
H80: JMP DOCON ; (0/1)
DW 0x80
H_ONEF DW H_H80
DB 0x82,'1F'
ONEF: JMP DOCON ; (0/1)
DW 0x1F
H_SEVENF DW H_ONEF
DB 0x82,'7F'
SEVENF: JMP DOCON ; (0/1)
DW 0x7F
H_BLANK DW H_SEVENF
DB 0x82,'BL'
BLANK: JMP DOCON ; (0/1)
DW 0x20
H_ROOT DW H_BLANK
DB 0x84,'ROOT'
ROOT: JMP DOCON ; (0/1)
DW RUTE
H_CURRENT DW H_ROOT
DB 0x87,'CURRENT'
CURRENT: JMP DOVAR ; (0/1)
DW RUTE
H_CONTEXT DW H_CURRENT
DB 0x87,'CONTEXT'
CONTEXT: JMP DOVAR ; (0/1)
CONT DW RUTE
; : LATEST CURRENT @ @ ; (0/1)
H_LATEST DW H_CONTEXT
DB 0x86,'LATEST'
LATEST: CALL DOCOLON
DW CURRENT,ATT,ATT,EXIT
; : CLATEST CONTEXT @ @ ; (0/1)
H_CLATEST DW H_LATEST
DB 0x87,'CLATEST'
CLATEST:CALL DOCOLON
DW CONTEXT,ATT,ATT,EXIT
; : PATCH 1+ DUP >R 2+ - R> ! ; (2/0)
H_PATCH DW H_CLATEST
DB 0x85,'PATCH'
PATCH: CALL DOCOLON
DW ONEPL,DUPE,TOR,TWOPL,SUBT,RFR,STORE,EXIT
H_TOIN DW H_PATCH
DB 0x83,'>IN'
TOIN: JMP DOTOVAR ; (0/1)
DW CTOIN
H_HERE DW H_TOIN
DB 0x84,'HERE'
HERE: JMP DOTOVAR ; (0/1)
DW CHERE
H_SPAN DW H_HERE
DB 0x84,'SPAN'
SPAN: JMP DOTOVAR ; (0/1)
DW CSPAN
H_BLK DW H_SPAN
DB 0x83,'BLK'
BLK: JMP DOTOVAR ; (0/1)
DW CBLK
H_BLOCK DW H_BLK
DB 0x85,'BLOCK'
BLOCK: JMP DOTOVAR ; (0/1)
DW CBLOCK
H_BASE DW H_BLOCK
DB 0x84,'BASE'
BASE: JMP DOTOVAR ; (0/1)
DW CBASE
H_COMP DW H_BASE
DB 0x89,'COMPILING'
COMP: JMP DOTOVAR ; (0/1)
DW CCOMP
H_TDP DW H_COMP
DB 0x83,'TDP'
TDP: JMP DOTOVAR ; (0/1)
DW CTDP
H_R0 DW H_TDP
DB 0x82,'R0'
R0: JMP DOTOVAR ; (0/1)
DW CRZERO
H_S0 DW H_R0
DB 0x82,'S0'
S0: JMP DOTOVAR ; (0/1)
DW CS0
H_DBL DW H_S0
DB 0x83,'DBL'
DBL: JMP DOTOVAR ; (0/1)
DW CDBL
H_LBRAK DW H_DBL
DB 0xC1,'[' ; : [ 0 TO COMPILING ; (0/0) {IMMED}
LBRAK: CALL DOCOLON
DW ZERO,TOU,COMP,EXIT
H_RBRAK DW H_LBRAK
DB 0x81,']' ; NOT immediate
RBRAK: CALL DOCOLON
DW MIONE,TOU,COMP,EXIT
H_SPACE DW H_RBRAK
DB 0x85,'SPACE' ; : BL EMIT ; (0/0)
SPACE: CALL DOCOLON
DW BLANK,EMIT,EXIT
H_COUNT DW H_SPACE
DB 0x85,'COUNT' ; (1/2)
COUNT: JMP COUNT1
DW COUNT2
COUNT1: MOV AX,BX
INC AX
PUSH AX
MOV BL,[BX]
MOV BH,0
LODSW
JMP AX
COUNT2 equ $-COUNT1
; : .W HERE COUNT 1F AND TYPE SPACE ; (0/0)
H_DOTW DW H_COUNT
DB 0x82,'.W'
DOTW: CALL DOCOLON
DW HERE,COUNT,ONEF,ANDD,TYPEE,SPACE,EXIT
; : LL TDP 2- ; (0/1)
H_LL DW H_DOTW
DB 0x82,'LL'
LL: CALL DOCOLON
DW TDP,TWOMI,EXIT
; : ?EX LL @ = ; (1/1)
H_QEX DW H_LL
DB 0x83,'?EX'
QEX: CALL DOCOLON
DW LL,ATT,EQUAL,EXIT
; : ILT R> COUNT 2DUP + >R TYPE ; (0/0)
H_ILT DW H_QEX
DB 0x83,'ILT'
ILT: CALL DOCOLON
DW RFR,COUNT,DUP2,PLUS,TOR,TYPEE,EXIT
H_ALLOT DW H_ILT
DB 0x85,'ALLOT' ; : ALLOT +TO HERE ; (1/0)
ALLOT: CALL DOCOLON
DW PTO,HERE,EXIT
H_COMMA DW H_ALLOT
DB 0x81,',' ; : , HERE ! 2 ALLOT ; (1/0)
COMMA: CALL DOCOLON
DW HERE,STORE,TWO,ALLOT,EXIT
H_CCOMMA DW H_COMMA
DB 0x82,'C,' ; : C, HERE C! 1 ALLOT ; (1/0)
CCOMMA: CALL DOCOLON
DW HERE,CSTORE,ONE,ALLOT,EXIT
H_STCSP DW H_CCOMMA
DB 0x84,'!CSP' ; (0/0)
STCSP: JMP STCSP1
DW STCSP2
STCSP1: MOV AX,SP
MOV [CSP],AX
LODSW
JMP AX
STCSP2 equ $-STCSP1
H_CSPQ DW H_STCSP
DB 0x84,'CSP?' ; RETURNS 'TRUE' IF CSP <> SP
CSPQ: JMP CSPQ1 ; (0/1)
DW CSPQ2
CSPQ1: MOV AX,SP
PUSH BX
XOR BX,BX
CMP AX,[CSP]
JZ .L0
DEC BX
.L0: LODSW
JMP AX
CSPQ2 equ $-CSPQ1
; : ?CSP CSP? ABORT" Unbalanced" ; (0/0)
H_QCSP DW H_CSPQ
DB 0x84,'?CSP'
QCSP: CALL DOCOLON
DW CSPQ,QER,
DB 11,' Unbalanced'
DW EXIT
; : :, 0xE8 C, LIT DOCOLON HERE 2+ - , ; (0/0)
H_COLCOM DW H_QCSP
DB 0x82,':,'
COLCOM: CALL DOCOLON
DW LIT,0xE8,CCOMMA,LIT,DOCOLON,HERE,TWOPL,SUBT,COMMA,EXIT
; : ?C COMPILING 0= (0/0)
; IF 1 , HERE TO TDP :, !CSP ] THEN ;
H_QC DW H_COLCOM
DB 0x82,'?C'
QC: CALL DOCOLON
DW COMP,ZEQ,ZBRAN,QC1,ONE,COMMA,HERE,TOU,TDP,COLCOM,STCSP,RBRAK
QC1: DW EXIT
; : COMPILE ?C R> DUP @ , 2+ >R ; (0/0)
H_COMPILE DW H_QC
DB 0x87,'COMPILE'
COMPILE:CALL DOCOLON
DW QC,RFR,DUPE,ATT,COMMA,TWOPL,TOR,EXIT
H_CXR DW H_COMPILE
DB 0x83,'CXR' ; XOR CHAR AT ADDR WITH BYTE: (ADDR BYTE... )
CXR: JMP CXR1 ; (2/0)
DW CXR2
CXR1: POP DI
XOR [DI],BL
POP BX
LODSW
JMP AX
CXR2 equ $-CXR1
H_SPST DW H_CXR
DB 0x83,'SP!' ; (1/0)
SPST: JMP SPST1
DW SPST2
SPST1: POP AX
MOV SP,BX
MOV BX,AX
LODSW
JMP AX
SPST2 equ $-SPST1
H_RPST DW H_SPST
DB 0x83,'RP!' ; (1/0)
RPST: JMP RPST1
DW RPST2
RPST1: MOV BP,BX
POP BX
LODSW
JMP AX
RPST2 equ $-RPST1
H_CLR DW H_RPST
DB 0x83,'CLR'
CLR: CALL DOCOLON ; : CLR S0 SP! ; (0/0)
DW S0,SPST,EXIT
H_EXECUTE DW H_CLR
DB 0x87,'EXECUTE'
EXECUTE:JMP XEXEC
H_ERROR DW H_EXECUTE
DB 0x85,'ERROR'
ERROR: DB 0xE9 ; VECTORED ERROR HANDLER - PRESENTLY CLEARS STACK
DW CLR-($+2)
; : HEX 16 TO BASE ; (0/0)
H_HEXX DW H_ERROR
DB 0x83,'HEX'
HEXX: CALL DOCOLON
DW LIT,16,TOU,BASE,EXIT
; : DECIMAL 10 TO BASE ; (0/0)
H_DECIM DW H_HEXX
DB 0x87,'DECIMAL'
DECIM: CALL DOCOLON
DW LIT,10,TOU,BASE,EXIT
; : LITERAL COMPILING (1/0 COMPILING)
; IF COMPILE LIT , THEN ; (0/0 NON-COMPILING)
; An immediate word
H_LITERAL DW H_DECIM
DB 0xC7,'LITERAL'
LITERAL:CALL DOCOLON
DW COMP,ZBRAN,LI1,COMPILE,LIT,COMMA
LI1: DW EXIT
; : LINK LL CURRENT @ ! ; (0/0)
H_LYNK DW H_LITERAL
DB 0x84,'LINK'
LYNK: CALL DOCOLON
DW LL,CURRENT,ATT,STORE,EXIT
; : RID LL TO HERE ; (0/0)
H_RID DW H_LYNK
DB 0x83,'RID'
RID: CALL DOCOLON
DW LL,TOU,HERE,EXIT
H_ZEROTO DW H_RID
DB 0x83,'0TO' ; RESET THE 'TO' FLAG TO ZERO (0/0)
ZEROTO: JMP ZT1
DW ZT2
ZT1: MOV WORD [TFL],0
LODSW
JMP AX
ZT2 equ $-ZT1
H_FINDE DW H_ZEROTO
DB 0x84,'find' ; (2/2)
FINDE: JMP FIND1
DW FIND2
FIND1: POP DX ; ADDRESS OF 'HERE'
PUSH SI ; SAVE IP FOR LATER
.L0: MOV BX,[BX] ; START OF SEARCH
OR BX,BX ; DONE IF LINK = 0
JZ .L2
MOV DI,DX ; ADDR TO DI
MOV SI,BX ; AND SI
ADD SI,2 ; STEP TO NAME FIELD
MOV CL,[SI] ; NAME LENGTH
AND CX,0x1F ; REDUCED TO 31 MAX BYTES
CMP CL,[DI] ; LENGTHS MATCH?
JNZ .L0 ; NO, GET NEXT NAME
INC SI ; YES, STEP TO FIRST CHAR IN NAME
INC DI
REPZ CMPSB ; COMPARE THEM
JNZ .L0 ; NO MATCH - GO GET NEXT
POP CX ; NAMES HIT! RESTORE SI
PUSH SI ; SI = CODE ADDRESS OF WORD
MOV SI,CX ; IP ONCE AGAIN = SI
TEST BYTE [BX+2],0x40 ; CHACK FOR IMMEDIATE WORD
MOV BX,-1 ; TRUE FLAG BUT -1
JZ .L1
NEG BX ; TRUE FLAG BUT +1 IF IMMEDIATE
.L1: LODSW ; ALL DONE
JMP AX
.L2: POP SI ; DID NOT FIND WORD SO RECOVER IP
PUSH DX ; BX = 0 FOR FALSE FLAG, DX = 'HERE'
LODSW ; AND WE'RE DONE
JMP AX
FIND2 equ $-FIND1
H_DOTH DW H_FINDE
DB 0x82,'.H' ; PRINT 4 DIGIT UNSIGNED HEX NUMBER AND SPACE
DOTH: MOV CX,4 ; (1/0)
CALL PRH
POP BX
LODSW
JMP AX
H_DOTHC DW H_DOTH
DB 0x83,'.HC' ; PRINT 2 DIGIT UNSGNED HEX NUMBER AND SPACE
DOTHC: MOV CX,2 ; (1/0)
CALL PRH
POP BX
LODSW
JMP AX
PRH: MOV DI,CX
MOV AX,BX
MOV BX,16
.L0: XOR DX,DX
DIV BX
XCHG AX,DX
ADD AL,0x90
DAA
ADC AL,0x40
DAA
PUSH AX
XCHG AX,DX
LOOP .L0
MOV CX,DI
MOV AH,2
.L1: POP DX
INT 0x21
LOOP .L1
MOV DL,' '
INT 0x21
RET
H_DEPTH DW H_DOTHC
DB 0x85,'DEPTH' ; RETURN STACK DEPTH (0/1)
DEPTH: JMP D1
DW D2
D1: PUSH BX
MOV BX,[CS0] ; ???? added[]
SUB BX,SP
SAR BX,1
DEC BX ; ACCOUNT FOR NUMBER JUST PUSHED
LODSW
JMP AX
D2 equ $-D1
H_BDOS DW H_DEPTH
DB 0x84,'BDOS' ; RUN DOS SERVICE $21
BDOS: JMP BDOS1 ; ENTER WITH BX,CX,DX AND # ON STACK (4/1)
DW BDOS2 ; RETURNS FALSE IF NO ERROR - AX,BX,CX,DX
BDOS1: MOV AX,BX ; FUNCTION IN AH
POP BX
POP CX
POP DX
INT 0x21
PUSH DX
PUSH CX
PUSH BX
PUSH AX
MOV BX,0
JNC .L0
DEC BX
.L0: LODSW
JMP AX
BDOS2 equ $-BDOS1
H_DU DW H_BDOS
DB 0x82,'DU' ; CONVERT STRING AT ADDRESS TO AN (1/3)
DU: JMP DU1 ; UNSIGNED DOUBLE NUMBER PLUS FLAG
DW DU2 ; TRUE IF SUCCESSFUL CONVERSION
DU1: MOV DI,BX
XOR AX,AX
MOV DX,AX ; CLEAR DOUBLE ACCUMULATOR
MOV [CDBL],AX ; CLEAR DOUBLE PRECISION FLAG
MOV CX,[CBASE] ; CX = NUMBER BASE ????added[]
.L0: MOV BL,[DI] ; ASCII CHARACTER TO CONVERT
MOV BH,0
SUB BX,0x30 ; REMOVE ASCII BIAS
JB EX ; DONE IF <0
CMP BX,10
JB .L1
SUB BX,7 ; -7 IF >= 10
CMP BX,10
JB EX ; DONE IF < 10
.L1: CMP BX,CX
JNB EX ; DONE IF >= BASE
PUSH BX ; SAVE NUMBER
PUSH DX ; AND MSH OF PRODUCT
MUL CX
MOV BX,AX ; SAVE LSH OF PRODUCT
POP AX ; RECOVER MSH OF PRODUCT
PUSH DX ; SAVE OVERFLOW
MUL CX
POP DX
ADD DX,AX ; ADD OVERFLOW TO MSH
MOV AX,BX ; RECOVER LSH
POP BX ; AND NUMBER
ADD AX,BX ; ADD IT IN 16-BIT TO 32-BIT ADD
ADC DX,0
INC DI
JMP DU1.L0
EX: PUSH AX
PUSH DX ; SAVE DOUBLE NUMBER
MOV BX,-1 ; TRUE FLAG
CMP BYTE [DI],'.'
JNZ .L2
MOV [CDBL],BX ; DOUBLE PRECISION IF DELIMITER IS A PERIOD
INC DI
.L2: CMP BYTE [DI],' ' ; MUST BE A SPACE FOR VALID NUMBER
JZ .L3 ; OK
INC BX ; FALSE FLAG
.L3: LODSW
JMP AX
DU2 equ $-DU1
; : DS COUNT ASCII - = DUP >R 0= + DU ( 1/3)
; IF R> IF DENEGATE -1 THEN
; ELSE R> DROP 0
; THEN ;
H_DS0 DW H_DU
DB 0x82,'DS'
DS0: CALL DOCOLON
DW COUNT,LIT,0x2D,EQUAL,DUPE,TOR,ZEQ,PLUS,DU,ZBRAN,DS1
DW RFR,ZBRAN,DS2,DNEGATE
DS2: DW MIONE,BRAN,DS3
DS1: DW RFR,DROP,ZERO
DS3: DW EXIT
; : $DS BASE >R COUNT ASCII $ = DUP ( 1/3)
; IF HEX THEN 0= + DS R> TO BASE ;
H_HDS DW H_DS0
DB 0x83,'$DS'
HDS: CALL DOCOLON
DW BASE,TOR,COUNT,LIT,0x24,EQUAL,DUPE,ZBRAN,HDS1,HEXX
HDS1: DW ZEQ,PLUS,DS0,RFR,TOU,BASE,EXIT
H_NU DW H_HDS
DB 0x82,'NU' ; VECTORED WORD FOR 'NUMBER' INITIALIZED
NU: DB 0xE9
DW HDS-($+2) ; TO POINT TO '$DS' FOR HEX ENTRY
H_QQ DW H_NU
DB 0x82,'??'
QQ: CALL DOCOLON ; : ?? 0= IF .W -1 ABORT" ?" ; ( 1/0)
DW ZEQ,ZBRAN,QQ1,DOTW,MIONE,QER
DB 2,' ?'
QQ1: DW EXIT
; : ?NU NU ?? ; ( 1/3/0)
H_QNU DW H_QQ
DB 0x83,'?NU'
QNU: CALL DOCOLON
DW NU,QQ,EXIT
H_KBD DW H_QNU
DB 0x83,'KBD' ; ACCEPT UP TO 80 CHARACTERS FROM THE KEYBOARD
KBD: JMP KBD1 ; SPAN HOLDS THE ACTUAL COUNT OF KEYSTROKES
DW KBD2 ; ( 0/0)
KBD1: MOV DX,BUF
MOV AH,10
INT 0x21
MOV AL,[CNT] ; ?????????? removed B at end of line, added[]
CBW
MOV [CSPAN],AX
LODSW
JMP AX
KBD2 equ $-KBD1
; : RF ROOT find ; ( 1/2)
H_RF DW H_KBD
DB 0x82,'RF'
RF: CALL DOCOLON
DW ROOT,FINDE,EXIT
H_FIND DW H_RF
DB 0x84,'FIND'
FIND: DB 0xE9 ; 'FIND' VECTORED TO 'RF' INITIALLY
DW RF-($+2)
; (1/1) FOR WORD
H_XWORD DW H_FIND
DB 0x84,'WORD' ; GET NEXT WORD FROM INPUT TO 'HERE'. LEAVE
XWORD: JMP WORD1 ; 'HERE' ON STACK. ALSO ACCEPTS TAB, CR, AND LF
DW WORD2 ; AS ABSOLUTE DELIMITERS IN ADDITION TO CHAR ON STK
WORD1: MOV AH,9 ; TAB CHARACTER
MOV DX,0xD0A ; CR AND LF CHARACTERS
MOV AL,BL ; SCAN CHARACTER
MOV BX,BUF+2 ; START OF KEYBOARD BUFFER ;????? !!!!!!!! ?????
MOV CX,[CBLK] ; 0 IF KEYBOARD ?????????? removed W at end of line
ded[]
JCXZ .L0
MOV BX,[CBLOCK] ; ELSE GET BLOCK ADDRESS ????added[]
XOR CX,CX ; AND SET CX COUNT TO 0
.L0: ADD BX,[CTOIN] ; OFFSET INTO BUFFER ????? added[]
JMP .L2
.L1: INC CX
INC BX
.L2: CMP [BX],AL
JZ .L1
CMP [BX],AH
JZ .L1
CMP [BX],DL
JZ .L1
CMP [BX],DH
JZ .L1 ; SKIP BUT COUNT LEADING CHARS
PUSH SI ; SAVE THE IP
MOV SI,BX ; SI -> FIRST CHAR OF WORD
JMP .L4
.L3: INC CX
INC BX
.L4: CMP [BX],AH
JZ .L5
CMP [BX],DL
JZ .L5
CMP [BX],DH
JZ .L5
CMP [BX],AL
JNZ .L3 ; SCAN FOR DELIMITER
.L5: INC CX ; STEP PAST DELIMITER
ADD [CTOIN],CX ; ADVANCE >IN BY CX
SUB BX,SI ; ACTUAL COUNT OF WORD
MOV CX,BX ; INTO CX
MOV DI,[CHERE] ; MOVE TO HERE ???? added[]
MOV BX,DI ; TOS ALSO = HERE ON EXIT
MOV AL,CL ; WORD LENGTH
STOSB
REP MOVSB ; AND STRING MOVED TO HERE
MOV AL,' ' ; FOLLOWED BY A SPACE
STOSB
POP SI ; RESTORE THE IP
LODSW
JMP AX
WORD2 equ $-WORD1
; : W, WORD C@ 1+ ALLOT ; (1/0)
H_WCOMMA DW H_XWORD
DB 0x82,'W,'
WCOMMA: CALL DOCOLON
DW XWORD,CAT,ONEPL,ALLOT,EXIT
; : HEAD LATEST , HERE TO TDP BL W, TDP $80 CXR ; (0/0)
H_HED DW H_WCOMMA
DB 0x84,'HEAD'
HED: CALL DOCOLON
DW LATEST,COMMA,HERE,TOU,TDP,BLANK,WCOMMA
DW TDP,H80,CXR,EXIT
; : CREATE HEAD $E9 C, LIT DOVAR HERE 2+ - , ; (0/0)
H_VCREATE DW H_HED
DB 0x86,'CREATE'
VCREATE:CALL DOCOLON
DW HED,LIT,0xE9,CCOMMA,LIT,DOVAR,HERE,TWOPL,SUBT,COMMA,EXIT
; : : HEAD :, !CSP ] ; (0/0)
H_COLN DW H_VCREATE
DB 0x81,':'
COLN: CALL DOCOLON
DW HED,COLCOM,STCSP,RBRAK,EXIT
; : ; IMMEDIATE ?CSP COMPILE EXIT 1 ?EX (0/0)
; IF 2 LL !
; ELSE LINK
; THEN [ ;
H_SEMI DW H_COLN
DB 0xC1,';'
SEMI: CALL DOCOLON
DW QCSP,COMPILE,EXIT,ONE,QEX,ZBRAN,SE1,TWO,LL,STORE,BRAN,SE2
SE1: DW LYNK
SE2: DW LBRAK,EXIT
; : LOCATE BL WORD FIND ; (0/2)
H_LOCATE DW H_SEMI
DB 0x86,'LOCATE'
LOCATE: CALL DOCOLON
DW BLANK,XWORD,FIND,EXIT
; : NUMBER 1+ ?NU COMPILING ( 1/0 COMPILING)
; IF DBL IF SWAP LITERAL LITERAL ( 1/1 NON-COMPILING)
; ELSE DROP LITERAL
; THEN
; ELSE DBL 0= IF DROP THEN
; THEN ;
H_NUMB DW H_LOCATE
DB 0x86,'NUMBER'
NUMB: CALL DOCOLON
DW ONEPL,QNU,COMP,ZBRAN,NN1,DBL,ZBRAN,NN2,SWAP
DW LITERAL,LITERAL,BRAN,NN4
NN2: DW DROP,LITERAL,BRAN,NN4
NN1: DW DBL,ZEQ,ZBRAN,NN4,DROP
NN4: DW EXIT
; : BYE 0 EXECUTE ; (0/0)
H_BYE DW H_NUMB
DB 0x83,'BYE'
BYE: CALL DOCOLON
DW ZERO,EXECUTE,EXIT
; : INTERPRET COMPILING (1/0)
; IF 1+ IF EXECUTE
; ELSE ,
; THEN
; ELSE DROP EXECUTE
; THEN ;
H_INTERP DW H_BYE
DB 0x89,'INTERPRET'
INTERP: CALL DOCOLON
DW COMP,ZBRAN,IN1,ONEPL,ZBRAN,IN2,EXECUTE,BRAN,IN3
IN2: DW COMMA
IN3: DW BRAN,IN4
IN1: DW DROP,EXECUTE
IN4: DW EXIT
; : RUN CR BEGIN >IN SPAN < ( 0/0)
; WHILE 0TO LOCATE ?DUP
; IF INTERPRET
; ELSE NUMBER
; THEN DEPTH 0< $80 DEPTH < OR ABORT" Stack?"
; REPEAT
; 2 ?EX IF TDP EXECUTE RID [ THEN ;
H_RUN DW H_INTERP
DB 0x83,'RUN'
RUN: CALL DOCOLON
DW CR
RU1: DW TOIN,SPAN,LESS,ZBRAN,RU4,ZEROTO,LOCATE,QDUP,ZBRAN,RU3
DW INTERP,BRAN,RU2
RU3: DW NUMB
RU2: DW DEPTH,ZLESS,H80,DEPTH,LESS,ORE,QER
DB 7,' Stack?'
DW BRAN,RU1
RU4: DW TWO,QEX,ZBRAN,RU5,TDP,EXECUTE,RID,LBRAK
RU5: DW EXIT
; : QUIT R0 RP! [ ( 0/0)
; BEGIN CR 0 TO BLK KBD 0 TO >IN RUN
; COMPILING 0= IF ." ok" THEN
; AGAIN ;
H_QUIT DW H_RUN
DB 0x84,'QUIT'
QUIT: CALL DOCOLON
DW R0,RPST,LBRAK
QUI: DW CR,ZERO,TOU,BLK,KBD,ZERO,TOU,TOIN,RUN,COMP,ZEQ
DW ZBRAN,QU1,ILT
DB 3,' ok'
QU1: DW BRAN,QUI,EXIT
; : ?ER 0TO (1/0)
; IF COMPILING IF RID THEN
; R> COUNT TYPE ERROR QUIT
; ELSE R> COUNT + >R
; THEN ;
H_QER DW H_QUIT
DB 0x83,'?ER'
QER: CALL DOCOLON
DW ZEROTO,ZBRAN,QER3,COMP,ZBRAN,QER2,RID
QER2: DW RFR,COUNT,TYPEE,ERROR,QUIT,BRAN,QER1
QER3: DW RFR,COUNT,PLUS,TOR
QER1: DW EXIT
; : ABORT [ -1 ABORT" MINIFORTH V1.0 - 8/8/88" ; (0/0)
H_ABORT DW H_QER
LAST: DB 0x85,'ABORT'
ABORT: CALL DOCOLON
DW LBRAK,MIONE,QER
DB CT
CT1: DB 'MINIFORTH V1.0 - 8/8/88'
CT equ $-CT1
DW EXIT
INIT: CLD
XOR AX,AX
MOV BX,AX
MOV [CRZERO],AX
MOV BP,AX
SUB AX,256
MOV [CS0],AX ; added[]
MOV SP,AX
MOV AX,10
MOV [CBASE],AX
MOV [CCOMP],BX
MOV SI,ABORT+3
LODSW
JMP AX
DP equ $
; TODO CHANGE LYNK FOR LINK BUT WATCHOUT CHANGES IT EVERYWHERE
; MOV BX,BUF+2 !!!!!!!!! ????????? should it be mov bx,[buf+2]??? ligne 140
Net-Tamer V 1.08X - Test Drive