-- 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 single-precision floats

extend single_float isa float;

prim c_++ {
#ifdef INDEXED_FIELDS
static int float_field_offset = -1;
static void lookup_float_field_offset(OOP p) {
    FieldEntry* e = p->map()->findField("value@anon:single_float:");
    if (e == NULL) {
      fatal("expected to find a 'value' field in single__float_obj");
    }
    float_field_offset = e->offset;
}
extern "C" OOP create_initialized_single__float_obj();
inline OOP newFloatObject(float value) {
  OOP res = create_initialized_single__float_obj();
  if (float_field_offset == -1) lookup_float_field_offset(res);
  SF_OOP(res, float_field_offset, float, value);
  return res;
}
inline float getFloatValue(OOP f) {
  if (float_field_offset == -1) lookup_float_field_offset(f);
  return GF_OOP(f, float_field_offset, float);
}
#else
inline OOP newFloatObject(float f) {
    return asTaggedPointer(new CecilFloatObject(f));
}
inline float getFloatValue(OOP f) {
    return f->asFloat()->value;
}
#endif
};

-- arithmetic

method = (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left =_float_log right goto l1;
            return false;
        label l1;
            return true;"
}

method < (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left <_float_log right goto l1;
            return false;
        label l1;
            return true;"
}

method <= (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left <=_float_log right goto l1;
            return false;
        label l1;
            return true;"
}

method > (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left >_float_log right goto l1;
            return false;
        label l1;
            return true;"
}

method >= (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left >=_float_log right goto l1;
            return false;
        label l1;
            return true;"
}

method != (l@:single_float, r@:single_float):bool {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            if left =_float_log right goto l1;
            return true;
        label l1;
            return false;"
}

method + (l@:single_float, r@:single_float):single_float {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            decl wordFloat t1 := left +_float right;
            decl OOP t3 := box_float t1;
            return t3;"
}

method - (l@:single_float, r@:single_float):single_float {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            decl wordFloat t1 := left -_float right;
            decl OOP t3 := box_float t1;
            return t3;"
}

method * (l@:single_float, r@:single_float):single_float {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            decl wordFloat t1 := left *_float right;
            decl OOP t3 := box_float t1;
            return t3;"
}

method / (l@:single_float, r@:single_float):single_float {
    prim
      rtl: "decl wordFloat left := unbox_float l;
            decl wordFloat right := unbox_float r;
            decl wordFloat t1 := left /_float right;
            decl OOP t3 := box_float t1;
            return t3;"
}


method as_single_float(f@:single_float):single_float { f }

method as_double_float(f@:single_float):double_float {
 prim
  rtl:"
    decl wordFloat fval := unbox_float f;
    decl doubleWordFloat x := convert_float_to_double fval;
    decl OOP ans := box_double 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 float to int)
method as_int(f@:single_float):int {
 prim
  rtl:"
    decl wordFloat fval := unbox_float f;
    decl wordInt x := convert_float_to_int fval;
    decl OOP ans := box_int x;
    return ans;
  "
}

prim c_++: "
#include <math.h>
";

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- printing behavior

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

method print_string(f@:single_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, \"%.*f\", decimals, getFloatValue(f));
#ifdef DISPATCHERS
    RETURN(NEW_STRING(buffer));
#else
    BP(NEW_STRING(buffer));
#endif
  "
}

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


method parse_as_float(s@:string):single_float {
    parse_as_float(s, { error("not a float") }) }
method parse_as_float(s@:string, if_error:&():single_float):single_float {
    parse_as_float(s.as_vstring, if_error) }
method parse_as_float(s@:vstring, if_error:&():single_float):single_float
                      (** sends(r1 = eval([if_error])),
		          return_type(r1, single_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_float(@vstring,b)\");
    } else {
#ifdef DISPATCHERS
	RETURN(newFloatObject(f));
#else
	BP(newFloatObject(f));
#endif
    }
"
}

let pi:float := 3.1415927;