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

cleaning up types - using a single union for all heap allocated types

Browse source
This commit is contained in:
Alex Shinn 2009-03-15 20:59:35 +09:00
parent 4bc491c946
commit caa9a104dd
6 changed files with 401 additions and 335 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -30,7 +30,7 @@ cleaner: clean
rm -rf *.dSYM rm -rf *.dSYM
test: chibi-scheme test: chibi-scheme
for f in tests/*.scm; do \ @for f in tests/*.scm; do \
./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
if diff -q $${f%.scm}.out $${f%.scm}.res; then \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \
echo "[PASS] $${f%.scm}"; \ echo "[PASS] $${f%.scm}"; \

27
debug.c
View file

@ -17,8 +17,8 @@ static const char* reverse_opcode_names[] =
"READ-CHAR", "READ-CHAR",
}; };
void disasm (bytecode bc) { void disasm (sexp bc) {
unsigned char *ip=bc->data, opcode; unsigned char *ip=sexp_bytecode_data(bc), opcode;
loop: loop:
opcode = *ip++; opcode = *ip++;
if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
@ -55,29 +55,30 @@ void disasm (bytecode bc) {
} }
fprintf(stderr, "\n"); fprintf(stderr, "\n");
if ((! (opcode == OP_RET) || (opcode == OP_DONE)) if ((! (opcode == OP_RET) || (opcode == OP_DONE))
&& (ip - bc->data < bc->len)) && (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)))
goto loop; goto loop;
} }
void print_bytecode (bytecode bc) { void print_bytecode (sexp bc) {
int i; int i;
unsigned char *data = sexp_bytecode_data(bc);
fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n",
bc, bc->data, bc->len); bc, data, sexp_bytecode_length(bc));
for (i=0; i+16 < bc->len; i+=8) { for (i=0; i+16 < sexp_bytecode_length(bc); i+=8) {
fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i,
bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], data[i], data[i+1], data[i+2], data[i+3],
bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); data[i+4], data[i+5], data[i+6], data[i+7]);
i += 8; i += 8;
fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n",
bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], data[i], data[i+1], data[i+2], data[i+3],
bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); data[i+4], data[i+5], data[i+6], data[i+7]);
} }
if (i != bc->len) { if (i != sexp_bytecode_length(bc)) {
fprintf(stderr, "%02x:", i); fprintf(stderr, "%02x:", i);
for ( ; i < bc->len; i++) { for ( ; i < sexp_bytecode_length(bc); i++) {
if ((i % 8) == 0 && (i % 16) != 0) if ((i % 8) == 0 && (i % 16) != 0)
fprintf(stderr, " "); fprintf(stderr, " ");
fprintf(stderr, " %02x", bc->data[i]); fprintf(stderr, " %02x", data[i]);
} }
fprintf(stderr, "\n"); fprintf(stderr, "\n");
} }

390
eval.c
View file

@ -23,54 +23,56 @@ static sexp interaction_environment;
/********************** environment utilities ***************************/ /********************** environment utilities ***************************/
static sexp env_cell(env e, sexp key) { static sexp env_cell(sexp e, sexp key) {
sexp ls; sexp ls;
do { do {
for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) for (ls=sexp_env_bindings(e); SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
if (SEXP_CAAR(ls) == key) if (SEXP_CAAR(ls) == key)
return SEXP_CAR(ls); return SEXP_CAR(ls);
e = e->parent; e = sexp_env_parent(e);
} while (e); } while (e);
return NULL; return NULL;
} }
static int env_global_p (env e, sexp id) { static int env_global_p (sexp e, sexp id) {
while (e->parent) { while (sexp_env_parent(e)) {
if (sexp_assq(id, e->bindings) != SEXP_FALSE) if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE)
return 0; return 0;
else else
e = e->parent; e = sexp_env_parent(e);
} }
return 1; return 1;
} }
static void env_define(env e, sexp key, sexp value) { static void env_define(sexp e, sexp key, sexp value) {
sexp cell = env_cell(e, key); sexp cell = env_cell(e, key);
if (cell) { if (cell) {
SEXP_CDR(cell) = value; SEXP_CDR(cell) = value;
} else { } else {
e->bindings = sexp_cons(sexp_cons(key, value), e->bindings); sexp_env_bindings(e)
= sexp_cons(sexp_cons(key, value), sexp_env_bindings(e));
} }
} }
static env extend_env_closure (env e, sexp fv, int offset) { static sexp extend_env_closure (sexp e, sexp fv, int offset) {
int i; int i;
env e2 = (env) SEXP_ALLOC(sizeof(struct env)); sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env));
e2->tag = SEXP_ENV; e2->tag = SEXP_ENV;
e2->parent = e; sexp_env_parent(e2) = e;
e2->bindings = SEXP_NULL; sexp_env_bindings(e2) = SEXP_NULL;
for (i=offset; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i--) for (i=offset; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i--)
e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), sexp_env_bindings(e2)
e2->bindings); = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)),
sexp_env_bindings(e2));
return e2; return e2;
} }
static int core_code (env e, sexp sym) { static int core_code (sexp e, sexp sym) {
sexp cell = env_cell(e, sym); sexp cell = env_cell(e, sym);
if (! cell || ! SEXP_COREP(SEXP_CDR(cell))) return 0; if (! cell || ! SEXP_COREP(SEXP_CDR(cell))) return 0;
return (((core_form)SEXP_CDR(cell))->code); return (sexp_core_code(SEXP_CDR(cell)));
} }
static sexp sexp_reverse_flatten_dot (sexp ls) { static sexp sexp_reverse_flatten_dot (sexp ls) {
@ -86,39 +88,41 @@ static sexp sexp_flatten_dot (sexp ls) {
/************************* bytecode utilities ***************************/ /************************* bytecode utilities ***************************/
static void shrink_bcode(bytecode *bc, sexp_uint_t i) { static void shrink_bcode(sexp *bc, sexp_uint_t i) {
bytecode tmp; sexp tmp;
if ((*bc)->len != i) { if (sexp_bytecode_length(*bc) != i) {
/* fprintf(stderr, "shrinking to %d\n", i); */ tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + i);
tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i);
tmp->tag = SEXP_BYTECODE; tmp->tag = SEXP_BYTECODE;
tmp->len = i; sexp_bytecode_length(tmp) = i;
memcpy(tmp->data, (*bc)->data, i); memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i);
SEXP_FREE(*bc); SEXP_FREE(*bc);
*bc = tmp; *bc = tmp;
} }
} }
static void expand_bcode(bytecode *bc, sexp_uint_t *i, sexp_uint_t size) { static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) {
bytecode tmp; sexp tmp;
if ((*bc)->len < (*i)+size) { if (sexp_bytecode_length(*bc) < (*i)+size) {
fprintf(stderr, "expanding bytecode %u < %u + %u = %u\n", (*bc)->len, (*i), size, (*i)+size); tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)
tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + (*bc)->len*2); + sexp_bytecode_length(*bc)*2);
tmp->len = (*bc)->len*2; tmp->tag = SEXP_BYTECODE;
memcpy(tmp->data, (*bc)->data, (*bc)->len); sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2;
memcpy(sexp_bytecode_data(tmp),
sexp_bytecode_data(*bc),
sexp_bytecode_length(*bc));
SEXP_FREE(*bc); SEXP_FREE(*bc);
*bc = tmp; *bc = tmp;
} }
} }
static void emit(bytecode *bc, sexp_uint_t *i, char c) { static void emit(sexp *bc, sexp_uint_t *i, char c) {
expand_bcode(bc, i, 1); expand_bcode(bc, i, 1);
(*bc)->data[(*i)++] = c; sexp_bytecode_data(*bc)[(*i)++] = c;
} }
static void emit_word(bytecode *bc, sexp_uint_t *i, sexp_uint_t val) { static void emit_word(sexp *bc, sexp_uint_t *i, sexp_uint_t val) {
expand_bcode(bc, i, sizeof(sexp)); expand_bcode(bc, i, sizeof(sexp));
*((sexp_uint_t*)(&((*bc)->data[*i]))) = val; *((sexp_uint_t*)(&(sexp_bytecode_data(*bc)[*i]))) = val;
*i += sizeof(sexp_uint_t); *i += sizeof(sexp_uint_t);
} }
@ -127,43 +131,41 @@ static void emit_word(bytecode *bc, sexp_uint_t *i, sexp_uint_t val) {
static sexp sexp_make_procedure(char flags, unsigned short num_args, static sexp sexp_make_procedure(char flags, unsigned short num_args,
sexp bc, sexp vars) { sexp bc, sexp vars) {
procedure proc = SEXP_ALLOC(sizeof(struct procedure)); sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure));
proc->tag = SEXP_PROCEDURE; proc->tag = SEXP_PROCEDURE;
proc->flags = flags; sexp_procedure_flags(proc) = flags;
proc->num_args = num_args; sexp_procedure_num_args(proc) = num_args;
proc->bc = (bytecode) bc; sexp_procedure_code(proc) = bc;
proc->vars = vars; sexp_procedure_vars(proc) = vars;
return (sexp) proc; return proc;
} }
static sexp sexp_make_macro (procedure p, env e) { static sexp sexp_make_macro (sexp p, sexp e) {
macro mac = SEXP_ALLOC(sizeof(struct macro)); sexp mac = (sexp) SEXP_ALLOC(sexp_sizeof(macro));
mac->tag = SEXP_MACRO; mac->tag = SEXP_MACRO;
mac->e = e; sexp_macro_env(mac) = e;
mac->proc = p; sexp_macro_proc(mac) = p;
return (sexp) mac; return mac;
} }
/************************* the compiler ***************************/ /************************* the compiler ***************************/
sexp sexp_expand_macro (macro mac, sexp form, env e) { sexp sexp_expand_macro (sexp mac, sexp form, sexp e) {
sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
bytecode bc;
sexp_uint_t i=0; sexp_uint_t i=0;
fprintf(stderr, "expanding: "); fprintf(stderr, "expanding: ");
sexp_write(form, cur_error_port); sexp_write(form, cur_error_port);
fprintf(stderr, "\n => "); fprintf(stderr, "\n => ");
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+64); bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64);
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = 32; sexp_bytecode_length(bc) = 32;
emit_push(&bc, &i, mac->e); emit_push(&bc, &i, sexp_macro_env(mac));
emit_push(&bc, &i, e); emit_push(&bc, &i, e);
emit_push(&bc, &i, form); emit_push(&bc, &i, form);
emit_push(&bc, &i, mac->proc); emit_push(&bc, &i, sexp_macro_proc(mac));
emit(&bc, &i, OP_CALL); emit(&bc, &i, OP_CALL);
emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3));
emit(&bc, &i, OP_DONE); emit(&bc, &i, OP_DONE);
/* disasm(bc); */
res = vm(bc, e, stack, 0); res = vm(bc, e, stack, 0);
sexp_write(res, cur_error_port); sexp_write(res, cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
@ -172,11 +174,10 @@ sexp sexp_expand_macro (macro mac, sexp form, env e) {
return res; return res;
} }
void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) {
int tmp1, tmp2, tmp3; int tmp1, tmp2, tmp3;
env e2; sexp o1, o2, e2, cell;
sexp o1, o2, cell;
loop: loop:
if (SEXP_PAIRP(obj)) { if (SEXP_PAIRP(obj)) {
@ -188,19 +189,19 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e,
} }
o1 = SEXP_CDR(o1); o1 = SEXP_CDR(o1);
if (SEXP_COREP(o1)) { if (SEXP_COREP(o1)) {
switch (((core_form)o1)->code) { switch (sexp_core_code(o1)) {
case CORE_LAMBDA: case CORE_LAMBDA:
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, tailp); bc, i, e, params, fv, sv, d, tailp);
break; break;
case CORE_DEFINE_SYNTAX: case CORE_DEFINE_SYNTAX:
env_define(e, SEXP_CADR(obj), env_define(e, SEXP_CADR(obj),
sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); sexp_make_macro(eval(SEXP_CADDR(obj), e), e));
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
(*d)++; (*d)++;
break; break;
case CORE_DEFINE: case CORE_DEFINE:
if ((((core_form)o1)->code == CORE_DEFINE) if ((sexp_core_code(o1) == CORE_DEFINE)
&& SEXP_PAIRP(SEXP_CADR(obj))) { && SEXP_PAIRP(SEXP_CADR(obj))) {
o2 = SEXP_CAR(SEXP_CADR(obj)); o2 = SEXP_CAR(SEXP_CADR(obj));
analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), analyze_lambda(SEXP_CAR(SEXP_CADR(obj)),
@ -211,7 +212,7 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e,
o2 = SEXP_CADR(obj); o2 = SEXP_CADR(obj);
analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0);
} }
if (! e->parent) { if (sexp_env_global_p(e)) {
emit(bc, i, OP_GLOBAL_SET); emit(bc, i, OP_GLOBAL_SET);
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);
@ -256,26 +257,28 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e,
(*d)--; (*d)--;
tmp2 = *i; tmp2 = *i;
emit(bc, i, 0); emit(bc, i, 0);
((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /* patch */ /* ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /\* patch *\/ */
((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1;
if (SEXP_PAIRP(SEXP_CDDDR(obj))) { if (SEXP_PAIRP(SEXP_CDDDR(obj))) {
analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d, tailp); analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d, tailp);
} else { } else {
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
(*d)++; (*d)++;
} }
((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /* patch */ /* ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /\* patch *\/ */
((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2;
break; break;
case CORE_QUOTE: case CORE_QUOTE:
emit_push(bc, i, SEXP_CADR(obj)); emit_push(bc, i, SEXP_CADR(obj));
(*d)++; (*d)++;
break; break;
default: default:
errx(1, "unknown core form: %s", ((core_form)o1)->code); errx(1, "unknown core form: %s", sexp_core_code(o1));
} }
} else if (SEXP_OPCODEP(o1)) { } else if (SEXP_OPCODEP(o1)) {
analyze_opcode((opcode)o1, obj, bc, i, e, params, fv, sv, d, tailp); analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp);
} else if (SEXP_MACROP(o1)) { } else if (SEXP_MACROP(o1)) {
obj = sexp_expand_macro((macro) o1, obj, e); obj = sexp_expand_macro(o1, obj, e);
goto loop; goto loop;
} else { } else {
/* general procedure call */ /* general procedure call */
@ -286,7 +289,7 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e,
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) && (sexp_core_code(o2) == CORE_LAMBDA)
&& sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) {
/* let */ /* let */
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj)))); tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj))));
@ -323,13 +326,13 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e,
} }
} }
void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp)
{ {
int tmp1; int tmp1;
sexp o1; sexp o1;
switch (op->op_class) { switch (sexp_opcode_class(op)) {
case OPC_TYPE_PREDICATE: case OPC_TYPE_PREDICATE:
case OPC_PREDICATE: case OPC_PREDICATE:
case OPC_ARITHMETIC: case OPC_ARITHMETIC:
@ -340,55 +343,55 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e,
case OPC_GENERIC: case OPC_GENERIC:
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
if (tmp1 == 0) { if (tmp1 == 0) {
errx(1, "opcode with no arguments: %s", op->name); errx(1, "opcode with no arguments: %s", sexp_opcode_name(op));
} else if (tmp1 == 1) { } else if (tmp1 == 1) {
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0);
if (op->op_class == OPC_ARITHMETIC_INV) { if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) {
emit(bc, i, op->op_inverse); emit(bc, i, sexp_opcode_inverse(op));
(*d)++; (*d)++;
} else if (op->op_class != OPC_ARITHMETIC) { } else if (sexp_opcode_class(op) != OPC_ARITHMETIC) {
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
} }
} else { } else {
for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1))
analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0);
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
(*d) -= (tmp1-1); (*d) -= (tmp1-1);
if (op->op_class == OPC_ARITHMETIC) if (sexp_opcode_class(op) == OPC_ARITHMETIC)
for (tmp1-=2; tmp1>0; tmp1--) for (tmp1-=2; tmp1>0; tmp1--)
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
} }
break; break;
case OPC_IO: case OPC_IO:
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
if (tmp1 == op->num_args && op->var_args_p) { if (tmp1 == sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) {
emit(bc, i, OP_PARAMETER); emit(bc, i, OP_PARAMETER);
emit_word(bc, i, (sexp_uint_t) op->data); emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op));
(*d)++; (*d)++;
tmp1++; tmp1++;
} }
for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1))
analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0);
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
(*d) -= (tmp1-1); (*d) -= (tmp1-1);
break; break;
case OPC_PARAMETER: case OPC_PARAMETER:
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
emit_word(bc, i, (sexp_uint_t) op->data); emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op));
break; break;
case OPC_FOREIGN: case OPC_FOREIGN:
for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1))
analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0);
emit_push(bc, i, op->data); emit_push(bc, i, sexp_opcode_data(op));
emit(bc, i, op->op_name); emit(bc, i, sexp_opcode_code(op));
(*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1); (*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1);
break; break;
default: default:
errx(1, "unknown opcode class: %d", op->op_class); errx(1, "unknown opcode class: %d", sexp_opcode_class(op));
} }
} }
void analyze_var_ref (sexp obj, bytecode *bc, sexp_uint_t *i, env e, void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d) { sexp params, sexp fv, sexp sv, sexp_uint_t *d) {
int tmp; int tmp;
sexp o1; sexp o1;
@ -418,7 +421,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, sexp_uint_t *i, env e,
} }
} }
void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e, void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) {
sexp o1; sexp o1;
sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
@ -445,7 +448,7 @@ void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e,
(*d) -= (len); (*d) -= (len);
} }
sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) {
sexp o1; sexp o1;
if (SEXP_SYMBOLP(obj)) { if (SEXP_SYMBOLP(obj)) {
if (env_global_p(e, obj) if (env_global_p(e, obj)
@ -458,7 +461,7 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) {
if ((o1 = env_cell(e, SEXP_CAR(obj))) if ((o1 = env_cell(e, SEXP_CAR(obj)))
&& SEXP_COREP(o1) && SEXP_COREP(o1)
&& (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) { && (sexp_core_code(SEXP_CDR(o1)) == CORE_LAMBDA)) {
return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv);
} }
} }
@ -472,17 +475,17 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
} }
} }
sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) {
sexp tmp; sexp tmp;
if (SEXP_NULLP(formals)) if (SEXP_NULLP(formals))
return sv; return sv;
if (SEXP_PAIRP(obj)) { if (SEXP_PAIRP(obj)) {
if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) {
if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) {
if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { if (sexp_core_code(SEXP_CDR(tmp)) == CORE_LAMBDA) {
formals = sexp_lset_diff(formals, SEXP_CADR(obj)); formals = sexp_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 (sexp_core_code(SEXP_CDR(tmp)) == CORE_SET
&& (sexp_list_index(formals, SEXP_CADR(obj)) >= 0) && (sexp_list_index(formals, SEXP_CADR(obj)) >= 0)
&& ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) { && ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) {
sv = sexp_cons(SEXP_CADR(obj), sv); sv = sexp_cons(SEXP_CADR(obj), sv);
@ -499,11 +502,10 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) {
} }
void analyze_lambda (sexp name, sexp formals, sexp body, void analyze_lambda (sexp name, sexp formals, sexp body,
bytecode *bc, sexp_uint_t *i, env e, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, sexp params, sexp fv, sexp sv, sexp_uint_t *d,
int tailp) { int tailp) {
sexp obj, ls, flat_formals, fv2; sexp obj, ls, flat_formals, fv2, e2;
env e2;
int k; int k;
flat_formals = sexp_flatten_dot(formals); flat_formals = sexp_flatten_dot(formals);
fv2 = free_vars(e, flat_formals, body, SEXP_NULL); fv2 = free_vars(e, flat_formals, body, SEXP_NULL);
@ -512,7 +514,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
/* sexp_write(fv2, cur_error_port); */ /* sexp_write(fv2, cur_error_port); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
/* compile the body with respect to the new params */ /* compile the body with respect to the new params */
obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0); obj = compile(flat_formals, body, e2, fv2, sv, 0);
/* push the closed vars */ /* push the closed vars */
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
emit_push(bc, i, sexp_length(fv2)); emit_push(bc, i, sexp_length(fv2));
@ -544,28 +546,33 @@ sexp make_param_list(sexp_uint_t i) {
return res; return res;
} }
sexp make_opcode_procedure(opcode op, sexp_uint_t i, env e) { sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) {
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp bc, params, res;
sexp params = make_param_list(i);
sexp_uint_t pos=0, d=0; sexp_uint_t pos=0, d=0;
if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
return sexp_opcode_proc(op);
bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE);
params = make_param_list(i);
e = extend_env_closure(e, params, -4); e = extend_env_closure(e, params, -4);
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = INIT_BCODE_SIZE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE;
analyze_opcode(op, sexp_cons((sexp) op, params), &bc, &pos, e, params, analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params,
SEXP_NULL, SEXP_NULL, &d, 0); SEXP_NULL, SEXP_NULL, &d, 0);
emit(&bc, &pos, OP_RET); emit(&bc, &pos, OP_RET);
shrink_bcode(&bc, pos); shrink_bcode(&bc, pos);
/* disasm(bc); */ /* disasm(bc); */
return sexp_make_procedure(0, (int) sexp_make_integer(i), res = sexp_make_procedure(0, (int) sexp_make_integer(i), bc, SEXP_UNDEF);
(sexp) bc, SEXP_UNDEF); if (i == sexp_opcode_num_args(op))
sexp_opcode_proc(op) = res;
return res;
} }
bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) {
sexp_uint_t i = 0, j, d = 0, core, define_ok=1; sexp_uint_t i = 0, j, d = 0, core, define_ok=1;
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(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;
bc->len = INIT_BCODE_SIZE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE;
sexp_debug("set-vars: ", sv2); sexp_debug("set-vars: ", sv2);
/* box mutable vars */ /* box mutable vars */
for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) {
@ -581,7 +588,7 @@ 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 */
if (e->parent) { if (sexp_env_parent(e)) {
for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) {
core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj))
? core_code(e, SEXP_CAAR(obj)) : 0); ? core_code(e, SEXP_CAAR(obj)) : 0);
@ -661,8 +668,8 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
#define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;} #define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;}
sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
unsigned char *ip=bc->data; unsigned char *ip=sexp_bytecode_data(bc);
sexp cp=SEXP_UNDEF, tmp1, tmp2; sexp cp=SEXP_UNDEF, tmp1, tmp2;
sexp_sint_t i, j, k; sexp_sint_t i, j, k;
@ -868,7 +875,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) {
make_call: make_call:
if (SEXP_OPCODEP(tmp1)) if (SEXP_OPCODEP(tmp1))
/* hack, compile an opcode application on the fly */ /* hack, compile an opcode application on the fly */
tmp1 = make_opcode_procedure((opcode) tmp1, i, e); tmp1 = make_opcode_procedure(tmp1, i, e);
/* print_stack(stack, top); */ /* print_stack(stack, top); */
if (! SEXP_PROCEDUREP(tmp1)) { if (! SEXP_PROCEDUREP(tmp1)) {
fprintf(stderr, "error: non-procedure app: "); fprintf(stderr, "error: non-procedure app: ");
@ -914,7 +921,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) {
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
/* print_bytecode(bc); */ /* print_bytecode(bc); */
/* disasm(bc); */ /* disasm(bc); */
ip = bc->data; ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1); cp = sexp_procedure_vars(tmp1);
/* fprintf(stderr, "... calling procedure at %p\ncp: ", ip); */ /* fprintf(stderr, "... calling procedure at %p\ncp: ", ip); */
/* /\* sexp_write(cp, stderr); *\/ */ /* /\* sexp_write(cp, stderr); *\/ */
@ -948,7 +955,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) {
sexp_vector(1, sexp_save_stack(stack, top+3))); sexp_vector(1, sexp_save_stack(stack, top+3)));
top+=3; top+=3;
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
ip = bc->data; ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1); cp = sexp_procedure_vars(tmp1);
break; break;
case OP_RESUMECC: case OP_RESUMECC:
@ -979,7 +986,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) {
stack[top+2] = cp; stack[top+2] = cp;
top+=3; top+=3;
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
ip = bc->data; ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(tmp1); cp = sexp_procedure_vars(tmp1);
break; break;
case OP_FCALL0: case OP_FCALL0:
@ -1096,7 +1103,7 @@ sexp sexp_load (sexp source) {
closep = 1; closep = 1;
} }
while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) while ((obj=sexp_read(source)) != (sexp) SEXP_EOF)
eval_in_stack(obj, (env) interaction_environment, stack, 0); eval_in_stack(obj, interaction_environment, stack, 0);
if (closep) sexp_close_port(source); if (closep) sexp_close_port(source);
SEXP_FREE(stack); SEXP_FREE(stack);
return SEXP_UNDEF; return SEXP_UNDEF;
@ -1104,67 +1111,67 @@ sexp sexp_load (sexp source) {
/*********************** standard environment *************************/ /*********************** standard environment *************************/
static const struct core_form core_forms[] = { static struct sexp_struct core_forms[] = {
{SEXP_CORE, CORE_DEFINE, "define"}, {.tag=SEXP_CORE, .value={.core={CORE_DEFINE, "define"}}},
{SEXP_CORE, CORE_SET, "set!"}, {.tag=SEXP_CORE, .value={.core={CORE_SET, "set!"}}},
{SEXP_CORE, CORE_LAMBDA, "lambda"}, {.tag=SEXP_CORE, .value={.core={CORE_LAMBDA, "lambda"}}},
{SEXP_CORE, CORE_IF, "if"}, {.tag=SEXP_CORE, .value={.core={CORE_IF, "if"}}},
{SEXP_CORE, CORE_BEGIN, "begin"}, {.tag=SEXP_CORE, .value={.core={CORE_BEGIN, "begin"}}},
{SEXP_CORE, CORE_QUOTE, "quote"}, {.tag=SEXP_CORE, .value={.core={CORE_QUOTE, "quote"}}},
{SEXP_CORE, CORE_DEFINE_SYNTAX, "define-syntax"}, {.tag=SEXP_CORE, .value={.core={CORE_DEFINE_SYNTAX, "define-syntax"}}},
{SEXP_CORE, CORE_LET_SYNTAX, "let-syntax"}, {.tag=SEXP_CORE, .value={.core={CORE_LET_SYNTAX, "let-syntax"}}},
{SEXP_CORE, CORE_LETREC_SYNTAX, "letrec-syntax"}, {.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}},
}; };
static const struct opcode opcodes[] = { static struct sexp_struct opcodes[] = {
#define _OP(c,o,n,m,t,u,i,s) {SEXP_OPCODE, c, o, n, m, t, u, i, s, NULL, NULL} #define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}}
#define _FN(o,n,t,u,s,f) {SEXP_OPCODE, OPC_FOREIGN, o, n, 0, t,u, 0, s, (sexp)f, NULL} #define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL)
#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) #define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f)
#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f)
#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f)
#define _PARAM(n,a,t) {SEXP_OPCODE, OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL} #define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL)
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"), _OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL),
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"), _OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL),
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"), _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL),
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!"), _OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL),
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref"), _OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL),
_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!"), _OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL),
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref"), _OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL),
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!"), _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL),
_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, "-", NULL, NULL),
_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, "/", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"), _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<="), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">"), _OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">="), _OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "="), _OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL),
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector"), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure"), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"), _OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?"), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?"), _OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?"), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?"), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?"), _OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"), _OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), _OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL),
_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1"), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL),
_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL),
_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL),
{SEXP_OPCODE, OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL}, _OP(OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL}, _OP(OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL}, _OP(OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL}, _OP(OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL}, _OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL}, _OP(OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL),
{SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL}, _OP(OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL),
_FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "length", sexp_length),
_FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "reverse", sexp_reverse),
_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
@ -1188,28 +1195,28 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV),
#undef _PARAM #undef _PARAM
}; };
env make_standard_env() { sexp make_standard_env() {
sexp_uint_t i; sexp_uint_t i;
env e = (env) SEXP_ALLOC(sizeof(struct env)); sexp e = (sexp) SEXP_ALLOC(sexp_sizeof(env));
e->tag = SEXP_ENV; e->tag = SEXP_ENV;
e->parent = NULL; sexp_env_parent(e) = NULL;
e->bindings = SEXP_NULL; sexp_env_bindings(e) = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++)
env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); env_define(e, sexp_intern(sexp_core_name(&core_forms[i])), &core_forms[i]);
for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++)
env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]);
return e; return e;
} }
/************************** eval interface ****************************/ /************************** eval interface ****************************/
sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top) { sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) {
bytecode bc; sexp bc;
bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1);
return vm(bc, e, stack, top); return vm(bc, e, stack, top);
} }
sexp eval(sexp obj, env e) { sexp eval(sexp obj, sexp e) {
sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE);
sexp res = eval_in_stack(obj, e, stack, 0); sexp res = eval_in_stack(obj, e, stack, 0);
SEXP_FREE(stack); SEXP_FREE(stack);
@ -1217,7 +1224,7 @@ sexp eval(sexp obj, env e) {
} }
void scheme_init() { void scheme_init() {
bytecode bc; sexp bc;
sexp_uint_t i=0; sexp_uint_t i=0;
if (! scheme_initialized_p) { if (! scheme_initialized_p) {
scheme_initialized_p = 1; scheme_initialized_p = 1;
@ -1225,15 +1232,15 @@ void scheme_init() {
cur_input_port = sexp_make_input_port(stdin); cur_input_port = sexp_make_input_port(stdin);
cur_output_port = sexp_make_output_port(stdout); cur_output_port = sexp_make_output_port(stdout);
cur_error_port = sexp_make_output_port(stderr); cur_error_port = sexp_make_output_port(stderr);
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16);
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = 16; sexp_bytecode_length(bc) = 16;
emit(&bc, &i, OP_RESUMECC); emit(&bc, &i, OP_RESUMECC);
continuation_resumer = (sexp) bc; continuation_resumer = (sexp) bc;
} }
} }
void repl (env e, sexp *stack) { void repl (sexp e, sexp *stack) {
sexp obj, res; sexp obj, res;
while (1) { while (1) {
sexp_write_string("> ", cur_output_port); sexp_write_string("> ", cur_output_port);
@ -1250,23 +1257,20 @@ void repl (env e, sexp *stack) {
} }
int main (int argc, char **argv) { int main (int argc, char **argv) {
sexp obj, res, in, out, *stack, err_handler, err_handler_sym; sexp bc, e, obj, res, in, out, *stack, err_handler, err_handler_sym;
env e;
bytecode bc;
sexp_uint_t i, quit=0, init_loaded=0; sexp_uint_t i, quit=0, init_loaded=0;
FILE *stream;
scheme_init(); scheme_init();
stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE);
e = make_standard_env(); e = make_standard_env();
interaction_environment = (sexp) e; interaction_environment = e;
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16);
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = 16; sexp_bytecode_length(bc) = 16;
i = 0; i = 0;
emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF);
emit(&bc, &i, OP_DONE); emit(&bc, &i, OP_DONE);
err_handler = sexp_make_procedure(0, 0, (sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); err_handler = sexp_make_procedure(0, 0, bc, sexp_make_vector(0, SEXP_UNDEF));
err_handler_sym = sexp_intern("*error-handler*"); err_handler_sym = sexp_intern("*error-handler*");
env_define(e, err_handler_sym, err_handler); env_define(e, err_handler_sym, err_handler);
exception_handler_cell = env_cell(e, err_handler_sym); exception_handler_cell = env_cell(e, err_handler_sym);

65
eval.h
View file

@ -16,6 +16,7 @@
#define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) #define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port))
/* procedure types */
typedef sexp (*sexp_proc0) (); typedef sexp (*sexp_proc0) ();
typedef sexp (*sexp_proc1) (sexp); typedef sexp (*sexp_proc1) (sexp);
typedef sexp (*sexp_proc2) (sexp, sexp); typedef sexp (*sexp_proc2) (sexp, sexp);
@ -25,52 +26,6 @@ typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp);
typedef struct bytecode {
char tag;
unsigned int len;
unsigned char data[];
} *bytecode;
typedef struct procedure {
char tag;
char flags;
unsigned short num_args;
bytecode bc;
sexp vars;
} *procedure;
typedef struct env {
char tag;
struct env *parent;
sexp bindings;
} *env;
typedef struct macro {
char tag;
procedure proc;
env e;
} *macro;
typedef struct opcode {
char tag;
char op_class;
char op_name;
char num_args;
char var_args_p;
char arg1_type;
char arg2_type;
char op_inverse;
char* name;
sexp data;
sexp proc;
} *opcode;
typedef struct core_form {
char tag;
char code;
char* name;
} *core_form;
enum core_form_names { enum core_form_names {
CORE_DEFINE = 1, CORE_DEFINE = 1,
CORE_SET, CORE_SET,
@ -172,22 +127,22 @@ enum opcode_names {
/**************************** prototypes ******************************/ /**************************** prototypes ******************************/
bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p);
void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i,
env e, sexp params, sexp fv, sexp sv, sexp e, sexp params, sexp fv, sexp sv,
sexp_uint_t *d, int tailp); sexp_uint_t *d, int tailp);
void analyze_lambda (sexp name, sexp formals, sexp body, void analyze_lambda (sexp name, sexp formals, sexp body,
bytecode *bc, sexp_uint_t *i, env e, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp);
void analyze_var_ref (sexp name, bytecode *bc, sexp_uint_t *i, env e, void analyze_var_ref (sexp name, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d); sexp params, sexp fv, sexp sv, sexp_uint_t *d);
void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp);
sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top); sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top);
sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top); sexp eval_in_stack(sexp expr, sexp e, sexp* stack, sexp_sint_t top);
sexp eval(sexp obj, env e); sexp eval(sexp expr, sexp e);
#endif /* ! SEXP_EVAL_H */ #endif /* ! SEXP_EVAL_H */

56
sexp.c
View file

@ -79,10 +79,12 @@ void sexp_free (sexp obj) {
/*************************** list utilities ***************************/ /*************************** list utilities ***************************/
sexp sexp_cons(sexp head, sexp tail) { sexp sexp_cons(sexp head, sexp tail) {
sexp pair = SEXP_NEW(); sexp pair = SEXP_ALLOC(sexp_sizeof(pair));
pair->tag = SEXP_PAIR; pair->tag = SEXP_PAIR;
pair->data1 = (void*) head; /* pair->data1 = (void*) head; */
pair->data2 = (void*) tail; /* pair->data2 = (void*) tail; */
SEXP_CAR(pair) = head;
SEXP_CDR(pair) = tail;
return pair; return pair;
} }
@ -170,20 +172,22 @@ sexp sexp_length(sexp ls) {
/********************* strings, symbols, vectors **********************/ /********************* strings, symbols, vectors **********************/
sexp sexp_make_flonum(double f) { sexp sexp_make_flonum(double f) {
sexp x = SEXP_NEW(); sexp x = SEXP_ALLOC(sexp_sizeof(flonum));
x->tag = SEXP_FLONUM; x->tag = SEXP_FLONUM;
sexp_flonum_value(x) = f; sexp_flonum_value(x) = f;
return x; return x;
} }
sexp sexp_make_string(char *str) { sexp sexp_make_string(char *str) {
sexp s = SEXP_NEW(); sexp s = SEXP_ALLOC(sexp_sizeof(string));
unsigned long len = strlen(str); sexp_uint_t len = strlen(str);
char *mystr = SEXP_ALLOC(len+1); char *mystr = SEXP_ALLOC(len+1);
memcpy(mystr, str, len+1); memcpy(mystr, str, len+1);
s->tag = SEXP_STRING; s->tag = SEXP_STRING;
s->data1 = (void*) len; /* s->data1 = (void*) len; */
s->data2 = (void*) mystr; /* s->data2 = (void*) mystr; */
sexp_string_length(s) = len;
sexp_string_data(s) = mystr;
return s; return s;
} }
@ -240,14 +244,16 @@ sexp sexp_intern(char *str) {
symbol_table = newtable; symbol_table = newtable;
} }
sym = SEXP_NEW(); sym = SEXP_ALLOC(sexp_sizeof(symbol));
len = strlen(str); len = strlen(str);
mystr = SEXP_ALLOC(len+1); mystr = SEXP_ALLOC(len+1);
memcpy(mystr, str, len+1); memcpy(mystr, str, len+1);
mystr[len]=0; mystr[len]=0;
sym->tag = SEXP_SYMBOL; sym->tag = SEXP_SYMBOL;
sym->data1 = (void*) len; /* sym->data1 = (void*) len; */
sym->data2 = (void*) mystr; /* sym->data2 = (void*) mystr; */
sexp_symbol_length(sym) = len;
sexp_symbol_data(sym) = mystr;
symbol_table[cell] = sym; symbol_table[cell] = sym;
return symbol_table[cell]; return symbol_table[cell];
} }
@ -256,14 +262,16 @@ sexp sexp_make_vector(sexp len, sexp dflt) {
sexp v, *x; sexp v, *x;
int i, clen = sexp_unbox_integer(len); int i, clen = sexp_unbox_integer(len);
if (! clen) return the_empty_vector; if (! clen) return the_empty_vector;
v = SEXP_NEW(); v = SEXP_ALLOC(sexp_sizeof(vector));
x = (void*) SEXP_ALLOC(clen*sizeof(sexp)); x = (sexp*) SEXP_ALLOC(clen*sizeof(sexp));
for (i=0; i<clen; i++) { for (i=0; i<clen; i++) {
x[i] = dflt; x[i] = dflt;
} }
v->tag = SEXP_VECTOR; v->tag = SEXP_VECTOR;
v->data1 = (void*) clen; /* v->data1 = (void*) clen; */
v->data2 = (void*) x; /* v->data2 = (void*) x; */
sexp_vector_length(v) = clen;
sexp_vector_data(v) = x;
return v; return v;
} }
@ -325,16 +333,18 @@ int sstream_close(void *vec) {
} }
sexp sexp_make_input_port(FILE* in) { sexp sexp_make_input_port(FILE* in) {
sexp p = SEXP_NEW(); sexp p = SEXP_ALLOC(sexp_sizeof(port));
p->tag = SEXP_IPORT; p->tag = SEXP_IPORT;
p->data1 = in; /* p->data1 = in; */
sexp_port_stream(p) = in;
return p; return p;
} }
sexp sexp_make_output_port(FILE* out) { sexp sexp_make_output_port(FILE* out) {
sexp p = SEXP_NEW(); sexp p = SEXP_ALLOC(sexp_sizeof(port));
p->tag = SEXP_OPORT; p->tag = SEXP_OPORT;
p->data1 = out; /* p->data1 = out; */
sexp_port_stream(p) = out;
return p; return p;
} }
@ -782,10 +792,12 @@ void sexp_init() {
the_quasiquote_symbol = sexp_intern("quasiquote"); the_quasiquote_symbol = sexp_intern("quasiquote");
the_unquote_symbol = sexp_intern("unquote"); the_unquote_symbol = sexp_intern("unquote");
the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing");
the_empty_vector = SEXP_NEW(); the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector));
the_empty_vector->tag = SEXP_VECTOR; the_empty_vector->tag = SEXP_VECTOR;
the_empty_vector->data1 = 0; /* the_empty_vector->data1 = 0; */
the_empty_vector->data2 = 0; /* the_empty_vector->data2 = 0; */
sexp_vector_length(the_empty_vector) = 0;
sexp_vector_data(the_empty_vector) = NULL;
} }
} }

192
sexp.h
View file

@ -16,7 +16,7 @@
#if HAVE_ERR_H #if HAVE_ERR_H
#include <err.h> #include <err.h>
#else #else
/* requires that msg be a string literal */ /* requires msg be a string literal, and at least one argument */
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) #define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
#endif #endif
@ -63,6 +63,7 @@
#define SEXP_LSYMBOL_TAG 3 #define SEXP_LSYMBOL_TAG 3
#define SEXP_ISYMBOL_TAG 7 #define SEXP_ISYMBOL_TAG 7
#define SEXP_CHAR_TAG 6 #define SEXP_CHAR_TAG 6
#define SEXP_EXTENDED_TAG 14
enum sexp_types { enum sexp_types {
SEXP_OBJECT, SEXP_OBJECT,
@ -87,24 +88,79 @@ enum sexp_types {
SEXP_OPCODE, SEXP_OPCODE,
}; };
typedef struct sexp_struct {
char tag;
void *data1;
void *data2;
} *sexp;
typedef unsigned long sexp_uint_t; typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t; typedef long sexp_sint_t;
typedef char sexp_tag_t;
typedef struct sexp_struct *sexp;
#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) struct sexp_struct {
#define SEXP_NULL MAKE_IMMEDIATE(0) sexp_tag_t tag;
#define SEXP_FALSE MAKE_IMMEDIATE(1) union {
#define SEXP_TRUE MAKE_IMMEDIATE(2) double flonum;
#define SEXP_EOF MAKE_IMMEDIATE(3) struct {
#define SEXP_UNDEF MAKE_IMMEDIATE(4) sexp car, cdr;
#define SEXP_ERROR MAKE_IMMEDIATE(5) } pair;
#define SEXP_CLOSE MAKE_IMMEDIATE(6) /* internal use */ struct {
#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ sexp_uint_t length;
sexp *data;
} vector;
struct {
sexp_uint_t length;
char *data;
} string;
struct {
sexp_uint_t length;
char *data;
} symbol;
struct {
FILE *stream;
char *name;
sexp_uint_t line;
} port;
struct {
sexp kind, message, irritants, file, line;
} exception;
struct {
char flags;
sexp parent, bindings;
} env;
struct {
sexp_uint_t length;
unsigned char data[];
} bytecode;
struct {
char flags;
unsigned short num_args;
sexp bc, vars;
} procedure;
struct {
sexp proc, env;
} macro;
struct {
unsigned char op_class, code, num_args, flags,
arg1_type, arg2_type, inverse;
char *name;
sexp data, proc;
} opcode;
struct {
char code;
char *name;
} core;
} value;
};
#define sexp_sizeof_field(field) (sizeof((sexp)NULL)->value.field)
#define sexp_sizeof(field) (sizeof(struct sexp_struct)-sexp_sizeof_field(exception)+sexp_sizeof_field(field))
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) + SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(4)
#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5)
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
#define SEXP_NULLP(x) ((x) == SEXP_NULL) #define SEXP_NULLP(x) ((x) == SEXP_NULL)
#define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) #define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
@ -113,19 +169,22 @@ typedef long sexp_sint_t;
#define SEXP_CHARP(x) (((sexp_uint_t)(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_CHECK_TAG(x,t) (SEXP_POINTERP(x) && (x)->tag == (t))
#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_PAIRP(x) (SEXP_CHECK_TAG(x, SEXP_PAIR))
#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) #define SEXP_STRINGP(x) (SEXP_CHECK_TAG(x, SEXP_STRING))
#define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) #define SEXP_LSYMBOLP(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL))
#define SEXP_IPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_IPORT) #define SEXP_VECTORP(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR))
#define SEXP_OPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPORT) #define SEXP_FLONUMP(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM))
#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) #define SEXP_IPORTP(x) (SEXP_CHECK_TAG(x, SEXP_IPORT))
#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_OPORTP(x) (SEXP_CHECK_TAG(x, SEXP_OPORT))
#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) #define SEXP_EXCEPTIONP(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION))
#define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) #define SEXP_PROCEDUREP(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE))
#define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) #define SEXP_ENVP(x) (SEXP_CHECK_TAG(x, SEXP_ENV))
#define SEXP_MACROP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_MACRO) #define SEXP_BYTECODEP(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE))
#define SEXP_COREP(x) (SEXP_CHECK_TAG(x, SEXP_CORE))
#define SEXP_OPCODEP(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE))
#define SEXP_MACROP(x) (SEXP_CHECK_TAG(x, SEXP_MACRO))
#define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x))
@ -135,31 +194,70 @@ typedef long sexp_sint_t;
#define SEXP_DOTP(x) ((x)==sexp_the_dot_symbol) #define SEXP_DOTP(x) ((x)==sexp_the_dot_symbol)
#endif #endif
#define sexp_make_integer(n) ((sexp) (((long) n<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG)) #define sexp_make_integer(n) ((sexp) (((sexp_sint_t) n<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
#define sexp_unbox_integer(n) ((long) n>>SEXP_FIXNUM_BITS) #define sexp_unbox_integer(n) ((sexp_sint_t) n>>SEXP_FIXNUM_BITS)
#define sexp_make_character(n) ((sexp) (((long) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG)) #define sexp_make_character(n) ((sexp) (((sexp_sint_t) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
#define sexp_unbox_character(n) ((long) n>>SEXP_EXTENDED_BITS) #define sexp_unbox_character(n) ((sexp_sint_t) n>>SEXP_EXTENDED_BITS)
#define sexp_flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) #define sexp_flonum_value(f) ((f)->value.flonum)
#define sexp_vector_length(x) ((sexp_uint_t) x->data1) #define sexp_vector_length(x) ((x)->value.vector.length)
#define sexp_vector_data(x) ((sexp*) (((sexp)x)->data2)) #define sexp_vector_data(x) ((x)->value.vector.data)
#define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) #define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)])
#define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v)) #define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v))
#define sexp_procedure_num_args(x) (((procedure)x)->num_args) #define sexp_procedure_num_args(x) ((x)->value.procedure.num_args)
#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(((procedure)x)->flags) & 1) #define sexp_procedure_flags(x) ((x)->value.procedure.flags)
#define sexp_procedure_code(x) ((bytecode) ((procedure)x)->bc) #define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1)
#define sexp_procedure_vars(x) ((sexp) ((procedure)x)->vars) #define sexp_procedure_code(x) ((x)->value.procedure.bc)
#define sexp_procedure_vars(x) ((x)->value.procedure.vars)
#define sexp_string_length(x) ((sexp_uint_t) x->data1) #define sexp_string_length(x) ((x)->value.string.length)
#define sexp_string_data(x) ((char*) x->data2) #define sexp_string_data(x) ((x)->value.string.data)
#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) #define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)]))
#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v))
#define sexp_port_stream(p) ((FILE*) ((sexp)p)->data1) #define sexp_symbol_length(x) ((x)->value.symbol.length)
#define sexp_symbol_data(x) ((x)->value.symbol.data)
#define sexp_port_stream(p) ((p)->value.port.stream)
#define sexp_port_name(p) ((p)->value.port.name)
#define sexp_port_line(p) ((p)->value.port.line)
#define sexp_exception_kind(p) ((p)->value.exception.kind)
#define sexp_exception_message(p) ((p)->value.exception.message)
#define sexp_exception_irritants(p) ((p)->value.exception.irritants)
#define sexp_exception_file(p) ((p)->value.exception.file)
#define sexp_exception_line(p) ((p)->value.exception.line)
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
#define sexp_bytecode_data(x) ((x)->value.bytecode.data)
#define sexp_env_flags(x) ((x)->value.env.flags)
#define sexp_env_parent(x) ((x)->value.env.parent)
#define sexp_env_bindings(x) ((x)->value.env.bindings)
#define sexp_env_global_p(x) (! sexp_env_parent(x))
#define sexp_macro_proc(x) ((x)->value.macro.proc)
#define sexp_macro_env(x) ((x)->value.macro.env)
#define sexp_core_code(x) ((x)->value.core.code)
#define sexp_core_name(x) ((x)->value.core.name)
#define sexp_opcode_class(x) ((x)->value.opcode.op_class)
#define sexp_opcode_code(x) ((x)->value.opcode.code)
#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args)
#define sexp_opcode_flags(x) ((x)->value.opcode.flags)
#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type)
#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type)
#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse)
#define sexp_opcode_name(x) ((x)->value.opcode.name)
#define sexp_opcode_data(x) ((x)->value.opcode.data)
#define sexp_opcode_proc(x) ((x)->value.opcode.proc)
#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1)
#if USE_STRING_STREAMS #if USE_STRING_STREAMS
#if SEXP_BSD #if SEXP_BSD
@ -183,10 +281,6 @@ void sexp_write_string(sexp str, sexp port);
void sexp_printf(sexp port, sexp fmt, ...); void sexp_printf(sexp port, sexp fmt, ...);
#endif #endif
#define sexp_symbol_pointer(x) (x)
#define sexp_symbol_length(x) ((sexp_uint_t) (sexp_symbol_pointer(x)->data1))
#define sexp_symbol_data(x) ((char*) (sexp_symbol_pointer(x)->data2))
#define sexp_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)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)(((sexp_sint_t)a)-((sexp_sint_t)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)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)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)))
@ -198,8 +292,8 @@ void sexp_printf(sexp port, sexp fmt, ...);
#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) #define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL)))
#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) #define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL))))
#define SEXP_CAR(x) (((sexp)x)->data1) #define SEXP_CAR(x) ((x)->value.pair.car)
#define SEXP_CDR(x) (((sexp)x)->data2) #define SEXP_CDR(x) ((x)->value.pair.cdr)
#define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) #define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x)))
#define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) #define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x)))