home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / DECOM.SEQ < prev    next >
Encoding:
Text File  |  1989-09-26  |  12.0 KB  |  345 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. 0 VALUE PFALINE
  173. 0 VALUE DIDPFA
  174. 0 VALUE TOPCRS
  175. 0 VALUE DUMMYCRS
  176. 0 VALUE #EMPTY
  177.  
  178. : TOPCR         ( --- )
  179.                 DUMMYCRS
  180.         IF      DECR> DUMMYCRS
  181.                 OFF> #OUT
  182.         ELSE    #LINE @ SPLIT-L# 2- >=
  183.                 IF      SPLIT-L# 1- SAVE!> ROWS \ save ROWS and set to split
  184.                         0 2 AT                  \ move to third line
  185.                         -LINE                   \ scroll upper portion
  186.                         RESTORE> ROWS           \ restore ROWS
  187.                         0 SPLIT-L# 2- AT        \ move to split line
  188.                 ELSE    SRCEEOLCR
  189.                 THEN
  190.         THEN    INCR> TOPCRS ;
  191.  
  192. : .PFA          ( LIST_SEGMENT -- )
  193.                 >BODY   @ +XSEG =: DECOMSEG 0
  194.                 SAVESTATE
  195.                 8 LMARGIN !
  196.                 COLS 10 - RMARGIN !
  197.                 #LINE @ =: TOPCRS
  198.                 SAVE> CR
  199.                 ?DEBUG
  200.                 IF      ['] TOPCR IS CR
  201.                         #EMPTY =: DUMMYCRS
  202.                 THEN
  203.                 BEGIN   ?CR
  204.                         DUP PFASAV @ OVER = ?DEBUG AND
  205.                         IF      >ATTRIB4 ON> ?DEFATTRIB
  206.                                 TOPCRS =: PFALINE
  207.                                 ON> DIDPFA
  208.                         THEN
  209.                         DECOMSEG@ EXECUTION-CLASS .EXECUTION-CLASS >NORM
  210.                         OFF> ?DEFATTRIB
  211.                         DUP 0= KEY? OR
  212.                         ?DEBUG
  213.                         IF      #LINE @ SPLIT-L# 2- >=  \ hit bottom
  214.                                 IF      DIDPFA
  215.                                         IF      PFALINE SPLIT-L# 2- >=
  216.                                                 IF      PFALINE 10 -
  217.                                                         =: #EMPTY
  218.                                                 ELSE    TRUE OR
  219.                                                 THEN
  220.                                                 OFF> DIDPFA
  221.                                         THEN
  222.                                 THEN
  223.                         THEN
  224.                         PFALINE 12 < IF OFF> #EMPTY THEN
  225.                 UNTIL   DROP
  226.                 RESTORE> CR
  227.                 RESTORESTATE ;
  228.  
  229. : .IMMEDIATE   ( CFA -- )
  230.                 >NAME YC@ 64 AND
  231.                 IF      ." IMMEDIATE"   THEN   ;
  232.  
  233. : .CONSTANT     ( CFA -- )
  234.                 DUP >BODY ?   ." CONSTANT "   >NAME.ID   ;
  235.  
  236. : .VALUE        ( CFA -- )
  237.                 DUP >BODY ?   ." VALUE "      >NAME.ID   ;
  238.  
  239. : .VARIABLE     ( CFA -- )
  240.                 DUP C@ 232 =
  241.                 IF      DUP >BODY .   ." VARIABLE "   DUP >NAME.ID
  242.                         ." Value = " >BODY ?
  243.                 ELSE    >NAME.ID  THEN ;
  244.  
  245. : .:            ( CFA -- )
  246.                 ." : "  DUP >NAME .ID CR TAB .PFA   ;
  247.  
  248. : .DOES>        ( BODY -- )
  249.                 DUP>R BODY> @REL>ABS DUP R@ 2+ =  \ Self defining word
  250.                 IF      R@ @ >NAME .ID
  251.                 ELSE    DUP >.ID
  252.                 THEN    R>DROP ." DOES> " .PFA   ;
  253.  
  254. : .USER-VARIABLE   ( CFA -- )
  255.                 DUP >BODY ?   ." USER VARIABLE "   DUP >NAME.ID
  256.                 ." Value = "   >IS  ?   ;
  257.  
  258.  
  259. : .DEFER        ( CFA -- )
  260.                 ." DEFERRED " DUP >NAME.ID   ." IS "  >IS @ (SEE)  ;
  261.  
  262. : .USER-DEFER   ( cfa -- )
  263.    ." USER DEFERRED "   DUP >NAME.ID  ." IS "  >IS @ (SEE)  ;
  264.  
  265. : .OTHER   ( CFA -- )
  266.         DUP     >NAME.ID
  267.         DUP C@  232 <>                  \ cfa doesn't contain a call for code
  268.         IF      DROP    ." is Code, load DISASSEM to see it."
  269.                                         EXIT
  270.         THEN
  271.         DUP DOES?                       \ Is this a DOES> word?
  272.         IF      .DOES>  DROP            EXIT
  273.         THEN    2DROP   ." is Unknown"   ;
  274.  
  275. headers
  276.  
  277. 7 CONSTANT MAX-CLASSES
  278.  
  279. MAX-CLASSES ASSOCIATIVE: DEFINITION-CLASS
  280.    ( 0 )   '      QUIT @REL>ABS ,   ( 1 )   '  #VOCS @REL>ABS ,
  281.    ( 2 )   '     STATE @REL>ABS ,   ( 3 )   '   BASE @REL>ABS ,
  282.    ( 4 )   '        CR @REL>ABS ,   ( 5 )   '   EMIT @REL>ABS ,
  283.    ( 6 )   '  DECOMSEG @REL>ABS ,
  284.  
  285. : .DEFINITION-CLASS     ( N1 --- )
  286.                 0MAX MAX-CLASSES MIN EXEC:
  287.                 ( 0 )     .:            ( 1 )     .CONSTANT
  288.                 ( 2 )     .VARIABLE     ( 3 )     .USER-VARIABLE
  289.                 ( 4 )     .DEFER        ( 5 )     .USER-DEFER
  290.                 ( 6 )     .VALUE        ( 7 )     .OTHER      ;
  291.  
  292. : ((SEE))       ( Cfa -- )
  293.                 SAVE> ATTRIB
  294.                 CR   DUP DUP @REL>ABS
  295.                 DEFINITION-CLASS
  296.                 .DEFINITION-CLASS
  297.                 .IMMEDIATE
  298.                 RESTORE> ATTRIB ;
  299.  
  300. ' ((SEE)) IS (SEE)
  301.  
  302. FORTH DEFINITIONS
  303.  
  304. : SEE           ( | name -- )
  305.                 '   (SEE) ;
  306.  
  307. : SHOWSRC       ( --- ) \ Show the source for the current debugging word.
  308.                 savecursor
  309.                 0 0 AT
  310.                 ['] SRCEEOLCR IS CR
  311.                 ON> ?DEBUG
  312.                 DEFCFA  @ (SEE)
  313.                 OFF> ?DEBUG
  314.                 KEY? 0=
  315.                 IF      #LINE @ SPLIT-L# 1- MIN SPLIT-L# 1- SWAP
  316.                         ?DO     CR EEOL
  317.                         LOOP
  318.                 THEN
  319.                 ['] CRLF IS CR
  320.                 0 SPLIT-L# 1- AT >ATTRIB4
  321. ."  C-cont, D-done, F-forth, N-nest, Q-quit, S-skipto, U-unnest, X-source-on/off"
  322.                 EEOL >NORM
  323.                 restcursor ;
  324.  
  325. ' SHOWSRC IS .SRCDEF
  326.  
  327. : SRCCR         ( --- ) \ Source CR for the debugger, subscreen scroll.
  328.                 0 SPLIT-L# AT -LINE 0 ROWS 1- AT ;
  329.  
  330. ' SRCCR IS .SRCCR
  331.  
  332. : SRCON         ( --- ) \ Enable source printing durring debugging.
  333.                 ['] showsrc is .defsrc
  334.                 ['] SRCCR   IS CCR ;
  335.  
  336. : SRCOFF        ( --- ) \ disable source printing durring debugging.
  337.                 ['] noop    is .defsrc
  338.                 ['] CRLF    IS CCR ;
  339.  
  340. SRCOFF
  341.  
  342. behead
  343.  
  344.  
  345.