cross.4

\ Cross compiler to produce machine-independent binary image of RelF
\ (Relative Forth). Uses kernel.4.
\ Based on SOD32 by L.C. Benschop
\ Copyright 2001 - 2005, Kirill Timofeev, kt97679@gmail.com
\ The program is released under the GNU General Public License version 2.
\ There is NO WARRANTY.

\ PART 1: THE VOCABULARIES.

VOCABULARY TARGET
\ This vocabulary will hold shadow definitions for all words that are in
\ the target dictionary. When a shadow definition is executed, it
\ performs the compile action in the target dictionary.

VOCABULARY TRANSIENT
\ This vocabulary will hold definitions that must be executed by the
\ host system ( the system on which the cross compiler runs) and that
\ compile to the target system.

\ Expl: The word IF occurs in all three vocabularies. The word IF in the
\       FORTH vocabulary is run by the host system and is used when
\       compiling host definitions. A different version is in the
\       TRANSIENT vocabulary. This one runs on the host system and
\       is used when compiling target definitions. The version in the
\       TARGET vocabulary is the version that will run on the target
\       system.


\ PART 2: THE TARGET DICTIONARY SPACE.

\ Next we need to define the target space and the words to access it.

20000 CONSTANT IMAGE_SIZE

CREATE IMAGE IMAGE_SIZE CHARS ALLOT \ This space contains the target image.
       IMAGE IMAGE_SIZE 0 FILL      \ Initialize it to zero.

\ Fetch and store characters in the target space.
: C@-T ( t-addr --- c) CHARS IMAGE + C@ ;
: C!-T ( c t-addr ---) CHARS IMAGE + C! ;

\ Fetch and store cells in the target space.
\ SOD32 is big endian 32 bit so store explicitly big-endian.
: @-T  ( t-addr --- x)
       CHARS IMAGE + DUP C@ 24 LSHIFT OVER 1 CHARS + C@ 16 LSHIFT +
       OVER 2 CHARS + C@ 8 LSHIFT + SWAP 3 CHARS + C@ + ;
: !-T  ( x t-addr ---)
       CHARS IMAGE + OVER 24 RSHIFT OVER C! OVER 16 RSHIFT OVER 1 CHARS + C!
       OVER 8 RSHIFT OVER 2 CHARS + C! 3 CHARS + C! ;

\ A dictionary is constructed in the target space. Here are the primitives
\ to maintain the dictionary pointer and to reserve space.

VARIABLE DP-T                       \ Dictionary pointer for target dictionary.
0 DP-T !                            \ Initialize it to zero, SOD starts at 0.
: THERE ( --- t-addr) DP-T @ ;      \ Equivalent of HERE in target space.
: ALLOT-T ( n --- ) DP-T +! ;       \ Reserve n bytes in the dictionary.
: CHARS-T ( n1 --- n2 ) ;
: CELLS-T ( n1 --- n2 ) 2 LSHIFT ;  \ Cells are 4 chars.
: ALIGN-T                           \ SOD only accesses cells at aligned
                                    \ addresses.
  BEGIN THERE 3 AND WHILE 1 ALLOT-T REPEAT ;
: ALIGNED-T ( n1 --- n2 ) 3 + -4 AND ;
: C,-T  ( c --- )  THERE C!-T 1 CHARS ALLOT-T ;
: ,-T   ( x --- )  THERE !-T  1 CELLS-T ALLOT-T ;

: PLACE-T ( c-addr len t-addr --- ) \ Move counted string to target space.
  OVER OVER C!-T 1+ CHARS IMAGE + SWAP CHARS CMOVE ;

\ After the Forth system is constructed, its image must be saved.
: SAVE-IMAGE ( "name" --- )
  32 WORD COUNT W/O BIN CREATE-FILE ABORT" Can't create file" >R
  IMAGE THERE R@ WRITE-FILE ABORT" Can't write file"
  R> CLOSE-FILE ABORT" Can't close file" ;

\ PART 3: CREATING NEW DEFINITIONS IN THE TARGET SYSTEM.

\ These words create new target definitions, both the shadow definition
\ and the header in the target dictionary. The layout of target headers
\ can be changed but FIND in the target system must be changed accordingly.

VARIABLE TLINK 0 TLINK !   \ This variable points to the name
                           \ of the last definition.

: "HEADER >IN @ CREATE >IN ! \ Create the shadow definition.
  ALIGN-T
  TLINK @ IF
    TLINK @ THERE - ,-T        \ Lay out the link field.
  ELSE
    0 ,-T
  THEN
  BL WORD
  COUNT DUP >R THERE PLACE-T  \ Place name in target dictionary.
  THERE TLINK !
  THERE C@-T 128 OR THERE C!-T R> 1+ ALLOT-T ALIGN-T ;
      \ Set bit 7 of count byte as a marker.

\ : "HEADER CREATE ALIGN-T ;  \ Alternative for "HEADER in case the target system
                      \ is just an application without headers.

ALSO TRANSIENT DEFINITIONS

: IMMEDIATE TLINK @ DUP C@-T 64 OR SWAP C!-T ;
            \ Set the IMMEDIATE bit of last name.

PREVIOUS DEFINITIONS


\ PART 4: CODE GENERATION

VARIABLE STATE-T 0 STATE-T ! \ State variable for cross compiler.
: T] 1 STATE-T ! ;
: T[ 0 STATE-T ! ;

VARIABLE CSP   \ Stack pointer checking between : and ;
: !CSP DEPTH CSP ! ;
: ?CSP DEPTH CSP @ - ABORT" Incomplete control structure" ;

VARIABLE LAST-PRIMITIVE 1 LAST-PRIMITIVE !

: LITERAL-T ( n --- ) 9 ,-T ,-T ;

ONLY FORTH ALSO TRANSIENT DEFINITIONS FORTH
\ Now define the words that do compile code.

: PRIMITIVE ( c --- )
  LAST-PRIMITIVE @ DUP 4 LAST-PRIMITIVE +!
  "HEADER DUP , ,-T 5 ,-T          \ Create an executable target definition.
  TLINK @ DUP C@-T 32 OR SWAP C!-T   \ Set the MACRO bit of last name. 
  DOES> @ ,-T
;

: : !CSP "HEADER THERE , T] DOES> @ THERE - 4 - ,-T ;

: ; 5 ,-T T[ ?CSP ; \ Compile EXIT (5). Quit compilation state.

FORTH DEFINITIONS

\ PART 5: FORWARD REFERENCES

\ Some definitions are referenced before they are defined. A definition
\ in the TRANSIENT voc is created for each forward referenced definition.
\ This links all addresses together where the forward reference is used.
\ The word RESOLVE stores the real address everywhere it is needed.

: FORWARD
  CREATE -1 ,              \ Store head of list in the definition.
  DOES> 
        DUP @ ,-T THERE 1 CELLS-T - SWAP ! \ Reserve a cell in the dictionary
                  \ where the call to the forward definition must come.
                  \ As the call address is unknown, store link to next
                  \ reference instead.
;

: RESOLVE
  ALSO TARGET >IN @ ' >BODY @ >R >IN ! \ Find the resolving word in the
                          \ target voc. and take the CFA out of the definition.
  TRANSIENT ' >BODY  @                 \ Find the forward ref word in the
                                       \ TRANSIENT VOC and take list head.
  BEGIN
   DUP -1 -                            \ Traverse all the links until end.
  WHILE
   DUP @-T                             \ Take address of next link from dict.
   R@ ROT SWAP OVER - 4 - SWAP !-T         \ Set resolved address in dict.
  REPEAT DROP R> DROP PREVIOUS
;

\ PART 6: DEFINING WORDS.

TRANSIENT DEFINITIONS FORTH

FORWARD DOVAR \ Dovar is the runtime part of a variable.

: VARIABLE "HEADER THERE , [ TRANSIENT ] DOVAR [ FORTH ]  0 ,-T
\ Create a variable.
  DOES> @ THERE - 4 - ,-T ;

: CONSTANT "HEADER THERE ,
  9 ,-T ,-T 5 ,-T \ Assemble the instruction LIT (9) with EXIT (5).
  DOES> @ 4 + @-T LITERAL-T \ Compile const as a literal for speed.
;

FORTH DEFINITIONS

: T' ( --- t-addr) \ Find the execution token of a target definition.
  ALSO TARGET ' >BODY @ \ Get the address from the shadow definition.
  PREVIOUS
;

: >BODY-T ( t-addr1 --- t-addr2 ) \ Convert executing token to param address.
  1 CELLS + ;

\ PART 7: COMPILING WORDS

TRANSIENT DEFINITIONS FORTH

: BEGIN THERE ;
: UNTIL 17 ,-T THERE - ,-T ;        \ 17 - conditional jump
: IF 17 ,-T THERE 1 CELLS ALLOT-T ; \ 13 - unconditional jump
: THEN THERE OVER - SWAP !-T ;
: ELSE 13 ,-T THERE 1 CELLS ALLOT-T SWAP THERE OVER - SWAP !-T ;
: WHILE 17 ,-T THERE 1 CELLS ALLOT-T SWAP ;
: REPEAT 13 ,-T THERE - ,-T THERE OVER - SWAP !-T ;

FORWARD (DO)
FORWARD (LOOP)
FORWARD (.")
FORWARD (ABORT")
FORWARD (POSTPONE)

: DO [ TRANSIENT ] (DO) [ FORTH ] THERE ;
: LOOP [ TRANSIENT ] (LOOP) [ FORTH ] THERE - ,-T ;
: ." [ TRANSIENT ] (.") [ FORTH ] 34 WORD COUNT DUP 1+ >R
      THERE PLACE-T R> ALLOT-T ALIGN-T ;
: POSTPONE [ TRANSIENT ] (POSTPONE) [ FORTH ] T' THERE - ,-T ;
: ABORT" [ TRANSIENT ] (ABORT") [ FORTH ] 34 WORD COUNT DUP 1+ >R
      THERE PLACE-T R> ALLOT-T ALIGN-T ;

: \ POSTPONE \ ; IMMEDIATE
: ( POSTPONE ( ; IMMEDIATE \ Move duplicates of comment words to TRANSIENT
: CHARS-T CHARS-T ; \ Also words that must be executed while cross compiling.
: CELLS-T CELLS-T ;
: ALLOT-T ALLOT-T ;
: ['] T' LITERAL-T ;

FORTH DEFINITIONS

\ PART 8: THE CROSS COMPILER ITSELF.

VARIABLE DPL
: NUMBER? ( c-addr ---- d f)
  -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
;


: CROSS-COMPILE
  ONLY TARGET DEFINITIONS ALSO TRANSIENT \ Restrict search order.
  BEGIN
   BL WORD
   DUP C@ 0= IF \ Get new word
    DROP REFILL DROP                      \ If empty, get new line.
   ELSE
    DUP COUNT S" END-CROSS" COMPARE 0=    \ Exit cross compiler on END-CROSS
    IF
     ONLY FORTH ALSO DEFINITIONS          \ Normal search order again.
     DROP EXIT
    THEN
    FIND IF                               \ Execute if found.
     EXECUTE
    ELSE
     NUMBER? 0= ABORT" Undefined word" DROP
     STATE-T @ IF \ Parse it as a number.
      LITERAL-T   \ If compiling then compile as a literal.
     THEN
    THEN
   THEN
  0 UNTIL
;

\ PART 9: CROSS COMPILING THE KERNEL

\ Up till now not a single byte of the new Forth kernel has actually been
\ compiled.

TRANSIENT DEFINITIONS
FORWARD COLD
FORWARD WARM
FORWARD DIV-EX
FORWARD BREAK-EX
FORWARD TIMER-EX
FORWARD THROW
FORTH DEFINITIONS

S" kernel.4" INCLUDED

\ PART 10: FINISHING AND SAVING THE TARGET IMAGE.

\ Resolve the forward references created by the cross compiler.
RESOLVE (DO)
RESOLVE DOVAR
RESOLVE (LOOP)
RESOLVE (.")
RESOLVE (ABORT")
RESOLVE COLD
RESOLVE WARM
\  RESOLVE DIV-EX
\  RESOLVE BREAK-EX
\  RESOLVE TIMER-EX
RESOLVE THROW
RESOLVE (POSTPONE)

\ Store appropriate values into some of the new Forth's variables.
TLINK @ T' FORTH-WORDLIST >BODY-T !-T
THERE   T' DP             >BODY-T !-T

SAVE-IMAGE kernel.img \ Save the newly constructed Forth system to disk.

BYE