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