home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / DECOM.SEQ < prev    next >
Encoding:
Text File  |  1988-01-04  |  8.4 KB  |  246 lines
  1. \ DECOM.SEQ     The F83 decompiler         Enhancements by Tom Zimmer
  2.  
  3. \    A Forth decompiler is a utility program that translates
  4. \ executable forth code back into source code.  Normally this is
  5. \ impossible, since traditional compilers produce more object
  6. \ code than source, but in Forth it is quite easy.  The decompiler
  7. \ is almost one to one, failing only to correctly decompile the
  8. \ various Forth control stuctures and special compiling words.
  9. \ It was written with modifiability in mind, so if you add your
  10. \ own special compiling words, it will be easy to change the
  11. \ decompiler to include them.  This code is highly implementation
  12. \ dependant, and will NOT work on other Forth system.  To invoke
  13. \ the decompiler, use the word SEE <name> where <name> is the
  14. \ name of a Forth word.
  15.  
  16. : +TAB          ( --- )
  17.                 8 LMARGIN +! ;
  18.  
  19. : -TAB          ( --- )
  20.                 LMARGIN @ 8 - 0 MAX LMARGIN ! ;
  21.  
  22. : CRTAB         RMARGIN @ ?LINE ;
  23.  
  24. HIDDEN DEFINITIONS
  25.  
  26. : ASSOCIATIVE:
  27.    CONSTANT
  28.    DOES>         ( N -- INDEX )
  29.       DUP @ ( N PFA CNT )   -ROT DUP @ 0 ( CNT N PFA CNT 0 )
  30.       DO   2+   2DUP @ = ( CNT N PFA' BOOL )
  31.          IF 2DROP DROP   I 0 0   LEAVE   THEN
  32.             ( CLEAR STACK AND RETURN INDEX THAT MATCHED )
  33.       LOOP   2DROP   ;
  34.  
  35. : .WORD         ( IP -- IP' )
  36.                 DUP X@ >NAME YC@ 64 AND
  37.                 IF      DUP YC@ 31 AND 10 + ?LINE
  38.                         ." [COMPILE] "
  39.                 THEN    DUP X@ >NAME.ID   2+   ;
  40.  
  41. : .LIT          ( IP -- IP' )
  42.                 6 ?LINE
  43.                 2+ DUP X@ . 2+ ;
  44.  
  45. : .IF           ( IP -- IP' )
  46.                 CRTAB 4 + ." IF " TAB +TAB ;
  47.  
  48. : .ELSE         ( IP -- IP' )
  49.                 -TAB CRTAB 4 + ." ELSE " TAB +TAB ;
  50.  
  51. : .DO           ( IP -- IP' )
  52.                 CRTAB 4 + ." DO " TAB +TAB ;
  53.  
  54. : .?DO          ( IP -- IP' )
  55.                 CRTAB 4 + ." ?DO  " TAB +TAB ;
  56.  
  57. : .LOOP         ( IP -- IP' )
  58.                 -TAB CRTAB 4 + ." LOOP " TAB ;
  59.  
  60. : .+LOOP        ( IP -- IP' )
  61.                 -TAB CRTAB 4 + ." +LOOP " TAB ;
  62.  
  63. : .WHILE        ( IP -- IP' )
  64.                 -TAB CRTAB 4 + ." WHILE " TAB +TAB ;
  65.  
  66. : .REPEAT       ( IP -- IP' )
  67.                 -TAB CRTAB 4 + ." REPEAT " TAB ;
  68.  
  69. : .UNTIL        ( IP -- IP' )
  70.                 -TAB CRTAB 4 + ." UNTIL " TAB ;
  71.  
  72. : .AGAIN        ( IP -- IP' )
  73.                 -TAB CRTAB 4 + ." AGAIN " TAB ;
  74.  
  75. : .BEGIN        ( IP -- IP' )
  76.                 CRTAB 2+ ." BEGIN " TAB +TAB ;
  77.  
  78. : .THEN         ( IP -- IP' )
  79.                 -TAB CRTAB 2+ ." THEN " TAB ;
  80.  
  81. : .QUOTE        ( IP -- IP' )
  82.                 .WORD   .WORD ;
  83.  
  84. : .STRING."     ( IP -- IP' )
  85.                 2+ DUP X@ C@ 5 + ?LINE
  86.                 ASCII . EMIT ASCII " EMIT SPACE
  87.                 DUP 2+ SWAP X@ COUNT TYPE ASCII " EMIT SPACE ;
  88.  
  89. : .STRING"      ( IP -- IP' )
  90.                 2+ DUP X@ C@ 4 + ?LINE
  91.                 ASCII " EMIT SPACE
  92.                 DUP 2+ SWAP X@ COUNT TYPE ASCII " EMIT SPACE ;
  93.  
  94. : .ABORT"       ( IP -- IP' )
  95.                 2+ DUP X@ C@ 10 + ?LINE
  96.                 ." ABORT" ASCII " EMIT SPACE
  97.                 DUP 2+ SWAP X@ COUNT TYPE ASCII " EMIT SPACE ;
  98.  
  99. : .(;CODE)    ( IP -- IP' )
  100.                 .WORD   DOES?
  101.                 IF  ." DOES> "
  102.                 ELSE  DROP FALSE  THEN  ;
  103.  
  104. : .UNNEST     ( IP -- IP' )
  105.                 ." ; "   DROP   0   ;
  106.  
  107. : .FINISH     ( IP -- IP' )
  108.                 .WORD   DROP   0   ;
  109.  
  110. 20 ASSOCIATIVE: EXECUTION-CLASS
  111.    (  0 ) '   (LIT)        ,         (  1 ) '   ?BRANCH      ,
  112.    (  2 ) '   BRANCH       ,         (  3 ) '   (LOOP)       ,
  113.    (  4 ) '   (+LOOP)      ,         (  5 ) '   (DO)         ,
  114.    (  6 ) '   COMPILE      ,         (  7 ) '   (.")         ,
  115.    (  8 ) '   (ABORT")     ,         (  9 ) '   (;CODE)      ,
  116.    ( 10 ) '   UNNEST       ,         ( 11 ) '   (")          ,
  117.    ( 12 ) '   (?DO)        ,         ( 13 ) '   (;USES)      ,
  118.    ( 14 ) '   ?UNTIL       ,         ( 15 ) '   ?WHILE       ,
  119.    ( 16 ) '   DOAGAIN      ,         ( 17 ) '   DOREPEAT     ,
  120.    ( 18 ) '   DOBEGIN      ,         ( 19 ) '   DOTHEN       ,
  121.  
  122.  
  123. : .EXECUTION-CLASS      ( N1 --- )
  124.                 0 MAX 20 MIN EXEC:
  125.                 (  0 )     .LIT         (  1 )     .IF
  126.                 (  2 )     .ELSE        (  3 )     .LOOP
  127.                 (  4 )     .+LOOP       (  5 )     .DO
  128.                 (  6 )     .QUOTE       (  7 )     .STRING."
  129.                 (  8 )     .ABORT"      (  9 )     .(;CODE)
  130.                 ( 10 )     .UNNEST      ( 11 )     .STRING"
  131.                 ( 12 )     .?DO         ( 13 )     .FINISH
  132.                 ( 14 )     .UNTIL       ( 15 )     .WHILE
  133.                 ( 16 )     .AGAIN       ( 17 )     .REPEAT
  134.                 ( 18 )     .BEGIN       ( 19 )     .THEN
  135.                 ( 20 )     .WORD      ;
  136.  
  137. : .PFA          ( CFA -- )
  138.                 >BODY   @
  139.                 SAVESTATE
  140.                 8 LMARGIN !
  141.                 70 RMARGIN !
  142.                 BEGIN
  143.                         ?CR   DUP PFASAV @ OVER =
  144.                         IF      >ATTRIB4
  145.                         THEN    X@ EXECUTION-CLASS .EXECUTION-CLASS
  146.                         >NORM
  147.                         DUP 0= KEY? OR
  148.                 UNTIL   DROP RESTORESTATE ;
  149.  
  150. : .IMMEDIATE   ( CFA -- )
  151.                 >NAME YC@ 64 AND
  152.                 IF      ." IMMEDIATE"   THEN   ;
  153.  
  154. : .CONSTANT     ( CFA -- )
  155.                 DUP >BODY ?   ." CONSTANT "   >NAME.ID   ;
  156.  
  157. : .VARIABLE     ( CFA -- )
  158.                 DUP C@ 232 =
  159.                 IF      DUP >BODY .   ." VARIABLE "   DUP >NAME.ID
  160.                         ." Value = " >BODY ?
  161.                 ELSE    >NAME.ID  THEN ;
  162.  
  163. : .:            ( CFA -- )
  164.                 ." : "  DUP >NAME .ID CR TAB .PFA   ;
  165.  
  166. : .DOES>        ( CFA -- )
  167.                 BODY> @REL>ABS DUP >.ID ." DOES> " .PFA   ;
  168.  
  169. : .USER-VARIABLE   ( CFA -- )
  170.                 DUP >BODY ?   ." USER VARIABLE "   DUP >NAME.ID
  171.                 ." Value = "   >IS  ?   ;
  172.  
  173.  
  174. : .DEFER        ( CFA -- )
  175.                 ." DEFERRED " DUP >NAME.ID   ." IS "  >IS @ (SEE)  ;
  176.  
  177. : .USER-DEFER   ( cfa -- )
  178.    ." USER DEFERRED "   DUP >NAME.ID  ." IS "  >IS @ (SEE)  ;
  179.  
  180. : .OTHER   ( CFA -- )
  181.         DUP     >NAME.ID
  182.         DUP C@  232 <>                  \ cfa doesn't contain a call for code
  183.         IF      DROP    ." is Code"     EXIT
  184.         THEN
  185.         DUP DOES?                       \ Is this a DOES> word?
  186.         IF      .DOES>  DROP            EXIT
  187.         THEN    2DROP   ." is Unknown"   ;
  188.  
  189. 6 ASSOCIATIVE: DEFINITION-CLASS
  190.    ( 0 )   '      QUIT @REL>ABS ,   ( 1 )   '         0 @REL>ABS ,
  191.    ( 2 )   '     STATE @REL>ABS ,   ( 3 )   '      BASE @REL>ABS ,
  192.    ( 4 )   '        CR @REL>ABS ,   ( 5 )   '      EMIT @REL>ABS ,
  193.  
  194. : .DEFINITION-CLASS     ( N1 --- )
  195.                 0 MAX 6 MIN EXEC:
  196.                 ( 0 )     .:            ( 1 )     .CONSTANT
  197.                 ( 2 )     .VARIABLE     ( 3 )     .USER-VARIABLE
  198.                 ( 4 )     .DEFER        ( 5 )     .USER-DEFER
  199.                 ( 6 )     .OTHER      ;
  200.  
  201. : ((SEE))       ( Cfa -- )
  202.                 CR   DUP DUP @REL>ABS
  203.                 DEFINITION-CLASS .DEFINITION-CLASS
  204.                 .IMMEDIATE ;   ' ((SEE)) IS (SEE)
  205.  
  206. FORTH DEFINITIONS
  207.  
  208. : SEE           ( | name -- )
  209.                 '   (SEE) ;
  210.  
  211. VARIABLE CFASAV   CFASAV ON
  212.  
  213. DEFER SRCSPACES ' SPACES IS SRCSPACES
  214.  
  215. : SRCEEOLCR    77 #OUT @ - SRCSPACES CRLF ;
  216.  
  217. : SHOWSRC       ( --- ) \ Show the source for the current debugging word.
  218.                 #out @ #line @ >r >r
  219.                 0 0 AT DEFCFA @ CFASAV @ <>
  220.                 IF      18 0
  221.                         DO      0 I AT 80 SRCSPACES
  222.                         LOOP    DEFCFA @ CFASAV !
  223.                 THEN    0 1 AT
  224.                 ['] SRCEEOLCR IS CR
  225.                 defcfa  @ (SEE)
  226.                 ['] CRLF IS CR
  227.                 0 17 AT 78 SRCSPACES
  228.                 0 18 AT >ATTRIB4
  229.                 ."   C-continuous, F-forth, N-nest, Q-quit, Z-zip, X-source-off"
  230.                 77 #OUT @ - SRCSPACES >NORM
  231.                 r> r> at ;
  232.  
  233. : SRCCR         ( --- ) \ Source CR for the debugger, subscreen scroll.
  234.                 0 19 AT -LINE 0 24 AT ;
  235.  
  236.  
  237. : SRCON         ( --- ) \ Enable source printing durring debugging.
  238.                 ['] showsrc is .defsrc
  239.                 ['] SRCCR   IS CCR ;     srcon
  240.  
  241. : SRCOFF        ( --- ) \ disable source printing durring debugging.
  242.                 ['] noop    is .defsrc
  243.                 ['] CRLF    IS CCR ;
  244.  
  245.  
  246.