Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial image file support

Browse source
This commit is contained in:
Alex Shinn 2011-09-24 17:18:35 +09:00
parent 230bcb24bb
commit 4f9903db00
12 changed files with 337 additions and 149 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
eval.c
View file

@ -306,7 +306,7 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) {
return mac; return mac;
} }
static sexp sexp_make_synclo_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) { sexp sexp_make_synclo_op (sexp ctx sexp_api_params(self, n), sexp env, sexp fv, sexp expr) {
sexp res; sexp res;
if (! (sexp_symbolp(expr) || sexp_pairp(expr))) if (! (sexp_symbolp(expr) || sexp_pairp(expr)))
return expr; return expr;
@ -992,7 +992,7 @@ sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) {
/************************ library procedures **************************/ /************************ library procedures **************************/
static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) {
sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn); sexp_assert_type(ctx, sexp_exceptionp, SEXP_EXCEPTION, exn);
return sexp_exception_kind(exn); return sexp_exception_kind(exn);
} }
@ -1067,8 +1067,15 @@ static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
return init(ctx sexp_api_pass(NULL, 1), env); return init(ctx sexp_api_pass(NULL, 1), env);
} }
#else #else
static sexp sexp_make_dl (sexp ctx, sexp file, void* handle) {
sexp res = sexp_alloc_type(ctx, dl, SEXP_DL);
sexp_dl_file(res) = file;
sexp_dl_handle(res) = handle;
return res;
}
static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
sexp_proc2 init; sexp_proc2 init;
sexp_gc_var2(res, old_dl);
void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); void *handle = dlopen(sexp_string_data(file), RTLD_LAZY);
if (! handle) if (! handle)
return sexp_compile_error(ctx, "couldn't load dynamic library", file); return sexp_compile_error(ctx, "couldn't load dynamic library", file);
@ -1077,7 +1084,13 @@ static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
dlclose(handle); dlclose(handle);
return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file);
} }
return init(ctx sexp_api_pass(NULL, 1), env); sexp_gc_preserve2(ctx, res, old_dl);
old_dl = sexp_context_dl(ctx);
sexp_context_dl(ctx) = sexp_make_dl(ctx, file, handle);
res = init(ctx sexp_api_pass(NULL, 1), env);
sexp_context_dl(ctx) = old_dl;
sexp_gc_release2(ctx);
return res;
} }
#endif #endif
#endif #endif
@ -1171,7 +1184,7 @@ sexp sexp_register_optimization (sexp ctx sexp_api_params(self, n), sexp f, sexp
#endif #endif
#define define_math_op(name, cname, t, f) \ #define define_math_op(name, cname, t, f) \
static sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \ sexp name (sexp ctx sexp_api_params(self, n), sexp z) { \
double d; \ double d; \
if (sexp_flonump(z)) \ if (sexp_flonump(z)) \
d = sexp_flonum_value(z); \ d = sexp_flonum_value(z); \
@ -1198,7 +1211,7 @@ define_math_op(sexp_trunc, trunc, 0, sexp_complex_dummy)
define_math_op(sexp_floor, floor, 0, sexp_complex_dummy) define_math_op(sexp_floor, floor, 0, sexp_complex_dummy)
define_math_op(sexp_ceiling, ceil, 0, sexp_complex_dummy) define_math_op(sexp_ceiling, ceil, 0, sexp_complex_dummy)
static sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) { sexp sexp_sqrt (sexp ctx sexp_api_params(self, n), sexp z) {
int negativep = 0; int negativep = 0;
double d, r; double d, r;
sexp_gc_var1(res); sexp_gc_var1(res);
@ -1247,7 +1260,7 @@ sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) {
} }
#endif #endif
static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
long double f, x1, e1; long double f, x1, e1;
sexp res; sexp res;
#if SEXP_USE_COMPLEX #if SEXP_USE_COMPLEX
@ -1322,28 +1335,28 @@ static sexp sexp_expt_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
} }
#if SEXP_USE_RATIOS #if SEXP_USE_RATIOS
static sexp sexp_ratio_numerator_op (sexp ctx sexp_api_params(self, n), sexp rat) { sexp sexp_ratio_numerator_op (sexp ctx sexp_api_params(self, n), sexp rat) {
sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat); sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
return sexp_ratio_numerator(rat); return sexp_ratio_numerator(rat);
} }
static sexp sexp_ratio_denominator_op (sexp ctx sexp_api_params(self, n), sexp rat) { sexp sexp_ratio_denominator_op (sexp ctx sexp_api_params(self, n), sexp rat) {
sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat); sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat);
return sexp_ratio_denominator(rat); return sexp_ratio_denominator(rat);
} }
#endif #endif
#if SEXP_USE_COMPLEX #if SEXP_USE_COMPLEX
static sexp sexp_complex_real_op (sexp ctx sexp_api_params(self, n), sexp cpx) { sexp sexp_complex_real_op (sexp ctx sexp_api_params(self, n), sexp cpx) {
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx); sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
return sexp_complex_real(cpx); return sexp_complex_real(cpx);
} }
static sexp sexp_complex_imag_op (sexp ctx sexp_api_params(self, n), sexp cpx) { sexp sexp_complex_imag_op (sexp ctx sexp_api_params(self, n), sexp cpx) {
sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx); sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx);
return sexp_complex_imag(cpx); return sexp_complex_imag(cpx);
} }
#endif #endif
static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) { sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, sexp str2, sexp ci) {
sexp_sint_t len1, len2, len, diff; sexp_sint_t len1, len2, len, diff;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2);
@ -1614,14 +1627,18 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
sexp_opcode_data(res) = data; sexp_opcode_data(res) = data;
sexp_opcode_data2(res) = data2; sexp_opcode_data2(res) = data2;
sexp_opcode_func(res) = func; sexp_opcode_func(res) = func;
sexp_opcode_name(res) = sexp_stringp(name) ? strdup(sexp_string_data(name)) : ""; sexp_opcode_name(res) = name;
#if SEXP_USE_DL
sexp_opcode_dl(res) = sexp_context_dl(ctx);
#endif
} }
return res; return res;
} }
sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
int flags, sexp_proc1 f, sexp data) { int flags, sexp_proc1 f, sexp data) {
sexp res; sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
#if ! SEXP_USE_EXTENDED_FCALL #if ! SEXP_USE_EXTENDED_FCALL
if (num_args > 4) if (num_args > 4)
return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
@ -1638,9 +1655,13 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
if (flags & 1) num_args--; if (flags & 1) num_args--;
sexp_opcode_num_args(res) = num_args; sexp_opcode_num_args(res) = num_args;
sexp_opcode_flags(res) = flags; sexp_opcode_flags(res) = flags;
sexp_opcode_name(res) = name; sexp_opcode_name(res) = sexp_c_string(ctx, name, -1);
sexp_opcode_data(res) = data; sexp_opcode_data(res) = data;
sexp_opcode_func(res) = f; sexp_opcode_func(res) = f;
#if SEXP_USE_DL
sexp_opcode_dl(res) = sexp_context_dl(ctx);
#endif
sexp_gc_release1(ctx);
return res; return res;
} }
@ -1673,16 +1694,16 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name,
/*********************** standard environment *************************/ /*********************** standard environment *************************/
static struct sexp_core_form_struct core_forms[] = { static struct sexp_core_form_struct core_forms[] = {
{SEXP_CORE_DEFINE, "define"}, {SEXP_CORE_DEFINE, (sexp)"define"},
{SEXP_CORE_SET, "set!"}, {SEXP_CORE_SET, (sexp)"set!"},
{SEXP_CORE_LAMBDA, "lambda"}, {SEXP_CORE_LAMBDA, (sexp)"lambda"},
{SEXP_CORE_IF, "if"}, {SEXP_CORE_IF, (sexp)"if"},
{SEXP_CORE_BEGIN, "begin"}, {SEXP_CORE_BEGIN, (sexp)"begin"},
{SEXP_CORE_QUOTE, "quote"}, {SEXP_CORE_QUOTE, (sexp)"quote"},
{SEXP_CORE_SYNTAX_QUOTE, "syntax-quote"}, {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
{SEXP_CORE_DEFINE_SYNTAX, "define-syntax"}, {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
{SEXP_CORE_LET_SYNTAX, "let-syntax"}, {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
{SEXP_CORE_LETREC_SYNTAX, "letrec-syntax"}, {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
}; };
sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) {
@ -1703,7 +1724,8 @@ sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) {
e = sexp_make_env(ctx); e = sexp_make_env(ctx);
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
core = sexp_copy_core(ctx, &core_forms[i]); core = sexp_copy_core(ctx, &core_forms[i]);
sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); sexp_env_define(ctx, e, sexp_intern(ctx, (char*)sexp_core_name(core), -1), core);
sexp_core_name(core) = sexp_c_string(ctx, (char*)sexp_core_name(core), -1);
} }
sexp_gc_release2(ctx); sexp_gc_release2(ctx);
return e; return e;
@ -1716,13 +1738,17 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) {
e = sexp_make_null_env(ctx, version); e = sexp_make_null_env(ctx, version);
for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
op = sexp_copy_opcode(ctx, &opcodes[i]); op = sexp_copy_opcode(ctx, &opcodes[i]);
name = sexp_intern(ctx, sexp_opcode_name(op), -1); name = sexp_intern(ctx, (char*)sexp_opcode_name(op), -1);
sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) {
sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1);
sexp_opcode_data(op) = sexp_env_ref(e, sym, SEXP_FALSE); sexp_opcode_data(op) = sexp_env_ref(e, sym, SEXP_FALSE);
} else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) { } else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) {
sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE); sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE);
} }
if (sexp_opcode_class(op) == SEXP_OPC_FOREIGN && sexp_opcode_data2(op)) {
sexp_opcode_data2(op) = sexp_c_string(ctx, (char*)sexp_opcode_data2(op), -1);
}
sexp_env_define(ctx, e, name, op); sexp_env_define(ctx, e, name, op);
} }
sexp_gc_release4(ctx); sexp_gc_release4(ctx);
@ -1896,7 +1922,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp); sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp);
sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
#if SEXP_USE_SIMPLIFY #if SEXP_USE_SIMPLIFY
op = sexp_make_foreign(ctx, "simplify", 1, 0, op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0,
(sexp_proc1)sexp_simplify, SEXP_VOID); (sexp_proc1)sexp_simplify, SEXP_VOID);
tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);

134
gc.c
View file

@ -473,12 +473,88 @@ void* sexp_alloc (sexp ctx, size_t size) {
#if ! SEXP_USE_GLOBAL_HEAP #if ! SEXP_USE_GLOBAL_HEAP
sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
sexp_sint_t i, off, len, freep; sexp_sint_t i, off, len, freep, loadp;
sexp_heap to, from = sexp_context_heap(ctx);
sexp_free_list q; sexp_free_list q;
sexp p, p2, t, end, *v; sexp p, t, end, name, *v;
freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); 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)) {
sexp_context_ip(p) += off;
sexp_context_saves(p) = NULL;
/* if (sexp_context_heap(p) - off != from_heap) */
/* fprintf(stderr, "unexpected heap: %p\n", sexp_context_heap(p)); */
sexp_context_heap(p) = heap;
} else if (loadp && sexp_dlp(p)) {
sexp_dl_handle(p) = NULL;
}
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)));
}
}
/* 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_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(RTLD_SELF, sexp_string_data(name));
}
}
t = types[sexp_pointer_tag(p)];
p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)));
}
}
}
}
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 */ /* validate input, creating a new heap if needed */
if (from->next) { if (from->next) {
@ -498,55 +574,9 @@ sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
/* copy the raw data */ /* copy the raw data */
off = (char*)to - (char*)from; off = (char*)to - (char*)from;
memcpy(to, from, sexp_heap_pad_size(from->size)); memcpy(to, from, sexp_heap_pad_size(from->size));
to->free_list = (sexp_free_list) ((char*)to->free_list + off);
to->data += off;
end = (sexp) (from->data + from->size);
/* adjust the free list */ /* adjust the pointers */
for (q=to->free_list; q->next; q=q->next) sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
q->next = (sexp_free_list) ((char*)q->next + off);
/* adjust if the destination is larger */
if (from->size < to->size) {
if (((char*)q + q->size - off) >= (char*)end) {
q->size += (to->size - from->size);
} else {
q->next = (sexp_free_list) ((char*)end + off);
q->next->next = NULL;
q->next->size = (to->size - from->size);
}
}
/* adjust data by traversing over the _original_ heap */
p = (sexp) (from->data + sexp_heap_align(sexp_free_chunk_size));
q = from->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_object_type(ctx, p);
len = sexp_type_num_slots_of_object(t, p);
p2 = (sexp)((char*)p + off);
v = (sexp*) ((char*)p2 + 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(p2) = 0;
/* adjust context heaps, don't copy saved sexp_gc_vars */
if (sexp_contextp(p2)) {
sexp_context_saves(p2) = NULL;
if (sexp_context_heap(p2) == from)
sexp_context_heap(p2) = to;
}
p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
}
}
return dst; return dst;
} }

4
include/chibi/features.h
View file

@ -526,6 +526,10 @@
#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000 #define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000
#endif #endif
#ifndef SEXP_USE_IMAGE_LOADING
#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
#endif
#if SEXP_USE_NATIVE_X86 #if SEXP_USE_NATIVE_X86
#undef SEXP_USE_BOEHM #undef SEXP_USE_BOEHM
#define SEXP_USE_BOEHM 1 #define SEXP_USE_BOEHM 1

28
include/chibi/sexp.h
View file

@ -118,6 +118,9 @@ enum sexp_types {
SEXP_ENV, SEXP_ENV,
SEXP_BYTECODE, SEXP_BYTECODE,
SEXP_CORE, SEXP_CORE,
#if SEXP_USE_DL
SEXP_DL,
#endif
SEXP_OPCODE, SEXP_OPCODE,
SEXP_LAMBDA, SEXP_LAMBDA,
SEXP_CND, SEXP_CND,
@ -230,22 +233,20 @@ struct sexp_type_struct {
unsigned short size_scale; unsigned short size_scale;
short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra; short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra;
short depth; short depth;
char *name; sexp name, cpl, slots;
sexp cpl, slots;
sexp_proc2 finalize; sexp_proc2 finalize;
sexp_proc3 print; sexp_proc3 print;
}; };
struct sexp_opcode_struct { struct sexp_opcode_struct {
unsigned char op_class, code, num_args, flags, inverse; unsigned char op_class, code, num_args, flags, inverse;
const char *name; sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type, dl;
sexp data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type;
sexp_proc1 func; sexp_proc1 func;
}; };
struct sexp_core_form_struct { struct sexp_core_form_struct {
char code; char code;
const char *name; sexp name;
}; };
struct sexp_struct { struct sexp_struct {
@ -342,6 +343,10 @@ struct sexp_struct {
struct { struct {
sexp env, free_vars, expr; sexp env, free_vars, expr;
} synclo; } synclo;
struct {
sexp file;
void* handle;
} dl;
struct sexp_opcode_struct opcode; struct sexp_opcode_struct opcode;
struct sexp_core_form_struct core; struct sexp_core_form_struct core;
/* ast types */ /* ast types */
@ -380,6 +385,9 @@ struct sexp_struct {
sexp_uint_t pos, depth, last_fp; sexp_uint_t pos, depth, last_fp;
sexp bc, lambda, stack, env, fv, parent, child, sexp bc, lambda, stack, env, fv, parent, child,
globals, params, proc, name, specific, event; globals, params, proc, name, specific, event;
#if SEXP_USE_DL
sexp dl;
#endif
} context; } context;
#if SEXP_USE_AUTO_FORCE #if SEXP_USE_AUTO_FORCE
struct { struct {
@ -575,6 +583,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) #define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV))
#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) #define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE))
#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) #define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE))
#define sexp_dlp(x) (sexp_check_tag(x, SEXP_DL))
#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) #define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE))
#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) #define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO))
#define sexp_syntacticp(x) (sexp_corep(x) || sexp_macrop(x)) #define sexp_syntacticp(x) (sexp_corep(x) || sexp_macrop(x))
@ -811,11 +820,15 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_core_code(x) (sexp_field(x, core, SEXP_CORE, code)) #define sexp_core_code(x) (sexp_field(x, core, SEXP_CORE, code))
#define sexp_core_name(x) (sexp_field(x, core, SEXP_CORE, name)) #define sexp_core_name(x) (sexp_field(x, core, SEXP_CORE, name))
#define sexp_dl_file(x) (sexp_field(x, dl, SEXP_DL, file))
#define sexp_dl_handle(x) (sexp_field(x, dl, SEXP_DL, handle))
#define sexp_opcode_class(x) (sexp_field(x, opcode, SEXP_OPCODE, op_class)) #define sexp_opcode_class(x) (sexp_field(x, opcode, SEXP_OPCODE, op_class))
#define sexp_opcode_code(x) (sexp_field(x, opcode, SEXP_OPCODE, code)) #define sexp_opcode_code(x) (sexp_field(x, opcode, SEXP_OPCODE, code))
#define sexp_opcode_num_args(x) (sexp_field(x, opcode, SEXP_OPCODE, num_args)) #define sexp_opcode_num_args(x) (sexp_field(x, opcode, SEXP_OPCODE, num_args))
#define sexp_opcode_flags(x) (sexp_field(x, opcode, SEXP_OPCODE, flags)) #define sexp_opcode_flags(x) (sexp_field(x, opcode, SEXP_OPCODE, flags))
#define sexp_opcode_inverse(x) (sexp_field(x, opcode, SEXP_OPCODE, inverse)) #define sexp_opcode_inverse(x) (sexp_field(x, opcode, SEXP_OPCODE, inverse))
#define sexp_opcode_dl(x) (sexp_field(x, opcode, SEXP_OPCODE, dl))
#define sexp_opcode_name(x) (sexp_field(x, opcode, SEXP_OPCODE, name)) #define sexp_opcode_name(x) (sexp_field(x, opcode, SEXP_OPCODE, name))
#define sexp_opcode_data(x) (sexp_field(x, opcode, SEXP_OPCODE, data)) #define sexp_opcode_data(x) (sexp_field(x, opcode, SEXP_OPCODE, data))
#define sexp_opcode_data2(x) (sexp_field(x, opcode, SEXP_OPCODE, data2)) #define sexp_opcode_data2(x) (sexp_field(x, opcode, SEXP_OPCODE, data2))
@ -895,6 +908,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_context_event(x) (sexp_field(x, context, SEXP_CONTEXT, event)) #define sexp_context_event(x) (sexp_field(x, context, SEXP_CONTEXT, event))
#define sexp_context_timeoutp(x) (sexp_field(x, context, SEXP_CONTEXT, timeoutp)) #define sexp_context_timeoutp(x) (sexp_field(x, context, SEXP_CONTEXT, timeoutp))
#define sexp_context_waitp(x) (sexp_field(x, context, SEXP_CONTEXT, waitp)) #define sexp_context_waitp(x) (sexp_field(x, context, SEXP_CONTEXT, waitp))
#define sexp_context_dl(x) (sexp_field(x, context, SEXP_CONTEXT, dl))
#if SEXP_USE_ALIGNED_BYTECODE #if SEXP_USE_ALIGNED_BYTECODE
#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx))
@ -1180,6 +1194,7 @@ SEXP_API void sexp_maybe_unblock_port (sexp ctx, sexp in);
#define SEXP_COPY_DEFAULT SEXP_ZERO #define SEXP_COPY_DEFAULT SEXP_ZERO
#define SEXP_COPY_FREEP SEXP_ONE #define SEXP_COPY_FREEP SEXP_ONE
#define SEXP_COPY_LOADP SEXP_TWO
#if SEXP_USE_GLOBAL_HEAP #if SEXP_USE_GLOBAL_HEAP
#define sexp_free_heap(heap) #define sexp_free_heap(heap)
@ -1236,7 +1251,8 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj)
#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); #define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b);
#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b) #define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx sexp_api_pass(NULL, 1), s)
#define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx sexp_api_pass(NULL, 2), s, b)
#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i) #define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx sexp_api_pass(NULL, 2), l, i)
#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c) #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c)
#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c) #define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c)

5
lib/chibi/ast.c
View file

@ -53,7 +53,7 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) {
else if (! sexp_opcode_name(op)) else if (! sexp_opcode_name(op))
return SEXP_FALSE; return SEXP_FALSE;
else else
return sexp_intern(ctx, sexp_opcode_name(op), -1); return sexp_opcode_name(op);
} }
static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
@ -162,7 +162,7 @@ static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) {
static sexp sexp_type_name_op (sexp ctx sexp_api_params(self, n), sexp t) { static sexp sexp_type_name_op (sexp ctx sexp_api_params(self, n), sexp t) {
sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
return sexp_c_string(ctx, sexp_type_name(t), -1); return sexp_type_name(t);
} }
static sexp sexp_type_cpl_op (sexp ctx sexp_api_params(self, n), sexp t) { static sexp sexp_type_cpl_op (sexp ctx sexp_api_params(self, n), sexp t) {
@ -284,7 +284,6 @@ static sexp sexp_gc_op (sexp ctx sexp_api_params(self, n)) {
return sexp_make_unsigned_integer(ctx, sum_freed); return sexp_make_unsigned_integer(ctx, sum_freed);
} }
static sexp sexp_string_contains (sexp ctx sexp_api_params(self, n), sexp x, sexp y) { static sexp sexp_string_contains (sexp ctx sexp_api_params(self, n), sexp x, sexp y) {
const char *res; const char *res;
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x); sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);

4
lib/chibi/disasm.c
View file

@ -33,7 +33,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
if (sexp_procedurep(bc)) { if (sexp_procedurep(bc)) {
bc = sexp_procedure_code(bc); bc = sexp_procedure_code(bc);
} else if (sexp_opcodep(bc)) { } else if (sexp_opcodep(bc)) {
sexp_write_string(ctx, sexp_opcode_name(bc), out); sexp_display(ctx, sexp_opcode_name(bc), out);
sexp_write_string(ctx, " is a primitive\n", out); sexp_write_string(ctx, " is a primitive\n", out);
return SEXP_VOID; return SEXP_VOID;
} else if (! sexp_bytecodep(bc)) { } else if (! sexp_bytecodep(bc)) {
@ -87,7 +87,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
case SEXP_OP_FCALL4: case SEXP_OP_FCALL4:
sexp_write_pointer(ctx, ((sexp*)ip)[0], out); sexp_write_pointer(ctx, ((sexp*)ip)[0], out);
sexp_write_char(ctx, '\n', out); sexp_write_char(ctx, '\n', out);
sexp_write_string(ctx, sexp_opcode_name(((sexp*)ip)[0]), out); sexp_display(ctx, sexp_opcode_name(((sexp*)ip)[0]), out);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_REF:

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

@ -41,7 +41,7 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
} else { } else {
print_name: print_name:
sexp_write_string(ctx, "#<", out); sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx, sexp_object_type_name(ctx, x), out); sexp_display(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out); sexp_write_string(ctx, ">", out);
} }
} }
@ -97,7 +97,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
res = SEXP_NULL; res = SEXP_NULL;
for (i=hi_type; i>0; i--) for (i=hi_type; i>0; i--)
if (stats[i]) { if (stats[i]) {
name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res); res = sexp_cons(ctx, tmp, res);
} }

5
lib/chibi/optimize/rest.c
View file

@ -9,7 +9,7 @@ static sexp sexp_num_parameters (sexp ctx sexp_api_params(self, n)) {
} }
struct sexp_opcode_struct local_ref_op = struct sexp_opcode_struct local_ref_op =
{SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, "local-ref", SEXP_VOID, {SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, (sexp)"local-ref", SEXP_VOID,
NULL, NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM), NULL, NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM),
0, 0, NULL}; 0, 0, NULL};
@ -24,7 +24,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_gc_preserve2(ctx, name, op); sexp_gc_preserve2(ctx, name, op);
sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters); sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters);
op = sexp_copy_opcode(ctx, &local_ref_op); op = sexp_copy_opcode(ctx, &local_ref_op);
name = sexp_intern(ctx, sexp_opcode_name(op), -1); sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1);
name = sexp_string_to_symbol(ctx, sexp_opcode_name(op));
sexp_env_define(ctx, env, name, op); sexp_env_define(ctx, env, name, op);
sexp_gc_release2(ctx); sexp_gc_release2(ctx);
return SEXP_VOID; return SEXP_VOID;

99
main.c
View file

@ -18,6 +18,80 @@
#define exit_failure() exit(70) #define exit_failure() exit(70)
#endif #endif
#if SEXP_USE_IMAGE_LOADING
#include <sys/types.h>
#include <sys/uio.h>
#include <unistd.h>
#define SEXP_IMAGE_MAGIC "\x07\x07chibi\n\0"
#define SEXP_IMAGE_MAJOR_VERSION 1
#define SEXP_IMAGE_MINOR_VERSION 0
typedef struct sexp_image_header_t* sexp_image_header;
struct sexp_image_header_t {
const char magic[8];
short major, minor;
sexp_uint_t size, base, context;
};
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 ctx, *globals, *types;
int fd;
sexp_sint_t offset;
char* image;
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;
}
read(fd, &header, sizeof(header));
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;
}
image = malloc(sexp_heap_pad_size(header.size));
read(fd, image, header.size);
offset = (sexp_sint_t)(image - (sexp_sint_t)header.base);
ctx = (sexp)(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));
sexp_offset_heap_pointers((sexp_heap)image, (sexp_heap)header.base, types, sexp_fx_add(SEXP_COPY_LOADP, SEXP_COPY_FREEP));
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;
file = fopen(path, "w");
if (!file) {
fprintf(stderr, "couldn't open image file for writing: %s\n", path);
return 0;
}
heap = sexp_context_heap(ctx);
memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
header.major = SEXP_IMAGE_MAJOR_VERSION;
header.minor = SEXP_IMAGE_MINOR_VERSION;
header.size = heap->size;
header.base = (sexp_uint_t)heap;
header.context = (sexp_uint_t)ctx;
fwrite(&header, sizeof(header), 1, file);
fwrite(heap, heap->size, 1, file);
fclose(file);
return 1;
}
#endif
static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) { static sexp sexp_param_ref (sexp ctx, sexp env, sexp name) {
sexp res=sexp_env_ref(env, name, SEXP_FALSE); sexp res=sexp_env_ref(env, name, SEXP_FALSE);
return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : SEXP_VOID; return sexp_opcodep(res) ? sexp_parameter_ref(ctx, res) : SEXP_VOID;
@ -211,6 +285,29 @@ void run_main (int argc, char **argv) {
if (sexp_isalpha(*arg)) heap_max_size *= multiplier(*arg++); if (sexp_isalpha(*arg)) heap_max_size *= multiplier(*arg++);
} }
break; break;
#if SEXP_USE_IMAGE_LOADING
case 'i':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
if (ctx) {
fprintf(stderr, "-:i <file>: image files must be loaded first\n");
exit_failure();
}
ctx = sexp_load_image(arg);
if (!ctx) {
fprintf(stderr, "-:i <file>: couldn't open file for reading: %s\n", arg);
exit_failure();
}
env = sexp_context_env(ctx);
init_loaded++;
break;
case 'd':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
if (!sexp_save_image(ctx, arg))
exit_failure();
quit = 1;
break;
#endif
case 'V': case 'V':
load_init(); load_init();
if (! sexp_oportp(out)) if (! sexp_oportp(out))
@ -241,7 +338,7 @@ void run_main (int argc, char **argv) {
else else
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args);
sexp_eval_string(ctx, sexp_argv_proc, -1, env); /* sexp_eval_string(ctx, sexp_argv_proc, -1, env); */
if (i < argc) { /* script usage */ if (i < argc) { /* script usage */
sexp_context_tracep(ctx) = 1; sexp_context_tracep(ctx) = 1;
check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env));

6
opcodes.c
View file

@ -1,7 +1,11 @@
#define _I(n) sexp_make_fixnum(n) #define _I(n) sexp_make_fixnum(n)
#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, s, d, NULL, NULL, rt, a1, a2, a3, f} #define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, SEXP_FALSE, f}
#if SEXP_USE_IMAGE_LOADING
#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, SEXP_FALSE, (sexp_proc1)f}
#else
#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f) #define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f)
#endif
#define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f) #define _FN0(rt, s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, rt, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, s, d, f)
#define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) #define _FN1(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f)
#define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f) #define _FN1OPT(rt, a1, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, rt, a1, SEXP_FALSE, SEXP_FALSE, s, d, f)

111
sexp.c
View file

@ -71,7 +71,7 @@ sexp sexp_write_simple_object (sexp ctx sexp_api_params(self, n), sexp obj, sexp
sexp_write_char(ctx, '{', out); sexp_write_char(ctx, '{', out);
sexp_write_string(ctx, sexp_write_string(ctx,
(i < sexp_context_num_types(ctx)) (i < sexp_context_num_types(ctx))
? sexp_type_name_by_index(ctx, i) : "invalid", ? sexp_string_data(sexp_type_name_by_index(ctx, i)) : "invalid",
out); out);
t = sexp_object_type(ctx, obj); t = sexp_object_type(ctx, obj);
len = sexp_type_num_slots_of_object(t, obj); len = sexp_type_num_slots_of_object(t, obj);
@ -112,55 +112,61 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) {
#define SEXP_FINALIZE_PORT NULL #define SEXP_FINALIZE_PORT NULL
#endif #endif
static struct sexp_type_struct _sexp_type_specs[] = { #if SEXP_USE_DL
{SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, sexp sexp_finalize_dl (sexp ctx sexp_api_params(self, n), sexp dl) {
{SEXP_TYPE, sexp_offsetof(type, cpl), 2, 2, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, "type", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, dlclose(sexp_dl_handle(dl));
{SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, return SEXP_VOID;
{SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, }
{SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, "pair", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, "symbol", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, "byte-vector", SEXP_FALSE, SEXP_FALSE, 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, "string", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
#else
{SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, "string", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
#endif #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, "vector", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, "real", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, static struct sexp_type_struct _sexp_type_specs[] = {
{SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, "bignum", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_TYPE, sexp_offsetof(type, name), 3, 3, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, 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, 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, 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, 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, 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, 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, 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, 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, NULL, NULL},
#if SEXP_USE_RATIOS #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, "ratio", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
#endif #endif
#if SEXP_USE_COMPLEX #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, "complex", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
#endif #endif
{SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL}, {SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL},
{SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL}, {SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL},
{SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, "exception", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, "procedure", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
{SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, "macro", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
{SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Syntactic-Closure", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
#if SEXP_USE_RENAME_BINDINGS {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, NULL, NULL},
{SEXP_ENV, sexp_offsetof(env, parent), 4, 4, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
#else {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, NULL, NULL},
{SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, 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_finalize_dl, NULL},
#endif #endif
{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, "bytecode", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, {SEXP_OPCODE, sexp_offsetof(opcode, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, "core-form", SEXP_FALSE, SEXP_FALSE, 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, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, "opcode", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Conditional", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, "lambda", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Reference", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, "conditional", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {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, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, "reference", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sequence", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, "set!", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Literal", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object},
{SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, "sequence", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, 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, NULL, NULL},
{SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, "literal", SEXP_FALSE, SEXP_FALSE, NULL, (sexp_proc3)sexp_write_simple_object}, {SEXP_CONTEXT, sexp_offsetof(context, bc), 13+SEXP_USE_DL, 13+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
{SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, 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, NULL, NULL},
{SEXP_CONTEXT, sexp_offsetof(context, bc), 13, 13, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, 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, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
#if SEXP_USE_AUTO_FORCE #if SEXP_USE_AUTO_FORCE
{SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, "promise", SEXP_FALSE, SEXP_FALSE, NULL, NULL}, {SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, NULL},
#endif #endif
}; };
@ -216,7 +222,8 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo); sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo);
sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws); sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws);
sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we); sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we);
sexp_type_name(type) = strdup(sexp_string_data(name)); /* sexp_type_name(type) = strdup(sexp_string_data(name)); */
sexp_type_name(type) = name;
sexp_type_finalize(type) = f; sexp_type_finalize(type) = f;
sexp_type_print(type) = p; sexp_type_print(type) = p;
if (sexp_typep(parent)) { if (sexp_typep(parent)) {
@ -269,7 +276,7 @@ static sexp sexp_find_type_by_name(sexp ctx, sexp str) {
int i, len; int i, len;
const char* name = sexp_string_data(str); const char* name = sexp_string_data(str);
for (i=0, len=sexp_context_num_types(ctx); i<len; i++) for (i=0, len=sexp_context_num_types(ctx); i<len; i++)
if (strcmp(name, sexp_type_name_by_index(ctx, i)) == 0) if (strcmp(name, sexp_string_data(sexp_type_name_by_index(ctx, i))) == 0)
return sexp_type_by_index(ctx, i); return sexp_type_by_index(ctx, i);
return SEXP_FALSE; return SEXP_FALSE;
} }
@ -326,6 +333,7 @@ void sexp_init_context_globals (sexp ctx) {
type = sexp_alloc_type(ctx, type, SEXP_TYPE); type = sexp_alloc_type(ctx, type, SEXP_TYPE);
memcpy(&(type->value), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0])); memcpy(&(type->value), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
vec[i] = type; vec[i] = type;
sexp_type_name(type) = sexp_c_string(ctx, (char*)sexp_type_name(type), -1);
} }
} }
@ -377,6 +385,9 @@ sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) {
#if SEXP_USE_GREEN_THREADS #if SEXP_USE_GREEN_THREADS
sexp_context_event(res) = SEXP_FALSE; sexp_context_event(res) = SEXP_FALSE;
sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM; sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM;
#endif
#if SEXP_USE_DL
sexp_context_dl(res) = ctx ? sexp_context_dl(ctx) : SEXP_FALSE;
#endif #endif
if (ctx) { if (ctx) {
sexp_context_globals(res) = sexp_context_globals(ctx); sexp_context_globals(res) = sexp_context_globals(ctx);
@ -466,7 +477,7 @@ sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) {
sexp_gc_var1(res); sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res); sexp_gc_preserve1(ctx, res);
res = sexp_string_cat3(ctx, "invalid type, expected ", res = sexp_string_cat3(ctx, "invalid type, expected ",
sexp_type_name_by_index(ctx, type_id), ""); sexp_string_data(sexp_type_name_by_index(ctx, type_id)), "");
res = type_exception(ctx, self, res, obj, SEXP_FALSE); res = type_exception(ctx, self, res, obj, SEXP_FALSE);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
return res; return res;
@ -500,7 +511,7 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp
} }
} else if (sexp_opcodep(sexp_exception_procedure(exn))) { } else if (sexp_opcodep(sexp_exception_procedure(exn))) {
sexp_write_string(ctx, " in ", out); sexp_write_string(ctx, " in ", out);
sexp_write_string(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out); sexp_display(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
} }
} }
ls = sexp_exception_source(exn); ls = sexp_exception_source(exn);
@ -1397,7 +1408,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
break; break;
case SEXP_TYPE: case SEXP_TYPE:
sexp_write_string(ctx, "#<type ", out); sexp_write_string(ctx, "#<type ", out);
sexp_write_string(ctx, sexp_type_name(obj), out); sexp_display(ctx, sexp_type_name(obj), out);
sexp_write_string(ctx, ">", out); sexp_write_string(ctx, ">", out);
break; break;
case SEXP_STRING: case SEXP_STRING:
@ -1458,7 +1469,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
#endif #endif
case SEXP_OPCODE: case SEXP_OPCODE:
sexp_write_string(ctx, "#<opcode ", out); sexp_write_string(ctx, "#<opcode ", out);
sexp_write_string(ctx, sexp_opcode_name(obj), out); sexp_display(ctx, sexp_opcode_name(obj), out);
sexp_write_char(ctx, '>', out); sexp_write_char(ctx, '>', out);
break; break;
#if SEXP_USE_BYTEVECTOR_LITERALS #if SEXP_USE_BYTEVECTOR_LITERALS
@ -1486,7 +1497,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
if (sexp_exceptionp(x)) return x; if (sexp_exceptionp(x)) return x;
} else { } else {
sexp_write_string(ctx, "#<", out); sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx, sexp_type_name(x), out); sexp_display(ctx, sexp_type_name(x), out);
sexp_write_char(ctx, '>', out); sexp_write_char(ctx, '>', out);
} }
} }

6
vm.c
View file

@ -642,7 +642,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
refs = sexp_cons(ctx2, op, refs); refs = sexp_cons(ctx2, op, refs);
generate_opcode_app(ctx2, refs); generate_opcode_app(ctx2, refs);
bc = finalize_bytecode(ctx2); bc = finalize_bytecode(ctx2);
sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); sexp_bytecode_name(bc) = sexp_opcode_name(op);
res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
if (i == sexp_opcode_num_args(op)) if (i == sexp_opcode_num_args(op))
sexp_opcode_proc(op) = res; sexp_opcode_proc(op) = res;
@ -1331,14 +1331,14 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_REF:
_ALIGN_IP(); _ALIGN_IP();
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-ref: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
_ARG1 = sexp_slot_ref(_ARG1, _UWORD1); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
ip += sizeof(sexp)*2; ip += sizeof(sexp)*2;
break; break;
case SEXP_OP_SLOT_SET: case SEXP_OP_SLOT_SET:
_ALIGN_IP(); _ALIGN_IP();
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-set!: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
else if (sexp_immutablep(_ARG1)) else if (sexp_immutablep(_ARG1))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
sexp_slot_set(_ARG1, _UWORD1, _ARG2); sexp_slot_set(_ARG1, _UWORD1, _ARG2);