cons_t* proc_mul(cons_t *p, environment_t *env)
{
rational_t product;
product.numerator = 1;
product.denominator = 1;
bool exact = true;
for ( ; !nullp(p); p = cdr(p) ) {
cons_t *i = listp(p)? car(p) : p;
if ( integerp(i) ) {
product *= i->number.integer;
if ( !i->number.exact ) exact = false;
} else if ( rationalp(i) ) {
if ( !i->number.exact ) exact = false;
product *= i->number.rational;
} else if ( realp(i) ) {
// automatically convert; perform rest of computation in floats
exact = false;
return proc_mulf(cons(real(product), p), env);
} else
raise(runtime_exception("Cannot multiply integer with " + to_s(type_of(i)) + ": " + sprint(i)));
}
return rational(product, exact);
}
/*
* Returns a void pointer to the data the cell holds,
* whose data type must be compatible with `type`.
*/
static void* make_arg(ffi_type *type, cons_t* val)
{
if ( type == &ffi_type_uint ||
type == &ffi_type_sint )
{
if ( !integerp(val) )
raise(runtime_exception("Argument must be an integer"));
return static_cast<void*>(&val->number.integer);
}
if ( type == &ffi_type_pointer ) {
if ( stringp(val) ) return static_cast<void*>(&val->string);
if ( pointerp(val) ) return &val->pointer->value;
if ( integerp(val) ) return &val->number.integer;
if ( realp(val) ) return &val->number.real;
raise(runtime_exception(format(
"Unsupported pointer type %s", to_s(type_of(val)).c_str())));
}
const std::string expect = ffi_type_name(type),
given = to_s(type_of(val));
raise(runtime_exception(format(
"Foreign function wants %s but input data was %s, "
"which we don't know how to convert.",
indef_art("'"+expect+"'").c_str(),
indef_art("'"+given+"'").c_str())));
return NULL;
}
cons_t* proc_add(cons_t *p, environment_t* env)
{
/*
* Integers have an IDENTITY, so we can do this,
* but a more correct approach would be to take
* the value of the FIRST number we find and
* return that.
*/
rational_t sum;
sum.numerator = 0;
sum.denominator = 1;
bool exact = true;
for ( ; !nullp(p); p = cdr(p) ) {
cons_t *i = listp(p)? car(p) : p;
if ( integerp(i) ) {
if ( !i->number.exact ) exact = false;
sum += i->number.integer;
} else if ( rationalp(i) ) {
if ( !i->number.exact ) exact = false;
sum += i->number.rational;
} else if ( realp(i) ) {
// automatically convert; perform rest of computation in floats
exact = false;
return proc_addf(cons(real(sum), p), env);
} else
raise(runtime_exception(
"Cannot add integer with " + to_s(type_of(i)) + ": " + sprint(i)));
}
return rational(sum, exact);
}
cons_t* proc_nanp(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( realp(car(p)) )
return boolean(std::isnan(car(p)->number.real));
return boolean(false);
}
cons_t* proc_abs(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( realp(car(p)) ) {
real_t n = car(p)->number.real;
return real(n<0.0? -n : n);
}
int n = car(p)->number.integer;
return integer(n<0? -n : n);
}
static VOID make_number P2C(Number *, num, LVAL, x)
{
if (realp(x)) {
num->real = makefloat(x);
num->imag = 0.0;
num->complex = FALSE;
}
else if (complexp(x)) {
num->real = makefloat(getreal(x));
num->imag = makefloat(getimag(x));
num->complex = TRUE;
}
else xlerror("not a number", x);
}
cons_t* proc_mulf(cons_t *p, environment_t*)
{
real_t product = 1.0;
for ( ; !nullp(p); p = cdr(p) ) {
cons_t *i = listp(p)? car(p) : p;
if ( integerp(i) )
product *= static_cast<real_t>(i->number.integer);
else if ( realp(i) )
// automatically convert; perform rest of computation in floats
product *= i->number.real;
else
raise(runtime_exception("Cannot multiply integer with " + to_s(type_of(i)) + ": " + sprint(i)));
}
return real(product);
}
cons_t* proc_addf(cons_t *p, environment_t*)
{
real_t sum = 0.0;
for ( ; !nullp(p); p = cdr(p) ) {
cons_t *i = listp(p)? car(p) : p;
if ( integerp(i) )
sum += static_cast<real_t>(i->number.integer);
else if ( realp(i) )
sum += i->number.real;
else if ( rationalp(i) )
sum += real(i->number.rational)->number.real;
else
raise(runtime_exception("Cannot add real with " + to_s(type_of(i)) + ": " + sprint(i)));
}
return real(sum);
}
cons_t* proc_div(cons_t *p, environment_t *e)
{
assert_length(p, 2);
cons_t *a = car(p);
cons_t *b = cadr(p);
assert_number(a);
assert_number(b);
bool exact = (a->number.exact && b->number.exact);
if ( zerop(b) )
raise(runtime_exception(format(
"Division by zero: %s", sprint(cons(symbol("/"), p)).c_str())));
if ( type_of(a) == type_of(b) ) {
if ( integerp(a) ) {
// division yields integer?
if ( gcd(a->number.integer, b->number.integer) == 0)
return integer(a->number.integer / b->number.integer, exact);
else
return rational(make_rational(a) /= make_rational(b), exact);
} else if ( realp(a) )
return real(a->number.real / b->number.real);
else if ( rationalp(a) )
return rational(a->number.rational / b->number.rational, exact);
else
raise(runtime_exception(format("Cannot perform division on %s",
indef_art(to_s(type_of(a))).c_str())));
}
bool anyrational = (rationalp(a) || rationalp(b));
bool anyinteger = (integerp(a) || integerp(b));
// int/rat or rat/int ==> turn into rational, and not an int
if ( anyrational && anyinteger )
return rational(make_rational(a) /= make_rational(b), exact, false);
// proceed with real division
return proc_divf(p, e);
}
