\ 26NOV82MCS ******************************************************* * * * * * Michael Stolowitz * * 335 Merrilee Place * * Danville, CA 94526 * * * * (415) 837-3887 * * * ******************************************************* \ LOAD SCREEN FOR HD1 11may83mcs 12 LOAD EXIT \ Load Screen for Meta Compiler 11may83mcs 5 26 +THRU \ That's all folks CR ." Meta Compiler Loaded" \ MD11 rev 1.0 - Load Screen 03sep83mcsFORTH DEFINITIONS : NLOAD CR DUP . (LOAD) ; ' NLOAD IS LOAD HEX 7F00 2600 ERASE DECIMAL 45 LOAD \ Auto Code - Buffer Equates 80 151 +THRU \ Forth Code - System Equates FORTH DEFINITIONS DECIMAL CR ." TARGET DONE" EXIT \ Memory Access Words 03sep83mcsVOCABULARY META IMMEDIATE META DEFINITIONS 32768 CONSTANT TARGET-ORIGIN VARIABLE DP-T : HOST-TARGET ( h-adr t-adr -- ) - ['] TARGET-ORIGIN ! ; : THERE (S taddr -- addr ) TARGET-ORIGIN + ; : C@-T (S taddr -- char ) THERE C@ ; : @-T (S taddr -- n ) THERE @ ; : C!-T (S char taddr -- ) THERE C! ; : !-T (S n taddr -- ) THERE ! ; : HERE-T (S -- taddr ) DP-T @ ; : ALLOT-T (S n -- ) DP-T +! ; : ,-T (S n -- ) HERE-T !-T 2 ALLOT-T ; : C,-T (S char -- ) HERE-T C!-T 1 ALLOT-T ; : S,-T (S addr len -- ) 0 ?DO DUP C@ C,-T 1+ LOOP DROP ; \ Define Symbol Table Vocabularies 28APR82HHLVOCABULARY TARGET IMMEDIATE TARGET DEFINITIONS : X R> DROP ; VOCABULARY TRANSITION IMMEDIATE TRANSITION DEFINITIONS HEX 0 ' X LFA 80C1 ' X NFA DECIMAL META DEFINITIONS ! ! VARIABLE LAST : CREATE (S -- ) CREATE LATEST LAST ! ; : (DOES) (S -- ) R> LAST @ PFA CFA ! ; : T-DOES> (S -- ) COMPILE (DOES) 205 ( CALL ) C, [ ' DOES> 12 + @ ] LITERAL , ; IMMEDIATE \ 8080 Meta Assembler 29APR82HHLVOCABULARY ASSEMBLER IMMEDIATE ASSEMBLER DEFINITIONS : 8* 2* 2* 2* ; HEX 4 CONSTANT H 5 CONSTANT L 7 CONSTANT A 6 CONSTANT PSW 2 CONSTANT D 3 CONSTANT E 0 CONSTANT B 1 CONSTANT C 6 CONSTANT M 6 CONSTANT SP C2 CONSTANT 0= D2 CONSTANT CS E2 CONSTANT PE F2 CONSTANT 0< : 1MI CREATE C, DOES> C@ C,-T ; : 2MI CREATE C, DOES> C@ + C,-T ; : 3MI CREATE C, DOES> C@ SWAP 8* + C,-T ; : 4MI CREATE C, DOES> C@ C,-T C,-T ; : 5MI CREATE C, DOES> C@ C,-T ,-T ; : NOT 8 + ; : MOV 8* 40 + + C,-T ; : MVI 8* 6 + C,-T C,-T ; : LXI 8* 1+ C,-T ,-T ; DECIMAL \ 8080 Meta Assembler 29APR82HHLHEX 00 1MI NOP 76 1MI HLT F3 1MI DI FB 1MI EI 07 1MI RLC 0F 1MI RRC 17 1MI RAL 1F 1MI RAR E9 1MI PCHL F9 1MI SPHL E3 1MI XTHL EB 1MI XCHG 27 1MI DAA 2F 1MI CMA 37 1MI STC 3F 1MI CMC C0 1MI RNZ C8 1MI RZ D0 1MI RNC E0 1MI RPO E8 1MI RPE F0 1MI RP F8 1MI RM C9 1MI RET D8 1MI RC 80 2MI ADD 88 2MI ADC 90 2MI SUB 98 2MI SBB A0 2MI ANA A8 2MI XRA B0 2MI ORA B8 2MI CMP 09 3MI DAD C1 3MI POP C5 3MI PUSH 02 3MI STAX 0A 3MI LDAX 04 3MI INR 05 3MI DCR 03 3MI INX 0B 3MI DCX C7 3MI RST D3 4MI OUT DB 4MI IN C6 4MI ADI CE 4MI ACI D6 4MI SUI DE 4MI SBI E6 4MI ANI EE 4MI XRI F6 4MI ORI FE 4MI CPI 22 5MI SHLD 2A 5MI LHLD 32 5MI STA 3A 5MI LDA C4 5MI CNZ CC 5MI CZ D4 5MI CNC DC 5MI CC E4 5MI CPO EC 5MI CPE DECIMAL \ 8080 Meta Assembler 29APR82HHLHEX F4 5MI CP FC 5MI CM CD 5MI CALL C3 5MI JMP FA 5MI JM F2 5MI JP CA 5MI JZ C2 5MI JNZ DA 5MI JC D2 5MI JNC : THEN HERE-T SWAP !-T ; : IF C,-T HERE-T 0 ,-T ; : ELSE C3 IF SWAP THEN ; : BEGIN HERE-T ; : UNTIL C,-T ,-T ; : AGAIN C3 UNTIL ; : WHILE IF ; : REPEAT SWAP AGAIN THEN ; META DEFINITIONS DECIMAL \ Meta Compiler Vocabulary Manipulators 27May82map: MAKE-CODE (S PFA -- ) @ ,-T ; : LABEL (S -- ) HERE-T CONSTANT ; : IN-TARGET (S -- ) [COMPILE] TARGET DEFINITIONS ; : IN-TRANSITION (S -- ) IN-TARGET TARGET [COMPILE] TRANSITION ; : IN-META (S -- ) [COMPILE] META DEFINITIONS ; \ Meta Compiler Forward Reference Linking 02MAY82HHL: LINK-BACKWARDS (S PFA -- ) HERE-T OVER @ ,-T SWAP ! ; : RESOLVED? (S pfa -- f ) 2+ C@ ; : FORWARD-CODE (S pfa -- ) DUP RESOLVED? IF MAKE-CODE ELSE LINK-BACKWARDS THEN ; : FORWARD: (S -- ) IN-TARGET CREATE IN-META 0 , 0 C, T-DOES> FORWARD-CODE ; \ Meta Compiler Create Target Image 6Jul82mapVARIABLE WIDTH 31 WIDTH ! VARIABLE LATEST : HEADER (S -- ) BL WORD C@ 1+ WIDTH @ MIN ?DUP IF LATEST @ ,-T HERE-T HERE ROT S,-T DUP THERE 128 TOGGLE HERE-T 1- THERE 128 TOGGLE LATEST ! THEN ; : TARGET-CREATE (S -- ) >IN @ HEADER >IN ! IN-TARGET CREATE IN-META HERE-T , 1 C, T-DOES> MAKE-CODE ; FORWARD: FORWARD: FORWARD: FORWARD: <(.")> FORWARD: FORWARD: FORWARD: <(;CODE)> FORWARD: FORWARD: FORWARD: <(ABORT")> FORWARD: <(IS)> FORWARD: FORWARD: FORWARD: <(")> \ Meta Compiler Equates and Transition words 29APR82HHL: H: (S -- ) [COMPILE] : ; : T: (S -- ) TARGET [COMPILE] TRANSITION DEFINITIONS [COMPILE] : SMUDGE IN-META ; : T; (S -- ) [COMPILE] ; SMUDGE ; IMMEDIATE T: LITERAL TARGET ,-T T; T: DLITERAL TARGET ,-T ,-T T; : EQU (S n -- ) >IN @ >R DUP CONSTANT R> >IN ! IN-TARGET CREATE IN-META , 1 C, T-DOES> @ TARGET TRANSITION LITERAL ; \ Meta compiler Branching & Looping 04MAY82HHLFORWARD: BRANCH FORWARD: ?BRANCH FORWARD: (DO) FORWARD: (LOOP) FORWARD: (+LOOP) : BACK (S addr -- ) HERE-T - ,-T ; T: DO TARGET (DO) HERE-T 3 T; T: LOOP 3 ?PAIRS TARGET (LOOP) BACK T; T: +LOOP 3 ?PAIRS TARGET (+LOOP) BACK T; T: BEGIN HERE-T 1 T; T: AGAIN 1 ?PAIRS TARGET BRANCH BACK T; T: UNTIL 1 ?PAIRS TARGET ?BRANCH BACK T; T: IF TARGET ?BRANCH HERE-T 0 ,-T 2 T; T: THEN 2 ?PAIRS HERE-T OVER - SWAP !-T T; T: ELSE 2 ?PAIRS TARGET BRANCH HERE-T 0 ,-T SWAP 2 TRANSITION THEN 2 T; \ Meta Compiler Branching & Defining Words 30APR82HHLT: WHILE TARGET TRANSITION IF 2+ T; T: REPEAT >R >R TARGET TRANSITION AGAIN R> R> 2- THEN T; : DIGIT? (S CHAR -- F ) BASE @ DIGIT DUP IF SWAP DROP THEN ; : PUNCT? (S CHAR -- F ) ASCII . OVER = SWAP ASCII - OVER = SWAP ASCII / OVER = SWAP DROP OR OR ; : NUMERIC? (S ADDR LEN -- F ) 1 -ROT 0 ?DO DUP C@ DUP DIGIT? SWAP PUNCT? OR ROT AND SWAP 1+ LOOP DROP ; : FIND (S -- PFA F ) BL WORD CONTEXT @ @ (FIND) IF DROP TRUE ELSE 0 FALSE THEN ; \ Meta Compiler Compiling Loop 02MAY82HHL: NUMERIC (S -- ) HERE NUMBER DPL @ 1+ IF TARGET TRANSITION DLITERAL META ELSE DROP TARGET TRANSITION LITERAL META THEN ; : UNDEFINED (S -- ) HERE-T 0 ,-T CREATE , 0 C, T-DOES> FORWARD-CODE ; VARIABLE T-IN : ] (S -- ) IN-TRANSITION BEGIN >IN @ T-IN ! FIND IF EXECUTE ELSE DROP HERE COUNT NUMERIC? IF NUMERIC ELSE T-IN @ >IN ! UNDEFINED THEN THEN AGAIN ; T: [ (S -- ) IN-META R> DROP T; \ Meta Compiler Defining Words 30APR82HHL: CREATE >IN @ TARGET-CREATE >IN ! TARGET META HERE-T CONSTANT ; : VARIABLE CREATE 0 ,-T ; : CONSTANT >IN @ TARGET-CREATE >IN ! TARGET META DUP ,-T CONSTANT ; : USER TARGET-CREATE TARGET META ,-T ; HEX : VOCABULARY TARGET-CREATE TARGET META 0 ,-T A081 ,-T 0 ,-T ; DECIMAL \ Meta Compiler Defining Words 01MAY82HHL: DEFERRED TARGET-CREATE TARGET 0 ,-T ; : CODE TARGET-CREATE HERE-T 2+ ,-T [COMPILE] ASSEMBLER !CSP ; : C; IN-META ?CSP ; : IMMEDIATE WIDTH @ IF LATEST @ THERE 64 TOGGLE THEN ; \ Meta Compiler Transition Words 29Jun82mapT: ( [COMPILE] ( T; T: (S [COMPILE] (S T; T: \ [COMPILE] \ T; : STRING,-T (S -- ) ASCII " WORD DUP C@ 1+ S,-T ; T: ." TARGET <(.")> META STRING,-T T; T: " TARGET <(")> META STRING,-T T; : 'T (S -- pfa ) FIND NOT ABORT" not in TARGET" ; T: ['] 'T @ 2+ TARGET TRANSITION LITERAL META T; T: ABORT" TARGET <(ABORT")> META STRING,-T T; T: IS TARGET <(IS)> META T; \ Meta Compiler Transition Words 01MAY82HHLT: ;CODE (S -- taddr ) TARGET <(;CODE)> META HERE-T [COMPILE] ASSEMBLER !CSP R> DROP T; T: DOES> (S -- taddr ) TARGET <(;CODE)> META HERE-T 205 ( CALL ) C,-T TARGET META T; T: ; TARGET META IN-META R> DROP T; T: [COMPILE] [COMPILE] TARGET 'T EXECUTE TARGET [COMPILE] TRANSITION META T; \ Meta Compiler Resolve Forward References 02MAY82HHL: .UNRESOLVED (S -- ) IN-TARGET CONTEXT @ @ BEGIN DUP PFA RESOLVED? NOT IF ?CR DUP ID. THEN 2- ( NFA -> LFA ) @ DUP 0= ?KEY OR UNTIL DROP IN-META ; : FIND-UNRESOLVED (S -- pfa ) IN-TARGET 'T BEGIN DUP RESOLVED? WHILE HERE SWAP LFA @ (FIND) NOT ABORT" Already Resolved" DROP REPEAT IN-META ; : RESOLVE (S taddr pfa -- ) 2DUP 1 OVER 2+ C! @ BEGIN DUP WHILE 2DUP @-T -ROT SWAP !-T REPEAT 2DROP ! ; : RESOLVES (S taddr -- ) FIND-UNRESOLVED RESOLVE ; \ Cross-Ref 26AUG82MCS: LIST-ID (S nfa -- ) DUP PFA @ 4 U.R SPACE ( value ) DUP ID. C@ 31 AND 13 SWAP - SPACES >OUT @ 60 > IF CR THEN ; : .CROSS-REF (S -- ) IN-TARGET BASE @ HEX CR CONTEXT @ @ BEGIN DUP LIST-ID 2- @ DUP 0= ?KEY OR UNTIL DROP BASE ! IN-META ; \ Meta Compiler set up : and HOST 02MAY82HHL: : TARGET-CREATE TARGET META ] ; H: ' CONTEXT @ IN-TARGET 'T @ 2+ IN-META SWAP CONTEXT ! ; H: , ,-T ; H: C, C,-T ; H: GO HERE ! HERE 2+ EXECUTE ; H: HERE HERE-T ; H: ALLOT ALLOT-T ; 24AUG82MCS \ TEXT>BLK - Load Screen 09NOV82MCS BLK @ LIST 1 5 +THRU EXIT TEXT>BLK is a utility which may be used to transfer a CP/M text file to a sequence of FORTH screens. The file is transferred a line at a time. 8 bits are masked, TABs are expanded and short lines are padded with blanks. \ TEXT>BLK - TEXT-LINE 09NOV82MCS 128 CONSTANT BUF VARIABLE EOF 0 CONSTANT SKIP VARIABLE LN# VARIABLE CH# : END ( -- ) 1 EOF ! ; : CH>PAD ( C --- ) CH# @ PAD + C! 1 CH# +! ; : TEXT-LINE ( -- ) PAD SCR @ BLOCK LN# @ C/L * + C/L CMOVE UPDATE 0 CH# ! 1 LN# +! PAD C/L BLANK LN# @ 16 = IF SKIP LN# ! 1 SCR +! THEN ; : TAB ( -- ) 8 CH# @ OVER MOD - 0 DO BL CH>PAD LOOP ; \ TEXT>BLK - TEXT-BUF 09NOV82MCS: TEXT-BUF ( -- ) BUF 128 RANGE DO I C@ 127 AND ( MASK 8 BIT ) DUP BL < IF ( CTL ) DUP 13 = IF ( CR ) TEXT-LINE ELSE DUP 9 = IF ( TAB ) TAB ELSE DUP 26 = IF ( EOF ) TEXT-LINE 1 EOF ! LEAVE ELSE DROP THEN THEN THEN ELSE ( PRINTABLE ) \ DUP ASCII ; = IF 0 CH>PAD CH>PAD ELSE DUP 127 < IF ( NOT DELETE ) CH>PAD ELSE DROP ( THEN ) THEN THEN EOF @ IF LEAVE THEN LOOP ; EXIT SEND PRINTABLE CHARACTERS TO PAD. EXPAND TABS. EXECUTES TEXT-LINE AT END OF LINE ( CR ). CTL Z DOES TEXT-LINE, THEN SETSEND OF FILE AND LEAVES. OTHER CONTROL CHARACTERS ARE DROPPED. \ TEXT>BLK - DOS-FNC FCBQ BUF FILE-TYPE 26dec82mcs 92 CONSTANT FCB1 : DOS-FNC ( n -- ) CREATE , DOES> ( arg -- f ) @ FCB @ SWAP BDOS ; 20 DOS-FNC SEQ-READ 21 DOS-FNC SEQ-WRITE 19 DOS-FNC DELETE 22 DOS-FNC MAKE 16 DOS-FNC CLOSE 15 DOS-FNC OPEN : FILE-TYPE ( -- addr ) FCB @ 9 + ; \ TEXT>BLK - (!FCB) !FCB 09NOV82MCS: (!FCB) (S Addr len --- ) FCB @ DUP 38 ERASE DUP 1+ 11 BLANK >R OVER 1+ C@ ASCII : = IF OVER C@ UPC [ ASCII A 1- ] LITERAL - R@ C! 2 S+ THEN R> 1+ -ROT 0 DO DUP C@ ASCII . = IF SWAP 8 I - + SWAP 1+ ELSE 2DUP C@ SWAP C! 1+ SWAP 1+ SWAP THEN LOOP 2DROP ; : !FCB BL WORD COUNT (!FCB) ; EXIT \ TEXT>BLK - TEXT>BLK 09NOV82MCS: TEXT>BLK ( scr -- ) ( file name ) SCR ! 0 EOF ! 0 CH# ! SKIP LN# ! PAD C/L BLANK FCB1 FCB ! !FCB OPEN-FILE CPM-ERR? ABORT" File Open Error" BEGIN BUF SET-DMA FCB1 FCB ! SEQ-READ NOT WHILE TEXT-BUF REPEAT ; \ AUTO CODE - Load Screen 03sep83mcsBLK @ LIST CR CR ." WARNING - CRC uses master reset on HARD DISK" CR ." Code is transformed in compiler" CR CR 1 39 HEX +THRU \ Load the code HEX A000 200 DECIMAL CP/M SAVE PROM.DAT CR ." Prom Image Saved as PROM.DAT" CR CR ." Code 08 09" CR DECIMAL EXIT \ Equates for AUTO Code 06sep83mcsHEX 8800 CONSTANT BUF BUF 100 / 1 - CONSTANT PRE BUF 100 / 4 + CONSTANT POST DECIMAL \ AUTO MODE - Compiler 11may83mcsHEX 7F00 2000 + 200 - CONSTANT EPROM-ORG A000 CONSTANT PROM-ORG A200 CONSTANT RAM-ORG VARIABLE OP-CODE VARIABLE DP-PROM : OP-SEC ( op sec -- ) 20 * SWAP 80 * + DP-PROM ! ; : RAM ( -- n ) 0 ; : SR ( -- n ) 2 ; : CRC ( -- n ) 1 ; : CW ( bus rd cm mk pr ie eprom -- ) DP-PROM @ EPROM-ORG + C! 4 * SWAP NOT 8 * + 20 + SWAP 10 * + SWAP 40 * + SWAP 80 * + + DP-PROM @ PROM-ORG + ! 1 DP-PROM +! DEPTH IF ( DROP ) DP-PROM @ RAM-ORG 1 - + C! THEN ; \ AUTO CODE - READ SECTOR 03sep83mcsEXIT Entry requirements: HL PRE+3 PCHL target for READ SYNC C 20 Sector Size / 32 LATCH ? RAM, READ, CMPR, MARK, PROM REVS 2 Index interrupts for timeout MODE 2 Vectored interrupt response IE 1 Interrupts enabled Header PRE+4 Location of header image COMMAND 3 1K sectors ( see C register ) EPROM LOCATION ARE RELATIVE TO ERPOM SIZE - 200H. \ AUTO CODE - READ SECTOR 03sep83mcs0 2 OP-SEC \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 37 CW \ scf A1 RAM 1 0 0 0 1 E9 CW \ pchl FE RAM 1 1 0 1 1 B7 CW \ ora a 00 RAM 1 1 0 1 1 00 CW \ nop 00 RAM 1 1 0 1 1 00 CW \ nop 00 RAM 1 1 0 1 1 00 CW \ nop 00 CRC 1 1 0 1 1 00 CW \ nop CRC 1 1 0 1 1 00 CW \ nop RAM 1 1 0 1 1 21 CW \ lxi h, RAM 1 0 0 1 1 0ED CW \ data RAM 0 0 0 1 1 PRE CW \ pchl+1 \ AUTO CODE - READ SECTOR 11may83mcs\ BUS R C M P L EPROM COMMENT A1 RAM 1 0 0 0 1 E9 CW \ pchl - loop until sF8 SR 1 1 0 1 1 DD CW \ jmp SR 1 0 0 1 1 E9 CW \ around write EXIT \ AUTO CODE - READ SECTOR 09jan83mcs0 1 OP-SEC \ BUS R C M P L EPROM COMMENT SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop \ AUTO CODE - READ SECTOR 09jan83mcs \ BUS R C M P L EPROM COMMENT SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop \ AUTO CODE - READ SECTOR 09jan83mcs \ BUS R C M P L EPROM COMMENT SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop \ AUTO CODE - READ SECTOR 03sep83mcs \ BUS R C M P L EPROM COMMENT SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 0D CW \ dcr c SR 1 0 0 1 1 CA CW \ jz SR 1 0 0 1 1 00 CW \ after SR 1 0 0 1 1 POST CW \ data field SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop \ AUTO CODE - READ SECTOR 11may83mcs0 3 OP-SEC \ BUS R C M P L EPROM COMMENT CRC 1 0 0 1 1 00 CW \ nop CRC 1 1 0 1 1 00 CW \ nop 00 RAM 1 1 0 1 1 C3 CW \ jmp 00 RAM 1 0 0 1 1 03 CW \ addr 00 RAM 0 0 0 1 1 00 CW \ addr 00 RAM 0 0 0 1 1 00 CW \ addr \ AUTO CODE - WRITE SECTOR 03sep83mcsEXIT \ \ Entry requirements: \ \ HL PRE+3 PCHL target for READ SYNC \ C 20 Sector Size / 32 \ LATCH ? RAM, READ, CMPR, MARK, PROM \ REVS 2 Index interrupts for timeout \ MODE 1 No interrupt response \ IE 1 Interrupts enabled \ Header PRE+4 Location of header image \ COMMAND 3 1K sectors ( see C register ) \ \ AUTO CODE - WRITE SECTOR 03sep83mcs1 2 OP-SEC \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 37 CW \ scf A1 RAM 1 0 0 0 1 E9 CW \ pchl FE RAM 1 1 0 1 1 B7 CW \ ora a 00 RAM 1 1 0 1 1 00 CW \ nop 00 RAM 1 1 0 1 1 00 CW \ nop 00 RAM 1 1 0 1 1 00 CW \ nop 00 CRC 1 1 0 1 1 00 CW \ nop CRC 1 1 0 1 1 C3 CW \ jmp RAM 1 1 0 1 1 F7 CW \ around RAM 1 0 0 1 1 PRE CW \ read \ AUTO CODE - WRITE SECTOR 10may83mcs \ BUS R C M P L EPROM COMMENT 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop 00 RAM 0 0 0 1 1 00 CW \ nop \ AUTO CODE - WRITE SECTOR 03sep83mcs \ BUS R C M P L EPROM COMMENT 00 RAM 0 0 0 1 1 16 CW \ mvi d, 00 RAM 0 1 0 1 1 03 CW \ 3 00 RAM 0 1 0 1 1 15 CW \ dcr d 00 RAM 0 1 0 1 1 C2 CW \ jnz 00 RAM 0 1 0 1 1 F9 CW \ loop for 00 RAM 0 1 0 1 1 PRE CW \ preamble 00 RAM 0 1 0 0 1 00 CW \ nop A1 RAM 0 1 1 1 1 00 CW \ nop F8 RAM 0 1 0 1 1 00 CW \ nop \ AUTO CODE - WRITE SECTOR 10may83mcs1 1 OP-SEC \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop EXIT \ AUTO CODE - WRITE SECTOR 10may83mcs \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop EXIT \ AUTO CODE - WRITE SECTOR 10may83mcs \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop EXIT \ AUTO CODE - WRITE SECTOR 03sep83mcs \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 00 CW \ nop E5 RAM 0 1 0 1 1 0D CW \ dcr c E5 RAM 0 1 0 1 1 CA CW \ jz E5 RAM 0 1 0 1 1 00 CW \ addr E5 RAM 0 1 0 1 1 POST CW \ addr E5 RAM 0 1 0 1 1 00 CW \ nop EXIT \ AUTO CODE - WRITE SECTOR 10may83mcs1 3 OP-SEC \ BUS R C M P L EPROM COMMENT CRC 0 1 0 1 1 00 CW \ nop CRC 0 1 0 1 1 00 CW \ nop RAM 0 1 0 1 1 00 CW \ nop 00 RAM 0 1 0 1 1 C3 CW \ jmp 00 RAM 0 1 0 1 1 03 CW \ addr 00 RAM 0 0 0 1 1 00 CW \ addr \ AUTO CODE - READ HEADER 10may83mcsEXIT \ \ Entry requirements: \ \ LATCH ? SR, READ, PROM \ REVS 2 Index interrupts for timeout \ MODE 1 No interrupt response \ IE 1 Interrupts enabled \ \ F801 7 bytes of header which follow m \ AUTO CODE - READ HEADER 03sep83mcs2 2 OP-SEC \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 C3 CW \ jmp RAM 0 0 0 1 1 FB CW \ RAM 0 0 0 1 1 PRE CW \ RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop \ AUTO CODE - READ HEADER 03sep83mcs \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop \ AUTO CODE - READ HEADER 03sep83mcs \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 00 CW \ nop RAM 0 0 0 1 1 21 CW \ lxi h, RAM 0 0 0 1 1 FF CW \ data RAM 0 0 0 1 1 PRE CW \ pchl+1 A1 RAM 1 0 0 0 1 E9 CW \ pchl SR 1 0 0 1 1 00 CW \ nop \ AUTO CODE - READ HEADER 11may83mcs2 1 OP-SEC \ BUS R C M P L EPROM COMMENT SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop SR 1 0 0 1 1 00 CW \ nop RAM 1 0 0 1 1 00 CW \ nop RAM 1 0 0 1 1 C3 CW \ jmp RAM 1 0 0 1 1 03 CW \ RAM 0 0 0 1 1 00 CW \ RAM 0 0 0 1 1 00 CW \ \ AUTO CODE - FORMAT 15jun83mcsEXIT \ \ Entry requirements: \ B 3 Revolutions C 8 Number of sectors H 0F Gap 3 / 4 L 20 Sector Size / 32 Values shown are for 8 sectors of 1024 bytes \ AUTO CODE - FORMAT 03sep83mcs3 2 OP-SEC \ Wait for index \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 78 CW \ mov a,b RAM 0 0 0 1 1 FE CW \ cpi , RAM 0 0 0 1 1 01 CW \ 1 RAM 0 0 0 1 1 CA CW \ jz RAM 0 0 0 1 1 E7 CW \ RAM 0 0 0 1 1 PRE CW \ RAM 0 0 0 1 1 76 CW \ hlt EXIT f7e0-f7e6 \ AUTO CODE - FORMAT 03sep83mcs \ Write 16 bytes of 4E at start of track. \ BUS R C M P L EPROM COMMENT RAM 0 0 0 1 1 16 CW \ mvi d, RAM 0 0 0 1 1 04 CW \ 4 4E RAM 0 1 0 1 1 15 CW \ dcr d 4E RAM 0 1 0 1 1 C2 CW \ jnz 4E RAM 0 1 0 1 1 E9 CW \ 4E RAM 0 1 0 1 1 PRE CW \ EXIT f7e7-f7ec \ AUTO CODE - FORMAT 03sep83mcs \ Write preamble of 13 bytes of 00. \ BUS R C M P L EPROM COMMENT 00 RAM 0 1 0 1 1 16 CW \ mvi d, 00 RAM 0 1 0 1 1 02 CW \ 2 00 RAM 0 1 0 1 1 15 CW \ dcr d 00 RAM 0 1 0 1 1 00 CW \ nop 00 RAM 0 1 0 1 1 C2 CW \ jnz 00 RAM 0 1 0 1 1 EF CW \ 00 RAM 0 1 0 1 1 PRE CW \ 00 RAM 0 1 0 0 1 00 CW \ EXIT f7ed-f7f4 \ AUTO CODE - FORMAT 11may83mcs \ Write header mark. \ BUS R C M P L EPROM COMMENT A1 RAM 0 1 1 1 1 00 CW \ FE RAM 0 1 0 1 1 00 CW \ EXIT f7f5-f7f6 \ AUTO CODE - FORMAT 11may83mcs \ RAM BUS R C M P L EPROM COMMENT 11 RAM 0 1 0 1 1 06 CW \ mvi b, 11 RAM 0 1 0 1 1 POST CW \ 11 RAM 0 1 0 1 1 0A CW \ ldax b CRC 0 1 0 1 1 16 CW \ mvi d, RAM 0 1 0 1 1 03 CW \ 3 00 RAM 0 1 0 0 1 15 CW \ dcr d 00 RAM 0 1 0 0 1 00 CW \ 00 RAM 0 1 0 0 1 C2 CW \ jnz 00 RAM 0 1 0 0 1 FC CW \ F7FC EXIT f7f7-f7ff \ AUTO CODE - FORMAT 03sep83mcs3 1 OP-SEC \ BUS R C M P L EPROM COMMENT 00 RAM 0 1 0 0 1 PRE CW \ A1 RAM 0 1 1 1 1 00 CW \ F8 RAM 0 1 0 1 1 5D CW \ mov e,l EXIT f800-f802 \ AUTO CODE - FORMAT 03sep83mcs \ Write 22 bytes of data field \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 16 CW \ mvi d, E5 RAM 0 1 0 1 1 05 CW \ 5 E5 RAM 0 1 0 1 1 15 CW \ dcr d E5 RAM 0 1 0 1 1 C2 CW \ jnz E5 RAM 0 1 0 1 1 05 CW \ E5 RAM 0 1 0 1 1 BUF CW \ EXIT f803-f808 \ AUTO CODE - FORMAT 03sep83mcs \ Exit outer loop early if last 32 byte block. \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 1D CW \ dcr e E5 RAM 0 1 0 1 1 CA CW \ jz E5 RAM 0 1 0 1 1 13 CW \ E5 RAM 0 1 0 1 1 BUF CW \ EXIT f809-f80c \ AUTO CODE - FORMAT 03sep83mcs \ Complete outer loop if more blocks of 32 bytes. \ BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 C3 CW \ jmp E5 RAM 0 1 0 1 1 03 CW \ E5 RAM 0 1 0 1 1 BUF CW \ EXIT f80d-f812 \ AUTO CODE - FORMAT 03sep83mcs \ Complete outer loop for final block of 32 bytes. \ RAM BUS R C M P L EPROM COMMENT E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 RAM 0 1 0 1 1 00 CW \ E5 CRC 0 1 0 1 1 C3 CW \ jmp CRC 0 1 0 1 1 10 CW \ RAM 0 1 0 1 1 POST CW \ EXIT f813-f81a \ AUTO CODE - FORMAT 15jun83mcs3 3 OP-SEC \ RAM BUS R C M P L EPROM COMMENT 00 CRC 0 1 0 1 1 00 CW \ 08 CRC 0 1 0 1 1 00 CW \ 07 CRC 0 1 0 1 1 00 CW \ 06 CRC 0 1 0 1 1 00 CW \ 05 CRC 0 1 0 1 1 00 CW \ 04 CRC 0 1 0 1 1 00 CW \ 03 CRC 0 1 0 1 1 00 CW \ 02 CRC 0 1 0 1 1 00 CW \ 01 CRC 0 1 0 1 1 00 CW \ EXIT fc00-fc08 \ AUTO CODE - FORMAT 15jun83mcs \ RAM BUS R C M P L EPROM COMMENT 08 CRC 0 1 0 1 1 00 CW \ 07 CRC 0 1 0 1 1 00 CW \ 06 CRC 0 1 0 1 1 00 CW \ 05 CRC 0 1 0 1 1 00 CW \ 04 CRC 0 1 0 1 1 00 CW \ 03 CRC 0 1 0 1 1 00 CW \ 02 CRC 0 1 0 1 1 00 CW \ EXIT fc09-fc0f \ AUTO CODE - FORMAT 03sep83mcs \ Write postamble and Gap3. \ RAM BUS R C M P L EPROM COMMENT 00 RAM 0 1 0 1 1 54 CW \ mov d,h 00 RAM 0 1 0 1 1 15 CW \ dcr d 4E RAM 0 1 0 1 1 15 CW \ dcr d 4E RAM 0 1 0 1 1 C2 CW \ jnz 4E RAM 0 1 0 1 1 12 CW \ 4E RAM 0 1 0 1 1 POST CW \ EXIT fc10-fc15 \ AUTO CODE - FORMAT 03sep83mcs \ Complete postamble. Loop if more sectors to do. \ RAM BUS R C M P L EPROM COMMENT 4E RAM 0 1 0 0 1 0D CW \ dcr c 4E RAM 0 1 0 0 1 C2 CW \ jnz 4E RAM 0 1 0 0 1 0ED CW \ 4E RAM 0 1 0 0 1 PRE CW \ \ Write 4E to end of track if no more sectors. 4E RAM 0 1 0 0 1 06 CW \ mvi b, 4E RAM 0 1 0 0 1 01 CW \ 1 4E RAM 0 1 0 0 1 76 CW \ hlt - until index 4E RAM 0 1 0 0 1 00 CW \ EXIT fc16-fc1a \ MP11 Target System Setup META DEFINITIONS HEX 0 EQU ROM-ORG \ Origin of ROM 4000 EQU RAM-ORG \ Run Time start 7000 EQU LIMIT-T \ Run time end 0 LATEST ! \ Seal Vocabulary 40 EQU US \ User Area Size A0 EQU RTS \ Return Stack Size DECIMAL EXIT \ MP11 - Buffer and Disk Constants and Equates HEX \ Buffer Area Equates BUF 20 - EQU PRE PRE 4 + EQU IMAGE BUF EQU BUFFER BUF 400 + EQU BUF-TAIL \ Hard Disk Parameters 300 EQU STEP-RATE 300 EQU SLOW 1500 EQU HEAD-SETTLE 80 EQU LC-TRK 80 EQU PR-TRK 10 EQU #TRYS DECIMAL \ MP11 - Constants and Equates 03sep83mcsHEX 40 EQU DRV 41 EQU BANK 4B EQU MODE 4F EQU CTL C0 EQU STAT C2 EQU CLRINT DECIMAL EXIT See screen 143 for serial I/O equates \ Cold boot jump table 03sep83mcsHEX 0 DP-T ! 7F00 0 HOST-TARGET ASSEMBLER -1 JMP \ Cold Boot Entry NOP -1 JMP \ Return Location From Auto HERE 1 THERE ! 10 A MVI 41 OUT \ Set AUTO-ENA in BANK A XRA 4F OUT 41 OUT \ Clear CTL and BANK 100 H LXI RAM-ORG D LXI \ Source & Destination 1D00 B LXI 0ED C, 0B0 C, \ Copy Forth to Ram CLRINT IN \ CLEAR INTR RAM-ORG JMP EXIT \ Entry for AUTO mode HEX LABEL (AUTO) ASSEMBLER 30 A MVI BANK OUT CTL B LXI \ CTL F4 A MVI \ RD,CM,MK,IE,RAM 0ED C, 79 C, \ OUT @C,A A XRA 0ED C, 47 C, \ I = 0 PRE 3 + H LXI \ TARGET OF PCHL 320 B LXI \ REVS / SIZE 0ED C, 05E C, \ MODE 2 0DD C, 021 C, BUFFER , \ BUFFER TO IX FOR LATER JMP CLRINT IN \ CLR INTR 0FB C, PRE JMP \ EI AND GO DECIMAL \ Exit for AUTO mode 03sep83mcsHEX LABEL (EXIT) ASSEMBLER 0F3 C, \ Disable interrupts A XRA CTL OUT \ Clear CTL register BANK OUT \ Clr MTR & AUTO-ENA RET \ and exit DECIMAL EXIT \ Interrupts -MATCH INDEX 14sep83mcsHEX ASSEMBLER HERE 0F6 THERE ! ( Code for -MATCH interrupt ) D POP ( Discard return ) CLRINT IN ( clear int ) 0FB C, ( Enable Interrupts ) PRE JMP ( And try again ) HERE 0F4 THERE ! ( Code for INDEX interrupt ) D POP ( Discard return ) B DCR ( Decrement revolutions ) 0= NOT IF CLRINT IN ( Clear Int ) 0FB C, ( Enable ) PRE 3 + H LXI PRE JMP ( And keep trying ) THEN 1 H LXI ( status ) (EXIT) JMP HERE 005 THERE ! ( Patch Exit-Auto to here ) 0F3 C, ( Disable interrupts ) 0 H LXI ( OK Status ) (EXIT) JMP DECIMAL \ Pre-Buf Image 03sep83mcsHEX 0C2 DP-T ! A1 C, FE C, 0CC DP-T ! A1 C, F8 C, 0DE DP-T ! A1 C, F8 C, DECIMAL EXIT \ Boot up Literals HEX RAM-ORG DP-T ! 8000 RAM-ORG HOST-TARGET HERE EQU ORIGIN ASSEMBLER NOP LABEL CLD -1 JMP NOP LABEL WRM -1 JMP 2 C, 0 C, 0 C, ( RELEASE, VERSION, USER ) 0E C, ( MACHINE PARAMETERS ) 0 , ( NFA OF LATEST DEF ) 8 , ( INPUT BACKSPACE ) 0 , ( UP ) 0 , ( S0 ) 0 , ( R0 ) 0 , ( TIB ) 01F ( WIDTH ) , 0 , ( WARNING ) 0 , ( FENCE ) 0 , ( DP ) 0 , ( VOC-LINK ) LABEL UP 0 , ( USER POINTER ) LABEL RPP 0 , ( RETURN STACK POINTER ) DECIMAL LABEL DPUSH D PUSH LABEL HPUSH H PUSH LABEL NEXT B LDAX B INX A L MOV B LDAX B INX A H MOV LABEL NEXT1 M E MOV H INX M D MOV XCHG PCHL \ EXECUTE (LIT) BRANCH ?BRANCH 04MAY82HHLCODE EXECUTE (S pfa -- ) H POP H DCX H DCX NEXT1 JMP C; CODE (LIT) (S -- n ) B LDAX B INX A L MOV B LDAX B INX A H MOV HPUSH JMP C; CODE BRANCH (S -- ) B H MOV C L MOV M E MOV H INX M D MOV H DCX D DAD L C MOV H B MOV NEXT JMP C; CODE ?BRANCH (S f -- ) H POP L A MOV H ORA ' BRANCH JZ B INX B INX NEXT JMP C; \ (LOOP) (+LOOP) 30APR82HHLCODE (LOOP) (S -- ) 1 D LXI LABEL XLOOP1 RPP LHLD M A MOV E ADD A M MOV A E MOV H INX M A MOV D ADC A M MOV H INX D INR D DCR A D MOV 0< NOT IF E A MOV M SUB D A MOV H INX M SBB ELSE M A MOV E SUB H INX M A MOV D SBB THEN ' BRANCH JM H INX RPP SHLD B INX B INX NEXT JMP C; CODE (+LOOP) (S n -- ) D POP XLOOP1 JMP C; \ (/LOOP) (DO) LEAVE 30APR82HHLCODE (/LOOP) (S n -- ) D POP RPP LHLD M A MOV E ADD A M MOV A E MOV H INX M A MOV D ADC A M MOV H INX D INR D DCR A D MOV E A MOV M SUB D A MOV H INX M SBB ' BRANCH JM H INX RPP SHLD B INX B INX NEXT JMP C; CODE (DO) (S n1 n2 -- ) RPP LHLD H DCX H DCX H DCX H DCX RPP SHLD D POP E M MOV H INX D M MOV D POP H INX E M MOV H INX D M MOV NEXT JMP C; CODE LEAVE RPP LHLD M E MOV H INX M D MOV H INX E M MOV H INX D M MOV NEXT JMP C; \ >R R> R@ I R I' J 30APR82HHLCODE R> (S -- n ) RPP LHLD M E MOV H INX M D MOV H INX RPP SHLD D PUSH NEXT JMP C; CODE >R (S n -- ) D POP RPP LHLD H DCX H DCX RPP SHLD E M MOV H INX D M MOV NEXT JMP C; CODE R@ RPP LHLD LABEL R@1 M E MOV H INX M D MOV D PUSH NEXT JMP C; CODE I -2 ALLOT ' R@ , C; CODE R -2 ALLOT ' R@ , C; CODE I' RPP LHLD H INX H INX R@1 JMP C; CODE J RPP LHLD H INX H INX H INX H INX R@1 JMP C; \ DIGIT 0= 0< NOT 30APR82HHLASSEMBLER LABEL PUSH-TRUE 1 H LXI HPUSH JMP LABEL PUSH-FALSE 0 H LXI HPUSH JMP LABEL DIGIT1 L CMP PUSH-FALSE JP A E MOV D PUSH PUSH-TRUE JMP CODE DIGIT (S char base -- [n] f ) H POP D POP E A MOV ASCII 0 SUI PUSH-FALSE JM 10 CPI 0< NOT IF 7 SUI 10 CPI PUSH-FALSE JM THEN DIGIT1 JMP C; CODE 0= (S n -- f ) H POP L A MOV H ORA PUSH-TRUE JZ PUSH-FALSE JMP C; CODE 0< (S n -- f ) H POP H DAD PUSH-TRUE JC PUSH-FALSE JMP C; CODE NOT -2 ALLOT ' 0= , C; \ (FIND) 30APR82HHLHEX CODE (FIND) (S here nfa -- [ pfa len ] f ) H POP BEGIN D POP D PUSH H PUSH D LDAX M XRA 3F ANI 0= IF BEGIN D INX H INX D LDAX M XRA A ADD 0= IF SWAP CS UNTIL H INX H INX H INX D POP XTHL XCHG M E MOV 0 D MVI 1 H LXI DPUSH JMP THEN THEN H POP H DCX M D MOV H DCX M E MOV XCHG L A MOV H ORA 0= UNTIL XTHL NEXT JMP C; DECIMAL \ ENCLOSE for 1024 byte buffers 30APR82HHLASSEMBLER LABEL ENCL1 B POP D PUSH D INX D PUSH NEXT JMP LABEL ENCL2 B POP D INX D PUSH D DCX D PUSH NEXT JMP CODE ENCLOSE ( address\delim --- address\n1\n2\n3 ) \ n1 is offset to 1st nondelim,n2 to next delim\n3 to next char D POP H POP H PUSH E A MOV -1 D LXI H DCX BEGIN H INX D INX M CMP 0= NOT UNTIL D PUSH B PUSH A C MOV M A MOV A ANA ENCL2 JZ BEGIN H INX D INX M A MOV C CMP ENCL1 JZ A ANA 0= UNTIL B POP D PUSH D PUSH NEXT JMP C; \ + D+ NEGATE DNEGATE D- 30APR82HHLCODE + (S n1 n2 -- sum ) D POP H POP D DAD HPUSH JMP C; CODE D+ (S d1 d2 -- dsum ) 6 H LXI SP DAD M E MOV C M MOV H INX M D MOV B M MOV B POP H POP D DAD XCHG H POP L A MOV C ADC A L MOV H A MOV B ADC A H MOV B POP DPUSH JMP C; CODE NEGATE (S n -- n' ) H POP L A MOV CMA A L MOV H A MOV CMA A H MOV H INX HPUSH JMP C; CODE DNEGATE (S d -- d' ) H POP D POP A SUB E SUB A E MOV 0 A MVI D SBB A D MOV 0 A MVI L SBB A L MOV 0 A MVI H SBB A H MOV DPUSH JMP C; \ OVER DROP SWAP DUP ROT -ROT 30APR82HHLCODE OVER (S n1 n2 -- n1 n2 n1 ) D POP H POP H PUSH DPUSH JMP C; CODE DROP (S n1 -- ) H POP NEXT JMP C; CODE SWAP (S n1 n2 -- n2 n1 ) H POP XTHL HPUSH JMP C; CODE DUP (S n1 -- n1 n1 ) H POP H PUSH HPUSH JMP C; CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) D POP H POP XTHL DPUSH JMP C; CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) H POP D POP XTHL XCHG DPUSH JMP C; \ 2SWAP 2OVER PICK 2DROP 2DUP 30APR82HHLCODE 2SWAP (S d1 d2 -- d2 d1 ) H POP D POP XTHL H PUSH 5 H LXI SP DAD M A MOV D M MOV A D MOV H DCX M A MOV E M MOV A E MOV H POP DPUSH JMP C; CODE 2OVER (S d2 d2 -- d1 d2 d1 ) 7 H LXI SP DAD M D MOV H DCX M E MOV D PUSH H DCX M D MOV H DCX M E MOV D PUSH NEXT JMP C; CODE PICK (S nm ... n2 n1 k -- nm ... n2 n1 nk ) H POP H DCX H DAD SP DAD M E MOV H INX M D MOV D PUSH NEXT JMP C; CODE 2DROP (S d -- ) H POP H POP NEXT JMP C; CODE 2DUP (S d -- d d ) H POP D POP D PUSH H PUSH DPUSH JMP C; \ +! TOGGLE 2* 2/ 30APR82HHLCODE +! (S n addr -- ) H POP D POP M A MOV E ADD A M MOV H INX M A MOV D ADC A M MOV NEXT JMP C; CODE TOGGLE (S addr n -- ) D POP H POP M A MOV E XRA A M MOV H INX M A MOV D XRA A M MOV NEXT JMP C; CODE 2* (S n -- 2*n ) H POP H DAD HPUSH JMP C; CODE 2/ (S n -- n/2 ) H POP H A MOV RLC RRC RAR A H MOV L A MOV RAR A L MOV HPUSH JMP C; \ 1+ 2+ 1- 2- S->D 11MAY82HHLCODE 1+ H POP H INX HPUSH JMP C; CODE 2+ H POP H INX H INX HPUSH JMP C; CODE 1- H POP H DCX HPUSH JMP C; CODE 2- H POP H DCX H DCX HPUSH JMP C; CODE S->D (S n -- d ) D POP 0 H LXI D A MOV 128 ANI 0= NOT IF H DCX THEN DPUSH JMP C; \ CMOVE FILL NOOP 30APR82HHLCODE CMOVE ( from to count -- ) C L MOV B H MOV B POP D POP XTHL HERE 8 + JMP BEGIN M A MOV H INX D STAX D INX B DCX ( JMP ABOVE GETS HERE ) B A MOV C ORA 0= UNTIL B POP NEXT JMP C; CODE FILL ( start-addr count char -- ) C L MOV B H MOV D POP B POP XTHL XCHG BEGIN B A MOV C ORA 0= NOT WHILE L A MOV D STAX D INX B DCX REPEAT B POP NEXT JMP C; CODE NOOP NEXT JMP C; \ U* 30APR82HHL ASSEMBLER LABEL MPYX 0 H LXI ( 0=PARTIAL PROD ) 4 C MVI ( LOOP COUNTER ) BEGIN H DAD ( LEFT SHIFT AHL 24 BITS ) RAL CS IF D DAD 0 ACI THEN H DAD RAL CS IF D DAD 0 ACI THEN C DCR 0= UNTIL RET CODE U* (S n1 n2 -- d ) D POP H POP B PUSH H B MOV L A MOV MPYX CALL H PUSH A H MOV B A MOV H B MOV MPYX CALL D POP D C MOV B DAD 0 ACI L D MOV H L MOV A H MOV B POP DPUSH JMP C; \ DIVIDE SUBROUTINES 26FEB82HHLASSEMBLER LABEL USL0 A E MOV H A MOV C SUB A H MOV E A MOV B SBB CS IF H A MOV C ADD A H MOV E A MOV D DCR RZ LABEL USLA H DAD RAL USL0 JNC A E MOV H A MOV C SUB A H MOV E A MOV B SBB THEN L INR D DCR USLA JNZ RET LABEL USBAD -1 H LXI B POP H PUSH HPUSH JMP \ U/ 30APR82HHL CODE U/ (S d1 n1 -- Remainder Quotient ) B H MOV C L MOV B POP D POP XTHL XCHG ( HLDE = NUMERATOR BC = DENOMINATOR ) L A MOV C SUB H A MOV B SBB USBAD JNC H A MOV L H MOV D L MOV 8 D MVI D PUSH USLA CALL D POP H PUSH E L MOV USLA CALL A D MOV H E MOV B POP C H MOV B POP D PUSH HPUSH JMP C; \ AND OR XOR FLIP 30APR82HHLCODE AND (S n1 n2 -- n3 ) D POP H POP E A MOV L ANA A L MOV D A MOV H ANA A H MOV HPUSH JMP C; CODE OR (S n1 n2 -- n3 ) D POP H POP E A MOV L ORA A L MOV D A MOV H ORA A H MOV HPUSH JMP C; CODE XOR (S n1 n2 -- n3 ) D POP H POP E A MOV L XRA A L MOV D A MOV H XRA A H MOV HPUSH JMP C; CODE FLIP (S n1 n2 -- n3 ) H POP L A MOV CMA A L MOV H A MOV CMA A H MOV HPUSH JMP C; \ SP@ SP! RP@ RP! EXIT 30APR82HHLCODE SP@ (S -- n ) 0 H LXI SP DAD HPUSH JMP C; CODE SP! (S -- ) UP LHLD 6 D LXI D DAD M E MOV H INX M D MOV XCHG SPHL NEXT JMP C; CODE RP@ (S -- addr ) RPP LHLD HPUSH JMP C; CODE RP! (S -- ) UP LHLD 8 D LXI D DAD M E MOV H INX M D MOV XCHG RPP SHLD NEXT JMP C; CODE EXIT (S -- ) RPP LHLD M C MOV H INX M B MOV H INX RPP SHLD NEXT JMP C; \ @ C@ 2@! C! 2! 30APR82HHLCODE @ (S addr -- n ) H POP M E MOV H INX M D MOV D PUSH NEXT JMP C; CODE C@ (S addr -- char ) H POP M L MOV 0 H MVI HPUSH JMP C; CODE 2@ (S addr -- d ) H POP 2 D LXI D DAD M E MOV H INX M D MOV D PUSH -3 D LXI D DAD M E MOV H INX M D MOV D PUSH NEXT JMP C; CODE ! (S n addr -- ) H POP D POP E M MOV H INX D M MOV NEXT JMP C; CODE C! (S char addr -- ) H POP D POP E M MOV NEXT JMP C; CODE 2! (S d addr -- ) H POP D POP E M MOV H INX D M MOV H INX D POP E M MOV H INX D M MOV NEXT JMP C; \ EXECUTE VECTORS [ ] : ; 8Jun82mapDEFERRED LOAD DEFERRED KEY DEFERRED EMIT DEFERRED CR DEFERRED ?KEY DEFERRED CREATE DEFERRED R/W DEFERRED INTERPRET DEFERRED WHERE DEFERRED WARN : [ (S -- ) 0 STATE ! ; IMMEDIATE : ] (S -- ) 192 STATE ! ; : : (S -- ) ?EXEC !CSP CURRENT @ CONTEXT ! CREATE SMUDGE ] ;CODE RPP LHLD H DCX B M MOV H DCX C M MOV RPP SHLD D INX E C MOV D B MOV NEXT JMP C; IMMEDIATE RESOLVES : ; (S -- ) ?CSP COMPILE EXIT SMUDGE [COMPILE] [ ; IMMEDIATE \ CONSTANT USER 0 1 2 3 BL C/L TRUE FALSE NEXT 02MAY82HHL: CONSTANT CREATE , ;CODE D INX XCHG M E MOV H INX M D MOV D PUSH NEXT JMP C; RESOLVES : USER CONSTANT ;CODE D INX XCHG M E MOV 0 D MVI UP LHLD D DAD HPUSH JMP C; RESOLVES 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 32 CONSTANT BL 64 CONSTANT C/L 1 CONSTANT TRUE 0 CONSTANT FALSE ASSEMBLER NEXT META CONSTANT NEXT ASSEMBLER UP META EQU UP : +ORIGIN ORIGIN + ; \ USER VARIABLES 29Jun82map ( 0 THRU 5 ARE RESERVED ) 06 USER S0 ( INITIAL PARAMETER STACK ) 08 USER R0 ( INITIAL RETURN STACK ) 10 USER TIB ( TERMINAL INPUT BUFFER ) 12 USER WIDTH ( WIDTH OF NAME FIELD ) 14 USER WARNING ( CONTROL OF WARNING MESSAGES ) 16 USER FENCE ( BARRIER FOR FORGETTING ) 18 USER H ( DICTIONARY POINTER ) 18 USER DP ( DICTIONARY POINTER ) 20 USER VOC-LINK ( POINTS TO NEWEST VOCABULARY ) 22 USER BLK ( BLOCK NUMBER TO INTERPRET ) 24 USER >IN ( OFFSET INTO INPUT STREAM ) 26 USER >OUT ( NUMBER OF CHARACTERS EMITTED ) \ USER VARIABLES 05oct82mcs 28 USER SCR ( SCREEN LAST LISTED OR EDITED ) 30 USER OFFSET ( RELATIVE TO ABSOLUTE DISK BLOCK 0 ) 32 USER CONTEXT ( VOCABULARY SEARCHED FIRST ) 34 USER CURRENT ( VOCABULARY WHICH GETS DEFINITIONS ) 36 USER STATE ( COMPILATION OR INTERPRETATION ) 38 USER BASE ( FOR NUMERIC INPUT AND OUTPUT ) 40 USER DPL ( NUMERIC INPUT PUNCTUATION ) 40 USER PTR ( NUMERIC INPUT PUNCTUATION ) 42 USER FLD ( OUTPUT FIELD WIDTH ) 44 USER CSP ( FOR STACK POSITION ERROR CHECKING ) 46 USER R# ( EDITING CURSOR POSITION ) 48 USER HLD ( POINTS TO LAST CHARACTER HELD IN PAD ) 50 USER BLOCKS ( RANGE AVAILABLE FOR WRITING ) 52 USER FILES ( POINTS TO MOST RECENTLY OPENED FCB ) \ HERE ALLOT , C, - = < > <> SPACE ?DUP WITHIN U< 01MAY82HHL: HERE (S -- addr ) H @ ; : ALLOT (S n -- ) H +! ; : , (S n -- ) HERE ! 2 ALLOT ; : C, (S char -- ) HERE C! 1 ALLOT ; : - (S n1 n2 -- n3 ) NEGATE + ; : = (S n1 n2 -- f ) - 0= ; : < (S n1 n2 -- f ) - 0< ; : > (S n1 n2 -- f ) SWAP < ; : <> (S n1 n2 -- f ) = NOT ; : SPACE (S -- ) BL EMIT ; : ?DUP (S n -- [n] n ) DUP IF DUP THEN ; : WITHIN (S n min max+1 -- f ) >R 1- OVER < SWAP R> < AND ; : U< (S n1 n2 -- f ) 2DUP XOR 0< IF DROP 0< 0= ELSE - 0< THEN ; \ ERASE BLANK PAD DEPTH .S HEX DECIMAL ( EPRINT 30May82map: ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; : PAD (S -- addr ) HERE 80 + ; : DEPTH (S -- n ) SP@ S0 @ SWAP - 2/ ; : .S (S -- ) DEPTH ?DUP IF 0 DO DEPTH I - PICK 7 .R LOOP ELSE ." Empty" THEN ; : HEX (S -- ) 16 BASE ! ; : DECIMAL (S -- ) 10 BASE ! ; : ( (S -- ) 41 ( ( ) WORD DROP ; IMMEDIATE VARIABLE EPRINT \ TRAVERSE LATEST NFA LFA CFA PFA COMPILE SMUDGE 01MAY82HHL : TRAVERSE (S addr direction -- addr ) SWAP BEGIN OVER + 127 OVER C@ < UNTIL SWAP DROP ; : LATEST (S -- addr ) CURRENT @ @ ; : NFA (S addr -- addr') 3 - -1 TRAVERSE ; : LFA (S addr -- addr') NFA 2- ; : CFA (S addr -- addr') 2- ; : PFA (S addr -- addr') 1 TRAVERSE 3 + ; : COMPILE (S -- ) R> DUP 2+ >R @ , ; : SMUDGE (S -- ) LATEST 32 TOGGLE ; : IMMEDIATE (S -- ) LATEST 64 TOGGLE ; \ Error Checking 01MAY82HHL: !CSP SP@ CSP ! ; ( SAVE STACK POSITION IN 'CSP' *) : ?COMP STATE @ 0= ABORT" Compilation Only " ; : ?EXEC STATE @ ABORT" Execution Only " ; : ?PAIRS - ABORT" Conditionals not paired " ; : ?CSP SP@ CSP @ - ABORT" Definition not Finished" ; : ?LOADING BLK @ 0= ABORT" Use only when Loading" ; : ?MISSING IF HERE COUNT TYPE 1 ABORT" ?" THEN ; : ?STACK SP@ S0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; : ?ENOUGH (S n -- ) DEPTH 1- > ABORT" Not enough Parameters" ; \ (;CODE) ;CODE DOES> 01MAY82HHL: (;CODE) (S -- ) R> LATEST PFA CFA ! ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) [COMPILE] [ SMUDGE NOOP ( ASSEMBLER ) ; IMMEDIATE ASSEMBLER LABEL DODOES RPP LHLD H DCX B M MOV H DCX C M MOV RPP SHLD H POP L C MOV H B MOV D INX XCHG HPUSH JMP : DOES> COMPILE (;CODE) 205 C, [ ASSEMBLER DODOES ] LITERAL , ; IMMEDIATE \ VARIABLE VOCABULARY FORTH DEFINITIONS 01MAY82HHLHEX : VARIABLE CREATE 0 , ;CODE D INX D PUSH NEXT JMP C; RESOLVES : VOCABULARY CREATE CURRENT @ 2+ , A081 , HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES VOCABULARY FORTH IMMEDIATE DECIMAL : DEFINITIONS (S -- ) CONTEXT @ CURRENT ! ; \ CRASH DEFERRED (IS) IS 01MAY82HHL: CRASH (S -- ) 1 ABORT" This would have crashed!" ; : DEFERRED CREATE ['] CRASH , DOES> @ EXECUTE ; RESOLVES : (IS) (S PFA --- ) R @ 2+ ! R> 2+ >R ; : IS (S PFA --- ) STATE @ IF COMPILE (IS) ELSE ' ! THEN ; IMMEDIATE \ +- D+- ABS DABS D- MIN MAX 01MAY82HHL: +- (S n1 n2 -- n3 ) 0< IF NEGATE THEN ; : D+- (S d1 n -- d2 ) 0< IF DNEGATE THEN ; : ABS (S n1 -- n2 ) DUP +- ; : DABS (S d1 -- d2 ) DUP D+- ; : D- (S d1 d2 -- d3 ) DNEGATE D+ ; : MIN (S n1 n2 -- n3 ) 2DUP > IF SWAP THEN DROP ; : MAX (S n1 n2 -- n3 ) 2DUP < IF SWAP THEN DROP ; \ M* M/ * /MOD / MOD */MOD */ M/MOD 01MAY82HHL: M* (S n1 n2 -- d# ) 2DUP XOR >R ABS SWAP ABS U* R> D+- ; : M/ (S d# n1 -- rem quot ) OVER >R >R DABS R ABS U/ R> R XOR +- SWAP R> +- SWAP ; : * (S n1 n2 -- n3 ) U* DROP ; : /MOD (S n1 n2 -- rem quot ) >R S->D R> M/ ; : / (S n1 n2 -- quot ) /MOD SWAP DROP ; : MOD (S n1 n2 -- rem ) /MOD DROP ; : */MOD (S n1 n2 n3 -- rem quot ) >R M* R> M/ ; : */ (S n1 n2 n3 -- n1*n2/n3 ) */MOD SWAP DROP ; : M/MOD (S d# n1 -- rem d#quot ) >R 0 R U/ R> SWAP >R U/ R> ; \ SPACES <# # #S #> SIGN 01MAY82HHL: SPACES (S n -- ) 0 MAX ?DUP IF 0 DO SPACE LOOP THEN ; : HOLD (S char -- ) -1 HLD +! HLD @ C! ; : <# (S -- ) PAD HLD ! ; : #> (S d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN (S n1 d# -- d# ) ROT 0< IF 45 ( - ) HOLD THEN ; : # (S -- ) BASE @ M/MOD ROT 9 OVER < IF 7 + THEN 48 + HOLD ; : #S (S -- ) BEGIN # 2DUP OR 0= UNTIL ; \ D.R UD.R D. UD. .R . ? U. U.R 01MAY82HHL: D.R (S d# n -- ) >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE ; : UD.R (S d# n -- ) >R <# #S #> R> OVER - SPACES TYPE ; : D. (S d# -- ) 0 D.R SPACE ; : UD. (S d# -- ) 0 UD.R SPACE ; : .R (S n fld -- ) >R S->D R> D.R ; : . (S n -- ) S->D D. ; : ? (S addr -- ) @ . ; : U. (S n -- ) 0 D. ; : U.R (S n fld -- ) 0 SWAP D.R ; \ WORD 29Jun82map : WORD ( delimiter -- address ) BLK @ IF BLK @ BLOCK ELSE TIB @ THEN >IN @ + SWAP ( ADDRESS-2, DELIMITER-1 ) ENCLOSE ( ADDRESS-4, START-3, END-2, TOTAL COUNT-1 ) HERE 22 BLANK ( PREPARE FIELD OF 34 BLANK ) >IN +! ( STEP OVER THIS STRING ) OVER - >R ( SAVE CHAR COUNT ) R HERE C! ( LENGTH STORED FIRST ) + HERE 1+ R> CMOVE ( MOVE STRING FROM BUFFER TO HERE+1 ) HERE ; ( AND RETURN ADDRESS OF WORDS BUFFER ) \ (NUMBER) NUMBER -FIND 02MAY82HHLHEX : (NUMBER) ( CONVERT DOUBLE NUMBER, LEAVING UNCONV. ADDR. *) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ U* DROP ROT BASE @ U* D+ DPL @ 1+ IF 1 DPL +! THEN R> REPEAT R> ; : NUMBER ( ENTER W/ STRING ADDR. LEAVE DOUBLE NUMBER *) 0 0 ROT DUP 1+ C@ 2D = DUP >R + -1 BEGIN DPL ! (NUMBER) DUP C@ BL - WHILE DUP C@ 2E - ?MISSING 0 REPEAT DROP R> IF DNEGATE THEN ; : -FIND ( RETURN PFA-3, LEN BYTE-2, TRUE-1; ELSE FALSE *) BL WORD CONTEXT @ @ (FIND) DUP 0= IF DROP HERE LATEST (FIND) THEN ; DECIMAL \ COUNT TYPE -TRAILING (.") ." (") " 28Jun82map: COUNT (S addr --- addr+1 cnt ) DUP 1+ SWAP C@ ; : TYPE (S addr len -- ) ?DUP IF 0 DO DUP C@ EMIT 1+ LOOP THEN DROP ; : -TRAILING (S addr len -- addr len' ) DUP 0 DO 2DUP + 1- C@ BL - IF LEAVE ELSE 1- THEN LOOP ; : (.") (S -- ) R> COUNT 2DUP + >R TYPE ; : ." (S -- ) 34 ( " ) STATE @ IF COMPILE (.") WORD C@ 1+ ALLOT ELSE WORD COUNT TYPE THEN ; IMMEDIATE : (") R> COUNT 2DUP + >R ; : " COMPILE (") 34 WORD C@ 1+ ALLOT ; IMMEDIATE \ EXPECT 27Jul82map: EXPECT ( ADDR LEN --- ) SWAP 0 >R BEGIN OVER R = IF + 0 SWAP ! R> DROP EXIT THEN KEY DUP 16 ( ^P ) = IF EPRINT 1 TOGGLE DROP BL THEN DUP 08 = OVER 127 = OR IF DROP R IF R> 1 - >R 8 EMIT SPACE 8 EMIT THEN ELSE DUP 21 ( ^U ) = IF DROP ." XXX" CR R> DROP 0 >R ELSE DUP 27 ( ESC ) = IF [COMPILE] FORTH DEFINITIONS 1 ABORT" Reset " ELSE DUP 13 ( CR ) = IF DROP BL EMIT R> + 0 SWAP ! DROP EXIT ELSE DUP EMIT OVER R + C! R> 1+ >R THEN THEN THEN THEN AGAIN ; \ (CREATE) [COMPILE] LITERAL DLITERAL 8Jun82map: (CREATE) (S -- ) LATEST , ( LAY DOWN LINK FIELD ) -FIND ( CHECK IF UNIQUE IN CURRENT AND CONTEXT ) IF ( WARN USER ) DROP WARN THEN HERE DUP C@ WIDTH @ MIN 1+ ALLOT DUP 128 TOGGLE HERE 1- 128 TOGGLE ( DELIMIT BITS ) CURRENT @ ! ( REMEMBER LATEST DEFINITION ) ['] CFA , ; : [COMPILE] (S -- ) -FIND 0= ?MISSING DROP CFA , ; IMMEDIATE : LITERAL (S n -- ) STATE @ IF COMPILE (LIT) , THEN ; IMMEDIATE : DLITERAL (S d# -- ) STATE @ IF SWAP [COMPILE] LITERAL [COMPILE] LITERAL THEN ; IMMEDIATE \ (INTERPRET) QUIT WARM 02OCT82MCS: (INTERPRET) (S -- ) BEGIN -FIND IF ( FOUND ) STATE @ < IF CFA , ELSE EXECUTE THEN ?STACK ELSE HERE NUMBER DPL @ 1+ IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN ?STACK THEN AGAIN ; DEFERRED QUIT : (QUIT) (S -- ) 0 BLK ! [COMPILE] [ BEGIN RP! CR QUERY INTERPRET STATE @ 0= IF ." OK" THEN AGAIN ; : WARM (S -- ) 1 ABORT" Warm Start" ; \ ID. NULL QUERY ' ['] 29Jun82mapHEX : ID. (S nfa -- ) DUP 1+ DUP C@ ROT C@ 1F AND 0 DO DUP 7F AND EMIT 80 AND IF 0DF ( _ ) ELSE 1+ DUP C@ THEN LOOP 2DROP SPACE ; 8081 HERE 2+ : X (S -- ) R> DROP ; !-T IMMEDIATE DECIMAL : QUERY (S -- ) TIB @ 80 EXPECT 0 >IN ! ; : ' (S -- ) -FIND 0= ?MISSING DROP ; : ['] (S -- ) ' [COMPILE] LITERAL ; IMMEDIATE \ CONTITIONALS, WITH ERROR CHECKING 04MAY82HHL: BACK HERE - , ; : BEGIN ?COMP HERE 1 ; IMMEDIATE : THEN ?COMP 2 ?PAIRS HERE OVER - SWAP ! ; IMMEDIATE : DO COMPILE (DO) HERE 3 ; IMMEDIATE : LOOP 3 ?PAIRS COMPILE (LOOP) BACK ; IMMEDIATE : +LOOP 3 ?PAIRS COMPILE (+LOOP) BACK ; IMMEDIATE : /LOOP 3 ?PAIRS COMPILE (/LOOP) BACK ; IMMEDIATE : UNTIL 1 ?PAIRS COMPILE ?BRANCH BACK ; IMMEDIATE : AGAIN 1 ?PAIRS COMPILE BRANCH BACK ; IMMEDIATE : REPEAT >R >R [COMPILE] AGAIN R> R> 2 - [COMPILE] THEN ; IMMEDIATE : IF COMPILE ?BRANCH HERE 0 , 2 ; IMMEDIATE : ELSE 2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 [COMPILE] THEN 2 ; IMMEDIATE : WHILE [COMPILE] IF 2+ ; IMMEDIATE \ Micro Decision - Serial I/O 03sep83mcsHEX 61 EQU S1STAT \ Serial #1 Status CODE PEMIT ( char -- ) H POP C D MOV S1STAT C MVI BEGIN 0ED C, 78 C, ( IN @C ) 4 ANI 0= NOT UNTIL C DCR L A MOV 7F ANI 0ED C, 79 C, ( OUT @C ) D C MOV NEXT JMP C; CODE (?KEY) ( -- flg ) C D MOV S1STAT C MVI 0ED C, 78 C, ( IN @C ) D C MOV 1 ANI A L MOV 0 H MVI HPUSH JMP C; DECIMAL EXIT \ Micro Decision - Serial I/O HEX CODE (KEY) ( -- char ) C D MOV S1STAT C MVI BEGIN 0ED C, 78 C, ( IN @C ) 1 ANI 0= NOT UNTIL C DCR 0ED C, 78 C, ( IN @C ) D C MOV 7F ANI A L MOV 0 H MVI HPUSH JMP C; : (EMIT) (S char -- ) PEMIT 1 >OUT +! ; DECIMAL : CRLF (S -- ) 13 EMIT 10 EMIT 0 >OUT ! ; EXIT \ P! P@ 04may83mcsHEX CODE P! ( n port -- ) D POP H POP B PUSH E C MOV L A MOV 0ED C, 79 C, ( OUT @C ) B POP NEXT JMP C; CODE P@ ( port -- n ) D POP B PUSH E C MOV 0ED C, 78 C, ( IN @C ) B POP A L MOV 0 H MVI HPUSH JMP C; DECIMAL EXIT These are Z80 words which will operate from ROM. \ Iterated Interpretation 07may83mcsVARIABLE #TOGO ( # times left to repeat ) : TIMES ( n -- ) 1 #TOGO +! #TOGO @ < IF 1 #TOGO ! ELSE 0 >IN ! THEN ; : MANY (S -- ) ?KEY NOT IF 0 >IN ! THEN ; : GO ( -- ) ' >R BEGIN R EXECUTE ?KEY UNTIL R> DROP ; : RANGE ( first n -- last+1 first ) OVER + SWAP ; \ ##. A. DLN DU DUMP 09jan83mcs: ##. ( n -- ) 0 <# # # #> TYPE SPACE ; : A. ( n -- ) DUP BL < OVER 127 > OR IF DROP 46 THEN EMIT ; : DLN ( addr -- ) BASE @ HEX SWAP DUP 4 U.R 2 SPACES 16 0 DO I 3 AND 0 = IF SPACE THEN DUP I + C@ ##. LOOP 2 SPACES 16 RANGE DO I C@ A. LOOP CR BASE ! ; : DU ( addr -- ) CR 64 RANGE DO I DLN 16 +LOOP ; : DUMP ( addr cnt -- ) CR RANGE DO I DLN ?KEY IF LEAVE THEN 16 +LOOP ; EXIT \ Micro Decision-HD - Equates Constants Variables 14sep83mcs VARIABLE DRIVE VARIABLE TRACK VARIABLE HEAD VARIABLE DEBUG 16 CONSTANT SEC/CYL 8 CONSTANT SEC/TRK EXIT \ Micro Decision-HD - AUTO 10may83mcsHEX CODE AUTO ( -- n ) B PUSH (AUTO) CALL B POP HPUSH JMP C; DECIMAL EXIT Save IP and call (AUTO) in rom. On return, restore IP and moveresulting status to stack. \ Micro Decision-HD - DELAY MSEC 11may83mcsHEX HERE EQU (DELAY) ASSEMBLER BEGIN BEGIN L DCR 0= UNTIL H DCR 0= UNTIL RET CODE DELAY (S n -- ) H POP H INR L INR (DELAY) CALL NEXT JMP C; DECIMAL : MSEC ( n -- ) 364 * DELAY ; EXIT \ Micro Decision-HD - STEP HOME SEEK 14sep83mcsHEX : ON ( -- ) DRIVE @ 40 P! 20 41 P! ; : STEP ( dly n -- dly n ) DUP 80 OR ( step ) DRV P! DUP DRV P! ( clr step ) OVER DELAY ; : HOME ( -- ) ON SLOW DRIVE @ DUP DRV P! BEGIN STEP STAT P@ 40 AND UNTIL HEAD-SETTLE DELAY DROP DROP 0 TRACK ! ; : SEEK ( new -- ) ON DUP TRACK @ - ?DUP IF ( delta ) DUP 0< IF ( OUT ) 0 ELSE ( IN ) 40 THEN DRIVE @ OR DUP DRV P! STEP-RATE SWAP ROT ABS 0 DO STEP LOOP HEAD-SETTLE DELAY DROP DROP TRACK ! ELSE DROP THEN ; DECIMAL EXIT \ SET-SECTOR SET-HEAD T&SCALC 14sep83mcsHEX : SET-SECTOR ( sector -- ) ( 1+ ) IMAGE SWAP OVER 3 + C! HEAD @ OVER 2 + C! TRACK @ SWAP ! ; : SET-HEAD ( head -- ) DUP HEAD ! 4 * DRIVE @ OR TRACK @ LC-TRK @ < NOT IF 20 OR THEN DRV P! ; : T&SCALC ( sec -- ) SEC/CYL /MOD SEEK SEC/TRK /MOD SET-HEAD SET-SECTOR ; DECIMAL EXIT \ Micro Decision-HD - SET-MODE PRE-BUF POST-BUF 11may83mcsHEX : SET-MODE ( flg -- ) 38 ( 1K MFM ) SWAP IF ( read ) 0 ELSE ( write ) 40 THEN OR ( Op Code ) TRACK @ PR-TRK @ < NOT IF ( precomp ) 1+ THEN MODE P! ; : PRE-BUF ( flg -- ) NOT IF ( write ) BUF-TAIL DUP 1 - SWAP 1 CMOVE THEN ; : POST-BUF ( flg -- ) IF ( read ) BUF-TAIL DUP 2 - 2 CMOVE THEN ; DECIMAL EXIT PRE-BUF and POST-BUF assume 1K sectors. \ Micro Decision-HD - NTRY HR/W R/W 11may83mcs: R/W ( sec r/w -- n ) SWAP T&SCALC DUP SET-MODE DUP PRE-BUF AUTO SWAP POST-BUF ; EXIT : NTRY ( -- flg ) 0 #TRYS 0 DO DROP AUTO DUP NOT IF LEAVE THEN DUP IF DEBUG @ IF CR ." Disk Error " . CR THEN THEN LOOP ; : HR/W ( sec flg -- ) SWAP T&SCALC SET-MODE DUP PRE-BUF NTRY SWAP POST-BUF ; : R/W ( addr sect r/w -- ) ROT DROP ( Single Fixed Buffer ) 2DUP HR/W DUP IF DROP HOME 2DUP HR/W THEN >R DROP DROP R> ABORT" Disk Error" ; \ XX Call to floppy code 11may83mcs HEX CODE XX ( n -- ? -- ) FE80 JMP C; CODE JCOLD B PUSH 100 CALL B POP NEXT JMP C; DECIMAL EXIT \ (WARN) INITUART 03sep83mcs: (WARN) NFA ID. ." isn't unique. " ; HEX CREATE (INITUART) 0B C, 18 C, 10 C, 04 C, 4C C, 03 C, 0C1 C, 05 C, 68 C, 10 C, 01 C, 0 C, : INITUART ( -- ) (INITUART) COUNT RANGE DO I C@ S1STAT P! LOOP 0BE 53 P! 01A 52 P! 0 52 P! ( CTC INIT ) ; DECIMAL EXIT \ (LOAD) INIT-VEC 04may83mcs: INIT-VEC ['] (KEY) IS KEY ['] (EMIT) IS EMIT \ ['] (LOAD) IS LOAD ['] CRLF IS CR ['] (?KEY) IS ?KEY \ ['] VR/W IS R/W ['] (CREATE) IS CREATE ['] (INTERPRET) IS INTERPRET ; EXIT : (LOAD) (S n -- ) 1 ?ENOUGH BLK @ >R >IN @ >R 0 >IN ! BLK ! INTERPRET R> >IN ! R> BLK ! ; \ (ABORT") ABORT" 6Jul82map: (ABORT") (S f -- ) IF SP! INIT-VEC 0 EPRINT ! R COUNT SPACE TYPE SPACE BLK @ IF >IN @ BLK @ WHERE THEN QUIT THEN R> COUNT + >R ; : ABORT" (S -- ) ?COMP COMPILE (ABORT") 34 ( " ) WORD C@ 1+ ALLOT ; IMMEDIATE \ COLD for RAM system TASK HEX : COLD 12 +ORIGIN UP @ 6 + 10 CMOVE INIT-VEC SP! INITUART CR ." Micro Decision - HD" CR ." MCS Forth 2.0.3" CR 0C +ORIGIN @ ['] FORTH ! 0 OFFSET ! ['] (WARN) IS WARN ['] NOOP IS WHERE [COMPILE] FORTH DEFINITIONS HEX 2 DRIVE ! ( BUFFER 420 ERASE ) C0 BUFFER 20 - 20 CMOVE ['] (QUIT) IS QUIT NOOP QUIT ; : TASK ; DECIMAL \ CLD 10may83mcsLABEL CLD1 ' COLD CFA , HERE ORIGIN 2 + !-T ( COLD ENTRY POINT ) ASSEMBLER LIMIT-T H LXI \ ' LIMIT SHLD ( LIMIT ) \ NSCR 1028 * NEGATE D LXI D DAD ' FIRST SHLD ( FIRST ) US NEGATE D LXI D DAD ORIGIN 16 + SHLD ( INIT-R0 ) ORIGIN 20 + SHLD ( R0 ) UP SHLD ( UP ) RPP SHLD ( RP! ) RTS NEGATE D LXI D DAD ORIGIN 18 + DUP SHLD ( S0 ) 4 + SHLD ( TIB ) SPHL CLD1 B LXI NEXT JMP EXIT Dynamic ram sizing removed. Initializes down from LIMIT-T \ WRM 29Jun82mapLABEL WRM1 ' WARM CFA , HERE ORIGIN 6 + !-T ( WARM ENTRY POINT ) ASSEMBLER WRM1 B LXI NEXT JMP LATEST @ ORIGIN 12 + !-T ( NFA OF TOP WORD ) ' FORTH 4 + ORIGIN 32 + !-T ( INITIAL VOC LINK ) HERE ORIGIN 30 + !-T ( INITIAL DP ) \ Resolve Forward References 02OCT82MCS' EXIT CFA RESOLVES ' (LIT) CFA RESOLVES ' (.") CFA RESOLVES <(.")> ' (") CFA RESOLVES <(")> ASSEMBLER DODOES RESOLVES META ' (;CODE) CFA RESOLVES <(;CODE)> ' (IS) CFA RESOLVES <(IS)> ' (ABORT") CFA RESOLVES <(ABORT")> ' BRANCH CFA RESOLVES BRANCH ' ?BRANCH CFA RESOLVES ?BRANCH ' (DO) CFA RESOLVES (DO) ' (LOOP) CFA RESOLVES (LOOP) ' (+LOOP) CFA RESOLVES (+LOOP) ' STATE CFA RESOLVES STATE ' ?EXEC CFA RESOLVES ?EXEC ' !CSP CFA RESOLVES !CSP ' WORD CFA RESOLVES WORD ' CURRENT CFA RESOLVES CURRENT ' CONTEXT CFA RESOLVES CONTEXT \ Resolve Forward References ' SMUDGE CFA RESOLVES SMUDGE ' ?CSP CFA RESOLVES ?CSP ' COMPILE CFA RESOLVES COMPILE ' , CFA RESOLVES , ' .R CFA RESOLVES .R ' COUNT CFA RESOLVES COUNT ' TYPE CFA RESOLVES TYPE ' ' CFA RESOLVES ' ' QUERY CFA RESOLVES QUERY ' BLOCK CFA RESOLVES BLOCK CR ." Cross Reference Listing:" CR .CROSS-REF CR ." Unresolved references:" CR .UNRESOLVED HEX 7F00 2000 DECIMAL CP/M SAVE TFORTH.COM CR ." Meta Compilation Completed" \ Micro Decision-HD - R/W Load Screen 09may83mcs: EQU ( n -- ) CONSTANT ; : WAIT ( n -- ) DROP ; : AUTO ( -- f ) ; BLK @ LIST 1 6 +THRU EXIT \ Micro Decision-HD - R/W Load Screen 09may83mcsHEX 40 EQU DRV 40 EQU STAT 41 EQU BANK 4B EQU MODE 17E3 EQU IMAGE FC00 EQU BUF-TAIL 1 EQU STEP-RATE 1 EQU HEAD-SETTLE 1 EQU SLOW 128 EQU LC-TRK 128 EQU PR-TRK 10 EQU #TRYS DECIMAL EXIT \ Micro Decision-HD - Equates Constants Variables 09may83mcs VARIABLE DRIVE VARIABLE TRACK VARIABLE HEAD VARIABLE DEBUG 36 CONSTANT SEC/CYL 9 CONSTANT SEC/TRK EXIT \ Micro Decision-HD - AUTO 10may83mcsHEX CODE AUTO ( -- n ) B PUSH (AUTO) CALL B POP HPUSH JMP C; DECIMAL EXIT Save IP and call (AUTO) in rom. On return, restore IP and moveresulting status to stack. \ Micro Decision-HD - DELAY MSEC 11may83mcsHEX HERE EQU (DELAY) ASSEMBLER BEGIN BEGIN L DCR 0= UNTIL H DCR 0= UNTIL RET CODE DELAY (S n -- ) H POP H INR L INR (DELAY) CALL NEXT JMP C; DECIMAL : MSEC ( n -- ) 364 * DELAY ; EXIT \ Micro Decision-HD - STEP MOVED? HOME SEEK 08may83mcsHEX : STEP ( n -- n ) DUP 80 OR ( step ) DRV P! DUP DRV P! ( clr step ) STEP-RATE @ WAIT ; : MOVED? ( new -- delta ) TRACK @ - ; : HOME ( -- ) STEP-RATE @ ( save fast ) SLOW STEP-RATE ! DRIVE @ DUP DRV P! BEGIN STAT P@ 2 AND ( seek cmpl ) NOT WHILE STEP REPEAT DROP 0 DRIVE ! STEP-RATE ! ; : SEEK ( new -- ) DUP MOVED? ?DUP IF ( new track ) DUP 0< IF ( out ) 0 ELSE ( in ) 40 THEN DRIVE @ OR DUP DRV P! ABS 0 DO STEP LOOP HEAD-SETTLE @ WAIT TRACK ! ELSE DROP THEN ; DECIMAL EXIT \ Micro Decision-HD - T&SCALC SET-HEAD SET-SECTOR 08may83mcsHEX : SET-SECTOR ( sector -- ) IMAGE SWAP OVER 3 + C! HEAD @ OVER 2 + C! TRACK @ SWAP ! ; : SET-HEAD ( head -- ) DUP HEAD ! 4 * DRIVE @ OR TRACK @ LC-TRK @ < NOT IF 20 OR THEN DRV P! ; : T&SCALC ( sec -- ) SEC/CYL /MOD SEEK SEC/TRK /MOD SET-HEAD SET-SECTOR ; DECIMAL EXIT \ Micro Decision-HD - SET-MODE PRE-BUF POST-BUF 08may83mcsHEX : SET-MODE ( flg -- ) 38 ( 1K MFM ) SWAP IF ( read ) 0 ELSE ( write ) 40 THEN OR ( Op Code ) TRACK @ PR-TRK @ < NOT IF ( precomp ) 1+ THEN MODE P! ; : PRE-BUF ( flg -- ) NOT IF ( write ) BUF-TAIL DUP 1 - SWAP 1 CMOVE THEN ; : POST-BUF ( flg -- ) IF ( read ) BUF-TAIL DUP 3 - 3 CMOVE THEN ; DECIMAL EXIT PRE-BUF and POST-BUF assume 1K sectors. \ Micro Decision-HD - NTRY HR/W R/W 09may83mcs: NTRY ( -- flg ) 0 #TRYS 0 DO DROP AUTO DUP NOT IF LEAVE THEN DUP IF DEBUG @ IF CR ." Disk Error " . CR THEN THEN LOOP ; : HR/W ( sec flg -- ) SWAP T&SCALC SET-MODE DUP PRE-BUF NTRY SWAP POST-BUF ; : R/W ( addr sect r/w -- ) ROT DROP ( Single Fixed Buffer ) 2DUP HR/W DUP IF DROP HOME 2DUP HR/W THEN >R DROP DROP R> ABORT" Disk Error" ;