Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial hugenums implementation (incomplete).

Browse source
This commit is contained in:
Alex Shinn 2012-12-04 19:48:14 +09:00
parent 5909732e82
commit e9963b4a57
8 changed files with 519 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

322
bignum.c
View file

@ -233,13 +233,13 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
} else {
if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1), 0);
}
#if SEXP_USE_RATIOS
} else if (c=='/') {
res = sexp_bignum_normalize(res);
res = sexp_make_ratio(ctx, res, SEXP_ONE);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10);
sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10, 1);
res = sexp_ratio_normalize(ctx, res, in);
#endif
#if SEXP_USE_COMPLEX
@ -839,6 +839,109 @@ sexp sexp_complex_atan (sexp ctx, sexp z) {
#endif
#endif
#if SEXP_USE_HUGENUMS
/* Conway's chained arrows */
/* Here a, b, c are integers, and X, Y are arbitrary subchains. */
/* 1. a = a */
/* 2. a->b = a^b */
/* 3. X->1->... = X */
/* 4. X->(a+1)->(b+1) = X->(X->a->(b+1))->b */
/* Alternate forms */
/* a->b->c = hyper(a, c+2, b) in hyper notation */
/* = a^^...^^b in Knuth's arrow notation */
/* c '^'s */
/* Ackermann(a, b) = (2->(a+3)->(b-2)) - 3 for b > 2*/
/* Special cases */
/* 2->2->X = 4 (will always expand to a power tower of 2 2s) */
/* X->2->2 = X->(X) (chain X with it's value concatenated to it) */
/* a->b->2 = a^^b (a tetrated to b) */
/* a->2->3 = a->a->2 (a tetrated to itself) */
/* a->3->3 = a->(a->a->2)->2 = a^^(a^^a) */
/* a->b->c->d = huge for a, b, c, d >= 2, a or b >= 3 */
sexp sexp_make_hugenum (sexp ctx, sexp_uint_t len) {
sexp_uint_t size = sexp_sizeof(hugenum) + len*sizeof(sexp);
sexp res = sexp_alloc_tagged(ctx, size, SEXP_HUGENUM);
sexp_hugenum_length(res) = len;
return res;
}
sexp sexp_copy_hugenum (sexp ctx, sexp a) {
sexp_uint_t i, len = sexp_hugenum_length(a);
sexp_uint_t size = sexp_sizeof(hugenum) + len*sizeof(sexp);
sexp res = sexp_alloc_tagged(ctx, size, SEXP_HUGENUM);
sexp_hugenum_length(res) = len;
for (i=0; i<len; i++) sexp_hugenum_data(res)[i] = sexp_hugenum_data(a)[i];
return res;
}
sexp sexp_hugenum2 (sexp ctx, sexp base, sexp exponent) {
sexp res = sexp_make_hugenum(ctx, 2);
sexp_hugenum_data(res)[0] = base;
sexp_hugenum_data(res)[1] = exponent;
return res;
}
int sexp_hugenum_sign (sexp a) {
sexp first = sexp_hugenum_data(a)[0];
if (sexp_fixnump(first))
return sexp_unbox_fixnum(first);
if (sexp_bignump(first))
return sexp_bignum_sign(first);
return 0; /* shouldn't happen */
}
int sexp_compare_hugenum_magnitude (sexp ctx, sexp a, sexp b, int sign) {
sexp *av, *bv;
int i, diff;
sexp_gc_var2(loga, logb);
if ((diff = sexp_hugenum_length(a) - sexp_hugenum_length(b)) != 0)
return diff * sign;
if (sexp_hugenum_length(a) == 2) {
sexp_gc_preserve2(ctx, loga, logb);
loga = sexp_log(ctx, a);
logb = sexp_log(ctx, b);
diff = sexp_unbox_fixnum(sexp_compare(ctx, loga, logb));
sexp_gc_release2(ctx);
return diff;
}
av = sexp_hugenum_data(a);
bv = sexp_hugenum_data(b);
for (i=sexp_hugenum_length(a); i>=0; i--)
if ((diff = sexp_unbox_fixnum(sexp_compare(ctx, av[i], bv[i]))) != 0)
return diff * sign;
return 0;
}
int sexp_compare_hugenum (sexp ctx, sexp a, sexp b) {
int sign;
if ((sign = sexp_hugenum_sign(a)) != sexp_hugenum_sign(b))
return sign;
return sexp_compare_hugenum_magnitude(ctx, a, b, sign);
}
sexp sexp_max_hugenum_magnitude (sexp ctx, sexp a, sexp b) {
if (sexp_compare_hugenum_magnitude(ctx, a, b, 1) < 0)
return b;
return a;
}
sexp sexp_max_hugenum (sexp ctx, sexp a, sexp b) {
if (sexp_compare_hugenum(ctx, a, b) < 0)
return b;
return a;
}
#endif
/****************** generic arithmetic ************************/
enum sexp_number_types {
@ -852,6 +955,9 @@ enum sexp_number_types {
#if SEXP_USE_COMPLEX
SEXP_NUM_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_HUG,
#endif
};
enum sexp_number_combs {
@ -864,6 +970,9 @@ enum sexp_number_combs {
#endif
#if SEXP_USE_COMPLEX
SEXP_NUM_NOT_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_NOT_HUG,
#endif
SEXP_NUM_FIX_NOT,
SEXP_NUM_FIX_FIX,
@ -874,6 +983,9 @@ enum sexp_number_combs {
#endif
#if SEXP_USE_COMPLEX
SEXP_NUM_FIX_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_FIX_HUG,
#endif
SEXP_NUM_FLO_NOT,
SEXP_NUM_FLO_FIX,
@ -884,6 +996,9 @@ enum sexp_number_combs {
#endif
#if SEXP_USE_COMPLEX
SEXP_NUM_FLO_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_FLO_HUG,
#endif
SEXP_NUM_BIG_NOT,
SEXP_NUM_BIG_FIX,
@ -895,6 +1010,9 @@ enum sexp_number_combs {
#if SEXP_USE_COMPLEX
SEXP_NUM_BIG_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_BIG_HUG,
#endif
#if SEXP_USE_RATIOS
SEXP_NUM_RAT_NOT,
SEXP_NUM_RAT_FIX,
@ -904,6 +1022,9 @@ enum sexp_number_combs {
#if SEXP_USE_COMPLEX
SEXP_NUM_RAT_CPX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_NUM_RAT_HUG,
#endif
#endif
#if SEXP_USE_COMPLEX
SEXP_NUM_CPX_NOT,
@ -914,11 +1035,28 @@ enum sexp_number_combs {
SEXP_NUM_CPX_RAT,
#endif
SEXP_NUM_CPX_CPX,
#if SEXP_USE_HUGENUMS
SEXP_NUM_CPX_HUG,
#endif
#endif
#if SEXP_USE_COMPLEX
SEXP_NUM_HUG_NOT,
SEXP_NUM_HUG_FIX,
SEXP_NUM_HUG_FLO,
SEXP_NUM_HUG_BIG,
SEXP_NUM_HUG_RAT,
#if SEXP_USE_HUGENUMS
SEXP_NUM_HUG_CPX,
#endif
SEXP_NUM_HUG_HUG,
#endif
};
static int sexp_number_types[] =
#if SEXP_USE_RATIOS && SEXP_USE_COMPLEX
#if SEXP_USE_HUGENUMS && SEXP_USE_COMPLEX
{0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 5, 6, 0};
#else
#if SEXP_USE_RATIOS && (SEXP_USE_COMPLEX || SEXP_USE_HUGENUMS)
{0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 5, 0, 0};
#else
#if SEXP_USE_RATIOS || SEXP_USE_COMPLEX
@ -927,8 +1065,9 @@ static int sexp_number_types[] =
{0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0};
#endif
#endif
#endif
#define SEXP_NUM_NUMBER_TYPES (4 + SEXP_USE_RATIOS + SEXP_USE_COMPLEX)
#define SEXP_NUM_NUMBER_TYPES (4 + SEXP_USE_RATIOS + SEXP_USE_COMPLEX + SEXP_USE_HUGENUMS)
static int sexp_number_type (sexp a) {
return sexp_pointerp(a) ?
@ -940,6 +1079,16 @@ static int sexp_number_type (sexp a) {
: sexp_fixnump(a);
}
#if SEXP_USE_RATIOS
#define sexp_rat_case(x) case x:
#endif
#if SEXP_USE_COMPLEX
#define sexp_cpx_case(x) case x:
#endif
#if SEXP_USE_HUGENUMS
#define sexp_hug_case(x) case x:
#endif
sexp sexp_add (sexp ctx, sexp a, sexp b) {
sexp_sint_t sum;
int at=sexp_number_type(a), bt=sexp_number_type(b), t;
@ -950,12 +1099,9 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_NOT_RAT:
#endif
#if SEXP_USE_COMPLEX
case SEXP_NUM_NOT_CPX:
#endif
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_FIX:
@ -993,9 +1139,7 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
break;
#endif
#if SEXP_USE_COMPLEX
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_CPX:
#endif
sexp_rat_case(SEXP_NUM_RAT_CPX)
case SEXP_NUM_FLO_CPX:
case SEXP_NUM_FIX_CPX:
case SEXP_NUM_BIG_CPX:
@ -1004,6 +1148,23 @@ sexp sexp_add (sexp ctx, sexp a, sexp b) {
case SEXP_NUM_CPX_CPX:
r = sexp_complex_add(ctx, a, b);
break;
#endif
#if SEXP_USE_HUGENUMS
case SEXP_NUM_FLO_HUG:
r = sexp_infp(a) ? a : b;
break;
case SEXP_NUM_RAT_HUG:
case SEXP_NUM_FIX_HUG:
case SEXP_NUM_BIG_HUG:
r = b;
break;
case SEXP_NUM_CPX_HUG:
b = tmp = sexp_make_complex(ctx, b, SEXP_ZERO);
r = sexp_complex_add(ctx, a, b);
break;
case SEXP_NUM_HUG_HUG:
r = sexp_max_hugenum_magnitude(ctx, a, b);
break;
#endif
}
sexp_gc_release1(ctx);
@ -1021,21 +1182,14 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_NOT_RAT:
#endif
#if SEXP_USE_COMPLEX
case SEXP_NUM_NOT_CPX:
#endif
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_NOT:
#endif
#if SEXP_USE_COMPLEX
case SEXP_NUM_CPX_NOT:
#endif
sexp_rat_case(SEXP_NUM_RAT_NOT)
sexp_cpx_case(SEXP_NUM_CPX_NOT)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b);
break;
case SEXP_NUM_FIX_FIX:
@ -1132,6 +1286,40 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
}
}
break;
#endif
#if SEXP_USE_HUGENUMS
case SEXP_NUM_HUG_FLO:
case SEXP_NUM_HUG_RAT:
case SEXP_NUM_HUG_FIX:
case SEXP_NUM_HUG_BIG:
r = tmp1 = sexp_sub(ctx, b, a);
if (sexp_hugenump(r)) r = sexp_copy_hugenum(ctx, r);
sexp_negate(r);
break;
case SEXP_NUM_FLO_HUG:
if (sexp_infp(a)) {
r = a;
} else {
/* ... FALLTHROUGH ... */
case SEXP_NUM_RAT_HUG:
case SEXP_NUM_FIX_HUG:
case SEXP_NUM_BIG_HUG:
r = sexp_copy_hugenum(ctx, b);
sexp_negate(r);
}
break;
case SEXP_NUM_CPX_HUG:
b = tmp1 = sexp_make_complex(ctx, b, SEXP_ZERO);
r = sexp_complex_sub(ctx, a, b);
break;
case SEXP_NUM_HUG_HUG:
if (sexp_compare_hugenum_magnitude(ctx, a, b, 1) > 0) {
r = a;
} else {
r = tmp1 = sexp_copy_hugenum(ctx, b);
sexp_negate(r);
}
break;
#endif
}
sexp_gc_release2(ctx);
@ -1148,9 +1336,9 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_NOT_RAT:
#endif
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_FIX:
@ -1189,9 +1377,7 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
break;
#endif
#if SEXP_USE_COMPLEX
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_CPX:
#endif
sexp_rat_case(SEXP_NUM_RAT_CPX)
case SEXP_NUM_FLO_CPX:
case SEXP_NUM_FIX_CPX:
case SEXP_NUM_BIG_CPX:
@ -1200,6 +1386,33 @@ sexp sexp_mul (sexp ctx, sexp a, sexp b) {
case SEXP_NUM_CPX_CPX:
r = sexp_complex_mul(ctx, a, b);
break;
#endif
#if SEXP_USE_HUGENUMS
case SEXP_NUM_FLO_HUG:
if (sexp_infp(a)) {
r = sexp_mul(ctx, a, sexp_make_fixnum(sexp_hugenum_sign(b)));
} else {
r = sexp_copy_hugenum(ctx, b);
if (sexp_flonum_value(a) < 0) {
sexp_negate(r);
}
}
break;
case SEXP_NUM_RAT_HUG:
case SEXP_NUM_FIX_HUG:
case SEXP_NUM_BIG_HUG:
r = sexp_copy_hugenum(ctx, b);
if (sexp_negativep(a) < 0) {
sexp_negate(r);
}
break;
case SEXP_NUM_CPX_HUG:
b = tmp = sexp_make_complex(ctx, b, SEXP_ZERO);
r = sexp_complex_add(ctx, a, b);
break;
case SEXP_NUM_HUG_HUG:
r = sexp_max_hugenum_magnitude(ctx, a, b);
break;
#endif
}
sexp_gc_release1(ctx);
@ -1217,15 +1430,13 @@ sexp sexp_div (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_NOT_RAT:
#endif
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_NOT:
#endif
sexp_rat_case(SEXP_NUM_RAT_NOT)
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b);
break;
case SEXP_NUM_FIX_FIX:
@ -1349,15 +1560,16 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
#endif
sexp_rat_case(SEXP_NUM_FLO_RAT)
if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
} else {
@ -1372,16 +1584,12 @@ sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_COMPLEX
case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX:
#if SEXP_USE_RATIOS
case SEXP_NUM_CPX_RAT:
#endif
sexp_rat_case(SEXP_NUM_CPX_RAT)
#endif
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_FLO:
#endif
sexp_rat_case(SEXP_NUM_RAT_FLO)
if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
} else {
@ -1423,15 +1631,16 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_FLO_RAT:
#endif
sexp_rat_case(SEXP_NUM_FLO_RAT)
if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
} else {
@ -1446,16 +1655,12 @@ sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
#if SEXP_USE_COMPLEX
case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO:
case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX:
#if SEXP_USE_RATIOS
case SEXP_NUM_CPX_RAT:
#endif
sexp_rat_case(SEXP_NUM_CPX_RAT)
#endif
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
#if SEXP_USE_RATIOS
case SEXP_NUM_RAT_FLO:
#endif
sexp_rat_case(SEXP_NUM_RAT_FLO)
if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) {
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
} else {
@ -1502,12 +1707,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
sexp_rat_case(SEXP_NUM_NOT_RAT)
sexp_cpx_case(SEXP_NUM_NOT_CPX)
sexp_hug_case(SEXP_NUM_NOT_HUG)
#if SEXP_USE_COMPLEX
case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX:
case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG:
#if SEXP_USE_RATIOS
case SEXP_NUM_CPX_RAT:
#endif
sexp_rat_case(SEXP_NUM_CPX_RAT)
#endif
r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a);
break;

57
eval.c
View file

@ -1308,7 +1308,6 @@ sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sex
}
define_math_op(sexp_exp, exp, sexp_complex_exp)
define_math_op(sexp_log, log, sexp_complex_log)
define_math_op(sexp_sin, sin, sexp_complex_sin)
define_math_op(sexp_cos, cos, sexp_complex_cos)
define_math_op(sexp_tan, tan, sexp_complex_tan)
@ -1381,6 +1380,34 @@ sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
return res;
}
sexp sexp_log_op (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
double d;
sexp_gc_var1(tmp);
if (sexp_flonump(z))
d = sexp_flonum_value(z);
else if (sexp_fixnump(z))
d = (double)sexp_unbox_fixnum(z);
maybe_convert_ratio(z)
maybe_convert_bignum(z)
maybe_convert_complex(z, sexp_complex_log)
#if SEXP_USE_HUGENUMS
else if (sexp_hugenump(z)) {
if (sexp_hugenum_length(z) == 2) {
sexp_gc_preserve1(ctx, tmp);
tmp = sexp_log(ctx, sexp_hugenum_data(z)[0]);
tmp = sexp_mul(ctx, tmp, sexp_hugenum_data(z)[1]);
sexp_gc_release1(ctx);
return tmp;
} else {
return z;
}
}
#endif
else
return sexp_type_exception(ctx, self, SEXP_NUMBER, z);
return sexp_make_flonum(ctx, log(d));
}
#endif /* SEXP_USE_MATH */
#if SEXP_USE_RATIOS || !SEXP_USE_FLONUMS
@ -1403,10 +1430,26 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
#else
long double f, x1, e1;
sexp res;
sexp_gc_var1(res);
#if SEXP_USE_COMPLEX
if (sexp_complexp(x) || sexp_complexp(e))
return sexp_complex_expt(ctx, x, e);
#endif
sexp_gc_preserve1(ctx, res);
#if SEXP_USE_HUGENUMS
if (sexp_hugenump(x)) {
if (sexp_hugenum_length(x) == 2 && (!sexp_hugenump(e) || sexp_hugenum_length(e) <= 2)) {
res = sexp_make_hugenum(ctx, 2);
sexp_hugenum_data(res)[0] = sexp_hugenum_data(x)[0];
sexp_hugenum_data(res)[1] = sexp_mul(ctx, sexp_hugenum_data(x)[1], e);
} else if (sexp_hugenump(e)) {
res = sexp_max_hugenum(ctx, x, e);
} else {
res = x;
}
} else if (sexp_hugenump(e)) {
res = e;
} else
#endif
#if SEXP_USE_BIGNUMS
if (sexp_bignump(e)) { /* bignum exponent needs special handling */
@ -1416,6 +1459,10 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
res = SEXP_ONE; /* 1.0 */
else if (sexp_flonump(x))
res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e)));
#if SEXP_USE_HUGENUMS
else if (sexp_fixnump(x) || sexp_bignump(x))
res = sexp_hugenum2(ctx, x, e);
#endif
else
res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */
} else if (sexp_bignump(x)) {
@ -1429,14 +1476,17 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
#if SEXP_USE_RATIOS
else if (sexp_ratiop(x)) {
if (sexp_fixnump(e)) {
sexp_gc_release1(ctx);
return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e));
} else {
x1 = sexp_ratio_to_double(x);
}
}
#endif
else
else {
sexp_gc_release1(ctx);
return sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
}
if (sexp_fixnump(e))
e1 = sexp_unbox_fixnum(e);
else if (sexp_flonump(e))
@ -1461,6 +1511,7 @@ sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
#if SEXP_USE_BIGNUMS
}
#endif
sexp_gc_release1(ctx);
return res;
#endif /* !SEXP_USE_FLONUMS */
}

5
include/chibi/bignum.h
View file

@ -65,6 +65,11 @@ SEXP_API sexp sexp_complex_asin (sexp ctx, sexp z);
SEXP_API sexp sexp_complex_acos (sexp ctx, sexp z);
SEXP_API sexp sexp_complex_atan (sexp ctx, sexp z);
#endif
#if SEXP_USE_HUGENUMS
SEXP_API sexp sexp_make_hugenum (sexp ctx, sexp_uint_t len);
SEXP_API sexp sexp_hugenum2 (sexp ctx, sexp base, sexp exponent);
SEXP_API sexp sexp_max_hugenum (sexp ctx, sexp a, sexp b);
#endif
#endif /* ! SEXP_BIGNUM_H */

3
include/chibi/eval.h
View file

@ -148,7 +148,8 @@ SEXP_API sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n);
#if SEXP_USE_MATH
SEXP_API sexp sexp_exp(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_log(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_log_op(sexp ctx, sexp self, sexp_sint_t n, sexp z);
#define sexp_log(ctx, z) sexp_log_op(ctx, NULL, 1, z)
SEXP_API sexp sexp_sin(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_cos(sexp ctx, sexp self, sexp_sint_t n, sexp z);
SEXP_API sexp sexp_tan(sexp ctx, sexp self, sexp_sint_t n, sexp z);

24
include/chibi/features.h
View file

@ -146,6 +146,9 @@
/* uncomment this if you don't want imaginary number support */
/* #define SEXP_USE_COMPLEX 0 */
/* uncomment this if you don't want inexact huge number support */
/* #define SEXP_USE_HUGENUMS 0 */
/* uncomment this if you don't want 1## style approximate digits */
/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */
@ -428,6 +431,23 @@
#define SEXP_USE_COMPLEX SEXP_USE_FLONUMS
#endif
#ifndef SEXP_USE_HUGENUMS
#define SEXP_USE_HUGENUMS SEXP_USE_RATIOS
#endif
/* hugenums imply ratios and complex */
#if SEXP_USE_HUGENUMS
#undef SEXP_USE_RATIOS
#define SEXP_USE_RATIOS 1
#undef SEXP_USE_COMPLEX
#define SEXP_USE_COMPLEX 1
#endif
#ifndef SEXP_MAX_BIGNUM_LENGTH
#define SEXP_MAX_BIGNUM_LENGTH (128*1024*1024) /* 128MB */
#endif
/* either of ratios or complex imply bignums and flonums */
#if (SEXP_USE_RATIOS || SEXP_USE_COMPLEX)
#undef SEXP_USE_BIGNUMS
#define SEXP_USE_BIGNUMS 1
@ -462,6 +482,10 @@
#ifndef SEXP_USE_MATH
#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
#endif
#if SEXP_USE_HUGENUMS
#undef SEXP_USE_MATH
#define SEXP_USE_MATH 1
#endif
#ifndef SEXP_USE_ESCAPE_NEWLINE
#define SEXP_USE_ESCAPE_NEWLINE ! SEXP_USE_NO_FEATURES

50
include/chibi/sexp.h
View file

@ -131,6 +131,9 @@ enum sexp_types {
#endif
#if SEXP_USE_COMPLEX
SEXP_COMPLEX,
#endif
#if SEXP_USE_HUGENUMS
SEXP_HUGENUM,
#endif
SEXP_IPORT,
SEXP_OPORT,
@ -350,6 +353,10 @@ struct sexp_struct {
sexp_uint_t length;
sexp_uint_t data[];
} bignum;
struct {
sexp_uint_t length;
sexp data[];
} hugenum;
struct {
sexp numerator, denominator;
} ratio;
@ -648,6 +655,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
#else
#define sexp_complexp(x) 0
#endif
#if SEXP_USE_HUGENUMS
#define sexp_hugenump(x) (sexp_check_tag(x, SEXP_HUGENUM))
#else
#define sexp_hugenump(x) 0
#endif
#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER))
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE))
@ -732,7 +744,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
#if SEXP_USE_FLONUMS
#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x)))
#if SEXP_USE_HUGENUMS
#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x)) || sexp_hugenump(x)
#else
#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x))
#endif
#else
#define _or_integer_flonump(x)
#endif
@ -758,7 +774,11 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#if SEXP_USE_FLONUMS
#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x)))
#if SEXP_USE_RATIOS
#if SEXP_USE_HUGENUMS
#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x) || sexp_ratiop(x) || sexp_hugenump(x))
#else
#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x) || sexp_ratiop(x))
#endif
#else
#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x))
#endif
@ -773,11 +793,18 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_numberp(x) (sexp_realp(x))
#endif
#define sexp_exact_negativep(x) (sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \
: (SEXP_USE_BIGNUMS && sexp_bignump(x)) \
&& (sexp_bignum_sign(x) < 0))
#define sexp_negativep(x) (sexp_exact_negativep(x) || \
(sexp_flonump(x) && sexp_flonum_value(x) < 0))
#define sexp_exact_integer_negativep(x) \
(sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \
: (sexp_bignump(x) && (sexp_bignum_sign(x) < 0)))
#define sexp_exact_negativep(x) \
(sexp_ratiop(x) ? sexp_exact_integer_negativep(sexp_ratio_numerator(x)) \
: sexp_exact_integer_negativep(x))
#define sexp_negativep(x) \
(sexp_flonump(x) ? (sexp_flonum_value(x) < 0) \
: sexp_hugenump(x) ? (sexp_exact_integer_negativep(sexp_hugenum_data(x)[0])) \
: sexp_exact_negativep(x))
#define sexp_positivep(x) (!(sexp_negativep(x)))
#if SEXP_USE_BIGNUMS
@ -801,9 +828,11 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#endif
#define sexp_negate(x) \
if (sexp_flonump(x)) \
if (sexp_flonump(x)) { \
sexp_negate_flonum(x); \
else \
} else if (sexp_hugenump(x)) { \
sexp_negate_exact(sexp_hugenum_data(x)[0]); \
} else \
sexp_negate_exact(x)
#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
@ -915,6 +944,9 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_complex_real(q) (sexp_pred_field(q, complex, sexp_complexp, real))
#define sexp_complex_imag(q) (sexp_pred_field(q, complex, sexp_complexp, imag))
#define sexp_hugenum_length(h) (sexp_pred_field(h, hugenum, sexp_hugenump, length))
#define sexp_hugenum_data(h) (sexp_pred_field(h, hugenum, sexp_hugenump, data))
#define sexp_exception_kind(x) (sexp_field(x, exception, SEXP_EXCEPTION, kind))
#define sexp_exception_message(x) (sexp_field(x, exception, SEXP_EXCEPTION, message))
#define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants))
@ -1342,13 +1374,13 @@ SEXP_API sexp sexp_display_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sex
SEXP_API sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
SEXP_API sexp sexp_read_string (sexp ctx, sexp in, int sentinel);
SEXP_API sexp sexp_read_symbol (sexp ctx, sexp in, int init, int internp);
SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base);
SEXP_API sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp);
#if SEXP_USE_BIGNUMS
SEXP_API sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
signed char sign, sexp_uint_t base);
SEXP_API sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base);
#endif
SEXP_API sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp);
SEXP_API sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp, int exactp);
#if SEXP_USE_COMPLEX
SEXP_API sexp sexp_read_complex_tail(sexp ctx, sexp in, sexp res);
#endif

2
opcodes.c
View file

@ -192,7 +192,7 @@ _FN2OPT(_I(SEXP_OPORT), _I(SEXP_FIXNUM), _I(SEXP_BOOLEAN), "open-output-file-des
_FN2OPT(_I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), "register-optimization!", _I(600), sexp_register_optimization),
#if SEXP_USE_MATH
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp),
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ln", 0, sexp_log),
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "ln", 0, sexp_log_op),
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "sin", 0, sexp_sin),
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "cos", 0, sexp_cos),
_FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "tan", 0, sexp_tan),

162
sexp.c
View file

@ -194,6 +194,9 @@ static struct sexp_type_struct _sexp_type_specs[] = {
#endif
#if SEXP_USE_COMPLEX
{SEXP_COMPLEX, sexp_offsetof(complex, real), 2, 2, 0, 0, sexp_sizeof(complex), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Complex", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
#endif
#if SEXP_USE_HUGENUMS
{SEXP_HUGENUM, sexp_offsetof(hugenum, data), 0, 0, sexp_offsetof(hugenum, length), 1, sexp_sizeof(hugenum), sexp_offsetof(hugenum, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Hugenum", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
#endif
{SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT},
{SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_PORT},
@ -1938,6 +1941,20 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
sexp_write(ctx, sexp_complex_imag(obj), out);
sexp_write_char(ctx, 'i', out);
break;
#endif
#if SEXP_USE_HUGENUMS
case SEXP_HUGENUM:
if (sexp_hugenum_length(obj) == 2 && sexp_hugenum_data(obj)[0] == SEXP_TEN) {
sexp_write_string(ctx, "1e", out);
sexp_write(ctx, sexp_hugenum_data(obj)[1], out);
} else {
sexp_write(ctx, sexp_hugenum_data(obj)[0], out);
for (i=1; i<sexp_hugenum_length(obj); i++) {
sexp_write_string(ctx, "->", out);
sexp_write(ctx, sexp_hugenum_data(obj)[i], out);
}
}
break;
#endif
case SEXP_OPCODE:
sexp_write_string(ctx, "#<opcode ", out);
@ -2130,7 +2147,7 @@ sexp sexp_read_string (sexp ctx, sexp in, int sentinel) {
case 'r': c = '\r'; break;
case 't': c = '\t'; break;
case 'x':
res = sexp_read_number(ctx, in, 16);
res = sexp_read_number(ctx, in, 16, 1);
if (sexp_fixnump(res)) {
c = sexp_read_char(ctx, in);
if (c != ';') {
@ -2244,9 +2261,12 @@ sexp sexp_complex_normalize (sexp cpx) {
sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
int c = sexp_read_char(ctx, in), c2;
#if SEXP_USE_HUGENUMS
int i;
#endif
sexp default_real = SEXP_ZERO;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
sexp_gc_var2(res, tmp);
sexp_gc_preserve2(ctx, res, tmp);
res = SEXP_VOID;
if (c=='i' || c=='I') { /* trailing i, no sign */
trailing_i:
@ -2270,11 +2290,34 @@ sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
default_real = real;
real = (c=='-') ? SEXP_NEG_ONE : SEXP_ONE;
goto trailing_i;
#if SEXP_USE_HUGENUMS
} else if (c=='-' && c2=='>') { /* chained arrow */
if (!sexp_exact_integerp(real)) {
res = sexp_read_error(ctx, "chains can only follow exact integers", real, in);
} else {
tmp = sexp_read_number(ctx, in, 10, 1);
if (real == SEXP_ONE || tmp == SEXP_ONE) {
res = real;
} else if (sexp_hugenump(tmp)) {
res = sexp_make_hugenum(ctx, sexp_hugenum_length(tmp)+1);
sexp_hugenum_data(res)[0] = real;
for (i=0; i<sexp_hugenum_length(tmp); i++)
sexp_hugenum_data(res)[i+1] = sexp_hugenum_data(tmp)[i];
} else if (sexp_exact_integerp(tmp)) {
res = sexp_make_hugenum(ctx, 2);
sexp_hugenum_data(res)[0] = real;
sexp_hugenum_data(res)[1] = tmp;
} else {
res = sexp_exceptionp(tmp) ? tmp
: sexp_read_error(ctx, "invalid chained arrow component", tmp, in);
}
}
#endif
} else {
sexp_push_char(ctx, c2, in);
/* read imaginary part */
if (c=='-') sexp_push_char(ctx, c, in);
res = sexp_read_number(ctx, in, 10);
res = sexp_read_number(ctx, in, 10, 0);
if (sexp_complexp(res)) {
if (sexp_complex_real(res) == SEXP_ZERO)
sexp_complex_real(res) = real;
@ -2289,7 +2332,7 @@ sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
}
}
}
sexp_gc_release1(ctx);
sexp_gc_release2(ctx);
return sexp_complex_normalize(res);
}
@ -2297,7 +2340,7 @@ sexp sexp_read_complex_tail (sexp ctx, sexp in, sexp real) {
sexp sexp_read_polar_tail (sexp ctx, sexp in, sexp magnitude) {
sexp_gc_var2(res, theta);
sexp_gc_preserve2(ctx, res, theta);
theta = sexp_read_number(ctx, in, 10);
theta = sexp_read_number(ctx, in, 10, 0);
if (sexp_exceptionp(theta)) {
res = theta;
} else if (sexp_complexp(theta) || !sexp_numberp(theta)) {
@ -2315,12 +2358,11 @@ sexp sexp_read_polar_tail (sexp ctx, sexp in, sexp magnitude) {
#endif
#endif
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp, int exactp) {
int c, c2;
sexp exponent=SEXP_VOID;
double val=0.0, scale=0.1, e=0.0;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
sexp_gc_var2(res, exponent);
sexp_gc_preserve2(ctx, res, exponent);
for (c=sexp_read_char(ctx, in); sexp_isdigit(c);
c=sexp_read_char(ctx, in), scale*=0.1)
val += digit_value(c)*scale;
@ -2333,9 +2375,9 @@ sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
if (is_precision_indicator(c)) {
c2 = sexp_read_char(ctx, in);
if (c2 != '+') sexp_push_char(ctx, c2, in);
exponent = sexp_read_number(ctx, in, 10);
exponent = sexp_read_number(ctx, in, 10, 1);
if (sexp_exceptionp(exponent)) {
sexp_gc_release1(ctx);
sexp_gc_release2(ctx);
return exponent;
}
#if SEXP_USE_COMPLEX
@ -2345,7 +2387,11 @@ sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
}
#endif
e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent)
: sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0);
: sexp_flonump(exponent) ? sexp_flonum_value(exponent)
#if SEXP_USE_HUGENUMS
: (sexp_bignump(exponent) || sexp_hugenump(exponent)) ? (DBL_MAX_EXP+1)
#endif
: 0.0);
#if SEXP_USE_COMPLEX
if (sexp_complexp(res)) {
if (sexp_complex_real(res) == SEXP_ZERO) {
@ -2353,17 +2399,44 @@ sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
} else {
sexp_complex_real(res) = sexp_make_flonum(ctx, val * pow(10, e));
}
sexp_gc_release1(ctx);
sexp_gc_release2(ctx);
return res;
}
#endif
}
if (e != 0.0) val *= pow(10, e);
#if SEXP_USE_FLONUMS
res = sexp_make_flonum(ctx, val);
#else
res = sexp_make_fixnum((sexp_uint_t)val);
if (e != 0.0) {
#if SEXP_USE_BIGNUMS
if (exactp && (val == trunc(val))) {
res = sexp_make_integer(ctx, (sexp_sint_t)val);
exponent = sexp_expt(ctx, SEXP_TEN, exponent);
res = sexp_mul(ctx, res, exponent);
sexp_gc_release2(ctx);
return res;
} else
#endif
val *= pow(10, e);
}
#if SEXP_USE_HUGENUMS
if (isinf(val)) {
if (sexp_hugenump(exponent)) {
res = sexp_expt(ctx, SEXP_TEN, exponent);
} else {
res = sexp_make_hugenum(ctx, 2);
if (sexp_flonump(exponent)) {
sexp_hugenum_data(res)[1] = sexp_flonum_value(exponent) > SEXP_MAX_FIXNUM ? sexp_double_to_bignum(ctx, sexp_flonum_value(exponent)) : sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(exponent));
} else {
sexp_hugenum_data(res)[1] = exponent;
}
sexp_hugenum_data(res)[0] = SEXP_TEN;
}
} else
#endif
#if SEXP_USE_FLONUMS
if (!exactp)
res = sexp_make_flonum(ctx, val);
else
#endif
res = sexp_make_fixnum((sexp_sint_t)val);
if (!is_precision_indicator(c)) {
#if SEXP_USE_COMPLEX
if (c=='i' || c=='i' || c=='+' || c=='-') {
@ -2377,7 +2450,7 @@ sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
else
sexp_push_char(ctx, c, in);
}
sexp_gc_release1(ctx);
sexp_gc_release2(ctx);
return res;
}
@ -2422,7 +2495,7 @@ sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
}
#endif
sexp sexp_read_number (sexp ctx, sexp in, int base) {
sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp) {
sexp_sint_t val = 0, tmp = -1;
int c, digit, negativep = 0;
#if SEXP_USE_PLACEHOLDER_DIGITS
@ -2467,7 +2540,7 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
whole += sexp_placeholder_digit_value(10)*scale;
if (is_precision_indicator(c)) {
sexp_push_char(ctx, c, in);
return sexp_read_float_tail(ctx, in, whole, negativep);
return sexp_read_float_tail(ctx, in, whole, negativep, exactp);
} else if ((c!=EOF) && !sexp_is_separator(c)) {
return sexp_read_error(ctx, "invalid numeric syntax after placeholders",
sexp_make_character(c), in);
@ -2481,10 +2554,10 @@ sexp sexp_read_number (sexp ctx, sexp in, int base) {
if (base != 10)
return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
if (c!='.') sexp_push_char(ctx, c, in);
return sexp_read_float_tail(ctx, in, val, negativep);
return sexp_read_float_tail(ctx, in, val, negativep, exactp);
} else if (c=='/') {
sexp_gc_preserve2(ctx, res, den);
den = sexp_read_number(ctx, in, base);
den = sexp_read_number(ctx, in, base, 1);
if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
res = (sexp_exceptionp(den)
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
@ -2705,15 +2778,31 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
case '#':
switch (c1=sexp_read_char(ctx, in)) {
case 'b': case 'B':
res = sexp_read_number(ctx, in, 2); break;
res = sexp_read_number(ctx, in, 2, 0); break;
case 'o': case 'O':
res = sexp_read_number(ctx, in, 8); break;
res = sexp_read_number(ctx, in, 8, 0); break;
case 'd': case 'D':
res = sexp_read_number(ctx, in, 10); break;
res = sexp_read_number(ctx, in, 10, 0); break;
case 'x': case 'X':
res = sexp_read_number(ctx, in, 16); break;
res = sexp_read_number(ctx, in, 16, 0); break;
case 'e': case 'E':
res = sexp_read(ctx, in);
if ((c1=sexp_read_char(ctx, in)) == '#') {
switch (c2=sexp_read_char(ctx, in)) {
case 'b': case 'B':
res = sexp_read_number(ctx, in, 2, 1); break;
case 'o': case 'O':
res = sexp_read_number(ctx, in, 8, 1); break;
case 'd': case 'D':
res = sexp_read_number(ctx, in, 10, 1); break;
case 'x': case 'X':
res = sexp_read_number(ctx, in, 16, 1); break;
default:
res = sexp_read_error(ctx, "invalid numeric syntax after #e#", sexp_make_character(c2), in); break;
}
} else {
sexp_push_char(ctx, c1, in);
res = sexp_read_number(ctx, in, 10, 1);
}
#if SEXP_USE_INFINITIES
if (sexp_flonump(res)
&& (isnan(sexp_flonum_value(res)) || isinf(sexp_flonum_value(res))))
@ -2841,7 +2930,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
c2 = sexp_read_char(ctx, in);
sexp_push_char(ctx, c2, in);
if ((c1 == 'x' || c1 == 'X') && (sexp_isxdigit(c2))) {
res = sexp_read_number(ctx, in, 16);
res = sexp_read_number(ctx, in, 16, 1);
if (sexp_fixnump(res) && sexp_unbox_fixnum(res) >= 0 && sexp_unbox_fixnum(res) <= 0x10FFFF)
res = sexp_make_character(sexp_unbox_fixnum(res));
else if (!sexp_exceptionp(res))
@ -2902,7 +2991,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
if (c1 == EOF || sexp_is_separator(c1)) {
res = SEXP_RAWDOT;
} else if (sexp_isdigit(c1)) {
res = sexp_read_float_tail(ctx, in, 0, 0);
res = sexp_read_float_tail(ctx, in, 0, 0, 0);
} else {
res = sexp_read_symbol(ctx, in, '.', 1);
}
@ -2925,7 +3014,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
c2 = sexp_read_char(ctx, in);
if (c2 == '.' || sexp_isdigit(c2)) {
sexp_push_char(ctx, c2, in);
res = sexp_read_number(ctx, in, 10);
res = sexp_read_number(ctx, in, 10, 0);
if ((c1 == '-') && ! sexp_exceptionp(res)) {
#if SEXP_USE_FLONUMS
if (sexp_flonump(res))
@ -2958,6 +3047,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
sexp_negate(sexp_complex_real(res));
}
} else
#endif
#if SEXP_USE_HUGENUMS
if (sexp_hugenump(res)) {
sexp_negate(sexp_hugenum_data(res)[0]);
} else
#endif
res = sexp_fx_mul(res, SEXP_NEG_ONE);
}
@ -3007,7 +3101,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
sexp_push_char(ctx, c1, in);
res = sexp_read_number(ctx, in, 10);
res = sexp_read_number(ctx, in, 10, 0);
break;
default:
res = sexp_read_symbol(ctx, in, c1, 1);
@ -3065,7 +3159,7 @@ sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sex
sexp_read_char(ctx, in);
}
in = ((sexp_string_data(str)[0] == '#') || base == 10 ?
sexp_read(ctx, in) : sexp_read_number(ctx, in, base));
sexp_read(ctx, in) : sexp_read_number(ctx, in, base, 0));
sexp_gc_release1(ctx);
return sexp_numberp(in) ? in : SEXP_FALSE;
}