/*  Pfe module:  hffloat-ext.c
  ^Forth input:  hffloat.hf
          Date:  26-Nov-2002 09:13:22
    Translator:  0.1.6 
*/

#define _P4_SOURCE 1

/* pfe register variables, etc. */
#include <pfe/def-config.h>

/* Compiler switches for extra registers are NO_EXTRA_REGS,
   HF_TOSREG, and HF_FTOSREG.*/

#if !defined NO_EXTRA_REGS
  #if defined __target_arch_ppc
    register int hf_index asm ("21");  /* top DO ... LOOP params */
    register int hf_limit asm ("22");
    #ifdef HF_TOSREG
      register int TOS asm ("23");
      register int hf_flag asm ("24");
    #endif  /* HF_TOSREG */
    #ifdef HF_FTOSREG
      register double FTOS asm ("f14");
    #endif  /* HF_FTOSREG */
  #elif defined __target_arch_i386
    static int hf_index; /* top DO ... LOOP params */
    static int hf_limit;
    #undef HF_TOSREG
    #ifdef HF_FTOSREG  /* THIS DOES NOT WORK! */
      register double FTOS asm ("%st(7)");
    #endif  /* HF_FTOSREG */
  #elif defined __target_cpu_hppa
    register int hf_index asm ("r11");  /* top DO ... LOOP params */
    register int hf_limit asm ("r10");
    #ifdef HF_TOSREG
      register int TOS asm ("r9");
      register int hf_flag asm ("r8");
    #endif  /* HF_TOSREG */
    #ifdef HF_FTOSREG
      register double FTOS asm ("fr21");
    #endif  /* HF_FTOSREG */
  #else
    #define NO_EXTRA_REGS 1
    #warning Unknown architecture, using no extra register variables.
  #endif
#endif  /* !defined NO_EXTRA_REGS */

#ifdef NO_EXTRA_REGS
  static int hf_index;  /* top DO ... LOOP params */
  static int hf_limit;
  #undef HF_TOSREG
  #undef HF_FTOSREG
#endif  /* NO_EXTRA_REGS */

#ifdef HF_TOSREG
  #define HF_FILL_TOS  TOS = *SP;  /* note ";" in these two */
  #define HF_SPILL_TOS *SP = TOS;
  #define HF_PUSH(A)  *SP-- = TOS; TOS = (A)
  #define HF_POP(A)   (A) = TOS; TOS = *++SP   
  #define HF_DROP1    TOS = *++SP
  #define HF_DROP2    SP += 2; TOS = *SP
  #define HF_IF       HF_POP(hf_flag); if (hf_flag)
  #define HF_NIF      HF_POP(hf_flag); if (!hf_flag)
  #define HF_UNTIL    HF_POP(hf_flag);}while (!hf_flag)
  #define HF_NUNTIL   HF_POP(hf_flag);}while (hf_flag)
#else
  #define TOS *SP
  #define HF_FILL_TOS
  #define HF_SPILL_TOS
  #define HF_PUSH(A)  *--SP = (A)
  #define HF_POP(A)   (A) = *SP++   
  #define HF_DROP1    SP += 1
  #define HF_DROP2    SP += 2
  #define HF_IF       if (*SP++)
  #define HF_NIF      if (!*SP++)
  #define HF_UNTIL    }while (!*SP++)
  #define HF_NUNTIL   }while (*SP++)
  #endif  /* HF_TOSREG */

#ifdef HF_FTOSREG
  #define HF_FILL_FTOS  FTOS = *FP;  /* note ";" in these two */
  #define HF_SPILL_FTOS *FP = FTOS;
  #define HF_FPUSH(A)  *FP-- = FTOS; FTOS = (A)
  #define HF_FPOP(A)   (A) = FTOS; FTOS = *++FP
  #define HF_FDROP1    FTOS = *++FP
  #define HF_FDROP2    FP += 2; FTOS = *FP
  #define HF_FDROP3    FP += 3; FTOS = *FP
#else
  #define FTOS *FP
  #define HF_FILL_FTOS
  #define HF_SPILL_FTOS
  #define HF_FPUSH(A)  *--FP = (A)
  #define HF_FPOP(A)   (A) = *FP++
  #define HF_FDROP1    FP += 1
  #define HF_FDROP2    FP += 2
  #define HF_FDROP3    FP += 3
#endif  /* HF_FTOSREG */

/* The basic pfe include. */
#include <pfe/pfe-base.h>

/* Extra includes. */
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <float.h>
#include <math.h>

#include <pfe/double-sub.h>

#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 !!!
 */

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 /* PFE_HAVE_ACOSH */

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

p4cell
hf_dfaligned (p4cell n)	
{
  while (!P4_DFALIGNED (n)) n++;
  return n;
}
FCode (p4_to_float);
FCode (p4_d_to_f);
FCode (hfi_f_store)
{ HF_FILL_TOS HF_FILL_FTOS 
  *(double *) TOS = FTOS; HF_DROP1; HF_FDROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_star)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = FTOS * FP[1]; FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_plus)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = FTOS + FP[1]; FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_minus)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = FP[1] - FTOS; FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_slash)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = FP[1] / FTOS; FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_zero_less)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS < 0)); HF_FDROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_zero_equal)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS == 0)); HF_FDROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_less_than)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS > FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (p4_f_to_d);
FCode (hfi_f_fetch)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_FPUSH (*(double *) TOS); HF_DROP1; 
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_depth)
{ HF_FILL_TOS HF_FILL_FTOS 
#ifdef HF_TOSREG
  *SP = TOS; TOS = p4_F0 - FP; SP--; 
#else 
  { p4cell diff = p4_F0 - FP;
    *--SP = diff; }
#endif
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_drop)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_FDROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_dup)
{ HF_FILL_TOS HF_FILL_FTOS 
#ifdef HF_FTOSREG
 *FP-- = FTOS;
#else
  FP--;  FP[0] = FP[1];
#endif
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_floor)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = floor (FTOS);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_max)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = (FTOS > FP[1]) ? FTOS : FP[1];
    FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_min)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = (FTOS < FP[1]) ? FTOS : FP[1];
    FP++; FTOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_negate)
{ HF_FILL_TOS HF_FILL_FTOS 
    FTOS = -FTOS;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_over)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_SPILL_FTOS --FP; FTOS = FP[2];
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_rot)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double h = FP[2]; FP[2] = FP[1];
    FP[1] = FTOS; FTOS = h; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (p4_f_round);
FCode (hfi_f_swap)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double h = FP[1]; FP[1] = FTOS; FTOS = h; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (p4_represent);
FCode (hfi_d_f_align)
{ HF_FILL_TOS HF_FILL_FTOS 
  while (!P4_DFALIGNED (DP)) *DP++ = 0;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_d_f_aligned)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = hf_dfaligned (FTOS);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_d_float_plus)
{ HF_FILL_TOS HF_FILL_FTOS 
  TOS += sizeof (double);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_d_floats)
{ HF_FILL_TOS HF_FILL_FTOS 
  TOS *= sizeof (double);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_floats)
{ HF_FILL_TOS HF_FILL_FTOS 
  TOS *= sizeof (double);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_star_star)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = pow (FP[1], FTOS); FP++; TOS = res; }
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (p4_f_dot);
FCode (hfi_f_abs)
{ HF_FILL_TOS HF_FILL_FTOS 
  if (FTOS < 0) FTOS = -FTOS;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (p4_f_e_dot);
FCode (p4_f_s_dot);
FCode (hf_f_proximate);
FCode (hfi_f_proximate)
{ HF_FILL_TOS HF_FILL_FTOS 
  hf_f_proximate_ ();
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hf_f_proximate)
{
double a, b, c;

  a = FP[2]; b = FP[1]; c = FTOS; HF_FDROP3;
  HF_PUSH (P4_FLAG(
      c > 0 
        ? fabs (a - b) < c 
        : c < 0
        ? fabs (a - b) < -c * (fabs (a) + fabs (b))
        : a == b));
}
FCode (hfi_precision)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (PRECISION);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_set_precision)
{ HF_FILL_TOS HF_FILL_FTOS 
  PRECISION = TOS; SP++;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_s_f_store)
{ HF_FILL_TOS HF_FILL_FTOS 
  *(float *) TOS = FTOS; HF_DROP1; HF_FDROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_s_f_fetch)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_FPUSH (*(float *) TOS); HF_DROP1; 
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_s_float_plus)
{ HF_FILL_TOS HF_FILL_FTOS 
  TOS += sizeof (float);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_s_floats)
{ HF_FILL_TOS HF_FILL_FTOS 
  TOS *= sizeof (float);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_acos)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = acos (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_acosh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = acosh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_alog)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = pow10 (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_asin)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = asin (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_asinh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = asinh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_atan)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = atan (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_atan2)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double res = atan2 (FP [1], FTOS); FP++; FTOS = res; }  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_atanh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = atanh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_cos)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = cos (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_cosh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = cosh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_exp)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = exp (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_expm1)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = exp (FTOS) - 1.0;  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_ln)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = log (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_lnp1)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = log (FTOS + 1.0);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_log)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = log10 (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_sin)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = sin (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_sincos)
{ HF_FILL_TOS HF_FILL_FTOS 
  { double x = FTOS; *FP-- = sin (x); FTOS = cos (x) ; }  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_sinh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = sinh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_sqrt)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = sqrt (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_tan)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = tan (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_tanh)
{ HF_FILL_TOS HF_FILL_FTOS 
  FTOS = tanh (FTOS);  HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_p_fetch)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH ((p4cell) FP);
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_p_store)
{ HF_FILL_TOS HF_FILL_FTOS 
  FP = (double *) TOS; HF_DROP1;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_equal)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS == FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_not_equal)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS != FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_greater_than)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS < FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_less_than_or_equal)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS >= FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }
FCode (hfi_f_greater_than_or_equal)
{ HF_FILL_TOS HF_FILL_FTOS 
  HF_PUSH (P4_FLAG (FTOS <= FP[1])); HF_FDROP2;
 HF_SPILL_TOS HF_SPILL_FTOS }

P4_LISTWORDS (hffloat) = 
{
 P4_FXco ("F!", hfi_f_store),
 P4_FXco ("F*", hfi_f_star),
 P4_FXco ("F+", hfi_f_plus),
 P4_FXco ("F-", hfi_f_minus),
 P4_FXco ("F/", hfi_f_slash),
 P4_FXco ("F0<", hfi_f_zero_less),
 P4_FXco ("F0=", hfi_f_zero_equal),
 P4_FXco ("F<", hfi_f_less_than),
 P4_FXco ("F@", hfi_f_fetch),
 P4_FXco ("FDEPTH", hfi_f_depth),
 P4_FXco ("FDROP", hfi_f_drop),
 P4_FXco ("FDUP", hfi_f_dup),
 P4_FXco ("FLOOR", hfi_floor),
 P4_FXco ("FMAX", hfi_f_max),
 P4_FXco ("FMIN", hfi_f_min),
 P4_FXco ("FNEGATE", hfi_f_negate),
 P4_FXco ("FOVER", hfi_f_over),
 P4_FXco ("FROT", hfi_f_rot),
 P4_FXco ("FSWAP", hfi_f_swap),
 P4_FXco ("DFALIGN", hfi_d_f_align),
 P4_FXco ("DFALIGNED", hfi_d_f_aligned),
 P4_FXco ("DFLOAT+", hfi_d_float_plus),
 P4_FXco ("DFLOATS", hfi_d_floats),
 P4_FXco ("FLOATS", hfi_floats),
 P4_FXco ("F**", hfi_f_star_star),
 P4_FXco ("FABS", hfi_f_abs),
 P4_FXco ("F~", hfi_f_proximate),
 P4_FXco ("PRECISION", hfi_precision),
 P4_FXco ("SET-PRECISION", hfi_set_precision),
 P4_FXco ("SF!", hfi_s_f_store),
 P4_FXco ("SF@", hfi_s_f_fetch),
 P4_FXco ("SFLOAT+", hfi_s_float_plus),
 P4_FXco ("SFLOATS", hfi_s_floats),
 P4_FXco ("FACOS", hfi_f_acos),
 P4_FXco ("FACOSH", hfi_f_acosh),
 P4_FXco ("FALOG", hfi_f_alog),
 P4_FXco ("FASIN", hfi_f_asin),
 P4_FXco ("FASINH", hfi_f_asinh),
 P4_FXco ("FATAN", hfi_f_atan),
 P4_FXco ("FATAN2", hfi_f_atan2),
 P4_FXco ("FATANH", hfi_f_atanh),
 P4_FXco ("FCOS", hfi_f_cos),
 P4_FXco ("FCOSH", hfi_f_cosh),
 P4_FXco ("FEXP", hfi_f_exp),
 P4_FXco ("FEXPM1", hfi_f_expm1),
 P4_FXco ("FLN", hfi_f_ln),
 P4_FXco ("FLNP1", hfi_f_lnp1),
 P4_FXco ("FLOG", hfi_f_log),
 P4_FXco ("FSIN", hfi_f_sin),
 P4_FXco ("FSINCOS", hfi_f_sincos),
 P4_FXco ("FSINH", hfi_f_sinh),
 P4_FXco ("FSQRT", hfi_f_sqrt),
 P4_FXco ("FTAN", hfi_f_tan),
 P4_FXco ("FTANH", hfi_f_tanh),
 P4_FXco ("FP@", hfi_f_p_fetch),
 P4_FXco ("FP!", hfi_f_p_store),
 P4_FXco ("F=", hfi_f_equal),
 P4_FXco ("F<>", hfi_f_not_equal),
 P4_FXco ("F>", hfi_f_greater_than),
 P4_FXco ("F<=", hfi_f_less_than_or_equal),
 P4_FXco ("F>=", hfi_f_greater_than_or_equal)
};
P4_COUNTWORDS (hffloat, "^Forth Floating-Point Word Set");