\ meta.f: ANS Compliant Meta Compiler with Late Binding \ ========================================================================= \ Copyright 1997-99 by John Rible, \ Permission is granted for individual non-commercial use, provided this \ notice is included. Contact the author concerning other uses. \ ========================================================================= \ I think this is an ANS Forth Program with Environmental Dependencies, \ requiring: \ 2's complement, little endian, 2^n cell size, 1 char/byte address units \ the Exception word set, \ the Search-Order word set, \ NIP TUCK TO VALUE WITHIN from the Core word set extensions, \ INCLUDED from the File word set, \ BYE from the Tools Extension word set, \ SLITERAL from the String word set, \ the word standalone from the 'make' file \ target names for EMPLACE: _LIT _VAR _CON _USR _ABORT" _." _S" R> \ _IF _ELSE _DOES> COMPILE EXIT \ target names for EMPLOY: _NEST \ A Standard System exists after this program is loaded. \ Any operator's terminal facilities provided by the system are adequate. \ ------------------------------------------------------------------------- \ 970529 jwr: copied from qs2116 file \ 970615 jwr: copied from sp1601 file \ 970813 jwr: changes for sp1602 \ 970829 jet: many changes to make SEA list as useable Verilog/assembly code \ 980504 jet: many changes to fit new assembler, add forth listing \ 980610 jwr: more changes for newer assembler & D# H# \ 980722 jwr: bug fixes; \ 981118 jwr: clean up for FORML \ 990527 jwr: added some more comments and debugging aids \ ========================================================================= \ Implementation notes: \ This metacompiler will work (unmodified) with hosts and targets where: \ - The target's cell size is not larger than host's cell size. \ - Both host and target have byte-sized, little endian, address units. \ This metacompiler sets up four wordlists ( META NAMES INSIDE OUTSIDE ) to \ manage the search order during the target compilation process, and creates \ a cell-by-cell target memory image in the host's data space. \ Target compilation is always done using the host's interpreter, with ':' \ and ';' switching between the 'outside' and 'inside' search orders. This \ requires numbers 'inside' target colon definitions to be preceeded by a \ word to compile them ( B# D# H# ). \ The host's requirement for target-specific information is handled by the \ 'late-binding' of word names that the target must use. \ The target compilation of DOES> words is included, although the execution \ of their children at compile time requires extending the metacompiler. \ The children of standard defining words return their address ( VARIABLE \ CREATE ) or value ( CONSTANT ). \ Metacompiler wordlist ---------------------------------------------------- HEX WORDLIST CONSTANT META-WORDLIST \ isolate metacompiler words : +META ( - ) META-WORDLIST +ORDER ; +META DEFINITIONS \ Metacompiler miscellaneous ----------------------------- : .META ( - ) ." meta 3.3 " ; : COMPILE-ONLY ; \ Dummy for ANS : PARSE-WORD ( 'word' - ca cc ) BL WORD COUNT ; \ kludge! : NUF? ( -- f ) KEY? DUP IF DROP KEY KEY = 0= THEN ; \ Return false (to continue) when no key has been pressed \ Pause when a key has been pressed; return false (to continue) when the same \ key is pressed again, or true (to stop) when a different key is pressed. \ Metacompiler Error-handler ----------------------------------------------- \ Used instead of ABORT" for a different message display. : .ERROR ( - ) >IN @ 3 - 0 MAX CR SOURCE TYPE CR SPACES ." ^= " ; : ?ERROR ( f ca cc - ) ROT IF .ERROR TYPE QUIT THEN 2DROP ; : ERROR" ( 'text' - ) POSTPONE S" POSTPONE ?ERROR ; IMMEDIATE \ Metacompiler WORDLISTs --------------------------------------------------- \ search a wordlist expecting to find the word : FindXT ( ca cc wid - xt ) SEARCH-WORDLIST 0= ERROR" missing?" ; WORDLIST CONSTANT NAMES-WORDLIST \ contains just the target words, each \ with the behavior of compiling their \ own target XT. VARIABLE NBODY \ pointer to last NAMES body (target may be headerless) : CREATE-NAME ( flags na|0 xt - ) \ The body is: | tXT | tNA|0 | tFLAGS | NAMES-WORDLIST SWAP-CURRENT CREATE SET-CURRENT HERE NBODY ! , , , ; \ the DOES> part appears below in the word ALIAS : NAMES-BODY ( 'word' - ia ) PARSE-WORD NAMES-WORDLIST FindXT >BODY ; : .T' ( 'word' - ) NAMES-BODY 3 CELLS DUMP ; WORDLIST CONSTANT OUTSIDE-WORDLIST \ contains the metacompiler words that \ are active while interpreting target \ source code and child words. : :O ( 'word' - wid colon-sys ) OUTSIDE-WORDLIST SWAP-CURRENT : ; : ;O ( wid colon-sys - ) POSTPONE ; SET-CURRENT ; IMMEDIATE : [O] ( 'word' - ) PARSE-WORD OUTSIDE-WORDLIST FindXT COMPILE, ; IMMEDIATE WORDLIST CONSTANT INSIDE-WORDLIST \ contains the metacompiler words that \ are active while compiling target \ colon-definition source code. : :I ( 'word' - wid colon-sys ) INSIDE-WORDLIST SWAP-CURRENT : ; : ;I ( wid colon-sys - ) POSTPONE ; SET-CURRENT ; IMMEDIATE : [I] ( 'word' - ) PARSE-WORD INSIDE-WORDLIST FindXT COMPILE, ; IMMEDIATE \ Late binding ------------------------------------------------------------- : _bind ( .. ca cc wid - ?? ) FindXT CATCH ERROR" bind?" ; : bind ( wid 'word' - ) \ compile code to look up & execute 'word' PARSE-WORD POSTPONE SLITERAL POSTPONE LITERAL POSTPONE _bind ; COMPILE-ONLY \ EMPLOY 'late-binds' target labels and equates into definitions : EMPLOY ( 'word' - ) OUTSIDE-WORDLIST bind ; IMMEDIATE \ EMPLACE 'late-binds' target definition names into definitions : EMPLACE ( 'word' - ) NAMES-WORDLIST bind ; IMMEDIATE \ Target address-space ===================================================== \ These calculations assume: \ that the host and target address-units are bytes (chars), \ that the number of bytes per host/target cell are powers of two, \ that the target cell is not bigger than the host cell, \ that both host and target have 'little endian' byte order, and \ that there's enough host data space for the complete target image. CREATE TSIZE 0 , \ target image max size in cells CREATE T/CELL 0 , \ #bytes/target cell CREATE HADDR 0 , \ target image starting host byte address CREATE HSIZE 0 , \ target image max size in host bytes CREATE H/CELL 1 CELLS , \ #bytes/host cell : >H ( Tau - Hau ) 0 T/CELL @ UM/MOD H/CELL @ * + ; : >HA ( Ta - Ha ) >H DUP HSIZE @ 0 WITHIN ERROR" adr range" HADDR @ + ; :O C! ( c ca - ) >HA C! ;O :O C@ ( ca - c ) >HA C@ ;O :O ! ( x aa - ) >HA ! ;O :O @ ( aa - x ) >HA @ ;O :O 2! ( x x aa - ) >HA 2! ;O :O 2@ ( ca - x x ) >HA 2@ ;O :O CHARS ( n - ca ) ;O :O CELLS ( n - aa ) T/CELL @ * ;O :O CHAR+ ( ca - ca' ) 1+ ;O :O CELL+ ( aa - aa' ) T/CELL @ + ;O :O CHAR- ( ca - ca' ) 1- ;O :O CELL- ( aa - aa' ) T/CELL @ - ;O :O COUNT ( ca - ca+ c ) DUP [O] CHAR+ SWAP [O] C@ ;O :O @++ ( aa - aa+ x ) DUP [O] CELL+ SWAP [O] @ ;O VARIABLE WASTE \ number of target bytess lost to alignment VARIABLE TDP \ target dictionary pointer VARIABLE TNP \ pointer to last target header xa : ALIGNS ( a - au ) NEGATE T/CELL @ 1- AND ; \ *** assumes 2's complement *** :O ALIGNED ( a - aa ) DUP ALIGNS DUP WASTE +! + ;O : ?full ( - ) TNP @ TDP @ 100 + - 0< ERROR" dictionary full" ; : ?aligned ( - ) TDP @ ALIGNS ERROR" unaligned" ; :O ORG ( a - ) ?full TDP ! ;O :O HERE ( - a ) TDP @ ;O :O ALLOT ( au - ) [O] HERE + [O] ORG ;O :O ALIGN ( - ) [O] HERE [O] ALIGNED [O] ORG ;O :O WHERE ( - aa ) [O] ALIGN [O] HERE ;O :O C, ( c - ) [O] HERE 1 [O] CHARS [O] ALLOT [O] C! ;O :O , ( x - ) ?aligned [O] HERE 1 [O] CELLS [O] ALLOT [O] ! ;O : pack>t ( Ha cc Ta - Ta ) \ move host string to target image ( Ha cc Ta ) >R ?DUP IF ( R: Ta ) ( Ha cc ) R@ 2DUP [O] C! SWAP [O] CHARS OVER + >R ( R: Ta end ) ( Ha Ta ) BEGIN [O] CHAR+ >R COUNT R@ [O] C! R> ( Ha+ Ta+ ) R@ OVER = UNTIL R> 2DROP ( R: Ta ) ( Ha+ ) THEN DROP R> ( R: ) ; :O ,C" ( 'text' - ) \ compile string in target image [CHAR] " PARSE [O] HERE OVER 1+ [O] ALLOT pack>t DROP ;O \ Target name-space ======================================================== \ The target image has separate name and data spaces: |...dp> ... t DUP [O] CELL- \ copy name ( xt na la ) 2DUP TLAST SWAP OVER @ SWAP [O] ! ! [O] CELL- \ update link ( xt na xa' ) DUP TNP ! ROT SWAP [O] ! ?full \ store xt ; : !TLEX ( c - na|0 ) \ change flags of last name in NAMES wordlist >R NBODY @ CELL+ DUP CELL+ DUP @ R> OR SWAP ! @ ; : !LEX ( c - ) \ change NAMES flags and image flags if there's a header ( c ) DUP !TLEX ?DUP IF ( c na ) [O] COUNT [O] CHARS + DUP [O] C@ ROT OR OVER [O] C! ( fa ) THEN DROP ; : =IMED ( - x ) 1 ; \ IMMEDIATE flag bit mask : =COMP ( - x ) 2 ; \ COMPILE-ONLY flag bit mask :O IMMEDIATE ( - ) =IMED !LEX ;O :O COMPILE-ONLY ( - ) =COMP !LEX ;O : NORM? ( ia - f ) CELL+ CELL+ @ =IMED AND 0= ; :O ALIAS ( xt 'word' - ) \ define in NAMES wordlist and maybe build a header >R 0 HEADS? @ DUP IF DROP >IN @ R@ HEAD, SWAP >IN ! THEN R> CREATE-NAME \ The behavior of children defined using ALIAS is to compile the target \ definition's execution token DOES> DUP NORM? 0= ERROR" imm word" @ [O] COMPILE, ;O :O initDictionary ( - last np dp ) \ display pointers TLAST @ TNP @ TDP @ 2DUP CR ." DP= " . ." NP= " . ." HI= " TSIZE @ [O] CELLS . ;O \ Defining words =========================================================== \ This QS3 target uses 'link-threaded code' and separated heads and \ assumes these target names: _CON _VAR _USR _NEST VARIABLE TCSP \ provide a minimal amount of target error checking :O !CSP ( ... - ... ) DEPTH TCSP ! ;O :O ?CSP ( ... - ... ) DEPTH TCSP @ - ERROR" stack changed" ;O :O EQU ( x 'word' - ) CONSTANT ;O \ definitions go into OUTSIDE-WORDLIST :O LABEL ( 'word' - ) [O] WHERE [O] EQU ;O \ only labels word addresses :O >ADR ( xt - aa ) ;O \ QS3 :O >XT ( aa - xt ) ;O \ QS3 : NEST ( - aa ) [O] WHERE EMPLOY _NEST [O] @ [O] , ; \ QS3 : LIST ( 'word' - ) NEST [O] >XT [O] ALIAS ; \ name a colon definition : DATA ( 'word' - ) >IN @ LIST >IN ! ; \ name a data definition :O ] ( - ) NAMES-WORDLIST INSIDE-WORDLIST 2 SET-ORDER DEFINITIONS ;O :O : ( 'word' - colon-sys) LIST [O] ] [O] !CSP ;O :O CREATE ( 'word' - ) DATA EMPLACE _VAR [O] LABEL ;O :O VARIABLE ( 'word' - ) DATA EMPLACE _VAR [O] LABEL 0 [O] , ;O :O CONSTANT ( x 'word' - ) DATA EMPLACE _CON DUP [O] EQU [O] , ;O :O USER ( n 'word' - ) DATA EMPLACE _USR DUP [O] EQU [O] , ;O :O ' ( 'word' - xt ) NAMES-BODY @ ;O :O NAME> ( na - xt ) [O] CELL- [O] CELL- [O] @ ;O \ Number input ------------------------------------------------------------- : X# ( radix 'word' - n|d f ) \ interpret numbers ( u ) DEPTH >R BASE @ >R BASE ! PARSE-WORD ['] EVALUATE CATCH R> BASE ! \ *** careful! the 'word' following *# might be a name *** ( n|d f ) DEPTH 1- R> - SWAP OVER 2 0 WITHIN OR ERROR" number?" ; :O B# ( 'word' - n|d ) 2 X# DROP ;O :O D# ( 'word' - n|d ) 0A X# DROP ;O :O H# ( 'word' - n|d ) 10 X# DROP ;O \ These HOST words --------------------------------------------------------- \ are the only ones useable outside target definitions while metacompiling: :O .S ( ... - ... ) .S ;O :O .( ( 'text' - ) CR POSTPONE .( ;O :O ( ( 'text' - ) POSTPONE ( ;O :O \ ( 'text' - ) POSTPONE \ ;O :O INCLUDE ( 'path\file' - ) PARSE-WORD ['] INCLUDED CATCH ERROR" bad file" ;O :O DUP DUP ;O :O + + ;O :O CHAR CHAR ;O :O . . ;O :O DROP DROP ;O :O - - ;O :O MAX MAX ;O :O / / ;O :O INVERT INVERT ;O :O * * ;O :O MIN MIN ;O :O CR CR ;O :O SWAP SWAP ;O :O OR OR ;O :O 1- 1- ;O :O OVER OVER ;O :O AND AND ;O :O 1+ 1+ ;O :O WORDS CR WORDS ;O :O DECIMAL DECIMAL ;O :O HEX HEX ;O standalone 0= [IF] :O HOST HOST ;O :O ORDER ORDER ;O :O +META +META ;O [THEN] \ The "IMMEDIATE" Meta words =============================================== \ require these target names: _ELSE _IF _ABORT" _." _S" _DOES> _LIT \ EXIT R> COMPILE :I BEGIN ( - A ) ?aligned [O] HERE ;I \ MARK ( - a ) ?aligned [O] HERE 0 [O] , ; :I THEN ( a - ) ?aligned [O] HERE SWAP [O] ! ;I \ >RESOLVE :I IF ( - a ) EMPLACE _IF >MARK ;I :I AHEAD ( - a ) EMPLACE _ELSE >MARK ;I :I UNTIL ( A - ) EMPLACE _IF ' - ) EMPLACE _ABORT" [O] ,C" [O] ALIGN ;I :I ." ( 'text' - ) EMPLACE _." [O] ,C" [O] ALIGN ;I :I S" ( 'text' - ) EMPLACE _S" [O] ,C" [O] ALIGN ;I :I LITERAL ( x - ) EMPLACE _LIT [O] , ;I :I ['] ( 'word' - xt ) [O] ' [I] LITERAL ;I :I [CHAR] ( 'word' - n ) CHAR [I] LITERAL ;I :I [COMPILE] ( 'word' - ) [O] ' [O] COMPILE, ;I : #I ( n|d f - ) IF SWAP [I] LITERAL THEN [I] LITERAL ; :I B# ( 'word' - ) 2 X# #I ;I :I D# ( 'word' - ) 0A X# #I ;I :I H# ( 'word' - ) 10 X# #I ;I :I DOES> ( colon-sys1 - colon-sys2 ) EMPLACE _DOES> EMPLACE R> ;I :I POSTPONE ( 'word' - ) NAMES-BODY DUP NORM? IF EMPLACE COMPILE THEN @ [O] COMPILE, ;I :I RECURSE ( - ) NBODY @ @ [O] COMPILE, ;I :I [ ( - ) OUTSIDE-WORDLIST 1 SET-ORDER DEFINITIONS ;I :I ; ( colon-sys - ) EMPLACE EXIT [I] [ [O] ?CSP ;I \ These HOST words --------------------------------------------------------- \ are the only ones useable inside target definitions while metacompiling: :I ( ( 'ccc' - ) [O] ( ;I :I \ ( 'ccc' - ) [O] \ ;I :I WORDS ( - ) CR WORDS NAMES-WORDLIST +ORDER CR WORDS -ORDER ;I standalone 0= [IF] :I HOST HOST ;I :I ORDER ORDER ;I :I +META +META ;I [THEN] \ And finally, the target image handling =================================== VARIABLE unburned 0FFFF unburned ! \ value put in unused cells VARIABLE SHORE \ end of disassembled memory HOST +META \ Put these words in the host's wordlist: : image[ ( - ) [O] HEADERS [O] !CSP HEX [I] [ ; \ enter the target :O ]image ( - ) CR ." Waste=" WASTE ? [O] ?CSP HOST ;O \ restore host : =image ( #cells #bytes/cell - ) \ initialize the target memory image OVER 8000 100 WITHIN OVER H/CELL @ 1+ 2 WITHIN OR ERROR" image params?" T/CELL ! DUP TSIZE ! DUP SHORE ! DUP [O] CELLS TNP ! DUP CELLS HSIZE ! HERE HADDR ! 0 DO unburned @ , LOOP 0 TDP ! 0 TLAST ! 0 WASTE ! ; : Image ( - #bytes/cell host-address #cells ) T/CELL @ HADDR @ TSIZE @ ; -ORDER \ remove META