-- Copyright 1993-1998, by the Cecil Project
-- Department of Computer Science and Engineering, University of Washington
-- See the LICENSE file for license information.


-- methods for double-precision floats

extend double_float isa float;

prim c_++ {
#ifdef INDEXED_FIELDS
static int double_float_field_offset = -1;
static void lookup_double_float_field_offset(OOP p) {
    FieldEntry* e = p->map()->findField("value@anon:double_float:");
    if (e == NULL) {
      fatal("expected to find a 'value' field in double__float_obj");
    }
    double_float_field_offset = e->offset;
}
extern "C" OOP create_initialized_double__float_obj();
inline OOP newDoubleFloatObject(double value) {
  OOP res = create_initialized_double__float_obj();
  if (double_float_field_offset == -1) lookup_double_float_field_offset(res);
  SF_OOP(res, double_float_field_offset, double, value);
  return res;
}
inline double getDoubleFloatValue(OOP d) {
  if (double_float_field_offset == -1) lookup_double_float_field_offset(d);
  return GF_OOP(d, double_float_field_offset, double);
}
#else
inline OOP newDoubleFloatObject(double f) {
    return asTaggedPointer(new CecilDoubleFloatObject(f));
}
inline double getDoubleFloatValue(OOP d) {
    return d->asDoubleFloat()->value;
}
#endif
};

-- arithmetic

method = (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left =_double_log right goto l1;
            return false;
        label l1;
            return true;"
}

method < (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left <_double_log right goto l1;
            return false;
        label l1;
            return true;"
}

method <= (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left <=_double_log right goto l1;
            return false;
        label l1;
            return true;"
}

method > (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left >_double_log right goto l1;
            return false;
        label l1;
            return true;"
}

method >= (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left >=_double_log right goto l1;
            return false;
        label l1;
            return true;"
}

method != (l@:double_float, r@:double_float):bool {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            if left =_double_log right goto l1;
            return true;
        label l1;
            return false;"
}

method + (l@:double_float, r@:double_float):double_float {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            decl doubleWordFloat t1 := left +_double right;
            decl OOP t3 := box_double t1;
            return t3;"
}

method - (l@:double_float, r@:double_float):double_float {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            decl doubleWordFloat t1 := left -_double right;
            decl OOP t3 := box_double t1;
            return t3;"
}

method * (l@:double_float, r@:double_float):double_float {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            decl doubleWordFloat t1 := left *_double right;
            decl OOP t3 := box_double t1;
            return t3;"
}

method / (l@:double_float, r@:double_float):double_float {
    prim
      rtl: "decl doubleWordFloat left := unbox_double l;
            decl doubleWordFloat right := unbox_double r;
            decl doubleWordFloat t1 := left /_double right;
            decl OOP t3 := box_double t1;
            return t3;"
}


method as_double_float(f@:double_float):double_float { f }

method as_single_float(f@:double_float):single_float {
 prim
  rtl:"
    decl doubleWordFloat fval := unbox_double f;
    decl wordFloat x := convert_double_to_float fval;
    decl OOP ans := box_float x;
    return ans;
  "
}

-- converts to an int, with some to-be-determined way of rounding
-- (really, the same thing that C does with a cast from double_float to int)
method as_int(f@:double_float):int {
 prim
  rtl:"
    decl doubleWordFloat fval := unbox_double f;
    decl wordInt x := convert_double_to_int fval;
    decl OOP ans := box_int x;
    return ans;
  "
}

prim c_++ {
#include <math.h>
};

method sin(f@:double_float):double_float (** return_type(double_float),
					     sends(),
					     formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(sin(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(sin(getDoubleFloatValue(f))));
#endif
 "
}

method cos(f@:double_float):double_float (** return_type(double_float),
					     sends(),
					     formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(cos(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(cos(getDoubleFloatValue(f))));
#endif
 "
}

method tan(f@:double_float):double_float (** return_type(double_float),
					     sends(),
					     formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(tan(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(tan(getDoubleFloatValue(f))));
#endif
 "
}

method asin(f@:double_float):double_float (** return_type(double_float),
					      sends(),
					      formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(asin(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(asin(getDoubleFloatValue(f))));
#endif
 "
}

method acos(f@:double_float):double_float (** return_type(double_float),
					      sends(),
					      formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(acos(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(acos(getDoubleFloatValue(f))));
#endif
 "
}

method atan(f@:double_float):double_float (** return_type(double_float),
					      sends(),
					      formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(atan(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(atan(getDoubleFloatValue(f))));
#endif
 "
}

method exp(f@:double_float):double_float (** return_type(double_float),
					     sends(),
					     formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(exp(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(exp(getDoubleFloatValue(f))));
#endif
 "
}

method log(f@:double_float):double_float (** return_type(double_float),
					     sends(),
					     formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(log(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(log(getDoubleFloatValue(f))));
#endif
 "
}


method sqrt(f@:double_float):double_float (** return_type(double_float),
					      sends(),
					      formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(sqrt(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(sqrt(getDoubleFloatValue(f))));
#endif
 "
}

-- round to integer, using current IEEE rounding direction
method round_as_int(f@:double_float):int (** return_type(int), sends(),
					     formals_escape(f) **) {
 prim c_++: "
    int res;
#if VORTEX_SUN4
    res = irint(getDoubleFloatValue(f));
#elif VORTEX_POWERPC
    res = itrunc(rint(getDoubleFloatValue(f)));
#else
    /* a generic implementation */
    res = (int)(rint(getDoubleFloatValue(f)));
#endif
#ifdef DISPATCHERS
    RETURN(asTaggedInt(res));
#else
    BP(asTaggedInt(res));
#endif
"
}

-- round to integral value, using current IEEE rounding direction
method round(f@:double_float):double_float (** return_type(double_float),
					       sends(),
					       formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(rint(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(rint(getDoubleFloatValue(f))));
#endif
 "
}

-- round towards zero
method round_towards_zero(f@:double_float):double_float
		     (** return_type(double_float), sends(),
		         formals_escape(f)  **) {
 prim c_++: "
   doubleWordFloat res;
#if VORTEX_SUN4
   res = aint(getDoubleFloatValue(f));
#elif VORTEX_POWERPC
   res = trunc(getDoubleFloatValue(f));
#else
   /* a generic implementation */
   doubleWordFloat fv = getDoubleFloatValue(f);
   if (f < 0) {
     res = ceil(fv);
   } else {
     res = floor(fv);
   }
#endif
#ifdef DISPATCHERS
   RETURN(newDoubleFloatObject(res));
#else
   BP(newDoubleFloatObject(res));
#endif
"
}

--DOCSHORT round towards positive infinity
method ceiling(f@:double_float):double_float (** return_type(double_float),
					         sends(),
					         formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(ceil(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(ceil(getDoubleFloatValue(f))));
#endif
 "
}

--DOCSHORT round towards negative infinity
method floor(f@:double_float):double_float (** return_type(double_float),
					       sends(),
					       formals_escape(f) **) {
 prim c_++: "
#ifdef DISPATCHERS
    RETURN(newDoubleFloatObject(floor(getDoubleFloatValue(f))));
#else
    BP(newDoubleFloatObject(floor(getDoubleFloatValue(f))));
#endif
 "
}


-- printing behavior

method print_string(f@:double_float):string (** return_type(i_vstring),
					        sends(),
					        formals_escape(f) **) {
  prim c_++: "
    char buffer[30];
    sprintf(buffer, \"%g\", getDoubleFloatValue(f));
#ifdef DISPATCHERS
    RETURN(NEW_STRING(buffer));
#else
    BP(NEW_STRING(buffer));
#endif
  "
}

method print_string(f@:double_float, num_decimal_places@:int):string
				(** return_type(i_vstring), sends(),
				    formals_escape(f,f) **) {
  prim c_++: "
    char buffer[200];
    int decimals = num_decimal_places->asInt();
    sprintf(buffer, \"%.*g\", decimals, getDoubleFloatValue(f));
    BP(NEW_STRING(buffer));"
}

-- this method prints out the full precision of the double
method print_string_full(f@:double_float):string
				(** return_type(i_vstring), sends(),
				    formals_escape(f) **) {
  prim c_++: "
    char buffer[200];
    sprintf(buffer, \"%.18e\", getDoubleFloatValue(f));
#ifdef DISPATCHERS
    RETURN(NEW_STRING(buffer));
#else
    BP(NEW_STRING(buffer));
#endif
  "
}


method parse_as_double(s@:string):double_float {
    parse_as_double(s, { error("not a float") }) }
method parse_as_double(s@:string, if_error:&():double_float):double_float {
    parse_as_double(s.as_vstring, if_error) }
method parse_as_double(s@:vstring, if_error:&():double_float):double_float
                    (** sends(r1 = eval([if_error])),
		        return_type(r1, double_float),
		        formals_escape(f,f)**) {
  prim c_++: "
    double f;
    int ok = sscanf(AS_C_STRING(s), \"%lf\", &f);
    if (ok != 1) {
        TAIL_SEND(eval, 0, 1, (if_error),
                  \"1#parse_as_double(@vstring,b)\");
    } else {
#ifdef DISPATCHERS
	RETURN(newDoubleFloatObject(f));
#else
	BP(newDoubleFloatObject(f));
#endif
    }
"
}