/** 
   --  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) =
{
    P4_INTO ("FORTH", "[ANS]"),

    /* FORTH-83 required word set */
    P4_FXco ("2+",		p4_two_plus),
    P4_FXco ("2-",		p4_two_minus),
    P4_FXco ("?TERMINAL",	p4_key_question),
    P4_SXco ("COMPILE",		p4_compile),
    P4_SXco ("NOT",		p4_not), 
    P4_FXco ("VOCABULARY",	p4_vocabulary),

    /* FORTH-83 controlled reference words */
    P4_IXco ("-->",		p4_next_block),
    P4_FXco ("INTERPRET",	p4_interpret),
    P4_SXco ("K",		p4_k),
    P4_FXco ("OCTAL",		p4_octal),
    P4_FXco ("SP@",		p4_s_p_fetch),

    /* FORTH-83 uncontrolled reference words */
    P4_FXco ("!BITS",		p4_store_bits),
    P4_FXco ("@BITS",		p4_fetch_bits),
    P4_FXco ("><",		p4_byte_swap),
    P4_FXco (">MOVE<",		p4_byte_swap_move),
    P4_FXco ("**",		p4_power),
    P4_DVaR ("DPL",		dpl),

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

/*@}*/

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