/** 
   -- miscellaneous useful extra words for FLOATING-EXT
  
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE              @(#) %derived_by: guidod %
    @version %version:  %
      (%date_modified:  %)
  
    @description
        Compatiblity with former standards, miscellaneous useful words.
        ... for FLOATING-EXT
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:   % $";
#endif

#define _P4_SOURCE 1

#ifndef P4_NO_FP

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


/** FP@ ( -- addr )
   returns the floating point stack pointer 
 */
FCode (p4_f_p_fetch)		
{				
    *--SP = (p4cell) FP;
}


/** FP! ( addr -- )
   sets the floating point stack pointer -
   this is the inverse of => FP@
 */
FCode (p4_f_p_store)		
{		
    FP = (double *) *SP++;
}


FCode (p4_f_equal)
{
    *--SP = P4_FLAG (FP[1] == FP[0]);
    FP += 2;
}
 

FCode (p4_f_not_equal)
{
    *--SP = P4_FLAG (FP[1] != FP[0]);
    FP += 2;
}


/* FCode (p4_f_less_than) // already in [ANS] floating-ext
{
    *--SP = P4_FLAG (FP[1] < FP[0]);
    FP += 2; 
} */

FCode (p4_f_greater_than)
{
    *--SP = P4_FLAG (FP[1] > FP[0]);
    FP += 2; 
}


FCode (p4_f_less_than_or_equal)
{
    *--SP = P4_FLAG (FP[1] <= FP[0]);
    FP += 2;
}


FCode (p4_f_greater_than_or_equal)
{
    *--SP = P4_FLAG (FP[1] >= FP[0]);
    FP += 2;
}


P4_LISTWORDS (floating_misc) =
{
    P4_INTO ("FORTH", 0),

    P4_FXco ("FLIT",		 p4_f_literal_execution), 
    P4_DVaR ("F0",		 f0),
    P4_DVaR ("FLOAT-INPUT",	 float_input),
    P4_FXco ("FP@",		 p4_f_p_fetch),
    P4_FXco ("FP!",		 p4_f_p_store),

    P4_FXco ("F=",               p4_f_equal),
    P4_FXco ("F<>",              p4_f_not_equal),
    P4_FXco ("F>",               p4_f_greater_than),
    P4_FXco ("F<=",              p4_f_less_than_or_equal),
    P4_FXco ("F>=",              p4_f_greater_than_or_equal),
}
;
P4_COUNTWORDS (floating_misc, "FLOATING-Misc Compatibility words");

#endif /* _NO_FP */

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