/** 
 * --  Compatiblity with the FORTH-83 standard.
 *
 *  Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
 *
 *  @see     GNU LGPL
 *  @author  Tektronix CTE              @(#) %derived_by: guidod %
 *  @version %version: bln_mpt1!5.24 %
 *    (%date_modified: Mon Apr 08 20:22:35 2002 %)
 *
 *  @description
 *     All FORTH-83-Standard words are included here that are not 
 *     in the dpANS already.
 *     Though most of the "uncontrolled reference words" are omitted.
 */
/*@{*/

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

#define _P4_SOURCE 1

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

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

#include <pfe/def-comp.h>
#include <pfe/facility-ext.h>
#include <pfe/logging.h>
#include <pfe/_missing.h>

/************************************************************************/
/* required word set                                                    */
/************************************************************************/

/** 2+ ( i -- i ) 
 *  add 2 to the value on stack (and leave the result there)
 simulate:
   : 2+ 2 + ;
 */
FCode (p4_two_plus) 
{
    *SP += 2;
}

/** 2- ( i -- i )
 *  substract 2 from the value on stack (and leave the result there)
 simulate:
   : 2- 2 - ;
 */
FCode (p4_two_minus)
{
    *SP -= 2;
}

/** COMPILE ( 'word' -- ) 
 * compile the next word. The next word should not be immediate,
 * in which case you would have to use [COMPILE]. For this
 * reason, you should use the word POSTPONE, which takes care
 * it.
 simulate:
   : COMPILE  R> DUP @ , CELL+ >R ;  ( not immediate !!! )
 */
FCode (p4_compile)		
{
    FX_COMPILE (p4_compile);
    FX (p4_bracket_compile);
}

extern FCode (p4_postpone_execution);

P4COMPILES (p4_compile, p4_postpone_execution,
  P4_SKIPS_CELL, P4_DEFAULT_STYLE);

/** ((VOCABULARY)) ( -- )
 * runtime of a VOCABULARY
 */ 
FCode_RT (p4_vocabulary_RT)
{
    FX_USE_BODY_ADDR;
    CONTEXT[0] = (Wordl *) FX_POP_BODY_ADDR;
}

/** VOCABULARY ( 'name' -- )
 * create a vocabulary of that name. If the named vocabulary
 * is called later, it will run ((VOCABULARY)) , thereby
 * putting it into the current search order.
 * Special pfe-extensions are accessible via 
 * CASE-SENSITIVE-VOC and SEARCH-ALSO-VOC
 simulate:
   : VOCABULARY  CREATE ALLOT-WORDLIST
        DOES> ( the ((VOCABULARY)) runtime )
          CONTEXT ! 
   ; IMMEDIATE
 */
FCode (p4_vocabulary)
{
    FX_HEADER;
    FX_RUNTIME1(p4_vocabulary);
    p4_make_wordlist (LAST);
}

P4RUNTIME1(p4_vocabulary, p4_vocabulary_RT);

/************************************************************************/
/* Controlled reference words                                           */
/************************************************************************/

/** --> ( -- ) no-return
 * does increase BLK and refills the input-buffer
 * from there. Does hence break interpretation of the
 * current BLK and starts with the next. Old-style
 * forth mechanism. You should use INCLUDE
 */
FCode (p4_next_block)		
{
    FX (p4_Q_loading);
    p4_refill ();
}

/** K ( -- counter-val )
 * the 3rd loop index just like I and J
 */
FCode (p4_k)			
{
    FX_COMPILE (p4_k);
}

FCode (p4_k_execution)			
{
    FX_USE_CODE_ADDR;
    FX_PUSH (FX_RP[6] + FX_RP[7]);
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_k, p4_k_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** OCTAL ( -- )
 * sets BASE to 8. Compare with HEX and DECIMAL
 simulate:
   : OCTAL  8 BASE ! ;
 */
FCode (p4_octal)
{
    BASE = 8;
}

/** SP@ ( -- )
 * the address of the top of stack. Does save it onto
 * the stack. You could do 
   : DUP  SP@ @ ;
 */
FCode (p4_s_p_fetch)		
{
    void *p = SP;

    *--SP = (p4cell) p;
}

/************************************************************************/
/* Some uncontrolled reference words                                    */
/************************************************************************/

/** !BITS ( bits addr mask -- )
 * at the cell pointed to by addr, change only the bits that
 * are enabled in mask
 simulate:
   : !BITS  >R 2DUP @ R NOT AND SWAP R> AND OR SWAP ! DROP ;
 */
FCode (p4_store_bits)		
{
    p4ucell mask = SP[0];
    p4ucell *ptr = (p4ucell *) SP[1];
    p4ucell bits = SP[2];
    
    SP += 3;
    *ptr = (*ptr & ~mask) | (bits & mask);
}

/** ** ( a b -- r )
 * raise second to top power
 */
FCode (p4_power)
{
    p4cell i = *SP++;
    p4cell n = *SP, m;

    for (m = 1; --i >= 0; m *= n) { }
    *SP = m;
}

/** >< ( a -- a' )
 * byte-swap a word
 */
FCode (p4_byte_swap)
{
    p4char *p = (p4char *) SP
# if PFE_BYTEORDER == 4321
        + (sizeof (p4cell) - 2)
# endif
        , h;

    h = p[1];
    p[1] = p[0];
    p[0] = h;
}

/** >MOVE< ( from-addr to-addr count -- )
 * see MOVE , does byte-swap for each word underway
 */
FCode (p4_byte_swap_move)
{
    p4char *p = (p4char *) SP[2];
    p4char *q = (p4char *) SP[1];
    p4cell n = SP[0];

    SP += 3;
    for (; n > 0; n -= 2)
    {
        q[1] = p[0];
        q[0] = p[1];
        p += 2;
        q += 2;
    }
}

/** @BITS ( addr mask -- value )
 * see the companion word !BITS
 simulate:
   : @BITS  SWAP @ AND ;
 */ 
FCode (p4_fetch_bits)
{
    SP[1] = *(p4cell *) SP[1] & SP[0];
    SP++;
}

/************************************************************************/
/* Search order specification and control                               */
/************************************************************************/

/** SEAL ( -- )
 * looks through the search-order and kills the ONLY wordset -
 * hence you can't access the primary vocabularies from there.
 */
FCode (p4_seal)
{
    Wordl **w;

    for (w = CONTEXT; w <= &ONLY; w++)
        if (*w == ONLY)
            w = NULL;
}

/** NOT ( x - ~x )
 * a SYNONYM for INVERT - the word NOT is not portable as in some
 * systems it is a SYNONYM for 0= ... therefore try to avoid it.
 * (may change later to be a real SYNONYM of either INVERT or 0=)
 : NOT INVERT LOG.WARN" forth' NOT is not portable, use INVERT or 0=" ;
 */
FCode (p4_not)
{
    FX_COMPILE(p4_not);
    P4_warn ("forth' NOT is not portable, use INVERT or 0= ");
}

P4COMPILES(p4_not, p4_invert, P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

P4_LISTWORDS (forth_83) =
{
     (, ),

    /* FORTH-83 required word set */
     (,		),
     (,		),
     (,	),
     (,		),
     (,		), 
     (,	),

    /* FORTH-83 controlled reference words */
     (,		),
     (,	),
     (,		),
     (,		),
     (,		),

    /* FORTH-83 uncontrolled reference words */
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),

    /* FORTH-83 Search order specification and control */
     (,		),
};
P4_COUNTWORDS (forth_83, "Forth'83 compatibility");

/*@}*/

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