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