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

internal define support

Browse source
This commit is contained in:
Alex Shinn 2009-03-11 02:53:05 +09:00
parent 66b44631e4
commit c2103148cb
3 changed files with 75 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

93
eval.c
View file

@ -176,6 +176,11 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
emit_word(bc, i, (sexp_uint_t) o2); emit_word(bc, i, (sexp_uint_t) o2);
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
} else { } else {
o1 = env_cell(e, o2);
if (! o1)
errx(1, "define in bad position: %p", o2);
emit(bc, i, OP_STACK_SET);
emit_word(bc, i, sexp_unbox_integer(SEXP_CDR(o1)));
} }
(*d)++; (*d)++;
break; break;
@ -347,7 +352,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
} else if ((tmp = sexp_list_index(fv, obj)) >= 0) { } else if ((tmp = sexp_list_index(fv, obj)) >= 0) {
/* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */
emit(bc, i, OP_CLOSURE_REF); emit(bc, i, OP_CLOSURE_REF);
emit_word(bc, i, tmp); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp));
} else { } else {
/* fprintf(stderr, "compiling global ref: %p\n", obj); */ /* fprintf(stderr, "compiling global ref: %p\n", obj); */
emit(bc, i, OP_GLOBAL_REF); emit(bc, i, OP_GLOBAL_REF);
@ -475,7 +480,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
} }
bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
unsigned int i = 0, j, d = 0, define_ok=1; unsigned int i = 0, j, d = 0, core, define_ok=1;
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE);
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls;
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
@ -494,36 +499,55 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
} }
sv = sexp_append(sv2, sv); sv = sexp_append(sv2, sv);
/* determine internal defines */ /* determine internal defines */
/* for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { */ if (e->parent) {
/* core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) */ for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) {
/* && core_code(SEXP_CAAR(obj)); */ core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj))
/* if (core == CORE_BEGIN) { */ && core_code(e, SEXP_CAAR(obj));
/* obj = sexp_cons(SEXP_CAR(obj), */ if (core == CORE_BEGIN) {
/* sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); */ obj = sexp_cons(SEXP_CAR(obj),
/* } else { */ sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj)));
/* if (core == CORE_DEFINE) { */ } else {
/* if (! define_ok) */ if (core == CORE_DEFINE) {
/* errx(1, "definition in non-definition context: %p", obj); */ if (! define_ok)
/* internals = sexp_cons(SEXP_CADR(obj), internals); */ errx(1, "definition in non-definition context: %p", obj);
/* } else { */ internals = sexp_cons(SEXP_PAIRP(SEXP_CADAR(obj))
/* define_ok = 0; */ ? SEXP_CAR(SEXP_CADAR(obj)) : SEXP_CADAR(obj),
/* } */ internals);
/* ls = sexp_cons(SEXP_CAR(obj), ls); */ } else {
/* } */ define_ok = 0;
/* } */ }
/* obj = sexp_reverse(ls); */ ls = sexp_cons(SEXP_CAR(obj), ls);
/* if (SEXP_PAIRP(internals)) { */ }
/* e = extend_env_closure(e, internals); */ }
/* } */ obj = sexp_reverse(ls);
/* sexp_write_string("internals: ", cur_error_port); */
/* sexp_write(internals, cur_error_port); */
/* sexp_write_string("\n", cur_error_port); */
j = sexp_length(internals);
if (SEXP_PAIRP(internals)) {
e = extend_env_closure(e, internals, 2);
params = sexp_append(internals, params);
for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF);
d+=j;
}
}
/* analyze body sequence */ /* analyze body sequence */
for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) {
if (SEXP_PAIRP(SEXP_CDR(obj))) { if (SEXP_PAIRP(SEXP_CDR(obj))) {
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0);
emit(&bc, &i, OP_DROP); emit(&bc, &i, OP_DROP);
} else { } else {
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, ! done_p); analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d,
! done_p && ! SEXP_PAIRP(internals));
} }
} }
if (SEXP_PAIRP(internals)) {
emit(&bc, &i, OP_STACK_SET);
emit_word(&bc, &i, j+1);
for (j; j>0; j--)
emit(&bc, &i, OP_DROP);
}
emit(&bc, &i, done_p ? OP_DONE : OP_RET); emit(&bc, &i, done_p ? OP_DONE : OP_RET);
shrink_bcode(&bc, i); shrink_bcode(&bc, i);
print_bytecode(bc); print_bytecode(bc);
@ -559,7 +583,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
int i, j, k; int i, j, k;
loop: loop:
/* 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");
@ -582,12 +606,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top++; top++;
break; break;
case OP_STACK_SET: case OP_STACK_SET:
/* print_stack(stack, top); */
/* fprintf(stderr, "stack-set: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */
/* sexp_write(stack[top-1], cur_error_port); */
/* fprintf(stderr, "\n"); */
stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1]; stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1];
stack[top-1] = SEXP_UNDEF; stack[top-1] = SEXP_UNDEF;
/* print_stack(stack, top); */
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]); /* fprintf(stderr, "closure-ref: %d => ", sexp_unbox_integer(((sexp*)ip)[0])); */
/* sexp_write(sexp_vector_ref(cp, ((sexp*)ip)[0]), cur_error_port); */
/* fprintf(stderr, "\n"); */
stack[top++]=sexp_vector_ref(cp, ((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_VECTOR_REF: case OP_VECTOR_REF:
@ -597,6 +629,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_VECTOR_SET: case OP_VECTOR_SET:
sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]); sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]);
stack[top-3]=SEXP_UNDEF; stack[top-3]=SEXP_UNDEF;
/* fprintf(stderr, "vector-set: %d => ", sexp_unbox_integer(stack[top-2])); */
/* sexp_write(stack[top-1], cur_error_port); */
/* fprintf(stderr, "\n"); */
top-=2; top-=2;
break; break;
case OP_STRING_REF: case OP_STRING_REF:
@ -745,6 +780,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top-1] = tmp1; stack[top-1] = tmp1;
/* print_stack(stack, top); */ /* print_stack(stack, top); */
/* exit(0); */ /* exit(0); */
/* sexp_debug("call proc: ", tmp1); */
/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */
/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
ip = bc->data; ip = bc->data;
cp = sexp_procedure_vars(tmp1); cp = sexp_procedure_vars(tmp1);
@ -788,6 +826,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top] = sexp_make_integer(ip+4); stack[top] = sexp_make_integer(ip+4);
stack[top+1] = cp; stack[top+1] = cp;
top+=2; top+=2;
/* sexp_debug("call proc: ", tmp1); */
/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */
/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
/* print_bytecode(bc); */ /* print_bytecode(bc); */
/* disasm(bc); */ /* disasm(bc); */

2
eval.h
View file

@ -76,7 +76,7 @@ enum core_form_names {
}; };
enum opcode_classes { enum opcode_classes {
OPC_GENERIC, OPC_GENERIC = 1,
OPC_TYPE_PREDICATE, OPC_TYPE_PREDICATE,
OPC_PREDICATE, OPC_PREDICATE,
OPC_ARITHMETIC, OPC_ARITHMETIC,

7
sexp.h
View file

@ -204,8 +204,15 @@ void sexp_printf(sexp port, sexp fmt, ...);
#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) #define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x)))
#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) #define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x)))
#define SEXP_CAAAR(x) (SEXP_CAR(SEXP_CAAR(x)))
#define SEXP_CAADR(x) (SEXP_CAR(SEXP_CADR(x)))
#define SEXP_CADAR(x) (SEXP_CAR(SEXP_CDAR(x)))
#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) #define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x)))
#define SEXP_CDAAR(x) (SEXP_CDR(SEXP_CAAR(x)))
#define SEXP_CDADR(x) (SEXP_CDR(SEXP_CADR(x)))
#define SEXP_CDDAR(x) (SEXP_CDR(SEXP_CDAR(x)))
#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) #define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x)))
#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) #define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x)))
#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) #define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x)))