Oakland CPM Archive

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

/ Oakland CPM Archive / oakcpm.iso / sigm / vol150 / z8001.zsc < prev next >

Wrap

Text File | 1985-02-10 | 30.0 KB | 1,208 lines

% 30 Dec 82 1443 hrs. PROGRAM BOOT;% WRITTEN FOR AMD MACZ ASSEMBLER ORIGIN #0000;% RESET POINT FOR Z8001. % GRESET: WORD: #0000; WORD: #5000; WORD: #0000;% SEGMENT ZERO. WORD: UTIL; UTIL: JP BLOCKL; BLOCKL: LD R1, ^PBOOT;%SOURCE OF BLOCK MOVE. LD R2, ^BOOT;%DEST OF LOAD. LD R3, ( ^DP - ^BOOT + 2 );%LENGTH OF FORTH & ZSIO. LDIR R2^, R1^, R3;%MOVE FORTH FROM EPROM TO 4100. JP KICK; PBOOT: %BEGIN EPROM HERE. ORIGIN #4100; CONST DSIOA =#1000;% Z80-SIO PORT LOCATIONS CONST DSIOB =#1001;% DATA PORT B CONST CSIOA =#1002;% CONTROL/STATUS PORT A CONST CSIOB =#1003;% CONTROL/STATUS PORT B % BOOT: WORD: #5000; % ENABLE Z8001 INT. -NOT USED. WORD: KICK; KICK: LD R15, #6000;% SET STACK TO RAM END. CALL ZSIO; %DIS SIO INT'S.( POLLING USED ) JP FORTH; % FOR START. % ZSIO: % SET UP SIO'S LD R2, CSIOA; LD R3, ^SIOBUF; %OUTPUT STRING BUF SOURCE LD R4, #000A; %COMAND STRING LENGTH OTIRB R2, R3^, R4; RET; SIOBUF: WORD: #0100;% 00 -> REGISTER #1 WORD: #0200; WORD: #03C1; WORD: #0444;% 44 -> REG #4 ( 19.2K BAUD, etc. ) WORD: #056A; % % SIOIN: IN R2, CSIOA;% Get SIO A status. AND R2, #0001;% Received a char yet ? JR ZR, SIOIN;% no, poll IN R0, DSIOA;% yes, get the character AND R0, #007F;% clear parity bit CPB RL0, #0D; % DON'T ECHO CRETS. JR ZR, NECHO; CPB RL0, #08; % SUPRESS BSP ? JR ZR, NECHO; CPB RL0, #7F; % SUPRESS DEL ? JR ZR, NECHO; è CALL SIOUT; % ECHO THE CHARACTER. NECHO: CP R0, #0000; % RETURN TO UTILITY IF ^@ OR 'NUL', exit. JP ZR, STARTX;% If a utility or monitor prog exists. EXB RH0, RL0; %PUT Rx -> RH0 WITH A SWAP. RET; STARTX║ L─á R2¼á CSIOA;Ñá Re-enablσ SI╧ INT'╙ fo≥á monito≥á iµ needed LD R3, ^SIORTN; LD R4, #0002; OTIRB R2, R3^, R4; JP UTIL; SIORTN: WORD: #0118;% 18 -> REG #1 (enable receive INT'S ) % SIOUT: IN R2, CSIOA; AND R2, #0004; %IS Tx BUFFER EMPTY YET? JR ZR, SIOUT; NOP; %YES, CONTINUE. OUT DSIOA, R0; %OUTPUT LOW-ORDER BYTE TO SIO PORT. RET; % % CONOUT: LD R0, R13^; %OUTPUT STRING TO CONSOLE. AND R0, #7F7F; %CLEAR MSB'S OF ASCII BYTES IN R0 EXB RL0, RH0; %GET CHAR TO BE SENT INTO RL0. CALL CHARO; %OUTPUT LOWER CHAR IN R0 RET EQ; %EXIT IF 04 OR 0A ENCOUNTERED. EXB RL0, RH0; %ACCESS 2nd BYTE IN R0 CALL CHARO; %OUTPUT 2nd BYTE RET EQ; %EXIT IF 0A OR 04 ENCOUNTERED INC R13, #2; %GET NEXT CHARAC4ERS. JR CONOUT; % CHARO: CALL SIOUT; %OUTPUT LOWER BYTE TO SIO CPB RL0, #0D; %WAS IT A CRET? JR NZ, BBB; %JR IF NOT LDB RL0, #0A; %YES, FOLLOW W/LINEFEED CALL SIOUT; SETFLG ZR; %SIGNAL CALLING ROUTINE THIS IS LAST CHAR. RET; BBB: CPB RL0, #04; %WAS IT A 04 END-OF-STRING ? RET; %ZR=1 IF END-OF-STRING. % CONIN: LD R13, ^INBUF; STILL: CALL SIOIN; CPB RH0, #0D; %CRET? JR ZR, DONE; CPB RH0, #08; % BACKSPACE? JR ZR, BKUP; CPB RH0, #7F; % DELETE? JR ZR, BKUP; LDB R13^, RH0; % PUT CHAR INTO INBUF @R13. CP R13, ^INBUF(#64); % END OF BUFFER ? JR ZR, HOLD; % YES, OVERLAY LAST CHAR. INC R13; JR STILL; BKUP: CP R13, ^INBUF; è JR LE, STILL; % CAN'T BACKUP LOWER. DEC R13; % BACKUP OVER LAST CHARACTER. HOLD: LDB RL0, #08; % BACKSPACE. CALL SIOUT; LDB RL0, #20; % ERASE CRT CHAR. CALL SIOUT; LDB RL0, #08; %BACKSPACE OVER SPACE. CALL SIOUT; JR STILL; % GET NEXT CHAR. DONE: LDB R13^, #80; INC R13; LDB R13^, #80; LD BUFPNT, ^INBUF; RET; WORD(40); % PATCH SPACE. % MACRO DATE; BEGIN BYTE: #0A,'30 Dec 82 1443 hrs.', #0D; END; % % MODULE "FORTH"; % 30 Dec 82. For Z8001 J. L. Way % FROM Dr. Dobb's Journal No. 71 sept '82. % By L. L. Odette ORIGIN #0001; NUM1: % MACZ doesn't support constant declarations % for address arithmetic. ORIGIN #0004; NUM4: ORIGIN #4300; FORTH: CLR BASE; CLR START; JP INIT; % R1 IS THE INSTR. REG. AND MUST BE SAVED BY ALL ROUTINES. % R14 IS THE RETURN STACK POINTER % R15 IS THE DATA STACK POINTER. % MACRO HEADER N, NFIELD, LFIELD ; % N is # of chars in name % NFIELD is 1st 3 chars of name field. % LFIELD is compilation addrs of previous entry. (link) BEGIN BYTE: N ; BYTE: NFIELD ; WORD: LFIELD - 6 ; END; % MACRO NEXT ; BEGIN POP R2, R1^; JP R2^; END; WORD(4); %ADJUST CODE TO LISTING + 300. è% % % I/O BUFFERS INBUF: BYTE ( #64); OUTBUF: BYTE ( #64); % % % SYSTEM DATA AREA, DO NOT CHANGE ORDER OF PARAMETERS % START: WORD (1); BASE: WORD (1); MODE: BYTE (1); STATE: BYTE (1); DICPNT: WORD (1); CONXT: WORD (1); CURRNT: WORD (1); BUFPNT: WORD (1); STKPNT: WORD (1); CMPLER: WORD: SEMI1(-6); CONST SYSTEM =START; CONST TERM =#0080; % SYSTEM MESSAGES. RSTMSG: BYTE: #0A,' RESTART!',#0D; SRTMSG: BYTE: #2B,#1B,#2B,'Z8000-FORTH: (C) 1982, L. L. ODETTE',#0D; OK: BYTE: #04,' OK',#0D; NOTKNO: BYTE: #03,' ?',#0D; STKMSG: BYTE: #11,' STACK UNDERFLOW',#0D; % % ADDRESS INTERPRETER. % COLON: PUSH R14^,R1; POP R1,R15^; NEXT; % SEMI: POP R1,R14^; NEXT; % % TEXT INTERPRETER. % OUTINT: WORD: TYPE; WORD: QUERY; WORD: ASPACE; WORD: WORD_; WORD: DROP; WORD: SERCH1; WORD: SYSIF; WORD: #000E; WORD: NUMBR1; WORD: SYSEND; WORD: #0010; WORD: QUESTN; WORD: SYSWHL; WORD: #001A; è WORD: EXEC1; WORD: SYSWHL; WORD: #001C; % % TEXT INTERPRETER WORDS. % SERCH1: CALL COLON; WORD: CONTXT; WORD: FETCH; WORD: FETCH; WORD: SEARCH; WORD: DUP; WORD: SYSIF; WORD: #0024; WORD: MOD_; WORD: CFETCH; WORD: SYSIF; WORD: #001C; WORD: DROP; WORD: CMPLR; WORD: FETCH; WORD: SEARCH; WORD: DUP; WORD: SYSIF; WORD: #0008; WORD: ZERO; WORD: SYSELS; WORD: #0004; WORD: ONE; WORD: ST8; WORD: CSTORE; WORD: SEMI; % EXEC1: CALL COLON; %EXECUTE ROUTINE WORD: ST8; WORD: CFETCH; WORD: ST8; WORD: C0SET; WORD: MOD_; WORD: CFETCH; WORD: EQUALS; WORD: SYSIF; WORD: #000A; WORD: EXECUT; WORD: STACK; WORD: SYSELS; WORD: #0004; WORD: COMMA; WORD: SEMI; % NUMBR1: CALL COLON; WORD: NUMBER; WORD: SYSIF; WORD: #0018; WORD: MOD_; è WORD: CFETCH; WORD: SYSIF; WORD: #000A; WORD: LITERL; WORD: LITERL; WORD: COMMA; WORD: COMMA; WORD: ZERO; WORD: SYSELS; WORD: #0004; WORD: ONE; WORD: SEMI; % % SYSTEM SUBROUTINES. % CONVOC: WORD (1); CURVOC: WORD (1); % INIT: LD R2, ^RSTMSG; TEST BASE; JR NZ, ABORT; % LD R15, #5FF0;% SET FORTH DATA STACK LD STKPNT, R15; LD R12, ^DP; LD DICPNT, R12; LD R12, ^QUIT(-6); LD CONVOC, R12; LD CURVOC, R12; LD R12, ^CONVOC; LD CONXT, R12; LD R12, ^CURVOC; LD CURRNT, R12; LD BASE, #0010; % HEX. FOR DECIMAL, USE #0A HERE. LD R2, ^SRTMSG; % ABORT: PUSH R15^, R2; CLR MODE; LD R14, #5F00; LD R1, ^OUTINT; % ERROR SOURCE TRIAL R10! NEXT; % CONWRT: CLRB RH6; LDB RL6, R12^; % EXPECTS MESS'G ADRS IN R12. INC R12; LD R13, ^OUTBUF; LDIRB R13^,R12^,R6; LDB R13^, #04; % SET END OF STRING LD R13, ^OUTBUF; CALL CONOUT; RET; % CRLF: LD R13, ^OUTBUF; LDB R13^, #0D; CALL CONOUT; è RET; % PATCH: TESTB MODE; % MODE=0 (EXECUTE). JP EQ, ABORT; % YES. LD R8, CURRNT; LD R9, R8^; % RESET DICTIONARY POINTER. LD DICPNT, R9; INC R9, #04; % GET LINK ADRS. LD R9, R9^; LD R8^, R9; JP ABORT; % ASCWD: PUSH R15^, #0020; % PUSH SPACE ON STACK. ASCII: CLR R6; % CLR HI WORD. DIV RR6, BASE; % DIVIDE BY BASE. CPB RL6,#0A; JR LT, ASCII0; ADDB RL6, #07; % OTHERWISE ADD OFFSET TO ALPHABET. ASCII0: ADDB RL6, '0'; PUSH R15^,R6; TEST R7; JR NE, ASCII; ASCII1: POP R6, R15^; LDB R13^, RL6; INC R13; CPB RL6, #20; JR NE, ASCII1; RET; % % SYSTEM WORDS (HEADERLESS) % % SYSTEM VARIABLES. MOD_: CALL SYS; WORD: #0004; % DPNT: CALL SYS; WORD: #0006; % BFPNT: CALL SYS; WORD: #000C; % CMPLR: CALL SYS; WORD: #0010; % % SYSTEM I/O, NUMBER CONVERSION, SEARCH. % QUESTN: LD R12, DICPNT; INC R12; BITB R12^, #07; JR EQ, $(12); LD R2, ^OK; PUSH R15^, R2; NEXT; CALL CRLF; DEC R12; è CALL CONWRT; LD R2,^NOTKNO; JP PATCH; % STACK: CP R15, STKPNT; JP LE, SEMI(2); LD R15, STKPNT; LD R2, ^STKMSG; JP PATCH; % NUMBER: CLR R6; CLR R10; LD R8, DICPNT; LDB RH0, R8^; INC R8; % STEP OVER COUNT. CPB R8^, '-'; CLRB RL0; JR NE, $(8); DECB RL0; DECB RH0; INC R8; % PUSH R15^, #0000; NLOOP: LDB RL6, R8^; SUBB RL6, #30; JR MI, NOTNO; CPB RL6, #0A; JR MI, NUMB; CPB RL6, #11; JR MI, NOTNO; SUBB RL6, #07; % NUMB: CP R6, BASE; JR MI, $(10); NOTNO: LD R15^, #0000; NEXT; % LD R11, R15^; MULT RR10, BASE; ADD R11, R6; LD R15^,R11; INC R8; DBJNZ RH0, NLOOP; TESTB RL0; JR EQ, $(8); CLR R11; SUB R11, R15^; LD R15^, R11; PUSH R15^, #00FF; NEXT; SEARCH: LD R8, R15^; LD R9, DICPNT; LDB RH0, R9^; CPB RH0, R8^; è JR NE, NXTHDR; CPB RH0, #04; JR LT, NXTCH; LDB RH0, #03; NXTCH: INC R9; INC R8; LDB RL0, R9^; CPB RL0, R8^; JR NE, NXTHDR; DBJNZ RH0, NXTCH; INC R15^, #06; PUSH R15^, #0000; JR $(18); NXTHDR: LD R8, R15^; INC R8, #04; LD R7, R8^; LD R15^, R7; TEST R7; JR NE, SEARCH; LD R15^, #0001; NEXT; ENDC: CALL COLON; WORD: COMMA; WORD: HERE; WORD: SWAP_; WORD: MINUS; WORD: COMMA; WORD: SEMI; % DOC: CALL COLON; WORD: COMMA; WORD: HERE; WORD: SEMI; % BUILD: CALL COLON; WORD: ENTRY; WORD: ASPACE; WORD: WORD_; WORD: CRNT; WORD: FETCH; WORD: STORE; WORD: LITERL; WORD: #0004; WORD: DPNT; WORD: PSTORE; WORD: COMMA; WORD: LITERL; WORD: #5F00; WORD: COMMA; WORD: LITERL; WORD: COLON; WORD: COMMA; WORD: SEMI; % ENTRY: CALL COLON; è WORD: CRNT; WORD: FETCH; WORD: FETCH; WORD: SEMI; % CAXCLM: CALL COLON; WORD: ENTRY; WORD: LITERL; WORD: #0008; WORD: PLUS; WORD: STORE; WORD: SEMI; % SCODE: CALL COLON; WORD: RFROM; WORD: CAXCLM; WORD: SEMI; % % SYSTEM DIRECTIVES: IMPLMT CONTROL STRUCTRS. % SYSIF: POP R8, R15^; TEST R8; JR EQ, SYSELS; INC R1, #02; NEXT; % SYSELS: LD R6, R1^; ADD R1,R6; NEXT; % SYSEND: POP R8, R15^; TEST R8; JR EQ, SYSWHL; INC R1, #02; NEXT; % SYSWHL: LD R6,R1^; SUB R1,R6; NEXT; % LITERL: PUSH R15^, R1^; INC R1, #02; NEXT; % SYSPLP: POP R8, R14^; POP R7, R15^; JR LP; % SYSLOP: POP R8, R14^; LD R7, #1; LP: ADD R8, R7; CP R8, R14^; PUSH R14^, R8; JR MI, SYSWHL; POPL RR8, R14^; è INC R1,#2; NEXT; % SYSDO: POPL RR8, R15^; PUSHL R14^, RR8; NEXT; SYS: LD R8, ^SYSTEM; POP R2, R15^; ADD R8, R2^; PUSH R15^, R8; NEXT; % % DICTIONARY WORD SETS % % MEMORY REFERENCE WORD SET % HEADER 1, '@XX',6; FETCH: LD R6, R15^; LD R6,R6^; LD R15^, R6; NEXT; HEADER 2,'C@X',^FETCH; % C@ CFETCH: LD R6,R15^; LDB RL5, R6^; EXTSB R5; LD R15^, R5; NEXT; HEADER 1, '!XX', ^CFETCH; % C! STORE: POPL RR6, R15^; LD R6^, R7; NEXT; HEADER 2, 'C!X', ^STORE; CSTORE: POPL RR6, R15^; LDB R6^, RL7; NEXT; HEADER 2, '+!X', ^CSTORE; PSTORE: POPL RR6, R15^; ADD R7 , R6^; LD R6^ , R7; NEXT; HEADER 1, '?XX', ^PSTORE; QMARK: POP R6, R15^; LD R7, R6^; LD R13, ^OUTBUF; CALL ASCWD; LDB R13^, #04; LD R13, ^OUTBUF; CALL CONOUT; NEXT; HEADER 4, 'MOV', ^QMARK; MOVE: POPL RR6, R15^; POP R5, R15^; BIT R6, #0F; JR NE, $(6); LDIR R7^, R5^, R6; è NEXT; HEADER 5, 'CMO', ^MOVE; CMOVE: POPL RR6, R15^; POP R5, R15^; BIT R6, #0F; JR NE, $(6); LDIRB R7^, R5^, R6; NEXT; HEADER 4, 'FIL', ^CMOVE; FILL: POPL RR6, R15^; POP R5, R15^; BIT R7, #0F; JR NE, $(8); LDB R5^, RL6; INC R5; DJNZ R7, $(-4); NEXT; HEADER 2, 'P!X', ^FILL; POUT: POP R2, R15^; POP R3, R15^; OUT R2, R3; NEXT; HEADER 2, 'P@X', ^POUT; P@: POP R2, R15^; IN R2, R2; PUSH R15^, R2; NEXT; % % COMPARISON WORD SET. % HEADER 3, 'NOT', ^P@; N_T: POP R12, R15^; AND R12, R12; CLR R12; JR NZ, CHANGE; INC R12; CHANGE: PUSH R15^, R12; NEXT; HEADER 1, '=XX', ^N_T; EQUALS: POP R6,R15^; CP R6, R15^; CLR R15^; JR NE, $(4); INC R15^; NEXT; HEADER 2, '0=X', ^EQUALS; EQUAL0: JR N_T; HEADER 1, '<XX', ^EQUAL0; LESS: POP R6,R15^; CP R6, R15^; CLR R15^; JR LE, $(4); INC R15^; NEXT; HEADER 1, '>XX', ^LESS; èGREATR: POP R6, R15^; CP R6, R15^; CLR R15^; JR GE, $(4); INC R15^; NEXT; % % ARITH & LOGIC WORD SET. % HEADER 1, '+XX', ^GREATR; PLUS: POP R6, R15^; ADD R6, R15^; LD R15^, R6; NEXT; HEADER 1, '-XX', ^PLUS; MINUS: POPL RR6, R15^; SUB R7, R6; PUSH R15^, R7; NEXT; HEADER 2, '1+X', ^MINUS; PLUS1: INC R15^; NEXT; HEADER 2, '1-X', ^PLUS1; MINUS1: DEC R15^; NEXT; HEADER 2, '2+X', ^MINUS1; PLUS2: INC R15^, #2; NEXT; HEADER 2, '2-X', ^PLUS2; MINUS2: DEC R15^, #2; NEXT; HEADER 1, '*XX', ^MINUS2; TIMES: POPL RR6, R15^; LD R5, R6; MULT RR6, R5; PUSH R15^, R7; NEXT; HEADER 1, '/XX', ^TIMES; DIVIDE: POPL RR6, R15^; LD R5, R6; CLR R6; DIV RR6, R5; PUSH R15^, R7; NEXT; HEADER 3, 'MOD', ^DIVIDE; MOD0: POPL RR6, R15^; LD R5,R6; CLR R6; DIV RR6, R5; PUSH R15^, R6; NEXT; HEADER 4, '/MO', ^MOD0; DIVMOD: POPL RR6, R15^; LD R5, R6; CLR R6; è DIV RR6, R5; EX R6, R7; PUSHL R15^, RR6; NEXT; HEADER 6, 'NEG', ^DIVMOD; NEGATE: NEG R15^; NEXT; HEADER 3, 'ABS', ^NEGATE; ABS: BIT R15^, #0F; JR NE, NEGATE; NEXT; HEADER 3, 'AND', ^ABS; AND0: POP R6, R15^; AND R6, R15^; LD R15^, R6; NEXT; HEADER 2, 'ORX',^AND0; OR0: POP R6,R15^; OR R6, R15^; LD R15^, R6; NEXT; % % STACK MANIPULATION % HEADER 2, 'R>X', ^OR0; RFROM: POP R6, R14^; PUSH R15^, R6; NEXT; HEADER 2, '>RX', ^RFROM; TOR: POP R6, R15^; PUSH R14^, R6; NEXT; HEADER 2, 'R@X', ^TOR; RFETCH: PUSH R15^, R14^; NEXT; HEADER 3, 'DUP', ^RFETCH; DUP: PUSH R15^, R15^; NEXT; HEADER 4, 'DRO', ^DUP; DROP: POP R6, R15^; NEXT; HEADER 4, 'SWA', ^DROP; SWAP_: POP R6, R15^; EX R6, R15^; PUSH R15^, R6; NEXT; HEADER 4, 'OVE', ^SWAP_; OVER: INC R15, #2; % MODIFIED FROM ODETTE'S VERSION. LD R2, R15^; DEC R15, #2; PUSH R15^, R2; NEXT; HEADER 3, 'ROT', ^OVER; ROT: POPL RR6, R15^; POP R5, R15^; è PUSHL R15^, RR6; PUSH R15^, R5; NEXT; HEADER 4, 'ROL', ^ROT; ROLL: POP R4, R15^; DEC R4; LD R6, R15; ADD R6, R4; ADD R6, R4; LD R7, R6^; LD R5, R6; DEC R5, #2; LDDR R6^, R5^, R4; LD R15^, R7; NEXT; HEADER 4, 'PIC', ^ROLL; PICK: POP R4, R15^; DEC R4; LD R6, R15; ADD R6, R4; ADD R6, R4; PUSH R15^, R6^; NEXT; HEADER 4, '?DU', ^PICK; QDUP: TEST R15^; JR EQ, $(4); PUSH R15^, R15^; NEXT; HEADER 2, 'CRX', ^QDUP; CR: LD R13, ^OUTBUF; LDB R13^, #0D; CALL CONOUT; NEXT; HEADER 4, 'EMI', ^CR; EMIT: LD R13, ^OUTBUF; POP R6, R15^; LDB R13^, RL6; LDB NUM1(R13), #04; CALL CONOUT; NEXT; HEADER 5, 'SPA', ^EMIT; SPACE: LD R13, ^OUTBUF; LD R13^, #2004; % SET SPACE & END-OF-STRING CALL CONOUT; NEXT; HEADER 4, 'TYP', ^SPACE; TYPE: POP R12, R15^; CALL CONWRT; NEXT; HEADER 4, 'WOR', ^TYPE; WORD_: LD R8, BUFPNT; LD R9, DICPNT; POP R6, R15^; CPB RL6, #20; JR NE, TOK; èIGNLB: CPB R8^, #20; % IGNORE SPACES IN BUFFER JR NE, TOK; INC R8; JR IGNLB; TOK: PUSH R15^, R8; COUNT: INCB RH6; INC R8; CPB RL6, R8^; JR EQ, ENDTOK; % FIND NEXT SEPARATOR CPB R8^, TERM; % COMPARE W/ TERMINATOR JR NE, COUNT; DEC R8; ENDTOK: INC R8; LD BUFPNT, R8; LDB R9^, RH6; LD R8, R15^; LD R15^, R9; INC R9; LDB RL6, RH6; CLRB RH6; LDIRB R9^, R8^, R6; NEXT; HEADER 5, 'QUE', ^WORD_; QUERY: CALL CONIN; NEXT; % % MISC WORDS % HEADER 4, 'BAS', ^QUERY; BASE0: CALL SYS; WORD: #0002; HEADER 1, '0XX', ^BASE0; ZERO: PUSH R15^, #0; NEXT; HEADER 1, '1XX', ^ZERO; ONE: PUSH R15^, #1; NEXT; HEADER 1, '2XX', ^ONE; TWO: PUSH R15^, #2; NEXT; HEADER 6, 'ASP', ^TWO; ASPACE: PUSH R15^, #20; NEXT; HEADER 1, '.XX', ^ASPACE; PERIOD: POP R7, R15^; LD R13, ^OUTBUF; CALL ASCWD; LDB R13^, #04; LD R13, ^OUTBUF; CALL CONOUT; NEXT; HEADER 4, '2DU', ^PERIOD; DUP2: PUSH R15^, R15^; PUSH R15^, R15^; NEXT; è HEADER 5, '2DR', ^DUP2; DROP2: POPL RR6, R15^; NEXT; HEADER 5, 'C0S', ^DROP2; C0SET: POP R6, R15^; CLRB R6^; NEXT; HEADER 5, 'C1S', ^C0SET; C1SET: POP R6,R15^; LDB R6^, #01; NEXT; % % VOCABULARIES. % HEADER 7, 'CON', ^C1SET; CONTXT: CALL SYS; WORD: #0008; HEADER 7, 'CUR', ^CONTXT; CRNT: CALL SYS; WORD: #000A; HEADER 11, 'DEF', ^CRNT; DEFN: CALL COLON; WORD: CRNT; WORD: FETCH; WORD: CONTXT; WORD: STORE; WORD: SEMI; HEADER 4, 'FIN', ^DEFN; FIND: CALL COLON; WORD: ASPACE; WORD: WORD_; WORD: DROP; WORD: CONTXT; WORD: FETCH; WORD: FETCH; WORD: SEARCH; WORD: SYSIF; WORD: #0004; WORD: ZERO; WORD: SEMI; HEADER 6, 'FOR', ^FIND; FORGET: CALL COLON; WORD: ASPACE; WORD: WORD_; WORD: DROP; WORD: CRNT; WORD: FETCH; WORD: FETCH; WORD: SEARCH; WORD: SYSIF; WORD: #0004; WORD: QUESTN; WORD: DUP; WORD: TWO; WORD: MINUS; è WORD: FETCH; WORD: CRNT; WORD: FETCH; WORD: STORE; WORD: LITERL; WORD: #0006; WORD: MINUS; WORD: DPNT; WORD: STORE; WORD: SEMI; % % DEFINING WORDS, COMPILER WORDS, CONTROL WORDS % BYTE: #01; BYTE: ', '; WORD: ^FORGET(-6); COMMA: POP R6, R15^; LD R7, DICPNT; LD R7^, R6; INC DICPNT, #2; NEXT; HEADER 5, 'ALL', ^COMMA; ALLOT: POP R6, R15^; ADD R6, DICPNT; LD DICPNT, R6; NEXT; HEADER 5, 'LEA', ^ALLOT; LEAVE: LD R12, R14^; LD R14^(2), R12; NEXT; HEADER 1, 'IXX', ^LEAVE; I: PUSH R15^, R14^; NEXT; HEADER 1, 'JXX', ^I; J: PUSH R15^, NUM4(R14); NEXT; HEADER 5, 'STA', ^J; ST8: CALL SYS; % STATE WORD: #0005; HEADER 4, 'HER', ^ST8; HERE: PUSH R15^, DICPNT; NEXT; HEADER 7, 'EXE', ^HERE; EXECUT: POP R2, R15^; JP R2^; HEADER 6, 'CRE', ^EXECUT; CREATE: CALL COLON; WORD: ZERO; WORD: CNSTNT; WORD: SEMI; HEADER 5, 'DOE', ^CREATE; DOES: CALL COLON; WORD: RFROM; WORD: ENTRY; WORD: LITERL; è WORD: #000A; WORD: PLUS; WORD: STORE; WORD: SCODE; PUSH R14^, R1; POP R2, R15^; POP R1, R2^; PUSH R15^, R2; NEXT; HEADER 8, 'VAR', ^DOES; VARIBL: CALL COLON; WORD: CNSTNT; WORD: SCODE; NEXT; HEADER 8, 'CON', ^VARIBL; CNSTNT: CALL COLON; WORD: BUILD; WORD: COMMA; WORD: SCODE; POP R2, R15^; PUSH R15^, R2^; NEXT; HEADER 10, 'VOC', ^CNSTNT; VOCAB: CALL COLON; WORD: CREATE; WORD: ENTRY; WORD: COMMA; WORD: DOES; WORD: CONTXT; WORD: STORE; WORD: SEMI; HEADER 1, ':XX', ^VOCAB; COLON1: CALL COLON; WORD: CRNT; WORD: FETCH; WORD: CONTXT; WORD: STORE; WORD: BUILD; WORD: MOD_; WORD: C1SET; WORD: SEMI; % % COMPILER VOCABULARY. % HEADER 2, 'DOX', 6; DO_: CALL COLON; WORD: LITERL; WORD: SYSDO; WORD: DOC; WORD: SEMI; HEADER 4, 'LOO', ^DO_; LOOP: CALL COLON; WORD: LITERL; WORD: SYSLOP; WORD: ENDC; è WORD: SEMI; HEADER 5, '+LO', ^LOOP; PLOOP: CALL COLON; WORD: LITERL; WORD: SYSPLP; WORD: ENDC; WORD: SEMI; HEADER 5, 'BEG', ^PLOOP; BEGIN_: CALL COLON; WORD: HERE; WORD: SEMI; HEADER 5, 'UNT', ^BEGIN_; UNTIL_: CALL COLON; WORD: LITERL; WORD: SYSEND; WORD: ENDC; WORD: SEMI; HEADER 5, 'WHI', ^UNTIL_; WHILE: CALL COLON; WORD: IF_; WORD: SEMI; HEADER 6, 'REP', ^WHILE; REPEAT: CALL COLON; WORD: SWAP_; WORD: LITERL; WORD: SYSWHL; WORD: ENDC; WORD: THEN_; WORD: SEMI; HEADER 2, 'IFX', ^REPEAT; IF_: CALL COLON; WORD: LITERL; WORD: SYSIF; WORD: DOC; WORD: ZERO; WORD: COMMA; WORD: SEMI; HEADER 4, 'THE', ^IF_; THEN_: CALL COLON; WORD: HERE; WORD: OVER; WORD: MINUS; WORD: SWAP_; WORD: STORE; WORD: SEMI; HEADER 4, 'ELS', ^THEN_; ELSE_: CALL COLON; WORD: LITERL; WORD: SYSELS; WORD: DOC; WORD: ZERO; WORD: COMMA; WORD: SWAP_; WORD: THEN_; WORD: SEMI; è HEADER 1, ';XX', ^ELSE_; SEMI1: CALL COLON; % FIRST ENTRY OF COMPILER DIRECTIVES WORD: LITERL; WORD: SEMI; WORD: COMMA; WORD: MOD_; WORD: C0SET; WORD: SEMI; % % The following words were not part of the original FORTH % in Dr. Dobbs Journal ( op. cit.) % HEADER 2, 'JXR', ^COLON1; JXVAR: CALL VARIBL(8);%Nearest NEXT. WORD: #0000;% VALUE OF THE VARIABLE 'JX' HEADER 3,'NUM', ^JXVAR; NUMBR: CALL COLON;% Display numbers with leading zero's WORD: DUP; WORD: LITERL; WORD: #8000; WORD: AND0; WORD: SYSIF; WORD: #0008; WORD: PERIOD; WORD: SYSELS; WORD: #0058; WORD: DUP; WORD: LITERL; WORD: #0FFF; WORD: GREATR; WORD: SYSIF; WORD: #0008; WORD: PERIOD; WORD: SYSELS; WORD: #0046; WORD: DUP; WORD: LITERL; WORD: #00FF; WORD: GREATR; WORD: SYSIF; WORD: #000E; WORD: LITERL; WORD: #0030; WORD: EMIT; WORD: PERIOD; WORD: SYSELS; WORD: #002E; WORD: DUP; WORD: LITERL; WORD: #000F; WORD: GREATR; WORD: SYSIF; WORD: #0012; WORD: LITERL; WORD: #0030; è WORD: DUP; WORD: EMIT; WORD: EMIT; WORD: PERIOD; WORD: SYSELS; WORD: #0012; WORD: LITERL; WORD: #0030; WORD: DUP; WORD: DUP; WORD: EMIT; WORD: EMIT; WORD: EMIT; WORD: PERIOD; WORD: SEMI; HEADER 3, 'DMP', ^NUMBR;% For use by memory dump word. DMPLP: CALL COLON; WORD: LITERL; WORD: #0010; WORD: ZERO; WORD: SYSDO; WORD: JXVAR; WORD: FETCH; WORD: I; WORD: PLUS; WORD: FETCH; WORD: NUMBR; WORD: TWO; WORD: SYSPLP; WORD: #0010; WORD: SEMI; HEADER 4, 'DUM', ^DMPLP;% Mem. dump word ( addr lgth ---; ) DUMP: CALL COLON; WORD: CR; WORD: OVER; WORD: PLUS; WORD: PLUS1; WORD: SWAP_; WORD: SYSDO; WORD: I; WORD: DUP; WORD: JXVAR; WORD: STORE; WORD: NUMBR; WORD: SPACE; WORD: SPACE; WORD: DMPLP; WORD: CR; WORD: LITERL; WORD: #0010; WORD: SYSPLP; WORD: #0018; WORD: SEMI; HEADER 9, '?TE', ^DUMP;% ?TERMINAL word FTER: CALL COLON; è WORD: LITERL; WORD: #1002;% READ TERMINAL STATUS BYTE. WORD: P@; WORD: ONE; WORD: AND0; WORD: SEMI; HEADER 4, 'QUI', ^FTER;% QUIT word QUIT: CALL COLON; WORD: FTER; WORD: SYSIF; WORD: #0004; WORD: LEAVE; WORD: SEMI; % DP: WORD(2);% Initial dictionary pointer, cold start. % % END.