\ This is the file kernel.4, included by the cross compiler. \ created 1994 by L.C. Benschop. \ copyleft (c) 1994-2014 by the sbc09 team, see AUTHORS for more details. \ license: GNU General Public License version 2, see LICENSE for more details. \ It is excessively commented as it must serve as an introduction to the \ construction of Forth compilers. \ Lines starting with \G are comments that are included in the glossary. ALSO TRANSIENT DEFINITIONS FORWARD THROW FORWARD COLD FORWARD WARM PREVIOUS DEFINITIONS ALSO ASSEMBLER DEFINITIONS : NEXT \ JMP $300 \ For tracing/debugging. PULU PC \ For normal use. ; PREVIOUS DEFINITIONS ASSEMBLE HEX ORIGIN ORG 7E C, TRANSIENT COLD ASSEMBLER 7E C, TRANSIENT WARM ASSEMBLER \ Jumps to cold and warm entry points. ENDASM DECIMAL CROSS-COMPILE LABEL DOCON LDD 0 ,S [] \ Get constant. STD 0 ,S \ Store it on stack. LABEL DOVAR NEXT LABEL DOCOL STU ,--Y \ Save IP on return stack. PULS U \ Pop IP from stack where it is left by JSR DOCOL. NEXT LABEL DODEFER LDX ,S++ [] \ Get jump address. JMP 0 ,X ENDASM CODE LIT ( --- n) PULU D \ Get literal from instruction stream. PSHS D NEXT END-CODE CODE BRANCH LABEL BR LDU 0 ,U NEXT END-CODE CODE ?BRANCH ( f ---) LDD ,S++ BEQ BR \ Bracnh if TOS is zero. LEAU 2 ,U \ Skip branch address. NEXT END-CODE CODE EXECUTE ( a ---) RTS END-CODE CODE EXIT LDU ,Y++ NEXT END-CODE CODE UNNEST LDU ,Y++ NEXT END-CODE CODE (DO) ( l s ---) PULS D LABEL DO1 SUBD 0 ,S EORA # $80 \ Now START-LIMIT-$8000 Initial value for counter. PULS X STX ,--Y \ Push limit value. STD ,--Y NEXT END-CODE CODE (?DO) ( l s ---) PULS D CMPD 0 ,S 0<> IF LEAU 2 ,U \ Skip branch address. BRA DO1 THEN LEAS 2 ,S BRA BR END-CODE CODE (LOOP) LDD 0 ,Y ADDD # 1 LABEL LOOP1 VC IF STD 0 ,Y LDU 0 ,U NEXT THEN LEAY 4 ,Y \ Discard parameters from return stack. LEAU 2 ,U \ Skip branch address. NEXT END-CODE CODE (+LOOP) ( n ---) LDD 0 ,Y ADDD ,S++ BRA LOOP1 END-CODE CODE (LEAVE) LABEL LEAV1 LDU 0 ,U LEAY 4 ,Y NEXT END-CODE CODE (?LEAVE) ( f ---) LDD ,S++ BEQ LEAV1 LEAU 2 ,U NEXT END-CODE CODE I ( --- n) LDD 0 ,Y EORA # $80 ADDD 2 ,Y PSHS D NEXT END-CODE CODE I' ( ---n) LDD 2 ,Y PSHS D NEXT END-CODE CODE J ( ---n) LDD 4 ,Y EORA # $80 ADDD 6 ,Y PSHS D NEXT END-CODE CODE UNLOOP LEAY 4 ,Y NEXT END-CODE CODE R@ ( --- n) LDD 0 ,Y PSHS D NEXT END-CODE CODE >R ( n ---) PULS D STD ,--Y NEXT END-CODE CODE R> ( --- n) LDD ,Y++ PSHS D NEXT END-CODE CODE RP@ ( --- addr) PSHS Y NEXT END-CODE CODE RP! ( addr --- ) PULS Y NEXT END-CODE CODE SP@ ( --- addr) TFR S, D PSHS D NEXT END-CODE CODE SP! ( addr ---) PULS D TFR D, S NEXT END-CODE CODE UM* ( u1 u2 --- ud) LEAS -4 ,S \ Create room for result. LDA 7 ,S LDB 5 ,S MUL \ Multiply least significant bytes. STD 2 ,S LDA 7 ,S LDB 4 ,S MUL \ Multiply LSB of n1 and MSB of n2. ADDB 2 ,S ADCA # 0 STD 1 ,S LDA 6 ,S LDB 5 ,S MUL \ Multiply LSB of n2 and MSB of n1. ADDD 1 ,S STD 1 ,S LDA # 0 ADCA # 0 STA 0 ,S LDA 6 ,S LDB 4 ,S MUL \ Multiply most significant bytes. ADDD 0 ,S STD 4 ,S LDD 2 ,S STD 6 ,S \ Move result to position of numbers. LEAS 4 ,S \ Reclaim extra space for result. NEXT END-CODE CODE UM/MOD ( ud u --- rem quot) LDX # 16 \ iteration counter. LDD 2 ,S BEGIN ASL 5 ,S ROL 4 ,S ROLB ROLA U< IF \ Account for extra bit shifted out, perform subtraction anyway. SUBD 0 ,S INC 5 ,S ELSE CMPD 0 ,S \ Perform trial subtraction. U>= IF SUBD 0 ,S INC 5 ,S \ Add 1-bit to quotient. THEN THEN LEAX -1 ,X 0= UNTIL LEAS 2 ,S LDX 2 ,S \ rem and quot on proper positions STX 0 ,S STD 2 ,S \ D contains rem NEXT END-CODE CODE + ( n1 n2 ---n3) PULS D ADDD 0 ,S STD 0 ,S NEXT END-CODE CODE - ( n1 n2 ---n3) LDD 2 ,S SUBD ,S++ STD 0 ,S NEXT END-CODE CODE NEGATE ( n1 --- n2) CLRA CLRB SUBD 0 ,S STD 0 ,S NEXT END-CODE CODE AND ( n1 n2 ---n3) PULS D ANDA ,S ANDB 1 ,S STD 0 ,S NEXT END-CODE CODE OR ( n1 n2 ---n3) PULS D ORA ,S ORB 1 ,S STD 0 ,S NEXT END-CODE CODE XOR ( n1 n2 ---n3) PULS D EORA ,S EORB 1 ,S STD 0 ,S NEXT END-CODE CODE 1+ ( n1 --- n2) INC 1 ,S 0= IF INC 0 ,S THEN NEXT END-CODE CODE 1- ( n1 --- n2) LDD 0 ,S SUBD # 1 STD 0 ,S NEXT END-CODE CODE 2+ ( n1 --- n2) LDD 0 ,S ADDD # 2 STD 0 ,S NEXT END-CODE CODE 2- ( n1 --- n2) LDD 0 ,S SUBD # 2 STD 0 ,S NEXT END-CODE CODE 2* ( n1 --- n2) LDD 0 ,S ASLB ROLA STD 0 ,S NEXT END-CODE CODE 2/ ( n1 --- n2) LDD 0 ,S ASRA RORB STD 0 ,S NEXT END-CODE CODE D+ ( d1 d2 --- d3) LDD 6 ,S ADDD 2 ,S STD 6 ,S LDD 4 ,S ADCB 1 ,S ADCA 0 ,S STD 4 ,S LEAS 4 ,S NEXT END-CODE CODE DNEGATE ( d1 --- d2) CLRA CLRB SUBD 2 ,S STD 2 ,S LDD # 0 SBCB 1 ,S SBCA 0 ,S STD 0 ,S NEXT END-CODE CODE LSHIFT ( u1 n1 --- u2) PULS D TSTB 0<> IF BEGIN ASL 1 ,S ROL 0 ,S DECB 0= UNTIL THEN NEXT END-CODE CODE RSHIFT ( u1 n1 --- u2) PULS D TSTB 0<> IF BEGIN LSR 0 ,S ROR 1 ,S DECB 0= UNTIL THEN NEXT END-CODE CODE DROP ( n --- ) LEAS 2 ,S NEXT END-CODE CODE DUP ( n --- n n ) LDD 0 ,S PSHS D NEXT END-CODE CODE SWAP ( n1 n2 --- n2 n1) LDD 0 ,S LDX 2 ,S STX 0 ,S STD 2 ,S NEXT END-CODE CODE OVER ( n1 n2 --- n1 n2 n1) LDD 2 ,S PSHS D NEXT END-CODE CODE ROT ( n1 n2 n3 --- n2 n3 n1) LDD 4 ,S LDX 0 ,S STD 0 ,S LDD 2 ,S STX 2 ,S STD 4 ,S NEXT END-CODE CODE -ROT ( n1 n2 n3 --- n3 n1 n2) LDD 4 ,S LDX 2 ,S STD 2 ,S LDD 0 ,S STX 0 ,S STD 4 ,S NEXT END-CODE CODE 2DROP ( d ---) LEAS 4 ,S NEXT END-CODE CODE 2DUP ( d --- d d ) LDX 2 ,S LDD 0 ,S PSHS X, D NEXT END-CODE CODE 2SWAP ( d1 d2 --- d2 d1) LDD 6 ,S LDX 2 ,S STD 2 ,S STX 6 ,S LDD 4 ,S LDX 0 ,S STD 0 ,S STX 4 ,S NEXT END-CODE CODE 2OVER ( d1 d2 --- d1 d2 d1) LDX 6 ,S LDD 4 ,S PSHS X, D NEXT END-CODE CODE PICK ( n1 --- n2) LDD 0 ,S ADDD # 1 \ Correct index ASLB \ Cell* (assert: cellL=2!) ROLA LDX D,S \ Pick value STX 0 ,S \ Replace top NEXT END-CODE CODE ROLL ( n1 ---) LDD 0 ,S LEAS -2 ,S \ Make room to store counter. ADDD # 1 STD 0 ,S \ Store 1 plus the counter. ADDD 2 ,S \ Double counter. ADDD # 3 LEAX D,S \ Point past last elemtn to roll on stack. LEAX 2 ,X LDD D,S STD 2 ,S \ Store element picked. INC 0 ,S BEGIN BEGIN LDD -4 ,X STD ,--X DEC 1 ,S 0= UNTIL DEC 0 ,S 0= UNTIL LEAS 4 ,S NEXT END-CODE CODE C@ ( addr --- c) LDB 0 ,S [] CLRA STD 0 ,S NEXT END-CODE CODE @ ( addr --- n) LDD 0 ,S [] STD 0 ,S NEXT END-CODE CODE C! ( c addr ---) LDB 3 ,S STB 0 ,S [] LEAS 4 ,S NEXT END-CODE CODE ! ( n addr ---) LDD 2 ,S STD 0 ,S [] LEAS 4 ,S NEXT END-CODE CODE +! ( n addr ---) PULS X PULS D ADDD 0 ,X STD 0 ,X NEXT END-CODE CODE 2@ ( addr --- d) LDX 0 ,S LDD 0 ,X LDX 2 ,X STX 0 ,S PSHS D NEXT END-CODE CODE 2! ( d addr ---) LDX 0 ,S LDD 2 ,S STD 0 ,X LDD 4 ,S STD 2 ,X LEAS 6 ,S NEXT END-CODE LABEL YES \ Store a true flag on stack. LEAX -1 ,X STX 0 ,S NEXT ENDASM CODE 0= ( n --- f) LDX # 0 LDD 0 ,S BEQ YES STX 0 ,S NEXT END-CODE CODE 0< ( n --- f) LDX # 0 LDD 0 ,S BMI YES STX 0 ,S NEXT END-CODE CODE < ( n1 n2 --- f) LDX # 0 LDD 2 ,S SUBD ,S++ BLT YES STX 0 ,S NEXT END-CODE CODE U< ( n1 n2 --- f) LDX # 0 LDD 2 ,S SUBD ,S++ BLO YES STX 0 ,S NEXT END-CODE CODE CMOVE ( addr1 addr2 n ---) LDX 4 ,S STY 4 ,S LDY 2 ,S LDD 0 ,S 0<> IF INC 0 ,S BEGIN BEGIN LDA ,X+ STA ,Y+ DECB 0= UNTIL DEC 0 ,S 0= UNTIL THEN LDY 4 ,S LEAS 6 ,S NEXT END-CODE CODE CMOVE> ( addr1 addr2 n ---) LDX 4 ,S STY 4 ,S LDY 2 ,S LDD 0 ,S LEAX D,X LEAY D,Y LDD 0 ,S 0<> IF INC 0 ,S BEGIN BEGIN LDA ,-X STA ,-Y DECB 0= UNTIL DEC 0 ,S 0= UNTIL THEN LDY 4 ,S LEAS 6 ,S NEXT END-CODE CODE FILL ( addr n c ---) LDX 4 ,S LDD 2 ,S 0<> IF INC 2 ,S LDA 1 ,S BEGIN BEGIN STA ,X+ DECB 0= UNTIL DEC 2 ,S 0= UNTIL THEN LEAS 6 ,S NEXT END-CODE CODE (FIND) ( word firstnfa --- cfa/word f ) LDX 0 ,S 0<> IF STU 0 ,S LDU 2 ,S STY 2 ,S PSHS U BEGIN TFR X, Y LDA ,X+ ANDA # $1F CMPA ,U+ \ Compare count bytes. 0= IF \ Do count bytes match? BEGIN DECA LDB ,X+ CMPB ,U+ 0<> UNTIL \ Compare strings until difference encountered. INCA 0= IF LEAS 2 ,S \ Yes, then word is found. TFR Y, X LDY 2 ,S LDU 0 ,S LDA 0 ,X ANDA # $40 0= IF LDD # -1 ELSE LDD # 1 \ Make flag that indicates immediate bit. THEN STD 0 ,S LDB ,X+ ANDB # $1F ABX \ Compute CFA STX 2 ,S NEXT THEN THEN LDU 0 ,S LDX -2 ,Y \ Point to next word in linked list. 0= UNTIL LEAS 2 ,S LDY 2 ,S STU 2 ,S LDU 0 ,S STX 0 ,S THEN NEXT END-CODE CODE SKIP ( addr1 len1 c --- addr2 len2 ) STU ,--Y PULS D PULS X PULS U LEAX 0 ,X 0<> IF BEGIN CMPB ,U+ 0<> IF LEAU -1 ,U PSHS U PSHS X LDU ,Y++ NEXT THEN LEAX -1 ,X 0= UNTIL THEN PSHS U PSHS X LDU ,Y++ NEXT END-CODE CODE SCAN ( addr1 len1 c --- addr2 len2 ) STU ,--Y PULS D PULS X PULS U LEAX 0 ,X 0<> IF BEGIN CMPB ,U+ 0= IF LEAU -1 ,U PSHS U PSHS X LDU ,Y++ NEXT THEN LEAX -1 ,X 0= UNTIL THEN PSHS U PSHS X LDU ,Y++ NEXT END-CODE CODE KEY ( --- c) JSR 0 CLRA PSHS D NEXT END-CODE CODE EMIT ( c ---) PULS D JSR 3 NEXT END-CODE CODE KEY? ( --- f) JSR 15 SEX PSHS D NEXT END-CODE CODE BYE JMP $E400 NEXT END-CODE CODE CR JSR 12 NEXT END-CODE CODE XOPENIN JSR 18 NEXT END-CODE CODE XABORTIN PSHS Y, U JSR 24 PULS Y, U NEXT END-CODE : NOOP ; 00 CONSTANT 0 01 CONSTANT 1 02 CONSTANT 2 -1 CONSTANT -1 \ PART 3: SIMPLE DEFINITIONS \ This is a large class of words, which would be written in machine code \ on most non-native code systems. Many contain just a few words, so they \ are implemented as macros. \ This category contains simple arithmetic and compare words, the runtime \ parts of DO LOOP and string related words etc, many on which are \ dependent on each other, so they are in a less than logical order to \ avoid large numbers of forward references. : = ( x1 x2 --- f) \G f is true if and only if x1 is equal to x2. - 0= ; : <> ( x1 x2 --- f) \G f is true if and only if x1 is not equal to x2. = 0= ; : > ( n1 n2 --- f) \G f is true if and only if the signed number n1 is less than n2. SWAP < ; : 0> ( n --- f) \G f is true if and only if n is greater than 0. 0 > ; : U> ( u1 u2 --- f) \G f is true if and only if the unsigned number u1 is greater than u2. SWAP U< ; VARIABLE S0 ( --- a-addr) \G Variable that holds the bottom address of the stack. -2 ALLOT-T LABEL S0ADDR ENDASM 02 ALLOT-T VARIABLE R0 ( --- a-addr) \G Variable that holds the bottom address of the return stack. -2 ALLOT-T LABEL R0ADDR ENDASM 02 ALLOT-T : DEPTH ( --- n ) \G n is the number of cells on the stack (before DEPTH was executed). SP@ S0 @ SWAP - 2/ ; : COUNT ( c-addr1 --- c-addr2 c) \G c-addr2 is the next address after c-addr1 and c is the character \G stored at c-addr1. \G This word is intended to be used with 'counted strings' where the \G first character indicates the length of the string. DUP 1 + SWAP C@ ; : TYPE ( c-addr1 u --- ) \G Output the string starting at c-addr and length u to the terminal. DUP IF 0 DO DUP I + C@ EMIT LOOP DROP ELSE DROP DROP THEN ; : ALIGNED ( c-addr --- a-addr ) \G a-addr is the first aligned address after c-addr. ; : (.") ( --- ) \G Runtime part of ." \ This expects an in-line counted string. R> COUNT OVER OVER TYPE + ALIGNED >R ; : (S") ( --- c-addr u ) \G Runtime part of S" \ It returns address and length of an in-line counted string. R> COUNT OVER OVER + ALIGNED >R ; 00 CONSTANT FALSE ( --- 0) \G Constant 0, indicates FALSE -01 CONSTANT TRUE ( --- -1) \G Constant -1, indicates TRUE 32 CONSTANT BL ( --- 32 ) \G Constant 32, the blank character : OFF ( a-addr ---) \G Store FALSE at a-addr. 0 SWAP ! ; : ON ( a-addr ---) \G Store TRUE at a-addr. -1 SWAP ! ; : INVERT ( x1 --- x2) \G Invert all the bits of x1 (one's complement) -1 XOR ; \ The next few words manipulate addresses in a system-independent way. \ Use CHAR+ instead of 1+ and it will be portable to systems where you \ have to add something different from 1. : CHAR+ ( c-addr1 --- c-addr2) \G c-addr2 is the next character address after c-addr1. 1+ ; : CHARS ( n1 --- n2) \G n2 is the number of address units occupied by n1 characters. ; \ A no-op. : CHAR- ( c-addr1 --- c-addr2) \G c-addr2 is the previous character address before c-addr1. 1- ; : CELL+ ( a-addr1 --- a-addr2) \G a-addr2 is the address of the next cell after a-addr2. 2+ ; : CELLS ( n2 --- n1) \G n2 is the number of address units occupied by n1 cells. 1 LSHIFT ; : CELL- ( a-addr1 --- a-addr2) \G a-addr2 is the address of the previous cell before a-addr1. 2- ; : ?DUP ( n --- 0 | n n) \G Duplicate the top cell on the stack, but only if it is nonzero. DUP IF DUP THEN ; : MIN ( n1 n2 --- n3) \G n3 is the minimum of n1 and n2. OVER OVER > IF SWAP THEN DROP ; : MAX ( n1 n2 --- n3) \G n3 is the maximum of n1 and n2. OVER OVER < IF SWAP THEN DROP ; : ABS ( n --- u) \G u is the absolute value of n. DUP 0< IF NEGATE THEN ; : DABS ( d --- ud) \G ud is the absolute value of d. DUP 0< IF DNEGATE THEN ; : SM/REM ( d n1 --- nrem nquot ) \G Divide signed double number d by single number n1, giving quotient and \G remainder. Round towards zero, remainder has same sign as dividend. 2DUP XOR >R OVER >R \ Push signs of quot and rem. ABS >R DABS R> UM/MOD SWAP R> 0< IF NEGATE THEN SWAP R> 0< IF NEGATE THEN ; : FM/MOD ( d n1 --- nrem nquot ) \G Divide signed double number d by single number n1, giving quotient and \G remainder. Round always down (floored division), \G remainder has same sign as divisor. DUP >R OVER OVER XOR >R SM/REM OVER R> 0< AND IF SWAP R@ + SWAP 1 - THEN R> DROP ; : M* ( n1 n2 --- d ) \G Multiply the signed numbers n1 and n2, giving the signed double number d. 2DUP XOR >R ABS SWAP ABS UM* R> 0< IF DNEGATE THEN ; : * ( w1 w2 --- w3) \G Multiply single numbers, signed or unsigned give the same result. UM* DROP ; : */MOD ( n1 n2 n3 --- nrem nquot) \G Multiply signed numbers n1 by n2 and divide by n3, giving quotient and \G remainder. Intermediate result is double. >R M* R> FM/MOD ; : */ ( n1 n2 n3 --- n4 ) \G Multiply signed numbers n1 by n2 and divide by n3, giving quotient n4. \G Intermediate result is double. */MOD SWAP DROP ; : S>D ( n --- d) \G Convert single number to double number. DUP 0< ; : /MOD ( n1 n2 --- nrem nquot) \G Divide signed number n1 by n2, giving quotient and remainder. SWAP S>D ROT FM/MOD ; : / ( n1 n2 --- n3) \G n3 is n1 divided by n2. /MOD SWAP DROP ; : MOD ( n1 n2 --- n3) \G n3 is the remainder of n1 and n2. /MOD DROP ; : ?THROW ( f n --- ) \G Perform n THROW if f is nonzero. SWAP IF THROW ELSE DROP THEN ; \ PART 4: NUMERIC OUTPUT WORDS. VARIABLE BASE ( --- a-addr) \G Variable that contains the numerical conversion base. VARIABLE DP ( --- a-addr) \G Variable that contains the dictionary pointer. New space is allocated \G from the address in DP VARIABLE HLD ( --- a-addr) \G Variable that holds the address of the numerical output conversion \G character. VARIABLE DPL ( --- a-addr) \G Variable that holds the decimal point location for numerical conversion. : DECIMAL ( --- ) \G Set numerical conversion to decimal. 10 BASE ! ; : HEX ( --- ) \G Set numerical conversion to hexadecimal. 16 BASE ! ; : SPACE ( ---) \G Output a space to the terminal. 32 EMIT ; : SPACES ( u --- ) \G Output u spaces to the terminal. ?DUP IF 0 DO SPACE LOOP THEN ; : HERE ( --- c-addr ) \G The address of the dictionary pointer. New space is allocated here. DP @ ; : PAD ( --- c-addr ) \G The address of a scratch pad area. Right below this address there is \G the numerical conversion buffer. DP @ 84 + ; : MU/MOD ( ud u --- urem udquot ) \G Divide unsigned double number ud by u and return a double quotient and \G a single remainder. >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ The numerical conversion buffer starts right below PAD and grows down. \ Characters are added to it from right to left, as as the div/mod algorithm \ to convert numbers to an arbitrary base produces the digits from right to \ left. : HOLD ( c ---) \G Insert character c into the numerical conversion buffer. 1 NEGATE HLD +! HLD @ C! ; : # ( ud1 --- ud2) \G Extract the rightmost digit of ud1 and put it into the numerical \G conversion buffer. BASE @ MU/MOD ROT DUP 9 > IF 7 + THEN 48 + HOLD ; : #S ( ud --- 0 0 ) \G Convert ud by repeated use of # until ud is zero. BEGIN # OVER OVER OR 0= UNTIL ; : SIGN ( n ---) \G Insert a - sign in the numerical conversion buffer if n is negative. 0< IF 45 HOLD THEN ; : <# ( --- ) \G Reset the numerical conversion buffer. PAD HLD ! ; : #> ( ud --- addr u ) \G Discard ud and give the address and length of the numerical conversion \G buffer. DROP DROP HLD @ PAD OVER - ; : D. ( d --- ) \G Type the double number d to the terminal. SWAP OVER DABS <# #S ROT SIGN #> TYPE SPACE ; : U. ( u ---) \G Type the unsigned number u to the terminal. 0 D. ; : . ( n ---) \G Type the signed number n to the terminal. S>D D. ; : MOVE ( c-addr1 c-addr2 u --- ) \G Copy a block of u bytes starting at c-addr1 to c-addr2. Order is such \G that partially overlapping blocks are copied intact. >R OVER OVER U< IF R> CMOVE> ELSE R> CMOVE THEN ; CODE ACCEPT ( c-addr n1 --- n2 ) \G Read a line from the terminal to a buffer starting at c-addr with \G length n1. n2 is the number of characters read, PULS X, D JSR 6 CLRA PSHS D NEXT END-CODE $200 CONSTANT TIB ( --- addr) \G is the standard terminal input buffer. VARIABLE SPAN ( --- addr) \G This variable holds the number of characters read by EXPECT. VARIABLE #TIB ( --- addr) \G This variable holds the number of characters in the terminal input buffer. VARIABLE >IN ( --- addr) \G This variable holds an index in the current input source where the next word \G will be parsed. VARIABLE SID ( --- addr) \G This variable holds the source i.d. returned by SOURCE-ID. VARIABLE SRC ( --- addr) \G This variable holds the address of the current input source. VARIABLE #SRC ( --- addr) \G This variable holds the length of the current input source. VARIABLE LOADLINE ( --- addr) \G This variable holds the line number in the file being included. : EXPECT ( c-addr u --- ) \G Read a line from the terminal to a buffer at c-addr with length u. \G Store the length of the line in SPAN. ACCEPT SPAN ! ; : QUERY ( --- ) \G Read a line from the terminal into the terminal input buffer. TIB 128 ACCEPT #TIB ! ; : SOURCE ( --- addr len) \G Return the address and length of the current input source. SRC @ #SRC @ ; : SOURCE-ID ( --- sid) \G Return the i.d. of the current source i.d., 0 for terminal, -1 \G for EVALUATE and positive number for INCLUDE file. SID @ ; : REFILL ( --- f) \G Refill the current input source when it is exhausted. f is \G true if it was successfully refilled. SOURCE-ID -1 = IF 0 \ Not refillable for EVALUATE ELSE QUERY #TIB @ #SRC ! 0 >IN ! -1 \ Always successful from terminal. 1 LOADLINE +! THEN ; : PARSE ( c --- addr len ) \G Find a character sequence in the current source that is delimited by \G character c. Adjust >IN to 1 past the end delimiter character. >R SOURCE >IN @ - SWAP >IN @ + R> OVER >R >R SWAP R@ SKIP OVER R> SWAP >R SCAN IF 1 >IN +! THEN DUP R@ - R> SWAP ROT R> - >IN +! ; : PLACE ( addr len c-addr --- ) \G Place the string starting at addr with length len at c-addr as \G a counted string. OVER OVER C! 1+ SWAP CMOVE ; : WORD ( c --- addr ) \G Parse a character sequence delimited by character c and return the \G address of a counted string that is a copy of it. The counted \G string is actually placed at HERE. The character after the counted \G string is set to a space. PARSE HERE PLACE HERE BL HERE COUNT + C! ; VARIABLE CAPS ( --- a-addr) \G This variable contains a nonzero number if input is case insensitive. : UPPERCASE? ( --- ) \G Convert the parsed word to uppercase is CAPS is true. CAPS @ HERE C@ AND IF HERE COUNT 0 DO DUP I + C@ DUP 96 > SWAP 123 < AND IF DUP I + DUP C@ 32 - SWAP C! THEN LOOP DROP THEN ; \ PART 8: INTERPRETER HELPER WORDS \ First we need FIND and related words. \ Each word list consists of a number of linked list of definitions (number \ is a power of 2). Hashing \ is used to speed up dictionary search. All names in the dictionary \ are at aligned addresses and FIND is optimized to compare one 4-byte \ cell at a time. \ Dictionary definitions are built as follows: \ \ LINK field: 1 cell, aligned, contains name field of previous word in thread. \ NAME field: counted string of at most 31 characters. \ bits 5-7 of length byte have special meaning. \ 7 is always set to mark start of name ( for >NAME) \ 6 is set if the word is immediate. \ CODE field: first aligned address after name, is execution token for word. \ here the executable code for the word starts. (is 3 bytes for \ variables etc.) \ PARAMETER field: (body) Contains the data of constants and variables etc. VARIABLE NAMEBUF ( --- a-addr) \G An aligned buffer that holds a copy of the name that is searched. 30 ALLOT-T VARIABLE FORTH-WORDLIST ( --- addr) 4 CELLS-T ALLOT-T \G This array holds pointers to the last definition of each thread in the Forth \G word list. VARIABLE LAST ( --- addr) \G This variable holds a pointer to the last definition created. VARIABLE CONTEXT 28 ALLOT-T ( --- a-addr) \G This variable holds the addresses of up to 8 word lists that are \G in the search order. VARIABLE #ORDER ( --- addr) \G This variable holds the number of word list that are in the search order. VARIABLE CURRENT ( --- addr) \G This variable holds the address of the word list to which new definitions \G are added. : HASH ( c-addr u #threads --- n) \G Compute the hash function for the name c-addr u with the indicated number \G of threads. >R OVER C@ 1 LSHIFT OVER 1 > IF ROT CHAR+ C@ 2 LSHIFT XOR ELSE ROT DROP THEN XOR R> 1- AND ; : NAME>BUF ( c-addr u ---) \G Move the name c-addr u to the aligned buffer NAMEBUF. NAMEBUF 32 0 FILL 32 MIN NAMEBUF PLACE ; : SEARCH-WORDLIST ( c-addr u wid --- 0 | xt 1 xt -1) \G Search the wordlist with address wid for the name c-addr u. \G Return 0 if not found, the execution token xt and -1 for non-immediate \G words and xt and 1 for immediate words. ROT ROT NAME>BUF NAMEBUF COUNT 2 PICK @ HASH 1+ CELLS SWAP + @ \ Get the right thread. DUP IF NAMEBUF SWAP (FIND) DUP 0= IF DROP DROP 0 THEN EXIT THEN DROP 0 \ Not found. ; : FIND ( c-addr --- c-addr 0| xt 1|xt -1 ) \G Search all word lists in the search order for the name in the \G counted string at c-addr. If not found return the name address and 0. \G If found return the execution token xt and -1 if the word is non-immediate \G and 1 if the word is immediate. #ORDER @ DUP 1 > IF CONTEXT #ORDER @ 1- CELLS + DUP @ SWAP CELL- @ = ELSE 0 THEN IF 1- THEN \ If last wordlist is double, don't search it twice. BEGIN DUP WHILE 1- >R DUP COUNT R@ CELLS CONTEXT + @ SEARCH-WORDLIST DUP IF R> DROP ROT DROP EXIT \ Exit if found. THEN DROP R> REPEAT ; \ The following words are related to numeric input. : DIGIT? ( c -- 0| c--- n -1) \G Convert character c to its digit value n and return true if c is a \G digit in the current base. Otherwise return false. 48 - DUP 0< IF DROP 0 EXIT THEN DUP 9 > OVER 17 < AND IF DROP 0 EXIT THEN DUP 9 > IF 7 - THEN DUP BASE @ < 0= IF DROP 0 EXIT THEN -1 ; : >NUMBER ( ud1 c-addr1 u1 --- ud2 c-addr2 u2 ) \G Convert the string at c-addr with length u1 to binary, multiplying ud1 \G by the number in BASE and adding the digit value to it for each digit. \G c-addr2 u2 is the remainder of the string starting at the first character \G that is no digit. BEGIN DUP WHILE 1 - >R COUNT DIGIT? 0= IF R> 1+ SWAP 1 - SWAP EXIT THEN SWAP >R >R SWAP BASE @ UM* ROT BASE @ * 0 SWAP D+ \ Multiply ud by base. R> 0 D+ \ Add new digit. R> R> REPEAT ; : CONVERT ( ud1 c-addr1 --- ud2 c-addr2) \G Convert the string starting at c-addr1 + 1 to binary. c-addr2 is the \G address of the first non-digit. Digits are added into ud1 as in >NUMBER 1 - -1 >NUMBER DROP ; : NUMBER? ( c-addr ---- d f) \G Convert the counted string at c-addr to a double binary number. \G f is true if and only if the conversion was successful. DPL contains \G -1 if there was no point in the number, else the position of the point \G from the right. Special prefixes: # means decimal, $ means hex. -1 DPL ! BASE @ >R COUNT OVER C@ 45 = DUP >R IF 1 - SWAP 1 + SWAP THEN \ Get any - sign OVER C@ 36 = IF 16 BASE ! 1 - SWAP 1 + SWAP THEN \ $ sign for hex. OVER C@ 35 = IF 10 BASE ! 1 - SWAP 1 + SWAP THEN \ # sign for decimal DUP 0 > 0= IF R> DROP R> BASE ! 0 EXIT THEN \ Length 0 or less? >R >R 0 0 R> R> BEGIN >NUMBER DUP IF OVER C@ 46 = IF 1 - DUP DPL ! SWAP 1 + SWAP ELSE \ handle point. R> DROP R> BASE ! 0 EXIT THEN \ Error if anything but point THEN DUP 0= UNTIL DROP DROP R> IF DNEGATE THEN R> BASE ! -1 ; \ PART 9: THE COMPILER VARIABLE ERROR$ ( --- a-addr ) \G Variable containing string address of ABORT" message. VARIABLE HANDLER ( --- a-addr ) \G Variable containing return stack address where THROW should return. : (ABORT") ( f -- - ) \G Runtime part of ABORT" IF R> ERROR$ ! -2 THROW ELSE R> COUNT + ALIGNED >R THEN ; : THROW ( n --- ) \G If n is nonzero, cause the corresponding CATCH to return with n. DUP IF HANDLER @ IF HANDLER @ RP! RP@ 4 + @ HANDLER ! \ point to previous exception frame. R> \ get old stack pointer. SWAP >R SP! DROP R> \ save throw code temp. on ret. stack set old sp. R> DROP \ remove address of handler. \ return stack points to return address of CATCH. ELSE WARM \ Warm start if no exception frame on stack. THEN ELSE DROP \ continue if zero. THEN ; : CATCH ( xt --- n ) \G Execute the word with execution token xt. If it returns normally, return \G 0. If it executes a THROW, return the throw parameter. HANDLER @ >R \ push handler on ret stack. SP@ >R \ push stack pointer on ret stack, RP@ HANDLER ! EXECUTE RP@ 4 + @ HANDLER ! \ set handler to previous exception frame. R> DROP R> DROP \ remove exception frame. 0 \ return 0 ; : ALLOT ( n --- ) \G Allot n extra bytes of memory, starting at HERE to the dictionary. DP +! ; : , ( x --- ) \G Append cell x to the dictionary at HERE. HERE ! 1 CELLS ALLOT ; : C, ( n --- ) \G Append character c to the dictionary at HERE. HERE C! 1 ALLOT ; : ALIGN ( --- ) \G Add as many bytes to the dictionary as needed to align dictionary pointer. ; : >NAME ( addr1 --- addr2 ) \G Convert execution token addr1 (address of code) to address of name. BEGIN 1- DUP C@ 128 AND UNTIL ; : NAME> ( addr1 --- addr2 ) \G Convert address of name to address of code. COUNT 31 AND + ALIGNED ; : HEADER ( --- ) \G Create a header for a new definition without a code field. ALIGN 0 , \ Create link field. HERE LAST ! \ Set LAST so definition can be linked by REVEAL 32 WORD UPPERCASE? DUP FIND IF ." Redefining: " HERE COUNT TYPE CR THEN DROP \ Give warning if existing word redefined. DUP COUNT CURRENT @ @ HASH 1+ CELLS CURRENT @ + @ HERE CELL- ! \ Set link field to point to the right thread C@ 1+ HERE C@ 128 + HERE C! ALLOT ALIGN \ Allot the name and set bit 7 in length byte. ; : JSR, $BD C, ; : REVEAL ( --- ) \G Add the last created definition to the CURRENT wordlist. LAST @ DUP COUNT 31 AND \ Get address and length of name CURRENT @ @ HASH \ compute hash code. 1+ CELLS CURRENT @ + ! ; : CREATE ( "ccc" --- ) \G Create a definition that returns its parameter field address when \G executed. Storage can be added to it with ALLOT. HEADER REVEAL JSR, LIT DOVAR , ; : VARIABLE ( "ccc" --- ) \G Create a variable where 1 cell can be stored. When executed it \G returns the address. CREATE 0 , ; : CONSTANT ( x "ccc" ---) \G Create a definition that returns x when executed. \ Definition contains lit & return in its code field. HEADER REVEAL JSR, LIT DOCON , , ; VARIABLE STATE ( --- a-addr) \G Variable that holds the compiler state, 0 is interpreting 1 is compiling. : ] ( --- ) \G Start compilation mode. 1 STATE ! ; : [ ( --- ) \G Leave compilation mode. 0 STATE ! ; IMMEDIATE : LITERAL ( n --- ) \G Add a literal to the current definition. POSTPONE LIT , ; IMMEDIATE : COMPILE, ( xt --- ) \G Add the execution semantics of the definition xt to the current definition. , ; VARIABLE CSP ( --- a-addr ) \G This variable is used for stack checking between : and ; VARIABLE 'LEAVE ( --- a-addr) \ This variable is used for LEAVE address resolution. : !CSP ( --- ) \G Store current stack pointer in CSP. SP@ CSP ! ; : ?CSP ( --- ) \G Check that stack pointer is equal to value contained in CSP. SP@ CSP @ - -22 ?THROW ; : ; ( --- ) \G Finish the current definition by adding a return to it, make it \G visible and leave compilation mode. POSTPONE UNNEST [ ?CSP REVEAL ; IMMEDIATE : (POSTPONE) ( --- ) \G Runtime for POSTPONE. \ has inline argument. R> DUP @ SWAP CELL+ >R DUP >NAME C@ 64 AND IF EXECUTE ELSE COMPILE, THEN ; : : ( "ccc" --- ) \G Start a new definition, enter compilation mode. !CSP HEADER JSR, LIT DOCOL , ] ; : BEGIN ( --- x ) \G Start a BEGIN UNTIL or BEGIN WHILE REPEAT loop. HERE ; IMMEDIATE : UNTIL ( x --- ) \G Form a loop with matching BEGIN. \G Runtime: A flag is take from the stack \G each time UNTIL is encountered and the loop iterates until it is nonzero. POSTPONE ?BRANCH , ; IMMEDIATE : IF ( --- x) \G Start an IF THEN or IF ELSE THEN construction. \G Runtime: At IF a flag is taken from \G the stack and if it is true the part between IF and ELSE is executed, \G otherwise the part between ELSE and THEN. If there is no ELSE, the part \G between IF and THEN is executed only if flag is true. POSTPONE ?BRANCH HERE 1 CELLS ALLOT ; IMMEDIATE : THEN ( x ---) \G End an IF THEN or IF ELSE THEN construction. HERE SWAP ! ; IMMEDIATE : ELSE ( x1 --- x2) \G part of IF ELSE THEN construction. POSTPONE BRANCH HERE 1 CELLS ALLOT SWAP POSTPONE THEN ; IMMEDIATE : WHILE ( x1 --- x2 x1 ) \G part of BEGIN WHILE REPEAT construction. \G Runtime: At WHILE a flag is taken from the stack. If it is false, \G the program jumps out of the loop, otherwise the part between WHILE \G and REPEAT is executed and the loop iterates to BEGIN. POSTPONE IF SWAP ; IMMEDIATE : REPEAT ( x1 x2 --- ) \G part of BEGIN WHILE REPEAT construction. POSTPONE BRANCH , POSTPONE THEN ; IMMEDIATE VARIABLE POCKET ( --- a-addr ) \G Buffer for S" strings that are interpreted. 252 ALLOT-T : ' ( "ccc" --- xt) \G Find the word with name ccc and return its execution token. 32 WORD UPPERCASE? FIND 0= -13 ?THROW ; : ['] ( "ccc" ---) \G Copile the execution token of the word with name ccc as a literal. ' LITERAL ; IMMEDIATE : CHAR ( "ccc" --- c) \G Return the first character of "ccc". BL WORD 1 + C@ ; : [CHAR] ( "ccc" --- ) \G Compile the first character of "ccc" as a literal. CHAR LITERAL ; IMMEDIATE : DO ( --- x) \G Start a DO LOOP. \G Runtime: ( n1 n2 --- ) start a loop with initial count n2 and \G limit n1. POSTPONE (DO) 'LEAVE @ HERE 0 'LEAVE ! ; IMMEDIATE : ?DO ( --- x ) \G Start a ?DO LOOP. \G Runtime: ( n1 n2 --- ) start a loop with initial count n2 and \G limit n1. Exit immediately if n1 = n2. POSTPONE (?DO) 'LEAVE @ HERE 'LEAVE ! 0 , HERE ; IMMEDIATE : LEAVE ( --- ) \G Runtime: leave the matching DO LOOP immediately. \ All places where a leave address for the loop is needed are in a linked \ list, starting with 'LEAVE variable, the other links in the cells where \ the leave addresses will come. POSTPONE (LEAVE) HERE 'LEAVE @ , 'LEAVE ! ; IMMEDIATE : RESOLVE-LEAVE \G Resolve the references to the leave addresses of the loop. 'LEAVE @ BEGIN DUP WHILE DUP @ HERE ROT ! REPEAT DROP ; : LOOP ( x --- ) \G End a DO LOOP. \G Runtime: Add 1 to the count and if it is equal to the limit leave the loop. POSTPONE (LOOP) , RESOLVE-LEAVE 'LEAVE ! ; IMMEDIATE : +LOOP ( x --- ) \G End a DO +LOOP \G Runtime: ( n ---) Add n to the count and exit if this crosses the \G boundary between limit-1 and limit. POSTPONE (+LOOP) , RESOLVE-LEAVE 'LEAVE ! ; IMMEDIATE : RECURSE ( --- ) \G Compile a call to the current (not yet finished) definition. LAST @ NAME> COMPILE, ; IMMEDIATE : ." ( "ccc" --- ) \G Parse a string delimited by " and compile the following runtime semantics. \G Runtime: type that string. POSTPONE (.") 34 WORD C@ 1+ ALLOT ALIGN ; IMMEDIATE : S" ( "ccc" --- ) \G Parse a string delimited by " and compile the following runtime semantics. \G Runtime: ( --- c-addr u) Return start address and length of that string. STATE @ IF POSTPONE (S") 34 WORD C@ 1+ ALLOT ALIGN ELSE 34 WORD COUNT POCKET PLACE POCKET COUNT THEN ; IMMEDIATE : ABORT" ( "ccc" --- ) \G Parse a string delimited by " and compile the following runtime semantics. \G Runtime: ( f --- ) if f is nonzero, print the string and abort program. POSTPONE (ABORT") 34 WORD C@ 1+ ALLOT ALIGN ; IMMEDIATE : ABORT ( --- ) \G Abort unconditionally without a message. -1 THROW ; : POSTPONE ( "ccc" --- ) \G Parse the next word delimited by spaces and compile the following runtime. \G Runtime: depending on immediateness EXECUTE or compile the execution \G semantics of the parsed word. POSTPONE (POSTPONE) ' , ; IMMEDIATE : IMMEDIATE ( --- ) \G Make last definition immediate, so that it will be executed even in \G compilation mode. LAST @ DUP C@ 64 OR SWAP C! ; : ( ( "ccc" --- ) \G Comment till next ). 41 PARSE DROP DROP ; IMMEDIATE : \ \G Comment till end of line. SOURCE >IN ! DROP ; IMMEDIATE : >BODY ( xt --- a-addr) \G Convert execution token to parameter field address. 3 + ; : (;CODE) ( --- ) \G Runtime for DOES>, exit calling definition and make last defined word \G execute the calling definition after (;CODE) R> LAST @ NAME> 1+ ! ; : DOES> ( --- ) \G Word that contains DOES> will change the behavior of the last created \G word such that it pushes its parameter field address onto the stack \G and then executes whatever comes after DOES> POSTPONE (;CODE) JSR, LIT DOCOL , ; IMMEDIATE \ PART 10: TOP LEVEL OF INTERPRETER : ?STACK ( ---) \G Check for stack over/underflow and abort with an error if needed. DEPTH DUP 0< -4 ?THROW 10000 > -3 ?THROW ; : INTERPRET ( ---) \G Interpret words from the current source until the input source is exhausted. BEGIN 32 WORD UPPERCASE? DUP C@ WHILE FIND DUP IF -1 = STATE @ AND IF COMPILE, ELSE EXECUTE THEN ELSE DROP NUMBER? 0= -13 ?THROW DPL @ 1+ IF STATE @ IF SWAP LITERAL LITERAL THEN ELSE DROP STATE @ IF LITERAL THEN THEN THEN ?STACK REPEAT DROP ; : EVALUATE ( c-addr u --- ) \G Evaluate the string c-addr u as if it were typed on the terminal. SID @ >R SRC @ >R #SRC @ >R >IN @ >R #SRC ! SRC ! 0 >IN ! -1 SID ! INTERPRET R> >IN ! R> #SRC ! R> SRC ! R> SID ! ; VARIABLE ERRORS ( --- a-addr) \G This variable contains the head of a linked list of error messages. : ERROR-SOURCE ( --- ) \G Print location of error source. SID @ 0 > IF ." in line " LOADLINE @ . THEN HERE COUNT TYPE CR WARM ; : QUIT ( --- ) \G This word resets the return stack, resets the compiler state, the include \G buffer and then it reads and interprets terminal input. R0 @ RP! [ TIB SRC ! 0 SID ! BEGIN REFILL DROP ['] INTERPRET CATCH DUP 0= IF DROP STATE @ 0= IF ." OK" THEN CR ELSE \ throw occured. XABORTIN DUP -2 = IF ERROR$ @ COUNT TYPE SPACE ELSE ERRORS @ BEGIN DUP WHILE OVER OVER @ = IF 4 + COUNT TYPE SPACE ERROR-SOURCE THEN CELL+ @ REPEAT DROP ." Error " . THEN ERROR-SOURCE THEN 0 UNTIL ; : XLOAD XOPENIN 1 SID ! 0 LOADLINE ! ; : WARM ( ---) \G This word is called when an error occurs. Clears the stacks, sets \G BASE to decimal, closes the files and resets the search order. R0 @ RP! S0 @ SP! DECIMAL 2 #ORDER ! FORTH-WORDLIST CONTEXT ! FORTH-WORDLIST CONTEXT CELL+ ! FORTH-WORDLIST CURRENT ! 0 HANDLER ! ." Welcome to Forth" CR QUIT ; CODE COLD ( --- ) \G The first word that is called at the start of Forth. LDY # $8000 STY R0ADDR LDS # $7C00 STS S0ADDR A; $7E C, WARM END-CODE END-CROSS \ PART 10: FINISHING AND SAVING THE TARGET IMAGE. \ Resolve the forward references created by the cross compiler. RESOLVE DOCOL RESOLVE DOCON RESOLVE LIT RESOLVE BRANCH RESOLVE ?BRANCH RESOLVE (DO) RESOLVE DOVAR RESOLVE UNNEST RESOLVE (LOOP) RESOLVE (.") RESOLVE COLD RESOLVE WARM RESOLVE THROW RESOLVE (POSTPONE) \ Store appropriate values into some of the new Forth's variables. : CELLS>TARGET 0 DO OVER I CELLS + @ OVER I CELLS-T + !-T LOOP 2DROP ; #THREADS T' FORTH-WORDLIST >BODY-T !-T TLINKS T' FORTH-WORDLIST >BODY-T 2 + #THREADS CELLS>TARGET THERE T' DP >BODY-T !-T : TELLMEHOW BASE @ HEX ." Type SO" ORIGIN . ." ,then SS" IMAGE . ." ," THERE ORIGIN - . BYE ;