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

moving towards closure support

Browse source
This commit is contained in:
Alex Shinn 2009-03-01 14:47:34 +09:00
parent 105c317700
commit 3a7d12062f
1 changed files with 209 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

276
sexp.c
View file

@ -108,6 +108,9 @@ static sexp the_if_symbol;
#define vector_length(x) ((unsigned long) x->data1) #define vector_length(x) ((unsigned long) x->data1)
#define vector_data(x) ((sexp*) x->data2) #define vector_data(x) ((sexp*) x->data2)
#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)])
#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v))
#define procedure_code(x) ((bytecode) ((sexp)x)->data1) #define procedure_code(x) ((bytecode) ((sexp)x)->data1)
#define procedure_vars(x) ((sexp) ((sexp)x)->data2) #define procedure_vars(x) ((sexp) ((sexp)x)->data2)
@ -203,6 +206,14 @@ sexp set_car(sexp obj, sexp val) {
} }
} }
sexp set_cdr(sexp obj, sexp val) {
if (SEXP_PAIRP(obj)) {
return SEXP_CDR(obj) = val;
} else {
return SEXP_ERROR;
}
}
int listp (sexp obj) { int listp (sexp obj) {
while (SEXP_PAIRP(obj)) while (SEXP_PAIRP(obj))
obj = SEXP_CDR(obj); obj = SEXP_CDR(obj);
@ -220,14 +231,6 @@ int list_index (sexp ls, sexp elt) {
return -1; return -1;
} }
sexp set_cdr(sexp obj, sexp val) {
if (SEXP_PAIRP(obj)) {
return SEXP_CDR(obj) = val;
} else {
return SEXP_ERROR;
}
}
sexp reverse(sexp ls) { sexp reverse(sexp ls) {
sexp res = SEXP_NULL; sexp res = SEXP_NULL;
for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
@ -271,6 +274,26 @@ sexp list(int count, ...) {
return nreverse(res); return nreverse(res);
} }
sexp memq (sexp x, sexp ls) {
while (SEXP_PAIRP(ls)) {
if (x == SEXP_CAR(ls))
return ls;
else
ls = SEXP_CDR(ls);
}
return SEXP_FALSE;
}
sexp assq (sexp x, sexp ls) {
while (SEXP_PAIRP(ls)) {
if (x == SEXP_CAAR(ls))
return ls;
else
ls = SEXP_CDR(ls);
}
return SEXP_FALSE;
}
unsigned long length(sexp ls) { unsigned long length(sexp ls) {
sexp x; sexp x;
unsigned long res; unsigned long res;
@ -885,31 +908,35 @@ enum opcode_classes {
/* #define OP_UNSAFE(op) ((op)+128) */ /* #define OP_UNSAFE(op) ((op)+128) */
enum opcode_names { enum opcode_names {
OP_NOOP, OP_NOOP, /* 0 */
OP_STACK_REF, OP_STACK_REF, /* 1 */
OP_STACK_SET, OP_STACK_SET, /* 2 */
OP_GLOBAL_REF, OP_GLOBAL_REF, /* 3 */
OP_GLOBAL_SET, OP_GLOBAL_SET, /* 4 */
OP_CLOSURE_REF, OP_CLOSURE_REF, /* 5 */
OP_CLOSURE_SET, OP_CLOSURE_SET,
OP_VECTOR_REF,
OP_VECTOR_SET, /* 8 */
OP_MAKE_PROCEDURE,
OP_MAKE_VECTOR,
OP_PUSH, OP_PUSH,
OP_DUP, OP_DUP, /* C */
OP_DROP, OP_DROP,
OP_SWAP, OP_SWAP,
OP_CAR, OP_CAR,
OP_CDR, OP_CDR, /* 10 */
OP_CONS, OP_CONS,
OP_ADD, OP_ADD,
OP_SUB, OP_SUB,
OP_MUL, OP_MUL, /* 14 */
OP_DIV, OP_DIV,
OP_MOD, OP_MOD,
OP_NEG, OP_NEG,
OP_INV, OP_INV, /* 18 */
OP_LT, OP_LT,
OP_CALL, OP_CALL,
OP_JUMP_UNLESS, OP_JUMP_UNLESS,
OP_JUMP, OP_JUMP, /* 1C */
OP_RET, OP_RET,
OP_DONE, OP_DONE,
}; };
@ -923,18 +950,22 @@ typedef struct opcode {
char arg1_type; char arg1_type;
char arg2_type; char arg2_type;
char* name; char* name;
char op_inverse;
sexp proc; sexp proc;
} *opcode; } *opcode;
static struct opcode opcodes[] = { static struct opcode opcodes[] = {
{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", NULL}, {SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0, NULL},
{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", NULL}, {SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0, NULL},
{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0, NULL},
{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG, NULL},
{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0, NULL},
{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV, 0},
{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0, NULL},
{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", NULL}, {SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0, NULL},
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0, NULL},
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0, NULL},
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL},
}; };
sexp env_cell(env e, sexp key) { sexp env_cell(env e, sexp key) {
@ -962,6 +993,16 @@ sexp make_procedure(sexp bc, sexp vars) {
return proc; return proc;
} }
int env_global_p (env e, sexp id) {
while (e->parent) {
if (assq(id, e->bindings))
return 0;
else
e = e->parent;
}
return 1;
}
void env_define(env e, sexp key, sexp value) { void env_define(env e, sexp key, sexp value) {
sexp cell = env_cell(e, key); sexp cell = env_cell(e, key);
if (cell) { if (cell) {
@ -971,6 +1012,18 @@ void env_define(env e, sexp key, sexp value) {
} }
} }
env extend_env_closure (env e, sexp fv) {
int i;
env e2 = (env) malloc(sizeof(struct env));
e2->tag = SEXP_ENV;
e2->parent = e;
e2->bindings = SEXP_NULL;
for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) {
e2->bindings = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings);
}
return e2;
}
env make_standard_env() { env make_standard_env() {
int i; int i;
env e = (env) malloc(sizeof(struct env)); env e = (env) malloc(sizeof(struct env));
@ -1079,8 +1132,11 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
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, unsigned int *d); sexp params, unsigned int *d);
void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e,
sexp params, unsigned int *d);
void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d) { void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, unsigned int *d) {
int tmp1, tmp2; int tmp1, tmp2;
env e2 = e; env e2 = e;
sexp o1, o2, cell; sexp o1, o2, cell;
@ -1167,15 +1223,27 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign
case OPC_TYPE_PREDICATE: case OPC_TYPE_PREDICATE:
case OPC_PREDICATE: case OPC_PREDICATE:
case OPC_ARITHMETIC: case OPC_ARITHMETIC:
case OPC_ARITHMETIC_INV:
case OPC_ARITHMETIC_CMP: case OPC_ARITHMETIC_CMP:
/* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ if (SEXP_NULLP(SEXP_CDR(obj))) {
for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class);
/* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ } else if (SEXP_NULLP(SEXP_CDDR(obj))) {
analyze(SEXP_CAR(o2), bc, i, e, params, d); if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) {
analyze(SEXP_CADR(obj), bc, i, e, params, d);
emit(bc, i, ((opcode)o1)->op_inverse);
} else {
analyze(SEXP_CADR(obj), bc, i, e, params, d);
}
} else {
/* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */
for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) {
/* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */
analyze(SEXP_CAR(o2), bc, i, e, params, d);
}
fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name);
emit(bc, i, ((opcode)o1)->op_name);
(*d) -= length(SEXP_CDDR(obj));
} }
fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name);
emit(bc, i, ((opcode)o1)->op_name);
(*d) -= length(SEXP_CDDR(obj));
break; break;
default: default:
errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class);
@ -1186,32 +1254,19 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign
} }
} 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));
if (o2 /* if (o2 */
&& SEXP_COREP(SEXP_CDR(o2)) /* && SEXP_COREP(SEXP_CDR(o2)) */
&& (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { /* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { */
/* let */ /* /\* let *\/ */
} else { /* } else { */
/* computed application */ /* computed application */
analyze_app(obj, bc, i, e, params, d); analyze_app(obj, bc, i, e, params, 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)) {
/* variable reference */ analyze_var_ref (obj, bc, i, e, params, d);
/* cell = env_cell(e, obj); */
fprintf(stderr, "symbol lookup, param length: %d\n", length(params));
if ((tmp1 = list_index(params, obj)) >= 0) {
fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp1, *d);
emit(bc, i, OP_STACK_REF);
emit_word(bc, i, tmp1 + *d + 3);
(*d)++;
} else {
fprintf(stderr, "compiling global ref: %p\n", obj);
emit(bc, i, OP_GLOBAL_REF);
emit_word(bc, i, (unsigned long) obj);
(*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);
@ -1220,6 +1275,25 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign
} }
} }
void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, unsigned int *d) {
int tmp;
/* variable reference */
/* cell = env_cell(e, obj); */
fprintf(stderr, "symbol lookup, param length: %d\n", length(params));
if ((tmp = list_index(params, obj)) >= 0) {
fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d);
emit(bc, i, OP_STACK_REF);
emit_word(bc, i, tmp + *d + 4);
(*d)++;
} else {
fprintf(stderr, "compiling global ref: %p\n", obj);
emit(bc, i, OP_GLOBAL_REF);
emit_word(bc, i, (unsigned long) obj);
(*d)++;
}
}
void analyze_app (sexp obj, bytecode *bc, unsigned int *i, void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
env e, sexp params, unsigned int *d) { env e, sexp params, unsigned int *d) {
sexp o1; sexp o1;
@ -1238,14 +1312,60 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
emit_word(bc, i, (unsigned long) make_integer(len)); emit_word(bc, i, (unsigned long) make_integer(len));
} }
sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
sexp o1;
if (SEXP_SYMBOLP(obj)) {
if (env_global_p(e, obj)
|| (list_index(formals, obj) >= 0)
|| (list_index(fv, obj) >= 0))
return fv;
else
return cons(obj, fv);
} else if (SEXP_PAIRP(obj)) {
if (SEXP_SYMBOLP(SEXP_CAR(obj))) {
if ((o1 = env_cell(e, SEXP_CAR(obj)))
&& SEXP_COREP(o1)
&& (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) {
return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv);
}
}
while (SEXP_PAIRP(obj)) {
fv = free_vars(e, formals, SEXP_CAR(obj), fv);
obj = SEXP_CDR(obj);
}
return fv;
} else {
return 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, unsigned int *d) { sexp params, unsigned int *d) {
sexp obj = (sexp) compile(formals, body, e, 0); sexp obj;
sexp fv = free_vars(e, formals, body, SEXP_NULL), ls;
env e2 = extend_env_closure(e, formals);
int k;
obj = (sexp) compile(formals, body, e2, 0);
emit(bc, i, OP_PUSH); emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) SEXP_UNDEF);
emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) make_integer(length(fv)));
emit(bc, i, OP_MAKE_VECTOR);
(*d)++; (*d)++;
obj = make_procedure(obj, SEXP_NULL); for (ls=fv, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) {
analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, d);
emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) make_integer(k));
emit(bc, i, OP_STACK_REF);
emit_word(bc, i, 2);
emit(bc, i, OP_VECTOR_SET);
emit(bc, i, OP_DROP);
(*d)--;
}
emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) obj); emit_word(bc, i, (unsigned long) obj);
emit(bc, i, OP_MAKE_PROCEDURE);
} }
sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
@ -1288,10 +1408,28 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top++; top++;
break; break;
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
/* stack[top++]=cp[*ip++]; */ stack[top++]=vector_ref(cp,((sexp*)ip)[0]);
ip += sizeof(sexp);
break; break;
case OP_CLOSURE_SET: /* case OP_CLOSURE_SET: */
/* cp[*ip++]=stack[top--]; */ /* cp[*ip++]=stack[--top]; */
/* break; */
case OP_VECTOR_REF:
stack[top-2]=vector_ref(stack[top-1], stack[top-2]);
top--;
break;
case OP_VECTOR_SET:
vector_set(stack[top-1], stack[top-2], stack[top-3]);
stack[top-3]=SEXP_UNDEF;
top-=2;
break;
case OP_MAKE_PROCEDURE:
stack[top-2]=make_procedure(stack[top-1], stack[top-2]);
top--;
break;
case OP_MAKE_VECTOR:
stack[top-2]=make_vector(unbox_integer(stack[top-2]), stack[top-1]);
top--;
break; break;
case OP_PUSH: case OP_PUSH:
/* fprintf(stderr, " (push)\n"); */ /* fprintf(stderr, " (push)\n"); */
@ -1321,11 +1459,12 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top--; top--;
break; break;
case OP_ADD: case OP_ADD:
fprintf(stderr, "OP_ADD %d %d\n", unbox_integer(stack[top-2]), unbox_integer(stack[top-1]));
stack[top-2]=sexp_add(stack[top-2],stack[top-1]); stack[top-2]=sexp_add(stack[top-2],stack[top-1]);
top--; top--;
break; break;
case OP_SUB: case OP_SUB:
stack[top-2]=sexp_sub(stack[top-2],stack[top-1]); stack[top-2]=sexp_sub(stack[top-1],stack[top-2]);
top--; top--;
break; break;
case OP_MUL: case OP_MUL:
@ -1352,11 +1491,13 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
errx(2, "non-procedure application: %p", tmp); errx(2, "non-procedure application: %p", tmp);
stack[top-1] = (sexp) i; stack[top-1] = (sexp) i;
stack[top] = (sexp) (ip+4); stack[top] = (sexp) (ip+4);
top++; stack[top+1] = cp;
top+=2;
bc = procedure_code(tmp); bc = procedure_code(tmp);
print_bytecode(bc); print_bytecode(bc);
ip = bc->data; ip = bc->data;
fprintf(stderr, "... jumping to procedure at %p\n", ip); cp = procedure_vars(tmp);
fprintf(stderr, "... calling procedure at %p\n", ip);
/* print_stack(stack, top); */ /* print_stack(stack, top); */
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
@ -1381,10 +1522,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/* print_stack(stack, top); */ /* print_stack(stack, top); */
/* top-1 */ /* top-1 */
/* stack: args ... n ip result */ /* stack: args ... n ip result */
ip = (unsigned char*) stack[top-2]; cp = stack[top-2];
i = unbox_integer(stack[top-3]); ip = (unsigned char*) stack[top-3];
stack[top-i-3] = stack[top-1]; i = unbox_integer(stack[top-4]);
top = top-i-2; stack[top-i-4] = stack[top-1];
top = top-i-3;
break; break;
case OP_DONE: case OP_DONE:
fprintf(stderr, "finally returning @ %d: ", top-1); fprintf(stderr, "finally returning @ %d: ", top-1);