factor/native/float.c

#include "factor.h"

double to_float(CELL tagged)
{
	F_RATIO* r;
	double x;
	double y;

	switch(TAG(tagged))
	{
	case FIXNUM_TYPE:
		return (double)untag_fixnum_fast(tagged);
	case BIGNUM_TYPE:
		return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
	case RATIO_TYPE:
		r = (F_RATIO*)UNTAG(tagged);
		x = to_float(r->numerator);
		y = to_float(r->denominator);
		return x / y;
	case FLOAT_TYPE:
		return ((F_FLOAT*)UNTAG(tagged))->n;
	default:
		type_error(FLOAT_TYPE,tagged);
		return 0.0; /* can't happen */
	}
}

void primitive_to_float(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(to_float(dpeek())));
}

void primitive_str_to_float(void)
{
	F_STRING* str;
	char *c_str, *end;
	double f;

	maybe_gc(sizeof(F_FLOAT));

	str = untag_string(dpeek());
	c_str = to_c_string(str,true);
	end = c_str;
	f = strtod(c_str,&end);
	if(end != c_str + string_capacity(str))
		general_error(ERROR_FLOAT_FORMAT,tag_object(str),true);
	drepl(tag_float(f));
}

void primitive_float_to_str(void)
{
	char tmp[33];

	maybe_gc(sizeof(F_FLOAT));

	snprintf(tmp,32,"%.16g",to_float(dpop()));
	tmp[32] = '\0';
	box_c_string(tmp);
}

#define GC_AND_POP_FLOATS(x,y) \
	double x, y; \
	maybe_gc(sizeof(F_FLOAT)); \
	y = untag_float_fast(dpop()); \
	x = untag_float_fast(dpop());

void primitive_float_add(void)
{
	GC_AND_POP_FLOATS(x,y);
	dpush(tag_float(x + y));
}

void primitive_float_subtract(void)
{
	GC_AND_POP_FLOATS(x,y);
	dpush(tag_float(x - y));
}

void primitive_float_multiply(void)
{
	GC_AND_POP_FLOATS(x,y);
	dpush(tag_float(x * y));
}

void primitive_float_divfloat(void)
{
	GC_AND_POP_FLOATS(x,y);
	dpush(tag_float(x / y));
}

void primitive_float_mod(void)
{
	GC_AND_POP_FLOATS(x,y);
	dpush(tag_float(fmod(x,y)));
}

void primitive_float_less(void)
{
	GC_AND_POP_FLOATS(x,y);
	box_boolean(x < y);
}

void primitive_float_lesseq(void)
{
	GC_AND_POP_FLOATS(x,y);
	box_boolean(x <= y);
}

void primitive_float_greater(void)
{
	GC_AND_POP_FLOATS(x,y);
	box_boolean(x > y);
}

void primitive_float_greatereq(void)
{
	GC_AND_POP_FLOATS(x,y);
	box_boolean(x >= y);
}

void primitive_facos(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(acos(to_float(dpeek()))));
}

void primitive_fasin(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(asin(to_float(dpeek()))));
}

void primitive_fatan(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(atan(to_float(dpeek()))));
}

void primitive_fatan2(void)
{
	double x, y;
	maybe_gc(sizeof(F_FLOAT));
	y = to_float(dpop());
	x = to_float(dpop());
	dpush(tag_float(atan2(x,y)));
}

void primitive_fcos(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(cos(to_float(dpeek()))));
}

void primitive_fexp(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(exp(to_float(dpeek()))));
}

void primitive_fcosh(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(cosh(to_float(dpeek()))));
}

void primitive_flog(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(log(to_float(dpeek()))));
}

void primitive_fpow(void)
{
	double x, y;
	maybe_gc(sizeof(F_FLOAT));
	y = to_float(dpop());
	x = to_float(dpop());
	dpush(tag_float(pow(x,y)));
}

void primitive_fsin(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(sin(to_float(dpeek()))));
}

void primitive_fsinh(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(sinh(to_float(dpeek()))));
}

void primitive_fsqrt(void)
{
	maybe_gc(sizeof(F_FLOAT));
	drepl(tag_float(sqrt(to_float(dpeek()))));
}

void primitive_float_bits(void)
{
	FLOAT_BITS b;
	b.x = (float)to_float(dpeek());
	drepl(tag_cell(b.y));
}

void primitive_bits_float(void)
{
	FLOAT_BITS b;
	b.y = unbox_unsigned_4();
	dpush(tag_float(b.x));
}

void primitive_double_bits(void)
{
	DOUBLE_BITS b;
	b.x = to_float(dpop());
	box_unsigned_8(b.y);
}

void primitive_bits_double(void)
{
	DOUBLE_BITS b;
	b.y = unbox_unsigned_8();
	dpush(tag_float(b.x));
}

#define DEFBOX(name,type)                                                      \
void name (type flo)                                                       \
{                                                                              \
	dpush(tag_float(flo));                                               \
}

#define DEFUNBOX(name,type)                                                    \
type name(void)                                                                \
{                                                                              \
	return to_float(dpop());                                                  \
}

DEFBOX(box_float,float)
DEFUNBOX(unbox_float,float)  
DEFBOX(box_double,double)
DEFUNBOX(unbox_double,double)