mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-06 20:56:38 +02:00
minor bignum bugfixes
This commit is contained in:
Alex Shinn
parent
d0aa8de1e6
commit
ce9bc2edeb
7 changed files with 88 additions and 33 deletions
32
eval.c
32
eval.c
|
|
@ -1531,8 +1531,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
|
||||
case OP_NULLP:
|
||||
_ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
|
||||
case OP_INTEGERP:
|
||||
_ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break;
|
||||
case OP_FIXNUMP:
|
||||
_ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break;
|
||||
case OP_SYMBOLP:
|
||||
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
|
||||
case OP_CHARP:
|
||||
|
|
@ -2101,24 +2101,24 @@ define_math_op(sexp_ceiling, ceil)
|
|||
#endif
|
||||
|
||||
static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
|
||||
double f, x1, e1;
|
||||
long double f, x1, e1;
|
||||
sexp res;
|
||||
#if USE_BIGNUMS
|
||||
if (sexp_bignump(e)) {
|
||||
if (sexp_bignump(e)) { /* bignum exponent needs special handling */
|
||||
if ((x == sexp_make_fixnum(0)) || (x == sexp_make_fixnum(-1)))
|
||||
res = sexp_make_flonum(ctx, pow(0, 0));
|
||||
res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */
|
||||
else if (x == sexp_make_fixnum(1))
|
||||
res = sexp_make_flonum(ctx, sexp_unbox_fixnum(x));
|
||||
res = sexp_make_flonum(ctx, 1); /* 1.0 */
|
||||
else if (sexp_flonump(x))
|
||||
res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e)));
|
||||
else
|
||||
res = sexp_make_flonum(ctx, pow(10.0, 1e100));
|
||||
res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */
|
||||
} else if (sexp_bignump(x)) {
|
||||
res = sexp_bignum_expt(ctx, x, e);
|
||||
} else {
|
||||
#endif
|
||||
if (sexp_fixnump(x))
|
||||
x1 = (double)sexp_unbox_fixnum(x);
|
||||
x1 = sexp_unbox_fixnum(x);
|
||||
#if USE_FLONUMS
|
||||
else if (sexp_flonump(x))
|
||||
x1 = sexp_flonum_value(x);
|
||||
|
|
@ -2126,7 +2126,7 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
|
|||
else
|
||||
return sexp_type_exception(ctx, "not a number", x);
|
||||
if (sexp_fixnump(e))
|
||||
e1 = (double)sexp_unbox_fixnum(e);
|
||||
e1 = sexp_unbox_fixnum(e);
|
||||
#if USE_FLONUMS
|
||||
else if (sexp_flonump(e))
|
||||
e1 = sexp_flonum_value(e);
|
||||
|
|
@ -2135,13 +2135,15 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
|
|||
return sexp_type_exception(ctx, "not a number", e);
|
||||
f = pow(x1, e1);
|
||||
#if USE_FLONUMS
|
||||
if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) {
|
||||
if (sexp_flonump(x) || sexp_flonump(e))
|
||||
res = sexp_make_flonum(ctx, f);
|
||||
#if USE_BIGNUMS
|
||||
else
|
||||
res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e);
|
||||
if ((f > SEXP_MAX_FIXNUM) || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) {
|
||||
#endif
|
||||
#if USE_BIGNUMS
|
||||
if (sexp_fixnump(x) && sexp_fixnump(e))
|
||||
res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e);
|
||||
else
|
||||
#endif
|
||||
#if USE_FLONUMS
|
||||
res = sexp_make_flonum(ctx, f);
|
||||
} else
|
||||
#endif
|
||||
res = sexp_make_fixnum((sexp_sint_t)round(f));
|
||||
|
|
|
|||
|
|
@ -95,6 +95,12 @@
|
|||
/* will not be available by default. */
|
||||
/* #define USE_STRING_STREAMS 0 */
|
||||
|
||||
/* uncomment this to disable automatic closing of ports */
|
||||
/* If enabled, the underlying FILE* for file ports will be */
|
||||
/* automatically closed when they're garbage collected. Doesn't */
|
||||
/* apply to stdin/stdout/stderr. */
|
||||
/* #define USE_AUTOCLOSE_PORTS 0 */
|
||||
|
||||
/* uncomment this to disable stack overflow checks */
|
||||
/* By default stacks are fairly small, so it's good to leave */
|
||||
/* this enabled. */
|
||||
|
|
@ -225,6 +231,10 @@
|
|||
#define USE_STRING_STREAMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_AUTOCLOSE_PORTS
|
||||
#define USE_AUTOCLOSE_PORTS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_CHECK_STACK
|
||||
#define USE_CHECK_STACK 1
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ enum sexp_opcode_names {
|
|||
OP_MAKE_VECTOR,
|
||||
OP_AND,
|
||||
OP_NULLP,
|
||||
OP_INTEGERP,
|
||||
OP_FIXNUMP,
|
||||
OP_SYMBOLP,
|
||||
OP_CHARP,
|
||||
OP_EOFP,
|
||||
|
|
|
|||
|
|
@ -195,7 +195,9 @@ struct sexp_struct {
|
|||
sexp_uint_t data[];
|
||||
} bignum;
|
||||
struct {
|
||||
sexp_uint_t freep, length;
|
||||
void *value;
|
||||
char body[];
|
||||
} cpointer;
|
||||
/* runtime types */
|
||||
struct {
|
||||
|
|
@ -459,18 +461,28 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
|
||||
#if USE_BIGNUMS
|
||||
SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
||||
#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x) _or_integer_flonump(x))
|
||||
#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x))
|
||||
#else
|
||||
#define sexp_make_integer(ctx, x) sexp_make_fixnum(x)
|
||||
#define sexp_integerp(x) (sexp_fixnump(x) _or_integer_flonump(x))
|
||||
#define sexp_exact_integerp(x) sexp_fixnump(x)
|
||||
#endif
|
||||
|
||||
#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x))
|
||||
|
||||
#if USE_FLONUMS
|
||||
#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x)))
|
||||
#else
|
||||
#define sexp_fixnum_to_flonum(ctx, x) (x)
|
||||
#endif
|
||||
|
||||
#if USE_FLONUMS || USE_BIGNUMS
|
||||
#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0]))
|
||||
#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0]))
|
||||
#else
|
||||
#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x))
|
||||
#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x))
|
||||
#endif
|
||||
|
||||
/*************************** field accessors **************************/
|
||||
|
||||
#define sexp_vector_length(x) ((x)->value.vector.length)
|
||||
|
|
@ -509,7 +521,11 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
#define sexp_exception_procedure(p) ((p)->value.exception.procedure)
|
||||
#define sexp_exception_source(p) ((p)->value.exception.source)
|
||||
|
||||
#define sexp_cpointer_value(p) ((p)->value.cpointer.value)
|
||||
#define sexp_cpointer_freep(p) ((p)->value.cpointer.freep)
|
||||
#define sexp_cpointer_length(p) ((p)->value.cpointer.length)
|
||||
#define sexp_cpointer_body(p) ((p)->value.cpointer.body)
|
||||
#define sexp_cpointer_value(p) ((p)->value.cpointer.value)
|
||||
#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p))
|
||||
|
||||
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
|
||||
#define sexp_bytecode_name(x) ((x)->value.bytecode.name)
|
||||
|
|
@ -734,7 +750,7 @@ SEXP_API sexp sexp_intern(sexp ctx, char *str);
|
|||
SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str);
|
||||
SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
|
||||
SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls);
|
||||
SEXP_API sexp sexp_make_cpointer(sexp ctx, void* value);
|
||||
SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, int freep);
|
||||
SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out);
|
||||
SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out);
|
||||
SEXP_API sexp sexp_flush_output(sexp ctx, sexp out);
|
||||
|
|
@ -764,8 +780,16 @@ SEXP_API void sexp_destroy_context(sexp ctx);
|
|||
#endif
|
||||
|
||||
#if USE_TYPE_DEFS
|
||||
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
|
||||
SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
|
||||
SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name);
|
||||
SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj);
|
||||
#define sexp_register_c_type(ctx, name, finalizer) \
|
||||
sexp_register_type(ctx, name, sexp_make_fixnum(0), sexp_make_fixnum(0), \
|
||||
sexp_make_fixnum(0), sexp_make_fixnum(0), \
|
||||
sexp_make_fixnum(0), \
|
||||
sexp_make_fixnum(sexp_sizeof(cpointer)), \
|
||||
sexp_make_fixnum(0), sexp_make_fixnum(0), finalizer)
|
||||
#endif
|
||||
|
||||
#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE)
|
||||
|
|
|
|||
7
init.scm
7
init.scm
|
|
@ -383,7 +383,8 @@
|
|||
(define real? number?)
|
||||
(define exact? fixnum?)
|
||||
(define inexact? flonum?)
|
||||
(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x)))))
|
||||
(define (integer? x)
|
||||
(if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x))))))
|
||||
|
||||
(define (zero? x) (= x 0))
|
||||
(define (positive? x) (> x 0))
|
||||
|
|
@ -523,9 +524,9 @@
|
|||
res)))
|
||||
|
||||
(define (with-output-to-file file thunk)
|
||||
(let ((old-out (current-input-port))
|
||||
(let ((old-out (current-output-port))
|
||||
(tmp-out (open-output-file file)))
|
||||
(current-input-port tmp-out)
|
||||
(current-output-port tmp-out)
|
||||
(let ((res (thunk)))
|
||||
(current-output-port old-out)
|
||||
res)))
|
||||
|
|
|
|||
|
|
@ -52,11 +52,12 @@ _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0),
|
|||
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0),
|
||||
|
|
|
|||
33
sexp.c
33
sexp.c
|
|
@ -53,12 +53,17 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_finalize_port (sexp ctx, sexp port) {
|
||||
#if USE_AUTOCLOSE_PORTS
|
||||
static sexp sexp_finalize_port (sexp ctx, sexp port) {
|
||||
if (sexp_port_openp(port) && sexp_port_stream(port)
|
||||
&& sexp_stringp(sexp_port_name(port)))
|
||||
fclose(sexp_port_stream(port));
|
||||
return SEXP_VOID;
|
||||
}
|
||||
#define SEXP_FINALIZE_PORT sexp_finalize_port
|
||||
#else
|
||||
#define SEXP_FINALIZE_PORT NULL
|
||||
#endif
|
||||
|
||||
#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n,f) \
|
||||
{.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n,f}}}
|
||||
|
|
@ -75,9 +80,9 @@ static struct sexp_struct _sexp_type_specs[] = {
|
|||
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL),
|
||||
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL),
|
||||
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL),
|
||||
_DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer", NULL),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", sexp_finalize_port),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", sexp_finalize_port),
|
||||
_DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT),
|
||||
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL),
|
||||
_DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure", NULL),
|
||||
_DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL),
|
||||
|
|
@ -105,7 +110,8 @@ static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES;
|
|||
static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES;
|
||||
|
||||
sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
|
||||
sexp flo, sexp fls, sexp sb, sexp so, sexp sc) {
|
||||
sexp flo, sexp fls, sexp sb, sexp so, sexp sc,
|
||||
sexp_proc2 f) {
|
||||
struct sexp_struct *type, *new, *tmp;
|
||||
sexp res;
|
||||
sexp_uint_t i, len;
|
||||
|
|
@ -138,6 +144,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
|
|||
sexp_type_size_off(type) = sexp_unbox_fixnum(so);
|
||||
sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
|
||||
sexp_type_name(type) = strdup(sexp_string_data(name));
|
||||
sexp_type_finalize(type) = f;
|
||||
res = sexp_make_fixnum(sexp_type_tag(type));
|
||||
}
|
||||
return res;
|
||||
|
|
@ -151,7 +158,13 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
|
|||
sexp_make_fixnum(offsetof(struct sexp_struct, value)),
|
||||
slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(type_size), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0));
|
||||
sexp_make_fixnum(0), NULL);
|
||||
}
|
||||
|
||||
sexp sexp_finalize_c_type (sexp ctx, sexp obj) {
|
||||
if (sexp_cpointer_freep(obj))
|
||||
free(sexp_cpointer_value(obj));
|
||||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
#else
|
||||
|
|
@ -696,9 +709,13 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) {
|
|||
return vec;
|
||||
}
|
||||
|
||||
sexp sexp_make_cpointer (sexp ctx, void *value) {
|
||||
sexp ptr = sexp_alloc_type(ctx, port, SEXP_CPOINTER);
|
||||
sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) {
|
||||
sexp ptr;
|
||||
if (! value) return SEXP_FALSE;
|
||||
ptr = sexp_alloc_type(ctx, cpointer, typeid);
|
||||
sexp_cpointer_value(ptr) = value;
|
||||
sexp_cpointer_freep(ptr) = freep;
|
||||
sexp_cpointer_length(ptr) = 0;
|
||||
return ptr;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue