/** 
 * -- 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) =
{
     (, ),
    
    /** quick constants - implemented as code */
     (,		),
     (,		),
     (,		),
     (,		),

    /* more comparision */
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),
     (,		),

    /* forth distributor info */
     (,	),
     (,	),
     (,	),
     (,		),
     (,	),

    /* parse and place HERE */
     (,      ),
     (,       ),
     (,     ),

    /* definition checks */
     (,       ),
     (,      ),
     (,    ),
     (,  ),
};
P4_COUNTWORDS (core_misc, "CORE-Misc Compatibility words");

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