VolksForth/8080/CPM/see.fb

\ Extended-Decompiler for VolksForth LOAD-SCREEN      UH 07Nov86                                                                Dieses File enthaelt einen Decompiler, der bereits kompilierte  Worte wieder in Sourcetextform bringt.                          Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL  und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang      erkannt und umgeformt.                                          Ein Decompiler kann aber keine (Stack-) Kommentare wieder       herzaubern, die Benutzung der Screens und dann view, wird       daher staerkstens empfohlen.                                                                                                    Denn:        Es ist immernoch ein Fehler drin!                  Und um den zu korrigieren, ist der Sourcetext dem Objektkode    doch vorzuziehen.                                                                                                                             Benutzung:       see <name>                       \ Extended-Decompiler for VolksForth LOAD-SCREEN         07Nov86                                                                Onlyforth Tools also definitions                                                                                                1 13 +thru                                                                                                                      \\                                                              Produces compilable Forth source from normal compiled Forth.                                                                             These source blocks are based on the works of                                                                                      Henry Laxen, Mike Perry and Wil Baden                                                                                              volksFORTH version: U. Hoffmann                                                                                                                                                  \ detacting does>                                        01Jul86                                                                internal                                                                                                                        ' does> 4+ @   Alias (;code                                     ' Forth @ 1+ @  Constant (dodoes>                                                                                               : does?    ( IP -  f )                                             dup c@  $CD ( call ) =  swap                                    1+ @  (dodoes>  = and ;                                                                                                                                                                                                                                                                                                                                                                                                                                      \ indentation.                                           04Jul86Variable #spaces   #spaces off                                                                                                  : +in  ( -- ) 3 #spaces +! ;                                                                                                    : -in  ( -- ) -3 #spaces +! ;                                                                                                   : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr  #spaces @ spaces ;                                                                : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN  ;                                                                                                                                                                                                                                                                                                                                                                                                                   \ case defining words                                    01Jul86                                                                : Case:  ( -- )                                                    Create:  Does>   swap 2* +  perform ;                                                                                        : Associative: ( n -- )                                            Constant   Does>      ( n - index )                             dup @ -rot  dup @ 0                                             DO  2+  2dup @ =                                                    IF  2drop drop  I  0 0  LEAVE  THEN   LOOP 2drop ;                                                                                                                                                                                                                                                                                                                                                                                                       \ branching                                              04Jul86                                                                Variable #branches    Variable #branch                                                                                          : branch-type ( n -- a ) 6 * pad + ;                            : branch-from ( n -- a ) branch-type 2+ ;                       : branch-to   ( n -- a ) branch-type 4+ ;                                                                                       : branched ( adr type -- ) \ Make entry in branch-table.             #branches @ branch-type !   dup #branches @ branch-from !       2+ dup @ +  #branches @ branch-to !   1 #branches +! ;                                                                     \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... }                                                                                                                                                                                                      \ branching                                              01Jul86                                                                : branch-back ( adr type --  )                                     \  : make entry in branch-table & reclassify branch-type.)      over swap branched                                              2+ dup dup @ + swap 2+ ( loop-start,-end.)                      0  #branches @ 1-                                               ?DO                                                                over I branch-from @  u> IF LEAVE THEN                          dup  I branch-to @ = IF ['] while  I branch-type !  THEN     -1 +LOOP 2drop ;                                                                                                                                                                                                                                                                                                                                                                             \ branching                                              01Jul86: forward? ( ip -- f )   2+ @ 0> ;                                                                                              : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward?                  IF ['] if branched exit THEN   ['] until branch-back ;                                                                       : branch+ ( ip -- ip' ) dup 4+ swap dup forward?                   IF ['] else branched exit THEN ['] repeat branch-back ;                                                                      : (loop)+ ( ip -- ip' )                                            dup  dup @ ( loop,+loop )  branch-back -1 #branches +! 4+ ;                                                                  : string+ ( ip -- ip' ) 2+ count + even ;                                                                                       : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+  ;                                                                  \ classify each word                                     25Aug86Forth                                                                                                                           &15 Associative: execution-class                                 ] clit         lit             ?branch         branch             (do          (."             (abort"         (;code             ("           (?do            (loop                              (+loop       unnest          (is             compile   [                                                                     Case:  execution-class+                                            3+           4+              ?branch+        branch+            2+           string+         string+         (;code+            string+      2+              4+                                 4+           0=              4+              4+         2+  ;                                                                Tools                                                           \ first pass                                             01Jul86                                                                : pass1 ( cfa -- ) #branches off >body                             BEGIN dup @ execution-class execution-class+                       dup 0= stop? or                                              UNTIL drop ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ identify branch destinations.                          04Jul86: thru.branchtable ( -- limit start ) #branches @ 0 ;           : ?.then ( ip -- ) thru.branchtable                                ?DO I branch-to @ over =                                           IF I branch-from @ over u<                                        IF I branch-type @ dup ['] else = swap ['] if = or                IF -in ." THEN " ind-cr LEAVE THEN THEN THEN             LOOP ;                                                       : ?.begin ( ip -- ) thru.branchtable                               ?DO I branch-to @ over =                                           IF I branch-from @ over u< not                                    IF I branch-type @ dup                                             ['] repeat = swap ['] until = or                                IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN           LOOP ;                                                       ( put "BEGIN" and "THEN" where used.)                           \ decompile each type of word                            01Jul86                                                                : .word   ( ip -- ip' ) dup @ >name .name 2+  ;                                                                                 : .(word  ( ip -- ip' )     dup @  >name                              ?dup 0= IF ." ??? " ELSE                                        count $1f and swap 1+ swap 1-  type space THEN 2+ ;       : .inline ( val16b -- )                                              dup >name ?dup IF ." ['] " .name drop exit THEN . ;                                                                        : .lit    ( ip -- ip' )     2+ dup @ .inline  2+  ?.then ;      : .clit   ( ip -- ip' )     2+ dup c@ . 1+ ?.then ;             : .string ( ip -- ip' )                                              .(word count 2dup type Ascii " emit space + even ?.then ;                                                                  : .unnest  ( ip -- 0 )      ." ; " 0=  ;                        \ decompile each type of word                            01Jul86                                                                : .default ( ip -- ip' ) dup @ >name ?dup IF                        c@ $40 and IF ." [COMPILE] " THEN THEN   .word ?.then ;                                                                     : .['] ( ip -- ip' )  .(word dup @ 2- >name .name  2+  ?.then ;                                                                 : .compile ( ip -- ip' ) .word  .word  ?.then ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ decompiling conditionals                               04Jul86                                                                : .if     ( ip nfa -- ip' )  ind-cr .name +in 4+ ?.then ;       : .repeat ( ip nfa -- ip' )  -in .name ind-cr 4+ ?.then ;       : .else   ( ip nfa -- ip' )  -in ind-cr .name +in 4+ ;          : .do     ( ip nfa -- ip' )  ind-cr .(word +in 2+ ?.then ;      : .loop   ( ip nfa -- ip' )  -in .(word ind-cr 2+ ?.then ;                                                                      5 Associative: branch-class                                      ' if ,   ' while ,  ' else ,  ' repeat ,  ' until ,            Case: .branch-class                                                .if    .else      .else     .repeat     .repeat      ;                                                                       : .branch ( ip -- ip' )                                             #branch @   branch-type @   1 #branch +!                        dup >name   swap branch-class .branch-class ;               \ decompile Does> ;code                                  04Jul86                                                                : .(;code  ( IP - IP' f)                                           2+ dup does?                                                    IF  ind-cr ." DOES> " 3+  ELSE  ." ;CODE "  0=  THEN ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       \ classify word's output                                 01Jul86                                                                Case: .execution-class                                             .clit        .lit            .branch         .branch            .do          .string         .string         .(;code            .string      .do             .loop                              .loop        .unnest         .[']            .compile           .default ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \ decompile colon-definitions                            04Jul86                                                                : pass2 ( cfa -- ) #branch off >body                               BEGIN ?.begin ?ind-cr  dup @ execution-class .execution-class         dup 0= stop? or                                           UNTIL drop ;                                                                                                                 : .pfa ( cfa -- ) #spaces off  +in  dup pass1   pass2 ;                                                                         : .immediate  ( cfa - )    >name c@ dup                             ?ind-cr  40 and IF  ." IMMEDIATE "  THEN                        ?ind-cr  80 and IF  ." RESTRICT"    THEN ;                                                                                  : .:  ( cfa - )  ." : " dup >name .name 3 spaces  .pfa ;                                                                                                                                        \ display category of word                               01Jul86external   Defer (see   internal                                                                                                : .does>  ( cfa - )     ." DOES> "  @  1+ .pfa ;                                                                                : .user-variable  ( cfa - ) ." USER " dup >name dup .name           3 spaces swap execute @ u. .name ." ! " ;                                                                                   : .defer   ( cfa - )                                             ." deferred "  dup >name .name  ." Is "  >body @  (see  ;                                                                      : .other   ( cfa - )  dup >name .name                               dup @ over >body =   IF drop ."  is Code " exit THEN            dup @ does? IF .does> exit THEN                                 drop ." is unknown " ;                                                                                                      \ decompiling variables and constants                    01Jul86                                                                : .constant   ( cfa - )                                             dup  >body @ u.  ." CONSTANT "  >name .name ;                                                                               : .variable   ( cfa - ) ." VARIABLE "                               dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \ classify a word                                     UH 25Jan88                                                                5 Associative: definition-class                                   ' quit @ ,    ' 0 @ ,         ' scr @ ,       ' base @ ,        ' 'cold @ ,                                                                                                                   Case: .definition-class                                           .:            .constant       .variable       .user-variable    .defer        .other  ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       \ Top level of Decompiler                                04Jul86                                                                external                                                                                                                        : ((see    ( cfa -)                                                 #spaces off cr                                                  dup dup @                                                       definition-class .definition-class   .immediate  ;                                                                          ' ((see Is (see                                                                                                                 Forth definitions                                               : see   ' (see ;