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

variadic args working

Browse source
This commit is contained in:
Alex Shinn 2009-03-09 23:41:17 +09:00
parent 7795b773aa
commit 160149c97b
4 changed files with 137 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

138
eval.c
View file

@ -21,20 +21,18 @@ static sexp continuation_resumer;
#endif #endif
/********************** environment utilities ***************************/ /********************** environment utilities ***************************/
static sexp env_cell(env e, sexp key) { static sexp env_cell(env e, sexp key) {
sexp ls, res=NULL; sexp ls;
do { do {
for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
if (SEXP_CAAR(ls) == key) { if (SEXP_CAAR(ls) == key)
res = SEXP_CAR(ls); return SEXP_CAR(ls);
break;
}
}
e = e->parent; e = e->parent;
} while (e && ! res); } while (e);
return res; return NULL;
} }
static int env_global_p (env e, sexp id) { static int env_global_p (env e, sexp id) {
@ -62,13 +60,23 @@ static env extend_env_closure (env e, sexp fv) {
e2->tag = SEXP_ENV; e2->tag = SEXP_ENV;
e2->parent = e; e2->parent = e;
e2->bindings = SEXP_NULL; e2->bindings = SEXP_NULL;
for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++)
e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)),
e2->bindings); e2->bindings);
}
return e2; return e2;
} }
static sexp sexp_reverse_flatten_dot (sexp ls) {
sexp res;
for (res=SEXP_NULL; SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
res = sexp_cons(SEXP_CAR(ls), res);
return (SEXP_NULLP(ls) ? res : sexp_cons(ls, res));
}
static sexp sexp_flatten_dot (sexp ls) {
return sexp_nreverse(sexp_reverse_flatten_dot(ls));
}
/************************* bytecode utilities ***************************/ /************************* bytecode utilities ***************************/
static void shrink_bcode(bytecode *bc, unsigned int i) { static void shrink_bcode(bytecode *bc, unsigned int i) {
@ -112,13 +120,15 @@ static void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) {
#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) #define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj))
static sexp sexp_make_procedure(sexp bc, sexp vars) { static sexp sexp_make_procedure(char flags, unsigned short num_args,
sexp proc = SEXP_NEW(); sexp bc, sexp vars) {
if (! proc) return SEXP_ERROR; procedure proc = SEXP_ALLOC(sizeof(struct procedure));
proc->tag = SEXP_PROCEDURE; proc->tag = SEXP_PROCEDURE;
proc->data1 = (void*) bc; proc->flags = flags;
proc->data2 = (void*) vars; proc->num_args = num_args;
return proc; proc->bc = (bytecode) bc;
proc->vars = vars;
return (sexp) proc;
} }
/************************* the compiler ***************************/ /************************* the compiler ***************************/
@ -178,14 +188,14 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
emit(bc, i, OP_JUMP); emit(bc, i, OP_JUMP);
tmp2 = *i; tmp2 = *i;
emit(bc, i, 0); emit(bc, i, 0);
((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /* patch */
if (SEXP_PAIRP(SEXP_CDDDR(obj))) { if (SEXP_PAIRP(SEXP_CDDDR(obj))) {
analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d);
} else { } else {
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
(*d)++; (*d)++;
} }
((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /* patch */
break; break;
case CORE_QUOTE: case CORE_QUOTE:
emit_push(bc, i, SEXP_CADR(obj)); emit_push(bc, i, SEXP_CADR(obj));
@ -205,9 +215,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
case OPC_CONSTRUCTOR: case OPC_CONSTRUCTOR:
case OPC_ACCESSOR: case OPC_ACCESSOR:
case OPC_GENERIC: case OPC_GENERIC:
if (SEXP_NULLP(SEXP_CDR(obj))) { tmp1 = sexp_length(SEXP_CDR(obj));
if (tmp1 == 0) {
errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); errx(1, "opcode with no arguments: %s", ((opcode)o1)->name);
} else if (SEXP_NULLP(SEXP_CDDR(obj))) { } else if (tmp1 == 1) {
if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) {
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
emit(bc, i, ((opcode)o1)->op_inverse); emit(bc, i, ((opcode)o1)->op_inverse);
@ -225,7 +236,11 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
} }
emit(bc, i, ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name);
(*d) -= sexp_length(SEXP_CDDR(obj)); (*d) -= (tmp1-1);
if (((opcode)o1)->op_class == OPC_ARITHMETIC) {
for (tmp1-=2; tmp1>0; tmp1--)
emit(bc, i, ((opcode)o1)->op_name);
}
} }
break; break;
case OPC_IO: case OPC_IO:
@ -384,13 +399,18 @@ 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, unsigned int *i, env e, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, sexp sv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL); sexp obj, ls, flat_formals, fv2;
env e2 = extend_env_closure(e, formals); env e2;
int k; int k;
flat_formals = sexp_flatten_dot(formals);
fv2 = free_vars(e, flat_formals, body, SEXP_NULL);
e2 = extend_env_closure(e, flat_formals);
fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); fprintf(stderr, "%d free-vars\n", sexp_length(fv2));
sexp_write(fv2, cur_error_port); sexp_write(fv2, cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
obj = (sexp) compile(formals, body, e2, fv2, sv, 0); /* compile the body with respect to the new params */
obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0);
/* push the closed vars */
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
emit_push(bc, i, sexp_make_integer(sexp_length(fv2))); emit_push(bc, i, sexp_make_integer(sexp_length(fv2)));
emit(bc, i, OP_MAKE_VECTOR); emit(bc, i, OP_MAKE_VECTOR);
@ -404,7 +424,10 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
emit(bc, i, OP_DROP); emit(bc, i, OP_DROP);
(*d)--; (*d)--;
} }
/* push the additional procedure info and make the closure */
emit_push(bc, i, obj); emit_push(bc, i, obj);
emit_push(bc, i, sexp_make_integer(sexp_length(formals)));
emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1));
emit(bc, i, OP_MAKE_PROCEDURE); emit(bc, i, OP_MAKE_PROCEDURE);
} }
@ -412,13 +435,11 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
unsigned int i = 0, j, d = 0; unsigned int i = 0, j, d = 0;
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE);
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls;
/* fprintf(stderr, "set-vars: "); sexp_write(sv2, stderr); fprintf(stderr, "\n"); */
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = INIT_BCODE_SIZE; bc->len = INIT_BCODE_SIZE;
/* fprintf(stderr, "analyzing\n"); */ /* 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)) {
/* fprintf(stderr, "consing mutable var\n"); */
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);
@ -429,20 +450,19 @@ 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);
/* analyze body sequence */
for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) {
/* fprintf(stderr, "loop: "); sexp_write(obj, stderr); fprintf(stderr, "\n"); */
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d);
if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP);
} }
/* return */
emit(&bc, &i, done_p ? OP_DONE : OP_RET); emit(&bc, &i, done_p ? OP_DONE : OP_RET);
shrink_bcode(&bc, i); shrink_bcode(&bc, i);
print_bytecode(bc); /* print_bytecode(bc); */
disasm(bc); disasm(bc);
return bc; return bc;
} }
/************************ library functions ***************************/
/*********************** the virtual machine **************************/ /*********************** the virtual machine **************************/
sexp sexp_save_stack(sexp *stack, unsigned int to) { sexp sexp_save_stack(sexp *stack, unsigned int to) {
@ -468,7 +488,7 @@ unsigned int sexp_restore_stack(sexp saved, sexp *current) {
sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
unsigned char *ip=bc->data; unsigned char *ip=bc->data;
sexp cp=SEXP_UNDEF, tmp1, tmp2; sexp cp=SEXP_UNDEF, tmp1, tmp2;
int i; int i, j, k;
loop: loop:
switch (*ip++) { switch (*ip++) {
@ -517,8 +537,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top-=2; top-=2;
break; break;
case OP_MAKE_PROCEDURE: case OP_MAKE_PROCEDURE:
stack[top-2]=sexp_make_procedure(stack[top-1], stack[top-2]); stack[top-4]=sexp_make_procedure((int) stack[top-1], (int) stack[top-2], stack[top-3], stack[top-4]);
top--; top-=3;
break; break;
case OP_MAKE_VECTOR: case OP_MAKE_VECTOR:
stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]); stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]);
@ -633,10 +653,37 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_CALL: case OP_CALL:
/* fprintf(stderr, "CALL\n"); */ /* fprintf(stderr, "CALL\n"); */
i = (sexp_uint_t) ((sexp*)ip)[0]; i = (sexp_uint_t) ((sexp*)ip)[0];
i = sexp_unbox_integer(i);
tmp1 = stack[top-1]; tmp1 = stack[top-1];
if (! SEXP_PROCEDUREP(tmp1)) if (! SEXP_PROCEDUREP(tmp1))
errx(2, "non-procedure application: %p", tmp1); sexp_raise(sexp_intern("non-procedure-application"));
stack[top-1] = (sexp) i; j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1));
if (j < 0)
sexp_raise(sexp_intern("not-enough-args"));
if (j > 0) {
if (sexp_procedure_variadic_p(tmp1)) {
stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL);
for (k=top-i; k<top-(i-j)-1; k++)
stack[top-i-1] = sexp_cons(stack[k], stack[top-i-1]);
for ( ; k<top; k++)
stack[k-j+1] = stack[k];
top -= (j-1);
i-=(j-1);
} else {
fprintf(stderr, "got: %d, expected: %d\n", i, sexp_procedure_num_args(tmp1));
sexp_raise(sexp_intern("too-many-args"));
}
} else if (sexp_procedure_variadic_p(tmp1)) {
/* shift stack, set extra arg to null */
print_stack(stack, top);
for (k=top; k>=top-i; k--)
stack[k] = stack[k-1];
stack[top-i-1] = SEXP_NULL;
top++;
i++;
print_stack(stack, top);
}
stack[top-1] = sexp_make_integer(i);
stack[top] = sexp_make_integer(ip+4); stack[top] = sexp_make_integer(ip+4);
stack[top+1] = cp; stack[top+1] = cp;
top+=2; top+=2;
@ -679,7 +726,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/* fprintf(stderr, "saved: ", top); */ /* fprintf(stderr, "saved: ", top); */
/* sexp_write(tmp2, cur_error_port); */ /* sexp_write(tmp2, cur_error_port); */
/* fprintf(stderr, "\n", top); */ /* fprintf(stderr, "\n", top); */
stack[top-1] = sexp_make_procedure(continuation_resumer, stack[top-1] = sexp_make_procedure(0, (int) sexp_make_integer(1),
continuation_resumer,
sexp_vector(1, tmp2)); sexp_vector(1, tmp2));
top+=3; top+=3;
bc = sexp_procedure_code(tmp1); bc = sexp_procedure_code(tmp1);
@ -732,17 +780,17 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top-=3; top-=3;
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); /* fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); */
if (stack[--top] == SEXP_FALSE) { if (stack[--top] == SEXP_FALSE) {
fprintf(stderr, "test passed, jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); /* fprintf(stderr, "test failed, jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */
ip += ((signed char*)ip)[0]; ip += ((signed char*)ip)[0];
} else { } else {
fprintf(stderr, "test failed, not jumping\n"); /* fprintf(stderr, "test passed, not jumping\n"); */
ip++; ip++;
} }
break; break;
case OP_JUMP: case OP_JUMP:
fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); /* fprintf(stderr, "jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */
ip += ((signed char*)ip)[0]; ip += ((signed char*)ip)[0];
break; break;
case OP_DISPLAY: case OP_DISPLAY:
@ -835,8 +883,8 @@ _OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!"),
_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"),
_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!"),
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"),
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"),
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"),
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"),
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"), _OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"),
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"), _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"),
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"),
@ -847,7 +895,7 @@ _OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "="),
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"),
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"),
_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"),
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, 0, "make-procedure"), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure"),
_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"), _OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"),
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?"), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "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?"),
@ -962,7 +1010,7 @@ int main (int argc, char **argv) {
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((sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); err_handler = sexp_make_procedure(0, 0, (sexp)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);

8
eval.h
View file

@ -29,6 +29,14 @@ typedef struct bytecode {
unsigned char data[]; unsigned char data[];
} *bytecode; } *bytecode;
typedef struct procedure {
char tag;
char flags;
unsigned short num_args;
bytecode bc;
sexp vars;
} *procedure;
typedef struct env { typedef struct env {
char tag; char tag;
struct env *parent; struct env *parent;

50
sexp.c
View file

@ -35,6 +35,8 @@ static char sexp_separators[] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */
}; };
#define digit_value(c) (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10))
static int is_separator(int c) { static int is_separator(int c) {
/* return (!((c-9)&(~3))) | (~(c^4)); */ /* return (!((c-9)&(~3))) | (~(c^4)); */
return 0<c && c<0x60 && sexp_separators[c]; return 0<c && c<0x60 && sexp_separators[c];
@ -78,7 +80,6 @@ void sexp_free (sexp obj) {
sexp sexp_cons(sexp head, sexp tail) { sexp sexp_cons(sexp head, sexp tail) {
sexp pair = SEXP_NEW(); sexp pair = SEXP_NEW();
if (! pair) return SEXP_ERROR;
pair->tag = SEXP_PAIR; pair->tag = SEXP_PAIR;
pair->data1 = (void*) head; pair->data1 = (void*) head;
pair->data2 = (void*) tail; pair->data2 = (void*) tail;
@ -182,7 +183,6 @@ unsigned long sexp_length(sexp ls) {
sexp sexp_make_flonum(double f) { sexp sexp_make_flonum(double f) {
sexp x = SEXP_NEW(); sexp x = SEXP_NEW();
if (! x) return SEXP_ERROR;
x->tag = SEXP_FLONUM; x->tag = SEXP_FLONUM;
sexp_flonum_value(x) = f; sexp_flonum_value(x) = f;
return x; return x;
@ -190,10 +190,8 @@ sexp sexp_make_flonum(double f) {
sexp sexp_make_string(char *str) { sexp sexp_make_string(char *str) {
sexp s = SEXP_NEW(); sexp s = SEXP_NEW();
if (! s) return SEXP_ERROR;
unsigned long len = strlen(str); unsigned long len = strlen(str);
char *mystr = SEXP_ALLOC(len+1); char *mystr = SEXP_ALLOC(len+1);
if (! mystr) { SEXP_FREE(s); return SEXP_ERROR; }
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;
@ -255,10 +253,8 @@ sexp sexp_intern(char *str) {
} }
sym = SEXP_NEW(); sym = SEXP_NEW();
if (! sym) { return SEXP_ERROR; }
len = strlen(str); len = strlen(str);
mystr = SEXP_ALLOC(len+1); mystr = SEXP_ALLOC(len+1);
if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; }
memcpy(mystr, str, len+1); memcpy(mystr, str, len+1);
mystr[len]=0; mystr[len]=0;
sym->tag = SEXP_SYMBOL; sym->tag = SEXP_SYMBOL;
@ -273,9 +269,7 @@ sexp sexp_make_vector(unsigned int len, sexp dflt) {
sexp v, *x; sexp v, *x;
if (! len) return the_empty_vector; if (! len) return the_empty_vector;
v = SEXP_NEW(); v = SEXP_NEW();
if (v == NULL) return SEXP_ERROR;
x = (void*) SEXP_ALLOC(len*sizeof(sexp)); x = (void*) SEXP_ALLOC(len*sizeof(sexp));
if (x == NULL) return SEXP_ERROR;
for (i=0; i<len; i++) { for (i=0; i<len; i++) {
x[i] = dflt; x[i] = dflt;
} }
@ -286,9 +280,7 @@ sexp sexp_make_vector(unsigned int len, sexp dflt) {
} }
sexp sexp_list_to_vector(sexp ls) { sexp sexp_list_to_vector(sexp ls) {
sexp vec = sexp_make_vector(sexp_length(ls), SEXP_FALSE); sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF);
if (vec == SEXP_ERROR) return vec;
sexp x;
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))
@ -297,8 +289,7 @@ sexp sexp_list_to_vector(sexp ls) {
} }
sexp sexp_vector(int count, ...) { sexp sexp_vector(int count, ...) {
sexp vec = sexp_make_vector(count, SEXP_FALSE); sexp vec = sexp_make_vector(count, SEXP_UNDEF);
if (vec == SEXP_ERROR) return vec;
sexp *elts = sexp_vector_data(vec); sexp *elts = sexp_vector_data(vec);
va_list ap; va_list ap;
int i; int i;
@ -347,7 +338,6 @@ 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_NEW();
if (p == NULL) return SEXP_ERROR;
p->tag = SEXP_IPORT; p->tag = SEXP_IPORT;
p->data1 = in; p->data1 = in;
return p; return p;
@ -355,7 +345,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_NEW(); sexp p = SEXP_NEW();
if (p == NULL) return SEXP_ERROR;
p->tag = SEXP_OPORT; p->tag = SEXP_OPORT;
p->data1 = out; p->data1 = out;
return p; return p;
@ -547,7 +536,7 @@ sexp sexp_read_float_tail(sexp in, long whole) {
double res = 0.0, scale=0.1; double res = 0.0, scale=0.1;
int c; int c;
for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1)
res += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale; res += digit_value(c)*scale;
sexp_push_char(c, in); sexp_push_char(c, in);
return sexp_make_flonum(whole + res); return sexp_make_flonum(whole + res);
} }
@ -564,7 +553,7 @@ sexp sexp_read_number(sexp in, int base) {
} }
for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in))
res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10)); res = res * base + digit_value(c);
if (c=='.') { if (c=='.') {
if (base != 10) { if (base != 10) {
fprintf(stderr, "decimal found in non-base 10"); fprintf(stderr, "decimal found in non-base 10");
@ -633,7 +622,7 @@ sexp sexp_read_raw (sexp in) {
return SEXP_ERROR; return SEXP_ERROR;
} else { } else {
tmp = sexp_read_raw(in); tmp = sexp_read_raw(in);
if (sexp_read(in) != SEXP_CLOSE) { if (sexp_read_raw(in) != SEXP_CLOSE) {
fprintf(stderr, "sexp: multiple tokens in dotted tail\n"); fprintf(stderr, "sexp: multiple tokens in dotted tail\n");
sexp_free(res); sexp_free(res);
return SEXP_ERROR; return SEXP_ERROR;
@ -681,6 +670,31 @@ sexp sexp_read_raw (sexp in) {
case ';': case ';':
sexp_read_raw(in); sexp_read_raw(in);
goto scan_loop; goto scan_loop;
case '\\':
c1 = sexp_read_char(in);
c2 = sexp_read_char(in);
if (c2 == EOF || is_separator(c2)) {
sexp_push_char(c2, in);
res = sexp_make_character(c1);
} else if ((c1 == 'x' || c1 == 'X') && isxdigit(c2)) {
c1 = sexp_read_char(in);
res = sexp_make_character(16 * digit_value(c2) + digit_value(c1));
} else {
str = sexp_read_symbol(in, c1);
if (strcasecmp(str, "space") == 0)
res = sexp_make_character(' ');
else if (strcasecmp(str, "newline") == 0)
res = sexp_make_character('\r');
else if (strcasecmp(str, "return") == 0)
res = sexp_make_character('\r');
else if (strcasecmp(str, "tab") == 0)
res = sexp_make_character('\t');
else {
fprintf(stderr, "unknown character name: '%s'\n", str);
res = SEXP_ERROR;
}
}
break;
case '(': case '(':
sexp_push_char(c1, in); sexp_push_char(c1, in);
res = sexp_read(in); res = sexp_read(in);

6
sexp.h
View file

@ -146,8 +146,10 @@ typedef long sexp_sint_t;
#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_code(x) ((bytecode) ((sexp)x)->data1) #define sexp_procedure_num_args(x) (((procedure)x)->num_args)
#define sexp_procedure_vars(x) ((sexp) ((sexp)x)->data2) #define sexp_procedure_variadic_p(x) (sexp_unbox_integer(((procedure)x)->flags) & 1)
#define sexp_procedure_code(x) ((bytecode) ((procedure)x)->bc)
#define sexp_procedure_vars(x) ((sexp) ((procedure)x)->vars)
#define sexp_string_length(x) ((sexp_uint_t) x->data1) #define sexp_string_length(x) ((sexp_uint_t) x->data1)
#define sexp_string_data(x) ((char*) x->data2) #define sexp_string_data(x) ((char*) x->data2)