\\              *** Decompiler/Tracer ***              02sep09py                                                                This file contains the decompiler for optimized code, which     corresponds to the usual decompiler for a tracer.  In addition, it also can produce recompilable source code.                                                                                   The tracer in the last part of this file can trace optimized    code, but beware: stack changes don't always have the expected  result, since sometimes the TOS is really a constant that's     already part of the program code.                                                                                                                                                                                                                                                                                                                                                                                                                               \ Loadscreen                                           23jun12py$22 +load                                                       Module tools                    $34 +load                       4 Value /indent                                                 ?head @ 1 ?head !                                               $01 $1C +thru                                                   ?head !                                                         $1D $21 +thru                                                   \needs disline : disline base push hex ." code "dup w@ 4 .r 2+ ; ' disline IS disassemble                                       $23 +load   \ Load tracer                                       export: drop  initdecom                                                 export  tools  see dsee dump du dl ? d' vocs                            >debug debug trace' BP: BP'on BP'off B~~                        (~~) ~~, ~~ tab traceall notrace becomes ;      Module;                                                         \ Variablen und Ausgabehilfen                          12aug93pyUser mfield     $20 cell- uallot  drop                          User macro+     cell uallot       drop   User /macro            : initdecom  macro+ off /macro off ;            initdecom       User thenbranch     $F cells uallot  drop                       User beginbranch    $F cells uallot  drop                       User push>      User @tos                                       User n?     \ N oder Decompiler?                                User indent     0 indent !                                      : tab   ( n -- )                col - 0 max spaces ;            : tab1   &10 tab ;                                              : +indent ( n -- )  indent +! indent @ tab ;                    : cr? n? @ ?exit col indent @ = 0= IF cr indent @ spaces THEN ; : +ind  /indent +indent ;                                       : -cr?  /indent negate +indent cr? ;                            : cfa#  ( cfa -- cfa n )  dup 2- wx@ abs ;                      Code instab R:  \ Insert-Table                         21nov93pyBEGIN :ax    w,  :S R:  AX push                       THEN      BEGIN :lit   w,  :S R:  AX push                       THEN      BEGIN :dx    w,  :S R:  DX pop                        THEN      BEGIN :dx>   w,  :S R:  AX DX mov  AX pop             THEN      BEGIN :+loop w,  :S R:  AX loopreg add  AX pop        THEN      BEGIN :cdx   w,  :S R:  DX pop  AX DX cmp             THEN      BEGIN :?     w,  :S R:  AX AX test                    THEN      BEGIN :+     w,  :S R:  DX pop  DX AX add             THEN      BEGIN :-     w,  :S R:  DX pop  DX AX xchg  DX AX sub THEN      BEGIN :or    w,  :S R:  DX pop  DX AX or              THEN      BEGIN :and   w,  :S R:  DX pop  DX AX and             THEN      BEGIN :xor   w,  :S R:  DX pop  DX AX xor             THEN      BEGIN :@     w,  :S R:  AX ) AX mov                   THEN      BEGIN :c@    w,  :S R:  .b AX ) AX movzx              THEN      BEGIN :!     w,  :S R:  AX ) pop   THEN  end-code               \ !begin lit?                                          01apr93py: macro+!  [ ' instab dup 2- w@ bounds swap ] Aliteral Aliteral   DO  dup i c@ = IF  i 1+ count macro+ place  LEAVE  THEN         i 1+ c@ 2+ +LOOP  drop ;                                      : !begin ( addr -- ) initdecom   opttab #opt bounds               DO  dup I 1+ count over + within  IF  I c@ push> ! LEAVE THEN       I 1+ c@ 2+ +LOOP  dup 5 + c@ /macro ! 1+ c@ macro+! ;     : findtab  ( reg -- addr count )  opttab                          BEGIN  2dup c@ = 0=  WHILE  1+ count +  REPEAT nip 1+ count ; : findit ( cfa n -- addr/0 ) >r cfa# 3 - false r> findtab bounds  DO  2 pick 2 pick I 3+ c@ - mfield -text                            0= IF  true 2 pick I 3+ c@ - mfield + I 5 + count bounds               ?DO  i c@  ?dup IF over c@ = 0=                                                    IF 2drop false 0 LEAVE THEN THEN                  1+ LOOP  drop IF  drop I LEAVE  THEN  THEN          i 5 + c@ 6+ +LOOP  nip nip ;                              \ instance? var? value? .nfa .nfa? (.lit               16mar93py: instance? ( addr pfa -- flag )                                  swap dup [ Memory ] HeapStart HeapEnd [ FORTH ] within          IF  dup body> under = 0= IF  cfa@ = exit  THEN                  THEN  2drop false ;                                                                                                           : var? ( addr -- flag )   [ ' udp cfa@ ] Aliteral instance? ;   : value? ( addr -- flag ) [ ' c/l cfa@ ] Aliteral instance? ;   : .nfa   ( nfa -- )                                                ?dup  IF  count $1F and type  ELSE ." ???"  THEN space ;     : .cfaname ( cfa -- ) >name .nfa ;                              : .nfa? ( cfa -- ) dup >name dup  IF  .nfa drop exit  THEN        drop >body . ;                                                : (.lit ( lit -- )                                                dup >name  dup IF  ." ['] " .nfa drop exit  THEN  drop          dup var?       IF  body> .nfa?        exit  THEN  . ;         \ .lit >mfield                                         03nov01py                                                                : >mfield  ( IP -- IP ) macro+ count mfield swap move             dup /macro @ + mfield $20  macro+ c@ /string move ;           : ?S~R ( IP -- IP' ) dup w@ $F487 =                               IF  2+ 0  ELSE  $F48702  THEN  macro+ ! /macro off ;          : !S~R ( IP -- IP' ) /macro off dup w@ $F487 =                    IF  2+ 0  ELSE  mfield 9 + c@ $58 =                                 IF  1+ $F48702  ELSE  $50F48703  THEN  THEN  macro+ ! ;   : >S~R ( IP -- IP IP' )  dup macro+ c@ 0=                         IF  dup 2- w@ $F487 =                                               IF  2-  ELSE  push> @ :s = 0= 2* -  THEN  THEN ;          : <S~R  ( IP IP' -- IP'' IP' )                                    2dup =  IF dup w@ $F487 = IF swap ?S~R swap exit THEN THEN      2dup > 0=  IF  ?S~R swap 2dup - + swap  THEN ;                : .to ( addr -- ) n? @ 0= IF  drop exit  THEN  ." to " . ;      \ literals                                             05mar00pyUser lastlit                                                    | : n+  1 + ;   | : n@  1 @ ;   | : nc@ 1 c@ ;                  : .(@  dup value?  IF  dup body> >name dup                                             IF  .nfa drop exit  THEN  drop THEN             dup var?    IF  body> .nfa?  ELSE  .  THEN  ." @ " ;     : .(c@ dup var?    IF  body> .nfa?  ELSE  .  THEN  ." c@ " ;    : lit?  ( -- lit# ) mfield @ $B850F487 =                          dup 0= IF  drop ['] n+  :#+   findit  THEN                      dup 0= IF  drop ['] n@  :#@   findit  THEN                      dup 0= IF  drop ['] nc@ :#c@  findit  THEN                      dup 0= IF  drop ['] 1   :lit  findit  THEN ;                                                                                                                                                                                                                                                                                  \ literals                                             03nov01py                                                                Variable lastlit@               lastlit@ off                    : .lit ( IP lit# -- IP' )  macro+ c@ /macro @ - >r initdecom      dup 0> IF  dup !begin dup 2+ c@ dup $7F >                                  IF -$80 or THEN  push> @ :#+ = +  ELSE 0 THEN        mfield 4+ + lastlit !  swap 2 r> - + swap                       push> @ :#@  = IF   lastlit @ @ .(@  ELSE                       push> @ :#c@ = IF   lastlit @ 2+ @ .(c@  swap 2+ swap                          ELSE lastlit @ @                                                     over dup 0> IF  c@ :#@ =  ELSE  0>  THEN                        IF    lastlit@ !                                                ELSE  (.lit  THEN  THEN  THEN               push> @ :#+  = IF   swap 1- swap ." + "  THEN                   dup 0> IF  3+ c@ - 6+  ELSE  drop  6+ ?S~R  THEN ;                                                                            \ .branch .then                                        03jun97py                                                                : branch?  ( -- flag ) mfield @ $FFFFFF and $E9F487 = ;                                                                         : .branch  3+ macro+ c@ - dup  @ 2dup + cell+  swap 0<            IF   -cr?  over 4+ thenbranch dup @ cells + @ =                      IF   ." REPEAT  " -1 thenbranch +!                              ELSE ." AGAIN  " THEN .to 4+ ?S~R exit  THEN               dup 6 ['] unloop 2+ -text 0=                                    IF  ."  LEAVE  " drop  4+ ?S~R exit  THEN                       -cr? over 4+ thenbranch dup @ cells + @ =                       IF  ." ELSE  " +ind  ELSE  ." AHEAD  " 1 thenbranch +!  THEN    dup .to dup thenbranch dup @ dup                                IF  $10 min cells + !  ELSE  2drop drop  THEN  drop 4+ ?S~R ;                                                                                                                                 \ "?branch                                             03jun97py                                                                : "?branch ( flag# IP - flag# string -1/0/1 )                     1+ dup  @ under + cell+  swap 0<                                IF  drop " UNTIL " -cr? false exit  THEN                        dup 6 ['] unloop 2+ -text 0=                                    IF  drop 1 xor "  ?LEAVE  " false exit  THEN                    dup cell- @ -$8000 u>                                           IF  "  WHILE " 1  ELSE  cr? " IF " true  THEN  >r swap          1 thenbranch +! thenbranch dup @ $10 min cells + ! r> ;       : .then ( IP - IP )                                               BEGIN  >S~R thenbranch @ ?dup  WHILE                                   $10 min cells thenbranch + @ over =  WHILE                      col indent @ = IF  at? /indent - at  THEN                       -1 thenbranch +! ." THEN " -cr? <S~R drop                REPEAT THEN drop ;                                            \ .comp                                                12aug93py                                                                : comp? ( -- flag )                                               mfield 2@ swap $F0FFFFFF and $800F.58.D03B.5A.F487 d= ;       Create branchtable                                              ," "            ," "            ," U< 0= "      ," U< "         ," = 0= "       ," = "          ," U> "         ," U> 0= "      ," "            ," "            ," "            ," "            ," < 0= "       ," < "          ," > "          ," > 0= "       : branchflag  branchtable swap 0 ?DO  count +  LOOP ;           : ?ind  dup 0> IF  cr?  THEN  0< IF  +ind  THEN ;               : .comp  ( IP -- IP' )                                            7 + /macro @ macro+ c@ - +                                      dup c@ $F and over "?branch >r >r branchflag                    count type r> count type  r> ?ind  5 + initdecom                dup dup cell- @ + .to ?S~R ;                                  \ .test                                                08jun01py: test? ( -- flag )  mfield $A ['] within -text                   0= IF  mfield $A + @ $F0FFFF and $800F58 = ?dup ?exit  THEN     mfield 2@ swap   $F0FFFF and    $800F.58.C085.F487 d=           mfield 2@ swap       $F0 and         $800F.58.F487 d= or ;    Create testtable                                                4 c, ," "  5 c, ," 0= "  6 c, ," WITHIN "  7 c, ," WITHIN 0= "  $8 c, ," 0< 0= "  $9 c, ," 0< "  $E c, ," 0> "  $F c, ," 0> 0= ": testflag ( n -- string )  >r testtable                          BEGIN  count r@ = 0=  WHILE  count +  REPEAT  rdrop ;         : .test  ( IP -- IP' )  dup >r mfield 2+ w@ $C085 = IF 2+ THEN    mfield $A ['] within -text 0= IF  8+ THEN                       4+ dup r> - >r /macro @ + macro+ c@ - r> mfield + c@            $F and over "?branch >r >r  testflag                            count type r> count type r> ?ind  5 + initdecom                 dup dup cell- @ + .to ?S~R ;                                  \ ?begin .begin >begin                                 12aug93py: ?begin ( IP -- ) dup 2+ swap c@ $E9 = + dup @ dup -$8000 u>     IF cell+ + 1 beginbranch +!                                        beginbranch cell+ dup dup cell- @ $10 min 1- 0 max cells +      ?DO  dup i cell- @ > IF  i cell- @ i !  ELSE  i ! unloop                                 exit  THEN  -cell +LOOP                beginbranch cell+ ! exit THEN 2drop ;                      : >begin ( endaddr cfa -- endaddr cfa ) beginbranch off           2dup ?DO  i w@  dup  $810F = 0=                                           IF  dup $F0FF and  $800F = swap $FF and $E9 = or                    IF  i ?begin  THEN  ELSE drop THEN  LOOP ;      : .begin ( IP - IP' )  >S~R                                       BEGIN  beginbranch @ ?dup  WHILE                                       $10 min cells beginbranch + @ over =  WHILE  cr?                -1 beginbranch +! ." BEGIN " +ind <S~R  REPEAT THEN             drop ;                                                 \ (macrocomp                                           25oct93py                                                                Label (macrocomp  ( AX: source CX: dest -- true/opt/cont ) :S         AX push  CX push  CX SI mov  AX DI mov                          AX AX xor  .w lods  .w AX not  AX CX mov                        BEGIN  repe .b cmps  0<> WHILE  0 # -1 SI D) cmp  0= WHILE             3 # SI add  3 # DI add  3 # CX sub  <= UNTIL                    CX pop  AX pop  ret  THEN THEN                           0= IF  CX pop  8 # SP add  2 # CX add  CX $18 SP D) mov                popa  -1 # AX mov  CX push  Next  THEN                   DI dec  SI dec  CX dec 0< IF  DI dec  SI dec  CX inc  THEN      0= IF  .w $F487 # SI ) cmp                                         0= IF  CX pop  8 # SP add  2 # CX add  CX $18 SP D) mov                popa  -2 # AX mov  CX push  Next  THEN  THEN                                                                                                                                    \ (macrocomp Fortsetzung                               26oct93py                                                                      3 SI CX DI) AL mov  $7F # AX and                                0= IF  CX pop  AX pop  ret  THEN   :f # AX cmp                  0= IF  7 # CX cmp                                                      0= IF  .b $0F # 1 DI D) cmp                                            0= IF  .w 1 DI D) AX mov                                        ELSE  1 DI D) AH mov  $0F # AL mov  THEN                        $0F # AH and  $90 # AH or  .w AX SI ) cmp                       0= IF  CX pop  8 # SP add  2 # CX add                                  CX $18 SP D) mov .b $0F # 1 DI D) cmp                           0= IF  popa  -3 # AX mov                                        ELSE   popa  -4 # AX mov  THEN                                  CX push  Next  THEN                               THEN   CX pop  AX pop  ret                               THEN                                                      \ (macrocomp Fortsetzung                               25oct93py      SI CX I) BP lea  opttab A# SI mov   #opt # BX mov               BEGIN   AL SI ) cmp  0= IF  SI inc  .b lods  AL BX movzx          BEGIN  3 SI D) CL cmp                                             0= IF  CX push  BP push  SI push  DI push                           .b 2 SI D) CX movsx  CX BP add .b 5 SI D) CX movzx              6 # SI add  BEGIN  CX CX test  0<> WHILE                               repe .b cmps  0<> WHILE .b 0 # -1 SI D) cmp                     0= WHILE  CX BP sub  -1 BP D) AL mov                            -1 DI D) AL cmp 0= WHILE  CX BP add  REPEAT                     THEN  THEN  THEN  DI pop  SI pop  BP pop                 0= IF  CX pop  CX pop  8 # SP add  2 # CX add                          CX $18 SP D) mov  SI $1C SP D) mov  popa                        CX push  Next  THEN  CX pop  THEN                    CX push  5 SI D) CL mov  6 # CX add  CX SI add                  CX BX sub  CX pop  <= UNTIL  CX pop  AX pop  ret  THEN\ find macro                                           25oct93py                                                                        SI inc  AX push  .b lods  AX SI add  AX inc  AX inc             AX BX sub  AX pop  <= UNTIL                                   CX pop  AX pop  ret  end-code                             code ((macro?   ( thread addr -- cfa t/f )  DX pop  pusha            BEGIN  DX ) DX mov  DX DX test  0<> WHILE                              4 DX D) CL mov  $3F # CX and  5 # CX btr                        5 CX DX DI) CX lea                                              b IF   CX ) CX mov  2 # CX sub   THEN                           .w -1 # CX ) cmp  < IF  (macrocomp rel) call  THEN       REPEAT  popa  AX AX xor  Next  end-code                    : (macro?   ( addr -- cfa f )                                     context @ over ((macro? dup IF  rot drop exit  THEN  drop       voc-link  BEGIN  @  dup  WHILE  2dup 8 - swap ((macro? dup      IF 2swap 2drop exit THEN  drop  REPEAT ;                      \ macro?                                               02nov01py: macro?   ( -- cfa f )  mfield  (macro?                          over ['] dup = @tos @ :ax = and  IF drop 0 THEN ;             User macrolen                                                   : >macrolen ( cfa flag -- cfa flag )                              dup  IF  over 2- wx@ invert macrolen !  /macro @ macro+ c@ -             macrolen +! macro+ off  THEN  /macro off  dup          0>   IF  dup !begin  dup 4+ c@ over 3+ c@ - macrolen +!  THEN   -2 case? IF  $F48702 macro+ ! exit  THEN                        -3 case? IF  $85F48707.840F58C0  macro+ 2! -2 macrolen +!                    3 /macro ! exit  THEN                              -4 =     IF  $85F48706.007458C0  macro+ 2! -1 macrolen +!                    0 /macro !  THEN ;                               : call? ( -- flag )  mfield c@ $E8 = ;                          defer disassemble                                                                                                               \ call? .call                                          17oct99py: user#  ( IP -- IP' n )  mfield 4+ c@ $C7 and dup $45 =          IF    drop 6+ mfield 5 + c@                                     ELSE  $85 =  IF  6+ mfield 5 + @  THEN  THEN ;                : user?  ( n -- cfa flag )                                        $8D50F487 pad ! dup $80 < IF  $45 swap pad 5 + c!  6            ELSE  $85 swap pad 5 + ! 9  THEN  pad + $F487 swap w!           pad 4+ c! pad (macro? ;                                       : defer? ( n -- cfa flag )  $95FF pad w! pad 2+ ! pad (macro? ; : ?user  mfield @ dup $8D50F487 = swap $8F50F487 = or             mfield 4+ c@ dup $45 = swap $85 = or and ;                    : user@? ( -- flag )  ['] dp :susr@ findit                        dup 0= IF  drop ['] lastlit :user@ findit  THEN ;             : .user@ ( IP user@# -- IP' )  swap /macro @ + macro+ c@ - swap   !begin 3 - user# user?  IF  .cfaname ." @ " exit  THEN          dup user# nip ." UP@ "  . ." + @ " ;                          \ .macro                                               03nov01py: .macro   ( addr cfa flag -- )  >macrolen                        ['] (LOOP  case?  IF -cr? ." LOOP "  macrolen @ + 4+ exit THEN  ['] (+LOOP case?  IF -cr? ." +LOOP " macrolen @ + 4+ exit THEN  ['] (NEXT  case?  IF -cr? ." NEXT "  macrolen @ + 4+ exit THEN  dup ['] @ =  IF  lastlit@ @ IF drop lastlit@ dup @ swap off                      .(@  macrolen @ + macro+ c@ - exit THEN THEN   dup ['] .a1 = over ['] .a2 = or over ['] .a3 = or               0= IF  .cfaname  ELSE  drop  THEN  macrolen @ + macro+ c@ - ; : .user ( IP -- IP' )  /macro @ macro+ c@ - + user#               dup defer?  IF    nip ." & " .cfaname                                       ELSE  drop user?  IF  .cfaname                                        ELSE  drop ." ??? "  THEN  THEN               mfield 4+ c@ $85 =  IF    3+   THEN                             mfield 3+ c@ $8F =  IF    :! macro+! /macro off                                     ELSE  ?S~R  THEN ;                        \ .@ .!                                                02sep09py: !? ( -- flag )                                                  mfield @ $8F50F487 = mfield cell+ c@ $05 = and ;              : .! ( IP -- IP' )  6+ /macro @ + !S~R mfield 5 + @               dup [ Memory ] HeapStart HeapEnd [ FORTH ] within               IF  dup dup >r 1- c@ $BA = r> 4+ w@ $E2FF = and                     IF  dup 1- >name dup  IF  ." IS " .nfa drop exit  THEN              drop  THEN  dup value?  IF  ." TO " body> .nfa?             exit  THEN  THEN  (.lit ." ! " ;                          : .does>  ( IP -- IP' )                                           >mfield macro?  dup IF  over ['] r> =                           IF >macrolen  drop true  ELSE  2drop false  THEN  THEN          IF ." DOES> " macrolen @ + macro+ c@ - ELSE ." ;CODE " THEN ; : .exit ( endaddr IP -- endaddr IP )                              2dup > 0=  IF    ." ; " 2drop initdecom cr rdrop rdrop                     ELSE  ." EXIT " ( :s push> ! )  THEN ;             \ .exit .string                                        14jul96py                                                                : ."_ Ascii " emit space ;                                      : .string ( IP addr count -- IP' )  under >r >r >r                count dup r> + 2+ col + cols $10 - > IF  cr?  THEN              r> r>  type space 2dup type + aligned ."_ ;                   : .compile ( IP cfa -- IP ) drop dup @ dup >name dup              IF    ." COMPILE " .nfa drop                                    ELSE ." (COMPILE [ " drop . ." A, ] " THEN  cell+ ;                                                                           : "<paren ( cfa -- addr n )  >name count $1F and 1 /string ;    : .<paren ( cfa -- )  "<paren  type space ;                     : .<(" ( IP cfa -- IP' )  "<paren .string ;                     : .DO   cr? .<paren  +ind ;     : .?DO  .DO 7 + ?S~R ;                                                                                                                                          \ .cfa                                                 02sep09py$10 2* cells Constant #cfas                                     Table: cfatable                                                    (DO .DO   (?DO .?DO   (FOR .DO   (." .<("   (C" .<("            (S" .<("  (0" .<("    (ABORT" .<("   (ERROR" .<("               (COMPILE .compile [                                          here #cfas over cfatable - - 0 [?DO]  0 A,  cell [+LOOP]        AVariable cfatable'  cfatable' !                                : .cfa ( IP cfa -- IP' )  cfatable #cfas bounds                   DO  dup I @ = IF  I cell+ perform unloop exit  THEN                 [ 2 cells ] Literal  +LOOP                                  ['] (;code case?  IF                                               cr? 2+ nip cfa# 1- bounds .does> exit THEN  dup >name        dup IF    dup c@ $40 and  IF  ." COMPILE "  THEN  .nfa drop         ELSE  drop ." [ " . ." cfa, ] " THEN ;                    : .call ( IP -- IP' ) ." call "  dup >body swap cfa@ .cfa ;     \ decom                                                03nov01py: (decom  ( IP -- IP' )  push> off dup >r                         macro+ c@ 2 = IF  ?S~R  THEN  >mfield                           call?       IF  .call   rdrop exit  THEN                        ?user       IF  .user   rdrop exit  THEN                        test?       IF  .test   rdrop exit  THEN                        comp?       IF  .comp   rdrop exit  THEN                        branch?     IF  .branch rdrop exit  THEN                        !?          IF  .!      rdrop exit  THEN                        lit?    dup IF  .lit    rdrop exit  THEN  drop                  user@?  dup IF  .user@  rdrop exit  THEN  drop                  macro?  dup IF  .macro  rdrop exit  THEN  2drop  drop r>        /macro @ + initdecom n? @ 0= IF cr? dup 6 u.r ." :" THEN        disassemble  n? @ 0= IF  cr  THEN ;                           : decom ( IP -- IP' )  push> @ @tos !                             BEGIN  (decom  lastlit@ @ 0= UNTIL ;                          \ .word .pfa                                           02sep09py                                                                : .word ( IP -- IP' ) dup >mfield drop                            call?  IF   dup cfa@ >r >body r> .cfa  exit  THEN               mfield @ $F487F487 = dup cell and mfield + c@ $C3 =             IF  2* - .exit 1+  exit  THEN  drop decom ;                                                                                   : (.pfa ( ende pfa -- )  >begin                                   BEGIN  .then .begin .word                                              >r thenbranch dup @ $10 min cells + @ max r>                    ?cr col 0= IF  indent @ spaces  THEN  stop?  UNTIL       2drop initdecom  cr ;                                                                                                         : .pfa  ( pfa -- )  2 +indent                                      cfa# 1- bounds  (.pfa  indent off ;                                                                                          \ .immediate .Value .variable                          26oct93py                                                                : .immediate  ( cfa - )                                           >name ?dup 0= ?exit                                             dup name> 2- wx@ 0<  IF ." macro " THEN  c@ dup                 $40 and IF  ." immediate "  THEN                                $80 and IF  ." restrict"    THEN ;                                                                                            : .Value   ( cfa - )                                              dup  >body @ .  ." Value "      .cfaname ;                    : .variable   ( cfa - )                                           ." Variable "  dup .cfaname 2 spaces                            dup >body @ . .cfaname ." ! " ;                                                                                                                                                                                                                               \ display category of word                             18apr93py                                                                : .:      ( cfa - )      ." : " dup .cfaname cr? .pfa ;                                                                         : .user-variable  ( cfa - )                                       ." User "  dup .cfaname 2 spaces                                dup execute @ . .cfaname ." ! " ;                                                                                             Patch (see                                                      : .(defer ( cfa -- )  dup .cfaname dup >body @ dup (see           ." ' " .cfaname ." IS "  .cfaname cr ;                        : .defer   ( cfa - )  ." Defer " .(defer ;                      : .patch   ( cfa - )  ." Patch " .(defer ;                                                                                                                                                                                                                      \ .other und .code                                     02sep09py                                                                : .others   ( cfa -- ) initdecom                                  dup 2- 7 [ ' base  2- ] ALiteral -text                          0= IF .user-variable exit THEN                                  dup 2- 7 [ ' current  2- ] ALiteral -text                       0= IF .user-variable exit THEN                                  dup 2- @             $95FFFFF9 =  IF  .defer  exit  THEN        dup 2- @ $FFFFFF and $00BA0000 =  IF  .patch  exit  THEN        dup 2- w@  IF  .:  exit  THEN                                   ." Create " dup .cfaname   cfa@ cr? .does>                      macrolen @ macro+ c@ - dup >r -                                 cfa# 1- bounds r> + (.pfa  indent off ;                       : .file ( cfa -- ) [ DOS ] ." File "                              dup .cfaname ."  \ " >body .fcb ;                             : .vocabulary ( cfa -- )  ." Vocabulary " .cfaname ;            \ Classify a word                                      20may00py                                                                : .input  ( cfa - ) cr? ." Input " dup .cfaname ." is"            >body c@  input  @ + @ (see ;                                 : .output ( cfa - ) cr? ." Output " dup .cfaname ." is"           >body c@  output @ + @ (see ;                                 : .cold:  ( cfa - ) cr? dup .cfaname                              >body c@  cells $18 + thisModule @ + @                          cfa# 1- bounds  (.pfa ;                                       Create definition-class                                         ' c/l cfa@ A,   ' udp cfa@ A,   ' key cfa@ A,   ' emit cfa@ A,  ' forth cfa@ A, ' cold: cfa@ A, ' forth.fb cfa@ A,                                                                              Table: .definition-class                                        .value          .variable       .input          .output         .vocabulary     .cold:          .file [                         \ see                                                  29dec02py                                                                : ((see    ( cfa -- ) n? off                                      cr? dup >name heap?  IF ." | " THEN                             thenbranch off  dup 0 over cfa@                                 7 0 DO  definition-class Ith case?                                      IF  0= .definition-class Ith LEAVE  THEN                    LOOP  swap  IF  execute  ELSE  drop .others  THEN           .immediate  ;                                                                                                                 ' ((see Is (see                                                                                                                 : see   name find 0= IF number drop THEN (see ;                 : bind-see  ( cfa action -- )  swap cfatable' @ dup @ 0=          IF  2! 8 cfatable' +!  ELSE  drop 2drop  THEN ;                                                                               \ n                                                    03nov01py                                                                tools definitions                                                                                                               | : c@?    dup c@    3 .r ;                                     | : ?:     dup      8 u.r ." :"  tab1 ;                                                                                         : s   ( addr -- addr+ )                                            ?: space  c@? 3 spaces  count 2dup type  +  aligned ;        : nd  ( IP -- IP' )  n? on .then .begin decom ;                 : n   ( IP -- IP' )  ?: nd ;                                    : dsee ( -- )  base push hex  ' dup cfa# bounds >begin dup >r     BEGIN  dup r@ <=   r> cr ?: disassemble >r  IF  nd  THEN               2dup > 0= stop? or UNTIL                                 2drop drop rdrop cr ;                                                                                                         \ General Dump Utility - Output                   32b  07aug10py                                                                : d   ( addr n -- addr+n)                                         over ?:  over  0 ?DO  c@? 1+  LOOP  2 spaces  -rot type ;     : c   ( addr -- addr+1 )      1 d ;                             : ?   ( addr -- ) @ . ;     \ print cont. of address            | : .2   ( n -- )   0  <<#   # #   #>   type  #>>  space ;      | : .8   ( n -- )   8 u.r ;                                     | : d.2   ( addr len -- )   bounds                                  ?DO  I ['] c@ catch IF  drop ." -- " ELSE  .2  THEN LOOP ;  | : emit.   ( char -- )                                             dup $7F and bl <  IF  drop Ascii .  THEN  emit ;            | : dumpline   ( addr --- )  cr  dup .8  2 spaces                   8 2dup d.2  space   over + 8 d.2  space   $10 bounds            ?DO  I ['] c@ catch IF  drop ." ." ELSE  emit.  THEN LOOP       dumped off ;                                                \\ Longdump  basics                               32b  23jun12py                                                                | : ?.n    ( n1 n2 -- n1 )                                          2dup - IF  .2 exit  THEN  ." \/ "  drop ;                                                                                   | : ?.a    ( n1 n2 -- n1 )                                          2dup - IF  1 .r exit  THEN  ." V"  drop ;                                                                                   | : .head   ( addr len -- addr' len' )                              swap  dup -$10 and  swap  $0F and  cr $A spaces                 8 0 DO  I ?.n  LOOP  space  $10 8 DO  I ?.n  LOOP               space  $10 0 DO  I ?.a  LOOP  rot + ;                                                                                                                                                                                                                                                                                       \ Dump Memory Utility                             32b  23jun12py                                                                : dump    ( addr len -- )  base push  hex                         bounds ?DO  I dumpline  stop? ?LEAVE  $10 +LOOP ;                                                                             : du   ( addr -- addr+$40 )     dup $40 dump  $40 + ;                                                                           : dl   ( line# -- )             c/l * scr @ block + c/l dump ;                                                                  : d'        ' dup cfa# bounds >begin                                        BEGIN  cr n  2dup > 0= stop? or UNTIL                           2drop drop cr ;                                                                                                     : vocs     voc-link                                                        list>  8 - dup body> >name dup                                  IF .nfa drop space  ELSE  2drop  THEN  ?cr ;         \ Debugger help macros                                 25oct93py                                                                Code .a1  nop             Next end-code  macro                  Code .a2  BP BP mov       Next end-code  macro                  Code .a3  0 BP D) BP lea  Next end-code  macro                                                                                  : I_C@  I c@ ; macro            bl last @ 2+  c!                : within_0=  within 0= ; macro  bl last @ 7 + c!                                                                                : .dumped  cr dumped 8 cells + dup                                7 FOR  cell- dup @ $A .r  NEXT  drop                            3 FOR  dup @ $A .r cell+  NEXT  drop ;                                                                                                                                                                                                                                                                                        \ Trace Loadscreen                                     30sep06py                                                                \ cr .( Mit Tracer wird das Forth ca. 400 mal langsamer) cr                                                                     1 $10 +thru                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ Variables do-trace                                 bp25may97py                                                                | 0 AValue <rp          \ Return Stack range                    | 0 AValue <up          \ User Pointer of tracing task          | 0 AValue <pc          \ start of trace trap range             | 0 AValue pc>          \ end of trace trap range               | 0 AValue <macro       \ start of next instr.                    0 AValue macro>       \ end+1 of next instr. or macro         | 0 AValue nest?        \ addr. of next instruction after NEST                                                                  | User #spaces          \ for indenting nested trace            | User r0save           \ save initial value of r0                                                                              : macro>!       ( addr -- )  macro> @ 0<> and macro> ! ;                                                                                                                                        \ define register addresses                         bp 19may97py                                                                patch tAX                                                       | : register    ( offset -- ) Create c,  Does> c@ tAX + ;       | : registers   ( n -- )      0 ?DO dup register cell+ LOOP ;                                                                   cell 9 registers CX DX BX SP BP SI DI EFLAGS IP                 Constant #regs                                                                                                                  Create AX  #regs allot          \ tAX avoids name conflicts     ' AX IS tAX                                                                                                                     Variable s/r                                                                                                                    Defer debugi/o  ' standardi/o IS debugi/o                                                                                       \ OS specific trace vector setups                      09dec01py[IFDEF] go32  : tv!  1 idt! ;                           [THEN]  [IFDEF] unix  | Variable tv                                     also dos 3 libc sigaction sigaction previous                    Code trace-handler  ( sigcontext sig -- )                            R: 6 cells # SP add  tAX A# AX mov                              7 [FOR]  [I] cells AX D) pop  [NEXT]                            2 cells # SP add  9 cells AX D) pop  DX pop                     8 cells AX D) pop   2 cells # SP add  DX pop \ DX ) frstor      7 [FOR]  [I] cells AX D) [I] dup 3 << + $C0 + mov  [NEXT]       eflags A#) push  CS push  IP A#) push                           tv A#) jmp  end-code                                       Create trace-sig  ' trace-handler A,                            [IFDEF] glibc     $20  [ELSE]  1  [THEN]                                          0 [DO] 0 , [LOOP]  $58000000 , 0 ,            : tv! tv ! 0 trace-sig 5 sigaction drop ;                [THEN] \ OS specific trace vector setups                      19may97py                                                                [IFDEF] os2                                             [THEN]  [IFDEF] win32                                           [THEN]  [IFUNDEF]  tv!  : tv!  drop ;                           [THEN]                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  \ throw status on Return-Stack                      bp 07aug10py: .eflags  ( -- )   col ." AVR-NPLODITSZ-A-P-C"  cr  tab          base push 2 base !                                              eflags @ 0 <<#  &19 0 DO # LOOP  #> type #>> ;                | Defer 'nestall ' noop IS 'nestall                             | User step     step on         | User go?      go? off         | User cont?    cont? off                                       | : oneline   step @  0= IF  stop? step !  THEN  cont? off          step @   IF  BEGIN  .status space query interpret                                   cont? @ #tib @ 0= or UNTIL  THEN            -$166 allot  'nestall ;                                     : go step off cont? on ;                                        Defer .dump     ' .s is .dump                                   : dumpregs  base push  .s cr                                      S" AXCXDXBXSPBPSIDI" bounds DO 7 spaces I 2 type space 2 +LOOP  hex  DI cell+ AX  DO  I @ 9 u.r space  cell +LOOP  .eflags ;  \ dump stack or register                               09dec01py                                                                | Table: >op  noop  +  -  and  or  xor  noop @ [                | Variable last#                                                                                                                | : .@tos :DX   case?  IF DX @                      exit THEN             :AX   case?  IF AX !                      exit THEN             :lit  case?  IF lastlit @ @ dup last# !                                         @tos @ $70 and 4/ >op + perform                                                           exit THEN             :user =      IF <macro @ user# nip up@ +  exit THEN ;                                                                 | : tos@ ( -- n / )    @tos @ $F and .@tos ;                                                                                                                                                                                                                    \ dump stack or register                               09dec01py                                                                | Table: op>  2drop  -  +  drop drop  xor noop 2drop [                                                                          | : tos! ( n / -- )   @tos @ $F and                                 :DX   case?  IF  DX !           exit  THEN                      :AX   case?  IF  AX @           exit  THEN                      :lit  case?  IF  last# @ @tos @ $70 and 4/ op> + perform                                        exit  THEN                      :user =      IF  drop           exit  THEN  ;                                                                                                                                                                                                                                                                                                                                                                                                               \ reenter tracer                                       12nov94py                                                                ' exit  c@ | constant [unnest]                                  | : .traceerr ( 0/1/2 -- )  2 case? error" can't be debugged"       1 = macro> @ and error" is a Macro !" ;                                                                                     | : (debug  ( addr -- )          \ start tracing at addr            dup <pc !  dup >name          \ is there a length info ?        IF    dup 2- wx@   dup 0=  2 and .traceerr                                         dup 0<        .traceerr  abs +               ELSE  cr ." End of word not found !"                                  \ BEGIN  1+ dup c@  [unnest] =  UNTIL  1+                       dup 2- wx@ abs +                                          THEN                                                            pc> !                                                           pc> @  <macro !  <pc @  macro>! ;                           \ Nextstep                                             19may97py                                                                $10 | Constant maxsave                                          | Variable <pc>save -1 , 0 , -1 , maxsave 3 cells Q* allot      $10 cells allot  here  cell allot | Constant pushstack                                                                          | : <pc>push  <pc>save @ 1+ dup maxsave min <pc>save !              dup dup + + cells  <pc>save +                                   cell+ <pc @ over ! cell+ pc> @ over ! cell+ <rp @ swap ! ;  | : <pc>pull ( raddr -- )   <pc>save @ 1+                           BEGIN 1- dup 0< 0=  WHILE  2dup dup dup + + cells                     <pc>save + cell+ dup >r @ r> cell+ @ within UNTIL THEN    dup 0< IF  2drop  0 <pc>save @  THEN                            dup 1- 0 max dup <pc>save ! #spaces !                           dup dup + + cells <pc>save +                                    cell+ dup @ <pc ! cell+ dup @ pc> ! cell+ @ <rp ! drop ;    \ enable and disable tracer                            19may97py| Code nextstep  R: .b s/r A#) 0 # cmp  0<> IF  SP RP xchg  THEN       eflags A#) push  CS push  IP A#) push                           1 cells tAX + A#) CX mov  2 cells tAX + A#) DX mov       Label fnext   iret   end-code                                   Label fnexttask   8 # 8 SP D) btr  iret  end-code               Code do-trace   \ enables Tracer                                     pushf  8 # SP ) bts  popf  Next  end-code                  Code end-trace  \ disables Tracer                                    8 # eflags A#) btr        \ change SR storage location          pushf  8 # SP ) btr  popf  Next  end-code                  Label rp?  SP RP cmp  u> IF  RP push  ELSE  SP push   THEN                 -1 L# SP ) cmp   here 4-  to <rp  4 SP D) SP lea                fnext u< jmpIF  CX push  DX push  SI push                       pushstack A# SI mov  AX SI ) mov  8 SP D) AX mov                ' <pc>pull rel) call  SI pop  DX pop  CX pop         \ check trace conditions                               09dec01pyLabel debugger  :R  AX push  4 SP D) AX mov                               .b $9D # AX ) cmp  AX pop      fnexttask 0= jmpIF               -1 L# SP ) cmp  here 4- to <pc    rp?   u<= jmpIF               -1 L# SP ) cmp  here 4- to pc>    rp?   u>  jmpIF               -1 L# SP ) cmp  here 4- to <macro                        u>= IF -1 L# SP ) cmp  here 4- to macro> fnext u< jmpIF THEN AHEAD  Label nester  :R  AX push  4 SP D) AX mov                          .b $9D # AX ) cmp  AX pop  fnexttask 0= jmpIF                   -1 L# SP ) cmp   here 4- to nest?   fnext jnz  THEN             -1 L# UP cmp     here 4- to <up     fnext jnz                   8 SP D) push  eflags A#) pop     \ save SR                      AX push  AX push  tAX A# AX mov  AX ) pop                       8 1 [DO]  9 [I] * $C0 +  [I] cells AX D) mov  [LOOP]            AX pop  IP A#) pop  4 SP D) SP lea  eflags A#) pop              SP RP cmp  u> IF  SP RP xchg  THEN  s/r A#) u> setIF  \ tracer display                                       02nov01py                                                                ;c:  debugger tv!  nest? @                                       IF  <pc>push  nest? @ (debug  nest? off  1 #spaces +!  THEN     s/r c@ macro+ c@ 0= and  IF  $F48702 macro+ !  THEN  rp@ <rp !  IP @  ['] nextstep >r   pushi/o tflush  r0 push  debugi/o       BEGIN  $166 allot #spaces @ spaces   >r tos@ r> <macro !               .dump  cr                                                       base @ hex <macro @  N  $30 tab   macro>! base !                state push  blk push  blk off                                   & 'quit push  & parser push  >in @ >r  $FF newtib               rp@ cell- r0 !  ['] oneline IS 'quit                            also Tools quit toss  tflush                                    deltib  r> >in !  tos!  push> @ @tos !                          macro> @ <macro @ over <  UNTIL  drop ;                                                                                 \ DEBUG with "intelligent" trap range sele             20apr93py                                                                | : traceable   ( cfa -- cfa' 0/ 1/ 2 )  recursive                  ['] pause case?  IF  2 exit  THEN  \ is inline macro            dup 2- @ $95FFFFF9 =  IF  >body @ traceable exit  THEN          dup 2- wx@  dup 0< IF 2drop 1 exit THEN 0 swap ?exit drop       dup cfa@ over = 0=  IF  dup cfa@                                  [ ' key  cfa@ ] ALiteral case?                                  IF  >body c@  Input @ +  @ traceable  exit  THEN                [ ' type cfa@ ] ALiteral =                                      IF  >body c@  Output @ + @ traceable  exit  THEN                dup cfa@ >mfield drop macro?  dup IF  over ['] r> =                 IF    >macrolen drop cfa@ macrolen @ +  0 exit                  ELSE  2drop drop 2 exit  THEN THEN THEN                   dup c@ $BA = over 5 + w@ $E2FF = and                            IF  >body @ traceable  exit THEN drop 2 ;                   \ misc. words for tracing                              02nov01py: endloop  <pc @ <macro ! ;  \ skip LOOPs at their end          : unbug    deltib end-trace toss                                           <pc>save off ['] (quit is 'quit  -$166 allot                    r0save @ r0 ! handler @ $14 + @ handler ! abort ;    | : ?nest ( -- addr t / 0 ) <macro @  dup cfa@ under =              IF  drop mfield 5 ['] execute -text 0=  IF dup                  ELSE mfield 5 ['] perform -text 0= IF  dup @                    ELSE mfield dup w@ $95FF = IF >body @                       \    ELSE dup @ $92FF178B = IF cell+ @ ^ @ + @ THEN                 ELSE drop 0 exit THEN THEN THEN THEN -1 ;                   : nest                  \ trace next high-level word executed     ?nest 0=  error" founds no subroutine call"                     traceable .traceerr nest? !  nester tv! cont? on ;            | : (nestall pc> @ 0= ?exit  ?nest  0= ?exit                        traceable 0> ?exit nest? ! nester tv! ;                     \ misc. words for tracing                              02nov01py                                                                : nestall ['] (nestall IS 'nestall cont? on ;                   : nonest ['] noop IS 'nestall cont? on ;                        : unnest  <pc on  pc> off  <macro on  1 macro>! cont? on ;      | : (>debug ( addr -- )                                             (debug   #spaces on  <pc>save on  step on                       @tos off  <pc @  nest? !  pushi/o debugi/o bot                  <rp on  up@ <up !  ;                                        : >debug ( addr -- )  (>debug  debugger tv!                       do-trace ;                                                    : debug  ( -- )  initdecom   \ use it  DEBUG <name>               r0 @  r0save !   '  traceable  .traceerr ( also Tools) (>debug  nester tv!  do-trace ;                                        : trace' ( -- )  \ traces following word                          >in @ >r  debug  r> >in ! ' execute  end-trace ;              \ BP:                                                  11may09py: BP: here reveal rel dup push on lastcfa dup push @ swap >r      | : compile exit swap compile Literal                               ['] >debug compile Literal compile >r                           compile ; hmacro  lastcfa @ 2- dup wx@ abs swap w!              ] r> dp ! lastcfa @ cfa, ;  immediate restrict            : BP'on  $90 ' c! ;             : BP'off $C3 ' c! ;             \ Setzt ein NOP                   Setzt ein RTS                 : B~~  r> >debug ;                                              : (~~)  base push output push display cr >name >r                 [ also DOS ] ?fcb filename >len type ': emit [ previous ]       swap decimal 0 .r ': emit 0 .r ." :" r> .name hex .time .s ;  : ~~,  blk@ postpone Literal >in @ postpone Literal               isfile@ postpone ALiteral lastcfa @ postpone Literal ;        : ~~  ~~, postpone (~~) ;               immediate                                                                               \ Debugging Tools for beginners                        05sep09py\ n TO TAB erzeugt Tabulator                                                                                                    : notrace   ['] (name     IS name ;                             Create tab   0  , DOES> @ col - spaces ;                        Create tmark '| , DOES> @ ?dup IF  emit space  THEN ;           | : .rs  depth ?dup 0= ?exit 0 swap 1- DO  i pick .  -1 +LOOP ; | : (traceall  cr .rs tab tmark                                     source >in @ /string bl skip blk @ IF  1- c/l Qmod 1+  THEN     -trailing type space  stop? IF notrace THEN (name ;         : traceall  ['] (traceall IS name ;                                                                                             : becomes ( xt <name> -- )  here >r ' ( >body ) dp ! >r           postpone AHEAD  r> dp !  postpone  THEN  r> dp ! ;