Diff for /gforth/see.fs between versions 1.2 and 1.75

version 1.2, 1994/05/03 19:10:36 version 1.75, 2010/09/12 17:10:04
Line 1 Line 1
 \ SEE.FS       highend SEE for ANSforth                16may93jaw  \ SEE.FS       highend SEE for ANSforth                16may93jaw
   
   \ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation, either version 3
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program. If not, see http://www.gnu.org/licenses/.
   
   
 \ May be cross-compiled  \ May be cross-compiled
   
 \ I'm sorry. This is really not "forthy" enough.  \ I'm sorry. This is really not "forthy" enough.
   
 \ Ideas:        Level should be a stack  \ Ideas:        Level should be a stack
   
   require look.fs
   require termsize.fs
   require wordinfo.fs
   
 decimal  decimal
   
 \ Screen format words                                   16may93jaw  \ Screen format words                                   16may93jaw
Line 29  VARIABLE Level Line 51  VARIABLE Level
 : level-        -7 Level +! ;  : level-        -7 Level +! ;
   
 VARIABLE nlflag  VARIABLE nlflag
   VARIABLE uppercase      \ structure words are in uppercase
   
 DEFER nlcount ' noop IS nlcount  DEFER nlcount ' noop IS nlcount
   
 : 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 80 XPos @ - spaces                  IF C-Clearline @ IF cols XPos @ - spaces
                                  ELSE cr THEN                                   ELSE cr THEN
                 1 YPos +! 0 XPos !                  1 YPos +! 0 XPos !
                 Level @ spaces                  Level @ spaces
Line 45  DEFER nlcount ' noop IS nlcount Line 68  DEFER nlcount ' noop IS nlcount
   
 : warp?         ( len -- len )  : warp?         ( len -- len )
                 nlflag @ IF (nl) nlflag off THEN                  nlflag @ IF (nl) nlflag off THEN
                 XPos @ over + 79 u> IF (nl) THEN ;                  XPos @ over + cols u>= IF (nl) THEN ;
   
 : ctype         ( adr len -- )  : ctype         ( adr len -- )
                 warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;                  warp? dup XPos +! C-Output @ 
                   IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP
                                     uppercase off ELSE type THEN
                   ELSE 2drop THEN ;
   
 : cemit         1 warp?  : cemit         1 warp?
                 over bl = Level @ XPos @ = and                  over bl = Level @ XPos @ = and
                 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 xt-see-xt ( xt -- )
   \ this one is just a forward declaration for indirect recursion
   
   : .defname ( xt c-addr u -- )
       rot look
       if ( c-addr u nfa )
           -rot type space .name
       else
           drop ." noname " type
       then
       space ;
   
   Defer discode ( addr u -- ) \ gforth
   \G hook for the disassembler: disassemble u bytes of code at addr
   ' dump IS discode
   
   : next-head ( addr1 -- addr2 ) \ gforth
       \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 ;
   
   [ifundef] umin \ !! bootstrapping help
   : umin ( u1 u2 -- u )
       2dup u>
       if
           swap
       then
       drop ;
   [then]
   
   : 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> + ;
   
   DEFER .string ( c-addr u n -- )
   
 [IFDEF] Green  [IFDEF] Green
 VARIABLE Colors Colors on  VARIABLE Colors Colors on
Line 76  VARIABLE Colors Colors on Line 154  VARIABLE Colors Colors on
   
 ' (.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
                           restore
                               r@ base !
                           endtry
                           rdrop throw
                       endif
                   endif
                   1 /string
               endif
       repeat
       2drop ;
   
 : .struc        Str# .string ;  : .struc        
           uppercase on Str# .string ;
   
 \ CODES                                                 15may93jaw  \ CODES (Branchtypes)                                    15may93jaw
   
 21 CONSTANT RepeatCode  21 CONSTANT RepeatCode
 22 CONSTANT AgainCode  22 CONSTANT AgainCode
Line 89  VARIABLE Colors Colors on Line 195  VARIABLE Colors Colors on
 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 132  ACONSTANT MaxTable Line 247  ACONSTANT MaxTable
         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 163  ACONSTANT MaxTable Line 292  ACONSTANT MaxTable
         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 176  VARIABLE C-Pass Line 306  VARIABLE C-Pass
 : Scan? ( -- flag ) C-Pass @ 0= ;  : Scan? ( -- flag ) C-Pass @ 0= ;
 : Display? ( -- flag ) C-Pass @ 1 = ;  : Display? ( -- flag ) C-Pass @ 1 = ;
 : Debug? ( -- flag ) C-Pass @ 2 = ;  : Debug? ( -- flag ) C-Pass @ 2 = ;
   : ?.string  ( c-addr u n -- )   Display? if .string else 2drop drop then ;
   
 : back? ( n -- flag ) 0< ;  : back? ( addr target -- addr flag )
 : ahead? ( n -- flag ) 0> ;      over u< ;
   
 : c-(compile)  
         Display? IF s" POSTPONE " Com# .string  
                     dup @ look 0= ABORT" SEE: No valid XT"  
                     cell+ count $1F and 0 .string bl cemit  
                  THEN  
         cell+ ;  
   
 : c-lit  
         Display? IF dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN  
         cell+ ;  
   
 : c-s"  : .word ( addr x -- addr )
         count 2dup + aligned -rot      \ print x as a word if possible
         Display?      dup look 0= IF
         IF      [char] S cemit [char] " cemit bl cemit 0 .string          drop dup threaded>name dup 0= if
                 [char] " cemit bl cemit              drop over 1 cells - @ dup body> look
         ELSE    2drop              IF
         THEN ;                  nip nip dup ." <" name>string rot wordinfo .string ." > "
               ELSE
                   2drop ." <" 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
       cell+ ;
   
   : c-callxt ( addr1 -- addr2 )
       Display? IF
           dup @ .word bl cemit
       THEN
       cell+ ;
   
   \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
   \ here over - 2constant doers
   
   [IFDEF] !does
   : c-does>               \ end of create part
           Display? IF S" DOES> " Com# .string THEN ;
   \       maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff
   [THEN]
   
 : c-."  : c-lit ( addr1 -- addr2 )
         count 2dup + aligned -rot      dup @ dup body> dup cfaligned over = swap in-dictionary? and if
         Display?          ( addr1 addr1@ )
         IF      [char] . cemit          dup body> @ dovar: = if
                 [char] " cemit bl cemit 0 .string              drop c-call EXIT
                 [char] " cemit bl cemit          endif
         ELSE    2drop      endif
         THEN ;      over 4 cells + over = if
           over 1 cells + @ decompile-prim ['] call xt>threaded = >r
           over 3 cells + @ decompile-prim ['] ;S xt>threaded =
           r> and if
               over 2 cells + @ ['] !does >body = if  drop
                   S" DOES> " Com# ?.string 4 cells + EXIT endif
           endif
           [IFDEF] !;abi-code
               over 2 cells + @ ['] !;abi-code >body = if  drop
                   S" ;abi-code " Com# ?.string   4 cells +
                   c-stop on
                   Display? if
                       dup   dup  next-head   over - discode 
                       S" end-code" Com# ?.string 
                   then   EXIT
               endif
           [THEN]
       endif
       Display? if
           \ !! test for cfa here, and print "['] ..."
           dup abs 0 <# #S rot sign #> 0 .string bl cemit
       else  drop  then
       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 ;
   
   [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 )
       \ 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
       \ 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
       ELSE
           false
       THEN ;
   
 : Forward? ( a-addr true | false -- )  : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
         IF      dup dup @ swap 1 cells - @ -  
                 Ahead? IF true ELSE drop false THEN  
                 \ only if forward jump  
         ELSE    false THEN ;  
   
 : RepeatCheck  
         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 235  VARIABLE C-Pass Line 485  VARIABLE C-Pass
         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 262  VARIABLE C-Pass Line 513  VARIABLE C-Pass
                         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      dup cell+ @ WhileCode2 =                          IF      S" LEAVE " .struc
                                 IF nl S" ELSE" .struc level+                          ELSE
                                 ELSE level- nl S" ELSE" .struc level+ THEN                                  dup cell+ BranchAddr? Forward?
                                 cell+ Disable swap !                                  IF      dup cell+ @ WhileCode2 =
                         ELSE    S" AHEAD" .struc level+                                          IF nl S" ELSE " .struc level+
                         THEN                                          ELSE level- nl S" ELSE" .struc level+ THEN
                                           cell+ Disable swap !
                                   ELSE    S" AHEAD " .struc level+
                                   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 309  VARIABLE C-Pass Line 551  VARIABLE C-Pass
                                          IF WhileCode2 swap !                                           IF WhileCode2 swap !
                                          ELSE drop THEN                                           ELSE drop THEN
                                 level- nl                                  level- nl
                                 S" WHILE" .struc                                  S" WHILE " .struc
                                 level+                                  level+
                         ELSE    nl S" IF" .struc level+                          ELSE    MyBranch cell+ @ LeaveCode =
                                   IF   s" 0= ?LEAVE " .struc
                                   ELSE nl S" IF " .struc level+
                                   THEN
                         THEN                          THEN
                 THEN                  THEN
         THEN          THEN
         DebugBranch          DebugBranch
         cell+ ;          cell+ ;
   
 : c-do  
         Display? IF nl S" DO" .struc level+ THEN ;  
   
 : c-?do  
         Display? IF nl S" ?DO" .struc level+ THEN  
         DebugBranch cell+ ;  
   
 : c-for  : c-for
         Display? IF nl S" FOR" .struc level+ THEN ;          Display? IF nl S" FOR" .struc level+ THEN ;
   
 : c-next  
         Display? IF level- nl S" NEXT " .struc nl THEN  
         DebugBranch cell+ cell+ ;  
   
 : c-loop  : c-loop
         Display? IF level- nl S" LOOP " .struc 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
           Display? IF nl .name-without level+ THEN ;
   
 : c-+loop  : c-?do ( addr1 -- addr2 )
         Display? IF level- nl S" +LOOP " .struc nl THEN      Display? IF
         DebugBranch cell+ cell+ ;          nl .name-without level+
       THEN
 : c-leave      DebugBranch cell+ ;
         Display? IF S" LEAVE " .struc THEN  
         Debug? IF dup @ + THEN cell+ ;  : c-exit ( addr1 -- addr2 )
       dup 1 cells -
 : c-?leave      CheckEnd
         Display? IF S" ?LEAVE " .struc THEN      IF
         cell+ DebugBranch swap cell+ swap cell+ ;          Display? IF nlflag off S" ;" Com# .string THEN
           C-Stop on
 : c-exit  dup 1 cells -      ELSE
         CheckEnd          Display? IF S" EXIT " .struc THEN
         IF      Display? IF nlflag off S" ;" Com# .string THEN      THEN
                 C-Stop on      Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!
         ELSE    Display? IF S" EXIT " .struc THEN  
         THEN  
         Debug? IF drop THEN ;  
   
 : c-;code               \ 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 370  VARIABLE C-Pass Line 606  VARIABLE C-Pass
         ELSE    2drop          ELSE    2drop
         THEN ;          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]
         ' ?branch A,     ' c-?branch A,  \               ' useraddr A,       ....
         ' branch A,      ' c-branch A,                  ' lit-perform A,    ' c-call A,
         ' leave A,       ' c-leave A,                  ' lit+ A,           ' c-lit+ A,
         ' ?leave A,      ' c-?leave A,  [IFDEF] (s")    ' (s") A,           ' c-c" A, [THEN]
         ' (do) A,        ' c-do A,  [IFDEF] (.")    ' (.") A,           ' c-c" A, [THEN]
         ' (?do) A,       ' c-?do A,  [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]
         ' (for) A,       ' c-for A,  [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
         ' (loop) A,      ' c-loop A,                  ' (do) A,           ' c-do A,
         ' (+loop) A,     ' c-+loop A,  [IFDEF] (+do)   ' (+do) A,          ' c-?do A, [THEN]
         ' (next) A,      ' c-next A,  [IFDEF] (u+do)  ' (u+do) A,         ' c-?do A, [THEN]
         ' ;s A,          ' c-exit A,  [IFDEF] (-do)   ' (-do) A,          ' c-?do A, [THEN]
         ' (;code) A,     ' c-;code A,  [IFDEF] (u-do)  ' (u-do) A,         ' c-?do A, [THEN]
         ' (abort") A,    ' c-abort" A,                  ' (?do) A,          ' c-?do A,
         ' (compile) A,   ' c-(compile) A,                  ' (for) A,          ' c-for A,
         0 ,                  ' ?branch A,        ' c-?branch A,
                   ' branch A,         ' c-branch A,
                   ' (loop) A,         ' c-loop A,
                   ' (+loop) A,        ' c-loop A,
   [IFDEF] (s+loop) ' (s+loop) A,      ' c-loop A, [THEN]
   [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
                   ' (next) A,         ' c-loop A,
                   ' ;s A,             ' c-exit A,
   [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
   \ only defined if compiler is loaded
   [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
                   0 ,             here 0 ,
   
   avariable c-extender
   c-extender !
   
 \ DOTABLE                                               15may93jaw  \ DOTABLE                                               15may93jaw
   
 : DoTable ( cfa -- flag )  : DoTable ( ca/cfa -- flag )
         C-Table      decompile-prim C-Table BEGIN ( cfa table-entry )
         BEGIN   dup @ dup          dup @ dup 0=  IF
         WHILE   2 pick <>              drop cell+ @ dup IF ( next table!)
         WHILE   2 cells +                  dup @
         REPEAT              ELSE ( end!)
         nip cell+ @ EXECUTE                  2drop false EXIT
         true              THEN 
         ELSE          THEN
         2drop drop false          \ jump over to extender, if any 26jan97jaw
         THEN ;          xt>threaded 2 pick <>
       WHILE
               2 cells +
       REPEAT
       nip cell+ perform
       true
   ;
   
 : BranchTo? ( a-addr -- a-addr )  : BranchTo? ( a-addr -- a-addr )
         Display?  IF     dup BranchAddr?          Display?  IF    dup BranchAddr?
                         IF BEGIN cell+ @ dup 20 u>                          IF
                                   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 423  CREATE C-Table Line 690  CREATE C-Table
                   THEN ;                    THEN ;
   
 : analyse ( a-addr1 -- a-addr2 )  : analyse ( a-addr1 -- a-addr2 )
         Branches @ IF BranchTo? THEN      Branches @ IF BranchTo? THEN
         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= ABORT" SEE: Bua!"      IF
            cell+ dup count 31 and rot wordinfo .string bl cemit          .word bl cemit
         ELSE drop      ELSE
         THEN ;          drop
       THEN ;
   
 : c-init  : c-init
         0 YPos ! 0 XPos !          0 YPos ! 0 XPos !
Line 440  CREATE C-Table Line 708  CREATE C-Table
         Branches on ;          Branches on ;
   
 : makepass ( a-addr -- )  : makepass ( a-addr -- )
         c-stop off      c-stop off
         BEGIN      BEGIN
                 analyse          analyse
                 c-stop @          c-stop @
         UNTIL drop ;      UNTIL drop ;
   
 DEFER dosee  : seecode ( xt -- )
       dup s" Code" .defname
 : dopri .name ." is primitive" cr ;      >code-address
 : dovar .name ." is variable" cr ;      dup in-dictionary? \ user-defined code word?
 : docon  dup .name ." is constant, value: "      if
          cell+ (name>) >body @ . cr ;          dup next-head
 : doval .name ." is value" cr ;      else
 : dodef .name ." is defered word, is: "          dup next-prim
          here @ look 0= ABORT" SEE: No valid xt in defered word"      then
         .name cr here @ look drop dosee ;      over - discode
 : dodoe .name ." is created word" cr      ." end-code" cr ;
         S" DOES> " Com# .string XPos @ Level !  : seeabicode ( xt -- )
         here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN      dup s" ABI-Code" .defname
         ScanMode c-pass ! dup makepass      >body dup dup next-head 
         DisplayMode c-pass ! makepass ;      swap - discode
 : doali .name ." is alias of "      ." end-code" cr ;
         here @ .name cr  : seevar ( xt -- )
         here @ dosee ;      s" Variable" .defname cr ;
 : docol S" : " Com# .string  : seeuser ( xt -- )
         cell+ dup count $1F and 2 pick wordinfo .string bl cemit bl cemit      s" User" .defname cr ;
         ( XPos @ ) 2 Level !  : seecon ( xt -- )
         name> >body      dup >body ?
         C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN      s" Constant" .defname cr ;
         ScanMode c-pass ! dup makepass  : seevalue ( xt -- )
         DisplayMode c-pass ! makepass ;      dup >body ?
       s" Value" .defname cr ;
 create wordtypes  : seedefer ( xt -- )
         Pri# ,   ' dopri A,      dup >body @ xt-see-xt cr
         Var# ,   ' dovar A,      dup s" Defer" .defname cr
         Con# ,   ' docon A,      >name ?dup-if
         Val# ,   ' doval A,          ." IS " .name cr
         Def# ,   ' dodef A,      else
         Doe# ,   ' dodoe A,          ." latestxt >body !"
         Ali# ,   ' doali A,      then ;
         Col# ,   ' docol A,  : see-threaded ( addr -- )
         0 ,      C-Pass @ DebugMode = IF
           ScanMode c-pass !
 : (dosee) ( lfa -- )          EXIT
         dup cell+ dup c@ 32 and IF over .name ." is an immediate word" cr THEN      THEN
         wordinfo      ScanMode c-pass ! dup makepass
         wordtypes      DisplayMode c-pass ! makepass ;
         BEGIN dup @ dup  : seedoes ( xt -- )
         WHILE 2 pick = IF cell+ @ nip EXECUTE EXIT THEN      dup s" create" .defname cr
               2 cells +      S" DOES> " Com# .string XPos @ Level !
         REPEAT      >does-code see-threaded ;
         2drop  : seecol ( xt -- )
         .name ." Don't know how to handle" cr ;      dup s" :" .defname nl
       2 Level !
 ' (dosee) IS dosee      >body see-threaded ;
   : seefield ( xt -- )
 : see   name find cr 0= IF ." Word unknown" cr drop exit THEN      dup >body ." 0 " ? ." 0 0 "
         >name c-init      s" Field" .defname cr ;
         dosee ;  
   : xt-see ( xt -- ) \ gforth
 : xtc ( xt -- )       \ do see at xt      \G Decompile the definition represented by @i{xt}.
         Look 0= ABORT" SEE: No valid XT"      cr c-init
         cr c-init      dup >does-code
         dosee ;      if
           seedoes EXIT
 : lfc   cr c-init cell+ dosee ;      then
 : nfc   cr c-init dosee ;      dup xtprim?
       if
           seecode EXIT
       then
       dup >code-address
       CASE
           docon: of seecon endof
   [IFDEF] dovalue:
           dovalue: of seevalue endof
   [THEN]
           docol: of seecol endof
           dovar: of seevar endof
   [IFDEF] douser:
           douser: of seeuser endof
   [THEN]
   [IFDEF] dodefer:
           dodefer: of seedefer endof
   [THEN]
   [IFDEF] dofield:
           dofield: of seefield endof
   [THEN]
   [IFDEF] doabicode:
           doabicode: of seeabicode endof
   [THEN]
           over       of seecode endof \ direct threaded code words
           over >body of seecode endof \ indirect threaded code words
           2drop abort" unknown word type"
       ENDCASE ;
   
   : (xt-see-xt) ( xt -- )
       xt-see cr ." latestxt" ;
   ' (xt-see-xt) is xt-see-xt
   
   : (.immediate) ( xt -- )
       ['] execute = if
           ."  immediate"
       then ;
   
   : name-see ( nfa -- )
       dup name>int >r
       dup name>comp 
       over r@ =
       if \ normal or immediate word
           swap xt-see (.immediate)
       else
           r@ ['] ticking-compile-only-error =
           if \ compile-only word
               swap xt-see (.immediate) ."  compile-only"
           else \ interpret/compile word
               r@ xt-see-xt cr
               swap xt-see-xt cr
               ." interpret/compile: " over .name drop
           then
       then
       rdrop drop ;
   
   : 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=
       IF
           drop -&13 throw
       THEN
       name-see ;
   
   

Removed from v.1.2  
changed lines
  Added in v.1.75


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>