Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / forth / compiler / min4zh / mini.a86 next >

Wrap

Text File | 1988-08-08 | 21.6 KB | 1,213 lines

; 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 while ; 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 number ; 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 learning ; how to use miniforth. For those used to FORTH, this listing and the MINI.MIN ; file should provide adequate information on how to extend miniforth. ; ******************************************* HEAD MACRO DW LINK LINK=$-2 DB #1+080 DB #2 #EM HEADI MACRO DW LINK LINK=$-2 DB #1+0C0 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 0100 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 CR0 DW 0 CDBL DW 0 TFL DW 0 CSP DW 0 BUF: DB 80 ; TIB FOR KEYBOARD CNT DB 81 DUP (0) ; HEADERLESS EXECUTION CODE GOES HERE DOCOLON: X PUSH SI X POP SI NEXT DOTOVAR: PUSH BX ADD AX,3 MOV BX,AX MOV BX,[BX] MOV CX,TFL JCXZ FETCH OR CX,CX MOV W TFL,0 JNS XSTORE XPSTORE: POP AX ADD [BX],AX POP BX NEXT XSTORE: POP AX MOV [BX],AX POP BX NEXT DOCON: PUSH BX ADD AX,3 MOV BX,AX FETCH: MOV BX,[BX] NEXT DOVAR: PUSH BX ADD AX,3 MOV BX,AX NEXT DOVOC: ADD AX,3 MOV W CONT,AX NEXT XEXEC: MOV AX,BX POP BX JMP AX XEXIT: X POP SI X NEXT XTOR: X PUSH BX X POP BX NEXT XRFR: PUSH BX X POP BX X NEXT XTOR2: POP AX X PUSH BX,AX X POP BX NEXT XRFR2: PUSH BX X POP AX,BX X PUSH AX NEXT XTO: INC W TFL NEXT XPTO: DEC W TFL NEXT XDUP: PUSH BX NEXT XQDUP: OR BX,BX JNZ XDUP NEXT XDROP: POP BX NEXT XSWAP: POP AX PUSH BX MOV BX,AX NEXT XOVER: POP AX PUSH AX,BX MOV BX,AX NEXT XROT: POP CX,DX PUSH CX,BX MOV BX,DX NEXT XCAT: MOV BL,[BX] MOV BH,0 NEXT XCSTORE:POP AX MOV [BX],AL POP BX NEXT XDUP2: PUSH BX MOV DI,SP PUSH [DI+2] NEXT XDROP2: POP BX,BX NEXT XSWAP2: POP AX,CX,DX PUSH AX,BX,DX MOV BX,CX NEXT XPLUS: POP AX ADD BX,AX NEXT XSUBT: POP AX NEG BX ADD BX,AX NEXT XZEQ: XOR AX,AX OR BX,BX JNZ X1 X2: DEC AX X1: XCHG AX,BX NEXT 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: NEXT XPLOOP: X POP AX,CX INC AX INC CX JO EXLP L1: PUSH CX,AX X XBRAN: MOV SI,[SI] NEXT XPPLOOP: POP DI X POP AX,CX ADD AX,BX ADD CX,BX MOV BX,DI JNO L1 EXLP: X L3: ADD SI,2 NEXT XZBRAN: OR BX,BX POP BX JZ XBRAN JNZ L3 XI: XRAT: PUSH BX X POP BX PUSH BX X NEXT XOF: POP AX CMP AX,BX JZ >L1 MOV BX,AX JMP XBRAN L1: POP BX ADD SI,2 NEXT XOVER2: POP AX,CX,DX PUSH DX,CX,AX,BX,DX MOV BX,CX NEXT XONEPL: INC BX NEXT XTWOPL: ADD BX,2 NEXT XTHREEPL: ADD BX,3 NEXT XONEMI: DEC BX NEXT XTWOMI: SUB BX,2 NEXT XTHREEMI:SUB BX,3 NEXT XTWOSLS:SAR BX,1 NEXT XTWOSTAR: SHL BX,1 NEXT XUMSTAR:POP AX MUL BX PUSH AX MOV BX,DX NEXT XUMSLSM:POP DX XOR AX,AX CMP DX,BX JNB >L0 POP AX DIV BX PUSH DX L0: MOV BX,AX NEXT XDPLUS: POP AX,CX,DX ADD DX,AX PUSH DX ADC BX,CX NEXT XDNEGATE:POP AX NEG AX PUSH AX XCHG AX,BX MOV BX,0 SBB BX,AX NEXT XNEGATE:NEG BX NEXT XAND: POP AX AND BX,AX NEXT XORE: POP AX OR BX,AX NEXT XXORX: POP AX XOR BX,AX NEXT XLIT: PUSH BX LODSW MOV BX,AX NEXT XULESS: POP AX SUB AX,BX MOV BX,-1 JB >L0 INC BX L0: NEXT XLESS: POP AX SUB AX,BX MOV BX,-1 JL >L0 INC BX L0: NEXT XTWOAT: PUSH [BX+2] MOV BX,[BX] NEXT XTWOSTORE:POP [BX] POP [BX+2] POP BX NEXT XPICK: SHL BX,1 ADD BX,SP MOV BX,[BX] NEXT XEQUAL: POP AX CMP BX,AX MOV BX,-1 JZ >L0 INC BX L0: NEXT XCR: MOV DL,0D MOV AH,2 INT 021 MOV DL,0A INT 021 NEXT XQKEY: PUSH BX MOV AH,0B INT 021 CBW MOV BX,AX NEXT XKEY: PUSH BX MOV AH,7 INT 021 XOR AH,AH MOV BX,AX NEXT XEMIT: MOV DL,BL MOV AH,2 INT 021 POP BX NEXT XTYPE: POP DX MOV CX,BX JCXZ >L0 MOV AH,040 MOV BX,1 INT 021 L0: POP BX NEXT LINK=0 ; START OF MINIFORTH WITH ITS HEADERS MINE: DW LINK DB 0E4,'MINI' ; BIT 6 SET FOR IMMEDIATE, BIT 5 FOR VOCABULARY MINI: VOCAB RUTE: DW LAST ; HOLDER FOR LAST DW MINE ; VOCABULARY STOPPER LINK=$-2 ; WORDS LINK INTO ROOT VOCABULARY, 'MINI'. HEAD 4,'EXIT' ; ( 0/0) EXIT: JMP XEXIT HEAD 1,'!' ; (2/0) STORE: JMP XSTORE HEAD 2,'+!' ; (2/0) PSTOR: JMP XPSTORE HEAD 1,'@' ; (1/1) ATT: JMP FETCH HEAD 2,'>R' ; (1/0) TOR: JMP XTOR HEAD 2,'R>' ; (0/1) RFR: JMP XRFR HEAD 3,'2>R' ; (2/0) TOR2: JMP XTOR2 HEAD 3,'2R>' ; (0/2) RFR2: JMP XRFR2 HEAD 2,'to' ; (1/0) TO: JMP XTO HEAD 3,'+to' ; (1/0) PTO: JMP XPTO HEAD 3,'DUP' ; (1/2) DUPE: JMP XDUP HEAD 4,'?DUP' ; (1/2/0) QDUP: JMP XQDUP HEAD 4,'DROP' ; (1/0) DROP: JMP XDROP HEAD 4,'SWAP' ; (2/2) SWAP: JMP XSWAP HEAD 4,'OVER' ; (2/3) OVER: JMP XOVER HEAD 3,'ROT' ; (3/3) ROT: JMP XROT HEAD 2,'C@' ; (1/1) CAT: JMP XCAT HEAD 2,'C!' ; (2/0) CSTORE: JMP XCSTORE HEAD 4,'2DUP' ; (2/4) DUP2: JMP XDUP2 HEAD 5,'2DROP' ; (2/0) DROP2: JMP XDROP2 HEAD 5,'2SWAP' ; (4/4) SWAP2: JMP XSWAP2 HEAD 5,'2OVER' ; (4/6) OVER2: JMP XOVER2 HEAD 1,'+' ; (2/1) PLUS: JMP XPLUS HEAD 1,'-' ; (2/1) SUBT: JMP XSUBT HEAD 2,'0=' ; (1/1) ZEQ: JMP XZEQ HEAD 2,'0<' ; (1/1) ZLESS: JMP XZLESS HEAD 2,'0>' ; (1/1) ZGRT: JMP XZGRT HEAD 3,'0<>' ; (1/1) ZNE: JMP XZNE HEAD 1,'=' ; (2/1) EQUAL: JMP XEQUAL HEAD 3,'0br' ; (1/0) ZBRAN: JMP XZBRAN HEAD 2,'br' ; (0/0) BRAN: JMP XBRAN HEAD 2,'lp' ; (0/0) PLOOP: JMP XPLOOP HEAD 3,'+lp' ; (1/0) PPLOOP: JMP XPPLOOP HEAD 1,'I' ; (0/1) I: JMP XI HEAD 2,'R@' ; (0/1) RAT: JMP XRAT HEAD 2,'of' ; (2/0/1) OF: JMP XOF HEAD 2,'1+' ; (1/1) ONEPL: JMP XONEPL HEAD 2,'2+' ; (1/1) TWOPL: JMP XTWOPL HEAD 2,'3+' ; (1/1) THREEPL:JMP XTHREEPL HEAD 2,'1-' ; (1/1) ONEMI: JMP XONEMI HEAD 2,'2-' ; (1/1) TWOMI: JMP XTWOMI HEAD 2,'3-' ; (1/1) THREEMI:JMP XTHREEMI HEAD 2,'2/' ; (1/1) TWOSLS: JMP XTWOSLS HEAD 2,'2*' ; (1/1) TWOSTAR:JMP XTWOSTAR HEAD 3,'UM*' ; (2/2) UMSTAR: JMP XUMSTAR HEAD 6,'UM/MOD' ; (3/2) UMSLSM: JMP XUMSLSM HEAD 2,'D+' ; (4/2) DPLUS: JMP XDPLUS HEAD 7,'DNEGATE'; (2/2) DNEGATE:JMP XDNEGATE HEAD 6,'NEGATE' ; (1/1) NEGATE: JMP XNEGATE HEAD 3,'AND' ; (2/1) ANDD: JMP XAND HEAD 2,'OR' ; (2/1) ORE: JMP XORE HEAD 3,'XOR' ; (2/1) XORX: JMP XXORX HEAD 3,'LIT' ; (1/0) LIT: JMP XLIT HEAD 2,'U<' ; (2/1) ULESS: JMP XULESS HEAD 1,'<' ; (2/1) LESS: JMP XLESS HEAD 2,'2@' ; (1/2) TWOAT: JMP XTWOAT HEAD 2,'2!' ; (3/0) TWOSTORE:JMP XTWOSTORE HEAD 4,'PICK' ; (1/1) PICK: JMP XPICK HEAD 2,'CR' ; (0/0) CR: JMP XCR HEAD 4,'?KEY' ; (0/1) QKEY: JMP XQKEY HEAD 3,'KEY' ; (0/1) KEY: JMP XKEY HEAD 4,'EMIT' ; (1/0) EMIT: JMP XEMIT HEAD 4,'TYPE' ; (2/0) TYPEE: JMP XTYPE HEAD 2,'<>' ; (2/1) NEQ: COLON DW EQUAL,ZEQ,EXIT HEAD 5,'CMOVE' CMOVE: JMP LONG CM1 ; (3/0) DW CM2 CM1: POP DI,AX PUSH SI MOV SI,AX MOV CX,BX JCXZ >L0 REP MOVSB L0: POP SI,BX NEXT CM2=$-CM1 HEAD 1,'0' ZERO: CONST ; (0/1) DW 0 HEAD 1,'1' ONE: CONST ; (0/1) DW 1 HEAD 1,'2' TWO: CONST ; (0/1) DW 2 HEAD 2,'-1' MIONE: CONST ; (0/1) DW -1 HEAD 3,'$40' H40: CONST ; (0/1) DW 040 HEAD 3,'$80' H80: CONST ; (0/1) DW 080 HEAD 2,'1F' ONEF: CONST ; (0/1) DW 01F HEAD 2,'7F' SEVENF: CONST ; (0/1) DW 07F HEAD 2,'BL' BLANK: CONST ; (0/1) DW 020 HEAD 4,'ROOT' ROOT: CONST ; (0/1) DW RUTE HEAD 7,'CURRENT' CURRENT:VARI ; (0/1) DW RUTE HEAD 7,'CONTEXT' CONTEXT:VARI ; (0/1) CONT DW RUTE ; : LATEST CURRENT @ @ ; (0/1) HEAD 6,'LATEST' LATEST: COLON DW CURRENT,ATT,ATT,EXIT ; : CLATEST CONTEXT @ @ ; (0/1) HEAD 7,'CLATEST' CLATEST:COLON DW CONTEXT,ATT,ATT,EXIT ; : PATCH 1+ DUP >R 2+ - R> ! ; (2/0) HEAD 5,'PATCH' PATCH: COLON DW ONEPL,DUPE,TOR,TWOPL,SUBT,RFR,STORE,EXIT HEAD 3,'>IN' TOIN: TOVAR ; (0/1) DW OFFSET CTOIN HEAD 4,'HERE' HERE: TOVAR ; (0/1) DW OFFSET CHERE HEAD 4,'SPAN' SPAN: TOVAR ; (0/1) DW OFFSET CSPAN HEAD 3,'BLK' BLK: TOVAR ; (0/1) DW OFFSET CBLK HEAD 5,'BLOCK' BLOCK: TOVAR ; (0/1) DW OFFSET CBLOCK HEAD 4,'BASE' BASE: TOVAR ; (0/1) DW OFFSET CBASE HEAD 9,'COMPILING' COMP: TOVAR ; (0/1) DW OFFSET CCOMP HEAD 3,'TDP' TDP: TOVAR ; (0/1) DW OFFSET CTDP HEAD 2,'R0' R0: TOVAR ; (0/1) DW OFFSET CR0 HEAD 2,'S0' S0: TOVAR ; (0/1) DW OFFSET CS0 HEAD 3,'DBL' DBL: TOVAR ; (0/1) DW OFFSET CDBL HEADI 1,'[' ; : [ 0 TO COMPILING ; (0/0) LBRAK: COLON DW ZERO,TO,COMP,EXIT HEAD 1,']' RBRAK: COLON DW MIONE,TO,COMP,EXIT HEAD 5,'SPACE' ; : BL EMIT ; (0/0) SPACE: COLON DW BLANK,EMIT,EXIT HEAD 5,'COUNT' ; (1/2) COUNT: JMP LONG COUNT1 DW COUNT2 COUNT1: MOV AX,BX INC AX PUSH AX MOV BL,[BX] MOV BH,0 NEXT COUNT2=$-COUNT1 ; : .W HERE COUNT 1F AND TYPE SPACE ; (0/0) HEAD 2,'.W' DOTW: COLON DW HERE,COUNT,ONEF,ANDD,TYPEE,SPACE,EXIT ; : LL TDP 2- ; (0/1) HEAD 2,'LL' LL: COLON DW TDP,TWOMI,EXIT ; : ?EX LL @ = ; (1/1) HEAD 3,'?EX' QEX: COLON DW LL,ATT,EQUAL,EXIT ; : ILT R> COUNT 2DUP + >R TYPE ; (0/0) HEAD 3,'ILT' ILT: COLON DW RFR,COUNT,DUP2,PLUS,TOR,TYPEE,EXIT HEAD 5,'ALLOT' ; : ALLOT +TO HERE ; (1/0) ALLOT: COLON DW PTO,HERE,EXIT HEAD 1,',' ; : , HERE ! 2 ALLOT ; (1/0) COMMA: COLON DW HERE,STORE,TWO,ALLOT,EXIT HEAD 2,'C,' ; : C, HERE C! 1 ALLOT ; (1/0) CCOMMA: COLON DW HERE,CSTORE,ONE,ALLOT,EXIT HEAD 4,'!CSP' ; (0/0) STCSP: JMP LONG STCSP1 DW STCSP2 STCSP1: MOV AX,SP MOV CSP,AX NEXT STCSP2=$-STCSP1 HEAD 4,'CSP?' ; RETURNS 'TRUE' IF CSP <> SP CSPQ: JMP LONG CSPQ1 ; (0/1) DW CSPQ2 CSPQ1: MOV AX,SP PUSH BX XOR BX,BX CMP AX,CSP JZ >L0 DEC BX L0: NEXT CSPQ2=$-CSPQ1 ; : ?CSP CSP? ABORT" Unbalanced" ; (0/0) HEAD 4,'?CSP' QCSP: COLON DW CSPQ,QER, DB 11,' Unbalanced' DW EXIT ; : :, $E8 C, LIT DOCOLON HERE 2+ - , ; (0/0) HEAD 2,':,' COLCOM: COLON DW LIT,0E8,CCOMMA,LIT,DOCOLON,HERE,TWOPL,SUBT,COMMA,EXIT ; : ?C COMPILING 0= (0/0) ; IF 1 , HERE TO TDP :, !CSP ] THEN ; HEAD 2,'?C' QC: COLON DW COMP,ZEQ,ZBRAN,QC1,ONE,COMMA,HERE,TO,TDP,COLCOM,STCSP,RBRAK QC1: DW EXIT ; : COMPILE ?C R> DUP @ , 2+ >R ; (0/0) HEAD 7,'COMPILE' COMPILE:COLON DW QC,RFR,DUPE,ATT,COMMA,TWOPL,TOR,EXIT HEAD 3,'CXR' ; XOR CHAR AT ADDR WITH BYTE: (ADDR BYTE... ) CXR: JMP LONG CXR1 ; (2/0) DW CXR2 CXR1: POP DI XOR [DI],BL POP BX NEXT CXR2=$-CXR1 HEAD 3,'SP!' ; (1/0) SPST: JMP LONG SPST1 DW SPST2 SPST1: POP AX MOV SP,BX MOV BX,AX NEXT SPST2=$-SPST1 HEAD 3,'RP!' ; (1/0) RPST: JMP LONG RPST1 DW RPST2 RPST1: MOV BP,BX POP BX NEXT RPST2=$-RPST1 HEAD 3,'CLR' CLR: COLON ; : CLR S0 SP! ; (0/0) DW S0,SPST,EXIT HEAD 7,'EXECUTE' EXECUTE:JMP XEXEC HEAD 5,'ERROR' ERROR: DB 0E9 ; VECTORED ERROR HANDLER - PRESENTLY CLEARS STACK DW CLR-($+2) ; : HEX 16 TO BASE ; (0/0) HEAD 3,'HEX' HEXX: COLON DW LIT,16,TO,BASE,EXIT ; : DECIMAL 10 TO BASE ; (0/0) HEAD 7,'DECIMAL' DECIM: COLON DW LIT,10,TO,BASE,EXIT ; : LITERAL COMPILING (1/0 COMPILING) ; IF COMPILE LIT , THEN ; (0/0 NON-COMPILING) HEADI 7,'LITERAL' LITERAL:COLON DW COMP,ZBRAN,LI1,COMPILE,LIT,COMMA LI1: DW EXIT ; : LINK LL CURRENT @ ! ; (0/0) HEAD 4,'LINK' LYNK: COLON DW LL,CURRENT,ATT,STORE,EXIT ; : RID LL TO HERE ; (0/0) HEAD 3,'RID' RID: COLON DW LL,TO,HERE,EXIT HEAD 3,'0TO' ; RESET THE 'TO' FLAG TO ZERO (0/0) ZEROTO: JMP LONG ZT1 DW ZT2 ZT1: MOV W TFL,0 NEXT ZT2=$-ZT1 HEAD 4,'find' ; (2/2) FINDE: JMP LONG 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,01F ; 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 B[BX+2],040 ; CHACK FOR IMMEDIATE WORD MOV BX,-1 ; TRUE FLAG BUT -1 JZ >L1 NEG BX ; TRUE FLAG BUT +1 IF IMMEDIATE L1: NEXT ; ALL DONE L2: POP SI ; DID NOT FIND WORD SO RECOVER IP PUSH DX ; BX = 0 FOR FALSE FLAG, DX = 'HERE' NEXT ; AND WE'RE DONE FIND2=$-FIND1 HEAD 2,'.H' ; PRINT 4 DIGIT UNSIGNED HEX NUMBER AND SPACE DOTH: MOV CX,4 ; (1/0) CALL PRH POP BX NEXT HEAD 3,'.HC' ; PRINT 2 DIGIT UNSGNED HEX NUMBER AND SPACE DOTHC: MOV CX,2 ; (1/0) CALL PRH POP BX NEXT PRH: MOV DI,CX MOV AX,BX MOV BX,16 L0: XOR DX,DX DIV BX XCHG AX,DX ADD AL,090 DAA ADC AL,040 DAA PUSH AX XCHG AX,DX LOOP L0 MOV CX,DI MOV AH,2 L1: POP DX INT 021 LOOP L1 MOV DL,' ' INT 021 RET HEAD 5,'DEPTH' ; RETURN STACK DEPTH (0/1) DEPTH: JMP LONG D1 DW D2 D1: PUSH BX MOV BX,CS0 SUB BX,SP SAR BX,1 DEC BX ; ACCOUNT FOR NUMBER JUST PUSHED NEXT D2=$-D1 HEAD 4,'BDOS' ; RUN DOS SERVICE $21 BDOS: JMP LONG 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,CX,DX INT 021 PUSH DX,CX,BX,AX MOV BX,0 JNC >L0 DEC BX L0: NEXT BDOS2=$-BDOS1 HEAD 2,'DU' ; CONVERT STRING AT ADDRESS TO AN (1/3) DU: JMP LONG 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 L0: MOV BL,[DI] ; ASCII CHARACTER TO CONVERT MOV BH,0 SUB BX,030 ; 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 L0 EX: PUSH AX,DX ; SAVE DOUBLE NUMBER MOV BX,-1 ; TRUE FLAG CMP B[DI],'.' JNZ >L2 MOV CDBL,BX ; DOUBLE PRECISION IF DELIMITER IS A PERIOD INC DI L2: CMP B[DI],' ' ; MUST BE A SPACE FOR VALID NUMBER JZ >L3 ; OK INC BX ; FALSE FLAG L3: NEXT DU2=$-DU1 ; : DS COUNT ASCII - = DUP >R 0= + DU ( 1/3) ; IF R> IF DENEGATE -1 THEN ; ELSE R> DROP 0 ; THEN ; HEAD 2,'DS' DS0: COLON DW COUNT,LIT,02D,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 ; HEAD 3,'$DS' HDS: COLON DW BASE,TOR,COUNT,LIT,024,EQUAL,DUPE,ZBRAN,HDS1,HEXX HDS1: DW ZEQ,PLUS,DS0,RFR,TO,BASE,EXIT HEAD 2,'NU' ; VECTORED WORD FOR 'NUMBER' INITIALIZED NU: DB 0E9 DW HDS-($+2) ; TO POINT TO '$DS' FOR HEX ENTRY HEAD 2,'??' QQ: COLON ; : ?? 0= IF .W -1 ABORT" ?" ; ( 1/0) DW ZEQ,ZBRAN,QQ1,DOTW,MIONE,QER DB 2,' ?' QQ1: DW EXIT ; : ?NU NU ?? ; ( 1/3/0) HEAD 3,'?NU' QNU: COLON DW NU,QQ,EXIT HEAD 3,'KBD' ; ACCEPT UP TO 80 CHARACTERS FROM THE KEYBOARD KBD: JMP LONG KBD1 ; SPAN HOLDS THE ACTUAL COUNT OF KEYSTROKES DW KBD2 ; ( 0/0) KBD1: MOV DX,BUF MOV AH,10 INT 021 MOV AL,CNT B CBW MOV CSPAN,AX NEXT KBD2=$-KBD1 ; : RF ROOT find ; ( 1/2) HEAD 2,'RF' RF: COLON DW ROOT,FINDE,EXIT HEAD 4,'FIND' FIND: DB 0E9 ; 'FIND' VECTORED TO 'RF' INITIALLY DW RF-($+2) ; (1/1) FOR WORD HEAD 4,'WORD' ; GET NEXT WORD FROM INPUT TO 'HERE'. LEAVE XWORD: JMP LONG 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,0D0A ; CR AND LF CHARACTERS MOV AL,BL ; SCAN CHARACTER MOV BX,BUF+2 ; START OF KEYBOARD BUFFER MOV CX,CBLK W ; 0 IF KEYBOARD JCXZ >L0 MOV BX,CBLOCK ; ELSE GET BLOCK ADDRESS XOR CX,CX ; AND SET CX COUNT TO 0 L0: ADD BX,CTOIN ; OFFSET INTO BUFFER JMP >L1 L2: INC CX INC BX L1: CMP [BX],AL JZ L2 CMP [BX],AH JZ L2 CMP [BX],DL JZ L2 CMP [BX],DH JZ L2 ; SKIP BUT COUNT LEADING CHARS PUSH SI ; SAVE THE IP MOV SI,BX ; SI -> FIRST CHAR OF WORD JMP >L0 L1: INC CX INC BX L0: CMP [BX],AH JZ >L3 CMP [BX],DL JZ >L3 CMP [BX],DH JZ >L3 CMP [BX],AL JNZ L1 ; SCAN FOR DELIMITER L3: 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 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 NEXT WORD2=$-WORD1 ; : W, WORD C@ 1+ ALLOT ; (1/0) HEAD 2,'W,' WCOMMA: COLON DW XWORD,CAT,ONEPL,ALLOT,EXIT ; : HEAD LATEST , HERE TO TDP BL W, TDP $80 CXR ; (0/0) HEAD 4,'HEAD' HED: COLON DW LATEST,COMMA,HERE,TO,TDP,BLANK,WCOMMA DW TDP,H80,CXR,EXIT ; : CREATE HEAD $E9 C, LIT DOVAR HERE 2+ - , ; (0/0) HEAD 6,'CREATE' VCREATE:COLON DW HED,LIT,0E9,CCOMMA,LIT,DOVAR,HERE,TWOPL,SUBT,COMMA,EXIT ; : : HEAD :, !CSP ] ; (0/0) HEAD 1,':' COLN: COLON DW HED,COLCOM,STCSP,RBRAK,EXIT ; : ; IMMEDIATE ?CSP COMPILE EXIT 1 ?EX (0/0) ; IF 2 LL ! ; ELSE LINK ; THEN [ ; HEADI 1,';' SEMI: COLON 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) HEAD 6,'LOCATE' LOCATE: COLON 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 ; HEAD 6,'NUMBER' NUMB: COLON 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) HEAD 3,'BYE' BYE: COLON DW ZERO,EXECUTE,EXIT ; : INTERPRET COMPILING (1/0) ; IF 1+ IF EXECUTE ; ELSE , ; THEN ; ELSE DROP EXECUTE ; THEN ; HEAD 9,'INTERPRET' INTERP: COLON 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 ; HEAD 3,'RUN' RUN: COLON 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 ; HEAD 4,'QUIT' QUIT: COLON DW R0,RPST,LBRAK QUI: DW CR,ZERO,TO,BLK,KBD,ZERO,TO,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 ; HEAD 3,'?ER' QER: COLON 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) LAST: HEAD 5,'ABORT' ABORT: COLON DW LBRAK,MIONE,QER DB CT CT1: DB 'MINIFORTH V1.0 - 8/8/88' CT=$-CT1 DW EXIT INIT: CLD XOR AX,AX MOV BX,AX MOV CR0,AX MOV BP,AX SUB AX,256 MOV CS0,AX MOV SP,AX MOV AX,10 MOV CBASE,AX MOV CCOMP,BX MOV SI,ABORT+3 NEXT DP=$