double sexp_ratio_to_double (sexp rat) {
sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
return (sexp_bignump(num) ? sexp_bignum_to_double(num)
: sexp_fixnum_to_double(num))
/ (sexp_bignump(den) ? sexp_bignum_to_double(den)
: sexp_fixnum_to_double(den));
}
static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
sexp res;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, i;
#endif
if (sexp_fixnump(x)) {
if (sexp_fixnump(y))
res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(y))
res = sexp_bit_and(ctx, self, n, y, x);
#endif
else
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
if (sexp_fixnump(y)) {
res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]);
} else if (sexp_bignump(y)) {
if (sexp_bignum_length(x) < sexp_bignum_length(y))
res = sexp_copy_bignum(ctx, NULL, x, 0);
else
res = sexp_copy_bignum(ctx, NULL, y, 0);
for (i=0, len=sexp_bignum_length(res); i<len; i++)
sexp_bignum_data(res)[i]
= sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i];
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, y);
}
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_rs_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp bound) {
sexp res;
int32_t m;
#if SEXP_USE_BIGNUMS
int32_t hi, mod, len, i, *data;
#endif
if (! sexp_random_source_p(rs))
res = sexp_type_exception(ctx, self, rs_type_id, rs);
if (sexp_fixnump(bound)) {
sexp_call_random(rs, m);
res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound));
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(bound)) {
hi = sexp_bignum_hi(bound);
len = hi * sizeof(sexp_uint_t) / sizeof(int32_t);
res = sexp_make_bignum(ctx, hi);
data = (int32_t*) sexp_bignum_data(res);
for (i=0; i<len-1; i++) {
sexp_call_random(rs, m);
data[i] = m;
}
sexp_call_random(rs, m);
mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t);
if (mod)
data[i] = m % mod;
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
}
return res;
}
static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
int i;
if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
|| sexp_flonump(x) || sexp_bignump(x)) {
sexp_write(ctx, x, out);
} else if (depth <= 0) {
goto print_name;
} else if (sexp_synclop(x)) {
sexp_write_string(ctx, "#<sc ", out);
sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
sexp_write_string(ctx, ">", out);
} else if (sexp_pairp(x)) {
sexp_write_char(ctx, '(', out);
sexp_print_simple(ctx, sexp_car(x), out, depth-1);
sexp_write_string(ctx, " . ", out);
sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
sexp_write_char(ctx, ')', out);
} else if (sexp_vectorp(x)) {
sexp_write_string(ctx, "#(", out);
for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) {
if (i>0)
sexp_write_char(ctx, ' ', out);
sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
}
if (i<(int)sexp_vector_length(x))
sexp_write_string(ctx, " ...", out);
sexp_write_char(ctx, ')', out);
} else {
print_name:
sexp_write_string(ctx, "#<", out);
sexp_write(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out);
}
}
sexp sexp_bignum_normalize (sexp a) {
sexp_uint_t *data;
if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1))
return a;
data = sexp_bignum_data(a);
if ((data[0] > SEXP_MAX_FIXNUM)
&& ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1)))
return a;
return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a));
}
static double sexp_to_double (sexp x) {
if (sexp_flonump(x))
return sexp_flonum_value(x);
else if (sexp_fixnump(x))
return sexp_fixnum_to_double(x);
else if (sexp_bignump(x))
return sexp_bignum_to_double(x);
#if SEXP_USE_RATIOS
else if (sexp_ratiop(x))
return sexp_ratio_to_double(x);
#endif
else
return 0.0;
}
static sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
else if (sexp_fixnump(state))
*sexp_random_data(rs) = sexp_unbox_fixnum(state);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(state))
*sexp_random_data(rs)
= sexp_bignum_data(state)[0]*sexp_bignum_sign(state);
#endif
else
return sexp_type_exception(ctx, self, SEXP_FIXNUM, state);
return SEXP_VOID;
}
static sexp sexp_to_complex (sexp ctx, sexp x) {
#if SEXP_USE_RATIOS
sexp_gc_var1(tmp);
#endif
if (sexp_flonump(x) || sexp_fixnump(x) || sexp_bignump(x)) {
return sexp_make_complex(ctx, x, SEXP_ZERO);
#if SEXP_USE_RATIOS
} else if (sexp_ratiop(x)) {
sexp_gc_preserve1(ctx, tmp);
tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x));
sexp_gc_release1(ctx);
return tmp;
#endif
} else {
return x;
}
}
