mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-22 07:09:18 +02:00
cleanup, removing mid-function returns which could corrupt
the gc_var trace.
This commit is contained in:
Alex Shinn
parent
39fdd89474
commit
7e3014ba38
8 changed files with 205 additions and 169 deletions
2
Makefile
2
Makefile
|
|
@ -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
|
||||
|
|
|
|||
84
eval.c
84
eval.c
|
|
@ -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,6 +423,10 @@ 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);
|
||||
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));
|
||||
|
|
@ -439,10 +437,13 @@ static sexp analyze_set (sexp ctx, sexp x) {
|
|||
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);
|
||||
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;
|
||||
analyze_bind(fail, fail_expr, ctx);
|
||||
res = sexp_make_cnd(ctx, test, pass, fail);
|
||||
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,6 +537,9 @@ 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);
|
||||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
||||
res = sexp_compile_error(ctx, "bad define syntax", x);
|
||||
} else {
|
||||
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));
|
||||
|
|
@ -554,11 +564,13 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
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)) {
|
||||
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));
|
||||
analyze_check_exception(proc);
|
||||
if (sexp_procedurep(proc)) {
|
||||
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);
|
||||
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);
|
||||
analyze_check_exception(tmp);
|
||||
res = analyze_seq(ctx2, sexp_cddr(x));
|
||||
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);
|
||||
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,7 +711,7 @@ 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);
|
||||
if (! sexp_exceptionp(res))
|
||||
sexp_push(ctx, res, op);
|
||||
}
|
||||
} else {
|
||||
|
|
@ -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);
|
||||
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));
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
31
gc.c
31
gc.c
|
|
@ -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))
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
|
|||
141
sexp.c
141
sexp.c
|
|
@ -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 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 : sexp_list1(ctx, 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 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
2
sexp.h
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue