mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
progress
This commit is contained in:
Alex Shinn
parent
bafd9ebd29
commit
cce116bc0a
6 changed files with 265 additions and 79 deletions
2
debug.c
2
debug.c
|
|
@ -20,7 +20,7 @@ static const char* reverse_opcode_names[] =
|
|||
"NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
|
||||
};
|
||||
|
||||
static sexp sexp_disasm (sexp bc, sexp out) {
|
||||
static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
|
||||
unsigned char *ip, opcode;
|
||||
if (sexp_procedurep(bc))
|
||||
bc = sexp_procedure_code(bc);
|
||||
|
|
|
|||
29
eval.c
29
eval.c
|
|
@ -251,7 +251,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
|
|||
if (ctx) sexp_gc_preserve(ctx, res, save_res);
|
||||
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
|
||||
if ((! stack) || (stack == SEXP_FALSE)) {
|
||||
stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK);
|
||||
stack = sexp_alloc_tagged(ctx, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK);
|
||||
sexp_stack_length(stack) = INIT_STACK_SIZE;
|
||||
sexp_stack_top(stack) = 0;
|
||||
}
|
||||
|
|
@ -451,7 +451,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
|
|||
sexp_gc_preserve(ctx, tmp, s_tmp);
|
||||
sexp_gc_preserve(ctx, value, s_value);
|
||||
sexp_gc_preserve(ctx, defs, s_defs);
|
||||
/* verify syntax */
|
||||
/* verify syntax - XXXX release! */
|
||||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
|
||||
return sexp_compile_error(ctx, "bad lambda syntax", x);
|
||||
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
|
|
@ -462,25 +462,19 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
|
|||
/* build lambda and analyze body */
|
||||
res = sexp_make_lambda(ctx, sexp_cadr(x));
|
||||
ctx = sexp_make_child_context(ctx, res);
|
||||
sexp_context_env(ctx)
|
||||
= extend_env(ctx,
|
||||
sexp_context_env(ctx),
|
||||
sexp_flatten_dot(ctx, sexp_lambda_params(res)),
|
||||
res);
|
||||
tmp = sexp_flatten_dot(ctx, sexp_lambda_params(res));
|
||||
sexp_context_env(ctx) = extend_env(ctx, sexp_context_env(ctx), tmp, res);
|
||||
sexp_env_lambda(sexp_context_env(ctx)) = res;
|
||||
body = analyze_seq(ctx, sexp_cddr(x));
|
||||
analyze_check_exception(body);
|
||||
/* delayed analyze internal defines */
|
||||
defs = SEXP_NULL;
|
||||
for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
||||
tmp = sexp_car(ls);
|
||||
if (sexp_pairp(sexp_cadr(tmp))) {
|
||||
name = sexp_caadr(tmp);
|
||||
value = analyze_lambda(ctx,
|
||||
sexp_cons(ctx,
|
||||
SEXP_VOID,
|
||||
sexp_cons(ctx,
|
||||
sexp_cdadr(tmp),
|
||||
sexp_cddr(tmp))));
|
||||
tmp = sexp_cons(ctx, sexp_cdadr(tmp), sexp_cddr(tmp));
|
||||
value = analyze_lambda(ctx, sexp_cons(ctx, SEXP_VOID, tmp));
|
||||
} else {
|
||||
name = sexp_cadr(tmp);
|
||||
value = analyze(ctx, sexp_caddr(tmp));
|
||||
|
|
@ -1709,6 +1703,7 @@ sexp vm (sexp proc, sexp ctx) {
|
|||
|
||||
end_loop:
|
||||
sexp_gc_release(ctx, self, s_self);
|
||||
sexp_context_top(ctx) = top;
|
||||
return _ARG1;
|
||||
}
|
||||
|
||||
|
|
@ -1767,14 +1762,15 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
|
|||
sexp_gc_preserve(ctx, x, s_x);
|
||||
sexp_gc_preserve(ctx, in, s_in);
|
||||
ctx2 = sexp_make_context(ctx, NULL, env);
|
||||
sexp_context_parent(ctx2) = ctx;
|
||||
out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
|
||||
tmp = sexp_env_bindings(env);
|
||||
sexp_context_tailp(ctx2) = 0;
|
||||
in = sexp_open_input_file(ctx, source);
|
||||
if (sexp_exceptionp(in)) {
|
||||
sexp_print_exception(ctx, in, out);
|
||||
return in;
|
||||
}
|
||||
res = in;
|
||||
} else {
|
||||
while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) {
|
||||
res = eval_in_context(ctx2, x);
|
||||
if (sexp_exceptionp(res))
|
||||
|
|
@ -1787,6 +1783,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
|
|||
if (sexp_oportp(out))
|
||||
sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
|
||||
#endif
|
||||
}
|
||||
sexp_gc_release(ctx, ctx2, s_ctx2);
|
||||
return res;
|
||||
}
|
||||
|
|
@ -1957,10 +1954,10 @@ sexp apply (sexp ctx, sexp proc, sexp args) {
|
|||
stack[--offset] = sexp_car(ls);
|
||||
stack[top] = sexp_make_integer(top);
|
||||
top++;
|
||||
sexp_context_top(ctx) = top + 3;
|
||||
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
|
||||
stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID);
|
||||
stack[top++] = sexp_make_integer(0);
|
||||
sexp_context_top(ctx) = top;
|
||||
return vm(proc, ctx);
|
||||
}
|
||||
|
||||
|
|
|
|||
148
gc.c
148
gc.c
|
|
@ -13,11 +13,13 @@ static char* sexp_heap;
|
|||
static char* sexp_heap_end;
|
||||
static sexp sexp_free_list;
|
||||
|
||||
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
||||
static sexp* stack_base;
|
||||
|
||||
sexp_uint_t sexp_allocated_bytes0 (sexp x) {
|
||||
switch (sexp_pointer_tag(x)) {
|
||||
case SEXP_PAIR: return sexp_sizeof(pair);
|
||||
case SEXP_SYMBOL: return sexp_sizeof(symbol);
|
||||
case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x);
|
||||
case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x)+1;
|
||||
case SEXP_VECTOR:
|
||||
return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp));
|
||||
case SEXP_STACK:
|
||||
|
|
@ -45,6 +47,21 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
|
|||
}
|
||||
}
|
||||
|
||||
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
||||
sexp_uint_t res, *len_ptr;
|
||||
sexp t;
|
||||
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT))
|
||||
return sexp_align(1, 4);
|
||||
t = &(sexp_types[sexp_pointer_tag(x)]);
|
||||
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));
|
||||
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
|
||||
if (res != sexp_allocated_bytes0(x)) {
|
||||
fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res);
|
||||
/* exit(1); */
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
void sexp_mark (sexp x) {
|
||||
sexp *data;
|
||||
sexp_uint_t i;
|
||||
|
|
@ -433,8 +450,20 @@ void sexp_show_free_list (sexp ctx) {
|
|||
putc('\n', stderr);
|
||||
}
|
||||
|
||||
sexp sexp_sweep (sexp ctx) {
|
||||
sexp_uint_t freed=0, size;
|
||||
void validate_free_list (sexp ctx) {
|
||||
sexp p=sexp_free_list, prev=NULL;
|
||||
while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) {
|
||||
if (((char*)p < sexp_heap) || ((char*)p >= sexp_heap_end))
|
||||
fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev);
|
||||
if (p < prev)
|
||||
fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p));
|
||||
prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p));
|
||||
p = sexp_cdr(p);
|
||||
}
|
||||
}
|
||||
|
||||
void validate_heap (sexp ctx) {
|
||||
sexp_uint_t size;
|
||||
sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4));
|
||||
sexp q=sexp_free_list, r;
|
||||
/* scan over the whole heap */
|
||||
|
|
@ -448,53 +477,128 @@ sexp sexp_sweep (sexp ctx) {
|
|||
continue;
|
||||
}
|
||||
size = sexp_align(sexp_allocated_bytes(p), 4);
|
||||
if (sexp_pointer_tag(p) == 0) {
|
||||
fprintf(stderr, "bare object found at %p\n", p);
|
||||
} else if (sexp_pointer_tag(p) == 0) {
|
||||
fprintf(stderr, "type object found at %p\n", p);
|
||||
} else if (sexp_pointer_tag(p) > SEXP_CONTEXT) {
|
||||
fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p));
|
||||
}
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
}
|
||||
|
||||
void validate_gc_vars (sexp ctx) {
|
||||
struct sexp_gc_var_t *saves, *prev=NULL;
|
||||
if (! ctx)
|
||||
return;
|
||||
for (saves=sexp_context_saves(ctx); saves; saves=saves->next) {
|
||||
/* if (saves->var) { */
|
||||
/* if (((char*)*(saves->var) < sexp_heap) */
|
||||
/* || ((char*)*(saves->var) >= sexp_heap_end)) */
|
||||
/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */
|
||||
/* } */
|
||||
if (prev && (prev > saves)) {
|
||||
fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves);
|
||||
return;
|
||||
} else if (prev == saves) {
|
||||
fprintf(stderr, "loop in gc vars at %p\n", saves);
|
||||
return;
|
||||
}
|
||||
prev = saves;
|
||||
}
|
||||
}
|
||||
|
||||
void validate_freed_pointer (sexp x, sexp *start) {
|
||||
sexp *p;
|
||||
for (p=start; p<stack_base; p++) {
|
||||
if (*p == x) {
|
||||
fprintf(stderr, "reference to freed var %p at %p: ", x, p);
|
||||
simple_write(x, 1, stderr);
|
||||
putc('\n', stderr);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sexp sexp_sweep (sexp ctx) {
|
||||
sexp_uint_t freed, max_freed=0, sum_freed=0, size;
|
||||
sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4));
|
||||
sexp q=sexp_free_list, r;
|
||||
/* scan over the whole heap */
|
||||
while (((char*)p) < sexp_heap_end) {
|
||||
/* find the preceding and succeeding free list pointers */
|
||||
for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r))
|
||||
;
|
||||
/* fprintf(stderr, "p: %p q: %p r: %p\n", p, q, r); */
|
||||
if (r == p) {
|
||||
p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
|
||||
continue;
|
||||
} else if (p <= q) {
|
||||
fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q);
|
||||
}
|
||||
size = sexp_align(sexp_allocated_bytes(p), 4);
|
||||
if (! sexp_gc_mark(p)) {
|
||||
/* fprintf(stderr, "\x1B[31mfreeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */
|
||||
/* simple_write(p, 1, stderr); */
|
||||
/* fprintf(stderr, "\x1B[0m\n"); */
|
||||
freed += size;
|
||||
validate_freed_pointer(p, &ctx);
|
||||
sum_freed += size;
|
||||
if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
|
||||
&& (q != sexp_free_list)) {
|
||||
/* merge q with p */
|
||||
/* fprintf(stderr, "\x1B[34mleft merging %lu bytes @ %p ", size, p); */
|
||||
/* simple_write(p, 1, stderr); */
|
||||
/* fprintf(stderr, " with %lu bytes @ %p (%p)\x1B[0m\n", */
|
||||
/* (sexp_uint_t)sexp_car(q), q, sexp_cdr(q)); */
|
||||
if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
|
||||
/* ... and with r */
|
||||
sexp_car(q)
|
||||
= (sexp)(size+(sexp_uint_t)sexp_car(q)+(sexp_uint_t)sexp_car(r));
|
||||
sexp_cdr(q) = sexp_cdr(r);
|
||||
r = sexp_cdr(r);
|
||||
freed = (sexp_uint_t)sexp_car(q) + size + (sexp_uint_t)sexp_car(r);
|
||||
p = (sexp) (((char*)p)+size+(sexp_uint_t)sexp_car(r));
|
||||
} else {
|
||||
sexp_car(q) = (sexp)(size+(sexp_uint_t)sexp_car(q));
|
||||
freed = (sexp_uint_t)sexp_car(q) + size;
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
sexp_car(q) = (sexp)freed;
|
||||
} else {
|
||||
sexp_pointer_tag(p) = SEXP_PAIR;
|
||||
if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
|
||||
/* merge p with r */
|
||||
/* fprintf(stderr, "\x1B[34mright merging %lu bytes @ %p ", size, p); */
|
||||
/* simple_write(p, 1, stderr); */
|
||||
/* fprintf(stderr, " with %lu bytes @ %p (%p)\x1B[0m\n", */
|
||||
/* (sexp_uint_t)sexp_car(r), r, sexp_cdr(r)); */
|
||||
sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r));
|
||||
sexp_cdr(p) = sexp_cdr(r);
|
||||
r = p;
|
||||
sexp_cdr(q) = p;
|
||||
freed = size + (sexp_uint_t)sexp_car(r);
|
||||
} else {
|
||||
sexp_car(p) = (sexp)size;
|
||||
sexp_cdr(p) = r;
|
||||
}
|
||||
sexp_cdr(q) = p;
|
||||
freed = size;
|
||||
}
|
||||
sexp_pointer_tag(p) = SEXP_PAIR;
|
||||
p = (sexp) (((char*)p)+freed);
|
||||
}
|
||||
if (freed > max_freed)
|
||||
max_freed = freed;
|
||||
} else {
|
||||
/* fprintf(stderr, "\x1B[32msaving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */
|
||||
/* simple_write(p, 1, stderr); */
|
||||
/* fprintf(stderr, "\x1B[0m\n"); */
|
||||
sexp_gc_mark(p) = 0;
|
||||
}
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
/* fprintf(stderr, "**************** freed %ld bytes ****************\n", freed); */
|
||||
return sexp_make_integer(freed);
|
||||
}
|
||||
fprintf(stderr, "**************** freed %ld bytes, max %ld ****************\n", sum_freed, max_freed);
|
||||
return sexp_make_integer(max_freed);
|
||||
}
|
||||
|
||||
extern sexp continuation_resumer, final_resumer;
|
||||
|
||||
sexp sexp_gc (sexp ctx) {
|
||||
int i;
|
||||
/* fprintf(stderr, "************* garbage collecting *************\n"); */
|
||||
fprintf(stderr, "************* garbage collecting *************\n");
|
||||
/* sexp_show_free_list(ctx); */
|
||||
sexp_mark(continuation_resumer);
|
||||
sexp_mark(final_resumer);
|
||||
|
|
@ -507,7 +611,6 @@ sexp sexp_gc (sexp ctx) {
|
|||
void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) {
|
||||
sexp p=(sexp)(start+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4));
|
||||
sexp q=(sexp)(((char*)sexp_free_list)+offset), r;
|
||||
/* fprintf(stderr, "************* adjusting heap *************\n"); */
|
||||
while (((char*)p) < end) {
|
||||
/* find the preceding and succeeding free list pointers */
|
||||
for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r))
|
||||
|
|
@ -537,7 +640,8 @@ int sexp_grow_heap (sexp ctx, size_t size) {
|
|||
sexp q;
|
||||
size_t cur_size = sexp_heap_end - sexp_heap, new_size;
|
||||
new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4);
|
||||
/* fprintf(stderr, "************* growing heap *************\n"); */
|
||||
fprintf(stderr, "************* growing heap *************\n");
|
||||
validate_heap(ctx);
|
||||
if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) {
|
||||
fprintf(stderr, "************* heap too large *************\n");
|
||||
return 0;
|
||||
|
|
@ -547,6 +651,7 @@ int sexp_grow_heap (sexp ctx, size_t size) {
|
|||
return 0;
|
||||
}
|
||||
if (tmp1 != sexp_heap) {
|
||||
fprintf(stderr, "************* adjusting heap pointers *************\n");
|
||||
sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size);
|
||||
tmp2 = sexp_heap;
|
||||
sexp_heap = tmp1;
|
||||
|
|
@ -592,6 +697,9 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
|
|||
|
||||
void* sexp_alloc (sexp ctx, size_t size) {
|
||||
void *res;
|
||||
validate_heap(ctx);
|
||||
validate_free_list(ctx);
|
||||
validate_gc_vars(ctx);
|
||||
size = sexp_align(size, 4);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
|
|
@ -606,6 +714,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
exit(70);
|
||||
}
|
||||
}
|
||||
/* fprintf(stderr, "sexp_alloc %lu => %p\n", size, res); */
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -622,6 +731,7 @@ void sexp_gc_init () {
|
|||
sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE
|
||||
- sexp_align(sexp_sizeof(pair), 4));
|
||||
sexp_cdr(next) = SEXP_NULL;
|
||||
/* fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); */
|
||||
stack_base = &next;
|
||||
fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next);
|
||||
}
|
||||
|
||||
|
|
|
|||
1
main.c
1
main.c
|
|
@ -18,6 +18,7 @@ void repl (sexp ctx) {
|
|||
sexp_print_exception(ctx, obj, err);
|
||||
} else {
|
||||
tmp = sexp_env_bindings(env);
|
||||
sexp_context_top(ctx) = 0;
|
||||
res = eval_in_context(ctx, obj);
|
||||
#if USE_WARN_UNDEFS
|
||||
sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
|
||||
|
|
|
|||
72
sexp.c
72
sexp.c
|
|
@ -56,6 +56,38 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
|
|||
return res;
|
||||
}
|
||||
|
||||
static struct sexp_struct sexp_types[] = {
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_PAIR, 0, 0, 0, 0, sexp_sizeof(pair), 0, 0, "pair"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_SYMBOL, 0, 0, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, offsetof(struct sexp_struct, value.string.length), 1, "string"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_VECTOR, 0, 0, 0, 0, sexp_sizeof(vector), offsetof(struct sexp_struct, value.vector.length), 4, "vector"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), offsetof(struct sexp_struct, value.bignum.length), 4, "bignum"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_IPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "input-port"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_OPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "output-port"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_EXCEPTION, 0, 0, 0, 0, sexp_sizeof(exception), 0, 0, "exception"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_PROCEDURE, 0, 0, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_MACRO, 0, 0, 0, 0, sexp_sizeof(macro), 0, 0, "macro"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_SYNCLO, 0, 0, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_ENV, 0, 0, 0, 0, sexp_sizeof(env), 0, 0, "environment"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_BYTECODE, 0, 0, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_OPCODE, 0, 0, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_LAMBDA, 0, 0, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_CND, 0, 0, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_REF, 0, 0, 0, 0, sexp_sizeof(ref), 0, 0, "reference"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_SET, 0, 0, 0, 0, sexp_sizeof(set), 0, 0, "set!"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_SEQ, 0, 0, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_LIT, 0, 0, 0, 0, sexp_sizeof(lit), 0, 0, "literal"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_STACK, 0, 0, 0, 0, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"}}},
|
||||
{.tag=SEXP_TYPE, .value={.type={SEXP_CONTEXT, 0, 0, 0, 0, sexp_sizeof(context), 0, 0, "context"}}},
|
||||
};
|
||||
|
||||
#if ! USE_BOEHM
|
||||
#if USE_MALLOC
|
||||
void sexp_deep_free (sexp ctx, sexp obj) {
|
||||
|
|
@ -183,12 +215,19 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
|
|||
}
|
||||
|
||||
static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
|
||||
sexp name = (sexp_port_name(port)
|
||||
sexp res;
|
||||
sexp_gc_var(ctx, name, s_name);
|
||||
sexp_gc_var(ctx, str, s_str);
|
||||
sexp_gc_preserve(ctx, name, s_name);
|
||||
sexp_gc_preserve(ctx, str, s_str);
|
||||
name = (sexp_port_name(port)
|
||||
? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE);
|
||||
return sexp_make_exception(ctx, the_read_error_symbol,
|
||||
sexp_c_string(ctx, msg, -1),
|
||||
irritants, SEXP_FALSE, name,
|
||||
str = sexp_c_string(ctx, msg, -1);
|
||||
res = sexp_make_exception(ctx, the_read_error_symbol,
|
||||
str, irritants, SEXP_FALSE, name,
|
||||
sexp_make_integer(sexp_port_line(port)));
|
||||
sexp_gc_release(ctx, name, s_name);
|
||||
return res;
|
||||
}
|
||||
|
||||
/*************************** list utilities ***************************/
|
||||
|
|
@ -390,7 +429,8 @@ sexp sexp_intern(sexp ctx, char *str) {
|
|||
struct huff_entry he;
|
||||
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket;
|
||||
char c, *p=str;
|
||||
sexp sym, ls;
|
||||
sexp ls;
|
||||
sexp_gc_var(ctx, sym, s_sym);
|
||||
|
||||
#if USE_HUFF_SYMS
|
||||
res = 0;
|
||||
|
|
@ -418,9 +458,11 @@ sexp sexp_intern(sexp ctx, char *str) {
|
|||
return sexp_car(ls);
|
||||
|
||||
/* not found, make a new symbol */
|
||||
sexp_gc_preserve(ctx, sym, s_sym);
|
||||
sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL);
|
||||
sexp_symbol_string(sym) = sexp_c_string(ctx, str, len);
|
||||
sexp_push(ctx, sexp_symbol_table[bucket], sym);
|
||||
sexp_gc_release(ctx, sym, s_sym);
|
||||
return sym;
|
||||
}
|
||||
|
||||
|
|
@ -519,24 +561,30 @@ off_t sstream_seek (void *vec, off_t offset, int whence) {
|
|||
|
||||
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
|
||||
FILE *in;
|
||||
sexp res, cookie;
|
||||
sexp res;
|
||||
sexp_gc_var(ctx, cookie, s_cookie);
|
||||
sexp_gc_preserve(ctx, cookie, s_cookie);
|
||||
cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)),
|
||||
sexp_make_integer(0));
|
||||
in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
|
||||
res = sexp_make_input_port(ctx, in, NULL);
|
||||
sexp_port_cookie(res) = cookie;
|
||||
sexp_gc_release(ctx, cookie, s_cookie);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_make_output_string_port (sexp ctx) {
|
||||
FILE *out;
|
||||
sexp res, size, cookie;
|
||||
sexp res, size;
|
||||
sexp_gc_var(ctx, cookie, s_cookie);
|
||||
sexp_gc_preserve(ctx, cookie, s_cookie);
|
||||
size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE);
|
||||
cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID),
|
||||
size, sexp_make_integer(0));
|
||||
out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
|
||||
res = sexp_make_output_port(ctx, out, NULL);
|
||||
sexp_port_cookie(res) = cookie;
|
||||
sexp_gc_release(ctx, cookie, s_cookie);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -697,6 +745,11 @@ void sexp_write (sexp obj, sexp out) {
|
|||
sexp_write_string(">", out);
|
||||
break;
|
||||
#endif
|
||||
case SEXP_TYPE:
|
||||
sexp_write_string("#<type ", out);
|
||||
sexp_write_string(sexp_type_name(obj), out);
|
||||
sexp_write_string(">", out);
|
||||
break;
|
||||
case SEXP_STRING:
|
||||
sexp_write_char('"', out);
|
||||
i = sexp_string_length(obj);
|
||||
|
|
@ -1015,7 +1068,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
/* case '0': case '1': case '2': case '3': case '4': */
|
||||
/* case '5': case '6': case '7': case '8': case '9': */
|
||||
case ';':
|
||||
sexp_read_raw(ctx, in); /* discard */
|
||||
tmp = sexp_read_raw(ctx, in); /* discard */
|
||||
if (sexp_exceptionp(tmp))
|
||||
res = tmp;
|
||||
else
|
||||
goto scan_loop;
|
||||
case '\\':
|
||||
c1 = sexp_read_char(in);
|
||||
|
|
|
|||
66
sexp.h
66
sexp.h
|
|
@ -52,6 +52,7 @@
|
|||
|
||||
enum sexp_types {
|
||||
SEXP_OBJECT,
|
||||
SEXP_TYPE,
|
||||
SEXP_FIXNUM,
|
||||
SEXP_CHAR,
|
||||
SEXP_BOOLEAN,
|
||||
|
|
@ -84,7 +85,7 @@ enum sexp_types {
|
|||
|
||||
typedef unsigned long sexp_uint_t;
|
||||
typedef long sexp_sint_t;
|
||||
typedef char sexp_tag_t;
|
||||
typedef unsigned char sexp_tag_t;
|
||||
typedef struct sexp_struct *sexp;
|
||||
|
||||
struct sexp_gc_var_t {
|
||||
|
|
@ -99,6 +100,12 @@ struct sexp_struct {
|
|||
union {
|
||||
/* basic types */
|
||||
double flonum;
|
||||
struct {
|
||||
sexp_tag_t tag;
|
||||
sexp_sint_t field_base, field_len_base, field_len_off, field_len_scale;
|
||||
sexp_sint_t size_base, size_off, size_scale;
|
||||
char *name;
|
||||
} type;
|
||||
struct {
|
||||
sexp car, cdr;
|
||||
} pair;
|
||||
|
|
@ -183,9 +190,9 @@ struct sexp_struct {
|
|||
sexp data[];
|
||||
} stack;
|
||||
struct {
|
||||
sexp bc, lambda, stack, env, fv, parent;
|
||||
struct sexp_gc_var_t *saves;
|
||||
sexp_uint_t pos, depth, tailp, tracep;
|
||||
sexp bc, lambda, stack, env, fv, parent;
|
||||
} context;
|
||||
} value;
|
||||
};
|
||||
|
|
@ -218,29 +225,18 @@ struct sexp_struct {
|
|||
#else
|
||||
|
||||
#define sexp_gc_var(ctx, x, y) \
|
||||
sexp x = SEXP_FALSE; \
|
||||
struct sexp_gc_var_t y = {0, 0};
|
||||
sexp x = SEXP_VOID; \
|
||||
struct sexp_gc_var_t y = {NULL, NULL};
|
||||
|
||||
#define sexp_gc_preserve(ctx, x, y) \
|
||||
do { \
|
||||
(y).var = &(x); \
|
||||
(y).next = sexp_context_saves(ctx); \
|
||||
sexp_context_saves(ctx) = &(y); \
|
||||
} while (0)
|
||||
|
||||
#define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \
|
||||
(y).next = sexp_context_saves(ctx), \
|
||||
sexp_context_saves(ctx) = &(y))
|
||||
#define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next)
|
||||
|
||||
#define sexp_with_gc_var1(ctx, x, body) \
|
||||
sexp_gc_var(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
|
||||
do {body} while (0); \
|
||||
sexp_gc_release(ctx, x, _sexp_gcv1);
|
||||
|
||||
#define sexp_with_gc_var2(ctx, x, y, body) \
|
||||
sexp_gc_var(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_var(ctx, y, _sexp_gcv2); \
|
||||
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_preserve(ctx, y, _sexp_gcv2); \
|
||||
do {body} while (0); \
|
||||
sexp_gc_release(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_release(ctx, y, _sexp_gcv2);
|
||||
|
||||
#if USE_MALLOC
|
||||
#define sexp_alloc(ctx, size) malloc(size)
|
||||
#define sexp_alloc_atomic(ctx, size) malloc(size)
|
||||
|
|
@ -258,6 +254,21 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
#endif
|
||||
#endif
|
||||
|
||||
#define sexp_with_gc_var1(ctx, x, body) \
|
||||
sexp_gc_var(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
|
||||
do {body} while (0); \
|
||||
sexp_gc_release(ctx, x, _sexp_gcv1);
|
||||
|
||||
#define sexp_with_gc_var2(ctx, x, y, body) \
|
||||
sexp_gc_var(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_var(ctx, y, _sexp_gcv2); \
|
||||
sexp_gc_preserve(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_preserve(ctx, y, _sexp_gcv2); \
|
||||
do {body} while (0); \
|
||||
sexp_gc_release(ctx, x, _sexp_gcv1); \
|
||||
sexp_gc_release(ctx, y, _sexp_gcv2);
|
||||
|
||||
#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
|
||||
|
||||
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
|
||||
|
|
@ -279,6 +290,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
|
||||
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
|
||||
|
||||
#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE))
|
||||
#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR))
|
||||
#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING))
|
||||
#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL))
|
||||
|
|
@ -438,6 +450,16 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
|
||||
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
|
||||
|
||||
#define sexp_type_tag(x) ((x)->value.type.tag)
|
||||
#define sexp_type_field_base(x) ((x)->value.type.field_base)
|
||||
#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
|
||||
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
|
||||
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
|
||||
#define sexp_type_size_base(x) ((x)->value.type.size_base)
|
||||
#define sexp_type_size_off(x) ((x)->value.type.size_off)
|
||||
#define sexp_type_size_scale(x) ((x)->value.type.size_scale)
|
||||
#define sexp_type_name(x) ((x)->value.type.name)
|
||||
|
||||
/****************************** arithmetic ****************************/
|
||||
|
||||
#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue