
compiletoflash

: cornerstone ( Name ) ( -- )
  <builds does> eraseflashfrom
;

compiletoflash

: (* ( -- ) \ Long comment

begin
  token  \ Get next token
  dup 0= if 2drop cr query token then  \ If length of token is zero, end of line is reached. Fetch new line. Fetch new token.
  s" *)" compare  \ Search for *)
until

immediate 0-foldable ; 
compiletoflash

\ -----------------------------------------------------------
\   Cooperative Multitasking
\ -----------------------------------------------------------

\ Configuration:

32 cells constant stackspace \ 32 stack elements for every task

\ Internal stucture of task memory:
\  0: Pointer to next task
\  2: Task currently active ?
\  4: Saved stack pointer
\  6: Handler for Catch/Throw
\  Parameter stack space
\  Return    stack space

false 0 true flashvar-here 4 cells - 4 nvariable boot-task \ Boot task is active,
                                   \ without handler and has no extra stackspace.
boot-task boot-task ! \ For compilation into RAM only

boot-task variable up \ User Pointer
: next-task  ( -- task )    up @ inline ;
: task-state ( -- state )   up @ 1 cells + inline ;
: save-task  ( -- save )    up @ 2 cells + inline ;
: handler    ( -- handler ) up @ 3 cells + inline ;

: (pause) ( stacks fly around )
    [ $1206 , $1205 , ] \ push r6 & push r5 to save I and I'
    rp@ sp@ save-task !  \ save return stack and stack pointer
    begin
      next-task @ up !     \ switch to next running task
    task-state @ until
    save-task @ sp! rp!  \ restore pointers
    unloop ;              \ pop r5 & pop r6 to restore the loop registers

: wake ( task -- ) 1 cells +  true swap ! ; \ Wake a random task (IRQ safe)
: idle ( task -- ) 1 cells + false swap ! ;  \ Idle a random task (IRQ safe)

\ -------------------------------------------------------
\  Round-robin list task handling - do not use in IRQ !
\ -------------------------------------------------------

: stop ( -- ) false task-state ! pause ; \ Stop current task
: multitask  ( -- ) ['] (pause) hook-pause ! ;
: singletask ( -- ) [']  nop    hook-pause ! ;

: task-in-list? ( task -- ? ) \ Checks if a task is currently inside of round-robin list
                              ( do not use in IRQ )
  next-task
  begin
    ( Task-Address )
    2dup = if 2drop true exit then
    @ dup next-task = \ Stop when end of circular list is reached
  until
  2drop false
;

: previous ( task -- addr-of-task-before )
  \ Find the task that has the desired one in its next field
  >r next-task begin dup @ r@ <> while @ repeat rdrop
;

: insert ( task -- ) \ Insert a task into the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if drop else next-task @ over ! next-task ! then
;

: remove ( task -- ) \ Remove a task from the round-robin list
  dup task-in-list?  \ Is the desired task currently linked into ?
  if dup @ ( task next )
     swap previous ( next previous ) !
  else drop then
;

\ -----------------------------------------
\ Create a new task - do not use in IRQ !
\ -----------------------------------------

: task: ( "name" -- )  stackspace cell+ 2*  4 cells +  buffer: ;

: preparetask ( task continue -- )
  swap >r ( continue R: task )

    \ true  r@ 1 cells + ! \ Currently running
      false r@ 3 cells + ! \ No handler

    r@ 4 cells + stackspace + ( continue start-of-parameter-stack )
      dup   r@ 2 cells + ! \ Start of parameter stack

    dup stackspace + ( continue start-of-parameter-stack start-of-return-stack )
    tuck      ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack )
    2 cells - ( continue start-of-return-stack start-of-parameter-stack start-of-return-stack* )
                                                      \ Adjust for saved loop index and limit
    swap  !   ( continue start-of-return-stack ) 
                           \ Store the adjusted return stack pointer into the parameter stack
    !         \ Store the desired entry address at top of the tasks return stack

  r> insert
;

: activate ( task --   R: continue -- )
  true over 1 cells + ! \ Currently running
  r> preparetask
;

: background ( task --   R: continue -- )
  false over 1 cells + ! \ Currently idling
  r> preparetask
;

\ --------------------------------------------------
\  Multitasking insight
\ --------------------------------------------------

: tasks ( -- ) \ Show tasks currently in round-robin list
  hook-pause @ singletask \ Stop multitasking as this list may be changed during printout.

  \ Start with current task.
  next-task cr

  begin
    ( Task-Address )
    dup             ." Task Address: " hex.
    dup           @ ." Next Task: " hex.
    dup 1 cells + @ ." State: " hex.
    dup 2 cells + @ ." Stack: " hex.
    dup 3 cells + @ ." Handler: " hex. cr

    @ dup next-task = \ Stop when end of circular list is reached
  until
  drop

  hook-pause ! \ Restore old state of multitasking
;

\ --------------------------------------------------
\  Exception handling
\ --------------------------------------------------

: catch ( x1 .. xn xt -- y1 .. yn throwcode / z1 .. zm 0 )
    [ $1206 , $1205 , ]  \ push r6 & push r5 to save I and I'
    sp@ >r handler @ >r rp@ handler !  execute
    r> handler !  rdrop  0 unloop ;

: throw ( throwcode -- )  dup IF
        handler @ 0= IF false task-state ! THEN 
                        \ unhandled error: stop task
          handler @ rp! r> handler ! r> swap >r sp! drop r>
        UNLOOP  EXIT
ELSE  drop  THEN ;

\ --------------------------------------------------
\  Lowpower mode
\ --------------------------------------------------

: up-alone? ( -- ? ) \ Checks if all other tasks are currently in idle state
  next-task @ \ Current task is in UP. Start with the next one.
  begin
    dup up @ <> \ Scan the whole round-robin list until back to current task.
  while
    dup 1 cells + @ if drop false exit then 
              \ Check state of this task and exit if it is active
    @ \ Next task in list
  repeat
  drop true
;

\ Lowpower-Task: To be done !

compiletoflash

\ ------------------------------------------------
\  A quick list of words - a wish of Paul Verbeke
\ ------------------------------------------------

\ Dictionary structure is:
\  (2-aligned)
\      1 Byte Flags 
\      1 Byte Name length and name characters as counted string, maybe with filling zero to align
\  (2-aligned)
\      2 Bytes Link
\      Code entry point

: list ( -- )
  cr
  dictionarystart 
  begin
    dup 1+ ctype space
    dictionarynext
  until
  drop
;

\ -------------------------------------------------------------
\  Which definitions are in use ? - An idea of Sandy Bumgarner
\ -------------------------------------------------------------

0 variable searchfor

: searchcalls ( address-of-name -- )

  \ As this searches for call opcodes until first ret,
  \ it may fail on definitions using multiple exit points or inline strings.
  \ Definitions in core include all sort of assembly tricks, direct jumps and others, so you cannot
  \ rely on the output to determine what definitions in core are using Flamingo.

  dup skipstring
  begin
    2+
    dup @ $12B0 = if dup 2+ @ searchfor @ = if drop ctype space exit then then
    dup @ $4130 = \ Ret opcode
  until
  2drop
;

: uses ( -- ) \ "uses Flamingo" searches for definitions which contain calls to Flamingo.
  cr ' searchfor ! \ Get code entry point

  dictionarystart
  begin
    dup c@ $FF <> if dup 1+ searchcalls then \ Skip invisible definitions
    dictionarynext
  until
  drop
;

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

: name. ( Address -- ) \ Wenn die Adresse der Code-Anfang eines Dictionarywortes ist, wird es benannt.
  >r                   \ If the address is Code-Start of a dictionary word, it gets named.
  dictionarystart
  begin
    dup   1+ dup skipstring 2+ r@ = if ."   --> " ctype else drop then
    dictionarynext
  until
  r> 2drop
;

0 variable disasm-$   \ Current position for disassembling

: disasm-fetch        \ ( -- Data ) Fetches opcodes and operands, increments disasm-$
    disasm-$ @ @      \             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 -1           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-string ( -- ) \ Takes care of an inline string
  disasm-$ @ dup ctype skipstring disasm-$ !
;

: 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 )

  \ Bei Call-Befehlen versuchen, den Einsprung zu benennen und Strings zu erkennen.
  \ Try to give calls a name and detect inline strings.
  $12B0 = if
    disasm-$ @ 2- @  \ Fetch call target address
    dup name. \ Try to give it a name
    case
      ['] ." $1E + of ."    .' " disasm-string ." '" endof \ It is ." runtime ?
      ['] s" $06 + of ."    s' " disasm-string ." '" endof \ It is s" runtime ?
      ['] c" $06 + of ."    c' " disasm-string ." '" endof \ It is c" runtime ?
    endcase
  then
;

: 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 ." : " @ 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-$ @ @ $4130 =  \ Flag: Loop terminates with ret
    disasm-step
  until

  base !
;

: see ( -- ) \ Takes name of definition and shows its contents from beginning to first ret
  ' disasm-$ !
  seec
;

compiletoflash

\ MSP430 Assembler, Copyright (C) 2012  Matthias Koch
\ This is free software under GNU General Public License v3.
\ Resolves constants, symbols and variable names and
\ gives you a comfortable way to write machine instructions.

: zero-operand <builds , $30 setflags
                 does> @ , ;

%0001001100000000 zero-operand reti

\ Emulated instructions
$4130 zero-operand ret
$c312 zero-operand clrc
$c222 zero-operand clrn
$c322 zero-operand clrz
$d312 zero-operand setc
$d222 zero-operand setn
$d322 zero-operand setz

\ nop1 and nop2 wait 1 or 2 clock cycles.
\ Internal nop of Forth gets optimized away,
\ as it is intended for open IRQ handlers.

$4303 zero-operand nop1
$3c00 zero-operand nop2


\ Jumps and Labels

0 variable label-
0 variable label--
0 variable label---

: l-:   label-- @ label--- !
        label-  @ label--  !
        here      label-   !
immediate ;

\ Forward labels
\ Idea: Remember place and jump-opcodes to be filled in when label is reached.

0. 2variable label-f1
0. 2variable label-f2
0. 2variable label-f3
0. 2variable label-f4
0. 2variable label-f5
0. 2variable label-f6
0. 2variable label-f7
0. 2variable label-f8

: check+label ( Sprungkonstruktadresse -- )
  dup @ $000F and ( Addr Labelzähler )
    dup if \ Ungleich 0 ( Addr Labelzähler )

          1 = if ( Adresse )
                dup 2@ ( Adresse Lückenadresse Labelopcode )
                1- \ Label 1 auf 0 setzen, damit Opcode stimmt !
                ( Adresse Lückenadresse Opcode-Bitmaske )
                here swap
                ( Adresse Lückenadresse Zieladresse Opcode-Bitmaske )
                jump,
                ( Adresse )
                >r 0. r> 2!  \ Sprunglabel aus Tabelle löschen

              else

                dup ( Adresse Adresse )
                @   ( Adresse Labelopcode )
                1-  ( Adresse Labelopcode* )
                swap ( Labelopcode* Adresse )
                !
              then

        else \ Null - nichts tun
          ( Addr Labelzähler )
          2drop
        then
;

: l+:
  \ Time to fill in opcodes for forward jumps.
  \ Crawl the notes to see what is pending.
  label-f1 check+label
  label-f2 check+label
  label-f3 check+label
  label-f4 check+label
  label-f5 check+label
  label-f6 check+label
  label-f7 check+label
  label-f8 check+label
immediate ;

: remember+jump ( Zieladresse Opcode )
  \ Find an empty location in the forward-jump-notes.
  \ If it contains zero, the fresh wish for a jump can be filled in.
  label-f1 @ 0= if label-f1 2!  exit then
  label-f2 @ 0= if label-f2 2!  exit then
  label-f3 @ 0= if label-f3 2!  exit then
  label-f4 @ 0= if label-f4 2!  exit then
  label-f5 @ 0= if label-f5 2!  exit then
  label-f6 @ 0= if label-f6 2!  exit then
  label-f7 @ 0= if label-f7 2!  exit then
  label-f8 @ 0= if label-f8 2!  exit then
  ." Too many forward references" cr quit
;



: jump-destination ( Opcode Stringaddress Length -- Opcode Flag )
    2dup s" +"   compare if 2drop 1 or false exit then  \ False: Has to be resolved later
    2dup s" ++"  compare if 2drop 2 or false exit then
    2dup s" +++" compare if 2drop 3 or false exit then

    2dup s" -"   compare if 2drop label-   @  here - true exit then \ True: Insert now
    2dup s" --"  compare if 2drop label--  @  here - true exit then
    2dup s" ---" compare if 2drop label--- @  here - true exit then

    number   1 <> if ." Jump into the ocean " quit then
    true
;

: jumps <builds , $30 setflags
        does> @ token
              jump-destination  \ Maybe some checks for jump distance soon ?
              if   \ Backward Jump
                2-   \ Destination shifted by two bytes for jump opcode itself
                shr %1111111111 and or ,
              else \ Forward-Jump
                here swap remember+jump 2 allot
              then
;

%0010000000000000 jumps jne
%0010000000000000 jumps jnz
%0010010000000000 jumps jeq
%0010010000000000 jumps jz
%0010100000000000 jumps jnc
%0010100000000000 jumps jlo
%0010110000000000 jumps jc
%0010110000000000 jumps jhs
%0011000000000000 jumps jn
%0011010000000000 jumps jge
%0011100000000000 jumps jl
%0011110000000000 jumps jmp


\ Ein paar Stringhelferlein
\ A few helpers for strings

: vorneabschneiden ( Adresse Length -- Adresse Length )
  1- swap 1+ swap
;

: ersteszeichen ( Adresse Length -- Adresse Length Zeichen )
  over c@
;

: letzteszeichen ( Adresse Length -- Adresse Length Zeichen )
  2dup 1- + c@
;

: hintenabschneiden ( Adresse Length -- Adresse Length )
  1-
;


\ Muss jetzt noch angegebene Konstanten, Variablen, Wörter und Werte abhandeln.
\ Das passiert dadurch, dass ich das Ding
\ - im Dictionary suche
\     - Falls Variable  --> Variablenadresse
\     - Falls Konstante --> Konstante holen
\ - Versuche in eine Zahl umzuwandeln

\ Konstanten im Flash und Variablen im RAM haben Flag $40, Feste Variablen im Flash haben Flag $81, selbstdefinierte Einfachvariablen $C1 oder Doppeltvariablen $C2.

: symbolwert ( Stringaddress Length -- Symbolvalue )

  2dup find ( Adresse Flags ) over 0<>
        if
          \ Probe, ob die Flags auf Variablen oder Konstanten hindeuten
          ( Adresse Flags )
          swap
          ( Flags Adresse )
          over $40 = if execute then \ Konstanten im RAM und Flash; Variablen im RAM
          over $81 = if execute then \ Kernvariablen im Flash
          over $C1 = if execute then \ Selbstdefinierte Variablen        im Flash
          over $C2 = if execute then \ Selbstdefinierte Doppeltvariablen im Flash
          nip ( Adresse oder geholte Konstante )

          nip nip exit \ Vergiss Stringadresse und Länge, Rücksprung
        else
          2drop \ Vergiss Ergebnisse von find
        then

  2dup number 1 =
        if \ ."  Zahl " dup u.
          nip nip exit \ Vergiss Stringadresse und Länge, Rücksprung
        then

  ." Invalid Symbol: "    \ ." Ungültiges Symbol: "
  type cr quit
;

: registerparser ( Stringadresse Length -- Nummer )
  ersteszeichen [char] r = if base @ >r decimal
                             vorneabschneiden
                             number 1 <> if ." Invalid Register" cr quit then
                             15 and
                             r> base !
                           exit
                           then

  2dup s" pc" compare if 2drop 0 exit then
  2dup s" sp" compare if 2drop 1 exit then
  2dup s" sr" compare if 2drop 2 exit then
  2dup s" cg" compare if 2drop 3 exit then

  ." Invalid Operand" \ ." Falsche Operandenangabe"
  cr quit
;

: operandenparser  \ Bearbeitet r14, @r14, @r14+, (r14), #42, &p2out
  ( -- Daten Bitmaske )
    token

    \ Bitmaske hat Format:
    \ Bit 15: Nur als Quelloperand gültig
    \ Bit 14:
    \ Bit 13:
    \ Bit 12: Quelloperand folgt nach Befehl

    \ Bit 11-8: Register für Quelle

    \ Bit 7: Adressmodus Ziel       -  wenn gesetzt, kommt ein Zieloperand dazu
    \ Bit 6: Immer 0 (Bytebefehl)
    \ Bit 5: Adressmodus Quelle
    \ Bit 4: Adressmodus Quelle

    \ Bit 3-0: Register für Ziel

    ersteszeichen [char] # =
      if  \ ." Konstante "
        vorneabschneiden \ # weg
        symbolwert $9030
      exit
      then

    ersteszeichen [char] & =
      if  \ ." Absolut "
        vorneabschneiden \ & weg
        symbolwert $1292   \ Emuliert als Index(R2)
      exit
      then

    ersteszeichen [char] ( =
      if  \ ." Indirekt "
        vorneabschneiden  \ ( weg
        hintenabschneiden \ ) weg

        registerparser
        dup 8 lshift or \ Register zweimal in der Bitmaske
        $1090 or

        token symbolwert swap

      exit
      then

    ersteszeichen [char] @ =
      if  \ ." @Register "
         vorneabschneiden \ @ weg

         letzteszeichen [char] + = if \  ." rinc "
                                     hintenabschneiden  \ + am Ende weg
                                     registerparser
                                     dup 8 lshift or \ Register zweimal in der Bitmaske
                                     $80B0 or

                                     over \ Hole Opcode, der auf dem Stack liegt... Brauche dies NUR für Schiebebefehle
                                     $0040 and if \ Bytebefehl ?

                                                 dup $000E and if \ andere Register
                                                                 $FFFF
                                                               else \ PC, SP
                                                                 $FFFE
                                                               then
                                               else \ Wordbefehl
                                                 $FFFE
                                               then


                                     ( $FFFE ) swap
                                   else
                                     registerparser
                                     dup 8 lshift or \ Register zweimal in der Bitmaske
                                     $00A0 or
                                     0 swap \ Daten für Emulation von @Register als 0(Register)
                                   then
      exit
      then

    registerparser
    dup 8 lshift or \ Register zweimal in der Bitmaske
    $0000 swap
;

0 constant false
-1 constant true


: ziel-operand ( Opcode -- Daten Opcode true | Opcode false )
  ( Opcode )
  \ Zweiter Operand:
  operandenparser
  ( Opcode Daten Bitmaske )

  dup $8000 and if ( ." Ungültiger Zieloperand " ) ." Invalid Destination Operand " cr quit then

  dup $0080 and if \ Extradaten vorhanden

                  ( Opcode Daten Bitmaske )
                  $008F and \ Maske für Zieloperanden
                  rot ( Daten Bitmaske Opcode )
                  or ( Daten Opcode* )
                  true

                else \ Keine Daten für den zweiten Operanden

                  ( Opcode Daten Bitmaske )
                  $008F and \ Maske für Zieloperanden
                  nip \ Daten Weg
                  ( Opcode Bitmaske )
                  or ( Opcode* )
                  false

                then
;


: constantengenerator-r3 \ For single- and double-operand-instructions
  ( Data Bitmask )
  \ Check if bitmask is for @pc+
  dup $9030 = if


    over  0 = if drop $8303 exit then
    over  1 = if drop $8313 exit then
    over  2 = if drop $8323 exit then
    over -1 = if drop $8333 exit then

              then
;

: constantengenerator-r2 \ For double-operand-instructions
  ( Data Bitmask )
  \ Check if bitmask is for @pc+
  dup $9030 = if

    over  4 = if drop $8222 exit then
    over  8 = if drop $8232 exit then

              then
;

: double-operand <builds , $30 setflags
                 does> @ ( Opcode )

                       operandenparser ( Opcode -- Opcode Data Bitmask )
                       constantengenerator-r2
                       constantengenerator-r3
                       dup $1000 and
                       if \ Daten folgen aus dem ersten Operanden
                         ( Opcode Daten Bitmaske )
                         $0F30 and \ Maske für Quelloperanden
                         ( Opcode Daten Bitmaske* )
                         rot ( Daten Bitmaske* Opcode )
                         or ( Daten Opcode* )

                         ziel-operand if   ( Daten-1 Daten-2 Opcode ) , swap , ,
                                      else ( Daten-1 Opcode )         , ,
                                      then


                       else \ Keine Daten folgen aus dem ersten Operanden
                         ( Opcode Daten Bitmaske )
                         nip \ Daten weg
                         $0F30 and \ Maske für Quelloperanden
                         or ( Opcode* )

                         ziel-operand if ( Daten Opcode ) , ,
                                      else ( Opcode )       ,
                                      then
                       then
; \ double-operand


%0100000000000000 double-operand mov.w
%0100000001000000 double-operand mov.b
%0101000000000000 double-operand add.w
%0101000001000000 double-operand add.b
%0110000000000000 double-operand addc.w
%0110000001000000 double-operand addc.b
%0111000000000000 double-operand subc.w
%0111000001000000 double-operand subc.b
%1000000000000000 double-operand sub.w
%1000000001000000 double-operand sub.b
%1001000000000000 double-operand cmp.w
%1001000001000000 double-operand cmp.b
%1010000000000000 double-operand dadd.w
%1010000001000000 double-operand dadd.b
%1011000000000000 double-operand bit.w
%1011000001000000 double-operand bit.b
%1100000000000000 double-operand bic.w
%1100000001000000 double-operand bic.b
%1101000000000000 double-operand bis.w
%1101000001000000 double-operand bis.b
%1110000000000000 double-operand xor.w
%1110000001000000 double-operand xor.b
%1111000000000000 double-operand and.w
%1111000001000000 double-operand and.b

: single-operand <builds , $30 setflags
                 does> @ ( Opcode )

                       operandenparser ( Opcode -- Opcode Daten Bitmaske )
                       constantengenerator-r3
                       dup $1000 and
                       if \ Daten folgen aus dem ersten Operanden
                         ( Opcode Daten Bitmaske )
                         $003F and \ Maske für Quelloperanden
                         ( Opcode Daten Bitmaske* )
                         rot ( Daten Bitmaske* Opcode )
                         or ( Daten Opcode* )
                         , ,

                       else \ Keine Daten folgen aus dem ersten Operanden
                         ( Opcode Daten Bitmaske )
                         nip \ Daten weg
                         $003F and \ Maske für Quelloperanden
                         or ( Opcode* )
                         ,
                       then
; \ single-operand

%0001000000000000 single-operand rrc.w
%0001000001000000 single-operand rrc.b
%0001000010000000 single-operand swpb.w
%0001000100000000 single-operand rra.w
%0001000101000000 single-operand rra.b
%0001000110000000 single-operand sxt.w
%0001001000000000 single-operand push.w
%0001001001000000 single-operand push.b
%0001001010000000 single-operand call.w


\ Emulierte Befehle, die aber der Einfachheit halber trotzdem gesondert behandelt werden:
\ Spezielle Nur-Ziel-Zwei-Operanden-Befehle

: emu-destination-operand
                 <builds , $30 setflags
                 does> @ ( Opcode )
                       ziel-operand if   ( Daten Opcode ) , ,
                                    else ( Opcode )       ,
                                    then
;


$6300 emu-destination-operand adc.w
$6340 emu-destination-operand adc.b
$7300 emu-destination-operand sbc.w
$7340 emu-destination-operand sbc.b
$4300 emu-destination-operand clr.w
$4340 emu-destination-operand clr.b
$8310 emu-destination-operand dec.w
$8350 emu-destination-operand dec.b
$8320 emu-destination-operand decd.w
$8360 emu-destination-operand decd.b
$5310 emu-destination-operand inc.w
$5350 emu-destination-operand inc.b
$5320 emu-destination-operand incd.w
$5360 emu-destination-operand incd.b
$e330 emu-destination-operand inv.w
$e370 emu-destination-operand inv.b
$9300 emu-destination-operand tst.w
$9340 emu-destination-operand tst.b
$4130 emu-destination-operand pop.w
$4170 emu-destination-operand pop.b


: emu-shift-operand
                 <builds , $30 setflags
                 does> @ ( Opcode )

  \ Fälle: Register, Register indirekt (inkl. absoluter Adressierung) --> Zieloperand identisch
  \        @Register --> Quelle und Ziel etwas anders, @Register+ --> @r10+, -2(r10) :-)
  \        Alle Fälle mit Ausnahme von Konstanten sind erlaubt. Wozu aber auch Konstanten schieben ?


                       operandenparser ( Opcode -- Opcode Daten Bitmaske )

                       dup $1000 and
                       if \ Daten folgen aus dem ersten Operanden
                          \ In diesem Fall müssen die Operanden zweimal geschrieben werden.
                          \ Indexed, Absolut.
                         ( Opcode Daten Bitmaske )
                         $0FBF and \ Maske für Quell- und Zieloperanden
                         ( Opcode Daten Bitmaske* )
                         rot ( Daten Bitmaske* Opcode )
                         or ( Daten Opcode* )
                         , dup , ,
                       else \ Keine Daten folgen aus dem ersten Operanden, vielleicht aus dem zweiten.

                         ( Opcode Daten Bitmaske )
                         dup $0080 and if \ Daten für zweiten Operanden
                                         \ Probe auf @rx+ im Bytebefehl !!
                                        $0FBF and \ Maske für Quell- und Zieloperanden
                                        ( Opcode Daten Bitmaske* )
                                        rot ( Daten Bitmaske* Opcode )
                                        or ( Daten Opcode* )
                                        , ,

                                      else \ Keine Daten für zweiten Operanden
                                        nip ( Opcode Bitmaske )
                                        $0FBF and \ Maske für Quell- und Zieloperanden
                                        or ,
                                      then
                       then

;

$5000 emu-shift-operand rla.w
$5040 emu-shift-operand rla.b
$6000 emu-shift-operand rlc.w
$6040 emu-shift-operand rlc.b

\ Assembler hier zu Ende.
\ End of Assembler

\ A convenient memory dump helper

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

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

\ A small helper to find occurences of a special bit pattern

: scanrange ( pattern end-addr start-addr -- )
  do dup i @ = if i 16 dump then 2 +loop drop
;

\ -----------------------------------------------------------------------------
\  Text mode with character buffer
\ -----------------------------------------------------------------------------

$6000 constant characters
$7000 constant glyphs

: font! ( x addr -- ) glyphs     + c! ;
: font@ ( addr -- x ) glyphs     + c@ ;

: char! ( x addr -- ) characters + c! ;
: char@ ( addr -- x ) characters + c@ ;

\ -----------------------------------------------------------------------------
\   Character handling for text mode
\ -----------------------------------------------------------------------------

100 constant xres
 37 constant yres

0 variable xpos
0 variable ypos

0 variable textmarker

: highlight ( -- )  $80 textmarker ! ;
: normal    ( -- )    0 textmarker ! ;

0 variable captionchars

: caption ( -- ) \ Fix caption lines when scrolling
  ypos @ xres * xpos @ + captionchars !
;

: nocaption ( -- ) 0 captionchars ! ; \ Remove caption protection

: page ( -- ) \ Clear display
  xres yres * captionchars @ do 32 i char! loop
  captionchars @ xres /mod ypos ! xpos !
;

: clrscr ( -- ) page ; \ Just an intuitive alias for page

: addline ( -- )
  ypos @ yres 1- < if
    1 ypos +!
  else
    captionchars @ xres +  characters +
    captionchars @         characters +
    xres yres * captionchars @ - xres -
    move

    xres yres 1- * characters + xres 32 fill
  then
  0 xpos !
;

: addchar ( c -- )
  textmarker @ or
  xpos @ xres 1- > if addline 0 xpos ! then
  ypos @ xres * xpos @ + char!
  1 xpos +!
;

: stepback ( -- )
  xpos @
  if
    -1 xpos +!
  else
    ypos @ if -1 ypos +! xres 1- xpos ! then
  then
;

: hdmi-emit ( c -- )
  case
    10 of addline  endof \ Line Feed
     8 of stepback endof \ Backspace
    dup $C0 and $80 <>
    if dup 127 umin addchar then \ Display block glyph for UTF-8 chars.
  endcase
;

$03 constant IFG2
$6E constant UCB0RXBUF
$6F constant UCB0TXBUF

: leds    ( c -- ) $29 c! $FF $2A c! ;
: buttons ( -- x ) $18 c@ ;

: cycles  ( -- u ) $01F0 @ ;

   40 constant cycles/us  \ For 40 MHz
40000 constant cycles/ms

: delay-cycles ( cycles -- )
  cycles ( cycles start )
  begin
    pause
    2dup ( cycles start cycles start )
    cycles ( cycles start cycles start current )
    swap - ( cycles start cycles elapsed )
    u<=
  until
  2drop
;

: us ( u -- )       cycles/us *  delay-cycles      ;
: ms ( u -- ) 0 ?do cycles/ms    delay-cycles loop ;

: random ( -- x ) 0 32 0 do 10 us 2* $1C c@ or loop ;

\ -----------------------------------------------------------------------------
\  Terminal IO
\ -----------------------------------------------------------------------------

: usb-connected? ( -- ? ) pause IFG2 c@ 16 and 0<> ; \ Are we configured already?

: usb-emit? ( -- ? ) pause IFG2 c@ 8 and 0<> ;
: usb-key?  ( -- ? ) pause IFG2 c@ 4 and 0<> ;
: usb-emit  ( c -- ) begin usb-emit? until UCB0TXBUF c! ;
: usb-key   ( -- c ) begin usb-key?  until UCB0RXBUF c@ ;

\ -----------------------------------------------------------------------------
\  Terminal redirection
\ -----------------------------------------------------------------------------

: serial-terminal ( -- )
  ['] serial-key?  hook-key?  !
  ['] serial-emit? hook-emit? !
  ['] serial-key   hook-key   !
  ['] serial-emit  hook-emit  !
;

: serial-hdmi-emit ( c -- ) dup hdmi-emit serial-emit ;

: serial-hdmi-terminal ( -- )
  ['] serial-key?      hook-key?  !
  ['] serial-emit?     hook-emit? !
  ['] serial-key       hook-key   !
  ['] serial-hdmi-emit hook-emit  !
;


: usb-terminal ( -- )
  ['] usb-key?  hook-key?  !
  ['] usb-emit? hook-emit? !
  ['] usb-key   hook-key   !
  ['] usb-emit  hook-emit  !
;

: usb-hdmi-emit ( c -- ) dup hdmi-emit usb-emit ;

: usb-hdmi-terminal ( -- )
  ['] usb-key?       hook-key?  !
  ['] usb-emit?      hook-emit? !
  ['] usb-key        hook-key   !
  ['] usb-hdmi-emit  hook-emit  !
;

\ -----------------------------------------------------------------------------
\  Terminal selection and prompt
\ -----------------------------------------------------------------------------

: +hdmi ( -- ) usb-connected? if usb-hdmi-terminal else serial-hdmi-terminal then ;
: -hdmi ( -- ) usb-connected? if      usb-terminal else      serial-terminal then ;

: prompt ( -- )
  begin
    highlight
    query
    normal
    interpret
    ."  ok." cr
  again
;

\ -----------------------------------------------------------------------------
\  Initialisation
\ -----------------------------------------------------------------------------

: Flamingo cr
  ."      _" cr
  ."     ^-)" cr
  ."      (.._          .._" cr
  ."       \`\\        (\`\\        (" cr
  ."        |>         ) |>        |)" cr
  ." ______/|________ (7 |` ______\|/_______a:f" cr
;

: welcome ( -- )
  ." Mecrisp by Matthias Koch"
  cr
  Flamingo
  cr
  ." Have a nice day !" cr
;

: init ( -- )
  page +hdmi welcome
  begin key? while key drop repeat \ Alle aufgelaufenen Zeichen verwerfen
  ['] prompt hook-quit ! quit
;

cornerstone eraseflash
reset
