--- gforth/see.fs	1996/08/26 10:07:21	1.14
+++ gforth/see.fs	2010/12/31 18:09:02	1.76
@@ -1,12 +1,12 @@
 \ SEE.FS       highend SEE for ANSforth                16may93jaw
 
-\ Copyright (C) 1995 Free Software Foundation, Inc.
+\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008,2010 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 2
+\ 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,
@@ -15,8 +15,7 @@
 \ 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, write to the Free Software
-\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+\ along with this program. If not, see http://www.gnu.org/licenses/.
 
 
 \ May be cross-compiled
@@ -25,7 +24,9 @@
 
 \ Ideas:        Level should be a stack
 
+require look.fs
 require termsize.fs
+require wordinfo.fs
 
 decimal
 
@@ -50,12 +51,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
@@ -69,14 +71,69 @@ DEFER nlcount ' noop IS nlcount
                 XPos @ over + cols u>= IF (nl) 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@ toupper 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 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
 VARIABLE Colors Colors on
@@ -97,10 +154,38 @@ VARIABLE Colors Colors on
 
 ' (.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
 22 CONSTANT AgainCode
@@ -110,21 +195,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 +247,20 @@ ACONSTANT MaxTable
         2drop true
         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
 \       BEGIN ... WHILE ... AGAIN ... THEN
@@ -184,7 +292,8 @@ ACONSTANT MaxTable
         BranchPointer @ 1 cells - ! ;
 
 : 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
 VARIABLE NoOutput
@@ -197,100 +306,176 @@ VARIABLE C-Pass
 : Scan? ( -- flag ) C-Pass @ 0= ;
 : Display? ( -- flag ) C-Pass @ 1 = ;
 : Debug? ( -- flag ) C-Pass @ 2 = ;
+: ?.string  ( c-addr u n -- )   Display? if .string else 2drop drop then ;
 
-: back? ( n -- flag ) 0< ;
-: ahead? ( n -- flag ) 0> ;
+: back? ( addr target -- addr flag )
+    over u< ;
 
-: c-(compile)
-    Display?
+: .word ( addr x -- addr )
+    \ print x as a word if possible
+    dup look 0= IF
+	drop dup threaded>name dup 0= if
+	    drop over 1 cells - @ dup body> look
+	    IF
+		nip nip dup ." <" name>string rot wordinfo .string ." > "
+	    ELSE
+		2drop ." <" 0 .r ." > "
+	    THEN
+	    EXIT
+	then
+    THEN
+    nip dup cell+ @ immediate-mask and
     IF
-	s" POSTPONE " Com# .string
-	dup @ look 0= ABORT" SEE: No valid XT"
-	name>string 0 .string bl cemit
+	bl cemit  ." POSTPONE "
     THEN
-    cell+ ;
+    dup name>string rot wordinfo .string
+    ;
 
-: 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+ ;
+\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
+\ here over - 2constant doers
 
-: 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+ ;
+[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-laddr#
-    Display? IF
-	S" laddr# " 0 .string
-	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
-    THEN
+: c-lit ( addr1 -- addr2 )
+    dup @ dup body> dup cfaligned over = swap in-dictionary? and if
+	( addr1 addr1@ )
+	dup body> @ dovar: = if
+	    drop c-call EXIT
+	endif
+    endif
+    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-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 )
+    \ !! 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"
+	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 ;
+[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 -- )
-        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 @ +
+                   1 cells - @ swap @
                    u<=
             WHILE  drop dup cell+
                    MoreBranchAddr? 0=
@@ -300,7 +485,8 @@ VARIABLE C-Pass
         ELSE false
         THEN ;
 
-: c-branch
+: c-branch ( addr1 -- addr2 )
+    c-string? ?exit
         Scan?
         IF      dup @ Branch!
                 dup @ back?
@@ -327,36 +513,27 @@ 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?
-        IF      dup @ +
+        IF      @ \ !!! cross-interacts with debugger !!!
         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
+        IF      dup @ swap THEN ; \ return 2 different addresses
 
 : c-?branch
         Scan?
@@ -376,71 +553,49 @@ 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-do
-        Display? IF nl S" DO" .struc 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+ ;
+        Display? IF level- nl .name-without nl bl cemit THEN
+        DebugBranch cell+ 
+	Scan? 
+	IF 	dup BranchAddr? 
+		BEGIN   WHILE cell+ LeaveCode swap !
+			dup MoreBranchAddr?
+		REPEAT
+	THEN
+	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
-                C-Stop on
-        ELSE    Display? IF S" EXIT " .struc THEN
-        THEN
-        Debug? IF drop THEN ;
+: c-do
+        Display? IF nl .name-without level+ THEN ;
 
-: c-does>               \ end of create part
-        Display? IF S" DOES> " Com# .string THEN
-        Cell+ cell+ ;
+: c-?do ( addr1 -- addr2 )
+    Display? IF
+	nl .name-without level+
+    THEN
+    DebugBranch cell+ ;
+
+: c-exit ( addr1 -- addr2 )
+    dup 1 cells -
+    CheckEnd
+    IF
+	Display? IF nlflag off S" ;" Com# .string THEN
+	C-Stop on
+    ELSE
+	Display? IF S" EXIT " .struc THEN
+    THEN
+    Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!!
 
 : c-abort"
         count 2dup + aligned -rot
@@ -451,62 +606,79 @@ VARIABLE C-Pass
         ELSE    2drop
         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,
-        comp' leave drop A, ' c-leave A,
-        comp' ?leave drop 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]
+        	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+ perform
-        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 +690,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 !
@@ -541,29 +714,22 @@ CREATE C-Table
 	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 -- )
-\  hook for the disassembler: disassemble code at addr (as far as the
-\  disassembler thinks is sensible)
-:noname ( addr -- )
-    drop ." ..." ;
-IS discode
-
 : seecode ( xt -- )
     dup s" Code" .defname
-    >body discode
-    ."  end-code" cr ;
+    >code-address
+    dup in-dictionary? \ user-defined code word?
+    if
+	dup next-head
+    else
+	dup next-prim
+    then
+    over - discode
+    ." end-code" cr ;
+: seeabicode ( xt -- )
+    dup s" ABI-Code" .defname
+    >body dup dup next-head 
+    swap - discode
+    ." end-code" cr ;
 : seevar ( xt -- )
     s" Variable" .defname cr ;
 : seeuser ( xt -- )
@@ -577,10 +743,10 @@ IS discode
 : seedefer ( xt -- )
     dup >body @ xt-see-xt cr
     dup s" Defer" .defname cr
-    >name dup ??? = if
-	drop ." lastxt >body !"
-    else
+    >name ?dup-if
 	." IS " .name cr
+    else
+	." latestxt >body !"
     then ;
 : see-threaded ( addr -- )
     C-Pass @ DebugMode = IF
@@ -594,37 +760,51 @@ IS discode
     S" DOES> " Com# .string XPos @ Level !
     >does-code see-threaded ;
 : seecol ( xt -- )
-    dup s" :" .defname cr
+    dup s" :" .defname nl
     2 Level !
     >body see-threaded ;
 : seefield ( xt -- )
     dup >body ." 0 " ? ." 0 0 "
     s" Field" .defname cr ;
 
-: xt-see ( xt -- )
+: xt-see ( xt -- ) \ gforth
+    \G Decompile the definition represented by @i{xt}.
     cr c-init
     dup >does-code
     if
 	seedoes EXIT
     then
-    dup forthstart u<
+    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
-	over >body of seecode 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 ." lastxt" ;
+    xt-see cr ." latestxt" ;
 ' (xt-see-xt) is xt-see-xt
 
 : (.immediate) ( xt -- )
@@ -639,21 +819,26 @@ IS discode
     if \ normal or immediate word
 	swap xt-see (.immediate)
     else
-	r@ ['] compile-only-error =
+	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)
+	    ." interpret/compile: " over .name drop
 	then
     then
     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=
     IF
-	drop -&13 bounce
+	drop -&13 throw
     THEN
     name-see ;