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


compiletoflash

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  0. Teil: Helferlein
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


\ -----------------------------------------------------------------------------
\  Speicherbereiche mal genauer betrachten
\ -----------------------------------------------------------------------------

\ A convenient memory dump helper

: u.4 ( u -- ) 0 <# # # # # #> type ;
: u.2 ( u -- ) 0 <# # # #> type ;

: hex.4 ( u ) base @ swap hex u.4 base ! space ;

: dump16 ( addr -- ) \ Print 16 bytes memory
  base @ >r hex
  $F bic
  dup hex. ." :  "

  dup 16 + over do
    i c@ u.2 space \ Print data with 2 digits
    i $F and 7 = if 2 spaces then
  loop

  ."  | "

  dup 16 + swap do
        i c@ 32 u>= i c@ 127 u< and if i c@ emit else [char] . emit then
        i $F and 7 = if 2 spaces then
      loop

  ."  |" cr
  r> base !
;

: dump ( addr len -- ) \ Print a memory region
  cr
  over 15 and if 16 + then \ One more line if not aligned on 16
  begin
    swap ( len addr )
    dup dump16
    16 + ( len addr+16 )
    swap 16 - ( addr+16 len-16 )
    dup 0<
  until
  2drop
;

: 32->16l16h ( x -- l h )
           dup
           $FFFF and  \ Untere 16 Bits maskieren
           swap 16 rshift \ Obere 16 Bits maskieren
;

: 16l16h->32 ( l h -- x )
           16 lshift or
;

\ -----------------------------------------------------------------------------
\  Zahleneingabe, 16 Bits breit
\ -----------------------------------------------------------------------------

: number16 ( addr len -- 0 )
           (             n 1 )
           (             d-low d-high 2 )

  number
  case

    0 of 0 endof

    1 of $FFFF and 1 endof \ Low-Teil auf 16 Bits maskieren

    2 of drop 32->16l16h 2 endof

  endcase
;

\ -----------------------------------------------------------------------------
\  Einblick in den Return-Stack
\ -----------------------------------------------------------------------------

: h.rs ( -- )

  rdepth dup ." [" hex. ." ] "

  begin
    dup
  while
    1-
    dup rpick hex.

  repeat
  drop
;

\ -----------------------------------------------------------------------------
\  Bedingte Kompilation
\ -----------------------------------------------------------------------------

\ Idea similar to http://lars.nocrew.org/dpans/dpansa15.htm#A.15.6.2.2532

: nexttoken ( -- addr len )
  begin
    token          \ Fetch new token.
  dup 0= while      \ If length of token is zero, end of line is reached.
    2drop cr query   \ Fetch new line.
  repeat
;

: [else] ( -- )
  1 \ Initial level of nesting
  begin
    nexttoken ( level addr len )

    2dup s" [if]"     compare
 >r 2dup s" [ifdef]"  compare r> or
 >r 2dup s" [ifndef]" compare r> or

    if
      2drop 1+  \ One more level of nesting
    else
      2dup s" [else]" compare
      if
        2drop 1- dup if 1+ then  \ Finished if [else] is reached in level 1. Skip [else] branch otherwise.
      else
        s" [then]" compare if 1- then  \ Level completed.
      then
    then

    ?dup 0=
  until

  immediate 0-foldable
;

: [then] ( -- ) immediate 0-foldable ;

: [if]   ( ? -- )                 0=  if postpone [else] then immediate 1-foldable ;
: [ifdef]  ( -- ) token find drop 0=  if postpone [else] then immediate 0-foldable ;
: [ifndef] ( -- ) token find drop 0<> if postpone [else] then immediate 0-foldable ;
\
\    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
;

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  2. Teil: Primitiven, die nur im Host wirken
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ Sachen, die erstmal nützlich sind, aber hinterher im Target nicht mehr zur Verfügung stehen werden...

' hex      t-prim: hex     t-hostonly
' binary   t-prim: binary  t-hostonly
' decimal  t-prim: decimal t-hostonly

' h.s      t-prim: .s      t-hostonly
' t-words  t-prim: words   t-hostonly
' t-list   t-prim: list    t-hostonly
' char     t-prim: char    t-hostonly
' char     t-prim: [char]  0 t-foldable

\
\    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
;

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Die Speicherkarte und Aufteilung des vorhandenen Platzes
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


\ -----------------------------------------------------------------------------
\   Memory map of MSP430F2011/MSP430F2012/MSP430F2013:
\ -----------------------------------------------------------------------------

\ $0000 - $000F  Special function registers, mostly for peripheral interrupt configuration
\ $0010 - $00FF  Byte peripheral registers
\ $0100 - $01FF  Word peripheral registers
\ $0200 - $027F  RAM, 128 Bytes
\ $1000 - $10FF  Info Flash, 256 Bytes, contains factory calibration values. Better do not touch.
\ $F800 - $FFFF  Flash, 2048 Bytes

\ Vector table, 16 entries, at the end of flash from $FFE0 to $FFFF.
\ $FFFE contains the Reset vector.

 $0200 constant ramstart

    \ Space for Variables and Buffers

    $0240 constant stackarea
    $0260 constant initialdatastack
    $0280 constant initialreturnstack
 $0280 constant ramend

 $F800 constant flashstart

    \ Space for Forth Dictionary

    $FFE0 constant vectortable
$10000 constant flashend


\ -----------------------------------------------------------------------------
\   Small tools for handling a memory image
\ -----------------------------------------------------------------------------

flashend flashstart - buffer: memoryimage

\ Enforce little endian.

: imagec! ( x addr -- ) flashstart - memoryimage + c! ;
: imagec@ ( addr -- x ) flashstart - memoryimage + c@ ;

:  image! ( x addr -- ) 2dup imagec! swap 8 rshift swap 1+ imagec! ;
:  image@ ( addr -- x )  dup imagec@ swap 1+ imagec@ 8 lshift or ;

: clearmemory ( -- ) flashend flashstart do $FF i imagec! loop ;

0 variable org

: image, ( x -- )
  \  ."  Image, " org @ hex. ." : " dup hex. cr

  org @ image! 2 org +!

  org @ vectortable u>= if ." Flash full." cr quit then
;

ramstart variable variablenpointer \ Hier wird begonnen, Variablen einzukompilieren.

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Verwaltung der verfügbaren Register
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ Register verfügbar:

\   Hardwired:
\     r0    pc
\     r1    sp
\     r2    sr
\     r3    cg
\   Gewählt:
\     r4    dsp
\     r5    nicht benutzt
\   Für den RA verfügbar:
\     r6
\     r7
\     r8
\     r9
\     r10
\     r11
\     r12
\     r13
\     r14
\     r15
\

\ -----------------------------------------------------------------------------
\   Die Zustandsvariablen des Registerallokators
\ -----------------------------------------------------------------------------

\ Aufbau der Opcodes:
\
\                    5432 1098 7654 3210
\   Single Operand:  oooo oooo obss rrrr
\   Double Operand:  oooo ssss dbss dddd
\   Jumps:           oooc cc-- ---- ----
\
\   Adressierungsmodi:
\     00  0  Register
\     01  1  Indexed/Absolute
\     10  -  Indirect
\     11  -  Indirect Autoincrement

\ Die möglichen Zustände der einzelnen Elemente, gleich fertig für Single-Operand-Opcodes


$31 constant  r-unknown  \ @r1+
$34 constant    unknown  \ @r4+

  6 constant  reg6
  7 constant  reg7
  8 constant  reg8
  9 constant  reg9

 10 constant  reg10
 11 constant  reg11
 12 constant  reg12
 13 constant  reg13
 14 constant  reg14
 15 constant  reg15

$20 constant  fetchbit
$30 constant  literal@pc+

$40 constant  bytebit

$0012 constant fetchabsolute

: literal? ( stackzustand -- ? )
  literal@pc+ =
;

: indexed? ( stackzustand -- ? )  \ Wird noch ein weiteres Element am Opcode benötigt ?
  dup  $30 and $10 =
  swap literal? or
;

: fetchworddestination? ( stackzustand -- ? ) \ Soll ein Element geholt werden, und zwar mit Wordbreite, welches so auch als Zieloperand verwendet werden könnte ?
  dup
    \ $3F and fetchabsolute =
    $30 and $10 = \ Indexed, Absolute
  swap
    $30 and $20 = \ Indirect, also @r...
  or
;

\ Register@
\ Literal@


\ Damit kann ich 4 R-Stack-Elemente und 6 D-Stack-Elemente in den RA aufnehmen

0 r-unknown  2variable  state-tor
0 r-unknown  2variable  state-nor
0 r-unknown  2variable  state-3or
0 r-unknown  2variable  state-4or

0 unknown  2variable  state-tos
0 unknown  2variable  state-nos
0 unknown  2variable  state-3os
0 unknown  2variable  state-4os
0 unknown  2variable  state-5os
0 unknown  2variable  state-6os




: cura ( -- ) \ See you RA
  cr

  ." 4OR: " state-4or 2@ hex. hex. cr
  ." 3OR: " state-3or 2@ hex. hex. cr
  ." NOR: " state-nor 2@ hex. hex. cr
  ." TOR: " state-tor 2@ hex. hex. cr

  ." 6OS: " state-6os 2@ hex. hex. cr
  ." 5OS: " state-5os 2@ hex. hex. cr
  ." 4OS: " state-4os 2@ hex. hex. cr
  ." 3OS: " state-3os 2@ hex. hex. cr
  ." NOS: " state-nos 2@ hex. hex. cr
  ." TOS: " state-tos 2@ hex. hex. cr

;

' cura     t-prim: cura    t-hostonly



\ Um zu vermerken, welche Register im Laufe der Routine verwendet werden, damit ich Interrupteinsprünge passend präparieren kann.

0 variable registerusage

\ Damit lassen sich Vergleiche und Sprünge optimal vereinen.

0 variable flagtrampolin
0 variable sprungtrampolin

\ Damit lassen sich Zwei-Operanden-Befehle auf ihre Eignung für den Konstantengenerator hin untersuchen.

: konstantengenerator ( konstante/index opcode -- )
  \ Prüfe zunächst, ob es sich um eine Konstante oder um einen Index handelt.

  dup $0F30 and $0030 =
  if
    over
    case
      $FFFF of nip           $0330 or image, exit endof
          0 of nip $0030 bic $0300 or image, exit endof
          1 of nip $0030 bic $0310 or image, exit endof
          2 of nip $0030 bic $0320 or image, exit endof
          4 of nip $0030 bic $0220 or image, exit endof
          8 of nip           $0230 or image, exit endof
    endcase
  then

  \ Falls es ein Index war oder die Konstante nicht generiert werden konnte, einfach so schreiben.
  image, image,
;

: konstantengenerator-push ( konstante/index opcode -- )
  \ Prüfe zunächst, ob es sich um eine Konstante oder um einen Index handelt.

  dup $003F and $0030 =
  if
    over
    case
      $FFFF of nip           $0033 or image, exit endof
          0 of nip $0030 bic $0003 or image, exit endof
          1 of nip $0030 bic $0013 or image, exit endof
          2 of nip $0030 bic $0023 or image, exit endof
    endcase
  then

  \ Falls es ein Index war oder die Konstante nicht generiert werden konnte, einfach so schreiben.
  image, image,
;

\ -----------------------------------------------------------------------------
\  Infrastruktur für die Registerbelegung
\ -----------------------------------------------------------------------------

: registerfrei? ( reg -- reg ? )
  state-6os @ $F and over = if false exit then
  state-5os @ $F and over = if false exit then
  state-4os @ $F and over = if false exit then
  state-3os @ $F and over = if false exit then
  state-nos @ $F and over = if false exit then
  state-tos @ $F and over = if false exit then

  state-4or @ $F and over = if false exit then
  state-3or @ $F and over = if false exit then
  state-nor @ $F and over = if false exit then
  state-tor @ $F and over = if false exit then

  true
;

: get-free-register-intern ( -- reg ) \ Wenn alle Register belegt sind, lieber einen R-Register rausschreiben als einen D-Register, braucht weniger Opcodes und Takte.

  reg6  registerfrei? if exit then drop
  reg7  registerfrei? if exit then drop
  reg8  registerfrei? if exit then drop
  reg9  registerfrei? if exit then drop
  reg10 registerfrei? if exit then drop
  reg11 registerfrei? if exit then drop
  reg12 registerfrei? if exit then drop
  reg13 registerfrei? if exit then drop
  reg14 registerfrei? if exit then drop
  reg15 registerfrei? if exit then drop

  ." No free registers available. This should not happen, please report bug." quit
;

: get-free-register ( -- reg ) \ Vermerkt die Wahl auch gleich in "registerusage".
  get-free-register-intern
  1 over lshift registerusage bis! \ Zur bisherigen Registerverwendung hinzuverodern
;

\ -----------------------------------------------------------------------------
\  Infrastruktur für die Register im RA
\ -----------------------------------------------------------------------------

: eliminiere-tos ( -- )
  state-nos 2@  state-tos 2!
  state-3os 2@  state-nos 2!
  state-4os 2@  state-3os 2!
  state-5os 2@  state-4os 2!
  state-6os 2@  state-5os 2!
  unknown state-6os !
;

: eliminiere-nos ( -- )
  state-3os 2@  state-nos 2!
  state-4os 2@  state-3os 2!
  state-5os 2@  state-4os 2!
  state-6os 2@  state-5os 2!
  unknown state-6os !
;

\ Agenda: Ermöglichen, einen Wert als @r4+ in den RA einzufügen.
\         Wenn bereits ein @r4+ im RA vorhanden ist, muss dieser geladen werden und der nächste kann auf @r4+ gesetzt werden.

\ Ähnliches für den R-Stack, aber hier ist es weniger wahrscheinlich, kommt später.

: expect-one-element ( -- )
  state-tos @ unknown =
  if
    get-free-register
    dup state-tos !
    $4430 or image, \ Vom Stack nachfüllen
  then
;

: expect-two-elements ( -- )
  expect-one-element
  state-nos @ unknown =
  if
    get-free-register
    dup state-nos !
    $4430 or image, \ Vom Stack nachfüllen
  then
;

: operand-for-double ( x -- x' )
  dup $F and >r \ Register wegmaskieren
  $00F0 and
  r> 8 lshift or
;

: expect-element-in-register ( Zustandsvariable -- )
  dup @ reg15 u<= if drop exit then \ Ist das Element nicht in einem Register ?

    \ Bereite also einen mov-Opcode vor, der das Element in einen Register bugsiert.

    dup @ operand-for-double $4000 or \ mov-Opcode zusammenbauen
    ( Zustandsvariable Opcode )

    over @ indexed?
    if
      over cell+ @ \ Literal oder Adresse holen
      >r           \ Für später aufbewahren

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over get-free-register swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen

      r> swap konstantengenerator

    else

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over get-free-register swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen
      image,


    then
;

: expect-tos-in-register ( -- ) state-tos expect-element-in-register ;
: expect-nos-in-register ( -- ) state-nos expect-element-in-register ;


0 variable welcherregister

: element-in-diesen-register ( zustandsvariable register -- ) \ So ähnlich wie expect-element-in-register

  welcherregister !

    \ Bereite also einen mov-Opcode vor, der das Element in einen Register bugsiert.

    dup @ operand-for-double $4000 or \ mov-Opcode zusammenbauen
    ( Zustandsvariable Opcode )

    over @ indexed?
    if
      over cell+ @ \ Literal oder Adresse holen
      >r           \ Für später aufbewahren

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over welcherregister @ swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen

      r> swap konstantengenerator

    else

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over welcherregister @ swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen
      image,


    then
;

\ -----------------------------------------------------------------------------
\  Kleine Helferlein, damit die Faltung auch im RA durchgeführt werden kann
\ -----------------------------------------------------------------------------

\ Für die Faltung im RA, denn durch das Inlining können hier Konstanten aufeinandertreffen und müssen optimiert werden.

: einekonstante? ( -- ? )   state-tos @ literal@pc+ = ;
: einekonstante  ( -- tos ) state-tos cell+ @  eliminiere-tos ;

: zweikonstanten? ( -- ? ) state-tos @ literal@pc+ = state-nos @ literal@pc+ = and ;
: zweikonstanten ( -- nos tos ) state-nos cell+ @  state-tos cell+ @  eliminiere-tos eliminiere-tos ;

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Aufräumroutine zurück in den Grundzustand
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


create kanonischer-zustand-tos-im-register

     reg6 , \ TOS
  unknown , \ NOS
  unknown , \ 3OS
  unknown , \ 4OS
  unknown , \ 5OS
  unknown , \ 6OS

r-unknown , \ TOR
r-unknown , \ NOR
r-unknown , \ 3OR
r-unknown , \ 4OR

create kanonischer-zustand-tos-auf-stack

  unknown , \ TOS
  unknown , \ NOS
  unknown , \ 3OS
  unknown , \ 4OS
  unknown , \ 5OS
  unknown , \ 6OS

r-unknown , \ TOR
r-unknown , \ NOR
r-unknown , \ 3OR
r-unknown , \ 4OR

\ Standardmäßig sei Tos in r6. Erstmal zur Probe der verschiedenen Möglichkeiten :-)

0 cells constant kanon-tos
1 cells constant kanon-nos
2 cells constant kanon-3os
3 cells constant kanon-4os
4 cells constant kanon-5os
5 cells constant kanon-6os

6 cells constant kanon-tor
7 cells constant kanon-nor
8 cells constant kanon-3or
9 cells constant kanon-4or



kanonischer-zustand-tos-im-register variable kanonischer-zustand
\ kanonischer-zustand-tos-auf-stack variable kanonischer-zustand


: r-tidyup ( Zustandsvariable -- )

  dup @ r-unknown <> if
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
    
    dup @ $1200 or ( Zustandsvariable Opcode )   \ Push-Opcode zusammenbauen
    over @ indexed? if over cell+ @ swap konstantengenerator-push else image, then \ Adresse oder Literal anfügen
    
    r-unknown swap !
    
  else drop then
;

: d-tidyup ( Zustandsvariable -- )

  dup @ unknown <> if
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
 
    $8324 image, \ decd r4 
    
    dup @ operand-for-double $4084 or ( Zustandsvariable Opcode )   \ mov ..., x(r4)
    over @ indexed? if over cell+ @ swap konstantengenerator else image, then \ Adresse oder Literal anfügen
    $0000 image,
    
    unknown swap !
    
  else drop then
;




: d-tidyup-ohne-decd ( Zustandsvariable -- )
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
     
    dup @ operand-for-double $4084 or ( Zustandsvariable Opcode )   \ mov ..., 0(r4)
    over @ indexed? if over cell+ @ swap konstantengenerator else image, then \ Adresse oder Literal anfügen
    
    unknown swap !   
;



: d-tidyup-cache ( Anzahl Zustandsvariable -- ... Anzahl* )
  dup @ unknown <> if
    swap 1+ \ Ein Element mehr rauszuschreiben
  else drop then  
;

: d-tidyup-flush ( ... Anzahl -- )
  \ Habe jetzt die Zahl der Elemente, die auf den Stack geschrieben werden sollen.
  \ Zunächst einen passenden sub-Opcode schreiben:
  dup if
    dup 2* $8034 konstantengenerator \ sub #Anzahl, r4
  then
  
  \ Jetzt die Elemente abarbeiten.
  
  0 ?do \ Schleife über die Elemente  
    d-tidyup-ohne-decd
    i 2* image,
  loop
;




: init-ra ( -- ) \ Setzt alles wieder auf den Ausgangszustand zurück.

  kanonischer-zustand @ kanon-tos + @ state-tos !
  kanonischer-zustand @ kanon-nos + @ state-nos !
  kanonischer-zustand @ kanon-3os + @ state-3os !
  kanonischer-zustand @ kanon-4os + @ state-4os !
  kanonischer-zustand @ kanon-5os + @ state-5os !
  kanonischer-zustand @ kanon-6os + @ state-6os !

  kanonischer-zustand @ kanon-tor + @ state-tor !
  kanonischer-zustand @ kanon-nor + @ state-nor !
  kanonischer-zustand @ kanon-3or + @ state-3or !
  kanonischer-zustand @ kanon-4or + @ state-4or !  
  
  0 flagtrampolin !
  0 sprungtrampolin !
;


: free-6os-element ( -- )
  state-6os d-tidyup
;

: befreie-tos ( -- )
  free-6os-element              \ Unterstes Element befreien
  
  state-5os 2@  state-6os 2!    \ Die anderen Elemente nachrutschen lassen
  state-4os 2@  state-5os 2!
  state-3os 2@  state-4os 2!
  state-nos 2@  state-3os 2!
  state-tos 2@  state-nos 2!
  
  unknown state-tos !           \ TOS ist jetzt in einem unbekanntem Zustand
;


: tos-elementkopie ( -- ) \ Den Inhalt des TOS-Registers in einen neuen, freien Register kopieren.
  $4000
  state-tos @ 8 lshift or
  eliminiere-tos
  befreie-tos
  get-free-register dup state-tos ! or
  image,  
;

: make-tos-changeable ( -- ) \ Das Ziel ist immer ein Register. Muss also nur Vergleichen, ob dieser schoneinmal woanders auftaucht.
   
  state-tos @ $F and state-nos @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-3os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-4os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-5os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-6os @ $F and = if tos-elementkopie exit then
  
  state-tos @ $F and state-tor @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-nor @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-3or @ $F and = if tos-elementkopie exit then  
  state-tos @ $F and state-4or @ $F and = if tos-elementkopie exit then    
;


: registereinmaligkeit ( Zustandsvariable -- )

  \ Zuerst auf den Stack liegende Elemente aussortieren.  
  dup @   unknown = if drop exit then
  dup @ r-unknown = if drop exit then
  
  \ Anschließend Literals & Fetch-Absolute aussortieren.
  \ Das ist hier aber nicht nötig, weil alles, was nicht auf dem Stack lag beim Einsprung hier bereits in Register geladen worden ist.
    
  \ Im Prinzip brauche ich nur zu checken, ob der Register woanders nochmal auftaucht. Falls ja, muss ich einen neuen freien Register anfordern und einen Registerwechsel durchführen.
  >r  \ Achte darauf: Nicht mit sich selbst vergleichen !

    false \ Erstmal kein Wechsel nötig
   
    r@ state-4or <> if   r@ @  state-4or @ = or    then
    r@ state-3or <> if   r@ @  state-3or @ = or    then
    r@ state-nor <> if   r@ @  state-nor @ = or    then
    r@ state-tor <> if   r@ @  state-tor @ = or    then
   
    r@ state-6os <> if   r@ @  state-6os @ = or    then
    r@ state-5os <> if   r@ @  state-5os @ = or    then    
    r@ state-4os <> if   r@ @  state-4os @ = or    then
    r@ state-3os <> if   r@ @  state-3os @ = or    then    
    r@ state-nos <> if   r@ @  state-nos @ = or    then
    r@ state-tos <> if   r@ @  state-tos @ = or    then

    if \ Ein Registerwechsel für dieses Element ist nötig.
      \ ." Registerwechsel wegen Doppelbelegung" cr
      
      $4000                        \ Mov-Opcode
      r@ @ 8 lshift or              \ Alten Register holen
      get-free-register dup r@ ! or  \ Neuen Register anfordern, registrieren und in den Opcode einfügen
      image,
    
    then

  rdrop
;

: alle-vorhandenen-elemente-in-register-laden ( -- )

  state-tos @   unknown <> if state-tos expect-element-in-register then
  state-nos @   unknown <> if state-nos expect-element-in-register then
  state-3os @   unknown <> if state-3os expect-element-in-register then
  state-4os @   unknown <> if state-4os expect-element-in-register then
  state-5os @   unknown <> if state-5os expect-element-in-register then
  state-6os @   unknown <> if state-6os expect-element-in-register then

  state-tor @ r-unknown <> if state-tor expect-element-in-register then
  state-nor @ r-unknown <> if state-nor expect-element-in-register then
  state-3or @ r-unknown <> if state-3or expect-element-in-register then
  state-4or @ r-unknown <> if state-4or expect-element-in-register then
  
  \ An dieser Stelle kann ein Register mehrere Elemente zugleich repräsentieren.
  \ Das ist natürlich ein unmöglicher Aufräumzustand, muss also darauf achten, dass jeder Register nur einmal verwendet wird.
  \ Notfalls sind nun Elementkopien anzulegen.
  
  state-4or registereinmaligkeit
  state-3or registereinmaligkeit
  state-nor registereinmaligkeit
  state-tor registereinmaligkeit    
  
  state-6os registereinmaligkeit
  state-5os registereinmaligkeit
  state-4os registereinmaligkeit
  state-3os registereinmaligkeit
  state-nos registereinmaligkeit
  state-tos registereinmaligkeit

;

: nullprobe-schreiben-und-alle-vorhandenen-elemente-in-register-laden ( -- )

  expect-one-element
  expect-tos-in-register  \ Dies ist der Wert, der geprüft werden soll...
  $B000 state-tos @ or state-tos @ 8 lshift or image, \ Schreibe die Nullprobe mit einem passenden Register
  eliminiere-tos        

  alle-vorhandenen-elemente-in-register-laden
;


0 variable trampolin-sprungopcode

: vergleich-schreiben-und-alle-vorhandenen-elemente-in-register-laden ( -- )

  sprungtrampolin @ execute trampolin-sprungopcode !
  
    0 flagtrampolin !
  0 sprungtrampolin !

  alle-vorhandenen-elemente-in-register-laden
;


\ -----------------------------------------------------------------------------
\   Eine Routine, die einen Registersatz umsortieren kann, notfalls mit Umweg über r5.
\ -----------------------------------------------------------------------------

10 2* cells buffer: tauschpaare
        0 variable #tauschpaare

: registertausch-cache ( Quellregister Zielregister -- )  
  swap #tauschpaare @ 2 cells * tauschpaare + 2!
  1 #tauschpaare +!  
;

: quellelementaddr ( u -- addr ) 2 cells * tauschpaare +       ; 
:  zielelementaddr ( u -- addr ) 2 cells * tauschpaare + cell+ ;

: registerfrei? ( register -- ? ) \ Taucht der Zielregister noch in der Liste der Quellregister auf ?

  #tauschpaare @ 0 ?do
    dup  
    i quellelementaddr @ \ Die Quellregisterliste durchgucken
    $F and = if unloop drop false exit then
  loop
  drop
  true
;

: registertausch-einblick ( -- )
  cr
  #tauschpaare @ 0 ?do
    i quellelementaddr @ hex.
    i  zielelementaddr @ hex. cr
  loop
;

: tauschzug ( quelle ziel -- )

  swap operand-for-double $4000 or \ Quelloperand einfügen, nach Bedarf mit @Register
  or                               \ Zielregister einfügen.
  
  image,
;

: fertiggetauscht? ( -- true | i false ) \ Prüft, ob nun alle Tauschpaare abgearbeitet sind.
  #tauschpaare @ 0 ?do
    i quellelementaddr @  i zielelementaddr @  <>  if i unloop false exit then
  loop
  true
;

true variable keintauschmehr

: registertausch-direkt ( -- ) \ Versucht alle Fälle abzuarbeiten, bei denen ein direktes Laden möglich ist.

  \ Versuchen, alle Register so weit es geht direkt in ihre Zielregister zu laden.
  begin
    true keintauschmehr !    
    #tauschpaare @ 0 ?do
      i quellelementaddr @  i zielelementaddr @  <>
      if \ Stimmt das Paar noch nicht ?
        i zielelementaddr @ registerfrei? \ Ist der Zielregister frei ?
        if          
          i quellelementaddr @ i zielelementaddr @ tauschzug    \ So kann ich das Element direkt in den Zielregister schreiben          
          i zielelementaddr @ i quellelementaddr !              \ Und es als im richtigen Register angekommen vermerken.
          false keintauschmehr ! \ Vielleicht gibt es nun eine neue Gelegenheit.
        then
      then      
    loop  
  keintauschmehr @ until  
;  

: quellregister-durch-r5-ersetzen ( quellregister -- )
  
  1 5 lshift registerusage bis!  \ Verwendung von r5 anmelden

  #tauschpaare @ 0 ?do
    dup i quellelementaddr @ $F and =
    if
      i quellelementaddr @
        $F bic  \ Alten Quellregister wegmaskieren, Adressiermodus dabei jedoch erhalten
        5 or    \ Register 5 einfügen
      i quellelementaddr !
    then
  loop
  drop
;

: registertausch-flush ( -- ) 

\  ." Registertausch-Flush beginnt" cr
\  registertausch-einblick cr

  begin    
    registertausch-direkt    
  fertiggetauscht? not while       \ Einen "Zyklentausch" durchführen ?     
    ( Element ) \ Erstes Element, bei dem es noch nicht passt, auf dem Stack.   
    quellelementaddr @ $F and dup 5 tauschzug \ Wechsele diesen Register in r5    
    ( Ehemaliger-Quellregister-der-jetzt-in-r5-ist )    
    quellregister-durch-r5-ersetzen           
  repeat
  
\  ." Registertausch-Flush endet" cr
;

\ -----------------------------------------------------------------------------
\   Nun wird es Zeit, wirklich zum Aufräumen zu kommen !
\ -----------------------------------------------------------------------------

: mitregister? ( zustandsvariable -- ? ) \ Prüft, ob es sich hierbei um etwas in Registern handelt.
  @ $F and 5 u>= \ Register 0 bis 4 haben besondere Aufgaben...
;  

: tidyup-common ( -- ) \ Dies muss bei der Erfüllung der Aufgabe allerdings die Flags intakt lassen !

  kanonischer-zustand @ kanon-4or + @ r-unknown = if state-4or r-tidyup then
  kanonischer-zustand @ kanon-3or + @ r-unknown = if state-3or r-tidyup then  
  kanonischer-zustand @ kanon-nor + @ r-unknown = if state-nor r-tidyup then
  kanonischer-zustand @ kanon-tor + @ r-unknown = if state-tor r-tidyup then  

  \ Alles, was gemäß des kanonischen Zustandes auf den Stack soll, ist nun rausgeschrieben.
  
  \ Alles, was unknown sein soll, ist bereits rausgeschrieben. Was jetzt noch übrig ist, kommt im Laufe der Routine in den vorgegebenen Register.
  
  \ Nun alles, was in Registern ist oder @Register ist, in die passenden Register laden.

  0 #tauschpaare ! \ Zahl der zu wechselnden Register initialisieren
  
  state-tos mitregister? if   state-tos @   kanonischer-zustand @ kanon-tos + @     dup state-tos !     registertausch-cache   then
  state-nos mitregister? if   state-nos @   kanonischer-zustand @ kanon-nos + @     dup state-nos !     registertausch-cache   then
  state-3os mitregister? if   state-3os @   kanonischer-zustand @ kanon-3os + @     dup state-3os !     registertausch-cache   then
  state-4os mitregister? if   state-4os @   kanonischer-zustand @ kanon-4os + @     dup state-4os !     registertausch-cache   then
  state-5os mitregister? if   state-5os @   kanonischer-zustand @ kanon-5os + @     dup state-5os !     registertausch-cache   then
  state-6os mitregister? if   state-6os @   kanonischer-zustand @ kanon-6os + @     dup state-6os !     registertausch-cache   then
                                                                                                        
  state-tor mitregister? if   state-tor @   kanonischer-zustand @ kanon-tor + @     dup state-tor !     registertausch-cache   then
  state-nor mitregister? if   state-nor @   kanonischer-zustand @ kanon-nor + @     dup state-nor !     registertausch-cache   then
  state-3or mitregister? if   state-3or @   kanonischer-zustand @ kanon-3or + @     dup state-3or !     registertausch-cache   then
  state-4or mitregister? if   state-4or @   kanonischer-zustand @ kanon-4or + @     dup state-4or !     registertausch-cache   then
                                                                                                       
  registertausch-flush \ Finde eine gute Lösung für die Registerwechsel und schreibe sie alle kollisionsfrei dahin, wo sie hingehören.
  

  \ Rausgeschrieben ok. Was schon in Registern war, ist nun im richtigen Register.  
  \ Jetzt noch: Nachladen und Nicht-Register-Elemente in den jeweiligen Zielregister laden.
  \ Das ist das letzte, was übrig geblieben ist... Hier wird also alles nachgeladen. Reihenfolge wichtig !

  state-tos @ kanonischer-zustand @ kanon-tos + @  <>  if  state-tos  kanonischer-zustand @ kanon-tos + @   element-in-diesen-register  then
  state-nos @ kanonischer-zustand @ kanon-nos + @  <>  if  state-nos  kanonischer-zustand @ kanon-nos + @   element-in-diesen-register  then
  state-3os @ kanonischer-zustand @ kanon-3os + @  <>  if  state-3os  kanonischer-zustand @ kanon-3os + @   element-in-diesen-register  then
  state-4os @ kanonischer-zustand @ kanon-4os + @  <>  if  state-4os  kanonischer-zustand @ kanon-4os + @   element-in-diesen-register  then
  state-5os @ kanonischer-zustand @ kanon-5os + @  <>  if  state-5os  kanonischer-zustand @ kanon-5os + @   element-in-diesen-register  then
  state-6os @ kanonischer-zustand @ kanon-6os + @  <>  if  state-6os  kanonischer-zustand @ kanon-6os + @   element-in-diesen-register  then
                                                                                                              
  state-tor @ kanonischer-zustand @ kanon-tor + @  <>  if  state-tor  kanonischer-zustand @ kanon-tor + @   element-in-diesen-register  then
  state-nor @ kanonischer-zustand @ kanon-nor + @  <>  if  state-nor  kanonischer-zustand @ kanon-nor + @   element-in-diesen-register  then
  state-3or @ kanonischer-zustand @ kanon-3or + @  <>  if  state-3or  kanonischer-zustand @ kanon-3or + @   element-in-diesen-register  then
  state-4or @ kanonischer-zustand @ kanon-4or + @  <>  if  state-4or  kanonischer-zustand @ kanon-4or + @   element-in-diesen-register  then

  \ Jetzt ist der gewünschte Zustand erreicht ! Fein !
;

: tidyup-ra ( -- )

  \ Die Datenstackaufräumer zusammenfassen, um nur ein sub #..., r4 Befehl schreiben zu müssen.
  
  0 \ Zahl der bisher gesammelten Aufräumfälle
  
  kanonischer-zustand @ kanon-6os + @   unknown = if state-6os d-tidyup-cache then
  kanonischer-zustand @ kanon-5os + @   unknown = if state-5os d-tidyup-cache then  
  kanonischer-zustand @ kanon-4os + @   unknown = if state-4os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-3os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-nos d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-tos d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
          
  tidyup-common
;

: tidyup-nullprobe ( -- ) \ Als Einleitung eines 0-branch

  0 \ Zahl der bisher gesammelten Aufräumfälle
  
  kanonischer-zustand @ kanon-5os + @   unknown = if state-6os d-tidyup-cache then  
  kanonischer-zustand @ kanon-4os + @   unknown = if state-5os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-4os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-3os d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-nos d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
      
  expect-one-element
  expect-tos-in-register  \ Dies ist der Wert, der geprüft werden soll...
  $B000 state-tos @ or state-tos @ 8 lshift or image, \ Schreibe die Nullprobe mit einem passenden Register
  eliminiere-tos        
                
  tidyup-common
;

: tidyup-bisaufzwei-sprungtrampolin ( -- ) \ Als Einleitung eines Doppeltvergleiches

  0 \ Zahl der bisher gesammelten Aufräumfälle
 
  kanonischer-zustand @ kanon-4os + @   unknown = if state-6os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-5os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-4os d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-3os d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
      
  sprungtrampolin @ execute trampolin-sprungopcode !
  
    0 flagtrampolin !
  0 sprungtrampolin !
      
  tidyup-common

;

: tos-bytesperre ( -- ) \ Byte-Fetches können im RA mitschwimmen, dürfen aber nur selten weiterverwendet werden.

  state-tos @ bytebit and
  if
    state-tos expect-element-in-register  
  then
;


\ -----------------------------------------------------------------------------
\  Infrastruktur R-Stack
\ -----------------------------------------------------------------------------

: befreie-tor ( -- )
  state-4or r-tidyup

  state-3or 2@  state-4or 2!
  state-nor 2@  state-3or 2!
  state-tor 2@  state-nor 2!
  
  r-unknown state-tor !           \ TOR ist jetzt in einem unbekanntem Zustand  
;

: eliminiere-tor ( -- )
  state-nor 2@  state-tor 2!
  state-3or 2@  state-nor 2!
  state-4or 2@  state-3or 2!
  r-unknown state-4or !  
;

: expect-one-r-element ( -- )
  state-tor @ r-unknown =
  if
    get-free-register
    dup state-tor !
    $4130 or image, \ Vom R-Stack nachfüllen
  then
;

: tos-fetchsperre ( -- ) \ Sollte TOS ein Fetch enthalten, führe diesen sofort aus:

  state-tos @ unknown <>
  state-tos @ indexed? and
  state-tos @ literal? not and \ Konstanten dürfen gerne "mitschwimmen".
  if
    state-tos cell+ @                       \ Adresse holen, Literals werden hier nicht behandelt    
    state-tos @ operand-for-double $4000 or  \ Mov-Opcode vorbereiten
    eliminiere-tos                            \ Registerwechsel zum Fetch einleiten
    befreie-tos
    get-free-register dup state-tos !
    or
    image, \ Opcode
    image, \ Adresse        
  then    
;


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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Der Cross-Kompilierende Registerallokator
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

false variable noch-ein-pass?
false variable schon-ein-snapshot-festgelegt?

\ -----------------------------------------------------------------------------
\   Die Schnittstelle zum Rest der Welt
\ -----------------------------------------------------------------------------

: insertprimitive ( token -- )

  dup hostonly> t@ if t-name. ."  is available on host only." cr quit then

  dup primitive-ra> t@ ?dup if ( ." RA-Primitive" cr ) execute drop exit else ( ." Primitive räumt auf" cr ) tidyup-ra then

  ." No pure machine language primitives possible anymore. This should not happen, please report bug." cr quit

\    \ Als Maschinensprache definierte Primitiven inline einfügen.
\
\    dup registerusage> t@ registerusage bis! \ Zur bisherigen Registerverwendung hinzuverodern
\
\      ."  inp " dup hex. cr
\    code>
\    begin
\      dup t@ retopcode <>     \ ... bis zum Ret einfügen.
\    while
\      dup t@ image,           \ Opcodes der Primitive ...
\      4 +
\    repeat
\    drop
;

: compileliteral ( n -- )

  \ Das übernimmt nun fortan der Registerallokator.

  befreie-tos           \ Das oberste Element freischieben
  state-tos cell+ !      \ Vermerke die Konstante im RA
  literal@pc+ state-tos ! \ Vermerke den neuen Status

\  $8324  image, \ sub.w #2h, r4
\  $40B4  image, \ mov.w #2Ah, 0h(r4)
\         image,
\  $0000  image,
;

: ergebnismerken ( x -- ) compileliteral ;

\ ----------------------------------------------------------------------------------------------------------------------------------------------------------
\ ----------------------------------------------------------------------------------------------------------------------------------------------------------



\ Dies hier wird schon nicht mehr durch den RA geschickt:

: compilecalltotoken ( token -- )
  $12B0 image, \ Call-Opcode
  addrintarget> t@ image, \ Zieladresse
;

\ -----------------------------------------------------------------------------
\  Helferlein für den RA über Sprünge hinweg
\ -----------------------------------------------------------------------------


: savesnapshot ( t-addr -- )

  state-tos @ over kanon-tos + t!
  state-nos @ over kanon-nos + t!
  state-3os @ over kanon-3os + t!
  state-4os @ over kanon-4os + t!
  state-5os @ over kanon-5os + t!
  state-6os @ over kanon-6os + t!

  state-tor @ over kanon-tor + t!
  state-nor @ over kanon-nor + t!
  state-3or @ over kanon-3or + t!
  state-4or @ over kanon-4or + t!

  drop
;

: loadsnapshot ( t-addr -- )

  dup kanon-tos + t@  state-tos !
  dup kanon-nos + t@  state-nos !
  dup kanon-3os + t@  state-3os !
  dup kanon-4os + t@  state-4os !
  dup kanon-5os + t@  state-5os !
  dup kanon-6os + t@  state-6os !

  dup kanon-tor + t@  state-tor !
  dup kanon-nor + t@  state-nor !
  dup kanon-3or + t@  state-3or !
  dup kanon-4or + t@  state-4or !

  drop
;

: curasnapshotgesetzt? ( t-addr -- ? )
  12 + t@ 0<> \ Die Null kommt im RA nie vor, kann also dagegen prüfen.
;

\ -----------------------------------------------------------------------------
\  Kurze Sprünge einfügen
\ -----------------------------------------------------------------------------

0 variable zuletzteinenunbedingtensprung

64 constant maxjumps  \ Maximale Zahl von gepufferten Vorwärtssprüngen
maxjumps 8 * buffer: jumpcollection
jumpcollection maxjumps 8 * 0 fill

: showjumps ( -- )
  maxjumps 0 do
    i 8 * jumpcollection + @
    if
      ." Destination: " i 8 * jumpcollection + @ hex.
      ." Opcode location: " i 8 * jumpcollection + 4 + @ hex. cr
    then
  loop
;

: patch-jump-opcode ( Zieladresse-im-Target Opcodeadresse -- )
      dup >r
      - 2 - shr $3FF and     \ Offset berechnen
      r@ image@ or r> image!  \ Zum vorgefertigten Opcode dazuverodern


;

: resolvejumps ( host-style-addr -- )

  maxjumps 0 do
    i 8 * jumpcollection + @ over =
    if
      \ Sprungopcode liegt schon im Speicher, muss nur noch den Offset berechnen und dazuverodern.

      dup 8 + t@  ( Zieladresse-im-Target )

        \ dup ." Zieladresse im Target" hex. cr

      i 8 * jumpcollection + 4 + @ ( Zieladresse-im-Target Opcodeadresse )
      patch-jump-opcode

      \ Aus der Liste löschen:
      0   i 8 * jumpcollection +       !
      0   i 8 * jumpcollection +  4 +  !

    then
  loop
  drop
;

: collectjump ( opcode-location unresolved-host-style-destination )

  \ Prüfe erstmal, ob die host-style-destination vielleicht schon bekannt ist.

  dup 8 + t@ ?dup \ Absolute Adresse im Target oder Null für unbekanntes Ziel

  if \ Adresse bereits zugeordnet

    ( opcode-location host-style-addr target-destination-addr )
    nip
    ( opcode-location target-destination-addr )
    swap patch-jump-opcode

  else \ Target-Zieladresse noch nicht bekannt

    \ Suche die erste freie Stelle in der Liste noch zu bearbeitender Sprünge

    jumpcollection
    begin
      dup @ 0<>
    while
      8 +
    repeat
    >r

    ( opcode-location unresolved-host-style-destination R: addr-der-ersten-freien-stelle )
    r@     ! \ unresolved-host-style-destination
    r> 4 + ! \ opcode-location

     \ showjumps

 then \ Target-Adresse schon bekannt ?
;

: otherdestinationsbefore? ( host-style-destination -- ? )

  maxjumps 0 do
    i 8 * jumpcollection + @
    ?dup if   \ 0 bedeutet: Leere Stelle,
      over u<= \ Gibt es einen unbehandelten Vorwärtssprung, der vor unserem Ziel einspringt ?
      if unloop drop true exit then
    then
  loop
  drop false
;




: eliminiere-sprungziel ( addr -- ) signaltyp signal-branchtarget = if  signal-nop      swap t!  true noch-ein-pass? !  else drop then ; \ Nur dann ein weiterer Pass, wenn tatsächlich etwas deaktiviert wurde.
: eliminiere-token      ( addr -- ) signaltyp signal-token        = if  signal-noptoken swap t!  true noch-ein-pass? !  else drop then ;

: vorsprung-unterwegs ( ziel start -- ziel ) \ Der Start ist immer ein Sprung. Das Ziel ist auf jeden Fall eine Sprungstelle.

  \  Untersuche nun alle Sprünge in dem Bereich und eliminiere ihre Ziel-Aufräumstellen, damit diese die weitere Optimierung nicht stören.
  \  Entferne auch alle Token-Einsprünge, damit diese bei der nächsten Verwendungsprobe nicht berücksichtigt werden müssen.

  \ Das hier sind bereits Code-Adressen. Kann sie direkt verwenden.
  begin
    signaltyp
    case

       signal-branch of parameter eliminiere-sprungziel endof
      signal-0branch of parameter eliminiere-sprungziel endof
        signal-token of dup       eliminiere-token      endof

    endcase
    2dup u>
  while
    skip-element drop
  repeat
  drop
;


: in-diesen-zustand-aufräumen ( Cura-Quelladresse Aufräumer-xt -- )
  kanonischer-zustand @ >r                       \ Merken ! Wir müssen ihn später wieder herstellen können.
  swap 12 + t-dictionary + kanonischer-zustand !  \ Setze den Zustand "als den Kanonischen"...
  execute                                          \ Räume mit dem gewünschten Aufräumer in den gewünschten Zustand auf
  r>  kanonischer-zustand !                         \ Schließlich wieder der kanonische kanonische Zustand.
;


\ Zähle die Elemente, die jeweils in Registern sind oder sein sollten, um zu bestimmen, wie viele Register an den Vereinigungsstellen verwendet werden sollen.

: anzahl-elemente-d-aktuell ( -- u )
  0
  state-tos @ unknown <> if 1+ then
  state-nos @ unknown <> if 1+ then
  state-3os @ unknown <> if 1+ then
  state-4os @ unknown <> if 1+ then
  state-5os @ unknown <> if 1+ then
  state-6os @ unknown <> if 1+ then
;

: anzahl-elemente-r-aktuell ( -- u )
  0
  state-tor @ r-unknown <> if 1+ then
  state-nor @ r-unknown <> if 1+ then
  state-3or @ r-unknown <> if 1+ then
  state-4or @ r-unknown <> if 1+ then
;

: anzahl-elemente-d-snapshot ( Cura-Quelladresse -- u )
  12 + >r 0
  r@ kanon-tos + t@ unknown <> if 1+ then
  r@ kanon-nos + t@ unknown <> if 1+ then
  r@ kanon-3os + t@ unknown <> if 1+ then
  r@ kanon-4os + t@ unknown <> if 1+ then
  r@ kanon-5os + t@ unknown <> if 1+ then
  r> kanon-6os + t@ unknown <> if 1+ then
;

: anzahl-elemente-r-snapshot ( Cura-Quelladresse -- u )
  12 + >r 0
  r@ kanon-tor + t@ r-unknown <> if 1+ then
  r@ kanon-nor + t@ r-unknown <> if 1+ then
  r@ kanon-3or + t@ r-unknown <> if 1+ then
  r> kanon-4or + t@ r-unknown <> if 1+ then
;


btarget-len buffer: tmp-snapshot
0 variable gewünschte-anzahl-d-elemente
0 variable gewünschte-anzahl-r-elemente

: begrenze-zahl-der-elemente ( -- ) \ tmp-snapshot auf die gewünschten Elementanzahlen zurückstutzen.

  gewünschte-anzahl-d-elemente @ 1 u< if   unknown tmp-snapshot kanon-tos + ! then
  gewünschte-anzahl-d-elemente @ 2 u< if   unknown tmp-snapshot kanon-nos + ! then
  gewünschte-anzahl-d-elemente @ 3 u< if   unknown tmp-snapshot kanon-3os + ! then
  gewünschte-anzahl-d-elemente @ 4 u< if   unknown tmp-snapshot kanon-4os + ! then
  gewünschte-anzahl-d-elemente @ 5 u< if   unknown tmp-snapshot kanon-5os + ! then
  gewünschte-anzahl-d-elemente @ 6 u< if   unknown tmp-snapshot kanon-6os + ! then

  gewünschte-anzahl-r-elemente @ 1 u< if r-unknown tmp-snapshot kanon-tor + ! then
  gewünschte-anzahl-r-elemente @ 2 u< if r-unknown tmp-snapshot kanon-nor + ! then
  gewünschte-anzahl-r-elemente @ 3 u< if r-unknown tmp-snapshot kanon-3or + ! then
  gewünschte-anzahl-r-elemente @ 4 u< if r-unknown tmp-snapshot kanon-4or + ! then

  \ Nur einen Snapshot pro Pass festlegen ! Die anderen Register könnten nämlich dadurch verrutschen.
  schon-ein-snapshot-festgelegt? @ 0=
  if
  \  ." Tatsächlich festlegen" cr
    true tmp-snapshot 10 cells + !
    true noch-ein-pass? !
    true schon-ein-snapshot-festgelegt? !
  then
;


0 variable welcher-aufräumer
0 variable wie-viele-elemente-weniger


: universal-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

  dup  anzahl-elemente-d-snapshot anzahl-elemente-d-aktuell wie-viele-elemente-weniger @ - 0 max u>
  over anzahl-elemente-r-snapshot anzahl-elemente-r-aktuell u> or
      \ drop false \ Umschalten in den alten Modus ohne Sprungzielfestlegungen
  if
    \ ." Muss eine Vereinigungsstelle festlegen." cr
    \ Den Zustand, in den aufgeräumt werden soll sichern, und die Zahl der Elemente, um den Snapshot für den nächsten Pass vorbereiten zu können
    dup t-dictionary + 12 + tmp-snapshot btarget-len move
    anzahl-elemente-d-aktuell wie-viele-elemente-weniger @ - 0 max gewünschte-anzahl-d-elemente !
    anzahl-elemente-r-aktuell gewünschte-anzahl-r-elemente !

    \ Mache das Aufräumen erstmal so weiter, wie es mit dem in diesem Pass schon festliegenden Snapsnot erforderlich ist
    dup    welcher-aufräumer @ in-diesen-zustand-aufräumen

    \ Begrenze die Zahl der Elemente in dem gesicherten Snapshot
    begrenze-zahl-der-elemente

    \ Und bereit den Snapshot für den nächsten Pass vor, der dann liegen bleibt:
    tmp-snapshot swap t-dictionary + 12 + btarget-len move
  else
     welcher-aufräumer @ in-diesen-zustand-aufräumen
  then
;

\   cr
\   ." Mit tidyup-ra aufräumen "
\   ."  D aktuell " anzahl-elemente-d-aktuell .
\   ."  D cura " dup anzahl-elemente-d-snapshot .
\   ."  R aktuell " anzahl-elemente-r-aktuell .
\   ."  R cura " dup anzahl-elemente-r-snapshot .
\   cr
\

: mit-tidyup-ra-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   0  wie-viele-elemente-weniger !
  ['] tidyup-ra welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

: mit-tidyup-nullprobe-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   1  wie-viele-elemente-weniger !
  ['] tidyup-nullprobe welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

: mit-tidyup-bisaufzwei-sprungtrampolin-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   2  wie-viele-elemente-weniger !
  ['] tidyup-bisaufzwei-sprungtrampolin welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

0 variable hs-destination  \ Temporär, um Stackrobatik zu vermeiden...


: compilebranch ( Fadenadresse host-style-destination -- Fadenadresse* )
  \ Dies hier kann auch einen Block unbedingt weglassen, deshalb Zugriff auf die Fadenadresse erforderlich.

  hs-destination !

  hs-destination @ over u>
  if \ Unbedingter Vorwärtssprung.
    hs-destination @ otherdestinationsbefore? 0=
    if
      hs-destination @ swap vorsprung-unterwegs ( Fadenaddr* ) \ Es ist ein Vorwärtssprung, der samt des Blocks weggelassen wird.
      exit \ Fertig, nach der übersprungenen Stelle weiterkompilieren.
    then
  then


  \ Der Sprung muss ganz normal behandelt werden - kann ihn nicht weglassen.
  true zuletzteinenunbedingtensprung !


  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-ra-in-diesen-zustand-aufräumen

  else

    \ Ziel-Registerzustand ist noch unbekannt. Nimm den aktuellen Zustand.
    alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    $3C00 image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;


: compile-0-branch ( host-style-destination -- )
  hs-destination !

  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-nullprobe-in-diesen-zustand-aufräumen

  else

    \ Ziel-Registerzustand ist noch unbekannt. Nimm den aktuellen Zustand.
    nullprobe-schreiben-und-alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    $2400 image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;

: flagschreiber ( -- )
  flagtrampolin @ ?dup if execute 0 flagtrampolin ! 0 sprungtrampolin ! then
;

: compile-0-branch-trampolin ( host-style-destination -- )
  hs-destination !

  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-bisaufzwei-sprungtrampolin-in-diesen-zustand-aufräumen

  else

    vergleich-schreiben-und-alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    trampolin-sprungopcode @ image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;

\ -----------------------------------------------------------------------------

\ true variable inlining

: inline? ( token -- ? ) \ Alles, was genau einmal benutzt wird, soll inline eingefügt werden.
  dup inline> t@          \ Ist es als "stets inline" markiert ?
  swap usage> t@ 1 =       \ Oder wird es nur einmal verwendet ?
  ( inlining @ and )
  or                         \ Um das große Einfügen auch mal probeweise abstellen zu können.
;

: tos-konstant-false? ( -- ? )
  \ Ist TOS konstant false, wird aus 0-branch ein branch.

  state-tos @ literal?
  state-tos cell+ @ 0=
  and
;

: tos-konstant-true? ( -- ? )
  \ Ist TOS konstant true, kann ein 0-branch weggelassen werden

  state-tos @ literal?
  state-tos cell+ @ 0<>
  and
;

: t-inlinedata ( addr len -- )
  begin
    dup
  while
    2 -
    swap
    dup th@ image,
    2 +
    swap
  repeat
  2drop
;

: crosscompiledefinition ( token -- )
  \ ."  ccd " dup hex. cr
  \ Entlanghangeln und als Objektcode einfügen.

  code>

  begin


    org @  over 8 + t!    \ Aktuelle Target-Adresse dieses Bausteins vermerken

    signaltyp
    case

      \ Diese beiden haben eigene Case-Fälle, weil beim Durchfallen weiter nach hinten immer weniger Optimierungen möglich werden.

      signal-ret of drop exit endof \ Definition zu Ende ? Fertig !
      signal-nop of           endof \ Eliminierte Sprungziel-Aufräumstellen gar nicht behandeln.
 signal-noptoken of           endof \ Eliminierte Token                     gar nicht behandeln.


      dup signal-branchtarget <> if false zuletzteinenunbedingtensprung ! then \ Um später auf unbedingte Sprünge treffende Branchtargets zu erkennen.


      signal-0branch of
                       parameter over +  ( Fadenadresse Sprungziel )

                       flagtrampolin @
                       if
                         compile-0-branch-trampolin \ Ein Sprung, der aus einem Flag gespeist wird, kann nie wegoptimiert werden.
                       else
                         \ Sollte TOS konstant false sein, muss der Sprung unbedingt stattfinden.
                         tos-konstant-false?
                         if
                           eliminiere-tos compilebranch \ Umgewandelt in einen unbedingten Sprung.
                         else
                           \ Sollte TOS konstant true sein, wird der Sprung nie ausgeführt. Lasse ihn weg, entferne die Aufräumstelle.
                           tos-konstant-true? if eliminiere-tos eliminiere-sprungziel else compile-0-branch then
                         then
                       then
                     endof

      flagschreiber \ Alle anderen Sachen können mit einem Flag nichts anfangen, muss also den Vergleich tatsächlich kompilieren.


      signal-branch  of         \ Unbedingte Sprünge. Beim "Vorspringen" alle Sprünge unterwegs prüfen und ihre Aufräumstellen eliminieren.
                       parameter over +  ( Fadenadresse Sprungziel )
                       compilebranch
                     endof

      signal-token   of
                       parameter dup ramallot> t@
                       if
                         \ Dieses Token ist ein Puffer oder eine Variable. Muss nun die Target-Adresse als Literal einfügen !
                         addrintarget> t@ compileliteral
                       else
                         dup inline?
                         if dup primitive> t@ if insertprimitive else dup adresszuordnungputzen recurse then
                         else tidyup-ra compilecalltotoken then
                       then
                     endof

      signal-literal of parameter compileliteral endof \ Literal holen und liegenlassen


      signal-data-addr of \ Adress-Datenblöcke benötigen kein Aufräumen zuvor. Muss nur die Adresse auf den Datenstack legen, die kann anschließend weiterbenutzt werden.
                         befreie-tos                     \ Adresse des Datenblocks auf den Stack legen
                         literal@pc+ state-tos !          \ Dafür den Zustand von TOS auf Konstante setzen
                         org @ 2 + state-tos 4 + !         \ und die richtige Adresse dort hinterlegen. Plus 2 für den Sprung-Opcode, der direkt folgt.
                         parameter ( Länge ) 2/ $3C00 or image, \ Sprung über den Datenblock generieren, hier direkt.
                         parameter ( Länge ) over 12 + ( Adresse ) swap t-inlinedata \ Datenblock inline einfügen
                       endof

      signal-data      of
                         tidyup-ra
                         parameter ( Länge ) over 12 + ( Adresse ) swap t-inlinedata \ Datenblock inline einfügen
                       endof


   signal-branchtarget of

                            dup curasnapshotgesetzt?
                            if \ Für diese Stelle existiert bereits ein Snapshot, für den nun Kontrollfluss-Vereinigungs-Vorbereitung nötig ist.

                              \ War das letzte Signal ein unbedingter Sprung ? Wenn ja, laufe ich hier nie vorbei und muss nicht aufräumen.
                              \ Es gibt natürlich noch den unsinnigen Fall, dass der Sprung direkt hierher kommt...
                              \ Aber dann ist dies der Ziel von dem Sprung selbst und es muss auch nichts aufgreäumt oder angepasst werden.

                                       zuletzteinenunbedingtensprung @ if
                                         dup 12 + loadsnapshot \ Gesicherten Cura-Snapshot laden
                                       else
                                         dup mit-tidyup-ra-in-diesen-zustand-aufräumen
                                       then

                            else \ Noch kein Snapshot angelegt. Alles in Register laden und den aktuellen Zustand vermerken.

                              alle-vorhandenen-elemente-in-register-laden  \ Alles, was nun im RA ist, soll in Registern sein
                              dup 12 + savesnapshot                         \ Vermerke die Registerbelegung für später

                            then


                            org @   over 8 + t! \ Dann muss allerdings auch die ORG-Stelle angepasst werden.
                            dup resolvejumps    \ Gibt es noch unaufgelöste Vorwärtssprünge zu dieser Stelle ? Falls ja, werden sie nun eingefügt.

                            false zuletzteinenunbedingtensprung !
                          endof

    endcase
    skip-element
  if exit then again \ until  -- Jump too far :-)

;

: t-crosstoken-irq ( token -- )

  org @ over addrintarget> t! \ Die Adresse im Target in der Primitive vermerken, damit sie angesprungen werden kann

  0 registerusage ! \ Noch wurden keine Register verwendet.

\  dup t-seetoken

  dup

    dup primitive> t@
    if insertprimitive
    else
      \ ." Unprimitive Definition" drop
      crosscompiledefinition
    then

    tidyup-ra

  registerusage> registerusage @ swap t! \ Die verwendeten Register vermerken.
;

: t-crosstoken ( token -- )
  \ org @ hex. dup t-name. cr  \ Wohin wird es kompiliert ?

  t-crosstoken-irq
  retopcode image,
;



: variableninit ( -- )
  \ Geht das Dictionary einmal komplett durch schreibt die Initialisierungswerte in die Variablen.

  t-dictionaryend
  begin

    dup raminit> t@ 0<
    if
      dup usage> t@ 0 >
      if
        \ ." Variable : "
        \ dup addrintarget> t@ hex. \ Die Adresse der Variablen im Ziel
        \ ." Anfangswert: "
        \ dup raminit> t@ $FFFF and hex. \ Der Initialisierungswert, der später geschrieben werden muss


        \ An dieser Stelle nun mov #..., &... Opcodes konstruieren, natürlich mit Konstantengenerator.

        dup raminit> t@ $FFFF and  \ Der Initialisierungswert, der später geschrieben werden muss
        $40B2 konstantengenerator   \ Natürlich kurze Konstanten optimieren
        dup addrintarget> t@ image,  \ Die Adresse der Variablen im Ziel

      then
    then

    t-dictionarybefore
  until
  drop
;

: reset-vorspann ( definition -- definition )
  \ Disable Watchdog, strictly necessary for real chips

  $40B2 image,  \ mov.w #5A80h, &120h
  $5A80 image,
  $0120 image,

  \ Prepare stack pointers

  $4031 image,  \ mov.w #const, r1
  initialreturnstack image,

  $4034 image,  \ mov.w #const, r4
  initialdatastack      image,

  \ Initialise variables
  variableninit
;

: reset-nachspann ( definition -- definition )
  $3FFF image, \ - jmp -   Endlosschleife als Falle
;


: unkanonisch? ( register -- ? ) \ Kommt dieser Register im kanonischen Grundzustand vor ? Wenn ja, braucht er nicht gesichert zu werden :-)

  dup kanonischer-zustand @ kanon-tos + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-nos + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-3os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-4os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-5os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-6os + @ = if drop false exit then

  dup kanonischer-zustand @ kanon-tor + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-nor + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-3or + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-4or + @ = if drop false exit then

  drop
  true
;



0 variable registersicherung
0 variable stellensicherung

\ Wenn Elemente auf Grund des kanonischen Rückfalls grundsätzlich im Register liegen, müssen diese Register nicht mehr separat gesichert zu werden.

: irq-push ( -- ) \ ." Push " registersicherung @ hex. cr \ exit

  registersicherung @

    5 unkanonisch? if   dup 1  5 lshift and if $1205 image, then   then
    6 unkanonisch? if   dup 1  6 lshift and if $1206 image, then   then
    7 unkanonisch? if   dup 1  7 lshift and if $1207 image, then   then
    8 unkanonisch? if   dup 1  8 lshift and if $1208 image, then   then
    9 unkanonisch? if   dup 1  9 lshift and if $1209 image, then   then
   10 unkanonisch? if   dup 1 10 lshift and if $120A image, then   then
   11 unkanonisch? if   dup 1 11 lshift and if $120B image, then   then
   12 unkanonisch? if   dup 1 12 lshift and if $120C image, then   then
   13 unkanonisch? if   dup 1 13 lshift and if $120D image, then   then
   14 unkanonisch? if   dup 1 14 lshift and if $120E image, then   then
   15 unkanonisch? if   dup 1 15 lshift and if $120F image, then   then

  drop
;

1 16 lshift constant wakeup-register \ Einfach eine Bitmaske, für die kein physikalischer Register existiert.

: irq-pop ( -- ) \ ." Pop " registersicherung @ hex. cr \ exit

  registersicherung @

   15 unkanonisch? if   dup 1 15 lshift and if $413F image, then   then
   14 unkanonisch? if   dup 1 14 lshift and if $413E image, then   then
   13 unkanonisch? if   dup 1 13 lshift and if $413D image, then   then
   12 unkanonisch? if   dup 1 12 lshift and if $413C image, then   then
   11 unkanonisch? if   dup 1 11 lshift and if $413B image, then   then
   10 unkanonisch? if   dup 1 10 lshift and if $413A image, then   then
    9 unkanonisch? if   dup 1  9 lshift and if $4139 image, then   then
    8 unkanonisch? if   dup 1  8 lshift and if $4138 image, then   then
    7 unkanonisch? if   dup 1  7 lshift and if $4137 image, then   then
    6 unkanonisch? if   dup 1  6 lshift and if $4136 image, then   then
    5 unkanonisch? if   dup 1  5 lshift and if $4135 image, then   then

  \ Falls dieser spezielle Aufwach-Register auftaucht, das Ende des Interruptvektors vor dem RETI noch mit einem bic.w #F0h, 0h(r1) Opcode ausstatten:
  wakeup-register and if $C0B1 image, $00F0 image, $0000 image, then
;

: irq-vorspann  ( definition -- definition )  dup vector> t@ $FFFE = if reset-vorspann  else irq-push               then ;
: irq-nachspann ( definition -- definition )  dup vector> t@ $FFFE = if reset-nachspann else irq-pop   $1300 image, then ;

: targetimage-vector ( definition -- definition )
  \ Eintrag in der Vektor-Tabelle anlegen
  org @ over vector> t@ image!  \ Vector table entry

  org @ stellensicherung ! \ Vermerken, wohin org nach Ende der Probekompilation zurückgesetzt werden muss

    dup t-crosstoken-irq \ Einmal zur Probe kompilieren, um zu sehen, welche Register dabei verwendet werden.
    dup registerusage> t@ registersicherung ! \ Die verwendeten Register merken

  \ Jetzt kennen wir den Registerbedarf und müssen die Kompilation zurücknehmen, damit der Interrupt-Rahmen geschrieben werden kann.

  dup adresszuordnungputzen
  stellensicherung @ org !

  \ Interrupt-Vorspann schreiben
  \ Hier kommt für den Reset-Vektor etwas anderes hin als für andere Vektoren, später.
  irq-vorspann

  \ Den Inhalt des Vektors schreiben - das kann, muss aber nicht Inline sein, falls die Definition in mehreren Vektoren verwendet wird.
  \ org @ hex. dup t-name. cr  \ Wohin wird es kompiliert ?
  dup t-crosstoken-irq

  \ Interrupt-Nachspann schreiben
  irq-nachspann
;

: variablenprobe ( -- )
  variablenpointer @ stackarea u>= if ." Ram full." cr quit then
;

: speicherbedarf ( -- )
    cr org @ flashstart -       ." Memory usage in Flash without vector table " u. ." bytes." cr
 variablenpointer @ ramstart -  ." Memory usage in RAM   without stacks       " u. ." bytes." cr
;

: crosscompile-pass ( -- )

  clearmemory        \ Speicher putzen
  flashstart org !    \ Anfangsadresse passend setzen
  ramstart variablenpointer ! \ Die RAM-Benutzung zurücksetzen
  init-ra              \ Den Registerallokator in den Urzustand zurückversetzen
  \ cr cr

  t-dictionaryend
  begin

    dup vector> t@ 0<>
    if

      targetimage-vector

    else \ Nein, es ist kein Interrupt-Vektor.
        dup usage> t@ 0<>
        if \ Diese Definition wird mindestens einmal verwendet.
           \ Soll sie kompiliert werden, oder muss an dieser Stelle Speicher angefordert werden ?

          dup ramallot> t@ 0<>
          if \ Speicher anfordern und Adresse im Target vermerken

            \ ." Speicher anfordern !"
            variablenpointer @ over addrintarget> t! \ Vermerke die RAM-Adresse in dem Feld der "Target-Adresse" der Primitive.
            dup ramallot> t@ variablenpointer +! variablenprobe \ RAM-Adresse im Target weiterrücken

          else \ Normal kompilieren
            dup inline? not
            if dup ( .s ) t-crosstoken then
          then
        then
    then
    t-dictionarybefore
  until
  drop

;

0 variable pass#

: crosscompile ( -- )

  0 pass# !

  make-clean         \ Alle Reste vorhergegangener Kompilationen putzen
  verwendungsproben   \ Prüfen, welche Definitionen verwendet werden

  begin
    false noch-ein-pass? !
    false schon-ein-snapshot-festgelegt? !
    1 pass# +!

    \ cr
    \ ." ----------------------------------------------------------------" cr
    \ ."   Pass " pass# @ . cr
    \ ." ----------------------------------------------------------------" cr
    crosscompile-pass
    \ speicherbedarf

    noch-ein-pass? @
  while
    verwendungsputzen
    verwendungsproben
  repeat


  speicherbedarf
  ." Required passes: " pass# @ . cr
;
\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Konstanten, Variablen und Puffer definieren
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ -----------------------------------------------------------------------------
\  Konstanten
\ -----------------------------------------------------------------------------

: t-constant ( n -- ) \ Lege eine Definition an, die eigentlich nur ein Literal zurückgibt und anschließend Faltbarkeit und Inline für diese Definition setzt.
  t:
  t-literal
  t-ret,  
  0 t-foldable
;

' t-constant t-prim: constant t-hostonly \ Kann so zwar keine "Konstenten kompilieren", aber das macht ja nichts - im Target gibt's sowieso keinen Parser.

\ -----------------------------------------------------------------------------
\  Variablen und Puffer
\ -----------------------------------------------------------------------------

: t-variable ( n -- )
  t:
  t-here 2 3 * cells +  \ Eine Adresse auf die kommende "Variablenstelle" anlegen
  t-literal
  t-ret,  
  dup t,       \ Initialisierungswert als ersten Variableninhalt setzen
    t-raminit  \ Vermerke den Initialisierungswert, der im Reset-Vektor geschrieben werden soll
  2 t-ramallot \ Markiere, dass diese Definition bei ihrer Kompilation RAM anfordert.
;

' t-variable t-prim: variable t-hostonly

\ Habe jetzt eine Variable definiert, die im Host ab dieser Adresse zu erreichen ist.
\ Sie muss ein besonderes Flag bekommen, das "ramallot"-Flag.


: cellsforbytes ( u -- u* ) 2 rshift 1 + ; \ Das gilt so streng genommen im ARM.

: t-buffer: ( bytes -- )
  2 umax \ Puffer müssen mindestens zwei Bytes reservieren, sonst gibt's Probleme mit der Ramallot-Logik

  t:
  t-here 2 3 * cells +  \ Eine Adresse auf die kommende "Variablenstelle" anlegen
  t-literal
  t-ret,
  
  dup cellsforbytes 0 ?do 0 t, loop 
  even t-ramallot \ Markiere, dass diese Definition bei ihrer Kompilation RAM anfordert. Vielfache von 2 nötig.
;

' t-buffer: t-prim: buffer: t-hostonly
 
\
\    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/>.
\


\ -----------------------------------------------------------------------------
\  Primitiven neu durchdacht. Stackjongleure
\ -----------------------------------------------------------------------------

\ Primitiven müssen zwei Teile besitzen:
\  Einen zum Ausführen und einen zum Kompilieren im RA.

: t-dup     ( x -- x x ) dup ;
: t-dup-ra  ( -- ) \ exit
    expect-one-element
    tos-fetchsperre    \ Speicherstellen nicht zweimal lesen.
    befreie-tos
    state-nos 2@ state-tos 2!
;

' t-dup  ' t-dup-ra  t-prim-ra:  dup  t-inline  1 t-foldable



: t-swap-intern ( -- ) \ Falls klar ist, dass diese beiden Elemente wirklich getauscht werden sollen, egal, was sie enthalten.
  state-nos 2@ 2>r
      state-tos 2@  state-nos 2!
    2r> state-tos 2!
;    

: t-swap     ( x1 x2 -- x2 x1 ) swap ;
: t-swap-ra  ( -- )
    expect-two-elements
    \ tos-fetchsperre  \ Entfernt, denn es geht hier nur um die Anordnung der einzelnen Lesezugriffe
    t-swap-intern
;

' t-swap  ' t-swap-ra  t-prim-ra:  swap  t-inline  2 t-foldable



: t-drop    ( x -- ) drop ;
: t-drop-ra ( -- ) state-tos @ unknown = if $5324 image, else ( tos-fetchsperre ) eliminiere-tos then ;
' t-drop  ' t-drop-ra  t-prim-ra:  drop  t-inline  1 t-foldable


\ -----------------------------------------------------------------------------
\  Primitiven neu durchdacht. Returnstack.
\ -----------------------------------------------------------------------------

\ Ein kleiner, einfacher, zirkularer R-Stack fürs Target, nur, um ein paar Werte mal zwischenzuspeichern.

32 cells buffer: r-stack
0 variable r-stack-pointer

: t->r    ( x -- ) r-stack-pointer @ 1+ $1F and r-stack-pointer !
                   r-stack-pointer @ cells r-stack + ! ;                   
: t->r-ra ( -- ) expect-one-element befreie-tor state-tos 2@ state-tor 2! eliminiere-tos ; \ Ein Fetch darf in ROT mitwandern :-)
' t->r  ' t->r-ra  t-prim-ra: >r  t-inline

: t-r@    ( -- x ) r-stack-pointer @ cells r-stack + @ ;
: t-r@-ra ( -- ) expect-one-r-element befreie-tos state-tor 2@ state-tos 2! tos-fetchsperre state-tos 2@ state-tor 2!  ;  \ Jedes Fetch nur einmal durchführen. r@ käme aber sonst einem dup gleich.
' t-r@  ' t-r@-ra  t-prim-ra: r@  t-inline

: t-r>    ( -- x ) t-r@    r-stack-pointer @ 1- $1F and r-stack-pointer ! ;
: t-r>-ra ( -- ) expect-one-r-element befreie-tos state-tor 2@ state-tos 2! \ Wie r@ nur ohne Fetchsperre, damit auch einmal eine Variable oder Speicherstelle über den R-Stack wandern kann.
                 eliminiere-tor ;
' t-r>  ' t-r>-ra  t-prim-ra: r>  t-inline

\ -----------------------------------------------------------------------------
\  Zusammengesetzte Stackjongleure, direkt im Target definiert.
\ -----------------------------------------------------------------------------

\ Durch konsequentes Inlining keinen Performanceverlust !

target
  : rot   >r swap r> swap     inline  3-foldable  ;
  : -rot  rot rot             inline  3-foldable  ;
  : over  >r dup r> swap      inline  2-foldable  ;
  : nip   swap drop           inline  2-foldable  ;  
  : tuck  swap over           inline  2-foldable  ;
  : rdrop r> drop             inline              ;
  
  : 2drop drop drop           inline  2-foldable  ;
  : 2dup  over over           inline  2-foldable  ;
  : 2swap >r -rot r> -rot     inline  4-foldable  ;
host
\
\    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/>.
\


\ Diese Primitiven hier laden ALLES ausnahmslos zuerst in Register, oder genauer: Lassen in Register laden.
\ Für neue besondere Adressierfälle muss ich hier also nichts mehr hinzufügen.

\ -----------------------------------------------------------------------------
\   Rechnungen und Logik mit einem Operanden, für die es Opcodes im Prozessor gibt
\ -----------------------------------------------------------------------------

: t-not    ( n -- ~n ) not $FFFF and ;

: t-not-ra ( -- ) einekonstante? if einekonstante t-not ergebnismerken else
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $E330 state-tos @ or image,  \ xor #-1, r...
  then
;

\ Not wird in manchen Zusammensetzungen benötigt, aber für nach außen ist es praktischer, es via -1 xor zu definieren.
\ Dies hier braucht zwar während des Kompilierens ein Element weniger im RA, kann aber nicht so gut überoptimiert werden.
\ ' t-not  ' t-not-ra  t-prim-ra: not  t-inline  1 t-foldable


: t-shl    ( n -- n<<1 ) shl $FFFF and ;
: t-shl-ra ( -- ) einekonstante? if einekonstante t-shl ergebnismerken else
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $5000 state-tos @ or state-tos @ 8 lshift or
  image,
  then
;

: t-shr    ( n -- n>>1 ) shr ;
: t-shr-ra ( -- ) einekonstante? if einekonstante t-shr ergebnismerken else
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $C312 image, \ bic.w #1h, r2
  $1000 state-tos @ or image,  \ rrc r...
  then
;

: t-2/    ( n -- n>>>1 ) dup shr swap $8000 and or ; \ 16-Bit-Vorzeichen beachten
: t-2/-ra ( -- ) einekonstante? if einekonstante t-2/ ergebnismerken else
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $1100 state-tos @ or image,  \ rra r...
  then
;

' t-shl     ' t-shl-ra     t-prim-ra: shl     t-inline  1 t-foldable
' t-shl     ' t-shl-ra     t-prim-ra: 2*      t-inline  1 t-foldable
' t-shr     ' t-shr-ra     t-prim-ra: shr     t-inline  1 t-foldable
' t-2/      ' t-2/-ra      t-prim-ra: 2/      t-inline  1 t-foldable


: t-><    ( 00hl -- 00lh ) dup   $FF and 8 lshift   swap   8 rshift $FF and   or  ; \ Swap Bytes.
: t-><-ra ( -- ) einekonstante? if einekonstante t->< ergebnismerken else
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $1080 state-tos @ or image,  \ swpb r...
  then
;

' t-><      ' t-><-ra      t-prim-ra: ><      t-inline 1-foldable

\ -----------------------------------------------------------------------------
\  Rotationen, die lassen sich auch hübsch einbauen
\ -----------------------------------------------------------------------------

: t-rol    ( x -- x* ) dup $8000 and if shl 1 or else shl then $FFFF and ;
: t-rol-ra ( -- ) einekonstante? if einekonstante t-rol ergebnismerken exit then

  expect-one-element
  expect-tos-in-register
  make-tos-changeable

  $5000 state-tos @ or state-tos @ 8 lshift or image, \ add r..., r...
  $6300 state-tos @ or image, \ addc #0, r...
;

: t-ror    ( x -- x* ) dup 1 and if shr $8000 or else shr then $FFFF and ;
: t-ror-ra ( -- ) einekonstante? if einekonstante t-ror ergebnismerken exit then
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $C312 image, \ bic.w #1h, r2
  $1000 state-tos @ or image,  \ rrc r...
  $2802 image, \ jnc 2+
  $D030 state-tos @ or image,  \ bis.w #8000h, r...
  $8000 image,
;

' t-rol     ' t-rol-ra     t-prim-ra: rol     t-inline  1 t-foldable
' t-ror     ' t-ror-ra     t-prim-ra: ror     t-inline  1 t-foldable

\ -----------------------------------------------------------------------------
\  Lange Helferlein für Doppeltzahlen, hübsch zusammengesetzt:
\ -----------------------------------------------------------------------------

: t-dshl    ( low1 high1 -- low high ) 16l16h->32 shl 32->16l16h ;

: t-dshl-ra ( -- ) t-swap-intern

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $5000 state-tos @ or state-tos @ 8 lshift or
  image,

                   t-swap-intern

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $6000 state-tos @ or state-tos @ 8 lshift or
  image,
                   ;

' t-dshl  ' t-dshl-ra  t-prim-ra: dshl  t-inline  2 t-foldable
' t-dshl  ' t-dshl-ra  t-prim-ra: d2*   t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-dshr    ( low1 high1 -- low high ) 16l16h->32 shr 32->16l16h ;

: t-dshr-ra ( -- )

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $C312 image, \ bic.w #1h, r2
  $1000 state-tos @ or image,  \ rrc r...

                   t-swap-intern

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $1000 state-tos @ or image,  \ rrc r...

                   t-swap-intern
                   ;

' t-dshr  ' t-dshr-ra  t-prim-ra: dshr  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-d2/    ( low1 high1 -- low high ) 16l16h->32 2/ 32->16l16h ;

: t-d2/-ra ( -- )

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $1100 state-tos @ or image,  \ rra r...

                   t-swap-intern

  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $1000 state-tos @ or image,  \ rrc r...

                   t-swap-intern
                   ;

' t-d2/  ' t-d2/-ra  t-prim-ra: d2/  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------
\   Stromsparmodi, benötigen keine Operanden
\   Lassen sich auch im Host während der Emulation ausführen.
\ -----------------------------------------------------------------------------

: t-lpm ( -- ) ." LPM. Press any key." cr key drop ;

: t-lpm0-ra ( -- ) tidyup-ra $D032 image,  $0018 image, ;  \ bis.w #18h, r2
: t-lpm1-ra ( -- ) tidyup-ra $D032 image,  $0058 image, ;  \ bis.w #58h, r2
: t-lpm2-ra ( -- ) tidyup-ra $D032 image,  $0098 image, ;  \ bis.w #98h, r2
: t-lpm3-ra ( -- ) tidyup-ra $D032 image,  $00D8 image, ;  \ bis.w #D8h, r2
: t-lpm4-ra ( -- ) tidyup-ra $D032 image,  $00F8 image, ;  \ bis.w #F8h, r2

: t-eint-ra ( -- ) tidyup-ra $D232 image,               ;  \ bis.w #8h, r2
: t-dint-ra ( -- ) tidyup-ra $C232 image,               ;  \ bic.w #8h, r2

\ Setzt einen besonderen "Register", welcher schließlich als Aufwach-Opcode an das Ende von Interruptvektoren gesetzt wird.
: t-wakeup-ra ( -- ) wakeup-register registerusage bis! ;

' t-lpm     ' t-lpm0-ra    t-prim-ra: lpm0    t-inline
' t-lpm     ' t-lpm1-ra    t-prim-ra: lpm1    t-inline
' t-lpm     ' t-lpm2-ra    t-prim-ra: lpm2    t-inline
' t-lpm     ' t-lpm3-ra    t-prim-ra: lpm3    t-inline
' t-lpm     ' t-lpm4-ra    t-prim-ra: lpm4    t-inline

' nop       ' t-eint-ra    t-prim-ra: eint    t-inline
' nop       ' t-dint-ra    t-prim-ra: dint    t-inline
' nop       ' t-wakeup-ra  t-prim-ra: wakeup  t-inline

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


\ -----------------------------------------------------------------------------
\   Rechnungen und Logik mit zwei Operanden, für die es Opcodes im Prozessor gibt
\ -----------------------------------------------------------------------------

: doppeltoperand-nichtkommutativ ( opcode -- )
     
     tos-bytesperre t-swap-intern tos-bytesperre t-swap-intern
     
     state-tos 2@ 2>r
     
       dup $9000 = \ CMP-Opcodes benötigen im Zweifelsfalle keine Elementkopie, weil sie das Ziel nicht verändern.
       if
         state-nos @ fetchworddestination? not if expect-nos-in-register then \ Der besondere Fall, dass NOS eine Speicherstelle oder ein @Register-Fetch ist, kann in den CMP-Opcodes nach der Bytesperre direkt behandelt werden.
         state-tos @ operand-for-double or  \ Kann damit alles mögliche in den Opcode einbauen !
         eliminiere-tos
         
         state-tos @ $F and or  \ Register für den Zieloperanden setzen
         state-tos @ fetchworddestination? if $0080 or then \ Und bei Bedarf auch das "Index-Bit"         
         
         2r> indexed? if swap konstantengenerator else drop image, then \ Adresse oder Literal anfügen, falls nötig
         
         state-tos @ fetchworddestination? if state-tos cell+ @ image, then \ Falls es eine Speicherstelle gewesen ist, gleich noch die absolute Adresse anfügen.
       else
         expect-nos-in-register \ NOS wird nun in jedem Fall verändert. 
         t-swap-intern make-tos-changeable t-swap-intern \ NOS bei Bedarf via Elementkopie duplizieren 
         
         state-tos @ operand-for-double or  \ Kann damit alles mögliche in den Opcode einbauen !
         eliminiere-tos
         state-tos @ or
         
         2r> indexed? if swap konstantengenerator else drop image, then \ Adresse oder Literal anfügen, falls nötig
       then
;

: doppeltoperand-kommutativ ( opcode -- )

    \ Der Tausch findet nur statt, wenn es mindestens einen Register gibt. Es werden also nie zwei "unknowns" vertauscht.
    \ Wenn TOS ein Register ist, umtauschen. So kann ich möglichst viele "Sonderfälle" als Quelloperand verwenden, und den Register in NOS behalten.
    
    state-tos @ reg15 u<= if t-swap-intern then \ Versuche einen Register als Zieloperanden zu bekommen
       
    doppeltoperand-nichtkommutativ
;

\ -----------------------------------------------------------------------------
\ Kommutative Helferlein, umgebaut, so dass nach Wunsch auch direkt ein Sprung folgen kann
\ -----------------------------------------------------------------------------

: t-+    ( n1 n2 -- n3 ) + $FFFF and ;

: t-+-ra-flag   ( -- )          $5000 doppeltoperand-kommutativ ;
: t-+-ra-sprung ( -- Opcode )   $5000 doppeltoperand-kommutativ eliminiere-tos $2400 ; \ jz-Opcode

: t-+-ra        ( -- )          zweikonstanten? if zweikonstanten t-+ ergebnismerken else 
                                    ['] t-+-ra-flag     flagtrampolin !
                                    ['] t-+-ra-sprung sprungtrampolin !
                                  then ;
                         
' t-+  ' t-+-ra  t-prim-ra: +  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

\ Der bis = or Opcode setzt keine Flags.

: t-or    ( n1 n2 -- n3 ) or ;
: t-or-ra ( -- ) zweikonstanten? if zweikonstanten t-or ergebnismerken else $D000 doppeltoperand-kommutativ then ;
' t-or  ' t-or-ra  t-prim-ra: or  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-xor    ( n1 n2 -- n3 ) xor ;

: t-xor-ra-flag   ( -- )        $E000 doppeltoperand-kommutativ ;
: t-xor-ra-sprung ( -- Opcode ) $E000 doppeltoperand-kommutativ eliminiere-tos $2400 ; \ jz-Opcode

: t-xor-ra        ( -- )        zweikonstanten? if zweikonstanten t-xor ergebnismerken else 
                                  ['] t-xor-ra-flag     flagtrampolin !
                                  ['] t-xor-ra-sprung sprungtrampolin !
                                then ;
                         
' t-xor  ' t-xor-ra  t-prim-ra: xor  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-and    ( n1 n2 -- n3 ) and ;

: t-and-ra-flag   ( -- )        $F000 doppeltoperand-kommutativ ;
: t-and-ra-sprung ( -- Opcode ) $F000 doppeltoperand-kommutativ eliminiere-tos $2400 ; \ jz-Opcode

: t-and-ra        ( -- )        zweikonstanten? if zweikonstanten t-and ergebnismerken else 
                                  ['] t-and-ra-flag     flagtrampolin !
                                  ['] t-and-ra-sprung sprungtrampolin !
                                then ;
                         
' t-and  ' t-and-ra  t-prim-ra: and  t-inline  2 t-foldable
                         
\ -----------------------------------------------------------------------------                                                 
\ Nichtkommutative Helferlein
\ -----------------------------------------------------------------------------

: t--      ( n1 n2 -- n3 ) - $FFFF and ;

: t---ra-flag   ( -- )          $8000 doppeltoperand-nichtkommutativ ;
: t---ra-sprung ( -- Opcode )   $8000 doppeltoperand-nichtkommutativ eliminiere-tos $2400 ; \ jz-Opcode

: t---ra        ( -- )          zweikonstanten? if zweikonstanten t-- ergebnismerken else 
                                    ['] t---ra-flag     flagtrampolin !
                                    ['] t---ra-sprung sprungtrampolin !
                                  then ;
                         
' t--  ' t---ra  t-prim-ra: -  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

\ Der bic Opcode setzt keine Flags.

: t-bic    ( n1 n2 -- n3 ) bic ;
: t-bic-ra ( -- ) zweikonstanten? if zweikonstanten t-bic ergebnismerken else $C000 doppeltoperand-nichtkommutativ then ;
' t-bic  ' t-bic-ra  t-prim-ra: bic  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

target

: not -1 xor inline 1-foldable ;

: 1+   1 +   inline 1-foldable ;
: 1-   1 -   inline 1-foldable ;
: 2+   2 +   inline 1-foldable ;
: 2-   2 -   inline 1-foldable ;

host

\ -----------------------------------------------------------------------------
\  Lange Helferlein für Doppeltzahlen, hübsch zusammengesetzt:
\ -----------------------------------------------------------------------------

: t-d+    ( low1 high1 low2 high2 -- low high ) 2>r 16l16h->32 2r> 16l16h->32 + 32->16l16h ;
: t-d+-ra ( -- ) t->r-ra t-swap-intern t->r-ra
                 $5000 doppeltoperand-kommutativ
                 t-r>-ra t-r>-ra
                 $6000 doppeltoperand-kommutativ ;
' t-d+  ' t-d+-ra  t-prim-ra: d+  t-inline  4 t-foldable

\ -----------------------------------------------------------------------------

: t-d-    ( low1 high1 low2 high2 -- low high ) 2>r 16l16h->32 2r> 16l16h->32 - 32->16l16h ;
: t-d--ra ( -- ) t->r-ra t-swap-intern t->r-ra
                 $8000 doppeltoperand-nichtkommutativ
                 t-r>-ra t-r>-ra
                 $7000 doppeltoperand-nichtkommutativ ;
' t-d-  ' t-d--ra  t-prim-ra: d-  t-inline  4 t-foldable

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


\ -----------------------------------------------------------------------------
\   Vergleiche, die durch ihre vielfältigen Optimierungen ziemlich aufwändig geworden sind
\ ----------------------------------------------------------------------------- 

: sign16 ( s16 -- n ) [ $b236 h, ] inline ; \ sxth r6, r6 Opcode

: subc-tos-tos ( -- ) $7000 state-tos @ or state-tos @ 8 lshift or image, ;

: vergleichsvorbereitung-kommutativ ( -- ) \ Schreibt den für Vergleiche nötigen cmp-Opcode mit allen Varianten.
                    $9000 doppeltoperand-kommutativ  \ cmp Opcode
                    eliminiere-tos
;

: vergleichsvorbereitung ( -- ) \ Schreibt den für Vergleiche nötigen cmp-Opcode mit allen Varianten.
                    $9000 doppeltoperand-nichtkommutativ  \ cmp Opcode
                    eliminiere-tos
;

: tos-registerwechsel ( -- ) \ Gibt den Register frei und legt TOS in einen neuen Register.
  eliminiere-tos
  befreie-tos
  get-free-register state-tos !
;


: sprung-in-flag-verwandeln ( sprungopcode -- ) \ Schreibt die Opcodes, die nötig sind, um aus diesem sprungopcode für 0-branch ein Flag auf dem Stack zu erzeugen.
  \ ." Sprung in Flag verwandeln" cr
  tos-bytesperre
  $9000 doppeltoperand-nichtkommutativ
  tos-registerwechsel

  case
  
    $2000 of ( ." jnz " ) $B322 image, subc-tos-tos t-not-ra endof \ bit.w #2h, r2
    $2400 of ( ." jz "  ) $B322 image, subc-tos-tos          endof
    
    $2800 of ( ." jnc " ) subc-tos-tos t-not-ra  endof
    $2C00 of ( ." jc "  ) subc-tos-tos           endof          
          
    \ Für die anderen Fälle habe ich leider keine starken Optimierungen.
    \ Konstruiere stattdessen also einen Sprung-Flagsetzer...
    
    $4300 state-tos @ or image,  \ mov #0, tos
    dup 1 or image,                 \ j** +
    $4330 state-tos @ or image,  \ mov #-1, tos       
  endcase
;

\ -----------------------------------------------------------------------------

: t-=      ( x1 x2 -- ? ) = $FFFF and ;

: t-=-ra-flag ( -- ) \ Dies ist ein Spezialfall, der so kürzer ist und deshalb bleiben sollte.
                    tos-bytesperre
                    $E000 doppeltoperand-kommutativ \ xor
                    subc-tos-tos
;                    

: t-=-ra-sprung ( -- Opcode ) vergleichsvorbereitung $2000 ; \ jnz-Opcode

: t-=-ra   ( -- ) zweikonstanten? if zweikonstanten t-= ergebnismerken else 
                    ['] t-=-ra-flag     flagtrampolin !
                    ['] t-=-ra-sprung sprungtrampolin !
                  then ;
                  
' t-=  ' t-=-ra  t-prim-ra: =  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-<>     ( x1 x2 -- ? ) <> $FFFF and ;

: t-<>-ra-flag ( -- ) $2400 sprung-in-flag-verwandeln ;                    

: t-<>-ra-sprung ( -- Opcode ) vergleichsvorbereitung-kommutativ $2400 ; \ jz-Opcode
                  
: t-<>-ra   ( -- ) zweikonstanten? if zweikonstanten t-<> ergebnismerken else 
                    ['] t-<>-ra-flag     flagtrampolin !
                    ['] t-<>-ra-sprung sprungtrampolin !
                  then ;
                  
' t-<>  ' t-<>-ra  t-prim-ra: <>  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-u<     ( x1 x2 -- ? ) sign16 swap sign16 swap u< $FFFF and ;

: t-u<-ra-flag ( -- ) $2C00 sprung-in-flag-verwandeln ;

: t-u<-ra-sprung ( -- Opcode ) vergleichsvorbereitung $2C00 ; \ jc-Opcode

: t-u<-ra   ( -- ) zweikonstanten? if zweikonstanten t-u< ergebnismerken else 
                    ['] t-u<-ra-flag     flagtrampolin !
                    ['] t-u<-ra-sprung sprungtrampolin !
                  then ;
                  
' t-u<  ' t-u<-ra  t-prim-ra: u<  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-u>=     ( x1 x2 -- ? ) sign16 swap sign16 swap u>= $FFFF and ;

: t-u>=-ra-flag ( -- ) $2800 sprung-in-flag-verwandeln ;

: t-u>=-ra-sprung ( -- Opcode ) vergleichsvorbereitung $2800 ; \ jnc-Opcode

: t-u>=-ra   ( -- ) zweikonstanten? if zweikonstanten t-u>= ergebnismerken else 
                    ['] t-u>=-ra-flag     flagtrampolin !
                    ['] t-u>=-ra-sprung sprungtrampolin !
                  then ;
                  
' t-u>=  ' t-u>=-ra  t-prim-ra: u>=  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t-<      ( x1 x2 -- ? ) sign16 swap sign16 swap < $FFFF and ;
                                    
: t-<-ra-flag ( -- ) $3400 sprung-in-flag-verwandeln ;

: t-<-ra-sprung ( -- Opcode ) vergleichsvorbereitung $3400 ; \ jl-Opcode

: t-<-ra   ( -- ) zweikonstanten? if zweikonstanten t-< ergebnismerken else 
                    ['] t-<-ra-flag     flagtrampolin !
                    ['] t-<-ra-sprung sprungtrampolin !
                  then ;
                                    
' t-<  ' t-<-ra  t-prim-ra: <  t-inline  2 t-foldable

\ -----------------------------------------------------------------------------

: t->=      ( x1 x2 -- ? ) sign16 swap sign16 swap >= $FFFF and ;
                                    
: t->=-ra-flag ( -- ) $3800 sprung-in-flag-verwandeln ;

: t->=-ra-sprung ( -- Opcode ) vergleichsvorbereitung $3800 ; \ jge-Opcode

: t->=-ra   ( -- ) zweikonstanten? if zweikonstanten t->= ergebnismerken else 
                    ['] t->=-ra-flag     flagtrampolin !
                    ['] t->=-ra-sprung sprungtrampolin !
                  then ;
                                    
' t->=  ' t->=-ra  t-prim-ra: >=  t-inline  2 t-foldable

-----------------------------------------------------------------------------

target  \ Diese hier werden vom RA sehr gut von selbst zusammengebaut... Die umgekehrten Sprünge habe ich nicht - also keine weitere Optimierung so einfach möglich.

  : 0=   0 =       inline 1-foldable ;
  : 0<   0 <       inline 1-foldable ;
  : 0<>  0 <>      inline 1-foldable ;
    
  \ Erstmal zu Testzwecken, damit beim Probieren alles stimmt:
  \ : u>=  u< not inline 2-foldable ;
  \ :  >=   < not inline 2-foldable ;
    
  : u>   swap u<   inline 2-foldable ;  
  : u<=  swap u>=  inline 2-foldable ;
  
  : >    swap <    inline 2-foldable ;  
  : <=   swap >=   inline 2-foldable ;
      
host
\
\    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/>.
\

\ -----------------------------------------------------------------------------
\   Speicher holen und schreiben
\ -----------------------------------------------------------------------------

\ Byte-Fetch darf nicht überall weiterverpflanzt werden, weil sonst Byte-Opcodes überall auftauchen würden... Und Forth rechnet ja intern mit 16 Bits weiter.


: t-@    ( addr -- x ) th@ ;
: t-c@   ( addr -- x ) tc@ ;



: t-@-ra ( -- ) \ Kann von einem Literal oder einem Register direkt holen. Alles andere zuvor in einen Register laden.

         expect-one-element
         state-tos @ literal?
         if
           fetchabsolute state-tos ! \ Aus dem Literal ein "Fetch Absolute" machen. Die Konstante bleibt als Adresse.
         else
           expect-tos-in-register \ Falls TOS schon im Register war, ändert sich nun nichts.    
           state-tos @ fetchbit or state-tos ! \ Vermerken, dass jetzt von dem Register geholt werden muss, was ja auch als Parameter hier und da verwendet werden kann :-)
           0 state-tos cell+ ! \ Index 0 falls das als Zieloperand irgendwo auftauchen sollte.
         then
         ;

: t-c@-ra ( -- ) \ Kann von einem Literal oder einem Register direkt holen. Alles andere zuvor in einen Register laden.

         expect-one-element
         state-tos @ literal?
         if
           fetchabsolute bytebit or state-tos ! \ Aus dem Literal ein "Fetch Absolute" machen. Die Konstante bleibt als Adresse.
         else
           expect-tos-in-register \ Falls TOS schon im Register war, ändert sich nun nichts.
           state-tos @ fetchbit bytebit or or state-tos ! \ Vermerken, dass jetzt von dem Register geholt werden muss, was ja auch als Parameter hier und da verwendet werden kann :-)         
           0 state-tos cell+ ! \ Index 0 falls das als Zieloperand irgendwo auftauchen sollte.
         then
         ;

         
' t-@   ' t-@-ra   t-prim-ra: @   t-inline         
' t-c@  ' t-c@-ra  t-prim-ra: c@  t-inline

\ Flush wird benötigt, wenn ein Lesezugriff jetzt und unbedingt stattfinden soll.

: t-flush-ra ( -- ) tos-fetchsperre ;
' nop ' t-flush-ra t-prim-ra: flush t-inline

\ -----------------------------------------------------------------------------

\ Store muss stets den indizierten Modus verwenden, weil es an diese ADRESSE hingeschrieben werden soll, nicht in einen Register.
\ Entweder das Ziel ist ein Literal, dann mit r2 einfügen, oder es muss in einem Register liegen.

: store-ra ( opcode -- ) \ Kann fast alles direkt verwenden. Nur Byte-Schreibzugriffe müssen vorher die Elemente in den RA laden, weil sie sonst den Stackpointer ungerade machen würden.

    expect-one-element \ Der Zieloperand, die Adresse, darf nicht mehr auf dem Stack liegen. Das kann nun eine Konstante sein, ein Register, oder ein Fetch...
    
    state-tos @ literal@pc+ =
    if \ Literals können als absolute Adresse direkt eingefügt werden
      $0082 or
      state-tos cell+ @
    else \ Alles andere muss zuvor in einen Register geladen werden
      expect-tos-in-register
      state-tos @ or $0080 or
      0
    then
    
    ( opcode* index )                
    swap
        
    state-nos @ operand-for-double or ( Ziel-Index Opcode-mit-Quelle )
    state-nos @ indexed? if state-nos cell+ @ swap konstantengenerator else image, then \ Quelloperand anfügen, falls vorhanden
    image,
      
    eliminiere-tos eliminiere-tos    
;    

: t-!    ( x addr -- ) th! ;           
: t-!-ra ( -- ) tos-bytesperre $4000 store-ra ;  \ Mov-Opcode
' t-!  ' t-!-ra  t-prim-ra: !  t-inline

: t-+!    ( x addr -- ) dup >r th@ + r> th! ;           
: t-+!-ra ( -- ) tos-bytesperre $5000 store-ra ;
' t-+!  ' t-+!-ra  t-prim-ra: +!  t-inline

: t-bic!    ( x addr -- ) dup >r th@ swap bic r> th! ;           
: t-bic!-ra ( -- ) tos-bytesperre $C000 store-ra ;
' t-bic!  ' t-bic!-ra  t-prim-ra: bic!  t-inline

: t-bis!    ( x addr -- ) dup >r th@ or r> th! ;           
: t-bis!-ra ( -- ) tos-bytesperre $D000 store-ra ;
' t-bis!  ' t-bis!-ra  t-prim-ra: bis!  t-inline

: t-xor!    ( x addr -- ) dup >r th@ xor r> th! ;           
: t-xor!-ra ( -- ) tos-bytesperre $E000 store-ra ;
' t-xor!  ' t-xor!-ra  t-prim-ra: xor!  t-inline


: t-c!    ( x addr -- ) tc! ;           
: t-c!-ra ( -- ) expect-two-elements $4040 store-ra ; \ Mov.b Opcode  Byte-Befehle dürfen nicht direkt vom Stack laden, weil sie sonst den Stackpointer durcheinander bringen.
' t-c!  ' t-c!-ra  t-prim-ra: c!  t-inline

: t-cbic!    ( x addr -- ) dup >r tc@ swap bic r> tc! ;           
: t-cbic!-ra ( -- ) $C040 store-ra ;
' t-cbic!  ' t-cbic!-ra  t-prim-ra: cbic!  t-inline

: t-cbis!    ( x addr -- ) dup >r tc@ or r> tc! ;           
: t-cbis!-ra ( -- ) $D040 store-ra ;
' t-cbis!  ' t-cbis!-ra  t-prim-ra: cbis!  t-inline

: t-cxor!    ( x addr -- ) dup >r tc@ xor r> tc! ;           
: t-cxor!-ra ( -- ) $E040 store-ra ;
' t-cxor!  ' t-cxor!-ra  t-prim-ra: cxor!  t-inline


\ Das Päärchen bit@ und cbit@ ist eine Mischung aus einem besonderen "Speicherschreiben-Opcode" (der aber nur liest) und einem Vergleich, der direkt in Sprünge eingepflegt werden kann.
\ Deshalb ist hier die Behandlung ziemlich aufwändig !

\ -----------------------------------------------------------------------------

: t-bit@    ( x addr -- ) th@ and 0<> $FFFF and ;           

: t-bit@-ra-flag ( -- ) tos-bytesperre befreie-tos eliminiere-tos ( Register freischaufeln ) $B000 store-ra $B322 image, befreie-tos get-free-register state-tos ! subc-tos-tos ;

: t-bit@-ra-sprung ( -- ) $B000 store-ra $2400 ; \ jz-Opcode

: t-bit@-ra ( -- )  ['] t-bit@-ra-flag     flagtrampolin !  \ Hier kann nie gefaltet werden - also stets etwas zu tun !
                    ['] t-bit@-ra-sprung sprungtrampolin !  ;

' t-bit@  ' t-bit@-ra  t-prim-ra: bit@  t-inline

\ -----------------------------------------------------------------------------

: t-cbit@    ( x addr -- ) tc@ and 0<> $FFFF and ;           

: t-cbit@-ra-flag ( -- ) befreie-tos eliminiere-tos ( Register freischaufeln ) $B040 store-ra $B322 image, befreie-tos get-free-register state-tos ! subc-tos-tos ;

: t-cbit@-ra-sprung ( -- ) $B040 store-ra $2400 ; \ jz-Opcode

: t-cbit@-ra ( -- )  ['] t-cbit@-ra-flag     flagtrampolin !  \ Hier kann nie gefaltet werden - also stets etwas zu tun !
                     ['] t-cbit@-ra-sprung sprungtrampolin !  ;

' t-cbit@  ' t-cbit@-ra  t-prim-ra: cbit@  t-inline

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


\ -----------------------------------------------------------------------------
\   Schieben
\ -----------------------------------------------------------------------------

: $FF-and-opcode ( -- ) \ Ein kleines Helferlein, welches das untere Byte in einem Opcode maskiert.
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $F370 state-tos @ or image,
;

true variable shift-vorspann

: t-lshift   ( x u -- x* ) lshift $FFFF and ;
: t-rshift   ( x u -- x* ) rshift ;
: t-arshift  ( x u -- x* ) 0 ?do t-2/ loop ;


: t-lshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-lshift ergebnismerken exit then
  
  true shift-vorspann !
  einekonstante?
  not if else \ Der Sprungweite halber umgekehrt
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-shl-ra                        exit then
    dup  2  =  if drop t-shl-ra t-shl-ra               exit then
    dup  3  =  if drop t-shl-ra t-shl-ra t-shl-ra      exit then
    dup  4  =  if drop 4 0 do t-shl-ra loop            exit then
    dup  5  =  if drop 5 0 do t-shl-ra loop            exit then  \ Bis Schubweite 5 ist es noch genauso lang wie das klassische Schieben.

    dup  8  =  if drop $FF-and-opcode t-><-ra          exit then \ Schubweite 8: Swap Bytes und and.b #-1, r... zum Maskieren :-) Ergibt einen sehr kurzen Opcode !

    dup 16 u>= if drop eliminiere-tos 0 compileliteral exit then \ 16 oder mehr Stellen schieben: Ergibt Null.    

    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...
    false shift-vorspann !
  then

  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern

  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 4 or                                   image, \ jz +
  then
  
  t-swap-intern t-shl-ra t-swap-intern                \ add r-Daten, r-Daten
 \ $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 2 - or                            image, \ jnz -  
  
  eliminiere-tos
;

: t-rshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-rshift ergebnismerken exit then

  true shift-vorspann !
  einekonstante?
  if  
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-shr-ra                        exit then
    dup  2  =  if drop t-shr-ra t-shr-ra               exit then
    dup  3  =  if drop t-shr-ra t-shr-ra t-shr-ra      exit then \ Bis Schubweite 3 ist es noch genauso lang wie das klassische Schieben.
    
    dup  8  =  if drop t-><-ra $FF-and-opcode          exit then \ Schubweite 8: Swap Bytes und and.b #-1, r... zum Maskieren :-) Ergibt einen sehr kurzen Opcode !
    
    dup 16 u>= if drop eliminiere-tos 0 compileliteral exit then \ 16 oder mehr Stellen schieben: Ergibt Null.
    
    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...
    false shift-vorspann !
  then
    
  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern

  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 5 or                                   image, \ jz +
  then
  
  t-swap-intern t-shr-ra t-swap-intern                \ bic.w #1h, r2
                                                      \ rrc.w r-Daten  
 \ $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 3 - or                            image, \ jnz -  
  
  eliminiere-tos
;

: t-arshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-arshift ergebnismerken exit then

  true shift-vorspann !
  einekonstante?
  if  
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-2/-ra                         exit then
    dup  2  =  if drop t-2/-ra t-2/-ra                 exit then
    dup  3  =  if drop t-2/-ra t-2/-ra t-2/-ra         exit then
    dup  4  =  if drop t-2/-ra t-2/-ra t-2/-ra t-2/-ra           exit then
    dup  5  =  if drop t-2/-ra t-2/-ra t-2/-ra t-2/-ra t-2/-ra   exit then  \ Bis Schubweite 5 ist es noch genauso lang wie das klassische Schieben.
    
    dup 15 u>= if drop 0 compileliteral t-<-ra                   exit then \ 15 oder mehr Stellen schieben ergeben 0<
    
    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...    
    false shift-vorspann !
  then
    
  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern
      
  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 4 or                                   image, \ jz +
  then
  
  t-swap-intern t-2/-ra t-swap-intern                 \ rra r-Daten
\  $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 2 - or                            image, \ jnz -  
  
  eliminiere-tos
;

'  t-lshift  '  t-lshift-ra  t-prim-ra:  lshift  t-inline  2 t-foldable
'  t-rshift  '  t-rshift-ra  t-prim-ra:  rshift  t-inline  2 t-foldable
' t-arshift  ' t-arshift-ra  t-prim-ra: arshift  t-inline  2 t-foldable
 

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


\ -----------------------------------------------------------------------------
\   Multiplikation als Primitive
\ ----------------------------------------------------------------------------- 

: t-* ( n1 n2 -- n ) * $FFFF and ;

: t-*-ra ( -- )

  zweikonstanten? if zweikonstanten t-* ergebnismerken exit then
  
  \ Hier noch prüfen, ob einer der Operanden eine Konstante ist --> Abkürzungen und Schübe !

  state-nos @ literal@pc+ = if t-swap-intern then  \ Kommutativ - falls NOS Konstante ist, nach oben holen.
  
  einekonstante?
  not if else
    einekonstante  \ Alle Konstanten von -2 bis +7 werden hier "abgekürzt", außerdem jene, die durch Schübe dargestellt werden können.
    
    dup $FFFE  =  if ergebnismerken t-xor-ra 1 ergebnismerken t-+-ra t-shl-ra  exit then
    dup $FFFF  =  if ergebnismerken t-xor-ra 1 ergebnismerken t-+-ra           exit then
    dup     0  =  if eliminiere-tos ergebnismerken                             exit then
    dup     1  =  if drop                                                      exit then
    dup     3  =  if drop t-dup-ra t-shl-ra t-+-ra                             exit then
    dup     5  =  if drop t-dup-ra t-shl-ra t-shl-ra t-+-ra                    exit then
    dup     6  =  if drop t-shl-ra t-dup-ra t-shl-ra t-+-ra                    exit then
    dup     7  =  if drop t-dup-ra t-shl-ra t-shl-ra t-shl-ra t-swap-ra t---ra exit then
    
    dup $0002  =  if drop  1 ergebnismerken t-lshift-ra  exit then
    dup $0004  =  if drop  2 ergebnismerken t-lshift-ra  exit then
    dup $0008  =  if drop  3 ergebnismerken t-lshift-ra  exit then
                                                         
    dup $0010  =  if drop  4 ergebnismerken t-lshift-ra  exit then
    dup $0020  =  if drop  5 ergebnismerken t-lshift-ra  exit then
    dup $0040  =  if drop  6 ergebnismerken t-lshift-ra  exit then
    dup $0080  =  if drop  7 ergebnismerken t-lshift-ra  exit then
                                                         
    dup $0100  =  if drop  8 ergebnismerken t-lshift-ra  exit then
    dup $0200  =  if drop  9 ergebnismerken t-lshift-ra  exit then
    dup $0400  =  if drop 10 ergebnismerken t-lshift-ra  exit then    
    dup $0800  =  if drop 11 ergebnismerken t-lshift-ra  exit then
                                                         
    dup $1000  =  if drop 12 ergebnismerken t-lshift-ra  exit then
    dup $2000  =  if drop 13 ergebnismerken t-lshift-ra  exit then
    dup $4000  =  if drop 14 ergebnismerken t-lshift-ra  exit then
    dup $8000  =  if drop 15 ergebnismerken t-lshift-ra  exit then
    
    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...    
    false shift-vorspann !
  then  
  
  \ Tatsächlich eine Multiplikation schreiben.
  
  expect-two-elements
  expect-nos-in-register
  expect-tos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern
  
  befreie-tos
  get-free-register state-tos ! \ In diesem Register wird das Ergebnis entstehen
  
  \ Multipliziere nun 3OS mit NOS und lege das Ergebnis in TOS.
  
  \   mov #0, tos
  \ - rrc 3os               \ Ein Bit rausrotieren, Zufallsbit reinrotieren
  \   jnc +                 \ War es eine 1 ?
  \     add nos, tos        \  Wenn ja, dann addieren.
  \ + add nos, nos          \ Links schieben
  \   jnz -                 \ Alle Bits verbraucht ?
  
  $4300 state-tos @ or image,
  $1000 state-3os @ or image,
  $2801 image,
  $5000 state-tos @ or state-nos @ 8 lshift or image,
  $5000 state-nos @ or state-nos @ 8 lshift or image,
  $2000 $3FF 4 - or image,
 
  eliminiere-nos
  eliminiere-nos 
;

'  t-*  '  t-*-ra  t-prim-ra:  *  t-inline  2 t-foldable

target
  : negate ( n -- -n ) -1 * inline 1-foldable ;
host
\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  5. Teil: Disassembler zum Anschauen, ob auch alles stimmt.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ -------------------------------------------------------------
\  Disassembler
\ -------------------------------------------------------------

\ MSP430 Disassembler, Copyright (C) 2011  Matthias Koch
\ This is free software under GNU General Public License v3.
\ Knows MSP430 machine instructions, resolves call entry points and handles inline strings.
\ Usage: Specify your target address in disasm-$ and give disasm-step some calls.

0 variable disasm-$   \ Current position for disassembling

: disasm-fetch        \ ( -- Data ) Fetches opcodes and operands, increments disasm-$
    disasm-$ @ image@  \             Holt Opcode oder Operand, incrementiert disasm-$
  2 disasm-$ +!   ;

: u.4 0 <# # # # # #> type ;
: u.ns 0 <# #s #> type ;
: u.h u.ns ." h";
: register. ." r" decimal u.ns hex ;
: disasm-const ." #" u.h ;

: disasm-jumps   \ Bei Sprüngen ist bereits alle Information im Opcode enthalten.
  dup $1C00 and  \ Jumps have all information readily in their opcodes.
                 \ ( Opcode -- )
  case
    $0000 of ." jnz " endof
    $0400 of ." jz "  endof
    $0800 of ." jnc " endof
    $0C00 of ." jc "  endof
    $1000 of ." jn "  endof
    $1400 of ." jge " endof
    $1800 of ." jl "  endof
    $1C00 of ." jmp " endof
  endcase

  \ Calculate Offset
  $03FF and ( Offset )
    dup $0200 and if $FC00 or then
  shl disasm-$ @ +   u.4
;

: disasm-source   \ Takes care of source operands
                  \ Kümmert sich um den Quelloperanden des Befehls !
                  ( Opcode Source-Reg -- Opcode )

  over ( Opcode Source-Reg Opcode )
  dup $0040 and if ." .b " else ." .w " then

  $0030 and
  case
    $0000 of \ Register
            case
              3 of 0 disasm-const endof   \ CG
              dup register.
            endcase
          endof

    $0010 of \ Indexed
            case
              2 of ." &" disasm-fetch u.h endof \ SR
              3 of 1 disasm-const endof         \ CG

              dup disasm-fetch u.h ." (" register. ." )"
            endcase
          endof

    $0020 of \ Indirect
            case
              2 of 4 disasm-const endof \ SR
              3 of 2 disasm-const endof \ CG

              dup ." @" register.
            endcase
          endof

    $0030 of \ Indirect Autoincrement
             \ sr: 8 cg: -1 pc: Constant   All others: @rx+
            case
              2 of  8           disasm-const endof \ SR
              3 of $FFFF        disasm-const endof \ CG
              0 of disasm-fetch disasm-const endof \ PC

              dup ." @" register. ." +"
            endcase
          endof
  endcase
;

: disasm-destination \ Takes care of destination operands in two-operand-instructions
  ." , "             \ Kümmert sich um den Zieloperanden bei zwei-Operanden-Befehlen.
  dup $0080 and      \ ( Opcode -- )
  if  \ Indexed Destination

    dup $000F and 2 =
    if \ SR - Absolute addressing
      drop disasm-fetch ." &" u.h
    else \ Normal Indexed
      disasm-fetch u.h ." (" $000F and register. ." )"
    then

  else  \ Register Destination
    $000F and register.
  then
;

: disasm-single ( Opcode -- )
    dup $0F80 and
    case
      $0000 of ." rrc"  endof
      $0080 of ." swpb" endof
      $0100 of ." rra"  endof
      $0180 of ." sxt"  endof
      $0200 of ." push" endof
      $0280 of ." call" endof
      $0300 of ." reti" endof

      ." Unknown Opcode "
    endcase

  dup $000F and \ Mask Source Register
  ( Opcode Source-Reg )
  disasm-source
  ( Opcode )

  drop
;

: disasm-double ( Opcode -- )
  dup $0F00 and 8 rshift \ Mask Source Register
  ( Opcode Source-Reg )
  disasm-source
  ( Opcode )
  disasm-destination
;

: disasm ( -- )    \ Disassembles one machine instruction and advances disasm-$
  disasm-fetch     \ Fetch Opcode and test instruction type.
                   \ Opcode holen und auf Befehlstyp hin prüfen.

  dup $F000 and  ( Opcode Instruction-Mask )
  case
     $1000 of          disasm-single endof
     $2000 of          disasm-jumps  endof
     $3000 of          disasm-jumps  endof
     $4000 of ." mov"  disasm-double endof
     $5000 of ." add"  disasm-double endof
     $6000 of ." addc" disasm-double endof
     $7000 of ." subc" disasm-double endof
     $8000 of ." sub"  disasm-double endof
     $9000 of ." cmp"  disasm-double endof
     $A000 of ." dadd" disasm-double endof
     $B000 of ." bit"  disasm-double endof
     $C000 of ." bic"  disasm-double endof
     $D000 of ." bis"  disasm-double endof
     $E000 of ." xor"  disasm-double endof
     $F000 of ." and"  disasm-double endof

     ." Unknown Opcode " drop
  endcase
;

: memstamp \ ( Addr -- ) Shows a memory location nicely
    dup u.4 ." : " image@ u.4 ."   " ;

: disasm-step ( -- )
    disasm-$ @                 \ Note current position
    dup memstamp disasm cr     \ Disassemble one instruction

    begin \ Write out all disassembled memory locations
      2+ dup disasm-$ @ <>
    while
      dup memstamp cr
    repeat
    drop
;

: seec ( -- ) \ Continues to see
  base @ hex cr

  begin
    disasm-$ @ image@ $4130 =  \ Flag: Loop terminates with ret
    disasm-step
  until

  base !
;

: disimage ( -- )
  base @ hex cr

  flashstart disasm-$ !
  begin
    disasm-$ @ image@ $4130 =     \ ret
    disasm-$ @ image@ $1300 = or  \ reti
      disasm-step
    if cr then

    disasm-$ @ org @ u>=
  until

  base !

  speicherbedarf
;

\ -----------------------------------------------------------------------------
\   Intel HEX output
\ -----------------------------------------------------------------------------

: u.4 ( u -- ) 0 <# # # # # #> type ;
: u.2 ( u -- ) 0 <# # # #> type ;

: hexdump-without-cr ( -- ) \ Dumps complete Flash
  hex

  flashend flashstart
  do
    \ Check if it would be $FFFF only:
    0                    \ Not worthy to print
    i #16 + i do          \ Scan data
      i imagec@ $FF <> or  \ Set flag if there is a non-$FF byte
    loop

    if
      ." :10" i u.4 ." 00" \ Write record-intro with 4 digits.
      $10                   \ Begin checksum
      i          $FF and +   \ Sum the address bytes
      i 8 rshift $FF and +    \ separately into the checksum

      i #16 + i do
        i imagec@ u.2 \ Print data with 2 digits
        i imagec@ +    \ Sum it up for Checksum
      loop

      negate u.2  \ Write Checksum
      cr
    then

  #16 +loop
  ." :00000001FF" cr
  decimal
;

: hexdump ( -- ) cr hexdump-without-cr ;


[ifdef] jtag?
\ -----------------------------------------------------------------------------
\   Flash crosscompiled image to target
\ -----------------------------------------------------------------------------

\ Nur zum Testen ohne echte JTAG-Verbindung:
\ : writeflash ( x addr -- ) hex. hex. cr ;
\ : jtag-t@ ( addr -- x ) $FFFF or ;

: flashtarget ( -- )
  jtag? @ not if ." JTAG-Connection required." cr quit then

  erasetarget

  \ Write target

  flashend flashstart do
    i image@ $FFFF <> if i image@ i writeflash then
  2 +loop

  \ Verify target memory

  flashend flashstart do
     i jtag-t@   i image@  2dup <> if ." Memory verify error at " i hex. ." : Image: " hex. ." Target: " hex. cr else 2drop then
  2 +loop

  \ Fine.
;
[then]
\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  6. Teil: Die Möglichkeit, zu einem vorherigen Stand zurückzukehren
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: @+ ( addr -- addr+4 x ) dup @ swap 4 + swap ;

: cross-cornerstone ( -- ) \ cross-cornerstone Name

  <builds

    t-fadenende @ ,
    t-here ,
    t-here 0 ?do
      i t@ ,
    4 +loop

  does>

    t-dictionary dictionarysize 0 fill
    jumpcollection maxjumps 8 * 0 fill

    0 t-dp !

    @+ t-fadenende !
    @+ 0 ?do
      dup i + @  t,
    4 +loop
    drop
;

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  7. Teil: Noch eine Handvoll nützlicher Definitionen fürs Target
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

target

 0 constant false
-1 constant true

: ?dup dup if dup then inline 1-foldable ;

\ -----------------------------------------------------------------------------
\   Stromsparmodi, benötigen keine Operanden
\   Diese Definitionen funktionieren, lassen sich aber im Host nicht probeweise ausführen.
\ -----------------------------------------------------------------------------
\
\ : lpm0 ( -- ) [ $D032 , $0018 , ] inline ;  \ bis.w #18h, r2
\ : lpm1 ( -- ) [ $D032 , $0058 , ] inline ;  \ bis.w #58h, r2
\ : lpm2 ( -- ) [ $D032 , $0098 , ] inline ;  \ bis.w #98h, r2
\ : lpm3 ( -- ) [ $D032 , $00D8 , ] inline ;  \ bis.w #D8h, r2
\ : lpm4 ( -- ) [ $D032 , $00F8 , ] inline ;  \ bis.w #F8h, r2
\
\ : eint ( -- ) [ $D232 , ]         inline ;  \ bis.w #8h, r2
\ : dint ( -- ) [ $C232 , ]         inline ;  \ bic.w #8h, r2
\
\ -----------------------------------------------------------------------------
\   Case
\ -----------------------------------------------------------------------------

\ So ähnlich wie in Mecrisp-Ice

: case 0 immediate ; ( init count of ofs )

: of  ( #of -- orig #of+1 / x -- )
    1+    ( count ofs )
    >r    ( move off the stack in case the control-flow )
          ( stack is the data stack. )
    postpone over  postpone = ( copy and test case value)
    postpone if    ( add orig to control flow stack )
    postpone drop  ( discards case value if = )
    r>             ( we can bring count back now )
immediate ;

: endof ( orig1 #of -- orig2 #of )
    >r   ( move off the stack in case the control-flow )
         ( stack is the data stack. )
    postpone else
    r>   ( we can bring count back now )
immediate ;

: endcase  ( orig1..orign #of -- )

    postpone drop  ( discard case value )

    begin
      dup
    while
      1- swap
      postpone then
    repeat
    drop

immediate ;

\ -----------------------------------------------------------------------------
\   Do-Schleife, wird vom Kontrollfluss-RA prima optimiert
\ -----------------------------------------------------------------------------

: do ( -- R: -- 0 begin ) ( limit index --  R: limit index )

  postpone swap
  postpone >r
  postpone >r
    0 >r
  postpone begin
  >r
immediate ;

: ?do ( -- if 1 begin ) ( limit index --  R: limit index )

  postpone swap
    postpone 2dup
  postpone >r
  postpone >r
    postpone <>
    postpone if >r
    1 >r
  postpone begin
  >r
immediate ;

: leave ( --  R: ... u begin -- ... ahead u+1 begin ) ( --  R: limit index -- )
  r>
  r> 1+
  postpone ahead >r
  >r
  >r
immediate ;

: unloop
  postpone rdrop
  postpone rdrop
immediate ;

: loop ( --  R: ... u begin -- ) ( --  R: limit index -- )

                (                        R: limit index   )
  postpone r>   ( index                  R: limit         )
  postpone 1+   ( index+1                R: limit         )
  postpone r@   ( index+1 limit          R: limit         )
  postpone over ( index+1 limit index+1  R: limit         )
  postpone >r   ( index+1 limit          R: limit index+1 )
  postpone =    ( ?                      R: limit index+1 )

  r>
  postpone until

  r> begin
      dup
    while
      1-
      r> postpone then
    repeat
    drop

  postpone unloop
immediate ;

: i ( -- i )
  postpone r@
immediate ;

: j ( -- j )
  postpone r>
  postpone r>
  postpone r@
  postpone swap
  postpone >r
  postpone swap
  postpone >r
immediate ;

\ -----------------------------------------------------------------------------
\   Eine kleine und effiziente Schleife, die aber nicht so viel kann
\ -----------------------------------------------------------------------------

: (for) ( u -- )
  postpone >r
  postpone begin

  immediate
;


: (next)
  postpone r>
  postpone 1-
  postpone dup
  postpone >r
  postpone 0=
  postpone until
  postpone rdrop

  immediate
;

\ -----------------------------------------------------------------------------
\   Lange Multiplikation aus Mecrisp-Ice
\ -----------------------------------------------------------------------------

: mulstep ( ud u1 -- ud u1 )
  >r
  >r d2* r>
  dup 0 < if r@ swap >r 0 d+ r> then
  2*
  r>
;

: um*  ( u1 u2 -- ud )
  >r >r 0. r> r>

  16 (for)
    mulstep
  (next)

  drop drop

  2-foldable
;

\ -----------------------------------------------------------------------------
\   Lange Division aus Mecrisp-Ice
\ -----------------------------------------------------------------------------

\ see Hacker's Delight (2nd ed) 9-4 "Unsigned Long Division"

: divstep  \ ( y x z )

    >r
    dup 0< >r
    d2*
    dup r> or r@ u>= if
        r@ -
        swap 1+ swap
    then
    r>
;

: um/mod \ ( ud u1 -- u2 u3 ) ( 6.1.2370 )

  16 (for)
    divstep
  (next)

  drop swap

  3-foldable
;

\ -----------------------------------------------------------------------------
\   Helferlein für doppeltlange Zahlen aus Mecrisp-Ice übernommen
\ -----------------------------------------------------------------------------

: abs    ( n -- u ) dup 0< if negate then inline 1-foldable ;
: s>d    ( n -- d ) dup 0<                inline 1-foldable ;

: dnegate ( d -- -d ) not swap not swap 1. d+  inline 2-foldable ;
: dabs    ( u -- ud ) dup 0< if dnegate then   inline 2-foldable ;

: m* ( n1 n2 -- d )
    2dup xor >r
    abs swap abs um*
    r> 0< if dnegate then
2-foldable ;

: sgn ( u1 n1 -- n2 ) \ n2 is u1 with the sign of n1
    0< if negate then
inline 2-foldable ;

\ Divide d1 by n1, giving the symmetric quotient n3 and the remainder
\ n2.
: sm/rem ( d1 n1 -- n2 n3 )
    2dup xor >r     \ combined sign, for quotient
    over >r         \ sign of dividend, for remainder
    abs >r dabs r>
    um/mod          ( remainder quotient )
    swap r> sgn     \ apply to remainder
    swap r> sgn     \ apply to quotient
3-foldable ;

\ Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
\ Adapted from hForth
: fm/mod ( d1 n1 -- n2 n3 )
    dup >r 2dup xor >r
    >r dabs r@ abs
    um/mod
    r> 0< if
        swap negate swap
    then
    r> 0< if
        negate         \ negative quotient
        over if
            r@ rot - swap 1-
        then
    then
    r> drop
3-foldable ;

: */mod     >r m* r> sm/rem    3-foldable ;
: */        */mod nip          3-foldable ;

: /mod      >r s>d r> sm/rem   2-foldable ;
: /         /mod nip           2-foldable ;
: mod       /mod drop          2-foldable ;

\ -----------------------------------------------------------------------------
\   Word-Port-Definitionen
\ -----------------------------------------------------------------------------

$01B0 constant ADC10CTL0
$01B2 constant ADC10CTL1
$01B4 constant ADC10MEM

$0100 constant SD16CTL
$0102 constant SD16CCTL0
$0110 constant SD16IV
$0112 constant SD16MEM0

$0174 constant TACCR1
$0172 constant TACCR0
$0170 constant TAR
$0164 constant TACCTL1
$0162 constant TACCTL0
$0160 constant TACTL
$012E constant TAIV

$012C constant FCTL3
$012A constant FCTL2
$0128 constant FCTL1

$0120 constant WDTCTL

\ -----------------------------------------------------------------------------
\   Byte-Port-Definitionen
\ -----------------------------------------------------------------------------

  $4A constant ADC10AE      \ If you want to use Pins of Port 1 as analog inputs, you have to set the corresponding bits in ADC10AE0 !

  $B0 constant SD16INCTL0
  $B7 constant SD16AE

  $78 constant USICTL0
  $79 constant USICTL1
  $7A constant USICKCTL
  $7B constant USICNT
  $7C constant USISR

  $5B constant CAPD
  $5A constant CACTL2
  $59 constant CACTL1

  $53 constant BCSCTL3
  $58 constant BCSCTL2
  $57 constant BCSCTL1
  $56 constant DCOCTL

  $2F constant P2REN
  $2E constant P2SEL
  $2D constant P2IE
  $2C constant P2IES
  $2B constant P2IFG
  $2A constant P2DIR
  $29 constant P2OUT
  $28 constant P2IN

  $27 constant P1REN
  $26 constant P1SEL
  $25 constant P1IE
  $24 constant P1IES
  $23 constant P1IFG
  $22 constant P1DIR
  $21 constant P1OUT
  $20 constant P1IN

  $03 constant IFG2
  $02 constant IFG1
  $01 constant IE2
  $00 constant IE1


\ -----------------------------------------------------------------------------
\   Takt nach Wunsch setzen
\ -----------------------------------------------------------------------------

: 1MHz ( -- )
  $10FF c@ BCSCTL1 c!
  $10FE c@ DCOCTL  c!
  inline
;

: 8MHz ( -- )
  $10FD c@ BCSCTL1 c!
  $10FC c@ DCOCTL  c!
  inline
;

: 12MHz ( -- )
  $10FB c@ BCSCTL1 c!
  $10FA c@ DCOCTL  c!
  inline
;

: 16MHz ( -- )
  $10F9 c@ BCSCTL1 c!
  $10F8 c@ DCOCTL  c!
  inline
;

: reset ( -- ) 0 WDTCTL ! inline ;

\ -----------------------------------------------------------------------------
\   Helferlein für die Ein- und Ausgabe im Emulator oder im G2553.
\   Der F2012 hat keine asynchrone UART...
\ -----------------------------------------------------------------------------

: key?  ( -- ? ) 1 3 cbit@ inline ;
: emit? ( -- ? ) 2 3 cbit@ inline ;

: key   ( -- c ) begin key?  until $66 c@ inline ;
: emit  ( c -- ) begin emit? until $67 c! inline ;

: uart-init ( -- ) \ Ausgelegt für 8 MHz

    6 $26 c!
    6 $41 c!

  $80 $61 cbis!
  $41 $62 c!
    3 $63 c!
    4 $64 c!
    1 $61 cbic!
    0 $00 c!
;

\ -----------------------------------------------------------------------------
\   Ein paar Routinen für die Zahlenausgabe... Manchmal praktisch !
\ -----------------------------------------------------------------------------

: cr    ( -- ) 10 emit inline ;
: space ( -- ) 32 emit inline ;

: .digit ( u -- c ) dup 10 u< if 48 + else 55 + then ;

: hex-digit-emit ( u -- ) $F and .digit emit ;

: hex. ( u -- )

  dup 12 rshift hex-digit-emit
  dup  8 rshift hex-digit-emit
  dup  4 rshift hex-digit-emit
                hex-digit-emit
  space
;

: bin. ( x -- ) 16 0 do dup 0< 1 and [char] 0 + emit 2* loop drop space ;

\ -----------------------------------------------------------------------------
\   Helferlein für die hübsche Zahlenausgabe
\ -----------------------------------------------------------------------------

: spaces ( u -- ) 0 ?do space loop ;
: type ( addr len -- ) 0 ?do dup i + c@ emit loop drop ;
: d0= ( d -- ? ) or 0= inline 2-foldable ;

\ -----------------------------------------------------------------------------
\   Helferlein für die hübsche Zahlenausgabe auch aus Mecrisp-Ice übernommen
\ -----------------------------------------------------------------------------

( Pictured numeric output                    JCB 08:06 07/18/14)
\ Adapted from hForth

\ "The size of the pictured numeric output string buffer shall
\ be at least (2*n) + 2 characters, where n is the number of
\ bits in a cell."

16 2* 2 + constant maximum-number-length

maximum-number-length buffer: BUF0
BUF0 maximum-number-length + constant BUF

0 variable hld

10 variable output-base

: <#
    BUF hld !
;

: hold
    hld @ 1- dup hld ! c!
;

: sign
    0< if
        [char] - hold
    then
;

: #
    0 output-base @ um/mod >r output-base @ um/mod swap
    9 over < [char] A [char] 9 1 + - and +
    [char] 0 + hold r>
;

: #s
    begin
        #
        2dup d0=
    until
;

: #>
    2drop hld @ BUF over -
;

: (d.)
    dup >r dabs <# #s r> sign #>
;

: ud.
    <# #s #> type space
;

: d.
    (d.) type space
;

: .
    s>d d.
;

: u.
    0 d.
;

: rtype ( caddr u1 u2 -- ) \ display character string specified by caddr u1
                           \ in a field u2 characters wide.
  2dup u< if over - spaces else drop then
  type
;

: d.r
    >r (d.)
    r> rtype
;

: ud.r
    >r <# #s #>
    r> rtype
;

: .r
    >r s>d r> d.r
;

: u.r
    0 swap d.r
;

\ -----------------------------------------------------------------------------
host
\ -----------------------------------------------------------------------------

\ An dieser Stelle einen Rückkehrpunkt definieren, damit der Cross-Compiler so auch geflasht werden kann.
cross-cornerstone new

: init ( -- ) [ifdef] hw-init hw-init [then] new ;

[ifdef] cornerstone  cornerstone Rewind-Across [then]

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

compiletoflash

\ -----------------------------------------------------------------------------
\   Emit into a file
\ -----------------------------------------------------------------------------

\ write file via syscall interface                      uh 2015-09-26

\ : syscall ( r0 r1 r2 r3 r4 r5 r6 Syscall# -- r0 )

\ int creat(const char *pathname, mode_t mode);
8 constant #creat

8 base ! 
00400 constant S_IRUSR
00200 constant S_IWUSR
00100 constant S_IXUSR
decimal

: 0terminate ( addr len -- ) + 0 swap c! ;

: syscall-creat ( addr len mode -- fd )
  >r  dup >r here swap move  here r> 0terminate 
  here r> 0 0 0 0 0 #creat syscall ;


\ ssize_t write(int fd, const void *buf, size_t count);
4 constant #write
: syscall-write ( adr len fd -- len' )  -rot 0 0 0 0 #write syscall ; 

\ int close(int fd)
6 constant #close
: syscall-close ( fd -- ior ) 0 0 0 0 0 0 #close syscall ;

\ example: write logfile

0 variable logfile
: open-log ( addr len -- )  
   S_IRUSR S_IWUSR or syscall-creat  logfile ! ;

: write-log ( addr len -- )
   logfile @ syscall-write drop ; 

create newline 10 c,

: writeln-log ( addr len )
   write-log
   newline 1 write-log ;

: close-log ( -- )  logfile @ syscall-close drop ;

: log-emit ( c -- )
  sp@ 1 write-log drop
;  

\ -----------------------------------------------------------------------------
\   Write hexdump into a file
\ -----------------------------------------------------------------------------

: hexdump-file ( -- ) \ hexdump-file Name
  token open-log
  ['] log-emit hook-emit !
  hexdump-without-cr
  ['] serial-emit hook-emit !
  close-log
;

\ -----------------------------------------------------------------------------
\   Write a disassembler listing into a file
\ -----------------------------------------------------------------------------

: disimage-file ( -- ) \ disasm-file Name
  token open-log
  ['] log-emit hook-emit !
  disimage
  ['] serial-emit hook-emit !
  close-log
;

\ -----------------------------------------------------------------------------
\   Write a crosscompiler listing into a file
\ -----------------------------------------------------------------------------

: t-listing-file ( -- ) \ t-listing-file Name
  token open-log
  ['] log-emit hook-emit !
  t-listing
  ['] serial-emit hook-emit !
  close-log
;

\ Save a copy of the current Forth core with all contents of the user flash

\ -----------------------------------------------------------------------------
\ useful system calls
\ -----------------------------------------------------------------------------

\ : syscall ( r0 r1 r2 r3 r4 r5 r6 Syscall# -- r0 )

\ int open(const char *pathname, int flags, mode_t mode);
5 constant #open

8 base !
00444 constant S_IRUSR
00222 constant S_IWUSR
00111 constant S_IXUSR
decimal

8 base !
00000 constant O_RDONLY \ open for reading only
00001 constant O_WRONLY \ open for writing only
00002 constant O_RDWR   \ open for reading and writing
02000 constant O_APPEND \ set append mode
00100 constant O_CREAT  \ create if nonexistent
01000 constant O_TRUNC  \ truncate to zero length
00200 constant O_EXCL   \ error if already exists
decimal

: 0terminate ( addr len -- ) + 0 swap c! ;

: syscall-creat ( addr len mode -- fd )
  >r  dup >r here swap move  here r> 0terminate
  here O_WRONLY O_CREAT or O_TRUNC or r> 0 0 0 0 #open syscall ;

\ ssize_t write(int fd, const void *buf, size_t count);
4 constant #write
: syscall-write ( fd addr len -- len' ) 0 0 0 0 #write syscall ;

\ int close(int fd)
6 constant #close
: syscall-close ( fd -- ior ) 0 0 0 0 0 0 #close syscall ;

\ -----------------------------------------------------------------------------
\ reading and writing ELF headers
\ -----------------------------------------------------------------------------

\ retrieve program headers
: elfhdr>phdrs ( elfhdr -- phdrs )
  dup $1c + @ + ;

\ update program header file size
: p_filesz! ( phdr filesz -- )
  swap $10 + ! ;

\ retrieve section headers
: elfhdr>shdrs ( elfhdr -- shdrs )
  dup $20 + @ + ;

\ retrieve section header size
: elfhdr>shentsize ( elfhdr -- entsize )
  $2e + h@ ;

\ retrieve the desired section header
: elfhdr>shdr ( elfhdr i -- shdr )
  >r dup elfhdr>shdrs swap elfhdr>shentsize r> * + ;

\ adjust section end
: sh_end! ( shdr end -- )
  over $0c + @ -         \ compute sh_size from sh_addr and end
  swap $14 + ! ;         \ update sh_size

\ adjust section base address in image and memory
: sh_addr! ( shdr addr -- )
  over $0c + @ - >r         \ compute adjustment
  r@ over $0c + +!          \ adjust sh_addr
  r@ over $10 + +!          \ adjust sh_offset
  $14 + r> negate swap +! ; \ adjust sh_size

\ ELF section numbers (see elfheader.s)
2 constant #mecrisp
3 constant #userdictionary

\ adjust our own ELF header according to here
: adjustelf ( -- )
  incipit elfhdr>phdrs here incipit - p_filesz!
  incipit #mecrisp elfhdr>shdr here sh_end!
  incipit #userdictionary elfhdr>shdr here sh_addr! ;

\ -----------------------------------------------------------------------------
\ saving the program image back to disk
\ -----------------------------------------------------------------------------

: save ( addr len -- ) \ Save a copy of the whole Forth core with flash dictionary contents

  compiletoram? compiletoflash >r

  adjustelf
  S_IRUSR S_IWUSR S_IXUSR or or syscall-creat \ open new program image
  dup incipit here incipit - syscall-write drop
  syscall-close drop

  r> if compiletoram then
;

: save" ( -- ) [char] " parse save ;

\ -----------------------------------------------------------------------------


save" mecrisp-stellaris-linux-with-mecrisp-across"
\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: delchar ( addr len -- addr len )
  dup if 8 emit 32 emit 8 emit then

  begin
    dup 0= if exit then
    1- 2dup + c@
    $C0 and $80 <>
  until
;

: accept ( addr maxlen -- len )
  >r 0  ( addr len R: maxlen )

  begin
    key    ( addr len key R: maxlen )

    dup   9 = if drop 32 then
    dup 127 = if drop  8 then

    dup 31 u>
    if

      over r@ u<
      if
          dup emit
          >r 2dup + r@ swap c! 1+ r>
      then
    then

    dup 8 = if >r delchar r> then

    dup 10 = swap 13 = or
  until

  rdrop nip
  space
;


: type ( addr len -- )
  begin
    dup
  while
    over c@ >r
    1- swap 1+ swap
    r> emit
  repeat
  2drop
;

16 constant maxlength
maxlength buffer: tib

: terminal ( -- )
  8MHz uart-init
  begin
    [char] > emit space

    tib dup maxlength accept

    [char] { emit
    type
    [char] } emit
    cr
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFFE vector terminal  \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile            \ Zeit für die Crosscompilation !

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file accept.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file accept.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file accept.hex

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: us 0 ?do i i + drop i i + drop loop inline ; \ Für 8 MHz bemessen
: ms 0 ?do 998 us loop ;

: blinky ( -- )
  8MHz
  1 p1dir c!
  begin
    1 p1out cxor!
    1000 ms
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFFE vector blinky    \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile            \ Zeit für die Crosscompilation !

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file blinky.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file blinky.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file blinky.hex

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: us 0 ?do i i + drop i i + drop loop inline ; \ Für 8 MHz bemessen
: ms 0 ?do 998 us loop ;

: launchpad-init \ Launchpad hardware initialisations
  8 p1out cbis! \ High
  8 p1ren cbis! \ Pullup for button

  1 64 or p1out cbic! \ LEDs off
  1 64 or p1dir cbis! \ LEDs are outputs
;

: pwm-init ( Interval -- ) \ Init PWM on green LED
  64 p1dir cbis! \ Output
  64 p1sel cbis! \ Timer special function

  \ Configure Timer-A

       $172 ! \ PWM Interval in cycles
  $E0  $164 ! \ CCR1 Set/Reset
  0    $174 ! \ CCR1 PWM Duty Cycle
  $210 $160 ! \ SMCLK/1, upmode
;

: pwm ( Duty-Cycle -- ) $174 ! ; \ Sets duty cycle


1 constant Anode     \ Ein kleines Beispiel für den MSP430G2553:
2 constant Kathode    \ Helligkeitsmessung mit einer Leuchtdiode

: Strahle ( -- )
  Anode   P2OUT cbis!
  Kathode P2OUT cbic!
  Anode Kathode or P2DIR cbis!  ;

 : Lichtmessungs-Vorbereitung ( -- )
   Anode   P2OUT cbic!            \ Sperrschichtkapazität
   Kathode P2OUT cbis!            \ durch Verpolung laden
   Anode Kathode or P2DIR cbis!
   begin Kathode P2IN cbit@ until \ Warte bis Kathode geladen ist
   Kathode P2DIR cbic!   ;

: Kathodenochgeladen? ( -- ? ) Kathode P2IN cbit@ ;


: Wiedunkel? ( -- u )
  Lichtmessungs-Vorbereitung
  0
  begin
    50 us
    Kathodenochgeladen?
  while
    1+
  repeat
;

: Schatten ( -- )
  launchpad-init 8MHz uart-init

  Strahle 1000 ms

  500 pwm-init
  begin
    Wiedunkel? dup pwm hex. cr
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFFE vector Schatten  \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile            \ Zeit für die Crosscompilation !

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file brightness.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file brightness.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file brightness.hex

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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: vorbereitung ( -- )

  $5A14 $120 ! \ Watchdog-Interrupt mit ACLK/32768 = 1 s
  1 ie1 c!      \ Watchdog-Interrupt aktivieren

  65  p1dir c!
   1  p1out c!

  eint
;

: tick ( -- ) 64 p1out cxor! ;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

\ Vektortabelle füllen und Einsprungpunkte definieren

$FFF4 vector tick              \ Watchdog
$FFFE vector vorbereitung       \ Reset

\ Zeit für die Crosscompilation !

crosscompile

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file irqblinky.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file irqblinky.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file irqblinky.hex


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


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: us 0 ?do i i + drop i i + drop loop inline ; \ Für 8 MHz bemessen
: ms 0 ?do 998 us loop ;

: Sendedatenholen ( -- Daten true | false ) key? dup if key tuck emit then ;
: Datenempfangen  ( Daten -- ) emit ;
: Verbindungsanfang ( -- )  1 p1out cbis! [char] < emit ; \ Verbindungsanzeige nach Bedarf anpassen
: Verbindungsende   ( -- )  1 p1out cbic! [char] > emit ;


1 constant Anode
2 constant Kathode

: Strahle ( -- )
  Anode   P2OUT cbis!
  Kathode P2OUT cbic!
  Anode Kathode or P2DIR cbis!
;

: Lauschen-Vorbereitung ( -- )
  Anode   P2OUT cbic!            \ Sperrschichtkapazität
  Kathode P2OUT cbis!            \ durch Verpolung laden
  Anode Kathode or P2DIR cbis!
  begin Kathode P2IN cbit@ until \ Warten, bis die Kathode geladen ist
  Kathode P2DIR cbic!
;

: Lauschen-Nachbearbeitung ( -- Flag )
  Kathode P2IN cbit@ not        \ Ist die Kathode entladen, ist es hell
;


18 constant Synchrondauer

8 variable Strahlzaehler
0 variable Verbindungsdauer
0 variable Lauschzaehler
0 variable Lichtmuster
0 variable Sendedaten
0 variable Datenregister

true variable Zustand ( Hell oder Dunkel ? )

: msb? ( x -- x Flag ) dup 0< inline ;

: HolePuls ( -- )
  8 Strahlzaehler ! \ Null-Puls, wird auch im Ruhezustand gesendet.

  \ Verbindungsdauer prüfen, beginne erst zu Senden, wenn die Verbindung auch sicher besteht.
  \ Belasse es im Falle einer gerade laufenden Synchronisation dabei, Ruhezustandspulse abzugeben.

  Verbindungsdauer @ Synchrondauer =
  if

  Sendedaten @ ?dup if  \ An bestehender Übertragung weiterarbeiten
                      msb? if 4 Strahlzaehler ! then \ Eins-Puls erforderlich ?
                      shl
                      dup 0= if 12 Strahlzaehler ! then \ Wurde gerade die Merk-Eins herausrotiert ? Übertragungspuls !
                      Sendedaten !
                    else  \ Neue Daten holen und vorbereiten
                      Sendedatenholen
                      if
                        ?dup if  ( Daten-zum-Senden )
                               4 Strahlzaehler ! \ Bei neuen Daten ungleich Null wird die führende Eins gesendet

                               msb? if \ Ist das MSB schon die führende Eins ?
                                      shl 1 or \ Eine Merk-Eins reinrotieren, die nicht übertragen wird
                                    else
                                      shl 1 or \ Eine Merk-Eins reinrotieren, die nicht übertragen wird
                                      begin
                                        msb?   \ So lange schieben, bis die führende Eins herauspurzelt
                                        swap shl swap
                                      until
                                    then

                               Sendedaten ! \ Fertig geschobene Datenbits zum weiteren Senden bereitlegen
                             else 12 Strahlzaehler ! \ Für eine Null genügt ein Übertragungspuls
                             then
                      then
                    then
  then
;

: Bitmustererkennung ( -- )
  Verbindungsdauer @ Synchrondauer <>
  if \ Verbindung besteht erst nach 18 mal Zublinkern stabil.
    1 Verbindungsdauer +!
    Verbindungsdauer @ Synchrondauer = if Verbindungsanfang then
  then

  Lichtmuster @
      %1111111111100 and    \ Übertragungspuls wird mit 11 bis 14 Basiszeiten erkannt
  dup %1111111111100 = if drop Datenregister @ Datenempfangen
                             0 Datenregister ! \ Datenregister muss gelöscht werden,
                       else                    \  da die Daten aus mit variabler Länge übertragen werden

          %111111100 and    \ Null-Puls wird mit 7-10 Basiszeiten erkannt
          %111111100 = if   Datenregister @ shl      Datenregister !
                       else Datenregister @ shl 1 or Datenregister !
                       then \ Eins-Puls wird mit 3-6 Basiszeiten erkannt.

                       then
;

: Taktlauscher-init ( -- )
  0 Sendedaten !     \ Keine Daten zum Herausrotieren und Abstrahlen ! Wichtig !
  Verbindungsdauer @ Synchrondauer = if Verbindungsende then
  0 Verbindungsdauer !

  Zustand @ if
    \ Für einen hellen Taktlauscher
    HolePuls
    Strahle
  else
    \ Für einen dunkelen Taktlauscher
    0 Strahlzaehler !
    1 Lauschzaehler !
    Lauschen-Vorbereitung
  then
;

: Taktlauscher ( -- )
  Strahlzaehler @ ?dup
  if \ Strahlzähler ist nicht Null
    -1 Strahlzaehler +!
    1- if
         Strahle
       else \ Gerade Null geworden
         32 Lauschzaehler !
         0 Lichtmuster !
         Lauschen-Vorbereitung
       then
  else
    Lauschen-Nachbearbeitung
    1 and Lichtmuster @ shl or
    dup Lichtmuster ! ( Neues-Lichtmuster )
    %11111 and
    %11100 = if
               Bitmustererkennung
               HolePuls
               Strahle
             else
               -1 Lauschzaehler +!
               Lauschzaehler @ if Lauschen-Vorbereitung
                               else Taktlauscher-init then
             then
  then
;

: ledcomm ( -- )

  8MHz uart-init

  $5A14 $120 ! \ Watchdog-Interrupt mit ACLK/32768 = 1 s
  1 ie1 c!      \ Watchdog-Interrupt aktivieren

  Anode Kathode or p2dir c! \ Ausgänge für die Ledcomm-LED und die Verbindungsanzeige
  65  p1dir c!
  64  p1out c!

  Taktlauscher-init

  $10  $0162 !
  1953 $0172 !
  $210 $0160 !

  eint
;

: bright ( -- ) true zustand ! ;
: dark   ( -- ) false zustand ! ;

: blinky ( -- ) -1 zustand xor! ;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

\ Vektortabelle füllen und Einsprungpunkte definieren

$FFF2 vector taktlauscher  \ Timer A0
$FFF4 vector blinky        \ Watchdog
$FFFE vector ledcomm       \ Reset

\ Zeit für die Crosscompilation !

crosscompile

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file ledcomm.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file ledcomm.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file ledcomm.hex

new \ Das Dictionary des Crosscompilers zurücksetzen

\ +jtag \ Mit dem Zielchip verbinden

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

3 constant analog-pin
4 constant probe-pin

1 probe-pin lshift constant probe-bitmask

1 5 lshift constant led-cathode
1 6 lshift constant led


: logic ( -- )

  ( low high level detected )
  false false

  \ Dies gibt an, wie schnell der Logikprüfstift reagiert. Sollte etwa 0.05 s sein, damit der Stift mit 10 Hz blinkt, falls ein Pulszug reinkommt.
  60000 0 do
    p1in c@ flush dup >r or swap r> not or swap
  loop

  \ Die richtige Bitstelle maskieren, an der tatsächlich der Logikzustand zu sehen ist:
  probe-bitmask and swap probe-bitmask and swap

  led p1out cbit@
  if \ Indikator war gerade high
    if led p1out cbis! then \ An für High
    if led p1out cbic! then \ Falls in der Zwischenzeit ein Low-Pegel gesehen wurde, jetzt ausschalten.
  else
    swap \ Low zuerst prüfen
    if led p1out cbic! then \ Aus für Low
    if led p1out cbis! then \ Falls in der Zwischenzeit ein High-Pegel gesehen wurde, jetzt einschalten.
  then

;



$01B0 constant ADC10CTL0      \ control register 0
$01B2 constant ADC10CTL1      \ control register 0
$01B4 constant ADC10MEM       \ memory
$004A constant ADC10AE0       \ input enable register 0, Byte
$004B constant ADC10AE1       \ input enable register 1, Byte


\ ------------------------------------------------------------------------------
\ ADC10 - Konstanten für den Control Register 0
\ ------------------------------------------------------------------------------

\ Auswahl der Spannungsreferenz, Bit 15-13
\ 5432109876543210
 %0000000000000000 constant SREF_0         \ VR+ = AVCC and VR- = AVSS
 %0010000000000000 constant SREF_1         \ VR+ = VREF+ and VR- = AVSS
 %0100000000000000 constant SREF_2         \ VR+ = VEREF+ and VR- = AVSS
 %0110000000000000 constant SREF_3         \ VR+ = buffered VEREF+ and VR- = AVSS
 %1000000000000000 constant SREF_4         \ VR+ = AVCC and VR- = VREF-/VEREF-
 %1010000000000000 constant SREF_5         \ VR+ = VREF+ and VR- = VREF-/VEREF-
 %1100000000000000 constant SREF_6         \ VR+ = VEREF+ and VR- = VREF-/VEREF-
 %1110000000000000 constant SREF_7         \ VR+ = buffered VEREF+ and VR- = VREF-/VEREF-

\ sample-and-hold time, Bits 12-11
\ 5432109876543210
 %0000000000000000 constant ADC10SHT_0      \ 4 x ADC10CLKs
 %0000100000000000 constant ADC10SHT_1      \ 8 x ADC10CLKs
 %0001000000000000 constant ADC10SHT_2      \ 16 x ADC10CLKs
 %0001100000000000 constant ADC10SHT_3      \ 64 x ADC10CLKs
\ 5432109876543210
 %0000000000000001 constant ADC10SC
 %0000000000000010 constant ENC
 %0000000000000100 constant ADC10IFG
 %0000000000001000 constant ADC10IE
 %0000000000010000 constant ADC10ON
 %0000000000100000 constant REFON
 %0000000001000000 constant REF2_5V
 %0000000010000000 constant MSC
 %0000000100000000 constant REFBURST
 %0000001000000000 constant REFOUT
 %0000010000000000 constant ADC10SR


\ ------------------------------------------------------------------------------
\ ADC10 - Konstanten für den Control Register 1
\ ------------------------------------------------------------------------------

\ Eingangskanal, Bits 15-12
\ 5432109876543210
 %0000000000000000 constant INCH_0
 %0001000000000000 constant INCH_1
 %0010000000000000 constant INCH_2
 %0011000000000000 constant INCH_3
 %0100000000000000 constant INCH_4
 %0101000000000000 constant INCH_5
 %0110000000000000 constant INCH_6
 %0111000000000000 constant INCH_7
 %1000000000000000 constant INCH_8
 %1001000000000000 constant INCH_9
 %1010000000000000 constant INCH_10
 %1011000000000000 constant INCH_11
 %1100000000000000 constant INCH_12         \ Selects Channel 11
 %1101000000000000 constant INCH_13         \ Selects Channel 11
 %1110000000000000 constant INCH_14         \ Selects Channel 11
 %1111000000000000 constant INCH_15         \ Selects Channel 11

\ sample-and-hold source select, Bits 11-10
\ 5432109876543210
 %0000000000000000 constant SHS_0           \ ADC10SC - bit
 %0000010000000000 constant SHS_1           \ TA OUT1
 %0000100000000000 constant SHS_2           \ TA OUT0
 %0000110000000000 constant SHS_3           \ TA OUT2

 %0000001000000000 constant ADC10DF         \ Data format
 %0000000100000000 constant ISSH            \ invert singnal sample-and-hold

\ Taktteiler, Bits 7-5
\ 5432109876543210
%0000000000000000 constant ADC10DIV_0
%0000000000100000 constant ADC10DIV_1
%0000000001000000 constant ADC10DIV_2
%0000000001100000 constant ADC10DIV_3
%0000000010000000 constant ADC10DIV_4
%0000000010100000 constant ADC10DIV_5
%0000000011000000 constant ADC10DIV_6
%0000000011100000 constant ADC10DIV_7

\ clock source select, Bits 4-3
\ 5432109876543210
 %0000000000000000 constant ADC10SSEL_0     \ ADC10OSC
 %0000000000001000 constant ADC10SSEL_1     \ ACLK
 %0000000000010000 constant ADC10SSEL_2     \ MCLK
 %0000000000011000 constant ADC10SSEL_3     \ SMCLK

\ conversion sequenze mode select, Bits 2-1
\ 5432109876543210
 %0000000000000000 constant CONSEQ_0       \ Single channel single conversion
 %0000000000000010 constant CONSEQ_1       \ Sequence of channels
 %0000000000000100 constant CONSEQ_2       \ Repeat single channel
 %0000000000000110 constant CONSEQ_3       \ Repeat sequence of channels

 %0000000000000001 constant ADC10BUSY



: analog-vcc ( channel -- result )

  ENC ADC10CTL0 bic! \ Switch off ADC to change its configuration !

  ( channel ) 12 lshift    \ The topmost 4 bits choose one of the 16 input channels.
  ADC10SSEL_0 or           \ Single shot, select clock: ADC10OSC / 4
  ADC10DIV_3  or
  CONSEQ_0    or ADC10CTL1 !

  SREF_0 ADC10SHT_3 ADC10ON or or ADC10CTL0 ! \ Reference Vcc

  ENC ADC10SC or ADC10CTL0 bis! \ Start sampling/conversion

  begin ADC10BUSY ADC10CTL1 bit@ not until  \ ADC10BUSY? Wait for finished sampling

  ADC10MEM @ \ Return conversion result

;


1024 2/ 50 - constant open-low
1024 2/ 50 + constant open-high

: sample ( -- )
  \ Analog einlesen um zu schauen, ob es ein Floating-Eingang ist.
  analog-pin analog-vcc

  dup open-low u> swap open-high u< and
  if
    led p1out cbis!
    10 0 do loop
    led p1out cbic!
  else
    \ Normaler GPIO-Eingang
    logic
  then
;

: logicprobe ( -- )

  8MHz

  1 analog-pin lshift ADC10AE0 c!

  led led-cathode or p1dir c!
                   0 p1out c!

  begin
    sample
  again
;


\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFFE vector logicprobe   crosscompile   \ flashtarget -jtag run  \ Vektortabelle füllen, Einsprungpunkte definieren, Crosscompilation, Flashen des Zielchips

 t-listing-file logictest.list
  disimage-file logictest.asm
   hexdump-file logictest.hex

new

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: impuls ( -- ) 16 p1out cbis! 16 p1out cbic! ;

: solar ( -- )

   $5A80 1 5 lshift or $120 !  \ Watchdog on hold, Reset --> NMI, which is still disabled

   0 p1sel c!
   0 p2sel c!

   0 p1out c!
   0 p2out c!

   %11110111 p1dir c!
   %11111111 p2dir c!

   0 DCOCTL c! 0 BCSCTL1 \ c! %11111110 BCSCTL2 c! %00100000 BCSCTL3 c!  \ VLO/8, Clock out 1.5 kHz

  %00001000 BCSCTL2 c!  \ SELS: VLO --> SMCLK
  %00100000 BCSCTL3 c!   \ LFXT1S VLO, 12 kHz --> SMCLK, ACLK

   $10  TACCTL0 !  \ CCIE
 12000  TACCR0  !   \ Timer zählt bis 12 --> Impulse mit VLO/12 / 1000 --> 1 Hz
  $110  TACTL   !    \ ACLK, Up Mode

   \ 16 p1sel c! \ Clock out brauche ich hier nicht

  eint

  begin
    lpm1 \ CPU and DCO off
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFF2 vector impuls     \ Timer A0
$FFFE vector solar       \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile              \ Zeit für die Crosscompilation !


disimage-file solar.asm
 hexdump-file solar.hex

\
\  Tritiled für MSP430F2012
\
\    P1.3: Taster gegen GND
\    P1.6: Gate von N-MOSFET BS170, Source an GND, Drain über Spule 1 mH und grüner LED an Vcc
\
\    15 kOhm Hochziehwiderstand /Reset an VCC
\
\    Bei 3.3 V: Eingeschaltet 8.0 uA, Ausgeschaltet 0.6 uA
\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: us 0 ?do i i + drop i i + drop loop inline ; \ Für 8 MHz bemessen
: ms 0 ?do 998 us loop ;

: impuls ( -- ) 64 p1out cbis! 64 p1out cbic! ;

: knopfdruck ( -- ) $110 TACTL xor! 200 ms 0 p1ifg c! wakeup ;

: tritiled ( -- )

  0     p1sel c!  \ Keine Sonderfunktionen and Port 1
  8     p1out c!   \ Hochzieh-
  8     p1ren c!    \ widerstand für den Knopf aktivieren
  8 not p1dir c!     \ Alle anderen Pins Ausgänge, low

    0   p2sel c!  \ Quarzoszillator aus
    0   p2out c!   \ Low-
  255   p2dir c!    \ Ausgänge

  8MHz
  %00001000 BCSCTL2 c!  \ SELS: VLO --> SMCLK
  %00100000 BCSCTL3 c!   \ LFXT1S VLO, 12 kHz --> SMCLK, ACLK

   $10  TACCTL0 !  \ CCIE
    12  TACCR0  !   \ Timer zählt bis 12 --> Impulse mit VLO/12 --> 1 kHz
  $110  TACTL   !    \ ACLK, Up Mode

  8     p1ies c!  \ High-to-low, also Knopf drücken
  0     p1ifg c!   \ Noch kein Interrupt
  8     p1ie  c!    \ Interrupt bei Tastendruck

  eint

  begin
    tactl @
    if
      lpm1 \ CPU and DCO off
    else
      lpm4 \ Alles aus
    then
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>


$FFF2 vector impuls    \ Timer A0
$FFE4 vector knopfdruck \ Port 1
$FFFE vector tritiled    \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile              \ Zeit für die Crosscompilation !

disimage-file tritiled.asm
hexdump-file tritiled.hex
\
\    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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  8. Teil: Schließlich jenes, was kompiliert werden soll :-)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

new \ Das Dictionary des Crosscompilers zurücksetzen

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    TARGET
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

: uart-echo ( -- )
  8MHz uart-init
  begin
    key
    emit
  again
;

\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
    HOST
\ <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

$FFFE vector uart-echo \ Vektortabelle füllen und Einsprungpunkte definieren
crosscompile            \ Zeit für die Crosscompilation !

\ -----------------------------------------------------------------------------

\ Was hat der Compiler daraus gemacht ?

\ t-listing
t-listing-file uart-echo.list

\ Was ist entstanden ? Einen tiefen Einblick für den Menschen ermöglichen.

disimage
disimage-file uart-echo.asm

\ Und die fertige Intel-Hex-Datei für den Chip ausgeben.

hexdump
hexdump-file uart-echo.hex

