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

cleanup, removing mid-function returns which could corrupt

Browse source 
the gc_var trace.
This commit is contained in:
Alex Shinn 2009-06-18 00:36:39 +09:00
parent 39fdd89474
commit 7e3014ba38
8 changed files with 205 additions and 169 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme
LDFLAGS=-lm
# -Oz for smaller size on darwin
CFLAGS=-Wall -g -save-temps
CFLAGS=-Wall -O2 -g -save-temps
./gc/gc.a: ./gc/alloc.c
cd gc && make

190
eval.c
View file

@ -246,12 +246,14 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
return res;
}
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE)
static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
sexp_gc_var(ctx, res, save_res);
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, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK);
stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
sexp_stack_length(stack) = INIT_STACK_SIZE;
sexp_stack_top(stack) = 0;
}
@ -354,14 +356,6 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
return exn;
}
#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \
return (x); \
} while (0)
#define analyze_bind(var, x, ctx) do {(var) = analyze(ctx, x); \
analyze_check_exception(var); \
} while (0)
static sexp analyze_app (sexp ctx, sexp x) {
sexp_gc_var(ctx, res, s_res);
sexp_gc_var(ctx, tmp, s_tmp);
@ -429,20 +423,27 @@ static sexp analyze_set (sexp ctx, sexp x) {
sexp_gc_var(ctx, value, s_value);
sexp_gc_preserve(ctx, ref, s_ref);
sexp_gc_preserve(ctx, value, s_value);
ref = analyze_var_ref(ctx, sexp_cadr(x));
if (sexp_lambdap(sexp_ref_loc(ref)))
sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
value = analyze(ctx, sexp_caddr(x));
if (sexp_exceptionp(ref))
res = ref;
else if (sexp_exceptionp(value))
res = value;
else
res = sexp_make_set(ctx, ref, value);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
&& sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
res = sexp_compile_error(ctx, "bad set! syntax", x);
} else {
ref = analyze_var_ref(ctx, sexp_cadr(x));
if (sexp_lambdap(sexp_ref_loc(ref)))
sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
value = analyze(ctx, sexp_caddr(x));
if (sexp_exceptionp(ref))
res = ref;
else if (sexp_exceptionp(value))
res = value;
else
res = sexp_make_set(ctx, ref, value);
}
sexp_gc_release(ctx, ref, s_ref);
return res;
}
#define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
static sexp analyze_lambda (sexp ctx, sexp x) {
sexp name, ls;
sexp_gc_var(ctx, res, s_res);
@ -457,14 +458,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
sexp_gc_preserve(ctx, value, s_value);
sexp_gc_preserve(ctx, defs, s_defs);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
/* verify syntax - XXXX release! */
/* verify syntax */
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
return sexp_compile_error(ctx, "bad lambda syntax", x);
sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_idp(sexp_car(ls)))
return sexp_compile_error(ctx, "non-symbol parameter", x);
sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
return sexp_compile_error(ctx, "duplicate parameter", x);
sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
/* build lambda and analyze body */
res = sexp_make_lambda(ctx, sexp_cadr(x));
ctx2 = sexp_make_child_context(ctx, res);
@ -472,7 +473,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
sexp_context_env(ctx2) = extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
sexp_env_lambda(sexp_context_env(ctx2)) = res;
body = analyze_seq(ctx2, sexp_cddr(x));
analyze_check_exception(body);
if (sexp_exceptionp(body)) sexp_return(res, body);
/* delayed analyze internal defines */
defs = SEXP_NULL;
for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
@ -485,7 +486,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
name = sexp_cadr(tmp);
value = analyze(ctx2, sexp_caddr(tmp));
}
analyze_check_exception(value);
if (sexp_exceptionp(value)) sexp_return(res, value);
sexp_push(ctx2, defs,
sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value));
}
@ -498,6 +499,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
}
sexp_lambda_body(res) = body;
cleanup:
sexp_gc_release(ctx, res, s_res);
return res;
}
@ -510,11 +512,16 @@ static sexp analyze_if (sexp ctx, sexp x) {
sexp_gc_preserve(ctx, test, s_test);
sexp_gc_preserve(ctx, pass, s_pass);
sexp_gc_preserve(ctx, fail, s_fail);
analyze_bind(test, sexp_cadr(x), ctx);
analyze_bind(pass, sexp_caddr(x), ctx);
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
analyze_bind(fail, fail_expr, ctx);
res = sexp_make_cnd(ctx, test, pass, fail);
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad if syntax", x);
} else {
test = analyze(ctx, sexp_cadr(x));
pass = analyze(ctx, sexp_caddr(x));
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
fail = analyze(ctx, fail_expr);
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
}
sexp_gc_release(ctx, test, s_test);
return res;
}
@ -530,35 +537,40 @@ static sexp analyze_define (sexp ctx, sexp x) {
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, env, s_env);
env = sexp_context_env(ctx);
name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx));
sexp_push(ctx, sexp_env_bindings(env), tmp);
sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name);
sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x);
res = SEXP_VOID;
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad define syntax", x);
} else {
env_cell_create(ctx, env, name, SEXP_VOID);
if (sexp_pairp(sexp_cadr(x))) {
tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
value = analyze_lambda(ctx, tmp);
} else
value = analyze(ctx, sexp_caddr(x));
ref = analyze_var_ref(ctx, name);
if (sexp_exceptionp(ref))
res = ref;
else if (sexp_exceptionp(value))
res = value;
else
res = sexp_make_set(ctx, ref, value);
name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx));
sexp_push(ctx, sexp_env_bindings(env), tmp);
sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name);
sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x);
res = SEXP_VOID;
} else {
env_cell_create(ctx, env, name, SEXP_VOID);
if (sexp_pairp(sexp_cadr(x))) {
tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
value = analyze_lambda(ctx, tmp);
} else
value = analyze(ctx, sexp_caddr(x));
ref = analyze_var_ref(ctx, name);
if (sexp_exceptionp(ref))
res = ref;
else if (sexp_exceptionp(value))
res = value;
else
res = sexp_make_set(ctx, ref, value);
}
}
sexp_gc_release(ctx, ref, s_ref);
return res;
}
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
sexp res = SEXP_VOID;
sexp_gc_var(eval_ctx, proc, s_proc);
sexp_gc_var(eval_ctx, mac, s_mac);
sexp_gc_var(eval_ctx, tmp, s_tmp);
@ -566,16 +578,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
sexp_gc_preserve(eval_ctx, mac, s_mac);
sexp_gc_preserve(eval_ctx, tmp, s_tmp);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
proc = eval_in_context(eval_ctx, sexp_cadar(ls));
analyze_check_exception(proc);
if (sexp_procedurep(proc)) {
mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx));
tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
&& sexp_nullp(sexp_cddar(ls)))) {
res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls));
} else {
proc = eval_in_context(eval_ctx, sexp_cadar(ls));
if (sexp_exceptionp(proc)) {
res = proc;
break;
} else if (sexp_procedurep(proc)) {
mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx));
tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
}
}
}
sexp_gc_release(eval_ctx, proc, s_proc);
return SEXP_VOID;
return res;
}
static sexp analyze_define_syntax (sexp ctx, sexp x) {
@ -596,14 +615,17 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) {
sexp_gc_preserve(ctx, env, s_env);
sexp_gc_preserve(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, tmp, s_tmp);
env = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx));
sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx));
ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
sexp_context_env(ctx2) = env;
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2);
analyze_check_exception(tmp);
res = analyze_seq(ctx2, sexp_cddr(x));
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad let-syntax", x);
} else {
env = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx));
sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx));
ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
sexp_context_env(ctx2) = env;
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2);
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x)));
}
sexp_gc_release(ctx, env, s_env);
return res;
}
@ -612,8 +634,12 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
sexp res;
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, tmp, s_tmp);
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx);
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x)));
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
res = sexp_compile_error(ctx, "bad letrec-syntax", x);
} else {
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx);
res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x)));
}
sexp_gc_release(ctx, tmp, s_tmp);
return res;
}
@ -685,8 +711,8 @@ static sexp analyze (sexp ctx, sexp object) {
res = sexp_compile_error(ctx, "too many args for opcode", x);
} else {
res = analyze_app(ctx, sexp_cdr(x));
analyze_check_exception(res);
sexp_push(ctx, res, op);
if (! sexp_exceptionp(res))
sexp_push(ctx, res, op);
}
} else {
res = analyze_app(ctx, x);
@ -2031,15 +2057,19 @@ sexp compile (sexp ctx, sexp x) {
sexp_gc_preserve(ctx, ctx2, s_ctx2);
sexp_gc_preserve(ctx, vec, s_vec);
sexp_gc_preserve(ctx, res, s_res);
analyze_bind(ast, x, ctx);
free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */
ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx));
sexp_context_parent(ctx2) = ctx;
generate(ctx2, ast);
res = finalize_bytecode(ctx2);
vec = sexp_make_vector(ctx, 0, SEXP_VOID);
res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
res, vec);
ast = analyze(ctx, x);
if (sexp_exceptionp(ast)) {
res = ast;
} else {
free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */
ctx2 = sexp_make_context(ctx,sexp_context_stack(ctx),sexp_context_env(ctx));
sexp_context_parent(ctx2) = ctx;
generate(ctx2, ast);
res = finalize_bytecode(ctx2);
vec = sexp_make_vector(ctx, 0, SEXP_VOID);
res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
res, vec);
}
sexp_gc_release(ctx, ast, s_ast);
return res;
}

33
gc.c
View file

@ -4,9 +4,11 @@
#include "sexp.h"
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */
#define SEXP_INITIAL_HEAP_SIZE 37000
#define SEXP_MAXIMUM_HEAP_SIZE 0
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
#define SEXP_GROW_HEAP_RATIO 0.8
typedef struct sexp_heap *sexp_heap;
@ -21,6 +23,11 @@ static sexp_heap heap;
static sexp* stack_base;
extern sexp continuation_resumer, final_resumer;
static sexp_heap sexp_heap_last (sexp_heap h) {
while (h->next) h = h->next;
return h;
}
sexp_uint_t sexp_allocated_bytes (sexp x) {
sexp_uint_t res, *len_ptr;
sexp t;
@ -57,7 +64,7 @@ void sexp_mark (sexp x) {
}
}
#ifdef USE_DEBUG_GC
#if USE_DEBUG_GC
int stack_references_pointer_p (sexp ctx, sexp x) {
sexp *p;
for (p=&x; p<stack_base; p++)
@ -162,9 +169,7 @@ sexp_heap sexp_make_heap (size_t size) {
int sexp_grow_heap (sexp ctx, size_t size) {
size_t cur_size, new_size;
sexp_heap h;
for (h=heap; h->next; h=h->next)
;
sexp_heap h = sexp_heap_last(heap);
cur_size = h->size;
new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4);
h->next = sexp_make_heap(new_size);
@ -200,17 +205,20 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
void* sexp_alloc (sexp ctx, size_t size) {
void *res;
size_t freed;
sexp_heap h;
size = sexp_align(size, 4);
res = sexp_try_alloc(ctx, size);
if (! res) {
if (sexp_unbox_integer(sexp_gc(ctx)) >= size)
res = sexp_try_alloc(ctx, size);
if ((! res) && sexp_grow_heap(ctx, size))
res = sexp_try_alloc(ctx, size);
freed = sexp_unbox_integer(sexp_gc(ctx));
h = sexp_heap_last(heap);
if (((freed < size)
|| ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO)))
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
sexp_grow_heap(ctx, size);
res = sexp_try_alloc(ctx, size);
if (! res) {
fprintf(stderr,
"chibi: out of memory trying to allocate %ld bytes, aborting\n",
size);
fprintf(stderr, "out of memory allocating %ld bytes, aborting\n", size);
exit(70);
}
}
@ -220,6 +228,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
void sexp_gc_init () {
sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4);
heap = sexp_make_heap(size);
/* the +32 is a hack, but this is just for debugging anyway */
stack_base = ((sexp*)&size) + 32;
}

0
sexp-huff.c → opt/sexp-huff.c
View file

0
sexp-hufftabs.c → opt/sexp-hufftabs.c
View file

0
sexp-unhuff.c → opt/sexp-unhuff.c
View file

147
sexp.c
View file

@ -10,9 +10,9 @@ struct huff_entry {
unsigned char len;
unsigned short bits;
};
#include "sexp-hufftabs.c"
#include "opt/sexp-hufftabs.c"
static struct huff_entry huff_table[] = {
#include "sexp-huff.c"
#include "opt/sexp-huff.c"
};
#endif
@ -41,7 +41,6 @@ static int digit_value (c) {
}
static int is_separator(int c) {
/* return (!((c-9)&(~3))) | (~(c^4)); */
return 0<c && c<0x60 && sexp_separators[c];
}
@ -53,70 +52,45 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
return res;
}
#define _TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
#define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
{.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}}
static struct sexp_struct sexp_types[] = {
_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"),
_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"),
_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
_TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"),
_TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"),
_TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
_TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"),
_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"),
_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
_DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
_DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
_DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
_DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"),
_DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"),
_DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
_DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
_DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"),
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"),
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
_DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
_DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
_DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
_DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
_DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
_DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
_DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
_DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"),
_DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
_DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
_DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
_DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
_DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"),
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
};
#undef _TYPE
#undef _DEF_TYPE
#if ! USE_BOEHM
#if USE_MALLOC
void sexp_deep_free (sexp ctx, sexp obj) {
int len, i;
sexp *elts;
if (sexp_pointerp(obj)) {
switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR:
sexp_deep_free(sexp_car(obj));
sexp_deep_free(sexp_cdr(obj));
break;
case SEXP_VECTOR:
len = sexp_vector_length(obj);
elts = sexp_vector_data(obj);
for (i=0; i<len; i++)
sexp_deep_free(elts[i]);
sexp_free(ctx, elts);
break;
case SEXP_STRING:
case SEXP_SYMBOL:
sexp_free(ctx, sexp_string_data(obj));
break;
}
sexp_free(ctx, obj);
}
}
#else
#if ! USE_MALLOC
#include "gc.c"
#endif
#endif
@ -136,18 +110,36 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
}
sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) {
return sexp_make_exception(ctx, sexp_intern(ctx, "user"),
sexp_c_string(ctx, message, -1),
((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : sexp_list1(ctx, irritants)),
self, SEXP_FALSE, SEXP_FALSE);
sexp res;
sexp_gc_var(ctx, sym, s_sym);
sexp_gc_var(ctx, str, s_str);
sexp_gc_var(ctx, irr, s_irr);
sexp_gc_preserve(ctx, sym, s_sym);
sexp_gc_preserve(ctx, str, s_str);
sexp_gc_preserve(ctx, irr, s_irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"),
str = sexp_c_string(ctx, message, -1),
((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : (irr = sexp_list1(ctx, irritants))),
self, SEXP_FALSE, SEXP_FALSE);
sexp_gc_release(ctx, sym, s_sym);
return res;
}
sexp sexp_type_exception (sexp ctx, char *message, sexp obj) {
return sexp_make_exception(ctx, sexp_intern(ctx, "type"),
sexp_c_string(ctx, message, -1),
sexp_list1(ctx, obj),
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
sexp res;
sexp_gc_var(ctx, sym, s_sym);
sexp_gc_var(ctx, str, s_str);
sexp_gc_var(ctx, irr, s_irr);
sexp_gc_preserve(ctx, sym, s_sym);
sexp_gc_preserve(ctx, str, s_str);
sexp_gc_preserve(ctx, irr, s_irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"),
str = sexp_c_string(ctx, message, -1),
irr = sexp_list1(ctx, obj),
SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
sexp_gc_release(ctx, sym, s_sym);
return res;
}
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
@ -808,7 +800,7 @@ void sexp_write (sexp obj, sexp out) {
if (((sexp_uint_t)obj&7)==7) {
c = ((sexp_uint_t)obj)>>3;
while (c) {
#include "sexp-unhuff.c"
#include "opt/sexp-unhuff.c"
sexp_write_char(res, out);
}
}
@ -1119,7 +1111,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
res = sexp_read(ctx, in);
if (sexp_listp(ctx, res) == SEXP_FALSE) {
if (! sexp_exceptionp(res)) {
sexp_deep_free(ctx, res);
res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
SEXP_NULL,
in);
@ -1192,11 +1183,15 @@ sexp sexp_read (sexp ctx, sexp in) {
#if USE_STRING_STREAMS
sexp sexp_read_from_string(sexp ctx, char *str) {
sexp s = sexp_c_string(ctx, str, -1);
sexp in = sexp_make_input_string_port(ctx, s);
sexp res = sexp_read(ctx, in);
sexp_free(ctx, s);
sexp_deep_free(ctx, in);
sexp res;
sexp_gc_var(ctx, s, s_s);
sexp_gc_var(ctx, in, s_in);
sexp_gc_preserve(ctx, s, s_s);
sexp_gc_preserve(ctx, in, s_in);
s = sexp_c_string(ctx, str, -1);
in = sexp_make_input_string_port(ctx, s);
res = sexp_read(ctx, in);
sexp_gc_release(ctx, s, s_s);
return res;
}
#endif

2
sexp.h
View file

@ -426,6 +426,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_stack_top(x) ((x)->value.stack.top)
#define sexp_stack_data(x) ((x)->value.stack.data)
#define sexp_context_heap(x) ((x)->value.context.heap)
#define sexp_context_symbols(x) ((x)->value.context.symbols)
#define sexp_context_env(x) ((x)->value.context.env)
#define sexp_context_stack(x) ((x)->value.context.stack)
#define sexp_context_depth(x) ((x)->value.context.depth)