/**
   PFE-DEBUG --- analyze compiled code
  
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE             @(#) %derived_by: guidod %
    @version %version: bln_mpt1!5.36 %
      (%date_modified: Tue Jun 18 14:49:54 2002 %)
  
    @description
  	The Portable Forth Environment provides a decompiler for
        colon words and a single stepper for debugging. After 
        setting a breakpoint at a word saying => DEBUG <tt>word</tt>.
    	The next time the <tt>word</tt> gets executed the single
   	stepper takes control.
  
   	When this happens you see the top stack items displayed in one
  	line. The topmost stack item is the first in line, the second and
  	following stack items are displayed throughout the end of line.
  	This line is empty if the stack is empty when the word in question
  	executes.
  
  	On the next line you see the first word to become executed inside
  	the debugged <tt>word</tt>. There is a prompt <tt>&gt;</tt> to
  	the right of the displayed word. At this prompt you have several
  	options. Choose one by typing a key (<tt>[h]</tt> shows helpscreen):
  
  	<dl>
  	<dt> <tt>[enter], [x], [k], [down]</tt> </dt>  <dd>
  	The displayed word will be executed without single stepping.
  	Note that the execution of the word is slowed down a little
  	compared to execution outside the single stepper. This is
  	because the single stepper has to keep control to detect when
  	the word has finished.
  
  	After the actual word finished execution the resulting stack
  	is printed on the current line. The next line shows the next
  	word to become executed.
  
  	Having repeated this step several times, you can see to the
  	the right of every decompiled word what changes to the stack
  	this word caused by comparing with the stack display just
  	one line above.
        </dd>
  	<dt> <tt>[d], [l], [right]</tt> </dt><dd>
  	Begin single step the execution of the actual word. The first
  	word to become executed inside the definition is displayed on
  	the next line. The word's display is intended by two spaces
  	for each nesting level.
   
     	You can single step through colon-definitions and the children
  	of defining words. Note that most of the words in PFE are
  	rewritten in C for speed, and you can not step those kernel
  	words.
        </dd>
        <dt> <tt>[s], [j], [left]</tt> </dt><dd>
  	Leaves the nesting level. The rest of the definition currently
  	being executed is run with further prompt. If you leave the
  	outmost level, the single stepper won't get control again.
  	Otherwise the debugger stops after the current word is
  	finished and offers the next word in the previous nesting level.
  	</dd>
  	<dt> <tt>[space]</tt> </dt><dd>
  	The next word to be executed is decompiled. This should help 
  	to decide as if to single step that word.
  	</dd>
  	<dt> <tt>[q]</tt> </dt><dd>
  	Quits from the debugger. The execution of the debugged word is
  	not continued. The stacks are not cleared or changed.
  	</dd>
  	<dt> <tt>[c]</tt> </dt><dd>
  	Displays the profiling instruction counter.
  	<dt> <tt>[r]</tt> </dt><dd>
  	Reset the instruction counter, to profile some code. The
  	debugger counts how often the inner interpreter i.e. how
  	many Forth-primitives are executed. Use this option to 
        reset the counter to 0 to measure an arbitrary part of code.
  	</dd>
  	</dl>
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  debug-ext.c~31.5 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/def-xtra.h>
#include <pfe/def-types.h>
#include <pfe/def-comp.h>
#include <pfe/term-sub.h>

#include <ctype.h>
#include <string.h>

#include <pfe/_missing.h>
/************************************************************************/
/* decompiler                                                           */
/************************************************************************/

#ifdef WRONG_SPRINTF		/* provision for buggy sprintf (SunOS) */
#define SPRFIX(X) strlen(X)
#else
#define SPRFIX(X) X
#endif

#define UDDOTR(UD,W,BUF) p4_outs (p4_str_ud_dot_r (UD, &(BUF)[sizeof (BUF)], W,BASE))
#define DDOTR(D,W,BUF)	p4_outs (p4_str_d_dot_r (D, &(BUF) [sizeof (BUF)], W, BASE))
#define DOT(N,BUF)	p4_outs (p4_str_dot (N, &(BUF) [sizeof (BUF)], BASE))

/* ----------------------------------------------------------------------- */

typedef p4xt* (*func_SEE) (p4xt* , char*, p4_Semant*);

_export p4xt*
p4_locals_bar_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    int i;
        
    /* locals[PFE.level] = *(p4cell *) ip; */
    p += SPRFIX (sprintf (p, "LOCALS| "));
    for (i = ((p4cell*)ip)[1]; --i >= 0;)
        p += SPRFIX (sprintf (p, "<%c> ", 
          'A'-1 + (unsigned)(((p4ucell*)ip)[1]) - i));
    p += SPRFIX (sprintf (p, "| "));
    return (ip+=2);
}


_export p4xt* 
p4_local_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    sprintf (p, "<%c> ", 'A' - 1 +  (int) *(p4cell *) ip);
    return ++ip;
}


_export p4xt*
p4_literal_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    char buf[80];
    if (s) 
    
{
        if (s->name && ! memcmp (s->name+1, "LITERAL", 7)) /* 'bit fuzzy... */
            sprintf (p, "0x%X ", *(p4cell*)ip);
        else
            sprintf (p, "( %.*s) 0x%X ", 
              NFACNT(*s->name), s->name+1, *(p4cell*)ip);
    }
else
{
        strcpy (p, p4_str_dot (*(p4cell *) ip, buf + sizeof buf, BASE));
    }

    return ++ip;
}


_export p4xt* /* P4_SKIPS_TO_TOKEN */
p4_lit_to_token_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    register p4char* nfa;
    register p4xt xt = ip[-1];
    if (*P4_TO_CODE(xt) == s->exec[0])
    
{
        xt = *ip++;
        nfa = p4_to_name (xt);
        sprintf (p, "%.*s %.*s ", 
          NFACNT(*s->name), s->name+1,
          NFACNT(*nfa), nfa + 1);
        
{ /* make-recognition, from yours.c */
            if (s->decomp.space > 1) ip++;
            if (s->decomp.space > 2) ip++;
        }

        return ip;
    }
else
{
        sprintf (p, "%.*s <%c> ", 
          NFACNT(*s->name), s->name + 1,
          'A' - 1 + (int) *(p4cell *) ip);
        
{ /* make-recognition, from yours.c */
            if (s->decomp.space > 1) ip++;
            if (s->decomp.space > 2) ip++;
        }

        return ++ip;
    }

}


_export p4xt* /* P4_SKIPS_STRING */
p4_lit_string_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    sprintf (p, "%.*s %.*s\" ",
      NFACNT(*s->name), s->name + 1,
      (int) *(p4char *) ip, (p4char *) ip + 1);
    P4_SKIP_STRING (ip);
    return ip;
}


_export p4xt* /* P4_SKIPS_2STRINGS */
p4_lit_2strings_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    p4char *s1 = (p4char *) ip;
        
    P4_SKIP_STRING (ip);
    sprintf (p, "%.*s %.*s %.*s ",
      NFACNT(*s->name), s->name + 1, (int) *s1, s1 + 1,
      (int) *(p4char *) ip, (p4char *) ip + 1);
    P4_SKIP_STRING (ip);
    return ip;
}


_export p4xt* /* P4_SKIPS_DCELL */
p4_lit_dcell_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    char buf[80];
    sprintf (p, "%s. ",
      p4_str_d_dot_r (*(p4dcell *) ip, buf + sizeof buf, 0, BASE));
    P4_INC (ip, p4dcell);
    
    return ip;
}


static p4xt *
p4_decompile_word (p4xt* ip, char *p, p4_Decomp *d)
{
    static const p4_Decomp default_style = 
{P4_SKIPS_NOTHING, 0, 0, 0, 0, 0}
;
    /* assert SKIPS_NOTHING == 0 */
    register p4xt xt = *ip++;
    register p4_Semant *s;

    s = p4_to_semant (xt);
    memcpy (d, ((s) ? (& s->decomp) : (& default_style)), sizeof(*d));

    /* some tokens are (still) compiled without a semant-definition */
    if (*P4_TO_CODE(xt) == PFX (p4_literal_execution))
        return p4_literal_SEE (ip, p, s);
    if (*P4_TO_CODE(xt) == PFX (p4_locals_bar_execution))
        return p4_locals_bar_SEE (ip, p, s);
    if (*P4_TO_CODE(xt) == PFX (p4_local_execution))
        return p4_local_SEE (ip, p, s);

    if (d->skips == P4_SKIPS_CELL 
      || d->skips == P4_SKIPS_OFFSET)
    
{
        P4_INC (ip, p4cell); 
        sprintf (p, "%.*s ", NFACNT(*s->name), s->name + 1);
        return ip;
    }


    if (d->skips == P4_SKIPS_DCELL)
        return p4_lit_dcell_SEE (ip, p, s);
    if (d->skips == P4_SKIPS_STRING)
        return p4_lit_string_SEE (ip, p, s);
    if (d->skips == P4_SKIPS_2STRINGS)
        return p4_lit_2strings_SEE (ip, p, s);
    if (d->skips == P4_SKIPS_TO_TOKEN)
        return p4_lit_to_token_SEE (ip, p, s);

    /* per default, just call the skips-decomp routine */
    if (d->skips) /* SKIPS_NOTHING would be NULL */
	return (*d->skips)(ip, p, s);

    if (s == NULL)
    
{
        /* use the prim-name (or colon-name) */
        register p4char* nfa = p4_to_name (xt);
        sprintf (p, *_FFA(nfa) & P4xIMMEDIATE ? "POSTPONE %.*s " : "%.*s ",
          NFACNT(*nfa), nfa + 1);
        return ip;
    }
else
{
        /* use the semant-name (or compiled-by name) */
        sprintf (p, "%.*s ", NFACNT(*s->name), s->name + 1);
        return ip;
    }

}


_export void
p4_decompile_rest (p4xt *ip, int nl, int indent)
{
    p4char* buf = p4_pocket ();
    p4_Seman2 *s;
    p4_Decomp d;
    *buf = '\0';
    
    FX (p4_start_Q_cr);
    for (;;)
    
{
        if (!*ip) break;
        s = (p4_Seman2 *) p4_to_semant (*ip);
        ip = p4_decompile_word (ip, buf, &d);
        indent += d.ind_bef;
        if ((!nl && d.cr_bef) || p4_OUT + strlen (buf) >= (size_t) p4_COLS)
	
{
            if (p4_Q_cr ())
                break;
            nl = 1;
	}

        if (nl)
	
{
            p4_emits (indent, ' ');
            nl = 0;
	}

        p4_outs (buf);
        p4_emits (d.space, ' ');
        indent += d.ind_aft;
        if (d.cr_aft)
	
{
            if (p4_Q_cr ())
                break;
            nl = 1;
	}

        if (d.cr_aft > 2)  /* instead of exec[0] == PFX(semicolon_execution) */
            break;
    }

}


static P4_CODE_RUN(p4_variable_RT_SEE)
{
    strcat (p, "VARIABLE ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_builds_RT_SEE)
{
    strcat (p, "CREATE ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_constant_RT_SEE)
{
    strcat (p, p4_str_dot (*P4_TO_BODY (xt), p+200, BASE));
    strcat (p, "CONSTANT ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_value_RT_SEE)
{
    strcat (p, p4_str_dot (*P4_TO_BODY (xt), p+200, BASE));
    strcat (p, "VALUE ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_two_constant_RT_SEE)
{
    strcat (p, p4_str_d_dot_r (*(p4dcell*) P4_TO_BODY (xt), p+200, 0, BASE));
    strcat (p, ". 2CONSTANT ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_marker_RT_SEE)
{
    strcat (p, "MARKER ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_defer_RT_SEE)
{
    strcat (p, "DEFER ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_vocabulary_RT_SEE)
{
    strcat (p, "VOCABULARY ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_offset_RT_SEE)
{
    strcat (p, p4_str_dot (*P4_TO_BODY (xt), p+200, BASE));
    strcat (p, "OFFSET: ");
    strncat (p, nfa+1, NFACNT(*nfa));
    return 0;
}


static P4_CODE_RUN(p4_colon_RT_SEE)
{
    strcat (p, ": ");
    strncat (p, nfa+1, NFACNT(*nfa));
    strcat (p, "\n");
    return (p4xt*) p4_to_body (xt);
}


static P4_CODE_RUN(p4_does_RT_SEE)
{
    strcat (p, "<BUILDS ");
    strncat (p, nfa+1, NFACNT(*nfa));
    strcat (p, " ( ALLOT )");
    return (*P4_TO_DOES_CODE(xt))-1;
}


_export void
p4_decompile (char *nfa, p4xt xt)
{
    register p4char* buf = p4_pocket ();
    register p4xt* rest = 0;
    *buf = '\0';

    FX (p4_cr);
    if (*P4_TO_CODE(xt) == p4_variable_RT_) 
	p4_variable_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_builds_RT_) 
	p4_builds_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_constant_RT_) 
	p4_constant_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_value_RT_) 
	p4_value_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_two_constant_RT_) 
	p4_two_constant_RT_SEE (buf, xt, nfa);
    else if (PFE.decompile[0] && PFE.decompile[0](nfa,xt)) 
{ /* (unused) */ }

    else if (PFE.decompile[1] && PFE.decompile[1](nfa,xt)) 
{ /* (unused) */ }

    else if (PFE.decompile[2] && PFE.decompile[2](nfa,xt)) 
{ /* floating */ }

    else if (*P4_TO_CODE(xt) == p4_marker_RT_) 
	p4_marker_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_defer_RT_ ) 
	p4_defer_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_offset_RT_) 
	p4_offset_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_vocabulary_RT_) 
	p4_vocabulary_RT_SEE (buf, xt, nfa);
    else if (*P4_TO_CODE(xt) == p4_colon_RT_ || 
	     *P4_TO_CODE(xt) == p4_debug_colon_RT_)
	rest = p4_colon_RT_SEE(buf,xt,nfa);
    else if (*P4_TO_CODE(xt) == p4_does_RT_ || 
	     *P4_TO_CODE(xt) == p4_debug_does_RT_)
        rest = p4_does_RT_SEE(buf,xt,nfa);

    if (*buf)
    
{
	p4_outs (buf); p4_outs (" ");
	if (rest) 
	    p4_decompile_rest (rest , 1, 4);
	if (*_FFA(nfa) & P4xIMMEDIATE)
	    p4_outs (" IMMEDIATE ");
    }
else
{
        p4_dot_name (nfa);
	if (*_FFA(nfa) & P4xIMMEDIATE)
	    p4_outs ("is IMMEDIATE ");
	else
	    p4_outs ("is prim CODE ");
	if (P4xISxRUNTIME)
	    if (*_FFA(nfa) & P4xISxRUNTIME)
		p4_outs ("RUNTIME ");
#     ifdef PFE_HAVE_GNU_DLADDR
	
{ 
	    extern char* p4_dladdr (void*, int*);
	    register char* name = p4_dladdr (*P4_TO_CODE(xt), 0); 
	    if (name) p4_outs(name); else p4_outc('.');
	    p4_outc(' ');
	}

#     endif
    }

}


/************************************************************************/
/* debugger                                                             */
/************************************************************************/

_export char
p4_category (p4code p)
{
    if (p == p4_colon_RT_ || p == p4_debug_colon_RT_)
        return ':';
    if (p == p4_variable_RT_ || p == p4_value_RT_ || p == p4_builds_RT_)
        return 'V';
    if (p == p4_constant_RT_ || p == p4_two_constant_RT_)
        return 'C';
    if (p == p4_vocabulary_RT_)
        return 'W';
    if (p == p4_does_RT_ || p == p4_debug_does_RT_)
        return 'D';
    if (p == p4_marker_RT_)
        return 'M';
    if (p == p4_defer_RT_)
        return 'F'; 
    if (p == p4_offset_RT_)
        return '+';
    /* must be primitive */ return 'p';
}


static void
prompt_col (void)
{
    p4_emits (24 - p4_OUT, ' ');
}


static void
display (p4xt *ip)
{
    p4_Decomp style;
    char buf[80];
    int indent = PFE.maxlevel * 2;
    int depth = p4_S0 - SP, i;

    prompt_col ();
    for (i = 0; i < depth; i++)
    
{
        p4_outf ("%10ld ", (long) SP[i]);
        if (p4_OUT + 11 >= p4_COLS)
            break;
    }

    FX (p4_cr);
    p4_decompile_word (ip, buf, &style);
# ifndef PFE_CALL_THREADING /* FIXME */
    p4_outf ("%*s%c %s", indent, "", p4_category (**ip), buf);
# endif
}


static void
interaction (p4xt *ip)
{
    int c;

    for (;;)
    
{
        display (ip);
        
        prompt_col ();
        p4_outs ("> ");
        c = p4_getekey ();
        FX (p4_backspace);
        FX (p4_backspace);
        if (isalpha (c))
            c = tolower (c);

        switch (c)
	
{
         default:
             p4_dot_bell ();
             continue;
         case P4_KEY_kr:
         case 'd':
         case 'l':
             PFE.maxlevel++;
             return;
         case P4_KEY_kd:
         case '\r':
         case '\n':
         case 'k':
         case 'x':
             return;
         case P4_KEY_kl:
         case 's':
         case 'j':
             PFE.maxlevel--;
             return;
         case 'q':
             p4_outf ("\nQuit!");
             PFE.debugging = 0;
             p4_throw (P4_ON_QUIT);
         case ' ':
#          ifndef PFE_CALL_THREADING /*FIXME*/
             switch (p4_category (**ip))
             
{
              default:
                  p4_decompile (p4_to_name (*ip), *ip);
                  break;
              case ':':
                  FX (p4_cr);
                  p4_decompile_rest ((p4xt *) p4_to_body (*ip), 1, 4);
                  break;
              case 'd':
                  p4_outs ("\nDOES>");
#               ifndef PFE_CALL_THREADING /*FIXME*/
                  p4_decompile_rest ((p4xt *) (*ip)[-1], 0, 4);
#               endif
                  break;
             }

#          endif
             FX (p4_cr);
             continue;
         case 'r':
             PFE.opcounter = 0;
             p4_outf ("\nOperation counter reset\n");
             continue;
         case 'c':
             p4_outf ("\n%ld Forth operations\n", PFE.opcounter);
             continue;
         case 'h':
         case '?':
             p4_outf ("\nDown,  'x', 'k', CR\t" "execute word"
               "\nRight, 'd', 'l'\t\t" "single step word"
               "\nLeft,  's', 'j'\t\t" "finish word w/o single stepping"
               "\nSpace\t\t\t" "SEE word to be executed"
               "\n'C'\t\t\t" "display operation counter"
               "\n'R'\t\t\t" "reset operation counter"
               "\n'Q'\t\t\t" "QUIT"
		"\n'?', 'H'\t\t" "this message"
               "\n");
             continue;
	}

    }

}


static void
do_adjust_level (p4xt xt)
{
    if (*P4_TO_CODE(xt) == p4_colon_RT_ 
      || *P4_TO_CODE(xt) == p4_debug_colon_RT_ 
      || *P4_TO_CODE(xt) == p4_does_RT_ 
      || *P4_TO_CODE(xt) == p4_debug_does_RT_)
        PFE.level++;
    else if (*P4_TO_CODE(xt) == PFX (p4_semicolon_execution) 
      || *P4_TO_CODE(xt) == PFX (p4_locals_exit_execution))
        PFE.level--;
}


static void
p4_debug_execute (p4xt xt)
{
    do_adjust_level (xt);
    p4_normal_execute (xt);
}


static void
p4_debug_on (void)
{
    PFE.debugging = 1;
    PFE.opcounter = 0;
    PFE.execute = p4_debug_execute;
    PFE.level = PFE.maxlevel = 0;
    p4_outf ("\nSingle stepping, type 'h' or '?' for help\n");
}


_export void
p4_debug_off (void)
{
    PFE.debugging = 0;
    PFE.execute = p4_normal_execute;
}


static void			/* modified inner interpreter for */
do_single_step (void)		/* single stepping */
{
# ifndef PFE_SBR_CALL_THREADING /* FIXME: disable */
    while (PFE.level >= 0)
    
{
        if (PFE.level <= PFE.maxlevel)
	
{
            PFE.maxlevel = PFE.level;
            interaction (IP);
	}

        do_adjust_level (*IP);
        PFE.opcounter++;
        
{
#         if defined PFE_CALL_THREADING
	    p4xcode w = *IP++;
	    w ();
#         elif defined P4_WP_VIA_IP
            p4xcode w = *IP++;	/* ip is register but W isn't */
            
            (*w) ();
#         else
            p4WP = *IP++;	/* ip and W are same: register or not */
            (*p4WP) ();
#         endif
        }

    }

# endif
}


FCode (p4_debug_colon_RT)
{
    FX (p4_colon_RT);
    if (!PFE.debugging)
    
{
        p4_debug_on ();
        do_single_step ();
        p4_debug_off ();
    }

}

static FCode (p4_debug_colon) 
{ /* dummy */ }

P4RUNTIME1(p4_debug_colon, p4_debug_colon_RT);

FCode (p4_debug_does_RT)
{
    FX (p4_does_RT);
    if (!PFE.debugging)
    
{
        p4_debug_on ();
        do_single_step ();
        p4_debug_off ();
    }

}

static FCode (p4_debug_does) 
{ /* dummy */ }

P4RUNTIME1(p4_debug_does, p4_debug_does_RT);

/** DEBUG ( 'word' -- )
   this word will place an debug-runtime into
   the => CFA of the following word. If the
   word gets executed later, the user will
   be prompted and can decide to single-step
   the given word. The debug-stepper is
   interactive and should be self-explanatory.
   (use => NO-DEBUG to turn it off again)
 */
FCode (p4_debug)
{
    p4xt xt;

    xt = p4_tick_cfa (FX_VOID);
    if (P4_XT_VALUE(xt) == FX_GET_RT (p4_debug_colon) 
      || P4_XT_VALUE(xt) == FX_GET_RT (p4_debug_does))
        return;
    else if (P4_XT_VALUE(xt) == FX_GET_RT (p4_colon))
        P4_XT_VALUE(xt) = FX_GET_RT (p4_debug_colon);
    else if (P4_XT_VALUE(xt) == FX_GET_RT (p4_does))
        P4_XT_VALUE(xt) = FX_GET_RT (p4_debug_does);
    else
        p4_throw (P4_ON_ARG_TYPE);
}


/** NO-DEBUG ( 'word' -- )
   the inverse of " => DEBUG word "
 */
FCode (p4_no_debug)
{
    p4xt xt;

    xt = p4_tick_cfa (FX_VOID);
    if (P4_XT_VALUE(xt) == FX_GET_RT (p4_debug_colon))
        P4_XT_VALUE(xt) = FX_GET_RT (p4_colon);
    else if (P4_XT_VALUE(xt) == FX_GET_RT (p4_debug_does))
        P4_XT_VALUE(xt) = FX_GET_RT (p4_does);
    else
        p4_throw (P4_ON_ARG_TYPE);
}


/** (SEE) ( xt -- )
   decompile the token-sequence - used
   by => SEE name
 */
FCode (p4_paren_see)
{
    p4_decompile (0, (void*)FX_POP);
}


/** ADDR>NAME ( addr -- nfa|0 )
   search the next corresponding namefield that address
   is next too. If it is not in the base-dictionary, then
   just return 0 as not-found.
 */
_export const p4char *
p4_addr_to_name (const p4char* addr)
{
    Wordl* wl;
    int t;
    p4char const * nfa;
    p4char const * best = 0;

    if (addr >  DP) return 0;
    if (addr < PFE.dict) return 0;

    /* foreach vocobulary */
    for (wl = VOC_LINK; wl; wl = wl->prev)
    
{
        /* foreach thread */
        for (t=0; t < THREADS; t++)
        
{
            nfa = wl->thread[t];
            /* foreach name in linked names */
            while (nfa)
            
{
                if (nfa < addr && best < nfa)
                
{
                    best = nfa;
                }

                nfa = *p4_name_to_link(nfa);
            }

        }

    }

    return best;
}


/** ADDR>NAME ( addr -- nfa|0 )
   search the next corresponding namefield that address
   is next too. If it is not in the base-dictionary, then
   just return 0 as not-found.
 */
FCode (p4_addr_to_name)
{
    *SP = (p4cell) p4_addr_to_name((p4char*)(*SP));
}


/** COME_BACK ( -- )
   show the return stack before last exception
   along with the best names as given by => ADDR>NAME
 */
FCode (p4_come_back)
{
# ifdef PFE_SBR_CALL_THREADING
    p4_outs ("come_back not implemented in sbr-threaded mode\n");
# else
    char const * nfa;
    p4xcode** rp = (p4xcode**) p4_CSP;

    if (PFE.rstack < rp && rp < PFE.r0)
    
{
        if (PFE.dict < (p4char*) *rp && (p4char*) *rp < PFE.dp
          && (nfa = p4_addr_to_name ((void*)((*rp)[-1]))))
        
{
            p4_outf ("[at] %08p ' %.*s (%+d) \n", *rp, NFACNT(*nfa), nfa+1,
              ((p4xt) *rp) - (p4_name_from(nfa)));
        }
else
{
            p4_outf ("[at] %08p (???) \n", *rp);
        }


        while (rp < RP)
        
{
            nfa = p4_addr_to_name ((void*)(*rp));
            if (nfa)
            
{
                p4_outf ("[%02d] %08p ' %.*s (%+d) \n", 
                  RP-rp, *rp, NFACNT(*nfa), nfa+1, 
                  ((p4xt) *rp) - (p4_name_from(nfa)));
            }
else
{
                p4_outf ("[%02d] %08p   %+ld \n", 
                  RP-rp, *rp, (long) *rp);
            }

            rp++;
        }

    }
else
{
        p4_outs (" come_back csp trashed, sorry \n");
    }

# endif
}


P4_LISTWORDS (debug) =
{
    P4_INTO ("FORTH", 0),
    P4_FXco ("DEBUG",		p4_debug),
    P4_FXco ("NO-DEBUG",	p4_no_debug),
    P4_FXco ("(SEE)",		p4_paren_see),
    P4_FXco ("ADDR>NAME",	p4_addr_to_name),
    P4_FXco ("COME_BACK",	p4_come_back),

    P4_INTO ("ENVIRONMENT", 0),
    P4_DCON ("PFE-DEBUG",	maxlevel),
}
;
P4_COUNTWORDS (debug, "Debugger words");

/*@}*/