/**
 * 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 word.
 *  	The next time the word 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 word. There is a prompt gt; to
 *	the right of the displayed word. At this prompt you have several
 *	options. Choose one by typing a key ([h] shows helpscreen):
 *
 *	

 *	
 [enter], [x], [k], [down] 
  

 *	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.
 *      
 *	
 [d], [l], [right] 

 *	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.
 *      
 *      
 [s], [j], [left] 

 *	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.
 *	
 *	
 [space] 

 *	The next word to be executed is decompiled. This should help 
 *	to decide as if to single step that word.
 *	
 *	
 [q] 

 *	Quits from the debugger. The execution of the debugged word is
 *	not continued. The stacks are not cleared or changed.
 *	
 *	
 [c] 

 *	Displays the profiling instruction counter.
 *	
 [r] 

 *	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.
 *	
 *	
 */
/*@{*/

#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_COUNTWORDS (debug, "Debugger words");

/*@}*/