VolksForth/8086/pc-baremetal/meta.fth

( ----- 001 )
\ Target compiler loadscr                         ks cas 09jun20
  Onlyforth   \needs Assembler   2 loadfrom asm.fb

  : c+!     ( 8b addr -- )      dup c@ rot + swap c! ;

  ' find $22 + @ Alias found

  : search   ( string 'vocab -- acf n / string ff )
     dup @ [ ' Forth @ ] Literal - Abort" no vocabulary"
     >body (find IF  found exit  THEN  false ;

  3 &27 thru  Onlyforth savesystem meta.com

cr .( Metacompiler saved as META.COM  )
( ----- 002 )
\ Predefinitions loadscreen                       ks 30 apr 88

  &28 load

cr .( Predefinitions geladen ...) cr
( ----- 003 )
\ Target header pointers                          ks 29 jun 87

  Variable tfile      tfile off         \ handle of target file
  Variable tdp        tdp off           \ target dp
  Variable displace   displace off      \ diplacement of code
  Variable ?thead     ?thead off        \ for headerless code
  Variable tlast      tlast off         \ last name in target
  Variable glast'     glast' off        \ acf of latest ghost
  Variable tdoes>     tdoes> off        \ code addr of last does
  Variable tdodo      tdodo off         \ location of dodo
  Variable >in:       >in: off          \ last :-def
  Variable tvoc       tvoc off          \
  Variable tvoc-link  tvoc-link off     \ voc-link in target
  Variable tnext-link tnext-link off    \ link for tracer
( ----- 004 )
\ Target header pointers                          ks 10 okt 87

  : there  ( -- taddr )   tdp @ ;

  : new   pushfile  makefile   isfile@ tfile !
     tvoc-link off   tnext-link off
     $100 tdp !   $100 displace ! ;
( ----- 005 )
\ Ghost-creating                                  ks 07 dez 87

0 | Constant <forw>          0 | Constant <res>

| Create gname  $21 allot

| : >heap  ( from quan -- )   \ heap over - 1 and + \ align
     dup hallot heap swap cmove ;

  : symbolic  ( string -- cfa.ghost )
     count  dup 1 $1F uwithin not Abort" invalid Gname"
     gname place   BL gname append   align here >r  makeview ,
     state @ IF  context  ELSE  current  THEN @ @  dup @ ,
     gname count under here place   1+ allot align
     here r@ -   <forw> , 0 , 0 ,   r@ here over - >heap
     heap 2+ rot !   r> dp !   heap + ;
( ----- 006 )
\ ghost words                                     ks 07 dez 87

  : gfind  ( string -- cfa tf / string ff )
     >r   1 r@ c+!   r@ find   -1 r> c+! ;

  : ghost   ( -- cfa )   name gfind ?exit  symbolic ;

  : gdoes>  ( cfa.ghost -- cfa.does )
     4 + dup @ IF  @ exit THEN
     here  <forw> , 0 ,  dup 4 >heap
     dp !   heap swap !  heap ;
( ----- 007 )
\ ghost utilities                                 ks 29 jun 87

  : g'  ( -- acf )   name gfind 0= Abort" ?T?" ;

  : '.   g' dup @ <forw> case?
     IF ." forw"  ELSE  <res> - Abort" ??" ."  res"  THEN
     2+ dup @ 5 u.r      2+ @ ?dup
     IF dup @ <forw> case?
        IF ."  fdef"  ELSE <res> - Abort"  ??" ."  rdef"  THEN
        2+ @ 5 u.r THEN ;

  ' ' Alias h'
( ----- 008 )
\ .unresolved                                     ks 29 jun 87

| : forward? ( cfa -- cfa / exit&true )
     dup @ <forw> = 0=exit  dup 2+ @ 0=exit  drop true rdrop ;

| : unresolved? ( addr -- f )   2+
     dup count $1F and + 1- c@  bl =
     IF  name> forward? 4+ @  dup IF  forward?  THEN
     THEN drop  false ;

| : unresolved-words   ( thread -- )
     BEGIN  @ ?dup WHILE dup unresolved?
                         IF dup 2+ .name ?cr THEN  REPEAT ;

  : .unresolved       voc-link @
     BEGIN  dup 4 - unresolved-words  @ ?dup 0= UNTIL ;
( ----- 009 )
\ Extending Vocabularys for Target-Compilation    ks 29 jun 87

  Vocabulary Ttools
  Vocabulary Defining

  : Vocabulary       Vocabulary 0 , here tvoc @ , tvoc ! ;

  Vocabulary Transient    tvoc off

  Root definitions

  : T Transient ; immediate
  : H Forth     ; immediate
  : D Defining  ; immediate

  Forth definitions
( ----- 010 )
\ Image and byteorder                             ks 02 jul 87

| Code >byte  ( 16b -- 8b- 8b+ )   A A xor
     D- A- xchg   D+ D- xchg   A push   Next   end-code

| Code byte>  ( 8b- 8b+ -- 16b )
     A pop   D- D+ mov   A- D- xchg   Next   end-code

| : >target  ( addr1 -- daddr fcb )  displace @ - 0 tfile @  ;

  Transient definitions

  : c@    ( addr -- 8b )   [ Dos ]
     >target file@ dup 0< Abort" nie abgespeichert" ;

  : c!    ( 8b addr -- )   [ Dos ] >target file! ;
( ----- 011 )
\ Transient primitives                            ks 09 jul 87
  : @     ( addr -- n )    H dup T c@ swap 1+ c@ byte> ;
  : !     ( n addr -- )    H >r  >byte r@ 1+ T c!  r> c! H ;

  : cmove ( from.mem to.target quan -- )  [ Dos ]
     >r >target fseek   ds@ swap r> tfile @ lfputs ;
\    bounds ?DO  dup c@   I T c! H 1+  LOOP  drop ;

  : here  ( -- taddr )     H tdp @ ;
  : here! ( taddr -- )     H tdp ! ;
  : allot ( n -- )         H tdp +! ;
  : c,    ( 8b -- )        T here c! 1 allot H ;
  : ,     ( 16b -- )       T here !  2 allot H ;
  : align ( -- )           H ; immediate
  : even  ( addr1 -- addr2 ) H ; immediate
  : halign                 H ; immediate
( ----- 012 )
\ Transient primitives                            ks 29 jun 87

  : count ( addr1 -- addr2 len )  H dup 1+ swap T c@ H ;

  : ,"    H here ," here   over dp !
     over - T here swap dup allot cmove H ;

  : fill  ( addr quan 8b -- )  H
     -rot bounds ?DO  dup I T c! H  LOOP  drop ;
  : erase ( addr quan -- )    H  0 T fill H ;
  : blank ( addr quan -- )    H bl T fill H ;

  : move-threads    H tvoc @   tvoc-link @
     BEGIN  over ?dup
     WHILE  2- @ over 2- T !   @   H swap @ swap  REPEAT
     Error" some undef. Target-Vocs left" drop ;
( ----- 013 )
\ Resolving                                       ks 29 jun 87
  Forth definitions

  : resolve ( cfa.ghost cfa.target -- )   over dup @ <res> =
     IF  space dup >name .name ." exists "  ?cr
         2+ !  drop exit  THEN   >r >r  2+ @ ?dup
     IF  BEGIN  dup T @ H 2dup = Abort" resolve loop"
                r@ rot T ! H ?dup 0= UNTIL
     THEN  r> r>  <res> over !  2+ ! ;

  : resdoes> ( acf.ghost acf.target -- )  swap gdoes>
     dup @ <res> = IF  2+ ! exit  THEN  swap resolve ;

here 2+ 0 ] Does> dup @ there rot ! T , H ;  ' <forw> >body !
here 2+ 0 ] Does> @ T , H ;                  ' <res>  >body !
( ----- 014 )
\ compiling names into targ.                      ks 10 okt 87

| : tlatest ( -- addr )       current @ 6 + ;

  : (theader   ?thead @ IF  1 ?thead +! exit  THEN
     >in @  bl word  swap >in !  dup count upper
     dup c@ 1 $20 uwithin  not Abort" inval. Tname"
     blk @ $8400 or T align , H
     there tlatest @ T , H tlatest !   there tlast !
     there over c@ 1+  dup T allot cmove align H ;

  : theader    tlast off
     (theader ghost   dup glast' !   there resolve ;
( ----- 015 )
\ prebuild defining words                         ks 29 jun 87

| : (prebuild   >in @  Create  >in !
                r> dup 2+ >r  @ here 2- ! ;

| : tpfa,       there , ;

  : prebuild   ( addr check# -- check# )  0 ?pairs
     dup IF  compile (prebuild  dup ,  THEN
     compile theader   ghost gdoes> ,
     IF  compile tpfa, THEN  0 ; immediate

  : dummy   0 ;

  : DO>   [compile] Does> here 3 - compile @  0 ] ;
( ----- 016 )
\ Constructing defining words in Host            kks 07 dez 87

| : defcomp  ( string -- )  dup ['] Defining search ?dup
     IF  0> IF  nip execute exit  THEN  drop dup  THEN
     find ?dup IF  0< IF  nip , exit  THEN THEN
     drop  ['] Forth search ?dup
     IF  0< IF  , exit  THEN  execute exit  THEN
     number? ?dup 0= Abort" ?"
     0> IF  swap [compile] Literal  THEN  [compile] Literal ;

| : definter ( string -- )  dup ['] Defining search ?dup
     IF  0< IF  nip execute exit  THEN THEN  drop
     find ?dup IF  1 and 0= Abort" compile only"  execute exit
               THEN  number? 0= Error" ?"  ;
( ----- 017 )
\ Constructing defining words in Host             ks 22 dez 87

| : (;tcode      r> @   tlast @ T count +  ! H ;

Defining definitions

  : ]  H ] ['] defcomp Is parser ;

  : [  H [compile] [ ['] definter Is parser ; immediate

  : ;  H [compile] ;  [compile] \\ ; immediate

  : Does>    H compile (;tcode  tdoes> @ ,
     [compile] ; -2 allot [compile] \\ ; immediate
D ' Does> Alias ;Code  immediate   H
( ----- 018 )
\ reinterpreting defining words                   ks 22 dez 87
  Forth definitions

  : ?reinterpret ( f -- )   0=exit
     state @ >r  >in @ >r   adr parser @ >r
     >in: @ >in !   :  D ] H interpret
     r> Is parser   r> >in !   r> state ! ;

  : undefined?  ( -- f )   glast' @ 4+ @ 0= ;

| : flag!  ( 8b -- )  tlast @ ?dup 0= IF  drop exit  THEN
     dup T c@ rot or swap c! H ;

| : nfa? ( acf alf -- anf / acf ff )
     BEGIN  dup WHILE  2dup 2+ T count $1F and + even H =
                       IF  2+ nip exit  THEN  T @ H REPEAT ;
( ----- 019 )
\ the 8086 Assembler                              ks 29 jun 87

| Create relocate ] T c, , here ! c! H [

Transient definitions

  : Assembler  H [ Assembler ] relocate >codes ! Assembler ;

  : >label ( 16b -- )  H >in @ name gfind rot >in !
     IF over resolve dup THEN drop Constant ;

  : Label      T here >label Assembler H ;

  : Code       H theader T here 2+ , Assembler H ;
( ----- 020 )
( Transient primitives                           ks 17 dec 83 )

' exit Alias exit           ' load Alias load
' /    Alias /              ' thru Alias thru
' swap Alias swap           ' *    Alias *
' dup  Alias dup            ' drop Alias drop
' /mod Alias /mod           ' rot  Alias rot
' -rot Alias -rot           ' over Alias over
' 2*   Alias 2*             ' +    Alias +
' -    Alias -              ' 1+   Alias 1+
' 2+   Alias 2+             ' 1-   Alias 1-
' 2-   Alias 2-           ' negate Alias negate
' 2swap Alias 2swap         ' 2dup Alias 2dup
( ----- 021 )
\ Transient primitives                           kks 29 jun 87

       ' also Alias also         ' words Alias words
' definitions Alias definitions    ' hex Alias hex
' decimal     Alias decimal         ' (  Alias (  immediate
       ' \    Alias \  immediate    ' \\ Alias \\ immediate
       ' .(   Alias .( immediate    ' [  Alias [  immediate
       ' cr   Alias cr
' end-code    Alias end-code  ' Transient Alias Transient
   ' +thru    Alias +thru        ' +load Alias +load
         ' .s Alias .s

Tools ' trace  Alias trace  immediate
( ----- 022 )
\ immediate words and branch primitives           ks 29 jun 87

  : >mark     ( -- addr )  T here 0 , H ;
  : >resolve  ( addr -- )  T here over - swap ! H ;
  : <mark     ( -- addr )  H there ;
  : <resolve  ( addr -- )  T here - , H ;

  : immediate     H $40 flag! ;
  : restrict      H $80 flag! ;


  : |             H ?thead @ ?exit ?thead on ;
  : internal      H 1 ?thead ! ;
  : external      H ?thead off ;
( ----- 023 )
\ ' | compile  Alias  >name                       ks 29 jun 87

  : '        ( -- acf )     H g' dup @ <res> -
                            IF  Error" undefined"  THEN  2+ @ ;

  : compile       H ghost , ; immediate restrict

  : >name ( acf -- anf / ff )  H tvoc
     BEGIN  @ dup WHILE  under 2- @ nfa? ?dup IF nip exit THEN
            swap  REPEAT  nip ;
( ----- 024 )
\ >name  Alias                                    ks 29 jun 87

  : >body ( acf -- apf )   H 2+ ;

  : Alias ( n -- )   H tlast off
     (theader  ghost over resolve  T , H  $20 flag! ;

  : on    ( addr -- )   H  true swap T ! H ;
  : off   ( addr -- )   H false swap T ! H ;
( ----- 025 )
\ Target tools                                    ks  9 sep 86
  Onlyforth

| : .tfield ( taddr len quan -)  >r under Pad swap
     bounds ?DO  dup T c@ I H c!  1+  LOOP  drop
     Pad over type r> swap - 0 max spaces ;

  ' view Alias hview

  Ttools also definitions

| : ?:  ( addr -- addr )   dup 4 u.r ." :" ;
| : @?  ( addr -- addr )   dup T @ H 6 u.r ;
| : c?  ( addr -- addr )   dup T c@ H 3 .r ;
( ----- 026 )
\ Ttools for decompiling                          ks  9 sep 86

  : s  ( addr -- addr+ )   ?: space c? 4 spaces
     T count 2dup + even -rot 18 .tfield ;

  : n  ( addr -- addr+2 )  ?: @? 2 spaces   dup T @ >name H
     ?dup IF  T count H  ELSE  0 0  THEN
     $1F and  $18 .tfield 2+ ;

  : d  ( addr n -- addr+n )  2dup swap ?: 3 spaces
     swap 0 DO  c? 1+  LOOP  4 spaces -rot dup .tfield ;

  : l  ( addr -- addr+2 )  ?: 6 spaces @? 2+ 14 spaces ;

  : c  ( addr -- addr+1 )  1 d 15 spaces ;
( ----- 027 )
\ Tools for decompiling                           ks 29 jun 87

  : b  ( addr -- addr+2 )  ?: @? dup T @ H
     over + 6 u.r 2+ 14 spaces ;

  : dump ( addr n -- )
     bounds ?DO cr I 10 d drop stop? IF LEAVE THEN  10 +LOOP ;

  : view  T ' >name H ?dup 0=exit  4 - T @ H ?dup 0=exit edit ;
( ----- 028 )
\ Predefinitions loadscreen                       ks 29 jun 87
  Onlyforth

  : clear     H true Abort" There are ghosts" ;


  1 $B +thru
( ----- 029 )
\ Literal ['] ?" ." "                             ks 29 jun 87
  Transient definitions Forth

  : Literal  ( n -- )   H dup $FF00 and
     IF  T compile lit , H exit THEN  T compile clit c, H ;
  immediate

  : Ascii   H bl word 1+ c@  state @ 0=exit
            T [compile] Literal H ; immediate

  : [']     T compile lit           H ; immediate
  : ."      T compile (."  ," align H ; immediate
  : "       T compile ("   ," align H ; immediate
( ----- 030 )
\ Target compilation  ]                           ks 07 dez 87
  Forth definitions

| : tcompile  ( string -- )   dup find ?dup
     IF  0> IF  nip execute exit  THEN THEN
     drop gfind IF  execute exit  THEN   number? ?dup
     IF  0> IF  swap T [compile] Literal  THEN
                [compile] Literal H exit  THEN
     symbolic execute ;

  Transient definitions

  : ]    H ] ['] tcompile Is parser ;
( ----- 031 )
\ Target conditionals                             ks 10 sep 86

  : IF        T compile ?branch >mark H 1 ; immediate restrict
  : THEN      abs 1 ?pairs T >resolve H ;   immediate restrict
  : ELSE      1 ?pairs T compile branch >mark
              swap >resolve H -1 ;          immediate restrict

  : BEGIN     T <mark H 2 ;                 immediate restrict
  : WHILE     2 ?pairs 2 T compile ?branch >mark H -2 2swap ;
                                            immediate restrict

| : (repeat   2 ?pairs T <resolve H
              BEGIN  dup -2 = WHILE  drop T >resolve H REPEAT ;

  : UNTIL     T compile ?branch (repeat H ; immediate restrict
  : REPEAT    T compile  branch (repeat H ; immediate restrict
( ----- 032 )
\ Target conditionals   Abort" etc.               ks 09 feb 88

  : DO        T compile (do  >mark H 3 ;    immediate restrict
  : ?DO       T compile (?do >mark H 3 ;    immediate restrict
  : LOOP      3 ?pairs T compile (loop
              compile endloop >resolve H ;  immediate restrict
  : +LOOP     3 ?pairs T compile (+loop
              compile endloop >resolve H ;  immediate restrict

  : Abort"    T compile (abort" ," align H ; immediate restrict
  : Error"    T compile (error" ," align H ; immediate restrict
( ----- 033 )
\ Target does>  ;code                             ks 29 jun 87

| : dodoes>   T compile (;code
     H glast' @ there resdoes>   there tdoes> ! ;

  : Does>    H undefined? T dodoes>
     $E9 c,  H tdodo @ there - 2- T ,
     H ?reinterpret ; immediate restrict

  : ;Code  H 0 ?pairs undefined? T dodoes> H ?reinterpret
     T [compile] [ Assembler H ; immediate restrict
( ----- 034 )
\ User                                            ks 09 jul 87
  Forth definitions

  Variable torigin    torigin off       \ cold boot vector
  Variable tudp       tudp off          \ user variable counter
  : >user    ( addr1 -- addr2 )  T c@ H torigin @ + ;

  Transient definitions Forth

  : origin!  ( taddr -- )     H torigin !  tudp off ;
  : uallot   ( n -- offset )  H tudp @  swap tudp +! ;

  DO> >user ;
  : User      T prebuild User 2 uallot c, H ;
( ----- 035 )
\ Variable  Constant  Create                      ks 01 okt 87

  DO> ;
  : Variable T prebuild Create  2 allot H ;

  DO> T @ H ;
  : Constant T prebuild Constant  , H ;

  DO> ;
  : Create    T prebuild Create  H ;

  : Create:   T Create ] H end-code 0 ;
( ----- 036 )
\ Defer  Is  Vocabulary                           ks 29 jun 87

  DO> ;
  : Defer     T prebuild Defer  2 allot ;
  : Is        T ' >body H state @
     IF  T compile (is , H exit  THEN  T ! H ; immediate

  dummy
  : Vocabulary   H >in @ Vocabulary >in !
     T prebuild Vocabulary  0 , 0 ,
     H there   tvoc-link @ T , H   tvoc-link ! ;
( ----- 037 )
\ File                                            ks 19 m<>r 88
  Forth definitions

  Variable tfile-link  tfile-link off
  Variable tfileno     tfileno off
  &45 Constant tb/fcb

  Transient definitions Forth

  dummy
  : File   T prebuild File  here tb/fcb 0 fill
     here H tfile-link @ T , H tfile-link !
     1 tfileno +!  tfileno @ T c, 0 , 0 , 0 , 0 , 0 ,
     here dup >r  1+   tb/fcb &13 - allot   H tlast @
     T count dup r> c!
     H bounds ?DO  I T c@ over c! H 1+  LOOP drop ;
( ----- 038 )
\ : ; compile Host [compile]                      ks 29 jun 87

  dummy
  : :        H >in @ >in: !   T prebuild : ] H end-code 0 ;

  : ;        0 ?pairs T compile unnest
             [compile] [ H ; immediate restrict

  : compile  T compile compile H ; immediate restrict

  : Host     H Onlyforth ;

  : Compiler H Onlyforth Transient also definitions ;

  : [compile]  H ghost execute ; immediate restrict
( ----- 039 )
\ Target                                          ks 29 jun 87

  Onlyforth

  : Target   H vp off  Transient also definitions ;

  Transient definitions

  ghost c, drop