Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 23:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial float support, more opcodes

Browse source
This commit is contained in:
Alex Shinn 2009-03-04 02:16:01 +09:00
parent abecbd70f0
commit eafc5f2136
5 changed files with 300 additions and 192 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
debug.c
View file

@ -3,12 +3,13 @@
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
static const char* reverse_opcode_names[] = static const char* reverse_opcode_names[] =
{"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", {"NOOP", "CALL", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF",
"CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF",
"PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR",
"ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP",
"JUMP_UNLESS", "JUMP", "RET", "DONE" "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) { void disasm (bytecode bc) {
unsigned char *ip=bc->data, opcode; unsigned char *ip=bc->data, opcode;
@ -23,7 +24,6 @@ void disasm (bytecode bc) {
case OP_STACK_REF: case OP_STACK_REF:
case OP_STACK_SET: case OP_STACK_SET:
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
case OP_CLOSURE_SET:
fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); fprintf(stderr, "%d", (long) ((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;

267
eval.c
View file

@ -20,17 +20,36 @@ static struct core_form core_forms[] = {
static struct opcode opcodes[] = { 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} #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_ACCESSOR, 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_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, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0),
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG), _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, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0),
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV), _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, 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_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_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_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0),
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 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 #undef _OP
}; };
@ -111,7 +130,7 @@ env make_standard_env() {
void shrink_bcode(bytecode *bc, unsigned int i) { void shrink_bcode(bytecode *bc, unsigned int i) {
bytecode tmp; bytecode tmp;
if ((*bc)->len != i) { 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 = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i);
tmp->tag = SEXP_BYTECODE; tmp->tag = SEXP_BYTECODE;
tmp->len = i; tmp->len = i;
@ -124,7 +143,7 @@ void shrink_bcode(bytecode *bc, unsigned int i) {
void emit(bytecode *bc, unsigned int *i, char c) { void emit(bytecode *bc, unsigned int *i, char c) {
bytecode tmp; bytecode tmp;
if ((*bc)->len < (*i)+1) { 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 = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2);
tmp->len = (*bc)->len*2; tmp->len = (*bc)->len*2;
memcpy(tmp->data, (*bc)->data, (*bc)->len); memcpy(tmp->data, (*bc)->data, (*bc)->len);
@ -134,7 +153,7 @@ void emit(bytecode *bc, unsigned int *i, char c) {
(*bc)->data[(*i)++] = 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; bytecode tmp;
if ((*bc)->len < (*i)+4) { if ((*bc)->len < (*i)+4) {
tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); 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); *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 make_procedure(sexp bc, sexp vars) {
sexp proc = SEXP_NEW(); sexp proc = SEXP_NEW();
@ -167,26 +186,18 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
sexp o1, o2, cell; sexp o1, o2, cell;
if (SEXP_PAIRP(obj)) { if (SEXP_PAIRP(obj)) {
/* fprintf(stderr, ":: pair\n"); */
if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) {
fprintf(stderr, ":: symbol application\n");
o1 = env_cell(e, SEXP_CAR(obj)); o1 = env_cell(e, SEXP_CAR(obj));
/* fprintf(stderr, ":: => %p\n", o1); */
if (! o1) if (! o1)
errx(1, "unknown operator: %s", SEXP_CAR(obj)); errx(1, "unknown operator: %s", SEXP_CAR(obj));
o1 = SEXP_CDR(o1); o1 = SEXP_CDR(o1);
/* fprintf(stderr, ":: => %p\n", o1); */
if (SEXP_COREP(o1)) { if (SEXP_COREP(o1)) {
/* core form */
fprintf(stderr, ":: core form\n");
switch (((core_form)o1)->code) { switch (((core_form)o1)->code) {
case CORE_LAMBDA: case CORE_LAMBDA:
fprintf(stderr, ":: lambda\n");
analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj),
bc, i, e, params, fv, sv, d); bc, i, e, params, fv, sv, d);
break; break;
case CORE_DEFINE: case CORE_DEFINE:
fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj));
if ((((core_form)o1)->code == CORE_DEFINE) if ((((core_form)o1)->code == CORE_DEFINE)
&& SEXP_PAIRP(SEXP_CADR(obj))) { && SEXP_PAIRP(SEXP_CADR(obj))) {
analyze_lambda(SEXP_CAR(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); 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, (sexp_uint_t) (SEXP_PAIRP(SEXP_CADR(obj))
? SEXP_CAR(SEXP_CADR(obj)) ? SEXP_CAR(SEXP_CADR(obj))
: SEXP_CADR(obj))); : SEXP_CADR(obj)));
emit(bc, i, OP_PUSH); emit_push(bc, i, SEXP_UNDEF);
(*d)++; (*d)++;
emit_word(bc, i, (unsigned long) SEXP_UNDEF);
break; break;
case CORE_SET: 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(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d);
analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d);
emit(bc, i, OP_SET_CAR); emit(bc, i, OP_SET_CAR);
@ -219,38 +226,31 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
} }
break; break;
case CORE_IF: case CORE_IF:
fprintf(stderr, "test clause: %d\n", *i);
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, 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);
analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, 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);
if (SEXP_PAIRP(SEXP_CDDDR(obj))) { if (SEXP_PAIRP(SEXP_CDDDR(obj))) {
analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d);
} else { } else {
emit(bc, i, OP_PUSH); emit_push(bc, i, SEXP_UNDEF);
(*d)++; (*d)++;
emit_word(bc, i, (unsigned long) SEXP_UNDEF);
} }
((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */
break; break;
case CORE_QUOTE: case CORE_QUOTE:
emit(bc, i, OP_PUSH); emit_push(bc, i, SEXP_CADR(obj));
(*d)++; (*d)++;
emit_word(bc, i, (unsigned long)SEXP_CADR(obj));
break; break;
default: default:
errx(1, "unknown core form: %s", ((core_form)o1)->code); errx(1, "unknown core form: %s", ((core_form)o1)->code);
} }
} else if (SEXP_OPCODEP(o1)) { } else if (SEXP_OPCODEP(o1)) {
fprintf(stderr, ":: opcode\n");
/* direct opcode */
/* verify arity */ /* verify arity */
switch (((opcode)o1)->op_class) { switch (((opcode)o1)->op_class) {
case OPC_TYPE_PREDICATE: 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:
case OPC_ARITHMETIC_INV: case OPC_ARITHMETIC_INV:
case OPC_ARITHMETIC_CMP: case OPC_ARITHMETIC_CMP:
case OPC_CONSTRUCTOR:
case OPC_ACCESSOR:
case OPC_GENERIC:
if (SEXP_NULLP(SEXP_CDR(obj))) { if (SEXP_NULLP(SEXP_CDR(obj))) {
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))) {
@ -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); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
} }
} else { } else {
/* 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, sv, d); 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); emit(bc, i, ((opcode)o1)->op_name);
(*d) -= length(SEXP_CDDR(obj)); (*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)) { } else if (SEXP_SYMBOLP(obj)) {
analyze_var_ref(obj, bc, i, e, params, fv, sv, d); analyze_var_ref(obj, bc, i, e, params, fv, sv, d);
} else { } else {
fprintf(stderr, "push: %d\n", (unsigned long)obj); emit_push(bc, i, obj);
emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long)obj);
(*d)++; (*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, void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, sexp sv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
int tmp; int tmp;
fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); /* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */
write_sexp(stderr, sv); /* write_sexp(stderr, sv); */
fprintf(stderr, "\n"); /* fprintf(stderr, "\n"); */
if ((tmp = list_index(params, obj)) >= 0) { 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(bc, i, OP_STACK_REF);
emit_word(bc, i, tmp + *d + 4); emit_word(bc, i, tmp + *d + 4);
(*d)++; (*d)++;
} else if ((tmp = list_index(fv, obj)) >= 0) { } 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(bc, i, OP_CLOSURE_REF);
emit_word(bc, i, tmp); emit_word(bc, i, tmp);
(*d)++; (*d)++;
} 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);
emit_word(bc, i, (unsigned long) obj); emit_word(bc, i, (sexp_uint_t) obj);
(*d)++; (*d)++;
} }
if (list_index(sv, obj) >= 0) { 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); emit(bc, i, OP_CAR);
} }
} }
@ -351,7 +350,7 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
/* make the call */ /* make the call */
emit(bc, i, OP_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) { 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) { if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) {
formals = lset_diff(formals, SEXP_CADR(obj)); formals = lset_diff(formals, SEXP_CADR(obj));
return set_vars(e, formals, SEXP_CADDR(obj), sv); return set_vars(e, formals, SEXP_CADDR(obj), sv);
} else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET
if ((list_index(formals, SEXP_CADR(obj)) >= 0) && (list_index(formals, SEXP_CADR(obj)) >= 0)
&& ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) {
fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); sv = cons(SEXP_CADR(obj), sv);
fprintf(stderr, "\n"); return set_vars(e, formals, SEXP_CADDR(obj), sv);
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); write_sexp(stderr, fv2);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
obj = (sexp) compile(formals, body, e2, fv2, sv, 0); obj = (sexp) compile(formals, body, e2, fv2, sv, 0);
emit(bc, i, OP_PUSH); emit_push(bc, i, SEXP_UNDEF);
emit_word(bc, i, (unsigned long) SEXP_UNDEF); emit_push(bc, i, make_integer(length(fv2)));
emit(bc, i, OP_PUSH);
emit_word(bc, i, (unsigned long) make_integer(length(fv2)));
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, SEXP_NULL, d); analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d);
emit(bc, i, OP_PUSH); emit_push(bc, i, make_integer(k));
emit_word(bc, i, (unsigned long) make_integer(k));
emit(bc, i, OP_STACK_REF); emit(bc, i, OP_STACK_REF);
emit_word(bc, i, 3); emit_word(bc, i, 3);
emit(bc, i, OP_VECTOR_SET); emit(bc, i, OP_VECTOR_SET);
emit(bc, i, OP_DROP); emit(bc, i, OP_DROP);
(*d)--; (*d)--;
} }
emit(bc, i, OP_PUSH); emit_push(bc, i, obj);
emit_word(bc, i, (unsigned long) obj);
emit(bc, i, OP_MAKE_PROCEDURE); 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; unsigned int i = 0, j, d = 0;
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), ls; 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->tag = SEXP_BYTECODE;
bc->len = INIT_BCODE_SIZE; bc->len = INIT_BCODE_SIZE;
fprintf(stderr, "analyzing\n"); /* fprintf(stderr, "analyzing\n"); */
for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) {
if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) {
fprintf(stderr, "consing mutable var\n"); /* fprintf(stderr, "consing mutable var\n"); */
emit(&bc, &i, OP_PUSH); emit_push(&bc, &i, SEXP_NULL);
emit_word(&bc, &i, (unsigned long) SEXP_NULL);
emit(&bc, &i, OP_STACK_REF); emit(&bc, &i, OP_STACK_REF);
emit_word(&bc, &i, j+4); emit_word(&bc, &i, j+4);
emit(&bc, &i, OP_CONS); 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); sv = append(sv2, sv);
for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { 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); analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d);
if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); if (SEXP_PAIRP(SEXP_CDR(obj))) 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);
fprintf(stderr, "done compiling:\n");
print_bytecode(bc); print_bytecode(bc);
disasm(bc); disasm(bc);
return bc; return bc;
@ -491,42 +481,42 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
fprintf(stderr, "noop\n"); fprintf(stderr, "noop\n");
break; break;
case OP_GLOBAL_REF: case OP_GLOBAL_REF:
fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); /* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */
fflush(stderr); /* fflush(stderr); */
write_sexp(stderr, ((sexp*)ip)[0]); /* write_sexp(stderr, ((sexp*)ip)[0]); */
fprintf(stderr, "\n"); /* fprintf(stderr, "\n"); */
tmp = env_cell(e, ((sexp*)ip)[0]); tmp = env_cell(e, ((sexp*)ip)[0]);
stack[top++]=SEXP_CDR(tmp); stack[top++]=SEXP_CDR(tmp);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_GLOBAL_SET: case OP_GLOBAL_SET:
fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); /* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */
fflush(stderr); /* fflush(stderr); */
write_sexp(stderr, ((sexp*)ip)[0]); /* write_sexp(stderr, ((sexp*)ip)[0]); */
fprintf(stderr, "\n"); /* fprintf(stderr, "\n"); */
env_define(e, ((sexp*)ip)[0], stack[--top]); env_define(e, ((sexp*)ip)[0], stack[--top]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_STACK_REF: case OP_STACK_REF:
fprintf(stderr, "stack ref: ip=%p, %d - %d => ", /* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */
ip, top, (unsigned long) ((sexp*)ip)[0]); /* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */
fflush(stderr); /* fflush(stderr); */
write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); /* write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */
fprintf(stderr, "\n"); /* fprintf(stderr, "\n"); */
stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]];
ip += sizeof(sexp); ip += sizeof(sexp);
top++; top++;
break; break;
case OP_STACK_SET: 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; stack[top-1] = SEXP_UNDEF;
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); /* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */
fflush(stderr); /* fflush(stderr); */
write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); /* write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); */
fprintf(stderr, "\n"); /* fprintf(stderr, "\n"); */
stack[top++]=vector_ref(cp,((sexp*)ip)[0]); stack[top++]=vector_ref(cp,((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
@ -535,13 +525,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top--; top--;
break; break;
case OP_VECTOR_SET: 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]); vector_set(stack[top-1], stack[top-2], stack[top-3]);
stack[top-3]=SEXP_UNDEF; stack[top-3]=SEXP_UNDEF;
top-=2; top-=2;
break; 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: case OP_MAKE_PROCEDURE:
stack[top-2]=make_procedure(stack[top-1], stack[top-2]); stack[top-2]=make_procedure(stack[top-1], stack[top-2]);
top--; top--;
@ -551,7 +547,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top--; top--;
break; break;
case OP_PUSH: case OP_PUSH:
/* fprintf(stderr, " (push)\n"); */
stack[top++]=((sexp*)ip)[0]; stack[top++]=((sexp*)ip)[0];
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
@ -567,6 +562,33 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top-2]=stack[top-1]; stack[top-2]=stack[top-1];
stack[top-1]=tmp; stack[top-1]=tmp;
break; 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: case OP_CAR:
stack[top-1]=car(stack[top-1]); stack[top-1]=car(stack[top-1]);
break; break;
@ -588,7 +610,6 @@ 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", stack[top-1], stack[top-2]);
stack[top-2]=sexp_add(stack[top-1],stack[top-2]); stack[top-2]=sexp_add(stack[top-1],stack[top-2]);
top--; top--;
break; 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); stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE);
top--; top--;
break; 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: case OP_CALL:
fprintf(stderr, "CALL\n"); /* fprintf(stderr, "CALL\n"); */
i = (unsigned long) ((sexp*)ip)[0]; i = (sexp_uint_t) ((sexp*)ip)[0];
tmp = stack[top-1]; tmp = stack[top-1];
if (! SEXP_PROCEDUREP(tmp)) if (! SEXP_PROCEDUREP(tmp))
errx(2, "non-procedure application: %p", 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; stack[top+1] = cp;
top+=2; top+=2;
bc = procedure_code(tmp); bc = procedure_code(tmp);
print_bytecode(bc); /* print_bytecode(bc); */
disasm(bc); /* disasm(bc); */
ip = bc->data; ip = bc->data;
cp = procedure_vars(tmp); cp = procedure_vars(tmp);
fprintf(stderr, "... calling procedure at %p\ncp: ", ip); fprintf(stderr, "... calling procedure at %p\ncp: ", ip);
write_sexp(stderr, cp); write_sexp(stderr, cp);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
fprintf(stderr, "stack at %d\n", top); /* fprintf(stderr, "stack at %d\n", top); */
print_stack(stack, top); /* print_stack(stack, top); */
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); 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); fflush(stderr);
write_sexp(stderr, stack[top-1]); write_sexp(stderr, stack[top-1]);
fprintf(stderr, "...\n"); fprintf(stderr, "...\n");
print_stack(stack, top); /* print_stack(stack, top); */
/* top-1 */ /* top-1 */
/* stack: args ... n ip result */ /* stack: args ... n ip result */
cp = stack[top-2]; cp = stack[top-2];
@ -698,21 +736,38 @@ sexp eval(sexp obj, env e) {
int main (int argc, char **argv) { int main (int argc, char **argv) {
sexp obj, res, *stack; sexp obj, res, *stack;
env e; env e;
int i, quit=0;
sexp_init(); sexp_init();
e = make_standard_env(); e = make_standard_env();
stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); 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 */ /* repl */
fprintf(stdout, "> "); if (! quit) {
fflush(stdout); fprintf(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> ");
fflush(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; return 0;
} }

60
eval.h
View file

@ -66,42 +66,58 @@ enum opcode_classes {
OPC_ARITHMETIC_INV, OPC_ARITHMETIC_INV,
OPC_ARITHMETIC_CMP, OPC_ARITHMETIC_CMP,
OPC_CONSTRUCTOR, OPC_CONSTRUCTOR,
OPC_ACCESSOR,
}; };
enum opcode_names { enum opcode_names {
OP_NOOP, /* 0 */ OP_NOOP,
OP_STACK_REF, /* 1 */ OP_CALL,
OP_STACK_SET, /* 2 */ OP_JUMP_UNLESS,
OP_GLOBAL_REF, /* 3 */ OP_JUMP,
OP_GLOBAL_SET, /* 4 */ OP_RET,
OP_CLOSURE_REF, /* 5 */ OP_DONE,
OP_CLOSURE_SET, /* 6 */ OP_STACK_REF,
OP_VECTOR_REF, /* 7 */ OP_STACK_SET,
OP_VECTOR_SET, /* 8 */ 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_PROCEDURE,
OP_MAKE_VECTOR, OP_MAKE_VECTOR,
OP_PUSH, OP_PUSH,
OP_DUP, /* C */ OP_DUP,
OP_DROP, OP_DROP,
OP_SWAP, OP_SWAP,
OP_PAIRP,
OP_NULLP,
OP_VECTORP,
OP_INTEGERP,
OP_SYMBOLP,
OP_STRINGP,
OP_CHARP,
OP_EOFP,
OP_PROCEDUREP,
OP_CAR, OP_CAR,
OP_CDR, /* 10 */ OP_CDR,
OP_SET_CAR, /* 11 */ OP_SET_CAR,
OP_SET_CDR, /* 12 */ OP_SET_CDR,
OP_CONS, OP_CONS,
OP_ADD, /* 14 */ OP_ADD,
OP_SUB, OP_SUB,
OP_MUL, /* 16 */ OP_MUL,
OP_DIV, OP_DIV,
OP_MOD, /* 18 */ OP_MOD,
OP_NEG, OP_NEG,
OP_INV, /* 1A */ OP_INV,
OP_LT, OP_LT,
OP_CALL, /* 1C */ OP_LE,
OP_JUMP_UNLESS, OP_GT,
OP_JUMP, /* 1E */ OP_GE,
OP_RET, OP_EQN,
OP_DONE, OP_EQ,
}; };
/**************************** prototypes ******************************/ /**************************** prototypes ******************************/

108
sexp.c
View file

@ -23,11 +23,6 @@ static sexp the_quote_symbol;
static sexp the_quasiquote_symbol; static sexp the_quasiquote_symbol;
static sexp the_unquote_symbol; static sexp the_unquote_symbol;
static sexp the_unquote_splicing_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[] = { static char separators[] = {
/* 1 2 3 4 5 6 7 8 9 a b c d e f */ /* 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, 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, 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, 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) { static int is_separator(int c) {
/* return (!((c-9)&(~3))) | (~(c^4)); */ /* return (!((c-9)&(~3))) | (~(c^4)); */
return 0<c && c<128 && separators[c]; return 0<c && c<0x60 && separators[c];
} }
static sexp* symbol_table = NULL; static sexp* symbol_table = NULL;
@ -210,6 +203,14 @@ unsigned long length(sexp ls) {
/********************* strings, symbols, vectors **********************/ /********************* strings, symbols, vectors **********************/
sexp make_flonum(double f) {
sexp x = SEXP_NEW();
if (! x) return SEXP_ERROR;
x->tag = SEXP_FLONUM;
flonum_value(x) = f;
return x;
}
sexp make_string(char *str) { sexp make_string(char *str) {
sexp s = SEXP_NEW(); sexp s = SEXP_NEW();
if (! s) return SEXP_ERROR; if (! s) return SEXP_ERROR;
@ -233,7 +234,7 @@ int string_hash(char *str, int acc) {
sexp intern(char *str) { sexp intern(char *str) {
struct huff_entry he; 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; char c, *mystr, *p=str;
sexp sym, *newtable; sexp sym, *newtable;
@ -245,7 +246,7 @@ sexp intern(char *str) {
if ((space+newbits) > (sizeof(sexp)*8)) { if ((space+newbits) > (sizeof(sexp)*8)) {
goto normal_intern; goto normal_intern;
} }
res |= (((unsigned long) he.bits) << space); res |= (((sexp_uint_t) he.bits) << space);
space += newbits; space += newbits;
} }
return (sexp) (res + SEXP_ISYMBOL_TAG); return (sexp) (res + SEXP_ISYMBOL_TAG);
@ -285,7 +286,7 @@ sexp intern(char *str) {
sym->tag = SEXP_SYMBOL; sym->tag = SEXP_SYMBOL;
sym->data1 = (void*) len; sym->data1 = (void*) len;
sym->data2 = (void*) mystr; 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]; return symbol_table[cell];
} }
@ -367,6 +368,9 @@ void write_sexp (FILE *out, sexp obj) {
fprintf(out, ")"); fprintf(out, ")");
} }
break; break;
case SEXP_FLONUM:
fprintf(out, "%g", flonum_value(obj));
break;
case SEXP_PROCEDURE: case SEXP_PROCEDURE:
fprintf(out, "#<procedure>"); fprintf(out, "#<procedure>");
break; break;
@ -396,8 +400,8 @@ void write_sexp (FILE *out, sexp obj) {
} else if (SEXP_SYMBOLP(obj)) { } else if (SEXP_SYMBOLP(obj)) {
#ifdef USE_HUFF_SYMS #ifdef USE_HUFF_SYMS
if (((unsigned long)obj&7)==7) { if (((sexp_uint_t)obj&7)==7) {
c = ((unsigned long)obj)>>3; c = ((sexp_uint_t)obj)>>3;
while (c) { while (c) {
#include "sexp-unhuff.c" #include "sexp-unhuff.c"
putc(res, out); putc(res, out);
@ -407,20 +411,20 @@ void write_sexp (FILE *out, sexp obj) {
fprintf(out, "%s", symbol_data(obj)); fprintf(out, "%s", symbol_data(obj));
} else { } else {
switch ((unsigned long) obj) { switch ((sexp_uint_t) obj) {
case (int) SEXP_NULL: case (sexp_uint_t) SEXP_NULL:
fprintf(out, "()"); fprintf(out, "()");
break; break;
case (int) SEXP_TRUE: case (sexp_uint_t) SEXP_TRUE:
fprintf(out, "#t"); fprintf(out, "#t");
break; break;
case (int) SEXP_FALSE: case (sexp_uint_t) SEXP_FALSE:
fprintf(out, "#f"); fprintf(out, "#f");
break; break;
case (int) SEXP_EOF: case (sexp_uint_t) SEXP_EOF:
fprintf(out, "#<eof>"); fprintf(out, "#<eof>");
break; break;
case (int) SEXP_UNDEF: case (sexp_uint_t) SEXP_UNDEF:
fprintf(out, "#<undef>"); fprintf(out, "#<undef>");
break; break;
default: default:
@ -488,10 +492,19 @@ char* read_symbol(FILE *in, int init) {
return res; return res;
} }
int read_number(FILE *in) { sexp read_float_tail(FILE *in, long whole) {
int res = 0; double res = 0.0, scale=0.1;
int negativep = 0; int c;
char 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); c = fgetc(in);
if (c == '-') { if (c == '-') {
@ -500,12 +513,22 @@ int read_number(FILE *in) {
res = c - '0'; res = c - '0';
} }
for (c=fgetc(in); isdigit(c); c=fgetc(in)) { for (c=fgetc(in); isxdigit(c); c=fgetc(in))
res = res * 10 + (c - '0'); 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) { sexp read_sexp_raw (FILE *in) {
@ -581,10 +604,18 @@ sexp read_sexp_raw (FILE *in) {
break; break;
case '#': case '#':
switch (c1=fgetc(in)) { switch (c1=fgetc(in)) {
/* case 'b': */ case 'b':
/* case 'd': */ res = read_number(in, 2);
/* case 'o': */ break;
/* case 'x': */ 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 'e': */
/* case 'i': */ /* case 'i': */
case 'f': case 'f':
@ -623,8 +654,7 @@ sexp read_sexp_raw (FILE *in) {
res = SEXP_RAWDOT; res = SEXP_RAWDOT;
} else if (isdigit(c1)) { } else if (isdigit(c1)) {
ungetc(c1,in ); ungetc(c1,in );
/* res = read_float_tail(in); */ res = read_float_tail(in, 0);
res = SEXP_ERROR;
} else { } else {
ungetc(c1, in); ungetc(c1, in);
str = read_symbol(in, '.'); str = read_symbol(in, '.');
@ -637,13 +667,12 @@ sexp read_sexp_raw (FILE *in) {
break; break;
case '+': case '+':
case '-': case '-':
fprintf(stderr, "plus/minus: %c\n", c1);
c2 = fgetc(in); c2 = fgetc(in);
if (c2 == '.' || isdigit(c2)) { if (c2 == '.' || isdigit(c2)) {
ungetc(c2, in); 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 { } else {
fprintf(stderr, "... symbol: %c\n", c2);
ungetc(c2, in); ungetc(c2, in);
str = read_symbol(in, c1); str = read_symbol(in, c1);
res = intern(str); res = intern(str);
@ -653,7 +682,7 @@ sexp read_sexp_raw (FILE *in) {
case '0': case '1': case '2': case '3': case '4': case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '5': case '6': case '7': case '8': case '9':
ungetc(c1, in); ungetc(c1, in);
res = make_integer(read_number(in)); res = read_number(in, 10);
break; break;
default: default:
str = read_symbol(in, c1); str = read_symbol(in, c1);
@ -683,11 +712,6 @@ void sexp_init() {
the_quasiquote_symbol = intern("quasiquote"); the_quasiquote_symbol = intern("quasiquote");
the_unquote_symbol = intern("unquote"); the_unquote_symbol = intern("unquote");
the_unquote_splicing_symbol = intern("unquote-splicing"); 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");
} }
} }

43
sexp.h
View file

@ -5,6 +5,7 @@
#ifndef SEXP_H #ifndef SEXP_H
#define SEXP_H #define SEXP_H
#include <ctype.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
@ -67,6 +68,8 @@ enum sexp_types {
SEXP_SYMBOL, SEXP_SYMBOL,
SEXP_STRING, SEXP_STRING,
SEXP_VECTOR, SEXP_VECTOR,
SEXP_FLONUM,
SEXP_BIGNUM,
/* the following are used only by the evaluator */ /* the following are used only by the evaluator */
SEXP_PROCEDURE, SEXP_PROCEDURE,
SEXP_ENV, SEXP_ENV,
@ -81,6 +84,9 @@ typedef struct sexp_struct {
void *data2; void *data2;
} *sexp; } *sexp;
typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t;
#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) #define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14))
#define SEXP_NULL MAKE_IMMEDIATE(0) #define SEXP_NULL MAKE_IMMEDIATE(0)
#define SEXP_FALSE MAKE_IMMEDIATE(1) #define SEXP_FALSE MAKE_IMMEDIATE(1)
@ -92,16 +98,17 @@ typedef struct sexp_struct {
#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ #define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */
#define SEXP_NULLP(x) ((x) == SEXP_NULL) #define SEXP_NULLP(x) ((x) == SEXP_NULL)
#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) #define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) #define SEXP_INTEGERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG)
#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) #define SEXP_ISYMBOLP(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG)
#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_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_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) #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_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING)
#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) #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_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_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE)
#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV)
#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) #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)) #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x))
#ifdef USE_HUFF_SYMS #ifdef USE_HUFF_SYMS
#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<<SEXP_IMMEDIATE_BITS)+SEXP_ISYMBOL_TAG)) #define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<<SEXP_IMMEDIATE_BITS)+SEXP_ISYMBOL_TAG))
#else #else
#define SEXP_DOTP(x) ((x)==the_dot_symbol) #define SEXP_DOTP(x) ((x)==the_dot_symbol)
#endif #endif
@ -121,7 +128,9 @@ typedef struct sexp_struct {
#define make_character(n) ((sexp) (((long) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG)) #define make_character(n) ((sexp) (((long) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
#define unbox_character(n) ((long) n>>SEXP_EXTENDED_BITS) #define unbox_character(n) ((long) n>>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_data(x) ((sexp*) x->data2)
#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) #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_code(x) ((bytecode) ((sexp)x)->data1)
#define procedure_vars(x) ((sexp) ((sexp)x)->data2) #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 string_data(x) ((char*) x->data2)
#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) #define string_ref(x, i) (make_character(string_data(x)[unbox_integer(i)]))
#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) #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 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_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) #define sexp_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)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_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)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)+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_FIXNUM_TAG)
#define sexp_mod(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG) #define sexp_mod(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG)
#define list2(a, b) cons(a, cons(b, SEXP_NULL)) #define list2(a, b) cons(a, cons(b, SEXP_NULL))
#define list3(a, b, c) cons(a, cons(b, cons(c, SEXP_NULL))) #define list3(a, b, c) cons(a, cons(b, cons(c, SEXP_NULL)))
@ -177,6 +189,7 @@ sexp memq(sexp x, sexp ls);
sexp assq (sexp x, sexp ls); sexp assq (sexp x, sexp ls);
unsigned long length(sexp ls); unsigned long length(sexp ls);
sexp make_string(char *str); sexp make_string(char *str);
sexp make_flonum(double f);
int string_hash(char *str, int acc); int string_hash(char *str, int acc);
sexp intern(char *str); sexp intern(char *str);
sexp make_vector(unsigned long len, sexp dflt); sexp make_vector(unsigned long len, sexp dflt);
@ -186,7 +199,7 @@ void write_sexp(FILE *out, sexp obj);
void free_sexp(sexp obj); void free_sexp(sexp obj);
char* read_string(FILE *in); char* read_string(FILE *in);
char* read_symbol(FILE *in, int init); char* read_symbol(FILE *in, int init);
int read_number(FILE *in); sexp read_number(FILE *in, int base);
sexp read_sexp_raw(FILE *in); sexp read_sexp_raw(FILE *in);
sexp read_sexp(FILE *in); sexp read_sexp(FILE *in);
void sexp_init(); void sexp_init();