/** 
   -- miscellaneous useful extra words for CORE-EXT
  
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE              @(#) %derived_by: guidod %
    @version %version:  1.12 %
      (%date_modified:  Tue Mar 12 11:57:34 2002 %)
  
    @description
        Compatiblity with former standards, miscellaneous useful words.
        ... for CORE-EXT
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:   core-mix.c~1.12:csrc:bln_mpt1!1 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/version-sub.h>

/************************************************************************/
/* more comparision operators                                           */
/************************************************************************/

/** 0<= ( a -- flag )
 simulate    : 0<= 0> 0= ;
 */
FCode (p4_zero_less_equal)
{
    *SP = P4_FLAG (*SP <= 0);
}


/** 0>= ( a -- flag )
 simulate    : 0>= 0< 0= ;
 */
FCode (p4_zero_greater_equal)
{
    *SP = P4_FLAG (*SP >= 0);
}


/** <= ( a b -- flag )
 simulate    : <= > 0= ;
 */
FCode (p4_less_equal)
{
    SP[1] = P4_FLAG (SP[1] <= SP[0]);
    SP++;
}


/** >= ( a b -- flag )
 simulate    : >= < 0= ;
 */
FCode (p4_greater_equal)
{
    SP[1] = P4_FLAG (SP[1] >= SP[0]);
    SP++;
}


/** U<= ( a b -- flag )
 simulate    : U<= U> 0= ;
 */
FCode (p4_u_less_equal)
{
    SP[1] = P4_FLAG ((p4ucell) SP[1] <= (p4ucell) SP[0]);
    SP++;
}


/** U>= ( a b -- flag )
 simulate    : U>= U< 0= ;
 */
FCode (p4_u_greater_equal)
{
    SP[1] = P4_FLAG ((p4ucell) SP[1] >= (p4ucell) SP[0]);
    SP++;
}


/** UMAX ( a b -- max )
   see => MAX
 */
FCode (p4_u_max)
{
    if ((p4ucell) SP[0] > (p4ucell) SP[1])
        SP[1] = SP[0];
    SP++;
}


/** UMIN ( a b -- min )
   see => MIN , => MAX and => UMAX
 */
FCode (p4_u_min)
{
    if ((p4ucell) SP[0] < (p4ucell) SP[1])
        SP[1] = SP[0];
    SP++;
}


/** LICENSE ( -- )
   show a lisence info - the basic PFE system is licensed under the terms
   of the LGPL (Lesser GNU Public License) - binary modules loaded into
   the system and hooking into the system may carry another => LICENSE
 : LICENSE [ ENVIRONMENT ] FORTH-LICENSE TYPE ;
 */
FCode (p4_license)
{
    p4_outs (p4_license_string ());
}


/** WARRANTY ( -- )
   show a warranty info - the basic PFE system is licensed under the terms
   of the LGPL (Lesser GNU Public License) - which exludes almost any 
   liabilities whatsoever - however loadable binary modules may hook into
   the system and their functionality may have different WARRANTY infos.
 */
FCode (p4_warranty)
{
    p4_outs (p4_warranty_string ());
}


/** .VERSION ( -- )
   show the version of the current PFE system
 : .VERSION [ ENVIRONMENT ] FORTH-NAME TYPE FORTH-VERSION TYPE ;
 */
FCode (p4_dot_version)
{
    p4_outs (p4_version_string ());
}


/** .CVERSION ( -- )
   show the compile date of the current PFE system
 : .CVERSION [ ENVIRONMENT ] FORTH-NAME TYPE FORTH-DATE TYPE ;
 */
FCode (p4_dot_date)
{
    p4_outf ("PFE compiled %s, %s ",
	p4_compile_date (), p4_compile_time ());
}


/* _______________________________________________________________________ */
/* parse and place at HERE */

/** STRING,               ( str len -- )
    Store a string in data space as a counted string.
 : STRING, HERE  OVER 1+  ALLOT  PLACE ;
 */
FCode (p4_string_comma)
{
    p4_string_comma ((char*) SP[1], SP[0]);
    FX_2DROP;
}

 
/** PARSE,                    ( "chars<">" -- )
    Store a char-delimited string in data space as a counted
    string. As seen in Bawd's
 : ," [CHAR] " PARSE  STRING, ; IMMEDIATE
  
   this implementation is much different from Bawd's
 : PARSE, PARSE STRING, ;
 */
FCode (p4_parse_comma)
{
    p4_word_parse (FX_POP); *DP=0; /* PARSE-NOHERE */
    p4_string_comma (PFE.word.ptr, PFE.word.len);
}


/** "PARSE,\""  ( "chars<">" -- )
    Store a quote-delimited string in data space as a counted
    string.
 : ," [CHAR] " PARSE  STRING, ; IMMEDIATE
  
   implemented here as
 : PARSE," [CHAR] " PARSE, ; IMMEDIATE
 */
FCode (p4_parse_comma_quote)
{
    p4_word_parse ('"'); *DP=0; /* PARSE-NOHERE */
    p4_string_comma (PFE.word.ptr, PFE.word.len);
}



P4_LISTWORDS (core_misc) =
{
    P4_INTO ("FORTH", 0),
    
    /** quick constants - implemented as code */
    P4_OCoN ("0",		0),
    P4_OCoN ("1",		1),
    P4_OCoN ("2",		2),
    P4_OCoN ("3",		3),

    /* more comparision */
    P4_FXco ("0<=",		p4_zero_less_equal),
    P4_FXco ("0>=",		p4_zero_greater_equal),
    P4_FXco ("<=",		p4_less_equal),
    P4_FXco (">=",		p4_greater_equal),
    P4_FXco ("U<=",		p4_u_less_equal),
    P4_FXco ("U>=",		p4_u_greater_equal),
    P4_FXco ("UMIN",		p4_u_min),
    P4_FXco ("UMAX",		p4_u_max),

    /* forth distributor info */
    P4_FXco (".VERSION",	p4_dot_version),
    P4_FXco (".CVERSION",	p4_dot_date),
    P4_FNYM (".PFE-DATE",	".CVERSION"),
    P4_FXco ("LICENSE",		p4_license),
    P4_FXco ("WARRANTY",	p4_warranty),

    /* parse and place HERE */
    P4_FXco ("STRING,",      p4_string_comma),
    P4_FXco ("PARSE,",       p4_parse_comma),
    P4_IXco ("PARSE,\"",     p4_parse_comma_quote),

    /* definition checks */
    P4_ICoN ("[VOID]",       0),
    P4_FXco ("DEFINED",      p4_defined),
    P4_IXco ("[DEFINED]",    p4_defined),
    P4_IXco ("[UNDEFINED]",  p4_undefined),
}
;
P4_COUNTWORDS (core_misc, "CORE-Misc Compatibility words");

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