;
;    Mecrisp - A native code Forth implementation for MSP430 microcontrollers
;    Copyright (C) 2011  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/>.
;

; Sprünge, Helferlein und Kontrollstrukturen

;------------------------------------------------------------------------------
; --- Sprünge und Helferlein ---
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
  Wortbirne Flag_visible, "jump," ; Fügt einen Sprung ein.
jumpgenerator: ; ( Adresse-der-Opcodelücke Sprungziel Bitmaske -- )
;------------------------------------------------------------------------------
  mov 2(r4), r7
  sub 4(r4), r7 ; Differenz aus Lücken-Adresse und Sprungziel bilden
  decd r7       ; -2, da der aktuelle Befehl noch läuft.

  push r7 ; Sichern, während die Probe arbeitet.
  ; Probe der Sprungdistanz ! Prüfe auch gleich, ob es ungerade Sprungdistanzen gibt...
  and #1111110000000001b, r7
  jz + ; Wenn dies Null ergibt, positive Distanz ok.

  cmp #1111110000000000b, r7
  je + ; Wenn es gleich ist: Negative Distanz ok.
  ; Ansonsten ist die Sprungdistanz einfach zu groß.
  ; writeln "Sprungdistanz zu groß."
  writeln "Jump too far"
  br #quit ; quit setzt auch die Stacks zurück, brauche das hier nicht zu tun.

+ ; Probe befand die Sprungdistanz für okay.
  pop r7
  ; clrc  ; Dies Bit wird ins MSB geschoben und wird dort von der and-Maske eliminiert.
  rrc r7 ; Schieben, weil 10 Bit Offset * 2
  ;    9876543210
  and #1111111111b, r7 ; Maske anwenden

  ; Setze nun den Opcode zusammen und bereite den Stack.
  bis r7, @r4
  ; ( Adresse-der-Opcodelücke Sprungziel Sprungopcode -- )
  mov 4(r4), r7 ; Adresse für den Sprungbefehl holen

  ifdef flashdictionaryeinbinden
    push &DictionaryPointer
    mov r7, &DictionaryPointer
    call #komma
    pop &DictionaryPointer
  else ; Nur fürs Ram:
    mov @r4+, @r7  ; Befehl in den Speicher schreiben.
  endif

  add #4, r4 ; 2drop
  ret

;------------------------------------------------------------------------------
; Verschiedene Sprünge, die von den Kontrollstrukturen gebracht werden.
;------------------------------------------------------------------------------

branch_r:     ; ( -- Sprungziel ) "branch<--"  ; Einleitung bedingter und unbedingter Rückwärtssprung
    pushda &DictionaryPointer
    ret

r_branch_jnz:
    push #02000h
    jmp +

r_nullbranch: ; ( Sprungziel -- ) "<--0branch" ; Abschluss bedingter Rückwärtssprung
    call #nullprobekomma
    push #0010010000000000b ; Opcode für einen bedingten Sprung jz
    jmp +

r_branch:     ; ( Sprungziel -- ) "<--branch" ; Abschluss unbedingter Rückwärtssprung
    push #0011110000000000b ; Opcode für einen unbedingten Sprung jmp
+   call #branch_v ; pushdadouble &DictionaryPointer, #2
                   ; call #allot
    call #swap_sprung ; swap
    r_from
    jmp jumpgenerator

nullbranch_v: ; ( -- Adresse-für-Sprungbefehl ) "0branch-->" ; Einleitung bedingter Vorwärtssprung
    call #nullprobekomma
branch_v:     ; ( -- Adresse-für-Sprungbefehl ) "branch-->"  ; Einleitung unbedingter Vorwärtssprung
    pushda &DictionaryPointer
    br #zwei_allot

  ifdef caseeinbinden
v_casebranch:
    push #02000h ; Opcode für einen bedingten Sprung jnz
    jmp +
  endif

v_nullbranch: ; ( Adresse-für-Sprungbefehl -- ) "-->0branch" ; Abschluss bedingter Vorwärtssprung
    push #0010010000000000b ; Opcode für einen bedingten Sprung jz
    jmp +

v_branch:     ; ( Adresse-für-Sprungbefehl -- ) "-->branch" ; Abschluss unbedingter Vorwärtssprung
    push #0011110000000000b ; Opcode für einen unbedingten Sprung jmp
+   pushdadouble &DictionaryPointer, @sp+
    jmp jumpgenerator

;------------------------------------------------------------------------------
; --- Kontrollstrukturen ---
;------------------------------------------------------------------------------

Strukturpaar macro Marke
               cmp #Marke, @r4
               jne strukturen_passen_nicht
               drop
             endm

;------------------------------------------------------------------------------
  Wortbirne Flag_visible, "?pairs" ; ( n1 n2 -- ) Prüft, ob die Strukturwörter zusammengehören.
;------------------------------------------------------------------------------
  cmp @r4+, @r4
  je +
strukturen_passen_nicht:
    writeln "Structures don't match"
    br #quit
+ drop
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "then"
  ; ( -- Adresse-für-Sprung 2 | Adresse-für-Sprung 5 )
;------------------------------------------------------------------------------
  cmp #5, @r4 ; Kommend aus Else-Zweig
  jne +
    drop      ; Paar-Kennung vom Stack werfen
    jmp v_branch

+ cmp #2, @r4 ; Kommend direkt aus IF-Zweig
  jne strukturen_passen_nicht
    drop
    jmp v_nullbranch

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "else"
  ; ( Adresse-für-Sprung 2 -- Adresse-für-Sprung 5 )
;------------------------------------------------------------------------------
  ; Else macht es ein kleines bisschen Komplizierter.
  ; Bedingung  if           [true]    else                  [false]   then      Folgendes.
  ;            0branch-->             branch--> -->0branch            -->branch

  Strukturpaar 2

  ; ( Bedingter-Sprung )
  call #branch_v
  ; ( Bedingter-Sprung Unbedingter-Sprung )
  call #swap_sprung
  ; ( Unbedingter-Sprung Bedingter-Sprung )
  call #v_nullbranch
  ; ( Unbedingter Sprung )
  pushda #5 ; Strukturerkennung bereitlegen
  ; ( Unbedingter Sprung 5 )
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "if"
struktur_if: ; ( -- Adresse-für-Sprung 2 )
;------------------------------------------------------------------------------
  call #nullbranch_v
  pushda #2           ; Strukturerkennung
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "repeat"  ; Wie das Pascal-While-Konstrukt.
  ; ( Sprungziel Adresse-für-Sprung 4 -- )
;------------------------------------------------------------------------------
  ; begin (Bedingung) while (Agenda) repeat (Folgendes).
  ; In Pascal: while (true) do Agenda;

  ; ( Sprungziel-zurück-an-Anfang Adresse-für-Sprung-ans-Ende 4 )
  Strukturpaar 4
  ; ( Sprungziel-zurück-an-Anfang  Adresse-für-Sprung-ans-Ende )
  call #swap_sprung
  ; ( Adresse-für-Sprung-ans-Ende Sprungziel-zurück-an-Anfang )
  call #r_branch ; Rücksprung an den Anfang, falls ich normal einlaufe
  ; ( Adresse-für-Sprung-ans-Ende )
  jmp v_nullbranch ; Raussprung aus dem Konstrukt.

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "while"  ; Wie das Pascal-While-Konstrukt.
  ; ( Sprungziel 1 -- Sprungziel Adresse-Für-Sprung 4 )
;------------------------------------------------------------------------------
  ; begin (Bedingung) while (Agenda) repeat (Folgendes).
  ; In Pascal: while (true) do Agenda;
  Strukturpaar 1
  ; ( Sprungziel ) wird für den späteren Rücksprung benutzt.
  call #struktur_if ; Benutze einfach mal If.
  ; ( Sprungziel Adresse-Für-Sprung 2 )
  add #2, @r4
  ; ( Sprungziel Adresse-Für-Sprung 4 ) ; Strukturkennung 4 !
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "until"  ; Bedingte Schleife
  ; ( Sprungziel 1 -- )
;------------------------------------------------------------------------------
  Strukturpaar 1
  jmp r_nullbranch

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "again"  ; Endlosschleife
  ; ( Sprungziel 1 -- )
;------------------------------------------------------------------------------
  Strukturpaar 1
  jmp r_branch

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "begin"
  ; ( -- Sprungziel 1 )
;------------------------------------------------------------------------------
  call #branch_r
  pushda #1       ; Strukturerkennung
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "exit" ; Kompiliert ein ret mitten in die Definition.
;------------------------------------------------------------------------------
  br #retkomma

  ; Die Schleifenindizies sind nur innerhalb von Schleifen erreichbar -
  ; und dort sind sie via inline immer einkompiliert.

;------------------------------------------------------------------------------
  Wortbirne Flag_visible_inline, "k" ; Kopiert den drittobersten Schleifenindex
;------------------------------------------------------------------------------
  ; Returnstack ( Limit Index Limit Index [Rücksprung] )
  pushda 4(sp) ; Mit Rücksprung: 6(sp)
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible_inline, "j" ; Kopiert den zweitobersten Schleifenindex
;------------------------------------------------------------------------------
  ; Returnstack ( Limit Index [Rücksprung] )
  pushda @sp ; Mit Rücksprung: 2(sp)
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible_inline, "i" ; Kopiert den obersten Schleifenindex
;------------------------------------------------------------------------------
  ; Returnstack ( [Rücksprung] )
  pushda r5 ; Ist immer im Register.
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_inline, "unloop" ; Wirft die Schleifenstruktur vom Returnstack
unloop:
;------------------------------------------------------------------------------
  pop r5  ; Hole die alten Schleifenwerte zurück
  pop r6
  ret


  ifdef leaveeinbinden
;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "leave" ; Beendet die Schleife sofort.
  ; ( ... AlterLeavePointer 0 Sprungziel 3 ... )
  ; --
  ; ( ... AlterLeavePointer Vorwärtssprungziel{or-1-JZ} Sprungziel 3 ... )
;------------------------------------------------------------------------------
  ; Der LeavePointer zeigt an die Stelle, wo steht, wie viele Spezialsprünge noch abzuarbeiten sind.
  ; Alle Stackelemente weiterschieben, Sprungadresse einfügen, Zähler erhöhen, Lücke anlegen.

  push #0  ; Markierung, dass ein unbedingter Sprung gebraucht wird.

leave_bedingt:
  ; Stack verschieben.
  mov r4, r7
  decd r4 ; Ein Element mehr auf dem Stack

- mov @r7, -2(r7)
  incd r7
  cmp r7, &leavepointer
  jne -

  mov @r7, -2(r7) ; Ein letztes Mal noch.
  ; Alle Elemente sind nun einen weiter geschoben.

  inc -2(r7) ; Einen Sprung mehr auf der Liste !
  mov &DictionaryPointer, @r7 ; DictionaryPointer an die freie Stelle legen
  bis @sp+, @r7               ; Markierung anbringen, die zwischen unbedingtem und bedingtem Sprung unterscheiden lässt

  decd &leavepointer ; Durch das neue Element ist die Einfügestelle weitergeschoben.
  br #zwei_allot     ; Lücke für den Vorwärtssprung vorbereiten

; ANS sagt dazu:
; Discard the current loop control parameters. An ambiguous condition exists if they are unavailable.
; Continue execution immediately following the innermost syntactically enclosing DO ... LOOP or DO ... +LOOP.

  endif ; leaveeinbinden


;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "+loop" ; Es wird benutzt mit ( Increment -- ).
  ; ( Sprungziel 3 -- ) ohne leave
  ; ( AlterLeavePointer ... ZahlderAdressen Sprungziel 3 -- ) mit leave
;------------------------------------------------------------------------------
  Strukturpaar 3

  pushda #struktur_doplusloop_intern ; Nur ein Sprung, kein inline-Fragment mehr, ist so kürzer.
  call #callkomma

  call #r_branch

  jmp loop_generator_spaeter


struktur_doplusloop_intern:
  ; Variante, die einen Call einfügt, nicht ganz inline ist und so Platz spart.

  ; Inkrementiere den Index.
  ; Wenn Limit erreicht oder überschritten, Strukturen entfernen mit unloop Schleife verlassen.

  add #8000h, r5 ; Index + $8000
  sub r6, r5     ; Index + $8000 - Limit

  add @r4+, r5   ; Index + $8000 - Limit + Schritt

  bit #100h, sr  ; An dieser Stelle Flags prüfen

  jnc +           ; Beim Überlauf beenden.
    incd @sp      ; Den unbedingten Sprung nach dem Call überhüpfen.
+

  add r6, r5     ; Index + $8000 + Schritt
  sub #8000h, r5 ; Index + Schritt

  ret

; ANS: Add n to the loop index. If the loop index did not cross the boundary between
; the loop limit minus one and the loop limit, continue execution at the beginning of
; the loop. Otherwise, discard the current loop control parameters and continue execution
; immediately following the loop.
; Das Problem liegt darin, dass die Grenze von BEIDEN Seiten her überschritten werden kann !

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly, "loop" ; Es wird benutzt mit ( -- ).
  ; ( Sprungziel 3 -- ) ohne leave
  ; ( AlterLeavePointer ... ZahlderAdressen Sprungziel 3 -- ) mit leave
;------------------------------------------------------------------------------
  Strukturpaar 3

  pushdadouble #09506h, #05315h  ; inc r5      ; Index erhöhen
  call #doppelkomma              ; cmp r5, r6  ; Mit Limit vergleichen

  call #r_branch_jnz

loop_generator_spaeter:

  ifdef leaveeinbinden

  ifdef caseeinbinden
    call #spruenge_einpflegen ; Die gleiche Routine ist in Endcase am Werk
  else

    ; Einpflegen der gesammelten ?do und leave-Sprünge
    push r10
    popda r10 ; Hole die Zahl der einzupflegenden Sprünge hierher
    tst r10
    je +++

-   bit #1, @r4 ; Prüfe, ob es ein bedingter oder unbedingter Sprung werden soll:
    jnc +
      bic #1, @r4 ; Markierung für bedingten Sprung entfernen
      call #v_nullbranch
      jmp ++
+   call #v_branch
+   dec r10
    jnz -
+   pop r10 ; Alle einzufügenden Sprünge abgearbeitet
  endif

    mov @r4, &leavepointer ; Zurückholen für die nächste Schleifenebene
    mov #unloop, @r4 ; Anfügen: pop r5
    br #inlinekomma  ;          pop r6

  else ; leaveeinbinden
    pushda #unloop  ; Anfügen: pop r5
    br #inlinekomma ;          pop r6
  endif


  ifdef leaveeinbinden
;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly|Flag_opcodierbar_spezialfall, "?do" ; ( -- AlterLeavePointer Vorsprungadresse 1 Sprungziel 3 )
  ; Diese Schleife springt sofort ans Ende, wenn Limit=Index.
;------------------------------------------------------------------------------
  call #do_anfang ; Alles ganz normal !

  ; Auf dem Datenstack liegt nun: ( Rücksprunglückenadresse Strukturerkennung )
  ; An der Stelle, wohin der Rücksprung erfolgt, liegt aber nun der direkte Aussprung.
  ; Muss deswegen die Rücksprungadresse weiterschieben !

qdo_inneneinsprung:
  ; ( AlterLeavePointer 0 Sprungziel 3 )
  add #4, 2(r4) ; Rücksprungadresse um den Vergleich und den Leave-Sprung weiterschieben

  pushda #09506h ; cmp r5, r6   ; Mit Limit vergleichen
  call #komma

  push #1  ; Markierung, dass ein bedingter Sprung gebraucht wird
  jmp leave_bedingt

  ret ; Nur zur Erkennung des Endes, wird nicht ausgeführt.
  ;------------------------------------------------------------------------------
  ; Einsprung im Spezialfall: Kompilieren mit mindestens einer Konstanten.
    call #do_opcodierung
    jmp qdo_inneneinsprung

  endif

;------------------------------------------------------------------------------
  Wortbirne Flag_immediate_compileonly|Flag_opcodierbar_spezialfall, "do" ; Es wird benutzt mit ( Limit Index -- ).
  ; ( -- Sprungziel 3 ) ohne leave
  ; ( -- AlterLeavePointer 0 Sprungziel 3 ) mit leave
;------------------------------------------------------------------------------
do_anfang:
  pushda #struktur_do
  call #inlinekomma

do_inneneinsprung:
  ifdef leaveeinbinden
    pushdadouble &leavepointer, #0
    mov r4, &leavepointer ; Aktuelle Position im Stack sichern
  endif

  call #branch_r ; Schleifen-Rücksprung vorbereiten
  pushda #3      ; Strukturerkennung
  ret

  ;------------------------------------------------------------------------------
  ; Einsprung im Spezialfall: Kompilieren mit mindestens einer Konstanten.
do_opcodierung:
    mov #struktur_do, r12
    call #inline_at_r4_plus
    jmp do_inneneinsprung

struktur_do:
  push r6
  push r5
  popda r5
  popda r6
  ret
