home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / see < prev    next >
Text File  |  1996-02-18  |  9KB  |  248 lines
  1. \ $Id: see.f 1.1 1994/04/01 07:53:29 andrew Exp $
  2.  
  3. cr .( Loading the Decompiler...)
  4.  
  5. ( Decompiler from F83 )
  6.  
  7. (( A Forth decompiler is a utility program that translates
  8.   executable forth code back into source code.  Normally this is
  9.   impossible, since traditional compilers produce more object
  10.   code than source, but in Forth it is quite easy.  The decompiler
  11.   is almost one to one, failing only to correctly decompile the
  12.   various Forth control stuctures and special compiling words.
  13.   It was written with modifiability in mind, so if you add your
  14.   own special compiling words, it will be easy to change the
  15.   decompiler to include them.  This code is highly implementation
  16.   dependant, and will NOT work on other Forth system.  To invoke
  17.   the decompiler, use the word SEE <name> where <name> is the
  18.   name of a Forth word. ))
  19.  
  20.  
  21. only forth also definitions decimal
  22.  
  23. new-chain .execution-class-chain
  24. new-chain .other-class-chain
  25.  
  26. 0 value &flit
  27. 2 value cells/float
  28.  
  29. : dummy.float   ( a1 -- a2 )
  30.                 ." ???" cells/float cells+ ;
  31.  
  32. defer .float    ' dummy.float is .float
  33.  
  34. vocabulary hidden
  35.  
  36. DEFER (SEE)  ( cfa -- )
  37.  
  38. HIDDEN DEFINITIONS
  39.  
  40. : .WORD         ( IP -- IP' )
  41.                 DUP @ DUP 32768 HERE within
  42.         IF      DUP >R call@
  43.                 CASE   DOVALUE   OF R@                         .NAME   ENDOF
  44.                        DOVALUE!  OF R@ ." TO "       2 CELLS - .NAME   ENDOF
  45.                        DOVALUE+! OF R@ ." +TO "      3 CELLS - .NAME   ENDOF
  46.                       DO2VALUE!  OF R@ ." 2TO "      2 CELLS - .NAME   ENDOF
  47.                       DO2VALUE+! OF R@ ." 2+TO "     3 CELLS - .NAME   ENDOF
  48.                        DOLOCAL   OF R@                         .NAME   ENDOF
  49.                        DOLOCAL!  OF R@ ." TO "       2 CELLS - .NAME   ENDOF
  50.                        DOLOCAL+! OF R@ ." +TO "      3 CELLS - .NAME   ENDOF
  51.                        (IV@)     OF R@ ." I:"                  .NAME   ENDOF
  52.                        (IV!)     OF R@ ." TO-I: "    2 CELLS - .NAME   ENDOF
  53.                        (IV+!)    OF R@ ." +TO-I: "   3 CELLS - .NAME   ENDOF
  54.                        (IV[]@)   OF R@ ." I[]:"                .NAME   ENDOF
  55.                        (IV[]!)   OF R@ ." TO-I[]: "  2 CELLS - .NAME   ENDOF
  56.                        (IV[]+!)  OF R@ ." +TO-I[]: " 3 CELLS - .NAME   ENDOF
  57. \+ .M0NAME             M0CFA     OF R@ ." M0:"               .M0NAME   ENDOF
  58. \+ .M1NAME             M1CFA     OF R@ ." M1:"               .M1NAME   ENDOF
  59.                        DOOBJ     OF R@ ." O:"                  .NAME   ENDOF
  60.                                     R@                         .NAME
  61.                 ENDCASE R> DROP
  62.         ELSE    1 h.r ." h "
  63.         THEN    CELL+ ;
  64.  
  65. \ : .LIT          ( ip -- ip' )
  66. \                 ." lit " .word ;
  67.  
  68. : .BRANCH       ( IP -- IP' )
  69.                 .WORD  DUP @ CELL /  dup 0> if ." +" then h.  CELL+   ;
  70.  
  71. : .STRING       ( IP -- IP' )
  72.                 34 emit space
  73.                 CELL+
  74.                 dup c@ ?line
  75.                 COUNT 2DUP TYPE  34 emit space + 1+ aligned ;
  76.  
  77. \ : .call ( ip -- ip' )
  78. \         .word .word ;
  79.  
  80. : .locals       ( IP -- IP' )
  81.                 ." INIT-LOCALS "
  82.                 cols ?line ." LOCALS|"
  83.                 DUP 1+ c@ dup 0
  84.                 ?do     ."  L" i 2 pick c@ + 1 .r
  85.                 loop    drop
  86.                 dup c@ ?dup
  87.                 if      ."  \"
  88.                         dup 0
  89.                         ?do     ."  L" i 1 .r
  90.                         loop    drop
  91.                 then    ."  | " cols ?line
  92.                 CELL+ ;
  93.  
  94. \ Decompile each type of word                         28Feb84map
  95.  
  96. : does?  ( ip -- ip+ flag )
  97.         dup 8 +  swap call@ dodoes = ;
  98.  
  99. : .(;CODE)    ( IP -- IP' )
  100.    CELL+  DOES? IF  ." DOES> "  ELSE  ." ;CODE "  DROP FALSE  THEN  ;
  101.  
  102. : .execution-class  ( ip cfa -- ip' )
  103.     case
  104.         ['] lit         of cell+ ." lit "   .word                 endof
  105.             &flit       of cell+ ." flit "  .float                endof
  106.         ['] (is)        of cell+ ." (is) "  .word                 endof
  107.         ['] (.")        of ." ."        .string                   endof
  108.         ['] (S")        of ." S"        .string                   endof
  109.         ['] (Z")        of ." Z"        .string                   endof
  110.         ['] (C")        of ." C"        .string                   endof
  111.         ['] (abort")    of ." ABORT"    .string                   endof
  112.         ['] ?branch     of      cr ." IF  " +tab      cell+ cell+ endof
  113.         ['] branch      of -tab cr ." ELSE " +tab     cell+ cell+ endof
  114.         ['] (do)        of      cr ." DO  " +tab      cell+ cell+ endof
  115.         ['] (?do)       of      cr ." ?DO " +tab      cell+ cell+ endof
  116.         ['] (loop)      of -tab cr ." LOOP "          cell+ cell+ endof
  117.         ['] (+loop)     of -tab cr ." +LOOP "         cell+ cell+ endof
  118.         ['] _case       of      cr ." CASE    " +tab  cell+       endof
  119.         ['] _of         of      cr ." OF      " +tab  cell+ cell+ endof
  120.         ['] _endof      of     tab ." ENDOF   " -tab  cr
  121.                                                       cell+ cell+ endof
  122.         ['] _endcase    of -tab cr ." ENDCASE "       cell+       endof
  123.         ['] _then       of -tab cr ." THEN "          cell+       endof
  124.         ['] _begin      of      cr ." BEGIN " +tab    cell+       endof
  125.         ['] _while      of -tab cr ." WHILE " +tab    cell+ cell+ endof
  126.         ['] _until      of -tab cr ." UNTIL  "        cell+ cell+ endof
  127.         ['] _repeat     of -tab cr ." REPEAT "        cell+ cell+ endof
  128.         ['] _again      of -tab cr ." AGAIN  "        cell+ cell+ endof
  129.         ['] _localalloc of ." LOCALALLOC: " cell+ dup @
  130.                                           2 cells- .name cr cell+ endof
  131.         ['] compile     of .word .word                            endof
  132.         ['] unnest      of ." ; "  drop  0                        endof
  133.         ['] unnestm     of ." ;M " drop  0                        endof
  134.         ['] unnestp     of ." ;P " drop  0                        endof
  135.         ['] (;code)     of -tab cr .(;CODE) tab +tab              endof
  136.         ['] create      of cr .word tab +tab                      endof
  137.         ['] init-locals of cell+ .locals                          endof
  138.                            false .execution-class-chain do-chain 0=
  139.                            if    swap .word swap
  140.                            then
  141.     endcase     ;
  142.  
  143.  
  144. \ Decompile a : definition                            15Mar83map
  145.  
  146. : .PFA          ( CFA -- ) 
  147.                 tabing-on
  148.                 0TAB +TAB tab
  149.                 BEGIN   2 ?line  DUP @ .EXECUTION-CLASS
  150.                         tabing-off
  151.                         start/stop
  152.                         tabing-on
  153.                         DUP 0=
  154.                 UNTIL   DROP
  155.                 tabing-off ;
  156.  
  157. : .IMMEDIATE   ( CFA -- )
  158.    >NAME C@ 128 AND IF   ." IMMEDIATE "   THEN   ;
  159.  
  160.  
  161. \ Display category of word                            24APR84HHL
  162.  
  163. : .CONSTANT     ( CFA -- )
  164.                 DUP >BODY ?   ." CONSTANT "   .NAME   ;
  165.  
  166. : .VARIABLE     ( CFA -- )
  167.                 DUP >BODY .   ." VARIABLE "   DUP .NAME
  168.                 ." Value = " >BODY ?   ;
  169.  
  170. : .VALUE        ( CFA -- )
  171.                 DUP cell+ ?  ." VALUE "   .NAME  ;
  172.  
  173. : .CLASS        ( CFA -- )
  174.                 ." :CLASS "  .NAME  ;
  175.  
  176. : .VOCABULARY   ( CFA -- )
  177.                 ." VOCABULARY "  .NAME  ;
  178.  
  179. : .:            ( CFA -- )
  180.                 ." : "  DUP .NAME 2 SPACES  >BODY .PFA   ;
  181.  
  182. : .DOES>        ( PFA -- )
  183.                 ." DOES> "  .PFA   ;
  184.  
  185.  
  186. \ Display category of word                            24APR84HHL
  187. : .DEFER   ( CFA -- )
  188.            ." DEFER " DUP .NAME   ." IS "  >BODY @ (SEE)  ;
  189.  
  190. DEFER DISCODE   ' DROP IS DISCODE
  191.  
  192. \               ' DROP IS-DEFAULT DISCODE
  193.  
  194. : .CODE    ( CFA -- )
  195.            ." IS CODE " cr DISCODE ;
  196.  
  197. : .;CODE   ( CFA -- )
  198.            ." IS ;CODE " call@ DISCODE ;
  199.  
  200. : .SYNONYM ( CFA -- )
  201.            ." SYNONYM " DUP .NAME ." IS " >BODY CELL+ @ (SEE) ;
  202.  
  203. : .OTHER        ( CFA -- )
  204.                 DUP .NAME
  205.                 .other-class-chain do-chain ?dup
  206.                 if      DUP c@ 0xeb  =
  207.                         IF dup call@ DOES?
  208.                           IF   .DOES>   DROP   EXIT
  209.                           ELSE .;CODE          EXIT     THEN
  210.                         THEN
  211.                         .CODE
  212.                 then    ;
  213.  
  214.  
  215. synonym a_synonym noop
  216. 0 value a_value
  217.  
  218. \ Classify a word based on its CFA                    09SEP83HHL
  219.  
  220. : .definition-class  ( cfa cfa -- )
  221.     call@ case
  222.         ['] quit call@       of .:          endof
  223.         ['] TRUE call@       of .constant   endof
  224.         ['] last call@       of .variable   endof
  225.         ['] (see) @          of .defer      endof
  226.         ['] a_value call@    of .value      endof
  227.         ['] a_synonym call@  of .synonym    endof
  228.             doClass          of .class      endof
  229.             do|Class         of .class      endof
  230.         ['] forth call@      of .vocabulary endof
  231. \            doColP         of .:P         endof
  232.         swap .other
  233.     endcase ;
  234.  
  235.  
  236. \ Top level of the Decompiler SEE                     29Sep83map
  237.  
  238. : ((SEE))       ( Cfa -- )
  239.                 CR DUP DUP .DEFINITION-CLASS  .IMMEDIATE   ;
  240.  
  241. ' ((SEE)) IS (SEE)
  242.  
  243. FORTH DEFINITIONS
  244.  
  245. : SEE   ( -- )
  246.    '   (SEE)    ;
  247.  
  248.