mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
variadic args working
This commit is contained in:
Alex Shinn
parent
7795b773aa
commit
160149c97b
4 changed files with 137 additions and 65 deletions
138
eval.c
138
eval.c
|
|
@ -21,20 +21,18 @@ static sexp continuation_resumer;
|
|||
#endif
|
||||
|
||||
/********************** environment utilities ***************************/
|
||||
|
||||
static sexp env_cell(env e, sexp key) {
|
||||
sexp ls, res=NULL;
|
||||
sexp ls;
|
||||
|
||||
do {
|
||||
for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) {
|
||||
if (SEXP_CAAR(ls) == key) {
|
||||
res = SEXP_CAR(ls);
|
||||
break;
|
||||
}
|
||||
}
|
||||
for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls))
|
||||
if (SEXP_CAAR(ls) == key)
|
||||
return SEXP_CAR(ls);
|
||||
e = e->parent;
|
||||
} while (e && ! res);
|
||||
} while (e);
|
||||
|
||||
return res;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
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->parent = e;
|
||||
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);
|
||||
}
|
||||
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 ***************************/
|
||||
|
||||
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))
|
||||
|
||||
static sexp sexp_make_procedure(sexp bc, sexp vars) {
|
||||
sexp proc = SEXP_NEW();
|
||||
if (! proc) return SEXP_ERROR;
|
||||
static sexp sexp_make_procedure(char flags, unsigned short num_args,
|
||||
sexp bc, sexp vars) {
|
||||
procedure proc = SEXP_ALLOC(sizeof(struct procedure));
|
||||
proc->tag = SEXP_PROCEDURE;
|
||||
proc->data1 = (void*) bc;
|
||||
proc->data2 = (void*) vars;
|
||||
return proc;
|
||||
proc->flags = flags;
|
||||
proc->num_args = num_args;
|
||||
proc->bc = (bytecode) bc;
|
||||
proc->vars = vars;
|
||||
return (sexp) proc;
|
||||
}
|
||||
|
||||
/************************* the compiler ***************************/
|
||||
|
|
@ -178,14 +188,14 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
|
|||
emit(bc, i, OP_JUMP);
|
||||
tmp2 = *i;
|
||||
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))) {
|
||||
analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d);
|
||||
} else {
|
||||
emit_push(bc, i, SEXP_UNDEF);
|
||||
(*d)++;
|
||||
}
|
||||
((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */
|
||||
((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /* patch */
|
||||
break;
|
||||
case CORE_QUOTE:
|
||||
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_ACCESSOR:
|
||||
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);
|
||||
} else if (SEXP_NULLP(SEXP_CDDR(obj))) {
|
||||
} else if (tmp1 == 1) {
|
||||
if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) {
|
||||
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
|
||||
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);
|
||||
}
|
||||
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;
|
||||
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,
|
||||
bytecode *bc, unsigned int *i, env e,
|
||||
sexp params, sexp fv, sexp sv, unsigned int *d) {
|
||||
sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL);
|
||||
env e2 = extend_env_closure(e, formals);
|
||||
sexp obj, ls, flat_formals, fv2;
|
||||
env e2;
|
||||
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));
|
||||
sexp_write(fv2, cur_error_port);
|
||||
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_make_integer(sexp_length(fv2)));
|
||||
emit(bc, i, OP_MAKE_VECTOR);
|
||||
|
|
@ -404,7 +424,10 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
|
|||
emit(bc, i, OP_DROP);
|
||||
(*d)--;
|
||||
}
|
||||
/* push the additional procedure info and make the closure */
|
||||
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);
|
||||
}
|
||||
|
||||
|
|
@ -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;
|
||||
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE);
|
||||
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls;
|
||||
/* fprintf(stderr, "set-vars: "); sexp_write(sv2, stderr); fprintf(stderr, "\n"); */
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
bc->len = INIT_BCODE_SIZE;
|
||||
/* fprintf(stderr, "analyzing\n"); */
|
||||
/* box mutable vars */
|
||||
for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) {
|
||||
if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) {
|
||||
/* fprintf(stderr, "consing mutable var\n"); */
|
||||
emit_push(&bc, &i, SEXP_NULL);
|
||||
emit(&bc, &i, OP_STACK_REF);
|
||||
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);
|
||||
/* analyze body sequence */
|
||||
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);
|
||||
if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP);
|
||||
}
|
||||
/* return */
|
||||
emit(&bc, &i, done_p ? OP_DONE : OP_RET);
|
||||
shrink_bcode(&bc, i);
|
||||
print_bytecode(bc);
|
||||
/* print_bytecode(bc); */
|
||||
disasm(bc);
|
||||
return bc;
|
||||
}
|
||||
|
||||
/************************ library functions ***************************/
|
||||
|
||||
/*********************** the virtual machine **************************/
|
||||
|
||||
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) {
|
||||
unsigned char *ip=bc->data;
|
||||
sexp cp=SEXP_UNDEF, tmp1, tmp2;
|
||||
int i;
|
||||
int i, j, k;
|
||||
|
||||
loop:
|
||||
switch (*ip++) {
|
||||
|
|
@ -517,8 +537,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
top-=2;
|
||||
break;
|
||||
case OP_MAKE_PROCEDURE:
|
||||
stack[top-2]=sexp_make_procedure(stack[top-1], stack[top-2]);
|
||||
top--;
|
||||
stack[top-4]=sexp_make_procedure((int) stack[top-1], (int) stack[top-2], stack[top-3], stack[top-4]);
|
||||
top-=3;
|
||||
break;
|
||||
case OP_MAKE_VECTOR:
|
||||
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:
|
||||
/* fprintf(stderr, "CALL\n"); */
|
||||
i = (sexp_uint_t) ((sexp*)ip)[0];
|
||||
i = sexp_unbox_integer(i);
|
||||
tmp1 = stack[top-1];
|
||||
if (! SEXP_PROCEDUREP(tmp1))
|
||||
errx(2, "non-procedure application: %p", tmp1);
|
||||
stack[top-1] = (sexp) i;
|
||||
sexp_raise(sexp_intern("non-procedure-application"));
|
||||
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+1] = cp;
|
||||
top+=2;
|
||||
|
|
@ -679,7 +726,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
/* fprintf(stderr, "saved: ", top); */
|
||||
/* sexp_write(tmp2, cur_error_port); */
|
||||
/* 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));
|
||||
top+=3;
|
||||
bc = sexp_procedure_code(tmp1);
|
||||
|
|
@ -732,17 +780,17 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
top-=3;
|
||||
break;
|
||||
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) {
|
||||
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];
|
||||
} else {
|
||||
fprintf(stderr, "test failed, not jumping\n");
|
||||
/* fprintf(stderr, "test passed, not jumping\n"); */
|
||||
ip++;
|
||||
}
|
||||
break;
|
||||
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];
|
||||
break;
|
||||
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_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!"),
|
||||
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"),
|
||||
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"),
|
||||
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"),
|
||||
|
|
@ -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_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_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_NULLP, 1, 0, 0, 0, 0, "null?"),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?"),
|
||||
|
|
@ -962,7 +1010,7 @@ int main (int argc, char **argv) {
|
|||
i = 0;
|
||||
emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF);
|
||||
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*");
|
||||
env_define(e, err_handler_sym, err_handler);
|
||||
exception_handler_cell = env_cell(e, err_handler_sym);
|
||||
|
|
|
|||
8
eval.h
8
eval.h
|
|
@ -29,6 +29,14 @@ typedef struct bytecode {
|
|||
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;
|
||||
|
|
|
|||
50
sexp.c
50
sexp.c
|
|
@ -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_ */
|
||||
};
|
||||
|
||||
#define digit_value(c) (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10))
|
||||
|
||||
static int is_separator(int c) {
|
||||
/* return (!((c-9)&(~3))) | (~(c^4)); */
|
||||
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 pair = SEXP_NEW();
|
||||
if (! pair) return SEXP_ERROR;
|
||||
pair->tag = SEXP_PAIR;
|
||||
pair->data1 = (void*) head;
|
||||
pair->data2 = (void*) tail;
|
||||
|
|
@ -182,7 +183,6 @@ unsigned long sexp_length(sexp ls) {
|
|||
|
||||
sexp sexp_make_flonum(double f) {
|
||||
sexp x = SEXP_NEW();
|
||||
if (! x) return SEXP_ERROR;
|
||||
x->tag = SEXP_FLONUM;
|
||||
sexp_flonum_value(x) = f;
|
||||
return x;
|
||||
|
|
@ -190,10 +190,8 @@ sexp sexp_make_flonum(double f) {
|
|||
|
||||
sexp sexp_make_string(char *str) {
|
||||
sexp s = SEXP_NEW();
|
||||
if (! s) return SEXP_ERROR;
|
||||
unsigned long len = strlen(str);
|
||||
char *mystr = SEXP_ALLOC(len+1);
|
||||
if (! mystr) { SEXP_FREE(s); return SEXP_ERROR; }
|
||||
memcpy(mystr, str, len+1);
|
||||
s->tag = SEXP_STRING;
|
||||
s->data1 = (void*) len;
|
||||
|
|
@ -255,10 +253,8 @@ sexp sexp_intern(char *str) {
|
|||
}
|
||||
|
||||
sym = SEXP_NEW();
|
||||
if (! sym) { return SEXP_ERROR; }
|
||||
len = strlen(str);
|
||||
mystr = SEXP_ALLOC(len+1);
|
||||
if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; }
|
||||
memcpy(mystr, str, len+1);
|
||||
mystr[len]=0;
|
||||
sym->tag = SEXP_SYMBOL;
|
||||
|
|
@ -273,9 +269,7 @@ sexp sexp_make_vector(unsigned int len, sexp dflt) {
|
|||
sexp v, *x;
|
||||
if (! len) return the_empty_vector;
|
||||
v = SEXP_NEW();
|
||||
if (v == NULL) return SEXP_ERROR;
|
||||
x = (void*) SEXP_ALLOC(len*sizeof(sexp));
|
||||
if (x == NULL) return SEXP_ERROR;
|
||||
for (i=0; i<len; i++) {
|
||||
x[i] = dflt;
|
||||
}
|
||||
|
|
@ -286,9 +280,7 @@ sexp sexp_make_vector(unsigned int len, sexp dflt) {
|
|||
}
|
||||
|
||||
sexp sexp_list_to_vector(sexp ls) {
|
||||
sexp vec = sexp_make_vector(sexp_length(ls), SEXP_FALSE);
|
||||
if (vec == SEXP_ERROR) return vec;
|
||||
sexp x;
|
||||
sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF);
|
||||
sexp *elts = sexp_vector_data(vec);
|
||||
int i;
|
||||
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 vec = sexp_make_vector(count, SEXP_FALSE);
|
||||
if (vec == SEXP_ERROR) return vec;
|
||||
sexp vec = sexp_make_vector(count, SEXP_UNDEF);
|
||||
sexp *elts = sexp_vector_data(vec);
|
||||
va_list ap;
|
||||
int i;
|
||||
|
|
@ -347,7 +338,6 @@ int sstream_close(void *vec) {
|
|||
|
||||
sexp sexp_make_input_port(FILE* in) {
|
||||
sexp p = SEXP_NEW();
|
||||
if (p == NULL) return SEXP_ERROR;
|
||||
p->tag = SEXP_IPORT;
|
||||
p->data1 = in;
|
||||
return p;
|
||||
|
|
@ -355,7 +345,6 @@ sexp sexp_make_input_port(FILE* in) {
|
|||
|
||||
sexp sexp_make_output_port(FILE* out) {
|
||||
sexp p = SEXP_NEW();
|
||||
if (p == NULL) return SEXP_ERROR;
|
||||
p->tag = SEXP_OPORT;
|
||||
p->data1 = out;
|
||||
return p;
|
||||
|
|
@ -547,7 +536,7 @@ sexp sexp_read_float_tail(sexp in, long whole) {
|
|||
double res = 0.0, scale=0.1;
|
||||
int c;
|
||||
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);
|
||||
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))
|
||||
res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10));
|
||||
res = res * base + digit_value(c);
|
||||
if (c=='.') {
|
||||
if (base != 10) {
|
||||
fprintf(stderr, "decimal found in non-base 10");
|
||||
|
|
@ -633,7 +622,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
return SEXP_ERROR;
|
||||
} else {
|
||||
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");
|
||||
sexp_free(res);
|
||||
return SEXP_ERROR;
|
||||
|
|
@ -681,6 +670,31 @@ sexp sexp_read_raw (sexp in) {
|
|||
case ';':
|
||||
sexp_read_raw(in);
|
||||
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 '(':
|
||||
sexp_push_char(c1, in);
|
||||
res = sexp_read(in);
|
||||
|
|
|
|||
6
sexp.h
6
sexp.h
|
|
@ -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_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_vars(x) ((sexp) ((sexp)x)->data2)
|
||||
#define sexp_procedure_num_args(x) (((procedure)x)->num_args)
|
||||
#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_data(x) ((char*) x->data2)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue