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

; Routinen fürs Rechnen mit und Vergleichen von doppeltlangen Zahlen.

;------------------------------------------------------------------------------
;--- Doppelt-Rechnen ---
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "*/" ; Der Skalar ;-)
  ; ( n1 n2 n3 -- n1*n2/n3 ) Mit doppeltlangem Zwischenergebnis.
;------------------------------------------------------------------------------
  call #starslashmod
  nip
  ret

; : u*/  ( u1 u2 u3 -- u1 * u2 / u3 )  >r um* r> um/mod nip 3-foldable ;
;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "u*/" ; Der vorzeichenlose Skalar ;-)
  ; ( u1 u2 u3 -- u1*u2/u3 ) Mit doppeltlangem Zwischenergebnis.
;------------------------------------------------------------------------------
  to_r
  call #um_star
  r_from
  call #um_slash_mod
  nip
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "*/mod"
 starslashmod: ; ( n1 n2 n3 -- Rest n1*n2/n3 ) Mit doppeltlangem Zwischenergebnis.
;------------------------------------------------------------------------------
  to_r
  call #mstar
  r_from
  jmp mslashmod

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "m/mod"
mslashmod:
  ; Vorzeichenrichtige, symmetrische Division von Doppeltzahlen mit Rest.
  ; Fast genau wie  /mod
  ; ( Dividend Divisor -- Rest Ergebnis )
              ; ( d n1 -- n2 n3 ) Division mit Vorzeichen
              ;  32/16 = 16 Rest 16
;------------------------------------------------------------------------------
  push r10
  clr r10

  bit #8000h, 0(r4) ; Prüfe den Divisor
  jnc +
    inc r10
    negate

+ bit #8000h, 2(r4) ; Prüfe den Dividend
  push sr           ; Merke, ob er negativ gewesen ist !
  jnc +
    inc r10

    to_r            ; dnegate an zweiter Stelle auf dem Stack.
    call #dnegate
    r_from
+

  call #um_slash_mod

  pop sr ; Hole den Zustand des Dividenden zurück
  jnc +
    inv 2(r4) ; Negiere den Rest, wenn der Dividend negativ gewesen ist.
    inc 2(r4)
+

  ; Setze das Vorzeichen vom Ergebnis.
  bit #1, r10
  jnc +
  negate
+
  pop r10
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "m*"
mstar:        ; ( n1 n2 -- d ) Multiplikation mit Vorzeichen
              ;  d= n1 * n2
;------------------------------------------------------------------------------
  ; Zuerst die einzelnen Teile vom Vorzeichen befreien und das Vorzeichen für das Ergebnis bestimmen.
  push r10
  clr r10
  xor 2(r4), r10 ; Setzt negativ-Flag !
  bit #4, sr ; Negativ-Flag in Carry
  jnc +
    inv 2(r4)  ; Negieren
    inc 2(r4)
+
  xor @r4, r10 ; Setzt Vorzeichen für Ergebnis in r10
  bit #8000h, @r4 ; Prüfe das Vorzeichen des zweiten Faktors
  jnc +
    inv @r4
    inc @r4
+
  call #um_star

  rlc r10 ; r10 enthält im MSB das Vorzeichen des Ergebnisses.
  pop r10

  jc dnegate
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "um/mod"
um_slash_mod: ; ( ud u -- u u ) Dividend Divisor -- Rest Ergebnis
             ; 32/16 = 16 Rest 16
             ; Setzt bei einem Überlauf das Carry-Flag, mit Ergebnis $FFFF.
             ; Geht also brav in Sättigung.
;------------------------------------------------------------------------------
  ; Registerbenutzung:
  ; r12:r11 / r10 = r13, Rest in r12, r7 Zähler.
  push r10
  push r11
  push r12
  push r13

  popda r10      ; Divisor
  mov @r4, r12   ; Dividend - high
  mov 2(r4), r11 ;          - low

  clr r13
  mov #17, r7
- cmp r10, r12
  jlo +
  sub r10, r12
/ rlc r13
  jc ende_r12_r13_ergebnisse_auf_den_stack
  dec r7
  jz ende_r12_r13_ergebnisse_auf_den_stack
  rla r11
  rlc r12
  jnc --
  sub r10, r12
  setc
  jmp -

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "ud/mod"
ud_slash_mod: ; Dividiert 32/32 = 32 Rest 32.
;------------------------------------------------------------------------------
  ; ( DividendL DividendH DivisorL DivisorH -- ErgebnisL ErgebnisH RestL RestH )
  ;   6         4         2        0

  push r10 ; Hineinschiebe-Register für den Dividenden L
  clr r10  ; Normalerweise keine Kommastellenverschiebung.

ud_slash_mod_kommastellenverschiebung:
  push r11 ; Hineinschiebe-Register für den Dividenden H
  push r12 ; Ergebnis Low
  push r13 ; Ergebnis High
  ;     r7 ; Zähler

  push r15 ; Für die Kommastellenverschiebung. Wird benutzt, um f/ bereitzustellen.
  mov r10, r15 ; Lege die Kommastellenverschiebung hier in den richtigen Register

  clr r10 ; Ausnullen des "Schieberegisters"
  clr r11
  ; Ergebnis braucht nicht gelöscht zu werden, da dorthinein geschoben wird und 32 Schritte alle Bits belegen.

  mov #32, r7
- ; Schleife
  ; Schieben.
  rla 6(r4) ;  Low-Teil des Dividenden
  rlc 4(r4) ; High-Teil des Dividenden
  rlc r10   ;  Low-Schieberegister
  rlc r11   ; High-Schieberegister
  ; Wenn hier eine 1 rausfällt, also Carry gesetzt, so ist ein Überlauf aufgetreten.

  ; Dies ist die "Vorschaltkommastellenverschiebung".
  tst r15
  jz +
  dec r15
  jmp -
+ ; Wird nur einmal vor dem ersten Durchlauf benutzt !

  ; Prüfe, ob der Schieberegister größergleich des Dividenden ist. Schwierig, da hier zwei Register nacheinander
  ; verglichen werden müssen.

  cmp 0(r4), r11 ; Schieberegister-High mit Divisor-High vergleichen.
  jne + ; High-Teile sind ungleich gewesen.
  ; Beide sind gleich. Entscheidung fällt anhand des Low-Teils:
  cmp 2(r4), r10 ; Schieberegister-Low mit Divisor-Low vergleichen
+ jhs + ; Bereit zum Abziehen,
  ; Kleiner: Nicht abziehen.
  clrc    ; Null fürs Ergebnis
  jmp ++
+ ; Gleich oder größer, Abzugsbereit !
  sub  2(r4), r10 ; Divisor-Low vom Schieberegister-Low abziehen
  subc 0(r4), r11 ;         High                    High        , mit Übertrag.
  setc    ; Eins fürs Ergebnis
+ rlc r12 ; Ins Ergebnis rotieren. Low
  rlc r13 ;                        High.

  dec r7
  jnz -

  pop r15

ende_r10_r11_r12_r13_ergebnisse_auf_den_stack:
  mov r10, 6(r4)  ; Sowas wie Rest low
  mov r11, 4(r4)  ; Sowas wie Rest high
ende_r12_r13_ergebnisse_auf_den_stack:
  mov r12, 2(r4)  ; Ergebnis low
  mov r13, 0(r4)  ; Ergebnis high
  jmp ende_pop_13_10


  ifdef fixkommarechnungeneinbinden

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "udm*"
ud_star: ; Multipliziert vorzeichenlos 32*32 = 64
         ; ( ud ud -- 2*ud)
;------------------------------------------------------------------------------

  ; Auf dem Datenstack: ( 1L 1H 2L 2H -- LL L H HH )
  ;                       6  4  2  0
  ; Benötige einen langen Ergebnisregister !


  push r10 ; Ergebnis (1) LSB
  push r11 ; Ergebnis (2)
  push r12 ; Ergebnis (3)
  push r13 ; Ergebnis (4) MSB
  ;     r7 ; Zähler

  clr r10 ; Ergebnisregister löschen.
  clr r11
  clr r12
  clr r13 ; alle Teile leer.

  mov #32, r7 ; Zähler, wie viele Durchläufe noch erforderlich sind.

- ; Schiebe das Ergebnis um ein Bit nach Links.
  rla r10 ; Letztes Ergebnis * 2
  rlc r11 ;   rotieren
  rlc r12 ;   rotieren
  rlc r13 ;   rotieren

  ; Schiebe den einen Faktor um ein Bit nach links.
  rla 2(r4) ; 2. Faktor low
  rlc 0(r4) ; 2. Faktor high

  ; Prüfe, ob ein 1-Bit herausgepurzelt ist.
  jnc +
  ; Eins-Bit herausgepurzelt ? Dann addiere den 1. Faktor zum Ergebnis.
  add  6(r4), r10
  addc 4(r4), r11
  adc         r12
  adc         r13

+ dec r7
  jnz -

  jmp ende_r10_r11_r12_r13_ergebnisse_auf_den_stack

  endif ; fixkommarechnungeneinbinden

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "d2/"
  rra @r4   ; Erst High-Teil
  rrc 2(r4) ; dann Nachkommastellen / Low-Teil mit Übertrag
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "d2*"
  rla 2(r4) ; Erst Low-Teil
  rlc @r4   ; dann High-Teil mit Übertrag
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "dabs"
dabs:
  tst @r4 ; High-Teil auf Vorzeichenbit testen
  jn dnegate
  ret ; Nicht negativ ? Nichts zu tun.

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_3, "?dnegate" ; Negiert eine Doppeltzahl, wenn TOS negativ ist.
  add @r4+, -2(r4)   ; So eine Art rla @r4+ - Schiebt das MSB in Carry-Flag.
  jc dnegate
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "dnegate"
dnegate:
  inv 2(r4) ; Umkehren
  inv @r4
  inc 2(r4) ; Eins addieren
  adc @r4   ; Carry beachten.
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d-" ; ( 1L 1H 2L 2H )
dminus:                                        ;   6  4  2  0
  sub  2(r4), 6(r4) ; Erst den Low-Teil
  subc 0(r4), 4(r4) ; Dann den High-Teil mit Übertrag
  add #4, r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d+" ; Doppelt-Nummern: ( Low High ) bzw. ( Kommastellen Integerteil )
dplus:
  add  2(r4), 6(r4)
  addc 0(r4), 4(r4)
  add #4, r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_1, "s>d" ; ( n - dl dh ) Macht eine Doppeltzahl aus einer Einfachzahl
doppeltlangmachen:
  pushda #-1
  tst 2(r4)
  jn +

clr_at_r4_ret:
  clr @r4
+ ret


;------------------------------------------------------------------------------
;--- Doppelt-Vergleiche ---
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "du>"
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0
  call #dswap
  jmp +

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "du<"
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0

  ; Prüfe zunächst, ob 1H < 2H. Wenn ja, fertig !
  ; Prüfe zunächst, ob 1H >= 2H. Wenn ja, mit false fertig.
  ; 1H < 2H --> True, Fertig.
  ; 2H > 1H --> False, Fertig.
  ; 1H = 2H --> Weitere Probe mit den Nachkommastellen.

+ cmp @r4, 4(r4)
  jlo ++ ; Ist bereits kleiner. Fertig.
  jne +  ; Ist nicht kleiner, aber auch nicht gleich. Also Größer. Fertig.

  ; Muss also Nachkommastellen prüfen.
  cmp 2(r4), 6(r4)
  jlo ++ ; Nachkommastellen sind kleiner. True,

+ ; Aussprung False
  mov #0, 6(r4)
  jmp ++
+ ; Aussprung True
  mov #-1, 6(r4)
+ add #6, r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d>"
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0
  call #dswap
  jmp +

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d<"
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0

  ; Prüfe zunächst, ob 1H < 2H. Wenn ja, fertig !
  ; Prüfe zunächst, ob 1H >= 2H. Wenn ja, mit false fertig.
  ; 1H < 2H --> True, Fertig.
  ; 2H > 1H --> False, Fertig.
  ; 1H = 2H --> Weitere Probe mit den Nachkommastellen.

+ cmp @r4, 4(r4)
  jl  ++ ; Ist bereits kleiner. Fertig.
  jne +  ; Ist nicht kleiner, aber auch nicht gleich. Also Größer. Fertig.

  ; write " Prüfe Nachkommastellen: "
  ; Muss also Nachkommastellen prüfen.
  cmp 2(r4), 6(r4)
  jlo ++ ; Nachkommastellen sind kleiner. True,

+ ; Aussprung False
  mov #0, 6(r4)
  jmp ++
+ ; Aussprung True
  mov #-1, 6(r4)
+ add #6, r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "d0<"  ; Ist die Zahl negtativ ?
  ; ( 1L 1H -- Flag )
  ; Rotiere das MSB von 1H, also das Sign-Bit ins Carry.
  add @r4+, -2(r4) ; So eine Art rlc @r4+
  jnc clr_at_r4_ret ; Falls Sign-Bit nicht gesetzt war
  mov #-1, @r4      ; Lege ein True-Flag bereit
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_2, "d0="
  ; ( 1L 1H -- Flag )

  bit @r4+, -2(r4) ; Oberstes Element 1H auf Null prüfen und ablegen.
  jnz clr_at_r4_ret ; Nicht Null - Fertig !

  bit #-1, @r4   ; C gesetzt, wenn Ergebnis von "and" NICHT Null ist
  subc @r4, @r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d<>"
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0

  call #dgleich
  xor #-1, @r4
  ret

;------------------------------------------------------------------------------
  Wortbirne Flag_visible|Flag_foldable_4, "d="
  ; ( 2L 2H 1L 1H -- Flag )
  ;   6  4  2  0

dgleich:
  xor @r4+, 2(r4) ; Vergleiche 1H und 2H
  jc +
  ; ( 2L 2H 1L -- Flag )
  ;   4  2  0

  xor 0(r4), 4(r4) ; Wenn das erste Päärchen gleich ist, teste das Zweite.
+ subc 4(r4), 4(r4)
  add #4, r4
  ret
