CR .( Meta Compiler with Late Binding )
CR .( Copyright Bill Muench All rights reserved. )
CR ( 8086 eForth ITC 16bit inline model for MS-DOS )

( Bill Muench \ OntoLogic )
(             \ Santa Cruz  CA  95065 )

(        tracks ============================================= )
( 971014 no host interpreter/compiler vectoring needed, almost ANS )
(        replace  SP@ with DEPTH  INCLUDE with INCLUDED )
(        use WORDLIST  INSIDE OUTSIDE )
( 971003 change to INSIDE :I ;I [I]  OUTSIDE :O ;O [O] )
(        change EVOKE EMPLOY  fix error handling, again )
( 950720 add ENDIAN _C" )
( 941006 add META[ ]META )
(        change _]-T SERR PROC  remove HEADS )
( 940817 ITC 1616 and ITC 3232 )
( 930804 POSTFIX ASSEMBLER  ?BREAK  C"| )
( 930329 HEADS ON/OFF )
( 930221 BTC only )
( 920126 COMPILE, RECURSE  fix error handling )
( 910722 update C" ,C" RECURSE )
( 901030 start small model )
(        coyote ============================================= )

DECIMAL

: ROOT ( -- ) FORTH-WORDLIST DUP 2 SET-ORDER  DEFINITIONS ;

ROOT

VARIABLE CSP-T
: !CSP-T ( -- ) DEPTH CSP-T !  0 BREAK? ! ;

!CSP-T ( start error check )

\ : PARSE-WORD ( -- a u ) BL WORD COUNT ;

: INCLUDE ( 'filespec' -- )
  PARSE-WORD ['] INCLUDED CATCH ?DUP IF ROOT THROW THEN ;

: SERR ( a u -- ) CR CR .S SPACE TYPE ROOT 1 THROW ;

: ?CSP-T ( -- )
  BREAK? @ IF 0 BREAK? ! S" ctrl-break" SERR THEN
  DEPTH CSP-T @ XOR IF S" csp-t" SERR THEN ;

: WID' ( wid 'name' -- xt )
  >R  GET-ORDER  R> 1 SET-ORDER  ['] ' CATCH
  IF S" undefined" SERR THEN >R  SET-ORDER  R> ;

( database management ======================================= )

VARIABLE ISEG ( image segment )
VARIABLE #IMAGE ( maximum image size )
: >IMAGE ( a -- d ) #IMAGE @ OVER U< IF S" image" SERR THEN ISEG @ ;

: ALLOC-T ( u -- )
  >R  0  R@
  IF R@ 0 16 UM/MOD NIP alloc IF S" seg alloc" SERR THEN
    DUP ISEG ! R> [CHAR] b ( a s u c ) LFILL EXIT
  THEN S" 0 alloc" SERR ;

: SAVE-T ( -- ) ( save code, external segments )
  ACTIVE @ ( save current file id )
  S" EFORTH.COM" 2DUP 0 ( normal ) CREATE-FILE ?DOS  hHCB
  H# 100 ( offset for .COM file )
  #IMAGE @ OVER -  ISEG @ LONG!  WRITE  CLOSE
  ACTIVE ! ( restore open file if any ) ;

VARIABLE 'ENDIAN
: ENDIAN ( n -- n ) 'ENDIAN @EXECUTE ;
: ?ENDIAN ( -- ) ( check host byte order )
  BASE C@
  IF ['] NOOP ( little endian )
  ELSE ['] FLIP ( big endian )
  THEN 'ENDIAN ! ;

( storage for new system words ============================== )

WORDLIST CONSTANT TARGET-WORDLIST
TARGET-WORDLIST >VOC TARGET

( define words used inside target definitions =============== )

WORDLIST CONSTANT INSIDE-WORDLIST
INSIDE-WORDLIST >VOC INSIDE

: :I ( 'name' -- ) INSIDE-WORDLIST SET-CURRENT  :  ;
: ;I ( -- ) [COMPILE] ; DEFINITIONS ; IMMEDIATE
: [I] ( 'name' -- ) INSIDE-WORDLIST WID' COMPILE, ; IMMEDIATE

( define words used outside target definitions ============== )

WORDLIST CONSTANT OUTSIDE-WORDLIST
OUTSIDE-WORDLIST >VOC OUTSIDE

: :O ( 'name' -- ) OUTSIDE-WORDLIST SET-CURRENT  :  ;
: ;O ( -- ) [COMPILE] ; DEFINITIONS ; IMMEDIATE
: [O] ( 'name' -- ) OUTSIDE-WORDLIST WID' COMPILE, ; IMMEDIATE

( late binding ============================================== )

: _BIND ( a u wid -- )
  GET-ORDER DUP BEGIN ?DUP WHILE 1- ROT >R REPEAT >R ( save order )
  1 SET-ORDER ['] EVALUATE CATCH IF S" bind" SERR THEN
  R> DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT SET-ORDER ( restore order ) ;

: BIND ( wid 'ccc' -- ) ( -- a u wid )
  BL PARSE  [COMPILE] SLITERAL  [COMPILE] LITERAL  ['] _BIND COMPILE, ;

( EVOKE - to call Forth, elicit )
: EVOKE ( 'ccc' -- ) OUTSIDE-WORDLIST BIND ; IMMEDIATE
: EMPLOY ( 'ccc' -- ) TARGET-WORDLIST BIND ; IMMEDIATE

( target CHAR and CELL size ================================= )

16 CONSTANT #BITS ( bits per cell ) :O #BITS #BITS ;O

:O CHARS ( n -- n ) ;O      :I CHARS ( n -- n ) ;I
:O CHAR+ ( n -- n ) 1+ ;O   :O CHAR- ( n -- n ) 1- ;O

:O CELLS ( n -- n ) [ #BITS 8 / ] LITERAL * ;O
:O CELL+ ( n -- n ) 1 [O] CELLS + ;O
:O CELL- ( n -- n ) 1 [O] CELLS - ;O

( target memory ============================================= )

VARIABLE DP-T ( target dictionary pointer )
:O ORG ( a -- ) DP-T ! ;O
:O HERE ( -- a ) DP-T @ ;O
:O ALLOT ( n -- ) DP-T +! ;O

:O C@ ( a -- c ) >IMAGE LC@ ;O
:O C! ( c a -- ) >IMAGE LC! ;O
:O C, ( c -- ) [O] HERE 1 [O] CHARS [O] ALLOT [O] C! ;O
:O COUNT ( a -- a u ) DUP [O] CHAR+ SWAP [O] C@ ;O

:O @ ( a -- n ) >IMAGE L@ ENDIAN ;O
:O ! ( n a -- ) SWAP ENDIAN SWAP >IMAGE L! ;O
:O , ( n -- ) [O] HERE 1 [O] CELLS [O] ALLOT [O] ! ;O

: MOVE-C ( a a n -- ) >R CS0 SWAP >IMAGE R> LCMOVE ;

VARIABLE WASTE ( alignment wasted bytes )
:O ALIGNED ( a -- a ) 1 [O] CELLS 1- + 1 [O] CELLS 1- INVERT AND ;O
:O ALIGN ( -- ) [O] HERE  DUP [O] ALIGNED  DUP [O] ORG  SWAP - WASTE +! ;O

:O COMPILE, ( xt -- ) [O] , ;O

( dictionary names ========================================== )

VARIABLE HEAD?
:O | ( -- ) 0 HEAD? ! ;O ( one headerless word )

VARIABLE LAST-T ( most recently defined name )
: HEAD,-T ( 'name' -- )
  HEAD? @ ( save name? )
  IF >IN @  PARSE-WORD ( a u )
    [O] ALIGN  LAST-T @ [O] ,
    [O] HERE  DUP LAST-T ! ( link )
    OVER 1+ [O] CHARS [O] ALLOT  2DUP [O] C! [O] CHAR+ ( save count )
    SWAP MOVE-C ( save name )
    0 [O] C, ( attribute byte )
    >IN !  EXIT
  THEN -1 HEAD? ! ;

VARIABLE HEAD>
: XHEAD,-T ( xt 'name' -- )
  TARGET-WORDLIST SET-CURRENT
  CREATE DEFINITIONS  HERE HEAD> !  ( lex ) 0 , ( xt ) ,
  DOES> 2@ IF S" immediate" SERR THEN [O] COMPILE, ;

: CODE-T ( 'name' -- )
  HEAD,-T [O] ALIGN [O] HERE  DUP XHEAD,-T  [O] CELL+ [O] , ; \ ITC

: LIST-T ( 'name' -- )
  HEAD,-T [O] ALIGN [O] HERE XHEAD,-T  EVOKE LIST1 [O] , ; \ ITC

: !LEX-T ( n -- )
  LAST-T @  [O] COUNT [O] CHARS +  DUP >R [O] C@ OR R> [O] C! ;
:O IMMEDIATE ( -- ) EVOKE =IMED HEAD? @ IF DUP !LEX-T THEN HEAD> @ ! ;O
:O COMPILE-ONLY ( -- ) HEAD? @ IF EVOKE =COMP !LEX-T THEN ;O

( compiler ================================================== )

:I RECURSE ( -- ) HEAD> @ CELL+ @ [O] COMPILE, ;I

:O ,C" ( 'ccc' -- )
  [CHAR] " PARSE  DUP [O] C, ( save count )
  [O] HERE  SWAP [O] CHARS  DUP [O] ALLOT  MOVE-C ( save string )
  [O] ALIGN ;O

:I ABORT" ( 'ccc' -- ) EMPLOY _ABORT" [O] ,C" ;I
:I ." ( 'ccc' -- ) EMPLOY _." [O] ,C" ;I
:I S" ( 'ccc' -- ) EMPLOY _S" [O] ,C" ;I

:I LITERAL ( n -- ) EMPLOY _LIT [O] , ;I
:I 2LITERAL ( d -- ) SWAP [I] LITERAL [I] LITERAL ;I

: X# ( radix 'ccc' -- n | d )
  BASE @ >R  BASE ! ( save and set radix )
  BL PARSE NUMBER? ( using new base )
  R> BASE ! ( restore radix before error check )
  IF EXIT THEN S" radix" SERR ;

: #O ( d -- n | d ) DPL @ 0< IF DROP THEN ;
: #I ( n | d ) DPL @ 0< IF DROP [I] LITERAL EXIT THEN [I] 2LITERAL ;

:O ' ( 'name' -- xt ) TARGET-WORDLIST WID' >BODY CELL+ @ ;O
:I ['] ( 'name' -- xt ) [O] ' [I] LITERAL ;I

:O ] ( -- ) TARGET-WORDLIST INSIDE-WORDLIST 2 SET-ORDER ;O
:O : ( 'name' -- ) LIST-T [O] ] ;O

:I [ ( -- ) OUTSIDE-WORDLIST 1 SET-ORDER  DEFINITIONS ;I
:I ; ( -- ) EMPLOY EXIT [I] [ ;I

( control flow ============================================== )

:I BEGIN ( -- a ) [O] HERE ;I
:I THEN ( a -- ) [I] BEGIN ( OVER - ) SWAP [O] ! ;I

: RESOLVE ( a -- ) ( [I] BEGIN - ) [O] , ;
: MARK ( -- a ) [O] HERE [I] BEGIN RESOLVE ;

:I IF ( -- a ) EMPLOY _IF MARK ;I
:I AHEAD ( -- a ) EMPLOY _ELSE MARK ;I
:I ELSE ( a -- a ) [I] AHEAD SWAP [I] THEN ;I
:I WHILE ( a -- a a ) [I] IF SWAP ;I

:I UNTIL ( a -- ) EMPLOY _IF RESOLVE ;I
:I AGAIN ( a -- ) EMPLOY _ELSE RESOLVE ;I
:I REPEAT ( a a -- ) [I] AGAIN [I] THEN ;I

( defining words ============================================ )

ALSO ASM86

: C@-T ( a -- n ) [O] C@ ;  : C!-T ( n a -- ) [O] C! ;
: C,-T ( n -- ) [O] C, ;    : HERE-T ( -- a ) [O] HERE ;

  ' C@-T 'C@ !  ' C!-T   'C!   ! ( vectored for assembler )
  ' C,-T 'C, !  ' HERE-T 'HERE !

: TASM ( -- ) ALSO ASM86  !ASM ;

DEFINITIONS

: next, ( -- ) EVOKE NEXT1 jmp ;
: END-CODE ( -- ) PREVIOUS ;

ROOT

:O EQU ( n 'name' -- ) CONSTANT ;O
:O LABEL ( 'name' -- ) [O] HERE [O] EQU ;O

:O CODE ( 'name' -- ) CODE-T TASM ;O
:O PROC ( 'name' -- ) [O] LABEL TASM ;O

: DUO ( 'name' -- ) >IN @ LIST-T >IN ! ;

:O CREATE ( 'name' -- ) DUO  EMPLOY _VAR  [O] LABEL ;O
:O VARIABLE ( 'name' -- ) [O] CREATE 0 [O] , ;O
:O USER ( n 'name' -- ) DUO  EMPLOY _USR  DUP [O] EQU [O] , ;O
:O CONSTANT ( n 'name' -- ) DUO  EMPLOY _CON  DUP [O] EQU [O] , ;O

( magic ===================================================== )

:O ( [COMPILE] ( ;O   :I ( [O] ( ;I
:O \ [COMPILE] \ ;I   :I \ [O] \ ;I
:O .( CR 2 SPACES [COMPILE] .( ?CSP-T ;O  :I .( [O] .( ;I

:O B#  2 X# #O ;O   :I B#  2 X# #I ;I ( binary )
:O D# 10 X# #O ;O   :I D# 10 X# #I ;I ( decimal )
:O H# 16 X# #O ;O   :I H# 16 X# #I ;I ( hex )

:O DUP DUP ;O   :O DROP DROP ;O :O SWAP SWAP ;O :O OVER OVER ;O
:O + + ;O       :O - - ;O       :O * * ;O       :O / / ;O
:O AND AND ;O   :O OR OR ;O     :O XOR XOR ;O   :O . . ;O
:O MIN MIN ;O   :O MAX MAX ;O
:O INVERT INVERT ;O             :O NEGATE NEGATE ;O
:O CHAR CHAR ;O :I [CHAR] [O] CHAR [I] LITERAL ;I
:O >ADR ( xt -- a ) ;O          :I >ADR [O] >ADR ;I
:O >BODY ( xt -- a ) [O] >ADR [O] CELL+ [O] CELL+ ;O
:O ROOT ROOT ;O   :O CR CR ;O   :O INCLUDE INCLUDE ;O

( initialize compiler ======================================= )

: META[ ( -- ) ( initialize )
  -1 HEAD? !  0 LAST-T !  0 WASTE !
  H# 0 [O] ORG
  DECIMAL  ?ENDIAN  !CSP-T  [I] [ ;

:O !IMAGE ( u -- ) DUP ALLOC-T  #IMAGE ! ;O

:O ]META ( -- ) ( initialize and save target )
  DECIMAL  ?CSP-T
  [O] HERE  EVOKE DP  [O] ! ( dictionary pointer )
  LAST-T @ EVOKE FORTH-WORDLIST [O] ! ( search order )
  EVOKE VCOLD  EVOKE RESET  1+ [O] ! ( patch reset vector )
  SAVE-T  ROOT
  CR ." Used=" [O] HERE 0 .R  2 SPACES ." Waste=" WASTE @ 0 .R
  CR ." Copyright Bill Muench All rights reserved." ;O

( =========================================================== )

?CSP-T