\ ANNOTATED META SOURCE CODE OF SPECTRUM FORTH-83. \ Written by L.C. Benschop in 1988, annotations written in 2015. \ This is a text file that contains the source code from the files META1, \ META2, META3 and META4 from the Spectrum FORTH-83 distribution. \ \ These files have to be run in succession from Spectrum FORTH-83. \ RUN META1 RUN META2 RUN META3 RUN META4 \ \ Together these files rebuild the original FORTH system from source. \ The end product is the file FORT83.BIN. See also section 4.5 of the manual. \ When the newly built FORTH system loads the file EDITOR and is saved, \ it will be identical to the base FORTH system as distributed. \ \ Code has been reformatted and comments are added. \ But all source instructions themselves have been preserved, including \ bugs and things that are so awfully ugly after all these years. \ \ Note: this text file in this form cannot be loaded as source code \ into the Spectrum FORTH-83 system. Use the original files META1..META4 \ instead. This source code has never compiled on any system other than \ Spectrum FORTH-83 and will not work unmodified. \ FILE META1 \ Scr#1 \ Metaforth 83 COMPILER DEF'S HEX \ We will enter all numbers in hex, except when switching briefly to \ decimal for some numbers. \ The meta compiler will build a FORTH system image at a different address \ from where the image will later be loaded and run. The newly built \ image will be called the TARGET system. \ \ The HOST system is the FORTH system that runs the meta compiler. \ \ As the newly built system resides at a different address, FORTH cannot \ EXECUTE any words it has built in the target system. The target system \ and the host system can in \ principle be totally different FORTH systems, for different CPUs, \ with different threading style and with a different dictionary format. \ B400 CONSTANT VIRTSTART \ Start address of the target system, where it will be built by the meta \ compiler. This address is far enough above HERE, so the host dictionary \ will not run into it when it is extendend and far enough below the RAM \ disk. Ugly to steal a memory area in this way, but those were the days. \ CREATE VIRTSTART 2800 ALLOT would have been better. DECIMAL 26000 1030 + CONSTANT ORIGIN HEX \ Address where the target system will be loaded and run when it is finished. \ This is the COLD start entry point. See memory map in section 4.3 of the \ manual. \ \ Uglyness alert: the saved image will be from address 27028, 2 bytes \ below the ORIGIN address, so it includes the user area pointer as well. VIRTSTART ORIGIN - CONSTANT OFFSET \ Address difference between where the target system is stored now \ and where it will be loaded once it is finished. \ Operations on target system. \ The usual fetch and store operations. With these the meta compiler \ can pretend it reads and writes data at the addresses in the finished \ system. : C!-T OFFSET + C! ; : !-T OFFSET + ! ; : C@-T OFFSET + C@ ; : @-T OFFSET + @ ; VARIABLE LINK-T 0 LINK-T ! \ Link between words in the target directory. VARIABLE DP-T ORIGIN DP-T ! \ Dictionary pointer in the target system. \ More operations on the target system. : HERE-T DP-T @ ; : ALLOT-T DP-T +! ; : ,-T HERE-T !-T 2 ALLOT-T ; : C,-T HERE-T C!-T 1 ALLOT-T ; : NMOVE ( src dst n --- ) \ Move a block of n bytes to the target system. Source is a host address, \ destination is a target address. SWAP OFFSET + SWAP CMOVE ; \ This word creates a header for a new word in the target system (only link and \ name fields), code field not created. See section 4.2 in manual for header \ structure. \ For each word in the target system, a word is also created in the \ host dictionary. : CREATE-T CREATE \ Create a word in the host dictionary as well. \ will end up in the META vocabulary of host system. LINK-T @ ,-T \ Put link field in target system (= link to previous word). HERE-T LINK-T ! \ Update target link variable, so it points to the new word. LATEST HERE-T ( host-nfa target-nfa ) OVER C@ 01F AND 1+ ( host-nfa target-nfa namelength ) DUP >R NMOVE R> ALLOT-T \ Copy the name of the latest word from the \ host dictionary to the target and allocate space. HERE-T 1- DUP C@-T 80 OR SWAP C!-T \ Set bit 7 in final character of name. \ This is not even required as this bit was \ already set in the name copied from the host. \ but can be required when running on different host. IMMEDIATE \ Make the word in the host dictionary immediate. ; VOCABULARY META \ The META vocabulary contains all words that the meta compiler uses \ when compiling for the target system. Most words are created by \ CREATE-T and will add their own code field address to the target dictionary. \ Some words (for instance IF) are special definitions that run on the \ host system, but compile code for the target system. VOCABULARY TARGET \ The TARGET vocabulary contains all words that are immediate in the \ target system. They shall not be used by the meta compiler, but instead \ the meta compiler specific counterparts must be used. \ It's so ugly to move the immediate words from the target system from \ the META to the TARGET vocabulary, but that's how it's done here. \ Later meta compilers written by me use TRANSIENT and TARGET \ vocabularies, where TRANSIENT is always searched first and all target \ words are created in TARGET. In later FORTHs the search order can \ be specified more easily. \ \ This meta compiler was started on a FORTH where VOCABULARY was buggy \ and it might not even be possible to have three vocabularies in the \ search order. So that may be why it was done this way. \ Scr#2 \ METAFORTH83 ASSEMBLER #1 \ The Meta FORTH assembler was copied from the normal assemler (see file \ ASSEMBLER) and adapted to put the generated code in the target system. \ For assembler syntax see chapter 5 of the manual. \ \ With a sligtly better design we could have used the exact same source \ code for both. VOCABULARY ASSEMBLER IMMEDIATE \ Assembler words get their own vocabulary. HEX VARIABLE XY \ Variable that contains the index register opcode prefix byte, \ DD for IX, FD for IY. \ These definitions for CODE and ;C are for generating code definitions \ on the host system. Just copied from normal assembler and not used by \ meta compiler. : CODE CREATE -3 ALLOT \ Remove the code field of the newly created word. !CSP [COMPILE] ASSEMBLER HEX DD XY ! ; : ;C DECIMAL CURRENT @ CONTEXT ! ?CSP SMUDGE ; \ MACRO and ENDM are not used in the meta compiler either. : MACRO [COMPILE] ASSEMBLER [COMPILE] : ; ASSEMBLER DEFINITIONS : ENDM [COMPILE] ; ; IMMEDIATE : %X DD XY ! ; \ Select IX for index register operations. : %Y FD XY ! ; \ Select IY for index register operations. : CON CONSTANT ; \ CONSTANT is such a long word, so make a shorter synonym. \ These definitions provide shorter synonyms for operations on \ the target system. They allowed turning the assembler into a meta \ assembler with minimal editing. : HERE HERE-T ; : C_ C,-T ; : _ ,-T ; : C!_ C!-T ; : !_ !-T ; : 8* 2* 2* 2* ; \ The following constants specify register names. 0 CON B 1 CON C 2 CON D 3 CON E 4 CON H 5 CON L 6 CON M 7 CON A \ M is memory byte addressed by (HL). 6 CON SP 6 CON AF \ Specify use of IX/IY register (instead of HL) in some instructions. \ X JPHL becomes for JP (IX). : X XY @ C_ ; \ Allow use of lower and upper half of IX/IY register, not used. : XL X L ; : XH X H ; : ?PAGE ( offs --- offs) \ Check that offs is in range -128..127, for use in relative branches. DUP 80 + 00FF SWAP U< ABORT" BRANCH TOO LONG" ; \ Scr#3 \ METAFORTH83 ASSEMBLER #2 \ The words M1..MC are simple defining words, one for each category \ of instructions. : M1 CREATE C, DOES> C@ C_ ; \ Single opcode byte, no operands. : M2 CREATE C, DOES> C@ + C_ ; \ Single opcode byte, 8-bit register operand. : M3 CREATE C, DOES> C@ SWAP 8* + C_ ; \ Single opcode byte, 16-bit register operand. : M4 CREATE C, DOES> C@ C_ C_ ; \ Opcode byte plus 8-bit immediate. : M5 CREATE C, DOES> C@ C_ _ ; \ Opcode byte plus 16-bit immediate. : M6 CREATE C, DOES> 00CB C_ C@ + C_ ; \ CB prefix opcode, register operand. : M7 CREATE C, DOES> 00CB C_ C@ + SWAP 8* + C_ ; \ BIT/SET/RES instructions, register operand. : M8 CREATE , DOES> @ _ ; \ Two byte opcode, no operands. : M9 CREATE C, DOES> C@ C_ HERE 1+ - ?PAGE C_ ; \ Relative branches. : MA CREATE C, DOES> X C@ C_ C_ ; \ Indexed instructions. : MB CREATE C, DOES> X 00CB C_ C@ SWAP C_ C_ ; \ Indexed instructions with CB prefix. : MC CREATE C, DOES> X 00CB C_ C@ ROT ROT C_ 8* + C_ ; \ Indexed BIT, SET and RES. \ Some instructions get their own definition, no common defining word, : LDP# 8* 1+ C_ _ ; \ Load 16-bit immediate. : LD# 8* 06 + C_ C_ ; \ Load 8-bit immediate. : LD 8* 40 + + C_ ; \ Register-to-register move. : SBCP 00ED C_ 8* 42 + C_ ; \ 16-bit SBC : ADCP 00ED C_ 8* 4A + C_ ; \ 16-bit ADC : STP 00ED C_ 8* 43 + C_ _ ; \ 16-bit store to absolute address. : LDP 00ED C_ 8* 4B + C_ _ ; \ 16-bit load from absolute address. \ Scr#4 \ METAFORTH83 ASSEMBLER #3 \ Instructions, ordered by Z80 opcode. 00 M1 NOP 02 M3 STAP 03 M3 INC 04 M3 INR \ INC is increment 16-bit register, INR is increment 8-bit 05 M3 DER 07 M1 RLCA \ DER is decrement 8-bit register. 08 M1 EXAF 09 M3 ADDP 0A M3 LDAP 0B M3 DEC \ DEC is decrement 16-bit register 0F M1 RRCA 10 M9 DJNZ 17 M1 RLA 18 M9 JR 1F M1 RRA 20 M9 JRNZ 22 M5 STHL 27 M1 DAA 28 M9 JRZ 2A M5 LDHL 2F M1 CPL 30 M9 JRNC 32 M5 STA 37 M1 SCF 38 M9 JRC 3A M5 LDA 3F M1 CCF 76 M1 HALT 80 M2 ADD 88 M2 ADC 90 M2 SUB 98 M2 SBC B8 M2 CP \ Note that XOR AND and OR are missing here. \ They are defined much later when the original FORTH words with the same \ names are no longer needed in the ASSEMBLER vocabulary. C1 M3 POP C2 M5 JPNZ C3 M5 JP C5 M3 PUSH C6 M4 ADD# C7 M2 RST C9 M1 RET CA M5 JPZ CD M5 CALL CE M4 ADC# D2 M5 JPNC D3 M4 OUT D6 M4 SUB# D9 M1 EXX DA M5 JPC DB M4 IN DE M4 SBC# E2 M5 JPPO E3 M1 EXSP E6 M4 AND# E9 M1 JPHL EA M5 JPPE EB M1 EXDE EE M4 XOR# F2 M5 JPP \ Scr#5 \ METAFORTH83 ASSEMBLER #4 F3 M1 DI F6 M4 OR# F9 M1 LDSP FA M5 JPM FB M1 EI FE M4 CP# \ CB prefix instructions. 00 M6 RLC 08 M6 RRC 10 M6 RL 18 M6 RR 20 M6 SLA 28 M6 SRA 38 M6 SRL 40 M7 BIT 80 M7 RES C0 M7 SET \ ED prefix instructions. B0ED M8 LDIR B8ED M8 LDDR 44ED M8 NEG 57ED M8 LDAI 47ED M8 LDIA 56ED M8 IM1 5EED M8 IM2 B1ED M8 CPIR \ Indexed instructions. 86 MA )ADD 8E MA )ADC 96 MA )SUB 9E MA )SBC A6 MA )AND AE MA )XOR B6 MA )OR BE MA )CP 34 MA )INR 35 MA )DER 06 MB )RLC 0E MB )RRC 16 MB )RL 1E MB )RR 26 MB )SLA 2E MB )SRA 3E MB )SRL 46 MC )BIT 86 MC )RES C6 MC )SET \ Indexed instructions directly defined without a common defining word. : )LD X SWAP 8* 46 + C_ C_ ; : )ST X SWAP 70 + C_ C_ ; : )LD# X 36 C_ C_ C_ ; : )LDP OVER 1+ OVER )LD 1+ )LD ; : )STP OVER 1+ OVER )ST 1+ )ST ; \ Scr#6 \ METAFORTH83 ASSEMBLER #5 : CLR 0 SWAP LDP# ; \ Clear 16-bit register. : MOV 2DUP LD 1+ SWAP 1+ SWAP LD ; \ Macro to copy 16-bit register H B MOV : NOT 08 + ; \ Condition codes (Capitalized) for the relative jump instructions. \ \ Specific condition code values are Z80 opcodes for required instructions. \ Note that condition codes in the instructions are the opposite of \ the condition code mnemonics here. \ Example: Z IF requires an instruciton JR NZ, so Z specifies the JR NZ opcode. 20 CON Z 28 CON NZ 30 CON CS 38 CON NC \ Condition codes (lowercase) for the absolute jump instructions, can \ be followed by NOT for inverse condition codes. \ \ Specific condition code values are Z80 opcodes for required instructions. \ Example z specifies JP NZ opcode. C2 CON z D2 CON cs E2 CON pe E2 CON v F2 CON m \ Control structures generating relative jumps, capitalized, use \ capitalized conditions. \ NC IF ... THEN or BEGIN ... Z UNTIL \ \ These definitions look very terse and cryptic, \ \ But they work similarly to the FORTH control structure words, \ except they lay out Z80 opcodes instead of the FORTH BRANCH/?BRANCH words. \ (opcodes mostly supplied in condition codes) and single byte addresses follow \ the opcodes. : THEN 000A ?PAIRS HERE 1- OVER - ?PAGE SWAP C!_ ; : IF _ HERE 1- 000A ; : ELSE 000A ?PAIRS 0018 IF ROT SWAP THEN 000A ; : UNTIL _ 000B ?PAIRS 1- HERE 1- SWAP OVER - ?PAGE SWAP C!_ ; : BEGIN HERE 000B ; : AGAIN 0018 UNTIL ; \ Unconditional loop BEGIN..AGAIN. : DSZ 0010 UNTIL ; \ BEGIN..DSZ makes a loop with DJNZ instruction. : REPEAT 2SWAP AGAIN 2- THEN ; : WHILE IF 2+ ; \ Control structures generating absolute jumps, lowercase, use \ lowercase conditions. \ cs NOT if ... then or begin ... z until : then 08 ?PAIRS HERE SWAP !_ ; : if C_ HERE 0 _ 0008 ; : else 08 ?PAIRS C3 if ROT SWAP then 08 ; : begin HERE 09 ; : until C_ 09 ?PAIRS _ ; : while if 2+ ; : again C3 until ; : repeat 2SWAP again 2- then ; \ Scr#7 \ METAFORTH83 ASSEMBLER #6 \ The missing AND, OR and XOR are defined at the end. : RETC 8 XOR 2- C_ _ ; \ Conditional return : CALC 8 XOR 2+ C_ _ ; \ conditional call. A0 M2 AND B0 M2 OR : SUBP A AND SBCP ; \ Macro, 16-bit subtract. : TST DUP A LD 1+ OR ; \ Macro to test 16-bit regsiter for zero H TST tests HL A8 M2 XOR CF M4 HOOK \ RST 8 followed by byte: error code or Interface 1 system call. D7 M1 PRT \ RST 16 = print character. FORTH DEFINITIONS DECIMAL \ Assembler ends here. \ Scr#8 \ Metaforth 83 compiler META DEFINITIONS HEX \ Word to create code definitions on the target system. : CODE CREATE-T \ Create new word in target system. [OMPILE] ASSEMBLER \ select assembler vocabulary. SMUDGE \ Make word unfindable in host system. !CSP \ Mark stack HERE-T , \ Store target CFA into host word. DOES> @ ,-T ; \ runtime: add CFA to compiled target colon definition. ASSEMBLER DEFINITIONS : ;C CURRENT @ CONTEXT ! \ Restore vocabulary. ?CSP \ Check that stack pointer is the same as when CODE \ definition was started. SMUDGE \ Make word findable in host system. ; \ Variables used by assembler to store jump addresses VARIABLE L1 VARIABLE L2 META DEFINITIONS \ The word [COMPILE] for the meta compiler. Will look up the immediate \ word in the TARGET vocabulary and compile its address. : [COMPILE] TARGET ' \ Look up in TARGET vocabulary. 3 + \ Convert CFA to PFA. @ ,-T \ Read target CFA from parameter field and compile to \ target. META \ Return to META vocabulary. ; IMMEDIATE : IMM IMMEDIATE ; \ Create a synonym for the original IMMEDIATE. \ IMMEDIATE moves the latest word from the META vocabulary to the TARGET \ vocabulary, so another word in the META vocabulary with the same name \ will be found instead. : IMMEDIATE LATEST DUP 2- (latest-nfa latest-lfa) DUP @ CURRENT @ ! \ Adjust CURRENT vocabulary to point to previous \ definition, removing the word from current (=META). TARGET \ Set TARGET to context. CONTEXT @ @ SWAP ! \ Make link field in latest def point to previous \ def in TARGET. CONTEXT @ ! \ Make target point to latest def. META \ Switch back to META LINK-T @ DUP C@-T 40 OR SWAP C!-T \ Set bit 6 in first name field byte in target system \ to mark the word immediate there. ; FORTH DEFINITIONS VARIABLE 'LIT \ Variable to contain the address of LIT primitive in \ target system. \ Meta interpreter: Execute words and take care to compile literals. \ Execution of a normal word from the META vocabulary means compiling \ it to the target system. \ Some words will execute special actions. : META-INTERPRET BEGIN BL WORD DUP C@ \ Read next word until input stream exhausted. WHILE FIND IF EXECUTE \ Execute any word found. ELSE NUMBER DROP STATE @ \ Forget about double precision literals. IF 'LIT @ ,-T ,-T \ If compiling, add literal to target system. THEN THEN REPEAT DROP ; \ Scr#9 \ Metaforth 83 compiler \ Variables to contain the addresses of several FORTH primitives. \ Will be filled in when these words are defined later in the target system. \ DOCOL, DOCON, DOUSER and NEXT are constants, will be patched \ later when the corresponding primitives are defined. VARIABLE 'BRANCH VARIABLE 'LOOP VARIABLE '+LOOP VARIABLE '." VARIABLE '?DO VARIABLE '?BR 0 CONSTANT DOCOL \ Runtime part for colon definitions. VARIABLE 'EXIT 0 CONSTANT DOCON \ Runtime part for constants. VARIABLE 'DO 0 CONSTANT DOUSER \ Runtime part for user variables. VARIABLE 'ABORT 0 CONSTANT NEXT \ Address of inner interpreter. VARIABLE VL \ Pointer to fix up FORTH vocabulary in target system. VARIABLE 'CODE \ Runtime part for DOES> META DEFINITIONS \ Next create the words that will perform special actions in the \ meta compiler in the META vocabulary. When executed, they will \ do something different than just adding the code address to the \ current colon definition. : ." '." @ ,-T \ Compile runtime for ." 22 WORD \ Read word up to next " HERE-T HERE C@ 1+ NMOVE \ Copy counted string to target. HERE C@ 1+ ALLOT-T \ Allocate space for it. ; IMM : DO 'DO @ ,-T \ Compile runtime HERE-T \ Put current address on stack for forward ref. 0 ,-T \ Add extra cell for forward address. 3 \ 3 indicates loop structure. ; IMM : LOOP 3 ?PAIRS \ Check for nesting consistency. 'LOOP @ ,-T \ Compile runtime part. HERE-T SWAP !-T \ Fill in forward reference at address after DO. ; IMM : +LOOP 3 ?PAIRS \ Check for nesting consistency. '+LOOP @ ,-T \ Compile runtime part. HERE-T SWAP !-T \ Fill in forward reference at address after DO. ; IMM : ?DO '?DO @ ,-T \ Compile runtime HERE-T \ Put current address on stack for forward ref. 0 ,-T \ Add extra cell for forward address. 3 \ 3 indicates loop structure. ; IMM : IF '?BR @ ,-T \ Compile conditional branch HERE-T \ Put current address on stack for forward ref. 0 ,-T \ Add extra cell for forward address. 2 \ 2 indicates if structure. ; IMM : ELSE 2 ?PAIRS \ Check for nesting consistency. 'BRANCH @ ,-T \ Compile unconditional branch. HERE-T \ Put current address on stacl 0 ,-T \ Add extra cell for forward address. HERE-T ROT !-T \ Resolve original forward reference originating at IF, \ will jump past unconditional branch at ELSE. 2 \ 2 indicates if structure. ; IMM : THEN 2 ?PAIRS \ Check for nesting consistency. HERE-T SWAP !-T \ Fill in forward reference. ; IMM : BEGIN HERE-T \ Put current address on stack for backward reference. 1 \ 1 indicates BEGIN structure. ; IMM : UNTIL '?BR @ ,-T \ Compile conditional branch. 1 ?PAIRS \ Check for nesting consistency. ,-T \ Add backward address. ; IMM : WHILE 1 ?PAIRS \ Check for nesting consistency. '?BR @ ,-T \ Compile conditional branch. HERE-T \ Put current address on stack for forward reference. 0 ,-T \ Add cell for forward address. 4 \ 4 indicates WHILE ; IMM \ Scr#10 \ Metaforth 83 compiler : REPEAT 4 ?PAIRS \ Check for nesting consistency. 'BRANCH @ ,-T \ Compile unconditional branch. HERE-T 2+ SWAP !-T \ Resolve the forward reference originating in WHILE. ,-T \ Add the backward address to BEGIN. ; IMM : ABORT" 'ABORT @ ,-T \ Compile runtime. 22 WORD \ Read word until next " HERE-T HERE C@ 1+ NMOVE \ Move counted string to target. HERE C@ 1+ ALLOT-T \ Allocate space. ; IMM : CONSTANT CREATE-T \ Create new target word. HERE-T , \ Store target compilation address into host word. CD C,-T DOCON ,-T ,-T \ Compile a CALL to DOCON, followed by the constant. DOES> @ ,-T ; \ At runtime, compile to target system. : CREATE CREATE-T \ Create new target word. HERE-T , \ Store target compilation address into host word. CD C,-T NEXT ,-T \ Compile a call to NEXT. DOES> @ ,-T ; \ At runtime, compile to target system. : VARIABLE CREATE \ Create word in target system, just as CREATE. 0 ,-T ; \ Allocate space for variable . : DOES> 'CODE @ ,-T \ Compile the (;CODE) word. CD C,-T DOCOL ,-T \ Compile a call to DOCOL. ; IMM : USER CREATE-T \ Create new target word. HERE-T , \ Store target compilation address into host word. CD C,-T DOUSER ,-T C,-T \ Compile a call to DOUSER followed by byte offset. FORTH \ Select the FORTH vocabulary now to get the correct \ version of DOES> DOES> @ ,-T ; \ At runtime, compile to target system. \ Things get fairly ugly towards the end of this section, as more and \ more common words get a new definition in the META vocabulary, hiding \ their normal FORTH definitions, so we have to switch vocabularies \ quite a lot. META DEFINITIONS : ; 'EXIT @ ,-T \ Compile EXIT to the current colon definition. CURRENT @ CONTEXT ! \ Set context vocabulary. ?CSP \ Check stack balancing. SMUDGE \ Make word findable. 0 STATE ! \ Switch to interpretation state. ; IMM : LITERAL 'LIT @ ,-T ,-T \ Compile a literal. FORTH ; META DEFINITIONS IMM : : CREATE-T \ Creat new target word HERE-T , \ Store target compilation address into host word. CD C,-T DOCOL ,-T \ Compile a call to DOCOL. SMUDGE \ Make the word unfindable. !CSP \ Mart start stack pointer. FORTH 0BF STATE ! \ Switch to compilation state. DOES> @ ,-T \ At runtime compile to target system ; META DEFINITIONS IMM \ This is the last colon definition running on the host system that \ will be defined in the META vocabulary. The original FORTH : is now \ hidden. FORTH DEFINITIONS \ Create a few aliases for words that we need in their oriignal FORTH \ meaning, but that will be shadowed in the META vocabulary. : } ] ; : O+ + ; : DEF DEFINITIONS ; DECIMAL \ FILE META2 \ Scr#1 \ METAFORTH83 INNER INTERPRETER \ Until now, nothing has been compiled in the target image. HEX ASSEMBLER \ The following three entry points are the first instructions to add to \ the target system. \ Jump target addresses will be patched later. 0 JP \ Cold entry point 0 JP \ Warm entry point 0 JP \ BCAL return entry point. FORTH DEFINITIONS \ Constants that define addresses of variables in the user variable area. HERE-T CONSTANT 'BASE HERE-T 2 + CONSTANT 'DP HERE-T 4 + CONSTANT 'KEY HERE-T 6 + CONSTANT 'EMIT HERE-T 8 + CONSTANT RPTR HERE-T A + CONSTANT 'WAIT HERE-T C + CONSTANT 'FENCE HERE-T E + CONSTANT 'S0 HERE-T 10 + CONSTANT 'R0 ORIGIN 2- CONSTANT UPTR 3C ALLOT-T \ Allocate 60 bytes in the target system for the \ user variables. VARIABLE 'I \ Address of the code definition for I, will be \ used as a jump target by the assembler. ASSEMBLER DEFINITIONS : JPIX %X X JPHL ; \ Add JPIX instruction to the assembler. \ The inner interpreter starts here. \ See section 4.1 of the manual. HERE-T ' NEXT >BODY ! \ Patch the NEXT constant, used by CREATE/VARIABLE \ DE contains the instruction pointer. EXDE \ Instruction pointer to HL. M E LD H INC M D LD H INC \ Read word into DE, incrementing HL EXDE \ Instrucion pointer again in DE. JPHL \ Jump to the address just read. \ DOCON, runtime part of CONSTANT. HERE-T ' DOCON >BODY ! \ Patch the DOCON constant. H POP \ Pop parameter field address from stack, put there by CALL M C LD H INC M B LD \ Read word from address into BC. B PUSH \ Push constant to stack. JPIX \ IX always contains the NEXT address, JPIX short jump to NEXT. \ DOCOL, runtime part of colon defintiions. HERE-T ' DOCOL >BODY ! \ Patch the DOCOL constant. RPTR LDHL \ Read return stack pointer to HL H DEC D M LD H DEC E M LD \ Write DE (instruciton pointer) to return stack, \ thereby decrementing pointer. RPTR STHL \ Store return stack pointer. D POP \ Pop instruction pointer from stack, put there by CALL DOCOL. JPIX \ DOUSER, runtime part of user variables. HERE-T ' DOUSER >BODY ! H POP \ Pop parameter field address from stack, put there by CALL M C LD \ Load single byte offset into C. 0 B LD# \ Clear B. UPTR LDHL B ADDP \ Add to UPTR variable. H PUSH \ Push variable addres on stack. JPIX \ Scr#2 \ META PRIMITIVES LIT,BRANCH,DO META DEFINITIONS \ LIT is the first FORTH word defined. The previous code (NEXT, DOCOL) \ had no headers. \ Primitives used in compiling literals and control structures. \ When these words are defined, the corresponding variables in the meta \ compiler are filled in. \ This filling in is an action performed by the meta compiler when this code \ is assembled, it is not part of the generated code. CODE LIT ( --- 16b ) HERE-T 'LIT ! \ Fill in the 'LIT variable. EXDE \ Instruction pointer now in HL M C LD H INC M B LD H INC \ Read word at instruction pointer in BC, increment HL. B PUSH \ Push literal. NEXT 1+ JP \ Skip the first EXDE in NEXT. ;C CODE BRANCH ( --- ) HERE-T 'BRANCH ! \ Fill in the 'BRANCH variable. EXDE M E LD H INC M D LD JPIX ;C CODE ?BRANCH ( f --- ) HERE-T '?BR ! \ Fill in the '?BR variable. B POP \ Pop the flag B A LD C OR \ Test if it is zero. 'BRANCH @ JPZ \ If zero, do the branch. D INC D INC \ Not zero, Skip the branch address. JPIX ;C CODE EXECUTE ( addr --- ) H POP \ Pop execution address JPHL ;C \ Jump to it. Note: just RET would have worked too. CODE EXIT ( --- ) HERE-T 'EXIT ! \ Fill in the 'EXIT variable. RPTR LDHL \ Load return stack pointer into HL M E LD H INC M D LD H INC \ Load DE from return stack pointer, incrementin HL RPTR STHL \ Store updated return stack pointer. JPIX ;C \ Return stack for loop. A do loop pushes three items on the return stack. \ Limit \ reverse branch address (jump to here if loop repeats). \ current index (represented as (index-limit) xor 0x8000. This is at the top. \ The current index is represented this way so it is easier \ to check whether index has crossed the boundary between \ limit-1 and limit, acoording to \ the rules of Forth-83, even with negative increment in +LOOP. CODE (DO) ( w1 w2 --- ) HERE-T 'DO ! \ Fill in the 'DO variable. H POP B POP \ Initial value in HL, limit in BC. H PUSH \ Push initial value back. RPTR LDHL \ Return stack pointer in HL. H DEC B M LD H DEC C M LD \ Push limit value on return stack. D INC D INC \ Increment the instruction pointer, skip branch address. H DEC D M LD H DEC E M LD \ Push current instruction pointer on return stack. EXSP \ initial value now in HL, Return stack pointer on stack. A AND B SBCP \ Subtract limit value. H A LD 80 XOR# A B LD L C LD \ Flip most significant bit, move to BC. H POP \ Get return stack pointer from stack, H DEC B M LD H DEC C M LD \ Push (initial - limit) XOR 0x8000 onto return stack. RPTR STHL \ Save return stack pointer. JPIX ;C CODE (?DO) ( w1 w2 --- ) HERE-T '?DO ! \ Fill in the '?DO variable. H POP B POP \ initial value in HL, limit in BC, B SUBP \ Compare. NZ IF B ADDP \ Not equal: Reverse the subtraction. B PUSH H PUSH \ Push operands back onto stack. 'DO @ JR \ Perform regular DO. THEN 'BRANCH @ JP ;C \ Equal: Branch past the end of the loop. \ Scr#3 \ META PRIMITIVES LOOP,+LOOP,I CODE (LOOP) HERE-T 'LOOP ! \ Fill in the 'LOOP variable. RPTR LDHL \ Read return stack pointer into HL M C LD H INC M B LD \ Read current index value. B INC \ Increment it. B A LD 80 XOR# C OR \ Was it equal to 0x8000 ? Z IF 5 B LDP# \ If so, the real index has reached limit, terminate loop. B ADDP RPTR STHL \ Increment ret stack pointer by 5 (1 increment already done) \ and store updated ret stack pointer back. ELSE B M LD H DEC C M LD \ Store updated index. H INC H INC M E LD H INC M D LD \ Read loop start address into instruction pointer, repeat loop. THEN JPIX ;C CODE (+LOOP) ( w --- ) HERE-T '+LOOP ! \ Fill in '+LOOP variable. RPTR LDHL \ Read return stack pointer into HL. M C LD H INC M B LD \ Read Current index. EXSP \ HL now contains w, the increment value. A AND B ADCP \ Add increment to index. v if \ If overflow, then boundary between limit-1 and limit is \ crossed, terminate loop. H POP \ Get return stack pointer. 5 B LDP# B ADDP RPTR STHL \ Increment ret stack pointer by 5 (1 increment already done) \ and store updated ret stack pointer back. else H B LD L C LD \ Move updated index to BC. H POP \ Get return stack pointer. B M LD H DEC C M LD \ Store updated index. H INC H INC M E LD H INC M D LD \ Read loop start address into instruction pointer, repeat loop. then JPIX ;C CODE LEAVE RPTR LDHL \ Read return stack pointer into HL. H INC H INC M E LD H INC M D LD \ Get start address into DE. H INC H INC H INC RPTR STHL \ Write updated return stack pointer (6 was added). D DEC D DEC \ DE (instruction pointer) now points to forward branch address 'BRANCH @ JP ;C \ continue into BRANCH. CODE I ( --- w) HERE-T 'I ! \ Fill in 'I variable. RPTR LDHL \ Read return stack pointer into HL. \ J jumps here. M C LD H INC M B LD \ Read current index. (which is (index-limit) xor 0x8000. H INC H INC H INC M A LD \ Read limit and add to index C ADD A C LD H INC M A LD B ADC 80 XOR# \ and flip most significant bit, getting true index value. A B LD B PUSH \ Push result. JPIX ;C CODE J ( --- w) RPTR LDHL \ Read return stack pointer into HL 6 B LDP# B ADDP \ Add 6 to it, to get to next inner loop parameters. 'I @ 3 + JR ;C \ Continue into I. CODE I' ( --- w) RPTR LDHL \ Read return stack pointer into HL H INC H INC H INC H INC M C LD H INC M B LD \ Read limit value. B PUSH \ Push result JPIX ;C \ Scr#4 \ META PRIMITIVES FIND,WORD CODE (FIND) ( addr1 addr2 --- addr3 n ) EXX \ Use shadow register set, so original DE is preserved. D POP \ Get word list address, points to last defined name. BEGIN E A LD D OR NZ WHILE \ Terminate loop if name field address is zero. H POP H PUSH \ address of name to find. D PUSH \ Save address of name in dictionary. D LDAP \ Get length byte from name in dictionary. 3F AND# \ Mask off top 2 bits. Bit 5 is not masked, so a name \ with 'smudge' bit set will not match. M CP \ Is length byte equal? Z IF BEGIN D INC H INC D LDAP \ DE points to name in dict, HL points to name to find. M CP \ Compare names until bytes not equal. NZ UNTIL 7F AND# \ Check if last byte of name in dict with bit 7 masked off \ is equal to corresponding byte in name to search. M CP Z IF \ Names are equal, found. H POP \ Get start address of name in dictionary. AF POP \ Remove next stack item (address of name to find). D INC D PUSH \ Push code field address (final name address + 1). 1 D LDP# \ Set DE to 1. M A LD 40 AND# \ Is word not immediate. Z IF D DEC D DEC \ Change DE to -1. THEN D PUSH \ Push the flag word. EXX \ Go back to normal register set. JPIX \ Next. THEN THEN D POP \ Get start address of name in dictionary. D DEC EXDE M D LD H DEC M E LD \ Access link field, just below name and read link. REPEAT D PUSH \ Push zero flag value. EXX \ Go back to normal register set. JPIX ;C CODE (WORD) ( c addr1 --- addr2) EXX \ Use shadow register set, so original DE is preserved. H POP \ Input stream address in HL B POP \ Delimiter character in C C A LD \ Copy to A. H DEC BEGIN H INC M CP NZ UNTIL \ Scan input stream until character unequal to delimiter is \ found. 0 B LD# \ B contains length byte, initialize to zero. 'DP D LDP D INC \ Initialize DE to HERE+1. BEGIN M A LD \ Read next character from input stream. A OR NZ IF C CP \ Compare with delimiter if character is nonzero. THEN NZ WHILE \ Terminate loop if character read is 0 (input stream ends) \ or character is equal to delimiter. D STAP \ Store character at destination. D INC H INC B INR \ Increment source and destination pointers and byte count. REPEAT 20 A LD# D STAP \ Store a blank space just after word in destination. M A LD A OR NZ IF H INC \ Increment source pointer beyond delimiter, but only if \ last character read from source is the delimiter and not \ a zero byte. THEN H PUSH \ Push input stream address. 'DP LDHL B M LD \ Store length byte at HERE. EXX \ Switch to normal register set. JPIX ;C CODE R@ ( --- 16b) RPTR LDHL \ Read return stack pointer into HL M C LD H INC M B LD \ Read value into BC B PUSH \ Push value. JPIX ;C \ Scr#5 \ META PRIMITIVES DIGIT,>R,TCH CODE DIGIT ( c --- u true or false) B POP \ Get ASCII character, stored in C. UPTR LDHL \ Read user pointer to HL M B LD \ Read BASE variable to B, stored at offset 0 in user area. C A LD \ Move character to A. 0 H LDP# \ Initialize HL to 0 (false flag). 30 SUB# \ Subtract ASCII '0'. NC IF 0A CP# NC IF \ Is digit value 10 or higher? 7 SUB# \ Subtract 'A' - '9', so character 'A' gets value 10. 0A CP# CS IF \ If value lower than 10, it was one of the characters between \ '9' and '9' H PUSH \ push false flag and exit. JPIX THEN THEN ELSE H PUSH \ Lower then ASCII 0, no valid digit, push false flag and exit. JPIX THEN B CP NC IF \ Digit value greater or equal to BASE? H PUSH \ Then no valid digit, push false flag and exit. JPIX THEN H B LD A C LD \ Move digit value to BC. H DEC B PUSH \ Push Digit value. H PUSH \ Push true flag. JPIX ;C CODE >R ( 16b --- ) B POP \ Pop value to be pushed on return stack. RPTR LDHL \ Read return stack pointer into HL H DEC B M LD H DEC C M LD \ Store value, decrementing the pointer. RPTR STHL \ Write updated return stack pointer. JPIX ;C CODE R> ( --- 16b) RPTR LDHL \ Read return stack pointer into HL M C LD H INC M B LD H INC \ Read value, incrementing the pointer. RPTR STHL \ Write updated return stack pointer. B PUSH \ Push value. JPIX ;C CODE TCH ( c --- ) H POP L A LD \ Pop character and move to A. %Y FF 52 )LD# \ Set SCR_CT to 255 to prevent 'Scroll?' message. PRT \ Print value via RST 16 ROM call. JPIX ;C CODE CHAN ( n --- ) H POP \ Get channel number. D PUSH \ Save instruction pointer. L A LD 1601 CALL \ Call ROM CHAN-OPEN routine to select output channel. D POP \ Restore instruction pointer. JPIX ;C \ Scr#6 \ META PRIMITIVES PKEY,PAUSE CODE PKEY ( --- c) 5 %Y 1 )RES \ Clear bit 5 of FLAGS, key press available. BEGIN 5 %Y 1 )BIT \ Test bit 5 of FLAGS, is key press now available? \ Will be set by interrupt routine in ROM. Z WHILE \ Call the WAIT routine while no key press. \ All trickery within the WHILE loop is for calling a \ FORTH word from assembler code and returning. 'WAIT LDHL D PUSH \ Save current instruction pointer. HERE 4 + D LDP# \ Set instruction pointer to XXX, NEXT will fetch word \ at XXX JPHL \ Execute WAIT routine. \ XXX HERE 2+ _ \ Word fetched by NEXT, will execute at YYY. \ YYY D POP \ Restore instruction pointer. REPEAT 5C08 LDA \ Read LAST K variable, ASCII code of key pressed. HERE L1 ! \ Mark corrent address in L1, INKEY will jump here. \ The following compares and IFs will convert certain key codes \ yielded by just SYMBOL-SHIFT-KEY to ASCII codes that are normally obtained \ with EXTENDED-MODE SYMBOL-SHIT-KEY, \ so we don't have to use EXTENDED mode. C6 CP# Z IF 5B A LD# THEN \ [ C5 CP# Z IF 5D A LD# THEN \ ] E2 CP# Z IF 7E A LD# THEN \ ~ C3 CP# Z IF 7C A LD# THEN \ | CD CP# Z IF 5C A LD# THEN \ \ backslash. CC CP# Z IF 7B A LD# THEN \ { CB CP# Z IF 7D A LD# THEN \ } C7 CP# Z IF 1 A LD# THEN \ Convert '<=' to special Previous screen code. C9 CP# Z IF 2 A LD# THEN \ Convert '<>' to special HOME code. C8 CP# Z IF 3 A LD# THEN \ Convert '>=' to special Next screen code. A L LD 0 H LD# \ Move key code to HL H PUSH \ and push. %X JPIX ;C CODE INKEY ( --- c ) \ Same sequence of KEY-SCAN, K-TEST and K-DECODE calls is used in BASIC INKEY$ \ handler. D PUSH \ Save instruction pointer. 28E CALL \ Call KEY-SCAN in ROM. Z IF \ If key press valid? 31E CALL \ Call K-TEST in ROM. CS IF \ Valid code if carry set. 0 C LD# D DER A E LD 333 CALL \ Call K-DECODE in ROM. D POP \ Restore instruction pointer. L1 @ JR \ Continue into PKEY routine to process key code in A. THEN THEN D POP \ No valid key pressed. Restore instruction pointer. 0 H LDP# H PUSH   \ Push zero value. JPIX ;C CODE PAUSE ( u --- ) B POP \ Pop number of ticks. BEGIN B PUSH \ Save number of ticks, D PUSH \ Save instruction pointer. \ Use the same trick to call FORTH from assembler as was used in PKEY. 'WAIT LDHL HERE 4 + D LDP# \ Setup instruction pointer to XXX. JPHL \ Execute WAIT function. \ XXXX HERE 2+ _ \ Gets fetched by NEXT, causes execution of code to resume \ at YYY. \ YYY D POP B POP \ Restore instruction pointer and number of ticks, HALT \ Wait for next timer interrupt. B DEC \ Decrement number of ticks. B A LD C OR \ Test for zero. Z UNTIL JPIX ;C CODE NOOP ( --- ) JPIX ;C \ Scr#7 \ META PRMITIVES MTYPE,CMOVE CODE MTYPE ( addr u ---) FF %Y 52 )LD# \ Set SCR_CT variable to 255 to prevemt "Scroll?" message. D PUSH \ Save instruction pointer 2 A LD# 1601 CALL \ Select Channel 2, screen output. D POP \ Restore instruction pointer. B POP H POP \ Address in HL, count in BC BEGIN B A LD C OR \ As long as count nonzero. NZ WHILE M A LD PRT \ Print next character. B DEC H INC \ Decrement count, icrement pointer. REPEAT JPIX ;C CODE CMOVE ( addr1 addr2 u ---) EXX \ Use the shadow registers. B POP D POP H POP \ Get the operands. B A LD C OR NZ IF \ Skip if u is zero. LDIR \ Z80 does block move in one instruction. THEN EXX \ Back to normal registers. JPIX ;C CODE CMOVE> ( addr1 addr2 u ---) EXX \ Use the shadow registers. B POP D POP H POP \ Get the operands. B A LD C OR NZ IF \ Skip if u is zero. B ADDP H DEC \ Add u-1 to source address. EXDE B ADDP H DEC \ Add u-1 to destination address. EXDE LDDR \ Single instruction for block move in reverse order. THEN EXX \ Back to normal registers. JPIX ;C CODE FILL ( addr u 8b ---) EXX \ Use shadow registers. D POP B POP H POP \ Get the operands. BEGIN B A LD C OR NZ WHILE \ While count is not yet zero. E M LD \ Store byte H INC \ increment address B DEC \ decrement count. REPEAT EXX \ Back to normal registers. JPIX ;C CODE SP@ ( --- addr) 0 H LDP# SP ADDP \ Get stack pointer to HL H PUSH \ Push it. JPIX ;C CODE SP! ( --- ) 'S0 SP LDP \ Load stack pointer from initial variable. JPIX ;C CODE RP@ ( --- addr) RPTR LDHL H PUSH \ Push return stack pointer. JPIX ;C CODE RP! ( --- addr) 'R0 LDHL RPTR STHL \ Load return stack pointer from initial variable. JPIX SMUDGE \ Ugly! An extra ;C later on will reverse the effect of \ this SMUDGE. ;C \ 16x16 to 32 bit multiplication subroutine. \ A is loop counter. \ Operand 1 in DE (will be shifted out to the left). \ Operand 2 in BC (will be added to DE:HL) \ Result in DE (msw) and HL (lsw) \ During operation, result bits shift into DE from the right, ASSEMBLER HERE L1 ! \ L1 is label for this subroutine. 0 H LDP# 10 A LD# \ Iterate for 16 bits. BEGIN H ADDP E RL D RL \ Shift entire result 1 bit to the left, shift \ next bit of operand1 out onto carry. CS IF \ If operand1 bit was set. B ADDP \ Add operand2 bit into result. CS IF D INC \ If carry, add 1 to msw of result. THEN THEN A DER Z UNTIL RET ( MULTIPLY) \ Scr#8 \ META PRIMITIVES UM*,M*,UM/MOD \ 32 / 16 bit unsigned division subroutine. 16-bit result and remainder. \ A is a loop counter. \ 32-bit dividend is in HL (msw) and DE (lsw) \ During operation, dividend will shift to the left and divisor is \ trial-subtracted from HL. Quotient bits will shift in from the right. \ divisor in BC (will be subtracted from HL) \ Result: HL is remainder, DE is quotient. HERE L2 ! \ L2 is label for this subroutine. 10 A LD# \ Iterate for 16 bits. BEGIN E SLA D RL H ADCP \ Shift dividend 1 bit to the left CS IF \ If most significant bit of dividend was 1, do the \ subtraction anyway. B SUBP \ Subtract divisor from most significant word. ELSE B SBCP \ Trial subtraction. CS IF B ADDP \ Add back if subtraction result is negative. D DEC \ Compensate the effect of later D INC, so \ last significant quotient bit will not be set. THEN THEN D INC \ Set least significant bit of quotient if subtraction \ succeeded. A DER Z UNTIL RET ( DIVIDE) !CSP ;C \ Finish code definition. Side effect is toggling the SMUDGE bit \ of LATEST definition, RP! in this case. CODE UM* ( u1 u2 --- ud) EXX \ Use shadow registers. B POP D POP \ Get operands L1 @ CALL \ Do the multiplication. H PUSH D PUSH \ Push result EXX \ Back to normal registers. JPIX ;C CODE UM/MOD ( ud u1 --- u2 u3 ) EXX \ Use the shadow registers. B POP \ Divisor into BC. H POP D POP \ Dividend into HL:DE L A LD C SUB H A LD B SBC \ If HL >= BC, then division will overflow. NC IF -1 H LDP# \ Division overflows, Set quotient and remainder both L E LD \ to 0ffffh. H D LD ELSE L2 @ CALL \ Do the division. THEN H PUSH D PUSH \ Push results. EXX \ Back to normal registers JPIX ;C CODE M* ( n1 n2 --- d) EXX \ Use shadow registers. 0 H LDP# B POP \ Pop operand 2. 7 B BIT NZ IF A XOR \ If negative, negate operand2 C SUB A C LD H A LD B SBC A B LD H DER \ H is now -1, to indicate negative operand. THEN D POP \ Pop operand 1. 7 D BIT NZ IF A XOR \ If negative, negate operand1. E SUB A E LD L A LD D SBC A D LD L DER \ L is now -1, to indicate negative operand. THEN H A LD L XOR \ Exor the signs, sign of result. EXAF \ Save result sign. L1 @ CALL \ Do unsigned multiplication. EXAF A OR NZ IF \ If result sign is negative. A XOR \ Negate and push result. L SUB A L LD 0 A LD# H SBC A H LD H PUSH 0 H LDP# D SBCP H PUSH ELSE H PUSH \ No negation, just push the result. D PUSH THEN EXX \ Back to normal registers. JPIX ;C \ OVER ended up here, probably because I forgot to include this word \ when I wrote the stack words. This screen still had free space. CODE OVER ( 16b1 16b2 --- 16b1 16b2 16b1) B POP H POP \ Pop two numbers. H PUSH B PUSH \ Push them back H PUSH \ plus the second number. JPIX ;C \ Scr#9 \ META PRIMITIVES M/,AND,OR,XOR \ Floored division is long and hairy. CODE M/ ( d n1 --- n2 n3) EXX \ Use shadow registers. B POP \ Divisor in BC H POP D POP \ Dividend in HL (msw) and DE (lsw) B PUSH D PUSH \ Push divisor and dividend (lsw) 0 D LDP# \ DE will be used to record operand signs. 7 B BIT \ Is divisor negative? NZ IF A XOR \ Negate divisor. C SUB A C LD D A LD B SBC A B LD E DER \ E is now -1 to indicate negative divisor THEN 7 H BIT \ Is dividend negative? EXSP \ Get dividend LSW into HL NZ IF A XOR L SUB A L LD D A LD H SBC A H LD \ Negate it EXSP \ Get dividend MSW into HL, store LSW on stack. D A LD L SBC A L LD D A LD H SBC A H LD \ Negate that too. D DER \ D is now -1 to indicate negative dividend. EXSP \ Swap back, THEN EXDE EXSP \ Dividend MSW in HL, LSW in DE, operand signs on stack. \ Both operands are now nonnegative. L A LD C SUB H A LD B SBC \ If HL >= BC, then division will overflow. NC IF \ 0 H LDP \ Suggested fix for bug, insert thsese two instructions \ EXSP \ clear operand signs on stack. -1 H LDP# \ Set both quotient and remainder to -1. L E LD \ BUG: if operands are negative, we still negate the \ result(s) and correct for floored division. H D LD ELSE L2 @ CALL \ Divde the numbers THEN B POP \ Get signs from stack. B A LD A AND \ Test dividend sign. NZ IF A XOR \ Negate remainder if dividend is negative. L SUB A L LD 0 A LD# H SBC A H LD THEN B A LD C XOR NZ IF \ If operands have different signs. A XOR \ Negate quotient. E SUB A E LD 0 A LD# D SBC A D LD THEN H A LD L OR NZ IF \ If remainder is nonzero. B A LD C XOR NZ IF \ And operands have differnt signs. B POP B PUSH B ADDP \ Add original divisor to remainder D DEC \ decrement quotient, required for floored division. THEN THEN B POP \ Remove original divisor H PUSH \ Push remainder D PUSH \ Push quotient EXX \ Back to normal registers. JPIX ;C CODE STOPON ( --- ) IM2 \ Switch to Interrupt mode 2, so our own interrupt handler \ with the BREAK key test is used. JPIX ;C CODE STOPOFF ( --- ) IM1 \ Switch to Interrupt mode 1, so the ROM interrupt handler \ is used. JPIX ;C CODE XOR ( 16b1 16b2 --- 16b3) B POP H POP \ Get operands C A LD L XOR A L LD B A LD H XOR \ XOR them. A H LD H PUSH \ Push result JPIX ;C CODE AND ( 16b1 16b2 --- 16b3) B POP H POP \ Get operands C A LD L AND A L LD B A LD H AND \ AND them. A H LD H PUSH \ Push result JPIX ;C CODE OR ( 16b1 16b2 --- 16b3) B POP H POP \ Get operands. C A LD L OR A L LD B A LD H OR \ OR them. A H LD H PUSH \ Push result. JPIX ;C \ Scr#10 \ META PRIMITIVES ARITHMETIC CODE 0= ( n1 --- f) H POP H A LD L OR \ Check that operand is equal to 0. 0 B LDP# \ Prepare false flag in BC Z IF B DEC \ Change to true -1 is operand was 0. THEN B PUSH \ Push result. JPIX ;C CODE 0< ( n1 --- f) AF POP \ Only need to check most significant byte (in A). RLCA \ Shift most significant bit into carry. 0 A LD# \ A=0 0 SBC# \ If carry set, change it to 0ffh A L LD A H LD \ Flag in HL H PUSH \ Push result. JPIX ;C CODE < ( n1 n2 --- f) B POP H POP \ Get operands. A XOR \ A contains flag=0, clear carry. B SBCP \ Subtract operands m if FF A LD# \ If subtraction is negative, set flag to 0ffh then v if CPL \ If overflow, complement flag in A. then \ sign flag XOR overflow flag is proper result for \ signed compare, works throughout integer range. A L LD A H LD \ Flag in HL H PUSH \ Push result. JPIX ;C CODE + ( w1 w2 --- w3) B POP H POP \ Get operands. B ADDP \ Add H PUSH \ Push result. JPIX ;C CODE - ( w1 w2 --- w3) B POP H POP \ Get operands B SUBP \ Subtract H PUSH \ Push result JPIX ;C CODE NEGATE ( n1 --- n2) B POP \ Get operand A XOR \ A=0, clear carry. A L LD A H LD \ HL=0 B SBCP \ Subtract BC from 0 H PUSH \ Push result. JPIX ;C CODE D+ ( wd1 wd2 --- wd3 ) EXX \ Use shadow register set. B POP D POP \ wd2 in BC (msw) and DE (lsw) H POP \ get msw of wd1 EXSP \ swap with lsw of wd1 on stack. D ADDP \ Add least significant words. EXSP \ Store result on stack, get msw of wd1 in HL B ADCP \ Add most significant words H PUSH \ Push result. EXX \ Back to normal registers. JPIX ;C CODE D- ( wd1 wd2 --- wd3 ) EXX \ Use shadow register set. B POP D POP \ wd2 in BC (msw) and DE (lsw) H POP \ get msw of wd1 EXSP \ swap with lsw of wd1 on stack. D SUBP \ Subtract least significant words. EXSP \ Store result on stack, get msw of wd1 in HL B SBCP \ Subtract most significant words H PUSH \ Push result. EXX \ Back to normal registers. JPIX ;C CODE DNEGATE ( d1 --- d2) H POP B POP \ Get number in HL (msw) and BC (lsw) H PUSH \ Push msw. 0 H LDP# B SUBP \ subtract least sigificant word from 0. B POP \ Get msw of input H PUSH \ Push lsw of result 0 H LDP# B SBCP \ subtract most significant word from 0. H PUSH \ push msw of result. JPIX ;C CODE U< ( u1 u2 --- f) B POP H POP \ Get operands A XOR \ A=0 (prepare flag), clear carry. B SBCP \ Subtract operands. 0 SBC# \ Subtract carry of subtraction from A, A=0ffh if u1IN \ position in input stream/ 1C USER SCR \ Screen last listed. 1E USER BLK \ block number of input stream. 20 USER CURRENT \ vocabulary to add words to. 22 USER CONTEXT \ Vocabulary first searched. 24 USER SPAN \ Number of characters read with EXPECT. 26 USER #TIB \ Number of characters in Terminal Input Buffer. 2E USER WIDTH \ Max. number of characters stored in new name. \ One code definition thrown in here. CODE CLS ( --- ) D PUSH \ Save instruction pointer. 0DAF CALL \ Call CL-ALL routine in ROM to clear the screen. 2 A LD# 1601 CALL \ Select channel 2, screen output. D POP \ Restore instruction pointer. JPIX ;C \ The usual constants in the target system. 0 CONSTANT 0 20 CONSTANT BL \ Blank space. 1 CONSTANT 1 400 CONSTANT B/BUF \ Bytes per buffer 2 CONSTANT 2 01 CONSTANT B/SCR \ Buffers per screen. 3 CONSTANT 3 -1 CONSTANT -1 DECIMAL \ Constant addresses of items below FORTH image. See section 4.3 of User Manual. 26003 CONSTANT FIRST \ Start address of single block buffer. \ Two bytes below is the block number (0 if no block). \ The byte at address 26000 is unused, reserved for \ update flag. 27027 CONSTANT LIMIT \ Address beyond that buffer. 25600 CONSTANT TIB \ Address of terminal input buffer. HEX \ Only now do we start META-INTERPRET, this is our first colon definition \ to compile in the target system. META-INTERPRET : EMIT ( c --- ) (EMIT) @ EXECUTE 1 OUT +! ; \ The OUT user variable stores the column position. : HERE ( --- addr) DP @ ; : CR ( --- ) 0D EMIT 0 OUT ! ; : KEY ( --- c) (KEY) @ EXECUTE ; : TYPE ( addr u --- ) 0 ?DO DUP C@ EMIT 1+ LOOP DROP ; \ Scr#5 \ META COUNT,ABORT,ARITHMETIC : COUNT ( addr1 --- addr2 n) DUP 1+ SWAP C@ ; : (.") ( --- ) [ FORTH HERE-T 3 - '." ! META ] \ Fill in the address of the ." runtime part \ in META compiler. R> \ Get return address, where string is stored, COUNT 2DUP + \ Update return address. >R \ Put updated address back. TYPE ; \ Type the string. : ABORT ( --- ) \ Start executing at WARM entry point. [ FORTH ORIGIN 3 + META ] LITERAL EXECUTE ; : (ABORT") ( f --- ) [ FORTH HERE-T 3 - 'ABORT ! META ] \ Fill in the address of the ABORT" runtime \ part in META compiler. R> COUNT \ Access string at return address. ROT IF TYPE BL EMIT \ Type the error message. HERE COUNT TYPE \ Type the word last read. ABORT \ Never return from ABORT ELSE + >R \ Update return address. THEN ; : ?DUP ( 16b --- 16b 16b or 16b) DUP IF DUP THEN ; : 2ROT ( 32b1 32b2 32b3 ---- 32b2 32b3 32b1) 5 ROLL 5 ROLL ; : S->D ( n --- d) \ Sign-extend the single precision number, if n<0 then add 0xffff else 0 DUP 0< ; : 0> ( n --- f) NEGATE 0< ; : > ( n1 n2 --- f) SWAP < ; : = ( 16b1 16b2 --- f) - 0= ; : MIN ( n1 n2 --- n3) 2DUP > IF SWAP THEN DROP ; : MAX ( n1 n2 --- n3) 2DUP < IF SWAP THEN DROP ; : NOT ( 16b1 --- 16b2) \ Bitwise invert, will also invert \ proper flags 0xffff <-> 0x0000 -1 XOR ; : +- ( n1 n2 --- n3) 0< IF NEGATE THEN ; : ABS ( n --- u) DUP +- ; : D0= ( wd --- f) OR 0= ; : D0< ( d --- f) UNDER 0< ; \ Only need to check MSW. : D+- ( d1 --- d2) 0< IF DNEGATE THEN ; : DABS ( d --- ud) DUP D+- ; : * ( w1 w2 --- w3) UM* DROP ; : /MOD ( n1 n2 --- n3 n4) SWAP S->D ROT \ Convert n1 to double number. M/ ; : / ( n1 n2 --- n3) /MOD UNDER ; : MOD ( n1 n2 --- n3) /MOD DROP ; \ Scr#6 \ META EXPECT,BANK,ADDR CODE TOGGLE ( addr 8b --- ) B POP H POP C A LD M XOR A M LD JPIX ;C : BS ( --- ) 08 EMIT ; : SPACE ( --- ) BL EMIT ; : SPACES ( u ---) 0 ?DO SPACE LOOP ; : CAP ( ---) 5C6A 8 TOGGLE ; Flip bit 8 in FLAGS2 system variable. \ Expect is one of the most complex FORTH words. : EXPECT ( addr u ---) DUP IF \ Ignore if u=0 SWAP 0 SPAN ! BEGIN 12 EMIT 1 EMIT \ Set FLASHING. 4C \ Capital L 5C6A C@ 8 AND IF 9 - THEN \ If CAPS bit is set, change it into C. EMIT \ Emit the cursor character, flashing L or C. 12 EMIT 0 EMIT \ Set FLASHING off. BS \ Move cursor position one back. KEY \ Read key. DUP 1F > OVER 80 < AND \ Is it a printable character? IF DUP EMIT \ Display it. OVER C! \ Store it. 1+ \ Update address. 1 SPAN +! \ Increment SPAN. ELSE DUP 0D = IF \ is it ENTER? DROP 2DROP SPACE EXIT \ Remove stuff from stack and exit. ELSE DUP 0C = SPAN @ AND \ Is it DELETE and do we already have \ characters in the line? IF -1 SPAN +! \ Decrement number of characters read. SPACE BS BS \ Overwrite cursor with space, two backspaces. DROP \ Remove DEL charcter from stack 1- \ Decrement address. ELSE DUP 2 = IF \ Is SYM-SHIFT-W pressed? BYE ELSE 6 = IF CAP THEN \ Is CAPS-LOCK pressed, then flip state. THEN THEN THEN THEN OVER SPAN @ = \ Exit if number of characters equals max. UNTIL THEN SPACE \ Overwrite cursor with space. 2DROP ; : ERASE ( addr u ---) 0 FILL ; : BLANK ( addr u ---) BL FILL ; \ BANKSWITCH SPECTRUM 128 \ Map one of the RAM banks to the address range 0xc000-0xffff. \ 0 is the normal memory bank used by BASIC. \ 1-5 are converted to 1,3,4,6 and 7. Banks 2 and 5 are mapped \ to 0x4000-0xBfff, don't use these for RAM disk. \ Operation has no effect on Spectrum 48. : BANK ( n --- ) DUP 1 > IF 1+ THEN \ Convert range 0..5 to 0, 1, 3, 4, 6 and 7. DUP 4 > IF 1+ THEN 10 + \ Add 0x10 to select normal ROM. 7FFD P! ; VARIABLE LO \ Hold base address of RAM disk, 0 on Spectrum 128 0A CONSTANT #B \ Number of screens in RAM disk. : #SCR ( --- n) LO @ IF #B \ On the 48, number of screens is defined by #B. ELSE 50 \ On the 128 we have 80 screens. THEN ; \ ADDR yields the address of any given screen in the RAM disk \ and (on Spectrum 128) switches to the correct bank. \ Words that directly use this function have to reside below 0xC000. : ADDR ( n1 --- addr) 1- \ Screen numbers start at 1. DUP #SCR U< 0= ABORT" Out of ramdisk" \ Check this is a valid screen number. LO @ IF \ Spectrum 48 B/BUF * LO @ + \ Add to address in LO variable. ELSE \ Spectrum 128 10 /MOD \ Compute bank number and screen within bank. 1+ BANK \ Select bank. B/BUF * C000 + \ Add to 0xc000, start of upper 16kB. THEN ; \ Scr#7 \ META SAVE-B,EMPTY-B,BLOCK,WORD \ This FORTH system has one block buffer, containing a block from \ the RAM disk. Buffer handling functions are very simple. \ The word at FIRST - 2 is the block number of the block stored in the \ buffer, 0 if there is none. : SAVE-BUFFERS ( ---) \ Will always copy the buffer to RAM disk, whether \ it was updated or not. FIRST 2- @ ?DUP \ Do we have a buffer? IF ADDR FIRST SWAP B/BUF CMOVE \ Copy to RAM disk. 0 BANK \ Select normal memory bank. THEN ; : EMPTY-BUFFERS ( ---) \ Mark buffer as empty. 0 FIRST 2- ! ; : UPDATE ( --- ) \ Do nothing, SAVE-BUFFERS will always save. ; : BUFFER ( n --- addr) SAVE-BUFFERS FIRST 2- ! \ Mark block buffer number. FIRST B/BUF BLANK \ Fill buffer with spaces. FIRST ; : FLUSH ( ---) SAVE-BUFFERS EMPTY-BUFFERS ; : BLOCK ( n --- addr) DUP FIRST 2- @ - \ Does the current block buffer contain a different block \ from the one requested? IF SAVE-BUFFERS \ Save buffer to RAM disk. DUP ADDR FIRST B/BUF CMOVE \ Copy data from RAM disk to buffer. FIRST 2- ! \ Mark the block number stored. 0 BANK \ Switch to normal memory bank. ELSE DROP \ Drop block number. THEN FIRST \ Return the start address of the block buffer. 0 LIMIT C! ; \ Set byte at LIMIT to 0. : WORD ( c --- addr) 0 BANK \ Make sure normal RAM is selected. BLK @ ?DUP IF \ If BLK contains nonzero BLOCK \ Read from block. ELSE TIB \ else read from TIB. THEN SWAP OVER >IN @ + \ Add contents of >IN to address. (WORD) \ Do the hard work in a code definition. SWAP - >IN ! \ Subtract input start address and tore updated offset \ into >IN HERE ; \ Return address where word is stored. : FIND ( addr1 --- addr2 n) CONTEXT @ @ (FIND) \ Search context vocabulary first. CONTEXT @ CURRENT @ - \ Is CONTEXT different from CURRENT? IF ?DUP 0= IF \ If last find returned 0 flag? CURRENT @ @ (FIND) \ Search CURRENT. THEN THEN ; : ' ( --- addr) BL WORD FIND \ Read word and find. 0= ABORT" Not found" ; \ Complain if not found. : ALLOT ( n --- ) HERE + \ Add to current dictionary pointer. LO @ 1- OVER 80 + U< \ Check that we have enough space below LO. ABORT" Dictionary full" DUP FENCE @ U< \ Check that we are not below FENCE. ABORT" Protected dictionary" STOPOFF DP ! STOPON ; \ Prevent break key interrupt while updating DP. : PAD ( --- addr) HERE 38 + ; \ Scr#8 \ META ERRORS NUMERIC CONV \ Some more user variables. 28 USER STATE \ Outer interpreter state, nonzero for compiling. 2A USER CSP \ Stack pointer check for compiler. 20 CONSTANT C/L \ Characters per line (in screen), standard would be 64. \ The following words are used internally by the compiler for error checking. : ?PAIRS ( n1 n2 --- ) - ABORT" Wrong structure" ; : ?COMP ( --- ) STATE @ 0= ABORT" Not compiling" ; : ?EXEC ( --- ) STATE @ ABORT" Not executing" ; : !CSP ( --- ) \ Store stack pointer at start of definition. SP@ CSP ! ; : ?CSP ( --- ) \ Check that the stack pointer is the same as at start. SP@ CSP @ - ABORT" Incomplete structure" ; : ?LOADING ( ---) BLK @ 0= ABORT" Not loading" ; : ?STACK ( --- ) SP@ S0 @ 1+ U< 0= ABORT" Stack empty" SP@ 5C65 @ 10 + \ Read STKEND BASIC system variable, still require 16 \ bytes free above that. U< ABORT" Stack full" ; \ This word was used to make the ZX-Printer usable on a Spectrum 128. \ The Spectrum 128 redirects printer output to the serial port and abuses. \ the printer buffer for other purposes. \ The ROM must be switched to 48k mode by clearing bit 4 in FLAGS. \ This is done in COLD. : ZX-PRINT 5B00 100 ERASE \ Erase printer buffer. 09F4 5C4F @ 0F + ! ; \ Put original ROM entry point in the CHANS table. : */MOD ( n1 n2 n3 --- n4 n5) >R \ Save divisor on return stack. M* R> M/ ; : */ ( n1 n2 n3 ---) */MOD UNDER ; \ Discard modulus. \ This word is used for numeric conversion, 32 by 16 division giving 32-bit \ quotient. Implemented in many FORTHs since FIG-Forth. : M/MOD >R \ Save divisor on return stack. 0 R@ UM/MOD \ Zero-extend MSW of dividend and divide MSW. R> \ Get divisor back. SWAP >R \ Save quotient MSW on return stack. UM/MOD \ Divide MSWRemainder: LSWDividend by divisor. R> ; \ GET MSW of quotient. \ The following words are for numeric conversion. They have been implemented \ the same way in many FORTHs since FIG-Forth. \ \ The output string is produced from rightmost digit to leftmost digit \ in a memory area just below PAD, ad decreasing addresses. \ \ At the start of numeric conversion <#, a double number is on the stack. \ The word # extracts the rightmost digit and puts it into the string. \ The word #> discards the double number (which is now supposed to be zero) \ And returns the string. : HOLD ( c --- ) -1 HLD +! \ Decrement character address. HLD @ C! ; \ Store the character. : <# ( ud --- ud) PAD HLD ! ; : #> ( ud --- addr c) 2DROP \ Discard number being converted. HLD @ PAD OVER - ; \ Return result string. : # ( ud1 --- ud2) BASE @ M/MOD \ Divide by BASE. ROT \ Put modulus on top, this is the extracted digit value. \ Double number quotient remains on the stack. DUP 9 > IF \ If digit is above 9, add 'A'-'9', so digit value 10. \ will become A, etc. 7 + THEN 30 + HOLD ; \ Add ASCII '0', to convert digit to ASCII. : #S ( ud --- 0 0) BEGIN # 2DUP D0= UNTIL ; : SIGN ( n --- ) 0< IF 2D HOLD THEN ; \ Add minus sign to string if n is negative. \ Scr#9 \ META NUMERIC CONV,MASS STORE : D.R ( d n --- ) >R \ Save field width on stack. SWAP OVER ( d.msw d.lsw d.msw) \ Keep sign in original msw. DABS \ Take absolute value. <# #S \ Convert number to string. ROT SIGN \ Add - if original msw was negative. #> R> OVER - 0 MAX SPACES \ Print spaces (field width - string length) \ but do not print a negative number of spaces. TYPE ; \ Print the converted string. : .R ( n1 n2 --- ) >R S->D R> D.R ; : D. ( d --- ) 0 D.R SPACE ; \ If field width in D.R is 0, no spaces are printed in front. : . ( n ---) S->D D. ; : U. ( u ---) 0 D. ; : ? ( addr --- ) @ . ; : HEX ( --- ) 10 BASE ! ; : DECIMAL ( --- ) 0A BASE ! ; : H. ( u --- ) BASE @ \ Save and restore original base. SWAP HEX 0 <# # # # # #> TYPE SPACE BASE ! ; \ These words handle file I/O. They call BASIC routines to do the \ work for us. \ GETFN stores three items into BASIC variables, which were pre-initialized \ by the BASIC program. The same set of variables must be initialized \ in the same order, otherwise GETFN will no longer work. \ The offsets with respect to VARS are hard-coded in GETFN. \ \ A name is read from the input string and stored into A$ (A$ was initialized \ to length 10 before). \ \ Two integers are stored in variables I and J. \ Numeric variables in BASIC are normally floating point, but Spectrum BASIC \ represents numbers in the range -65535...+65535 as integers in \ an FP number with exponent byte set to zero. Therefore we can just store \ the integer at the right offset. : GETFN ( n1 n2 ---) 5C4B @ \ Read VARS. DUP 6 + DUP 0A BLANK \ Clear the A$ variable. BL WORD COUNT ROT SWAP CMOVE \ Copy word from input string into A$ \ We should have checked word length, we will \ silently clobber the variables if name is too long. DUP 19 + ROT SWAP ! \ Store J 13 + ! ; \ Store I. : DELETE ( --- ) \ Delete a file with the given name. 0 0 GETFN 28 BCAL ; \ BASIC line 40. : CAT ( --- ) \ Show a list of files. 2D BCAL ; \ BASIC line 45. : PUT ( n1 n2 --- ) FLUSH \ Synchronize RAM disk with buffer. OVER - 1+ B/BUF * \ Compute file length. SWAP DUP ADDR \ Compute base address ( n1 addr size ---) ROT GETFN \ Read name into A$, set I and J variables. ADDR DROP \ Select the correct bank again, was undone by GETFN 32 BCAL \ BASIC line 50. 0 BANK ; \ Back to normal memory bank. : GET ( n1 --- ) FLUSH \ Make sure block buffer is empty. DUP ADDR 0 GETFN \ Read name into A$ Address to I, J set to 0 (unused). ADDR DROP \ Select the correct bank again, was undone by GETFN 37 BCAL \ BASIC line 55 0 BANK ; \ Back to normal memory bank. : FORMAT \ Clear all buffers in RAM disk. #SCR 1+ 1 DO I BUFFER DROP LOOP ; : INDEX ( n1 n2 ---) 1+ SWAP DO CR I 2 .R \ Print \ Print block number in field of 2 characters. I BLOCK 1E TYPE \ Print top line, only 30 characters of it. LOOP ; \ Note: we use LIT TCH instead of ['] TCH which was a common FORTH idiom. \ The compiler does not even know it is a literal, it just lays out the \ compilation address for LIT followed by that of TCH. : >P ( ---) LIT TCH (EMIT) ! \ Set default handler for EMIT. 3 CHAN ; \ Select output channel 3, is printer. : >S ( ---) LIT TCH (EMIT) ! \ Set default handler for EMIT. 2 CHAN ; \ Select output channel 2, is screen. : TERMINAL ( --- ) LIT PKEY (KEY) ! \ Set default handler for KEY. >S ; \ And initialize screen output. \ Scr#10 \ META CONVERT,NUMBER,LITERAL : ?TERMINAL ( --- f) \ Check if EDIT (CAPS-SHIT-1) was pressed. INKEY 7 = ; \ The following words are for converting ASCII numbers to binary form, \ used by the interpreter of the target system. : CONVERT ( ud1 addr1 --- ud2 addr2) BEGIN 1+ \ Increment address. DUP >R \ Save it on the return stack C@ DIGIT \ Read a character and convert it to digit value. WHILE SWAP BASE @ UM* DROP \ Multiply number MSW by BASE. (digitval msw*base) ROT BASE @ UM* D+ \ Multiply number LSW by base and add it. \ Result is double number with value ud1*BASE+digitval. DPL @ 1+ IF 1 DPL +! THEN \ Increments DPL if it was set earlier.. R> \ Get saved address. REPEAT R> ; 2C USER 'ERRNUM \ Handler invoked when NUMBER finds an error. \ Allows number to be extended with other \ parsing code, e.g. for floating point. : NUMBER ( addr --- wd) 0 0 \ Start with a double of value 0. ROT DUP 1+ C@ \ Read character at addr+1 DUP 26 = IF \ Is it equal to ASCII '&'? DROP 2+ C@ \ Read character following the '&' return that. UNDER UNDER 0 \ Remove double value, zero extend char to double. -1 DPL ! \ Set DPL to -1, indicating single number. ELSE 2D = DUP >R \ Compare character with '-', save to return stack. - \ Also use the flag to adjust the address \ (if there was a minus sign, skip to next character. -1 \ Initialize DPL to -1. BEGIN DPL ! \ Store DPL value (-1 or 0). CONVERT \ Convert a string of digits into binary. DUP C@ BL - \ Is the next character a blank space? WHILE DUP C@ 2E - \ Compare the next character with '.' 'ERRNUM @ EXECUTE \ Error if not equal. 0 \ Initialize DPL to 0. REPEAT DROP \ drop address. R> IF DNEGATE THEN \ negate the number if saved sign THEN ; : (ERRNUM) ( f ---) \ If NUMBER can't convert the word after \ the interpreter could not find it, then abort. ABORT" Can't find" ; \ The following words are part of the compiler on the target system. : , ( 16b ---) HERE ! 2 ALLOT ; : C, ( 8b ---) HERE C! 1 ALLOT ; : COMPILE ( --- ) ?COMP \ Check we are compiling. R> DUP @ \ Read word at return address (immediately following \ COMPILE in the colon definition where itt was \ compiled. , \ Compile the compilation address to the new def. 2+ >R ; \ Update return address so we skip the next word. : LITERAL ( 16b --- nothing or 16b) STATE @ IF \ If we are compiling COMPILE LIT \ Compile the LIT primitive. , \ Put the literal value after it. THEN ; IMMEDIATE : DLITERAL (32b --- nothing or 32b) STATE @ IF SWAP [COMPILE] LITERAL \ Put LSW first. [COMPILE] LITERAL \ Put MSW last. THEN ; IMMEDIATE : LATEST ( --- addr) CURRENT @ @ ; : SMUDGE ( --- ) LATEST 20 TOGGLE ; \ Set bit 5 in name field of latest def to make it \ findable or unfindable. : ['] ( --- ) ' [COMPILE] LITERAL ; IMMEDIATE FORTH DEFINITIONS DECIMAL EXIT \ Exit the META interpreter at end of file. \ FILE META4 \ Scr#1 \ META CREATE AND BUILDING WORDS HEX META DEFINITIONS META-INTERPRET \ Start it again for the next file. : >BODY ( addr1 --- addr2) 3 + ; \ Skip code field. \ Defining words in the compiler on the target system. \ All defining words on the target system will call CREATE, which \ adds headers. \ \ Note that CREATE uses the WIDTH variable, so it can store names with \ fewer characters than the original length. Lengths must still match, but \ characters beyond the stored length are not checked. An old trick to save \ space. \ \ The trick was used occasionally to create a word with one signicicant name \ character, for instance $XXXX (WIDTH temporarily set to 1) with length 5. \ Now any word with length 5 and starting with $ will match that name, such as \ $0000 or $FFFF. When the word is executed it can read characters from \ the word buffer at HERE and use these, for instance to parse a hex number \ and put it on the stack/compile it as a literal. \ : CREATE ( --- ) LATEST , \ Add link field. BL WORD \ Read next word from input stream. DUP C@ 0= ABORT" Name expected" \ Abort if no word read. DUP C@ WIDTH @ MIN 1+ ALLOT \ Allocate space for the name. \ Note that the name was read at HERE, \ so it is already in its final location. HERE 1- 80 TOGGLE \ Set bit 7 in final character of name. STOPOFF \ No BREAK key while updating current. CURRENT @ ! \ Add new definition to CURRENT vocabulary. CD C, \ Add a CALL instruction. [ NEXT ] LITERAL , \ to the NEXT address, (, will call ALLOT will call STOPON) LATEST 80 TOGGLE ; \ Set bit 7 of first name character. : VARIABLE ( --- ) CREATE 2 ALLOT ; : CONSTANT ( 16b ---) CREATE [ DOCON ] LITERAL HERE 2- ! \ Store the DOCON address in the code field. , ; \ Add the value to the parameter field. : USER ( n ---) CREATE [ DOUSER ] LITERAL HERE 2- ! \ Store the DOUSER address in the code field. C, ; \ Add the variable offset to the parameter field. \ Traverse is used by >NAME and NAME> to find the opposite end of the \ name in a header. : TRAVERSE ( addr1 n --- addr2) SWAP BEGIN OVER + \ Update address by adding n (either 1 or -1) 7F OVER C@ < \ Read character and check it is at least 80h. UNTIL UNDER ; : >NAME ( addr1 --- addr2) 1- -1 TRAVERSE ; : NAME> ( addr1 --- addr2) 1 TRAVERSE 1+ ; : (;CODE) ( --- ) [ FORTH HERE-T 3 - 'CODE ! META ] \ Fill in the 'CODE address of the \ meta compiler. R> \ Remove return address. \ This is not put back, so (;CODE) will return from \ the containing colon definition. LATEST NAME> 1+ ! \ Put the return address in the code field of the \ latest definition. \ The latest definition will now CALL to the CALL DOCOL \ in the DOES> part. \ The first call puts the parameter field on stack, the \ DOCOL will execute the DOES> part as a colon definition. ; : DOES> ( --- ) COMPILE (;CODE) \ Add (;CODE) to the defining word, causing it to exit. \ and change the code field in the newly defined word, \ so it will execute the DOES> part. CD C, [ DOCOL ] LITERAL , \ Add a call to DOCOL to the defining word, \ just after (;CODE). ; IMMEDIATE : [ ( --- ) 0 STATE ! ; IMMEDIATE : ] ( --- ) 0BF STATE ! ; \ Note the value 0BF was used traditionally in Fig-FORTH \ so the inner interpreter could compare the length byte \ of the name with the contents of STATE \ In an IMMEDIATE word the length byte would be greater than \ 0BF, so the word would always execute. \ In a non-immediate word the length byte would be less than \ 0BF, but greater than 0, so it would execute if state was 0. \ On this system, the VALUE of STATE is NOT used in this way. : : ( ---) ?EXEC CREATE SMUDGE \ Make the word unfindable, temporarily until ;. [ DOCOL } LITERAL HERE 2- ! \ Store the DOCAL address in the code field. \ Note that we have to use } here instead of ] as ] is now redefined. \ And unlike many other compiler words, ] is not immediate. !CSP ] ; CURRENT @ CONTEXT ! ; IMMEDIATE : ; ( --- ) ?COMP ?CSP COMPILE EXIT SMUDGE [COMPILE] [ ; IMMEDIATE \ Scr#2 \ META OUTER INTERPRETER,STRUCT : QUERY ( --- ) TERMINAL \ Make sure wa use screen and keyboard. TIB 80 EXPECT \ Read the line. 0 TIB SPAN @ + C! \ Add a trailing null byte. 0 >IN ! 0 BLK ! SPAN @ #TIB ! ; : INTERPRET ( --- ) BEGIN BL WORD DUP C@ \ Read next word. WHILE \ Continue the loop as long as words are available. FIND DUP IF 0< STATE @ AND IF \ Word is found, execute it or compile it. , ELSE EXECUTE THEN ELSE DROP NUMBER \ Not found, parse it as a number. DPL @ 1+ IF \ If number contains decimal point. [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN ?STACK REPEAT DROP ; : LOAD ( n ---) >IN @ >R BLK @ >R \ Save old input stream on return stack. BLK ! 0 >IN ! INTERPRET R> BLK ! R> >IN ! ; \ Restore old input stream. : --> ( ---) ?LOADING 1 BLK +! 0 >IN ! ; IMMEDIATE : ( ( ---) 29 WORD DROP \ Read until next ')' character, discard it. ; IMMEDIATE : \ ( ---) ?LOADING >IN @ C/L NEGATE AND C/L + \ Adjust >IN to start of next line. >IN ! ; IMMEDIATE \ Control structure words on the target system. : >MARK ( --- addr) ?COMP HERE \ Put current address on stack for forward reference. 0 , \ Add extra cell for forward branch address. ; : >RESOLVE ( addr ---) ?COMP HERE SWAP ! \ Fill in forward branch address with current location. ; : MARK 3 \ Mark forward ref and push 3 on stack for consistency check. ; IMMEDIATE : ?DO ( --- addr 3) COMPILE (?DO) \ Compile runtime part >MARK 3 \ Mark forward ref and push 3 on stack for consistency check. ; IMMEDIATE : LOOP ( addr 3 --- ) 3 ?PAIRS \ Do consistency check. COMPILE (LOOP) \ Compile runtime part. >RESOLVE \ resolve forward reference from DO. ; IMMEDIATE : +LOOP 3 ?PAIRS \ Do consistency check. COMPILE (+LOOP) \ Compile runtime part. >RESOLVE \ resolve forward reference from DO. ; IMMEDIATE \ Scr#3 \ META COMPILING WORDS,QUIT : BEGIN ( --- addr 1) MARK 4 \ Mark forward reference and push 4 for consistency check. ; IMMEDIATE : REPEAT ( addr1 addr2 4 ---) 4 ?PAIRS SWAP COMPILE BRANCH \ Compile unconditional branch RESOLVE \ Resolve forward reference, starting at WHILE ; IMMEDIATE : IF ( --- addr 2) COMPILE ?BRANCH \ Compile conditional branch. >MARK 2 \ Mark forward reference and push 2 for consistency check. ; IMMEDIATE : ELSE ( addr1 2 --- addr2 2) 2 ?PAIRS COMPILE BRANCH \ Compile onconditional branch, so IF part skips ELSE part. >MARK \ Mark forward reference for this branch. SWAP >RESOLVE \ resolve forward reference originating in IF. \ if conditional branch at IF is taken, jump to ELSE part. 2 \ Push 2 for consistency check ; IMMEDIATE \ THEN will terminate either IF or IF..ELSE : THEN ( addr 2 --- ) 2 ?PAIRS >RESOLVE \ Resolve forward reference, either from IF or from ELSE. ; IMMEDIATE : ." ( ---) COMPILE (.") \ Compile runtime part. 22 WORD \ Get text delimited by next " C@ 1+ ALLOT \ Allocate space for it. String does not need to be moved, it \ is already at HERE. ; IMMEDIATE : .( ( ---) 29 WORD COUNT TYPE \ Type text delimited by ) ; IMMEDIATE : ABORT" COMPILE (ABORT") \ Compile runtime part. 22 WORD \ Get text delimited by next " C@ 1+ ALLOT \ Allocate space for it. String does not need to be moved, it \ is already at HERE. ; IMMEDIATE : [COMPILE] ( --- ) ' , \ Find the word and compile its compilation address. ; IMMEDIATE : QUIT ( --- ) RP! [COMPILE] [ \ Go to interpretation state. BEGIN CR QUERY INTERPRET STATE @ 0= IF ." Ok" THEN 0 UNTIL ; : DRIVE ( d ---) DUP 5C4B @ \ Read VARS system variable, start of BASIC variables. 1F + C! \ Store in D BASIC variable. Offset depends on variables \ having been assigned in a particular order. 5CB0 C! ; \ Store it also at 27028, the 'unused' system variable. \ Scr#4 \ META CLEAR,COPY,RUN : CLEAR ( n --- ) BUFFER DROP ; \ BUFFER clears the buffer. : COPY ( n1 n2 ---) SWAP BLOCK \ Source screen in block. SWAP ADDR \ Destination is RAM disk, in any bank. B/BUF CMOVE \ Copy one blck. 0 BANK ; \ Select normal bank. : RUN 1 GET 1 LOAD ; \ Get a file and load from it. \ Scr#5 \ META INTERRUPT,FORTH-83,VOC FORTH DEFINITIONS HEX \ Create an entiire 256-byte page + 1 byte (257 bytes) all filled with \ the same byte. The I register will point to this page. When in \ Interrupt mode 2, the Z80 will read an interrupt vector from this page \ where the least significant 8 bits of the address are read from the bus. \ \ Unfortunately no hardware provides the vector address. Normally 0ffh \ is read from the bus, but you can't be sure. Therefore the same word \ will be read from anywhere in the page, as the page is filled with the \ same byte. This will be the adress of the interrupt handler. HERE-T FF + FF00 AND \ Go to the next page-aligned address. DUP 101 + DP-T ! \ Add 257 to it, end of the 257-byte area to fill. DP-T 1+ C@ DUP 100 * + DP-T ! \ Set DP-T to address where both bytes are the same. \ Example: Filled page starts at 0x8400 and will be filled with all 0x85 bytes. \ The interrupt handler will now start at 0x8585. DUP CONSTANT INTREG \ Set INTREG to start of page. OFFSET + 101 HERE-T FF AND FILL \ Fill the page (257 bytes) with the byte. ASSEMBLER ( INTERRUPT) \ Interrupt handler starts here. 38 RST \ Call the standard ROM interrupt handler, keyboard scan \ and FRAMES increment. AF PUSH \ Save AF \ The following it similar to the BREAK-KEY routine in ROM. \ Do a WARM start if break key pressed. 7F A LD# FE IN \ Read Lower right keys, RRA NC IF \ Rightmost bit cleared, so SPACE pressed. FE A LD# FE IN \ Read lower left keys. RRA NC IF \ Rightmost bit cleared, so CAPS-SHIFT pressed too. 0 LDA \ Read the first ROM byte. F3 CP# \ Check that it's equal to F3h, standard 48k BASIC \ ROM paged in. \ Do not break when one of the other ROMs is paged in. Z IF 14 A LD# 5C3A STA \ Store ERR_NR, error code 20 for BREAK. ORIGIN 3 + JP \ Do a WARM start. THEN THEN THEN AF POP RET \ Return from interrupt. META DEFINITIONS : FORTH-83 ( --- ) CR ." Forth-83 Standard System" CR ." 1988 L.C. Benschop" CR ." Thanks to Coos Haak" CR LO @ HERE - 80 - . \ Compute number of free bytes. ." Bytes free, " #SCR . ." Screens " ; : VOCABULARY CREATE \ Create mew word. HERE 6 + , \ cell 1, contains latest def in this vocabulary, \ initialized to second dummy name field. A081 , \ cell 2, first dummy name field, forms dummy \ header with cell 1 as link field, will be \ silently traversed by FIND. CURRENT @ 2+ , \ cell 3 contains pointer to cell 2 in \ old CURRENT vocabulary, A081 , \ cell 4 second dummy name field, forms dummy \ header with cell 3 as link field, will be \ silently traversed by FIND. HERE VOC-LINK @ , VOC-LINK ! \ Link the new vocabulary in VOC-LINK list. \ cell 5 is link to previous vocabulary/ [ FORTH HERE-T VL ! META } \ Mark target address of DOES> part in VL. DOES> CONTEXT ! \ Set context VOCABULARY ; \ The two dummy headers (link field + name field) will cause FIND \ to continue searching from one vocabulary into the next. \ \ The name field in a dummy header is bytes 81h 0A0h, name of length 1 \ containing a single space. This will never be matched by the compiler \ but FIND will move on to the next header in the chain. \ \ When FIND traverses a new vocabulary, it will start at the pointer in \ cell 1 (CONTEXT @ @). All words will be traversed of this vocabulary, \ ending in the second dummy header. The link field of the second \ dummy header points to the first dummy header in the old CURRENT \ vocabulary, so the old current vocabulary will now be searched in its \ entirety. : DEFINITIONS ( --- ) CONTEXT @ CURRENT ! ; \ Scr#6 \ META FORTH,FORGET,WARM FORTH \ We cannot use our freshly made defining word VOCABULARY in the meta compiler \ to create the FORTH vocabulary. We have to build it by hand instead. CREATE-T FORTH \ Create header of FORTH vocabulary. ORIGIN 9 + UPTR !-T \ Initialize the User Pointer. Ugly! Why here? HERE-T , \ Store TARGET compilation address in HOST definition. \ The host word has no DOES> part, \ but [COMPILE] FORTH will work just fine. CD C,-T VL @ 2+ ,-T \ Create code field, CALL to DOES> part of VOCABULARY. HERE-T VL ! \ Mark address to patch with latest definition. 0 ,-T \ cell 1 latest def in this vocabulary, will be \ patched at end of meta compilation. A081 ,-T \ cell 2 First dummy name field 0 ,-T \ cell 3 link to old CURRENT, null for FORTH. A081 ,-T \ cell 4 Second dummy name field. HERE-T UPTR @-T 12 + !-T 0 ,-T \ Set VOC-LINK to HERE-T, store \ null pointer in cell 5. META DEF IMMEDIATE : (FORGET) ( addr --- ) DUP FENCE @ U< ABORT" Protected dictionary" \ Check that we don't forget below FENCE STOPOFF \ Disable BREAK key while operation in progress. VOC-LINK @ \ Traverse all vocabularies. BEGIN ?DUP \ While more vocabularies in list. WHILE 2DUP U< IF @ DUP VOC-LINK ! \ If vocabulary above forget address, unlink it \ from VOC-LINK list, discard vocabulary completely. ELSE DUP 8 - BEGIN @ 2- DUP 3 PICK U< \ Traverse vocabulary until below forget point UNTIL 2+ OVER 8 - ! \ Update link pointer in vocabulary. @ \ Go to next vocabulary in VOC-LINK list. THEN REPEAT DP ! \ Update dictionary pointer. STOPON ; : FORGET ( --- ) ' \ Find address of word to forget. CONTEXT @ OVER U< IF [COMPILE] FORTH \ Select FORTH vocabulary if CONTEXT is below forget \ address, so it will be removed completely. THEN CURRENT @ OVER U< IF DEFINITIONS \ Make sure CURRENT is not removed completely. THEN >NAME 2- (FORGET) ; : WARM STOPOFF RP! SP! DECIMAL LIT NOOP (WAIT) ! [COMPILE] FORTH DEFINITIONS BEGIN INKEY 0= UNTIL \ Wait until no key pressed. FF 5C3A C! \ Set ERR_NR to OK, clear error number. STOPON 0 BANK BLK @ ?DUP \ If we were loading from a screen, push BLK and >IN \ to stack, so WHERE can return to editor. IF >IN @ THEN 1F WIDTH ! \ Set WIDTH to 31, store up to 31 characters for each name. QUIT ; : DEPTH ( --- u ) S0 @ SP@ - 2/ 1- ; \ Scr#7 \ META COLD,.S,VLIST,DUMP : COLD STOPOFF LIMIT 0C + LIMIT 1+ ! \ Initialize User Area pointer. TERMINAL DECIMAL CLS ED 5C3B ! \ Clear bit 4 of FLAGS, Causes 128k Spectrum ROM to \ behave like 48k BASIC. \ ! instead of C! so it clears TV-FLAGS too, unintentional 0 BANK -1 C@ \ Get old byte at address -1 in bank 0. 0 -1 C! \ Store 0 at address -1. 1 BANK -1 C@ \ Get old byte at address -1 in bank 1. 1 -1 C! \ Store 1 at address -1. 0 BANK -1 C@ \ Read byte at address -1 in bank 0. IF \ If it was unequal to 0, bank switching did not work \ Assume we are Spectrum 48. ." 48" #B B/BUF * NEGATE LO ! \ Set LO variable to start of RAM disk. ELSE ." 128" 0 LO ! \ Set LO to 0, RAM disk will be in different banks on 128. THEN 1 BANK -1 C! 0 BANK -1 C! \ Restore the bytes at -1 in banks 1 and 0. ." K Spectrum" LIT (ERRNUM) 'ERRNUM ! RP! FENCE @ (FORGET) FORTH-83 EMPTY-BUFFERS 8 5C6A C! \ Set bit 3 in FLAGS2, set CAPS-LOCK. WARM ; : .S ( --- ) DEPTH IF DEPTH 0 DO DEPTH I - 1- PICK . LOOP ELSE ." Empty " THEN ; : STYPE ( addr u ---) \ Like TYPE, but mask off bit 7 and print control chars as . 0 ?DO DUP C@ \ Read byte 7F AND \ Mask off bit 7. DUP BL < IF DROP 2E THEN \ Control chars replaced by . EMIT 1+ \ increment address. LOOP DROP ; : ID. ( addr --- ) \ Print word name from header, addr is name field address. DUP NAME> OVER - 1- \ Compute name length. SWAP 1+ SWAP \ Increment start address, do not type length byte. STYPE ; : VLIST CONTEXT @ @ BEGIN DUP \ As long as address is not zero. ?TERMINAL 0= AND \ And EDIT key is not pressed. WHILE 6 EMIT \ Go to next TAB position on screen. DUP H. SPACE \ Print name field in hex. DUP ID. SPACE \ Print word's name. 2- @ \ Follow link to previous word in list. REPEAT DROP ; CODE >< ( 16b1 --- 16b2 ) H POP H A LD L H LD A L LD \ Swap H and L registers. H PUSH JPIX ;C : DUMP ( addr u --- ( 7 + -8 AND \ Round size up to next multiple of 8 bytes. 8 / 0 ?DO \ Print rows of 8 bytes. CR DUP H. \ Print current address. 8 0 DO I OVER + @ >< H. 2 +LOOP \ Print 4 byteswapped words in hex. DUP BS 8 STYPE \ Type as 8-byte ASCII ?TERMINAL IF LEAVE THEN \ Check for EDIT key to stop. 8 + \ Add 8 to address, next 8 bytes. LOOP DROP ; \ Scr#8 \ META FINAL STARTUP \ Define IMMEDIATE last. It will hide the META word IMMEDIATE. : IMMEDIATE ( --- ) LATEST 40 TOGGLE \ Set bit 6 in name length byte. ; ASSEMBLER \ COLD startup code. HERE-T ORIGIN 1+ !-T \ Patch jump address at cold entry point. 11 C,-T META COLD ASSEMBLER \ LD DE,#'COLD Set entry pointer to COLD HERE-T 5 + JR \ Jump past next LD DE,#xxx instruction. \ WARM startup code. HERE-T ORIGIN 4 + !-T \ Patch jump address at warm entry point. 11 C,-T META WARM ASSEMBLER \ LD DE.#'WARM Set entry pointer to WARM \ Common assembly code for COLD and WARM. NEXT XH LDP# \ Set IX register to NEXT address. D PUSH \ Save entry pointer. IM1 \ Select Interrupt mode 1. 2 A LD# 1601 CALL \ Select channel 2, screen output. D POP \ Restore entry pointer. %Y 0 31 )LD# \ Set DF_SZ to 0, so we can use all 24 screen lines. 5C3D SP LDP \ Set SP to ERR_SP. B POP \ Remove old address on stack. ORIGIN 3 + B LDP# B PUSH \ Push WARM entry point address on stack, so \ errors in ROM routines will now jump to WARM. \ instead of the BASIC command line. 0A B LD# BEGIN AF PUSH DSZ \ Push 10 dummy words in the stack to \ protect against stack underflow. D PUSH \ Save entry pointer. 5C3A LDA \ Load ERR_NR variable A INR NZ IF \ If error is not "OK" 1391 D LDP# 0C0A CALL \ Call PO_MSG in ROM to print error message. THEN D POP \ Restore entry pointer. INTREG C@-T 1- A LD# \ This is ugly! We read a byte from the interrupt vector table and use one less. \ What should have been here: \ INTREG 0 100 UM/MOD SWAP DROP A LD# \ We cannot use signed division here, hence the complex expression. LDIA \ Set I register to Interrupt vector table \ when IM2 is activated later, custom interrupt \ handler is used. EXDE JPHL \ Jump to FORTH entry pointer, executing \ either WARM or COLD, never return from there. FORTH \ Fix up a few variables in target system. HERE-T UPTR @-T 0C + !-T \ Set FENCE in target system. DECIMAL 26000 RPTR !-T \ Iniitialize return stack pointer. LINK-T @ VL @ !-T \ Store ponter to latest definition in \ FORTH vocabulary. 26000 'R0 !-T \ Initialize Return stack bottom. 25580 'S0 !-T \ Initialize stack bottom. EXIT \ Exit Meta compile loop. DECIMAL CR \ Save the target image staring at VIRTSTART-2 up to HERE-T \ to the file FORT83.BIN VIRTSTART 2- ( START) HERE-T ORIGIN 2- - ( LENGTH) GETFN FORT83.BIN 50 BCAL EXIT \ End of meta source.