[gforth] / gforth / see.fs  

gforth: gforth/see.fs

Diff for /gforth/see.fs between version 1.44 and 1.45

version 1.44, Wed Dec 25 21:16:54 2002 UTC version 1.45, Thu Dec 26 14:09:20 2002 UTC
Line 120 
Line 120 
   
 ' (.string) IS .string  ' (.string) IS .string
   
   : c-\type ( c-addr u -- )
       \ type string in \-escaped form
       begin
           dup while
               2dup newline string-prefix? if
                   '\ cemit 'n cemit
                   newline nip /string
               else
                   over c@
                   dup '" = over '\ = or if
                       '\ cemit cemit
                   else
                       dup bl 127 within if
                           cemit
                       else
                           base @ >r try
                               8 base ! 0 <<# # # # '\ hold #> ctype #>> 0
                           recover
                           endtry
                           r> base ! throw
                       endif
                   endif
                   1 /string
               endif
       repeat
       2drop ;
   
 : .struc  : .struc
         uppercase on Str# .string ;          uppercase on Str# .string ;
Line 188 
Line 214 
   
 : MyBranch      ( a-addr -- a-addr a-addr2 )  : MyBranch      ( a-addr -- a-addr a-addr2 )
 \ finds branch table entry for branch at a-addr  \ finds branch table entry for branch at a-addr
                 dup @ over +                  dup @
                 BranchAddr?                  BranchAddr?
                 BEGIN                  BEGIN
                 WHILE 1 cells - @                  WHILE 1 cells - @
                       over <>                        over <>
                 WHILE dup @ over +                  WHILE dup @
                       MoreBranchAddr?                        MoreBranchAddr?
                 REPEAT                  REPEAT
                 SearchPointer @ 3 cells -                  SearchPointer @ 3 cells -
Line 231 
Line 257 
         BranchPointer @ 1 cells - ! ;          BranchPointer @ 1 cells - ! ;
   
 : Branch! ( a-addr rel -- a-addr )  : Branch! ( a-addr rel -- a-addr )
         over + over ,Branch ,Branch 0 ,Branch ;      over ,Branch ,Branch 0 ,Branch ;
   \        over + over ,Branch ,Branch 0 ,Branch ;
   
 \ DEFER CheckUntil  \ DEFER CheckUntil
 VARIABLE NoOutput  VARIABLE NoOutput
Line 245 
Line 272 
 : Display? ( -- flag ) C-Pass @ 1 = ;  : Display? ( -- flag ) C-Pass @ 1 = ;
 : Debug? ( -- flag ) C-Pass @ 2 = ;  : Debug? ( -- flag ) C-Pass @ 2 = ;
   
 : back? ( n -- flag ) 0< ;  : back? ( addr target -- addr flag )
 : ahead? ( n -- flag ) 0> ;      over u< ;
   
 : .word ( addr xt -- addr )  : .word ( addr xt -- addr )
     look 0= IF      look 0= IF
Line 300 
Line 327 
     cell+ ;      cell+ ;
   
 : .name-without ( addr -- addr )  : .name-without ( addr -- addr )
 \ prints a name without () e.g. (+LOOP) or (s")  \ prints a name without a() e.g. a(+LOOP) or (s")
   dup 1 cells - @ look      dup 1 cells - @ look IF
   IF   name>string over c@ '( = IF 1 /string THEN          name>string over c@ 'a = IF
               1 /string
           THEN
            over c@ '( = IF
               1 /string
           THEN
        2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop         2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
   THEN ;    THEN ;
   
   [ifdef] (s")
 : c-c"  : c-c"
         Display? IF nl .name-without THEN          Display? IF nl .name-without THEN
         count 2dup + aligned -rot          count 2dup + aligned -rot
Line 314 
Line 347 
                 [char] " cemit bl cemit                  [char] " cemit bl cemit
         ELSE    2drop          ELSE    2drop
         THEN ;          THEN ;
   [endif]
   
   : c-string? ( addr1 -- addr2 f )
       \ f is true if a string was found and decompiled.
       \ if f is false, addr2=addr1
       \ recognizes the following patterns:
       \ c":     ahead X: len string then lit X
       \ s\":    ahead X: string then lit X lit len
       \ .\":    ahead X: string then lit X lit len type
       \ !! not recognized anywhere:
       \ abort": if ahead X: len string then lit X c(abort") then
       dup @ back? if false exit endif
       dup @ >r
       r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif
       r@ cell+ @ over cell+ <> if rdrop false exit endif
       \ we have at least C"
       r@ 2 cells + @ decompile-prim ['] lit xt>threaded = if
           r@ 3 cells + @ over cell+ + aligned r@ = if
               \ we have at least s"
               r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded =
               r@ 5 cells + @ ['] type >body = and if
                   6 s\" .\\\" "
               else
                   4 s\" s\\\" "
               endif
               \ !! make newline if string too long?
               display? if
                   0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit
               else
                   2drop
               endif
               nip cells r> + true exit
           endif
       endif
       \ !! check if count matches space?
       display? if
           s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit
       endif
       drop r> 2 cells + true ;
   
 : Forward? ( a-addr true | false -- a-addr true | false )  : Forward? ( a-addr true | false -- a-addr true | false )
 \ a-addr1 is pointer into branch table      \ a-addr is pointer into branch table
 \ returns true when jump is a forward jump  \ returns true when jump is a forward jump
         IF      dup dup @ swap 1 cells - @ -      IF
                 Ahead? IF true ELSE drop false THEN          dup dup @ swap 1 cells - @ u> IF
               true
           ELSE
               drop false
           THEN
                 \ only if forward jump                  \ only if forward jump
         ELSE    false THEN ;      ELSE
           false
       THEN ;
   
 : RepeatCheck ( a-addr1 a-addr2 true | false -- false )  : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
         IF  BEGIN  2dup          IF  BEGIN  2dup
                    1 cells - @ swap dup @ +                     1 cells - @ swap @
                    u<=                     u<=
             WHILE  drop dup cell+              WHILE  drop dup cell+
                    MoreBranchAddr? 0=                     MoreBranchAddr? 0=
Line 336 
Line 413 
         ELSE false          ELSE false
         THEN ;          THEN ;
   
 : c-branch  : c-branch ( addr1 -- addr2 )
       c-string? ?exit
         Scan?          Scan?
         IF      dup @ Branch!          IF      dup @ Branch!
                 dup @ back?                  dup @ back?
Line 430 
Line 508 
 : c-do  : c-do
         Display? IF nl .name-without level+ THEN ;          Display? IF nl .name-without level+ THEN ;
   
 : c-?do  : c-?do ( addr1 -- addr2 )
         Display? IF nl S" ?DO" .struc level+ THEN      Display? IF
           nl .name-without level+
       THEN
         DebugBranch cell+ ;          DebugBranch cell+ ;
   
 : c-exit  dup 1 cells -  : c-exit  dup 1 cells -
Line 481 
Line 561 
 [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]  [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]
 [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]  [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
                 ' (do) A,           ' c-do A,                  ' (do) A,           ' c-do A,
 [IFDEF] (+do)   ' (+do) A,          ' c-do A, [THEN]  [IFDEF] (+do)   ' a(+do) A,         ' c-?do A, [THEN]
 [IFDEF] (u+do)  ' (u+do) A,         ' c-do A, [THEN]  [IFDEF] (u+do)  ' a(u+do) A,        ' c-?do A, [THEN]
 [IFDEF] (-do)   ' (-do) A,          ' c-do A, [THEN]  [IFDEF] (-do)   ' a(-do) A,         ' c-?do A, [THEN]
 [IFDEF] (u-do)  ' (u-do) A,         ' c-do A, [THEN]  [IFDEF] (u-do)  ' a(u-do) A,        ' c-?do A, [THEN]
                 ' (?do) A,          ' c-?do A,                  ' a(?do) A,         ' c-?do A,
                 ' (for) A,          ' c-for A,                  ' (for) A,          ' c-for A,
                 ' ?branch A,        ' c-?branch A,                  ' a?branch A,       ' c-?branch A,
                 ' branch A,         ' c-branch A,                  ' abranch A,        ' c-branch A,
                 ' (loop) A,         ' c-loop A,                  ' a(loop) A,        ' c-loop A,
                 ' (+loop) A,        ' c-loop A,                  ' a(+loop) A,       ' c-loop A,
 [IFDEF] (s+loop) ' (s+loop) A,       ' c-loop A, [THEN]  [IFDEF] (s+loop) ' a(s+loop) A,     ' c-loop A, [THEN]
 [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]  [IFDEF] (-loop) ' a(-loop) A,       ' c-loop A, [THEN]
                 ' (next) A,         ' c-loop A,                  ' a(next) A,        ' c-loop A,
                 ' ;s A,             ' c-exit A,                  ' ;s A,             ' c-exit A,
 [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]  [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
 \ only defined if compiler is loaded  \ only defined if compiler is loaded

Generate output suitable for use with a patch program
Legend:
Removed from v.1.44  
changed lines
  Added in v.1.45
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help