\
\    Mecrisp-Across - A Forth cross compiler for small MSP430 microcontrollers
\    Copyright (C) 2016  Matthias Koch
\
\    This program is free software: you can redistribute it and/or modify
\    it under the terms of the GNU General Public License as published by
\    the Free Software Foundation, either version 3 of the License, or
\    (at your option) any later version.
\
\    This program is distributed in the hope that it will be useful,
\    but WITHOUT ANY WARRANTY; without even the implied warranty of
\    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\    GNU General Public License for more details.
\
\    You should have received a copy of the GNU General Public License
\    along with this program.  If not, see <http://www.gnu.org/licenses/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  1. Teil: Ein Compiler, der im Host ein sehr spezielles Dictionary anlegt
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


\ -----------------------------------------------------------------------------
\ Ein eigenes Dictionary anlegen, welches nur fürs Target gedacht ist:
\ -----------------------------------------------------------------------------

64 1024 * constant dictionarysize
dictionarysize buffer: t-dictionary
t-dictionary dictionarysize 0 fill

$200 variable t-dp \ Den IO-Bereich der echten Chips freilassen
0 variable t-fadenende


\ -----------------------------------------------------------------------------
\ Save & Recall, für Probekompilationen.
\ Das brauche ich zum Glück nicht mehr. Spart viel Platz !
\ -----------------------------------------------------------------------------
\
\ dictionarysize buffer: t-dictionary-shadow
\ 0 variable t-dp-shadow
\ 0 variable t-fadenende-shadow
\
\ : save-compilation ( -- )
\   t-dictionary t-dictionary-shadow dictionarysize move
\   t-dp @ t-dp-shadow !
\   t-fadenende @ t-fadenende-shadow !
\ ;
\
\ : recall-compilation ( -- )
\   t-dictionary-shadow t-dictionary dictionarysize move
\   t-dp-shadow @ t-dp !
\   t-fadenende-shadow @ t-fadenende !
\ ;
\
\ -----------------------------------------------------------------------------
\ Zugriffe ins Dictionary
\ -----------------------------------------------------------------------------

true variable hostterminal?

$4130 constant retopcode

: t-here ( -- addr )
  t-dp @
;

: t-allot ( u -- )
  t-dp +!
;

: t@ ( addr -- x )

  dup 3 and if ." Unaligned memory access" cr h.s cr h.rs cr cr then

  t-dictionary + @
;

: t! ( u addr -- )
  t-dictionary + !
;

: t+! ( u addr -- )
  t-dictionary + +!
;

[ifdef] jtag?
\ -----------------------------------------------------------------------------
\  Dictionary-Zugriffe mit JTAG-Umleitung der Ports
\ -----------------------------------------------------------------------------

: th@ ( addr -- x )

  dup 1 and if ." Unaligned memory access" cr h.s cr h.rs cr cr then

  dup $200 u< jtag? @ and
  if
    jtag-t@
  else
    t-dictionary + h@
  then
;

: tc@ ( addr -- x )

  dup $200 u< jtag? @ and
  if
    \ UART falls gewünscht auch bei bestehender JTAG-Verbindung lokal umleiten.
    dup $03 = hostterminal? @ and if drop   3 exit then
    dup $66 = hostterminal? @ and if drop key exit then

    jtag-tc@
  else

    case \ UART lokal umleiten, wenn keine JTAG-Verbindung besteht
      $03 of   3 endof
      $66 of key endof

      dup t-dictionary + c@ swap
    endcase

  then
;

: th! ( u addr -- )
  dup 1 and if ." Unaligned memory access" cr h.s cr h.rs cr cr then

  dup $200 u< jtag? @ and
  if
    jtag-t!
  else
    t-dictionary + h!
  then
;

: tc! ( c addr -- )

  dup $200 u< jtag? @ and
  if
    \ UART falls gewünscht auch bei bestehender JTAG-Verbindung lokal umleiten.
    dup $67 = hostterminal? @ and if drop emit exit then

    jtag-tc!
  else

    case \ UART lokal umleiten, wenn keine JTAG-Verbindung besteht
      $67 of emit endof

      t-dictionary + c!
      0
    endcase

  then
;

[else]

\ -----------------------------------------------------------------------------
\  Dictionary-Zugriffe ohne JTAG
\ -----------------------------------------------------------------------------

: th@ ( addr -- x )
  dup 1 and if ." Unaligned memory access" cr h.s cr h.rs cr cr then
  t-dictionary + h@
;

: tc@ ( addr -- x )
  case
    $03 of   3 endof
    $66 of key endof

    dup t-dictionary + c@ swap
  endcase
;

: th! ( u addr -- )
  dup 1 and if ." Unaligned memory access" cr h.s cr h.rs cr cr then
  t-dictionary + h!
;

: tc! ( c addr -- )
  case
    $67 of emit endof

    t-dictionary + c!
    0
  endcase
;

[then]

: t, ( u -- )
  \ dup hex.
  t-here t! 4 t-allot
;

: th, ( u -- )
  t-here th! 2 t-allot
;

: tc, ( c -- )
  t-here tc! 1 t-allot
;

: t-align ( -- )
  begin
    t-here 3 and
  while
    0 tc,
  repeat
;

\ -----------------------------------------------------------------------------
\  Helferlein, um das Target-Dictonary zu verwalten
\ -----------------------------------------------------------------------------

\ Aufbau des Dictionary-Headers:
\ 4 Bytes Link
\ n Bytes Flags
\ Namenslänge + Name
\ ... Ausführbares ?

12 cells constant length-of-flags

: t-header ( addr u -- )

  t-align
  t-here
    t-fadenende @ t,
  t-fadenende !

  length-of-flags 0 do 0 tc, loop \ Ein leeres Flag-Feld schreiben

  dup tc,
  0 ?do
    dup i + c@ tc,
  loop
  drop
  t-align
;

: t: ( -- )
  token ?dup if t-header else ."  t: needs name." cr quit then
;

: hex.
  base @ hex >r
  s>d <# # # # # # # # # #> type space
  r> base !
;

: byte.
  base @ hex >r
  s>d <# # # #> type space
  r> base !
;

: t-words-lang ( -- ) \ Zeigt wirklich ALLES an.
  cr
  t-fadenende @
  begin
    ?dup
  while
    dup ." Address: " hex.
        ." Flags: " length-of-flags 0 do i 3 and 0= if ." | " then dup 4 + i + tc@ byte. loop
    dup ." Name: " 4 + length-of-flags + t-dictionary + count type
    cr
    t@
  repeat
;

0 variable foldability

: t-find ( c-addr len -- c-addr len 0 | a-addr flags )
  \ ." Ankunft find " .s
  2>r
  t-fadenende @
  begin
    ?dup
  while
    dup 4 + length-of-flags + t-dictionary + count
        2r@ compare if
                  \    ." Gefunden"
                      dup 4 + 4 + t@ foldability !      \ Faltbarkeit vermerken
                      dup 4 + 0 + t@ if 1 else -1 then  \ Immediate überprüfen
                      2rdrop ( ." find-token" .s ) exit
                    then
    t@
  repeat

  2r> false
  \ ." find-unknown" .s
;

: t' ( -- pointer )
  token 2dup 2>r t-find 0= if space 2r> type ."  not found." cr quit else rdrop rdrop then
;

: [t'] t' 0-foldable ;

: t-dump t-dictionary t-here dump ;

\ -----------------------------------------------------------------------------
\  Flags der neuen Worte unbedingt beachten !
\ -----------------------------------------------------------------------------

\ Flags

\  0 Immediate
\  4 Faltbarkeit
\  8 Ausführadresse für Primitive
\ 12 Zahl der Verwendungen
\ 16 Code-Startadresse der Routine im Target, falls vorhanden
\ 20 Routine für den RA zum Kompilieren dieser Primitive
\ 24 Soll die Definition stets inline eingefügt werden, egal, wie oft ?
\ 28 Bitmaske, die zeigt, welche Register in dieser Definition insgesamt verwendet werden
\ 32 Für Helferlein, die nur im Host existieren, aber nicht im Target einkompiliert werden können
\ 36 Wie viele Bytes RAM sollen reserviert werden ?
\ 40 Vektor-Adresse, falls es sich um einen Interrupthandler bzw. den Reset-Einsprung handelt

: immediate>     4 +  0 + ;
: foldable>      4 +  4 + ;
: primitive>     4 +  8 + ;
: usage>         4 + 12 + ;
: addrintarget>  4 + 16 + ;
: primitive-ra>  4 + 20 + ;
: inline>        4 + 24 + ;
: registerusage> 4 + 28 + ;
: hostonly>      4 + 32 + ;
: ramallot>      4 + 36 + ;
: vector>        4 + 40 + ;
: raminit>       4 + 44 + ;
: code>          4 + length-of-flags + dup tc@ + 1 + aligned ;

: t-foldable ( u -- ) 1+ t-fadenende @ foldable> t! ; \ Setzt die Faltbarkeit eines Wortes

: t-immediate ( -- ) true t-fadenende @ immediate> t! ; \ Setzt ein Wort als immediate

: t-hostonly ( -- ) true t-fadenende @ hostonly> t! ; \ Setzt ein Wort als Host-Only, für Debug-Helferlein

: t-inline ( -- ) true t-fadenende @ inline> t! ; \ Setzt ein Wort als stets inline

\ : t-registers ( x -- ) t-fadenende @ registerusage> t! ; \ Setzt die Registerbelegung eines Wortes

: t-ramallot ( u -- ) t-fadenende @ ramallot> t! ; \ Markiert, dass dieses Wort RAM anfordert.

: t-raminit  ( u -- ) $80000000 or t-fadenende @ raminit> t! ; \ Vermerkt den Initialisierungswert für diese Variable

: t-prim: ( xt -- ) \ Beispielsweise für Immediate-Primitiven, die nicht im RA zum Kompilieren ankommen
  t:
  t-fadenende @ primitive> t!   \ xt zur Ausführung dort setzen.
;

: t-prim-ra: ( xt-exec xt-ra -- )
  t:
  t-fadenende @ primitive-ra> t!   \ xt zum Kompilieren dort setzen.
  t-fadenende @ primitive> t!      \ xt zur Ausführung dort setzen.
;

                                       ' t-immediate  t-prim: immediate    0 t-foldable   t-immediate
                                       ' t-inline     t-prim: inline       0 t-foldable   t-immediate

: t-0-foldable ( -- ) 0 t-foldable ;   ' t-0-foldable t-prim: 0-foldable   0 t-foldable   t-immediate
: t-1-foldable ( -- ) 1 t-foldable ;   ' t-1-foldable t-prim: 1-foldable   0 t-foldable   t-immediate
: t-2-foldable ( -- ) 2 t-foldable ;   ' t-2-foldable t-prim: 2-foldable   0 t-foldable   t-immediate
: t-3-foldable ( -- ) 3 t-foldable ;   ' t-3-foldable t-prim: 3-foldable   0 t-foldable   t-immediate
: t-4-foldable ( -- ) 4 t-foldable ;   ' t-4-foldable t-prim: 4-foldable   0 t-foldable   t-immediate
: t-5-foldable ( -- ) 5 t-foldable ;   ' t-5-foldable t-prim: 5-foldable   0 t-foldable   t-immediate
: t-6-foldable ( -- ) 6 t-foldable ;   ' t-6-foldable t-prim: 6-foldable   0 t-foldable   t-immediate
: t-7-foldable ( -- ) 7 t-foldable ;   ' t-7-foldable t-prim: 7-foldable   0 t-foldable   t-immediate

                                       ' (            t-prim: (            0 t-foldable   t-immediate
                                       ' \            t-prim: \            0 t-foldable   t-immediate



: t-words-intern ( token -- token )
    dup ." Address: " hex.
        ." Flags: "

    dup immediate> t@      if ." Imm " else ." --- " then
    dup inline>    t@      if ." Inl " else ." --- " then
    dup foldable>  t@ ?dup if 1- s>d <# # #> type ." -f" else ." ---" then

    dup ."  Name: " 4 + length-of-flags + t-dictionary + count type
    cr
;

: t-words ( -- ) \ Zeigt nur eine Auswahl der nützlichsten Dinge an
  cr
  t-fadenende @
  begin
    ?dup
  while
    t-words-intern
    t@
  repeat
;

: t-list ( -- ) \ Eine kleine Auflistung aller definierten Wörter
  cr
  t-fadenende @
  begin
    ?dup
  while
    dup 4 + length-of-flags + t-dictionary + count type space
    t@
  repeat
  cr
;

\ -----------------------------------------------------------------------------
\  Der innere Interpreter zum Ausprobieren der Targetdefinitionen
\ -----------------------------------------------------------------------------

\ Target-Compiler erstmal nur mit Inline-Cache

false variable t-state

\ Idee: Zielarchitektur habe 16 Bits, kann also 32 Bits nehmen und so auch Konstanten wunderbar einpflegen.
\ Versuche das mal !

\ Schon beim ersten Durchgang sogleich Konstantenfaltung ausführen, später dann noch einmal anhand des Inline-Caches.

hook-quit @ constant mecrisp-quit

: mecrisp ( -- ) \ Zurück zum normalen Forth
  cr
  begin depth while drop repeat \ Datenstack aufräumen
  begin rdepth while rdrop repeat \ Returnstack aufräumen

  mecrisp-quit hook-quit !
  quit
;


' mecrisp t-prim: host t-hostonly

42 constant signal-token
43 constant signal-noptoken

1 constant signal-ret
2 constant signal-literal
3 constant signal-branch
4 constant signal-0branch
5 constant signal-branchtarget
6 constant signal-nop            \ Zum Eliminieren von unbenutzten signal-branchtarget
7 constant signal-data           \ Datenblöcke, die direkt eingefügt werden. Variable Länge !
8 constant signal-data-addr

11 cells constant btarget-len    \ Um den Cura-Snapshot überspringen zu können

: nodata ( -- ) ." I am not a MSP430 and unfortunately cannot execute this data block as instructions !" cr ;

\ -----------------------------------------------------------------------------
\  Um eine Liste von Token leicht durchlaufen zu können
\ -----------------------------------------------------------------------------


: signaltyp     ( addr -- addr signaltyp )    dup     t@ ;
: parameter     ( addr -- addr parameter )    dup 4 + t@ ;
: targetadresse ( addr -- addr targetadresse) dup 8 + t@ ;

: skip-element ( addr -- addr* ? ) \ Für eine Schleife, die über alle möglichen Elemente hinwegspringt und das Code-Ende anzeigt.

  signaltyp
  case
    signal-ret          of true exit endof \ Schon beim Ret angekommen ? Nicht weitermachen !

    signal-nop          of btarget-len       + endof
    signal-branchtarget of btarget-len       + endof
    signal-data         of parameter aligned + endof
    signal-data-addr    of parameter aligned + endof
  endcase
  3 cells + \ Alle Einträge bestehen aus mindestens drei Werten.

  false \ Dies war noch nicht das Ret, also weitermachen !
;

\ -----------------------------------------------------------------------------
\  Der innere Interpreter persönlich
\ -----------------------------------------------------------------------------

: t-execute ( token -- )

  dup primitive> t@ ?dup \ Falls es eine bekannte Primitive ist, diese sogleich im Host ausführen.
  if nip execute
  else ( token-addr )    \ Es ist keine Primitive, sondern etwas Zusammengesetztes. Jetzt muss der "emulierende innere Interpreter" anlaufen.

    code>

    begin

      \ Um den inneren Emulations-Interpreter notfalls beenden zu können.
      [ifdef] switch1?   switch1? if quit then   [then]

     signaltyp

         case
           signal-token     of  parameter swap >r recurse r>       endof \ Token anspringen, dabei den aktuellen Faden zwischenmerken
           signal-literal   of  parameter swap                     endof \ Literal holen und liegenlassen
           signal-branch    of  parameter +                        endof \ Unbedingten Sprung ausführen
           signal-0branch   of  swap 0= if parameter + then        endof \ Bedingten Sprung bedingt ausführen

           signal-data      of  nodata                             endof \ Ausführbare Datenblöcke erstmal überspringen...
           signal-data-addr of  dup 12 + swap parameter swap       endof \ Konstanten-Datenblöcke mit Adresse lassen zwei Literals liegen und werden übersprungen.
         endcase

      skip-element
    until
    drop

  then
;

\ -----------------------------------------------------------------------------
\  Zum Anlegen von Datentoken
\ -----------------------------------------------------------------------------

0 variable aktuellesdatentoken

: target[    false t-state !          0 aktuellesdatentoken ! ; \ Umschalten in Execute-Modus
: target]     true t-state ! t-align  0 aktuellesdatentoken ! ;  \ Zurück in den Kompiliermodus

' target[ t-prim: [ t-immediate
' target] t-prim: ]

: datentoken ( -- )
  signal-data t,
  0 t,  \ Länge 0
  0 t,  \ Adresse im Target 0
;

: datentoken-addr ( -- )
  signal-data-addr t,
  0 t,  \ Länge 0
  0 t,  \ Adresse im Target 0
;

: target, ( h -- ) \ Fügt einen Wert an das letzte Datentoken an - und legt es bei Bedarf auch neu an.

  aktuellesdatentoken @ 0= if
    t-here aktuellesdatentoken ! \ Adresse des anzulegenden Datentokens vermerken
    datentoken                    \ Datentoken anlegen
  then

  2  aktuellesdatentoken @ 4 +  t+!   \ Länge des Datentokens um 2 vergrößern
  th, \ Daten als Halbword anfügen, damit ich in der interaktiven Emulation diese auch genauso lesen kann.

  \  aktuellesdatentoken @ hex.   t-here hex.   aktuellesdatentoken @ 4 + t@ hex.
;

' target, t-prim: , t-hostonly

\ -----------------------------------------------------------------------------
\  Die einzelnen Kompilier-Bestandteile, die auch emuliert werden müssen
\ -----------------------------------------------------------------------------

: adresse-des-rets ( code-start -- code-end-ret ) begin skip-element until ;

: t-insertinline ( token -- )
  \ Bis zum Ret rüberkopieren. Wie erkenne ich das RET eigentlich ?

  code>  ( Startadresse )
  dup adresse-des-rets ( Endadresse )

  \ cr ." t-insertinline" 2dup hex. hex. cr

  swap ?do  ( i hex. )    i t@   ( dup hex. cr ) t,   4 +loop
;


: t-compile, ( token -- ) \ An dieser Stelle alles, was bereits als inline bekannt ist, auch direkt inline einfügen.
                           \ Ein bisschen vorsichtig mit Primitiven und Nicht-Inline-Definitionen sein.

  dup inline> t@
  if
    dup primitive> t@ 0=
    if
      \ Damit stirbt die Faltbarkeitserkennung später in der Compilation, oder ? :-)

      t-insertinline
      exit \ Fertig !

    then
  then


  \ Ganz normal als Token einfügen

  signal-token t,
  t,
  0 t,
;

' t-compile, t-prim: compile, t-hostonly

: t-literal
  signal-literal t,
  t,
  0 t,
;

' t-literal t-prim: literal t-hostonly

: t-ret,
  signal-ret t,
  0 t,
  0 t,
;

: t-branchtarget,
  signal-branchtarget t,
  0 t,
  0 t,

  btarget-len 0 do 0 tc, loop \ Leeren Cura-Snapshot anfügen
;

\ -----------------------------------------------------------------------------
\  Kontrollstrukturen
\ -----------------------------------------------------------------------------

\ Rückwärtssprünge

: t-begin ( -- addr ) t-here   t-branchtarget, ;
: t-again ( addr -- ) t-here - signal-branch  t, ( --> ) t, 0 t, ; \ Sowas wie t-branch
: t-until ( addr -- ) t-here - signal-0branch t, ( --> ) t, 0 t, ; \ Sowas wie t-0branch

' t-begin t-prim: begin t-immediate
' t-again t-prim: again t-immediate
' t-until t-prim: until t-immediate

\ Vorwärtssprünge

: t-ahead ( -- addr ) t-here signal-branch  t, 0 t, 0 t, ;
: t-if    ( -- addr ) t-here signal-0branch t, 0 t, 0 t, ;
: t-then  ( addr -- ) t-here over - swap 4 + ( t-here swap ) t! t-branchtarget, ;  \ In die Adresse der Lücke soll relative Distanz zu t-here eingefügt werden.

' t-ahead t-prim: ahead t-immediate
' t-if    t-prim: if    t-immediate
' t-then  t-prim: then  t-immediate

\ Zusammengesetztes

: t-else     t-ahead swap t-then ;
: t-while    t-if swap ;
: t-repeat   t-again t-then ;

' t-else   t-prim: else   t-immediate
' t-while  t-prim: while  t-immediate
' t-repeat t-prim: repeat t-immediate

\ -----------------------------------------------------------------------------
\  Eine besondere Art von "Kontrollstruktur": exit
\ -----------------------------------------------------------------------------

\ Lege eine Liste mit den aktuell für diese Definition wichtigen Exit-Punkten an.

 0     variable #exitstellen
64 cells buffer: exitstellen \ Das sollte erstmal reichen...

: target-exit ( -- )
  t-ahead exitstellen #exitstellen @ cells + !
  1 #exitstellen +!
;

: exitstellen-abarbeiten ( -- )
  #exitstellen @ 0 ?do
    exitstellen i cells + @ t-then
  loop
  0 #exitstellen !
;

' target-exit t-prim: exit t-immediate

\ -----------------------------------------------------------------------------
\  Anfang & Ende von Definitionen
\ -----------------------------------------------------------------------------

: target;
  exitstellen-abarbeiten
  t-ret,
  false t-state !

  0 aktuellesdatentoken ! \ Am Ende kein Anfügen mehr zulassen. Würde nur Chaos ergeben :-)
;

: target:
  0 #exitstellen !
  t:
  true t-state !
;

' target: t-prim: :
' target; t-prim: ; t-immediate

\ -----------------------------------------------------------------------------
\  Postpone, um weitere Kontrollstrukturen definieren zu können
\ -----------------------------------------------------------------------------

 \ Postpone, um weitere Kontrollstrukturen wie Case direkt im Target definieren zu können

: t-postpone ( -- )
  token 2dup 2>r t-find ( c-addr len -- c-addr len 0 | a-addr flags )
  ?dup if
    rdrop rdrop

    0< if
        t-literal
        [t'] compile,
    then
    t-compile,

  else
    space 2r> type ."  not found." cr quit
  then
;

' t-postpone t-prim: postpone t-immediate


\ -----------------------------------------------------------------------------
\  <builds & does>
\ -----------------------------------------------------------------------------

\ <builds legt eine neue Definition an und bereitet alles vor, um einen Datenblock einzufügen.
\ Der Spezialitäten dieses Compilers wegen muss der Datenblock vollständig Inline-Fähig sein und mit einem Sprung flankiert werden.

: t-<builds ( -- )
  target:                     \ Neue Definition anlegen
  t-here aktuellesdatentoken ! \ Adresse des anzulegenden Datentokens vermerken
  datentoken-addr               \ Einen neuen Datenbereich mit Adressleger vorbereiten in den Komma dann schreiben kann
;

: t-does>-kreatur ( -- )
  t-align \ Der Datenblock könnte auf 4 ungerade sein

  exitstellen-abarbeiten   \ Vorsichtshalber, damit in target; wirklich nur noch das Ret-Signal geschrieben wird.

                          \ Einen Call auf die Definition einfügen, die nach dem Does-Teil anfängt. Der Teil ist schon im Dictionary, wenn dieses hier aufgerufen wird.
  2 rpick 12 + t-compile,  \ Von wo aus wurden wir aufgerufen ? Das hängt mit der Funktionsweise von t-execute zusammen...
                            \ Da auf (does>) direkt das signal-ret folgt und darauf sogleich die nächste Definition, brauche ich nur ein Schrittchen weiter zu gehen.

  target;   \ Definition beenden. Die kompilierende Definition soll niemals ins Target, also muss ich den "klassischen" does> Teil in eine separate Definition legen.
;

256 buffer: stringpad
0 variable stringlen

: addtostring ( addr len -- )
  >r
  stringpad stringlen @ +  r@   move
  r> stringlen +!
;

: t-does>-nd ( -- )

  \ Die neue Definition gut lesbar benennen
  0 stringlen !
  t-fadenende @ 4 + length-of-flags + t-dictionary + count addtostring
  s" -does>" addtostring

  target;  \ Abschließen der alten Definition

  \ In der neuen Definition weiterkompilieren

  stringpad stringlen @ t-header
  true t-state !
;

 ' t-<builds t-prim: <builds                                t-hostonly
 ' t-does>-kreatur   t-prim: (does>)                        t-hostonly
 ' t-does>-nd        t-prim: (does>-newdef)   t-immediate   t-hostonly

: t-does> ( -- )
  \ ." Does läuft" cr

  [t'] (does>)          t-compile,
  [t'] (does>-newdef)   t-execute
;

' t-does>        t-prim: does>        t-immediate




\ Create muss in einer "Klammer" benutzt werden, damit Anfang und Ende korrekt gerahmt werden.

: t-create ( -- )
  t-<builds
  target[
;

: t-endcreate ( -- )

  target]
  t-align \ Der Datenblock könnte auf 4 ungerade sein

  target;
;

' t-create    t-prim: create     t-hostonly
' t-endcreate t-prim: endcreate  t-hostonly

\ -----------------------------------------------------------------------------
\  Compiler aus Mecrisp-Ice mit Konstantenfaltung
\ -----------------------------------------------------------------------------




: on  ( addr -- ) true swap ! ;
: off ( addr -- ) false swap ! ;

true variable constantfoldingpointer
false variable fineforoptimisation

: flushconstants ( n*x count -- {n-1}*x count-1 ) \ Recursive to write them out in reverse order
  dup if \ Do nothing if count is zero
    dup    1 u> if 1- swap >r recurse r> swap then
    swap t-literal fineforoptimisation on
  then
;

: ice-interpret-compilemode
          >r >r \ Move xt and imm-flag out of the way

          \ Calculate how many constants are available
          depth                       \ Calculate how many
          constantfoldingpointer @ -  \ constants are available now
          ( #constants R: xt imm-flag ) \ Number of constants available now on stack

          dup foldability @ 1- u< not \ Check if there are enough constants left
          foldability @ 0<> \ Check if the current definition is foldable
          and
          if \ Fold it !
            drop
            r> r> drop t-execute
          else \ Not foldable or not enough constants available

            \ Write the constants into memory
            flushconstants drop

            \ No folding allowed over classic compilation
            constantfoldingpointer on

            r> r>

            \ Do classic compilation
            0< if t-compile, fineforoptimisation on else t-execute fineforoptimisation off then
          then
;


: ice-interpret
    begin
        token
        dup
    while

      constantfoldingpointer @ true =  \ If it is not set, initialise constant folding pointer
      if depth    2 - constantfoldingpointer ! then \ Do not include the values of parse-name

      t-find \ Try to find the definition in dictionary
      ?dup
      if ( xt imm-flag ) \ Found.

        t-state @
        if    \ Compile mode

         ice-interpret-compilemode

        else  \ Execute mode
          drop
          constantfoldingpointer on
          t-execute
        then

      else ( addr len ) \ Perhaps it is a number.
        2dup 2>r number16 0= if space 2r> type ."  not found." cr quit else rdrop rdrop then \ Leave the literal(s) on the stack
      then

    repeat
    2drop
;

\ -----------------------------------------------------------------------------
\  Die Quit-Schleife für den Crosscompiler
\ -----------------------------------------------------------------------------

: ts-quit ( -- )

  \ Das wird schon von dem internen Quit-Teil erledigt:
  begin depth while drop repeat \ Datenstack aufräumen
  begin rdepth while rdrop repeat \ Returnstack aufräumen

  false t-state !
  constantfoldingpointer on

  begin
    query
    \ ts-interpret
    ice-interpret
    ." ok." cr
  again
;

: target ( -- )
  cr
  begin depth while drop repeat \ Datenstack aufräumen
  begin rdepth while rdrop repeat \ Returnstack aufräumen

  \ t-dictionary dictionarysize 0 fill  \ Neu anfangen mit einem leeren Puffer

  ['] ts-quit hook-quit !             \ Umschalten der Quit-Schleife
  quit                                \ Einsprung in den Cross-Compiler
;

