home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / decom.seq < prev    next >
Text File  |  1991-04-10  |  11KB  |  313 lines
  1. \ DECOM.SEQ     The F-PC 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. ONLY FORTH ALSO DEFINITIONS HIDDEN ALSO
  17.  
  18. : +TAB          ( --- )
  19.                 8 LMARGIN +! ;
  20.  
  21. : -TAB          ( --- )
  22.                 LMARGIN @ 8 - 0MAX LMARGIN ! ;
  23.  
  24. : CRTAB         RMARGIN @ ?LINE ;
  25.  
  26. ONLY FORTH ALSO HIDDEN DEFINITIONS ALSO
  27.  
  28.  0 VALUE DECOMSEG
  29.  0 VALUE ?DEBUG
  30. 19 VALUE SPLIT-L#
  31.  
  32. : SRCEEOLCR    EEOL CRLF ;
  33.  
  34. : INIT-SPLIT    ( --- )         \ initialize the split line as 6 lines up
  35.                 DEFERS INITSTUFF
  36.                 ROWS DUP 4 / - =: SPLIT-L# ;
  37.  
  38. ' INIT-SPLIT IS INITSTUFF
  39.  
  40. headerless
  41.  
  42. : DECOMSEG@     ( N1 --- )
  43.                 DECOMSEG SWAP @L ;
  44.  
  45. : ASSOCIATIVE:
  46.    CONSTANT
  47.    DOES>         ( N -- INDEX )
  48.       DUP @ ( N PFA CNT )   -ROT DUP @ 0 ( CNT N PFA CNT 0 )
  49.       DO   2+   2DUP @ = ( CNT N PFA' BOOL )
  50.          IF 2DROP DROP   I 0 0   LEAVE   THEN
  51.             ( CLEAR STACK AND RETURN INDEX THAT MATCHED )
  52.       LOOP   2DROP   ;
  53.  
  54. : .WORD         ( IP -- IP' )
  55.                 DUP DECOMSEG@ >NAME YC@ 64 AND
  56.                 IF      DUP YC@ 31 AND 10 + ?LINE
  57.                         ." [COMPILE] "
  58.                 THEN    DUP DECOMSEG@ >NAME.ID   2+   ;
  59.  
  60. : (LIT+)        ( IP -- IP' )    6 ?LINE 4 + ;
  61.  
  62. : .LIT          ( IP -- IP' )    (LIT+) DUP 2- DECOMSEG@ . ;
  63.  
  64. : .[']          ( IP -- IP' )    CRTAB ." ['] " 2+ ;
  65.  
  66. : .IS           ( IP -- IP' )    ." IS " 2+ ;
  67.  
  68. : .IF           ( IP -- IP' )    CRTAB ." IF " (LIT+) TAB +TAB ;
  69.  
  70. : .ELSE         ( IP -- IP' )    -TAB CRTAB ." ELSE " (LIT+) TAB +TAB ;
  71.  
  72. : .CASE         ( IP -- IP' )    CRTAB ." CASE " 2+ TAB ;
  73.  
  74. : .OF           ( IP -- IP' )    CRTAB ." OF " (LIT+) TAB +TAB ;
  75.  
  76. : .ENDOF        ( IP -- IP' )    -TAB CRTAB ." ENDOF " (LIT+) TAB ;
  77.  
  78. : .ENDCASE      ( IP -- IP' )    CRTAB ." ENDCASE " 2+ TAB ;
  79.  
  80. : .DO           ( IP -- IP' )    CRTAB ." DO  " (LIT+) TAB +TAB ;
  81.  
  82. : .?DO          ( IP -- IP' )    CRTAB ." ?DO  " (LIT+) TAB +TAB ;
  83.  
  84. : .LOOP         ( IP -- IP' )    -TAB CRTAB ." LOOP " (LIT+) TAB ;
  85.  
  86. : .+LOOP        ( IP -- IP' )    -TAB CRTAB ." +LOOP " (LIT+) TAB ;
  87.  
  88. : .WHILE        ( IP -- IP' )    -TAB CRTAB ." WHILE " (LIT+) TAB +TAB ;
  89.  
  90. : .REPEAT       ( IP -- IP' )    -TAB CRTAB ." REPEAT " (LIT+) TAB ;
  91.  
  92. : .UNTIL        ( IP -- IP' )    -TAB CRTAB ." UNTIL " (LIT+) TAB ;
  93.  
  94. : .AGAIN        ( IP -- IP' )    -TAB CRTAB ." AGAIN " (LIT+) TAB ;
  95.  
  96. : .BEGIN        ( IP -- IP' )    CRTAB 2+ ." BEGIN " TAB +TAB ;
  97.  
  98. : .THEN         ( IP -- IP' )    -TAB CRTAB 2+ ." THEN " TAB ;
  99.  
  100. : .QUOTE        ( IP -- IP' )    .WORD   .WORD ;
  101.  
  102.                 \ Print the string at offset n1, and adjust n1 to the
  103.                 \ end of the string, while aligning it. Prepend a "
  104.                 \ space, and append a " space to the string
  105. : ."X$"         ( N1 --- N1+LEN )
  106.                 DUP '"' EMIT SPACE
  107.                 DECOMSEG SWAP 2DUP C@L 1+ >R ?CS: "BUF R@ CMOVEL
  108.                 R> DUP 1 AND + + "BUF COUNT TYPE '"' EMIT SPACE ;
  109.  
  110. : .STRING."     ( IP -- IP' )
  111.                 2+ DECOMSEG OVER C@L 5 + ?LINE
  112.                 '.' EMIT ."X$" ;
  113.  
  114. : .STRING"      ( IP -- IP' )
  115.                 2+ DUP 2+ SWAP DECOMSEG@ DUP C@ 4 + ?LINE
  116.                 '"' EMIT SPACE
  117.                 COUNT TYPE
  118.                 '"' EMIT SPACE ;
  119.  
  120. : .STRING""     ( IP -- IP' )
  121.                 2+ DECOMSEG OVER C@L 5 + ?LINE
  122.                 '"' EMIT ."X$" ;
  123.  
  124. : .ABORT"       ( IP -- IP' )
  125.                 2+ DUP DECOMSEG@ C@ 10 + ?LINE
  126.                 ." ABORT" ."X$" ;
  127.  
  128. : .(;CODE)    ( IP -- IP' )
  129.                 .WORD   DOES?
  130.                 IF  ." DOES> "
  131.                 ELSE  DROP FALSE  THEN  ;
  132.  
  133. : .UNNEST     ( IP -- IP' )
  134.                 ." ; "   DROP   0   ;
  135.  
  136. : .FINISH     ( IP -- IP' )
  137.                 .WORD   DROP   0   ;
  138.  
  139. 27 ASSOCIATIVE: EXECUTION-CLASS
  140.    (  0 ) '   (LIT)        ,         (  1 ) '   ?BRANCH      ,
  141.    (  2 ) '   BRANCH       ,         (  3 ) '   (LOOP)       ,
  142.    (  4 ) '   (+LOOP)      ,         (  5 ) '   (DO)         ,
  143.    (  6 ) '   COMPILE      ,         (  7 ) '   (.")         ,
  144.    (  8 ) '   (ABORT")     ,         (  9 ) '   (;CODE)      ,
  145.    ( 10 ) '   UNNEST       ,         ( 11 ) '   (")          ,
  146.    ( 12 ) '   (?DO)        ,         ( 13 ) '   (;USES)      ,
  147.    ( 14 ) '   ?UNTIL       ,         ( 15 ) '   ?WHILE       ,
  148.    ( 16 ) '   DOAGAIN      ,         ( 17 ) '   DOREPEAT     ,
  149.    ( 18 ) '   DOBEGIN      ,         ( 19 ) '   DOTHEN       ,
  150.    ( 20 ) '   (X")         ,         ( 21 ) '   <'>          ,
  151.    ( 22 ) '   (IS)         ,         ( 23 ) '   (OF)         ,
  152.    ( 24 ) '   DOENDOF      ,         ( 25 ) '   DOCASE       ,
  153.    ( 26 ) '   DOENDCASE    ,
  154.  
  155. : .EXECUTION-CLASS      ( N1 --- )
  156.                 0MAX 27 MIN EXEC:
  157.                 (  0 )     .LIT         (  1 )     .IF
  158.                 (  2 )     .ELSE        (  3 )     .LOOP
  159.                 (  4 )     .+LOOP       (  5 )     .DO
  160.                 (  6 )     .QUOTE       (  7 )     .STRING."
  161.                 (  8 )     .ABORT"      (  9 )     .(;CODE)
  162.                 ( 10 )     .UNNEST      ( 11 )     .STRING"
  163.                 ( 12 )     .?DO         ( 13 )     .FINISH
  164.                 ( 14 )     .UNTIL       ( 15 )     .WHILE
  165.                 ( 16 )     .AGAIN       ( 17 )     .REPEAT
  166.                 ( 18 )     .BEGIN       ( 19 )     .THEN
  167.                 ( 20 )     .STRING""    ( 21 )     .[']
  168.                 ( 22 )     .IS          ( 23 )     .OF
  169.                 ( 24 )     .ENDOF       ( 25 )     .CASE
  170.                 ( 26 )     .ENDCASE     ( 27 )     .WORD      ;
  171.  
  172. HEADERS         \ 05/28/90 21:18:53.22 TJZ
  173.  
  174. 0 VALUE PFALINE
  175. 0 VALUE DIDPFA
  176. 0 VALUE TOPCRS
  177. 0 VALUE DUMMYCRS
  178. 0 VALUE #EMPTY
  179.  
  180. HEADERLESS      \ 05/28/90 21:19:01.29 TJZ
  181.  
  182. : TOPCR         ( --- )
  183.                 DUMMYCRS
  184.         IF      DECR> DUMMYCRS
  185.                 OFF> #OUT
  186.         ELSE    #LINE @ SPLIT-L# 2- >=
  187.                 IF      SPLIT-L# 1- SAVE!> ROWS \ save ROWS and set to split
  188.                         0 2 AT                  \ move to third line
  189.                         -LINE                   \ scroll upper portion
  190.                         RESTORE> ROWS           \ restore ROWS
  191.                         0 SPLIT-L# 2- AT        \ move to split line
  192.                 ELSE    SRCEEOLCR
  193.                 THEN
  194.         THEN    INCR> TOPCRS ;
  195.  
  196. : .PFA          ( LIST_SEGMENT -- )
  197.                 >BODY   @ +XSEG =: DECOMSEG 0
  198.                 SAVESTATE
  199.                 8 LMARGIN !
  200.                 COLS 10 - RMARGIN !
  201.                 #LINE @ =: TOPCRS
  202.                 SAVE> CR
  203.                 ?DEBUG
  204.                 IF      ['] TOPCR IS CR
  205.                         #EMPTY =: DUMMYCRS
  206.                 THEN
  207.                 BEGIN   ?CR
  208.                         DUP PFASAV @ OVER = ?DEBUG AND
  209.                         IF      >ATTRIB4 ON> ?DEFATTRIB
  210.                                 TOPCRS =: PFALINE
  211.                                 ON> DIDPFA
  212.                         THEN
  213.                         DECOMSEG@ EXECUTION-CLASS .EXECUTION-CLASS >NORM
  214.                         OFF> ?DEFATTRIB
  215.                         DUP 0= KEY? OR
  216.                         ?DEBUG
  217.                         IF      #LINE @ SPLIT-L# 2- >=  \ hit bottom
  218.                                 IF      DIDPFA
  219.                                         IF      PFALINE SPLIT-L# 2- >=
  220.                                                 IF      PFALINE 10 -
  221.                                                         =: #EMPTY
  222.                                                 ELSE    TRUE OR
  223.                                                 THEN
  224.                                                 OFF> DIDPFA
  225.                                         THEN
  226.                                 THEN
  227.                         THEN
  228.                         PFALINE 12 < IF OFF> #EMPTY THEN
  229.                 UNTIL   DROP
  230.                 RESTORE> CR
  231.                 RESTORESTATE ;
  232.  
  233. : .IMMEDIATE   ( CFA -- )
  234.                 >NAME YC@ 64 AND
  235.                 IF      ." IMMEDIATE"   THEN   ;
  236.  
  237. : .CONSTANT     ( CFA -- )
  238.                 DUP >BODY ?   ." CONSTANT "   >NAME.ID   ;
  239.  
  240. : .VALUE        ( CFA -- )
  241.                 DUP >BODY ?   ." VALUE "      >NAME.ID   ;
  242.  
  243. : .VARIABLE     ( CFA -- )
  244.                 DUP C@ 232 =
  245.                 IF      DUP >BODY .   ." VARIABLE "   DUP >NAME.ID
  246.                         ." Value = " >BODY ?
  247.                 ELSE    >NAME.ID  THEN ;
  248.  
  249. : .:            ( CFA -- )
  250.                 ." : "  DUP >NAME .ID CR TAB .PFA   ;
  251.  
  252. : .DOES>        ( BODY -- )
  253.                 DUP>R BODY> @REL>ABS DUP R@ 2+ =  \ Self defining word
  254.                 IF      R@ @ >NAME .ID
  255.                 ELSE    DUP >.ID
  256.                 THEN    R>DROP ." DOES> " .PFA   ;
  257.  
  258. : .USER-VARIABLE   ( CFA -- )
  259.                 DUP >BODY ?   ." USER VARIABLE "   DUP >NAME.ID
  260.                 ." Value = "   >IS  ?   ;
  261.  
  262.  
  263. : .DEFER        ( CFA -- )
  264.                 ." DEFERRED " DUP >NAME.ID   ." IS "  >IS @ (SEE)  ;
  265.  
  266. : .USER-DEFER   ( cfa -- )
  267.    ." USER DEFERRED "   DUP >NAME.ID  ." IS "  >IS @ (SEE)  ;
  268.  
  269. : .OTHER   ( CFA -- )
  270.         DUP     >NAME.ID
  271.         DUP C@  232 <>                  \ cfa doesn't contain a call for code
  272.         IF      DROP    ." is Code, load DISASSEM to see it."
  273.                                         EXIT
  274.         THEN
  275.         DUP DOES?                       \ Is this a DOES> word?
  276.         IF      .DOES>  DROP            EXIT
  277.         THEN    2DROP   ." is Unknown"   ;
  278.  
  279. headers
  280.  
  281. 7 CONSTANT MAX-CLASSES
  282.  
  283. MAX-CLASSES ASSOCIATIVE: DEFINITION-CLASS
  284.    ( 0 )   '      QUIT @REL>ABS ,   ( 1 )   '  #VOCS @REL>ABS ,
  285.    ( 2 )   '     STATE @REL>ABS ,   ( 3 )   '   BASE @REL>ABS ,
  286.    ( 4 )   '        CR @REL>ABS ,   ( 5 )   '   EMIT @REL>ABS ,
  287.    ( 6 )   '  DECOMSEG @REL>ABS ,
  288.  
  289. : .DEFINITION-CLASS     ( N1 --- )
  290.                 0MAX MAX-CLASSES MIN EXEC:
  291.                 ( 0 )     .:            ( 1 )     .CONSTANT
  292.                 ( 2 )     .VARIABLE     ( 3 )     .USER-VARIABLE
  293.                 ( 4 )     .DEFER        ( 5 )     .USER-DEFER
  294.                 ( 6 )     .VALUE        ( 7 )     .OTHER      ;
  295.  
  296. : ((SEE))       ( Cfa -- )
  297.                 SAVE> ATTRIB
  298.                 CR   DUP DUP @REL>ABS
  299.                 DEFINITION-CLASS
  300.                 .DEFINITION-CLASS
  301.                 .IMMEDIATE
  302.                 RESTORE> ATTRIB ;
  303.  
  304. ' ((SEE)) IS (SEE)
  305.  
  306. FORTH DEFINITIONS
  307.  
  308. : SEE           ( | name -- )
  309.                 '   (SEE) ;
  310.  
  311. behead
  312.  
  313.