(* * LANGUAGE : ANS Forth * PROJECT : Forth Environments * DESCRIPTION : Source code for a Universal Meta Compiler * CATEGORY : Tool * AUTHOR : Marcel Hendrix * LAST CHANGE : Monday, June 09, 2003 2:27 AM, Marcel Hendrix; disabled TEVEN and TALIGN [ dataseg in future? ] * LAST CHANGE : Sunday, June 08, 2003 11:34 AM, Marcel Hendrix; added 4 extra fields in $,n * LAST CHANGE : Saturday, May 31, 2003 12:45 PM, Marcel Hendrix; added LEAVE and EXIT processing * LAST CHANGE : July 30, 1997, Marcel Hendrix; added [IF] [ELSE] [THEN] CASE OF ENDOF ENDCASE * LAST CHANGE : July 27, 1997, Marcel Hendrix; added C/I: and DO LOOP +LOOP (no LEAVE ?DO) * LAST CHANGE : July 5, 1997, Marcel Hendrix; added TMACRO * LAST CHANGE : June 7, 1997, Marcel Hendrix; for mxForth * LAST CHANGE : July 13, 1997, Marcel Hendrix; added TINLINE * LAST CHANGE : August 6, 1994, Marcel Hendrix; No support for LOCALs, DO LOOP and CASE * LAST CHANGE : February 24, 1992, Marcel Hendrix *) CASESENSITIVE ON ONLY FORTH ALSO DEFINITIONS REVISION -meta "ÄÄÄ Forth MetaCompiler Version 3.04 ÄÄÄ" ONLY FORTH DEFINITIONS ALSO XASM VOCABULARY META ALSO META DEFINITIONS PRIVATES DECIMAL ' META >BODY =: WARNING OFF INCLUDE mxf.cnf (* describes the model *) ONLY FORTH ALSO XASM ALSO META DEFINITIONS -- utility : SYNONYM CREATE \ SYNONYM ## GET-CURRENT @ HEAD> ! ; DOC Target addressing (* META ==== META works with 32 bit linear addresses pointing into emulated target address space. There are two location counters for the target, TCP for code and TNP for data. The basic operators on the target space are: TC@ \ --- TC! \ --- <> T@ \ --- Note: CELL operator (32 bits) T! \ --- <> Note: CELL operator (32 bits) T@+ \ --- TDUMP \ --- <> HOST>TARGET \ --- <> Move host string to target space TARGET>HOST \ --- <> Move target string to host TCOMPARE \ --- <-1|0|1> TC, \ --- <> T16, \ --- <> Sometimes unavoidable. T32, \ --- <> Sometimes unavoidable. T, \ --- <> Note: CELL operator (32 bits) TFILL \ --- <> TERASE \ --- <> TDUPC, \ --- <> Meta assumes that target addresses are mapped in host space, so they can be accessed with @ ! COMPARE etc. In general this will not be true. The target could be located on disk, on a network, or on a secondary board in I/O space or connected to a parallel or serial port. For a truly general metacompiler T>H and H>T must be build with TARGET>HOST and HOST>TARGET (The META source should be changed so that T>H and H>T tell the compiler how many bytes they want to access). T>H and H>T aren't necessary that often. Host->Target and Target->Host address conversion is achieved with: T>H \ --- Output is a physical address in host H>T \ --- Output is a logical address in target ?? \ <> --- special address, meaning: ``forward reference'' The user table (begin of ?f.inc source file) needs the values that CP and NP will have at the END of meta compilation. Therefore you can not use the PRESENT values of the location counters as in: TCP T, -- CP TNP T, -- NP You must copy the location counters to values that are not reset by METACOMPILE ## . I chose the names `FinalXX'. These values are updated by METACOMPILE when it finishes. *) ENDDOC TCELL 4 = [IF] : T, T32, ; \ --- <> : T! T32! ; \ <32b> --- <> : T@ T32@ ; \ --- <32b> : T@+ T32@+ ; \ --- <32b> : T!+ TUCK T32! TCELL + ; \ <32b> --- [ELSE] : T, T16, ; \ --- <> : T! T16! ; \ <16b> --- <> : T@ T16@ ; \ --- <16b> : T@+ T16@+ ; \ --- <16b> : T!+ TUCK T16! TCELL + ; \ <16b> --- [THEN] 0 VALUE DataPointer -- target address of data 0 VALUE TLAST 0 VALUE FinalTCP 0 VALUE FinalTNP 0 VALUE FinalLAST 0 VALUE mleaves PRIVATE 0 VALUE mexits PRIVATE -- TCP = `Target Code Space Pointer' , TNP = `Target Name Space Pointer' : TCP THERE ; \ <> --- : TNP DataPointer ; \ <> --- : !TNP TO DataPointer ; \ --- <> : !TCP SET-THERE ; \ --- <> DOC TNP TCP (* Be careful! The user table (begin of source file) needs the values CP and NP will have at the END of meta compilation. Therefore you can not use the PRESENT values of the location counters like: MACRO^ T, -- CP DataPointer T, -- NP You must copy the location counters to values that are NOT reset by METACOMPILE ## For instance, these values can be updated by METACOMPILE when it finishes. *) ENDDOC DOC Emulating CURRENT (* TCURRENT points to the location in the target where the address of the latest name is kept. This will be in the pfa of FORTH, ASSEMBLER etc, but when metacompiling, we'll have to simulate this (these words don't exist yet!). Note that the first cells of the target user area are reserved, so we'll use these during metacompilation. *) ENDDOC =BUFF =: TCURRENT PRIVATE \ <> --- -- Some words that behave in special ways in a METAFORTH environment. : TCELL+ =CELL + ; \ --- : TCELL- =CELL - ; \ --- : TCELLS =CELL * ; \ --- : T#CELLS =CELL /MOD SWAP IF 1+ \ --- ENDIF ; DOC Alignment & ANSF (* =CELL is not necessarily equal to the minimum `allocation unit'. Some 32-bit processors (680x0) can fetch from even addresses, but this is less efficient than from addresses that are a multiple of four. The INTEL family fetches from any address, but again with a speed penalty. The NOVIX had NO byte addressing at all. Design decision: Align strings at CELL boundaries, where CELL is the quantity fetched most efficiently by the target CPU. This has an important effect on string comparison: this can now be done a CELL at a time (up to 4 times as fast as some older Forths). But: this means the programmer *must* now be aware of subtle EVEN and ALIGNED effects to his (high-level) code! ( CREATE three 1 C, 4 , three @ H. \ does not show $0401 on an 80x8x ) There is a big problem with cell addressing. That's byte operators of course. How to specify CMOVE's arguments? How to define COUNT? How many bits has an address and how wide should the stack be? In the mxForth model an address has enough bits to specify any byte, but some words explicitly require cell addresses. This implies a cell address is a truncated byte address. Therefore there must be address conversion routines: byte -> cell : #CELLS byte -> byte' : BYTE+ cell -> byte : CELLS cell -> cell' : CELL+ With this model, it is perfectly ok to use 1+ instead of BYTE+ . It is strange that mxForth does not feature { #CELLS }. *) ENDDOC =CELL 1 = [IF] : TALIGNED ; [THEN] \ --- =CELL 2 = [IF] : TALIGNED DUP 1 AND + ; [THEN] \ --- =CELL 4 = [IF] : TALIGNED 4 OVER - 3 AND + ; [THEN] \ --- =CELL 1 = =CELL 2 = =CELL 4 = OR OR 0= [IF] ABORT =CELL not in {1,2,4} [THEN] -- Sometimes byte-addressing is possible, but numbers etc. must start at =CELL boundaries. : TEVEN =NOP THERE TALIGNED THERE - TDUPC, ; -- Strings are aligned and padded with nulls to a multiple of =AUNIT. : TPACK$ T>H PACK H>T ; \ <'$> -- : TTOKEN BL #31 MIN \ <> TTOKEN ## --> TNP OVER 1+ T#CELLS TCELLS - TALIGNED DUP 0= IF TCELL- ENDIF \ "0" is a special address... OVER ( cnt) 1+ T#CELLS 1- TCELLS OVER ( addr) + TCELL TERASE \ pad with 0 bytes. TPACK$ ; PRIVATE \ make room for counted $ : TNAME> 2 TCELLS - ; PRIVATE ( nfa -- i:cfa ) : TNAME>ICODE 2 TCELLS - ; PRIVATE ( nfa -- i:cfa ) : TNAME>CCODE 3 TCELLS - ; PRIVATE ( nfa -- c:cfa ) : TNAME>CDATA 4 TCELLS - ; PRIVATE ( nfa -- c:data ) : TNAME>ENTRY 5 TCELLS - ; PRIVATE ( nfa -- 'entry ) : TNAME>TRACE 6 TCELLS - ; PRIVATE ( nfa -- 'trace ) : TNAME>INFO 7 TCELLS - ; PRIVATE ( nfa -- 'info ) \ ALWAYS the last one, "7" = =#HSZ : TLINK> TCELL- ; PRIVATE ( nfa -- lfa ) -- TSAME? compares strings a cell at a time. META is case sensitive : TSAME? \ --- DUP 0= ?EXIT TCELLS >S 2DUP >R T>H S R> T>H S> COMPARE ; PRIVATE : tfind \ --- | SWAP \ va a DUP TC@ =CELL / LOCAL ttemp \ va a ( get cell count ) T@+ >S \ va a' ( cnt byte & 1st chars) SWAP \ a' va ( va points to namefield) BEGIN T@ DUP \ a' na na IF T@+ =MASK AND \ ignore lexicon bits, S = IF ttemp DUP IF TSAME? ENDIF ELSE ( a' na+1 ) TRUE ENDIF ELSE -S SWAP TCELL- SWAP EXIT ENDIF WHILE TCELL- TLINK> \ a' la REPEAT -S NIP ( na+1) TCELL- DUP TNAME> T@ SWAP ; PRIVATE : TTYPE >S T>H S> TYPE ; \ --- <> : T.$ T>H .$ ; \ --- <> -- META allows exactly *one* wordlist in the target : TNAME? TCURRENT tfind ; PRIVATE \ --- | <0> : TNAME2? TNAME? DUP 0<> IF NIP TRUE \ <'$> --- | <'$> ENDIF ; PRIVATE : THEAD' TTOKEN TNAME2? \ <> --- <'$|nfa> 0= IF ." (Forward reference to header -> " DUP T.$ ')' EMIT ENDIF ; DOC Forward references in target high-level words. (* The metacompiler does not keep its label information in a separate table, but simply consults the headers it has built in target space. This spells doom if multiple passes are needed, because normally headers would be generated anew, overwriting the information gathered on previous passes. We require that the Forth source fed to META doesn't EVER redefine names. A non-unique name thus implies we finished pass #1, and no header should be written this time. This protects the name space/the target symbol table. Code generation and putting data in the data segment are not inhibited on higher passes, so forward references get resolved eventually. Also, assembler labels are not kept in target memory, so they have no problems with multiple passes. This setup works because headers do NOT use code space. If code and headers are to be mixed, a way must be found to keep the header info intact on the higher passes. (Actually, this is just a simple adjustment of the CP.) See TMETA (transputer) where headers are fixed, but the code wanders between passes because of optimization (shorter addresses). *) ENDDOC 0 VALUE #mpass PRIVATE -- which (meta compiler) pass is this? 0 VALUE -finished PRIVATE : ONE-MORE 1 +TO -finished ; PRIVATE \ found a changing reference. : T?HEADER DUP >S \ --- | TNAME2? DUP #mpass 0= AND IF ." Redefinition ?! " S> TCOUNT =MASK AND TTYPE ELSE -S ENDIF ; PRIVATE -- Note that T$,n does NOT yet advance/manipulate THERE. (but it changes TNP) -- TNP --> [counter][flags][entry][c:data|0][c:cfa][i:cfa][lfa][nfa] 0 VALUE last_tnfa PRIVATE $FFFF VALUE =tinfo= PRIVATE : TI/O SWAP $0F UMIN $0F AND 4 LSHIFT ( n1 n2 -- ) SWAP $0F UMIN $0F AND OR =tinfo= $FFFFFF00 AND OR TO =tinfo= ; : T@/! SWAP $0F UMIN $0F AND 4 LSHIFT ( n1 n2 -- ) SWAP $0F UMIN $0F AND OR 8 LSHIFT =tinfo= $FFFF00FF AND OR TO =tinfo= ; -- [ 2ATLEAST TENTRY! ] etc. : TENTRY: THERE last_tnfa TNAME>ENTRY T! ; : T$,n DUP TC@ ( taddr[name] -- ) IF T?HEADER ( -- nfa bool ) OVER TO last_tnfa IF DUP >S TNAME>ICODE DUP T@ >S \ save old code pointer THERE SWAP T! \ update code pointer THERE S> <> IF ONE-MORE \ not finished! #mpass 3 \ You don't want when optimizing > IF S CR ." Transient: " TCOUNT =MASK AND TTYPE ENDIF ENDIF -S EXIT ENDIF \ header built, pass > 1 DUP TO TLAST \ ( for TUNVEIL ) TEVEN THERE SWAP TLINK> \ TCURRENT T@ \ SWAP T! \ ( -- cp ) TLAST TNAME>INFO !TNP TLAST TNAME>ICODE T! 0 TLAST TNAME>ENTRY T! 0 TLAST TNAME>TRACE T! =tinfo= TLAST TNAME>INFO T! $FFFF TO =tinfo= CR ." name: " TLAST TCOUNT =MASK AND TTYPE EXIT ENDIF TRUE ABORT" name not unique" ; PRIVATE -- It isn't necessary to inhibit TUNVEIL on passes > 0 as TLAST and TCURRENT -- won't change then. : TUNVEIL TLAST TCURRENT T! ; PRIVATE \ 'admit' the new name : ?PAIRS ( n1 n2 -- ) <> ABORT" META: Structure not balanced" ; VOCABULARY LABELS ' LABELS >BODY =: PRIVATE -- Forward reference to anything, but especially to a label: use " T' label " -- Note that it is possible to use T' and EQU's too. Because not everybody -- will like that behavior, T# is provided as a synonym. : do-equ CREATE $DEADBEEF , , \ --- <> DOES> CELL+ @ ; PRIVATE \ <> --- : EQU >IN @ >S \ --- <> $20 SEARCH-WORDLIST IF >BODY DUP @ $DEADBEEF <> ABORT" That's no LABEL or EQU" CELL+ ! -S EXIT ENDIF S> >IN ! ALSO GET-CURRENT LABELS DEFINITIONS SWAP ( n) do-equ SET-CURRENT PREVIOUS ; : LABEL TCP EQU ; \ <> --- <> : | LABEL ; \ <> --- <> : LABEL? HEAD> @ >BODY @ $DEADBEEF = ; \ --- : DOTS SPACE 1- 0 MAX 0 ?DO '.' EMIT LOOP SPACE ; PRIVATE -- Print all labels ( for debugging) : .TLABELS C/L #80 > IF 3 ELSE 2 ENDIF LOCAL lcols 0 LOCAL col# BEGIN @ ?DUP WHILE DUP LABEL? IF col# 0= IF CR lcols 1- TO col# ELSE 2 SPACES -1 +TO col# ENDIF DUP ID$ TYPE 1+ DOTS DUP HEAD> @ >BODY CELL+ @ H. ENDIF HEAD>LINK WAIT? UNTIL DROP THEN CR ; -- Hidden CODE definitions, see also H: H; : HC: LABEL ( "name" -- ) ALSO XASM ALSO LABELS ; : ;HC PREVIOUS PREVIOUS ; : TCODE $10 TTOKEN T$,n ( -- sys ) ALSO XASM ALSO LABELS ; : TEND-CODE $10 ?PAIRS TUNVEIL ;HC ; ( sys -- ) -- If we use the following values, we don't need EVAL tricks. -- (clunky, but it works. These values must be set in the target source file) 0 VALUE 'doCONST 0 VALUE 'doVAR 0 VALUE 'doUSER 0 VALUE 'c:CON 0 VALUE 'c:VAR 0 VALUE 'c:USR 0 VALUE 'doVOC 0 VALUE 'doLIT 0 VALUE 'doDOES 0 VALUE 'S"| 0 VALUE '."| 0 VALUE 'abort" 0 VALUE 'C"| 0 VALUE 's"| 0 VALUE 'do>>, 0 VALUE 'next 0 VALUE '?bra 0 VALUE 'unloop 0 VALUE 'R> 0 VALUE '>R 0 VALUE 'doCOMPILE, 0 VALUE '(do) 0 VALUE '(loop) 0 VALUE '(+loop) 0 VALUE 'c:INL 0 VALUE 'i:LST 0 VALUE 'do$COMPILE : TCALL, =CALLB TC, \ --- <> THERE TCELL+ - T, ; : TXCALL, =CALL T, THERE TCELL+ - T, ; \ --- <> : TWCALL, THERE DUP TALIGNED \ --- <> = IF TXCALL, ELSE TEVEN -1 TALLOT TCALL, ENDIF ; : TSTART: TTOKEN T$,n ; \ TSTART: ## \ only used by { T: } : THEADER: TSTART: TUNVEIL ; \ THEADER ## : (MACRO) #mpass ?EXIT ( -- ) TLAST TC@ =MACRO OR TLAST TC! ; PRIVATE -- If ROMmed, VARIABLE's, CREATE'd things, and 'ers don't work! -- This is preferably handled with a CPU register (like DI for USER's). : TCREATE THEADER: (MACRO) \ TCREATE ## THERE 'doVAR TWCALL, ( there) last_tnfa TNAME>ICODE T! 'c:VAR last_tnfa TNAME>CCODE T! THERE last_tnfa TNAME>CDATA T! ; : TVARIABLE TCREATE 0 T, ; \ TVARIABLE ## : TUSER THEADER: (MACRO) \ TUSER ## THERE 'doUSER TWCALL, ( there) last_tnfa TNAME>ICODE T! 'c:USR last_tnfa TNAME>CCODE T! THERE last_tnfa TNAME>CDATA T! ( offset) T, ; : TCONSTANT THEADER: (MACRO) \ TCONSTANT ## THERE 'doCONST TWCALL, ( there) last_tnfa TNAME>ICODE T! 'c:CON last_tnfa TNAME>CCODE T! THERE last_tnfa TNAME>CDATA T! ( value) T, ; : T?USER DUP /UP U> \ --- <> ABORT" User area overflow." CR UDEC. ." bytes in User Table. " ; : T$," '"' THERE TPACK$ TC@ 1+ TALLOT ( *** TEVEN ) ; PRIVATE : T$,~ '~' THERE TPACK$ TC@ 1+ TALLOT ( *** TEVEN ) ; PRIVATE -- It is necessary to inhibit TIMMEDIATE and TCOMPILE-ONLY on passes > 0 as -- TLAST and TCURRENT won't change then --> TCOMPILE-ONLY always works on -- the last def.... : TIMMEDIATE #mpass ?EXIT \ <> --- <> TLAST TC@ =IMED OR TLAST TC! ; : TCOMPILE-ONLY #mpass ?EXIT \ <> --- <> TLAST TC@ =COMP OR TLAST TC! ; DOC The Meta Interpreter loop. (* Within a high-level definition, the first vocabulary in the search order is TEXECUTABLES, which contains { T; IF ELSE ENDIF BEGIN WHILE } etcetera. If { [ } is encountered, the search order reverts to the one in effect outside definitions. Whenever a word is not in TEXECUTABLES, we attempt { T' T, }. If this fails, { TNUMBER, } gets executed. If a word is NOT a number, at this stage it must be a headerless target definition. *) ENDDOC 0 VALUE PRIVATE -- TEXECUTABLES not yet defined. 0 VALUE ?in.tword PRIVATE -- Are we compiling a high level target word? -- Note that META allows case-sensitive headerless definitions : HEADERLESS? 2DUP SEARCH-WORDLIST \ -- IF NIP NIP EXECUTE ELSE CR EOL ." Forward reference : " TYPE ONE-MORE -1 ENDIF ; PRIVATE : T' TTOKEN TNAME? ?EXIT \ <> --- DUP TC@ 1+ PAD TARGET>HOST PAD COUNT HEADERLESS? ; : TLITERAL, 'doLIT TCALL, T, ; : Number|Name, NUMBER? \ --- <> CASE 0 OF HEADERLESS? TCALL, ENDOF \ headerless or fwd.ref 1 OF TLITERAL, ENDOF 2 OF SWAP TLITERAL, TLITERAL, ENDOF ENDCASE ; PRIVATE -- Can't work: the target code moves constantly, so we can't get "past-pass" strings from it. : TINLINE TCOUNT BOUNDS ?DO I TC@ TC, LOOP ; PRIVATE \ --- <> -- For :inline words we can not use NAME>ICODE because that way there is -- infinite recursion (e.g. DUP, an inlined word, is used). : CHANDLE ( nfa -- ) DUP TNAME>ICODE T@ 0<> OVER TNAME>CCODE T@ 0<> AND OVER TNAME>CDATA T@ 0<> AND IF DUP TNAME>ICODE T@ 'i:LST = IF TNAME>CDATA T@ TCELL+ T@ ( inline is special) ELSE TNAME>ICODE T@ ENDIF ELSE TNAME>ICODE T@ ENDIF TCALL, ; PRIVATE CREATE temp_buffer #130 ALLOT PRIVATE : MEEVAL 2DUP SEARCH-WORDLIST \ --- <> IF NIP NIP EXECUTE \ looks ONLY in TEXECUTABLES ELSE 2DUP temp_buffer PACK DROP =TIB OVER TCELL + TERASE =TIB TPACK$ TNAME? DUP IF NIP CHANDLE ELSE 2DROP temp_buffer COUNT Number|Name, ENDIF ENDIF ; PRIVATE -- Fetch words inside T: ... T; etcetera : DO-META BEGIN \ <> --- <> BL DUP WHILE MEEVAL ?in.tword 0= IF EXIT \ after [ or T; etcetera ENDIF REPEAT 2DROP ; PRIVATE : READ-STREAM END-STREAM? \ <> --- <> IF REFILL 0= ABORT" READ-STREAM : no data" ENDIF ; PRIVATE -- In META , this is the same word as ] : MetaCompiler TRUE TO ?in.tword BEGIN READ-STREAM ['] DO-META CATCH ?DUP IF FALSE TO ?in.tword THROW \ to higher level ENDIF ?in.tword 0= UNTIL ; PRIVATE : mgather, mexits \ ( target -- ) BEGIN DUP \ walk along the linked list WHILE DUP T@ THERE ROT T! REPEAT TO mexits DROP ; PRIVATE : mrake, THERE #30 - mleaves \ ( -- ) BEGIN 2DUP U< \ walk along the linked list WHILE DUP T@ THERE ROT T! REPEAT TO mleaves DROP ; PRIVATE : (T:) $11 TSTART: \ (T:) "string" -- TRUE TO ?in.tword CLEAR mleaves CLEAR mexits ; PRIVATE : T: (T:) MetaCompiler ; \ <> T: ## --> <> : T; FALSE TO ?in.tword $11 ?PAIRS THERE mgather, =RETB TC, TUNVEIL mleaves ABORT" mleaves :: not consumed" mexits ABORT" mexits :: not consumed" ; : T;I T; TIMMEDIATE ; -- Synonyms -- Syntax: T: CLS $CLS .$ T; -- S: PAGE CLS S; \ do not add text behind `CLS' !! : S: $13 TRUE TO ?in.tword #mpass IF THEAD' TNAME>INFO THEAD' TNAME>INFO =#HSZ 1- TCELLS BOUNDS DO I T@ SWAP T!+ TCELL +LOOP DROP EXIT ENDIF TSTART: TUNVEIL THEAD' DUP TNAME> T@ ( cp) TLAST TNAME> T! TC@ =MASK INVERT AND ( attr) TLAST TC@ =MASK AND OR TLAST TC! ; : S; FALSE TO ?in.tword $13 ?PAIRS ; -- Headerless target definitions : H: $12 LABEL \ <> H: ## --> <> MetaCompiler ; : H; FALSE TO ?in.tword $12 ?PAIRS THERE mgather, =RETB TC, mleaves ABORT" mleaves :: not consumed" mexits ABORT" mexits :: not consumed" ; : ] TRUE TO ?in.tword \ not immediate, pair with '[' MetaCompiler ; : TMACRO TCODE (MACRO) \ "name" "smart-code" -- <> T' last_tnfa TNAME>CCODE T! ; : T:MAC (T:) (MACRO) \ "string" -- T' last_tnfa TNAME>CCODE T! MetaCompiler ; 0 VALUE 'inline-maximum : T:INLINE $11 TSTART: (MACRO) ( "name" -- ) THERE 'i:LST TWCALL, ( there) last_tnfa TNAME>ICODE T! 'c:INL last_tnfa TNAME>CCODE T! THERE last_tnfa TNAME>CDATA T! 'inline-maximum T, THERE >R 0 T, \ space for exec. vector ';' MULTI-LINE ( -- addr u ) \ get definition string ... DUP T, THERE OVER TALLOT T>H SWAP MOVE \ ... place it THERE R@ T! \ set exec. vector CLEAR mleaves CLEAR mexits R> CELL+ T@+ SWAP T>H SWAP S" T; " $+ ['] MetaCompiler $PROCESS ; \ compile the string contents : C/I: $11 TSTART: \ "name" "smart-code" -- <> (MACRO) \ compile/interpret is slow when executed: 1 jump extra T' last_tnfa TNAME>CCODE T! TRUE TO ?in.tword MetaCompiler ; : INLINE TCP 0 TC, \ <> --- ALSO XASM FALSE TO ?in.tword ; PRIVATE : >>, TCP OVER 1+ - \ --- <> SWAP TC! 'do>>, TCALL, PREVIOUS ] ; -- Simple decompiler toolkit. : T>NAME TCURRENT \ --- | <0> BEGIN T@ DUP WHILE 2DUP TNAME> T@ XOR WHILE TCELL- REPEATED ; : T.ID$ DUP 0<> IF T>H \ --- <> COUNT =MASK AND DUP >S TYPE #16 S> - DOTS ELSE DROP ." {no name} ......." ENDIF ; : T.ID DUP 0<> IF TCOUNT \ --- <> =MASK AND TTYPE ELSE DROP ." {no name}" ENDIF ; : tOffs>Addr TCELL+ + ; \ --- : .ADDR >S TYPE S> TCELL+ T@ H. ; : til-lit DUP >R tOffs>Addr >S \ --- S 'next = DUP IF S" NEXT " R@ .ADDR ENDIF S '?bra = DUP IF S" ?BRANCH " R@ .ADDR ENDIF OR S '(loop) = DUP IF S" LOOP " R@ .ADDR ENDIF OR S '(+loop) = DUP IF S" +LOOP " R@ .ADDR ENDIF OR S> 'doLIT = DUP IF R@ TCELL+ T@ DEC. ENDIF OR -R ; : til-string tOffs>Addr >S \ --- S 'S"| = DUP IF ." S" ENDIF S 's"| = DUP IF ." s" ENDIF OR S 'C"| = DUP IF ." C" ENDIF OR S '."| = DUP IF ." ." ENDIF OR S> 'abort" = DUP IF ." ABORT" ENDIF OR ; : TUN BEGIN DUP CR H. ." : " \ --- <> DUP TC@ =RETB = IF 1+ ." ; " BREAK? ELSE DUP TC@ =CALLB <> IF TC@+ B. ELSE 1+ DUP T@ OVER til-string IF TCELL+ DUP '"' EMIT T.$ '"' EMIT TCOUNT + ( *** TALIGNED ) ELSE DUP T@ OVER til-lit IF TCELL+ ELSE DUP T@ OVER tOffs>Addr T>NAME DUP IF T.ID DROP ELSE DROP ." call-> " H. ENDIF ENDIF TCELL+ ENDIF ENDIF WAIT? ENDIF UNTIL DROP ; : TSEE T' \ <> TSEE ## --> <> DUP CR H. ." : " DUP T>NAME ." : " T.ID DROP TUN ; : TIDIS T>H idis ; \ --- <> : TDIS T' TIDIS ; \ <> TDIS ## --> <> : TINFO' T' T>NAME NIP ( "name" -- ) CR ." name = `" DUP T.ID &' EMIT CR ." link = `" DUP TLINK> T@ T.ID &' EMIT CR ." i:xt = " DUP TNAME>ICODE T@ H. CR ." c:xt = " DUP TNAME>CCODE T@ H. CR ." data = " DUP TNAME>CDATA T@ H. CR ." entry = " DUP TNAME>CDATA T@ H. CR ." trace = " DUP TNAME>TRACE T@ H. CR ." info = [" TNAME>INFO T@ DUP $F000 AND IF '@' ELSE '_' ENDIF EMIT ',' EMIT DUP $0F00 AND IF '!' ELSE '_' ENDIF EMIT ',' EMIT DUP $00F0 AND 4 RSHIFT ." in:" 0DEC.R ',' EMIT $000F AND ." out:" 0DEC.R ']' EMIT ; : .TWORDS \ <> --- <> C/L #80 > IF 3 ELSE 2 ENDIF LOCAL lcols 0 LOCAL col# 0 LOCAL count'm TCURRENT BEGIN T@ DUP WHILE col# 0= IF CR lcols 1- TO col# ELSE 2 SPACES -1 +TO col# ENDIF 1 +TO count'm DUP SPACE T.ID$ DUP TNAME> T@ H. TLINK> WAIT? ?REPEATED DROP CR count'm DUP DEC. ." target name" ?s '.' EMIT ; : HOST ONLY FORTH ALSO XASM ALSO META ; : INIT.META =MAXADDR =LOC - TO =asize XINIT @EXECUTE ( init xasm ) =ORG ORG =LOC LOC 0 TCURRENT T! =NP !TNP CLEAR TLAST CLEAR ?in.tword CLEAR #mpass ; DOC (* Next words are substitutes for IMMEDIATE target words. (Because target code can never ever execute on the host machine). Make sure the target does NOT use lower case versions of the names in TEXECUTABLES . mxForth is case-insensitive and will execute the TEXECUTABLE upper case word, which is probably not what you intended. POSTPONE DOES> VARIABLE VALUE =: CONSTANT USER ?DO UNLOOP ;CODE : ; CODE END-CODE TO [CHAR] [CTRL] are not supported. POSTPONE COMPILE [COMPILE] DOES> ? VARIABLE TVARIABLE CONSTANT TCONSTANT =: ? USER TUSER ?DO ? UNLOOP ? ;CODE ? : T: H: ( headerless) S: ( synonym) ; T; T;I H; S; CODE TCODE END-CODE TEND-CODE TO ? [CHAR] [CTRL] the interpreter uses XNUMBER, you don't need them It would not be difficult to support almost all of these, but I originally thought the source would become too confusing. In retrospect, the only real problem are those words that can be used interpretively, like VARIABLE CONSTANT =: USER : CODE END-CODE TO . It seems that the only two serious cases here are { =: TO }, the others aren't very useful when metacompiling. *) ENDDOC VOCABULARY TEXECUTABLES ALSO TEXECUTABLES DEFINITIONS ' TEXECUTABLES >BODY TO \ resolve forward in MetaCompiler ' [IF] SYNONYM [IF] ' [ELSE] SYNONYM [ELSE] ' [THEN] SYNONYM [THEN] -- Define THEN before anything else, so THENCE uses the right word. : THEN THERE SWAP T! ; \ --- <> : THENCE DEPTH 0= ABORT" Case statement unbalanced" >S BEGIN DEPTH WHILE S OVER U< WHILE ( TEXECUTABLES!) THEN REPEATED -S ; : ( POSTPONE ( ; IMMEDIATE : \ POSTPONE \ ; IMMEDIATE : [ FALSE TO ?in.tword ; : [COMPILE] T' TCALL, ; : LITERAL 'doLIT TCALL, T, ; \ --- <> : ['] T' LITERAL ; \ <> ['] ## --> <> : COMPILE ['] 'doCOMPILE, TCALL, ; : POSTPONE THEAD' LITERAL ( "name" -- ) 'do$COMPILE TCALL, ; : BEGIN THERE ; \ <> --- : FOR '>R TCALL, BEGIN ; \ <> --- : NEXT 'next TCALL, T, ; \ --- <> : UNTIL '?bra TCALL, T, ; \ --- <> : IF '?bra TCALL, BEGIN 0 T, ; \ <> --- : AGAIN 0 LITERAL '?bra TCALL, T, ; \ --- <> : AHEAD 0 LITERAL IF ; \ <> --- : DO '(do) TCALL, BEGIN ; \ <> --- No ?DO : LOOP '(loop) TCALL, T, mrake, ; \ --- <> : +LOOP '(+loop) TCALL, T, mrake, ; \ --- <> : UNLOOP 'unloop TCALL, ; \ ( -- ) : LEAVE 'unloop TCALL, 0 LITERAL '?bra TCALL, \ leaves set in { : ; } THERE mleaves T, TO mleaves ; \ build linked list in place : REPEAT AGAIN THEN ; \ --- <> : ENDIF THEN ; \ --- <> : AFT DROP AHEAD BEGIN SWAP ; \ --- : ELSE AHEAD SWAP THEN ; \ --- : WHILE IF SWAP ; \ --- : EXIT 0 LITERAL '?bra TCALL, \ mexits set in { : ; } THERE mexits T, \ build linked list in place TO mexits ; : CASE BEGIN ; \ <> --- : OF S" OVER" MEEVAL \ <> --- S" =" MEEVAL IF S" DROP" MEEVAL ; : ENDOF ELSE SWAP ; \ --- : ENDCASE S" DROP" MEEVAL THENCE ; : S" 'S"| TCALL, T$," ; \ <> $" ## --> <> : S~ 'S"| TCALL, T$,~ ; \ <> $" ## --> <> : C" 'C"| TCALL, T$," ; \ <> $" ## --> <> : C~ 'C"| TCALL, T$,~ ; \ <> $" ## --> <> : ." '."| TCALL, T$," ; \ <> ." ## --> <> : .~ '."| TCALL, T$,~ ; \ <> ." ## --> <> : ASM<< 's"| TCALL, INLINE ; \ <> ASM<< opcodes >> --> <> : ABORT" 'abort" TCALL, T$," ; \ <> ABORT" ## --> <> : RECURSE TUNVEIL ; : DOES> 'doDOES TCALL, 'R> TCALL, ; : T; T; ; \ only TEXECUTABLES are searched! : T;I T;I ; : H; H; ; : S; S; ; : CHARS NOOP ; ONLY FORTH ALSO XASM ALSO META ALSO FORTH DEFINITIONS : TARGET INIT.META ONLY FORTH ALSO META ALSO XASM ALSO META DEFINITIONS ; CREATE mname $84 ALLOT PRIVATE : BUILD.LCMD BL $80 MIN mname PACK DROP ; PRIVATE -- Number of passes MUST BE ONE HIGHER then META thinks: -- not all label-needing words [might] update -finished ! 0 VALUE ready! PRIVATE : finished? -finished \ <> --- 0= IF 1 +TO ready! ENDIF ready! 1 > ; PRIVATE : .INFO EOS \ <> --- <> CR TCP =LOC - U. ." bytes CODE used, " =/CODE U. ." were allocated." CR =MAXADDR TNP - U. ." bytes DATA used, " =/DATA U. ." were allocated." CR -finished DUP DEC. ." transient reference" ?s '.' EMIT DEPTH ?DUP IF CR DUP DEC. ." item" ?s ." on the stack?" ENDIF CR UNUSED DEC. ." host bytes free." CR ." Target has at least " TNP TCP - DEC. ." bytes free." ; : PROGRAM BL 2DROP \ <> PROGRAM ## CLEAR -finished ; : ENDS CR .INFO ; : METACOMPILE TIMER-RESET \ METACOMPILE ## --> <> BUILD.LCMD FALSE TO ready! BEGIN =LOC SET-THERE \ Note: don't reset DataPointer mname COUNT INCLUDED CR ." Meta pass #" #mpass 2+ DEC. ." busy..." 1 +TO #mpass finished? KEY? OR UNTIL KEY? IF KEY DROP TRUE ABORT" META aborted by user" ENDIF CR .ELAPSED ; : SAVE.TARGET -finished \ SAVE.TARGET ## --> <> IF /PARSE 2DROP ELSE /PARSE R/W BIN CREATE-FILE ABORT" Cannot create output file" >S =LOC T>H =MAXIMUM S WRITE-FILE ABORT" write fault" S> CLOSE-FILE ABORT" Cannot close output file" CR =MAXIMUM U. ." code bytes saved." ENDIF ; : SYMBOLTABLE CR .SIGNON CR CR ." *** SYMBOL TABLE ***" CR ." Meta compiling: " .ELAPSED CR ." Time now: " .TIME$ CR CR ." [ LABELS ]" CR .TLABELS CR ." [ WORDS ]" CR .TWORDS CR ; ONLY FORTH ALSO XASM ALSO META DEFINITIONS DEPRIVE WARNING ON (* End of source *)