VolksForth/sources/cpm/see.fth

409 lines
25 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\ 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>
\ *** Block No. 1 Hexblock 1
\ 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
\ *** Block No. 2 Hexblock 2
\ detacting does> 01Jul86
internal
' does> 4+ @ Alias (;code
' Forth @ 1+ @ Constant (dodoes>
: does? ( IP - f )
dup c@ $CD ( call ) = swap
1+ @ (dodoes> = and ;
\ *** Block No. 3 Hexblock 3
\ indentation. 04Jul86
Variable #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 ;
\ *** Block No. 4 Hexblock 4
\ 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 ;
\ *** Block No. 5 Hexblock 5
\ 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 ... }
\ *** Block No. 6 Hexblock 6
\ 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 ;
\ *** Block No. 7 Hexblock 7
\ 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+ ;
\ *** Block No. 8 Hexblock 8
\ classify each word 25Aug86
Forth
&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
\ *** Block No. 9 Hexblock 9
\ first pass 01Jul86
: pass1 ( cfa -- ) #branches off >body
BEGIN dup @ execution-class execution-class+
dup 0= stop? or
UNTIL drop ;
\ *** Block No. 10 Hexblock A
\ 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.)
\ *** Block No. 11 Hexblock B
\ 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= ;
\ *** Block No. 12 Hexblock C
\ 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 ;
\ *** Block No. 13 Hexblock D
\ 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 ;
\ *** Block No. 14 Hexblock E
\ decompile Does> ;code 04Jul86
: .(;code ( IP - IP' f)
2+ dup does?
IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ;
\ *** Block No. 15 Hexblock F
\ classify word's output 01Jul86
Case: .execution-class
.clit .lit .branch .branch
.do .string .string .(;code
.string .do .loop
.loop .unnest .['] .compile
.default ;
\ *** Block No. 16 Hexblock 10
\ 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 ;
\ *** Block No. 17 Hexblock 11
\ display category of word 01Jul86
external 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 " ;
\ *** Block No. 18 Hexblock 12
\ 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 ." ! " ;
\ *** Block No. 19 Hexblock 13
\ classify a word UH 25Jan88
5 Associative: definition-class
' quit @ , ' 0 @ , ' scr @ , ' base @ ,
' 'cold @ ,
Case: .definition-class
.: .constant .variable .user-variable
.defer .other ;
\ *** Block No. 20 Hexblock 14
\ 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 ;
\ *** Block No. 21 Hexblock 15
\ *** Block No. 22 Hexblock 16
\ *** Block No. 23 Hexblock 17