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

Added full support for packed images, both for static and dynamic libraries.

Browse source
This commit is contained in:
Chris Walsh 2016-02-15 21:12:58 -05:00
parent 83c5792673
commit 2005c19ea0
24 changed files with 1163 additions and 624 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

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

26
bignum.c
View file

@ -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);
}

1
chibi-osx Executable file
View file

@ -0,0 +1 @@
LD_LIBRARY_PATH=.: DYLD_LIBRARY_PATH=.: CHIBI_MODULE_PATH=lib ./chibi-scheme "$@"

37
eval.c
View file

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

181
gc.c
View file

@ -14,12 +14,6 @@
#include <sys/mman.h>
#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; i<len; i++)
if (v[i] && sexp_pointerp(v[i]))
v[i] = (sexp) ((char*)v[i] + off);
/* don't free unless specified - only the original cleans up */
if (! freep)
sexp_freep(p) = 0;
/* adjust context heaps, don't copy saved sexp_gc_vars */
if (sexp_contextp(p)) {
#if SEXP_USE_GREEN_THREADS
sexp_context_ip(p) += off;
#endif
sexp_context_last_fp(p) += off;
sexp_stack_top(sexp_context_stack(p)) = 0;
sexp_context_saves(p) = NULL;
sexp_context_heap(p) = heap;
} else if (sexp_bytecodep(p) && off != 0) {
for (i=0; i<sexp_bytecode_length(p); ) {
switch (sexp_bytecode_data(p)[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
v = (sexp*)(&(sexp_bytecode_data(p)[i]));
if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
/* ... 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:
v = (sexp*)(&(sexp_bytecode_data(p)[i]));
if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
i += 3*sizeof(sexp); break;
}
}
} else if (sexp_portp(p) && sexp_port_stream(p)) {
sexp_port_stream(p) = 0;
sexp_port_openp(p) = 0;
sexp_freep(p) = 0;
#if SEXP_USE_DL
} else if (loadp && sexp_dlp(p)) {
sexp_dl_handle(p) = NULL;
#endif
}
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
}
}
/* make a second pass to fix code references */
if (loadp) {
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 {
#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

671
gc_heap.c Normal file
View file

@ -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 = "<static>";
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);
}

98
gc_heap.h Normal file
View file

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

9
include/chibi/eval.h
View file

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

5
include/chibi/features.h
View file

@ -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 <shlwapi.h>
#define strcasestr StrStrI

4
include/chibi/sexp-huff.h
View file

@ -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' */
};

181
include/chibi/sexp.h
View file

@ -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
};

135
lib/chibi/ast.c
View file

@ -8,6 +8,23 @@
#include <errno.h>
#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;

10
lib/chibi/disasm.c
View file

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

12
lib/chibi/heap-stats.c
View file

@ -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; i<SEXP_HEAP_VECTOR_DEPTH && i<sexp_vector_length(x); i++) {
for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) {
if (i>0)
sexp_write_char(ctx, ' ', out);
sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
}
if (i<sexp_vector_length(x))
if (i<(int)sexp_vector_length(x))
sexp_write_string(ctx, " ...", out);
sexp_write_char(ctx, ')', out);
} else {
@ -185,19 +185,19 @@ static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
#else
static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
return SEXP_NULL;
}
static sexp sexp_heap_sizes (sexp ctx, sexp self, sexp_sint_t n) {
sexp sexp_heap_sizes (sexp ctx, sexp self, sexp_sint_t n) {
return SEXP_NULL;
}
static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
return SEXP_NULL;
}
static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
return SEXP_NULL;
}

4
lib/scheme/time.c
View file

@ -65,7 +65,7 @@ static void current_ntp_clock_values (double *second, int *leap_second_indicator
}
}
static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
double second;
int leap_second_indicator;
sexp_gc_var3(res, car, cdr);
@ -80,7 +80,7 @@ static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
#endif /* def SEXP_USE_NTP_GETTIME */
static sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
#ifndef PLAN9
struct timeval tv;
struct timezone tz;

14
lib/srfi/18/threads.c
View file

@ -332,7 +332,7 @@ static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) {
return sexp_log2_lookup[((unsigned)n * 0x077CB531U) >> 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;

2
lib/srfi/27/rand.c
View file

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

18
lib/srfi/33/bit.c
View file

@ -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<sexp_bignum_length(x); i++)
for (i=count=0; i<(sexp_sint_t)sexp_bignum_length(x); i++)
count += bit_count(sexp_bignum_data(x)[i]);
res = sexp_make_fixnum(count);
#endif
@ -302,7 +302,7 @@ static sexp_uint_t integer_log2 (sexp_uint_t x) {
return (t = x >> 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<<rem)));
#endif
} else {

4
lib/srfi/39/param.c
View file

@ -6,7 +6,7 @@
#define _I(x) sexp_make_fixnum(x)
static sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init, sexp conv) {
sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init, sexp conv) {
sexp res;
sexp_gc_var1(cell);
sexp_gc_preserve1(ctx, cell);
@ -19,7 +19,7 @@ static sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init,
return res;
}
static sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp param) {
sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp param) {
sexp res;
sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, param);
res = sexp_opcode_data2(param);

16
lib/srfi/69/hash.c
View file

@ -23,7 +23,7 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
return acc % bound;
}
static sexp sexp_string_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
sexp sexp_string_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
else if (! sexp_fixnump(bound))
@ -38,7 +38,7 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
return acc % bound;
}
static sexp sexp_string_ci_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
sexp sexp_string_ci_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
else if (! sexp_fixnump(bound))
@ -69,7 +69,7 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t
size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
if (((char*)obj + size) > p0)
for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
for (i=0; i<(sexp_sint_t)size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
/* hash eq-object slots */
len = sexp_type_num_eq_slots_of_object(t, obj);
if (len > 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);

146
main.c
View file

@ -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 <sys/types.h>
#include <sys/uio.h>
#include <unistd.h>
#include <fcntl.h>
#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 <file>: 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 <file>: 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;
}

163
sexp.c
View file

@ -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; i<SEXP_NUM_CORE_TYPES; i++) {
type = sexp_alloc_type(ctx, type, SEXP_TYPE);
if (!type) {
return; // TODO - fundamental OOM, what to do here?
}
memcpy(&(type->value), &(_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<len; i++) {
for (i=1; i<(long)len; i++) {
sexp_write_char(ctx, ' ', out);
sexp_write_one(ctx, elts[i], out);
}
@ -1953,7 +1959,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
sexp_write_string(ctx, "#u8(", out);
str = sexp_bytes_data(obj);
len = sexp_bytes_length(obj);
for (i=0; i<len; i++) {
for (i=0; i<(long)len; i++) {
if (i!=0) sexp_write_char(ctx, ' ', out);
sexp_write(ctx, sexp_make_fixnum(((unsigned char*)str)[i]), out);
}
@ -2881,7 +2887,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
sexp_make_fixnum(16))) {
res = sexp_read_error(ctx, "reader label out of order", tmp, in);
} else {
if (c2 + 1 >= 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

14
tools/chibi-ffi
View file

@ -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 "*>"

32
vm.c
View file

@ -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<sexp_vector_length(src); i++)
for (i=1; i<(int)sexp_vector_length(src); i++)
if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(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));