diff --git a/eval.c b/eval.c index 21c23513..372f0ef7 100644 --- a/eval.c +++ b/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)); diff --git a/include/chibi/config.h b/include/chibi/config.h index 4b9957b7..43625f28 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -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 diff --git a/include/chibi/eval.h b/include/chibi/eval.h index f7340132..0e9dbdf2 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -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, diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7c7cfab3..739b2d29 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -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) diff --git a/init.scm b/init.scm index b3210595..c457e8b9 100644 --- a/init.scm +++ b/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))) diff --git a/opcodes.c b/opcodes.c index 28f2aa2e..79b97313 100644 --- a/opcodes.c +++ b/opcodes.c @@ -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), diff --git a/sexp.c b/sexp.c index 08f10c1d..0f2e9cb3 100644 --- a/sexp.c +++ b/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; }