--- gforth/see.fs	2002/09/14 11:18:57	1.41
+++ gforth/see.fs	2003/03/08 13:29:55	1.50
@@ -28,19 +28,6 @@
 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
 
@@ -120,6 +107,32 @@ 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
+			recover
+			endtry
+			r> base ! throw
+		    endif
+		endif
+		1 /string
+	    endif
+    repeat
+    2drop ;
 
 : .struc        
 	uppercase on Str# .string ;
@@ -188,12 +201,12 @@ ACONSTANT MaxTable
 
 : MyBranch      ( a-addr -- a-addr a-addr2 )
 \ finds branch table entry for branch at a-addr
-                dup @ over +
+                dup @
                 BranchAddr?
                 BEGIN
                 WHILE 1 cells - @
                       over <>
-                WHILE dup @ over +
+                WHILE dup @
                       MoreBranchAddr?
                 REPEAT
                 SearchPointer @ 3 cells -
@@ -231,7 +244,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
@@ -245,41 +259,78 @@ VARIABLE C-Pass
 : Display? ( -- flag ) C-Pass @ 1 = ;
 : Debug? ( -- flag ) C-Pass @ 2 = ;
 
-: back? ( n -- flag ) 0< ;
-: ahead? ( n -- flag ) 0> ;
+: back? ( addr target -- addr flag )
+    over u< ;
+
+: .word ( addr x -- addr )
+    \ 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
+		nip dup ." <" name>string rot wordinfo .string ." > "
+	    ELSE
+		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-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+ ;
 
-: .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-callxt ( addr1 -- addr2 )
+    Display? IF
+	dup @ .word bl cemit
+    THEN
+    cell+ ;
 
-: c-call
-    Display? IF  ." call " dup @ body> .word bl cemit  THEN  cell+ ;
+\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
+\ here over - 2constant doers
+
+: c-lit ( addr1 -- addr2 )
+    Display? IF
+	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-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 )
-\ 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 ;
+    \ !! 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
@@ -288,19 +339,70 @@ VARIABLE C-Pass
                 [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-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 ;
+    \ 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 ;
 
 : 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=
@@ -310,7 +412,8 @@ VARIABLE C-Pass
         ELSE false
         THEN ;
 
-: c-branch
+: c-branch ( addr1 -- addr2 )
+    c-string? ?exit
         Scan?
         IF      dup @ Branch!
                 dup @ back?
@@ -404,9 +507,11 @@ VARIABLE C-Pass
 : c-do
         Display? IF nl .name-without level+ THEN ;
 
-: c-?do
-        Display? IF nl S" ?DO" .struc level+ THEN
-        DebugBranch cell+ ;
+: c-?do ( addr1 -- addr2 )
+    Display? IF
+	nl .name-without level+
+    THEN
+    DebugBranch cell+ ;
 
 : c-exit  dup 1 cells -
         CheckEnd
@@ -444,27 +549,32 @@ VARIABLE C-Pass
 
 CREATE C-Table
 	        ' lit A,            ' c-lit A,
+		' does-exec A,	    ' c-callxt A,
+		' lit@ A,	    ' c-call A,
 [IFDEF] call	' call A,           ' c-call A, [THEN]
-		' (s") A,	    ' c-c" A,
-       		 ' (.") A,	    ' c-c" A,
-        	' "lit A,           ' c-c" A,
+\		' 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]
+[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] (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,
-        	' (abort") A,       ' c-abort" 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]
@@ -475,20 +585,23 @@ c-extender !
 
 \ DOTABLE                                               15may93jaw
 
-: DoTable ( cfa -- flag )
-        C-Table
-        BEGIN   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
-	;
+: 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?
@@ -551,8 +664,7 @@ Defer discode ( addr u -- ) \ gforth
 : next-head ( addr1 -- addr2 ) \ gforth
     \G find the next header starting after addr1, up to here (unreliable).
     here swap u+do
-	i head?
-	if
+	i head? -2 and if
 	    i unloop exit
 	then
     cell +loop