[gforth] / gforth / see.fs  

gforth: gforth/see.fs

Diff for /gforth/see.fs between version 1.16 and 1.54

version 1.16, Wed May 21 20:39:39 1997 UTC version 1.54, Sat Jun 19 15:32:31 2004 UTC
Line 1 
Line 1 
 \ SEE.FS       highend SEE for ANSforth                16may93jaw  \ SEE.FS       highend SEE for ANSforth                16may93jaw
   
 \ Copyright (C) 1995 Free Software Foundation, Inc.  \ Copyright (C) 1995,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ May be cross-compiled  \ May be cross-compiled
Line 25 
Line 25 
   
 \ Ideas:        Level should be a stack  \ Ideas:        Level should be a stack
   
   require look.fs
 require termsize.fs  require termsize.fs
   require wordinfo.fs
   
 decimal  decimal
   
Line 56 
Line 58 
   
 : nl            nlflag on ;  : nl            nlflag on ;
 : (nl)          nlcount  : (nl)          nlcount
                 XPos @ Level @ = ?Exit                  XPos @ Level @ = IF EXIT THEN \ ?Exit
                 C-Formated @ IF                  C-Formated @ IF
                 C-Output @                  C-Output @
                 IF C-Clearline @ IF cols XPos @ - spaces                  IF C-Clearline @ IF cols XPos @ - spaces
Line 69 
Line 71 
                 nlflag @ IF (nl) nlflag off THEN                  nlflag @ IF (nl) nlflag off THEN
                 XPos @ over + cols u>= IF (nl) THEN ;                  XPos @ over + cols u>= IF (nl) THEN ;
   
 : c-to-upper  : c-to-upper ( c1 -- c2 ) \ gforth
       \ nac05feb1999 there is a primitive, toupper, with this function
   dup [char] a >= over [char] z <= and if  bl -  then ;    dup [char] a >= over [char] z <= and if  bl -  then ;
   
 : ctype         ( adr len -- )  : ctype         ( adr len -- )
Line 83 
Line 86 
                 IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN                  IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
                 THEN ;                  THEN ;
   
 DEFER .string  DEFER .string ( c-addr u n -- )
   
 [IFDEF] Green  [IFDEF] Green
 VARIABLE Colors Colors on  VARIABLE Colors Colors on
Line 104 
Line 107 
   
 ' (.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 ;
   
 \ CODES                                                 15may93jaw  \ CODES (Branchtypes)                                    15may93jaw
   
 21 CONSTANT RepeatCode  21 CONSTANT RepeatCode
 22 CONSTANT AgainCode  22 CONSTANT AgainCode
Line 118 
Line 147 
 11 CONSTANT AheadCode  11 CONSTANT AheadCode
 13 CONSTANT WhileCode2  13 CONSTANT WhileCode2
 14 CONSTANT Disable  14 CONSTANT Disable
   15 CONSTANT LeaveCode
   
   
 \ FORMAT WORDS                                          13jun93jaw  \ FORMAT WORDS                                          13jun93jaw
   
 VARIABLE C-Stop  VARIABLE C-Stop
 VARIABLE Branches  VARIABLE Branches
   
 VARIABLE BranchPointer  VARIABLE BranchPointer  \ point to the end of branch table
 VARIABLE SearchPointer  VARIABLE SearchPointer
 CREATE BranchTable 500 allot  
   \ The branchtable consists of three entrys:
   \ address of branch , branch destination , branch type
   
   CREATE BranchTable 128 cells allot
 here 3 cells -  here 3 cells -
 ACONSTANT MaxTable  ACONSTANT MaxTable
   
 : FirstBranch BranchTable cell+ SearchPointer ! ;  : FirstBranch BranchTable cell+ SearchPointer ! ;
   
 : (BranchAddr?) ( a-addr -- a-addr true | false )  : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
   \ searches a branch with destination a-addr1
   \ a-addr1: branch destination
   \ a-addr2: pointer in branch table
         SearchPointer @          SearchPointer @
         BEGIN   dup BranchPointer @ u<          BEGIN   dup BranchPointer @ u<
         WHILE          WHILE
Line 161 
Line 199 
         2drop true          2drop true
         THEN ;          THEN ;
   
   : MyBranch      ( a-addr -- a-addr a-addr2 )
   \ finds branch table entry for branch at a-addr
                   dup @
                   BranchAddr?
                   BEGIN
                   WHILE 1 cells - @
                         over <>
                   WHILE dup @
                         MoreBranchAddr?
                   REPEAT
                   SearchPointer @ 3 cells -
                   ELSE    true ABORT" SEE: Table failure"
                   THEN ;
   
 \  \
 \                 addrw               addrt  \                 addrw               addrt
 \       BEGIN ... WHILE ... AGAIN ... THEN  \       BEGIN ... WHILE ... AGAIN ... THEN
Line 192 
Line 244 
         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 206 
Line 259 
 : 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< ;
   
 : c-(compile)  : .word ( addr x -- addr )
     Display?      \ print x as a word if possible
       dup look 0= IF
           drop dup threaded>name dup 0= if
               2drop dup 1 cells - @ dup body> look
     IF      IF
         s" POSTPONE " Com# .string                  nip dup ." <" name>string rot wordinfo .string ." > "
         dup @ look 0= ABORT" SEE: No valid XT"              ELSE
         name>string 0 .string bl cemit                  drop ." <" 0 .r ." > "
               THEN
               EXIT
           then
       THEN
       nip dup cell+ @ immediate-mask and
       IF
           bl cemit  ." POSTPONE "
       THEN
       dup name>string rot wordinfo .string
       ;
   
   : c-call ( addr1 -- addr2 )
       Display? IF
           dup @ body> .word bl cemit
     THEN      THEN
     cell+ ;      cell+ ;
   
 : c-lit  : c-callxt ( addr1 -- addr2 )
     Display? IF      Display? IF
         dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit          dup @ .word bl cemit
     THEN      THEN
     cell+ ;      cell+ ;
   
 : c-s"  \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
         count 2dup + aligned -rot  \ here over - 2constant doers
         Display?  
         IF      [char] S cemit [char] " cemit bl cemit 0 .string  
                 [char] " cemit bl cemit  
         ELSE    2drop  
         THEN ;  
   
 : c-."  : c-lit ( addr1 -- addr2 )
         count 2dup + aligned -rot      Display? IF
         Display?          dup @ dup body> dup cfaligned over = swap in-dictionary? and if
         IF      [char] . cemit              ( addr1 addr1@ )
                 [char] " cemit bl cemit 0 .string              dup body> @ dovar: = if
                 [char] " cemit bl cemit                  drop c-call EXIT
         ELSE    2drop              endif
           endif
           \ !! test for cfa here, and print "['] ..."
           dup abs 0 <# #S rot sign #> 0 .string bl cemit
       endif
       cell+ ;
   
   : c-lit+ ( addr1 -- addr2 )
       Display? if
           dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
           s" + " 0 .string
       endif
       cell+ ;
   
   : .name-without ( addr -- addr )
       \ !! the stack effect cannot be correct
       \ prints a name without a() e.g. a(+LOOP) or (s")
       dup 1 cells - @ threaded>name dup IF
           name>string over c@ 'a = IF
               1 /string
           THEN
            over c@ '( = IF
               1 /string
           THEN
           2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
         THEN ;          THEN ;
   
   [ifdef] (s")
 : c-c"  : c-c"
           Display? IF nl .name-without THEN
         count 2dup + aligned -rot          count 2dup + aligned -rot
         Display?          Display?
         IF      [char] C cemit [char] " cemit bl cemit 0 .string          IF      bl cemit 0 .string
                 [char] " cemit bl cemit                  [char] " cemit bl cemit
         ELSE    2drop          ELSE    2drop
         THEN ;          THEN ;
   [endif]
   
   : c-string? ( addr1 -- addr2 f )
 : Forward? ( a-addr true | false -- )      \ f is true if a string was found and decompiled.
         IF      dup dup @ swap 1 cells - @ -      \ if f is false, addr2=addr1
                 Ahead? IF true ELSE drop false THEN      \ recognizes the following patterns:
       \ c":     ahead X: len string then lit X
       \ flit:   ahead X: float      then lit X f@
       \ 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 dup ['] lit xt>threaded = if
           drop 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
       ['] f@ xt>threaded = if
           display? if
               r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit
           endif
           drop r> 3 cells + true exit
       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 )
       \ a-addr is pointer into branch table
       \ returns true when jump is a forward jump
       IF
           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  : 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 268 
Line 412 
         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 295 
Line 440 
                         IF      drop S" REPEAT " .struc nl                          IF      drop S" REPEAT " .struc nl
                         ELSE    S" AGAIN " .struc nl                          ELSE    S" AGAIN " .struc nl
                         THEN                          THEN
                 ELSE    dup cell+ BranchAddr? Forward?                  ELSE    MyBranch cell+ @ LeaveCode =
                           IF      S" LEAVE " .struc
                           ELSE
                                   dup cell+ BranchAddr? Forward?
                         IF      dup cell+ @ WhileCode2 =                          IF      dup cell+ @ WhileCode2 =
                                 IF nl S" ELSE" .struc level+                                  IF nl S" ELSE" .struc level+
                                 ELSE level- nl S" ELSE" .struc level+ THEN                                  ELSE level- nl S" ELSE" .struc level+ THEN
Line 304 
Line 452 
                         THEN                          THEN
                 THEN                  THEN
         THEN          THEN
           THEN
         Debug?          Debug?
         IF      dup @ +          IF      @ \ !!! cross-interacts with debugger !!!
         ELSE    cell+          ELSE    cell+
         THEN ;          THEN ;
   
 : MyBranch      ( a-addr -- a-addr a-addr2 )  
                 dup @ over +  
                 BranchAddr?  
                 BEGIN  
                 WHILE 1 cells - @  
                       over <>  
                 WHILE dup @ over +  
                       MoreBranchAddr?  
                 REPEAT  
                 SearchPointer @ 3 cells -  
                 ELSE    true ABORT" SEE: Table failure"  
                 THEN ;  
   
 : DebugBranch  : DebugBranch
         Debug?          Debug?
         IF      dup @ over + swap THEN ; \ return 2 different addresses          IF      dup @ swap THEN ; \ return 2 different addresses
   
 : c-?branch  : c-?branch
         Scan?          Scan?
Line 344 
Line 480 
                                 level- nl                                  level- nl
                                 S" WHILE " .struc                                  S" WHILE " .struc
                                 level+                                  level+
                           ELSE    MyBranch cell+ @ LeaveCode =
                                   IF   s" 0= ?LEAVE " .struc
                         ELSE    nl S" IF " .struc level+                          ELSE    nl S" IF " .struc level+
                         THEN                          THEN
                 THEN                  THEN
         THEN          THEN
           THEN
         DebugBranch          DebugBranch
         cell+ ;          cell+ ;
   
 : c-for  : c-for
         Display? IF nl S" FOR" .struc level+ THEN ;          Display? IF nl S" FOR" .struc level+ THEN ;
   
 : .name-without  
         dup 1 cells - @ look IF name>string 1 /string 1- .struc ELSE drop THEN ;  
   
 : c-loop  : c-loop
         Display? IF level- nl .name-without bl cemit nl THEN          Display? IF level- nl .name-without nl bl cemit THEN
         DebugBranch cell+ cell+ ;          DebugBranch cell+
           Scan?
           IF      dup BranchAddr?
                   BEGIN   WHILE cell+ LeaveCode swap !
                           dup MoreBranchAddr?
                   REPEAT
           THEN
           cell+ ;
   
 : 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-leave  : c-exit ( addr1 -- addr2 )
         Display? IF S" LEAVE " .struc THEN      dup 1 cells -
         Debug? IF dup @ + THEN cell+ ;  
   
 : c-?leave  
         Display? IF S" ?LEAVE " .struc THEN  
         cell+ DebugBranch swap cell+ swap cell+ ;  
   
 : c-exit  dup 1 cells -  
         CheckEnd          CheckEnd
         IF      Display? IF nlflag off S" ;" Com# .string THEN      IF
           Display? IF nlflag off S" ;" Com# .string THEN
                 C-Stop on                  C-Stop on
         ELSE    Display? IF S" EXIT " .struc THEN      ELSE
           Display? IF S" EXIT " .struc THEN
         THEN          THEN
         Debug? IF drop THEN ;      Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!
   
 : c-does>               \ end of create part  
         Display? IF S" DOES> " Com# .string THEN  
         Cell+ cell+ ;  
   
 : c-abort"  : c-abort"
         count 2dup + aligned -rot          count 2dup + aligned -rot
Line 397 
Line 533 
         ELSE    2drop          ELSE    2drop
         THEN ;          THEN ;
   
   [IFDEF] (does>)
   : c-does>               \ end of create part
           Display? IF S" DOES> " Com# .string THEN
           maxaligned /does-handler + ;
   [THEN]
   
   [IFDEF] (compile)
   : c-(compile)
       Display?
       IF
           s" POSTPONE " Com# .string
           dup @ look 0= ABORT" SEE: No valid XT"
           name>string 0 .string bl cemit
       THEN
       cell+ ;
   [THEN]
   
 CREATE C-Table  CREATE C-Table
         ' lit A,            ' c-lit A,          ' lit A,            ' c-lit A,
         ' (s") A,           ' c-s" A,                  ' does-exec A,      ' c-callxt A,
         ' (.") A,           ' c-." A,                  ' lit@ A,           ' c-call A,
         ' "lit A,           ' c-c" A,  [IFDEF] call    ' call A,           ' c-call A, [THEN]
         comp' leave drop A, ' c-leave A,  \               ' useraddr A,       ....
         comp' ?leave drop A, ' c-?leave A,                  ' lit-perform A,    ' c-call A,
                   ' lit+ A,           ' c-lit+ A,
   [IFDEF] (s")    ' (s") A,           ' c-c" A, [THEN]
   [IFDEF] (.")    ' (.") A,           ' c-c" A, [THEN]
   [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]
   [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
         ' (do) A,           ' c-do A,          ' (do) A,           ' c-do A,
         ' (+do) A,          ' c-do A,  [IFDEF] (+do)   ' (+do) A,          ' c-?do A, [THEN]
         ' (u+do) A,         ' c-do A,  [IFDEF] (u+do)  ' (u+do) A,         ' c-?do A, [THEN]
         ' (-do) A,          ' c-do A,  [IFDEF] (-do)   ' (-do) A,          ' c-?do A, [THEN]
         ' (u-do) A,         ' c-do A,  [IFDEF] (u-do)  ' (u-do) A,         ' c-?do A, [THEN]
         ' (?do) A,          ' c-?do A,          ' (?do) A,          ' c-?do A,
         ' (for) A,          ' c-for A,          ' (for) A,          ' c-for A,
         ' ?branch A,        ' c-?branch A,          ' ?branch A,        ' c-?branch A,
         ' branch A,         ' c-branch A,          ' branch A,         ' c-branch A,
         ' (loop) A,         ' c-loop A,          ' (loop) A,         ' c-loop A,
         ' (+loop) A,        ' c-loop A,          ' (+loop) A,        ' c-loop A,
         ' (s+loop) A,       ' c-loop A,  [IFDEF] (s+loop) ' (s+loop) A,      ' c-loop A, [THEN]
         ' (-loop) A,        ' c-loop A,  [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
         ' (next) A,         ' c-loop A,          ' (next) A,         ' c-loop A,
         ' ;s A,             ' c-exit A,          ' ;s A,             ' c-exit A,
         ' (does>) A,        ' c-does> A,  [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
         ' (abort") A,       ' c-abort" A,  \ only defined if compiler is loaded
         ' (compile) A,      ' c-(compile) A,  [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
   [IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
         0 ,             here 0 ,          0 ,             here 0 ,
   
 avariable c-extender  avariable c-extender
Line 430 
Line 588 
   
 \ DOTABLE                                               15may93jaw  \ DOTABLE                                               15may93jaw
   
 : DoTable ( cfa -- flag )  : DoTable ( ca/cfa -- flag )
         C-Table      decompile-prim C-Table BEGIN ( cfa table-entry )
         BEGIN   dup @ dup 0=          dup @ dup 0=  IF
                 IF drop cell+ @ dup              drop cell+ @ dup IF ( next table!)
                   IF ( next table!) dup @ ELSE                  dup @
                         ( end!) 2drop false EXIT THEN              ELSE ( end!)
                   2drop false EXIT
               THEN
                 THEN                  THEN
                 \ jump over to extender, if any 26jan97jaw                  \ jump over to extender, if any 26jan97jaw
                 2 pick <>          xt>threaded 2 pick <>
         WHILE   2 cells +      WHILE
               2 cells +
         REPEAT          REPEAT
         nip cell+ perform          nip cell+ perform
         true          true
Line 451 
Line 612 
                                 BEGIN cell+ @ dup 20 u>                                  BEGIN cell+ @ dup 20 u>
                                 IF drop nl S" BEGIN " .struc level+                                  IF drop nl S" BEGIN " .struc level+
                                 ELSE                                  ELSE
                                   dup Disable <>                                    dup Disable <> over LeaveCode <> and
                                   IF   WhileCode2 =                                    IF   WhileCode2 =
                                        IF nl S" THEN " .struc nl ELSE                                         IF nl S" THEN " .struc nl ELSE
                                        level- nl S" THEN " .struc nl THEN                                         level- nl S" THEN " .struc nl THEN
Line 467 
Line 628 
         dup cell+ swap @          dup cell+ swap @
         dup >r DoTable r> swap IF drop EXIT THEN          dup >r DoTable r> swap IF drop EXIT THEN
         Display?          Display?
         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"      IF
           .word bl cemit
         ELSE          ELSE
             dup cell+ count dup immediate-mask and          drop
             IF  bl cemit  ." POSTPONE " THEN  
             31 and rot wordinfo .string  THEN  bl cemit  
         ELSE drop  
         THEN ;          THEN ;
   
 : c-init  : c-init
Line 501 
Line 660 
     then      then
     space ;      space ;
   
 Defer discode ( addr -- )  Defer discode ( addr u -- ) \ gforth
 \  hook for the disassembler: disassemble code at addr (as far as the  \G hook for the disassembler: disassemble code at addr of length u
 \  disassembler thinks is sensible)  ' dump IS discode
 :noname ( addr -- )  
     drop ." ..." ;  : next-head ( addr1 -- addr2 ) \ gforth
 IS discode      \G find the next header starting after addr1, up to here (unreliable).
       here swap u+do
           i head? -2 and if
               i unloop exit
           then
       cell +loop
       here ;
   
   : umin ( u1 u2 -- u )
       2dup u>
       if
           swap
       then
       drop ;
   
   : next-prim ( addr1 -- addr2 ) \ gforth
       \G find the next primitive after addr1 (unreliable)
       1+ >r -1 primstart
       begin ( umin head R: boundary )
           @ dup
       while
           tuck name>int >code-address ( head1 umin ca R: boundary )
           r@ - umin
           swap
       repeat
       drop dup r@ negate u>=
       \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
       if ( umin R: boundary ) \ no primitive found behind -> use a default length
           drop 31
       then
       r> + ;
   
 : seecode ( xt -- )  : seecode ( xt -- )
     dup s" Code" .defname      dup s" Code" .defname
     >body discode      >code-address
       dup in-dictionary? \ user-defined code word?
       if
           dup next-head
       else
           dup next-prim
       then
       over - discode
     ."  end-code" cr ;      ."  end-code" cr ;
 : seevar ( xt -- )  : seevar ( xt -- )
     s" Variable" .defname cr ;      s" Variable" .defname cr ;
Line 525 
Line 721 
 : seedefer ( xt -- )  : seedefer ( xt -- )
     dup >body @ xt-see-xt cr      dup >body @ xt-see-xt cr
     dup s" Defer" .defname cr      dup s" Defer" .defname cr
     >name dup ??? = if      >name ?dup-if
         drop ." lastxt >body !"  
     else  
         ." IS " .name cr          ." IS " .name cr
       else
           ." latestxt >body !"
     then ;      then ;
 : see-threaded ( addr -- )  : see-threaded ( addr -- )
     C-Pass @ DebugMode = IF      C-Pass @ DebugMode = IF
Line 549 
Line 745 
     dup >body ." 0 " ? ." 0 0 "      dup >body ." 0 " ? ." 0 0 "
     s" Field" .defname cr ;      s" Field" .defname cr ;
   
 : xt-see ( xt -- )  : xt-see ( xt -- ) \ gforth
       \G Decompile the definition represented by @i{xt}.
     cr c-init      cr c-init
     dup >does-code      dup >does-code
     if      if
         seedoes EXIT          seedoes EXIT
     then      then
     dup forthstart u<      dup xtprim?
     if      if
         seecode EXIT          seecode EXIT
     then      then
Line 564 
Line 761 
         docon: of seecon endof          docon: of seecon endof
         docol: of seecol endof          docol: of seecol endof
         dovar: of seevar endof          dovar: of seevar endof
   [ [IFDEF] douser: ]
         douser: of seeuser endof          douser: of seeuser endof
   [ [THEN] ]
   [ [IFDEF] dodefer: ]
         dodefer: of seedefer endof          dodefer: of seedefer endof
   [ [THEN] ]
   [ [IFDEF] dofield: ]
         dofield: of seefield endof          dofield: of seefield endof
         over >body of seecode endof  [ [THEN] ]
           over       of seecode endof \ direct threaded code words
           over >body of seecode endof \ indirect threaded code words
         2drop abort" unknown word type"          2drop abort" unknown word type"
     ENDCASE ;      ENDCASE ;
   
 : (xt-see-xt) ( xt -- )  : (xt-see-xt) ( xt -- )
     xt-see cr ." lastxt" ;      xt-see cr ." latestxt" ;
 ' (xt-see-xt) is xt-see-xt  ' (xt-see-xt) is xt-see-xt
   
 : (.immediate) ( xt -- )  : (.immediate) ( xt -- )
Line 587 
Line 791 
     if \ normal or immediate word      if \ normal or immediate word
         swap xt-see (.immediate)          swap xt-see (.immediate)
     else      else
         r@ ['] compile-only-error =          r@ ['] ticking-compile-only-error =
         if \ compile-only word          if \ compile-only word
             swap xt-see (.immediate) ."  compile-only"              swap xt-see (.immediate) ."  compile-only"
         else \ interpret/compile word          else \ interpret/compile word
             r@ xt-see-xt cr              r@ xt-see-xt cr
             swap xt-see-xt cr              swap xt-see-xt cr
             ." interpret/compile " over .name (.immediate)              ." interpret/compile: " over .name drop
         then          then
     then      then
     rdrop drop ;      rdrop drop ;
   
 : see ( "name" -- ) \ tools  : see ( "<spaces>name" -- ) \ tools
       \G Locate @var{name} using the current search order. Display the
       \G definition of @var{name}. Since this is achieved by decompiling
       \G the definition, the formatting is mechanised and some source
       \G information (comments, interpreted sequences within definitions
       \G etc.) is lost.
     name find-name dup 0=      name find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 throw
     THEN      THEN
     name-see ;      name-see ;
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help