diff --git a/debug.c b/debug.c index cded6223..dfab37f8 100644 --- a/debug.c +++ b/debug.c @@ -3,12 +3,13 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", - "CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", - "PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", - "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", - "JUMP_UNLESS", "JUMP", "RET", "DONE" - }; + {"NOOP", "CALL", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", + "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", + "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", + "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", + "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "CAR", "CDR", + "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", + "INV", "LT", "LE", "GT", "GE", "EQN", "EQ"}; void disasm (bytecode bc) { unsigned char *ip=bc->data, opcode; @@ -23,7 +24,6 @@ void disasm (bytecode bc) { case OP_STACK_REF: case OP_STACK_SET: case OP_CLOSURE_REF: - case OP_CLOSURE_SET: fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; diff --git a/eval.c b/eval.c index 8d39dedb..164984ab 100644 --- a/eval.c +++ b/eval.c @@ -20,17 +20,36 @@ static struct core_form core_forms[] = { static struct opcode opcodes[] = { #define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL} -_OP(OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0), -_OP(OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0), +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, "car",0), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, "set-car!",0), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr",0), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, "set-cdr!",0), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-ref",0), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-set!",0), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, "string-ref",0), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, "string-set!",0), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0), _OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV), _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, "<=", 0), +_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, ">", 0), +_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, ">=", 0), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, "=", 0), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, "eq?", 0), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0), +_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, "pair?", 0), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, "null?", 0), +_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, "string?", 0), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, "symbol?", 0), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, "char?", 0), +_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, "vector?", 0), +_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, "procedure?", 0), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, "eof-object?", 0), #undef _OP }; @@ -111,7 +130,7 @@ env make_standard_env() { void shrink_bcode(bytecode *bc, unsigned int i) { bytecode tmp; if ((*bc)->len != i) { - fprintf(stderr, "shrinking to %d\n", i); + /* fprintf(stderr, "shrinking to %d\n", i); */ tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i); tmp->tag = SEXP_BYTECODE; tmp->len = i; @@ -124,7 +143,7 @@ void shrink_bcode(bytecode *bc, unsigned int i) { void emit(bytecode *bc, unsigned int *i, char c) { bytecode tmp; if ((*bc)->len < (*i)+1) { - fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); + /* fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); */ tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); @@ -134,7 +153,7 @@ void emit(bytecode *bc, unsigned int *i, char c) { (*bc)->data[(*i)++] = c; } -void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { +void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { bytecode tmp; if ((*bc)->len < (*i)+4) { tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); @@ -147,7 +166,7 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { *i += sizeof(unsigned long); } -#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(unsigned long)obj)) +#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) sexp make_procedure(sexp bc, sexp vars) { sexp proc = SEXP_NEW(); @@ -167,26 +186,18 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp o1, o2, cell; if (SEXP_PAIRP(obj)) { - /* fprintf(stderr, ":: pair\n"); */ if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - fprintf(stderr, ":: symbol application\n"); o1 = env_cell(e, SEXP_CAR(obj)); - /* fprintf(stderr, ":: => %p\n", o1); */ if (! o1) errx(1, "unknown operator: %s", SEXP_CAR(obj)); o1 = SEXP_CDR(o1); - /* fprintf(stderr, ":: => %p\n", o1); */ if (SEXP_COREP(o1)) { - /* core form */ - fprintf(stderr, ":: core form\n"); switch (((core_form)o1)->code) { case CORE_LAMBDA: - fprintf(stderr, ":: lambda\n"); analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d); break; case CORE_DEFINE: - fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), @@ -197,17 +208,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); } emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) - ? SEXP_CAR(SEXP_CADR(obj)) - : SEXP_CADR(obj))); - emit(bc, i, OP_PUSH); + emit_word(bc, i, (sexp_uint_t) (SEXP_PAIRP(SEXP_CADR(obj)) + ? SEXP_CAR(SEXP_CADR(obj)) + : SEXP_CADR(obj))); + emit_push(bc, i, SEXP_UNDEF); (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); break; case CORE_SET: - fprintf(stderr, "set!: "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, " sv: "); write_sexp(stderr, sv); - fprintf(stderr, "\n"); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); @@ -219,38 +226,31 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } break; case CORE_IF: - fprintf(stderr, "test clause: %d\n", *i); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ tmp1 = *i; emit(bc, i, 0); - fprintf(stderr, "pass clause: %d\n", *i); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP); tmp2 = *i; emit(bc, i, 0); ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ - fprintf(stderr, "fail clause: %d\n", *i); if (SEXP_PAIRP(SEXP_CDDDR(obj))) { analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); } else { - emit(bc, i, OP_PUSH); + emit_push(bc, i, SEXP_UNDEF); (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); } ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ break; case CORE_QUOTE: - emit(bc, i, OP_PUSH); + emit_push(bc, i, SEXP_CADR(obj)); (*d)++; - emit_word(bc, i, (unsigned long)SEXP_CADR(obj)); break; default: errx(1, "unknown core form: %s", ((core_form)o1)->code); } } else if (SEXP_OPCODEP(o1)) { - fprintf(stderr, ":: opcode\n"); - /* direct opcode */ /* verify arity */ switch (((opcode)o1)->op_class) { case OPC_TYPE_PREDICATE: @@ -258,6 +258,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_ARITHMETIC: case OPC_ARITHMETIC_INV: case OPC_ARITHMETIC_CMP: + case OPC_CONSTRUCTOR: + case OPC_ACCESSOR: + case OPC_GENERIC: if (SEXP_NULLP(SEXP_CDR(obj))) { errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { @@ -268,12 +271,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, 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, fv, sv, d); } - fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name); (*d) -= length(SEXP_CDDR(obj)); } @@ -301,9 +302,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } else if (SEXP_SYMBOLP(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); } else { - fprintf(stderr, "push: %d\n", (unsigned long)obj); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long)obj); + emit_push(bc, i, obj); (*d)++; } } @@ -311,27 +310,27 @@ void analyze(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, sexp sv, unsigned int *d) { int tmp; - fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); - write_sexp(stderr, sv); - fprintf(stderr, "\n"); +/* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ +/* write_sexp(stderr, sv); */ +/* fprintf(stderr, "\n"); */ if ((tmp = list_index(params, obj)) >= 0) { - fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); + /* 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 if ((tmp = 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_word(bc, i, tmp); (*d)++; } else { - fprintf(stderr, "compiling global ref: %p\n", obj); + /* fprintf(stderr, "compiling global ref: %p\n", obj); */ emit(bc, i, OP_GLOBAL_REF); - emit_word(bc, i, (unsigned long) obj); + emit_word(bc, i, (sexp_uint_t) obj); (*d)++; } if (list_index(sv, obj) >= 0) { - fprintf(stderr, "mutable variables, fetching CAR\n"); + /* fprintf(stderr, "mutable variable, fetching CAR\n"); */ emit(bc, i, OP_CAR); } } @@ -351,7 +350,7 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, /* make the call */ emit(bc, i, OP_CALL); - emit_word(bc, i, (unsigned long) make_integer(len)); + emit_word(bc, i, (sexp_uint_t) make_integer(len)); } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { @@ -391,14 +390,11 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { formals = lset_diff(formals, SEXP_CADR(obj)); return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { - if ((list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { - fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, "\n"); - sv = cons(SEXP_CADR(obj), sv); - return set_vars(e, formals, SEXP_CADDR(obj), sv); - } + } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET + && (list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { + sv = cons(SEXP_CADR(obj), sv); + return set_vars(e, formals, SEXP_CADDR(obj), sv); } } } @@ -420,24 +416,20 @@ void analyze_lambda (sexp name, sexp formals, sexp body, write_sexp(stderr, fv2); fprintf(stderr, "\n"); obj = (sexp) compile(formals, body, e2, fv2, sv, 0); - 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(fv2))); + emit_push(bc, i, SEXP_UNDEF); + emit_push(bc, i, make_integer(length(fv2))); emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(k)); + emit_push(bc, i, make_integer(k)); emit(bc, i, OP_STACK_REF); emit_word(bc, i, 3); 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_push(bc, i, obj); emit(bc, i, OP_MAKE_PROCEDURE); } @@ -445,15 +437,14 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; - fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); + /* fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); */ bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; - fprintf(stderr, "analyzing\n"); + /* fprintf(stderr, "analyzing\n"); */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { - fprintf(stderr, "consing mutable var\n"); - emit(&bc, &i, OP_PUSH); - emit_word(&bc, &i, (unsigned long) SEXP_NULL); + /* fprintf(stderr, "consing mutable var\n"); */ + emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); emit_word(&bc, &i, j+4); emit(&bc, &i, OP_CONS); @@ -464,13 +455,12 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } sv = append(sv2, sv); for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); + /* fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); */ analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - fprintf(stderr, "done compiling:\n"); print_bytecode(bc); disasm(bc); return bc; @@ -491,42 +481,42 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "noop\n"); break; case OP_GLOBAL_REF: - fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* fprintf(stderr, "\n"); */ tmp = env_cell(e, ((sexp*)ip)[0]); stack[top++]=SEXP_CDR(tmp); ip += sizeof(sexp); break; case OP_GLOBAL_SET: - fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* fprintf(stderr, "\n"); */ env_define(e, ((sexp*)ip)[0], stack[--top]); ip += sizeof(sexp); break; case OP_STACK_REF: - fprintf(stderr, "stack ref: ip=%p, %d - %d => ", - ip, top, (unsigned long) ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */ +/* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ +/* fprintf(stderr, "\n"); */ stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_STACK_SET: - stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; + stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1]; stack[top-1] = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: - fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); - fprintf(stderr, "\n"); +/* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); */ +/* fprintf(stderr, "\n"); */ stack[top++]=vector_ref(cp,((sexp*)ip)[0]); ip += sizeof(sexp); break; @@ -535,13 +525,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_VECTOR_SET: - fprintf(stderr, "vector-set! %p %d => ", stack[top-1], unbox_integer(stack[top-2])); - write_sexp(stderr, stack[top-3]); - fprintf(stderr, "\n"); vector_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; top-=2; break; + case OP_STRING_REF: + stack[top-2]=string_ref(stack[top-1], stack[top-2]); + top--; + break; + case OP_STRING_SET: + string_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--; @@ -551,7 +547,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_PUSH: - /* fprintf(stderr, " (push)\n"); */ stack[top++]=((sexp*)ip)[0]; ip += sizeof(sexp); break; @@ -567,6 +562,33 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=stack[top-1]; stack[top-1]=tmp; break; + case OP_PAIRP: + stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_NULLP: + stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_CHARP: + stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_INTEGERP: + stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_SYMBOLP: + stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_STRINGP: + stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_VECTORP: + stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_PROCEDUREP: + stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_EOFP: + stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; + break; case OP_CAR: stack[top-1]=car(stack[top-1]); break; @@ -588,7 +610,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_ADD: - fprintf(stderr, "OP_ADD %d %d\n", stack[top-1], stack[top-2]); stack[top-2]=sexp_add(stack[top-1],stack[top-2]); top--; break; @@ -612,9 +633,26 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); top--; break; + case OP_LE: + stack[top-2]=((stack[top-2] <= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_GT: + stack[top-2]=((stack[top-2] > stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_GE: + stack[top-2]=((stack[top-2] >= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_EQ: + case OP_EQN: + stack[top-2]=((stack[top-2] == stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; case OP_CALL: - fprintf(stderr, "CALL\n"); - i = (unsigned long) ((sexp*)ip)[0]; + /* fprintf(stderr, "CALL\n"); */ + i = (sexp_uint_t) ((sexp*)ip)[0]; tmp = stack[top-1]; if (! SEXP_PROCEDUREP(tmp)) errx(2, "non-procedure application: %p", tmp); @@ -623,15 +661,15 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top+1] = cp; top+=2; bc = procedure_code(tmp); - print_bytecode(bc); - disasm(bc); + /* print_bytecode(bc); */ + /* disasm(bc); */ ip = bc->data; cp = procedure_vars(tmp); fprintf(stderr, "... calling procedure at %p\ncp: ", ip); write_sexp(stderr, cp); fprintf(stderr, "\n"); - fprintf(stderr, "stack at %d\n", top); - print_stack(stack, top); + /* fprintf(stderr, "stack at %d\n", top); */ + /* print_stack(stack, top); */ break; case OP_JUMP_UNLESS: fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); @@ -652,7 +690,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fflush(stderr); write_sexp(stderr, stack[top-1]); fprintf(stderr, "...\n"); - print_stack(stack, top); + /* print_stack(stack, top); */ /* top-1 */ /* stack: args ... n ip result */ cp = stack[top-2]; @@ -698,21 +736,38 @@ sexp eval(sexp obj, env e) { int main (int argc, char **argv) { sexp obj, res, *stack; env e; + int i, quit=0; sexp_init(); e = make_standard_env(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + quit=1; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + /* repl */ - fprintf(stdout, "> "); - fflush(stdout); - while ((obj = read_sexp(stdin)) != SEXP_EOF) { - write_sexp(stdout, obj); - fprintf(stdout, "\n => "); - res = eval_in_stack(obj, e, stack, 0); - write_sexp(stdout, res); - fprintf(stdout, "\n> "); + if (! quit) { + fprintf(stdout, "> "); fflush(stdout); + while ((obj = read_sexp(stdin)) != SEXP_EOF) { + /* write_sexp(stdout, obj); */ + res = eval_in_stack(obj, e, stack, 0); + if (res != SEXP_UNDEF) { + /* fprintf(stdout, "\n "); */ + write_sexp(stdout, res); + fprintf(stdout, "\n"); + } + fprintf(stdout, "> "); + fflush(stdout); + } } return 0; } diff --git a/eval.h b/eval.h index a1596c9d..df328ffc 100644 --- a/eval.h +++ b/eval.h @@ -66,42 +66,58 @@ enum opcode_classes { OPC_ARITHMETIC_INV, OPC_ARITHMETIC_CMP, OPC_CONSTRUCTOR, + OPC_ACCESSOR, }; enum opcode_names { - OP_NOOP, /* 0 */ - OP_STACK_REF, /* 1 */ - OP_STACK_SET, /* 2 */ - OP_GLOBAL_REF, /* 3 */ - OP_GLOBAL_SET, /* 4 */ - OP_CLOSURE_REF, /* 5 */ - OP_CLOSURE_SET, /* 6 */ - OP_VECTOR_REF, /* 7 */ - OP_VECTOR_SET, /* 8 */ + OP_NOOP, + OP_CALL, + OP_JUMP_UNLESS, + OP_JUMP, + OP_RET, + OP_DONE, + OP_STACK_REF, + OP_STACK_SET, + OP_GLOBAL_REF, + OP_GLOBAL_SET, + OP_CLOSURE_REF, + OP_VECTOR_REF, + OP_VECTOR_SET, + OP_STRING_REF, + OP_STRING_SET, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, OP_PUSH, - OP_DUP, /* C */ + OP_DUP, OP_DROP, OP_SWAP, + OP_PAIRP, + OP_NULLP, + OP_VECTORP, + OP_INTEGERP, + OP_SYMBOLP, + OP_STRINGP, + OP_CHARP, + OP_EOFP, + OP_PROCEDUREP, OP_CAR, - OP_CDR, /* 10 */ - OP_SET_CAR, /* 11 */ - OP_SET_CDR, /* 12 */ + OP_CDR, + OP_SET_CAR, + OP_SET_CDR, OP_CONS, - OP_ADD, /* 14 */ + OP_ADD, OP_SUB, - OP_MUL, /* 16 */ + OP_MUL, OP_DIV, - OP_MOD, /* 18 */ + OP_MOD, OP_NEG, - OP_INV, /* 1A */ + OP_INV, OP_LT, - OP_CALL, /* 1C */ - OP_JUMP_UNLESS, - OP_JUMP, /* 1E */ - OP_RET, - OP_DONE, + OP_LE, + OP_GT, + OP_GE, + OP_EQN, + OP_EQ, }; /**************************** prototypes ******************************/ diff --git a/sexp.c b/sexp.c index 8e4b5535..ff728452 100644 --- a/sexp.c +++ b/sexp.c @@ -23,11 +23,6 @@ static sexp the_quote_symbol; static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; static sexp the_unquote_splicing_symbol; -static sexp the_lambda_symbol; -static sexp the_begin_symbol; -static sexp the_define_symbol; -static sexp the_set_x_symbol; -static sexp the_if_symbol; static char separators[] = { /* 1 2 3 4 5 6 7 8 9 a b c d e f */ @@ -37,13 +32,11 @@ static char separators[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x6_ */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x7_ */ }; static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ - return 0tag = SEXP_FLONUM; + flonum_value(x) = f; + return x; +} + sexp make_string(char *str) { sexp s = SEXP_NEW(); if (! s) return SEXP_ERROR; @@ -233,7 +234,7 @@ int string_hash(char *str, int acc) { sexp intern(char *str) { struct huff_entry he; - unsigned long len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; + sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; char c, *mystr, *p=str; sexp sym, *newtable; @@ -245,7 +246,7 @@ sexp intern(char *str) { if ((space+newbits) > (sizeof(sexp)*8)) { goto normal_intern; } - res |= (((unsigned long) he.bits) << space); + res |= (((sexp_uint_t) he.bits) << space); space += newbits; } return (sexp) (res + SEXP_ISYMBOL_TAG); @@ -285,7 +286,7 @@ sexp intern(char *str) { sym->tag = SEXP_SYMBOL; sym->data1 = (void*) len; sym->data2 = (void*) mystr; - symbol_table[cell] = (sexp) (((unsigned long)sym) + 3); + symbol_table[cell] = (sexp) (((sexp_uint_t)sym) + 3); return symbol_table[cell]; } @@ -367,6 +368,9 @@ void write_sexp (FILE *out, sexp obj) { fprintf(out, ")"); } break; + case SEXP_FLONUM: + fprintf(out, "%g", flonum_value(obj)); + break; case SEXP_PROCEDURE: fprintf(out, "#"); break; @@ -396,8 +400,8 @@ void write_sexp (FILE *out, sexp obj) { } else if (SEXP_SYMBOLP(obj)) { #ifdef USE_HUFF_SYMS - if (((unsigned long)obj&7)==7) { - c = ((unsigned long)obj)>>3; + if (((sexp_uint_t)obj&7)==7) { + c = ((sexp_uint_t)obj)>>3; while (c) { #include "sexp-unhuff.c" putc(res, out); @@ -407,20 +411,20 @@ void write_sexp (FILE *out, sexp obj) { fprintf(out, "%s", symbol_data(obj)); } else { - switch ((unsigned long) obj) { - case (int) SEXP_NULL: + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: fprintf(out, "()"); break; - case (int) SEXP_TRUE: + case (sexp_uint_t) SEXP_TRUE: fprintf(out, "#t"); break; - case (int) SEXP_FALSE: + case (sexp_uint_t) SEXP_FALSE: fprintf(out, "#f"); break; - case (int) SEXP_EOF: + case (sexp_uint_t) SEXP_EOF: fprintf(out, "#"); break; - case (int) SEXP_UNDEF: + case (sexp_uint_t) SEXP_UNDEF: fprintf(out, "#"); break; default: @@ -488,10 +492,19 @@ char* read_symbol(FILE *in, int init) { return res; } -int read_number(FILE *in) { - int res = 0; - int negativep = 0; - char c; +sexp read_float_tail(FILE *in, long whole) { + double res = 0.0, scale=0.1; + int c; + for (c=fgetc(in); isdigit(c); c=fgetc(in), scale*=0.1) + res += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale; + ungetc(c, in); + return make_flonum(whole + res); +} + +sexp read_number(FILE *in, int base) { + sexp tmp; + long res = 0, negativep = 0; + int c; c = fgetc(in); if (c == '-') { @@ -500,12 +513,22 @@ int read_number(FILE *in) { res = c - '0'; } - for (c=fgetc(in); isdigit(c); c=fgetc(in)) { - res = res * 10 + (c - '0'); + for (c=fgetc(in); isxdigit(c); c=fgetc(in)) + res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10)); + if (c=='.') { + if (base != 10) { + fprintf(stderr, "decimal found in non-base 10"); + return SEXP_ERROR; + } + tmp = read_float_tail(in, res); + if (negativep && SEXP_FLONUMP(tmp)) + flonum_value(tmp) = -1 * flonum_value(tmp); + return tmp; + } else { + ungetc(c, in); } - ungetc(c, in); - return negativep ? -res : res; + return make_integer(negativep ? -res : res); } sexp read_sexp_raw (FILE *in) { @@ -581,10 +604,18 @@ sexp read_sexp_raw (FILE *in) { break; case '#': switch (c1=fgetc(in)) { -/* case 'b': */ -/* case 'd': */ -/* case 'o': */ -/* case 'x': */ + case 'b': + res = read_number(in, 2); + break; + case 'o': + res = read_number(in, 8); + break; + case 'd': + res = read_number(in, 10); + break; + case 'x': + res = read_number(in, 16); + break; /* case 'e': */ /* case 'i': */ case 'f': @@ -623,8 +654,7 @@ sexp read_sexp_raw (FILE *in) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { ungetc(c1,in ); - /* res = read_float_tail(in); */ - res = SEXP_ERROR; + res = read_float_tail(in, 0); } else { ungetc(c1, in); str = read_symbol(in, '.'); @@ -637,13 +667,12 @@ sexp read_sexp_raw (FILE *in) { break; case '+': case '-': - fprintf(stderr, "plus/minus: %c\n", c1); c2 = fgetc(in); if (c2 == '.' || isdigit(c2)) { ungetc(c2, in); - res = make_integer(read_number(in) * ((c1 == '-') ? -1 : 1)); + res = read_number(in, 10); + if (c1 == '-') res = sexp_mul(res, -1); } else { - fprintf(stderr, "... symbol: %c\n", c2); ungetc(c2, in); str = read_symbol(in, c1); res = intern(str); @@ -653,7 +682,7 @@ sexp read_sexp_raw (FILE *in) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': ungetc(c1, in); - res = make_integer(read_number(in)); + res = read_number(in, 10); break; default: str = read_symbol(in, c1); @@ -683,11 +712,6 @@ void sexp_init() { the_quasiquote_symbol = intern("quasiquote"); the_unquote_symbol = intern("unquote"); the_unquote_splicing_symbol = intern("unquote-splicing"); - the_lambda_symbol = intern("lambda"); - the_begin_symbol = intern("begin"); - the_define_symbol = intern("define"); - the_set_x_symbol = intern("set!"); - the_if_symbol = intern("if"); } } diff --git a/sexp.h b/sexp.h index e2b88fa4..174297f3 100644 --- a/sexp.h +++ b/sexp.h @@ -5,6 +5,7 @@ #ifndef SEXP_H #define SEXP_H +#include #include #include #include @@ -67,6 +68,8 @@ enum sexp_types { SEXP_SYMBOL, SEXP_STRING, SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_ENV, @@ -81,6 +84,9 @@ typedef struct sexp_struct { void *data2; } *sexp; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; + #define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) #define SEXP_NULL MAKE_IMMEDIATE(0) #define SEXP_FALSE MAKE_IMMEDIATE(1) @@ -92,16 +98,17 @@ typedef struct sexp_struct { #define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ #define SEXP_NULLP(x) ((x) == SEXP_NULL) -#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) -#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) -#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) -#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define SEXP_INTEGERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define SEXP_ISYMBOLP(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define SEXP_CHARP(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) #define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) #define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) #define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) #define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) #define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) +#define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) #define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) #define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) @@ -111,7 +118,7 @@ typedef struct sexp_struct { #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) #ifdef USE_HUFF_SYMS -#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<>SEXP_EXTENDED_BITS) -#define vector_length(x) ((unsigned long) x->data1) +#define flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) + +#define vector_length(x) ((sexp_uint_t) x->data1) #define vector_data(x) ((sexp*) x->data2) #define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) @@ -130,18 +139,21 @@ typedef struct sexp_struct { #define procedure_code(x) ((bytecode) ((sexp)x)->data1) #define procedure_vars(x) ((sexp) ((sexp)x)->data2) -#define string_length(x) ((unsigned long) x->data1) +#define string_length(x) ((sexp_uint_t) x->data1) #define string_data(x) ((char*) x->data2) -#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) -#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) +#define string_ref(x, i) (make_character(string_data(x)[unbox_integer(i)])) +#define string_set(x, i, v) (string_data(x)[unbox_integer(i)] = unbox_character(v)) + +#define symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) +#define symbol_length(x) ((sexp_uint_t) (symbol_pointer(x)->data1)) #define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) -#define sexp_add(a, b) ((sexp)(((unsigned long)a)+((unsigned long)b)-SEXP_FIXNUM_TAG)) -#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) -#define sexp_mul(a, b) ((sexp)((((((unsigned long)a)-SEXP_FIXNUM_TAG)*(((unsigned long)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_div(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)/(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<