( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Assembler and Metacompiler for Retro                        )
( Copyright [c] 2009, Charles Childers                        )
( License: ISC                                                )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

vocab meta
((
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Configuration                                               )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
4096 constant IMAGE-SIZE

: ok. cr depth . ." ok " ; ' ok. is ok

( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Perform a check to see if we have enough free memory to     )
( actually build a new image.                                 )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: check ( - )
  #mem @ here - 4096 IMAGE-SIZE +
  <if cr ." Error: insufficent heap space" bye then ;
check forget check


( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Variables used in the target image [classes, dictionary, etc)
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
7 elements target origin 'WORD 'MACRO 'DATA link chain


( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( The assembler                                               )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: m,  ( n-  ) target @ ! target ++ ;
: vm: ( n"- ) ` : .data ` m, ` ; ;

 0 vm: nop,          1 vm: lit,          2 vm: dup,
 3 vm: drop,         4 vm: swap,         5 vm: push,
 6 vm: pop,          7 vm: call,         8 vm: jump,
 9 vm: ;,           10 vm: >jump,       11 vm: <jump,
12 vm: !jump,       13 vm: =jump,       14 vm: @,
15 vm: !,           16 vm: +,           17 vm: -,
18 vm: *,           19 vm: /mod,        20 vm: and,
21 vm: or,          22 vm: xor,         23 vm: <<,
24 vm: >>,          25 vm: 0;           26 vm: 1+,
27 vm: 1-,          28 vm: in,          29 vm: out,
30 vm: wait,        98 vm: halt,

: t-here ( -n  ) target @ origin @ - ;
: main:  ( -   ) t-here cr ." MAIN @ " dup . origin @ 1+ ! ;
: label: ( "-  ) t-here constant ;
: #      ( n-  ) lit, m, ;
: $,     ( $-  ) dup getLength for dup @ m, 1+ next 0 m, drop ;


( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( And now the metacompiler                                    )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  variable getxt
  : .colon getxt @ if getxt off ;then m, ;
---reveal---
  : t: ( "- ) label: nop, nop, ['] .colon last @ d->class ! ;
  : t' ( "-a ) getxt on ;
}}

{{
  : cond ( -a ) target @ 0 m, ;
---reveal---
  : =if  ( -a ) !jump, cond ;
  : <if  ( -a ) >jump, cond ;
  : >if  ( -a ) <jump, cond ;
  : !if  ( -a ) =jump, cond ;
  : if   ( -a ) 0 # !if ;
  : then ( a- ) t-here swap ! ;
}}

: jump:  ( "- ) jump, ' m, ;
: repeat ( -a ) t-here ;
: again  ( a- ) jump, m, ;

: variable: ( n"- ) label: m, ;
: variable  ( "-  ) 0 variable: ;

: entry  ( a"- ) t-here link @ m, link ! m, m, 32 accept tib $, ;
: word:  ( a"- ) 'WORD @ entry ;
: macro: ( a"- ) 'MACRO @ entry ;
: data:  ( a"- ) 'DATA @ entry ;
: patch-dictionary ( - ) link @ chain @ ! ;
: mark-dictionary  ( - ) target @ chain ! ;

: set-class ( aa- ) ! ;


( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( The last bit is the trickiest: we need to safely relocate   )
( the new image over the old one. Since we can't use *any*    )
( code that calls into the old image, we must redefine all    )
( words necessary here.                                       )
(                                                             )
( If you're not targeting a different VM, use "store-and-quit")
( instead of "boot-new"                                       )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  : @+       ( a-ac )  dup 1+ swap @ ;
  : !+       ( ca-a )  dup 1+ push ! pop ;
  : copy     ( aan- )  for push @+ pop !+ next drop drop ;
  : wait     ( - )     0 0 out [ 30 , ] ;
  : save     ( - )     1 4 out 0 0 out wait -9 5 out wait ;
  : relocate ( - )     origin @ 0 IMAGE-SIZE copy ;
---reveal---
  : boot-new       ( - ) relocate [ 0 , ] ;
  : save-and-quit  ( - ) relocate save ;
}}

: padding 128 t-here - for 0 m, next ;

: ; ;, ;; [

here IMAGE-SIZE zallot target ! target @ origin !
jump, 0 m,
))
' meta shut