\ DECOM.SEQ     The F83 decompiler         Enhancements by Tom Zimmer

\    A Forth decompiler is a utility program that translates
\ executable forth code back into source code.  Normally this is
\ impossible, since traditional compilers produce more object
\ code than source, but in Forth it is quite easy.  The decompiler
\ is almost one to one, failing only to correctly decompile the
\ various Forth control stuctures and special compiling words.
\ It was written with modifiability in mind, so if you add your
\ own special compiling words, it will be easy to change the
\ decompiler to include them.  This code is highly implementation
\ dependant, and will NOT work on other Forth system.  To invoke
\ the decompiler, use the word SEE <name> where <name> is the
\ name of a Forth word.

: +TAB          ( --- )
                8 LMARGIN +! ;

: -TAB          ( --- )
                LMARGIN @ 8 - 0 MAX LMARGIN ! ;

: CRTAB         RMARGIN @ ?LINE ;

HIDDEN DEFINITIONS

0 CONSTANT DECOMSEG

: DECOMSEG@     ( N1 --- )
                DECOMSEG SWAP @L ;

: ASSOCIATIVE:
   CONSTANT
   DOES>         ( N -- INDEX )
      DUP @ ( N PFA CNT )   -ROT DUP @ 0 ( CNT N PFA CNT 0 )
      DO   2+   2DUP @ = ( CNT N PFA' BOOL )
         IF 2DROP DROP   I 0 0   LEAVE   THEN
            ( CLEAR STACK AND RETURN INDEX THAT MATCHED )
      LOOP   2DROP   ;

: .WORD         ( IP -- IP' )
                DUP DECOMSEG@ >NAME YC@ 64 AND
                IF      DUP YC@ 31 AND 10 + ?LINE
                        ." [COMPILE] "
                THEN    DUP DECOMSEG@ >NAME.ID   2+   ;

: (LIT+)        ( IP -- IP' )
                6 ?LINE 4 + ;

: .LIT          ( IP -- IP' )
                (LIT+) DUP 2- DECOMSEG@ . ;

: .IF           ( IP -- IP' )
                CRTAB ." IF " (LIT+) TAB +TAB ;

: .ELSE         ( IP -- IP' )
                -TAB CRTAB ." ELSE " (LIT+) TAB +TAB ;

: .DO           ( IP -- IP' )
                CRTAB ." DO  " (LIT+) TAB +TAB ;

: .?DO          ( IP -- IP' )
                CRTAB ." ?DO  " (LIT+) TAB +TAB ;

: .LOOP         ( IP -- IP' )
                -TAB CRTAB ." LOOP " (LIT+) TAB ;

: .+LOOP        ( IP -- IP' )
                -TAB CRTAB ." +LOOP " (LIT+) TAB ;

: .WHILE        ( IP -- IP' )
                -TAB CRTAB ." WHILE " (LIT+) TAB +TAB ;

: .REPEAT       ( IP -- IP' )
                -TAB CRTAB ." REPEAT " (LIT+) TAB ;

: .UNTIL        ( IP -- IP' )
                -TAB CRTAB ." UNTIL " (LIT+) TAB ;

: .AGAIN        ( IP -- IP' )
                -TAB CRTAB ." AGAIN " (LIT+) TAB ;

: .BEGIN        ( IP -- IP' )
                CRTAB 2+ ." BEGIN " TAB +TAB ;

: .THEN         ( IP -- IP' )
                -TAB CRTAB 2+ ." THEN " TAB ;

: .QUOTE        ( IP -- IP' )
                .WORD   .WORD ;

                \ Print the string at offset n1, and adjust n1 to the
                \ end of the string, while aligning it. Prepend a "
                \ space, and append a " space to the string
: ."X$"         ( N1 --- N1+LEN )
                DUP ASCII " EMIT SPACE
                DECOMSEG SWAP 2DUP C@L 1+ >R ?CS: "BUF R@ CMOVEL
                R> DUP 1 AND + + "BUF COUNT TYPE ASCII " EMIT SPACE ;

: .STRING."     ( IP -- IP' )
                2+ DECOMSEG OVER C@L 5 + ?LINE
                ASCII . EMIT ."X$" ;

: .STRING"      ( IP -- IP' )
                2+ DUP 2+ SWAP DECOMSEG@ DUP C@ 4 + ?LINE
                COUNT TYPE ASCII " EMIT SPACE ;

: .STRING""     ( IP -- IP' )
                2+ DECOMSEG OVER C@L 5 + ?LINE
                ASCII " EMIT ."X$" ;

: .ABORT"       ( IP -- IP' )
                2+ DUP DECOMSEG@ C@ 10 + ?LINE
                ." ABORT" ."X$" ;

: .(;CODE)    ( IP -- IP' )
                .WORD   DOES?
                IF  ." DOES> "
                ELSE  DROP FALSE  THEN  ;

: .UNNEST     ( IP -- IP' )
                ." ; "   DROP   0   ;

: .FINISH     ( IP -- IP' )
                .WORD   DROP   0   ;

21 ASSOCIATIVE: EXECUTION-CLASS
   (  0 ) '   (LIT)        ,         (  1 ) '   ?BRANCH      ,
   (  2 ) '   BRANCH       ,         (  3 ) '   (LOOP)       ,
   (  4 ) '   (+LOOP)      ,         (  5 ) '   (DO)         ,
   (  6 ) '   COMPILE      ,         (  7 ) '   (.")         ,
   (  8 ) '   (ABORT")     ,         (  9 ) '   (;CODE)      ,
   ( 10 ) '   UNNEST       ,         ( 11 ) '   (")          ,
   ( 12 ) '   (?DO)        ,         ( 13 ) '   (;USES)      ,
   ( 14 ) '   ?UNTIL       ,         ( 15 ) '   ?WHILE       ,
   ( 16 ) '   DOAGAIN      ,         ( 17 ) '   DOREPEAT     ,
   ( 18 ) '   DOBEGIN      ,         ( 19 ) '   DOTHEN       ,
   ( 20 ) '   (X")         ,

: .EXECUTION-CLASS      ( N1 --- )
                0 MAX 21 MIN EXEC:
                (  0 )     .LIT         (  1 )     .IF
                (  2 )     .ELSE        (  3 )     .LOOP
                (  4 )     .+LOOP       (  5 )     .DO
                (  6 )     .QUOTE       (  7 )     .STRING."
                (  8 )     .ABORT"      (  9 )     .(;CODE)
                ( 10 )     .UNNEST      ( 11 )     .STRING"
                ( 12 )     .?DO         ( 13 )     .FINISH
                ( 14 )     .UNTIL       ( 15 )     .WHILE
                ( 16 )     .AGAIN       ( 17 )     .REPEAT
                ( 18 )     .BEGIN       ( 19 )     .THEN
                ( 20 )     .STRING""    ( 21 )     .WORD      ;

: .PFA          ( LIST_SEGMENT -- )
                >BODY   @ XSEG @ + =: DECOMSEG 0
                SAVESTATE
                8 LMARGIN !
                70 RMARGIN !
                BEGIN
                        ?CR   DUP PFASAV @ OVER =
                        IF      >ATTRIB4
                        THEN    DECOMSEG@
                        EXECUTION-CLASS .EXECUTION-CLASS
                        >NORM
                        DUP 0= KEY? OR
                UNTIL   DROP RESTORESTATE ;

: .IMMEDIATE   ( CFA -- )
                >NAME YC@ 64 AND
                IF      ." IMMEDIATE"   THEN   ;

: .CONSTANT     ( CFA -- )
                DUP >BODY ?   ." CONSTANT "   >NAME.ID   ;

: .VARIABLE     ( CFA -- )
                DUP C@ 232 =
                IF      DUP >BODY .   ." VARIABLE "   DUP >NAME.ID
                        ." Value = " >BODY ?
                ELSE    >NAME.ID  THEN ;

: .:            ( CFA -- )
                ." : "  DUP >NAME .ID CR TAB .PFA   ;

: .DOES>        ( CFA -- )
                BODY> @REL>ABS DUP >.ID ." DOES> " .PFA   ;

: .USER-VARIABLE   ( CFA -- )
                DUP >BODY ?   ." USER VARIABLE "   DUP >NAME.ID
                ." Value = "   >IS  ?   ;


: .DEFER        ( CFA -- )
                ." DEFERRED " DUP >NAME.ID   ." IS "  >IS @ (SEE)  ;

: .USER-DEFER   ( cfa -- )
   ." USER DEFERRED "   DUP >NAME.ID  ." IS "  >IS @ (SEE)  ;

: .OTHER   ( CFA -- )
        DUP     >NAME.ID
        DUP C@  232 <>                  \ cfa doesn't contain a call for code
        IF      DROP    ." is Code"     EXIT
        THEN
        DUP DOES?                       \ Is this a DOES> word?
        IF      .DOES>  DROP            EXIT
        THEN    2DROP   ." is Unknown"   ;

6 ASSOCIATIVE: DEFINITION-CLASS
   ( 0 )   '      QUIT @REL>ABS ,   ( 1 )   '  DECOMSEG @REL>ABS ,
   ( 2 )   '     STATE @REL>ABS ,   ( 3 )   '      BASE @REL>ABS ,
   ( 4 )   '        CR @REL>ABS ,   ( 5 )   '      EMIT @REL>ABS ,

: .DEFINITION-CLASS     ( N1 --- )
                0 MAX 6 MIN EXEC:
                ( 0 )     .:            ( 1 )     .CONSTANT
                ( 2 )     .VARIABLE     ( 3 )     .USER-VARIABLE
                ( 4 )     .DEFER        ( 5 )     .USER-DEFER
                ( 6 )     .OTHER      ;

: ((SEE))       ( Cfa -- )
                CR   DUP DUP @REL>ABS
                DEFINITION-CLASS .DEFINITION-CLASS
                .IMMEDIATE ;   ' ((SEE)) IS (SEE)

FORTH DEFINITIONS

: SEE           ( | name -- )
                '   (SEE) ;

VARIABLE CFASAV   CFASAV ON

: SRCEEOLCR    77 #OUT @ - SPACES CRLF ;

: SHOWSRC       ( --- ) \ Show the source for the current debugging word.
                #out @ #line @ >r >r ?CS: TYPESEG DUP @ >R !
                0 0 AT DEFCFA @ CFASAV @ <>
                IF      18 0
                        DO      0 I AT 80 SPACES
                        LOOP    DEFCFA @ CFASAV !
                THEN    0 1 AT
                ['] SRCEEOLCR IS CR
                defcfa  @ (SEE)
                #line @ 18 min 18 swap
                ?do     cr 78 spaces
                loop
                ['] CRLF IS CR
                0 18 AT >ATTRIB4
."   C-continuous, F-forth, N-nest, Q-quit, Z-zip thru CODE words, X-source-off"
                77 #OUT @ - SPACES >NORM
                R> TYPESEG !
                r> r> at ;

: SRCCR         ( --- ) \ Source CR for the debugger, subscreen scroll.
                0 19 AT -LINE 0 24 AT ;


: SRCON         ( --- ) \ Enable source printing durring debugging.
                ['] showsrc is .defsrc
                ['] SRCCR   IS CCR ;

: SRCOFF        ( --- ) \ disable source printing durring debugging.
                ['] noop    is .defsrc
                ['] CRLF    IS CCR ;    SRCOFF