minor bignum bugfixes

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:
+  case OP_FIXNUMP:
-    _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break;
+    _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 ((f > SEXP_MAX_FIXNUM) || (! sexp_fixnump(x)) || (! sexp_fixnump(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);
 #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));

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

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,

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_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)

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)))

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),

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_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_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_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 sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) {
-  sexp ptr = sexp_alloc_type(ctx, port, SEXP_CPOINTER);
+  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;
 }