2004-08-05 16:49:55 -04:00
|
|
|
#include "factor.h"
|
|
|
|
|
|
|
|
void primitive_floatp(void)
|
|
|
|
{
|
|
|
|
check_non_empty(env.dt);
|
|
|
|
env.dt = tag_boolean(typep(FLOAT_TYPE,env.dt));
|
|
|
|
}
|
|
|
|
|
|
|
|
FLOAT* to_float(CELL tagged)
|
|
|
|
{
|
|
|
|
switch(type_of(tagged))
|
|
|
|
{
|
|
|
|
case FIXNUM_TYPE:
|
|
|
|
return fixnum_to_float(tagged);
|
|
|
|
case BIGNUM_TYPE:
|
|
|
|
return bignum_to_float(tagged);
|
|
|
|
case RATIO_TYPE:
|
|
|
|
return ratio_to_float(tagged);
|
|
|
|
case FLOAT_TYPE:
|
|
|
|
return (FLOAT*)UNTAG(tagged);
|
|
|
|
default:
|
|
|
|
type_error(FLOAT_TYPE,tagged);
|
|
|
|
return NULL; /* can't happen */
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_to_float(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(to_float(env.dt));
|
|
|
|
}
|
|
|
|
|
2004-08-05 17:33:02 -04:00
|
|
|
void primitive_str_to_float(void)
|
|
|
|
{
|
2004-08-06 18:40:44 -04:00
|
|
|
STRING* str = untag_string(env.dt);
|
|
|
|
char* c_str = to_c_string(str);
|
|
|
|
char* end = c_str;
|
|
|
|
double f = strtod(c_str,&end);
|
|
|
|
if(end != c_str + str->capacity)
|
|
|
|
general_error(ERROR_FLOAT_FORMAT,tag_object(str));
|
|
|
|
env.dt = tag_object(make_float(f));
|
2004-08-05 17:33:02 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_float_to_str(void)
|
|
|
|
{
|
|
|
|
char tmp[33];
|
2004-08-06 18:40:44 -04:00
|
|
|
snprintf(&tmp,32,"%.16g",to_float(env.dt)->n);
|
2004-08-05 17:33:02 -04:00
|
|
|
tmp[32] = '\0';
|
|
|
|
env.dt = tag_object(from_c_string(tmp));
|
|
|
|
}
|
|
|
|
|
2004-08-06 02:51:32 -04:00
|
|
|
void primitive_float_to_bits(void)
|
|
|
|
{
|
2004-08-07 19:59:54 -04:00
|
|
|
double f = untag_float(env.dt);
|
|
|
|
BIGNUM_2 f_raw = *(BIGNUM_2*)&f;
|
|
|
|
env.dt = tag_object(bignum(f_raw));
|
2004-08-06 02:51:32 -04:00
|
|
|
}
|
|
|
|
|
2004-08-05 16:49:55 -04:00
|
|
|
CELL number_eq_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_boolean(((FLOAT*)UNTAG(x))->n
|
|
|
|
== ((FLOAT*)UNTAG(y))->n);
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL add_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_object(make_float(((FLOAT*)UNTAG(x))->n
|
|
|
|
+ ((FLOAT*)UNTAG(y))->n));
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL subtract_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_object(make_float(((FLOAT*)UNTAG(x))->n
|
|
|
|
- ((FLOAT*)UNTAG(y))->n));
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL multiply_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_object(make_float(((FLOAT*)UNTAG(x))->n
|
|
|
|
* ((FLOAT*)UNTAG(y))->n));
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL divide_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_object(make_float(((FLOAT*)UNTAG(x))->n
|
|
|
|
/ ((FLOAT*)UNTAG(y))->n));
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL divfloat_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_object(make_float(((FLOAT*)UNTAG(x))->n
|
|
|
|
/ ((FLOAT*)UNTAG(y))->n));
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL less_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_boolean(((FLOAT*)UNTAG(x))->n
|
|
|
|
< ((FLOAT*)UNTAG(y))->n);
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL lesseq_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_boolean(((FLOAT*)UNTAG(x))->n
|
|
|
|
<= ((FLOAT*)UNTAG(y))->n);
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL greater_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_boolean(((FLOAT*)UNTAG(x))->n
|
|
|
|
> ((FLOAT*)UNTAG(y))->n);
|
|
|
|
}
|
|
|
|
|
|
|
|
CELL greatereq_float(CELL x, CELL y)
|
|
|
|
{
|
|
|
|
return tag_boolean(((FLOAT*)UNTAG(x))->n
|
|
|
|
>= ((FLOAT*)UNTAG(y))->n);
|
|
|
|
}
|
2004-08-06 18:40:44 -04:00
|
|
|
|
|
|
|
void primitive_facos(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(acos(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fasin(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(asin(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fatan(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(atan(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fatan2(void)
|
|
|
|
{
|
|
|
|
double x = to_float(env.dt)->n;
|
|
|
|
double y = to_float(dpop())->n;
|
|
|
|
env.dt = tag_object(make_float(atan2(y,x)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fcos(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(cos(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fexp(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(exp(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fcosh(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(cosh(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_flog(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(log(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fpow(void)
|
|
|
|
{
|
|
|
|
double x = to_float(env.dt)->n;
|
|
|
|
double y = to_float(dpop())->n;
|
|
|
|
env.dt = tag_object(make_float(pow(y,x)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fsin(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(sin(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fsinh(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(sinh(to_float(env.dt)->n)));
|
|
|
|
}
|
|
|
|
|
|
|
|
void primitive_fsqrt(void)
|
|
|
|
{
|
|
|
|
env.dt = tag_object(make_float(sqrt(to_float(env.dt)->n)));
|
|
|
|
}
|