mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 05:32:28 +00:00
409 lines
26 KiB
Plaintext
409 lines
26 KiB
Plaintext
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
|