Frostbyte's 1980s DOS Shareware Collection

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

/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / FIGFORTH.ZIP / FORTH.ARC / 4TH-MAIN.ASM < prev next >

Wrap

Assembly Source File | 1983-08-04 | 50KB | 2,496 lines

TITLE Forth Interest Group 8086 FORTH NAME FORTH PAGE 62,132 .SALL .XCREF COMMENT \ Forth Interest Group 8086 FORTH Version 1.0 Original implementation by Thomas Newman made available by the FORTH INTEREST GROUP P.O. Box 1105 San Carlos, CA 94070 Modified by Joe Smith U. of Penn./Dept. of Chemistry 34th & Spruce St. Philadelphia, PA 19104 215 898-4797 Available through SIG/86 c/o Joseph Boykin 47-4 Sheridan Drive Shrewsbury, MA 01545 617 845-1074 Latest revision: June, 1983 This is a revision of fig-FORTH which includes the following changes: Source compatible with Microsoft's 8086 Macro Assembler Macros for dictionary headers Complete interface to MS-DOS, including screen files Command line arguments are interpreted All i/o is redirectable through execution vectors \ SUBTTL Assembly switches (TRUE/FALSE) and EQUATES PAGE INCLUDE 4TH-OPTS.H ;assembly options ; Version number: FIGREL EQU 1 ;fig release number FIGREV EQU 0 ;fig revision number USRVER EQU 0 ;user version number,0-25,printed as A-Z ; Memory allocation parameters: EM EQU 0000 ;64K top of memory + 1 NSCR EQU 8 ;No. of 1K block buffers BUFSIZE EQU 1024 ;size of FORTH's disk buffers US EQU 80 ;User area size ( in bytes ) RTS EQU 160 ;Return stack/TIB size BUF1 EQU EM-(NSCR*(BUFSIZE+4)) ;first buffer addr. INITR0 EQU BUF1-US ;Start of return stack (R0) INITS0 EQU INITR0-RTS ;Start of param. stack (S0) ; ASCII characters used ANUL EQU 0 ;ASCII NUL BELL EQU 7 ;ASCII bell: ^G BSOUT EQU 8 ;output backspace: ^H LF EQU 10 ;ASCII linefeed FF EQU 12 ;ASCII form feed ACR EQU 13 ;ASCII carriage return BSIN EQU 127 ;input delete char: DEL SUBTTL Main entry points and COLD start data PAGE + INCLUDE 4TH-LIB.MAC ;Required support macros ; Note: FORTH only uses one segment, and runs as a .COM program MAIN SEGMENT ASSUME CS:MAIN,DS:MAIN,SS:MAIN,ES:MAIN ORG 100H ORIG: NOP JMP CLD ;vector to COLD start NOP JMP WRM ;vector to WARM start DB FIGREL ;version # printed by COLD DB FIGREV DB USRVER DB 0EH ;version attributes DW LASTNFA ;top word in FORTH vocabulary DW BSIN ;backspace recognised by EXPECT DW INITR0 ;initial UP ; COLD start moves the following to USER var's. 3-10 ; MUST BE IN SAME ORDER AS USER VARIABLES DW INITS0 ; S0 DW INITR0 ; R0 DW INITS0 ; TIB DW 32 ; WIDTH DW 0 ; WARNING DW INITDP ; FENCE DW INITDP ; DP DW FORTH+6 ; VOC-LINK ; CPU id printed by COLD IF _ALIGN DD 0B3260005H ;"8086" ( in base 36 ! ) ELSE DD 0B3280005H ;"8088" ( in base 36 ! ) ENDIF UP DW INITR0 ;user area pointer RPP DW INITR0 ;return stack pointer $REPORT <Boot parameters completed> $REPORT <LIMIT =>,%EM $REPORT <FIRST =>,%BUF1 $REPORT <R0 =>,%INITR0 $REPORT <S0 =>,%INITS0 SUBTTL FORTH register usage PAGE + COMMENT \ FORTH 8086 Preservation rules ------------------------------------------------------------------------ IP SI Interpreter pointer Must be preserved across words NOTE: Also preserve the direction flag (always UP)! W DX Working register Jump to label DPUSH will push contents onto the parameter stack before falling into APUSH SP SP Parameter stack pointer Must be preserved across words RP BP Return stack pointer Must be preserved across words AX General purpose register Jump to label APUSH pushes contents onto the parameter stack CS,DS,SS Must be preserved across words All other registers are available \ SUBTTL Comment conventions PAGE COMMENT \ == means is equal to := means is assigned the value name == address of name (name) == contents at address name ((name))== contents at address contained in name NFA == Name Field Address LFA == Link Field Address CFA == Code Field Address PFA == Parameter Field Address S1,S2 == parameter stack: top item, next item R1,R2 == return stack: top word, next word LSB == Least Significant Bit MSB == Most Significant Bit LB,LW == Low Byte, Low Word HB,HW == High Byte, High Word \ IF _DEBUG SUBTTL Debugging support PAGE + BIP DW 0 ;breakpoint start address BIPE DW 0 ;breakpoint end address COMMENT \ BIP BIPE effect ----- ----- ------------------------------------------- 0 ? trace off -1 ? trace all NEXT calls addr1 0 trace addr1 only addr1 addr2 trace NEXT calls between addr1 and addr2 NOTE: addr1/addr2 can't be CFA's \ ; NEXT with code to trace FORTH word execution TNEXT: PUSHF ;save executing word's data PUSH AX MOV AX,BIP ;addr1 OR AX,AX JZ TNEXT2 ;no trace if addr1==0 CMP AX,-1 JZ TNEXT1 ;trace all CMP AX,SI JZ TNEXT1 ;in range, so trace JA TNEXT2 ;not in range MOV AX,BIPE OR AX,AX JZ TNEXT2 ;trace addr1 only CMP AX,SI JB TNEXT2 ;no longer in range ; Pause on address TNEXT1: POP AX ;restore executing word's reg's. POPF INT 3 ;Break to DEBUG BREAK: JMP SHORT TNEXT3 ;continue ; No pause, restore registers TNEXT2: POP AX POPF TNEXT3: LODSW ;AX:=(IP) MOV BX,AX JMP SHORT NEXT1 $REPORT <Debug trace included> ENDIF SUBTTL Inner interpreter, DPUSH, APUSH entry points PAGE + DPUSH: PUSH DX ;common entry point; DX, AX to S2, S1 APUSH: PUSH AX ;common entry point, AX to S1 NEXT: IF _DEBUG JMP TNEXT ELSE LODSW ; AX:=(IP), IP:=IP+1 MOV BX,AX ENDIF NEXT1: MOV DX,BX INC DX ; W:=(IP)+1 JMP WORD PTR [BX] ;to CFA SUBTTL FORTH dictionary PAGE + ;=C LIT push an inline literal -- n $CODE 83H,LI,T,LIT LODSW JMP APUSH ;=C EXECUTE executes the word at CFA CFA -- ? $CODE 87H,EXECUT,E,EXEC POP BX JMP NEXT1 ;=C BRANCH adds an inline offset to IP -- $CODE 86H,BRANC,H,BRAN BRAN1: ADD SI,[SI] ; IP:=IP+(IP) JMP NEXT ;=C 0BRANCH branch if f is zero f -- $CODE 87H,0BRANC,H,ZBRAN POP AX OR AX,AX JZ BRAN1 ;f==0, so branch INC SI ;point IP to next word INC SI JMP NEXT ;=C (LOOP) execution time loop code -- $CODE 86H,(LOOP,),XLOOP MOV BX,1 XLOO1: ADD [BP],BX ;R1:=R1+1 MOV AX,[BP] SUB AX,2[BP] ;compare new index to limit XOR AX,BX JS BRAN1 ;branch - keep looping ADD BP,4 ;end of loop, drop R1, R2 INC SI ;skip branch offset INC SI JMP NEXT ;=C (+LOOP) (LOOP) with increment on S1 n -- $CODE 87H,(+LOOP,),XPLOO POP BX JMP XLOO1 ;=C (DO) run-time loop initialization n2 n1 -- $CODE 84H,(DO,),XDO POP DX ;index POP AX ;limit XCHG BP,SP ;put them on the return stack PUSH AX ;R2:=S2 PUSH DX ;R1:=S2 XCHG BP,SP JMP NEXT ;=C I leave index value -- n $CODE 81H,,I,IDO MOV AX,[BP] ;AX:=R1 (index) JMP APUSH ;=C DIGIT convert c to binary using base n1 c n1 -- [n2] f $CODE 85H,DIGI,T,DIGIT POP DX ;base POP AX ;ASCII char SUB AL,'0' JB DIGI2 ;error if c < '0' CMP AL,9 JBE DIGI1 ;number 0-9 SUB AL,7 CMP AL,10 ;number A-Z? JB DIGI2 ;no, error DIGI1: CMP AL,DL JAE DIGI2 ;error if digit > base SUB DX,DX MOV DL,AL ;new binary number MOV AL,1 ;f==TRUE if OK JMP DPUSH DIGI2: SUB AX,AX JMP APUSH ;f==FALSE if error PAGE ;=C* (FIND) dictionary search primtive a1 NFA -- [PFA b] f $CODE 86H,(FIND,),PFIND MOV AX,DS MOV ES,AX ;DI defaults to ES POP BX ;BX:=NFA POP CX ;CX:=a1 ( search string ) PFIN1: MOV DI,CX ;get addr MOV AL,[BX] ;get word length MOV DL,AL XOR AL,[DI] AND AL,3FH ;check lengths+smudge bit JNZ PFIN5 ;lengths differ PFIN2: INC BX ;length matches, check chars INC DI MOV AL,[BX] XOR AL,[DI] ADD AL,AL ;this checks bit 8 JNZ PFIN5 ;chars differ JNB PFIN2 ;OK so far IF _ALIGN ADD BX,6 ;Compute PFA ( could be 5 or 6) AND BX,0FFFEH ;Clear LSB to align ELSE ADD BX,5 ENDIF ;end of word (bit 8 set), a match PUSH BX ;S3:=PFA MOV AX,1 ;f:=TRUE SUB DH,DH ;DX:=length byte JMP DPUSH ;S2:=f, S1:=l ; No match, try the next dictionary entry PFIN5: INC BX ;advance BX to LFA JB PFIN6 ;bit 8 set - must be the end MOV AL,[BX] ADD AL,AL JMP PFIN5 PFIN6: IF _ALIGN INC BX ;This could be one too many... AND BX,0FFFEH ;Clear LSB to align ENDIF MOV BX,[BX] ;BX:=(LFA) OR BX,BX ;start of dictionary? JNZ PFIN1 ;no, keep looking MOV AX,0 ;no match, f:=FALSE JMP APUSH ;S1:=f PAGE ;=C ENCLOSE text scanning primitive a1 c -- a1 n1 n2 n3 $CODE 87H,ENCLOS,E,ENCL POP AX ;delimiter c POP BX ;text addr PUSH BX ;S4:=text addr MOV AH,0 MOV DX,-1 ;DX is counter DEC BX ;BX points to text ; Scan to first non-delimiter ENCL1: INC BX ;next char INC DX ;count it CMP AL,[BX] ;delimiter found? JZ ENCL1 ;not yet, keep looking PUSH DX ;yes, S3:=count CMP AH,[BX] ;found NUL char? JNZ ENCL2 ;no... MOV AX,DX ;yes, n2:=n3 INC DX ;n3:=n3+1 JMP DPUSH ;exit ; Enclose text to first delimiter ENCL2: INC BX INC DX CMP AL,[BX] JZ ENCL4 ;found it... CMP AH,[BX] ;NUL? JNZ ENCL2 ;no, keep looking ; Found NUL at end of text ENCL3: MOV AX,DX JMP DPUSH ; Found delimiter ENCL4: MOV AX,DX ;count to delimiter INC AX ;count to first > delimiter JMP DPUSH ;S2, S1 SUBTTL Input/output primitives PAGE ;=:* EMIT char output c -- $COLON 84H,EMI,T,EMIT DW TICKEMIT, AT, EXEC DW ONE,OUTT DW PSTOR,SEMIS ;=:* KEY char input -- c $COLON 83H,KE,Y,KEY DW TICKEY, AT, EXEC, SEMIS ;=C ?TERMINAL console status -- f $CODE 89H,?TERMINA,L,QTERM JMP PQTER ;=:* CR output carriage return/line feed -- $COLON 82H,C,R,CR DW TICKCR, AT, EXEC, SEMIS SUBTTL PAGE ;=C CMOVE byte block move a1 a2 n -- $CODE 85H,CMOV,E,CMOVE CLD ;count up MOV BX,SI ;save IP POP CX ;move count POP DI ;a2 ( destination ) POP SI ;a1 ( source ) MOV AX,DS MOV ES,AX ;intrasegment only REP MOVSB ;all that for this? MOV SI,BX JMP NEXT ;=C U* unsigned mixed multiply u1 u2 -- ud $CODE 82H,U,*,USTAR POP AX POP BX MUL BX XCHG AX,DX ;S1:=MSW, S2:=LSW JMP DPUSH ;=C U/ unsigned mixed divide ud u -- urem uquot $CODE 82H,U,/,USLAS POP BX ;BX:=divisor POP DX ;DX:=MSW of dividend POP AX ;AX:=LSW CMP DX,BX ;0? JNB DZERO DIV BX JMP DPUSH DZERO: MOV AX,-1 ;divide by zero! leave -1 MOV DX,AX JMP DPUSH ;=C AND bitwise AND n n -- n $CODE 83H,AN,D,ANDD POP AX POP BX AND AX,BX JMP APUSH ;=C OR bitwise OR n n -- n $CODE 82H,O,R,ORR POP AX POP BX OR AX,BX JMP APUSH ;=C XOR bitwise exclusive OR n n -- n $CODE 83H,XO,R,XORR POP AX POP BX XOR AX,BX JMP APUSH ;=C SP@ push current parameter stack pointer -- SP $CODE 83H,SP,@,SPAT MOV AX,SP JMP APUSH ;=C SP! reset parameter stack ? -- $CODE 83H,SP,!!!!,SPSTO MOV BX,UP ;USER variable base addr MOV SP,6[BX] ;S0 is 6 bytes above base JMP NEXT ;=C RP@ push current RP onto parameter stack -- RP $CODE 83H,RP,@,RPAT MOV AX,BP JMP APUSH ;=C RP! reset return stack ? -- $CODE 83H,RP,!!!!,RPSTO MOV BX,UP ;USER variable base addr MOV BP,8[BX] ;offset of R0 is 8 JMP NEXT ;=C ;S end of screen or run time colon word -- $CODE 82H,!!!;,S,SEMIS MOV SI,[BP] ;IP:=R1 - pop return stack INC BP ;adjust RP INC BP JMP NEXT ;=C LEAVE force loop exit -- $CODE 85H,LEAV,E,LEAVE MOV AX,[BP] MOV 2[BP],AX ;limit:=index JMP NEXT ;=C >R push parm. stack to return stack n -- _NFA = $ DB 82H,'>','R'+80H ;macro can't handle it! $LINKS $+2,TOR POP BX ;BX:=S1 DEC BP ;adjust RP DEC BP MOV [BP],BX ;push it JMP NEXT ;=C R> pop return stack to parm. stack -- n $CODE 82H,R,!!!>,FROMR MOV AX,[BP] ;AX:=R1 INC BP ;adjust RP INC BP JMP APUSH ;=C R top of return stack to parm. stack -- n $NAME 81H,,R $LINKS IDO+2,RR ;synonym for I ;=C 0= test top of stack for zero n -- f $CODE 82H,0,=,ZEQU POP AX OR AX,AX MOV AX,1 JZ ZEQU1 DEC AX ZEQU1: JMP APUSH ;=C 0< test top of stack for negative value n -- f $CODE 82H,0,!!!<,ZLESS POP AX OR AX,AX MOV AX,1 JS ZLESS1 DEC AX ZLESS1: JMP APUSH ;=C + 16-bit addition n1 n2 -- nsum $CODE 81H,,+,PLUS POP AX POP BX ADD AX,BX JMP APUSH ;=C D+ 32-bit addition d1 d2 -- dsum $CODE 82H,D,+,DPLUS POP AX ;AX:=d2 MSW POP DX ;DX:=d2 LSW POP BX ;BX:=d1 MSW POP CX ;CX:=d1 LSW ADD DX,CX ;add low words ADC AX,BX ;add high words with carry JMP DPUSH ;=C MINUS 16-bit two's complement n -- -n $CODE 85H,MINU,S,MINUS POP AX NEG AX JMP APUSH ;=C DMINUS 32-bit two's complement d -- -d $CODE 86H,DMINU,S,DMINU POP BX ;MSW POP CX ;LSW SUB AX,AX MOV DX,AX SUB DX,CX ;subtract from 0 SBB AX,BX ;again for high word JMP DPUSH ;=C OVER copy second stack item to top n1 n2 -- n1 n2 n1 $CODE 84H,OVE,R,OVER POP DX POP AX PUSH AX JMP DPUSH ;=C DROP throw out top stack item n -- $CODE 84H,DRO,P,DROP POP AX JMP NEXT ;=C SWAP exchange top two stack items n1 n2 -- n2 n1 $CODE 84H,SWA,P,SWAP POP DX POP AX JMP DPUSH ;=C DUP duplicate the top stack item n -- n n $CODE 83H,DU,P,DUPP POP AX PUSH AX JMP APUSH ;=C 2DUP duplicate the top two stack items n1 n2 -- n1 n2 n1 n2 $CODE 84H,2DU,P,TDUP POP AX POP DX PUSH DX PUSH AX JMP DPUSH ;=C +! add to a memory location n addr -- $CODE 82H,+,!!!!,PSTOR POP BX POP AX ADD [BX],AX JMP NEXT ;=C TOGGLE toggle bits at a memory location n addr -- $CODE 86H,TOGGL,E,TOGGL POP AX POP BX XOR [BX],AL JMP NEXT ;=C @ push memory location to stack addr -- n $CODE 81H,,@,AT POP BX MOV AX,[BX] JMP APUSH ;=C C@ push byte location to stack addr -- b $CODE 82H,C,@,CAT POP BX MOV AL,[BX] SUB AH,AH JMP APUSH ;=C 2@ fetch 32-bit number addr -- d $CODE 82H,2,@,TAT POP BX MOV AX,[BX] ;LSW at addr MOV DX,[BX+2] ;MSW at addr+2 JMP DPUSH ;=C ! pop stack to memory - "store" n addr -- $CODE 81H,,!!!!,STORE POP BX POP AX MOV [BX],AX JMP NEXT ;=C C! byte store - "see-store" b addr -- $CODE 82H,C,!!!!,CSTOR POP BX POP AX MOV [BX],AL JMP NEXT ;=C 2! 32-bit store d addr -- $CODE 82H,2,!!!!,TSTOR POP BX POP AX MOV [BX],AX ;move LSW to addr POP AX MOV 2[BX],AX ;move MSW to addr+2 JMP NEXT SUBTTL Defining words PAGE ;=C : begin colon definition -- $COLON 0C1H,,: DW QEXEC, SCSP ;compile time code DW CURR, AT DW CONT, STORE DW CREAT, RBRAC DW PSCOD ;run time code DOCOL: INC DX ;W:=W+1 DEC BP DEC BP ;RP:=RP-2 MOV [BP],SI ;push IP onto return stack MOV SI,DX ;IP:=W JMP NEXT ;=: ; end colon definition -- $COLON 0C1H,,!!!; DW QCSP, COMP DW SEMIS, SMUDG DW LBRAC, SEMIS ;=: NOOP do nothing - no operation -- $COLON 84H,NOO,P,NOOP DW SEMIS ;=: CONSTANT define a symbolic constant n -- $COLON 88H,CONSTAN,T,CON DW CREAT, SMUDG ;compile time code DW COMMA, PSCOD ;run time code DOCON: INC DX ;point W to PFA MOV BX,DX MOV AX,[BX] ;get data at PFA JMP APUSH ;here it is! ;=: VARIABLE define a symbolic variable n -- $COLON 88H,VARIABL,E DW CON, PSCOD ;compile time code ;run time code DOVAR: INC DX ;point W to PFA PUSH DX ;return PFA JMP NEXT ;=: USER define a user variable n -- $COLON 84H,USE,R DW CON, PSCOD ;compile time code ;run time code DOUSE: INC DX ;point W to PFA MOV BX,DX ;BX:=(PFA) offset MOV BL,[BX] ;BX:=(PFA) offset<256 SUB BH,BH ;just to be safe... MOV DI,UP ;DI:=UP (user area base addr) LEA AX,[BX+DI] ;load effective address JMP APUSH ;push address to stack $REPORT <Code-level kernel completed> SUBTTL Constants and USER variables PAGE + ;=# 0 zero -- 0 $CONST 81H,,0,ZERO DW 0 ;=# 1 one -- 1 $CONST 81H,,1,ONE DW 1 ;=# 2 two -- 2 $CONST 81H,,2,TWO DW 2 ;=# 3 three -- 3 $CONST 81H,,3,THREE DW 3 ;=# BL ASCII blank -- 32 $CONST 82H,B,L,BLS DW 20H ;=# C/L characters per line -- 64 $CONST 83H,C/,L,CSLL DW 64 ;=# FIRST address of lowest disk buffer -- addr $CONST 85H,FIRS,T,FIRST DW BUF1 ;=# LIMIT last available memory address + 1 -- addr $CONST 85H,LIMI,T,LIMIT DW EM ;=# B/BUF size of disk buffers in bytes -- 1024 $CONST 85H,B/BU,F,BBUF DW BUFSIZE ;=# B/SCR number of disk buffers per screen -- 1 $CONST 85H,B/SC,R,BSCR DW 1 SUBTTL PAGE + ;=: +ORIGIN word for accessing data in low memory n -- addr $COLON 87H,+ORIGI,N,PORIG DW LIT, ORIG DW PLUS, SEMIS SUBTTL USER variables PAGE + ;=U S0 parameter stack base -- addr $USER 82H,S,0,SZERO DW 6 ;offset in user area ;=U R0 return stack base -- addr $USER 82H,R,0,RZERO DW 8 ;=U TIB Terminal Input Buffer address -- addr $USER 83H,TI,B,TIB DW 10 ;=U WIDTH maximum length of word names -- addr $USER 85H,WIDT,H,NWIDTH DW 12 ;=U WARNING switch for error processing: 0, 1, -1 -- addr $USER 87H,WARNIN,G,WARN DW 14 ;=U FENCE pointer to protected dictionary -- addr $USER 85H,FENC,E,FENCE DW 16 ;=U DP top address used in dictionary -- addr $USER 82H,D,P,DP DW 18 ;=U VOC-LINK pointer to top vocabulary -- addr $USER 88H,VOC-LIN,K,VOCL DW 20 ;The following user variables hold CFA's for their ;respective logical functions ;=U+ @KEY CFA of function to do character input -- addr $USER 84H,@KE,Y,TICKEY DW 22 ;=U+ @EMIT CFA of function to do character output -- addr $USER 85H,@EMI,T,TICKEMIT DW 24 ;=U+ @CR CFA of function to output newline -- addr $USER 83H,@C,R,TICKCR DW 58 ;=U+ @BLKRD CFA of function to read one block -- addr $USER 86H,@BLKR,D,TICKBRD DW 26 ;=U+ @BLKWRT CFA of function to write one block -- addr $USER 87H,@BLKWR,T,TICKBWRT DW 28 ;=U BLK current block, 0 if terminal -- addr $USER 83H,BL,K,BLK DW 30 ;=U IN current character in input stream -- addr $USER 82H,I,N,INN DW 32 ;=U OUT count of characters output -- addr $USER 83H,OU,T,OUTT DW 34 ;=U SCR current screen -- addr $USER 83H,SC,R,SCR DW 36 ;=U OFFSET number of lowest block to be used -- addr $USER 86H,OFFSE,T,OFSET DW 38 ;=U CONTEXT current vocabulary for execution -- addr $USER 87H,CONTEX,T,CONT DW 40 ;=U CURRENT current vocabulary for definitions -- addr $USER 87H,CURREN,T,CURR DW 42 ;=U STATE current interpreter state -- addr $USER 85H,STAT,E,STATE DW 44 ;=U BASE current number base for i/o -- addr $USER 84H,BAS,E,BASE DW 46 ;=U DPL Decimal Point Locator -- addr $USER 83H,DP,L,DPL DW 48 ;=U CSP temporary storage for Current SP -- addr $USER 83H,CS,P,CSPP DW 52 ;=U R# current editing cursor location -- addr $USER 82H,R,#,RNUM DW 54 ;=U HLD text pointer used in number formatting -- addr $USER 83H,HL,D,HLD DW 56 $REPORT <Constants and user variables completed> SUBTTL FORTH definitions PAGE + ;=C 1+ increment the top stack item n -- n+1 $CODE 82H,1,+,ONEP POP AX INC AX JMP APUSH ;=C 2+ add 2 to the top stack item n -- n+2 $CODE 82H,2,+,TWOP POP AX INC AX INC AX JMP APUSH ;=C+ 1- decrement the top stack item n -- n-1 $CODE 82H,1,-,ONEM POP AX DEC AX JMP APUSH ;=C+ 2- subtract 2 from the top stack item n -- n-2 $CODE 82H,2,-,TWOM POP AX DEC AX DEC AX JMP APUSH ;=: HERE next available dictionary location -- addr $COLON 84H,HER,E,HERE DW DP, AT, SEMIS ;=: ALLOT reserve n bytes in the dictionary n -- $COLON 85H,ALLO,T,ALLOT DW DP, PSTOR, SEMIS ;=: , compile n into the dictionary n -- $COLON 81H,,!!!,,COMMA DW HERE, STORE DW TWO, ALLOT, SEMIS ;=: C, compile a byte into the dictionary b -- $COLON 82H,C,!!!,,CCOMM DW HERE, CSTOR DW ONE, ALLOT, SEMIS ;=C - 16-bit subtraction n1 n2 -- n1-n2 $CODE 81H,,-,SUBB POP DX POP AX SUB AX,DX JMP APUSH ;=: = test top two items for equality n1 n2 -- f $COLON 81H,,=,EQUAL DW SUBB, ZEQU, SEMIS ;=C < test for top number > second number n1 n2 -- f $CODE 81H,,!!!<,LESS POP DX POP AX MOV BX,DX XOR BX,AX JS LES1 ;signs different SUB AX,DX LES1: OR AX,AX ;test sign bit MOV AX,0 ;assume false JNS LES2 ;not less than INC AX ;return true (1) LES2: JMP APUSH ;=: U< unsigned test for top > next item u1 u2 -- f $COLON 82H,U,!!!<,ULESS DW TDUP, XORR, ZLESS $GO?0 ULES1 DW DROP, ZLESS, ZEQU $GOTO ULES2 ULES1: DW SUBB, ZLESS ULES2: DW SEMIS ;=: > test for second item > top of stack n1 n2 -- f $COLON 81H,,!!!>,GREAT DW SWAP, LESS, SEMIS ;=C ROT bring the third stack item to top n1 n2 n3 -- n2 n3 n1 $CODE 83H,RO,T,ROT POP DX POP BX POP AX PUSH BX JMP DPUSH ;=: SPACE output a blank -- $COLON 85H,SPAC,E,SPACE DW BLS, EMIT, SEMIS ;=: -DUP duplicate the top number if it isn't 0 n -- n [n] $COLON 84H,-DU,P,DDUP DW DUPP $GO?0 DDUP1 DW DUPP DDUP1: DW SEMIS ;=: TRAVERSE move across a fig-FORTH name field addr1 n -- addr2 $COLON 88H,TRAVERS,E,TRAV DW SWAP TRAV1: DW OVER, PLUS DW LIT, 7FH DW OVER, CAT, LESS $GO?0 TRAV1 DW SWAP, DROP, SEMIS ;=: LATEST return the top NFA in CURRENT -- NFA $COLON 86H,LATES,T,LATES DW CURR, AT, AT, SEMIS ;=: LFA convert a PFA to LFA PFA -- LFA $COLON 83H,LF,A,LFA DW LIT, 4 DW SUBB, SEMIS ;=: CFA convert a PFA to CFA PFA -- CFA $COLON 83H,CF,A,CFA DW TWO, SUBB, SEMIS ;=:* NFA convert a PFA to NFA PFA -- NFA $COLON 83H,NF,A,NFA DW LIT, 5 DW SUBB IF _ALIGN DW DUPP, CAT DW LIT, 90H, EQUAL ;90H==NOP! $GO?0 NFA1 DW ONEM NFA1: ENDIF DW LIT, -1 DW TRAV, SEMIS ;=:* PFA convert a NFA to PFA NFA -- PFA $COLON 83H,PF,A,PFA DW ONE, TRAV IF _ALIGN DW LIT, 6, PLUS DW LIT, -2, ANDD ELSE DW LIT, 5, PLUS ENDIF DW SEMIS ;=: !CSP save SP at CSP -- $COLON 84H,!!!!CS,P,SCSP DW SPAT, CSPP DW STORE, SEMIS ;=: ?ERROR issue error message m if f is TRUE f m -- $COLON 86H,?ERRO,R,QERR DW SWAP $GO?0 QERR1 DW ERROR $GOTO QERR2 QERR1: DW DROP QERR2: DW SEMIS ;=: ?COMP issue a message if not compiling -- $COLON 85H,?COM,P,QCOMP DW STATE, AT DW ZEQU, LIT, 17 DW QERR, SEMIS ;=: ?EXEC issue a message if not executing -- $COLON 85H,?EXE,C,QEXEC DW STATE, AT DW LIT, 18 DW QERR, SEMIS ;=: ?PAIRS issue a message if n1 <> n2 n1 n2 -- $COLON 86H,?PAIR,S,QPAIR DW SUBB DW LIT, 19 DW QERR, SEMIS ;=: ?CSP issue a message if SP <> (CSP) -- $COLON 84H,?CS,P,QCSP DW SPAT, CSPP, AT, SUBB DW LIT, 20 DW QERR, SEMIS ;=: ?LOADING issue a message if not loading -- $COLON 88H,?LOADIN,G,QLOAD DW BLK, AT, ZEQU DW LIT, 22 DW QERR, SEMIS ;=: COMPILE compile the following word at run time -- $COLON 87H,COMPIL,E,COMP DW QCOMP DW FROMR, DUPP, TWOP, TOR DW AT, COMMA, SEMIS ;=: [ suspend compilation to do calculations -- $COLON 0C1H,,[,LBRAC DW ZERO, STATE, STORE, SEMIS ;=: ] resume compilation after [ -- $COLON 81H,,],RBRAC DW LIT, 0C0H DW STATE, STORE, SEMIS ;=: SMUDGE make the latest definition unFINDable -- $COLON 86H,SMUDG,E,SMUDG DW LATES DW LIT, 20H DW TOGGL, SEMIS ;=: HEX set the current number base to 16 -- $COLON 83H,HE,X DW LIT, 16 DW BASE, STORE, SEMIS ;=: DECIMAL set the current number base to 10 -- $COLON 87H,DECIMA,L,DECA DW LIT, 10 DW BASE, STORE, SEMIS ;=: (;CODE) run time code for ;CODE -- $COLON 87H,(!!!;CODE,),PSCOD DW FROMR, LATES, PFA DW CFA, STORE, SEMIS ;=: ;CODE end colon compilation, start CODE -- $COLON 0C5H,!!!;COD,E,SEMIC DW QCSP DW COMP, PSCOD, LBRAC SEMI1 DW NOOP ; (ASSEMBLER) DW SEMIS ;=: <BUILDS define compile time behavior -- $COLON 87H,!!!<BUILD,S,BUILD DW ZERO, CON, SEMIS ;=: DOES> define run time behavior -- $COLON 85H,DOES,!!!>,DOES DW FROMR, LATES, PFA, STORE DW PSCOD DODOE: XCHG BP,SP ;get RP PUSH SI ;RP:=IP XCHG BP,SP INC DX ;point W to PFA MOV BX,DX MOV SI,[BX] ;IP:=(PFA) INC DX INC DX ;W points to PFA PUSH DX JMP NEXT ;=: COUNT prepare to type a string addr -- addr+1 n $COLON 85H,COUN,T,COUNT DW DUPP, ONEP, SWAP, CAT, SEMIS ;=: TYPE output n characters beginning at addr addr n -- $COLON 84H,TYP,E,TYPES DW DDUP $GO?0 TYPE1 DW OVER, PLUS DW SWAP, XDO TYPE2: DW IDO, CAT, EMIT $LOOP TYPE2 $GOTO TYPE3 TYPE1: DW DROP TYPE3: DW SEMIS ;=: -TRAILING adjust addr/n to avoid trailing blanks addr n1 -- addr n2 $COLON 89H,-TRAILIN,G,DTRAI DW DUPP, ZERO, XDO DTRA1: DW OVER, OVER, PLUS DW ONE, SUBB, CAT DW BLS, SUBB $GO?0 DTRA2 DW LEAVE $GOTO DTRA3 DTRA2: DW ONE, SUBB DTRA3: $LOOP DTRA1 DW SEMIS ;=: (.") run time code for ." -- $COLON 84H,(.!!!",),PDOTQ DW RR DW COUNT, DUPP, ONEP DW FROMR, PLUS, TOR DW TYPES, SEMIS ;=: ." print the following string -- $COLON 0C2H,.,!!!",DOTQ DW LIT, '"' DW STATE, AT $GO?0 DOTQ1 DW COMP DW PDOTQ, WORDS, HERE DW CAT, ONEP, ALLOT $GOTO DOTQ2 DOTQ1: DW WORDS, HERE, COUNT, TYPES DOTQ2: DW SEMIS ;=: EXPECT input up to n characters to addr addr n -- $COLON 86H,EXPEC,T,EXPEC DW OVER, PLUS, OVER DW XDO EXPE1: DW KEY, DUPP DW LIT, 0EH DW PORIG, AT, EQUAL $GO?0 EXPE2 DW DROP, DUPP, IDO DW EQUAL, DUPP, FROMR DW TWO, SUBB, PLUS DW TOR $GO?0 EXPE6 DW LIT, BELL $GOTO EXPE7 EXPE6: DW LIT, BSOUT, EMIT DW BLS, EMIT DW LIT, BSOUT EXPE7: $GOTO EXPE3 EXPE2: DW DUPP, LIT, ACR DW EQUAL $GO?0 EXPE4 DW LEAVE, DROP, BLS, ZERO $GOTO EXPE5 EXPE4: DW DUPP EXPE5: DW IDO DW CSTOR, ZERO, IDO, ONEP DW STORE EXPE3: DW EMIT $LOOP EXPE1 DW DROP, SEMIS ;=: QUERY EXPECT 80 characters to TIB -- $COLON 85H,QUER,Y,QUERY DW TIB, AT DW LIT, 80, EXPEC DW ZERO, INN, STORE, SEMIS ;=: <nul> 0 in input: resets interpreter -- _NFA = $ DB 0C1H,80H ;zero header $LINKS DOCOL DW BLK, AT $GO?0 NULL1 DW ONE, BLK, PSTOR DW ZERO, INN, STORE DW BLK, AT DW BSCR, ONE, SUBB, ANDD DW ZEQU $GO?0 NULL2 DW QEXEC, FROMR, DROP NULL2: $GOTO NULL3 NULL1: DW FROMR, DROP NULL3: DW SEMIS ;=C FILL fill n bytes at address with c addr n c -- $CODE 84H,FIL,L,FILL POP AX ;fill char POP CX ;fill count POP DI ;destination address MOV BX,DS MOV ES,BX ;same segment CLD ;fill toward higher address REP STOSB ;GO! JMP NEXT ;=: ERASE fill n bytes at addr with 0's addr n -- $COLON 85H,ERAS,E,ERASEE DW ZERO, FILL, SEMIS ;=: BLANKS fill n bytes at addr with blanks addr n -- $COLON 86H,BLANK,S,BLANK DW BLS, FILL, SEMIS ;=: HOLD insert char in formatted output c -- $COLON 84H,HOL,D,HOLD DW LIT, -1 DW HLD, PSTOR DW HLD, AT, CSTOR, SEMIS ;=: PAD returns addr of the text output buffer -- addr $COLON 83H,PA,D,PAD DW HERE, LIT, 68, PLUS, SEMIS DW PLUS, SEMIS ;=: WORD get a word delimited by char to HERE c -- $COLON 84H,WOR,D,WORDS DW BLK, AT $GO?0 WORD1 DW BLK, AT, BLOCK $GOTO WORD2 WORD1: DW TIB, AT WORD2: DW INN, AT, PLUS, SWAP DW ENCL, HERE DW LIT, 34 DW BLANK, INN, PSTOR DW OVER, SUBB, TOR DW RR, HERE, CSTOR DW PLUS, HERE, ONEP DW FROMR, CMOVE, SEMIS ;=: (NUMBER) ASCII to binary conversion primitive d1 addr1 -- d2 addr2 $COLON 88H,(NUMBER,),PNUMB PNUM1: DW ONEP DW DUPP, TOR DW CAT, BASE, AT, DIGIT $GO?0 PNUM2 DW SWAP, BASE, AT, USTAR DW DROP, ROT, BASE, AT DW USTAR, DPLUS DW DPL, AT, ONEP $GO?0 PNUM3 DW ONE, DPL, PSTOR PNUM3: DW FROMR $GOTO PNUM1 PNUM2: DW FROMR, SEMIS ;=: NUMBER convert string at addr to 32-bit number addr -- d $COLON 86H,NUMBE,R,NUMB DW ZERO, ZERO DW ROT, DUPP, ONEP, CAT DW LIT, "-", EQUAL DW DUPP, TOR, PLUS DW LIT, -1 NUMB1: DW DPL, STORE DW PNUMB DW DUPP, CAT, BLS, SUBB $GO?0 NUMB2 DW DUPP, CAT DW LIT, ".", SUBB DW ZERO, QERR, ZERO $GOTO NUMB1 NUMB2: DW DROP, FROMR $GO?0 NUMB3 DW DMINU NUMB3: DW SEMIS ;=: -FIND search dictionary for next input word -- [PFA b] f $COLON 85H,-FIN,D,DFIND DW BLS, WORDS DW HERE, CONT, AT, AT DW PFIND, DUPP, ZEQU $GO?0 DFIN1 DW DROP DW HERE, LATES, PFIND DFIN1: DW SEMIS ;=: (ABORT) error function when WARNING is -1 -- $COLON 87H,(ABORT,),PABOR DW ABORT, SEMIS ;=: ERROR system error handler - n is line no. n -- [IN BLK] $COLON 85H,ERRO,R,ERROR DW WARN, AT, ZLESS $GO?0 ERRO1 DW PABOR ERRO1: DW HERE, COUNT, TYPES DW PDOTQ DB 2,"? " DW MESS DW SPSTO DW BLK, AT, DDUP $GO?0 ERRO2 DW INN, AT, SWAP ERRO2: DW QUIT ;=: ID. print dictionary name field NFA -- $COLON 83H,ID,.,IDDOT DW PAD DW LIT, 32 DW LIT, '_' DW FILL DW DUPP, PFA, LFA DW OVER, SUBB DW PAD, SWAP, CMOVE DW PAD, COUNT DW LIT, 1FH ;use low 5 bits of length ;Last char of name must have MSB reset! DW ANDD, DUPP, PAD, PLUS DW LIT, 80H, TOGGL DW TYPES, SPACE, SEMIS DW ANDD, TYPES, SPACE, SEMIS ;=:* CREATE create a dictionary header -- $COLON 86H,CREAT,E,CREAT DW DFIND $GO?0 CREA1 DW DROP, NFA, IDDOT DW LIT, 4, MESS ;"not unique" DW SPACE CREA1: DW HERE, DUPP, CAT DW NWIDTH, AT, MIN DW ONEP, ALLOT DW DUPP DW LIT, 0A0H DW TOGGL ;smudge it DW HERE, ONE, SUBB DW LIT, 80H DW TOGGL ;last char has bit 8 set IF _ALIGN ;This section of code forces the body of a compiled FORTH word to ;lie on even addresses. This allows the threaded CFA's to be ;fetched by the inner interpreter in one bus cycle. For the 8088 ;this means nothing, and the extra space required for alignment ;should be saved by setting _ALIGN to FALSE. The literal 90H is ;used because MASM uses NOP's to align words. NFA expects ;90H to be used also. DW LIT, 90H, CCOMM DW DP, AT DW LIT, -2, ANDD DW DP, STORE ENDIF DW LATES, COMMA ;compile LFA DW CURR, AT, STORE ;update vocabulary DW HERE, TWOP, COMMA, SEMIS ;CFA:=PFA ;=: [COMPILE] compile an otherwise immediate word -- $COLON 0C9H,[COMPILE,] DW DFIND DW ZEQU, ZERO, QERR DW DROP, CFA, COMMA, SEMIS ;=: LITERAL compile n to be used at run time n -- $COLON 0C7H,LITERA,L,LITER DW STATE, AT $GO?0 LITE1 DW COMP, LIT, COMMA LITE1: DW SEMIS ;=: DLITERAL compile d to be used at run time d -- $COLON 0C8H,DLITERA,L,DLITE DW STATE, AT $GO?0 DLIT1 DW SWAP, LITER, LITER DLIT1: DW SEMIS ;=: ?STACK check if the stack is out of bounds -- $COLON 86H,?STAC,K,QSTAC DW SPAT, SZERO, AT DW SWAP, ULESS, ONE, QERR ;underflow DW SPAT, HERE DW LIT, 80H DW PLUS, ULESS DW LIT, 7 DW QERR ;overflow DW SEMIS ;=: INTERPRET outer text interpreter -- $COLON 89H,INTERPRE,T,INTER INTE1: DW DFIND ;begin $GO?0 INTE2 DW STATE, AT, LESS $GO?0 INTE3 DW CFA, COMMA ;compile it $GOTO INTE4 INTE3: DW CFA, EXEC ;execute it INTE4: DW QSTAC $GOTO INTE5 INTE2: DW HERE, NUMB, DPL, AT, ONEP $GO?0 INTE6 DW DLITE ;32-bit number $GOTO INTE7 INTE6: DW DROP, LITER ;16-bit number INTE7: DW QSTAC INTE5: $GOTO INTE1 ;repeat forever ;=: IMMEDIATE mark the latest word to be executed -- $COLON 89H,IMMEDIAT,E DW LATES DW LIT, 40H ;bit 7 is precedence DW TOGGL, SEMIS ;=: VOCABULARY define a new vocabulary -- $COLON 8AH,VOCABULAR,Y DW BUILD DW LIT, 0A081H DW COMMA DW CURR, AT DW CFA, COMMA, HERE, VOCL DW AT, COMMA, VOCL, STORE DW DOES DOVOC: DW TWOP, CONT, STORE, SEMIS ;=: FORTH FORTH vocabulary header -- $DOES 0C5H,FORT,H,FORTH DW DOVOC DW 0A081H ;fake a null name field! DW LASTNFA ;link changes as def's are added DW 0 ;end of voc list ;=: DEFINITIONS set CURRENT to CONTEXT -- $COLON 8BH,DEFINITION,S,DEFIN DW CONT, AT DW CURR, STORE, SEMIS ;=: ( begin a comment ended by ')' -- $COLON 0C1H,,( DW LIT, ')', WORDS, SEMIS ;=: QUIT halt execution, reset interpreter -- $COLON 84H,QUI,T,QUIT DW ZERO, BLK, STORE DW LBRAC QUIT1: DW RPSTO, CR, QUERY DW INTER DW STATE, AT, ZEQU $GO?0 QUIT2 DW PDOTQ DB 2,"ok" QUIT2: $GOTO QUIT1 ;=: ABORT clear stacks and begin execution -- $COLON 85H,ABOR,T,ABORT DW SPSTO, DECA, QSTAC, CR DW DOTCPU, PDOTQ DB 16H,'Fig-FORTH Version ' DB FIGREL+30H, '.', FIGREV+30H DW LIT, 10, PORIG, CAT DW LIT, 41H, PLUS, EMIT DW FORTH, DEFIN DW LIT, 0, PRTER, STORE ;Reset echo ; The following lines add command line interpretation. ; Any text at 80H is copied to the TIB and interpreted. ; This code should probably go somewhere else, but I never bothered ; to move it... DW LIT, 80H, COUNT, DUPP ;anyone here? $GO?0 AB1 ;no... DW ZERO, LIT, 80H, CSTOR ;don't do twice DW TIB, AT, DUPP DW LIT, 64, ERASEE ;ensure NUL end DW SWAP, CMOVE ;move it DW ZERO, INN, STORE DW ZERO, BLK, STORE, LBRAC DW CR, CR, INTER ;interpret it $GOTO AB2 AB1: DW DROP, DROP ;nothing to do AB2: DW QUIT ;back to normal ; Warm start vector comes here WRM: MOV SI,OFFSET WRM1 JMP NEXT WRM1 DW WARM ;=: WARM empty disk buffers and abort -- $COLON 84H,WAR,M,WARM DW MTBUF, ABORT ; Cold start vector comes here CLD: MOV SI,OFFSET CLD1 ;initialize IP MOV AX,CS MOV DS,AX ;all in one segment MOV SP,12H[ORIG] ;initialize SP MOV SS,AX MOV ES,AX CLD ;SI gets incremented MOV BP,RPP ;init RP CALL NEAR PTR SYSINIT ;system dependent initialization JMP NEXT CLD1 DW COLD ;=:* COLD full initialization and restart -- $COLON 84H,COL,D,COLD DW DRZER, MTBUF DW FIRST, USE, STORE DW FIRST, PREV, STORE DW LIT, ORIG+12H DW LIT, UP, AT DW LIT, 6, PLUS DW LIT, 16, CMOVE ;USER variables DW LIT, ORIG+12,AT DW LIT, FORTH+6,STORE ;vocabulary link ; Initialize i/o vectors DW LIT, PKEY, TICKEY, STORE DW LIT, PEMIT, TICKEMIT, STORE DW LIT, PCR, TICKCR, STORE DW LIT, BLKRD, TICKBRD, STORE DW LIT, BLKWRT, TICKBWRT, STORE DW ABORT ;=C S->D convert a 16-bit number to 32-bits n -- d _NFA = $ DB 84H,'S->','D'+80H $LINKS $+2,STOD POP DX ;n, becomes LSW of result SUB AX,AX OR DX,DX ;is n negative? JNS STOD1 ;no, MSW:=AX=0 DEC AX ;yes, MSW:=-1 STOD1: JMP DPUSH ;S1=MSW, S2=LSW ;=: +- apply the sign of n2 to n1 n1 n2 -- n3 $COLON 82H,+,-,PM DW ZLESS $GO?0 PM1 DW MINUS PM1: DW SEMIS ;=: D+- apply the sign of n to d1 d1 n -- d2 $COLON 83H,D+,-,DPM DW ZLESS $GO?0 DPM1 DW DMINU DPM1: DW SEMIS ;=: ABS take the absolute value of n1 n1 -- n2 $COLON 83H,AB,S,ABBS DW DUPP, PM, SEMIS ;=: DABS take the absolute value of d1 d1 -- d2 $COLON 84H,DAB,S,DABS DW DUPP, DPM, SEMIS ;=: MIN return the smaller of n1 and n2 n1 n2 -- n $COLON 83H,MI,N,MIN DW TDUP, GREAT $GO?0 MIN1 DW SWAP MIN1: DW DROP, SEMIS ;=: MAX return the larger of two numbers n1 n2 -- n $COLON 83H,MA,X,MAX DW TDUP, LESS $GO?0 MAX1 DW SWAP MAX1: DW DROP, SEMIS ;=: M* mixed multiplication n1 n2 -- d $COLON 82H,M,*,MSTAR DW TDUP, XORR, TOR DW ABBS DW SWAP, ABBS, USTAR DW FROMR, DPM, SEMIS ;=: M/ mixed division d n1 -- nrem nquot $COLON 82H,M,/,MSLAS DW OVER, TOR, TOR DW DABS DW RR, ABBS, USLAS DW FROMR, RR, XORR DW PM, SWAP, FROMR DW PM, SWAP, SEMIS ;=: * 16-bit signed multipication n1 n2 -- n1*n2 $COLON 81H,,*,STAR DW MSTAR, DROP, SEMIS ;=: /MOD 16-bit signed division with remainder n1 n2 -- nrem nquot $COLON 84H,/MO,D,SLMOD DW TOR, STOD, FROMR DW MSLAS, SEMIS ;=: / 16-bit signed division n1 n2 -- nquot $COLON 81H,,/,SLASH DW SLMOD, SWAP, DROP, SEMIS ;=: MOD 16-bit modulo division n1 n2 -- nrem $COLON 83H,MO,D,MODD DW SLMOD, DROP, SEMIS ;=: */MOD scale n1 by the ratio of n2 to n3 n1 n2 n3 -- nrem nquot $COLON 85H,*/MO,D,SSMOD DW TOR, MSTAR, FROMR DW MSLAS, SEMIS ;=: */ scale n1 by the ratio of n2 to n3 n1 n2 n3 -- nquot $COLON 82H,*,/,SSLA DW SSMOD, SWAP, DROP, SEMIS ;=: M/MOD mixed unsigned scaler ud1 u -- urem udquot $COLON 85H,M/MO,D,MSMOD DW TOR, ZERO, RR, USLAS DW FROMR, SWAP, TOR DW USLAS, FROMR, SEMIS ;=: (LINE) convert a line/screen to addr/count l s -- addr count $COLON 86H,(LINE,),PLINE DW TOR DW LIT, 64 DW BBUF, SSMOD DW FROMR, BSCR, STAR DW PLUS DW BLOCK, PLUS DW LIT, 64, SEMIS ;=: .LINE type line n1 in screen n2 n1 n2 -- $COLON 85H,.LIN,E,DLINE DW PLINE, DTRAI, TYPES, SEMIS ;=: MESSAGE type error message n n -- $COLON 87H,MESSAG,E,MESS DW WARN, AT $GO?0 MESS1 DW DDUP $GO?0 MESS2 DW LIT, 4 DW OFSET, AT, BSCR, SLASH DW SUBB, DLINE, SPACE MESS2: $GOTO MESS3 MESS1: DW PDOTQ DB 6,"MSG # " DW DOT MESS3: DW SEMIS $REPORT <FORTH kernel completed> INCLUDE 4TH-SYSD.ASM ;System dependent code SUBTTL Disk interface words PAGE + ;=? DRIVE disk drive last accessed -- addr $VAR 85H,DRIV,E,DRIVE DW 0 ;=?+ RECORD disk record last accessed -- addr $VAR 86H,RECOR,D,REC DW 0 ;=?+ DTA disk transfer address last used -- addr $VAR 83H,DT,A,DTA DW FIRST ;=? USE pointer to disk buffer to use next -- addr $VAR 83H,US,E,USE DW BUF1 ;=? PREV pointer to disk buffer last accessed -- addr $VAR 84H,PRE,V,PREV DW BUF1 ;=# #BUFF total number of block buffers -- n $CONST 85H,#BUF,F,NOBUF DW NSCR ;=? DISK-ERROR status of last disk operation -- addr $VAR 8AH,DISK-ERRO,R,DSKERR DW 0 ;=?* PRINTER flag controlling printer -- addr $VAR 87H,PRINTE,R,PRTER DW 0 ;Block read/write words modified to use execution vectors. ;The functions called by BLOCK-READ/-WRITE have the following stack ;effect: ( addr blk -- ) and set DISK-ERROR accordingly. ;=:+ BLOCK-READ read one block to addr addr blk -- $COLON 8AH,BLOCK-REA,D,BLOCKRD DW TICKBRD, AT, EXEC, SEMIS ;=:+ BLOCK-WRITE write one block from addr addr blk -- $COLON 8BH,BLOCK-WRIT,E,BLOCKWRT DW TICKBWRT, AT, EXEC, SEMIS ;=:* +BUF advance addr to next buffer addr1 -- addr2 $COLON 84H,+BU,F,PBUF DW BBUF, TWOP, TWOP ;B/BUF+4 DW PLUS, DUPP, LIMIT, EQUAL $GO?0 PBUF1 DW DROP, FIRST PBUF1: DW DUPP, PREV, AT DW SUBB, SEMIS ;=: UPDATE mark PREV buffer to be saved -- $COLON 86H,UPDAT,E,UPDAT DW PREV, AT, AT DW LIT, 8000H DW ORR DW PREV, AT, STORE, SEMIS ;=:* EMPTY-BUFFERS wipe out disk buffers -- $COLON 8DH,EMPTY-BUFFER,S,MTBUF DW FIRST, LIMIT, OVER DW SUBB, ERASEE ;Modified so that emptied buffers won't look like block 0: ;instead, they're all assigned to block 32767. If you want to ;use FORTH on a disk that big - TOO BAD! DW LIT, 7FFFH DW NOBUF, ONEP, ZERO, XDO MTBUF1: DW DUPP, BUFFE, DROP $LOOP MTBUF1 DW DROP, SEMIS ;Words added to save buffers: ;=:+ SAVBUF saves buffer at addr if updated addr -- $COLON 86H,SAVBU,F,SAVBUF DW DUPP, TOR, AT, ZLESS $GO?0 SVBF1 ;not updated, return DW RR, TWOP, RR, AT DW LIT, 7FFFH, ANDD ;15-bits only! DW ZERO, RSLW ;write it DW DSKERR, AT, ZEQU $GO?0 SVBF1 ;don't un-update if error DW RR, ONEP ;high byte! DW LIT, 80H, TOGGL ;un-update buffer SVBF1: DW FROMR, DROP, SEMIS ;=:+ SAVE-BUFFERS flush buffers but don't empty -- $COLON 8CH,SAVE-BUFFER,S,SAVBUFS DW PREV, AT SVBFS1: DW PBUF, OVER, SAVBUF, ZEQU $GO?0 SVBFS1 DW DROP, SEMIS ;=:* BUFFER assign an available buffer to block n n -- addr ;BUFFER changed to write out ALL dirty buffers when one is found. $COLON 86H,BUFFE,R,BUFFE DW USE, AT, DUPP, TOR BUFF1: DW PBUF $GO?0 BUFF1 ;dont use PREV DW USE, STORE ;use this one NEXT! DW RR, AT, ZLESS ;found a dirty one? $GO?0 BUFF2 ;no DW SAVBUFS ;yes, save ALL BUFF2: DW RR, STORE ;set header to n DW RR, PREV, STORE ;this is now PREV DW FROMR, TWOP, SEMIS ;leave data addr ;=:* BLOCK get block n n -- addr $COLON 85H,BLOC,K,BLOCK DW OFSET, AT, PLUS, TOR ;get n+offset DW PREV, AT, DUPP ;look in PREV first DW AT, RR, SUBB DW DUPP, PLUS ;throw out high bit $GO?0 BLOC1 ;n is in PREV BLOC2: DW PBUF, ZEQU ;check next buffer $GO?0 BLOC3 ;found it DW DROP, RR ;not in buffer DW BUFFE, DUPP ;get a buffer DW RR, ONE, RSLW ;read blk DW TWO, SUBB ;leave buffer addr BLOC3: DW DUPP, AT, RR, SUBB ;check the buffer DW DUPP, PLUS, ZEQU $GO?0 BLOC2 DW DUPP, PREV, STORE ;either found it or read it BLOC1: DW FROMR, DROP ;return DW TWOP, SEMIS ;T&SCALC now done by D&RCALC in SYSD.ASM file... ;=:* R/W block read/write, f=1=write, f=2=read addr blk f -- $COLON 83H,R/,W,RSLW ;Modified to simply pass the address and blk to the R/W functions $GO?0 RSLW1 DW BLOCKRD $GOTO RSLW2 RSLW1: DW BLOCKWRT RSLW2: DW DSKERR, AT, DDUP $GO?0 RSLW5 ;OK DW ZLESS $GO?0 RSLW3 DW LIT, 9 ;Write error $GOTO RSLW4 RSLW3: DW LIT, 8 ;Read error RSLW4: DW LIT, 7FFFH ;Set buffer to 32767 DW PREV, AT, STORE ; to mark as bad DW WARN, AT, ZLESS ;If WARNING<0 then $GO?0 RSLW6 ;assume he can handle it $GOTO RSLW7 ;otherwise, RSLW6: DW ZERO, WARN, STORE ;don't try to read! RSLW7: DW QERR RSLW5: DW SEMIS ;=:* FLUSH empty buffers, saving changed ones -- $COLON 85H,FLUS,H,FLUSH DW NOBUF, ONEP DW ZERO, XDO FLUS1: DW LIT, 7FFFH, BUFFE, DROP $LOOP FLUS1 DW SEMIS ;=: LOAD interpret screen n n -- $COLON 84H,LOA,D DW BLK, AT, TOR DW INN, AT, TOR DW ZERO, INN, STORE DW BSCR, STAR, BLK, STORE DW INTER DW FROMR, INN, STORE DW FROMR, BLK, STORE DW SEMIS ;=: --> continue with next screen -- $COLON 0C3H,--,!!!> DW QLOAD DW ZERO, INN, STORE DW BSCR, BLK, AT DW OVER, MODD, SUBB DW BLK, PSTOR, SEMIS SUBTTL PAGE + ;=: ' find next input word in dictionary -- PFA _NFA = $ DB 0C1H,"'"+80H $LINKS DOCOL,TICK DW DFIND, ZEQU DW ZERO, QERR DW DROP, LITER, SEMIS ;=:* FORGET chop off the top of the dictionary -- $COLON 86H,FORGE,T DW CURR, AT DW CONT, AT DW SUBB DW LIT, 24, QERR ;"declare vocabulary" DW TICK, DUPP DW FENCE, AT, ULESS ;note change from fig DW LIT, 21, QERR ;"in protected dictionary" DW DUPP DW NFA, DP, STORE DW LFA, AT DW CONT, AT, STORE, SEMIS SUBTTL Control flow structures PAGE ;=: BACK compile a backward branch offset target -- $COLON 84H,BAC,K,BACK DW HERE, SUBB DW COMMA, SEMIS ;=: BEGIN starting point of looping structures -- HERE 1 $COLON 0C5H,BEGI,N DW QCOMP DW HERE, ONE, SEMIS ;=: ENDIF end of IF..ELSE..THEN structure addr 2 -- $COLON 0C5H,ENDI,F,ENDIFF DW QCOMP DW TWO, QPAIR DW HERE, OVER, SUBB DW SWAP, STORE, SEMIS ;=: THEN synonym for ENDIF addr 2 -- $COLON 0C4H,THE,N DW ENDIFF, SEMIS ;=: DO start of DO..LOOP structure -- HERE 3 $COLON 0C2H,D,O DW COMP, XDO DW HERE, THREE, SEMIS ;=: LOOP end of DO..LOOP structure addr 3 -- $COLON 0C4H,LOO,P DW THREE, QPAIR DW COMP, XLOOP DW BACK, SEMIS ;=: +LOOP end of DO..+LOOP structure addr 3 -- $COLON 0C5H,+LOO,P DW THREE, QPAIR DW COMP, XPLOO DW BACK, SEMIS ;=: UNTIL end of BEGIN..UNTIL loop addr 1 -- $COLON 0C5H,UNTI,L,UNTIL DW ONE, QPAIR DW COMP, ZBRAN DW BACK, SEMIS ;=: END synonym for UNTIL addr 1 -- $COLON 0C3H,EN,D DW UNTIL, SEMIS ;=: AGAIN end of BEGIN..AGAIN infinite loop addr 1 -- $COLON 0C5H,AGAI,N,AGAIN DW ONE, QPAIR DW COMP, BRAN DW BACK, SEMIS ;=: REPEAT end of BEGIN..WHILE..REPEAT structure addr 1 -- $COLON 0C6H,REPEA,T DW TOR, TOR DW AGAIN DW FROMR, FROMR DW TWO, SUBB DW ENDIFF, SEMIS ;=: IF conditional branch structure -- 2 $COLON 0C2H,I,F,IFF DW COMP, ZBRAN DW HERE, ZERO, COMMA DW TWO, SEMIS ;=: ELSE optional part of IF..ELSE..THEN addr 2 -- HERE 2 $COLON 0C4H,ELS,E DW TWO, QPAIR DW COMP, BRAN DW HERE, ZERO, COMMA DW SWAP DW TWO, ENDIFF, TWO DW SEMIS ;=: WHILE conditional loop BEGIN..WHILE..REPEAT addr 2 -- HERE 4 $COLON 0C5H,WHIL,E DW IFF, TWOP, SEMIS SUBTTL Output formatting words PAGE + ;=: SPACES type n spaces n -- $COLON 86H,SPACE,S,SPACS DW ZERO, MAX DW DDUP $GO?0 SPAX1 DW ZERO, XDO SPAX2: DW SPACE $LOOP SPAX2 SPAX1: DW SEMIS ;=: <# begin number formatting -- $COLON 82H,!!!<,#,BDIGS DW PAD, HLD, STORE DW SEMIS ;=: #> end number formatting d -- addr count $COLON 82H,#,!!!>,EDIGS DW DROP, DROP DW HLD, AT DW PAD DW OVER, SUBB, SEMIS ;=: SIGN places a '-' in output if n < 0 n d -- d $COLON 84H,SIG,N,SIGN DW ROT, ZLESS $GO?0 SIGN1 DW LIT, '-', HOLD SIGN1: DW SEMIS ;=: # convert one digit of d1 to ASCII d1 -- d2 $COLON 81H,,#,DIG DW BASE, AT, MSMOD DW ROT DW LIT, 9 DW OVER, LESS $GO?0 DIG1 DW LIT, 7, PLUS DIG1: DW LIT, '0', PLUS DW HOLD, SEMIS ;=: #S process all significant digits of d1 d1 -- 0. $COLON 82H,#,S,DIGS DIGS1: DW DIG DW OVER, OVER DW ORR, ZEQU $GO?0 DIGS1 DW SEMIS ;=: D.R print d right-aligned in n columns d n -- $COLON 83H,D.,R,DDOTR DW TOR, SWAP, OVER DW DABS DW BDIGS DW DIGS, SIGN DW EDIGS DW FROMR, OVER, SUBB DW SPACS, TYPES, SEMIS ;=: .R print n1 right-aligned in n2 columns n1 n2 -- $COLON 82H,.,R,DOTR DW TOR DW STOD, FROMR, DDOTR, SEMIS ;=: D. print a 32-bit number d -- $COLON 82H,D,.,DDOT DW ZERO DW DDOTR, SPACE, SEMIS ;=: . print a 16-bit number n -- $COLON 81H,,.,DOT DW STOD, DDOT, SEMIS ;=: ? print the value at addr addr -- $COLON 81H,,?,QUES DW AT, DOT, SEMIS ;=: U. print an unsigned 16-bit number u -- $COLON 82H,U,.,UDOT DW ZERO, DDOT, SEMIS ;=: VLIST print the words in CONTEXT vocabulary -- $COLON 85H,VLIS,T DW LIT, 80H DW OUTT, STORE DW CONT, AT, AT VLIS1: DW OUTT, AT DW CSLL, GREAT $GO?0 VLIS2 DW CR DW ZERO, OUTT, STORE VLIS2: DW DUPP DW IDDOT DW SPACE, SPACE DW PFA, LFA, AT DW DUPP, ZEQU DW QTERM, ORR $GO?0 VLIS1 DW DROP, SEMIS ;=: LIST list screen n, as 16 lines of 64 chars n -- $COLON 84H,LIS,T,LISTC DW DUPP, BLOCK ,DROP ;added 7-9-83 DW DECA, CR DW DUPP, SCR, STORE DW PDOTQ DB 6,"SCR # " DW DOT DW LIT, 16, ZERO, XDO LIST1: DW CR, IDO DW LIT, 3, DOTR, SPACE DW IDO, SCR, AT, DLINE DW QTERM $GO?0 LIST2 DW LEAVE LIST2: $LOOP LIST1 DW CR, SEMIS ;=: INDEX print line 0 of screens n1 thru n2 n1 n2 -- $COLON 85H,INDE,X DW LIT, FF, EMIT, CR DW ONEP, SWAP, XDO INDE1: DW CR, IDO DW LIT, 3, DOTR, SPACE DW ZERO, IDO, DLINE DW QTERM $GO?0 INDE2 DW LEAVE INDE2: $LOOP INDE1 DW SEMIS ;=: TRIAD list screens in groups of three n1 n2 -- $COLON 85H,TRIA,D DW LIT, FF, EMIT DW LIT, 3, SLASH DW LIT, 3, STAR DW LIT, 3, OVER DW PLUS, SWAP, XDO TRIA1: DW CR, IDO, LISTC DW QTERM $GO?0 TRIA2 DW LEAVE TRIA2: $LOOP TRIA1 DW CR DW LIT, 15, MESS, CR DW SEMIS ; $COLON 84H,.CP,U,DOTCPU DW BASE, AT DW LIT, 36, BASE, STORE DW LIT, 22H, PORIG, TAT DW DDOT DW BASE, STORE, SEMIS IF _EXTEND INCLUDE 4TH-XTNS.ASM ENDIF $REPORT <FORTH definitions completed> SUBTTL End of FORTH dictionary PAGE ;=: TASK word to mark the end of the dictionary -- LASTNFA: $COLON 84H,TAS,K,TASK DW SEMIS ; INITDP EQU $ MAIN ENDS $REPORT <End of assembly source> END ORIG