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

back to basics - literals and opcodes work

Browse source
This commit is contained in:
Alex Shinn 2009-03-25 23:59:01 +09:00
parent 989803f2d2
commit ab82735500
2 changed files with 51 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

87
eval.c
View file

@ -74,15 +74,15 @@ static sexp env_cell_create(sexp e, sexp key, sexp value) {
return cell; return cell;
} }
static int env_global_p (sexp e, sexp id) { /* static int env_global_p (sexp e, sexp id) { */
while (sexp_env_parent(e)) { /* while (sexp_env_parent(e)) { */
if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) /* if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) */
return 0; /* return 0; */
else /* else */
e = sexp_env_parent(e); /* e = sexp_env_parent(e); */
} /* } */
return 1; /* return 1; */
} /* } */
static void env_define(sexp e, sexp key, sexp value) { static void env_define(sexp e, sexp key, sexp value) {
sexp cell = sexp_assq(key, sexp_env_bindings(e)); sexp cell = sexp_assq(key, sexp_env_bindings(e));
@ -101,11 +101,11 @@ static sexp extend_env (sexp env, sexp vars, sexp value) {
return e; return e;
} }
static int core_code (sexp e, sexp sym) { /* static int core_code (sexp e, sexp sym) { */
sexp cell = env_cell(e, sym); /* sexp cell = env_cell(e, sym); */
if (! cell || ! sexp_corep(sexp_cdr(cell))) return 0; /* if (! cell || ! sexp_corep(sexp_cdr(cell))) return 0; */
return (sexp_core_code(sexp_cdr(cell))); /* return (sexp_core_code(sexp_cdr(cell))); */
} /* } */
static sexp sexp_reverse_flatten_dot (sexp ls) { static sexp sexp_reverse_flatten_dot (sexp ls) {
sexp res; sexp res;
@ -214,6 +214,7 @@ static sexp sexp_new_context(sexp *stack) {
sexp_context_bc(res) sexp_context_bc(res)
= sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE);
sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
sexp_context_lambda(res) = SEXP_FALSE;
sexp_context_stack(res) = stack; sexp_context_stack(res) = stack;
sexp_context_depth(res) = 0; sexp_context_depth(res) = 0;
sexp_context_pos(res) = 0; sexp_context_pos(res) = 0;
@ -307,6 +308,10 @@ sexp analyze (sexp x, sexp env) {
/* x = expand_macro(op, x, env); */ /* x = expand_macro(op, x, env); */
/* goto loop; */ /* goto loop; */
res = sexp_compile_error("macros not yet supported", sexp_list1(x)); res = sexp_compile_error("macros not yet supported", sexp_list1(x));
} else if (sexp_opcodep(op)) {
res = analyze_app(sexp_cdr(x), env);
analyze_check_exception(res);
sexp_push(res, op);
} else { } else {
res = analyze_app(x, env); res = analyze_app(x, env);
} }
@ -418,6 +423,7 @@ void sexp_context_patch_label (sexp context, sexp_uint_t label) {
static sexp finalize_bytecode (sexp context) { static sexp finalize_bytecode (sexp context) {
emit(OP_RET, context); emit(OP_RET, context);
shrink_bcode(context, sexp_context_pos(context)); shrink_bcode(context, sexp_context_pos(context));
disasm(sexp_context_bc(context));
return sexp_context_bc(context); return sexp_context_bc(context);
} }
@ -1209,6 +1215,7 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
#define _ARG2 stack[top-2] #define _ARG2 stack[top-2]
#define _ARG3 stack[top-3] #define _ARG3 stack[top-3]
#define _ARG4 stack[top-4] #define _ARG4 stack[top-4]
#define _ARG5 stack[top-5]
#define _PUSH(x) (stack[top++]=(x)) #define _PUSH(x) (stack[top++]=(x))
#define _POP() (stack[--top]) #define _POP() (stack[--top])
@ -1217,11 +1224,11 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
unsigned char *ip=sexp_bytecode_data(bc); unsigned char *ip=sexp_bytecode_data(bc);
sexp tmp1, tmp2; sexp tmp1, tmp2;
sexp_sint_t i, j, k; sexp_sint_t i, j, k, fp=top-4;
loop: loop:
/* print_stack(stack, top); */ print_stack(stack, top);
/* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "<unknown>", *ip); */ fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "<unknown>", *ip);
switch (*ip++) { switch (*ip++) {
case OP_NOOP: case OP_NOOP:
fprintf(stderr, "noop\n"); fprintf(stderr, "noop\n");
@ -1229,14 +1236,15 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
case OP_LOCAL_REF: case OP_LOCAL_REF:
/* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ /* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */
/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */
stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; /* stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; */
stack[top] = stack[fp - (sexp_sint_t) ((sexp*)ip)[0]];
ip += sizeof(sexp); ip += sizeof(sexp);
top++; top++;
break; break;
case OP_LOCAL_SET: case OP_LOCAL_SET:
/* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ /* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */
/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */
stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; stack[fp - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1;
_ARG1 = SEXP_UNDEF; _ARG1 = SEXP_UNDEF;
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
@ -1485,10 +1493,12 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
_ARG1 = sexp_make_integer(i); _ARG1 = sexp_make_integer(i);
stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top] = sexp_make_integer(ip+sizeof(sexp));
stack[top+1] = cp; stack[top+1] = cp;
top+=2; stack[top+2] = (sexp) fp;
top+=3;
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
ip = sexp_bytecode_data(bc); ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1); cp = sexp_procedure_vars(tmp1);
fp = top-4;
break; break;
case OP_APPLY1: case OP_APPLY1:
tmp1 = _ARG1; tmp1 = _ARG1;
@ -1594,15 +1604,18 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
break; break;
case OP_RET: case OP_RET:
if (top<4) /* if (top<4) */
goto end_loop; /* goto end_loop; */
cp = _ARG2; fp = (sexp_sint_t) _ARG2;
ip = (unsigned char*) sexp_unbox_integer(_ARG3); cp = _ARG3;
i = sexp_unbox_integer(_ARG4); ip = (unsigned char*) sexp_unbox_integer(_ARG4);
stack[top-i-4] = _ARG1; i = sexp_unbox_integer(_ARG5);
top = top-i-3; stack[top-i-5] = _ARG1;
top = top-i-4;
fprintf(stderr, "returning to %p (i=%ld)\n", ip, i);
break; break;
case OP_DONE: case OP_DONE:
fprintf(stderr, "done!\n");
goto end_loop; goto end_loop;
default: default:
sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1))));
@ -1747,7 +1760,7 @@ sexp make_standard_env () {
/************************** eval interface ****************************/ /************************** eval interface ****************************/
/* args ... n ret-ip ret-cp */ /* args ... n ret-ip ret-cp ret-fp */
sexp apply(sexp proc, sexp args, sexp env, sexp context) { sexp apply(sexp proc, sexp args, sexp env, sexp context) {
sexp *stack = sexp_context_stack(context), ls; sexp *stack = sexp_context_stack(context), ls;
sexp_sint_t top=0; sexp_sint_t top=0;
@ -1755,9 +1768,9 @@ sexp apply(sexp proc, sexp args, sexp env, sexp context) {
stack[top++] = sexp_car(ls); stack[top++] = sexp_car(ls);
stack[top] = sexp_make_integer(top); stack[top] = sexp_make_integer(top);
top++; top++;
stack[top++] stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
= sexp_make_integer(sexp_bytecode_data(sexp_procedure_code(final_resumer)));
stack[top++] = sexp_make_vector(0, SEXP_UNDEF); stack[top++] = sexp_make_vector(0, SEXP_UNDEF);
stack[top++] = sexp_make_integer(0);
return return
vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), env, stack, top); vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), env, stack, top);
} }
@ -1820,13 +1833,13 @@ void repl (sexp env, sexp context) {
} }
int main (int argc, char **argv) { int main (int argc, char **argv) {
sexp bc, e, obj, res, *stack, context, err_handler, err_handler_sym; sexp env, obj, res, context, err_handler, err_handler_sym;
sexp_uint_t i, quit=0, init_loaded=0; sexp_uint_t i, quit=0, init_loaded=0;
scheme_init(); scheme_init();
/* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */ /* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */
e = make_standard_env(); env = make_standard_env();
interaction_environment = e; interaction_environment = env;
/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */ /* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */
/* sexp_bytecode_length(bc) = 16; */ /* sexp_bytecode_length(bc) = 16; */
/* i = 0; */ /* i = 0; */
@ -1838,8 +1851,8 @@ int main (int argc, char **argv) {
finalize_bytecode(context), finalize_bytecode(context),
sexp_make_vector(0, SEXP_UNDEF)); sexp_make_vector(0, SEXP_UNDEF));
err_handler_sym = sexp_intern("*error-handler*"); err_handler_sym = sexp_intern("*error-handler*");
env_define(e, err_handler_sym, err_handler); env_define(env, err_handler_sym, err_handler);
exception_handler_cell = env_cell(e, err_handler_sym); exception_handler_cell = env_cell(env, err_handler_sym);
/* parse options */ /* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) { for (i=1; i < argc && argv[i][0] == '-'; i++) {
@ -1851,7 +1864,7 @@ int main (int argc, char **argv) {
init_loaded = 1; init_loaded = 1;
} }
obj = sexp_read_from_string(argv[i+1]); obj = sexp_read_from_string(argv[i+1]);
res = eval_in_context(obj, e, context); res = eval_in_context(obj, env, context);
if (argv[i][1] == 'p') { if (argv[i][1] == 'p') {
sexp_write(res, cur_output_port); sexp_write(res, cur_output_port);
sexp_write_char('\n', cur_output_port); sexp_write_char('\n', cur_output_port);
@ -1874,7 +1887,7 @@ int main (int argc, char **argv) {
for ( ; i < argc; i++) for ( ; i < argc; i++)
sexp_load(sexp_make_string(argv[i])); sexp_load(sexp_make_string(argv[i]));
else else
repl(e, context); repl(env, context);
} }
return 0; return 0;
} }

2
sexp.c
View file

@ -56,7 +56,7 @@ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) {
if (! res) if (! res)
errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld",
size ,tag); size ,tag);
res->tag = tag; sexp_pointer_tag(res) = tag;
return res; return res;
} }