From 2005c19ea0c58c2bbeb2fa336ee287a04d36fcee Mon Sep 17 00:00:00 2001 From: Chris Walsh Date: Mon, 15 Feb 2016 21:12:58 -0500 Subject: [PATCH] Added full support for packed images, both for static and dynamic libraries. --- Makefile | 4 +- bignum.c | 26 +- chibi-osx | 1 + eval.c | 37 ++- gc.c | 181 +--------- gc_heap.c | 671 ++++++++++++++++++++++++++++++++++++++ gc_heap.h | 98 ++++++ include/chibi/eval.h | 9 +- include/chibi/features.h | 5 + include/chibi/sexp-huff.h | 4 +- include/chibi/sexp.h | 181 +++++----- lib/chibi/ast.c | 135 ++++---- lib/chibi/disasm.c | 10 +- lib/chibi/heap-stats.c | 12 +- lib/scheme/time.c | 4 +- lib/srfi/18/threads.c | 14 +- lib/srfi/27/rand.c | 2 +- lib/srfi/33/bit.c | 18 +- lib/srfi/39/param.c | 4 +- lib/srfi/69/hash.c | 16 +- main.c | 146 ++------- sexp.c | 163 ++++----- tools/chibi-ffi | 14 +- vm.c | 32 +- 24 files changed, 1163 insertions(+), 624 deletions(-) create mode 100755 chibi-osx create mode 100644 gc_heap.c create mode 100644 gc_heap.h diff --git a/Makefile b/Makefile index 59e63044..51afbb26 100644 --- a/Makefile +++ b/Makefile @@ -115,8 +115,8 @@ sexp-ulimit.o: sexp.c $(BASE_INCLUDES) main.o: main.c $(INCLUDES) $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -SEXP_OBJS = gc.o sexp.o bignum.o -SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o +SEXP_OBJS = gc.o sexp.o bignum.o gc_heap.o +SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o gc_heap.o EVAL_OBJS = opcodes.o vm.o eval.o simplify.o libchibi-sexp$(SO): $(SEXP_OBJS) diff --git a/bignum.c b/bignum.c index eaed306f..fc7e3624 100644 --- a/bignum.c +++ b/bignum.c @@ -43,10 +43,10 @@ sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) { res = sexp_make_bignum(ctx, 1); if (x < 0) { sexp_bignum_sign(res) = -1; - sexp_bignum_data(res)[0] = -x; + sexp_bignum_data(res)[0] = (sexp_uint_t)-x; } else { sexp_bignum_sign(res) = 1; - sexp_bignum_data(res)[0] = x; + sexp_bignum_data(res)[0] = (sexp_uint_t)x; } } return res; @@ -59,7 +59,7 @@ sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) { } else { res = sexp_make_bignum(ctx, 1); sexp_bignum_sign(res) = 1; - sexp_bignum_data(res)[0] = x; + sexp_bignum_data(res)[0] = (sexp_uint_t)x; } return res; } @@ -75,7 +75,7 @@ sexp sexp_double_to_bignum (sexp ctx, double f) { scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE); sign = (f < 0 ? -1 : 1); for (f=fabs(f); f >= 1.0; f=trunc(f/10)) { - tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0); + tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_10s_digit(f), 0); res = sexp_bignum_add(ctx, res, res, tmp); scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0); } @@ -217,8 +217,8 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) { sexp_luint_t n = 0; for (i=len-1; i>=offset; i--) { n = (n << sizeof(sexp_uint_t)*8) + data[i]; - q = n / b; - r = n - (sexp_luint_t)q * b; + q = (sexp_uint_t)(n / b); + r = (sexp_uint_t)(n - (sexp_luint_t)q * b); data[i] = q; n = r; } @@ -235,9 +235,12 @@ sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) { return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q)); } b0 = (b >= 0) ? b : -b; + if (b0 == 0) { + return sexp_xtype_exception(ctx, NULL, "divide by zero", a); + } for (i=len-1; i>=0; i--) { n = (n << sizeof(sexp_uint_t)*8) + data[i]; - q = n / b0; + q = (sexp_uint_t)(n / b0); n -= (sexp_luint_t)q * b0; } return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n); @@ -253,7 +256,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, sexp_bignum_data(res)[0] = init; for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) { digit = digit_value(c); - if ((digit < 0) || (digit >= base)) + if ((digit < 0) || (digit >= (int)base)) break; res = sexp_bignum_fxmul(ctx, res, res, base, 0); res = sexp_bignum_fxadd(ctx, res, digit); @@ -303,6 +306,9 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) { sexp_gc_preserve2(ctx, b, str); b = sexp_copy_bignum(ctx, NULL, a, 0); sexp_bignum_sign(b) = 1; + if (lg_base < 1) { + return sexp_xtype_exception(ctx, NULL, "number base too small", a); + } i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1) / lg_base + 1; str = sexp_make_string(ctx, sexp_make_fixnum(str_len), @@ -563,7 +569,7 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) { } /* flip the sign if we overshot in our estimate */ if (sexp_bignum_sign(a1) != sign) { - sexp_bignum_sign(a1) = -sign; + sexp_bignum_sign(a1) = (char)(-sign); sign *= -1; } } @@ -710,7 +716,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) { for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) { res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0); f = f * 10; - res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f)); + res = sexp_bignum_fxadd(ctx, res, (sexp_uint_t)double_10s_digit(f)); f = f - trunc(f); scale = sexp_mul(ctx, scale, SEXP_TEN); } diff --git a/chibi-osx b/chibi-osx new file mode 100755 index 00000000..aceb1a3c --- /dev/null +++ b/chibi-osx @@ -0,0 +1 @@ +LD_LIBRARY_PATH=.: DYLD_LIBRARY_PATH=.: CHIBI_MODULE_PATH=lib ./chibi-scheme "$@" diff --git a/eval.c b/eval.c index 645e137d..a929ed68 100644 --- a/eval.c +++ b/eval.c @@ -236,6 +236,7 @@ sexp sexp_extend_synclo_env (sexp ctx, sexp env) { sexp_env_renames(e2) = sexp_env_renames(e1); #endif } + if (!e2) { return sexp_global(ctx, SEXP_G_OOM_ERROR); } sexp_env_parent(e2) = sexp_context_env(ctx); } sexp_gc_release1(ctx); @@ -261,7 +262,6 @@ int sexp_param_index (sexp ctx, sexp lambda, sexp name) { sexp ls; int i; while (1) { - i = 0; ls = sexp_lambda_params(lambda); for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) if (sexp_car(ls) == name) @@ -304,7 +304,7 @@ void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) { void sexp_expand_bcode (sexp ctx, sexp_sint_t size) { sexp tmp; - if (sexp_bytecode_length(sexp_context_bc(ctx)) + if ((sexp_sint_t)sexp_bytecode_length(sexp_context_bc(ctx)) < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) { tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); if (sexp_exceptionp(tmp)) { @@ -1766,7 +1766,7 @@ sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, s sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); off = sexp_string_index_to_offset(ctx, self, n, str, i); if (sexp_exceptionp(off)) return off; - if (sexp_unbox_fixnum(off) >= sexp_string_size(str)) + if (sexp_unbox_fixnum(off) >= (sexp_sint_t)sexp_string_size(str)) return sexp_user_exception(ctx, self, "string-ref: index out of range", i); return sexp_string_utf8_ref(ctx, str, off); } @@ -1821,7 +1821,7 @@ sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, s sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); off = sexp_string_index_to_offset(ctx, self, n, str, i); if (sexp_exceptionp(off)) return off; - if (sexp_unbox_fixnum(off) >= sexp_string_size(str)) + if (sexp_unbox_fixnum(off) >= (sexp_sint_t)sexp_string_size(str)) return sexp_user_exception(ctx, self, "string-set!: index out of range", i); sexp_string_utf8_set(ctx, str, off, ch); return SEXP_VOID; @@ -1937,13 +1937,13 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); else { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); - sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); - sexp_opcode_code(res) = sexp_unbox_fixnum(code); - sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); - sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_class(res) = (unsigned char)sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = (unsigned char)sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = (unsigned char)sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = (unsigned char)sexp_unbox_fixnum(flags); sexp_opcode_arg1_type(res) = arg1t; sexp_opcode_arg2_type(res) = arg2t; - sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_inverse(res) = (unsigned char)sexp_unbox_fixnum(invp); sexp_opcode_data(res) = data; sexp_opcode_data2(res) = data2; sexp_opcode_func(res) = func; @@ -1956,7 +1956,7 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, } sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, - int flags, sexp_proc1 f, sexp data) { + int flags, const char *fname, sexp_proc1 f, sexp data) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); #if ! SEXP_USE_EXTENDED_FCALL @@ -1978,6 +1978,9 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, sexp_opcode_name(res) = sexp_c_string(ctx, name, -1); sexp_opcode_data(res) = data; sexp_opcode_func(res) = f; + if (fname) { + sexp_opcode_data2(res) = sexp_c_string(ctx, fname, -1); + } #if SEXP_USE_DL sexp_opcode_dl(res) = sexp_context_dl(ctx); #endif @@ -1986,25 +1989,25 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, } sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, - int flags, sexp_proc1 f, sexp data) { + int flags, const char *fname, sexp_proc1 f, sexp data) { sexp_gc_var2(sym, res); sexp_gc_preserve2(ctx, sym, res); - res = sexp_make_foreign(ctx, name, num_args, flags, f, data); + res = sexp_make_foreign(ctx, name, num_args, flags, fname, f, data); if (!sexp_exceptionp(res)) sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res); sexp_gc_release2(ctx); return res; } -sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, - int num_args, sexp_proc1 f, const char *param) { +sexp sexp_define_foreign_param_aux (sexp ctx, sexp env, const char *name, + int num_args, const char *fname, sexp_proc1 f, const char *param) { sexp res = SEXP_FALSE; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); tmp = sexp_intern(ctx, param, -1); tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE); if (sexp_opcodep(tmp)) - res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, fname, f, tmp); sexp_gc_release1(ctx); return res; } @@ -2311,7 +2314,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; #if SEXP_USE_SIMPLIFY op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0, - (sexp_proc1)sexp_simplify, SEXP_VOID); + NULL, (sexp_proc1)sexp_simplify, SEXP_VOID); tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); #endif @@ -2320,7 +2323,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { /* load init-7.scm */ len = strlen(sexp_init_file); strncpy(init_file, sexp_init_file, len); - init_file[len] = sexp_unbox_fixnum(version) + '0'; + init_file[len] = (char)sexp_unbox_fixnum(version) + '0'; strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix)); init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0; tmp = sexp_load_module_file(ctx, init_file, e); diff --git a/gc.c b/gc.c index 5884a77e..41468142 100644 --- a/gc.c +++ b/gc.c @@ -14,12 +14,6 @@ #include #endif -#ifdef __APPLE__ -#define SEXP_RTLD_DEFAULT RTLD_SELF -#else -#define SEXP_RTLD_DEFAULT RTLD_DEFAULT -#endif - #define SEXP_BANNER(x) ("**************** GC "x"\n") #define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1)) @@ -362,10 +356,13 @@ sexp sexp_finalize (sexp ctx) { for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) ; if ((char*)r == (char*)p) { /* this is a free block, skip it */ - p = (sexp) (((char*)p) + r->size); + p = (sexp) (((char*)p) + (r ? r->size : 0)); continue; } size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); + if (size == 0) { + return SEXP_FALSE; + } if (!sexp_markedp(p)) { t = sexp_object_type(ctx, p); finalizer = sexp_type_finalize(t); @@ -404,7 +401,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) ; if ((char*)r == (char*)p) { /* this is a free block, skip it */ - p = (sexp) (((char*)p) + r->size); + p = (sexp) (((char*)p) + (r ? r->size : 0)); continue; } size = sexp_heap_align(sexp_allocated_bytes(ctx, p)); @@ -606,174 +603,6 @@ void* sexp_alloc (sexp ctx, size_t size) { return res; } -#if ! SEXP_USE_GLOBAL_HEAP - -void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) { - sexp_sint_t i, off, len, freep, loadp; - sexp_free_list q; - sexp p, t, end, *v; -#if SEXP_USE_DL - sexp name; -#endif - freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); - loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP); - - off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap); - heap->data += off; - end = (sexp) (heap->data + heap->size); - - /* adjust the free list */ - heap->free_list = (sexp_free_list) ((char*)heap->free_list + off); - for (q=heap->free_list; q->next; q=q->next) - q->next = (sexp_free_list) ((char*)q->next + off); - - /* adjust data by traversing over the new heap */ - p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size)); - q = heap->free_list; - while (p < end) { - /* find the next free list pointer */ - for ( ; q && ((char*)q < (char*)p); q=q->next) - ; - if ((char*)q == (char*)p) { /* this is a free block, skip it */ - p = (sexp) (((char*)p) + q->size); - } else { - t = (sexp)((char*)(types[sexp_pointer_tag(p)]) - + ((char*)types > (char*)p ? off : 0)); - len = sexp_type_num_slots_of_object(t, p); - v = (sexp*) ((char*)p + sexp_type_field_base(t)); - /* offset any pointers in the _destination_ heap */ - for (i=0; idata + sexp_heap_align(sexp_free_chunk_size)); - q = heap->free_list; - while (p < end) { - /* find the next free list pointer */ - for ( ; q && ((char*)q < (char*)p); q=q->next) - ; - if ((char*)q == (char*)p) { /* this is a free block, skip it */ - p = (sexp) (((char*)p) + q->size); - } else { -#if SEXP_USE_DL - if (sexp_opcodep(p) && sexp_opcode_func(p)) { - name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p); - if (sexp_dlp(sexp_opcode_dl(p))) { - if (!sexp_dl_handle(sexp_opcode_dl(p))) - sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY); - sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name)); - } else { - sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name)); - } - } else -#endif - if (sexp_typep(p)) { - if (sexp_type_finalize(p)) { - /* TODO: handle arbitrary finalizers in images */ -#if SEXP_USE_DL - if (sexp_type_tag(p) == SEXP_DL) - sexp_type_finalize(p) = SEXP_FINALIZE_DL; - else -#endif - sexp_type_finalize(p) = SEXP_FINALIZE_PORT; - } - } - t = types[sexp_pointer_tag(p)]; - p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD)); - } - } - } -} - -sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { - sexp_sint_t off; - sexp_heap to, from = sexp_context_heap(ctx); - - /* validate input, creating a new heap if needed */ - if (from->next) { - return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx); - } else if (! dst || sexp_not(dst)) { - to = sexp_make_heap(from->size, from->max_size, from->chunk_size); - if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR); - dst = (sexp) ((char*)ctx + ((char*)to - (char*)from)); - } else if (! sexp_contextp(dst)) { - return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst); - } else if (sexp_context_heap(dst)->size < from->size) { - return sexp_user_exception(ctx, NULL, "destination context too small", dst); - } else { - to = sexp_context_heap(dst); - } - - /* copy the raw data */ - off = (char*)to - (char*)from; - memcpy(to, from, sexp_heap_pad_size(from->size)); - - /* adjust the pointers */ - sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags); - - return dst; -} - -#endif void sexp_gc_init (void) { #if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC diff --git a/gc_heap.c b/gc_heap.c new file mode 100644 index 00000000..ee840e76 --- /dev/null +++ b/gc_heap.c @@ -0,0 +1,671 @@ +/* gc_heap.h -- heap packing, run-time image generation */ +/* Copyright (c) 2016 Chris Walsh. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "gc_heap.h" + +#define ERR_STR_SIZE 256 +char gc_heap_err_str[ERR_STR_SIZE]; + + +static sexp_uint_t sexp_gc_allocated_bytes (sexp ctx, sexp *types, size_t types_cnt, sexp x) { + sexp_uint_t res; + if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= types_cnt)) + return sexp_heap_align(1); + res = sexp_type_size_of_object(types[sexp_pointer_tag(x)], x) + SEXP_GC_PAD; + return res; +} + + +sexp sexp_gc_heap_walk(sexp ctx, + sexp *t, /* normally set to sexp_context_types(ctx) */ + size_t t_cnt, /* normally set to sexp_context_num_types(ctx) */ + void *user, + sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user), + sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user), + sexp (*sexp_callback)(sexp ctx, sexp s, void *user)) +{ + sexp res = SEXP_FALSE; + if (!ctx || !sexp_contextp(ctx)) return res; + + size_t size = 0; + sexp_heap h = sexp_context_heap(ctx); + while (h) { + + if (heap_callback && (res = heap_callback(ctx, h, user)) != SEXP_TRUE) { + return res; } + + sexp p = sexp_heap_first_block(h); + sexp_free_list q = h->free_list; + sexp end = sexp_heap_end(h); + + while (p < end) { + + /* find the preceding and succeeding free list pointers */ + sexp_free_list r = q->next; + while (r && ((char*)r < (char*)p)) { + q = r; + r = r->next; + } + + if ( (char*)r == (char*)p ) { + if (free_callback && (res = free_callback(ctx, r, user)) != SEXP_TRUE) { + return res; } + size = r ? r->size : 0; + } else { + if (sexp_callback && (res = sexp_callback(ctx, p, user)) != SEXP_TRUE) { + return res; } + size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, t, t_cnt, p)); + if (size == 0) { + strcpy(gc_heap_err_str, "Heap element with a zero size detected"); + goto done; + } + } + p = (sexp)(((char*)p) + size); + } + + h = h->next; + } + res = SEXP_TRUE; +done: + if (!res) res = sexp_user_exception(ctx, NULL, gc_heap_err_str, NULL); + return res; +} + + +struct sexp_remap { + sexp srcp; + sexp dstp; +}; + +struct sexp_remap_state { + size_t index, sexps_count, sexps_size; + sexp p, end, ctx_src, ctx_dst; + sexp_heap heap; + int mode; + struct sexp_remap *remap; +}; + + +static sexp sexp_callback_count(sexp ctx, sexp s, void *user) { + struct sexp_remap_state* state = user; + size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx), + sexp_context_num_types(ctx), s)); + state->sexps_count += 1; + state->sexps_size += size; + return SEXP_TRUE; +} + + +static sexp sexp_callback_remap(sexp ctx, sexp s, void *user) { + struct sexp_remap_state* state = user; + size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx), + sexp_context_num_types(ctx), s)); + memcpy(state->p, s, size); + + state->remap[state->index].srcp = s; + state->remap[state->index].dstp = state->p; + if (ctx == s) state->ctx_dst = state->p; + + state->p = (sexp)(((char*)state->p) + size); + state->index += 1; + + return SEXP_TRUE; +} + + + +/* Return a destination (remapped) pointer for a given source pointer */ +static sexp sexp_gc_heap_pack_src_to_dst(void* adata, sexp srcp) { + + struct sexp_remap_state* state = adata; + int imin = 0; + int imax = state->sexps_count - 1; + + while (imin <= imax) { + int imid = ((imax - imin) / 2) + imin; + sexp midp = state->remap[imid].srcp; + if (midp == srcp) { + return state->remap[imid].dstp; + } else if (midp < srcp) { + imin = imid + 1; + } else { + imax = imid - 1; + } + } + strcpy(gc_heap_err_str, "Source SEXP not found in src->dst mapping"); + return SEXP_FALSE; +} + + +static sexp sexp_adjust_fields(sexp dstp, sexp* types, sexp (* adjust_fn)(void *, sexp), void *adata) { + sexp_tag_t tag = sexp_pointer_tag(dstp); + sexp type_spec = types[tag]; + size_t type_sexp_cnt = sexp_type_num_slots_of_object(type_spec, dstp); + sexp* vec = (sexp*)((char*)dstp + sexp_type_field_base(type_spec)); + int i; + + for (i = 0; i < type_sexp_cnt; i++) { + sexp src = vec[i]; + sexp dst = src; + if (src && sexp_pointerp(src)) { + dst = adjust_fn(adata, src); + if (!sexp_pointerp(dst)) { return dstp; } + } + vec[i] = dst; + } + return SEXP_TRUE; +} + + +static sexp sexp_adjust_bytecode(sexp dstp, sexp (*adjust_fn)(void *, sexp), void *adata) { + sexp res = NULL; + sexp src, dst; + sexp* vec; + int i; + + for (i=0; i < sexp_bytecode_length(dstp); ) { + switch (sexp_bytecode_data(dstp)[i++]) { + case SEXP_OP_FCALL0: case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: case SEXP_OP_CALL: + case SEXP_OP_TAIL_CALL: case SEXP_OP_PUSH: + case SEXP_OP_GLOBAL_REF: case SEXP_OP_GLOBAL_KNOWN_REF: +#if SEXP_USE_GREEN_THREADS + case SEXP_OP_PARAMETER_REF: +#endif +#if SEXP_USE_EXTENDED_FCALL + case SEXP_OP_FCALLN: +#endif + vec = (sexp*)(&(sexp_bytecode_data(dstp)[i])); + src = vec[0]; + if (src && sexp_pointerp(src)) { + dst = adjust_fn(adata, src); + if (!sexp_pointerp(dst)) { res = dst; goto done; } + vec[0] = dst; + } + /* ... FALLTHROUGH ... */ + case SEXP_OP_JUMP: case SEXP_OP_JUMP_UNLESS: + case SEXP_OP_STACK_REF: case SEXP_OP_CLOSURE_REF: + case SEXP_OP_LOCAL_REF: case SEXP_OP_LOCAL_SET: + case SEXP_OP_TYPEP: +#if SEXP_USE_RESERVE_OPCODE + case SEXP_OP_RESERVE: +#endif + i += sizeof(sexp); break; + case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET: + i += 2*sizeof(sexp); break; + case SEXP_OP_MAKE_PROCEDURE: + vec = (sexp*)(&(sexp_bytecode_data(dstp)[i])); + src = vec[2]; + if (src && sexp_pointerp(src)) { + dst = adjust_fn(adata, src); + if (!sexp_pointerp(dst)) { res = dst; goto done; } + vec[2] = dst; + } + i += 3*sizeof(sexp); break; + } + } + res = SEXP_TRUE; +done: + return res; +} + +static sexp sexp_gc_heap_pack_adjust(sexp dstp, sexp* types, struct sexp_remap_state* state) { + sexp res = NULL; + /* Adjust internal types which contain fields of sexp pointer(s) + within in the heap */ + if ((res = sexp_adjust_fields(dstp, types, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) { + goto done; } + + /* Other adjustments - context heap pointer, bytecode pointers */ + if (sexp_contextp(dstp)) { + sexp_context_heap(dstp) = state->heap; + } else if (sexp_bytecodep(dstp)) { + if ((res = sexp_adjust_bytecode(dstp, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) { + goto done; } + } + res = SEXP_TRUE; +done: + return res; +} + + +static sexp_heap sexp_gc_packed_heap_make(size_t packed_size, size_t free_size) { + if (free_size > 0 && free_size < 2*sexp_free_chunk_size) { + free_size = 2*sexp_free_chunk_size; + } + free_size = sexp_heap_align(free_size); + sexp_heap heap = sexp_make_heap(sexp_heap_align(packed_size + free_size + sexp_free_chunk_size + 128), 0, 0); + if (!heap) { + strcpy(gc_heap_err_str, "Could not allocate memory for heap"); + return NULL; + } + sexp base = sexp_heap_first_block(heap); + size_t pad = (char *)base - (char *)heap->data; + heap->size = packed_size + free_size + pad; + heap->free_list->size = 0; + if (free_size == 0) { + heap->free_list->next = NULL; + } else { + heap->free_list->next = (sexp_free_list)((char *)base + packed_size); + heap->free_list->next->next = NULL; + heap->free_list->next->size = free_size; + } + return heap; +} + + +/* Pack the heap. Return a new context with a unified, packed heap. */ +sexp sexp_gc_heap_pack(sexp ctx, sexp_uint_t heap_free_size) { + + sexp res = NULL; + sexp_gc(ctx, NULL); + + struct sexp_remap_state state; + memset(&state, 0, sizeof(struct sexp_remap_state)); + state.ctx_src = ctx; + if ((res = sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx), + &state, NULL, NULL, sexp_callback_count)) != SEXP_TRUE) { + goto done; } + + state.heap = sexp_gc_packed_heap_make(state.sexps_size, heap_free_size); + if (!state.heap) { + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + goto done; } + + state.p = sexp_heap_first_block(state.heap); + state.end = sexp_heap_end(state.heap); + state.index = 0; + state.remap = malloc(sizeof(struct sexp_remap) * state.sexps_count); + if (!state.remap) { + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + goto done; } + + if ((res = sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx), + &state, NULL, NULL, sexp_callback_remap)) != SEXP_TRUE) { + goto done; } + + sexp* types = sexp_context_types(state.ctx_src); + int idx; + for (idx = 0; idx < state.sexps_count; idx++) { + sexp dstp = state.remap[idx].dstp; + if ((res = sexp_gc_heap_pack_adjust(dstp, types, &state)) != SEXP_TRUE) { + goto done; } + } + + res = state.ctx_dst; +done: + if (state.remap) free(state.remap); + return res; +} + + +#define SEXP_IMAGE_MAGIC "\a\achibi\n\0" +#define SEXP_IMAGE_MAJOR_VERSION 1 +#define SEXP_IMAGE_MINOR_VERSION 1 + +struct sexp_image_header_t { + char magic[8]; + short major, minor; + sexp_abi_identifier_t abi; + sexp_uint_t size; + sexp base; + sexp context; +}; + + +sexp sexp_save_image (sexp ctx_in, const char* filename) { + sexp_heap heap = NULL; + sexp res = NULL; + FILE *fp = fopen(filename, "wb"); + if (!fp) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "Could not open image file for writing: %s", filename); + goto done; + } + + /* Save ONLY packed, active SEXPs. No free list structures or padding. */ + sexp ctx = sexp_gc_heap_pack(ctx_in, 0); + if (!ctx || !sexp_contextp(ctx)) { + goto done; + } + heap = sexp_context_heap(ctx); + sexp base = sexp_heap_first_block(heap); + size_t pad = (size_t)((char *)base - (char *)heap->data); + size_t size = heap->size - pad; + + struct sexp_image_header_t header; + memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)); + memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi)); + header.major = SEXP_IMAGE_MAJOR_VERSION; + header.minor = SEXP_IMAGE_MINOR_VERSION; + header.size = size; + header.base = base; + header.context = ctx; + + sexp_gc(ctx, NULL); + if (! (fwrite(&header, sizeof(header), 1, fp) == 1 && + fwrite(base, size, 1, fp) == 1)) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "Error writing image file: %s", filename); + goto done; + } + + res = SEXP_TRUE; +done: + if (fp) fclose(fp); + if (heap) sexp_free_heap(heap); + //if (res != SEXP_TRUE) res = sexp_user_exception(ctx_in, NULL, gc_heap_err_str, NULL); + return res; +} + + + +#if SEXP_USE_DL + +#ifdef __APPLE__ +#define SEXP_RTLD_DEFAULT RTLD_SELF +#else +#define SEXP_RTLD_DEFAULT RTLD_DEFAULT +#endif + +struct load_image_state { + sexp_sint_t offset; + sexp_heap heap; + sexp *types; + size_t types_cnt; +}; + +/* Return a destination (remapped) pointer for a given source pointer */ +static sexp load_image_src_to_dst(void* adata, sexp srcp) { + struct load_image_state* state = adata; + return (sexp)((char *)srcp + state->offset); +} + + +static sexp load_image_callback_p1 (sexp ctx, sexp p, void *user) { + sexp res = NULL; + struct load_image_state* state = user; + + if ((res = sexp_adjust_fields(p, state->types, load_image_src_to_dst, state)) != SEXP_TRUE) { + goto done; } + + if (sexp_contextp(p)) { +#if SEXP_USE_GREEN_THREADS + sexp_context_ip(p) += state->offset; +#endif + sexp_context_last_fp(p) += state->offset; + sexp_stack_top(sexp_context_stack(p)) = 0; + sexp_context_saves(p) = NULL; + sexp_context_heap(p) = state->heap; + + } else if (sexp_bytecodep(p)) { + if ((res = sexp_adjust_bytecode(p, load_image_src_to_dst, state)) != SEXP_TRUE) { + goto done; } + + } else if (sexp_portp(p) && sexp_port_stream(p)) { + sexp_port_stream(p) = 0; + sexp_port_openp(p) = 0; + sexp_freep(p) = 0; + + } else if (sexp_dlp(p)) { + sexp_dl_handle(p) = NULL; + + } + res = SEXP_TRUE; +done: + return res; +} + +static void* load_image_fn(sexp dl, sexp name) { + void *fn = NULL; + char *handle_name = ""; + char *symbol_name = sexp_string_data(name); + if (dl && sexp_dlp(dl)) { + if (!sexp_dl_handle(dl)) { + sexp_dl_handle(dl) = dlopen(sexp_string_data(sexp_dl_file(dl)), + RTLD_LAZY); + if (!sexp_dl_handle(dl)) { + handle_name = sexp_string_data(sexp_dl_file(dl)); + snprintf(gc_heap_err_str, ERR_STR_SIZE, "dlopen failure: %s", + handle_name); + return NULL; + } + } + fn = dlsym(sexp_dl_handle(dl), symbol_name); + } else { + fn = dlsym(SEXP_RTLD_DEFAULT, symbol_name); + } + if (!fn) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, + "dynamic function lookup failure: %s %s", + handle_name, symbol_name); + } + return fn; +} + +static sexp load_image_callback_p2 (sexp ctx, sexp dstp, void *user) { + sexp res = NULL; + sexp name = NULL; + void *fn = NULL; + + if (sexp_opcodep(dstp) && sexp_opcode_func(dstp)) { + if (sexp_opcode_data2(dstp) && sexp_stringp(sexp_opcode_data2(dstp))) { + name = sexp_opcode_data2(dstp); + } else { + name = sexp_opcode_name(dstp); + } + if (!name) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "opcode func field missing function name"); + return SEXP_FALSE; + } + + fn = load_image_fn(sexp_opcode_dl(dstp), name); + if (!fn) { + return SEXP_FALSE; + } + sexp_opcode_func(dstp) = fn; + + } else if (sexp_typep(dstp) && sexp_type_finalize(dstp)) { + name = sexp_type_finalize_name(dstp); + if (!name) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "type finalize field missing function name"); + return SEXP_FALSE; + } + fn = load_image_fn(sexp_type_dl(dstp), name); + if (!fn) { + return SEXP_FALSE; + } + sexp_type_finalize(dstp) = fn; + } + res = SEXP_TRUE; + return res; +} + + +int load_image_header(FILE *fp, struct sexp_image_header_t* header) { + if (!fp || !header) { return 0; } + + if (fread(header, sizeof(struct sexp_image_header_t), 1, fp) != 1) { + strcpy(gc_heap_err_str, "couldn't read image header"); + return 0; + } + if (memcmp(header->magic, SEXP_IMAGE_MAGIC, sizeof(header->magic)) != 0) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "invalid image file magic %s\n", header->magic); + return 0; + } else if (header->major != SEXP_IMAGE_MAJOR_VERSION + || header->major < SEXP_IMAGE_MINOR_VERSION) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported image version: %d.%d\n", + header->major, header->minor); + return 0; + } else if (!sexp_abi_compatible(NULL, header->abi, SEXP_ABI_IDENTIFIER)) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported ABI: %s (expected %s)\n", + header->abi, SEXP_ABI_IDENTIFIER); + return 0; + } + return 1; +} + +char* sexp_load_image_err() { + gc_heap_err_str[ERR_STR_SIZE-1] = 0; + return gc_heap_err_str; +} + +sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) { + sexp res = NULL; + sexp ctx = NULL; + gc_heap_err_str[0] = 0; + + struct load_image_state state; + memset(&state, 0, sizeof(struct load_image_state)); + + FILE *fp = fopen(filename, "rb"); + if (!fp) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't open image file for reading: %s\n", filename); + goto done; + } + + struct sexp_image_header_t header; + if (!load_image_header(fp, &header)) { goto done; } + + state.heap = sexp_gc_packed_heap_make(header.size, heap_free_size); + if (!state.heap) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't malloc heap\n"); + goto done; + } + sexp base = sexp_heap_first_block(state.heap); + + if (fread(base, header.size, 1, fp) != 1) { + snprintf(gc_heap_err_str, ERR_STR_SIZE, "error reading image\n"); + goto done; + } + + /* Adjust pointers in loaded packed heap. */ + + state.offset = (sexp_sint_t)((sexp_sint_t)base - (sexp_sint_t)header.base); + ctx = (sexp)((char *)header.context + state.offset); + sexp_context_heap(ctx) = state.heap; + + /* Type information (specifically, how big types are) is stored as sexps in the + heap. This information is needed to sucessfully walk an arbitrary heap. A + copy of the type array pointers with correct offsets is applied is created outside + of the new heap to be used with the pointer adjustment process. + */ + sexp* ctx_globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + state.offset)); + sexp* ctx_types = sexp_vector_data((sexp)((char*)(ctx_globals[SEXP_G_TYPES]) + state.offset)); + state.types_cnt = sexp_unbox_fixnum(ctx_globals[SEXP_G_NUM_TYPES]); + state.types = malloc(sizeof(sexp) * state.types_cnt); + if (!state.types) goto done; + int i; + for (i = 0; i < state.types_cnt; i++) { + state.types[i] = (sexp)((char *)ctx_types[i] + state.offset); + } + + if (sexp_gc_heap_walk(ctx, state.types, state.types_cnt, + &state, NULL, NULL, load_image_callback_p1) != SEXP_TRUE) { + goto done; } + + /* Second pass to fix code references */ + if (sexp_gc_heap_walk(ctx, state.types, state.types_cnt, + &state, NULL, NULL, load_image_callback_p2) != SEXP_TRUE) { + goto done; } + + if (heap_max_size > SEXP_INITIAL_HEAP_SIZE) { + sexp_context_heap(ctx)->max_size = heap_max_size; + } + + res = ctx; +done: + if (fp) fclose(fp); + if (state.heap && !ctx) free(state.heap); + if (state.types) free(state.types); + return res; +} + +#else + +sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) { + return NULL; +} + +#endif + + + + +/****************** Debugging ************************/ + +#define SEXP_CORE_TYPES_MAX 255 + +struct sexp_stats_entry { + size_t count; + size_t size_all; + size_t size_min; + size_t size_max; +}; + +struct sexp_stats { + struct sexp_stats_entry sexps[SEXP_CORE_TYPES_MAX+1]; + struct sexp_stats_entry heaps; + struct sexp_stats_entry frees; + size_t sexp_count; +}; + +static void sexp_stats_entry_set(struct sexp_stats_entry *entry, size_t value) { + entry->count += 1; + entry->size_all += value; + if (entry->size_min == 0 || value < entry->size_min) entry->size_min = value; + if (value > entry->size_max) entry->size_max = value; +} + +static sexp heap_stats_callback(sexp ctx, sexp_heap h, void *user) { + struct sexp_stats *stats = user; + sexp_stats_entry_set(&(stats->heaps), h->size); + return SEXP_TRUE; +} + +static sexp free_stats_callback(sexp ctx, sexp_free_list f, void *user) { + struct sexp_stats *stats = user; + sexp_stats_entry_set(&(stats->frees), f->size); + return SEXP_TRUE; +} + +static sexp sexp_stats_callback(sexp ctx, sexp s, void *user) { + struct sexp_stats *stats = user; + int tag = sexp_pointer_tag(s); + size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx), + sexp_context_num_types(ctx), s)); + if (tag > SEXP_CORE_TYPES_MAX) tag = SEXP_CORE_TYPES_MAX; + sexp_stats_entry_set(&(stats->sexps[tag]), size); + stats->sexp_count += 1; + return SEXP_TRUE; +} + +void sexp_gc_heap_stats_print(sexp ctx) +{ + if (!ctx || !sexp_contextp(ctx)) return; + + struct sexp_stats stats; + memset(&stats, 0, sizeof(struct sexp_stats)); + sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx), + &stats, heap_stats_callback, free_stats_callback, sexp_stats_callback); + + printf("Heap Stats\n %6zu %7zu\n", + stats.heaps.count, stats.heaps.size_all); + printf("Free Stats\n %6zu %7zu %5zu %5zu\n", + stats.frees.count, stats.frees.size_all, stats.frees.size_min, stats.frees.size_max); + printf("Sexp Stats\n"); + size_t total_count = 0; + size_t total_size = 0; + int i; + for (i = 0; i <= SEXP_CORE_TYPES_MAX; i++) { + if (stats.sexps[i].count == 0) continue; + printf("%3d %6zu %7zu %5zu %5zu\n", i, + stats.sexps[i].count, stats.sexps[i].size_all, stats.sexps[i].size_min, stats.sexps[i].size_max); + total_count += stats.sexps[i].count; + total_size += stats.sexps[i].size_all; + } + printf(" ========================================\n"); + printf(" %6zu %7zu\n", total_count, total_size); +} + + diff --git a/gc_heap.h b/gc_heap.h new file mode 100644 index 00000000..712f126a --- /dev/null +++ b/gc_heap.h @@ -0,0 +1,98 @@ +/* gc_heap.h -- heap packing, run-time image generation */ +/* Copyright (c) 2016 Chris Walsh. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef GC_HEAP_H +#define GC_HEAP_H + +#include "chibi/sexp.h" + +/* Iterate the heap associated with the context argument 'ctx', + calling user provided callbacks for the individual heap elements. + + For each heap found, heap_callback is called. + For each free segment found, free_callback is called. + For each valid sexp found, sexp_callback is called. + + Callbacks are skipped if the associated function + pointer argument is NULL. + + A callback return value of SEXP_TRUE allows the heap walk to + continue normally. Any other value terminates the heap walk + with the callback result being returned. + + The sexp_gc_heap_walk return value of SEXP_TRUE indicates all + elements of the heap were walked normally. Any other return + value indicates an abnormal return condition. +*/ +sexp sexp_gc_heap_walk(sexp ctx, /* a possibly incomplete context */ + sexp *types, /* normally set to sexp_context_types(ctx) */ + size_t types_cnt, /* normally set to sexp_context_num_types(ctx) */ + void *user, /* arbitrary data passed to callbacks */ + sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user), + sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user), + sexp (*sexp_callback)(sexp ctx, sexp s, void *user)); + + +/* Returns a new context which contains a single, packed heap. + + The original ctx or heap are not altered, leaving two copies + of all sexps. For runtime use where you are packing the heap + to make accesses more efficient, the old heap and context should + be discarded after a sucessful call to heap pack; finalizers do + not need to be called since all active objects are in the new heap. + + The input heap_size specifies the amount of free space to allocate + at the end of the packed heap. A heap_size of zero will produce a + single packed heap just large enough to hold all sexps from the + original heap. +*/ +sexp sexp_gc_heap_pack(sexp ctx, sexp_uint_t heap_free_size); + + +/* Creates a new packed heap from the provided context, and saves + the contents of the packed heap to the file named filename. + + If sucessful, SEXP_TRUE is returned. If a problem was encountered + in either creating the packed heap or saving to a file, then either + SEXP_FALSE or an exception is returned. Because of shared code with + sexp_load_image, sexp_load_image_err() can also be used to return the + error condition. + + In all cases, upon completion the temporary packed context is deleted + and the context provided as an argument is not changed. +*/ +sexp sexp_save_image (sexp ctx, const char* filename); + + +/* Loads a previously saved image, and returns the context associated with + that image. If the context could not be loaded, either NULL or an exception + are returned instead. + + A new context is created with the contents of filename loaded into the + heap. The heap_free_size parameter specifies the size of the heap to be + created in addition to the heap image on disk. A size of zero will + result in an initial heap exactly the size of the disk image which will + be expanded with an additional heap when the system requests storage space. + + The return value is either the context of the loaded image, or NULL. In + the case of a NULL context, the function sexp_load_image_err() can be called + to provide a description of the error encountered. An sexp exception cannot be + returned because there is not a valid context in which to put the exception. +*/ +sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size); + + +/* In the case that sexp_load_image() returns NULL, this function will return + a string containing a description of the error condition. +*/ +char* sexp_load_image_err(); + + +/* Debugging tool. Prints a summary of the heap structure to stdout. + */ +void sexp_gc_heap_stats_print(sexp ctx); + + +#endif + diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 3cf7bcea..d1ba5f8f 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -129,7 +129,7 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); -SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); #if SEXP_USE_AUTO_FORCE SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val); @@ -189,10 +189,11 @@ SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch); SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch); #endif -#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) -#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) +SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name, int num_args, const char *fname, sexp_proc1 f, const char *param); -SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param); +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL) +#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p) +#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p) #define sexp_env_key(x) sexp_car(x) #define sexp_env_value(x) sexp_cdr(x) diff --git a/include/chibi/features.h b/include/chibi/features.h index 978a9385..35fa236a 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -743,6 +743,11 @@ #define isinf(x) (isInf(x,1) || isInf(x,-1)) #define isnan(x) isNaN(x) #elif defined(_WIN32) +#define _CRT_SECURE_NO_WARNINGS 1 +#define _CRT_NONSTDC_NO_DEPRECATE 1 +#pragma warning(disable:4146) /* unary minus operator to unsigned type */ +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) #ifdef __MINGW32__ #include #define strcasestr StrStrI diff --git a/include/chibi/sexp-huff.h b/include/chibi/sexp-huff.h index abf6bc9f..093a55e9 100644 --- a/include/chibi/sexp-huff.h +++ b/include/chibi/sexp-huff.h @@ -1,3 +1,4 @@ +static struct sexp_huff_entry huff_table[] = { {12, 0x0C00}, /* '\x00' */ {15, 0x0000}, /* '\x01' */ {15, 0x4000}, /* '\x02' */ @@ -125,4 +126,5 @@ {14, 0x0E00}, /* '|' */ {14, 0x2E00}, /* '}' */ {14, 0x1E00}, /* '~' */ - {14, 0x3E00}, /* '\x7f' */ + {14, 0x3E00} /* '\x7f' */ +}; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index cbda4c92..2bc23fe0 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -324,7 +324,7 @@ struct sexp_type_struct { unsigned short size_scale; short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra; short depth; - sexp name, cpl, slots, getters, setters, id, print, dl; + sexp name, cpl, slots, getters, setters, id, print, dl, finalize_name; sexp_proc2 finalize; }; @@ -1234,6 +1234,7 @@ SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE]; #define sexp_type_getters(x) (sexp_field(x, type, SEXP_TYPE, getters)) #define sexp_type_setters(x) (sexp_field(x, type, SEXP_TYPE, setters)) #define sexp_type_finalize(x) (sexp_field(x, type, SEXP_TYPE, finalize)) +#define sexp_type_finalize_name(x) (sexp_field(x, type, SEXP_TYPE, finalize_name)) #define sexp_type_print(x) (sexp_field(x, type, SEXP_TYPE, print)) #define sexp_type_dl(x) (sexp_field(x, type, SEXP_TYPE, dl)) #define sexp_type_id(x) (sexp_field(x, type, SEXP_TYPE, id)) @@ -1380,17 +1381,23 @@ SEXP_API int sexp_buffered_flush (sexp ctx, sexp p, int forcep); #if SEXP_USE_AUTOCLOSE_PORTS #define SEXP_FINALIZE_PORT sexp_finalize_port +#define SEXP_FINALIZE_PORTN (sexp)"sexp_finalize_port" #define SEXP_FINALIZE_FILENO sexp_finalize_fileno +#define SEXP_FINALIZE_FILENON (sexp)"sexp_finalize_fileno" #else #define SEXP_FINALIZE_PORT NULL +#define SEXP_FINALIZE_PORTN NULL #define SEXP_FINALIZE_FILENO NULL +#define SEXP_FINALIZE_FILENON NULL #endif #if SEXP_USE_DL sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl); #define SEXP_FINALIZE_DL sexp_finalize_dl +#define SEXP_FINALIZE_DLN (sexp)"sexp_finalize_dl" #else #define SEXP_FINALIZE_DL NULL +#define SEXP_FINALIZE_DLN NULL #endif #if SEXP_USE_TRACK_ALLOC_SOURCE @@ -1485,7 +1492,7 @@ SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x); SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y); SEXP_API sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args); SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args); -SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); SEXP_API void sexp_init(void); #if SEXP_USE_UTF8_STRINGS @@ -1559,7 +1566,7 @@ SEXP_API sexp sexp_finalize (sexp ctx); #define sexp_destroy_context(ctx) #else SEXP_API void sexp_free_heap (sexp_heap heap); -SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_destroy_context (sexp ctx); SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); #endif @@ -1576,7 +1583,7 @@ SEXP_API int sexp_valid_object_p(sexp ctx, sexp x); #endif #if SEXP_USE_TYPE_DEFS -SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, const char*, sexp_proc2); SEXP_API sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots); SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj); #define sexp_register_c_type(ctx, name, finalizer) \ @@ -1585,7 +1592,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj sexp_make_fixnum(sexp_sizeof(cpointer)), \ SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL, \ - (sexp_proc2)finalizer) + #finalizer, (sexp_proc2)finalizer) #endif #define sexp_current_input_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE)) @@ -1630,7 +1637,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp); #define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx, NULL, 1, out) #define sexp_expt(ctx, a, b) sexp_expt_op(ctx, NULL, 2, a, b) #define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx, NULL, 3, a, b, c) -#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, sn, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, sn, s) #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx, NULL, 2, a, b) #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx, NULL, 2, a, b) #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx, NULL, 3, a, b, c) @@ -1639,87 +1646,87 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp); #define sexp_make_fileno(ctx, fd, no_closep) sexp_make_fileno_op(ctx, NULL, 2, fd, no_closep) enum sexp_opcode_names { - SEXP_OP_NOOP, - SEXP_OP_RAISE, - SEXP_OP_RESUMECC, - SEXP_OP_CALLCC, - SEXP_OP_APPLY1, - SEXP_OP_TAIL_CALL, - SEXP_OP_CALL, - SEXP_OP_FCALL0, - SEXP_OP_FCALL1, - SEXP_OP_FCALL2, - SEXP_OP_FCALL3, - SEXP_OP_FCALL4, - SEXP_OP_FCALLN, - SEXP_OP_JUMP_UNLESS, - SEXP_OP_JUMP, - SEXP_OP_PUSH, - SEXP_OP_RESERVE, - SEXP_OP_DROP, - SEXP_OP_GLOBAL_REF, - SEXP_OP_GLOBAL_KNOWN_REF, - SEXP_OP_PARAMETER_REF, - SEXP_OP_STACK_REF, - SEXP_OP_LOCAL_REF, - SEXP_OP_LOCAL_SET, - SEXP_OP_CLOSURE_REF, - SEXP_OP_CLOSURE_VARS, - SEXP_OP_VECTOR_REF, - SEXP_OP_VECTOR_SET, - SEXP_OP_VECTOR_LENGTH, - SEXP_OP_BYTES_REF, - SEXP_OP_BYTES_SET, - SEXP_OP_BYTES_LENGTH, - SEXP_OP_STRING_REF, - SEXP_OP_STRING_SET, - SEXP_OP_STRING_LENGTH, - SEXP_OP_STRING_CURSOR_NEXT, - SEXP_OP_STRING_CURSOR_PREV, - SEXP_OP_STRING_SIZE, - SEXP_OP_MAKE_PROCEDURE, - SEXP_OP_MAKE_VECTOR, - SEXP_OP_MAKE_EXCEPTION, - SEXP_OP_AND, - SEXP_OP_NULLP, - SEXP_OP_FIXNUMP, - SEXP_OP_SYMBOLP, - SEXP_OP_CHARP, - SEXP_OP_EOFP, - SEXP_OP_TYPEP, - SEXP_OP_MAKE, - SEXP_OP_SLOT_REF, - SEXP_OP_SLOT_SET, - SEXP_OP_ISA, - SEXP_OP_SLOTN_REF, - SEXP_OP_SLOTN_SET, - SEXP_OP_CAR, - SEXP_OP_CDR, - SEXP_OP_SET_CAR, - SEXP_OP_SET_CDR, - SEXP_OP_CONS, - SEXP_OP_ADD, - SEXP_OP_SUB, - SEXP_OP_MUL, - SEXP_OP_DIV, - SEXP_OP_QUOTIENT, - SEXP_OP_REMAINDER, - SEXP_OP_LT, - SEXP_OP_LE, - SEXP_OP_EQN, - SEXP_OP_EQ, - SEXP_OP_CHAR2INT, - SEXP_OP_INT2CHAR, - SEXP_OP_CHAR_UPCASE, - SEXP_OP_CHAR_DOWNCASE, - SEXP_OP_WRITE_CHAR, - SEXP_OP_WRITE_STRING, - SEXP_OP_READ_CHAR, - SEXP_OP_PEEK_CHAR, - SEXP_OP_YIELD, - SEXP_OP_FORCE, - SEXP_OP_RET, - SEXP_OP_DONE, + /* 0 00 */ SEXP_OP_NOOP, + /* 1 01 */ SEXP_OP_RAISE, + /* 2 02 */ SEXP_OP_RESUMECC, + /* 3 03 */ SEXP_OP_CALLCC, + /* 4 04 */ SEXP_OP_APPLY1, + /* 5 05 */ SEXP_OP_TAIL_CALL, + /* 6 06 */ SEXP_OP_CALL, + /* 7 07 */ SEXP_OP_FCALL0, + /* 8 08 */ SEXP_OP_FCALL1, + /* 9 09 */ SEXP_OP_FCALL2, + /* 10 0A */ SEXP_OP_FCALL3, + /* 11 0B */ SEXP_OP_FCALL4, + /* 12 0C */ SEXP_OP_FCALLN, + /* 13 0D */ SEXP_OP_JUMP_UNLESS, + /* 14 0E */ SEXP_OP_JUMP, + /* 15 0F */ SEXP_OP_PUSH, + /* 16 10 */ SEXP_OP_RESERVE, + /* 17 11 */ SEXP_OP_DROP, + /* 18 12 */ SEXP_OP_GLOBAL_REF, + /* 19 13 */ SEXP_OP_GLOBAL_KNOWN_REF, + /* 20 14 */ SEXP_OP_PARAMETER_REF, + /* 21 15 */ SEXP_OP_STACK_REF, + /* 22 16 */ SEXP_OP_LOCAL_REF, + /* 23 17 */ SEXP_OP_LOCAL_SET, + /* 24 18 */ SEXP_OP_CLOSURE_REF, + /* 25 19 */ SEXP_OP_CLOSURE_VARS, + /* 26 1A */ SEXP_OP_VECTOR_REF, + /* 27 1B */ SEXP_OP_VECTOR_SET, + /* 28 1C */ SEXP_OP_VECTOR_LENGTH, + /* 29 1D */ SEXP_OP_BYTES_REF, + /* 30 1E */ SEXP_OP_BYTES_SET, + /* 31 1F */ SEXP_OP_BYTES_LENGTH, + /* 32 20 */ SEXP_OP_STRING_REF, + /* 33 21 */ SEXP_OP_STRING_SET, + /* 34 22 */ SEXP_OP_STRING_LENGTH, + /* 35 23 */ SEXP_OP_STRING_CURSOR_NEXT, + /* 36 24 */ SEXP_OP_STRING_CURSOR_PREV, + /* 37 25 */ SEXP_OP_STRING_SIZE, + /* 38 26 */ SEXP_OP_MAKE_PROCEDURE, + /* 39 27 */ SEXP_OP_MAKE_VECTOR, + /* 40 28 */ SEXP_OP_MAKE_EXCEPTION, + /* 41 29 */ SEXP_OP_AND, + /* 42 2A */ SEXP_OP_NULLP, + /* 43 2B */ SEXP_OP_FIXNUMP, + /* 44 2C */ SEXP_OP_SYMBOLP, + /* 45 2D */ SEXP_OP_CHARP, + /* 46 2E */ SEXP_OP_EOFP, + /* 47 2F */ SEXP_OP_TYPEP, + /* 48 30 */ SEXP_OP_MAKE, + /* 49 31 */ SEXP_OP_SLOT_REF, + /* 50 32 */ SEXP_OP_SLOT_SET, + /* 51 33 */ SEXP_OP_ISA, + /* 52 34 */ SEXP_OP_SLOTN_REF, + /* 53 35 */ SEXP_OP_SLOTN_SET, + /* 54 36 */ SEXP_OP_CAR, + /* 55 37 */ SEXP_OP_CDR, + /* 56 38 */ SEXP_OP_SET_CAR, + /* 57 39 */ SEXP_OP_SET_CDR, + /* 58 3A */ SEXP_OP_CONS, + /* 59 3B */ SEXP_OP_ADD, + /* 60 3C */ SEXP_OP_SUB, + /* 61 3D */ SEXP_OP_MUL, + /* 62 3E */ SEXP_OP_DIV, + /* 63 3F */ SEXP_OP_QUOTIENT, + /* 64 40 */ SEXP_OP_REMAINDER, + /* 65 41 */ SEXP_OP_LT, + /* 66 42 */ SEXP_OP_LE, + /* 67 43 */ SEXP_OP_EQN, + /* 68 44 */ SEXP_OP_EQ, + /* 69 45 */ SEXP_OP_CHAR2INT, + /* 70 46 */ SEXP_OP_INT2CHAR, + /* 71 47 */ SEXP_OP_CHAR_UPCASE, + /* 72 48 */ SEXP_OP_CHAR_DOWNCASE, + /* 73 49 */ SEXP_OP_WRITE_CHAR, + /* 74 4A */ SEXP_OP_WRITE_STRING, + /* 75 4B */ SEXP_OP_READ_CHAR, + /* 76 4C */ SEXP_OP_PEEK_CHAR, + /* 77 4D */ SEXP_OP_YIELD, + /* 78 4E */ SEXP_OP_FORCE, + /* 79 4F */ SEXP_OP_RET, + /* 80 50 */ SEXP_OP_DONE, SEXP_OP_NUM_OPCODES }; diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 63bd8d9b..60a00edd 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -8,6 +8,23 @@ #include #endif +#ifdef _WIN32 +int setenv(const char *name, const char *value, int overwrite) +{ + int errcode = 0; + if (!overwrite) { + size_t envsize = 0; + errcode = getenv_s(&envsize, NULL, 0, name); + if (errcode || envsize) return errcode; + } + return _putenv_s(name, value); +} +int unsetenv(const char *name) +{ + return setenv(name, "", 1); +} +#endif + #if ! SEXP_USE_BOEHM extern sexp sexp_gc (sexp ctx, size_t *sum_freed); #endif @@ -40,7 +57,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, sexp_gc_release2(ctx); } -static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) { +sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) { sexp cell; sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); cell = sexp_env_cell(ctx, env, id, 0); @@ -56,27 +73,27 @@ static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sex return cell ? cell : SEXP_FALSE; } -static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { +sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); return sexp_procedure_code(proc); } -static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { +sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); return sexp_procedure_vars(proc); } -static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { +sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); return sexp_make_fixnum(sexp_procedure_num_args(proc)); } -static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { +sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); return sexp_make_boolean(sexp_procedure_variadic_p(proc)); } -static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) { if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); else if (! sexp_opcode_name(op)) @@ -103,7 +120,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { return res; } -static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp res; if (!op) return sexp_type_by_index(ctx, SEXP_OBJECT); @@ -117,7 +134,7 @@ static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp o return sexp_translate_opcode_type(ctx, res); } -static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) { +sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) { sexp res; int p = sexp_unbox_fixnum(k); if (! sexp_opcodep(op)) @@ -136,7 +153,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp default: res = sexp_opcode_arg3_type(op); if (res && sexp_vectorp(res)) { - if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + if (sexp_vector_length(res) > (unsigned)(sexp_unbox_fixnum(k)-2)) res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); else res = sexp_type_by_index(ctx, SEXP_OBJECT); @@ -146,17 +163,17 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp return sexp_translate_opcode_type(ctx, res); } -static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); return sexp_make_fixnum(sexp_opcode_class(op)); } -static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); return sexp_make_fixnum(sexp_opcode_code(op)); } -static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp data; sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); data = sexp_opcode_data(op); @@ -167,29 +184,29 @@ static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data; } -static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); return sexp_make_fixnum(sexp_opcode_num_args(op)); } -static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) { +sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) { sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); return sexp_make_boolean(sexp_opcode_variadic_p(op)); } -static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) { +sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) { sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p); return sexp_make_fixnum(sexp_port_line(p)); } -static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) { +sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) { sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); sexp_port_line(p) = sexp_unbox_fixnum(i); return SEXP_VOID; } -static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) { if (!x) return sexp_type_by_index(ctx, SEXP_OBJECT); if (sexp_pointerp(x)) @@ -212,43 +229,43 @@ static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return sexp_type_by_index(ctx, SEXP_OBJECT); } -static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) { +sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1); if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2); sexp_env_parent(e1) = e2; return SEXP_VOID; } -static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { +sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE; } -static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) { +sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam); sexp_env_lambda(e) = lam; return SEXP_VOID; } -static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { +sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); return sexp_make_boolean(sexp_env_syntactic_p(e)); } -static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) { +sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); sexp_env_syntactic_p(e) = sexp_truep(synp); return SEXP_VOID; } -static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { +sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); return sexp_env_cell_define(ctx, env, name, value, NULL); } -static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { +sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { sexp_gc_var1(tmp); sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); @@ -258,38 +275,38 @@ static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp return SEXP_VOID; } -static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) { +sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) { sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c); return sexp_make_fixnum(sexp_core_code(c)); } -static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { +sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_type_name(t); } -static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { +sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_type_cpl(t); } -static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { +sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_type_slots(t); } -static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { +sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t)) : sexp_make_fixnum(sexp_type_field_eq_len_base(t)); } -static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { +sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE; } -static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp t; if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) return SEXP_ZERO; @@ -297,7 +314,7 @@ static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return sexp_make_fixnum(sexp_type_size_of_object(t, x)); } -static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) { +sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) { sexp x = (sexp)sexp_unbox_fixnum(i); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); if (!x || sexp_pointerp(x)) @@ -305,11 +322,11 @@ static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp return x; } -static sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return sexp_make_integer(ctx, (sexp_uint_t)x); } -static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) { +sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) { sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); sexp_lambda_name(res) = name; sexp_lambda_params(res) = params; @@ -323,7 +340,7 @@ static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, return res; } -static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) { +sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) { sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); sexp_lambda_name(res) = sexp_lambda_name(lambda); sexp_lambda_params(res) = sexp_lambda_params(lambda); @@ -337,21 +354,21 @@ static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) { return res; } -static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) { +sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) { sexp res = sexp_alloc_type(ctx, set, SEXP_SET); sexp_set_var(res) = var; sexp_set_value(res) = value; return res; } -static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) { +sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) { sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); sexp_ref_name(res) = name; sexp_ref_cell(res) = cell; return res; } -static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) { +sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) { sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); sexp_cnd_test(res) = test; sexp_cnd_pass(res) = pass; @@ -359,26 +376,26 @@ static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sex return res; } -static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) { +sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) { sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ); sexp_seq_ls(res) = ls; return res; } -static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) { +sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) { sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); sexp_lit_value(res) = value; return res; } -static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) { +sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) { sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO); sexp_macro_proc(res) = proc; sexp_macro_env(res) = env; return res; } -static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) { +sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { ctx2 = sexp_make_child_context(ctx, NULL); @@ -387,12 +404,12 @@ static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) return sexp_analyze(ctx2, x); } -static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) { +sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) { sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); return sexp_extend_env(ctx, env, vars, value); } -static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp_gc_var2(ls, res); sexp_gc_preserve2(ctx, ls, res); res = x; @@ -404,7 +421,7 @@ static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return res; } -static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) { +sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) { size_t sum_freed=0; #if SEXP_USE_BOEHM GC_gcollect(); @@ -414,16 +431,16 @@ static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) { return sexp_make_unsigned_integer(ctx, sum_freed); } -static sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) { +sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) { return sexp_make_unsigned_integer(ctx, sexp_context_gc_count(ctx)); } -static sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) { +sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) { return sexp_make_unsigned_integer(ctx, sexp_context_gc_usecs(ctx)); } #if SEXP_USE_GREEN_THREADS -static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) { +sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) { sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P); sexp_global(ctx, SEXP_G_ATOMIC_P) = new_val; return res; @@ -431,11 +448,11 @@ static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) { #endif sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) { - sexp ls; sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); res = SEXP_NULL; #if SEXP_USE_GREEN_THREADS + sexp ls; for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_push(ctx, res, sexp_car(ls)); for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -446,7 +463,7 @@ sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) { return res; } -static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { +sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { const char *res; sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y); @@ -454,7 +471,7 @@ static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, se return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE; } -static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) { +sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) { unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p; sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst), start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send); @@ -465,9 +482,9 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send); if (from < 0 || from > to) return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom); - if (start < 0 || start > sexp_string_size(src)) + if (start < 0 || start > (sexp_sint_t)sexp_string_size(src)) return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart); - if (end < start || end > sexp_string_size(src)) + if (end < start || end > (sexp_sint_t)sexp_string_size(src)) return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send); pfrom = (unsigned char*)sexp_string_data(dst) + from; pto = (unsigned char*)sexp_string_data(dst) + to; @@ -485,7 +502,7 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src)); } -static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { +sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { #ifdef PLAN9 return SEXP_FALSE; #else @@ -493,7 +510,7 @@ static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { #endif } -static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) { #ifdef PLAN9 return SEXP_FALSE; #else @@ -508,22 +525,22 @@ static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) { #endif } -static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) { return sexp_free_vars(ctx, x, SEXP_NULL); } -static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) { +sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) { sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value); return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1)); } -static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) { +sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) { sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); return sexp_make_boolean(unsetenv(sexp_string_data(name))); } -static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) { +sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) { sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value); sexp_exception_message(res) = SEXP_TRAMPOLINE; return res; diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index f0c5a293..de61b04e 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -80,12 +80,12 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { /* build a table of labels that are jumped to */ labels = (sexp_sint_t*)calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t)); ip = sexp_bytecode_data(bc); - while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) { + while (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc)) { switch (*ip++) { case SEXP_OP_JUMP: case SEXP_OP_JUMP_UNLESS: off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0]; - if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0) + if (off >= 0 && off < (int)sexp_bytecode_length(bc) && labels[off] == 0) labels[off] = label++; case SEXP_OP_CALL: case SEXP_OP_CLOSURE_REF: @@ -134,7 +134,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { == sexp_unbox_fixnum( sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) { src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off))); - src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1; + src_off = src_off < (sexp_sint_t)sexp_vector_length(src)-1 ? src_off + 1 : -1; } else { src_here = NULL; } @@ -163,7 +163,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_JUMP_UNLESS: sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0]; - if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) { + if (off >= 0 && off < (sexp_sint_t)sexp_bytecode_length(bc) && labels[off] > 0) { sexp_write_string(ctx, " L", out); sexp_write_integer(ctx, labels[off], out); } @@ -224,7 +224,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { && (depth < SEXP_DISASM_MAX_DEPTH) && tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp))) disasm(ctx, self, tmp, out, depth+1); - if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + if (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc)) goto loop; free(labels); diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 7ed40974..1c229d93 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -49,12 +49,12 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { sexp_write_char(ctx, ')', out); } else if (sexp_vectorp(x)) { sexp_write_string(ctx, "#(", out); - for (i=0; i0) sexp_write_char(ctx, ' ', out); sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); } - if (i> 27]; } -static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) { +sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) { int allsigs, restsigs, signum; if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) { return SEXP_FALSE; @@ -345,7 +345,7 @@ static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) { } } -static sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) { +sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) { sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum); return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum); } @@ -358,7 +358,7 @@ static sexp sexp_make_pollfds (sexp ctx) { return res; } -static sexp sexp_free_pollfds (sexp ctx, sexp self, sexp_sint_t n, sexp pollfds) { +sexp sexp_free_pollfds (sexp ctx, sexp self, sexp_sint_t n, sexp pollfds) { if (sexp_pollfds_fds(pollfds)) { free(sexp_pollfds_fds(pollfds)); sexp_pollfds_fds(pollfds) = NULL; @@ -397,7 +397,7 @@ static sexp sexp_insert_pollfd (sexp ctx, int fd, int events) { } /* block the current thread on the specified port */ -static sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd, sexp timeout) { +sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd, sexp timeout) { int fd; /* register the fd */ if (sexp_portp(portorfd)) @@ -653,7 +653,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds), SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, - SEXP_ZERO, SEXP_ZERO, NULL, + SEXP_ZERO, SEXP_ZERO, NULL, "sexp_free_pollfds", (sexp_proc2)sexp_free_pollfds); if (sexp_typep(t)) { sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID) = sexp_make_fixnum(sexp_type_tag(t)); @@ -681,9 +681,9 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) - = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); + = sexp_make_foreign(ctx, "scheduler", 1, 0, "sexp_scheduler", (sexp_proc1)sexp_scheduler, SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_BLOCKER) - = sexp_make_foreign(ctx, "blocker", 2, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE); + = sexp_make_foreign(ctx, "blocker", 2, 0, "sexp_blocker", (sexp_proc1)sexp_blocker, SEXP_FALSE); /* remember the env to lookup the runner later */ sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env; diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 678ecbfc..ed64d63d 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -212,7 +212,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_make_fixnum(sexp_offsetof_slot0), ONE, ONE, ZERO, ZERO, sexp_make_fixnum(sexp_sizeof_random), ZERO, - ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL); + ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL, NULL); if (sexp_exceptionp(op)) return op; rs_type_id = sexp_type_tag(op); diff --git a/lib/srfi/33/bit.c b/lib/srfi/33/bit.c index 51372f1f..be4b9fe1 100644 --- a/lib/srfi/33/bit.c +++ b/lib/srfi/33/bit.c @@ -45,7 +45,7 @@ static sexp sexp_fixnum_to_twos_complement (sexp ctx, sexp x, int len) { return res; } -static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { +sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { #if SEXP_USE_BIGNUMS sexp_sint_t len, i; #endif @@ -82,7 +82,7 @@ static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { } } -static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { +sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { sexp res; #if SEXP_USE_BIGNUMS sexp_sint_t len, i; @@ -122,7 +122,7 @@ static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { return sexp_bignum_normalize(res); } -static sexp sexp_bit_xor (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { +sexp sexp_bit_xor (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { sexp res; #if SEXP_USE_BIGNUMS sexp_sint_t len, i; @@ -172,7 +172,7 @@ static int log2i(sexp_uint_t v) { /* should probably split into left and right shifts, that's a better */ /* interface anyway */ -static sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) { +sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) { sexp_uint_t tmp; sexp_sint_t c; #if SEXP_USE_BIGNUMS @@ -260,7 +260,7 @@ static sexp_uint_t bit_count (sexp_uint_t i) { >> (sizeof(i) - 1) * CHAR_BIT); } -static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp res; sexp_sint_t i; #if SEXP_USE_BIGNUMS @@ -271,7 +271,7 @@ static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) { res = sexp_make_fixnum(bit_count(i<0 ? ~i : i)); #if SEXP_USE_BIGNUMS } else if (sexp_bignump(x)) { - for (i=count=0; i> 8) ? 8 + log_table_256[t] : log_table_256[x]; } -static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) { sexp_sint_t tmp; #if SEXP_USE_BIGNUMS sexp_sint_t hi; @@ -321,7 +321,7 @@ static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) { } } -static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) { +sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) { sexp_sint_t pos; #if SEXP_USE_BIGNUMS sexp_sint_t rem; @@ -338,7 +338,7 @@ static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) } else if (sexp_bignump(x)) { pos /= (sizeof(sexp_uint_t)*CHAR_BIT); rem = (sexp_unbox_fixnum(i) - pos*sizeof(sexp_uint_t)*CHAR_BIT); - return sexp_make_boolean((pos < sexp_bignum_length(x)) + return sexp_make_boolean((pos < (sexp_sint_t)sexp_bignum_length(x)) && (sexp_bignum_data(x)[pos] & (1UL< p0) - for (i=0; i 0) { @@ -91,13 +91,13 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t return (bound ? acc % bound : acc); } -static sexp sexp_hash (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) { +sexp sexp_hash (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH)); } -static sexp sexp_hash_by_identity (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) { +sexp sexp_hash_by_identity (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) { if (! sexp_exact_integerp(bound)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound); return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound)); @@ -119,7 +119,7 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) { args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx)); sexp_print_exception(ctx, res, args); res = SEXP_ZERO; - } else if (sexp_unbox_fixnum(res) >= len) { + } else if ((sexp_uint_t)sexp_unbox_fixnum(res) >= len) { res = SEXP_ZERO; } sexp_gc_release1(ctx); @@ -184,7 +184,7 @@ static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp has sexp_gc_release1(ctx); } -static sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj, sexp createp) { +sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj, sexp createp) { sexp buckets, eq_fn, hash_fn, i; sexp_uint_t size; sexp_gc_var1(res); @@ -214,7 +214,7 @@ static sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, s return res; } -static sexp sexp_hash_table_delete (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj) { +sexp sexp_hash_table_delete (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj) { sexp buckets, eq_fn, hash_fn, i, p, res; if (!(sexp_pointerp(ht) && strcmp(sexp_string_data(sexp_object_type_name(ctx, ht)), "Hash-Table") == 0)) return sexp_xtype_exception(ctx, self, "not a Hash-Table", ht); diff --git a/main.c b/main.c index 8ff057a9..89a10fe1 100644 --- a/main.c +++ b/main.c @@ -7,6 +7,7 @@ #endif #include "chibi/eval.h" +#include "gc_heap.h" #define sexp_argv_symbol "command-line" @@ -78,126 +79,6 @@ void sexp_segfault_handler(int sig) { } #endif -#if SEXP_USE_IMAGE_LOADING - -#include -#include -#include -#include - -#define SEXP_IMAGE_MAGIC "\a\achibi\n\0" -#define SEXP_IMAGE_MAJOR_VERSION 1 -#define SEXP_IMAGE_MINOR_VERSION 1 - -typedef struct sexp_image_header_t* sexp_image_header; -struct sexp_image_header_t { - char magic[8]; - short major, minor; - sexp_abi_identifier_t abi; - sexp_uint_t size; - sexp_heap base; - sexp context; -}; - -sexp sexp_gc (sexp ctx, size_t *sum_freed); -void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags); - -static sexp sexp_load_image (const char* file, sexp_uint_t heap_size, sexp_uint_t heap_max_size) { - sexp ctx, flags, *globals, *types; - int fd; - sexp_sint_t offset; - sexp_heap heap; - sexp_free_list q; - struct sexp_image_header_t header; - fd = open(file, O_RDONLY); - if (fd < 0) { - fprintf(stderr, "can't open image file: %s\n", file); - return NULL; - } - if (read(fd, &header, sizeof(header)) != sizeof(header)) - return NULL; - if (memcmp(header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)) != 0) { - fprintf(stderr, "invalid image file magic for %s: %s\n", file, header.magic); - return NULL; - } else if (header.major != SEXP_IMAGE_MAJOR_VERSION - || header.major < SEXP_IMAGE_MINOR_VERSION) { - fprintf(stderr, "unsupported image version: %d.%d\n", - header.major, header.minor); - return NULL; - } else if (!sexp_abi_compatible(NULL, header.abi, SEXP_ABI_IDENTIFIER)) { - fprintf(stderr, "unsupported ABI: %s (expected %s)\n", - header.abi, SEXP_ABI_IDENTIFIER); - return NULL; - } - if (heap_size < header.size) heap_size = header.size; - heap = (sexp_heap)malloc(sexp_heap_pad_size(heap_size)); - if (!heap) { - fprintf(stderr, "couldn't malloc heap\n"); - return NULL; - } - if (read(fd, heap, header.size) != header.size) { - fprintf(stderr, "error reading image\n"); - return NULL; - } - offset = (sexp_sint_t)((char*)heap - (sexp_sint_t)header.base); - /* expand the last free chunk if necessary */ - if (heap->size < heap_size) { - for (q=(sexp_free_list)(((char*)heap->free_list) + offset); q->next; - q=(sexp_free_list)(((char*)q->next) + offset)) - ; - if ((char*)q + q->size >= (char*)heap->data + heap->size) { - /* last free chunk at end of heap */ - q->size += heap_size - heap->size; - } else { - /* last free chunk in the middle of the heap */ - q->next = (sexp_free_list)((char*)heap->data + heap->size); - q = (sexp_free_list)(((char*)q->next) + offset); - q->size = heap_size - heap->size; - q->next = NULL; - } - heap->size += (heap_size - heap->size); - } - ctx = (sexp)(((char*)header.context) + offset); - globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + offset)); - types = sexp_vector_data((sexp)((char*)(globals[SEXP_G_TYPES]) + offset)); - flags = sexp_fx_add(SEXP_COPY_LOADP, SEXP_COPY_FREEP); - sexp_offset_heap_pointers(heap, header.base, types, flags); - close(fd); - return ctx; -} - -static int sexp_save_image (sexp ctx, const char* path) { - sexp_heap heap; - FILE* file; - struct sexp_image_header_t header; - heap = sexp_context_heap(ctx); - if (heap->next) { - fprintf(stderr, "can't save image for a chunked heap, try a larger initial heap with -h\n"); - return 0; - } - file = fopen(path, "w"); - if (!file) { - fprintf(stderr, "couldn't open image file for writing: %s\n", path); - return 0; - } - memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)); - memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi)); - header.major = SEXP_IMAGE_MAJOR_VERSION; - header.minor = SEXP_IMAGE_MINOR_VERSION; - header.size = heap->size; - header.base = heap; - header.context = ctx; - sexp_gc(ctx, NULL); - if (! (fwrite(&header, sizeof(header), 1, file) == 1 - && fwrite(heap, heap->size, 1, file) == 1)) { - fprintf(stderr, "error writing image file\n"); - return 0; - } - fclose(file); - return 1; -} - -#endif #if SEXP_USE_GREEN_THREADS static void sexp_make_unblocking (sexp ctx, sexp port) { @@ -406,7 +287,7 @@ static sexp sexp_resume_ctx = SEXP_FALSE; static sexp sexp_resume_proc = SEXP_FALSE; #endif -void run_main (int argc, char **argv) { +sexp run_main (int argc, char **argv) { #if SEXP_USE_MODULES char *impmod; #endif @@ -529,8 +410,9 @@ void run_main (int argc, char **argv) { exit_failure(); } ctx = sexp_load_image(arg, heap_size, heap_max_size); - if (!ctx) { + if (!ctx || !sexp_contextp(ctx)) { fprintf(stderr, "-:i : couldn't open file for reading: %s\n", arg); + fprintf(stderr, " %s\n", sexp_load_image_err()); exit_failure(); } env = sexp_load_standard_params(ctx, sexp_context_env(ctx)); @@ -542,8 +424,11 @@ void run_main (int argc, char **argv) { env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); } arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); - if (!sexp_save_image(ctx, arg)) + if (sexp_save_image(ctx, arg) != SEXP_TRUE) { + fprintf(stderr, "-d : couldn't save image to file: %s\n", arg); + fprintf(stderr, " %s\n", sexp_load_image_err()); exit_failure(); + } quit = 1; break; #endif @@ -555,7 +440,7 @@ void run_main (int argc, char **argv) { tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); - return; + return SEXP_TRUE; #if SEXP_USE_FOLD_CASE_SYMS case 'f': fold_case = 1; @@ -698,7 +583,11 @@ void run_main (int argc, char **argv) { } sexp_gc_release4(ctx); - sexp_destroy_context(ctx); + if (sexp_destroy_context(ctx) == SEXP_FALSE) { + fprintf(stderr, "destroy_context error\n"); + return SEXP_FALSE; + } + return SEXP_TRUE; } #ifdef EMSCRIPTEN @@ -718,7 +607,10 @@ int main (int argc, char **argv) { signal(SIGSEGV, sexp_segfault_handler); #endif sexp_scheme_init(); - run_main(argc, argv); - exit_success(); + if (run_main(argc, argv) == SEXP_FALSE) { + exit_failure(); + } else { + exit_success(); + } return 0; } diff --git a/sexp.c b/sexp.c index 1a8c20ac..14954ed5 100644 --- a/sexp.c +++ b/sexp.c @@ -12,9 +12,7 @@ struct sexp_huff_entry { #if SEXP_USE_HUFF_SYMS #include "chibi/sexp-hufftabs.h" -static struct sexp_huff_entry huff_table[] = { #include "chibi/sexp-huff.h" -}; #endif static int sexp_initialized_p = 0; @@ -177,58 +175,58 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl) { #endif static struct sexp_type_struct _sexp_type_specs[] = { - {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_TYPE, sexp_offsetof(type, name), 7+SEXP_USE_DL, 7+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_TYPE, sexp_offsetof(type, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #if SEXP_USE_PACKED_STRINGS - {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #else - {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #endif - {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #if SEXP_USE_RATIOS - {SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #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, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {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, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #endif - {SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORT}, - {SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORT}, - {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENO}, - {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_FINALIZE_PORT}, + {SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_FINALIZE_PORT}, + {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FINALIZE_FILENO}, + {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #if SEXP_USE_DL - {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_DL}, + {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_DLN, SEXP_FINALIZE_DL}, #endif - {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"If", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ref", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_SET_SYN, sexp_offsetof(set_syn, var), 3, 3, 0, 0, sexp_sizeof(set_syn), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set-Syn!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Seq", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lit", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL}, - {SEXP_STACK, sexp_offsetof(stack, data), 0, 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, - {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"If", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ref", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_SET_SYN, sexp_offsetof(set_syn, var), 3, 3, 0, 0, sexp_sizeof(set_syn), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set-Syn!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Seq", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lit", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL}, + {SEXP_STACK, sexp_offsetof(stack, data), 0, 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, + {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #if SEXP_USE_AUTO_FORCE - {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #endif #if SEXP_USE_WEAK_REFERENCES - {SEXP_EPHEMERON, sexp_offsetof(ephemeron, key), 2, 0, 0, 0, sexp_sizeof(ephemeron), 0, 0, sexp_offsetof(ephemeron, key), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL}, + {SEXP_EPHEMERON, sexp_offsetof(ephemeron, key), 2, 0, 0, 0, sexp_sizeof(ephemeron), 0, 0, sexp_offsetof(ephemeron, key), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL}, #endif }; @@ -240,7 +238,7 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots, sexp fb, sexp felb, sexp flb, sexp flo, sexp fls, sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo, - sexp ws, sexp we, sexp p, sexp_proc2 f) { + sexp ws, sexp we, sexp p, const char* fname, sexp_proc2 f) { sexp *v1, *v2; sexp_gc_var2(res, type); sexp_uint_t i, len, num_types=sexp_context_num_types(ctx), @@ -271,32 +269,33 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp_pointer_tag(type) = SEXP_TYPE; sexp_type_tag(type) = num_types; sexp_type_slots(type) = slots; - sexp_type_field_base(type) = sexp_unbox_fixnum(fb); - sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb); - sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb); - sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo); - sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls); - sexp_type_size_base(type) = sexp_unbox_fixnum(sb); - sexp_type_size_off(type) = sexp_unbox_fixnum(so); - sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); - sexp_type_weak_base(type) = sexp_unbox_fixnum(w); - sexp_type_weak_len_base(type) = sexp_unbox_fixnum(wb); - sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo); - sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws); - sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we); + sexp_type_field_base(type) = (short)sexp_unbox_fixnum(fb); + sexp_type_field_eq_len_base(type) = (short)sexp_unbox_fixnum(felb); + sexp_type_field_len_base(type) = (short)sexp_unbox_fixnum(flb); + sexp_type_field_len_off(type) = (short)sexp_unbox_fixnum(flo); + sexp_type_field_len_scale(type) = (unsigned short)sexp_unbox_fixnum(fls); + sexp_type_size_base(type) = (short)sexp_unbox_fixnum(sb); + sexp_type_size_off(type) = (short)sexp_unbox_fixnum(so); + sexp_type_size_scale(type) = (unsigned short)sexp_unbox_fixnum(sc); + sexp_type_weak_base(type) = (short)sexp_unbox_fixnum(w); + sexp_type_weak_len_base(type) = (short)sexp_unbox_fixnum(wb); + sexp_type_weak_len_off(type) = (short)sexp_unbox_fixnum(wo); + sexp_type_weak_len_scale(type) = (short)sexp_unbox_fixnum(ws); + sexp_type_weak_len_extra(type) = (short)sexp_unbox_fixnum(we); sexp_type_name(type) = name; sexp_type_getters(type) = SEXP_FALSE; sexp_type_setters(type) = SEXP_FALSE; sexp_type_finalize(type) = f; + sexp_type_finalize_name(type) = (fname) ? sexp_c_string(ctx, fname, -1) : NULL; sexp_type_id(type) = SEXP_FALSE; #if SEXP_USE_DL if (f) sexp_type_dl(type) = sexp_context_dl(ctx); #endif sexp_type_print(type) = p; - if (sexp_typep(parent)) { + if (parent && sexp_typep(parent)) { len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1; sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID); - if (sexp_vectorp(sexp_type_cpl(parent))) + if (parent && sexp_vectorp(sexp_type_cpl(parent))) memcpy(sexp_vector_data(sexp_type_cpl(type)), sexp_vector_data(sexp_type_cpl(parent)), len * sizeof(sexp)); @@ -307,7 +306,7 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID); } sexp_vector_data(sexp_type_cpl(type))[len] = type; - sexp_type_depth(type) = len; + sexp_type_depth(type) = (short)len; sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1); } res = type; @@ -317,14 +316,14 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, } sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots) { - short i, num_slots = sexp_unbox_fixnum(sexp_length(ctx, slots)); + short i, num_slots = (short)sexp_unbox_fixnum(sexp_length(ctx, slots)); sexp type_size, num_slots_obj, cpl, tmp; if (parent && sexp_typep(parent)) { - num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent))); + num_slots += (short)sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent))); if (sexp_vectorp((cpl = sexp_type_cpl(parent)))) - for (i=sexp_vector_length(cpl)-1; i>=0; i--) { + for (i=(short)sexp_vector_length(cpl)-1; i>=0; i--) { tmp = sexp_vector_ref(cpl, sexp_make_fixnum(i)); - num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp))); + num_slots += (short)sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp))); } } num_slots_obj = sexp_make_fixnum(num_slots); @@ -336,7 +335,7 @@ sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name type_size, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, sexp_type_print(sexp_type_by_index(ctx, SEXP_EXCEPTION)), - NULL); + NULL, NULL); } #if SEXP_USE_OBJECT_BRACE_LITERALS @@ -419,14 +418,20 @@ void sexp_init_context_globals (sexp ctx) { vec = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)); for (i=0; ivalue), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); vec[i] = type; sexp_type_name(type) = sexp_c_string(ctx, (char*)sexp_type_name(type), -1); + if (sexp_type_finalize_name(type)) { + sexp_type_finalize_name(type) = sexp_c_string(ctx, (char*)sexp_type_finalize_name(type), -1); + } if (sexp_type_print(type)) { if (print && ((sexp_proc1)sexp_type_print(type) == sexp_opcode_func(print))) sexp_type_print(type) = print; else - sexp_type_print(type) = print = sexp_make_foreign(ctx, "sexp_write_simple_object", 3, 0, (sexp_proc1)sexp_type_print(type), NULL); + sexp_type_print(type) = print = sexp_make_foreign(ctx, "sexp_write_simple_object", 3, 0, NULL, (sexp_proc1)sexp_type_print(type), NULL); } } } @@ -503,7 +508,7 @@ sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) { } #if ! SEXP_USE_GLOBAL_HEAP -void sexp_destroy_context (sexp ctx) { +sexp sexp_destroy_context (sexp ctx) { sexp_heap heap, tmp; size_t sum_freed; if (sexp_context_heap(ctx)) { @@ -511,15 +516,16 @@ void sexp_destroy_context (sexp ctx) { sexp_markedp(ctx) = 1; sexp_markedp(sexp_context_globals(ctx)) = 1; sexp_mark(ctx, sexp_global(ctx, SEXP_G_TYPES)); - sexp_finalize(ctx); + if (sexp_finalize(ctx) == SEXP_FALSE) { return SEXP_FALSE; } sexp_sweep(ctx, &sum_freed); - sexp_finalize(ctx); + if (sexp_finalize(ctx) == SEXP_FALSE) { return SEXP_FALSE; } sexp_context_heap(ctx) = NULL; for ( ; heap; heap=tmp) { tmp = heap->next; sexp_free_heap(heap); } } + return SEXP_TRUE; } #endif @@ -1014,7 +1020,7 @@ sexp sexp_string_offset_to_index (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp_sint_t off = sexp_unbox_fixnum(offset); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset); - if (off < 0 || off > sexp_string_size(str)) + if (off < 0 || off > (sexp_sint_t)sexp_string_size(str)) return sexp_user_exception(ctx, self, "string-offset->index: offset out of range", offset); return sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(str), off)); } @@ -1078,9 +1084,9 @@ sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start end = sexp_make_fixnum(sexp_string_size(str)); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end); if ((sexp_unbox_fixnum(start) < 0) - || (sexp_unbox_fixnum(start) > sexp_string_size(str)) + || (sexp_unbox_fixnum(start) > (sexp_sint_t)sexp_string_size(str)) || (sexp_unbox_fixnum(end) < 0) - || (sexp_unbox_fixnum(end) > sexp_string_size(str)) + || (sexp_unbox_fixnum(end) > (sexp_sint_t)sexp_string_size(str)) || (end < start)) return sexp_range_exception(ctx, str, start, end); res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); @@ -1529,16 +1535,16 @@ static void sexp_insert_fileno(sexp ctx, sexp fileno) { if (!sexp_vectorp(vec)) { vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS) = sexp_make_vector(ctx, sexp_make_fixnum(128), SEXP_FALSE); - } else if (n >= sexp_vector_length(vec)) { + } else if (n >= (sexp_sint_t)sexp_vector_length(vec)) { data = sexp_vector_data(vec); - for (i = n2 = 0; i < sexp_vector_length(vec); i++) + for (i = n2 = 0; i < (sexp_sint_t)sexp_vector_length(vec); i++) if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i])) n2++; if (n2 * 2 >= n) n2 = n * 2; tmp = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS) = sexp_make_vector(ctx, sexp_make_fixnum(n2), SEXP_FALSE); - for (i = n = 0; i < sexp_vector_length(vec); i++) + for (i = n = 0; i < (sexp_sint_t)sexp_vector_length(vec); i++) if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i]) && sexp_insert_fileno_ephemeron(ctx, tmp, data[i])) n++; @@ -1765,7 +1771,7 @@ static struct {const char* name; char ch;} sexp_char_names[] = { {"alarm", '\a'}, {"backspace", '\b'}, {"delete", 127}, - {"escape", '\e'}, + {"escape", 27}, {"null", 0}, #endif }; @@ -1820,7 +1826,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { } else { sexp_write_string(ctx, "#(", out); sexp_write_one(ctx, elts[0], out); - for (i=1; i= sexp_vector_length(*shares)) { + if (c2 + 1 >= (int)sexp_vector_length(*shares)) { tmp2 = sexp_make_vector(ctx, sexp_make_fixnum(sexp_vector_length(*shares)*2), SEXP_VOID); memcpy(sexp_vector_data(tmp2), sexp_vector_data(*shares), (sexp_vector_length(*shares)-1)*sizeof(sexp)); *shares = tmp2; @@ -2890,6 +2896,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) { if (tmp > sexp_vector_data(*shares)[sexp_vector_length(*shares)-1]) sexp_vector_data(*shares)[sexp_vector_length(*shares)-1] = tmp; res = sexp_read_raw(ctx, in, shares); + sexp_vector_data(*shares)[c2] = res; if (sexp_reader_labelp(res)) res = sexp_read_error(ctx, "self reader label reference", tmp, in); else diff --git a/tools/chibi-ffi b/tools/chibi-ffi index 1dd651a8..4d27651e 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -1390,7 +1390,7 @@ (write-gc-release gc-vars))) (define (write-func-declaration func) - (cat "static sexp " (func-stub-name func) + (cat "sexp " (func-stub-name func) " (sexp ctx, sexp self, sexp_sint_t n" (write-parameters (func-scheme-args func)) ")")) @@ -1516,7 +1516,7 @@ (else 1)) ", ")) "") - "(sexp_proc1)" (func-stub-name func) + (func-stub-name func) (cond (default (lambda () (cat ", " (write-default default)))) (no-bind? ", SEXP_VOID") @@ -1668,7 +1668,7 @@ "((" (x->string (or (type-struct-type name) "")) " " (x->string name) "*)" "sexp_cpointer_value(x))"))) - (cat "static sexp " (type-getter-name type name field) + (cat "sexp " (type-getter-name type name field) " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" (lambda () (write-validator "x" (parse-type name 0))) " return " @@ -1745,7 +1745,7 @@ (lambda () (scheme->c-converter (car field) val)) ";\n")))))) (define (write-type-setter type name field) - (cat "static sexp " (type-setter-name type name field) + (cat "sexp " (type-setter-name type name field) " (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n" (lambda () (write-validator "x" (parse-type name 0))) (lambda () (write-validator "v" (parse-type (car field) 1))) @@ -1762,7 +1762,7 @@ (scheme-name (if (pair? y) (car y) y)) (cname (if (pair? y) (cadr y) y)) (method? (not (memq 'finalizer: type)))) - (cat "static sexp " (generate-stub-name scheme-name) + (cat "sexp " (generate-stub-name scheme-name) " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" " if (sexp_cpointer_freep(x)) {\n" " " (if method? "" cname) "(" @@ -1787,7 +1787,7 @@ => (lambda (x) (let ((make (car (cadr x))) (args (cdr (cadr x)))) - (cat "static sexp " (generate-stub-name make) + (cat "sexp " (generate-stub-name make) " (sexp ctx, sexp self, sexp_sint_t n" (lambda () (let lp ((ls args) (i 0)) @@ -1928,7 +1928,7 @@ (let ((name (type-c-name-derefed (car t))) (finalizer-name (type-finalizer-name (car t)))) (cat - "static sexp " finalizer-name " (" + "sexp " finalizer-name " (" "sexp ctx, sexp self, sexp_sint_t n, sexp obj) {\n" " if (sexp_cpointer_freep(obj))\n" " delete static_cast<" name "*>" diff --git a/vm.c b/vm.c index d6bd1632..2aeee337 100644 --- a/vm.c +++ b/vm.c @@ -32,7 +32,7 @@ static sexp sexp_lookup_source_info (sexp src, int ip) { if (src && sexp_procedurep(src)) src = sexp_procedure_source(src); if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) { - for (i=1; i ip) return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1))); return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1))); @@ -200,7 +200,7 @@ static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) { generate_drop_prev(ctx, sexp_car(head)); sexp_inc_context_depth(ctx, -1); } - sexp_context_tailp(ctx) = tailp; + sexp_context_tailp(ctx) = (char)tailp; sexp_generate(ctx, name, loc, lam, sexp_car(head)); } @@ -209,12 +209,12 @@ static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) { sexp_push_source(ctx, sexp_cnd_source(cnd)); sexp_context_tailp(ctx) = 0; sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd)); - sexp_context_tailp(ctx) = tailp; + sexp_context_tailp(ctx) = (char)tailp; sexp_emit(ctx, SEXP_OP_JUMP_UNLESS); sexp_inc_context_depth(ctx, -1); label1 = sexp_context_make_label(ctx); sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd)); - sexp_context_tailp(ctx) = tailp; + sexp_context_tailp(ctx) = (char)tailp; sexp_emit(ctx, SEXP_OP_JUMP); sexp_inc_context_depth(ctx, -1); label2 = sexp_context_make_label(ctx); @@ -473,7 +473,7 @@ static void generate_general_app (sexp ctx, sexp app) { sexp_emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); - sexp_context_tailp(ctx) = tailp; + sexp_context_tailp(ctx) = (char)tailp; sexp_inc_context_depth(ctx, -len); sexp_gc_release1(ctx); } @@ -890,7 +890,7 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) { if (b == sexp_type_by_index(ctx, SEXP_OBJECT)) return 1; d = sexp_type_depth(b); - return (d < sexp_vector_length(v)) + return (d < (int)sexp_vector_length(v)) && sexp_vector_ref(v, sexp_make_fixnum(d)) == b; } @@ -1136,7 +1136,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { bc = sexp_procedure_code(self); cp = sexp_procedure_vars(self); ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3); - i = sexp_unbox_fixnum(_ARG4); + // TODO - value stored here never read, verify i = sexp_unbox_fixnum(_ARG4); top -= 4; _ARG1 = tmp1; break; @@ -1375,7 +1375,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { else if (! sexp_fixnump(_ARG2)) sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1))) sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_vector_ref(_ARG1, _ARG2); top--; @@ -1388,7 +1388,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { else if (! sexp_fixnump(_ARG2)) sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_vector_length(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1))) sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); sexp_vector_set(_ARG1, _ARG2, _ARG3); top-=3; @@ -1404,7 +1404,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_fixnump(_ARG2)) sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_bytes_length(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1))) sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_bytes_ref(_ARG1, _ARG2); top--; @@ -1415,7 +1415,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { else if (! sexp_fixnump(_ARG2)) sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_string_size(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1))) sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); _ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2); top--; @@ -1432,7 +1432,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { && sexp_unbox_fixnum(_ARG3)<0x100)) sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_bytes_length(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1))) sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); sexp_bytes_set(_ARG1, _ARG2, _ARG3); top-=3; @@ -1448,7 +1448,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { else if (! sexp_charp(_ARG3)) sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3)); i = sexp_unbox_fixnum(_ARG2); - if ((i < 0) || (i >= sexp_string_size(_ARG1))) + if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1))) sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2)); sexp_context_top(ctx) = top; sexp_string_set(ctx, _ARG1, _ARG2, _ARG3); @@ -1573,7 +1573,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_fixnump(_ARG3)) sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3)); if (sexp_vectorp(sexp_type_getters(_ARG1))) { - if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_getters(_ARG1))) + if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_getters(_ARG1))) sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1)))); tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3); if (sexp_opcodep(tmp1)) @@ -1602,7 +1602,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (! sexp_fixnump(_ARG3)) sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3)); if (sexp_vectorp(sexp_type_setters(_ARG1))) { - if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_setters(_ARG1))) + if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_setters(_ARG1))) sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1)))); tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3); if (sexp_opcodep(tmp1)) @@ -2007,7 +2007,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1)); else if (! sexp_fixnump(_ARG2)) sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2)); - if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_bytes_length(tmp1)) + if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > (sexp_sint_t)sexp_bytes_length(tmp1)) sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2)); if (! sexp_oportp(_ARG3)) sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));