Artifact 41fa181b05b80cf0bebde171390a2e251cca2b65

File autopsy.rx part of check-in [b96e9278eb] - autopsy: fix vertical decompilation, explore modes by crc on 2011-04-06 11:50:01. [annotate]

( Autopsy ------------------------------------------------------------------- )
( Copyright [c] 2010 - 2011, Charles Childers                                 )
( Copyright [c] 2011, Marc Simpson                                            )
( License: ISC                                                                )
( --------------------------------------------------------------------------- )
needs dissect'

chain: autopsy'
  : decompile  ( a-a )  [ ^dissect'decompile ] sip "%d %s\n" puts ;

( --[ Box Drawing Code ]----------------------------------------------------- )

( --[ Box geometry ]------------------------------------------ )
16 variable: boxWidth
 4 variable: boxMargin
 4 variable: box/line

{{
  ( --[ Core ]------------------------------------------------ )

  : putcs    ( cn-  )   [ dup putc ] times drop ;

  : padCount  ( n-n )   @boxWidth @boxMargin - swap - ;
  : .pad      ( n-n )   padCount 32 swap putcs ;
  : .pads     ( $-  )   withLength swap puts .pad ;
  : .number   ( n-  )   toString .pads ;

  : .boxedn   ( n-  )   '| putc space .number space '| putc ;
  : .empty    (  -  )   '| putc -2 .pad '| putc ;

  : xt->name  ( $-$ )   toNumber xt->d dup [ d->name ] [ drop "" ] if ;

  variable escCell
  : lookup    ( a-$ )
    @escCell
    [ toString escCell off ]
    [ ^dissect'lookupOpcode [ [ escCell on ] ifTrue ] [ drop xt->name ] if ] if ;
  : .lookup   ( a-  ) '| putc space lookup .pads space '| putc ;

  : .fill     ( c-  ) @boxWidth @boxMargin 2 - - putcs ;
  : .edge     (  -  ) '+ putc '- .fill '+ putc ;
  : .rule     (  -  ) '| putc '- .fill '| putc ;

  ( --[ Diagram for N contiguous cells ]---------------------- )

  6 constant boxRows                 create boxtbl boxRows allot

  boxtbl variable: currentRow
  : boxRow, @currentRow ! currentRow ++ ;

  [ ( a- ) .edge drop   ; ] boxRow,
  [ ( a- ) .boxedn      ; ] boxRow,
  [ ( a- ) .rule drop   ; ] boxRow,
  [ ( a- ) @ .boxedn    ; ] boxRow,
  [ ( a- ) @ .lookup    ; ] boxRow,
  [ ( a- ) .edge drop   ; ] boxRow,

  : (.row)  ( aqn-aqn )
    repeat dup 0 = if;
    [ over 1+ [ tuck do ] dip swap ] dip 1- again ;

  : .row    ( aqn-    ) cr (.row) 2drop drop ;

  : (.cells) ( an- )
    0 repeat dup boxRows = if; dup 1+
    [ ( ann ) boxtbl + @ ( anq ) [ 2over ] dip swap .row ( an ) ] dip again ;

  ( --[ Utility words for finding the RET opcode ]------------ )

  : findRet ( a-na )  1 swap repeat dup ^dissect'endOfWord? if; &1+ bi@ again ;
---reveal---

  : .cells ( an- )
    dup @box/line >
    [ @box/line - [ @box/line (.cells) drop + ] dip .cells ]
    [ (.cells) 2drop drop ] if ;

  : .cell   ( a- )  1 .cells ;
  : .thread ( a- )  dup findRet drop .cells ;
}}

( --[ "see" and "explore" ]-------------------------------------------------- )
variable vertical
{{
  : help  ( - )
    clear
    "Autposy is a tool for exploring images interactively.\n\n" puts
    "+---+----------------------------------+\n" puts
    "| i | Backtrack display by one address |\n" puts
    "+---+----------------------------------+\n" puts
    "| j | Backtrack display by one screen  |\n" puts
    "+---+----------------------------------+\n" puts
    "| k | Advance display by one address   |\n" puts
    "+---+----------------------------------+\n" puts
    "| l | Advance display by one screen    |\n" puts
    "+---+----------------------------------+\n" puts
    "| z | Quit Autospy                     |\n" puts
    "+---+----------------------------------+\n" puts
    "| ? | Display this help screen         |\n" puts
    "+---+----------------------------------+\n" puts
    "| 1 | Jump to address                  |\n" puts
    "+---+----------------------------------+\n" puts
    "\nPress any key to return to autospy.\n"    puts
    getc drop ;

  2 elements x more?

  : goToAddress ( "- )
    clear "Address to jump to: " puts getToken toNumber !x ;
  : rows @ch 2 - ;
  : cols @cw 1 - ;
  : handle
    cols [ '- putc ] times cr
    getc
      [ 'i = ] [ drop x --        ] when
      [ 'k = ] [ drop x ++        ] when
      [ 'j = ] [ drop rows -x     ] when
      [ 'l = ] [ drop rows +x     ] when
      [ '? = ] [ drop help        ] when
      [ '1 = ] [ drop goToAddress ] when
      [ 'z = ] [ drop more? off   ] when
    drop ;
  : browse     (  - )
    [ clear @x rows &decompile times drop handle @more? ] while ;
  : getAddress ( "- )
    getToken dup find [ nip @d->xt ] [ drop toNumber ] if ;
---reveal---
  : :see    ( a- )
    cr @vertical
    [ [ decompile dup 1- ^dissect'endOfWord? not ] while drop ] &.thread if ;
  : see     ( "- ) getAddress :see ;
  : explore ( "- ) getAddress !x more? on browse ;
}}
;chain

global with autopsy'