/** 
 * -- miscellaneous useful words, mostly stemming from fig-forth
 *
 *  Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
 *
 *  @see     GNU LGPL
 *  @author  Tektronix CTE              @(#) %derived_by: guidod %
 *  @version %version: bln_mpt1!5.57 %
 *    (%date_modified: Mon Feb 24 20:03:36 2003 %)
 *
 *  @description
 *      Compatiblity with former standards, miscellaneous useful words.
 */
/*@{*/

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

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>

#include <stdlib.h>
#include <string.h>
#include <errno.h>
#include <signal.h>

#include <pfe/def-comp.h>
#include <pfe/term-sub.h>
#include <pfe/file-sub.h>
#include <pfe/double-sub.h>
#include <pfe/block-ext.h>
#include <pfe/exception-sub.h>
#include <pfe/version-sub.h>
#include <pfe/core-mix.h>
#include <pfe/block-mix.h>

#include <pfe/def-words.h>
#include <pfe/_missing.h>

/** COLD ( -- )
 * cold abort - reinitialize everything and go to QUIT routine
 * ... this routine is implemented as a warm-boot in pfe.
 : WARM FENCE @ (FORGET) INCLUDE-FILE ?DUP IF COUNT INCLUDED THEN QUIT ;
 */
FCode (p4_cold)
{
    FX (p4_close_all_files);

#if 0
    PFE.atexit_running = 1;
    p4_forget (PFE.dict);
    PFE.atexit_running = 0;

    p4_boot_system (); 
#else
    PFE.atexit_running = 1;
    p4_forget (FENCE);
    PFE.atexit_running = 0;
#endif

    FX (p4_paren_abort);

    if (PFE_set.include_file)
    {
        p4_included1 (PFE_set.include_file, strlen (PFE_set.include_file), 0);
    }

    /* If it's a turnkey-application, start it: */
    if (APPLICATION)
    {
        p4_run_forth (APPLICATION);
        p4_longjmp_exit (); 
    }
    if (P4_opt.verbose)
        FX (p4_dot_memory);
    /* p4_longjmp_abort (); -> paren_abort + yield */
    p4_longjmp_yield ();
}

/** .LINE ( line# block# -- )
 */
FCode (p4_dot_line)			
{
    p4_dot_line (BLOCK_FILE, SP[0], SP[1]);
    SP += 2;
}

/************************************************************************/
/* some well known words without pedigree                               */
/************************************************************************/

/** UD.R ( 2val r -- )
 */
FCode (p4_u_d_dot_r)	
{
    p4cell w = *SP++;

    FX (p4_less_sh);
    FX (p4_sh_s);
    FX (p4_sh_greater);
    p4_emits (w - *SP, ' ');
    FX (p4_type);
}

/** UD. ( 2val -- )
 * see also UD.R
 */
FCode (p4_u_d_dot)
{
    *--SP = 0;
    FX (p4_u_d_dot_r);
    FX (p4_space);
}

/** .NAME ( nfa -- )
 * use ID. or better NAME>STRING TYPE
 */

/** ID. ( nfa -- )
 * print the name-field pointed to by the nfa-argument.
 * a synonym for .NAME - but this word is more portable due its
 * heritage from fig-forth. 
 * 
 * in fig-forth the name-field is effectivly a bstring with some flags,
 * so the nfa's count has to be masked out, e.g. 
 : .NAME COUNT 32 AND TYPE ;
 *
 * in other pfe configurations, the name might not contain the flags it
 * it just a counted string - and there may be even more possibility.
 : .NAME COUNT TYPE ;
 * 
 * you should more and more convert your code to use the sequence
 * NAME>STRING TYPE
 */
FCode(p4_id_dot)
{
    /* Anton Ertl (gforth), Tom Zimmer (win32for), Guido Draheim (pfe)
     * agreed to export ID. as a portable function since win32for's
     * .NAME did not match the gforth' and pfe' variant of the same
     * name. The ID. has a heritage dating back to fig-forth, and was
     * present in tek'mforth too.
     */
    p4_dot_name ((char *) *SP++);
}

/** -ROLL ( xn ... x2 x1 n -- x1 xn ... x2 )
 * the inverse of ROLL
 */
FCode (p4_dash_roll)
{
    p4cell n = *SP++;
    p4cell h, i;

    h = SP[0];
    for (i = 0; i < n; i++)
        SP[i] = SP[i + 1];
    SP[i] = h;
}

/* some systems (BSD) have a better random number generator than
   standard unix' rand() 
*/

#if defined PFE_HAVE_RANDOM
# define _rand_ random
#else
# define _rand_ rand
#endif

/** RANDOM ( n1 -- n2 )
 * returns random number with 0 <= n2 < n1)
 : RANDOM ?DUP IF _random SWAP MOD ELSE _random THEN ;
 */
FCode (p4_random)			
{				
    if (*SP == 0)
        *SP = _rand_ ();
    else
    {
# if (PFE_SIZEOF_CELL == 2 && RAND_MAX-0 == 32767) \
  || (PFE_SIZEOF_CELL == 4 && RAND_MAX-0 == 2147483647L)
        /* ansi-rand has 15-bit, and most unix-rand have 31-bit */
        *SP = p4_d_ummul (*SP, _rand_ () << 1).hi;
# elif (PFE_SIZEOF_CELL >= 4) 
        if (*(p4ucell*)SP < 32767)
        { /* many systems are 32-bit or better */
            *(p4ucell*)SP *= (p4ucell) _rand_ () & 32767;
            *(p4ucell*)SP >>= 15;
        }else
            *SP = ((p4ucell) _rand_ ()) % (*(p4ucell*)SP);
# else
        *SP = ((p4ucell) _rand_ ()) % (*(p4ucell*)SP);
# endif        
    }
}

#undef rand

/** SRAND ( n -- )
 */
FCode (p4_srand)			
{
#if defined PFE_HAVE_RANDOM
    srandom (*SP++);
#else
    srand (*SP++);
#endif
}

/** UNDER+ ( n1 x n2 -- n1+n2 x ) TF
 *     quicker than
 : UNDER+  ROT + SWAP ;
 */
FCode (p4_plus_under)
{
    p4cell n = FX_POP;
    SP[1] += n;
}

/**  (UNDER+)  ( n1 n2 -- n1+n2 n2 )
 * quicker than
 : (UNDER+) TUCK + SWAP ; or : (UNDER+) DUP UNDER+ ;
 */
FCode (p4_under_plus)
{		
    SP[1] += SP[0];
}

/************************************************************************/
/* more local variables                                                 */
/************************************************************************/

/** ((+TO)) ( val -- )
 * execution compiled by +TO
 * adds the stack-val to the lvalue compiled
 */
FCode_XE (p4_plus_to_execution)	
{	
    FX_USE_CODE_ADDR;
    *p4_to_body ((p4xt)(*IP++)) += *SP++;
    FX_USE_CODE_EXIT;
}

/** ((+TO.local)) ( val -- )
 * same as ((+TO)) when the lvalue is a LOCALS| value
 * 
 compiled by +TO
 */
FCode_XE (p4_plus_to_local_execution)
{
    FX_USE_CODE_ADDR;
    LP[(p4cell) *IP++] += *SP++;
    FX_USE_CODE_EXIT;
}

/** +TO ( val [name] -- )
 * add the val to the named VALUE or LOCALS| value
 */
FCode (p4_plus_to)
{
    if (STATE)
    {
        char *p;
        int l, n;

        p = p4_word (' ');
        l = *(p4char *) p++;
        if (PFE.locals && (n = p4_find_local (p, l)) != 0)
	{
            FX_COMPILE2 (p4_plus_to);
            FX_UCOMMA (n);
	}else{
            if ((p = p4_find (p, l)) == NULL)
                p4_throw (P4_ON_UNDEFINED);
            FX_COMPILE1 (p4_plus_to);
            FX_XCOMMA (p4_name_from (p));
	}
    }else{
        *p4_to_body (p4_tick_cfa (FX_VOID)) += FX_POP;
    }
}

P4COMPILES2 (p4_plus_to, p4_plus_to_execution, p4_plus_to_local_execution,
  P4_SKIPS_TO_TOKEN, P4_DEFAULT_STYLE);

/************************************************************************/
/* data structures                                                      */
/************************************************************************/

/** BUILD-ARRAY ( n1 n2 ... nX X --- n )
 * writes X, n1, ... nX into the dictionary - 
 * returns product n1 * n2 * ... * nX 
 */
FCode (p4_build_array)		
{				
    p4cell i = *SP++;		
    p4ucell n = 1;

    FX_UCOMMA (i);
    while (--i >= 0)
    {
        FX_UCOMMA (*SP);
        n *= *SP++;
    }
    *--SP = n;
}

/** ACCESS-ARRAY ( i1 i2 ... iX addr1 --- addr2 n )
 * see BUILD-ARRAY
 */
FCode (p4_access_array)	
{
    p4ucell *p = (p4ucell *) *SP++, n = 0;
    p4cell i = *p++;

    for (;;)
    {
        if (*p++ <= (p4ucell) *SP)
            p4_throw (P4_ON_INDEX_RANGE);
        n += *SP++;
        if (--i <= 0)
            break;
        n *= *p;
    }
    *--SP = (p4cell) p;
    *--SP = n;
}

/************************************************************************/
/* implementation                                                       */
/************************************************************************/

/** SOURCE-LINE ( -- n )
 * if SOURCE is from EVALUATE (or QUERY ) then
 * the result is 0 else the line-numbers start from 1 
 */
FCode (p4_source_line)
{
    switch (SOURCE_ID)
    {
     case 0:
         if (BLK)
         {
             *--SP = TO_IN / 64 + 1;	/* source line from BLOCK */
             break;
         }
         /* else fallthrough */
     case -1:			/* string from EVALUATE */
         *--SP = 0;		/* or from QUERY (0/BLK==0) */
         break;
     default:			/* source line from text file */
         *--SP = SOURCE_FILE->n + 1;
    }
}

/** SOURCE-NAME ( -- str-ptr str-len )
 * if SOURCE is from INCLUDE then the result is the filename,
 * otherwise a generic name for the SOURCE-ID is given.
 */
FCode (p4_source_name)
{
    switch (SOURCE_ID)
    {
     case 0:
         if (BLK) FX_PUSH("*block#*");
	 else FX_PUSH ("*query*"); /*correct?*/
	 break;
     case -1:	
	 FX_PUSH ("*evaluate*");
         break;
     default:			/* source line from text file */
         FX_PUSH (SOURCE_FILE->name);
    }
    FX_1ROOM; SP[0] = strlen((char*)(SP[1]));
}

/** TH'POCKET ( n -- addr u )
 * returns the specified pocket as a S" string reference
 */
FCode (p4_th_pocket)			
{			
    int n = *SP;

    SP -= 1;
    SP[1] = (p4cell) PFE.pockets[n] + 1;
    SP[0] = *(p4char *) PFE.pockets[n];
}

/** POCKET-PAD ( -- addr )
 * Returns the next pocket.
 * A pocket has usually the size of a maxstring, see ENVIRONMENT /STRING
 * (but can be configured to be different, mostly when MAXPATH > /STRING )
 * Note that a pocket is a temporary and forth internal functions do
 * sometimes call POCKET-PAD too, especially when building filenames
 * and getting a literal (but temporary) string from the keyboard.
 * Functions are not expected to hold references to this transient
 * area any longer than building a name and calling another word with it.

 * Usage of a pocket pad is a good way to make local temporary buffers
 * superfluous that are only used to construct a temporary string that 
 * usually gets swallowed by another function.
 depracated code:
   create temp-buffer 255 allot
   : make-temp ( str buf ) 
          temp-buffer place  " .tmp" count temp-buffer append 
          temp-buffer count make-file ;
 replace with this:
   : make-temp ( str buf )
        pocket-pad >r    
        r place  " .tmp" count r append
        r> count make-file
   ;
 */
FCode (p4_pocket_pad)
{
    FX_PUSH (p4_pocket());
}

/** WL-HASH ( c-addr n1 -- n2 )
 * calc hash-code for selection of thread
 * in a threaded-vocabulary
 */
FCode (p4_wl_hash)	
{			
    SP[1] = p4_wl_hash ((char *) SP[1], SP[0]);
    SP++;
}

/** TOPMOST ( wid -- a-addr )
 * that last valid word in the specified vocabulary
 */
FCode (p4_topmost)
{
    *SP = (p4cell) p4_topmost ((Wordl *) *SP);
}

/* .................. */

static void
ls_words (char const * cat)
{
    Wordl *wl = CONTEXT[0] ? CONTEXT[0] : ONLY;
    char *pattern = p4_word (' ');

    if (*pattern == 0)
        strcpy (pattern, "\001*");
    p4_outf ("\nWords matching %s:", pattern + 1);
    p4_wild_words (wl, pattern + 1, cat);
}

/** LS.WORDS ( -- )
 * see WORDS
 */
FCode (p4_ls_words)		{ ls_words (NULL); }

/** LS.PRIMITIVES ( -- )
 * see WORDS
 */
FCode (p4_ls_primitives)	{ ls_words ("p"); }

/** LS.COLON-DEFS ( -- )
 * see WORDS
 */
FCode (p4_ls_cdefs)		{ ls_words (":"); }

/** LS.DOES-DEFS ( -- )
 * see WORDS
 */
FCode (p4_ls_ddefs)		{ ls_words ("D"); }

/** LS.CONSTANTS ( -- )
 * see WORDS
 */
FCode (p4_ls_constants)		{ ls_words ("cC"); }

/** LS.VARIABLES ( -- )
 * see WORDS
 */
FCode (p4_ls_variables)		{ ls_words ("vV"); }

/** LS.VOCABULARIES ( -- )
 * see WORDS
 */
FCode (p4_ls_vocabularies)	{ ls_words ("W"); }

/** LS.MARKERS ( -- )
 * see WORDS
 */
FCode (p4_ls_markers)		{ ls_words ("M"); }

/* ............... */

/** W@ ( addr -- w-val )
 * fetch a 2byte-val from address
 */
FCode (p4_w_fetch)
{
    *SP = *(short *) *SP;
}

/** W! ( w-val addr -- )
 * store a 2byte-val at addressed 2byte-value
 */
FCode (p4_w_store)			
{
    *(short *) SP[0] = (short) SP[1];
    SP += 2;
}

/** W+! ( w-val addr -- )
 * add a 2byte-val to addressed 2byte-value
 */
FCode (p4_w_plus_store)	
{
    *(short *) SP[0] += (short) SP[1];
    SP += 2;
}

/** TAB ( n -- )
 * jump to next column divisible by n 
 */
FCode (p4_tab)			
{			
    p4_tab (*SP++);
}

/** BACKSPACE ( -- )
 * reverse of SPACE
 */
FCode (p4_backspace)
{
    p4_outs ("\b \b");
}

/** ?STOP ( -- flag )
 * check for 'q' pressed
 * - see ?CR
 */
FCode (p4_Q_stop)
{
    *--SP = P4_FLAG (p4_Q_stop ());
}

/** START?CR ( -- )
 * initialized for more-like effect
 * - see ?CR
 */
FCode (p4_start_Q_cr)	
{				
    PFE.more = PFE.rows - 2;
    PFE.lines = 0;
}

/** ?CR ( -- flag )
 * like CR , stop 25 lines past START?CR
 */
FCode (p4_Q_cr)	
{		
    *--SP = p4_Q_cr ();
}

/** CLOSE-ALL-FILES ( -- )
 */
FCode (p4_close_all_files)
{
    File *f = 0;

    for (f = PFE.files; f < PFE.files_top - 3; f++)
    {
        if (f->f)
	{
            if (f->updated)
	    {
                p4_read_write (f, f->buffer, f->n, P4_FALSE);
	    }
            fclose (f->f);
	}
    }
}

/** .MEMORY ( -- )
 */
FCode (p4_dot_memory)
{
    p4_outf ("\nDictionary space:    %7ld Bytes, in use: %7ld Bytes\n"
	"Stack space:         %7ld %s\n"
	"Floating stack space:%7ld %s\n"
	"Return stack space:  %7ld %s\n",
           	/* the C language returns n as n*sizeof==bytes */
	     (long) (PFE.dictlimit - PFE.dict),
	     (long) (PFE.dp - PFE.dict), 
	     (long) (PFE.s0 - PFE.stack),  /* sizeof (p4cell) */
	     (PFE.dstrings ? "cells, (extra dstrings stack)" : "cells"),
	     (long) (PFE.f0 - PFE.fstack), /* sizeof (double) */
	     (PFE.f0 ? "floats" : "       (not used)"),
	     (long) (PFE.r0 - PFE.rstack),  /* sizeof (p4xt**) */
	     ("cells, (not the C call stack)"));
}

/** .STATUS ( -- )
 * display internal variables 
 : .STATUS .VERSION .CVERSION .MEMORY .SEARCHPATHS .DICTVARS .REGSUSED ;
 */
FCode (p4_dot_status)
{
# ifndef PFE_MODULE_DIR
# define PFE_MODULE_DIR PFE_PKGLIBDIR
# endif

    FX (p4_cr);
    FX (p4_dot_version);
    FX (p4_cr);
    FX (p4_dot_date);
    FX (p4_cr);
    p4_outf ("\nMemory overview:");
    FX (p4_dot_memory);
    p4_outf ("\nsearch path for source files:     %s", P4_opt.incpaths);
    p4_outf ("\nextensions for source files:      %s", P4_opt.incext);
    p4_outf ("\nsearch path for block files:      %s", P4_opt.blkpaths);
    p4_outf ("\nextensions for block files:       %s", P4_opt.blkext);
    p4_outf ("\nsearching help files in:          %s", PFE_PKGHELPDIR);
    p4_outf ("\nsearching pfe shared modules in:  %s", PFE_MODULE_DIR);
    FX (p4_cr);
    p4_outf ("\nmaximum number of open files:     %u", P4_opt.max_files);
    p4_outf ("\nmaximum simultaneous S\" pockets   %u", P4_opt.pockets);
    p4_outf ("\ndictionary threads configured     %u", 1<<LD_THREADS);
    p4_outf ("\nmaximum wordlists in search order %u", P4_opt.wordlists);
    FX (p4_cr);
    p4_outf ("\nText screen size:                 %dx%d", PFE.rows, PFE.cols);

#define flag(X) ((X) ? "ON " : "OFF")
    p4_outf ("\n      CASELESS %s", flag (LOWER_CASE));
    p4_outf ("\nUPPER-CASE-IS  %s", flag (UPPER_CASE));
#ifdef P4_REGTH
    p4_outs ("           REGTH="P4_REGTH);
#elif defined PFE_WITH_STATIC_REGS
    p4_outs ("           (static regVM)");
#else
    p4_outs ("           (static regTH)");
#endif
    p4_outf ("\nLOWER-CASE-FN  %s", flag (LOWER_CASE_FN));
#ifdef P4_REGSP
    p4_outs ("           REGSP="P4_REGSP);
#endif
    p4_outf ("\nRESET-ORDER-IS %s", flag (RESET_ORDER));
#ifdef P4_REGIP
    p4_outs ("           REGIP="P4_REGIP);
#elif defined PFE_SBR_CALL_ARG_THREADING
    p4_outs ("           (sbr-call-arg-threading)");
#elif defined PFE_SBR_CALL_THREADING
    p4_outs ("           (sbr-call-threading)");
#endif
    p4_outf ("\nREDEFINED-MSG  %s", flag (REDEFINED_MSG));
#ifdef P4_REGRP
    p4_outs ("           REGRP="P4_REGRP);
#endif
    p4_outf ("\nFLOAT-INPUT    %s", flag (FLOAT_INPUT));
#ifdef P4_REGLP
    p4_outs ("           REGLP="P4_REGLP);
#endif
#undef flag
    p4_outf ("\nPRECISION      %d", PRECISION);
#ifdef P4_REGW
    p4_outs ("            REGW="P4_REGW);
#elif defined PFE_CALL_THREADING && !defined PFE_SBR_CALL_THREADING
    p4_outs ("            (call-threading)");
#endif
    FX (p4_space);
}

/************************************************************************/
/* tokenizer calls                                                      */
/************************************************************************/

/** LOWER-CASE! ( val -- )
 * Call to enable lower-case symbols as input, supersedes the plain
 * variable LOWER-CASE
 : LOWER-CASE! LOWER-CASE ! ;
 : LOWER-CASE! TO LOWER-CASE@ ;
 */
FCode (p4_lower_case_store)
{
    PFE.wordl_flag = FX_POP;
}

/** LOWER-CASE-FN! ( val -- )
 * Call to enable lower-case symbols as input, supersedes the plain
 * variable LOWER-CASE-FN
 : LOWER-CASE-FN!    LOWER-CASE-FN ! ;
 : LOWER-CASE-FN! TO LOWER-CASE-FN@ ;
 */
FCode (p4_lower_case_fn_store)
{
    PFE.lower_case_fn = FX_POP;
}

/** REDEFINED-MSG! ( val -- )
 * Call to enable warnings if creating symbols being in the ORDER 
 * - supersedes the plain variable REDEFINED-MSG
 : REDEFINED-MSG!    REDEFINED-MSG ! ;
 : REDEFINED-MSG! TO REDEFINED-MSG@ ;
 */
FCode (p4_redefined_msg_store)
{
    PFE.redefined_msg = FX_POP;
}

/************************************************************************/
/* vectorized I/O                                                       */
/************************************************************************/

/** (EMIT) ( val -- )
 * like EMIT and always to screen 
 * - the routine to be put into *EMIT*
 */
FCode (p4_paren_emit)
{
    p4_outc ((char) *SP++);
}

/** (EXPECT) ( . -- . )
 * like EXPECT and always from screen
 * - the routine to be put into *EXPECT*
 */
FCode (p4_paren_expect)
{
    p4_expect ((char *) SP[1], SP[0]);
    SP += 2;
}

/** (KEY) ( -- ... )
 * like KEY and always from screen
 * - the routine to be put into *KEY*
 */
FCode (p4_paren_key)
{
    int c;

    do {
        c = p4_getekey ();
    } while (c >= 0x100);
    *--SP = c;
}

/** (TYPE) ( val -- )
 * like TYPE and always to screen 
 * - the routine to be put into *TYPE*
 */
FCode (p4_paren_type)
{
    p4_type ((char *) SP[1], SP[0]);
    SP += 2;
}

/** STANDARD-I/O ( -- )
 * initialize *TYPE* , *EMIT* , *EXPECT* and *KEY*
 * to point directly to the screen I/O routines, 
 
 * namely (TYPE) , (EMIT) , (EXPECT) , (KEY) 
 */
FCode (p4_standard_io)
{
#  ifdef PFE_CALL_THREADING
    static const p4Word paren_emit_w =   { "",  PFX (p4_paren_emit) };
    static const p4Word paren_expect_w = { "", PFX (p4_paren_expect) };
    static const p4Word paren_key_w =    { "", PFX (p4_paren_key) };
    static const p4Word paren_type_w =   { "", PFX (p4_paren_type) };

    static const p4Word* paren_emit_xt =   & paren_emit_w;
    static const p4Word* paren_expect_xt = & paren_expect_w;
    static const p4Word* paren_key_xt =    & paren_key_w;
    static const p4Word* paren_type_xt =   & paren_type_w;

    PFE.emit =   &paren_emit_xt;
    PFE.expect = &paren_expect_xt;
    PFE.key =    &paren_key_xt;
    PFE.type =   &paren_type_xt;
#  else
    static p4code paren_emit_xt =   PFX (p4_paren_emit);
    static p4code paren_expect_xt = PFX (p4_paren_expect);
    static p4code paren_key_xt =    PFX (p4_paren_key);
    static p4code paren_type_xt =   PFX (p4_paren_type);

    PFE.emit =   &paren_emit_xt;
    PFE.expect = &paren_expect_xt;
    PFE.key =    &paren_key_xt;
    PFE.type =   &paren_type_xt;
#  endif
}

/************************************************************************/
/* Function keys on the commandline                                     */
/************************************************************************/

void
accept_executes_xt (int n)
{
    if (PFE.fkey_xt[n])
        p4_call (PFE.fkey_xt[n]);
}

static void
p4_store_execution (p4xt xt, int key)
{
    if (key < P4_KEY_k1 || P4_KEY_k0 < key)
        p4_throw (P4_ON_ARG_TYPE);
    PFE.fkey_xt[key - P4_KEY_k1] = xt;
}

/** ((EXECUTES)) ( n -- )
 * compiled by EXECUTES
 */
FCode_XE (p4_executes_execution)
{
    FX_USE_CODE_ADDR;
    p4_store_execution ((p4xt)(*IP++), *SP++);
    FX_USE_CODE_EXIT;
}

/** EXECUTES ( n [word] -- )
 * stores the execution token of following word into
 * the callback pointer for the specified function-key 
 */
FCode (p4_executes)
{
    if (STATE)
    {
        FX_COMPILE (p4_executes);
        FX (p4_bracket_compile);
    }else{
        p4_store_execution (p4_tick_cfa (FX_VOID), FX_POP);
    }
}

P4COMPILES (p4_executes, p4_executes_execution,
  P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/************************************************************************/
/* display help                                                         */
/************************************************************************/

/** HELP ( name -- )
 * will load the help module in the background and hand over the 
 * parsed name to (HELP) to be resolved. If no (HELP) word
 * can be loaded, nothing will happen.
 */
FCode (p4_help)
{
    char* wordpad = p4_pocket ();

    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    if (! PFE.word.len) { return; }

    p4_store_c_string (PFE.word.ptr, PFE.word.len, wordpad, P4_POCKET_SIZE);
    if (LOWER_CASE)
        p4_upper (wordpad, PFE.word.len);
    {
	extern void* p4_loadm_once (const p4char* nm, int l);
	register p4char* name;
	register int wordlen = PFE.word.len; /* loadm might parse */

	p4_loadm_once ("\thelp", 5);
	if ((name = p4_search_wordlist ("(HELP)", 6, PFE.forth_wl)))
	{
	    FX (p4_cr);
	    FX_PUSH(wordpad); /* arguments for => (HELP) */
	    FX_PUSH(wordlen);
	    p4_call(p4_name_from(name));
	}
    }
}

/** EDIT-BLOCKFILE ( name -- )
 * will load the edit module in the background and look for a word
 * called EDIT-BLOCK that could be used to edit the blockfile.
 * If no EDIT-BLOCKFILE word can be loaded, nothing will happen.
 * Otherwise, OPEN-BLOCKFILE is called followed by 0 EDIT-BLOCK
 * to start editing the file at the first block.
 */
FCode (p4_edit_blockfile)
{
    char* wordpad = p4_pocket ();

    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    if (! PFE.word.len) { return; }

    wordpad = p4_pocket_expanded_filename (PFE.word.ptr, PFE.word.len,
					   PFE_set.blkpaths, PFE_set.blkext);
    {
	extern void* p4_loadm_once (const p4char* nm, int l);
	register p4char* name;
	register int wordlen = PFE.word.len; /* loadm might parse */

	p4_loadm_once ("\tedit", 5);
	if ((name = p4_search_wordlist ("EDIT-BLOCK-START", 16, PFE.forth_wl)))
	{
	    /* see => OPEN-BLOCKFILE */
	    FX (p4_close_blockfile);
	    if (! p4_set_blockfile (p4_open_blockfile (wordpad, wordlen)))
		p4_throws (FX_IOR, wordpad, wordlen);

	    FX_PUSH(0); /* argument for => EDIT-BLOCK */
	    p4_call(p4_name_from(name));
	}
    }
}

/************************************************************************/
/* hooks to editors and os services                                     */
/************************************************************************/

/** ARGC ( -- n )
 */
FCode (p4_argc)                      
{
    FX_PUSH (P4_opt.argc);
}

/** ARGV ( n -- addr u )
 */
FCode (p4_argv)	
{
    p4ucell n = *SP++;

    if (n < (p4ucell) P4_opt.argc)
        p4_strpush (P4_opt.argv [n]);
    else
        p4_strpush (NULL);
}

/** EXPAND-FN ( addr1 u1 addr2 -- addr2 cnt2 )
 */
FCode (p4_expand_fn)		
{
    char *nm = (char *) SP[2];
    char *fn = (char *) SP[0];
    int len = SP[1];
    char* buf;

    buf = p4_pocket_expanded_filename (nm, len, 
				       P4_opt.incpaths, P4_opt.incext);
    strcpy (fn, buf);
    SP++;
    SP[1] = (p4cell) fn;
    SP[0] = strlen (fn);
}

/** ((LOAD")) ( -- ? )
 */
FCode_XE (p4_load_quote_execution)
{   FX_USE_CODE_ADDR {
#  if !defined PFE_SBR_CALL_THREADING
    register char *p = (char *) IP;
    register int n = (p4char) *p++;

    FX_SKIP_STRING;
    p4_load_file (p, n, *SP++);
#  else
    register char *p;
    FX_NEW_IP_WORK;
    p = FX_NEW_IP_CHAR;
    FX_NEW_IP_SKIP_STRING;
    FX_NEW_IP_DONE;
    p4_load_file (p+1, *p, *SP++);
#  endif
    FX_USE_CODE_EXIT;
}}

/** LOAD"  ( [filename<">] -- ? ) obsolete 
 * load the specified file - this word can be compiled into a word-definition
 * obsolete! use OPEN-BLOCKFILE name LOAD
 */
FCode (p4_load_quote)
{
    if (STATE)
    {
        FX_COMPILE (p4_load_quote);
        FX (p4_parse_comma_quote);
    }else{
        p4_skip_delimiter (' ');
        p4_word_parse ('"'); *DP=0; /* PARSE-NOHERE (actually PARSE-WORD) */
        p4_load_file (PFE.word.ptr, PFE.word.len, *SP++); /* uses p4_pocket */
    }
}

P4COMPILES (p4_load_quote, p4_load_quote_execution,
  P4_SKIPS_STRING, P4_DEFAULT_STYLE);

#ifndef NO_SYSTEM

/** SYSTEM ( addr u -- ret-val )
 * run a shell command  (note: embedded systems have no shell)
 */
FCode (p4_system)
{
    SP[1] = p4_systemf ("%.*s", (int) SP[0], (char *) SP[1]);
    SP++;
}

/** ((SYSTEM")) 
 * compiled by SYSTEM" commandline"
 */
FCode_XE (p4_system_quote_execution)
{   FX_USE_CODE_ADDR {
#  if !defined PFE_SBR_CALL_THREADING
    char *p = (char *) IP;

    FX_SKIP_STRING;
    *--SP = p4_systemf ("%.*s", *p, p + 1);
#  else
    char *p;
    FX_NEW_IP_WORK;
    p = FX_NEW_IP_CHAR;
    FX_NEW_IP_SKIP_STRING;
    FX_NEW_IP_DONE;
    *--SP = p4_systemf ("%.*s", *p, p + 1);
#  endif
    FX_USE_CODE_EXIT;
}}

/** SYSTEM" ( [commandline<">] -- ret-val ) obsolete
 * run a shell command (note:embedded systems have no shell)
 * obsolete! use S" string" SYSTEM
 */
FCode (p4_system_quote)
{
    if (STATE)
    {
        FX_COMPILE (p4_system_quote);
        FX (p4_parse_comma_quote);
    }else{
        p4_word_parse ('"'); *DP=0; /* PARSE-NOHERE */
        *--SP = p4_systemf ("%.*s", PFE.word.len, PFE.word.ptr);
    }
}

P4COMPILES (p4_system_quote, p4_system_quote_execution,
  P4_SKIPS_STRING, P4_DEFAULT_STYLE);

#endif /* NO_SYSTEM */

/** RAISE ( n -- )
 * send a SIGNAL to self
 */
FCode (p4_raise)
{
    _pfe_raise (*SP++);
}

/** SIGNAL ( xt1 n -- xt2 )
 * install signal handler
 * - return old signal handler
 */
FCode (p4_signal)		
{			
    SP[1] = (p4cell) p4_forth_signal (SP[0], (p4xt) SP[1]);
    SP++;
}

/** OK ( -- )
 * it usually prints "ok" 
 */

extern FCode (p4_ok); 

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

/** CREATE: ( 'name' -- )
 * this creates a name with the VARIABLE runtime.
 * Note that this is the FIG-implemenation of CREATE whereas in
 * ANS-Forth mode we have a CREATE identical to FIG-style <BUILDS
 : CREATE: BL WORD $HEADER DOVAR A, ;
 */
FCode (p4_create_var)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_variable);
}

/** BUFFER: ( size 'name' -- )
 * this creates a name with the VARIABLE runtime and ALLOTs memory
 : BUFFER: BL WORD $HEADER DOVAR A, ALLOT ;
 */
FCode (p4_buffer_var)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_variable);
    FX (p4_allot);
}

/** R'@ ( R: a b -- a R: a b )
 * fetch the next-under value from the returnstack.
 * used to interpret the returnstack to hold two LOCALS| values.
 * ( R@ / 2R@ / R>DROP / R"@)
 */
FCode (p4_r_tick_fetch)
{
    FX_COMPILE (p4_r_tick_fetch);
}

FCode_XE (p4_r_tick_fetch_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH (FX_RP[1]);
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_tick_fetch, p4_r_tick_fetch_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R'! ( x R: a b -- R: x b )
 * store the value into the next-under value in the returnstack.
 * used to interpret the returnstack to hold two LOCALS| values.
 * see R'@ for inverse operation
 */
FCode (p4_r_tick_store)
{
    FX_COMPILE (p4_r_tick_store);
}

FCode_XE (p4_r_tick_store_execution)
{
    FX_USE_CODE_ADDR;
    FX_RP[1] = FX_POP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_tick_store, p4_r_tick_store_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R"@ ( R: a b c -- a R: a b c )
 * fetch the second-under value from the returnstack.
 * used to interpret the returnstack to hold three LOCALS| values.
 * see R"! for inverse operation ( R'@ R@ / 2R@ / R>DROP )
 */
FCode (p4_r_quote_fetch)
{
    FX_COMPILE (p4_r_quote_fetch);
}

FCode_XE (p4_r_quote_fetch_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH (FX_RP[2]);
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_quote_fetch, p4_r_quote_fetch_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R"! ( x R: a b c -- R: x b c )
 * store the value into the second-under value in the returnstack.
 * used to interpret the returnstack to hold three LOCALS| values.
 * see R"@ for inverse operation
 */
FCode (p4_r_quote_store)
{
    FX_COMPILE (p4_r_quote_store);
}

FCode_XE (p4_r_quote_store_execution)
{
    FX_USE_CODE_ADDR;
    FX_RP[2] = FX_POP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_quote_store, p4_r_quote_store_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R! ( x R: a -- R: x )
 * store the value as the topmost value in the returnstack.
 * see R@ for inverse operation ( R'@ / R"@ / 2R@ / 2R!)
 */
FCode (p4_r_store)
{
    FX_COMPILE (p4_r_store);
}

FCode_XE (p4_r_store_execution)
{
    FX_USE_CODE_ADDR;
    FX_RP[0] = FX_POP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_store, p4_r_store_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** 2R! ( x y R: a b -- R: x y )
 * store the value as the topmost value in the returnstack.
 * see 2R@ for inverse operation ( R'@ / R"@ / 2R@ / 2R!)
 */
FCode (p4_two_r_store)
{
    FX_COMPILE (p4_two_r_store);
}

FCode_XE (p4_two_r_store_execution)
{
    FX_USE_CODE_ADDR;
    FX_RP[0] = SP[0];
    FX_RP[1] = SP[1];
    FX_2DROP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_two_r_store, p4_two_r_store_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** DUP>R ( val -- val )
 * shortcut, see R>DROP
 * 
 note again that the following will fail:
 : DUP>R DUP >R ;
 */
FCode (p4_dup_to_r)
{
    FX_COMPILE (p4_dup_to_r);
}

FCode_XE (p4_dup_to_r_execution)
{
    FX_USE_CODE_ADDR;
#  ifndef PFE_SBR_CALL_THREADING
    RP_PUSH (*SP);
#  else
    FX_NEW_RP_WORK;
    FX_NEW_RP_CELL_POSH = (p4xcode*) *SP;
    FX_NEW_RP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_dup_to_r, p4_dup_to_r_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R>DROP ( -- )
 * shortcut (e.g. in CSI-Forth)
 * 
 note that the access to R is configuration dependent - only in
 * a traditional fig-forth each NEST will be one cell wide - in case that
 * there are no LOCALS| of course. And remember, the word above reads
 * like the sequence R> and DROP but that is not quite true.
 : R>DROP R> DROP ; ( is bad - correct might be )  : R>DROP R> R> DROP >R ;
 */
FCode (p4_r_from_drop)
{
    FX_COMPILE (p4_r_from_drop);
}

FCode_XE (p4_r_from_drop_execution)
{
    FX_USE_CODE_ADDR;
#  ifndef PFE_SBR_CALL_THREADING
    RP++;
#  else
    FX_RP_DROP (1);
#  endif
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_from_drop, p4_r_from_drop_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** 2R>2DROP ( -- )
 * this is two times R>DROP but a bit quicker.
 * it is however really quick compared to the sequence 2R> and 2DROP
 */
FCode (p4_two_r_from_drop)
{
    FX_COMPILE (p4_two_r_from_drop);
}

FCode_XE (p4_two_r_from_drop_execution)
{
    FX_USE_CODE_ADDR;
    FX_RP_DROP (2);
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_two_r_from_drop, p4_two_r_from_drop_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** CLEARSTACK ( -- )
 * reset the parameter stack to be empty
 : CLEARSTACK  S0 SP! ;
 */
FCode (p4_clearstack)
{
    p4SP = PFE.s0;
}

/** LOWER-CASE ( -- var* ) depracated
 * Call to enable lower-case symbols as input
 * Replace code of "LOWER-CASE OFF" with "NO TO UPPER-CASE?"
 * see UPPER-CASE?
 */

/** UPPER-CASE? ( -- flag ) 
 * Call to check whether lower-case symbols in input can match 
 * words defined in uppercase. Actually it sets the internal
 * wordl-flag which has some bit-defs used when creating new
 * vocabularies.
 *
 * This flag VALUE is modifiable with TO
   YES TO UPPER-CASE?
 */

/** REDEFINED-MSG ( -- var* ) depracated
 * Call to enable warnings if creating symbols being in the ORDER 
 * Replace code of "REDEFINED-MSG OFF" with "NO TO REDEFINED-MSG?"
 * see REDEFINED-MSG?
 */

/** REDEFINED-MSG? ( -- flag ) 
 * Call to check whether the system will emit warnings if creating 
 * symbols being already defined in the CURRENT vocabulary.
 *
 * This flag VALUE is modifiable with TO
   YES TO REDEFINED-MSG?
 */

/** QUOTED-PARSE ( -- var* ) depracated
 * Call to enable quoted-parse extension in PARSE WORDs 
 * Replace code of "QUOTED-PARSE OFF" with "NO TO QUOTED-PARSE?"
 * see QUOTED-PARSE?
 */

/** QUOTED-PARSE? ( -- flag ) 
 * Call to check for quoted-parse extension in PARSE WORDs 
 *
 * This flag VALUE is modifiable with TO
   YES TO QUOTED-PARSE?
 */

P4_LISTWORDS (misc) =
{
     (, ),
    /** just print OK, also fine for copy-and-paste in terminal */
     (,		),

    /* more fig-forth */
     (,		),
     (,		),
     (,		),

    /** basic system variables ( OUT DP HLD R0 S0 ) */
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),

    /* words without pedigree */
     (,		),
     (,		),
     (,	        ),
     (,		),
     (,		),
     (,		),
     (,		),
     (,	),
     (,		),

    /* more local variables */
     (,		),

    /* data structures */
     (,	),
     (,	),

     (,		),
     (,	),

    /* NOTE: the newer "TO"-implementation is able to set DVaLs */
     (,	), /* will be bool-VaL */
     (,	), /* fixme: deleted somewhen */
     (,	), /* will be bool-VaL */
     (,	), /* fixme: delete somewhen */
     (,	), /* will be bool-VaL */
     (,	), /* fixme: delete somewhen */
     (,	),  /* will be bool-VaL */
  
     (,	),
     (,	),
     (,	),
     (,	),
    P4_OCoN ("/CELL",		sizeof (p4cell)),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     /** the variable accessed with LATEST */

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

     (,		),
     (,	),
     (,		),
     (,	),
     (,		),
     (, ),
     (,		),
    
    /** vectorized i/o variables, see STANDARD-I/O */
     (,		),
     (,	),
     (,		),
     (,		),
     (,		),
     (,	),
     (,		),
     (,		),
     (,	),

    /* show online help: */
     (,		),
     (,	),
  /** the application to be called, options like ARGC ARGV */
     (,	),

    /** task system hooks */
     (,		),
     (,		),
     (,	),
     /** ( -- fid ) - the standard file-handles of the task */
     (,		),	
     (,		),	
     (,		),	

     (,	),
     (,		),
#ifndef NO_SYSTEM
     (,		),
     (,	),
#endif /* NO_SYSTEM */
     (,		),
     (,		),

/* almost usable everywhere */
     (,		),
     (,		),

/* quite useful, esp. for non-locals code */
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,	),
     (,	),

     (,      ),
     (,          ),

/* smart */
     (,	),

     (,  ),
     (,	),
};
P4_COUNTWORDS (misc, "Misc.Compatibility words");

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