T3XFORTH Meta Compiler
\ T3XFORTH Meta Compiler
\ Nils M Holm, 2021
\ In the public domain / under the CC0 license
\ This is a very simple compiler for a subset of T3XFORTH that
\ is barely sufficient to bootstrap the high−level part of the
\ T3XFORTH kernel. It does not include an assembler; the CODE
\ words are copied from the kernel running the meta compiler.
VOCABULARY META−COMPILER META−COMPILER DEFINITIONS
\ Where the system sources reside
: SOURCE−BLOCKS ( −− u1 u2 ) 70 119 ;
\ Where to put the new kernel
[HEX] 6000 CONSTANT KERNEL−SPACE
\ Reserved memory at bottom of address space
256 CONSTANT RESERVED
\ Flags
[HEX] 80 CONSTANT IMMEDIATE−FLAG
[HEX] 40 CONSTANT COMP−ONLY−FLAG
VARIABLE DICTIONARY \ Dictionary of new kernel
\ For caching frequently−used words
VARIABLE DOCOLON VARIABLE DODO
VARIABLE DOVAR VARIABLE DOLOOP
VARIABLE DOCONST VARIABLE DO+LOOP
VARIABLE DOBRANCH VARIABLE DO/LOOP
VARIABLE DO0BRANCH VARIABLE DOEXIT
VARIABLE DOLIT
VARIABLE DO$" VARIABLE DOABORT"
VARIABLE RESETVEC \ See RESET in T3XFORT?.S86
VARIABLE M−H \ Kernel space HERE pointer
\ Is the word at NFA a CODE word?
: ?CODE ( nfa −− f ) DUP >PFA SWAP >CFA @ = ;
\ Find NFA and end of last CODE word in memory
: LAST−CODE−WORD ( −− nfa a )
(FORTH) @ DUP >LFA @ BEGIN DUP WHILE
DUP ?CODE IF EXIT THEN
SWAP >LFA @ SWAP >LFA @ REPEAT ;
\ Copy T3XFORTH VM to bottom of kernel space
: COPY−CODE ( −− ) LAST−CODE−WORD KERNEL−SPACE + DICTIONARY !
0 KERNEL−SPACE ROT DUP >R CMOVE
R> KERNEL−SPACE + DUP M−H ! 5 − RESETVEC ! ;
\ Report compilation error in the form
\ META−COMPILER: a1: a2
\ and then abort; if A1 is 0, ignore it.
: ERROR ( a1 a2 −− ) CR ." META−COMPILER: " COUNT TYPE
?DUP IF ." : " COUNT TYPE THEN CR ABORT ;
\ Look up word in kernel space
: M−LOOKUP ( a −− a T | F ) DUP UPCASE DICTIONARY @
KERNEL−SPACE − BEGIN ?DUP WHILE KERNEL−SPACE +
2DUP ?SAME IF NIP KERNEL−SPACE − −1 EXIT THEN
>LFA @ REPEAT DROP 0 ;
: NOT−FOUND ( −− ) $" NOT FOUND" ERROR ;
\ Find word in kernel space, fail when not found.
\ Return PFA upon success.
: M−FIND ( a −− a ) DUP M−LOOKUP IF NIP >CFA EXIT THEN
NOT−FOUND ;
\ String containing $"
: $"−STR ( −− a ) $" $x" [CHAR] " OVER 2 + C! ;
\ String containing ($")
: ($")−STR ( −− a ) $" ($x)" [CHAR] " OVER 3 + C! ;
\ String containing ABORT"
: ABORT"−STR ( −− a ) $" ABORTx" [CHAR] " OVER 6 + C! ;
\ String containing (ABORT")
: (ABORT")−STR ( −− a ) $" (ABORTx)" [CHAR] " OVER 7 + C! ;
\ The following words resemble T3XFORTH words, but write
\ to kernel space instead of the regular dictionary space
: M−HERE ( −− a ) M−H @ ;
: M−ALLOT ( u −− ) M−H +! ;
: M−C, ( −− ) M−H @ C! 1 M−H +! ;
: M−, ( −− ) M−H @ ! 2 M−H +! ;
VARIABLE M−LAST
: M−CREATE ( −− ) BL WORD DUP ENTRY M−HERE 6 CMOVE
6 M−ALLOT DICTIONARY @ KERNEL−SPACE − M−, DOVAR @ M−,
M−HERE >NFA M−LAST ! ;
: M−LINK ( −− ) M−LAST @ DICTIONARY ! ;
: M−; ( −− ) DOEXIT @ M−, M−LINK ;
: M−MARK ( −− a ) M−HERE 0 M−, ;
: M−RESOLVE ( a −− ) M−HERE KERNEL−SPACE − SWAP ! ;
: M−IF ( −− a ) DO0BRANCH @ M−, M−MARK ;
: M−ELSE ( −− a ) DOBRANCH @ M−, M−MARK SWAP M−RESOLVE ;
: M−THEN ( a −− a ) M−RESOLVE ;
: M−BEGIN ( −− a ) M−HERE KERNEL−SPACE − ;
: M−AGAIN ( a −− ) DOBRANCH @ M−, M−, ;
: M−WHILE ( a −− ) M−IF ;
: M−REPEAT ( a −− ) DOBRANCH @ M−, SWAP M−, M−RESOLVE ;
: M−UNTIL ( a −− ) DO0BRANCH @ M−, M−, ;
: M−DO ( −− a ) DODO @ M−, M−HERE KERNEL−SPACE − ;
: M−LOOP ( −− a ) DOLOOP @ M−, M−, ;
: M−+LOOP ( −− a ) DO+LOOP @ M−, M−, ;
: M−/LOOP ( −− a ) DO/LOOP @ M−, M−, ;
: M−LITERAL ( w −− ) DOLIT @ M−, M−, ;
\ Change CFA of most recently CREATEd word
: SET−CODE ( a −− ) M−H @ >NFA >CFA M−H ! M−, ;
: M−VARIABLE ( −− ) M−CREATE 0 M−, M−LINK ;
: M−CONSTANT ( w −− ) M−CREATE DOCONST @ SET−CODE M−, M−LINK ;
: M−' ( −− a ) BL WORD DUP M−LOOKUP IF NIP >PFA EXIT THEN
NOT−FOUND ;
: M−DEFER ( −− ) M−CREATE DOCOLON @ SET−CODE 0 M−,
DOEXIT @ M−, M−LINK ;
: M−IS ( −− )
M−LAST @ KERNEL−SPACE − >CFA M−' KERNEL−SPACE + ! ;
: COMP−STRING ( a −− ) M−HERE OVER C@ 1+ CMOVE
M−HERE C@ 1+ M−ALLOT ;
: M−$" ( −− ) DO$" @ 0= IF ($")−STR M−FIND DO$" ! THEN
DO$" @ M−, [CHAR] " WORD COMP−STRING ;
: M−ABORT" ( −− ) DOABORT" @ 0= IF
(ABORT")−STR M−FIND DOABORT" ! THEN
DOABORT" @ M−, [CHAR] " WORD COMP−STRING ;
\ Set flags of most recently CREATEd word
: SET−FLAG ( w −− ) M−LAST @ C@ OR M−LAST @ C! ;
: M−IMMEDIATE ( −− ) IMMEDIATE−FLAG SET−FLAG ;
: M−COMP−ONLY ( −− ) COMP−ONLY−FLAG SET−FLAG ;
: M−[HEX] ( −− w ) [COMPILE] [HEX] ;
: M−[CHAR] ( −− c ) [COMPILE] [CHAR] M−LITERAL ;
: M−['] ( −− ) M−' M−LITERAL ;
: M−[COMPILE] ( −− ) M−' PFA>CFA M−, ;
\ Store in kernel space
: M−! ( w a −− ) KERNEL−SPACE + ! ;
\ Are two packed strings equal? Leave A1 on stack
: =WORD ( a1 a2 −− a1 f ) OVER DUP C@ 1+ PAD SWAP CMOVE
PAD UPCASE PAD DUP C@ 1+ ROT −TEXT 0= ;
\ Compile word at NFA, report error if immediate;
\ "A" is a packed string naming the word.
: COMP ( a nfa −− a )
DUP KERNEL−SPACE + C@ IMMEDIATE−FLAG AND IF
OVER $" UNKNOWN IMMEDIATE" ERROR THEN >CFA M−, ;
\ Kernel−space colon compiler, continued
: M3−: ( −− )
$"−STR =WORD IF DROP M−$" ELSE
$" [CHAR]" =WORD IF DROP M−[CHAR] ELSE
$" [HEX]" =WORD IF DROP M−[HEX] M−LITERAL ELSE
$" [COMPILE]" =WORD IF DROP M−[COMPILE] ELSE
ABORT"−STR =WORD IF DROP M−ABORT" ELSE
DUP M−LOOKUP IF COMP DROP ELSE
DUP ?NUMBER IF M−LITERAL DROP ELSE
NOT−FOUND
THEN THEN THEN THEN THEN THEN THEN ;
\ Kernel−space colon compiler, continued
: M2−: ( −− )
$" BEGIN" =WORD IF DROP M−BEGIN ELSE
$" AGAIN" =WORD IF DROP M−AGAIN ELSE
$" UNTIL" =WORD IF DROP M−UNTIL ELSE
$" WHILE" =WORD IF DROP M−WHILE ELSE
$" REPEAT" =WORD IF DROP M−REPEAT ELSE
$" +LOOP" =WORD IF DROP M−+LOOP ELSE
$" /LOOP" =WORD IF DROP M−/LOOP ELSE
$" [']" =WORD IF DROP M−['] ELSE
M3−:
THEN THEN THEN THEN THEN THEN THEN THEN ;
\ Kernel−space colon compiler
: M−: ( −− ) M−CREATE DOCOLON @ SET−CODE
BEGIN BL WORD DUP C@ WHILE
$" (" =WORD IF DROP [COMPILE] ( ELSE
$" \" =WORD IF DROP [COMPILE] \ ELSE
$" ;" =WORD IF DROP M−; EXIT ELSE
$" IF" =WORD IF DROP M−IF ELSE
$" THEN" =WORD IF DROP M−THEN ELSE
$" ELSE" =WORD IF DROP M−ELSE ELSE
$" DO" =WORD IF DROP M−DO ELSE
$" LOOP" =WORD IF DROP M−LOOP ELSE
M2−:
THEN THEN THEN THEN THEN THEN THEN THEN
REPEAT DROP ;
\ Metacircular interpreter, continued
: M2−INTERPRET ( −− )
$" '" =WORD IF DROP M−' ELSE
$" !" =WORD IF DROP M−! ELSE
$" DEFER" =WORD IF DROP M−DEFER ELSE
$" IS" =WORD IF DROP M−IS ELSE
$" >NFA" =WORD IF DROP >NFA ELSE
DUP ?NUMBER IF NIP ELSE
NOT−FOUND
THEN THEN THEN THEN THEN THEN ;
\ Metacircular interpreter
: M−INTERPRET ( −− ) BEGIN BL WORD DUP C@ WHILE
$" (" =WORD IF DROP [COMPILE] ( ELSE
$" \" =WORD IF DROP [COMPILE] \ ELSE
$" :" =WORD IF DROP M−: ELSE
$" IMMEDIATE" =WORD IF DROP M−IMMEDIATE ELSE
$" COMPILE−ONLY"
=WORD IF DROP M−COMP−ONLY ELSE
$" VARIABLE" =WORD IF DROP M−VARIABLE ELSE
$" CONSTANT" =WORD IF DROP M−CONSTANT ELSE
$" [HEX]" =WORD IF DROP M−[HEX] ELSE
M2−INTERPRET
THEN THEN THEN THEN THEN THEN THEN THEN
REPEAT DROP ;
\ Load and meta−interpret block
: M−LOAD ( u −− )
BLK @ >R >IN @ >R #TIB @ >R ACTIVE @ >R
DUP BLOCK DROP BLK ! B/BUF #TIB ! 0 >IN !
M−INTERPRET
R> ACTIVE ! R> #TIB ! R> >IN ! R> BLK ! ;
\ Initial state setup
: SETUP ( −− ) PAD B/BUF + KERNEL−SPACE U> IF
0 $" TOO LITTLE SPACE" ERROR THEN COPY−CODE
$" (COLON)" M−FIND CFA>PFA DOCOLON !
$" (VAR)" M−FIND CFA>PFA DOVAR !
$" (CONST)" M−FIND CFA>PFA DOCONST !
$" (BRANCH)" M−FIND DOBRANCH !
$" (0BRANCH)" M−FIND DO0BRANCH !
$" (LIT)" M−FIND DOLIT !
$" (DO)" M−FIND DODO !
$" (LOOP)" M−FIND DOLOOP !
$" (+LOOP)" M−FIND DO+LOOP !
$" (/LOOP)" M−FIND DO/LOOP !
$" EXIT" M−FIND DOEXIT ! ;
\ Set kernel−space variable at A2 to image address A1
: SET−VAR ( a1 a2 −− ) M−FIND KERNEL−SPACE + CFA>PFA
SWAP KERNEL−SPACE − SWAP ! ;
\ Initialize variables and reset vector of the new kernel
: INIT−VARS ( −− ) M−HERE $" H" SET−VAR
DICTIONARY @ $" (FORTH)" SET−VAR
$" RESET" M−FIND CFA>PFA RESETVEC @ ! ;
\ Meta compiler
: BUILD−SYSTEM ( −− ) SETUP
SOURCE−BLOCKS 1+ SWAP DO I . I M−LOAD LOOP INIT−VARS ;
: IMAGE−SIZE ( −− ) M−HERE KERNEL−SPACE − RESERVED − ;
\ Write kernel to system blocks
: DUMP−SYSTEM ( u −− )
M−HERE KERNEL−SPACE − RESERVED − B/BUF 1− + B/BUF / 0 DO
I B/BUF * RESERVED + KERNEL−SPACE +
I 33 + BUFFER B/BUF CMOVE UPDATE FLUSH I 33 + . LOOP
EMPTY−BUFFERS IMAGE−SIZE . ;
FORTH DEFINITIONS
META−COMPILER : META−COMPILE ( −− ) CR ." COMPILING: "
BUILD−SYSTEM CR ." SAVING IMAGE: " DUMP−SYSTEM ; FORTH
contact |
privacy