/** 
 *  Implements dictionary and wordlists.
 *
 *  Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
 *
 *  @see     GNU LGPL
 *  @author  Tektronix CTE              @(#) %derived_by: guidod %
 *  @version %version: bln_mpt1!5.55 %
 *    (%date_modified: Wed Sep 11 13:17:53 2002 %)
 */
/*@{*/

#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  dict-sub.c~bln_mpt1!5.55:csrc:bln_12xx!1 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/def-xtra.h>

#include <string.h>
#include <ctype.h>
#include <stddef.h> /*offsetof*/
#include <stdlib.h>

#include <pfe/def-comp.h>
#include <pfe/term-sub.h>
#include <pfe/lined.h>
#include <pfe/_missing.h>
#include <pfe/logging.h>

#define UPPERMAX 32
#define UPPERCOPY(_upper_, _nm_, _l_) \
        if ((_l_) < UPPERMAX)         \
        { memcpy ((_upper_), (_nm_), (_l_)); p4_upper ((_upper_), (_l_)); }  \
        else                          \
        { *(int*)(_upper_) = 0; }

/*
 * A vocabulary is organized as a mixture between hash-table and
 * linked list. (This is a practice you can observe in several
 * systems.) It works like this: Given a name, first a hash-code is
 * generated. This hash-code selects one of several linked lists
 * called threads. The hooks to these threads are stored in a table.
 *
 * The body of a WORDLIST is essentially such a table of pointers to
 * threads, while in FIG-Forth it was just a pointer to the one and
 * only linked list a VOCABULARY consists of in FIG-Forth.
 */
_export int
p4_wl_hash (const char *s, int l)
/* s string, l length of string, returns hash-code for that name */
{
#  if 0 /*GUD* original by DUZ */
    int n = *s++ - '@';

    while (--l > 0)
        n = n * 37 + *s++ - '@';        /* a maybe-stupid hash function :-) */
    return n & (THREADS - 1);   /* i.e. modulo threads */

#  else /*GUD* more simpler, avoiding multiply */
    register char c = *s;

    while(--l > 0)
    { c += *s++; c ^= l; }
    return c & (THREADS - 1);
#  endif
}

/*
 * If we want to traverse a WORDLIST in it's entirety, we must follow
 * all threads simultaneously. The following definition eases this by
 * locating the thread with the hook pointing to the highest memory
 * location, assuming that this thread contains the latest definition
 * entered in the given WORDLIST. For usage refer to the definition of
 * WORDS.
 *
 * When following a wordlist using topmost, a copy of the word list
 * must be made. Everytime the topmost item was processed it must be
 * replaced by its successor in the linked list.
 */

/* find the thread with the latest word in the given word list */
_export p4char **
p4_topmost (p4_Wordl *w)

{
    int n = THREADS;
    p4char **p, **s = w->thread;

    for (p = s++; --n; s++)
        if (*s > *p)
            p = s;
    return p;
}

/* return the NFA of the latest definition in the CURRENT WORDLIST */
_export p4char * 
p4_latest (void) 
{
    return *p4_topmost (CURRENT);
}

/* --------------------------------
 * word list and forget 
 */

/** 
 * create a word list in the dictionary 
 */
_export p4_Wordl *
p4_make_wordlist (p4char* nfa)
{
    p4_Wordl *w = (Wordl *) DP; /* allocate word list in HERE */
    P4_INC (DP, Wordl);
    
    ZERO (w->thread);           /* initialize all threads to empty */
    w->nfa = nfa;               /* set name for the wordlist (if any) */
    w->flag = WORDL_FLAG;       /* init flags from global flags */
    w->prev = VOC_LINK;         /* chain word list in VOC-LINK */
    VOC_LINK = w;
    w->id = w->prev ? (w->prev->id << 1) : 1;
    if (w->flag & WORDL_CURRENT)
        w->also = CURRENT;      /* if WORDL_CURRENT, search also this */
    else
        w->also = 0;
    return w;
}

_export p4_Wordl *
p4_find_wordlist (const char* nm, int nmlen)
{
    auto p4char upper[UPPERMAX];
    p4_Wordl* wl;
    char* nfa;
    UPPERCOPY(upper, nm, nmlen)

    /* a special, since FORTH has no vocabulary_RT anymore */
    if (nmlen == 5 && ! memcmp (nm, "FORTH", 5))
        return PFE.forth_wl;
    if (nmlen == 11 && ! memcmp (nm, "ENVIRONMENT", 11))
        return PFE.environ_wl;

    for (wl = VOC_LINK; wl ; wl = wl->prev)
    {
        if (! wl->nfa) continue;
        nfa = wl->nfa;
        if (NFACNT(*nfa) != nmlen) continue;
        if (!memcmp (nfa+1, nm, nmlen) || !memcmp (nfa+1, upper, nmlen))
            return wl;
    }
    return 0;
}

/** ((FORGET)) 
 * remove words from dictionary, free dictionary space, this is the
 * runtime helper of (FORGET)
 */
FCode (p4_forget_dp)
{
    register p4_Wordl *wl;
    register p4char* new_dp = PFE.forget_dp;

    /* unchain words in all threads of all word lists: */
    for (wl = VOC_LINK; wl; wl = wl->prev)
    {
        p4char **p = wl->thread;
        int i;
       
	if (0) if (wl->nfa) 
	    fprintf(stderr,"\"%.*s\"", NFACNT(*wl->nfa), wl->nfa+1);

        for (i = THREADS; --i >= 0; p++)
        {  /* unchain words in thread: */
            while (*p >= new_dp) 
            {
                if (PFE_IS_DESTROYER(*p))
                {
                    P4_info2 (" destroy: \"%.*s\"", NFACNT(**p), *p+1);
                    p4_call (p4_name_from (*p));
                    new_dp = PFE.forget_dp; /* forget_dp is volatile */
                    /* and may have changed through recursive forget */
                }
                *p = *p4_name_to_link (*p);
            }
        }
    }

    /* unchain word lists: */
    while (VOC_LINK && VOC_LINK >= (p4_Wordl *) new_dp) 
    {   
        {   /* delete from search-order */   
            int i;
            for (i=0; i < PFE_set.wordlists; i++) 
            {
                if (CONTEXT[i] == VOC_LINK) 
                {
                    CONTEXT[i] = NULL;
                    if (! PFE.atexit_running)
                    {
                        const p4char* nfa = VOC_LINK->nfa ? VOC_LINK->nfa 
                            : (const p4char*) "\1?";
                        P4_note3 ("deleted '%.*s' "
                                  "from context search-order [%i]", 
                                  NFACNT(*nfa), nfa+1, i);
                    }
                }
            
                if (PFE.dforder[i] == VOC_LINK) 
                {
                    PFE.dforder[i] = NULL;
                    if (! PFE.atexit_running)
                    {
                        const p4char* nfa = VOC_LINK->nfa ? VOC_LINK->nfa 
                            : (const p4char*) "\1?";
                        P4_note3 ("deleted '%.*s' "
                                  "from default search-order [%i]", 
                                  NFACNT(*nfa), nfa+1, i);
                    }
                }
            }
        }
        
        VOC_LINK = VOC_LINK->prev;
    }
    
    /* compact search-order */
    { register int i, j;
      for (i=0, j=0; i < PFE_set.wordlists; i++)
      {
        if (CONTEXT[i]) CONTEXT[j++] = CONTEXT[i];
      }
      while (j < PFE_set.wordlists) CONTEXT[j++] = NULL;

      for (i=0, j=0; i < PFE_set.wordlists; i++)
      {
        if (PFE.dforder[i]) PFE.dforder[j++] = PFE.dforder[i];
      }
      while (j < PFE_set.wordlists) PFE.dforder[j++] = NULL;
    }
    
    /* free dictionary space: */
    DP = (p4char *) new_dp; 
    LAST = NULL;
    PFE.forget_dp = 0;

    if (CURRENT >= (p4_Wordl *) new_dp) 
    {
        if (CONTEXT[0]) CURRENT = PFE.forth_wl; /* initial CURRENT */
        if (! PFE.atexit_running)
            p4_throw (P4_ON_CURRENT_DELETED);  /* and still throw */
    }
}

/** (FORGET)
 * forget anything above address
 */
_export void
p4_forget (char* above)
{
    if ((p4char*) above < FENCE)
        p4_throw (P4_ON_INVALID_FORGET);

    if (PFE.forget_dp) /* some p4_forget_dp already started */
    {
        /* P4_info1 ("recursive forget %p", above); */
        if (PFE.forget_dp > above) 
        {
            PFE.forget_dp = above; /* update p4_forget_dp argument */
        }
    }else{ 
        /* P4_info1 ("forget start %p", above); */
        PFE.forget_dp = above; /* put new argument for p4_forget_dp */
        FX (p4_forget_dp);     /* forget execution start */
    }
}

FCode_RT (p4_destroyer_RT)
{   
    /* this code is a trampoline for ITC code not using an FFA flag.
     * we just expect the a prior p4_call in p4_forget has setup an
     * appropriate BODY pointer - either it goes through a p4WP or
     * indirectly through p4IP. All we have to do is, to fetch the
     * actual ccode from PFA[1] and branch down into the target code.
     */
#   if ! defined PFE_CALL_THREADING
    ((p4code*)(P4_WP_PFA))[1](FX_VOID);
#   elif ! defined PFE_SBR_CALL_THREADING /* not actually ever compiled */
    ((p4code*)(*IP))[1](FX_VOID); /* CTC, (*IP) would have the BODY-pointer */
#   else
    P4_fail (
        "you are not supposed to have a destroyer_RT in this configuration");
#   endif
}

P4RUNTIME1_RT(p4_destroyer);

/**
 * create a destroyer word. Upon FORGET the code will will be
 * run with the given argument. The structure is code/CFA and what/PFA.
 */
_export char*
p4_forget_word (const char *name, p4cell id, p4code ccode, p4cell what)
{
    char nm[255]; /* better as POCKET ? */
    sprintf (nm, name, id);

#  if defined PFE_WITH_FFA  && ! defined PFE_CALL_THREADING
    {
	p4_header_comma (nm, strlen(nm), PFE.atexit_wl);
	*_FFA(LAST) |= (P4xIMMEDIATE|P4xONxDESTROY);
	FX_RCOMMA (ccode); /*cfa*/
	FX_VCOMMA (what);  /*pfa*/
    }
#  elif ! defined PFE_CALL_THREADING
    {
	p4_header_comma (nm, strlen(nm), PFE.atexit_wl);
	*_FFA(LAST) |= (P4xIMMEDIATE|P4xONxDESTROY);
	FX_RUNTIME1_RT (p4_destroyer);
	FX_VCOMMA (what); /*pfa*/
	FX_RCOMMA (ccode); /*pfa+1*/
    }
#  else /* PFE_CALL_THREADING and up, p4_call uses INFO-block */
    {
	p4Word* w = (p4xt) p4_DP;
	FX_RCOMMA ("~"); /* trampoline with body */
	FX_RCOMMA (ccode);
	p4_header_comma (nm, strlen(nm), PFE.atexit_wl);
	*_FFA(LAST) |= (P4xIMMEDIATE|P4xONxDESTROY);
	FX_PCOMMA (w);    /* cfa = word-comp-info */
	FX_VCOMMA (what); /* pfa */
    }
#  endif    
    
    return LAST;
}

/* ------------------------------ 
 * search a header 
 */

static char *
search_thread (const char *nm, int l, char *t, p4cell wl_flag )
{
    auto char upper[UPPERMAX];
    if (l > NFACNTMAX)
        return NULL;

# if P4_LOG /* additional sanity check */
    if (p4_LogMask & P4_LOG_DEBUG) /* if any debug level */
        if (t && !((char*)PFE.dict <= t && t <= (char*)PFE.dictlimit)) 
        { 
            P4_fail3 ("hashlink pointer invalid %p in search for '%.*s'", 
              t, l, nm);
        }
# endif

    if( LOWER_CASE && (wl_flag & WORDL_NOCASE) )
    {   /* pfe 33.x will have this mode removed: */
        while (t)
        {
            if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*t) == l)
            {
                if (!p4_strncmpi (nm, t+1, l))  break;
            }
            t = *p4_name_to_link (t);
        }
        if (t && (wl_flag & WORDL_UPPER_CASE) && memcmp (nm, t+1, l)) 
        {   /* does not match case-sensitive */
            UPPERCOPY (upper, nm, l);
            if (memcmp (upper, t+1, l)) 
            {  /* and neither the upper-case form */
#             if defined _K12_SOURCE && defined VXWORKS
                p4_outf ("(warning: input '%.*s' hits '%.*s': bad spelling?)", 
                          l, nm, l, t+1);
#             endif
                P4_warn4 ("oops, input '%.*s' hits '%.*s': bad spelling?", 
                          l, nm, l, t+1);
                P4_info4 ("- the input word '%.*s' might not match '%.*s'"
                          "in the future - please fix it now.", l, nm, l, t+1);
            }
        }
    }else if( UPPER_CASE && (wl_flag & WORDL_UPPER_CASE) )
    {   /* note: p4_match/p4_search_incomplete */
        UPPERCOPY (upper, nm, l);

        /* this thread does contain some upper-case defs 
           AND lower-case input shall match those definitions */
        while (t)
        {
            if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*t) == l)
            {
                if (!memcmp (nm, t+1, l))  break;
                if (!memcmp (upper, t+1, l)) break;
            }
            t = *p4_name_to_link (t);
        }
    }else{
        /* input is case-sensitive OR vocabulary contains mixed-case defs */
        while (t)
        {
            if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*t) == l)
            {
                if (!memcmp (nm, t+1, l))  break;
            }
            t = *p4_name_to_link (t);
        }
    }

    return t;
}

_export char *
p4_search_wordlist (const char *nm, int l, const p4_Wordl *w)
{
    if( w->flag & WORDL_NOHASH )
    { return search_thread (nm, l, w->thread[0], w->flag ); }
    else
    { return search_thread (nm, l, w->thread[p4_wl_hash (nm, l)], w->flag ); }
}

/* search all word lists in the search order for name, return NFA 
 * (we use the id speedup here - the first WLs have each a unique bitmask
 *  in the wl->id. Especially the FORTH wordlist can be present multiple
 *  time - even in being just search via wl->also. With w->id each is just
 *  searched once - atleast for each of the WLs that have gotten an id-bit
 *  which on a 32bit system are 32 WLs - enough for many system setups.
 *  It might be possible to use the old code even here (that walked the
 *  ORDER to see if the next WL is present in an earlier slot) but in a
 *  system with so many vocs it is quite improbable to find duplicates
 *  other than the basic vocs like FORTH in there anyway - so we use this
 *  one that might search a WL twice theoretically. Tell me of occasions
 *  where that is really a problem - in my setups it happens that the ORDER
 *  overflows much before getting duplicates other than the basic wordlists.
 */
_export char *
p4_find (const char *nm, int l)
{
    register Wordl **p;
    register Wordl *wordl;
    register char *w = NULL;
    register int n = p4_wl_hash (nm, l);
    register p4ucell searched = 0;
    
    for (p = CONTEXT; p <= &ONLY; p++)
    {
        for (wordl = *p; wordl ; wordl=wordl->also)
	{
	    if (searched&wordl->id)
		continue;
	    searched |= wordl->id;

            if( wordl->flag & WORDL_NOHASH )
                w = search_thread (nm, l, wordl->thread[0], wordl->flag );
            else
                w = search_thread (nm, l, wordl->thread[n], wordl->flag );

	    if (w) return w;
        }
    }
    return w; /*0*/
}

/**
 * tick next word,  and
 * return count byte pointer of name field (to detect immediacy)
 */
_export char *
p4_tick_nfa (void) 
{
    register char *p;

    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    p = p4_find (PFE.word.ptr, PFE.word.len);
    if (! p)
        p4_throw (P4_ON_UNDEFINED);
    return p;
}

/**
 * tick next word,  and return xt
 */
_export p4xt
p4_tick_cfa (void)
{
    return p4_name_from (p4_tick_nfa ());
}

#if 0

/**
 * tick next word, store p4xt in xt, and
 * return count byte pointer of name field (to detect immediacy)
 */
___export char *
p4_tick (p4xt *xt)
{
    register char *p = p4_tick_nfa ();
    *xt = p4_name_from (p);
    return p;
}

#endif

/* ---------------------------
 * create a header 
 */

/* writes counted string into dictionary, returns address */
_export char *
p4_string_comma (const char *s, int len)
{
    char *p = (char *) DP;
    
    if (len >= (1 << CHAR_BIT))
        p4_throw (P4_ON_ARG_TYPE);
    *DP++ = len;                /* store count byte */
    while (--len >= 0)          /* store string */
        *DP++ = (p4char) *s++;
    FX (p4_align);
    return p;
}

/*
 *  char*                       |* use FX(p4_parse_comma_quote) !!! *|
 *  p4_parse_comma(char del)
 * {
 *    p4_word_parse (del); |* PARSE-WORD-NOTHROW *|
 *    return p4_string_comma (PFE.word.ptr, (int) PFE.word.len);
 * }
 */

/* ----------------------
 * words with wildcards 
*/

/*
 * Show words in word list matching pattern, and of one of the
 * categories in string `categories'. NULL pointer or zero length
 * string means all kinds of words.
 */
_export void
p4_wild_words (const p4_Wordl *wl, const char *pattern, const char *categories)
{
    p4char **t;
    /* Wordl wcopy = *wl;          // clobbered while following it */
    Wordl wcopy; memcpy (&wcopy, wl, sizeof(wcopy));

# ifndef WILD_TAB
# define WILD_TAB 26 /* traditional would be 20 (26*4=80), now 26*3=78 */
# endif

    FX (p4_cr);
    FX (p4_start_Q_cr);
    if (categories && *categories == '\0')
        categories = NULL;
    for (t = p4_topmost (&wcopy); *t; t = p4_topmost (&wcopy))
    {
        char wbuf[NFACNTMAX+1];
        p4char *w = *t;
        p4char **s = p4_name_to_link (w);
        int l = NFACNT(*w++);
        p4_store_c_string (w, l, wbuf, sizeof wbuf);
        if (p4_match (pattern, wbuf, wl->flag & P4_UPPER_CASE_FLAGS))
        {
	    char c = p4_category (*P4_TO_CODE(P4_LINK_FROM (s)));
            if (! categories || strchr (categories, c))
            {
                if (p4_OUT+WILD_TAB - p4_OUT%WILD_TAB + 2 + l > p4_COLS ||
                    p4_OUT+WILD_TAB - p4_OUT%WILD_TAB + WILD_TAB*2/3 > p4_COLS)
                {
                    if (p4_Q_cr ())
                        break;
                }else{
                    if (p4_OUT)
                        p4_tab (WILD_TAB);
                }
                p4_outf ("%c %.*s ", c, l, w);
            }
        }
        *t = *s;
    }
}

#ifdef _use_pfe_old_style_search_incomplete

/* completion of word against dictionary */
static p4char *
search_incomplete (const char *nm, int l, Wordl *w)
/*
 * traverses the entire given wordlist to find a matching word
 * caution: clobbers *w. This is needed to be able to continue the search.
 */
{
    auto char upper[UPPERMAX];
    p4char **t, *s;

    if (w->flag & P4_UPPER_CASE_FLAGS)
    {
        UPPERCOPY(upper, nm, l);
    }
    
    for (t = p4_topmost (w); *t; t = p4_topmost (w))
    {
        s = *t;
        *t = *p4_name_to_link (*t);

        if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*s) >= l)
        {
            if (NFACNT(*s) <= UPPERMAX) 
            { if (!memcmp (upper, s+1, l)) return s; }
            if (! memcmp (nm, s+1, l))  return s;
        }
    }
    return NULL;
}

/*
 * Try to complete string in/len from dictionary.
 * Store completion in out (asciiz), return number of possible completions.
 * If display is true, display alternatives.
 * (if (display && !len) { don't print 200 words, just the number })
 */
static int
p4_complete_word (const char *in, int len, char *out, int display)
{
    Wordl w, *wl, **p;
    char *s = NULL, *t = NULL;  
    int n = 0, m = 0, cnt = 0, searched_n = 0;
    Wordl* searched[32] = {0}; 
    
    for (p = CONTEXT; p <= &ONLY; p++)
    {
        for (wl = *p; wl; wl = wl->also ) 
        {
            for (n=0; n < searched_n; n++)
                if (wl == searched[n])
                    break;       /* continue at second outer for */
            if (wl == searched[n]) 
                continue;        /* must expressed like that in C*/
        
            if (searched_n < 32) 
                searched[searched_n++] = wl;
             
            for (w = *wl; (t = search_incomplete (in, len, &w)) != NULL; cnt++)
            {
                if (display && len) 
                {
                    FX (p4_space);
                    p4_type_on_line (t + 1, NFACNT(*t));
                }
                if (! s) 
                {
                    s = t + 1;
                    m = NFACNT(*t);
                }else{
                    ++t;
                    for (n = 0; n < m; n++)
                        if (s[n] != t[n])
                            break;
                    m = n;
                }
            }
        }
    }
    if (cnt)
        p4_store_c_string (s, m, out, NFACNTMAX+1);
    if (display && !len)
    { p4_outf (" %i words ", cnt); }
    return cnt;
}

#else

static char *
search_thread_inco (const char *nm, int l, char *t, p4cell wl_flag )
{  /* compare with p4_search_thread */
    auto char upper[UPPERMAX];
    if (l > NFACNTMAX)
        return NULL;

    if( UPPER_CASE && (wl_flag & WORDL_UPPER_CASE) )
    {   /* note: p4_match/p4_search_incomplete */
        UPPERCOPY (upper, nm, l);

        /* this thread does contain some upper-case defs 
           AND lower-case input shall match those definitions */
        while (t)
        {
            if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*t) >= l)
            {
                if (!memcmp (nm, t+1, l))  break;
                if (!memcmp (upper, t+1, l)) break;
            }
            t = *p4_name_to_link (t);
        }
    }else{
        /* input is case-sensitive OR vocabulary contains mixed-case defs */
        while (t)
        {
            if ( !(*_FFA(t) & P4xSMUDGED) && NFACNT(*t) >= l)
            {
                if (!memcmp (nm, t+1, l))  break;
            }
            t = *p4_name_to_link (t);
        }
    }
    return t;
}

static char *
find_next_incomplete (const char *nm, int l, char* old)
{   /* compare with p4_find */
    register Wordl **p, **q;
    register Wordl *wordl;
    register char *w = NULL;
    register int n;
    register p4ucell searched = 0;
    
    for (p = CONTEXT; p <= &ONLY; p++)
    {
        for (q = CONTEXT; q < p; q++)
        {
            if (!*q) continue;
            if (*q == *p) goto continue_outer;
        }

        for (wordl = *p; wordl ; wordl=wordl->also)
	{
            /* we _must_ ensure that no world-thread is searched twice unlike
             * p4_find, so just skip any wordl that does not have an id for
             * the search_also case. Generally, we do not miss any word thus.
             */
            if (! wordl->id) 
                continue;  
	    if (searched & wordl->id)
		continue;
	    searched |= wordl->id;
            
            for (n = 0; n < THREADS; n++)
            {
                w = wordl->thread[n];
                while (w)
                {
                    w = search_thread_inco (nm, l, w, wordl->flag );

                    if (w) 
                    {
                        if (! old)               /* search all wordl-threads */
                            return w;            /* until "old" is found     */
                        if (old == w)            /* then return the next nfa */
                            old = 0;             /* found after that one -   */
                        w = *p4_name_to_link(w); /* and if old-arg was null  */
                    }                            /* it returns the first w   */
                } /* while (w) */
            }
        }
    continue_outer:
        continue;
    }
    return w; /*0*/
}

/*
 * Try to complete string in/len from dictionary.
 * Store completion in out (asciiz), return number of possible completions.
 * If display is true, display alternatives.
 * (if (display && !len) { don't print 200 words, just the number })
 */
static int
p4_complete_word (const char *in, int len, char *out, int display)
{
    char *s = NULL, *t = NULL;  
    int n = 0, m = 0, cnt = 0;

    while ((t = find_next_incomplete(in, len, t)))
    {
        cnt ++;
        if (display && len) 
        {
            FX (p4_space);
            p4_type_on_line (t + 1, NFACNT(*t));
        }
        if (! s) 
        {
            s = t + 1;
            m = NFACNT(*t);
        }else{
            for (n = 0; n < m; n++)
                if (s[n] != (t+1)[n])
                    break;
            m = n;
        }
    }
    if (cnt)
        p4_store_c_string (s, m, out, NFACNTMAX+1);
    if (display && !len)
    { p4_outf (" %i words ", cnt); }
    return cnt;
}

#endif

_export int
p4_complete_dictionary (char *in, char *out, int display)
{
    char *lw, buf[NFACNTMAX+1];
    int n;
    
    lw = strrchr (in, ' ');
    if (lw)
        lw++;
    else
        lw = in;
    memcpy (out, in, lw - in);
    n = p4_complete_word (lw, strlen (lw), buf, display);
    strcpy (&out[lw - in], buf);
    return n;
}

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

/** ONLY ( -- )
 * the only-vocabulary is special. Calling it will erase
 * the search ORDER of vocabularies and only allows
 * to name some very basic vocabularies. Even ALSO
 * is not available.
 example:
   ONLY FORTH ALSO EXTENSIONS ALSO DEFINITIONS
 */
FCode (p4_only_RT)
{
    /* NO BODY_ADDR */
    memset(CONTEXT, 0, PFE_set.wordlists*sizeof(p4_Wordl*));
    CONTEXT[0] = CURRENT = ONLY;
}

P4RUNTIMES1_RT(p4_only, P4_ONLY_CODE1);

/** FORTH ( -- )
 : FORTH FORTH-WORDLIST CONTEXT ! ;
 */
FCode (p4_forth_RT)
{
    /* NO BODY_ADDR */
    CONTEXT[0] = PFE.forth_wl;
}

P4RUNTIMES1_RT(p4_forth, P4_ONLY_CODE1);

_export void
p4_preload_only (void)
{
    auto p4_Wordl only;                   /* scratch ONLY word list */
    
    DP = (p4char *) & PFE.dict[1];
  
    /* Load the ONLY word list to the scratch ONLY: */
    memset (&only, 0, sizeof only);
    /* # only.flag |= WORDL_NOHASH; */
    p4_header_comma ("ONLY", 4, &only ); FX_RUNTIME1_RT(p4_only);
    ONLY = p4_make_wordlist (LAST);
    /* # ONLY->flag |= WORDL_NOHASH; */
    COPY (ONLY->thread, only.thread);   /* Copy scratch ONLY to real ONLY */
    CURRENT = ONLY;

    /* FORTH -> [ANS] -> ONLY */
    p4_header_comma ("FORTH", 5, ONLY); FX_RUNTIME1_RT(p4_forth);
    PFE.forth_wl = p4_make_wordlist (LAST); 
    p4_header_comma ("[ANS]", 5, ONLY); FX_RUNTIME1(p4_vocabulary);
    FX_IMMEDIATE;
    PFE.forth_wl->also = p4_make_wordlist (LAST);
    PFE.forth_wl->also->also = ONLY;

    /* destroyers :: LOADED */
    p4_header_comma ("LOADED", 6, ONLY); FX_RUNTIME1(p4_vocabulary);
    PFE.atexit_wl = p4_make_wordlist (LAST); 
    PFE.atexit_wl->flag |= WORDL_NOHASH; /* see environment_dump in core.c */

    /* ENVIRONMENT -> LOADED */
    p4_header_comma ("ENVIRONMENT",11, ONLY); FX_RUNTIME1(p4_vocabulary);
    FX_IMMEDIATE;
    PFE.environ_wl = p4_make_wordlist (LAST);
    PFE.environ_wl->also = PFE.atexit_wl;
    PFE.environ_wl->flag |= WORDL_NOHASH;          /* for option-ext */
    PFE.environ_wl->thread[0] = PFE.set->opt.link; /* that goes here */
}

/*@}*/

/*
 * Local variables:
 * c-file-style: "stroustrup"
 * End:
 */