/**
 *  CORE-EXT -- The standard CORE and CORE-EXT wordset
 *
 *  Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
 *
 *  @see     GNU LGPL
 *  @author  Tektronix CTE              @(#) %derived_by: guidod %
 *  @version %version: bln_mpt1!5.65 %
 *    (%date_modified: Fri Feb 28 12:39:04 2003 %)
 *
 *  @description
 *      The Core Wordset contains the most of the essential words
 *      for ANS Forth.
 */
/*@{*/

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

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>

#include <ctype.h>
#include <string.h>
#ifndef P4_NO_FP
#include <float.h>
#endif
#include <limits.h>

#include <pfe/core-ext.h>
#include <pfe/core-mix.h>
#include <pfe/double-sub.h>
#include <pfe/double-ext.h>
#include <pfe/tools-sub.h>
#include <pfe/tools-mix.h>
#include <pfe/dict-sub.h>
#include <pfe/header-ext.h>
#include <pfe/term-sub.h>
#include <pfe/_missing.h>

#include <pfe/logging.h>

/************************************************************************/
/* Core Words                                                           */
/************************************************************************/

/** ! ( val addr -- )
 * store value at addr (sizeof CELL)
 */
FCode (p4_store)
{
    *(p4cell *) SP[0] = SP[1];
    SP += 2;
}

/** # ( n.n -- n.n' ) 
 * see also HOLD for old-style forth-formatting words
 * and PRINTF of the C-style formatting - this word
 * divides the argument by BASE and add it to the
 * picture space - it should be used inside of <#
 * and #>
 */
FCode (p4_sh)
{
    p4_hold (p4_num2dig (p4_u_d_div ((p4udcell *) SP, BASE)));
}

/** #> ( n.n -- str-addr str-len ) 
 * see also HOLD for old-style forth-formatting words
 * and PRINTF of the C-style formatting - this word
 * drops the argument and returns the picture space
 * buffer
 */
FCode (p4_sh_greater)
{
    SP[1] = (p4cell) p4_HLD;
    SP[0] = (p4cell) (p4_PAD - p4_HLD);
}

/** #S ( n.n -- n.n ) f
 * see also HOLD for old-style forth-formatting words
 * and PRINTF of the C-style formatting - this word
 * does repeat the word # for a number of times, until
 * the argument becomes zero. Hence the result is always
 * null - it should be used inside of <# and #>
 */
FCode (p4_sh_s)
{
    do {
        FX (p4_sh);
    } while (SP[0] || SP[1]);
}

/**  CFA'  ( 'name' -- xt ) 
 * return the execution token of the following name. This word
 * is _not_ immediate and may not do what you expect in
 * compile-mode. See ['] and '> - note that in FIG-forth
 * the word ' had returned the PFA (not the CFA) and therefore
 * this word was introduced being the SYNONYM of the ans-like
 * word '
 */

/**  '  ( 'name' -- xt ) 
 * return the execution token of the following name. This word
 * is _not_ immediate and may not do what you expect in
 * compile-mode. See ['] and '> - note that in FIG-forth
 * the word of the same name had returned the PFA (not the CFA)
 * and was immediate/smart, so beware when porting forth-code
 * from FIG-forth to ANSI-forth.
 */
FCode (p4_tick)
{
    FX_PUSH_SP = (p4cell) p4_tick_cfa (FX_VOID);
}

/**  (   ( 'comment' -- ) 
 * eat everything up to the next closing paren - treat it
 * as a comment.
 */
FCode (p4_paren)
{
    switch (SOURCE_ID)
    {
     case -1:
     case 0:
         p4_word_parse (')'); /* PARSE-NOHERE-NOTHROW */
         break;
     default:
         while (! p4_word_parse (')') && p4_refill ()); /* PARSE-NOHERE-NOTH */
         break;
    }
}

/**  *  ( a b -- a*b ) 
 * return the multiply of the two args
 */
FCode (p4_star)
{
    SP[1] = SP[0] * SP[1];
    SP++;
}

/**  */  ( a b c -- a*b/c ) 
 * regard the b/c as element Q - this word
 * has an advantage over the sequence of *
 * and / by using an intermediate double-cell
 * value
 */
FCode (p4_star_slash)
{
    fdiv_t res = p4_d_fmdiv (p4_d_mmul (SP[2], SP[1]), SP[0]);

    SP += 2;
    SP[0] = res.quot;
}

/**  */MOD  ( a b c -- m n )
 * has an adavantage over the sequence of *
 * and /MOD by using an intermediate double-cell
 * value.
 */
FCode (p4_star_slash_mod)
{
    *(fdiv_t *) &SP[1] = p4_d_fmdiv (p4_d_mmul (SP[2], SP[1]), SP[0]);
    SP++;
}

/** + ( a b -- a+b ) 
 * return the sum of the two args
 */
FCode (p4_plus)
{
    SP[1] += SP[0];
    SP++;
}

/** +! ( val addr -- ) 
 * add val to the value found in addr
 simulate:
   : +! TUCK @ + SWAP ! ;
 */
FCode (p4_plus_store)
{
    *(p4cell *) SP[0] += SP[1];
    SP += 2;
}

/** "((+LOOP))" ( increment -- ) 
 * compiled by +LOOP
 */ 
FCode_XE (p4_plus_loop_execution)
{   FX_USE_CODE_ADDR {

#  ifndef PFE_SBR_CALL_THREADING
    p4cell i = *SP++;
    if (i < 0
      ? (*FX_RP += i) >= 0
      : (*FX_RP += i) < 0)
    {
        IP = RP[2];
    }else{
        FX_RP_DROP (3);
    }
#  else
    if (*SP < 0)
    {
	FX_RP[0] += *SP++;
	if (FX_RP[0] >= 0)
	    goto branch;
    }else{
	FX_RP[0] += *SP++;
	if (FX_RP[0] < 0)
	    goto branch;
    }
    FX_RP_DROP (3);
    return;
 branch:
    FX_NEW_RP_WORK;
    FX_NEW_RETVAL = FX_NEW_RP_CODE [2];
    FX_NEW_RP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}}

/** +LOOP ( increment -- ) 
 * compile ((+LOOP)) which will use the increment
 * as the loop-offset instead of just 1. See the
 * DO and LOOP construct.
 */
FCode (p4_plus_loop)
{
    p4_Q_pairs (P4_LOOP_MAGIC);
    FX_COMPILE (p4_plus_loop);
    FX (p4_forward_resolve);
}

P4COMPILES (p4_plus_loop, p4_plus_loop_execution,
          P4_SKIPS_NOTHING, P4_LOOP_STYLE);

/**  ,  ( val -- ) 
 * store the value in the dictionary
 simulate:
   : , DP  1 CELLS DP +!  ! ;
 */
FCode (p4_comma)
{
    FX_VCOMMA (*SP++);
}

/**  -  ( a b -- a-b ) 
 * return the difference of the two arguments
 */
FCode (p4_minus)
{
    SP[1] -= SP[0];
    SP++;
}

/**  .  ( val -- ) 
 * print the numerical value to stdout - uses BASE
 */
FCode (p4_dot)
{
    FX (p4_s_to_d);
    FX (p4_d_dot);
}

/** '((.\"))' ( -- ) _skip_string_
 * compiled by ." string"
 */ 
FCode_XE (p4_dot_quote_execution)
{   FX_USE_CODE_ADDR {
#  ifndef PFE_SBR_CALL_THREADING
    register char *p = (char *) IP;
    p4_type (p + 1, *p);
    FX_SKIP_STRING;
#  else
    FX_NEW_IP_WORK;
    p4_type (FX_NEW_IP_CHAR +1, *FX_NEW_IP_CHAR);
    FX_NEW_IP_SKIP_STRING;
    FX_NEW_IP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}}

/**  ."  ( [string<">] -- ) 
 * print the string to stdout
 */
FCode (p4_dot_quote)
{
    _FX_STATESMART_Q_COMP;
    if (STATESMART) 
    {
        FX_COMPILE (p4_dot_quote);
	FX (p4_parse_comma_quote);
    }else{
        p4_word_parse ('"'); /* PARSE - no throw HERE */
        p4_type (PFE.word.ptr, PFE.word.len);
    }
}

P4COMPILES (p4_dot_quote, p4_dot_quote_execution,
          P4_SKIPS_STRING, P4_DEFAULT_STYLE);

/**  /  ( a b  -- a/b ) 
 * return the quotient of the two arguments
 */
FCode (p4_slash)
{
    fdiv_t res = p4_fdiv (SP[1], SP[0]);

    *++SP = res.quot;
}

/**  /MOD  ( a b -- m n ) 
 * divide a and b and return both
 * quotient n and remainder m
 */
FCode (p4_slash_mod)
{
    *(fdiv_t *) SP = p4_fdiv (SP[1], SP[0]);
}

/** 0< ( val -- cond ) 
 * return a flag that is true if val is lower than zero
 simulate:
  : 0< 0 < ;
 */
FCode (p4_zero_less)
{
    *SP = P4_FLAG (*SP < 0);
}

/** 0= ( val -- cond ) 
 * return a flag that is true if val is just zero
 simulate:
  : 0= 0 = ;
 */
FCode (p4_zero_equal)
{
    *SP = P4_FLAG (*SP == 0);
}

/** 1+ ( val -- val+1 ) 
 * return the value incremented by one
 simulate:
  : 1+ 1 + ;
 */
FCode (p4_one_plus)
{
    ++*SP;
}

/** 1- ( val -- val-1 ) 
 * return the value decremented by one
 simulate:
   : 1- 1 - ;
 */
FCode (p4_one_minus)
{
    --*SP;
}

/** 2! ( a,a addr -- ) 
 * double-cell store 
 */
FCode (p4_two_store)
{
    *(p4dcell *) *SP = *(p4dcell *) &SP[1];
    SP += 3;
}

/** 2* ( a -- a*2 ) 
 * multiplies the value with two - but it
 * does actually use a shift1 to be faster
 simulate:
  : 2* 2 * ; ( canonic) : 2* 1 LSHIFT ; ( usual)
 */
FCode (p4_two_star)
{
    *SP <<= 1;
}

/** 2/ ( a -- a/2 ) 
 * divides the value by two - but it
 * does actually use a shift1 to be faster
 simulate:
  : 2/ 2 / ; ( canonic) : 2/ 1 RSHIFT ; ( usual)
 */
FCode (p4_two_slash)
{
    *SP >>= 1;
}

/** 2@ ( addr -- a,a ) 
 * double-cell fetch
 */
FCode (p4_two_fetch)
{
    p4dcell *p = (p4dcell *) *SP--;

    *(p4dcell *) SP = *p;
}

/** 2DROP ( a b -- ) 
 * double-cell drop, also used to drop two items
 */
FCode (p4_two_drop)
{
    SP += 2;
}

/** 2DUP ( a,a -- a,a a,a ) 
 * double-cell duplication, also used to duplicate
 * two items
 simulate:
   : 2DUP OVER OVER ; ( wrong would be : 2DUP DUP DUP ; !!) 
 */
FCode (p4_two_dup)
{
    SP -= 2;
    SP[0] = SP[2];
    SP[1] = SP[3];
}

/** 2OVER ( a,a b,b -- a,a b,b a,a ) 
 * double-cell over, see OVER and 2DUP
 simulate:
   : 2OVER SP@ 2 CELLS + 2@ ;
 */
FCode (p4_two_over)
{
    SP -= 2;
    SP[0] = SP[4];
    SP[1] = SP[5];
}

/** 2SWAP ( a,a b,b -- b,b a,a ) 
 * double-cell swap, see SWAP and 2DUP
 simulate:
   : 2SWAP LOCALS| B1 B2 A1 A2 | B2 B1 A2 A1 ;
 */
FCode (p4_two_swap)
{
    p4cell h;

    h = SP[0];
    SP[0] = SP[2];
    SP[2] = h;
    h = SP[1];
    SP[1] = SP[3];
    SP[3] = h;
}

/** "(NEST)" ( -- ) 
 * compiled by :
 * (see also (NONAME) compiled by :NONAME )
 */
FCode_RT (p4_colon_RT)
{   FX_USE_BODY_ADDR {
#  if   ! defined PFE_CALL_THREADING
    FX_PUSH_RP = IP;
    IP = (p4xcode *) FX_POP_BODY_ADDR;
#  elif ! defined PFE_SBR_CALL_THREADING
    FX_POP_BODY_ADDR_p4_BODY;
    FX_PUSH_RP = IP; IP = (p4xcode *) p4_BODY;
#  else
    p4code c = (p4code) FX_POP_BODY_ADDR;
    c ();
#  endif
}}

FCode (p4_colon_EXIT)
{
    FX (p4_Q_csp);
    STATE = P4_FALSE;
    FX (p4_reveal);
}

/**  :  ( 'name' -- ) 
 * create a header for a nesting word and go to compiling
 * mode then. This word is usually ended with ; but
 * the execution of the resulting colon-word can also 
 * return with EXIT
 */
FCode (p4_colon)
{
    FX (p4_Q_exec);
    FX_RUNTIME_HEADER; FX_SMUDGED;
#  ifndef PFE_SBR_CALL_THREADING
    FX_RUNTIME1 (p4_colon);
#  else
    { static const char* x = "_"; FX_COMMA (&x); /* CODE trampoline */ }
    FX_COMPILE_PROC;
#  endif 
    FX (p4_store_csp);
    STATE = P4_TRUE;
    PFE.locals = NULL;
    PFE.semicolon_code = PFX(p4_colon_EXIT);
}

P4RUNTIME1(p4_colon, p4_colon_RT);

/** "((;))" ( -- ) 
 * compiled by ; and maybe ;AND --
 * it will perform an EXIT
 */ 
FCode_XE (p4_semicolon_execution)
{
#  if !defined PFE_SBR_CALL_THREADING
    FX_USE_CODE_ADDR;
    IP = *RP++;
    FX_USE_CODE_EXIT;
#  endif
}

/**  ;  ( -- ) 
 * compiles ((;)) which does EXIT the current
 * colon-definition. It does then end compile-mode
 * and returns to execute-mode. See : and :NONAME
 */
FCode (p4_semicolon)
{
    if (PFE.semicolon_code)
    {
        PFE.semicolon_code ();
    }else{
        PFE.state = P4_FALSE; /* atleast switch off compiling mode */
    }

    if (PFE.locals)
    {
        FX_COMPILE2_p4_semicolon;
        PFE.locals = NULL;
    }
    else
        FX_COMPILE1_p4_semicolon; /* in SBR-threading, compiles RET-code */
}

P4COMPILES2 (p4_semicolon, p4_semicolon_execution, p4_locals_exit_execution,
           P4_SKIPS_NOTHING, P4_SEMICOLON_STYLE);

/** < ( a b -- cond ) 
 * return a flag telling if a is lower than b
 */
FCode (p4_less_than)
{
    SP[1] = P4_FLAG (SP[1] < SP[0]);
    SP++;
}

/** <# ( -- ) 
 * see also HOLD for old-style forth-formatting words
 * and PRINTF of the C-style formatting - this word
 * does initialize the pictured numeric output space.
 */
FCode (p4_less_sh)
{
    p4_HLD = p4_PAD;
}

/** = ( a b -- cond )
 * return a flag telling if a is equal to b
 */
FCode (p4_equals)
{
    SP[1] = P4_FLAG (SP[1] == SP[0]);
    SP++;
}

/** > ( a b -- cond )
 * return a flag telling if a is greater than b
 */
FCode (p4_greater_than)
{
    SP[1] = P4_FLAG (SP[1] > SP[0]);
    SP++;
}

/** >BODY ( addr -- addr' )
 * adjust the execution-token (ie. the CFA) to point
 * to the parameter field (ie. the PFA) of a word.
 * this is not a constant operation - most words have their
 * parameters at "1 CELLS +" but CREATE/DOES-words have the
 * parameters at "2 CELLS +" and ROM/USER words go indirect
 * with a rom'ed offset i.e. "CELL + @ UP +"
 */
FCode (p4_to_body) 
{
    *SP = (p4cell) p4_to_body ((p4xt) *SP);
}

/** >NUMBER ( a,a str-adr str-len -- a,a' str-adr' str-len) 
 * try to convert a string into a number, and place
 * that number at a,a respeciting BASE
 */
FCode (p4_to_number)
{
    SP[1] = (p4cell)
        p4_to_number (
                      (char *) SP[1],
                      (p4ucell *) &SP[0],
                      (p4udcell *) &SP[2],
                      BASE);
}

/** >R ( value -- )
 * save the value onto the return stack. The return
 * stack must be returned back to clean state before
 * an exit and you should note that the return-stack
 * is also touched by the DO ... WHILE loop.
 * Use R> to clean the stack and R@ to get the 
 * last value put by >R
 */
FCode (p4_to_r)
{
    FX (p4_Q_comp);
    FX_COMPILE (p4_to_r);
}

FCode_XE (p4_to_r_execution)
{
    FX_USE_CODE_ADDR;
#  if !defined PFE_SBR_CALL_THREADING
    RP_PUSH (FX_POP);
#  else
    FX_NEW_RP_WORK;
    FX_NEW_RP_CELL_POSH = FX_POP;
    FX_NEW_RP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_to_r, p4_to_r_execution, 
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** ?DUP ( value -- value|[nothing] )
 * one of the rare words whose stack-change is 
 * condition-dependet. This word will duplicate
 * the value only if it is not zero. The usual
 * place to use it is directly before a control-word
 * that can go to different places where we can
 * spare an extra DROP on the is-null-part.
 * This makes the code faster and often a little
 * easier to read.
 example:
   : XX BEGIN ?DUP WHILE DUP . 2/ REPEAT ; instead of
   : XX BEGIN DUP WHILE DUP . 2/ REPEAT DROP ;
 */
FCode (p4_Q_dup)
{
    if (*SP)
        --SP, SP[0] = SP[1];
}

/** @ ( addr -- value )
 * fetch the value from the variables address
 */
FCode (p4_fetch)
{
    *SP = *(p4cell *) *SP;
}

/** ABS ( value -- value' )
 * return the absolute value
 */
FCode (p4_abs)
{
    if (*SP < 0)
        *SP = -*SP;
}

/** ACCEPT ( a n -- n' ) 
 * get a string from terminal into the named input 
 * buffer, returns the number of bytes being stored
 * in the buffer. May provide line-editing functions.
 */
FCode (p4_accept)
{
    SP[1] = p4_accept ((char *) SP[1], SP[0]);
    SP += 1;
}

/** ALIGN ( -- )
 * will make the dictionary aligned, usually to a
 * cell-boundary, see ALIGNED
 */
FCode (p4_align)
{
    while (! P4_ALIGNED (DP))
        *DP++ = 0;
}

/** ALIGNED ( addr -- addr' )
 * uses the value (being usually a dictionary-address)
 * and increment it to the required alignment for the
 * dictionary which is usually in CELLS - see also
 * ALIGN
 */
FCode (p4_aligned)
{
    *SP = p4_aligned (*SP);
}

/** ALLOT ( count -- )
 * make room in the dictionary - usually called after
 * a CREATE word like VARIABLE or VALUE
 * to make for an array of variables. Does not 
 * initialize the space allocated from the dictionary-heap.
 * The count is in bytes - use CELLS ALLOT to allocate 
 * a field of cells.
 */
FCode (p4_allot)
{
    DP += *SP++;
}

/** AND ( val mask -- val' )
 * mask with a bitwise and - be careful when applying
 * it to logical values.
 */
FCode (p4_and)
{
    SP[1] &= SP[0];
    SP++;
}

/** BEGIN ( -- ) compile-time: ( -- cs-marker )
 * start a control-loop, see WHILE and REPEAT
 */
FCode (p4_begin)
{
    FX_COMPILE (p4_begin);
    FX (p4_backward_mark);
    FX_PUSH_SP = P4_DEST_MAGIC;
}

P4COMPILES (p4_begin, p4_noop, P4_SKIPS_NOTHING, P4_BEGIN_STYLE);

/** C! ( value address -- )
 * store the byte-value at address, see !
 */
FCode (p4_c_store)
{
    *(char *) SP[0] = SP[1];
    SP += 2;
}

/** C, ( value -- )
 * store a new byte-value in the dictionary, implicit 1 ALLOT,
 * see ,
 */
FCode (p4_c_comma)
{
    *DP++ = (p4char) *SP++;
}

/** C@ ( addr -- value )
 * fetch a byte-value from the address, see @
 */
FCode (p4_c_fetch)
{
    *SP = *(p4char *) *SP;
}

/** CELL+ ( value -- value' )
 * adjust the value by adding a single Cell's width
 * - the value is often an address or offset, see CELLS
 */
FCode (p4_cell_plus)
{
    *SP += sizeof (p4cell);
}

/** CELLS ( value -- value' )
 * scale the value by the sizeof a Cell
 * the value is then often applied to an address or
 * fed into ALLOT
 */
FCode (p4_cells)
{
    *SP *= sizeof (p4cell);
}

/** CHAR ( 'word' -- value )
 * return the (ascii-)value of the following word's
 * first character. 
 */
FCode (p4_char)
{
    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    if (! PFE.word.len)
        p4_throw (P4_ON_INVALID_NAME);
    FX_PUSH_SP = (p4ucell) *(p4char*)PFE.word.ptr;
}

/** CHAR+ ( value -- value' )
 * increment the value by the sizeof one char
 * - the value is often a pointer or an offset,
 * see CHARS
 */
FCode (p4_char_plus)
{
    *SP += sizeof (char);
}

/** CHARS ( value -- value' )
 * scale the value by the sizeof a char
 * - the value is then often applied to an address or
 * fed into ALLOT (did you expect that sizeof(p4char)
 * may actually yield 2 bytes?)
 */
FCode (p4_chars)
{
    *SP *= sizeof (char);
}

/** "((CONSTANT))" ( -- )
 * runtime compiled by CONSTANT
 */ 
FCode_RT (p4_constant_RT)
{
    FX_USE_BODY_ADDR;
    FX_PUSH_SP = FX_POP_BODY_ADDR[0];
}

/** CONSTANT ( value 'name' -- )
 * CREATE a new word with runtime ((CONSTANT))
 * so that the value placed here is returned everytime
 * the constant's name is used in code. See VALUE
 * for constant-like names that are expected to change
 * during execution of the program. In a ROM-able
 * forth the CONSTANT-value may get into a shared
 * ROM-area and is never copied to a RAM-address.
 */
FCode (p4_constant)
{
    FX_RUNTIME_HEADER; 
    FX_RUNTIME1 (p4_constant);
    FX_VCOMMA (*SP++);
}

P4RUNTIME1(p4_constant, p4_constant_RT);

/** COUNT ( counted-string -- string-pointer string-length )
 * usually before calling TYPE
 *
 * (as an unwarranted extension, this word does try to be idempotent).
 */
FCode (p4_count)
{
    /* can not unpack twice - this trick prevents from many common errors */
    if (256 > (p4ucell)(SP[0])) goto possibly_idempotent;
    --SP;
    SP[0] = *P4_VAR(p4char*,SP[1] )++;
    return;

    /* an idempotent COUNT allows to ease the transition from counted-strings
     * to string-spans:
     c" hello world" count type ( is identical with...)
     s" hello world" count type
     * however: it makes some NULL argument or just illegal argument to be
     * silently accepted that can make debugging programs a pain. Therefore
     * this function has been given some intelligence, with the counter effect
     * of being somewhat undetermined which part gets triggered at runtime.
     */
 possibly_idempotent:
    if (((p4char**)SP)[1][-1] == (p4char)(SP[0])) /* idempotent ? */
    { if ((p4char)(SP[0])) return; } /* only if not null-count ! */
    FX_PUSH (0); /* makes later functions to copy nothing at all */
}

/** CR ( -- )
 * print a carriage-return/new-line on stdout
 */  
FCode (p4_cr)
{
    p4_outc ('\n');
    p4_OUT = 0;
    PFE.lines++;
}

/** DECIMAL ( -- )
 * set the BASE to 10
 simulate:
   : DECIMAL 10 BASE ! ;
 */
FCode (p4_decimal)
{
    BASE = 10;
}

/** DEPTH ( -- value )
 * return the depth of the parameter stack before
 * the call, see SP@ - the return-value is in CELLS
 */
FCode (p4_depth)
{
    register size_t n;

    n = p4_S0 - SP;
    FX_PUSH_SP = n;
}

/* implementation detail:
 * DO will compile (DO) and forward-address to LOOP
 * (DO) will set RP[2] to its point after that forward-adress
 * LOOP can just jump to RP[2]
 * LEAVE can jump via RP[2][-1] forward-address
 */

/** "((DO))" ( end start -- )
 * compiled by DO
 */ 
FCode_XE (p4_do_execution)
{
    FX_USE_CODE_ADDR;
#  if   ! defined PFE_SBR_CALL_THREADING
    RP -= 3;                     /* push onto return-stack: */
    RP[2] = ++IP;                /* IP to jump back to just after DO */
    RP[1] = (p4xcode *) SP[1];   /* upper limit */
    RP[0] = (p4xcode *) (SP[0] - /*lower_minus*/  SP[1] /*upper_limit*/ );
    FX_2DROP;
#  elif ! defined PFE_SBR_CALL_ARG_THREADING || !defined P4_IP_VIA_RP
    FX_NEW_RP_WORK; 
    FX_NEW_RP_CELL -= 3;
    FX_NEW_RP_CODE [2] = (p4xcode*) ++FX_NEW_RETVAL;
    FX_NEW_RP_CELL [0] =  SP[0];
    FX_NEW_RP_CELL [1] =  SP[1];
    FX_NEW_RP_CELL [0] -= SP[1];
    FX_2DROP;
    FX_NEW_RP_DONE;
#  else /* this one is desperately needed on i386 */
    FX_NEW_RP_WORK; 
    FX_NEW_RP_CELL -= 3;
    FX_NEW_RETVAL ++;
    FX_NEW_RP_DONE;
    RP [2] = RP[-1]; /* get RETVAL -> IP_VIA_RP */
    RP [1] = (p4xcode*) SP[1];
    RP [0] = (p4xcode*) (SP[0] - SP[1]);
    FX_2DROP;
#  endif
    FX_USE_CODE_EXIT;
}

/** DO ( end start -- ) ... LOOP
 *  pushes $end and $start onto the return-stack ( >R )
 *  and starts a control-loop that ends with LOOP or
 *  +LOOP and may get a break-out with LEAVE . The
 *  loop-variable can be accessed with I
 */
FCode (p4_do)
{
    FX_COMPILE (p4_do);
    FX (p4_forward_mark);
    FX_PUSH_SP = P4_LOOP_MAGIC;
}

P4COMPILES (p4_do, p4_do_execution,
  P4_SKIPS_OFFSET, P4_DO_STYLE);

/** "((VAR))" ( -- pfa )
 * the runtime compiled by VARIABLE
 */ 
FCode_RT (p4_variable_RT)
{
    FX_USE_BODY_ADDR;
    FX_PUSH_SP = (p4cell) FX_POP_BODY_ADDR;
}

/**  ((BUILDS))  ( -- pfa )
 * the runtime compiled by CREATE which
 * is not much unlike a VARIABLE 
 * (in ANS Forth Mode we reserve an additional DOES-field)
 */ 
FCode (p4_builds_RT)
{
    FX_USE_BODY_ADDR;
    FX_PUSH_SP = (p4cell)( FX_POP_BODY_ADDR + 1 );
}

/** "((DOES>))" ( -- pfa )
 * runtime compiled by DOES>
 */ 
FCode_RT (p4_does_RT)
{   FX_USE_BODY_ADDR {
#  if   ! defined PFE_CALL_THREADING
    FX_PUSH_SP = (p4cell) P4_TO_DOES_BODY(WP_CFA);  /* from CFA[2] */
    FX_PUSH_RP = IP; IP = *P4_TO_DOES_CODE(WP_CFA); /* from CFA[1] */
#  elif ! defined PFE_SBR_CALL_THREADING
    p4xt xt = (p4xt) (FX_POP_BODY_ADDR-1);
    FX_PUSH_SP = (p4cell) P4_TO_DOES_BODY(xt);  /* from CFA[2] */
    FX_PUSH_RP = IP; IP = *P4_TO_DOES_CODE(xt); /* from CFA[1] */
#  else
    p4xt xt = (p4xt) (FX_POP_BODY_ADDR-1);
    FX_PUSH_SP = (p4cell) P4_TO_DOES_BODY(xt);  /* from CFA[2] */
    ((p4code)(*P4_TO_DOES_CODE(xt)))(); /* from CFA[1] */
#  endif
}}

P4RUNTIME1 (p4_does, p4_does_RT);

/** "(DOES>)" ( -- pfa )
 * execution compiled by DOES>
 */ 
FCode_XE (p4_does_execution)
{   FX_USE_CODE_ADDR {
#  if   ! defined PFE_SBR_CALL_THREADING
    p4xt xt;
    if (! LAST)
        p4_throw (P4_ON_ARG_TYPE);

    xt = p4_name_from (LAST);
    P4_XT_VALUE(xt) = FX_GET_RT (p4_does); 
    *P4_TO_DOES_CODE(xt) = IP; /* into CFA[1] */

    if (LP != FX_RP)
        IP = *RP++;   /* double-EXIT */
    else
        FX (p4_locals_exit_execution);
#  else
    FX_NEW_IP_WORK;
    if (! LAST)
        p4_throw (P4_ON_ARG_TYPE);
    
    {
        p4xt xt = p4_name_from (LAST);
        P4_XT_VALUE(xt) = FX_GET_RT (p4_does); 
        *P4_TO_DOES_CODE(xt) = FX_NEW_IP_CODE; /* into CFA[1] */
    }
    FX_NEW_IP_CODE = PFX (p4_noop);   /* double-EXIT */
    FX_NEW_IP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}}

/**  DOES>  ( -- pfa )
 * does twist the last CREATE word to carry
 * the (DOES>) runtime. That way, using the
 * word will execute the code-piece following DOES>
 * where the pfa of the word is already on stack.
 * (note: FIG option will leave pfa+cell since does-rt is stored in pfa)
 */
FCode (p4_does)
{
    _FX_STATESMART_Q_COMP;
    if (STATESMART)
    {
        FX (p4_Q_csp);
        FX_COMPILE (p4_does);
        PFE.locals = NULL;
    }else{
        /* see p4_does_execution above */
        p4xt xt;
        if (! LAST)
            p4_throw (P4_ON_ARG_TYPE);
        FX (p4_align);

        xt = p4_name_from (LAST);
        P4_XT_VALUE(xt) = FX_GET_RT (p4_does); 
        *P4_TO_DOES_CODE(xt) = (p4xcode*) DP; /* into CFA[1] */

        /* now, see p4_colon */
        FX (p4_store_csp);
        STATE = P4_TRUE;
        PFE.locals = NULL;
        PFE.semicolon_code = PFX(p4_colon_EXIT);
    }
}

P4COMPILES (p4_does, p4_does_execution,
  P4_SKIPS_NOTHING, P4_DOES_STYLE);

/** CREATE ( 'name' -- )
 * create a name with runtime ((VAR)) so that everywhere the name is used 
 * the pfa of the name's body is returned. This word is not immediate and 
 * according to the ANS Forth documents it may get directly used in the 
 * first part of a DOES> defining word - in traditional forth systems
 * the word <BUILDS was used for that and CREATE was defined to be
 * the first part of a VARIABLE word (compare with CREATE: and the
 * portable expression 0 BUFFER:)
 */

/** <BUILDS ( 'name' -- )
 *  make a HEADER whose runtime will be changed later
 *  using DOES>  

 *  note that ans'forth does not define <BUILDS and
 *  it suggests to use CREATE directly. 

 *  ... if you want to write FIG-programs in pure pfe then you have
 *  to use CREATE: to get the FIG-like meaning of CREATE whereas
 *  the ans-forth CREATE is the same as <BUILDS
 : <BUILDS BL WORD HEADER DOCREATE A, 0 A, ;
 */
FCode (p4_builds)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_builds);
    FX_RCOMMA (0);
}

P4RUNTIME1(p4_builds, p4_builds_RT);

/** DROP ( a -- )
 * just drop the word on the top of stack, see DUP
 */
FCode (p4_drop)
{
    SP++;
}

/** DUP ( a -- a a )
 * duplicate the cell on top of the stack - so the
 * two topmost cells have the same value (they are
 * equal w.r.t = ) , see DROP for the inverse
 */
FCode (p4_dup)
{
    --SP;
    SP[0] = SP[1];
}

/** "((ELSE))" ( -- )
 * execution compiled by ELSE - just a simple
 * BRANCH
 */ 
FCode_XE (p4_else_execution)
{
    FX_USE_CODE_ADDR;
    FX_BRANCH;
    FX_USE_CODE_EXIT;
}

/** ELSE ( -- )
 * will compile an ((ELSE)) BRANCH that performs an 
 * unconditional jump to the next THEN - and it resolves 
 * an IF for the non-true case
 */
FCode (p4_else)
{
    p4_Q_pairs (P4_ORIG_MAGIC);
    FX_COMPILE (p4_else);
    FX (p4_ahead) ;
    FX (p4_rot) ;
    FX (p4_forward_resolve) ;
}

P4COMPILES (p4_else, p4_else_execution,
  P4_SKIPS_OFFSET, P4_ELSE_STYLE);

/** EMIT ( char -- )
 * print the char-value on stack to stdout
 */
FCode (p4_emit)
{
    PFE.execute (PFE.emit);
}

/** ENVIRONMENT? ( a1 n1 -- false | ?? true )
 * check the environment for a property, usually
 * a condition like questioning the existance of 
 * specified wordset, but it can also return some
 * implementation properties like "WORDLISTS"
 * (the length of the search-order) or "#LOCALS"
 * (the maximum number of locals) 

 * Here it implements the environment queries as a SEARCH-WORDLIST 
 * in a user-visible vocabulary called ENVIRONMENT
 : ENVIRONMENT?
   ['] ENVIRONMENT >WORDLIST SEARCH-WORDLIST
   IF  EXECUTE TRUE ELSE  FALSE THEN ;
 */
FCode (p4_environment_Q_core)
{
# if 1
    extern FCode (p4_environment_Q);
    FX (p4_environment_Q);
# else
    p4cell len = SP[0];

    if (len > 256 || -256 > len ) 
    {  /* this scheme allows you to submit a forth counted string */
        P4_warn ("counted string at query to ENVIRONMENT?");
        FX (p4_count); 
        len = SP[0];
    }

    if (0 < len && len < 32 && PFE.environ_wl) 
    { 
        p4char* nfa = p4_search_wordlist ((void*) SP[1], len, PFE.environ_wl);
        if (nfa)
        {
            FX_2DROP;
            if (PFE_IS_DESTROYER(nfa))
                FX_PUSH_SP = P4_TO_BODY(p4_name_from(nfa));
            else
                p4_call (p4_name_from(nfa));
            FX_PUSH(P4_TRUE);
            return;
        }
    }

    /* not found */
    FX_DROP;
    *SP = 0;
# endif
}

/** EVALUATE ( str-ptr str-len -- ) 
 * INTERPRET the given string, SOURCE id
 * is -1 during that time.
 */
FCode (p4_evaluate)
{
    char *p = (char *) SP[1];
    int n = SP[0];

    SP += 2;
    p4_evaluate (p, n);
}

/** EXECUTE ( xt -- )
 * run the execution-token on stack - this will usually
 * trap if it was null for some reason, see >EXECUTE
 simulate:
  : EXECUTE >R EXIT ;
 */
FCode (p4_execute)
{
#  ifndef PFE_CALL_THREADING
    PFE.execute ((p4xt) *SP++);
#  else
    p4_call ((p4xt) *SP++);
#  endif
}

/** EXIT ( -- )
 * will unnest the current colon-word so it will actually
 * return the word calling it. This can be found in the
 * middle of a colon-sequence between : and ;
 */
FCode (p4_exit)
{
    if (PFE.locals)
    {   FX_COMPILE2_p4_exit; }
    else
    { FX_COMPILE1_p4_exit; }
}

P4COMPILES2 (p4_exit, p4_semicolon_execution, p4_locals_exit_execution,
           P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** FILL ( mem-addr mem-length char -- )
 * fill a memory area with the given char, does now
 * simply call memset()
 */
FCode (p4_fill)
{
    memset ((void *) SP[2], SP[0], SP[1]);
    SP += 3;
}

/** FIND ( bstring -- cfa|bstring -1|0|1 )
 * looks into the current search-order and tries to find
 * the name string as the name of a word. Returns its
 * execution-token or the original-bstring if not found,
 * along with a flag-like value that is zero if nothing
 * could be found. Otherwise it will be 1 (a positive value)
 * if the word had been immediate, -1 otherwise (a negative
 * value).
 */
FCode (p4_find)
{
    char *p = (char *) *SP;

    p = p4_find (p + 1, *p);
    if (p)
    {
        *SP = (p4cell) p4_name_from (p);
        FX_PUSH_SP = *_FFA(p) & P4xIMMEDIATE ? P4_POSITIVE : P4_NEGATIVE;
    }
    else
        FX_PUSH_SP = 0;
}

/**  FM/MOD  ( n1.n1 n2 -- m n )
 * divide the double-cell value n1 by n2 and return
 * both (floored) quotient n and remainder m 
 */
FCode (p4_f_m_slash_mod)
{
    p4cell denom = *SP++;

    *(fdiv_t *) SP = p4_d_fmdiv (*(p4dcell *) SP, denom);
}

/** HERE ( -- dp-value )
 * used with WORD and many compiling words
 simulate:   : HERE DP @ ;
 */
FCode (p4_here)
{
    FX_PUSH_SP = (p4cell) DP;
}

/** HOLD ( char -- ) 
 * the old-style forth-formatting system -- this
 * word adds a char to the picutred output string.
 */
FCode (p4_hold)
{
    p4_hold ((char) *SP++);
}

/** I ( -- value )
 * returns the index-value of the innermost DO .. LOOP
 */
FCode (p4_i)
{
    FX_COMPILE (p4_i);
}

FCode_XE (p4_i_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH_SP = FX_RP[0] + FX_RP[1];
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_i, p4_i_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** "((IF))" ( -- )
 * execution word compiled by IF - just some simple ?BRANCH
 */
FCode_XE (p4_if_execution)
{
    FX_USE_CODE_ADDR;
    if (!*SP++)
        FX_BRANCH;
    else
        IP++;
    FX_USE_CODE_EXIT;
}

/** IF ( value -- ) .. THEN
 * checks the value on the stack (at run-time, not compile-time)
 * and if true executes the code-piece between IF and the next
 * ELSE or THEN . Otherwise it has compiled a branch over
 * to be executed if the value on stack had been null at run-time.
 */
FCode (p4_if)
{
    FX_COMPILE (p4_if);
    FX (p4_ahead);
}

P4COMPILES (p4_if, p4_if_execution,
  P4_SKIPS_OFFSET, P4_IF_STYLE);

/** IMMEDIATE ( -- )
 * make the LATEST word immediate, see also CREATE
 */
FCode (p4_immediate)
{
    if (LAST)
        *_FFA(LAST) |= P4xIMMEDIATE;
    else
        p4_throw (P4_ON_ARG_TYPE);
}

/** INVERT ( value -- value' )
 * make a bitwise negation of the value on stack.
 * see also NEGATE
 */
FCode (p4_invert)
{
    *SP = ~*SP;
}

/** J ( -- value )
 * get the current DO ... LOOP index-value being
 * the not-innnermost. (the second-innermost...)
 * see also for the other loop-index-values at
 * I and K
 */
FCode (p4_j)
{
    FX_COMPILE (p4_j);
}

FCode_XE (p4_j_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH_SP = FX_RP[3] + FX_RP[4];
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_j, p4_j_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** KEY ( -- char ) 
 * return a single character from the keyboard - the
 * key is not echoed.
 */
FCode (p4_key)
{
    PFE.execute (PFE.key);
}

/** LEAVE ( -- )
 * quit the innermost DO .. LOOP  - it does even
 * clean the return-stack and branches to the place directly
 * after the next LOOP
 */
FCode (p4_leave)
{
    FX_COMPILE (p4_leave);
}

FCode_XE (p4_leave_execution)
{
    FX_USE_CODE_ADDR;
#  if   ! defined  PFE_SBR_CALL_THREADING
    IP = RP[2] - 1; /* the place after the next LOOP */
    RP += 3;        /* UNLOOP */
    FX_BRANCH;
#  else
    FX_NEW_RP_WORK;
    FX_NEW_RETVAL = (p4xcode*) FX_NEW_RP_CODE[2][-1];
    FX_NEW_RP_CELL += 3;
    FX_NEW_RP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_leave, p4_leave_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** "((LIT))" ( -- value )
 * execution compiled by LITERAL
 */ 
FCode_XE (p4_literal_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH_SP = P4_POP (IP);
    FX_USE_CODE_EXIT;
}

/** LITERAL ( value -- ) immediate
 * if compiling this will take the value from the compiling-stack 
 * and puts in dictionary so that it will pop up again at the
 * run-time of the word currently in creation. This word is used
 * in compiling words but may also be useful in making a hard-constant
 * value in some code-piece like this:
 : DCELLS [ 2 CELLS ] LITERAL * ; ( will save a multiplication at runtime)
 * (in most configurations this word is statesmart and it will do nothing
 *  in interpret-mode. See LITERAL, for a non-immediate variant)
 */
FCode (p4_literal)
{
    _FX_STATESMART_Q_COMP;
    if (STATESMART)
    {
        FX_COMPILE (p4_literal);
        FX_SCOMMA (*SP++);
    }
}

P4COMPILES (p4_literal, p4_literal_execution,
  P4_SKIPS_CELL, P4_DEFAULT_STYLE);

/** "((LOOP))" ( -- )
 * execution compiled by LOOP
 */
FCode_XE (p4_loop_execution)
{
    FX_USE_CODE_ADDR;
#  ifndef PFE_SBR_CALL_THREADING
    if (++*FX_RP)                       /* increment top of return stack */
        IP = RP[2];                     /* if nonzero: loop back */
    else
    {
	FX_RP_DROP (3);             /* if zero: terminate loop */
    }
#  else
    if (++*FX_RP)
    {
	FX_NEW_RP_WORK;
	FX_NEW_RETVAL = FX_NEW_RP_CODE [2]; 
	FX_NEW_RP_DONE;
    }else{
	FX_RP_DROP (3);
    }
#  endif
    FX_USE_CODE_EXIT;
}

/** LOOP ( -- )
 * resolves a previous DO thereby compiling ((LOOP)) which
 * does increment/decrement the index-value and branch back if
 * the end-value of the loop has not been reached.
 */
FCode (p4_loop)
{
    p4_Q_pairs (P4_LOOP_MAGIC);
    FX_COMPILE (p4_loop);
    FX (p4_forward_resolve);
}

P4COMPILES (p4_loop, p4_loop_execution,
  P4_SKIPS_OFFSET, P4_LOOP_STYLE);

/** LSHIFT ( value shift-val -- value' )
 * does a bitwise left-shift on value
 */
FCode (p4_l_shift)
{
    SP[1] <<= SP[0];
    SP++;
}

/** M* ( a b -- m,m )
 * multiply and return a double-cell result
 */
FCode (p4_m_star)
{
    *(p4dcell *) SP = mmul (SP[0], SP[1]);
}

/** MAX ( a b -- c )
 * return the maximum of a and b
 */
FCode (p4_max)
{
    if (SP[0] > SP[1])
        SP[1] = SP[0];
    SP++;
}

/** MIN ( a b -- c )
 * return the minimum of a and b
 */
FCode (p4_min)
{
    if (SP[0] < SP[1])
        SP[1] = SP[0];
    SP++;
}

/** MOD ( a b -- c )
 * return the module of "a mod b"
 */
FCode (p4_mod)
{
    fdiv_t res = p4_fdiv (SP[1], SP[0]);
    
    *++SP = res.rem;
}

/** MOVE ( from to length -- ) 
 * memcpy an area
 */
FCode (p4_move)
{
    memmove ((void *) SP[1], (void *) SP[2], (size_t) SP[0]);
    SP += 3;
}

/** NEGATE ( value -- value' )
 * return the arithmetic negative of the (signed) cell
 simulate:   : NEGATE -1 * ;
 */
FCode (p4_negate)
{
    *SP = -*SP;
}

/** OR ( a b -- ab )
 * return the bitwise OR of a and b - unlike AND this
 * is usually safe to use on logical values
 */
FCode (p4_or)
{
    SP[1] |= SP[0];
    SP++;
}

/** OVER ( a b -- a b a )
 * get the value from under the top of stack. The inverse
 * operation would be TUCK
 */
FCode (p4_over)
{
    --SP;
    SP[0] = SP[2];
}

/** "((POSTPONE))" ( -- )
 * execution compiled by POSTPONE
 */ 
FCode_XE (p4_postpone_execution)
{
    FX_USE_CODE_ADDR;
    FX_COMPILE_COMMA((p4xt)( P4_POP (IP) ));
    FX_USE_CODE_EXIT;
}

/** POSTPONE ( [word] -- )
 * will compile the following word at the run-time of the
 * current-word which is a compiling-word. The point is that
 * POSTPONE takes care of the fact that word may be 
 * an IMMEDIATE-word that flags for a compiling word, so it
 * must be executed (and not pushed directly) to compile
 * sth. later. Choose this word in favour of COMPILE
 * (for non-immediate words) and [COMPILE] (for immediate
 * words)
 */
FCode (p4_postpone)
{
    p4char* nfa;

    FX (p4_Q_comp);
    nfa = p4_tick_nfa (FX_VOID);
# ifndef PFE_CALL_THREADING
    if (!( *_FFA (nfa) & P4xIMMEDIATE))
        FX_COMPILE (p4_postpone);
    FX_XCOMMA (p4_name_from (nfa)); /* a.k.a. FX_COMPILE_COMMA */
# else
    if (!( *_FFA (nfa) & P4xIMMEDIATE))
    {
	FX_COMPILE (p4_postpone);
	FX_XCOMMA (p4_name_from(nfa));
    }else{
	FX_COMPILE_COMMA (p4_name_from(nfa));
    }
# endif
}

P4COMPILES (p4_postpone, p4_postpone_execution,
          P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** QUIT ( -- ) no-return
 * this will throw and lead back to the outer-interpreter.
 * traditionally, the outer-interpreter is called QUIT
 * in forth itself where the first part of the QUIT-word
 * had been to clean the stacks (and some other variables)
 * and then turn to an endless loop containing QUERY 
 * and EVALUATE (otherwise known as INTERPRET )
 * - in pfe it is defined as a THROW ,
 : QUIT -56 THROW ;
 */
FCode (p4_quit)
{
    p4_throw (P4_ON_QUIT);
}

/** R> ( R: a -- a R: )
 * get back a value from the return-stack that had been saved
 * there using >R . This is the traditional form of a local
 * var space that could be accessed with R@ later. If you
 * need more local variables you should have a look at LOCALS|
 * which does grab some space from the return-stack too, but names
 * them the way you like.
 */
FCode (p4_r_from)
{
    FX (p4_Q_comp);
    FX_COMPILE (p4_r_from);
}

FCode_XE (p4_r_from_execution)
{
    FX_USE_CODE_ADDR;
#  if !defined PFE_SBR_CALL_THREADING
    FX_PUSH_SP = (p4cell) FX_POP_RP;
#  else
    FX_PUSH_SP = (p4cell) RP[0];
    FX_RP_DROP (1);
#  endif
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_from, p4_r_from_execution, 
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** R@ ( R: a -- a R: a )
 * fetch the (upper-most) value from the return-stack that had
 * been saved there using >R - This is the traditional form of a local
 * var space. If you need more local variables you should have a 
 * look at LOCALS| , see also >R and R> . Without LOCALS-EXT
 * there are useful words like 2R@ R'@ R"@ R! 
 */
FCode (p4_r_fetch)
{
    FX (p4_Q_comp);
    FX_COMPILE (p4_r_fetch);
}

FCode_XE (p4_r_fetch_execution)
{
    FX_USE_CODE_ADDR;
    FX_PUSH_SP = *FX_RP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_fetch, p4_r_fetch_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** RECURSE ( ? -- ? )
 * when creating a colon word the name of the currently-created
 * word is smudged, so that you can redefine a previous word
 * of the same name simply by using its name. Sometimes however
 * one wants to recurse into the current definition instead of
 * calling the older defintion. The RECURSE word does it 
 * exactly this.
   traditionally the following code had been in use:
   : GREAT-WORD [ UNSMUDGE ] DUP . 1- ?DUP IF GREAT-WORD THEN ;
   now use
   : GREAT-WORD DUP . 1- ?DUP IF RECURSE THEN ;
 */
FCode (p4_recurse)
{
    FX (p4_Q_comp);
    if (LAST)
        FX_COMPILE_COMMA (p4_name_from (LAST));
    else
        p4_throw (P4_ON_ARG_TYPE);
}

/** REPEAT ( -- )
 * ends an unconditional loop, see BEGIN
 */
FCode (p4_repeat)
{
    p4_Q_pairs (P4_DEST_MAGIC);
    FX_COMPILE (p4_repeat);
    FX (p4_backward_resolve);
    p4_Q_pairs (P4_ORIG_MAGIC);
    FX (p4_forward_resolve);
}

P4COMPILES (p4_repeat, p4_else_execution,
  P4_SKIPS_OFFSET, P4_REPEAT_STYLE);

/** ROT ( a b c -- b c a )
 * rotates the three uppermost values on the stack,
 * the other direction would be with -ROT - please
 * have a look at LOCALS| and VAR that can avoid 
 * its use.
 */
FCode (p4_rot)
{
    p4cell h = SP[2];

    SP[2] = SP[1];
    SP[1] = SP[0];
    SP[0] = h;
}

/** RSHIFT ( value shift-val -- value' )
 * does a bitwise logical right-shift on value
 * (ie. the value is considered to be unsigned)
 */
FCode (p4_r_shift)
{
    *(p4ucell *) &SP[1] >>= SP[0];
    SP++;
}

/** '((S"))' ( -- string-address string-length )
 * execution compiled by S"
 */ 
FCode_XE (p4_s_quote_execution)
{   FX_USE_CODE_ADDR {
#  ifndef PFE_SBR_CALL_THREADING
    p4char *p = (p4char *) IP;
    
    SP -= 2;
    SP[0] = *p;
    SP[1] = (p4cell) (p + 1);
    FX_SKIP_STRING;
#  else
    FX_NEW_IP_WORK;
    SP -= 2;
    SP[0] = *FX_NEW_IP_CHAR;
    SP[1] = (p4cell) (FX_NEW_IP_CHAR + 1);
    FX_NEW_IP_SKIP_STRING;
    FX_NEW_IP_DONE;
#  endif
    FX_USE_CODE_EXIT;
}}

/**  S"  ( [string<">] -- string-address string-length)
 * if compiling then place the string into the currently
 * compiled word and on execution the string pops up
 * again as a double-cell value yielding the string's address
 * and length. To be most portable this is the word to be
 * best being used. Compare with C" and non-portable "
 */
FCode (p4_s_quote)
{
    if (STATE) /* 'S"' is always STATESMART (required by FILE-EXT) */
    {
        FX_COMPILE (p4_s_quote);
        FX (p4_parse_comma_quote);
    }else{
        register char *p;
        register p4ucell n;

        p = p4_pocket ();
        p4_word_parse ('"'); /* PARSE - no throw HERE */
	n = PFE.word.len;
        if (n > P4_POCKET_SIZE-1)
            n = P4_POCKET_SIZE-1;
        *p++ = n;
        memcpy (p, PFE.word.ptr, n);
        FX_PUSH(p);
        FX_PUSH(n);
    }
}

P4COMPILES (p4_s_quote, p4_s_quote_execution,
  P4_SKIPS_STRING, P4_DEFAULT_STYLE);

/** S>D ( a -- a,a' )
 * signed extension of a single-cell value to a double-cell value
 */
FCode (p4_s_to_d)
{
    SP--;
    SP[0] = SP[1] < 0 ? -1 : 0;
}

/** SIGN ( a -- )
 * put the sign of the value into the hold-space, this is
 * the forth-style output formatting, see HOLD
 */
FCode (p4_sign)
{
    if (*SP++ < 0)
        p4_hold ('-');
}

/** SM/REM ( a.a b -- c d ) 
 * see /MOD or FM/MOD or UM/MOD or SM/REM
 */
FCode (p4_s_m_slash_rem)
{
    p4cell denom = *SP++;

    *(fdiv_t *) SP = p4_d_smdiv (*(p4dcell *) SP, denom);
}

/** SOURCE ( -- buffer IN-offset )
 *  the current point of interpret can be gotten through SOURCE.
 *  The buffer may flag out TIB or BLK or a FILE and IN gives
 *  you the offset therein. Traditionally, if the current SOURCE
 *  buffer is used up, REFILL is called that asks for another
 *  input-line or input-block. This scheme would have made it
 *  impossible to stretch an [IF] ... [THEN] over different blocks,
 *  unless [IF] does call REFILL
 */
FCode (p4_source)
{
    char *p;
    int in;

    p4_source (&p, &in);
    SP -= 2;
    SP[1] = (p4cell) p;
    SP[0] = in;
}