/** 
 * -- useful additional primitives
 *
 *  Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
 *
 *  @see     GNU LGPL
 *  @author  Tektronix CTE              @(#) %derived_by: guidod %
 *  @version %version: bln_mpt1!1.58 %
 *    (%date_modified: Tue Feb 25 13:22:45 2003 %)
 *
 *  @description
 *              This wordset adds some additional primitives that
 *		are useful. The structure of this file follows the
 *              the example in your-ext.c, yet some of the words here
 *              must be bound statically into the main pfe-object to
 *              work out smart and nicely.
 */
/*@{*/

#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  useful-ext.c~bln_mpt1!1.58: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 <pfe/dict-sub.h>
#include <pfe/logging.h>
#include <pfe/def-restore.h>

/** 
 * see >COMPILE  and POSTPONE
 */
void p4_to_compile (p4xt xt)
{
    if (!xt) return;
    if (STATE && !(*_FFA(p4_to_name (xt)) & P4xIMMEDIATE))
        FX_XCOMMA (xt);
    else
        p4_call (xt);
}

/** >COMPILE ( xt -- )
 *  does the work of POSTPONE on the execution token that 
 *  you got from somewhere else - so it checks if the name
 *  (that correspond to the execution-token argument) is
 *  actually immediate, so it has to be executed to compile
 *  something, e.g. IF or THEN - see also POSTPONE ,
 *  COMPILE , [COMPILE] , INTERPRET
 */
FCode (p4_to_compile)
{
    p4_to_compile ((p4xt) FX_POP);
}

#define P4_PAREN_MAGIC P4_MAGIC_('P','(',')','X')

extern FCode (p4_tick);

/**  ($  ( [word] -- cs-token ) compile-only
 *  takes the execution token of the following word and
 *  saves it on the compile-stack. The correspondig closing
 *  ) will then feed it into >COMPILE - so this pair
 *  of word provides you with a prefix-operation syntax
 *  that you may have been seen in lisp-like languages.
   ($ IF ($ 0= A1 @ )) ($ THEN ." hello " )
 * Note that an opening simple ( paren is a comment.
 */
FCode (p4_prefix_begin)
{
    FX (p4_Q_comp);
    FX (p4_tick);
    FX_PUSH (P4_PAREN_MAGIC);
}

/**  )  ( cs-token -- )
 * takes the execution-token from ($ and compiles
 * it using >COMPILE
 */
FCode (p4_prefix_end)
{
    p4_Q_pairs (P4_PAREN_MAGIC);
    FX (p4_to_compile);
}

/**  ))  ( cs-token cs-token -- )
 * takes two execution-tokens from two of ($ and compiles
 * them on after another using >COMPILE
 simulate:
    : )) [COMPILE] ) [COMPILE] ) ; IMMEDIATE
 */
FCode (p4_prefix_end_doubled)
{
    p4_Q_pairs (P4_PAREN_MAGIC);
    FX (p4_to_compile);
    p4_Q_pairs (P4_PAREN_MAGIC);
    FX (p4_to_compile);
}

/* ----------- output convenience ---------- */

extern FCode (p4_emit);

/** 
 *  printing a forth counted string is done through %#s,
 *  the standard %s is ignored defending against invalid use,
 *  but it may be useful to use %1s to print a real
 *  zeroterminated-string.
 */
static int
p4sprintf (char* s)
{
    p4char formbuf[255];
    p4char* formed;
    p4char* format;
    int format_n;
    int argn = 0;
    p4cell argv[16];
    
    formed = formbuf;
    format = (void*)FX_POP; /* get the argument string */
    format_n = *format++; /* COUNT */
  
    while (format_n > 0)
    {
        if (*format=='%') {
            *formed++ = *format++; format_n--;
            if (*format == '%') {
                *formed++ = *format++; format_n--;
                continue;
            }
            if (*format == 's') {
                /* not sure what a normal string is in this context */
                *formed++ = '%'; /* so it is ignored */
                format++; format_n--;
                FX_DROP;
                continue;
            }
            argv [argn++] = FX_POP; 
            while (format_n > 0)
            {
                if (argn >= 15) goto printnow;
                if (format[0] == '.' && format[1] == '*') {
                    argv [argn++] = FX_POP;
                    *formed++ = *format++; format_n--;
                    *formed++ = *format++; format_n--;
                    continue;
                }
                
                if (format[0] == '#' && format[1] == 's') {
                    p4char* p = (void*) argv [argn-1];
                    argv [argn-1] = *p; argv [argn++] = (p4cell)(p+1); 
                    *formed++ = '.';
                    *formed++ = '*';
                    *formed++ = 's';
                    format+=2; format_n-=2;
                    break;
                }
                
                if (isalpha(*format))
                    break;
                
                *formed++ = *format++; format_n--;
            }
            continue;
        }
        /*else*/
        *formed++ = *format++; format_n--;
    }
 printnow:
    { 
        int printed;
        *formed='\0'; /* should we do it really here ? 
                         or let it do the caller -gud */
        
        if (argn <= 8)
        {
            printed = sprintf (s, formbuf, 
              argv[0], argv[1], argv[2], argv[3], 
              argv[4], argv[5], argv[6], argv[7]);
        }else{
#         ifdef P4_UPPER_REGS /* i960 */
            P4_CALLER_MKSAVED
#         endif
            printed = sprintf (s, formbuf, 
              argv[0], argv[1], argv[2], argv[3], 
              argv[4], argv[5], argv[6], argv[7],
              argv[8], argv[9], argv[10], argv[11], 
              argv[12], argv[13], argv[14], argv[15]);
            
#         ifdef P4_UPPER_REGS
            P4_CALLER_RESTORE
#         endif
            if (argn > 13)
            { P4_warn1 ("quite many args for a printf (%i)", argn); }
        }
        if (printed > 255)
        { P4_warn1 ("printf long string (%i chars)", printed); }
        return printed;
    }
}

/** PFE-SPRINTF ( args ... format$ dest$ -- len-dest ) 
 * just like the standard sprintf() function in C, but
 * the format is a counted string and accepts %#s to
 * be the format-symbol for a forth-counted string.
 * The result is a zeroterminated string at dest$ having
 * a length being returned. To create a forth-counted
 * string, you could use:
   variable A 256 ALLOT
   15 " example" " the %#s value is %i" A 1+ SPRINTF A C!
   A COUNT TYPE
 */
FCode (p4_sprintf)
{
    FX_PUSH (p4sprintf ((void*)FX_POP));
}

/** PFE-PRINTF ( args ... format$ -- )
 * uses SPRINTF to print to a temporary 256-char buffer
 * and prints it to stdout afterwards. See the example
 * at SPRINTF of what it does internally.
 */
FCode (p4_printf)
{
    char outbuf[256];
    p4sprintf (outbuf);
    p4_outs (outbuf);
}

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

void
p4_forget_loadf(void)
{   FX_USE_BODY_ADDR {
    char* dp = (char*) FX_POP_BODY_ADDR[0];

    p4_forget (dp);
}}

/** LOADF ( "filename" -- )
 *  loads a file just like INCLUDE but does also put
 *  a MARKER in the LOADED dictionary that you can
 *  do a FORGET on to kill everything being loaded
 *  from that file.
 */
FCode (p4_loadf)
{
    char filename[NFACNTMAX+1];
    char* dp = DP;
    char* fn = p4_word(' ');
    
    p4_store_c_string (fn+1, *fn, filename, NFACNTMAX+1);
    
    if (p4_included1 (fn + 1, *(p4char *)fn, 1))
        p4_forget_word ("%s", (p4cell)filename, p4_forget_loadf, (p4cell)dp);
}

char*
p4_loadf_locate(p4xt xt)
{
    int i;
    Wordl* wl = PFE.atexit_wl;
    
    /* look for a loadf-marker that is above xt and contains a
       forget address below xt. This should make sure that xt is
       really defined during that LOADF.
    */
    for (i = THREADS; --i >= 0; )
    {
        char* p = wl->thread[i];
        while (p)
        {
            p4xt cfa = p4_name_from(p);
            if (*P4_TO_CODE(cfa) == p4_forget_loadf
              &&  cfa > xt && xt > *(p4xt*)P4_TO_BODY(cfa)) 
                return p;
            
            p = *p4_name_to_link(p);
        }
    }
    return 0;
}

/**  (LOADF-LOCATE)  ( xt -- nfa )
 * the implementation of LOADF-LOCATE
 */
FCode(p4_paren_loadf_locate)
{
    *SP = (p4cell) p4_loadf_locate((p4xt) *SP);
}

/** LOADF-LOCATE ( "name" -- )
 * look for the filename created by LOADF that had been
 * defining the given name. LOADF has created a marker
 * that is above the INCLUDED file and that
 * marker has a body-value just below the 
 * INCLUDED file. Hence the symbol was defined during
 * LOADF execution of that file.
 : LOADF-LOCATE ?EXEC POSTPONE ' (LOADF-LOCATE) .NAME ;
 */
FCode(p4_loadf_locate)
{
    p4xt xt;
    FX (p4_Q_exec);
    if ((xt = p4_tick_cfa (FX_VOID)))
    {
        char* nfa = p4_loadf_locate(xt);
        if (nfa) p4_outf("%.*s", *nfa, nfa+1);
        else p4_outs("(unknown)");
    }
}

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

/**@name MAKE-words
 * this make-implementation is quite different from the usual 
 * doer..make implementation. Actually, doer and defer are the
 * same in pfe, ie. make will store the cfa wherever you want it,
 * even in a locals-variable! For that purpose, the make-execution
 * works on the following compiled layout:
   
   +-----------------+----------------+---------------+-----------+
   | (make-exec)-CFA | TO-data-token  | BRANCH-offset | colon-RT  |
   +-----------------+----------------+---------------+-----------+
   
 * note: I had to hack debug.c to work correctly on this. beware.
*/
/**@{*/

/** "(;AND)" ( -- )
 * compiled by ;AND
 */
FCode_XE (p4_semicolon_and_execution)
{
    FX_USE_CODE_ADDR;
    FX (p4_semicolon_execution);
    /* cannot use it in P4COMPILES directly, since it would prevent
       decompiler from acting on at that place 
    */
    FX_USE_CODE_EXIT;
}

#if !defined PFE_SBR_CALL_THREADING
#define FX_COMPILE1_p4_semicolon_and FX_COMPILE(p4_semicolon_and)
#define FX_COMPILE2_p4_semicolon_and FX_COMPILE(p4_semicolon_and)
#else
#define FX_COMPILE1_p4_semicolon_and FX_COMPILE1_p4_semicolon
#define FX_COMPILE2_p4_semicolon_and FX_COMPILE2_p4_semicolon
#endif

/* the 3 in MAKE-begin style is invariant, see debug.c */

#define P4_MAKE0_STYLE 3, 1, 0,  0, 4  /* almost like IF */
#define P4_MAKE1_STYLE 1, 0, -4, 1, 0  /* almost like THEN */

/**  ;AND  ( -- )
 * For the code piece between MAKE and ;AND , this word
 * will do just an EXIT . For the code outside of
 * the MAKE construct a branch-around must be resolved then.
 */                
FCode (p4_semicolon_and)
{
    /* almost a copy of FX(p4_semicolon); */
    extern FCode (p4_store);

    p4_Q_pairs (P4_MAKE_MAGIC);
    PFE.state = FX_POP;
    PFE.locals = (void*) FX_POP;
    PFE.semicolon_code = (void*) FX_POP;

    if (PFE.locals)
    {
        FX_COMPILE2_p4_semicolon_and;
        PFE.locals = NULL;
    }else{
        FX_COMPILE1_p4_semicolon_and;
    }

    /*
    if (PFE.semicolon_code)
    {
        PFE.semicolon_code ();
    }else{
    */
        if (PFE.state)
            FX (p4_forward_resolve); /* atleast resolve the branch */
        /*
    }
        */
}

P4COMPILES (p4_semicolon_and, p4_semicolon_and_execution,
        	P4_SKIPS_NOTHING, P4_MAKE1_STYLE);

/** "((MAKE-))" ( -- )
 * compiled by MAKE
 */
FCode_XE (p4_make_to_local_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH (IP+2);             /* push following colon-RT, ie. CFA */
    FX (p4_to_local_execution); /* let TO put it into local */
    FX_BRANCH;                  /* and branch over */
    FX_USE_CODE_EXIT;
}

/** "((MAKE))" ( -- )
 * compiled by MAKE
 */
FCode_XE (p4_make_to_execution)
{
    extern FCode(p4_is_execution);
    FX_USE_CODE_ADDR;
    FX_PUSH (IP+2);             /* push following colon-RT, ie. CFA */
    FX (p4_is_execution);       /* let IS put it into defer */
    FX_BRANCH;                  /* and branch over */
    FX_USE_CODE_EXIT;
}

/** DOER ( word -- )
 * In PFE it is a synonym to DEFER which a semistandard word.
 * Unlike DEFER, the DOER-vector was set with an a small
 * piece of code between MAKE and ;AND. The "DOER"-word
 * should be replaced with DEFER IS, which is easy since
 * the DEFER and DOER point to the same internal runtime.
 */

extern void FXCode (p4_defer);

/** MAKE ( [word] -- ) ... ;AND
 * make a seperated piece of code between MAKE and ;AND 
 * and on execution of the MAKE the named word is twisted
 * to point to this piece of code. The word is usually 
 * a DOER but the current implementation works 
 * on DEFER just as well, just as it does on other words who
 * expect to find an execution-token in its PFA. You could even
 * create a colon-word that starts with NOOP and can then make
 * that colon-word be prefixed with the execution of the code piece. 
 * This MAKE
 * does even work on LOCALS| and VAR but it is uncertain
 * what that is good for.
 */
FCode (p4_make)
{
    extern int p4_tick_local (p4xt*);
    p4xt xt;
    int n;

    if (STATE) 
    {
        if ((n = p4_tick_local(&xt)))
        {
            FX_COMPILE2(p4_make);
            FX_UCOMMA (n);
        }else{
            FX_COMPILE1(p4_make);
            FX_XCOMMA (xt);
        }
        FX (p4_forward_mark);  /* third token is empty, filled at ";and"  */
    } else {
        xt = p4_tick_cfa (FX_VOID);
        * (p4xt*) P4_TO_DOES_BODY(xt) = (p4xt) PFE.dp; 
        /* so DEFER points to colon_RT now */
    }
    FX_RCOMMA (PFX(p4_colon_RT)); /* the implicit CFA that we need */
    FX_PUSH (PFE.semicolon_code); PFE.semicolon_code = PFX(p4_semicolon_and);
    FX_PUSH (PFE.locals); PFE.locals = NULL;
    FX_PUSH (PFE.state); PFE.state = P4_TRUE;
    FX_PUSH (P4_MAKE_MAGIC);
}

P4COMPILES2(p4_make, p4_make_to_execution, p4_make_to_local_execution,
        	P4_SKIPS_TO_TOKEN, P4_MAKE0_STYLE);

/**@}*/

/** OFFSET-RT ( value -- value+offset )
 *  this runtime will add the body-value to the value at top-of-stack.
 *  used heavily in structure access words, compiled by /FIELD
 */
FCode_RT (p4_offset_RT)
{
    FX_USE_BODY_ADDR;
    *SP += FX_POP_BODY_ADDR[0];
}

/** +CONSTANT ( offset "name" -- )
 * create a new offsetword. The word is created and upon execution
 * it adds the offset, ie. compiling the OFFSET-RT runtime:
       ( address -- address+offset )
 * This word is just a convenience word, just use the word +FIELD 
 * directly and choose a DROP to flag the end of a current
 * offset-field declaration series. See also /FIELD series to
 * declare simple structures which end with a final CONSTANT to
 * memorize the complete size. The /FIELD style is more traditional.
 */
FCode (p4_offset_constant)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_offset_constant);
    FX_UCOMMA (*SP); FX_DROP;
}

P4RUNTIME1(p4_offset_constant, p4_offset_RT);

/** +FIELD ( offset "name" -- offset )
 * created a new name with an OFFSET-RT runtime using the given offset. 
 * Leave the offset-value untouched, so it can be modified with words
 * like CHAR+ and CELL+ and SFLOAT+ ; This word is the simplest way 
 * to declared structure access words in forth - the two STRUCT modules 
 * contain a more elaborate series of words. Use this one like:
 0                        ( a fresh definition is started )
 +FIELD zapp.a+ CHAR+     ( zero offset from the base of the struct )
 +FIELD zapp.b+ CELL+     ( no alignment, starts off at 1 from base )
 +FIELD zapp+   DROP      ( store size of complete zap structure )

 0 zapp+                  ( extend the zap structure )
 +FIELD zappx.c+ CELL+    ( a new field )
 +FIELD zappx+   DROP     ( and save it again )

 CREATE zapp1  0 zapp+ ALLOT ( a way to allocate a strucutre )

 zapp2 zapp.b+ @         ( read a value from the field )
 16 zapp2 zapp.b+ !      ( store a value in there )

 * this form is not the traditional form used in forth, it is however
 * quite simple. Use the simplefield declaration with /FIELD to
 * be compatible with traditional styles that build on top of sizeof
 * constants in forth (which are not part of the ANS Forth standard).
 */
FCode (p4_plus_field)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_offset_constant);
    FX_UCOMMA (SP[0]);
}

/** /FIELD ( offset size "name" -- offset+size )
 * created a new +FIELD name with an OFFSET-RT
 * of offset. Then add the size value to the offset so that
 * the next /FIELD declaration will start at the end of the
 * field currently declared. This word is the simplest way to
 * declared structure access words in forth - the two STRUCT modules 
 * contain a more elaborate series of words. This one is used like:
 0                        ( a fresh definition is started )
 /CHAR /FIELD ->zapp.a    ( zero offset from the base of the struct )
 /CELL /FIELD ->zapp.b    ( no alignment, starts off at 1 from base )
 CONSTANT /zapp           ( store size of complete zap structure )

 /zapp                    ( extend the zap structure )
 /CELL /FIELD ->zappx.c   ( a new field )
 CONSTANT /zappx          ( and save it again )

 CREATE zapp1 /zapp ALLOT ( a way to allocate a strucutre )
 /zapp BUFFER: zapp2      ( another way to do it, semi-standard )

 zapp2 ->zapp.b @         ( read a value from the field )
 16 zapp2 ->zapp.b !      ( store a value in there )

 * compare also with /CHAR /WCHAR /CELL /DCELL
 * and use +FIELD as the lowlevel word, can simulate as
 : /FIELD SWAP +FIELD + ;
 */
FCode (p4_slash_field)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_offset_constant);
    FX_UCOMMA (SP[1]);
    SP[1] += SP[0]; FX_DROP;
}

/** [NOT] ( a -- a' )
 * executes 0= but this word is immediate so that it does 
 * affect the cs-stack while compiling rather than compiling
 * anything. This is useful just before words like [IF] to
 * provide semantics of an [IFNOT]. It is most useful in
 * conjunction with "[DEFINED] word" as it the sequence
 * "[DEFINED] word [NOT] [IF]" can simulate "[IFNOTDEF] word"
 */
FCode (p4_bracket_not)
{
    extern FCode(p4_zero_equal);
    FX (p4_zero_equal);
}

/* ------------------------- */
p4char*
p4_nextlowerNFA(void* adr)
{
    p4char* nfa = 0;
    register Wordl* wl;

    for (wl = VOC_LINK; wl; wl = wl->prev)
    {
        p4char * n;
        int i;
        for (i = THREADS; --i >= 0; )
        {
            for (n = wl->thread[i]; n; )
            {
                if (nfa < NFA2FF(n) && NFA2FF(n) < (p4char*) adr)
                    nfa = n;
                n = *p4_name_to_link(n);
            }
        }
    }
    return nfa;
}

p4char*
p4_nexthigherNFA(void* adr)
{
    p4char* nfa = PFE.dp;
    register Wordl* wl;

    for (wl = VOC_LINK; wl; wl = wl->prev)
    {
        p4char * n;
        int i;
        for (i = THREADS; --i >= 0; )
        {
            for (n = wl->thread[i]; n; )
            {
                if (NFA2FF(n) < nfa && NFA2FF(n) > (p4char*) adr)
                    nfa = n;
                n = *p4_name_to_link(n);
            }
        }
    }
    return nfa;
}

/** REPLACE-IN ( to-xt from-xt n "name" -- )
 * will handle the body of the named word as a sequence of cells (or tokens) 
 * and replaces the n'th occurences of from-xt into to-xt. A negative value
 * will change all occurences. A zero value will not change any.
 */
FCode(p4_replace_in)
{
    int n;
    p4cell fr, to;
    p4cell* ex;
    p4cell* xt;

    xt = (p4cell*) p4_tick_cfa (FX_VOID);
    xt = p4_to_body((p4xt)xt); /* body for _colon_RT */
    ex = (p4cell*) p4_nexthigherNFA(xt);

    n  = FX_POP;
    fr = FX_POP;
    to = FX_POP;
    if (!n) return;
    for ( ; xt < ex-1; xt++)
    {
        if (*xt == fr) 
        {
            --n;
            if (!n) { *xt = to; return; }
            if (n < 0) *xt = to; 
        }
    }
}

/* ------------------------------------------------------------------- 
 * hex string
 */

static int hexval (char c)
{
  if (c >= '0' && c <= '9' ) return c - '0';
  if (c >= 'A' && c <= 'Z' ) return c - 'A' + 10;
  if (c >= 'a' && c <= 'z' ) return c - 'a' + 10;
  if (c == '*') return 0xF;
  if (c == '!') return 0x1;
  return 0;
}

/**  X"  ( "hex-q" -- bstring ) 
 * places a counted string on stack
 * containing bytes specified by hex-string
 * - the hex string may contain spaces which will delimit the bytes
 example: 
    X" 41 42 4344" COUNT TYPE ( shows ABCD )
 */
FCode (p4_x_quote)
{
    register char *ps, *p, *q;
    register p4ucell n, i, pc;
    register unsigned int v;
    
    if (STATE) { FX_COMPILE (p4_x_quote); p = DP;  } 
    else { p = p4_pocket (); }
    
    p4_word_parse ('"'); *DP=0; /* PARSE-NOHERE */
    q = PFE.word.ptr;
    n = PFE.word.len;
    
    ps = p+1; pc = 0;
    
    i = 0;
    while (i < n)
    {
        while (q[i] == ' ' && i < n)  i++; /* skip whitespace */
        if (i >= n) break;
        
        v = hexval (q[i]); i++;
        if (i < n && q[i] != ' ')
        {
            v <<= 4; v |= hexval (q[i]);
            i++;
        }
        
        *ps++ = v; pc++; /* store on dest, pc is the count stored */
    }
    
    *p = pc; /* set count byte */
    
    if (STATE) { DP += pc + 1;  FX (p4_align); }
    else { FX_PUSH ((p4cell) p); }
}

extern FCode (p4_c_quote_execution);

P4COMPILES (p4_x_quote, p4_c_quote_execution,
            P4_SKIPS_STRING, P4_DEFAULT_STYLE);

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

/** [VOCABULARY] ( "name" -- )
 * create an immediate vocabulary. Provides for basic 
 * modularization.
 : [VOCABULARY] VOCABULARY IMMEDIATE ;
 */
FCode (p4_bracket_vocabulary)
{
    extern FCode (p4_vocabulary);

    FX (p4_vocabulary);
    *_FFA(LAST) |= P4xIMMEDIATE;
}

/** [POSSIBLY] ( [name] -- ?? )
 * check if the name exists, and execute it immediatly
 * if found. Derived from POSSIBLY as seen in other forth systems.
 : [POSSIBLY] (') ?DUP IF EXECUTE THEN ; IMMEDIATE
 */
FCode (p4_bracket_possibly)
{
    p4xt cfa;
    char* p = p4_word (' ');
    if (! p) return;
    p = p4_find ((char *) p+1, *(p4char*) p);
    if (! p) return;
    cfa = p4_name_from (p);
    if (! cfa) return;
    PFE.execute (cfa);
}

/** [DEF] ( -- )
 * immediatly set topmost CONTEXT voc to CURRENT compilation voc.
 : DEF' CURRENT @ CONTEXT ! ; IMMEDIATE
 * note that in PFE most basic vocabularies are immediate, so that
 * you can use a sequence of
 FORTH ALSO  DEFINITIONS
 [DEF] : GET-FIND-3  [ANS] ['] FIND  [FIG] ['] FIND  [DEF] ['] FIND ;
 * where the first wordlist to be searched via the search order are
 * [ANS] and [FIG] and FORTH (in this order) and which may or may not 
 * yield different flavours of the FIND routine (i.e. different XTs)
 */
FCode (p4_bracket_def)
{
    CONTEXT[0] = CURRENT;
}

/** CONTEXT? ( -- number )
 * GET-CONTEXT and count how many times it is in the order but
 * the CONTEXT variable itself. The returned number is therefore
 * minus one the occurences in the complete search-order.
 * usage:
   ALSO EXTENSIONS CONTEXT? [IF] PREVIOUS [THEN]
   ALSO DEF' DEFAULT-ORDER
 : CONTEXT? 
   0 LVALUE _count
   GET-ORDER 1- SWAP  LVALUE _context
   0 ?DO _context = IF 1 +TO _count THEN LOOP
   _count
 ;
 */
FCode (p4_context_Q)
{
    Wordl **p, **q;
    p4cell cnt = 0;

    p = CONTEXT; q= p+1;
    for (q = p+1; q <= &ONLY ; q++)
        if (*p == *q) cnt++;

    FX_PUSH(cnt);
}

/** DEFS-ARE-CASE-SENSITIVE ( -- ) 
 * accesses CURRENT which is generally the last wordlist that the
 * DEFINITIONS shall go in. sets there a flag in the vocabulary-definition
 * so that words are matched case-sensitive. 
 example: 
    VOCABULARY MY-VOC  MY-VOC DEFINITIONS DEFS-ARE-CASE-SENSITIVE
 */
FCode (p4_defs_are_case_sensitive)
{
    if (! CURRENT) return;
    CURRENT->flag &=~ WORDL_NOCASE ; 
}

/** CASE-SENSITIVE-VOC ( -- ) 
 * accesses CONTEXT which is generally the last named VOCABULARY .
 * sets a flag in the vocabulary-definition so that words are matched
 * case-sensitive. 
 example: 
    VOCABULARY MY-VOC  MY-VOC CASE-SENSITIVE-VOC
 * OBSOLETE! use DEFS-ARE-CASE-SENSITIVE
 */
FCode (p4_case_sensitive_voc)
{
    if (! CONTEXT[0]) return;
    CONTEXT[0]->flag &=~ WORDL_NOCASE ; 
}

/** DEFS-ARE-SEARCHED-ALSO ( -- )
 * binds CONTEXT with CURRENT. If the CURRENT VOCABULARY is in
 * the search-order (later), then the CONTEXT vocabulary will 
 * be searched also. If the result of this word could lead into 
 * a recursive lookup with FIND it will throw CURRENT_DELETED
 * and leave the CURRENT VOCABULARY unaltered.
 example:
 * MY-VOC DEFINITIONS  MY-VOC-PRIVATE DEFS-ARE-SEARCHED-ALSO
 */
FCode (p4_defs_are_searched_also)
{
    if (! CONTEXT[0] || ! CURRENT) return;
    { /* sanity check -> CURRENT may not be part of CONTEXT also-chain */
        register Wordl* wl; 
        for (wl = CONTEXT[0]; wl; wl=wl->also) 
            if (wl == CURRENT) p4_throw (P4_ON_CURRENT_DELETED);  
    }
    CURRENT->also = CONTEXT[0] ; 
}

/** SEARCH-ALSO-VOC ( -- )
 * OBSOLETE!! use DEFS-ARE-SEARCHED-ALSO
 */

/** [EXECUTE] ( [word] -- )
 * ticks the following word, and executes it - even in compiling mode.
 : [EXECUTE] ' EXECUTE ;
 */
FCode (p4_bracket_execute)
{
    p4_call (p4_tick_cfa(FX_VOID));
}

/** !NO ( -- false )
 * a synonym for FALSE
 !NO SMART-WORDS!
 */

/** !USE ( -- true )
 * a synonym for TRUE
 !USE SMART-WORDS!
 */

P4_LISTWORDS (useful) =
{
     (, ),
     (,		),
     (,			),
     (,			),
     (,		),
     (,		),
     (,			),
     (,			),
     (,			),
     (,			),
     (,			),
     (,			),
     (,			),

     (,		),  
     (,		),  
     (,			),  
     (,                  ),
     (,                  ),
     (,                   ),
     (,                  ),

     (,		),
     (,		),
     (,		),
# ifdef PFE_WITH_FIG
     (,		),
# endif
# ifdef WITH_NO_FFA
     (,		),
# endif
     (,			),
     (,		),
     (,		),
     (,			),
     (,		),
     (,			),
     (,		),
     (,      ),
     (, ),
     (,  ),
     (,         ),
     (,			),
     (,                    ),
     (,                      ),
};
P4_COUNTWORDS (useful, "Useful kernel extensions");

/*@}*/

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