\ *** Block No. 0 Hexblock 0 
\\ Tools                                                 11Nov86
Dieses File enthaelt die wichtigsten Werkzeuge zur Programm-    
entwicklung:    - den einfachen Decompiler                      
                - der DUMP-Befehl                               
                - den Tracer                                    
                                                                
Der einfache Decompiler wird benutzt, um neue Defining-Words    
zu ueberpruefen. Der automatische Decompiler kann ja dafuer     
nicht benutzt werden, da ihm diese Strukturen unbekannt sind.   
(Benutzung: addr und dann, je nach Art: S N D L C oder B)       
                                                                
DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP)  
                                                                
Der Tracer erlaubt Einzelschrittausfuehrung von Worten.         
Er ist unentbehrliches Hilfsmittel bei der Fehlersuche.         
(Benutzung:  DEBUG <name>  und  END-TRACE)                      
\ *** Block No. 1 Hexblock 1 
\  Programming-Tools word set / tracer            cas 19july2020
                                                                
Onlyforth    Vocabulary Tools  Tools also definitions           
                                                                
01 05 +thru   &15 &16 +thru                                     
   06 +load     \ Tracer                                        
                                                                
Onlyforth                                                       
                                                                
: internal \ start headerless definitions                       
   1 ?head ! ;                                                  
                                                                
: external \ end headerless definitions                         
   ?head off ;                                                  
                                                                
                                                                
\ *** Block No. 2 Hexblock 2 
\ Tools for decompiling                                  22feb86
                                                                
| : ?:     dup 4 u.r ." :" ;                                    
| : @?     dup @ 6 u.r ;                                        
| : c?     dup c@ 3 .r ;                                        
                                                                
: s   ( adr - adr+ )                                            
 ?: space  c? 3 spaces  dup 1+ over c@ type  dup c@ + 1+ even ; 
                                                                
: n   ( adr - adr+2 )  ?: @? 2 spaces  dup @ >name .name 2+ ;   
: d   ( adr n - adr+n)                                          
 2dup swap ?:  swap  0 DO c? 1+ LOOP  2 spaces  -rot type ;     
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 3 Hexblock 3 
\ Tools for decompiling                                  22feb86
                                                                
: l   ( adr - adr+2 )    ?: 5 spaces @? 2+ ;                    
: c   ( adr - adr+1)     1 d ;                                  
: b   ( adr - adr+1)     ?: @? dup @ over + 5 u.r 2+ ;          
                                                                
                                                                
                                                                
\\                                                              
: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE      
THEN 10 +LOOP ;                                                 
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 4 Hexblock 4 
\ General Dump Utility - Output                       UH 07Jun86
                                                                
| : .2   ( n -- )   0  <#   # #   #>   type  space ;            
| : .6   ( d -- )   <#  # # # # # #  #>  type ;                 
| : d.2   ( addr len -- )   bounds ?DO  I C@  .2  LOOP ;        
| : emit.   ( char -- )                                         
   $7F and  dup bl $7E uwithin not IF drop Ascii . THEN  emit ; 
| : dln   ( addr --- )                                          
   cr  dup 6 u.r  2 spaces  8 2dup d.2  space                   
   over + 8 d.2  space   $10 bounds ?DO  I C@ EMIT.  LOOP  ;    
| : ?.n    ( n1 n2 -- n1 )                                      
   2dup = IF  ." \/"  drop  ELSE  2 .r  THEN   space ;          
| : ?.a    ( n1 n2 -- n1 )                                      
   2dup = IF  ." V"  drop   ELSE  1 .r  THEN ;                  
                                                                
                                                                
\ *** Block No. 5 Hexblock 5 
\ .head                                               UH 03Jun86
                                                                
                                                                
| : .head   ( addr len -- addr' len' )                          
   swap  dup -$10 and  swap  $0F and  cr 8 spaces               
   8 0 DO  I ?.n  LOOP  space  $10 8 DO  I ?.n  LOOP            
   space  $10 0 DO  I ?.a  LOOP  rot + ;                        
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 6 Hexblock 6 
\ Dump and Fill Memory Utility                        UH 25Aug86
                                                                
Forth definitions                                               
                                                                
: dump   ( addr len -- )                                        
 base push  hex    .head                                        
 bounds ?DO  I dln  stop? IF  LEAVE  THEN  $10 +LOOP ;          
                                                                
Tools definitions                                               
                                                                
: du   ( addr -- addr+$40 )     dup $40 dump  $40 + ;           
                                                                
: dl   ( line# -- )             c/l * scr @ block + c/l  dump ; 
                                                                
Forth definitions                                               
                                                                
\ *** Block No. 7 Hexblock 7 
\ Trace Loadscreen                                       29Jun86
                                                                
Onlyforth       \needs Tools    Vocabulary Tools                
Tools also definitions                                          
                                                                
1 8 +thru                                                       
                                                                
Onlyforth                                                       
                                                                
\ clear                                                         
                                                                
\  don't forget END-TRACE after using DEBUG                     
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 8 Hexblock 8 
\ Variables do-trace                                  UH 04Nov86
                                                                
| Variable Wsave        \ Variable for saving W                 
| Variable <ip          \ start of trace trap range             
| Variable ip>          \ end of trace trap range               
| Variable 'ip          \ holds IP  (preincrement!)             
| Variable nest?        \ True if NEST shall be performed       
| Variable newnext      \ Address of new Next for tracing       
| Variable #spaces      \ for indenting nested trace            
| Variable tracing      \ true if trace mode active             
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 9 Hexblock 9 
\ install Tracer                                      UH 18Nov87
                                                                
Tools definitions                                               
                                                                
| Code do-trace   \ patch Next to new definition                
   $C3 A mvi ( jmp )  >next sta                                 
   newnext lhld       >next 1+ shld  Next                       
end-code                                                        
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 10 Hexblock A 
\ throw status on Return-Stack                           29Jun86
                                                                
| Create: npull                                                 
   rp@ count  2dup + even rp!  r> swap cmove ;                  
                                                                
: npush  ( addr len --)   r> -rot  over >r                      
   rp@ over 1+ -  even dup rp!  place  npull >r  >r ;           
                                                                
| : oneline   .status space query interpret  -&82 allot         
              rdrop ( delete quit from tracenext ) ;            
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 11 Hexblock B 
\ reenter tracer                                         04Nov86
                                                                
| Code (step                                                    
   true H lxi   tracing shld   IP rpop   Wsave lhld   H W mvx   
Label fnext                                                     
   xchg                                                         
   M E mov   H inx   M D mov   xchg   pchl                      
end-code                                                        
                                                                
| Create: nextstep   (step ;                                    
                                                                
| : (debug  ( addr --)   \ start tracing at addr                
      dup  <ip !                                                
      BEGIN  1+ dup @   ['] unnest =  UNTIL  2+ ip> ! ;         
                                                                
                                                                
\ *** Block No. 12 Hexblock C 
\ check trace conditions                                 04Nov86
                                                                
Label tracenext   tracenext newnext !                           
   IP ldax  IP inx   A L mov   IP ldax   IP inx   A H mov       
   xchg   tracing lhld   H A mov   L ora   fnext jz             
   nest? 1+ lda   A ana                                         
   0= ?[                                                        
         <IP lhld  H inx                                        
         IP A mov  H cmp   fnext jc                             
           0= ?[ IP' A mov  L cmp   fnext jc ]?                 
         IP> lhld                                               
         H A mov   IP cmp   fnext jc                            
           0= ?[ L A mov   IP' cmp   fnext jc ]?                
      ][ A xra nest? 1+ sta  ]? \ low byte still set            
                            \ one trace condition satisfied     
   W H mvx   Wsave shld   false H lxi   tracing shld            
\ *** Block No. 13 Hexblock D 
\ tracer display                                      UH 25Jan88
                                                                
;c: nest? @                                                     
    IF  nest? off  r>  ip> push  <ip push  dup 2- (debug        
         #spaces push  1 #spaces +!  >r   THEN                  
    r@ nextstep >r  input push  output push  standardi/o        
    cr #spaces @ spaces                                         
    dup 'ip !  2-  dup 5 u.r  @ dup 6 u.r  2 spaces             
    >name .name  $1C col -  0 max spaces  .s                    
    state push  blk push  >in push  ['] 'quit >body push        
    [ ' parser >body ] Literal push                             
    span push  #tib push  tib #tib @ npush  r0 push             
    rp@ r0 !  &82 allot  ['] oneline Is 'quit  quit ;           
                                                                
                                                                
                                                                
\ *** Block No. 14 Hexblock E 
\ DEBUG with errorchecking                               28Nov86
                                                                
| : traceable  ( cfa -- cfa' )                                  
 recursive  dup @                                               
 ['] : @    case? ?exit                                         
 ['] key @  case? IF  >body c@ Input @ +  @  traceable exit THEN
 ['] type @ case? IF  >body c@ Output @ + @  traceable exit THEN
 ['] r/w  @ case? IF  >body                  traceable exit THEN
 dup 1+ @ [ ' Forth @ 1+ @ ] Literal =      IF nip 1+  exit THEN
 drop >name .name ." can't be DEBUGged" quit ;                  
                                                                
also Forth definitions                                          
                                                                
: debug  ( -- )   \ reads a word                                
   '  traceable  (debug   Tools                                 
   nest? off  #spaces off  tracing on  do-trace ;               
\ *** Block No. 15 Hexblock F 
\ misc. words for tracing                                28Nov86
Tools definitions                                               
                                                                
: nest                  \ trace next high-level word executed   
   'ip @ 2- @ traceable drop  nest? on ;                        
                                                                
: unnest                \ ends tracing of actual word           
   <ip on  ip> off ;    \ clears trap range                     
                                                                
: endloop               \ stop tracing loop                     
   'ip @ <ip ! ;        \ use when at end of loop               
                                                                
Forth definitions                                               
                                                                
: trace' ( -- )   \ reads a word                                
   context push   debug   <ip perform  end-trace ;              
\ *** Block No. 16 Hexblock 10 
\ N>R  NR> cr                                                   
                                                                
: N>R  ( i * n +n -- ) ( R: -- j * x +n )                       
\ Transfer N items and count to the return stack.               
  DUP BEGIN DUP WHILE                                           
    ROT R> SWAP >R >R                                           
    1-                                                          
  REPEAT DROP  R> SWAP >R >R  ;                                 
                                                                
: NR>  ( -- i * x +n ) ( R: j * x +n -- )                       
\ Pull N items and count off the return stack.                  
  R> R> SWAP >R DUP                                             
  BEGIN  DUP  WHILE                                             
     R> R> SWAP >R -ROT                                         
     1-                                                         
 REPEAT  DROP  ;                                                
\ *** Block No. 17 Hexblock 11 
\  ?                                                            
                                                                
: ?  ( a-addr -- )                                              
\ Display the value stored at a-addr.                           
  @ . ;                                                         
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
