
compiletoflash

: 0-foldable $40 setflags immediate ;
: 1-foldable $41 setflags immediate ;
: 2-foldable $42 setflags immediate ;
: 3-foldable $43 setflags immediate ;

: ( [char] ) parse drop immediate 0-foldable ;  (  Forth-Style-Comment )
: { [char] } parse drop immediate 0-foldable ;  { Pascal-Style-Comment }
: \        0 parse drop immediate 0-foldable ;  \ Comment till end of line

32 constant bl
: cr    10 emit ;
: space bl emit ;
: spaces 0 ?do space loop ;

\ Just in case if you don't have it already in your flash...


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


\ Magic numbers inside:
\    Memory locations: $208 Variable for Link to latest definition
\                      $2500 Start of Flash-Dictionary
\                      ['] ?key 8 -   Address of first dictionary header in core
\                      ['] ." $1E +   Address of ." runtime
\                      ['] s" $06 +   Address of s" runtime
\    True magic:       $12B0 call opcode
\                      $4130 ret opcode

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

  \ Catch dictionary entry point
  here $2500 u>= if ['] ?key 8 - else $208 @ then

  begin        ( name-field-address R: wanted-code-address )
    1+         \ Skip Flags
    dup        ( name-field-address name-field-address )
    skipstring \ Skip string that contains name
               ( name-field-address link-field-address )

    dup 2+ r@ = if swap ."   --> " type else swap drop then

    @ dup $FFFF = \ Check if link points to another definition or into free space.
  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 type 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 ?
    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
;

: see \ Takes name of definition and shows its contents from beginning to first ret
  base @ hex cr

  ' disasm-$ !

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

  base !
;
