Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

lowercasing

Browse source
This commit is contained in:
Alex Shinn 2009-03-15 21:23:39 +09:00
parent caa9a104dd
commit 2c37e682ef
4 changed files with 225 additions and 242 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -3,7 +3,7 @@
all: chibi-scheme all: chibi-scheme
CFLAGS=-g -fno-inline -Os CFLAGS=-g -fno-inline -save-temps -Os
GC_OBJ=./gc/gc.a GC_OBJ=./gc/gc.a

291
eval.c
View file

@ -27,9 +27,9 @@ static sexp env_cell(sexp e, sexp key) {
sexp ls; sexp ls;
do { do {
for (ls=sexp_env_bindings(e); 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 = sexp_env_parent(e); e = sexp_env_parent(e);
} while (e); } while (e);
@ -49,7 +49,7 @@ static int env_global_p (sexp e, sexp id) {
static void env_define(sexp 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 {
sexp_env_bindings(e) sexp_env_bindings(e)
= sexp_cons(sexp_cons(key, value), sexp_env_bindings(e)); = sexp_cons(sexp_cons(key, value), sexp_env_bindings(e));
@ -62,24 +62,24 @@ static sexp extend_env_closure (sexp e, sexp fv, int offset) {
e2->tag = SEXP_ENV; e2->tag = SEXP_ENV;
sexp_env_parent(e2) = e; sexp_env_parent(e2) = e;
sexp_env_bindings(e2) = 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--)
sexp_env_bindings(e2) sexp_env_bindings(e2)
= sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), = sexp_cons(sexp_cons(sexp_car(fv), sexp_make_integer(i)),
sexp_env_bindings(e2)); sexp_env_bindings(e2));
return e2; return e2;
} }
static int core_code (sexp 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 (sexp_core_code(SEXP_CDR(cell))); return (sexp_core_code(sexp_cdr(cell)));
} }
static sexp sexp_reverse_flatten_dot (sexp ls) { static sexp sexp_reverse_flatten_dot (sexp ls) {
sexp res; sexp res;
for (res=SEXP_NULL; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(SEXP_CAR(ls), res); res = sexp_cons(sexp_car(ls), res);
return (SEXP_NULLP(ls) ? res : sexp_cons(ls, res)); return (sexp_nullp(ls) ? res : sexp_cons(ls, res));
} }
static sexp sexp_flatten_dot (sexp ls) { static sexp sexp_flatten_dot (sexp ls) {
@ -180,37 +180,35 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp o1, o2, e2, cell; sexp o1, o2, e2, cell;
loop: loop:
if (SEXP_PAIRP(obj)) { if (sexp_pairp(obj)) {
if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if (sexp_symbolp(sexp_car(obj))) {
o1 = env_cell(e, SEXP_CAR(obj)); o1 = env_cell(e, sexp_car(obj));
if (! o1) { if (! o1) {
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
return; return;
} }
o1 = SEXP_CDR(o1); o1 = sexp_cdr(o1);
if (SEXP_COREP(o1)) { if (sexp_corep(o1)) {
switch (sexp_core_code(o1)) { 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(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 ((sexp_core_code(o1) == 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_caadr(obj), sexp_cdadr(obj), sexp_cddr(obj),
SEXP_CDR(SEXP_CADR(obj)),
SEXP_CDDR(obj),
bc, i, e, params, fv, sv, d, 0); bc, i, e, params, fv, sv, d, 0);
} else { } else {
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 (sexp_env_global_p(e)) { if (sexp_env_global_p(e)) {
emit(bc, i, OP_GLOBAL_SET); emit(bc, i, OP_GLOBAL_SET);
@ -221,89 +219,87 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
if (! o1) if (! o1)
errx(1, "define in bad position: %p", o2); errx(1, "define in bad position: %p", o2);
emit(bc, i, OP_STACK_SET); emit(bc, i, OP_STACK_SET);
emit_word(bc, i, sexp_unbox_integer(SEXP_CDR(o1))); emit_word(bc, i, sexp_unbox_integer(sexp_cdr(o1)));
} }
(*d)++; (*d)++;
break; break;
case CORE_SET: case CORE_SET:
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 (sexp_list_index(sv, SEXP_CADR(obj)) >= 0) { if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) {
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);
} else { } else {
emit(bc, i, OP_GLOBAL_SET); emit(bc, i, OP_GLOBAL_SET);
emit_word(bc, i, (sexp_uint_t) SEXP_CADR(obj)); emit_word(bc, i, (sexp_uint_t) sexp_cadr(obj));
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
} }
break; break;
case CORE_BEGIN: case CORE_BEGIN:
for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { for (o2 = sexp_cdr(obj); sexp_pairp(o2); o2 = sexp_cdr(o2)) {
if (SEXP_PAIRP(SEXP_CDR(o2))) { if (sexp_pairp(sexp_cdr(o2))) {
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0);
emit(bc, i, OP_DROP); emit(bc, i, OP_DROP);
(*d)--; (*d)--;
} else } else
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, tailp); analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, tailp);
} }
break; break;
case CORE_IF: case CORE_IF:
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0);
emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */
(*d)--; (*d)--;
tmp1 = *i; tmp1 = *i;
emit(bc, i, 0); emit(bc, i, 0);
analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, tailp); analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp);
emit(bc, i, OP_JUMP); emit(bc, i, OP_JUMP);
(*d)--; (*d)--;
tmp2 = *i; tmp2 = *i;
emit(bc, i, 0); emit(bc, i, 0);
/* ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /\* patch *\/ */
((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; ((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*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; ((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", sexp_core_code(o1)); errx(1, "unknown core form: %s", sexp_core_code(o1));
} }
} else if (SEXP_OPCODEP(o1)) { } else if (sexp_opcodep(o1)) {
analyze_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(o1, obj, e); obj = sexp_expand_macro(o1, obj, e);
goto loop; goto loop;
} else { } else {
/* general procedure call */ /* general procedure call */
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
} }
} else if (SEXP_PAIRP(SEXP_CAR(obj))) { } else if (sexp_pairp(sexp_car(obj))) {
#if USE_FAST_LET #if USE_FAST_LET
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))
&& (sexp_core_code(o2) == 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_cadar(obj)));
e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)+(tmp1-1)); e2 = extend_env_closure(e, sexp_cadar(obj), (*d)+(tmp1-1));
for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2))
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0);
params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); params = sexp_append(sexp_cadar(obj), params);
for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { for (o2=sexp_cddar(obj); sexp_pairp(o2); o2=sexp_cdr(o2)) {
if (SEXP_PAIRP(SEXP_CDR(o2))) { if (sexp_pairp(sexp_cdr(o2))) {
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, 0);
emit(bc, i, OP_DROP); emit(bc, i, OP_DROP);
(*d)--; (*d)--;
} else { } else {
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, tailp);
} }
} }
emit(bc, i, OP_STACK_SET); emit(bc, i, OP_STACK_SET);
@ -316,9 +312,9 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
/* computed application */ /* computed application */
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
} else { } else {
errx(1, "invalid operator: %s", SEXP_CAR(obj)); errx(1, "invalid operator: %s", sexp_car(obj));
} }
} else if (SEXP_SYMBOLP(obj)) { } else if (sexp_symbolp(obj)) {
analyze_var_ref(obj, bc, i, e, params, fv, sv, d); analyze_var_ref(obj, bc, i, e, params, fv, sv, d);
} else { /* literal */ } else { /* literal */
emit_push(bc, i, obj); emit_push(bc, i, obj);
@ -341,11 +337,11 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
case OPC_CONSTRUCTOR: case OPC_CONSTRUCTOR:
case OPC_ACCESSOR: case OPC_ACCESSOR:
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", sexp_opcode_name(op)); 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 (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) {
emit(bc, i, sexp_opcode_inverse(op)); emit(bc, i, sexp_opcode_inverse(op));
(*d)++; (*d)++;
@ -353,8 +349,8 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
emit(bc, i, sexp_opcode_code(op)); 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, sexp_opcode_code(op)); emit(bc, i, sexp_opcode_code(op));
(*d) -= (tmp1-1); (*d) -= (tmp1-1);
if (sexp_opcode_class(op) == OPC_ARITHMETIC) if (sexp_opcode_class(op) == OPC_ARITHMETIC)
@ -363,15 +359,15 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
} }
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 == sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) { 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) sexp_opcode_data(op)); 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, sexp_opcode_code(op)); emit(bc, i, sexp_opcode_code(op));
(*d) -= (tmp1-1); (*d) -= (tmp1-1);
break; break;
@ -380,11 +376,11 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); 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, sexp_opcode_data(op)); emit_push(bc, i, sexp_opcode_data(op));
emit(bc, i, sexp_opcode_code(op)); 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", sexp_opcode_class(op)); errx(1, "unknown opcode class: %d", sexp_opcode_class(op));
@ -402,9 +398,9 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
o1 = env_cell(e, obj); o1 = env_cell(e, obj);
fprintf(stderr, "compiling local ref: "); fprintf(stderr, "compiling local ref: ");
sexp_write(obj, cur_error_port); sexp_write(obj, cur_error_port);
fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(SEXP_CDR(o1))); fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(sexp_cdr(o1)));
emit(bc, i, OP_STACK_REF); emit(bc, i, OP_STACK_REF);
emit_word(bc, i, *d - sexp_unbox_integer(SEXP_CDR(o1))); emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(o1)));
} else if ((tmp = sexp_list_index(fv, obj)) >= 0) { } else if ((tmp = sexp_list_index(fv, obj)) >= 0) {
fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp);
emit(bc, i, OP_CLOSURE_REF); emit(bc, i, OP_CLOSURE_REF);
@ -416,7 +412,6 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
} }
(*d)++; (*d)++;
if (sexp_list_index(sv, obj) >= 0) { if (sexp_list_index(sv, obj) >= 0) {
/* fprintf(stderr, "mutable variable, fetching CAR\n"); */
emit(bc, i, OP_CAR); emit(bc, i, OP_CAR);
} }
} }
@ -424,15 +419,15 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp 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)));
/* push the arguments onto the stack */ /* push the arguments onto the stack */
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);
} }
/* push the operator onto the stack */ /* push the operator onto the stack */
analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d, 0); analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0);
/* maybe overwrite the current frame */ /* maybe overwrite the current frame */
if (tailp) { if (tailp) {
@ -450,24 +445,24 @@ void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
sexp free_vars (sexp 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)
|| (sexp_list_index(formals, obj) >= 0) || (sexp_list_index(formals, obj) >= 0)
|| (sexp_list_index(fv, obj) >= 0)) || (sexp_list_index(fv, obj) >= 0))
return fv; return fv;
else else
return sexp_cons(obj, fv); return sexp_cons(obj, fv);
} else if (SEXP_PAIRP(obj)) { } else if (sexp_pairp(obj)) {
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)
&& (sexp_core_code(SEXP_CDR(o1)) == 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);
} }
} }
while (SEXP_PAIRP(obj)) { while (sexp_pairp(obj)) {
fv = free_vars(e, formals, SEXP_CAR(obj), fv); fv = free_vars(e, formals, sexp_car(obj), fv);
obj = SEXP_CDR(obj); obj = sexp_cdr(obj);
} }
return fv; return fv;
} else { } else {
@ -477,25 +472,25 @@ sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) {
sexp set_vars (sexp 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 (sexp_core_code(SEXP_CDR(tmp)) == 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 (sexp_core_code(SEXP_CDR(tmp)) == 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);
return set_vars(e, formals, SEXP_CADDR(obj), sv); return set_vars(e, formals, sexp_caddr(obj), sv);
} }
} }
} }
while (SEXP_PAIRP(obj)) { while (sexp_pairp(obj)) {
sv = set_vars(e, formals, SEXP_CAR(obj), sv); sv = set_vars(e, formals, sexp_car(obj), sv);
obj = SEXP_CDR(obj); obj = sexp_cdr(obj);
} }
} }
return sv; return sv;
@ -520,8 +515,8 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
emit_push(bc, i, sexp_length(fv2)); emit_push(bc, i, sexp_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_push(bc, i, sexp_make_integer(k)); emit_push(bc, i, sexp_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);
@ -575,8 +570,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) {
sexp_bytecode_length(bc) = 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)) {
if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) { if ((j = sexp_list_index(sv2, sexp_car(ls)) >= 0)) {
emit_push(&bc, &i, SEXP_NULL); emit_push(&bc, &i, 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);
@ -589,51 +584,51 @@ sexp compile(sexp params, sexp obj, sexp 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 (sexp_env_parent(e)) { 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);
if (core == CORE_BEGIN) { if (core == CORE_BEGIN) {
obj = sexp_cons(SEXP_CAR(obj), obj = sexp_cons(sexp_car(obj),
sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); sexp_append(sexp_cdar(obj), sexp_cdr(obj)));
} else { } else {
if (core == CORE_DEFINE) { if (core == CORE_DEFINE) {
if (! define_ok) if (! define_ok)
errx(1, "definition in non-definition context: %p", obj); errx(1, "definition in non-definition context: %p", obj);
internals = sexp_cons(SEXP_PAIRP(SEXP_CADAR(obj)) internals = sexp_cons(sexp_pairp(sexp_cadar(obj))
? SEXP_CAR(SEXP_CADAR(obj)) : SEXP_CADAR(obj), ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj),
internals); internals);
} else { } else {
define_ok = 0; define_ok = 0;
} }
ls = sexp_cons(SEXP_CAR(obj), ls); ls = sexp_cons(sexp_car(obj), ls);
} }
} }
obj = sexp_reverse(ls); obj = sexp_reverse(ls);
j = sexp_unbox_integer(sexp_length(internals)); j = sexp_unbox_integer(sexp_length(internals));
if (SEXP_PAIRP(internals)) { if (sexp_pairp(internals)) {
/* sexp_write_string("internals: ", cur_error_port); */ /* sexp_write_string("internals: ", cur_error_port); */
/* sexp_write(internals, cur_error_port); */ /* sexp_write(internals, cur_error_port); */
/* sexp_write_string("\n", cur_error_port); */ /* sexp_write_string("\n", cur_error_port); */
e = extend_env_closure(e, internals, 2); e = extend_env_closure(e, internals, 2);
params = sexp_append(internals, params); params = sexp_append(internals, params);
for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls))
emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF);
d+=j; d+=j;
} }
} }
/* analyze body sequence */ /* analyze body sequence */
for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { for ( ; sexp_pairp(obj); obj=sexp_cdr(obj)) {
if (SEXP_PAIRP(SEXP_CDR(obj))) { if (sexp_pairp(sexp_cdr(obj))) {
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d, 0);
emit(&bc, &i, OP_DROP); emit(&bc, &i, OP_DROP);
d--; d--;
} else { } else {
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d,
(! done_p) && (! SEXP_PAIRP(internals)) (! done_p) && (! sexp_pairp(internals))
); );
} }
} }
if (SEXP_PAIRP(internals)) { if (sexp_pairp(internals)) {
emit(&bc, &i, OP_STACK_SET); emit(&bc, &i, OP_STACK_SET);
emit_word(&bc, &i, j+1); emit_word(&bc, &i, j+1);
for (j; j>0; j--) for (j; j>0; j--)
@ -689,7 +684,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
/* fprintf(stderr, " => "); */ /* fprintf(stderr, " => "); */
/* sexp_write(SEXP_CDR(tmp1), cur_error_port); */ /* sexp_write(SEXP_CDR(tmp1), cur_error_port); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
stack[top++]=SEXP_CDR(tmp1); stack[top++]=sexp_cdr(tmp1);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_GLOBAL_SET: case OP_GLOBAL_SET:
@ -767,43 +762,43 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_PAIRP: case OP_PAIRP:
stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_pairp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_NULLP: case OP_NULLP:
stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_nullp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_CHARP: case OP_CHARP:
stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_charp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_INTEGERP: case OP_INTEGERP:
stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_integerp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_SYMBOLP: case OP_SYMBOLP:
stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_symbolp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_STRINGP: case OP_STRINGP:
stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_stringp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_VECTORP: case OP_VECTORP:
stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_vectorp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_PROCEDUREP: case OP_PROCEDUREP:
stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_procedurep(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_IPORTP: case OP_IPORTP:
stack[top-1]=SEXP_IPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_iportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_OPORTP: case OP_OPORTP:
stack[top-1]=SEXP_OPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=sexp_oportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_EOFP: case OP_EOFP:
stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_CAR: case OP_CAR:
/* print_stack(stack, top); */ /* print_stack(stack, top); */
if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair"));
stack[top-1]=SEXP_CAR(stack[top-1]); break; stack[top-1]=sexp_car(stack[top-1]); break;
case OP_CDR: case OP_CDR:
if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair"));
stack[top-1]=SEXP_CDR(stack[top-1]); break; stack[top-1]=sexp_cdr(stack[top-1]); break;
case OP_SET_CAR: case OP_SET_CAR:
if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair"));
SEXP_CAR(stack[top-1]) = stack[top-2]; sexp_car(stack[top-1]) = stack[top-2];
stack[top-2]=SEXP_UNDEF; stack[top-2]=SEXP_UNDEF;
top--; top--;
break; break;
case OP_SET_CDR: case OP_SET_CDR:
if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair"));
SEXP_CDR(stack[top-1]) = stack[top-2]; sexp_cdr(stack[top-1]) = stack[top-2];
stack[top-2]=SEXP_UNDEF; stack[top-2]=SEXP_UNDEF;
top--; top--;
break; break;
@ -873,11 +868,11 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
i = sexp_unbox_integer(((sexp*)ip)[0]); i = sexp_unbox_integer(((sexp*)ip)[0]);
tmp1 = stack[top-1]; tmp1 = stack[top-1];
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(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: ");
sexp_write(tmp1, cur_error_port); sexp_write(tmp1, cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
@ -935,14 +930,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
tmp2 = stack[top-2]; tmp2 = stack[top-2];
i = sexp_unbox_integer(sexp_length(tmp2)); i = sexp_unbox_integer(sexp_length(tmp2));
top += (i-2); top += (i-2);
for ( ; SEXP_PAIRP(tmp2); tmp2=SEXP_CDR(tmp2), top--) for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
stack[top-1] = SEXP_CAR(tmp2); stack[top-1] = sexp_car(tmp2);
top += i+1; top += i+1;
ip -= sizeof(sexp); ip -= sizeof(sexp);
goto make_call; goto make_call;
case OP_CALLCC: case OP_CALLCC:
tmp1 = stack[top-1]; tmp1 = stack[top-1];
if (! SEXP_PROCEDUREP(tmp1)) if (! sexp_procedurep(tmp1))
errx(2, "non-procedure application: %p", tmp1); errx(2, "non-procedure application: %p", tmp1);
stack[top] = sexp_make_integer(1); stack[top] = sexp_make_integer(1);
stack[top+1] = sexp_make_integer(ip); stack[top+1] = sexp_make_integer(ip);
@ -979,7 +974,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
sexp_write_string("ERROR: ", cur_error_port); sexp_write_string("ERROR: ", cur_error_port);
sexp_write(stack[top-1], cur_error_port); sexp_write(stack[top-1], cur_error_port);
sexp_write_string("\n", cur_error_port); sexp_write_string("\n", cur_error_port);
tmp1 = SEXP_CDR(exception_handler_cell); tmp1 = sexp_cdr(exception_handler_cell);
stack[top-1] = SEXP_UNDEF; stack[top-1] = SEXP_UNDEF;
stack[top] = (sexp) 1; stack[top] = (sexp) 1;
stack[top+1] = sexp_make_integer(ip+4); stack[top+1] = sexp_make_integer(ip+4);
@ -1019,7 +1014,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) {
ip += ((signed char*)ip)[0]; ip += ((signed char*)ip)[0];
break; break;
case OP_DISPLAY: case OP_DISPLAY:
if (SEXP_STRINGP(stack[top-1])) { if (sexp_stringp(stack[top-1])) {
sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]); sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]);
break; break;
} }
@ -1098,7 +1093,7 @@ sexp sexp_close_port (sexp port) {
sexp sexp_load (sexp source) { sexp sexp_load (sexp source) {
sexp obj, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); sexp obj, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
int closep = 0; int closep = 0;
if (SEXP_STRINGP(source)) { if (sexp_stringp(source)) {
source = sexp_open_input_file(source); source = sexp_open_input_file(source);
closep = 1; closep = 1;
} }

98
sexp.c
View file

@ -53,11 +53,11 @@ static int symbol_table_count = 0;
void sexp_free (sexp obj) { void sexp_free (sexp obj) {
int len, i; int len, i;
sexp *elts; sexp *elts;
if (SEXP_POINTERP(obj)) { if (sexp_pointerp(obj)) {
switch (obj->tag) { switch (obj->tag) {
case SEXP_PAIR: case SEXP_PAIR:
sexp_free(SEXP_CAR(obj)); sexp_free(sexp_car(obj));
sexp_free(SEXP_CDR(obj)); sexp_free(sexp_cdr(obj));
break; break;
case SEXP_VECTOR: case SEXP_VECTOR:
len = sexp_vector_length(obj); len = sexp_vector_length(obj);
@ -81,60 +81,58 @@ void sexp_free (sexp obj) {
sexp sexp_cons(sexp head, sexp tail) { sexp sexp_cons(sexp head, sexp tail) {
sexp pair = SEXP_ALLOC(sexp_sizeof(pair)); sexp pair = SEXP_ALLOC(sexp_sizeof(pair));
pair->tag = SEXP_PAIR; pair->tag = SEXP_PAIR;
/* pair->data1 = (void*) head; */ sexp_car(pair) = head;
/* pair->data2 = (void*) tail; */ sexp_cdr(pair) = tail;
SEXP_CAR(pair) = head;
SEXP_CDR(pair) = tail;
return pair; return pair;
} }
int sexp_listp (sexp obj) { int sexp_listp (sexp obj) {
while (SEXP_PAIRP(obj)) while (sexp_pairp(obj))
obj = SEXP_CDR(obj); obj = sexp_cdr(obj);
return (obj == SEXP_NULL); return (obj == SEXP_NULL);
} }
int sexp_list_index (sexp ls, sexp elt) { int sexp_list_index (sexp ls, sexp elt) {
int i=0; int i=0;
while (SEXP_PAIRP(ls)) { while (sexp_pairp(ls)) {
if (SEXP_CAR(ls) == elt) if (sexp_car(ls) == elt)
return i; return i;
ls = SEXP_CDR(ls); ls = sexp_cdr(ls);
i++; i++;
} }
return -1; return -1;
} }
sexp sexp_memq (sexp x, sexp ls) { sexp sexp_memq (sexp x, sexp ls) {
while (SEXP_PAIRP(ls)) while (sexp_pairp(ls))
if (x == SEXP_CAR(ls)) if (x == sexp_car(ls))
return ls; return ls;
else else
ls = SEXP_CDR(ls); ls = sexp_cdr(ls);
return SEXP_FALSE; return SEXP_FALSE;
} }
sexp sexp_assq (sexp x, sexp ls) { sexp sexp_assq (sexp x, sexp ls) {
while (SEXP_PAIRP(ls)) while (sexp_pairp(ls))
if (x == SEXP_CAAR(ls)) if (x == sexp_caar(ls))
return ls; return ls;
else else
ls = SEXP_CDR(ls); ls = sexp_cdr(ls);
return SEXP_FALSE; return SEXP_FALSE;
} }
sexp sexp_lset_diff(sexp a, sexp b) { sexp sexp_lset_diff(sexp a, sexp b) {
sexp res = SEXP_NULL; sexp res = SEXP_NULL;
for ( ; SEXP_PAIRP(a); a=SEXP_CDR(a)) for ( ; sexp_pairp(a); a=sexp_cdr(a))
if (! sexp_list_index(b, SEXP_CAR(a)) >= 0) if (! sexp_list_index(b, sexp_car(a)) >= 0)
res = sexp_cons(SEXP_CAR(a), res); res = sexp_cons(sexp_car(a), res);
return res; return res;
} }
sexp sexp_reverse(sexp ls) { sexp sexp_reverse(sexp ls) {
sexp res = SEXP_NULL; sexp res = SEXP_NULL;
for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(SEXP_CAR(ls), res); res = sexp_cons(sexp_car(ls), res);
return res; return res;
} }
@ -142,29 +140,29 @@ sexp sexp_nreverse(sexp ls) {
sexp a, b, tmp; sexp a, b, tmp;
if (ls == SEXP_NULL) { if (ls == SEXP_NULL) {
return ls; return ls;
} else if (! SEXP_PAIRP(ls)) { } else if (! sexp_pairp(ls)) {
return SEXP_ERROR; return SEXP_ERROR;
} else { } else {
b=ls; b = ls;
a=SEXP_CDR(ls); a = sexp_cdr(ls);
SEXP_CDR(b) = SEXP_NULL; sexp_cdr(b) = SEXP_NULL;
for ( ; SEXP_PAIRP(a); b=a, a=tmp) { for ( ; sexp_pairp(a); b=a, a=tmp) {
tmp=SEXP_CDR(a); tmp = sexp_cdr(a);
SEXP_CDR(a) = b; sexp_cdr(a) = b;
} }
return b; return b;
} }
} }
sexp sexp_append(sexp a, sexp b) { sexp sexp_append(sexp a, sexp b) {
for (a=sexp_reverse(a); SEXP_PAIRP(a); a=SEXP_CDR(a)) for (a=sexp_reverse(a); sexp_pairp(a); a=sexp_cdr(a))
b = sexp_cons(SEXP_CAR(a), b); b = sexp_cons(sexp_car(a), b);
return b; return b;
} }
sexp sexp_length(sexp ls) { sexp sexp_length(sexp ls) {
sexp_uint_t res=0; sexp_uint_t res=0;
for ( ; SEXP_PAIRP(ls); res++, ls=SEXP_CDR(ls)) for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls))
; ;
return sexp_make_integer(res); return sexp_make_integer(res);
} }
@ -184,8 +182,6 @@ sexp sexp_make_string(char *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->data2 = (void*) mystr; */
sexp_string_length(s) = len; sexp_string_length(s) = len;
sexp_string_data(s) = mystr; sexp_string_data(s) = mystr;
return s; return s;
@ -250,8 +246,6 @@ sexp sexp_intern(char *str) {
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->data2 = (void*) mystr; */
sexp_symbol_length(sym) = len; sexp_symbol_length(sym) = len;
sexp_symbol_data(sym) = mystr; sexp_symbol_data(sym) = mystr;
symbol_table[cell] = sym; symbol_table[cell] = sym;
@ -268,8 +262,6 @@ sexp sexp_make_vector(sexp len, sexp dflt) {
x[i] = dflt; x[i] = dflt;
} }
v->tag = SEXP_VECTOR; v->tag = SEXP_VECTOR;
/* v->data1 = (void*) clen; */
/* v->data2 = (void*) x; */
sexp_vector_length(v) = clen; sexp_vector_length(v) = clen;
sexp_vector_data(v) = x; sexp_vector_data(v) = x;
return v; return v;
@ -279,8 +271,8 @@ sexp sexp_list_to_vector(sexp ls) {
sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF); sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF);
sexp *elts = sexp_vector_data(vec); sexp *elts = sexp_vector_data(vec);
int i; int i;
for (i=0, x=ls; SEXP_PAIRP(x); i++, x=SEXP_CDR(x)) for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x))
elts[i] = SEXP_CAR(x); elts[i] = sexp_car(x);
return vec; return vec;
} }
@ -335,7 +327,6 @@ int sstream_close(void *vec) {
sexp sexp_make_input_port(FILE* in) { sexp sexp_make_input_port(FILE* in) {
sexp p = SEXP_ALLOC(sexp_sizeof(port)); sexp p = SEXP_ALLOC(sexp_sizeof(port));
p->tag = SEXP_IPORT; p->tag = SEXP_IPORT;
/* p->data1 = in; */
sexp_port_stream(p) = in; sexp_port_stream(p) = in;
return p; return p;
} }
@ -343,7 +334,6 @@ sexp sexp_make_input_port(FILE* in) {
sexp sexp_make_output_port(FILE* out) { sexp sexp_make_output_port(FILE* out) {
sexp p = SEXP_ALLOC(sexp_sizeof(port)); sexp p = SEXP_ALLOC(sexp_sizeof(port));
p->tag = SEXP_OPORT; p->tag = SEXP_OPORT;
/* p->data1 = out; */
sexp_port_stream(p) = out; sexp_port_stream(p) = out;
return p; return p;
} }
@ -371,16 +361,16 @@ void sexp_write (sexp obj, sexp out) {
if (! obj) { if (! obj) {
sexp_write_string("#<null>", out); sexp_write_string("#<null>", out);
} else if (SEXP_POINTERP(obj)) { } else if (sexp_pointerp(obj)) {
switch (obj->tag) { switch (obj->tag) {
case SEXP_PAIR: case SEXP_PAIR:
sexp_write_char('(', out); sexp_write_char('(', out);
sexp_write(SEXP_CAR(obj), out); sexp_write(sexp_car(obj), out);
for (x=SEXP_CDR(obj); SEXP_PAIRP(x); x=SEXP_CDR(x)) { for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
sexp_write_char(' ', out); sexp_write_char(' ', out);
sexp_write(SEXP_CAR(x), out); sexp_write(sexp_car(x), out);
} }
if (! SEXP_NULLP(x)) { if (! sexp_nullp(x)) {
sexp_write_string(" . ", out); sexp_write_string(" . ", out);
sexp_write(x, out); sexp_write(x, out);
} }
@ -438,15 +428,15 @@ void sexp_write (sexp obj, sexp out) {
sexp_write_char('"', out); sexp_write_char('"', out);
break; break;
} }
} else if (SEXP_INTEGERP(obj)) { } else if (sexp_integerp(obj)) {
sexp_printf(out, "%d", sexp_unbox_integer(obj)); sexp_printf(out, "%d", sexp_unbox_integer(obj));
} else if (SEXP_CHARP(obj)) { } else if (sexp_charp(obj)) {
if (33 <= sexp_unbox_character(obj) < 127) { if (33 <= sexp_unbox_character(obj) < 127) {
sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); sexp_printf(out, "#\\%c", sexp_unbox_character(obj));
} else { } else {
sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj));
} }
} else if (SEXP_SYMBOLP(obj)) { } else if (sexp_symbolp(obj)) {
#if USE_HUFF_SYMS #if USE_HUFF_SYMS
if (((sexp_uint_t)obj&7)==7) { if (((sexp_uint_t)obj&7)==7) {
@ -564,7 +554,7 @@ sexp sexp_read_number(sexp in, int base) {
return SEXP_ERROR; return SEXP_ERROR;
} }
tmp = sexp_read_float_tail(in, res); tmp = sexp_read_float_tail(in, res);
if (negativep && SEXP_FLONUMP(tmp)) if (negativep && sexp_flonump(tmp))
sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp); sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp);
return tmp; return tmp;
} else { } else {
@ -634,7 +624,7 @@ sexp sexp_read_raw (sexp in) {
} else { } else {
tmp2 = res; tmp2 = res;
res = sexp_nreverse(res); res = sexp_nreverse(res);
SEXP_CDR(tmp2) = tmp; sexp_cdr(tmp2) = tmp;
return res; return res;
} }
} }
@ -794,8 +784,6 @@ void sexp_init() {
the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing");
the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector)); 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->data2 = 0; */
sexp_vector_length(the_empty_vector) = 0; sexp_vector_length(the_empty_vector) = 0;
sexp_vector_data(the_empty_vector) = NULL; sexp_vector_data(the_empty_vector) = NULL;
} }

76
sexp.h
View file

@ -162,31 +162,31 @@ struct sexp_struct {
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* 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)
#define SEXP_INTEGERP(x) (((sexp_uint_t)(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) (((sexp_uint_t)(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) (((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_CHECK_TAG(x,t) (SEXP_POINTERP(x) && (x)->tag == (t)) #define SEXP_CHECK_TAG(x,t) (sexp_pointerp(x) && (x)->tag == (t))
#define SEXP_PAIRP(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) #define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR))
#define SEXP_STRINGP(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) #define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING))
#define SEXP_LSYMBOLP(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) #define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL))
#define SEXP_VECTORP(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) #define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR))
#define SEXP_FLONUMP(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) #define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM))
#define SEXP_IPORTP(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) #define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT))
#define SEXP_OPORTP(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) #define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT))
#define SEXP_EXCEPTIONP(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) #define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION))
#define SEXP_PROCEDUREP(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) #define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE))
#define SEXP_ENVP(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) #define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV))
#define SEXP_BYTECODEP(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) #define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE))
#define SEXP_COREP(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) #define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE))
#define SEXP_OPCODEP(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) #define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE))
#define SEXP_MACROP(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) #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))
#if USE_HUFF_SYMS #if USE_HUFF_SYMS
#define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<<SEXP_IMMEDIATE_BITS)+SEXP_ISYMBOL_TAG)) #define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<<SEXP_IMMEDIATE_BITS)+SEXP_ISYMBOL_TAG))
@ -292,25 +292,25 @@ 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) ((x)->value.pair.car) #define sexp_car(x) ((x)->value.pair.car)
#define SEXP_CDR(x) ((x)->value.pair.cdr) #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)))
#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) #define sexp_cdar(x) (sexp_cdr(sexp_car(x)))
#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) #define sexp_cddr(x) (sexp_cdr(sexp_cdr(x)))
#define SEXP_CAAAR(x) (SEXP_CAR(SEXP_CAAR(x))) #define sexp_caaar(x) (sexp_car(sexp_caar(x)))
#define SEXP_CAADR(x) (SEXP_CAR(SEXP_CADR(x))) #define sexp_caadr(x) (sexp_car(sexp_cadr(x)))
#define SEXP_CADAR(x) (SEXP_CAR(SEXP_CDAR(x))) #define sexp_cadar(x) (sexp_car(sexp_cdar(x)))
#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) #define sexp_caddr(x) (sexp_car(sexp_cddr(x)))
#define SEXP_CDAAR(x) (SEXP_CDR(SEXP_CAAR(x))) #define sexp_cdaar(x) (sexp_cdr(sexp_caar(x)))
#define SEXP_CDADR(x) (SEXP_CDR(SEXP_CADR(x))) #define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x)))
#define SEXP_CDDAR(x) (SEXP_CDR(SEXP_CDAR(x))) #define sexp_cddar(x) (sexp_cdr(sexp_cdar(x)))
#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) #define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x)))
#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) #define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x)))
#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
sexp sexp_cons(sexp head, sexp tail); sexp sexp_cons(sexp head, sexp tail);
int sexp_listp(sexp obj); int sexp_listp(sexp obj);