\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  3. Teil: Untersuchen, was verwendet wird, um effizient zu kompilieren.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: t-name. ( token-addr -- )
  4 + length-of-flags + t-dictionary + count type
;

\ -----------------------------------------------------------------------------
\  Von einem Einsprungpunkt aus die Zahl der Verwendungen aktualisieren
\ -----------------------------------------------------------------------------

: entrypoint-trace ( token-addr -- )

  dup usage> t@ 1+ over usage> t! \ Diese Definition wird nun einmal mehr verwendet.

  \ Wie oft wurde diese Definition bisher bereits verwendet ?

  dup usage> t@ $FFFF and 1 u> if drop exit then \ Wenn sie nun zum zweiten Mal oder noch öfter verwendet wird, Rekursion nicht fortsetzen.

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

    \ dup t-name. cr  \  Entweder den eigenen Namen oder den einer Primitive ausgeben.
    code>

    begin
      signaltyp signal-token = if parameter recurse then \ Token anspringen und Suche rekursiv fortführen.
      skip-element
    until
    drop

  then
;


: entrypoint ( -- )
  t' cr
  dup usage> t@ $10000 + over usage> t!   \ Vermerke den Einsprungpunkt, so dass er nie inline eingefügt wird.
  entrypoint-trace
;


: vector ( irq -- ) \ Legt einen Interruptvektor bzw. den Reset-Einsprung als neue Definition an.

  t' ( irq definition )

  base @ >r hex
    over s>d <#
               # # # #
               [char] $ hold
               [char] - hold
               [char] q hold
               [char] r hold
               [char] i hold
             #> t-header
  r> base !

  t-compile, \ Die gewünschte Definition einkompilieren. Es ist gut möglich, dass mehrere Interrupts den gleichen Handler anspringen !
  t-ret,

  t-fadenende @ vector> t! \ Vermerke, an welcher Stelle dieser Vektor in die Tabelle eingetragen werden soll
;


\ -----------------------------------------------------------------------------
\  Eine Art "Disassembler" für Definitionen
\ -----------------------------------------------------------------------------

: t-seeprimitive ( token -- )
  code>
  begin
    dup t@ space space hex. cr
    dup t@ retopcode <>
  while
    4 +
  repeat
  drop
;

: t-seedata ( addr len -- ) \ Zum Anzeigen eines Datenblockes

  base @ >r hex
  begin
    dup
  while
    2 -
    swap
    20 spaces ." $" dup th@ u.4 ."  ," cr
    2 +
    swap
  repeat
  2drop
  r> base !

;

: t@+ ( addr -- addr+4 data )
  dup 4 + swap t@
;

: seecurasnapshot ( t-addr -- )
  ." TOS: " t@+ hex.
  ." NOS: " t@+ hex.
  ." 3OS: " t@+ hex.
  ." 4OS: " t@+ hex.
  ." 5OS: " t@+ hex.
  ." 6OS: " t@+ hex.

  ." TOR: " t@+ hex.
  ." NOR: " t@+ hex.
  ." 3OR: " t@+ hex.
  ." 4OR: " t@  hex.
;


: seesignalelement ( addr -- addr )
      signaltyp
      case
        signal-token   of parameter t-name. space endof \ Token benennen
     signal-noptoken   of parameter ." Eliminated: " t-name. space endof \ Token benennen
        signal-literal of parameter ." $" hex.    endof \ Literal holen und anzeigen

        signal-branch  of  ." Branch "   parameter over +  ." $" hex. endof
        signal-0branch of  ." 0-Branch " parameter over +  ." $" hex. endof

   signal-branchtarget of  ." <--   "            ( dup 12 + seecurasnapshot ) endof
   signal-nop          of  ." <-- Eliminated   " ( dup 12 + seecurasnapshot ) endof

        signal-data    of  ." Data section:" cr
                         parameter ( Länge ) over 12 + ( Länge Adresse ) swap t-seedata \ Datenblock anzeigen
                       endof

      signal-data-addr of  ." Data section with address:" cr
                         parameter ( Länge ) over 12 + ( Länge Adresse ) swap t-seedata \ Datenblock anzeigen
                       endof


        signal-ret     of ." ;" endof \ Nur um die Erkennung falscher Signale beizubehalten.

        dup ." Invalid signal:  " hex. cr
      endcase
;


: t-seetoken ( token -- )

  ." : "

  dup primitive> t@ ?dup \ Falls es eine Primitive ist, kann sie nicht weiter zerlegt werden.
  if drop ( dup ) t-name. ."  ( Primitive ) ;" cr
              ( t-seeprimitive cr )
  else ( token-addr )    \ Es ist keine Primitive, sondern etwas Zusammengesetztes. Jetzt muss der "emulierende innere Interpreter" anlaufen.

    dup t-name. cr
    code>

    begin
      dup           hex.  ." : " \ Adresse im Host
      targetadresse hex.4 ." : " \ Adresse im Target
      seesignalelement cr

      skip-element
    until
    drop

  then
;

: t-see ( -- )
  t' cr
  t-seetoken
;

' t-see t-prim: see       t-hostonly

\ -----------------------------------------------------------------------------
\  Dictionary durchgehen, alles, was verwendet wird, anzeigen.
\ -----------------------------------------------------------------------------

: t-dictionaryend ( -- addr ) \ Find the last entry in the dictionary
  t-fadenende @
  begin
    dup t@
  while
    t@
  repeat
;

: t-dictionarybefore ( addr -- addr* flag )
  dup t-fadenende @ = if true exit then
  >r

  t-fadenende @
  begin
    dup t@ r@ <>
  while
    t@
  repeat

  rdrop
  false
;

: t-listing ( -- )
  cr cr
  t-dictionaryend
  begin
    dup usage> t@ 0<> if dup t-seetoken cr then
    t-dictionarybefore
  until
  drop
;

\ -----------------------------------------------------------------------------
\  Helferlein, die für den Multipass-Ansatz unbedingt erforderlich sind.
\ -----------------------------------------------------------------------------

: t-fill ( addr len c -- )
  rot
  t-dictionary +
  -rot
  fill
;

false variable make-clean?

: cura-snapshot-multipass? ( Cura-Snapshot -- ? )  \ Ist der Snapshot für weitere Pässe festgelegt ?
  10 cells + t@
;

: cura-snapshot-leeren ( Cura-Snapshot -- )
  \ Prüfe, ob der Snapshot für Multipass-Kompilation vorgemerkt ist:
  dup cura-snapshot-multipass? 0=  make-clean? @  or
  if btarget-len 0 t-fill else drop then
;

: adresszuordnung+eliminationen-putzen ( token -- ) \ In einer Definition, die (erneut?) inline eingefügt werden soll, alle Target-Adressen löschen und Sprünge reaktivieren.
    code>

    begin
      0 over 8 + t! \ Target-Adress-Zuordnung löschen

      signaltyp
      case
        signal-noptoken     of signal-token        over t!                                endof \ Alle token reaktivieren
        signal-nop          of signal-branchtarget over t!  dup 12 + cura-snapshot-leeren endof \ Alle Sprungziele reaktivieren
        signal-branchtarget of                              dup 12 + cura-snapshot-leeren endof
      endcase
      skip-element
    until
    drop
;


: make-clean ( -- )  \ Für eine komplette Neukompilation auch eliminierte Stellen wiederbeleben.
  true make-clean? ! \ Damit auch Multipass-Sprungziele gelöscht werden.
  t-dictionaryend
  begin
    0 over usage> t!
    0 over addrintarget> t!
    dup primitive> t@ 0= if dup adresszuordnung+eliminationen-putzen then
    t-dictionarybefore
  until
  drop
  false make-clean? !

;


: adresszuordnungputzen ( token -- ) \ In einer Definition, die (erneut?) inline eingefügt werden soll, alle Target-Adressen löschen und Sprungziel-RA-Images aufräumen.
    code>

    begin
      0 over 8 + t! \ Target-Adress-Zuordnung löschen

      signaltyp
      case
        signal-branchtarget of                              dup 12 + cura-snapshot-leeren endof
      endcase
      skip-element
    until
    drop
;

: verwendungsputzen ( -- )  \ Für einen weiteren Pass des Compilers vorbereiten
  t-dictionaryend
  begin
    0 over usage> t!
    0 over addrintarget> t!
    dup primitive> t@ 0= if dup adresszuordnungputzen then
    t-dictionarybefore
  until
  drop
;

: verwendungsproben ( -- )
  t-dictionaryend
  begin
    dup vector> t@
    if
      $10000 over usage> t!   \ Vermerke den Einsprungpunkt, so dass er nie inline eingefügt wird. Diese Definitionen müssen stets kompiliert werden.
      \ cr ." -->  " dup t-name. cr
      dup entrypoint-trace
    then
    t-dictionarybefore
  until
  drop
;

