mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
no more globals!
Each contexts keep a link to the heap which it is a part of (when using the native GC), as well as a vector of special globals that it needs quick access to (e.g. the `quote' and `quasiquote', etc. symbols. You can use this to manage multiple completely unrelated VMs in the same application, and everything will be thread-safe. The old behavior is still available by editing config.h, which now includes somewhat better descriptions of all the settings.
This commit is contained in:
Alex Shinn
parent
3a55e2b6f3
commit
66bd9a52bb
9 changed files with 374 additions and 193 deletions
19
README
19
README
|
|
@ -43,16 +43,27 @@ The essential functions to remember are:
|
|||
|
||||
#include <chibi/eval.h>
|
||||
|
||||
sexp_make_context(NULL, NULL, NULL)
|
||||
returns a new context
|
||||
sexp_make_eval_context(NULL, NULL, NULL)
|
||||
returns a new context with a fresh stack and standard environment
|
||||
|
||||
sexp_eval(context, expr)
|
||||
evaluates an s-expression
|
||||
sexp_destroy_context(context)
|
||||
free a context and all associated memory
|
||||
|
||||
sexp_eval(context, expr, env)
|
||||
evaluates an s-expression in an environment
|
||||
env can be NULL to use the context's default env
|
||||
|
||||
sexp_eval_string(context, str)
|
||||
reads an s-expression from str and evaluates it
|
||||
|
||||
sexp_load(context, file, env)
|
||||
read and eval all top-level forms from file
|
||||
|
||||
sexp_context_env(context)
|
||||
a macro returning the environment associated with a context
|
||||
|
||||
sexp_env_define(context, env, symbol, value)
|
||||
define a variable in an environment
|
||||
|
||||
A minimal module system is provided by default. Currently you can
|
||||
load the following SRFIs with (import (srfi N)):
|
||||
|
|
|
|||
176
eval.c
176
eval.c
|
|
@ -8,14 +8,6 @@
|
|||
|
||||
static int scheme_initialized_p = 0;
|
||||
|
||||
sexp continuation_resumer, final_resumer;
|
||||
static sexp the_interaction_env_symbol;
|
||||
static sexp the_err_handler_symbol, the_compile_error_symbol;
|
||||
static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
|
||||
|
||||
#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE)
|
||||
#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
|
||||
|
||||
#if USE_DEBUG
|
||||
#include "opt/debug.c"
|
||||
#else
|
||||
|
|
@ -31,14 +23,14 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version);
|
|||
|
||||
static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) {
|
||||
sexp exn;
|
||||
sexp_gc_var2(irritants, msg);
|
||||
sexp_gc_preserve2(ctx, irritants, msg);
|
||||
sexp_gc_var3(sym, irritants, msg);
|
||||
sexp_gc_preserve3(ctx, sym, irritants, msg);
|
||||
irritants = sexp_list1(ctx, obj);
|
||||
msg = sexp_c_string(ctx, message, -1);
|
||||
exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants,
|
||||
exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants,
|
||||
SEXP_FALSE, (sexp_pairp(obj) ?
|
||||
sexp_pair_source(obj) : SEXP_FALSE));
|
||||
sexp_gc_release2(ctx);
|
||||
sexp_gc_release3(ctx);
|
||||
return exn;
|
||||
}
|
||||
|
||||
|
|
@ -211,6 +203,12 @@ static void emit_push(sexp ctx, sexp obj) {
|
|||
sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj);
|
||||
}
|
||||
|
||||
static sexp finalize_bytecode (sexp ctx) {
|
||||
emit(ctx, OP_RET);
|
||||
shrink_bcode(ctx, sexp_context_pos(ctx));
|
||||
return sexp_context_bc(ctx);
|
||||
}
|
||||
|
||||
static sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args,
|
||||
sexp bc, sexp vars) {
|
||||
sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE);
|
||||
|
|
@ -280,51 +278,62 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE)
|
||||
/****************************** contexts ******************************/
|
||||
|
||||
sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
|
||||
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE)
|
||||
|
||||
void sexp_init_eval_context_globals (sexp ctx) {
|
||||
ctx = sexp_make_child_context(ctx, NULL);
|
||||
emit(ctx, OP_RESUMECC);
|
||||
sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx);
|
||||
ctx = sexp_make_child_context(ctx, NULL);
|
||||
emit(ctx, OP_DONE);
|
||||
sexp_global(ctx, SEXP_G_FINAL_RESUMER)
|
||||
= sexp_make_procedure(ctx,
|
||||
sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0),
|
||||
finalize_bytecode(ctx),
|
||||
sexp_make_vector(ctx, 0, SEXP_VOID));
|
||||
sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER)))
|
||||
= sexp_intern(ctx, "final-resumer");
|
||||
}
|
||||
|
||||
sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) {
|
||||
sexp_gc_var1(res);
|
||||
if (ctx) sexp_gc_preserve1(ctx, res);
|
||||
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
|
||||
sexp_context_parent(res) = ctx;
|
||||
sexp_context_lambda(res) = SEXP_FALSE;
|
||||
sexp_context_fv(res) = SEXP_NULL;
|
||||
sexp_context_saves(res) = 0;
|
||||
sexp_context_depth(res) = 0;
|
||||
sexp_context_pos(res) = 0;
|
||||
sexp_context_tailp(res) = 1;
|
||||
sexp_context_tracep(res) = 0;
|
||||
res = sexp_make_context(ctx);
|
||||
sexp_context_bc(res)
|
||||
= sexp_alloc_tagged(res, sexp_sizeof(bytecode)+SEXP_INIT_BCODE_SIZE,
|
||||
SEXP_BYTECODE);
|
||||
sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
|
||||
sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE;
|
||||
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
|
||||
if ((! stack) || (stack == SEXP_FALSE)) {
|
||||
stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
|
||||
sexp_stack_length(stack) = INIT_STACK_SIZE;
|
||||
stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK);
|
||||
sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE;
|
||||
sexp_stack_top(stack) = 0;
|
||||
}
|
||||
sexp_context_stack(res) = stack;
|
||||
if (! ctx) sexp_init_eval_context_globals(res);
|
||||
sexp_context_env(res)
|
||||
= (env ? env : sexp_make_standard_env(res, sexp_make_fixnum(5)));
|
||||
sexp_context_bc(res)
|
||||
= sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE,
|
||||
SEXP_BYTECODE);
|
||||
sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
|
||||
sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
|
||||
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
|
||||
if (ctx) sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_make_child_context(sexp context, sexp lambda) {
|
||||
sexp ctx = sexp_make_context(context,
|
||||
sexp_context_stack(context),
|
||||
sexp_context_env(context));
|
||||
sexp_context_parent(ctx) = context;
|
||||
sexp_context_lambda(ctx) = lambda;
|
||||
sexp_context_env(ctx) = sexp_context_env(context);
|
||||
sexp_context_top(ctx) = sexp_context_top(context);
|
||||
sexp_context_fv(ctx) = sexp_context_fv(context);
|
||||
sexp_context_tracep(ctx) = sexp_context_tracep(context);
|
||||
return ctx;
|
||||
sexp sexp_make_child_context (sexp ctx, sexp lambda) {
|
||||
sexp res = sexp_make_eval_context(ctx,
|
||||
sexp_context_stack(ctx),
|
||||
sexp_context_env(ctx));
|
||||
sexp_context_lambda(res) = lambda;
|
||||
sexp_context_top(res) = sexp_context_top(ctx);
|
||||
sexp_context_fv(res) = sexp_context_fv(ctx);
|
||||
sexp_context_tracep(res) = sexp_context_tracep(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
/**************************** identifiers *****************************/
|
||||
|
||||
static sexp sexp_identifierp (sexp ctx, sexp x) {
|
||||
return sexp_make_boolean(sexp_idp(x));
|
||||
}
|
||||
|
|
@ -742,12 +751,6 @@ static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
|
|||
*((sexp_sint_t*)data) = sexp_context_pos(ctx)-label;
|
||||
}
|
||||
|
||||
static sexp finalize_bytecode (sexp ctx) {
|
||||
emit(ctx, OP_RET);
|
||||
shrink_bcode(ctx, sexp_context_pos(ctx));
|
||||
return sexp_context_bc(ctx);
|
||||
}
|
||||
|
||||
static void generate_lit (sexp ctx, sexp value) {
|
||||
emit_push(ctx, value);
|
||||
}
|
||||
|
|
@ -980,7 +983,7 @@ static void generate_lambda (sexp ctx, sexp lambda) {
|
|||
prev_lambda = sexp_context_lambda(ctx);
|
||||
prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
|
||||
fv = sexp_lambda_fv(lambda);
|
||||
ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx));
|
||||
ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx));
|
||||
sexp_context_lambda(ctx2) = lambda;
|
||||
/* allocate space for local vars */
|
||||
for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
|
|
@ -1219,10 +1222,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
self = proc;
|
||||
|
||||
loop:
|
||||
#ifdef DEBUG_VM
|
||||
#if USE_DEBUG_VM
|
||||
if (sexp_context_tracep(ctx)) {
|
||||
sexp_print_stack(ctx, stack, top, fp,
|
||||
sexp_env_global_ref(env, the_cur_err_symbol, SEXP_FALSE));
|
||||
sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
|
||||
fprintf(stderr, "%s\n", (*ip<=OP_NUM_OPCODES) ?
|
||||
reverse_opcode_names[*ip] : "UNKNOWN");
|
||||
}
|
||||
|
|
@ -1237,7 +1239,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
stack[top+2] = self;
|
||||
stack[top+3] = sexp_make_fixnum(fp);
|
||||
top += 4;
|
||||
self = sexp_env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
|
||||
self = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE);
|
||||
bc = sexp_procedure_code(self);
|
||||
ip = sexp_bytecode_data(bc);
|
||||
cp = sexp_procedure_vars(self);
|
||||
|
|
@ -1267,8 +1269,10 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
sexp_vector_set(tmp2,
|
||||
sexp_make_fixnum(0),
|
||||
sexp_save_stack(ctx, stack, top+4));
|
||||
_ARG1 = sexp_make_procedure(ctx, sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(1), continuation_resumer,
|
||||
_ARG1 = sexp_make_procedure(ctx,
|
||||
sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(1),
|
||||
sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE),
|
||||
tmp2);
|
||||
top++;
|
||||
ip -= sizeof(sexp);
|
||||
|
|
@ -1302,7 +1306,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
goto make_call;
|
||||
case OP_CALL:
|
||||
#if USE_CHECK_STACK
|
||||
if (top+16 >= INIT_STACK_SIZE)
|
||||
if (top+16 >= SEXP_INIT_STACK_SIZE)
|
||||
errx(70, "out of stack space at %ld", top);
|
||||
#endif
|
||||
i = sexp_unbox_fixnum(_WORD0);
|
||||
|
|
@ -1851,9 +1855,11 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
if (sexp_flonump(_ARG1)) {
|
||||
if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) {
|
||||
sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1));
|
||||
#if USE_BIGNUMS
|
||||
} else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM)
|
||||
|| sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) {
|
||||
_ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1));
|
||||
#endif
|
||||
} else {
|
||||
_ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1));
|
||||
}
|
||||
|
|
@ -2015,14 +2021,13 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
|
|||
sexp_gc_preserve4(ctx, ctx2, x, in, res);
|
||||
res = SEXP_VOID;
|
||||
in = sexp_open_input_file(ctx, source);
|
||||
out = sexp_env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
|
||||
ctx2 = sexp_make_context(ctx, NULL, env);
|
||||
out = sexp_current_error_port(ctx);
|
||||
ctx2 = sexp_make_eval_context(ctx, NULL, env);
|
||||
sexp_context_parent(ctx2) = ctx;
|
||||
tmp = sexp_env_bindings(env);
|
||||
sexp_context_tailp(ctx2) = 0;
|
||||
if (sexp_exceptionp(in)) {
|
||||
if (sexp_not(out))
|
||||
out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE);
|
||||
if (sexp_not(out)) out = sexp_current_error_port(ctx);
|
||||
if (sexp_oportp(out))
|
||||
sexp_print_exception(ctx, in, out);
|
||||
res = in;
|
||||
|
|
@ -2124,8 +2129,10 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
|
|||
if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) {
|
||||
if (sexp_flonump(x) || sexp_flonump(e))
|
||||
res = sexp_make_flonum(ctx, f);
|
||||
#if USE_BIGNUMS
|
||||
else
|
||||
res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e);
|
||||
#endif
|
||||
} else
|
||||
#endif
|
||||
res = sexp_make_fixnum((sexp_sint_t)round(f));
|
||||
|
|
@ -2331,19 +2338,19 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op);
|
||||
}
|
||||
/* add io port and interaction env parameters */
|
||||
sexp_env_define(ctx, e, the_cur_in_symbol,
|
||||
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL),
|
||||
sexp_make_input_port(ctx, stdin, SEXP_FALSE));
|
||||
sexp_env_define(ctx, e, the_cur_out_symbol,
|
||||
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL),
|
||||
sexp_make_output_port(ctx, stdout, SEXP_FALSE));
|
||||
sexp_env_define(ctx, e, the_cur_err_symbol,
|
||||
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL),
|
||||
sexp_make_output_port(ctx, stderr, SEXP_FALSE));
|
||||
sexp_env_define(ctx, e, the_interaction_env_symbol, e);
|
||||
sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e);
|
||||
sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"),
|
||||
sexp_c_string(ctx, sexp_module_dir, -1));
|
||||
/* add default exception handler */
|
||||
err_cell = sexp_env_cell(e, the_cur_err_symbol);
|
||||
err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
|
||||
perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception"));
|
||||
ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), e);
|
||||
ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), e);
|
||||
sexp_context_tailp(ctx2) = 0;
|
||||
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
|
||||
emit(ctx2, OP_GLOBAL_KNOWN_REF);
|
||||
|
|
@ -2361,7 +2368,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
sexp_make_fixnum(0),
|
||||
finalize_bytecode(ctx2),
|
||||
tmp);
|
||||
sexp_env_define(ctx2, e, the_err_handler_symbol, err_handler);
|
||||
sexp_env_define(ctx2, e, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), err_handler);
|
||||
sexp_gc_release4(ctx);
|
||||
return e;
|
||||
}
|
||||
|
|
@ -2404,7 +2411,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
stack[top] = sexp_make_fixnum(len);
|
||||
top++;
|
||||
stack[top++] = sexp_make_fixnum(0);
|
||||
stack[top++] = final_resumer;
|
||||
stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
|
||||
stack[top++] = sexp_make_fixnum(0);
|
||||
sexp_context_top(ctx) = top;
|
||||
res = sexp_vm(ctx, proc);
|
||||
|
|
@ -2434,13 +2441,10 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
|
|||
sexp res, ctx2;
|
||||
sexp_gc_var1(thunk);
|
||||
sexp_gc_preserve1(ctx, thunk);
|
||||
ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
|
||||
ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
|
||||
thunk = sexp_compile(ctx2, obj);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(ctx2, thunk,
|
||||
sexp_env_global_ref(sexp_context_env(ctx2),
|
||||
the_cur_err_symbol,
|
||||
SEXP_FALSE));
|
||||
sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx));
|
||||
res = thunk;
|
||||
} else {
|
||||
res = sexp_apply(ctx2, thunk, SEXP_NULL);
|
||||
|
|
@ -2460,34 +2464,8 @@ sexp sexp_eval_string (sexp ctx, char *str, sexp env) {
|
|||
}
|
||||
|
||||
void sexp_scheme_init (void) {
|
||||
sexp ctx;
|
||||
if (! scheme_initialized_p) {
|
||||
scheme_initialized_p = 1;
|
||||
sexp_init();
|
||||
ctx = sexp_make_context(NULL, NULL, NULL);
|
||||
the_compile_error_symbol = sexp_intern(ctx, "compile");
|
||||
the_err_handler_symbol = sexp_intern(ctx, "*current-exception-handler*");
|
||||
the_cur_in_symbol = sexp_intern(ctx, "*current-input-port*");
|
||||
the_cur_out_symbol = sexp_intern(ctx, "*current-output-port*");
|
||||
the_cur_err_symbol = sexp_intern(ctx, "*current-error-port*");
|
||||
the_interaction_env_symbol = sexp_intern(ctx, "*interaction-environment*");
|
||||
#if USE_BOEHM
|
||||
GC_add_roots((char*)&continuation_resumer,
|
||||
((char*)&continuation_resumer)+sizeof(continuation_resumer)+1);
|
||||
GC_add_roots((char*)&final_resumer,
|
||||
((char*)&final_resumer)+sizeof(continuation_resumer)+1);
|
||||
GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1);
|
||||
#endif
|
||||
emit(ctx, OP_RESUMECC);
|
||||
continuation_resumer = finalize_bytecode(ctx);
|
||||
ctx = sexp_make_child_context(ctx, NULL);
|
||||
emit(ctx, OP_DONE);
|
||||
final_resumer = sexp_make_procedure(ctx,
|
||||
sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0),
|
||||
finalize_bytecode(ctx),
|
||||
sexp_make_vector(ctx, 0, SEXP_VOID));
|
||||
sexp_bytecode_name(sexp_procedure_code(final_resumer))
|
||||
= sexp_intern(ctx, "final-resumer");
|
||||
}
|
||||
}
|
||||
|
|
|
|||
38
gc.c
38
gc.c
|
|
@ -15,28 +15,14 @@
|
|||
#define sexp_heap_align(n) sexp_align(n, 4)
|
||||
#endif
|
||||
|
||||
typedef struct sexp_free_list *sexp_free_list;
|
||||
struct sexp_free_list {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list next;
|
||||
};
|
||||
|
||||
typedef struct sexp_heap *sexp_heap;
|
||||
struct sexp_heap {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list free_list;
|
||||
sexp_heap next;
|
||||
char *data;
|
||||
};
|
||||
|
||||
static sexp_heap heap;
|
||||
#if USE_GLOBAL_HEAP
|
||||
static sexp_heap sexp_global_heap;
|
||||
#endif
|
||||
|
||||
#if USE_DEBUG_GC
|
||||
static sexp* stack_base;
|
||||
#endif
|
||||
|
||||
extern sexp continuation_resumer, final_resumer;
|
||||
|
||||
static sexp_heap sexp_heap_last (sexp_heap h) {
|
||||
while (h->next) h = h->next;
|
||||
return h;
|
||||
|
|
@ -88,7 +74,7 @@ int stack_references_pointer_p (sexp ctx, sexp x) {
|
|||
|
||||
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
||||
size_t freed, max_freed=0, sum_freed=0, size;
|
||||
sexp_heap h = heap;
|
||||
sexp_heap h = sexp_context_heap(ctx);
|
||||
sexp p;
|
||||
sexp_free_list q, r, s;
|
||||
char *end;
|
||||
|
|
@ -150,11 +136,11 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
|||
|
||||
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
||||
sexp res;
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
int i;
|
||||
sexp_mark(continuation_resumer);
|
||||
sexp_mark(final_resumer);
|
||||
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
||||
sexp_mark(sexp_symbol_table[i]);
|
||||
#endif
|
||||
sexp_mark(ctx);
|
||||
res = sexp_sweep(ctx, sum_freed);
|
||||
return res;
|
||||
|
|
@ -179,7 +165,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 = sexp_heap_last(heap);
|
||||
sexp_heap h = sexp_heap_last(sexp_context_heap(ctx));
|
||||
cur_size = h->size;
|
||||
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
|
||||
h->next = sexp_make_heap(new_size);
|
||||
|
|
@ -189,7 +175,7 @@ int sexp_grow_heap (sexp ctx, size_t size) {
|
|||
void* sexp_try_alloc (sexp ctx, size_t size) {
|
||||
sexp_free_list ls1, ls2, ls3;
|
||||
sexp_heap h;
|
||||
for (h=heap; h; h=h->next)
|
||||
for (h=sexp_context_heap(ctx); h; h=h->next)
|
||||
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
|
||||
if (ls2->size >= size) {
|
||||
if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
|
||||
|
|
@ -214,7 +200,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
|
||||
h = sexp_heap_last(heap);
|
||||
h = sexp_heap_last(sexp_context_heap(ctx));
|
||||
if (((max_freed < size)
|
||||
|| ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO))))
|
||||
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
|
||||
|
|
@ -227,8 +213,12 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
}
|
||||
|
||||
void sexp_gc_init (void) {
|
||||
#if USE_GLOBAL_HEAP || USE_DEBUG_GC
|
||||
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
||||
heap = sexp_make_heap(size);
|
||||
#endif
|
||||
#if USE_GLOBAL_HEAP
|
||||
sexp_global_heap = sexp_make_heap(size);
|
||||
#endif
|
||||
#if USE_DEBUG_GC
|
||||
/* the +32 is a hack, but this is just for debugging anyway */
|
||||
stack_base = ((sexp*)&size) + 32;
|
||||
|
|
|
|||
|
|
@ -3,53 +3,109 @@
|
|||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
/* uncomment this to disable the module system */
|
||||
/* Currently this just loads the config.scm from main and */
|
||||
/* sets up an (import (module name)) macro. */
|
||||
/* #define USE_MODULES 0 */
|
||||
|
||||
/* uncomment this to disable dynamic loading */
|
||||
/* If enabled, you can LOAD .so files with a */
|
||||
/* sexp_init_library(ctx, env) function provided. */
|
||||
/* #define USE_DL 0 */
|
||||
|
||||
/* uncomment this to disable dynamic type definitions */
|
||||
/* This enables register-simple-type and related */
|
||||
/* opcodes for defining types, needed by the default */
|
||||
/* implementation of (srfi 9). */
|
||||
/* #define USE_TYPE_DEFS 0 */
|
||||
|
||||
/* uncomment this to use the Boehm conservative GC */
|
||||
/* Conservative GCs make it easier to write extensions, */
|
||||
/* since you don't have to keep track of intermediate */
|
||||
/* variables, but can leak memory. Boehm is also a */
|
||||
/* very large library to link in. You may want to */
|
||||
/* enable this when debugging your own extensions, or */
|
||||
/* if you suspect a bug in the native GC. */
|
||||
/* #define USE_BOEHM 1 */
|
||||
|
||||
/* uncomment this to just malloc manually instead of any GC */
|
||||
/* Mostly for debugging purposes, this is the no GC option. */
|
||||
/* You can use the just with the read/write API and */
|
||||
/* explicitly free sexps though. */
|
||||
/* #define USE_MALLOC 1 */
|
||||
|
||||
/* uncomment this to add conservative checks to the native GC */
|
||||
/* Please mail the author if enabling this makes a bug */
|
||||
/* go away and you're not working on your own C extension. */
|
||||
/* #define USE_DEBUG_GC 1 */
|
||||
|
||||
/* uncomment this if you only want fixnum support */
|
||||
/* uncomment this to make the heap common to all contexts */
|
||||
/* By default separate contexts can have separate heaps, */
|
||||
/* and are thus thread-safe and independant. */
|
||||
/* #define USE_GLOBAL_HEAP 1 */
|
||||
|
||||
/* uncomment this to make the symbol table common to all contexts */
|
||||
/* Will still be restricted to all contexts sharing the same */
|
||||
/* heap, of course. */
|
||||
/* #define USE_GLOBAL_SYMBOLS 1 */
|
||||
|
||||
/* uncomment this if you don't need flonum support */
|
||||
/* This is only for EVAL - you'll still be able to read */
|
||||
/* and write flonums directly through the sexp API. */
|
||||
/* #define USE_FLONUMS 0 */
|
||||
|
||||
/* uncomment this if you want immediate flonums */
|
||||
/* This is experimental, enablde at your own risk. */
|
||||
/* #define USE_IMMEDIATE_FLONUMS 1 */
|
||||
|
||||
/* uncomment this if you don't want bignum support */
|
||||
/* Bignums are implemented with a small, custom library */
|
||||
/* in opt/bignum.c. */
|
||||
/* #define USE_BIGNUMS 0 */
|
||||
|
||||
/* uncomment this if you don't need extended math operations */
|
||||
/* This includes the trigonometric and expt functions. */
|
||||
/* Automatically disabled if you've disabled flonums. */
|
||||
/* #define USE_MATH 0 */
|
||||
|
||||
/* uncomment this to disable warning about references to undefined variables */
|
||||
/* This is something of a hack, but can be quite useful. */
|
||||
/* It's very fast and doesn't involve any separate analysis */
|
||||
/* passes. */
|
||||
/* #define USE_WARN_UNDEFS 0 */
|
||||
|
||||
/* uncomment this to disable huffman-coded immediate symbols */
|
||||
/* By default (this may change) small symbols are represented */
|
||||
/* as immediates using a simple huffman encoding. This keeps */
|
||||
/* the symbol table small, and minimizes hashing when doing a */
|
||||
/* lot of reading. */
|
||||
/* #define USE_HUFF_SYMS 0 */
|
||||
|
||||
/* uncomment this to just use a single list for hash tables */
|
||||
/* You can trade off some space in exchange for longer read */
|
||||
/* times by disabling hashing and just putting all */
|
||||
/* non-immediate symbols in a single list. */
|
||||
/* #define USE_HASH_SYMS 0 */
|
||||
|
||||
/* uncomment this to disable string ports */
|
||||
/* If disabled some basic functionality such as number->string */
|
||||
/* will not be available by default. */
|
||||
/* #define USE_STRING_STREAMS 0 */
|
||||
|
||||
/* uncomment this to enable stack overflow checks */
|
||||
/* #define USE_CHECK_STACK 1 */
|
||||
/* uncomment this to disable stack overflow checks */
|
||||
/* By default stacks are fairly small, so it's good to leave */
|
||||
/* this enabled. */
|
||||
/* #define USE_CHECK_STACK 0 */
|
||||
|
||||
/* uncomment this to disable debugging utilities */
|
||||
/* By default there's a `disasm' procedure you can use to */
|
||||
/* view the compiled VM instructions of a procedure. You can */
|
||||
/* disable this if you don't need it. */
|
||||
/* #define USE_DEBUG 0 */
|
||||
|
||||
/* #define USE_DEBUG_VM 0 */
|
||||
/* Experts only. */
|
||||
/* For *very* verbose output on every VM operation. */
|
||||
|
||||
/************************************************************************/
|
||||
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
|
||||
/************************************************************************/
|
||||
|
|
@ -101,6 +157,22 @@
|
|||
#define USE_DEBUG_GC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_GLOBAL_HEAP
|
||||
#if USE_BOEHM || USE_MALLOC
|
||||
#define USE_GLOBAL_HEAP 1
|
||||
#else
|
||||
#define USE_GLOBAL_HEAP 0
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef USE_GLOBAL_SYMBOLS
|
||||
#if USE_BOEHM || USE_MALLOC
|
||||
#define USE_GLOBAL_SYMBOLS 1
|
||||
#else
|
||||
#define USE_GLOBAL_SYMBOLS 0
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifndef USE_FLONUMS
|
||||
#define USE_FLONUMS 1
|
||||
#endif
|
||||
|
|
@ -114,7 +186,7 @@
|
|||
#endif
|
||||
|
||||
#ifndef USE_MATH
|
||||
#define USE_MATH 1
|
||||
#define USE_MATH USE_FLONUMS
|
||||
#endif
|
||||
|
||||
#ifndef USE_WARN_UNDEFS
|
||||
|
|
@ -133,6 +205,10 @@
|
|||
#define USE_DEBUG 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG_VM
|
||||
#define USE_DEBUG_VM 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_STRING_STREAMS
|
||||
#define USE_STRING_STREAMS 1
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -9,13 +9,13 @@
|
|||
|
||||
/************************* additional types ***************************/
|
||||
|
||||
#define INIT_BCODE_SIZE 128
|
||||
#define INIT_STACK_SIZE 8192
|
||||
#define SEXP_INIT_BCODE_SIZE 128
|
||||
#define SEXP_INIT_STACK_SIZE 8192
|
||||
|
||||
#define sexp_init_file "init.scm"
|
||||
#define sexp_config_file "config.scm"
|
||||
|
||||
enum core_form_names {
|
||||
enum sexp_core_form_names {
|
||||
CORE_DEFINE = 1,
|
||||
CORE_SET,
|
||||
CORE_LAMBDA,
|
||||
|
|
@ -27,7 +27,7 @@ enum core_form_names {
|
|||
CORE_LETREC_SYNTAX
|
||||
};
|
||||
|
||||
enum opcode_classes {
|
||||
enum sexp_opcode_classes {
|
||||
OPC_GENERIC = 1,
|
||||
OPC_TYPE_PREDICATE,
|
||||
OPC_PREDICATE,
|
||||
|
|
@ -42,7 +42,7 @@ enum opcode_classes {
|
|||
OPC_NUM_OP_CLASSES
|
||||
};
|
||||
|
||||
enum opcode_names {
|
||||
enum sexp_opcode_names {
|
||||
OP_NOOP,
|
||||
OP_RAISE,
|
||||
OP_RESUMECC,
|
||||
|
|
@ -120,6 +120,8 @@ enum opcode_names {
|
|||
/**************************** prototypes ******************************/
|
||||
|
||||
SEXP_API void sexp_scheme_init (void);
|
||||
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env);
|
||||
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
|
||||
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
|
||||
SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
|
||||
SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
|
||||
|
|
@ -127,7 +129,6 @@ SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env);
|
|||
SEXP_API sexp sexp_make_env (sexp context);
|
||||
SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls);
|
||||
SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
|
||||
SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env);
|
||||
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);
|
||||
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
|
||||
SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data);
|
||||
|
|
|
|||
|
|
@ -127,6 +127,20 @@ typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp);
|
|||
typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
|
||||
typedef struct sexp_free_list *sexp_free_list;
|
||||
struct sexp_free_list {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list next;
|
||||
};
|
||||
|
||||
typedef struct sexp_heap *sexp_heap;
|
||||
struct sexp_heap {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list free_list;
|
||||
sexp_heap next;
|
||||
char *data;
|
||||
};
|
||||
|
||||
struct sexp_gc_var_t {
|
||||
sexp *var;
|
||||
/* char *name; */
|
||||
|
|
@ -239,9 +253,10 @@ struct sexp_struct {
|
|||
sexp data[];
|
||||
} stack;
|
||||
struct {
|
||||
sexp_heap heap;
|
||||
struct sexp_gc_var_t *saves;
|
||||
sexp_uint_t pos, depth, tailp, tracep;
|
||||
sexp bc, lambda, stack, env, fv, parent;
|
||||
sexp bc, lambda, stack, env, fv, parent, globals;
|
||||
} context;
|
||||
} value;
|
||||
};
|
||||
|
|
@ -561,8 +576,6 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
#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)
|
||||
|
|
@ -574,6 +587,21 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
#define sexp_context_saves(x) ((x)->value.context.saves)
|
||||
#define sexp_context_tailp(x) ((x)->value.context.tailp)
|
||||
#define sexp_context_tracep(x) ((x)->value.context.tailp)
|
||||
#define sexp_context_globals(x) ((x)->value.context.globals)
|
||||
|
||||
#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x])
|
||||
|
||||
#if USE_GLOBAL_HEAP
|
||||
#define sexp_context_heap(ctx) sexp_global_heap
|
||||
#else
|
||||
#define sexp_context_heap(ctx) ((ctx)->value.context.heap)
|
||||
#endif
|
||||
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
#define sexp_context_symbols(ctx) sexp_symbol_table
|
||||
#else
|
||||
#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS))
|
||||
#endif
|
||||
|
||||
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
|
||||
|
||||
|
|
@ -613,6 +641,25 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
|
||||
/****************************** utilities *****************************/
|
||||
|
||||
enum sexp_context_globals {
|
||||
#if ! USE_GLOBAL_SYMBOLS
|
||||
SEXP_G_SYMBOLS,
|
||||
#endif
|
||||
SEXP_G_QUOTE_SYMBOL,
|
||||
SEXP_G_QUASIQUOTE_SYMBOL,
|
||||
SEXP_G_UNQUOTE_SYMBOL,
|
||||
SEXP_G_UNQUOTE_SPLICING_SYMBOL,
|
||||
SEXP_G_EMPTY_VECTOR,
|
||||
SEXP_G_CUR_IN_SYMBOL,
|
||||
SEXP_G_CUR_OUT_SYMBOL,
|
||||
SEXP_G_CUR_ERR_SYMBOL,
|
||||
SEXP_G_ERR_HANDLER_SYMBOL,
|
||||
SEXP_G_INTERACTION_ENV_SYMBOL,
|
||||
SEXP_G_RESUMECC_BYTECODE,
|
||||
SEXP_G_FINAL_RESUMER,
|
||||
SEXP_G_NUM_GLOBALS
|
||||
};
|
||||
|
||||
#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL)
|
||||
|
||||
#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls)))
|
||||
|
|
@ -668,6 +715,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p);
|
|||
#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
|
||||
|
||||
SEXP_API struct sexp_struct *sexp_type_specs;
|
||||
SEXP_API sexp sexp_make_context(sexp ctx);
|
||||
SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
|
||||
SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail);
|
||||
SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
|
||||
|
|
@ -710,10 +758,19 @@ SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
|
|||
SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
|
||||
SEXP_API void sexp_init(void);
|
||||
|
||||
#if USE_GLOBAL_HEAP
|
||||
#define sexp_destroy_context(ctx)
|
||||
#else
|
||||
SEXP_API void sexp_destroy_context(sexp ctx);
|
||||
#endif
|
||||
|
||||
#if USE_TYPE_DEFS
|
||||
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
|
||||
#endif
|
||||
|
||||
#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE)
|
||||
#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
|
||||
|
||||
#endif /* ! SEXP_H */
|
||||
|
||||
|
|
|
|||
2
main.c
2
main.c
|
|
@ -128,7 +128,7 @@ void run_main (int argc, char **argv) {
|
|||
sexp_uint_t i, quit=0, init_loaded=0;
|
||||
sexp_gc_var1(str);
|
||||
|
||||
ctx = sexp_make_context(NULL, NULL, NULL);
|
||||
ctx = sexp_make_eval_context(NULL, NULL, NULL);
|
||||
sexp_gc_preserve1(ctx, str);
|
||||
env = sexp_context_env(ctx);
|
||||
out = sexp_eval_string(ctx, "(current-output-port)", env);
|
||||
|
|
|
|||
|
|
@ -65,9 +65,10 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
|
|||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
#ifdef DEBUG_VM
|
||||
#if USE_DEBUG_VM
|
||||
static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
|
||||
int i;
|
||||
if (! sexp_oport(out)) out = sexp_current_error_port(ctx);
|
||||
for (i=0; i<top; i++) {
|
||||
sexp_printf(ctx, out, "%s %02d: ", ((i==fp) ? "*" : " "), i);
|
||||
sexp_write(ctx, stack[i], out);
|
||||
|
|
|
|||
131
sexp.c
131
sexp.c
|
|
@ -19,14 +19,6 @@ static struct sexp_huff_entry huff_table[] = {
|
|||
|
||||
static int sexp_initialized_p = 0;
|
||||
|
||||
static sexp the_dot_symbol;
|
||||
static sexp the_quote_symbol;
|
||||
static sexp the_quasiquote_symbol;
|
||||
static sexp the_unquote_symbol;
|
||||
static sexp the_unquote_splicing_symbol;
|
||||
static sexp the_read_error_symbol;
|
||||
static sexp the_empty_vector;
|
||||
|
||||
sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp);
|
||||
|
||||
static char sexp_separators[] = {
|
||||
|
|
@ -51,7 +43,9 @@ static int is_separator(int c) {
|
|||
return 0<c && c<0x60 && sexp_separators[c];
|
||||
}
|
||||
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
|
||||
#endif
|
||||
|
||||
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
|
||||
sexp res = (sexp) sexp_alloc(ctx, size);
|
||||
|
|
@ -92,7 +86,7 @@ static struct sexp_struct _sexp_type_specs[] = {
|
|||
_DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
|
||||
_DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
|
||||
_DEF_TYPE(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), "stack"),
|
||||
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
|
||||
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context"),
|
||||
};
|
||||
#undef _DEF_TYPE
|
||||
|
||||
|
|
@ -165,6 +159,83 @@ sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
|
|||
|
||||
#endif /* ! USE_BOEHM */
|
||||
|
||||
/****************************** contexts ******************************/
|
||||
|
||||
void sexp_init_context_globals (sexp ctx) {
|
||||
sexp_context_globals(ctx)
|
||||
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_G_NUM_GLOBALS), SEXP_VOID);
|
||||
#if ! USE_GLOBAL_SYMBOLS
|
||||
sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL);
|
||||
#endif
|
||||
sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote");
|
||||
sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote");
|
||||
sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote");
|
||||
sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing");
|
||||
sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*");
|
||||
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*");
|
||||
sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*");
|
||||
sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL) = sexp_intern(ctx, "*current-exception-handler*");
|
||||
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*");
|
||||
sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
|
||||
sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
|
||||
}
|
||||
|
||||
#if ! USE_GLOBAL_HEAP
|
||||
sexp sexp_bootstrap_context (void) {
|
||||
sexp dummy_ctx, ctx;
|
||||
sexp_heap heap = sexp_make_heap(sexp_heap_align(SEXP_INITIAL_HEAP_SIZE));
|
||||
dummy_ctx = (sexp) malloc(sexp_sizeof(context));
|
||||
sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT;
|
||||
sexp_context_saves(dummy_ctx) = NULL;
|
||||
sexp_context_heap(dummy_ctx) = heap;
|
||||
ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT);
|
||||
sexp_context_heap(dummy_ctx) = NULL;
|
||||
sexp_context_heap(ctx) = heap;
|
||||
return ctx;
|
||||
}
|
||||
#endif
|
||||
|
||||
sexp sexp_make_context (sexp ctx) {
|
||||
sexp_gc_var1(res);
|
||||
if (ctx) sexp_gc_preserve1(ctx, res);
|
||||
#if ! USE_GLOBAL_HEAP
|
||||
if (! ctx) res = sexp_bootstrap_context();
|
||||
else
|
||||
#endif
|
||||
{
|
||||
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
|
||||
#if ! USE_BOEHM && ! USE_MALLOC
|
||||
sexp_context_heap(res) = sexp_context_heap(ctx);
|
||||
#endif
|
||||
}
|
||||
sexp_context_parent(res) = ctx;
|
||||
sexp_context_lambda(res) = SEXP_FALSE;
|
||||
sexp_context_fv(res) = SEXP_NULL;
|
||||
sexp_context_saves(res) = 0;
|
||||
sexp_context_depth(res) = 0;
|
||||
sexp_context_pos(res) = 0;
|
||||
sexp_context_tailp(res) = 1;
|
||||
sexp_context_tracep(res) = 0;
|
||||
if (ctx) {
|
||||
sexp_context_globals(res) = sexp_context_globals(ctx);
|
||||
sexp_gc_release1(ctx);
|
||||
} else {
|
||||
sexp_init_context_globals(res);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
#if ! USE_GLOBAL_HEAP
|
||||
void sexp_destroy_context (sexp ctx) {
|
||||
sexp_heap heap;
|
||||
if (sexp_context_heap(ctx)) {
|
||||
heap = sexp_context_heap(ctx);
|
||||
sexp_context_heap(ctx) = NULL;
|
||||
free(heap);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
/***************************** exceptions *****************************/
|
||||
|
||||
sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
|
||||
|
|
@ -275,16 +346,16 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
|
|||
|
||||
static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
|
||||
sexp res;
|
||||
sexp_gc_var3(name, str, irr);
|
||||
sexp_gc_preserve3(ctx, name, str, irr);
|
||||
sexp_gc_var4(sym, name, str, irr);
|
||||
sexp_gc_preserve4(ctx, sym, name, str, irr);
|
||||
name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE);
|
||||
name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port)));
|
||||
str = sexp_c_string(ctx, msg, -1);
|
||||
irr = ((sexp_pairp(irritants) || sexp_nullp(irritants))
|
||||
? irritants : sexp_list1(ctx, irritants));
|
||||
res = sexp_make_exception(ctx, the_read_error_symbol,
|
||||
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"),
|
||||
str, irr, SEXP_FALSE, name);
|
||||
sexp_gc_release3(ctx);
|
||||
sexp_gc_release4(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -386,7 +457,7 @@ sexp sexp_length (sexp ctx, sexp ls) {
|
|||
sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
||||
sexp_uint_t size;
|
||||
sexp_sint_t i, len;
|
||||
sexp t, tmp, *p, *q;
|
||||
sexp t, *p, *q;
|
||||
char *p0, *q0;
|
||||
|
||||
loop:
|
||||
|
|
@ -411,7 +482,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
|||
|
||||
if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
|
||||
#if USE_BIGNUMS && ! USE_IMMEDIATE_FLONUMS
|
||||
if (sexp_pointer_tag(a) == SEXP_FLONUM) {tmp=a; a=b; b=tmp;}
|
||||
if (sexp_pointer_tag(a) == SEXP_FLONUM) {t=a; a=b; b=t;}
|
||||
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
|
||||
return sexp_make_boolean((sexp_pointer_tag(b) == SEXP_FLONUM)
|
||||
&& sexp_fp_integerp(b)
|
||||
|
|
@ -577,7 +648,7 @@ sexp sexp_intern(sexp ctx, char *str) {
|
|||
bucket = 0;
|
||||
#endif
|
||||
len = strlen(str);
|
||||
for (ls=sexp_symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len))
|
||||
return sexp_car(ls);
|
||||
|
||||
|
|
@ -585,7 +656,7 @@ sexp sexp_intern(sexp ctx, char *str) {
|
|||
sexp_gc_preserve1(ctx, 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_push(ctx, sexp_context_symbols(ctx)[bucket], sym);
|
||||
sexp_gc_release1(ctx);
|
||||
return sym;
|
||||
}
|
||||
|
|
@ -599,7 +670,7 @@ sexp sexp_string_to_symbol (sexp ctx, sexp str) {
|
|||
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) {
|
||||
sexp v, *x;
|
||||
int i, clen = sexp_unbox_fixnum(len);
|
||||
if (! clen) return the_empty_vector;
|
||||
if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR);
|
||||
v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp),
|
||||
SEXP_VECTOR);
|
||||
x = sexp_vector_data(v);
|
||||
|
|
@ -1209,23 +1280,23 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
case '\'':
|
||||
res = sexp_read(ctx, in);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, the_quote_symbol, res);
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res);
|
||||
break;
|
||||
case '`':
|
||||
res = sexp_read(ctx, in);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, the_quasiquote_symbol, res);
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res);
|
||||
break;
|
||||
case ',':
|
||||
if ((c1 = sexp_read_char(ctx, in)) == '@') {
|
||||
res = sexp_read(ctx, in);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, the_unquote_splicing_symbol, res);
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res);
|
||||
} else {
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read(ctx, in);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_list2(ctx, the_unquote_symbol, res);
|
||||
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res);
|
||||
}
|
||||
break;
|
||||
case '"':
|
||||
|
|
@ -1472,28 +1543,24 @@ sexp sexp_write_to_string(sexp ctx, sexp obj) {
|
|||
}
|
||||
|
||||
void sexp_init(void) {
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
int i;
|
||||
sexp ctx;
|
||||
#endif
|
||||
if (! sexp_initialized_p) {
|
||||
sexp_initialized_p = 1;
|
||||
#if USE_BOEHM
|
||||
GC_init();
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
GC_add_roots((char*)&sexp_symbol_table,
|
||||
((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1);
|
||||
#endif
|
||||
#elif ! USE_MALLOC
|
||||
sexp_gc_init();
|
||||
#endif
|
||||
#if USE_GLOBAL_SYMBOLS
|
||||
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
||||
sexp_symbol_table[i] = SEXP_NULL;
|
||||
ctx = sexp_alloc_type(NULL, context, SEXP_CONTEXT);
|
||||
the_dot_symbol = sexp_intern(ctx, ".");
|
||||
the_quote_symbol = sexp_intern(ctx, "quote");
|
||||
the_quasiquote_symbol = sexp_intern(ctx, "quasiquote");
|
||||
the_unquote_symbol = sexp_intern(ctx, "unquote");
|
||||
the_unquote_splicing_symbol = sexp_intern(ctx, "unquote-splicing");
|
||||
the_read_error_symbol = sexp_intern(ctx, "read");
|
||||
the_empty_vector = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
|
||||
sexp_vector_length(the_empty_vector) = 0;
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue