factor/vm/math.c

554 lines
9.3 KiB
C

#include "master.h"
/* Fixnums */
F_FIXNUM to_fixnum(CELL tagged)
{
switch(TAG(tagged))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
return bignum_to_fixnum(untag_object(tagged));
default:
type_error(FIXNUM_TYPE,tagged);
return -1; /* can't happen */
}
}
CELL to_cell(CELL tagged)
{
return (CELL)to_fixnum(tagged);
}
DEFINE_PRIMITIVE(bignum_to_fixnum)
{
drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
}
DEFINE_PRIMITIVE(float_to_fixnum)
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
#define POP_FIXNUMS(x,y) \
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
DEFINE_PRIMITIVE(fixnum_add)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
DEFINE_PRIMITIVE(fixnum_subtract)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
DEFINE_PRIMITIVE(fixnum_multiply)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
dpush(tag_fixnum(0));
else
{
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
box_signed_cell(prod);
else
{
F_ARRAY *bx = fixnum_to_bignum(x);
REGISTER_BIGNUM(bx);
F_ARRAY *by = fixnum_to_bignum(y);
UNREGISTER_BIGNUM(bx);
dpush(tag_bignum(bignum_multiply(bx,by)));
}
}
}
DEFINE_PRIMITIVE(fixnum_divint)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
DEFINE_PRIMITIVE(fixnum_divmod)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
dpush(tag_fixnum(x % y));
}
DEFINE_PRIMITIVE(fixnum_mod)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x % y));
}
/*
* Note the hairy overflow check.
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
DEFINE_PRIMITIVE(fixnum_shift)
{
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
{
dpush(tag_fixnum(x));
return;
}
else if(y < 0)
{
if(y <= -WORD_SIZE)
dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
dpush(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
F_FIXNUM mask = -(1L << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
dpush(tag_fixnum(x << y));
return;
}
}
dpush(tag_bignum(bignum_arithmetic_shift(
fixnum_to_bignum(x),y)));
}
DEFINE_PRIMITIVE(fixnum_shift_fast)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
}
/* Bignums */
DEFINE_PRIMITIVE(fixnum_to_bignum)
{
drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
}
DEFINE_PRIMITIVE(float_to_bignum)
{
drepl(tag_bignum(float_to_bignum(dpeek())));
}
#define POP_BIGNUMS(x,y) \
F_ARRAY *y = untag_object(dpop()); \
F_ARRAY *x = untag_object(dpop());
DEFINE_PRIMITIVE(bignum_eq)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
DEFINE_PRIMITIVE(bignum_add)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_add(x,y)));
}
DEFINE_PRIMITIVE(bignum_subtract)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_subtract(x,y)));
}
DEFINE_PRIMITIVE(bignum_multiply)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_multiply(x,y)));
}
DEFINE_PRIMITIVE(bignum_divint)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_quotient(x,y)));
}
DEFINE_PRIMITIVE(bignum_divmod)
{
F_ARRAY *q, *r;
POP_BIGNUMS(x,y);
bignum_divide(x,y,&q,&r);
dpush(tag_bignum(q));
dpush(tag_bignum(r));
}
DEFINE_PRIMITIVE(bignum_mod)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_remainder(x,y)));
}
DEFINE_PRIMITIVE(bignum_and)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_and(x,y)));
}
DEFINE_PRIMITIVE(bignum_or)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_ior(x,y)));
}
DEFINE_PRIMITIVE(bignum_xor)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_xor(x,y)));
}
DEFINE_PRIMITIVE(bignum_shift)
{
F_FIXNUM y = to_fixnum(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}
DEFINE_PRIMITIVE(bignum_less)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
DEFINE_PRIMITIVE(bignum_lesseq)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
DEFINE_PRIMITIVE(bignum_greater)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
DEFINE_PRIMITIVE(bignum_greatereq)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
DEFINE_PRIMITIVE(bignum_not)
{
drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
}
DEFINE_PRIMITIVE(bignum_bitp)
{
F_FIXNUM bit = to_fixnum(dpop());
F_ARRAY *x = untag_object(dpop());
box_boolean(bignum_logbitp(bit,x));
}
DEFINE_PRIMITIVE(bignum_log2)
{
drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
}
unsigned int bignum_producer(unsigned int digit)
{
unsigned char *ptr = alien_offset(dpeek());
return *(ptr + digit);
}
DEFINE_PRIMITIVE(byte_array_to_bignum)
{
type_check(BYTE_ARRAY_TYPE,dpeek());
CELL n_digits = array_capacity(untag_object(dpeek()));
bignum_type bignum = digit_stream_to_bignum(
n_digits,bignum_producer,0x100,0);
drepl(tag_bignum(bignum));
}
void box_signed_1(s8 n)
{
dpush(tag_fixnum(n));
}
void box_unsigned_1(u8 n)
{
dpush(tag_fixnum(n));
}
void box_signed_2(s16 n)
{
dpush(tag_fixnum(n));
}
void box_unsigned_2(u16 n)
{
dpush(tag_fixnum(n));
}
void box_signed_4(s32 n)
{
dpush(allot_integer(n));
}
void box_unsigned_4(u32 n)
{
dpush(allot_cell(n));
}
void box_signed_cell(F_FIXNUM integer)
{
dpush(allot_integer(integer));
}
void box_unsigned_cell(CELL cell)
{
dpush(allot_cell(cell));
}
void box_signed_8(s64 n)
{
if(n < FIXNUM_MIN || n > FIXNUM_MAX)
dpush(tag_bignum(long_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
}
s64 to_signed_8(CELL obj)
{
switch(type_of(obj))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(obj);
case BIGNUM_TYPE:
return bignum_to_long_long(untag_object(obj));
default:
type_error(BIGNUM_TYPE,obj);
return -1;
}
}
void box_unsigned_8(u64 n)
{
if(n > FIXNUM_MAX)
dpush(tag_bignum(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
}
u64 to_unsigned_8(CELL obj)
{
switch(type_of(obj))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(obj);
case BIGNUM_TYPE:
return bignum_to_ulong_long(untag_object(obj));
default:
type_error(BIGNUM_TYPE,obj);
return -1;
}
}
CELL unbox_array_size(void)
{
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
{
F_FIXNUM n = untag_fixnum_fast(dpeek());
if(n >= 0 && n < ARRAY_SIZE_MAX)
{
dpop();
return n;
}
break;
}
case BIGNUM_TYPE:
{
bignum_type zero = untag_object(bignum_zero);
bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
bignum_type n = untag_object(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
{
dpop();
return bignum_to_ulong(n);
}
break;
}
}
general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
return 0; /* can't happen */
}
/* Ratios */
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
DEFINE_PRIMITIVE(from_fraction)
{
F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->denominator = dpop();
ratio->numerator = dpop();
dpush(RETAG(ratio,RATIO_TYPE));
}
/* Floats */
DEFINE_PRIMITIVE(fixnum_to_float)
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
DEFINE_PRIMITIVE(bignum_to_float)
{
drepl(allot_float(bignum_to_float(dpeek())));
}
DEFINE_PRIMITIVE(str_to_float)
{
char *c_str, *end;
double f;
F_STRING *str = untag_string(dpeek());
CELL capacity = string_capacity(str);
c_str = to_char_string(str,false);
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + capacity)
drepl(F);
else
drepl(allot_float(f));
}
DEFINE_PRIMITIVE(float_to_str)
{
char tmp[33];
snprintf(tmp,32,"%.16g",untag_float(dpop()));
tmp[32] = '\0';
box_char_string(tmp);
}
#define POP_FLOATS(x,y) \
double y = untag_float_fast(dpop()); \
double x = untag_float_fast(dpop());
DEFINE_PRIMITIVE(float_eq)
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
DEFINE_PRIMITIVE(float_add)
{
POP_FLOATS(x,y);
box_double(x + y);
}
DEFINE_PRIMITIVE(float_subtract)
{
POP_FLOATS(x,y);
box_double(x - y);
}
DEFINE_PRIMITIVE(float_multiply)
{
POP_FLOATS(x,y);
box_double(x * y);
}
DEFINE_PRIMITIVE(float_divfloat)
{
POP_FLOATS(x,y);
box_double(x / y);
}
DEFINE_PRIMITIVE(float_mod)
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
DEFINE_PRIMITIVE(float_less)
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
DEFINE_PRIMITIVE(float_lesseq)
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
DEFINE_PRIMITIVE(float_greater)
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
DEFINE_PRIMITIVE(float_greatereq)
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
DEFINE_PRIMITIVE(float_bits)
{
box_unsigned_4(float_bits(untag_float(dpop())));
}
DEFINE_PRIMITIVE(bits_float)
{
box_float(bits_float(to_cell(dpop())));
}
DEFINE_PRIMITIVE(double_bits)
{
box_unsigned_8(double_bits(untag_float(dpop())));
}
DEFINE_PRIMITIVE(bits_double)
{
box_double(bits_double(to_unsigned_8(dpop())));
}
float to_float(CELL value)
{
return untag_float(value);
}
double to_double(CELL value)
{
return untag_float(value);
}
void box_float(float flo)
{
dpush(allot_float(flo));
}
void box_double(double flo)
{
dpush(allot_float(flo));
}
/* Complex numbers */
DEFINE_PRIMITIVE(from_rect)
{
F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->imaginary = dpop();
complex->real = dpop();
dpush(RETAG(complex,COMPLEX_TYPE));
}