--- gforth/see.fs	1996/01/07 17:22:14	1.10
+++ gforth/see.fs	2002/12/25 21:16:54	1.44
@@ -1,6 +1,6 @@
 \ SEE.FS       highend SEE for ANSforth                16may93jaw
 
-\ Copyright (C) 1995 Free Software Foundation, Inc.
+\ Copyright (C) 1995,2000 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -16,7 +16,7 @@
 
 \ You should have received a copy of the GNU General Public License
 \ 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
@@ -25,7 +25,22 @@
 
 \ Ideas:        Level should be a stack
 
+require look.fs
 require termsize.fs
+require wordinfo.fs
+[IFUNDEF] .name
+: id. ( nt -- ) \ gforth
+    \G Print the name of the word represented by @var{nt}.
+    \ this name comes from fig-Forth
+    name>string type space ;
+
+' id. alias .id ( nt -- )
+\G F83 name for @code{id.}.
+
+' id. alias .name ( nt -- )
+\G Gforth <=0.5.0 name for @code{id.}.
+
+[THEN]
 
 decimal
 
@@ -50,12 +65,13 @@ VARIABLE Level
 : level-        -7 Level +! ;
 
 VARIABLE nlflag
+VARIABLE uppercase	\ structure words are in uppercase
 
 DEFER nlcount ' noop IS nlcount
 
 : nl            nlflag on ;
 : (nl)          nlcount
-                XPos @ Level @ = ?Exit
+                XPos @ Level @ = IF EXIT THEN \ ?Exit
                 C-Formated @ IF
                 C-Output @
                 IF C-Clearline @ IF cols XPos @ - spaces
@@ -68,15 +84,22 @@ DEFER nlcount ' noop IS nlcount
                 nlflag @ IF (nl) nlflag off THEN
                 XPos @ over + cols u>= IF (nl) THEN ;
 
+: 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 ;
+
 : 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@ c-to-upper emit LOOP
+				  uppercase off ELSE type THEN
+		ELSE 2drop THEN ;
 
 : cemit         1 warp?
                 over bl = Level @ XPos @ = and
                 IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
                 THEN ;
 
-DEFER .string
+DEFER .string ( c-addr u n -- )
 
 [IFDEF] Green
 VARIABLE Colors Colors on
@@ -98,9 +121,10 @@ VARIABLE Colors Colors on
 ' (.string) IS .string
 
 
-: .struc        Str# .string ;
+: .struc        
+	uppercase on Str# .string ;
 
-\ CODES                                                 15may93jaw
+\ CODES (Branchtypes)                                    15may93jaw
 
 21 CONSTANT RepeatCode
 22 CONSTANT AgainCode
@@ -110,21 +134,30 @@ VARIABLE Colors Colors on
 11 CONSTANT AheadCode
 13 CONSTANT WhileCode2
 14 CONSTANT Disable
+15 CONSTANT LeaveCode
+
 
 \ FORMAT WORDS                                          13jun93jaw
 
 VARIABLE C-Stop
 VARIABLE Branches
 
-VARIABLE BranchPointer
+VARIABLE BranchPointer	\ point to the end of branch table
 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 -
 ACONSTANT MaxTable
 
 : 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 @
         BEGIN   dup BranchPointer @ u<
         WHILE
@@ -153,6 +186,20 @@ ACONSTANT MaxTable
         2drop true
         THEN ;
 
+: MyBranch      ( a-addr -- a-addr a-addr2 )
+\ finds branch table entry for branch at a-addr
+                dup @ over +
+                BranchAddr?
+                BEGIN
+                WHILE 1 cells - @
+                      over <>
+                WHILE dup @ over +
+                      MoreBranchAddr?
+                REPEAT
+                SearchPointer @ 3 cells -
+                ELSE    true ABORT" SEE: Table failure"
+                THEN ;
+
 \
 \                 addrw               addrt
 \       BEGIN ... WHILE ... AGAIN ... THEN
@@ -201,94 +248,83 @@ VARIABLE C-Pass
 : back? ( n -- flag ) 0< ;
 : ahead? ( n -- flag ) 0> ;
 
-: c-(compile)
-    Display?
-    IF
-	s" POSTPONE " Com# .string
-	dup @ look 0= ABORT" SEE: No valid XT"
-	name>string 0 .string bl cemit
-    THEN
-    cell+ ;
+: .word ( addr xt -- addr )
+    look 0= IF
+	drop dup 1 cells - @ dup body> look
+	IF
+	    nip dup ." <" name>string rot wordinfo .string ." >"
+	ELSE
+	    drop ." <" 0 .r ." >"
+	THEN
+    ELSE
+	dup cell+ @ immediate-mask and
+	IF
+	    bl cemit  ." POSTPONE "
+	THEN
+	dup name>string rot wordinfo .string
+    THEN ;
 
-: c-lit
+: c-call ( addr1 -- addr2 )
     Display? IF
-	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
+	dup @ body> .word bl cemit
     THEN
     cell+ ;
 
-: c-@local#
+: c-callxt ( addr1 -- addr2 )
     Display? IF
-	S" @local" 0 .string
-	dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit
+	dup @ .word bl cemit
     THEN
     cell+ ;
 
-: c-flit
-    Display? IF
-	dup f@ scratch represent 0=
-	IF    2drop  scratch 3 min 0 .string
-	ELSE
-	    IF  '- cemit  THEN  1-
-	    scratch over c@ cemit '. cemit 1 /string 0 .string
-	    'E cemit
-	    dup abs 0 <# #S rot sign #> 0 .string bl cemit
-	THEN THEN
-    float+ ;
-
-: c-f@local#
-    Display? IF
-	S" f@local" 0 .string
-	dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit
-    THEN
-    cell+ ;
+\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
+\ here over - 2constant doers
 
-: c-laddr#
+: c-lit ( addr1 -- addr2 )
     Display? IF
-	S" laddr# " 0 .string
-	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
-    THEN
+	dup @ dup body> dup cfaligned over = swap in-dictionary? and if
+	    ( addr1 addr1@ )
+	    dup body> @ dovar: = if
+		drop c-call EXIT
+	    endif
+	endif
+	\ !! test for cfa here, and print "['] ..."
+	dup abs 0 <# #S rot sign #> 0 .string bl cemit
+    endif
     cell+ ;
 
-: c-lp+!#
-    Display? IF
-	S" lp+!# " 0 .string
+: c-lit+ ( addr1 -- addr2 )
+    Display? if
 	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
-    THEN
+	s" + " 0 .string
+    endif
     cell+ ;
 
-: c-s"
-        count 2dup + aligned -rot
-        Display?
-        IF      [char] S cemit [char] " cemit bl cemit 0 .string
-                [char] " cemit bl cemit
-        ELSE    2drop
-        THEN ;
-
-: c-."
-        count 2dup + aligned -rot
-        Display?
-        IF      [char] . cemit
-                [char] " cemit bl cemit 0 .string
-                [char] " cemit bl cemit
-        ELSE    2drop
-        THEN ;
+: .name-without ( addr -- addr )
+\ prints a name without () e.g. (+LOOP) or (s")
+  dup 1 cells - @ look 
+  IF   name>string over c@ '( = IF 1 /string THEN
+       2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop 
+  THEN ;
 
 : c-c"
+	Display? IF nl .name-without THEN
         count 2dup + aligned -rot
         Display?
-        IF      [char] C cemit [char] " cemit bl cemit 0 .string
+        IF      bl cemit 0 .string
                 [char] " cemit bl cemit
         ELSE    2drop
         THEN ;
 
 
-: Forward? ( a-addr true | false -- )
+: Forward? ( a-addr true | false -- a-addr true | false )
+\ a-addr1 is pointer into branch table
+\ returns true when jump is a forward jump
         IF      dup dup @ swap 1 cells - @ -
                 Ahead? IF true ELSE drop false THEN
                 \ only if forward jump
         ELSE    false THEN ;
 
-: RepeatCheck
+: RepeatCheck ( a-addr1 a-addr2 true | false -- false )
         IF  BEGIN  2dup
                    1 cells - @ swap dup @ +
                    u<=
@@ -327,13 +363,17 @@ VARIABLE C-Pass
                         IF      drop S" REPEAT " .struc nl
                         ELSE    S" AGAIN " .struc nl
                         THEN
-                ELSE    dup cell+ BranchAddr? Forward?
-                        IF      dup cell+ @ WhileCode2 =
-                                IF nl S" ELSE" .struc level+
-                                ELSE level- nl S" ELSE" .struc level+ THEN
-                                cell+ Disable swap !
-                        ELSE    S" AHEAD" .struc level+
-                        THEN
+                ELSE    MyBranch cell+ @ LeaveCode =
+			IF 	S" LEAVE " .struc
+			ELSE
+				dup cell+ BranchAddr? Forward?
+       	                 	IF      dup cell+ @ WhileCode2 =
+       	                         	IF nl S" ELSE" .struc level+
+                                	ELSE level- nl S" ELSE" .struc level+ THEN
+                                	cell+ Disable swap !
+                        	ELSE    S" AHEAD" .struc level+
+                        	THEN
+			THEN
                 THEN
         THEN
         Debug?
@@ -341,19 +381,6 @@ VARIABLE C-Pass
         ELSE    cell+
         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
         Debug?
         IF      dup @ over + swap THEN ; \ return 2 different addresses
@@ -376,60 +403,37 @@ VARIABLE C-Pass
                                 level- nl
                                 S" WHILE " .struc
                                 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
         DebugBranch
         cell+ ;
 
-: c-?branch-lp+!#  c-?branch cell+ ;
-: c-branch-lp+!#   c-branch  cell+ ;
+: c-for
+        Display? IF nl S" FOR" .struc level+ THEN ;
+
+: c-loop
+        Display? IF level- nl .name-without bl cemit nl THEN
+        DebugBranch cell+ 
+	Scan? 
+	IF 	dup BranchAddr? 
+		BEGIN   WHILE cell+ LeaveCode swap !
+			dup MoreBranchAddr?
+		REPEAT
+	THEN
+	cell+ ;
 
 : c-do
-        Display? IF nl S" DO" .struc level+ THEN ;
+        Display? IF nl .name-without level+ THEN ;
 
 : c-?do
         Display? IF nl S" ?DO" .struc level+ THEN
         DebugBranch cell+ ;
 
-: c-for
-        Display? IF nl S" FOR" .struc level+ THEN ;
-
-: c-next
-        Display? IF level- nl S" NEXT " .struc nl THEN
-        DebugBranch cell+ cell+ ;
-
-: c-loop
-        Display? IF level- nl S" LOOP " .struc nl THEN
-        DebugBranch cell+ cell+ ;
-
-: c-+loop
-        Display? IF level- nl S" +LOOP " .struc nl THEN
-        DebugBranch cell+ cell+ ;
-
-: c-s+loop
-        Display? IF level- nl S" S+LOOP " .struc nl THEN
-        DebugBranch cell+ cell+ ;
-
-: c--loop
-        Display? IF level- nl S" -LOOP " .struc nl THEN
-        DebugBranch cell+ cell+ ;
-
-: c-next-lp+!#  c-next cell+ ;
-: c-loop-lp+!#  c-loop cell+ ;
-: c-+loop-lp+!#  c-+loop cell+ ;
-: c-s+loop-lp+!#  c-s+loop cell+ ;
-: c--loop-lp+!#  c--loop cell+ ;
-
-: c-leave
-        Display? IF S" LEAVE " .struc THEN
-        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
         IF      Display? IF nlflag off S" ;" Com# .string THEN
@@ -438,10 +442,6 @@ VARIABLE C-Pass
         THEN
         Debug? IF drop THEN ;
 
-: c-does>               \ end of create part
-        Display? IF S" DOES> " Com# .string THEN
-        Cell+ cell+ ;
-
 : c-abort"
         count 2dup + aligned -rot
         Display?
@@ -451,62 +451,86 @@ VARIABLE C-Pass
         ELSE    2drop
         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
-        ' lit A,            ' c-lit A,
-	' @local# A,        ' c-@local# A,
-        ' flit A,           ' c-flit A,
-	' f@local# A,       ' c-f@local# A,
-	' laddr# A,         ' c-laddr# A,
-	' lp+!# A,          ' c-lp+!# A,
-        ' (s") A,           ' c-s" A,
-        ' (.") A,           ' c-." A,
-        ' "lit A,           ' c-c" A,
-        ' leave A,          ' c-leave A,
-        ' ?leave A,         ' c-?leave A,
-        ' (do) A,           ' c-do A,
-        ' (?do) A,          ' c-?do A,
-        ' (for) A,          ' c-for A,
-        ' ?branch A,        ' c-?branch A,
-        ' branch A,         ' c-branch A,
-        ' (loop) A,         ' c-loop A,
-        ' (+loop) A,        ' c-+loop A,
-        ' (s+loop) A,       ' c-s+loop A,
-        ' (-loop) A,        ' c--loop A,
-        ' (next) A,         ' c-next A,
-        ' ?branch-lp+!# A,  ' c-?branch-lp+!# A,
-        ' branch-lp+!# A,   ' c-branch-lp+!# A,
-        ' (loop)-lp+!# A,   ' c-loop-lp+!# A,
-        ' (+loop)-lp+!# A,  ' c-+loop-lp+!# A,
-        ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A,
-        ' (-loop)-lp+!# A,  ' c--loop-lp+!# A,
-        ' (next)-lp+!# A,   ' c-next-lp+!# A,
-        ' ;s A,             ' c-exit A,
-        ' (does>) A,        ' c-does> A,
-        ' (abort") A,       ' c-abort" A,
-        ' (compile) A,      ' c-(compile) A,
-        0 ,
+	        ' lit A,            ' c-lit A,
+		' does-exec A,	    ' c-callxt A,
+		' lit@ A,	    ' c-call A,
+[IFDEF] call	' call A,           ' c-call A, [THEN]
+\		' useraddr 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,
+[IFDEF] (+do)	' (+do) A,	    ' c-do A, [THEN]
+[IFDEF] (u+do)	' (u+do) A,	    ' c-do A, [THEN]
+[IFDEF] (-do)	' (-do) A,	    ' c-do A, [THEN]
+[IFDEF] (u-do)	' (u-do) A,	    ' c-do A, [THEN]
+        	' (?do) A,          ' c-?do A,
+        	' (for) A,          ' c-for A,
+        	' ?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]
+[IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
+        	0 ,		here 0 ,
+
+avariable c-extender
+c-extender !
 
 \ DOTABLE                                               15may93jaw
 
-: DoTable ( cfa -- flag )
-        C-Table
-        BEGIN   dup @ dup
-        WHILE   2 pick <>
-        WHILE   2 cells +
-        REPEAT
-        nip cell+ @ EXECUTE
-        true
-        ELSE
-        2drop drop false
-        THEN ;
+: DoTable ( ca/cfa -- flag )
+    decompile-prim C-Table BEGIN ( cfa table-entry )
+	dup @ dup 0=  IF
+	    drop cell+ @ dup IF ( next table!)
+		dup @
+	    ELSE ( end!)
+		2drop false EXIT
+	    THEN 
+	THEN
+	\ jump over to extender, if any 26jan97jaw
+	xt>threaded 2 pick <>
+    WHILE
+	    2 cells +
+    REPEAT
+    nip cell+ perform
+    true
+;
 
 : BranchTo? ( a-addr -- a-addr )
-        Display?  IF     dup BranchAddr?
-                        IF BEGIN cell+ @ dup 20 u>
+        Display?  IF    dup BranchAddr?
+                        IF
+				BEGIN cell+ @ dup 20 u>
                                 IF drop nl S" BEGIN " .struc level+
                                 ELSE
-                                  dup Disable <>
+                                  dup Disable <> over LeaveCode <> and
                                   IF   WhileCode2 =
                                        IF nl S" THEN " .struc nl ELSE
                                        level- nl S" THEN " .struc nl THEN
@@ -518,14 +542,15 @@ CREATE C-Table
                   THEN ;
 
 : analyse ( a-addr1 -- a-addr2 )
-        Branches @ IF BranchTo? THEN
-        dup cell+ swap @
-        dup >r DoTable r> swap IF drop EXIT THEN
-        Display?
-        IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
-           ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit
-        ELSE drop
-        THEN ;
+    Branches @ IF BranchTo? THEN
+    dup cell+ swap @
+    dup >r DoTable r> swap IF drop EXIT THEN
+    Display?
+    IF
+	.word bl cemit
+    ELSE
+	drop
+    THEN ;
 
 : c-init
         0 YPos ! 0 XPos !
@@ -535,79 +560,176 @@ CREATE C-Table
         Branches on ;
 
 : makepass ( a-addr -- )
-        c-stop off
-        BEGIN
-                analyse
-                c-stop @
-        UNTIL drop ;
-
-DEFER dosee
-
-: dopri .name ." is primitive" cr ;
-: dovar ." Variable " .name cr ;
-: douse ." User " .name cr ;
-: docon  dup cell+ (name>) >body @ . ." Constant " .name cr ;
-: doval  dup cell+ (name>) >body @ . ." Value " .name cr ;
-: dodef ." Defer " dup >r .name cr
-    r@ cell+ (name>) >body @ look
-    0= ABORT" SEE: No valid xt in deferred word"
-    dup dosee cr
-    ." ' " .name r> ." IS " .name cr ;
-: dodoe ." Create " dup .name cr
-        S" DOES> " Com# .string XPos @ Level ! name>
-        >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
-        ScanMode c-pass ! dup makepass
-        DisplayMode c-pass ! makepass ;
-: doali here @ .name ." Alias " .name cr
-        here @ dosee ;
-: docol
-    S" : " Com# .string
-    dup name>string 2 pick wordinfo .string bl cemit bl cemit
-    ( XPos @ ) 2 Level !
-    name> >body
-    C-Pass @ DebugMode =
-    IF
-	ScanMode c-pass ! EXIT
+    c-stop off
+    BEGIN
+	analyse
+	c-stop @
+    UNTIL drop ;
+
+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 code at addr of length u
+' 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 ;
+
+: 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 -- )
+    dup s" Code" .defname
+    >code-address
+    dup in-dictionary? \ user-defined code word?
+    if
+	dup next-head
+    else
+	dup next-prim
+    then
+    over - discode
+    ." end-code" cr ;
+: seevar ( xt -- )
+    s" Variable" .defname cr ;
+: seeuser ( xt -- )
+    s" User" .defname cr ;
+: seecon ( xt -- )
+    dup >body ?
+    s" Constant" .defname cr ;
+: seevalue ( xt -- )
+    dup >body ?
+    s" Value" .defname cr ;
+: seedefer ( xt -- )
+    dup >body @ xt-see-xt cr
+    dup s" Defer" .defname cr
+    >name ?dup-if
+	." IS " .name cr
+    else
+	." lastxt >body !"
+    then ;
+: see-threaded ( addr -- )
+    C-Pass @ DebugMode = IF
+	ScanMode c-pass !
+	EXIT
     THEN
     ScanMode c-pass ! dup makepass
     DisplayMode c-pass ! makepass ;
-
-create wordtypes
-        Pri# ,   ' dopri A,
-        Var# ,   ' dovar A,
-        Con# ,   ' docon A,
-        Val# ,   ' doval A,
-        Def# ,   ' dodef A,
-        Doe# ,   ' dodoe A,
-        Ali# ,   ' doali A,
-        Col# ,   ' docol A,
-	Use# ,   ' douse A,
-        0 ,
-
-: (dosee) ( lfa -- )
-        dup dup cell+ c@ >r
-        wordinfo
-        wordtypes
-        BEGIN dup @ dup
-        WHILE 2 pick = IF cell+ @ nip EXECUTE
-	                  r> dup 32 and IF ."  immediate" THEN
-			         64 and IF ."  restrict" THEN EXIT THEN
-              2 cells +
-        REPEAT
-        2drop rdrop
-        .name ." Don't know how to handle" cr ;
-
-' (dosee) IS dosee
-
-: xtc ( xt -- )       \ do see at xt
-        Look 0= ABORT" SEE: No valid XT"
-        cr c-init
-        dosee ;
-
-: see   name sfind 0= IF ." Word unknown" cr exit THEN
-        xtc ;
-
-: lfc   cr c-init cell+ dosee ;
-: nfc   cr c-init dosee ;
+: seedoes ( xt -- )
+    dup s" create" .defname cr
+    S" DOES> " Com# .string XPos @ Level !
+    >does-code see-threaded ;
+: seecol ( xt -- )
+    dup s" :" .defname nl
+    2 Level !
+    >body see-threaded ;
+: seefield ( xt -- )
+    dup >body ." 0 " ? ." 0 0 "
+    s" Field" .defname cr ;
+
+: xt-see ( xt -- ) \ gforth
+    \G Decompile the definition represented by @i{xt}.
+    cr c-init
+    dup >does-code
+    if
+	seedoes EXIT
+    then
+    dup xtprim?
+    if
+	seecode EXIT
+    then
+    dup >code-address
+    CASE
+	docon: of seecon endof
+	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] ]
+	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 ." lastxt" ;
+' (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 (.immediate)
+	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 ;