/* (C) Copyright International Business Machines Corporation 12 November */
/* 1990.  All Rights Reserved. */
/*  */
/* See the file USERAGREEMENT distributed with this software for full */
/* terms and conditions of use. */
/* Author: William Silverman */
#ifndef lint
static char sccsinfo[] = "@(#)o_real.c	1.2 2/17/92";
#endif


#include "ops.h"
#include "storage.h"
#include "sysdep.h"

#define Dst DstObj->value
#define Src SrcObj->value
#define Src1 Src1Obj->value
#define Src2 Src2Obj->value

/*
  These values were computed for the Sparc station, and may
  be incorrect for other platforms!
*/
#define MAXREAL 1.79769313486231580793728971405e+308
#define MINREAL -1.79769313486231580793728971405e+308

/*
   These values rely on truncation toward 0 and sufficient
   capacity in the double value to represent bounds exactly!
*/
#define REALINTUB (MAXINT + 1.0)
#define REALINTLB (MININT - 1.0)

#define init_real(objectp, val) \
  (set_init((objectp), dr_real), *((objectp)->value.real) = (val))

#define NewReal(Value) { \
    dfd_real *newreal; \
      if ((newreal = new(dfd_real)) is nil) { \
        raise_builtin(Depletion); \
        return; \
      } \
      Dst.real = newreal; \
      init_real(DstObj, Value); }


extern datarep dr_real, dr_boolean, dr_ord_enumeration, dr_integer;



NILOP(o_rcvt_int)
{
    register double s;

    OPCHK(SrcObj,real);
    s = *Src.real;		/* get source operand */

    if (REALINTLB < s and s < REALINTUB) {
      Dst.integer = s;
      set_init(DstObj, dr_integer);
    }
    else {
/*
      struct xx {long x1,x2};
      typedef struct xx yy;
      union {double d; yy xs} lb, xt, ub;
      double t;
      
      t = s;
      lb.d = REALINTLB;
      xt.d = s;
      ub.d = REALINTUB;
      
      printf("bounds: %08lx %08lx < %08lx %08lx < %08lx %08lx\n",
	     lb.xs.x1, lb.xs.x2,
	     xt.xs.x1, xt.xs.x2,
	     ub.xs.x1, ub.xs.x2
      );
*/
      raise_builtin(Depletion);
    }
}


NILOP(o_rcvt_enum)
{
    register double s;

    OPCHK(SrcObj,real);
    s = *Src.real;		/* get source operand */

    if ((0.0 <= s) and s < (args->qualifiers.integer)) {
      Dst.ord_enum = s;
      set_init(DstObj, dr_ord_enumeration);
    }
    else 
      raise_builtin(RangeError);
}


NILOP(o_rlit)
{
    dfd_real *newreal;

    if ((newreal = new(dfd_real)) is nil) {
      raise_builtin(Depletion);
      return;
    }

    Dst.real = newreal;
    init_real(DstObj, *(args->qualifiers.real));
                                /* for a literal, the value is the value */
				/* of the qualifier of the operation. */
}


NILOP(o_rnegate)
{
    OPCHK(SrcObj,real);
    NewReal(-(*Src.real));
}


NILOP(o_radd)
{
    register double s1, s2;

    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    s1 = *(Src1.real);		/* get operands.... */
    s2 = *(Src2.real);

    if (s2 >= 0.0) {		/* s2 is positive - is s1 too positive */
      if (s1 > MAXREAL - s2) {
	raise_builtin(Depletion);		/* overflow */
	return;
      }
    }
    else {			/* s2 is negative - is s1 too negative */
      if (s1 < MINREAL - s2) {
	raise_builtin(Depletion);		/* overflow */
	return;
      }
    }
    NewReal(s1 + s2);
}


NILOP(o_rsubtract)
{
    register double s1, s2;

    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    s1 = *(Src1.real);		/* get operands.... */
    s2 = *(Src2.real);

    if (s2 >= 0.0) {		/* s2 is positive - is s1 too negative */
      if (s1 < MINREAL + s2) {
	raise_builtin(Depletion);		/* overflow */
	return;
      }
    }
    else {			/* s2 is negative - is s1 too positive */
      if (s1 > MAXREAL + s2) {
	raise_builtin(Depletion);		/* overflow */
	return;
      }
    }
    NewReal(s1 - s2);
}


NILOP(o_rdivide)
{
    register double s1, s2;
    dfd_real *newreal;

    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    s1 = *(Src1.real);		/* get operands.... */
    s2 = *(Src2.real);

/* Comparisons to  ...REAL*s2  below check for quotient overflow when the
   divisor (s2) is a proper fraction. */

    if (s1 isnt 0) {
      if (s2 < 1.0) {
	if (-1.0 < s2) {
	  if (s2 > 0.0) {
	    if (s1 >= 0.0) {	/*  0.0 < s2 < 1.0  */
	      if (MAXREAL * s2 < s1) {
		raise_builtin(Depletion);	/* overflow */
		return;
	      }
	    }
	    else {
	      if (MINREAL * s2 > s1) {	/* overflow */
		raise_builtin(Depletion);
		return;
	      }
	    }
	  }
	  else {
	    if (s2 < 0.0) {	/* -1.0 < s2 < 0.0 */
	      if (s1 <= 0.0) {
		if (MAXREAL * s2 > s1) {
		  raise_builtin(Depletion);	/* overflow */
		  return;
		}
	      }
	      else {
		if (MINREAL * s2 < s1) {
		  raise_builtin(Depletion);	/* overflow */
		  return;
		}
	      }
	    }
	    else {
	      raise_builtin(DivideByZero);	/* trying to divide by zero. */
	      return;
	    }
	  }
	}
      }
      s1 = s1/s2;
      if (s1 is 0) {
	raise_builtin(Depletion);		/* underflow */
	return;
      }
    }
    else {
      if (s2 is 0) {
	raise_builtin(DivideByZero);		/* zero divided by zero ? */
	return;
      }
    }
    NewReal(s1);
}


NILOP(o_rmultiply)
{
    register double s1, s2;

    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    s1 = *(Src1.real);		/* get operands.... */
    s2 = *(Src2.real);

/* Comparisons to  ...REAL/s1  below check for product overflow when both
   factors are outside [-1, 1]. */

    if (s1 isnt 0) {
      if (s2 > 1.0) {
	if (s1 > 1.0) {
	  if (s1 > MAXREAL/s2) {
	    raise_builtin(Depletion);		/* overflow */
	    return;
	  }
	}
	else {
	  if (-1.0 >= s1) {
	    if (MINREAL/s2 > s1) {
	      raise_builtin(Depletion);		/* overflow */
	      return;
	    }
	  }
	}
      }
      else {
	if (s2 < -1.0) {
	  if (s1 > 1.0) {
	    if (s2 < MINREAL/s1) {
	      raise_builtin(Depletion);		/* overflow */
	      return;
	    }
	  }
	  else {
	    if (s1 < -1.0) {
	      if (s2 < MAXREAL/s1) {
		raise_builtin(Depletion);	/* overflow */
		return;
	      }
	    }
	  }
	}
      }
      s1 = s1*s2;
      if (s1 is 0 and s2 isnt 0) {
	raise_builtin(Depletion);		/* underflow */
	return;
      }
    }
    NewReal(s1);
}


NILOP(o_rgt)
{
    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    if (*(Src1.real) > *(Src2.real))
      DstObj->value.boolean = nil_true;
    else
      DstObj->value.boolean = nil_false;

    set_init(DstObj, dr_boolean);
}


NILOP(o_rge)
{
    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    if (*(Src1.real) >= *(Src2.real))
      DstObj->value.boolean = nil_true;
    else
      DstObj->value.boolean = nil_false;

    set_init(DstObj, dr_boolean);
}


NILOP(o_rlt)
{
    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    if (*(Src1.real) < *(Src2.real))
      DstObj->value.boolean = nil_true;
    else
      DstObj->value.boolean = nil_false;

    set_init(DstObj, dr_boolean);
}


NILOP(o_rle)
{
    OPCHK(Src1Obj,real);
    OPCHK(Src2Obj,real);
    if (*(Src1.real) <= *(Src2.real))
      DstObj->value.boolean = nil_true;
    else
      DstObj->value.boolean = nil_false;

    set_init(DstObj, dr_boolean);
}


/*ARGSUNUSED*/
void
fin_real(value, f_op, sched)
valcell value;
finalize_op f_op;
schedblock *sched;
{
  { dispose(value.real, dfd_real); }	/* free the real cell */
}


predef_exception
cp_real(dst, src)
valcell *dst, src;
{
    valcell newreal;

    if ((newreal.real = new(dfd_real)) is  nil)
      return(Depletion);
    *newreal.real = *src.real;
    dst->real = newreal.real;
    return(Normal);
}


status
eq_real(s1, s2)
valcell s1, s2;
{
    if (*s1.real is *s2.real)
      return(SUCCESS);
    else
      return(FAILURE);
}



/* These functions are implemented here temporarily - move when happy */


NILOP(o_oecvt_real)
{
    dfd_real *newreal;

    OPCHK(SrcObj,ord_enumeration);

    if ((newreal = new(dfd_real)) is nil) {
      raise_builtin(Depletion);
      return;
    }

    Dst.real = newreal;
    init_real(DstObj, Src.ord_enum);	/* move carefully!!! */
}



NILOP(o_icvt_real)
{
    dfd_real *newreal;

    OPCHK(SrcObj,integer);

    if ((newreal = new(dfd_real)) is nil) {
      raise_builtin(Depletion);
      return;
    }

    Dst.real = newreal;
    init_real(DstObj, Src.integer);	/* move carefully!!! */
}
