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

preparing for set! support

Browse source
This commit is contained in:
Alex Shinn 2009-03-01 15:54:46 +09:00
parent 107566d680
commit dec08e9cfa
1 changed files with 36 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
sexp.c
View file

@ -1063,14 +1063,20 @@ env make_standard_env() {
void print_bytecode (bytecode bc) { void print_bytecode (bytecode bc) {
int i; int i;
fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", bc, bc->data, bc->len); fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", bc, bc->data, bc->len);
for (i=0; i+8 < bc->len; i+=8) { for (i=0; i+16 < bc->len; i+=8) {
fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x\n", i, fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i,
bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3],
bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]);
i += 8;
fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n",
bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3],
bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]);
} }
if (i != bc->len) { if (i != bc->len) {
fprintf(stderr, "%02x:", i); fprintf(stderr, "%02x:", i);
for ( ; i < bc->len; i++) { for ( ; i < bc->len; i++) {
if ((i % 8) == 0 && (i % 16) != 0)
fprintf(stderr, " ");
fprintf(stderr, " %02x", bc->data[i]); fprintf(stderr, " %02x", bc->data[i]);
} }
fprintf(stderr, "\n"); fprintf(stderr, "\n");
@ -1126,17 +1132,17 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) {
*i += sizeof(unsigned long); *i += sizeof(unsigned long);
} }
bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p); bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p);
void analyze_app (sexp obj, bytecode *bc, unsigned int *i, void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
env e, sexp params, sexp fv, unsigned int *d); env e, sexp params, sexp fv, sexp sv, unsigned int *d);
void analyze_lambda (sexp name, sexp formals, sexp body, void analyze_lambda (sexp name, sexp formals, sexp body,
bytecode *bc, unsigned int *i, env e, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, unsigned int *d); sexp params, sexp fv, sexp sv, unsigned int *d);
void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, unsigned int *d); sexp params, sexp fv, sexp sv, unsigned int *d);
void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
int tmp1, tmp2; int tmp1, tmp2;
env e2 = e; env e2 = e;
sexp o1, o2, cell; sexp o1, o2, cell;
@ -1158,7 +1164,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
case CORE_LAMBDA: case CORE_LAMBDA:
fprintf(stderr, ":: lambda\n"); fprintf(stderr, ":: lambda\n");
analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj), analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj),
bc, i, e, params, fv, d); bc, i, e, params, fv, sv, d);
break; break;
case CORE_DEFINE: case CORE_DEFINE:
case CORE_SET: case CORE_SET:
@ -1168,9 +1174,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), analyze_lambda(SEXP_CAR(SEXP_CADR(obj)),
SEXP_CDR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)),
SEXP_CADDR(obj), SEXP_CADDR(obj),
bc, i, e, params, fv, d); bc, i, e, params, fv, sv, d);
} else { } else {
analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d);
} }
emit(bc, i, OP_GLOBAL_SET); emit(bc, i, OP_GLOBAL_SET);
emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj))
@ -1182,24 +1188,24 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
break; break;
case CORE_BEGIN: case CORE_BEGIN:
for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) {
analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
} }
break; break;
case CORE_IF: case CORE_IF:
fprintf(stderr, "test clause: %d\n", *i); fprintf(stderr, "test clause: %d\n", *i);
analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */
tmp1 = *i; tmp1 = *i;
emit(bc, i, 0); emit(bc, i, 0);
fprintf(stderr, "pass clause: %d\n", *i); fprintf(stderr, "pass clause: %d\n", *i);
analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d);
emit(bc, i, OP_JUMP); emit(bc, i, OP_JUMP);
tmp2 = *i; tmp2 = *i;
emit(bc, i, 0); emit(bc, i, 0);
((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */
fprintf(stderr, "fail clause: %d\n", *i); fprintf(stderr, "fail clause: %d\n", *i);
if (SEXP_PAIRP(SEXP_CDDDR(obj))) { if (SEXP_PAIRP(SEXP_CDDDR(obj))) {
analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d);
} else { } else {
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
(*d)++; (*d)++;
@ -1229,16 +1235,16 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class);
} else if (SEXP_NULLP(SEXP_CDDR(obj))) { } else if (SEXP_NULLP(SEXP_CDDR(obj))) {
if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) {
analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
emit(bc, i, ((opcode)o1)->op_inverse); emit(bc, i, ((opcode)o1)->op_inverse);
} else { } else {
analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
} }
} else { } else {
/* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */
for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) {
/* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */
analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
} }
fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name);
emit(bc, i, ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name);
@ -1250,7 +1256,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
} }
} else { } else {
/* function call */ /* function call */
analyze_app(obj, bc, i, e, params, fv, d); analyze_app(obj, bc, i, e, params, fv, sv, d);
} }
} else if (SEXP_PAIRP(SEXP_CAR(obj))) { } else if (SEXP_PAIRP(SEXP_CAR(obj))) {
o2 = env_cell(e, SEXP_CAAR(obj)); o2 = env_cell(e, SEXP_CAAR(obj));
@ -1260,13 +1266,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
/* /\* let *\/ */ /* /\* let *\/ */
/* } else { */ /* } else { */
/* computed application */ /* computed application */
analyze_app(obj, bc, i, e, params, fv, d); analyze_app(obj, bc, i, e, params, fv, sv, d);
/* } */ /* } */
} else { } else {
errx(1, "invalid operator: %s", SEXP_CAR(obj)); errx(1, "invalid operator: %s", SEXP_CAR(obj));
} }
} else if (SEXP_SYMBOLP(obj)) { } else if (SEXP_SYMBOLP(obj)) {
analyze_var_ref (obj, bc, i, e, params, fv, d); analyze_var_ref (obj, bc, i, e, params, fv, sv, d);
} else { } else {
fprintf(stderr, "push: %d\n", (unsigned long)obj); fprintf(stderr, "push: %d\n", (unsigned long)obj);
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
@ -1276,7 +1282,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
} }
void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
int tmp; int tmp;
/* variable reference */ /* variable reference */
/* cell = env_cell(e, obj); */ /* cell = env_cell(e, obj); */
@ -1300,17 +1306,17 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
} }
void analyze_app (sexp obj, bytecode *bc, unsigned int *i, void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
env e, sexp params, sexp fv, unsigned int *d) { env e, sexp params, sexp fv, sexp sv, unsigned int *d) {
sexp o1; sexp o1;
unsigned long len = length(SEXP_CDR(obj)); unsigned long len = length(SEXP_CDR(obj));
/* push the arguments onto the stack */ /* push the arguments onto the stack */
for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) {
analyze(SEXP_CAR(o1), bc, i, e, params, fv, d); analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d);
} }
/* push the operator onto the stack */ /* push the operator onto the stack */
analyze(SEXP_CAR(obj), bc, i, e, params, fv, d); analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d);
/* make the call */ /* make the call */
emit(bc, i, OP_CALL); emit(bc, i, OP_CALL);
@ -1346,7 +1352,7 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
void analyze_lambda (sexp name, sexp formals, sexp body, void analyze_lambda (sexp name, sexp formals, sexp body,
bytecode *bc, unsigned int *i, env e, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
sexp obj; sexp obj;
sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls;
env e2 = extend_env_closure(e, formals); env e2 = extend_env_closure(e, formals);
@ -1354,7 +1360,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
fprintf(stderr, "%d free-vars\n", length(fv2)); fprintf(stderr, "%d free-vars\n", length(fv2));
write_sexp(stderr, fv2); write_sexp(stderr, fv2);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
obj = (sexp) compile(formals, body, e2, fv2, 0); obj = (sexp) compile(formals, body, e2, fv2, sv, 0);
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) SEXP_UNDEF); emit_word(bc, i, (unsigned long) SEXP_UNDEF);
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
@ -1362,7 +1368,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
emit(bc, i, OP_MAKE_VECTOR); emit(bc, i, OP_MAKE_VECTOR);
(*d)++; (*d)++;
for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) {
analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, d); analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, sv, d);
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) make_integer(k)); emit_word(bc, i, (unsigned long) make_integer(k));
emit(bc, i, OP_STACK_REF); emit(bc, i, OP_STACK_REF);
@ -1562,13 +1568,13 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
return stack[top-1]; return stack[top-1];
} }
bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p) { bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE);
unsigned int i = 0, d = 0; unsigned int i = 0, d = 0;
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = INIT_BCODE_SIZE; bc->len = INIT_BCODE_SIZE;
fprintf(stderr, "analyzing\n"); fprintf(stderr, "analyzing\n");
analyze(obj, &bc, &i, e, params, fv, &d); analyze(obj, &bc, &i, e, params, fv, sv, &d);
emit(&bc, &i, done_p ? OP_DONE : OP_RET); emit(&bc, &i, done_p ? OP_DONE : OP_RET);
/* fprintf(stderr, "shrinking\n"); */ /* fprintf(stderr, "shrinking\n"); */
shrink_bcode(&bc, i); shrink_bcode(&bc, i);
@ -1578,7 +1584,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p) {
} }
sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) {
bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, 1); bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, SEXP_NULL, 1);
fprintf(stderr, "evaling\n"); fprintf(stderr, "evaling\n");
return vm(bc, e, stack, top); return vm(bc, e, stack, top);
} }