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

reintroducing dynamic opcode procedures

Browse source
This commit is contained in:
Alex Shinn 2009-03-27 18:02:41 +09:00
parent c97ecdb501
commit ca62786e3e
3 changed files with 46 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

68
eval.c
View file

@ -32,6 +32,7 @@ static sexp analyze_app (sexp x, sexp context);
static sexp analyze_define (sexp x, sexp context); static sexp analyze_define (sexp x, sexp context);
static sexp analyze_var_ref (sexp x, sexp context); static sexp analyze_var_ref (sexp x, sexp context);
static sexp analyze_set (sexp x, sexp context); static sexp analyze_set (sexp x, sexp context);
static sexp analyze_define_syntax (sexp x, sexp context);
static sexp_sint_t sexp_context_make_label (sexp context); static sexp_sint_t sexp_context_make_label (sexp context);
static void sexp_context_patch_label (sexp context, sexp_sint_t label); static void sexp_context_patch_label (sexp context, sexp_sint_t label);
@ -280,14 +281,18 @@ static sexp analyze (sexp x, sexp context) {
case CORE_QUOTE: case CORE_QUOTE:
res = sexp_make_lit(sexp_cadr(x)); res = sexp_make_lit(sexp_cadr(x));
break; break;
case CORE_DEFINE_SYNTAX:
res = analyze_define_syntax(x, context);
break;
default: default:
res = sexp_compile_error("unknown core form", sexp_list1(op)); res = sexp_compile_error("unknown core form", sexp_list1(op));
break; break;
} }
} else if (sexp_macrop(op)) { } else if (sexp_macrop(op)) {
/* x = expand_macro(op, x, context); */ x = apply(sexp_macro_proc(op),
/* goto loop; */ sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)),
res = sexp_compile_error("macros not yet supported", sexp_list1(x)); context);
goto loop;
} else if (sexp_opcodep(op)) { } else if (sexp_opcodep(op)) {
res = analyze_app(sexp_cdr(x), context); res = analyze_app(sexp_cdr(x), context);
analyze_check_exception(res); analyze_check_exception(res);
@ -396,6 +401,15 @@ static sexp analyze_set (sexp x, sexp context) {
return sexp_make_set(ref, value); return sexp_make_set(ref, value);
} }
static sexp analyze_define_syntax (sexp x, sexp context) {
sexp name = sexp_cadr(x), cell, proc;
proc = eval_in_context(sexp_caddr(x), context);
analyze_check_exception(proc);
cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF);
sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
return SEXP_UNDEF;
}
static sexp_sint_t sexp_context_make_label (sexp context) { static sexp_sint_t sexp_context_make_label (sexp context) {
sexp_sint_t label = sexp_context_pos(context); sexp_sint_t label = sexp_context_pos(context);
sexp_context_pos(context) += sizeof(sexp_uint_t); sexp_context_pos(context) += sizeof(sexp_uint_t);
@ -732,25 +746,24 @@ static sexp make_param_list(sexp_uint_t i) {
return res; return res;
} }
static sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env,
/* sexp bc, params, res; */ sexp *stack, sexp_sint_t top) {
/* sexp_uint_t pos=0, d=0; */ sexp context, params, bc, res;
/* if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) */ if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
/* return sexp_opcode_proc(op); */ return sexp_opcode_proc(op);
/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); */ params = make_param_list(i);
/* params = make_param_list(i); */ context = sexp_new_context(stack);
/* e = extend_env(e, params, SEXP_UNDEF); */ sexp_context_top(context) = top;
/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ sexp_context_env(context) = extend_env(env, params, SEXP_UNDEF);
/* analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, */ generate_opcode_app(sexp_cons(op, params), context);
/* SEXP_NULL, SEXP_NULL, &d, 0); */ bc = finalize_bytecode(context);
/* emit(&bc, &pos, OP_RET); */ res = sexp_make_procedure(sexp_make_integer(0),
/* shrink_bcode(&bc, pos); */ sexp_make_integer(i),
/* /\* disasm(bc); *\/ */ bc,
/* res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); */ SEXP_UNDEF);
/* if (i == sexp_opcode_num_args(op)) */ if (i == sexp_opcode_num_args(op))
/* sexp_opcode_proc(op) = res; */ sexp_opcode_proc(op) = res;
/* return res; */ return res;
return SEXP_UNDEF;
} }
/*********************** the virtual machine **************************/ /*********************** the virtual machine **************************/
@ -1032,7 +1045,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
make_call: make_call:
if (sexp_opcodep(tmp1)) { if (sexp_opcodep(tmp1)) {
/* compile non-inlined opcode applications on the fly */ /* compile non-inlined opcode applications on the fly */
tmp1 = make_opcode_procedure(tmp1, i, e); tmp1 = make_opcode_procedure(tmp1, i, e, stack, top);
if (sexp_exceptionp(tmp1)) { if (sexp_exceptionp(tmp1)) {
_ARG1 = tmp1; _ARG1 = tmp1;
goto call_error_handler; goto call_error_handler;
@ -1041,7 +1054,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
if (! sexp_procedurep(tmp1)) if (! sexp_procedurep(tmp1))
sexp_raise("non procedure application", sexp_list1(tmp1)); sexp_raise("non procedure application", sexp_list1(tmp1));
j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1));
fprintf(stderr, "arg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j); fprintf(stderr, "\narg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j);
if (j < 0) if (j < 0)
sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i)));
if (j > 0) { if (j > 0) {
@ -1338,9 +1351,10 @@ sexp make_standard_env () {
/* args ... n ret-ip ret-cp ret-fp */ /* args ... n ret-ip ret-cp ret-fp */
sexp apply(sexp proc, sexp args, sexp context) { sexp apply(sexp proc, sexp args, sexp context) {
sexp *stack = sexp_context_stack(context), ls; sexp *stack = sexp_context_stack(context), ls;
sexp_sint_t top = sexp_context_top(context); sexp_sint_t top = sexp_context_top(context), offset;
for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls)) offset = top + sexp_unbox_integer(sexp_length(args));
stack[top++] = sexp_car(ls); for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
stack[--offset] = sexp_car(ls);
stack[top] = sexp_make_integer(top); stack[top] = sexp_make_integer(top);
top++; top++;
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));

19
eval.h
View file

@ -124,24 +124,7 @@ enum opcode_names {
/**************************** prototypes ******************************/ /**************************** prototypes ******************************/
/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); */ sexp apply(sexp proc, sexp args, sexp context);
/* sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, */
/* sexp e, sexp params, sexp fv, sexp sv, */
/* sexp_uint_t *d, int tailp); */
/* sexp analyze_lambda(sexp name, sexp formals, sexp body, */
/* sexp *bc, sexp_uint_t *i, sexp e, */
/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */
/* void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, */
/* sexp params, sexp fv, sexp sv, sexp_uint_t *d); */
/* sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */
/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */
/* sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */
/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */
/* sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */
/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */
/* sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top); */
sexp eval_in_context(sexp expr, sexp context); sexp eval_in_context(sexp expr, sexp context);
sexp eval(sexp expr, sexp env); sexp eval(sexp expr, sexp env);

8
init.scm
View file

@ -84,10 +84,10 @@
;; (append (map (lambda (x) (cons 'define x)) (cadr expr)) ;; (append (map (lambda (x) (cons 'define x)) (cadr expr))
;; (cddr expr))))))) ;; (cddr expr)))))))
;; (define-syntax let (define-syntax let
;; (lambda (expr use-env mac-env) (lambda (expr use-env mac-env)
;; (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr)))
;; (map cadr (cadr expr))))) (map cadr (cadr expr)))))
;; (define-syntax or ;; (define-syntax or
;; (lambda (expr use-env mac-env) ;; (lambda (expr use-env mac-env)