/** 
 *  -- The No-FP-Stack Floating-Point Word Set
 * 
 *  Copyright (C) Krishna Myneni and Guido Draheim, 2002
 *
 *  @see     GNU LGPL
 *  @author  Krishna Myneni        @(#) %derived_by: guidod %
 *  @version %version: 32.12 %
 *    (%date_modified: Wed Oct 16 14:54:57 2002 %)
 *
 *  @description
 *         The No-FP-Stack Floating-Point Wordset is not usually
 *         used on embedded platforms. This Module implements
 *         the floating-point words but expects and puts the
 *         floating-point values on the forth parameter-stack.
 */
/*@{*/

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

#define _P4_SOURCE 1
#define _GNU_SOURCE 1            /* glibc's pow10 */

#if !defined P4_NO_FP

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

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <float.h>
#include <math.h>

#include <pfe/option-ext.h>
#include <pfe/def-comp.h>
#include <pfe/double-sub.h>
#include <pfe/logging.h>
#include <pfe/_missing.h>

#define CELLBITS	BITSOF (p4cell)
#define FSPINC  SP++; SP++
#define FSPDEC  SP--; SP--
#define FSP  ((double*) SP)

/* -----------------------------------------------------------------
 * Exact comparison of raw floats.  The following is intended to
 * capture the sizes listed for IEEE 754 by William Kahan,
 * "Fclass: a Proposed Classification of Standard Floating-Point
 * Operands", March 2, 2002.  He lists 4, >=6, 8, 10, 12, or 16
 * 8-bit bytes.  We assume that 4, 8, 10, 12, or 16 might
 * correspond to a double, and probably 4 could be omitted.  
 * --KM&DNW 2Mar03
 */

#if PFE_SIZEOF_DOUBLE == PFE_SIZEOF_INT
  #define EXACTLY_EQUAL(A,B)  ( *((int*) &(A)) == *((int*) &(B)) )
#elif PFE_SIZEOF_DOUBLE == 2 * PFE_SIZEOF_INT
  #define EXACTLY_EQUAL(A,B) \
        ( *((int*) &(A)) == *((int*) &(B)) \
       && *(((int*) &(A)) + 1) == *(((int*) &(B)) + 1) )
#elif PFE_SIZEOF_DOUBLE == 2 * PFE_SIZEOF_INT + PFE_SIZEOF_SHORT
  #define EXACTLY_EQUAL(A,B) \
        ( *((int*) &(A)) == *((int*) &(B)) \
       && *(((int*) &(A)) + 1) == *(((int*) &(B)) + 1) \
       && (short)*(((int*) &(A)) + 2) == (short)*(((int*) &(B)) + 2) )
#elif PFE_SIZEOF_DOUBLE == 3 * PFE_SIZEOF_INT
  #define EXACTLY_EQUAL(A,B) \
        ( *((int*) &(A)) == *((int*) &(B)) \
       && *(((int*) &(A)) + 1) == *(((int*) &(B)) + 1) \
       && *(((int*) &(A)) + 2) == *(((int*) &(B)) + 2) )
#elif PFE_SIZEOF_DOUBLE == 4 * PFE_SIZEOF_INT
  #define EXACTLY_EQUAL(A,B) \
        ( *((int*) &(A)) == *((int*) &(B)) \
       && *(((int*) &(A)) + 1) == *(((int*) &(B)) + 1) \
       && *(((int*) &(A)) + 2) == *(((int*) &(B)) + 2) \
       && *(((int*) &(A)) + 3) == *(((int*) &(B)) + 3) )
#else
  #error using memcmp() in p4_f_proximate()
  #define EXACTLY_EQUAL(A,B)  (memcmp (&(A), &(B), sizeof (double)) == 0)
#endif

/* ------------------------------------------------------------------ 
 * static helper routines for missing functionality.
 */

#if !defined PFE_HAVE_ACOSH

/*
 * Simple acosh(), asinh(), atanh() for those unfortunates who don't
 * have them. These are oversimplified routines (no error or boundry
 * checking). !!! DONT TRUST THESE ROUTINES !!!
 */

#include <math.h>

static double acosh (double n) 
{ 
    return log (n + sqrt (n * n - 1)); 
}

static double asinh (double n) 
{ 
    return (n < 0 ? -1.0 : 1.0) 
	* log (fabs (n) + sqrt (n * n + 1)); 
}

static double atanh (double n) 
{ 
    return log (1.0 + ((2.0 * n) / (1.0 - n))) * 0.5; 
}

#endif

#if !defined HAVE_POW10 && !defined PFE_HAVE_POW10
#define pow10(X) pow(10.0,(X))
#endif

/* ------------------------------------------------------------------ */

/**
 * return double float-aligned address
 */
_export p4cell
p4_nofp_dfaligned (p4cell n)	
{
    while (!P4_DFALIGNED (n))
        n++;
    return n;
}

/**
 *  used in engine
 */
_export int
p4_nofp_to_float (char *p, p4cell n, double *r)
{
# if defined USE_STRTOD		/* most systems have good strtod */

    char buf[80], *q;
  
    if (!*p) return 0; 
    /* strtod does crash on vxworks being empty non-null *gud*/

    p4_store_c_string (p, n, buf, sizeof buf);
    if (tolower (buf[n - 1]) == 'e')
        buf[n++] = '0';
    buf[n] = '\0';
    *r = strtod (buf, &q);
    if (q == NULL)
        return 1;
    while (isspace (*q))
        q++;
    return *q == '\0';

# else				/* but some haven't */

    enum state 			/* states of the state machine */
    {
        bpn,			/* before point, maybe sign */
        bp,			/* before point, no more sign (had one) */
        ap,			/* after point */
        exn,			/* exponent, maybe sign */
        ex,			/* exponent, no more sign, yet no digit */
        exd			/* exponent, no more sign, had one digit */
    };
    enum state state = bpn;
    int sign = 1;		/* sign of mantissa */
    long double mant = 0;	/* the mantissa */
    int esign = 1;		/* sign of exponent */
    int exp = 0;		/* the exponent */
    int bdigs = 0;		/* digits before point */
    int scale = 0;		/* number of digits after point */
    
    while (--n >= 0)
    {
        p4char c = *p++;

        switch (state)
	{
         case bpn:
             switch (c)
             {
              case '-':
                  sign = -1;
              case '+':
                  state = bp;
                  continue;
              case '.':
                  state = ap;
                  continue;
              default:
                  if (isspace (c))
                      continue;
                  if (isdigit (c))
                  {
                      bdigs = 1;
                      mant = c - '0';
                      state = bp;
                      continue;
                  }
             }
             return 0;
         case bp:
             switch (c)
             {
              case '.':
                  state = ap;
                  continue;
#            if 0
              case '-':
                  esign = -1;
              case '+':
                  state = ex;
                  continue;
#            endif
              case 'e':
              case 'E':
                  state = exn;
                  continue;
              default:
                  if (isdigit (c))
                  {
                      bdigs++;
                      mant *= 10;
                      mant += c - '0';
                      continue;
                  }
             }
             return 0;
         case ap:
             switch (c)
             {
              case '-':
                  esign = -1;
              case '+':
                  state = ex;
                  continue;
              case 'e':
              case 'E':
                  state = exn;
                  continue;
              default:
                  if (isdigit (c))
                  {
                      mant *= 10;
                      mant += c - '0';
                      scale--;
                      continue;
                  }
             }
             return 0;
         case exn:
             state = ex;
             switch (c)
             {
              case '-':
                  esign = -1;
              case '+':
                  continue;
              default: ;
             }
         case ex:
             if (isdigit (c))
             {
                 exp = c - '0';
                 state = exd;
                 continue;
             }
             return 0;
         case exd:
             if (isdigit (c))
             {
                 exp *= 10;
                 exp += c - '0';
                 continue;
             }
             return 0;
	}
    }
    *r = sign * mant * pow10 (scale + esign * exp);
    return bdigs - scale > 0;

# endif
}

/**
 */

FCode (p4_nofp_d_f_align);

#if defined USE_SSCANF		/* define this if you fully trust your scanf */

/*
 * This is a working solution on most machines.
 * Unfortunately it relies on pretty obscure features of sscanf()
 * which are not truly implemented everywhere.
 */
FCode (p4_nofp_to_float)		
{
    char *p, buf[80];
    static char *fmt[] =
    {
        "%lf%n %n%d%n$",
        "%lf%*1[DdEe]%n %n%d%n$",
    };
    int i, n, exp, n1, n2, n3;
    double r;
    
    p = (char *) SP[1];
    n = p4_dash_trailing (p, *SP);
    if (n == 0)
    {
        *FSP = 0.;
	--SP; *SP = P4_TRUE;
        return;
    }
    p4_store_c_string (p, n, buf, sizeof buf);
    strcat (buf, "$");
# if defined SYS_EMX
    /* emx' sscanf(), %lf conversion, doesn't read past 0E accepting the
     * "0" as good number when no exponent follows.  Therefore we change
     * the 'E' to 'D', ugly hack but helps. */
    p4_upper (buf, n);
    if (strchr (buf, 'E'))
        *strchr (buf, 'E') = 'D';
# endif
    if (1 == sscanf (buf, "%lf%n$", &r, &n1) 
      && n == n1)
    {
	*FSP = r;
	--SP; *SP = P4_TRUE;
        return;
    }
    for (i = 0; i < DIM (fmt); i++)
    {
        switch (sscanf (buf, fmt[i], &r, &n1, &n2, &exp, &n3))
        {
         case 1:
             if (n < n2)
                 break;

	     *FSP = r;
	     --SP; *SP = P4_TRUE;
             return;
         case 2:
             if (n1 != n2 || n < n3)
                 break;

	     *FSP = r * pow10 (exp);
	     --SP; *SP = P4_TRUE;
             return;
        }
    }
    *FSP = 0; --SP; *SP = P4_FALSE;
}

#else

FCode (p4_nofp_to_float)	
/*
 * This is an implementation based on a simple state machine.
 * Uses nothing but simple character manipulation and floating point math.
 */
{
    enum state			/* states of the state machine */
    {
        bpn,			/* before point, maybe sign */
        bp,			/* before point, no more sign (had one) */
        ap,			/* after point */
        exn,			/* exponent, maybe sign */
        ex,			/* exponent, no more sign */
        ts			/* trailing space */
    };
    enum state state = bpn;
    int sign = 1;		/* sign of mantissa */
    long double mant = 0;	/* the mantissa */
    int esign = 1;		/* sign of exponent */
    int exp = 0;		/* the exponent */
    int scale = 0;		/* number of digits after point */
    int n = *SP;		/* string length */
    char *p = (char *) *(SP+1);	/* points to string */

    while (--n >= 0)
    {
        p4char c = *p++;

        switch (state)
	{
         case bpn:
             switch (c)
             {
              case '-':
                  sign = -1;
              case '+':
                  state = bp;
                  continue;
              case '.':
                  state = ap;
                  continue;
              default:
                  if (isspace (c))
                      continue;
                  if (isdigit (c))
                  {
                      mant = c - '0';
                      state = bp;
                      continue;
                  }
             }
             goto bad;
         case bp:
             switch (c)
             {
              case '.':
                  state = ap;
                  continue;
              case '-':
                  esign = -1;
              case '+':
                  state = ex;
                  continue;
              case 'D':
              case 'd':
              case 'E':
              case 'e':
                  state = exn;
                  continue;
              default:
                  if (isspace (c))
                  {
                      state = ts;
                      continue;
                  }
                  if (isdigit (c))
                  {
                      mant *= 10;
                      mant += c - '0';
                      continue;
                  }
             }
             goto bad;
         case ap:
             switch (c)
             {
              case '-':
                  esign = -1;
              case '+':
                  state = ex;
                  continue;
              case 'D':
              case 'd':
              case 'E':
              case 'e':
                  state = exn;
                  continue;
              default:
                  if (isspace (c))
                  {
                      state = ts;
                      continue;
                  }
                  if (isdigit (c))
                  {
                      mant *= 10;
                      mant += c - '0';
                      scale--;
                      continue;
                  }
             }
             goto bad;
         case exn:
             switch (c)
             {
              case '-':
                  esign = -1;
              case '+':
                  state = ex;
                  continue;
              default:
                  if (isspace (c))
                  {
                      state = ts;
                      continue;
                  }
                  if (isdigit (c))
                  {
                      exp = c - '0';
                      state = ex;
                      continue;
                  }
             }
             goto bad;
         case ex:
             if (isspace (c))
             {
                 state = ts;
                 continue;
             }
             if (isdigit (c))
             {
                 exp *= 10;
                 exp += c - '0';
                 continue;
             }
             goto bad;
         case ts:
             if (isspace (c))
                 continue;
             goto bad;
	}
    }

    *FSP = sign * mant * pow10 (scale + esign * exp);
    --SP; *SP = P4_TRUE;
    return;
 bad:
    *FSP = 0.; --SP; *SP = P4_FALSE;
    return;
}

#endif

FCode (p4_nofp_d_to_f)
{
    int sign;
    double res;
    
    if (SP[0] < 0)
        sign = 1, dnegate ((p4dcell *) &SP[0]);
    else
        sign = 0;
#if Linux /*FIXME:*/
    /* slackware 2.2.0.1 (at least) has a bug in ldexp()  */
    res = (p4ucell) SP[0] * ((double)(1<<31) * 2) + (p4ucell) SP[1];
#else
    res = ldexp ((p4ucell) SP[0], CELLBITS) + (p4ucell) SP[1];
#endif

    *FSP = sign ? -res : res;
}

FCode (p4_nofp_f_store)
{
    *((double *) *SP) = *((double*) (SP+1));
    SP++;
    FSPINC;
}

FCode (p4_nofp_f_star)
{
    FSP[1] *= FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_plus)
{
    FSP[1] += FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_minus)
{
    FSP[1] -= FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_slash)
{
    FSP[1] /= FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_zero_less)
{
    *(SP+1) = P4_FLAG (*FSP < 0);
    SP++;
}

FCode (p4_nofp_f_zero_equal)
{
    *(SP+1) = P4_FLAG (*FSP == 0); 
    SP++;
}

FCode (p4_nofp_f_equal)
{
    int flag;
    flag = P4_FLAG (FSP[1] == FSP[0]);
    FSPINC;
    *++SP = flag;
}

FCode (p4_nofp_f_not_equal)
{
    int flag;
    flag = P4_FLAG (FSP[1] != FSP[0]);
    FSPINC;
    *++SP = flag;
}

FCode (p4_nofp_f_less_than)
{
    int flag;
    flag = P4_FLAG (FSP[1] < FSP[0]);
    FSPINC; 
    *++SP = flag;
}

FCode (p4_nofp_f_greater_than)
{
    int flag;
    flag = P4_FLAG (FSP[1] > FSP[0]);
    FSPINC; 
    *++SP = flag;
}

FCode (p4_nofp_f_less_than_or_equal)
{
    int flag;
    flag = P4_FLAG (FSP[1] <= FSP[0]);
    FSPINC; 
    *++SP = flag;
}

FCode (p4_nofp_f_greater_than_or_equal)
{
    int flag;
    flag = P4_FLAG (FSP[1] >= FSP[0]);
    FSPINC; 
    *++SP = flag;
}

FCode (p4_nofp_f_to_d)
{
    double a, hi, lo;
    int sign;
    
    if ((a = *FSP) < 0)
        sign = 1, a = -a;
    else
        sign = 0;
    lo = modf (ldexp (a, -CELLBITS), &hi);
    SP[0] = (p4ucell) hi;
    SP[1] = (p4ucell) ldexp (lo, CELLBITS);
    if (sign)
        dnegate ((p4dcell *) &SP[0]);
}

/* some words Julian Noble found useful, plus a few more */

/** S>F  ( n -- x )
 */
FCode (p4_nofp_s_to_f)
{
    p4cell n = *SP--;
    *FSP = (double) n;  
}

/** FTRUNC>S  ( x -- n )
 */
FCode (p4_nofp_f_trunc_to_s)
{
    double h = *FSP++;
    *--SP = (p4cell) h;
}

/** FROUND>S ( x -- n )
 */
FCode (p4_nofp_f_round_to_s)
{
    extern FCode (p4_nofp_f_round); /* defined later */
    FX (p4_nofp_f_round);
    FX (p4_nofp_f_trunc_to_s);
}

/** FTRUNC ( x -- x' )
 */
FCode (p4_nofp_f_trunc)
{
#  if __STDC_VERSION__+0 > 199900
    *FSP = trunc (*FSP);
#  else
    if (*FSP > 0)
	*FSP = floor (*FSP);
    else
	*FSP = ceil (*FSP);
#  endif
}

/** -FROT  ( x1 x2 x3 -- x3 x1 x2 )
 */
FCode (p4_nofp_minus_f_rot)
{
    double h = FSP[0];

    FSP[0] = FSP[1];
    FSP[1] = FSP[2];
    FSP[2] = h;
}

/** FNIP  ( x1 x2 -- x2 )
 */
FCode (p4_nofp_f_nip)
{
   FSP[1] = FSP[0];
   FSPINC;
}

/** FTUCK  ( x1 x2 -- x2 x1 x2 )
 */
FCode (p4_nofp_f_tuck)
{
    FSPDEC;
    FSP[0] = FSP[1];
    FSP[1] = FSP[2];
    FSP[2] = FSP[0];
}

/** 1/F  ( x -- 1/x )
 */
FCode (p4_nofp_one_over_f)
{
    *FSP = 1.0 / *FSP; 
}

/** F^2  ( x -- x^2 )
 */
FCode (p4_nofp_f_square)
{
    *FSP = *FSP * *FSP; 
}

/** F^N  ( x u -- x^u )
 * For large exponents, use F** instead.  Of course u=-1 is large. 
 */
FCode (p4_nofp_f_power_n)
{
    p4ucell n = *SP++;
    double x = *FSP;

    if ( n == 1 ) return;
 
    {   double r = 1.0;
 
        if ( n )
        {
            double xsq = x * x;

            if ( n & 1 ) r = x;
            for ( n = n/2; n > 0; n-- ) r = r * xsq;
        }
        *FSP = r;
    }
}

/** F2/  ( x -- x/2 )
 */
FCode (p4_nofp_f_two_slash)
{
    *FSP = ldexp (*FSP, -1); 
}

/** F2*  ( x -- x*2 )
 */
FCode (p4_nofp_f_two_star)
{
    *FSP = ldexp (*FSP, 1); 
}

/** F0>  ( x -- flag )
*/

FCode (p4_nofp_f_zero_greater)
{
    int flag;
    flag = P4_FLAG (*FSP > 0.);
    *++SP = flag;
}

/** F0<>  ( x -- flag )
*/
FCode (p4_nofp_f_zero_not_equal)
{
    int flag;
    flag = P4_FLAG (*FSP != 0.);
    *++SP = flag;
}

/* ------ */

FCode (p4_nofp_f_fetch)
{
    *((double*) (SP-1)) = *((double*) *SP); SP--;
}

FCode_RT (p4_nofp_f_constant_RT)
{
    FX_USE_BODY_ADDR;
    FSPDEC;
    *FSP = *(double *) p4_nofp_dfaligned ((p4cell) FX_POP_BODY_ADDR);
}

FCode (p4_nofp_f_constant)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_nofp_f_constant);
    FX (p4_nofp_d_f_align);
    FX_FCOMMA (*FSP);
    FSPINC;
}

P4RUNTIME1(p4_nofp_f_constant, p4_nofp_f_constant_RT);

FCode (p4_nofp_f_depth)
{
    *--SP = (p4_S0 - SP)/2;
}

FCode (p4_nofp_f_drop)
{
    FSPINC;
}

FCode (p4_nofp_f_dup)
{
    FSPDEC;
    FSP[0] = FSP[1];
}

/* originally P4_SKIPS_FLOAT */
p4xt* 
p4_lit_nofp_float_SEE (p4xt* ip, char* p, p4_Semant* s)
{
# if PFE_ALIGNOF_DFLOAT > PFE_ALIGNOF_CELL
    if (!P4_DFALIGNED (ip))
        ip++;
# endif
    sprintf (p, "%e ", *(double *) ip);
    P4_INC (ip, double);
    
    return ip;
}

FCode_XE (p4_nofp_f_literal_execution)
{
    FX_USE_CODE_ADDR;
    FSPDEC;
    *FSP= P4_POP_ (double, IP);
    FX_USE_CODE_EXIT;
}

FCode (p4_nofp_f_literal)
{
    _FX_STATESMART_Q_COMP;
    if (STATESMART)
    {
#if PFE_ALIGNOF_DFLOAT > PFE_ALIGNOF_CELL
        if (P4_DFALIGNED (DP))
            FX_COMPILE2 (p4_nofp_f_literal);
#endif
        FX_COMPILE1 (p4_nofp_f_literal);
        FX_FCOMMA (*FSP);
	FSPINC;
    }
}

P4COMPILES2 (p4_nofp_f_literal, p4_nofp_f_literal_execution, p4_noop,
	     p4_lit_nofp_float_SEE, P4_DEFAULT_STYLE);

FCode (p4_nofp_floor)
{
  *FSP = floor (*FSP);
}

FCode (p4_nofp_f_max)
{
    if (FSP[0] > FSP[1])
        FSP[1] = FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_min)
{
    if (FSP[0] < FSP[1])
        FSP[1] = FSP[0];
    FSPINC;
}

FCode (p4_nofp_f_negate)
{
    *FSP = -*FSP;
}

FCode (p4_nofp_f_over)
{
    FSPDEC;
    FSP[0] = FSP[2];
}

FCode (p4_nofp_f_rot)
{
    double h = FSP[2];
    
    FSP[2] = FSP[1];
    FSP[1] = FSP[0];
    FSP[0] = h;
}

#ifndef FROUND_FLOOR                /* same user.config as in floating-ext! */
#define FROUND_FLOOR 0              /* FROUND identical with floor(fp+0.5) ? */
#endif

FCode (p4_nofp_f_round)
{
#  if defined HAVE_RINT || defined PFE_HAVE_RINT
    /* correct and fast */
    *FSP = rint (*FSP);
#  elif FROUND_FLOOR
    /* incorrect but fast */
    *FSP = floor (*FSP + 0.5); 
#  else
    /* correct but slow */
    double whole, frac, offset;
 
    frac = fabs(modf(*FSP, &whole));
    *FSP = whole;
    FX(p4_nofp_f_to_d);  /* execute F>D */
    offset = (*SP < 0) ? -1. : 1.;
    
    if (*(SP+1) & 1)  /* check even or odd */
    {
	if (frac >= 0.5) whole += offset;
    }
    else
    {
	if (frac > 0.5) whole += offset;
    }
    *FSP = whole;
#  endif  
}

FCode (p4_nofp_f_swap)
{
    double h = FSP[1];
    
    FSP[1] = FSP[0];
    FSP[0] = h;
}

FCode_RT (p4_nofp_f_variable_RT)
{
    FX_USE_BODY_ADDR;
    FX_PUSH_SP = p4_nofp_dfaligned ((p4cell) FX_POP_BODY_ADDR);
}

FCode (p4_nofp_f_variable)
{
    FX_RUNTIME_HEADER;
    FX_RUNTIME1 (p4_nofp_f_variable);
    FX (p4_nofp_d_f_align);
    FX_FCOMMA (0.);
}

P4RUNTIME1(p4_nofp_f_variable, p4_nofp_f_variable_RT); 

FCode (p4_nofp_represent)		/* with help from Lennart Benshop */
{
    char *p, buf[0x80];
    int u, log, sign;
    double f;
    
    f = FSP[1];
    p = (char *) SP[1];
    u = SP[0];
    SP++;
    
    if (f < 0)
        sign = P4_TRUE, f = -f;
    else
        sign = P4_FALSE;
    if (f != 0)
    {
        log = (int) floor (log10 (f)) + 1;
        f *= pow10 (-log);
        if (f + 0.5 * pow10 (-u) >= 1)
            f /= 10, log++;
    }
    else
        log = 0;
    sprintf (buf, "%0.*f", u, f);
    memcpy (p, buf + 2, u);
    
    SP[2] = log;
    SP[1] = sign;
    SP[0] = P4_TRUE;
}

/* ********************************************************************** */
/* Floating point extension words:                                        */
/* ********************************************************************** */

FCode (p4_nofp_d_f_align)
{
    while (!P4_DFALIGNED (DP))
        *DP++ = 0;
}

FCode (p4_nofp_d_f_aligned)
{
    SP[0] = p4_nofp_dfaligned (SP[0]);
}

FCode (p4_nofp_d_float_plus)
{
    *SP += sizeof (double);
}

FCode (p4_nofp_d_floats)
{
    *SP *= sizeof (double);
}

FCode (p4_nofp_f_star_star)
{
    FSP[1] = pow (FSP[1], FSP[0]);
    FSPINC;
}

FCode (p4_nofp_f_dot)
{
    p4_outf ("%.*f ", PRECISION, *FSP);
    FSPINC;
}

FCode (p4_nofp_f_abs)
{
    *FSP = fabs(*FSP);
}

FCode (p4_nofp_f_e_dot)			/* with help from Lennart Benshop */
{
    double f = fabs (*FSP);
    double h = 0.5 * pow10 (-PRECISION);
    int n;

    if (f == 0)
        n = 0;
    else if (f < 1)
    {
        h = 1 - h;
        for (n = 3; f * pow10 (n) < h; n += 3);
    }else{
        h = 1000 - h;
        for (n = 0; h <= f * pow10 (n); n -= 3);
    }
    p4_outf ("%+*.*fE%+03d ", PRECISION + 5, PRECISION,
      *FSP * pow10 (n), -n);
    FSPINC;
}

FCode (p4_nofp_f_s_dot)
{
    p4_outf ("%.*E ", PRECISION, *FSP); FSPINC;
}

FCode (p4_nofp_f_proximate)
{
    double a, b, c;

    a = FSP[2];
    b = FSP[1];
    c = FSP[0];
    FSPINC; FSPINC; SP++;
    *SP = P4_FLAG
        (c > 0 
          ? fabs (a - b) < c 
          : c < 0 
          ? fabs (a - b) < -c * (fabs (a) + fabs (b))
          : EXACTLY_EQUAL (a, b));
}

FCode (p4_nofp_set_precision)
{
    PRECISION = *SP++;
}

FCode (p4_nofp_s_f_store)
{
    *(float *) *SP = *((double*) (SP+1));
    SP += 3;
}

FCode (p4_nofp_s_f_fetch)
{
    *((double*)(SP-1)) = *(float *) *SP;
    --SP;
}

FCode (p4_nofp_s_float_plus)
{
    *SP += sizeof (float);
}

FCode (p4_nofp_s_floats)
{
    *SP *= sizeof (float);
}

/*-- simple mappings to the ANSI-C library  --*/

FCode (p4_nofp_f_acos)	{ *FSP = acos (*FSP); }

FCode (p4_nofp_f_acosh)	{ *FSP = acosh (*FSP); }

FCode (p4_nofp_f_alog)	{ *FSP = pow10 (*FSP); }

FCode (p4_nofp_f_asin)	{ *FSP = asin (*FSP); }

FCode (p4_nofp_f_asinh)	{ *FSP = asinh (*FSP); }

FCode (p4_nofp_f_atan)	{ *FSP = atan (*FSP); }

FCode (p4_nofp_f_atan2)	{ FSP [1] = atan2 (FSP [1], FSP [0]); FSPINC; }

FCode (p4_nofp_f_atanh)	{ *FSP = atanh (*FSP); }

FCode (p4_nofp_f_cos)	{ *FSP = cos (*FSP); }

FCode (p4_nofp_f_cosh)	{ *FSP = cosh (*FSP); }

FCode (p4_nofp_f_exp)	{ *FSP = exp (*FSP); }

#if 1  /* ante C99 */

FCode (p4_nofp_f_expm1)	{ *FSP = exp (*FSP) - 1.0; }

#else  /* post C99 */

FCode (p4_nofp_f_expm1)	{ *FSP = expm1 (*FSP); }

#endif

FCode (p4_nofp_f_ln)	{ *FSP = log (*FSP); }

#if 1  /* ante C99 */

FCode (p4_nofp_f_lnp1)	{ *FSP = log (*FSP + 1.0); }

#else  /* post C99 */

FCode (p4_nofp_f_lnp1)	{ *FSP = log1p (*FSP); }

#endif

FCode (p4_nofp_f_log)	{ *FSP = log10 (*FSP); }

FCode (p4_nofp_f_sin)	{ *FSP = sin (*FSP); }

FCode (p4_nofp_f_sincos){ FSPDEC; FSP[0]=cos(FSP[1]); FSP[1]=sin(FSP[1]);}

FCode (p4_nofp_f_sinh)	{ *FSP = sinh (*FSP); }

FCode (p4_nofp_f_sqrt)	{ *FSP = sqrt (*FSP); }

FCode (p4_nofp_f_tan)	{ *FSP = tan (*FSP); }

FCode (p4_nofp_f_tanh)	{ *FSP = tanh (*FSP); }

/* environment queries */

static FCode (p__nofp_max_float)
{
    FSPDEC;
    *FSP = DBL_MAX;
}

/* words not from the ansi'94 forth standard  */

/* ================= INTERPRET =================== */

#ifndef DOUBLE_ALIGNED
#if defined HOST_ARCH_SPARC     || defined __target_arch_sparc
#define DOUBLE_ALIGNED 1
#elif defined HOST_ARCH_HPPA    || defined __target_arch_hppa
#define DOUBLE_ALIGNED 1
#elif defined HOST_ARCH_POWERPC || defined __target_arch_powerpc 
#define DOUBLE_ALIGNED 1
#else
#define DOUBLE_ALIGNED 0
#endif
#endif

static p4ucell FXCode (interpret_float) /*hereclean*/
{
    /* scanned word sits at PFE.word. (not at HERE) */
# ifndef P4_NO_FP
    if (! BASE == 10 || ! FLOAT_INPUT) return 0; /* quick path */

    {
	double f;
	/* WORD-string is at HERE */
	if (! p4_nofp_to_float (PFE.word.ptr, PFE.word.len, &f)) 
	    return 0; /* quick path */
	
	if (STATE)
	{
#          if PFE_ALIGNOF_DFLOAT > PFE_ALIGNOF_CELL
	    if (P4_DFALIGNED (DP))
		FX_COMPILE2 (p4_nofp_f_literal);
#          endif
	    FX_COMPILE1 (p4_nofp_f_literal);
	    FX_FCOMMA (f);
	}else{
	    FSPDEC;
#          if DOUBLE_ALIGNED
            if (((long)(void*)SP)&7) { SP--; P4_fail("auto dfaligned SP"); }
#          endif
	    *FSP = f;
	}
	return 1;
    }
#  else
	return 0;
#  endif
}

static int decompile_floating (char* nfa, p4xt xt)
{
    if (*P4_TO_CODE(xt) == PFX (p4_nofp_f_constant_RT))          
    {
        p4_outf ("%g FCONSTANT ( fpnostack )", 
          *(double *) p4_nofp_dfaligned ((p4cell) P4_TO_BODY (xt)));
        p4_dot_name (nfa);
        return 1;
    }
    else if (*P4_TO_CODE(xt) == PFX (p4_nofp_f_variable_RT))
    {
        p4_outf ("%g FVARIABLE ( fpnostack )", 
          *(double *) p4_nofp_dfaligned ((p4cell) P4_TO_BODY (xt)));
        p4_dot_name (nfa);
        return 1;
    } 
    return 0;
}

/*
 * slot 1 == p4_interpret_smart
 * slot 2 == p4_interpret_floating
 */

#ifndef FPNOSTACK_INTERPRET_SLOT       /* USER-CONFIG: */
#define FPNOSTACK_INTERPRET_SLOT 2     /* 1 == smart-ext / 2 == floating-ext */
#endif

static FCode_RT(fpnostack_deinit)
{
    FX_USE_BODY_ADDR; 
    FX_POP_BODY_ADDR_UNUSED;
    PFE.decompile[FPNOSTACK_INTERPRET_SLOT] = 0;
    PFE.interpret[FPNOSTACK_INTERPRET_SLOT] = 0;
}

static FCode(fpnostack_init)
{
    PFE.interpret[FPNOSTACK_INTERPRET_SLOT] = PFX (interpret_float);
    PFE.decompile[FPNOSTACK_INTERPRET_SLOT] = decompile_floating;
    p4_forget_word ("deinit:fpnostack:%i", FPNOSTACK_INTERPRET_SLOT, 
		    PFX(fpnostack_deinit), FPNOSTACK_INTERPRET_SLOT);
}

P4_LISTWORDS (fpnostack) =
{
     (, ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,               ),
     (,               ),
     (,              ),
     (,              ),
     (,              ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,	 ),
     (,	 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,	 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,	 ),
     (,	 ),
    /* floating point extension words */
     (,		 ),
     (,		 ),
     (,		 ),
     (,	 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,	 ),
     (,	 ),
     (,		 ),
     (,		 ),
     (,		 ), /* alias cell-aligned */
     (,	 ),
     (,		 ),
     (,		 ),

    /* more useful nonstandard words */
     (,		 ),
     (,	 ),
     (,	 ),
     (,              ),
     (,           ),

     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),
     (,		 ),

     (,  ),
     (,          ),
     (,	  ),
     (,	  ),
     (, ),
#  if ! DOUBLE_ALIGNED
     (,     ),
#  endif
};
P4_COUNTWORDS (fpnostack, "FpNoStack Floating point + extensions");

/* if !defined P4_NO_FP */

#endif 

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