http://t3x.org/t3xforth/metacomp.html   (light|dark)

T3XFORTH Logo

T3XFORTH

 
\ 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