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

switching to ports instead of streams

Browse source
This commit is contained in:
Alex Shinn 2009-03-04 23:27:36 +09:00
parent eafc5f2136
commit 598e71c950
6 changed files with 464 additions and 342 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config.h
View file

@ -5,4 +5,5 @@
#define USE_BOEHM 1 #define USE_BOEHM 1
#define USE_HUFF_SYMS 1 #define USE_HUFF_SYMS 1
#define USE_DEBUG 1 #define USE_DEBUG 1
#define USE_STRING_STREAMS 1

4
debug.c
View file

@ -31,7 +31,7 @@ void disasm (bytecode bc) {
case OP_GLOBAL_SET: case OP_GLOBAL_SET:
case OP_CALL: case OP_CALL:
case OP_PUSH: case OP_PUSH:
write_sexp(stderr, ((sexp*)ip)[0]); sexp_write(((sexp*)ip)[0], cur_error_port);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_JUMP: case OP_JUMP:
@ -75,7 +75,7 @@ void print_stack (sexp *stack, int top) {
for (i=0; i<top; i++) { for (i=0; i<top; i++) {
fprintf(stderr, " %02d: ", i); fprintf(stderr, " %02d: ", i);
fflush(stderr); fflush(stderr);
write_sexp(stderr, stack[i]); sexp_write(stack[i], cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
} }
} }

165
eval.c
View file

@ -1,11 +1,15 @@
/* eval.c -- evaluator library implementation */ /* eval.c -- evaluator library implementation */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include "eval.h" #include "eval.h"
/************************************************************************/ /************************************************************************/
static int scheme_initialized_p = 0;
static sexp cur_input_port, cur_output_port, cur_error_port;
static struct core_form core_forms[] = { static struct core_form core_forms[] = {
{SEXP_CORE, "define", CORE_DEFINE}, {SEXP_CORE, "define", CORE_DEFINE},
{SEXP_CORE, "set!", CORE_SET}, {SEXP_CORE, "set!", CORE_SET},
@ -63,6 +67,22 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, "eof-object?", 0),
/********************** environment utilities ***************************/ /********************** environment utilities ***************************/
sexp sexp_set_car(sexp obj, sexp val) {
if (SEXP_PAIRP(obj))
return SEXP_CAR(obj) = val;
else {
sexp_debug("error: set-car! not a pair: ", obj);
return SEXP_ERROR;
}
}
sexp sexp_set_cdr(sexp obj, sexp val) {
if (SEXP_PAIRP(obj))
return SEXP_CDR(obj) = val;
else
return SEXP_ERROR;
}
sexp env_cell(env e, sexp key) { sexp env_cell(env e, sexp key) {
sexp ls, res=NULL; sexp ls, res=NULL;
@ -81,7 +101,7 @@ sexp env_cell(env e, sexp key) {
int env_global_p (env e, sexp id) { int env_global_p (env e, sexp id) {
while (e->parent) { while (e->parent) {
if (assq(id, e->bindings) != SEXP_FALSE) if (sexp_assq(id, e->bindings) != SEXP_FALSE)
return 0; return 0;
else else
e = e->parent; e = e->parent;
@ -94,7 +114,7 @@ void env_define(env e, sexp key, sexp value) {
if (cell) { if (cell) {
SEXP_CDR(cell) = value; SEXP_CDR(cell) = value;
} else { } else {
e->bindings = cons(cons(key, value), e->bindings); e->bindings = sexp_cons(sexp_cons(key, value), e->bindings);
} }
} }
@ -105,7 +125,8 @@ env extend_env_closure (env e, sexp fv) {
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 = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings); e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)),
e2->bindings);
} }
return e2; return e2;
} }
@ -117,10 +138,10 @@ env make_standard_env() {
e->parent = NULL; e->parent = NULL;
e->bindings = SEXP_NULL; e->bindings = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) {
env_define(e, intern(core_forms[i].name), (sexp)(&core_forms[i])); env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i]));
} }
for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) {
env_define(e, intern(opcodes[i].name), (sexp)(&opcodes[i])); env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i]));
} }
return e; return e;
} }
@ -168,7 +189,7 @@ 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))
sexp make_procedure(sexp bc, sexp vars) { sexp sexp_make_procedure(sexp bc, sexp vars) {
sexp proc = SEXP_NEW(); sexp proc = SEXP_NEW();
if (! proc) return SEXP_ERROR; if (! proc) return SEXP_ERROR;
proc->tag = SEXP_PROCEDURE; proc->tag = SEXP_PROCEDURE;
@ -271,12 +292,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
} }
} else { } else {
for (o2 = 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)) {
/* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
} }
emit(bc, i, ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name);
(*d) -= length(SEXP_CDDR(obj)); (*d) -= sexp_length(SEXP_CDDR(obj));
} }
break; break;
default: default:
@ -311,14 +333,14 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, sexp sv, unsigned int *d) { sexp params, sexp fv, sexp sv, unsigned int *d) {
int tmp; int tmp;
/* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ /* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */
/* write_sexp(stderr, sv); */ /* sexp_write(sv, stderr); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
if ((tmp = list_index(params, obj)) >= 0) { if ((tmp = sexp_list_index(params, obj)) >= 0) {
/* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */
emit(bc, i, OP_STACK_REF); emit(bc, i, OP_STACK_REF);
emit_word(bc, i, tmp + *d + 4); emit_word(bc, i, tmp + *d + 4);
(*d)++; (*d)++;
} else if ((tmp = list_index(fv, obj)) >= 0) { } else if ((tmp = 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);
emit_word(bc, i, tmp); emit_word(bc, i, tmp);
@ -329,7 +351,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
emit_word(bc, i, (sexp_uint_t) obj); emit_word(bc, i, (sexp_uint_t) obj);
(*d)++; (*d)++;
} }
if (list_index(sv, obj) >= 0) { if (sexp_list_index(sv, obj) >= 0) {
/* fprintf(stderr, "mutable variable, fetching CAR\n"); */ /* fprintf(stderr, "mutable variable, fetching CAR\n"); */
emit(bc, i, OP_CAR); emit(bc, i, OP_CAR);
} }
@ -338,10 +360,10 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
void analyze_app (sexp obj, bytecode *bc, unsigned int *i, void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
env e, sexp params, sexp fv, sexp sv, unsigned int *d) { env e, sexp params, sexp fv, sexp sv, unsigned int *d) {
sexp o1; sexp o1;
unsigned long len = length(SEXP_CDR(obj)); unsigned long len = sexp_length(SEXP_CDR(obj));
/* push the arguments onto the stack */ /* push the arguments onto the stack */
for (o1 = 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); analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d);
} }
@ -350,18 +372,18 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
/* make the call */ /* make the call */
emit(bc, i, OP_CALL); emit(bc, i, OP_CALL);
emit_word(bc, i, (sexp_uint_t) make_integer(len)); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
} }
sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
sexp o1; sexp o1;
if (SEXP_SYMBOLP(obj)) { if (SEXP_SYMBOLP(obj)) {
if (env_global_p(e, obj) if (env_global_p(e, obj)
|| (list_index(formals, obj) >= 0) || (sexp_list_index(formals, obj) >= 0)
|| (list_index(fv, obj) >= 0)) || (sexp_list_index(fv, obj) >= 0))
return fv; return fv;
else else
return 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)))
@ -388,12 +410,12 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) {
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 (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) {
formals = 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 (((core_form)SEXP_CDR(tmp))->code == CORE_SET
&& (list_index(formals, SEXP_CADR(obj)) >= 0) && (sexp_list_index(formals, SEXP_CADR(obj)) >= 0)
&& ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { && ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) {
sv = 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);
} }
} }
@ -412,17 +434,17 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL); sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL);
env e2 = extend_env_closure(e, formals); env e2 = extend_env_closure(e, formals);
int k; int k;
fprintf(stderr, "%d free-vars\n", length(fv2)); fprintf(stderr, "%d free-vars\n", sexp_length(fv2));
write_sexp(stderr, fv2); sexp_write(fv2, cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
obj = (sexp) compile(formals, body, e2, fv2, sv, 0); obj = (sexp) compile(formals, body, e2, fv2, sv, 0);
emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, SEXP_UNDEF);
emit_push(bc, i, make_integer(length(fv2))); emit_push(bc, i, sexp_make_integer(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, 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);
emit(bc, i, OP_VECTOR_SET); emit(bc, i, OP_VECTOR_SET);
@ -437,12 +459,12 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
unsigned int i = 0, j, d = 0; unsigned int i = 0, j, d = 0;
bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE);
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls;
/* fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); */ /* fprintf(stderr, "set-vars: "); 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"); */ /* fprintf(stderr, "analyzing\n"); */
for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) {
if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) {
/* fprintf(stderr, "consing mutable var\n"); */ /* 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);
@ -453,9 +475,9 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
emit(&bc, &i, OP_DROP); emit(&bc, &i, OP_DROP);
} }
} }
sv = append(sv2, sv); sv = sexp_append(sv2, sv);
for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) {
/* fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); */ /* fprintf(stderr, "loop: "); 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);
} }
@ -483,7 +505,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_GLOBAL_REF: case OP_GLOBAL_REF:
/* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */ /* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */
/* fflush(stderr); */ /* fflush(stderr); */
/* write_sexp(stderr, ((sexp*)ip)[0]); */ /* sexp_write(stderr, ((sexp*)ip)[0]); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
tmp = env_cell(e, ((sexp*)ip)[0]); tmp = env_cell(e, ((sexp*)ip)[0]);
stack[top++]=SEXP_CDR(tmp); stack[top++]=SEXP_CDR(tmp);
@ -492,7 +514,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_GLOBAL_SET: case OP_GLOBAL_SET:
/* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */ /* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */
/* fflush(stderr); */ /* fflush(stderr); */
/* write_sexp(stderr, ((sexp*)ip)[0]); */ /* sexp_write(stderr, ((sexp*)ip)[0]); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
env_define(e, ((sexp*)ip)[0], stack[--top]); env_define(e, ((sexp*)ip)[0], stack[--top]);
ip += sizeof(sexp); ip += sizeof(sexp);
@ -501,7 +523,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */ /* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */
/* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */ /* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */
/* fflush(stderr); */ /* fflush(stderr); */
/* write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ /* sexp_write(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]];
ip += sizeof(sexp); ip += sizeof(sexp);
@ -515,35 +537,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
/* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */ /* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */
/* fflush(stderr); */ /* fflush(stderr); */
/* write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); */ /* sexp_write(stderr, vector_ref(cp,((sexp*)ip)[0])); */
/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "\n"); */
stack[top++]=vector_ref(cp,((sexp*)ip)[0]); stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_VECTOR_REF: case OP_VECTOR_REF:
stack[top-2]=vector_ref(stack[top-1], stack[top-2]); stack[top-2]=sexp_vector_ref(stack[top-1], stack[top-2]);
top--; top--;
break; break;
case OP_VECTOR_SET: case OP_VECTOR_SET:
vector_set(stack[top-1], stack[top-2], stack[top-3]); sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]);
stack[top-3]=SEXP_UNDEF; stack[top-3]=SEXP_UNDEF;
top-=2; top-=2;
break; break;
case OP_STRING_REF: case OP_STRING_REF:
stack[top-2]=string_ref(stack[top-1], stack[top-2]); stack[top-2]=sexp_string_ref(stack[top-1], stack[top-2]);
top--; top--;
break; break;
case OP_STRING_SET: case OP_STRING_SET:
string_set(stack[top-1], stack[top-2], stack[top-3]); sexp_string_set(stack[top-1], stack[top-2], stack[top-3]);
stack[top-3]=SEXP_UNDEF; stack[top-3]=SEXP_UNDEF;
top-=2; top-=2;
break; break;
case OP_MAKE_PROCEDURE: case OP_MAKE_PROCEDURE:
stack[top-2]=make_procedure(stack[top-1], stack[top-2]); stack[top-2]=sexp_make_procedure(stack[top-1], stack[top-2]);
top--; top--;
break; break;
case OP_MAKE_VECTOR: case OP_MAKE_VECTOR:
stack[top-2]=make_vector(unbox_integer(stack[top-1]), stack[top-2]); stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]);
top--; top--;
break; break;
case OP_PUSH: case OP_PUSH:
@ -590,23 +612,23 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE;
break; break;
case OP_CAR: case OP_CAR:
stack[top-1]=car(stack[top-1]); stack[top-1]=sexp_car(stack[top-1]);
break; break;
case OP_CDR: case OP_CDR:
stack[top-1]=cdr(stack[top-1]); stack[top-1]=sexp_cdr(stack[top-1]);
break; break;
case OP_SET_CAR: case OP_SET_CAR:
set_car(stack[top-1], stack[top-2]); sexp_set_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:
set_cdr(stack[top-1], stack[top-2]); sexp_set_cdr(stack[top-1], stack[top-2]);
stack[top-2]=SEXP_UNDEF; stack[top-2]=SEXP_UNDEF;
top--; top--;
break; break;
case OP_CONS: case OP_CONS:
stack[top-2]=cons(stack[top-1], stack[top-2]); stack[top-2]=sexp_cons(stack[top-1], stack[top-2]);
top--; top--;
break; break;
case OP_ADD: case OP_ADD:
@ -657,16 +679,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
if (! SEXP_PROCEDUREP(tmp)) if (! SEXP_PROCEDUREP(tmp))
errx(2, "non-procedure application: %p", tmp); errx(2, "non-procedure application: %p", tmp);
stack[top-1] = (sexp) i; stack[top-1] = (sexp) i;
stack[top] = make_integer(ip+4); stack[top] = sexp_make_integer(ip+4);
stack[top+1] = cp; stack[top+1] = cp;
top+=2; top+=2;
bc = procedure_code(tmp); bc = sexp_procedure_code(tmp);
/* print_bytecode(bc); */ /* print_bytecode(bc); */
/* disasm(bc); */ /* disasm(bc); */
ip = bc->data; ip = bc->data;
cp = procedure_vars(tmp); cp = sexp_procedure_vars(tmp);
fprintf(stderr, "... calling procedure at %p\ncp: ", ip); fprintf(stderr, "... calling procedure at %p\ncp: ", ip);
write_sexp(stderr, cp); /* sexp_write(cp, stderr); */
fprintf(stderr, "\n"); fprintf(stderr, "\n");
/* fprintf(stderr, "stack at %d\n", top); */ /* fprintf(stderr, "stack at %d\n", top); */
/* print_stack(stack, top); */ /* print_stack(stack, top); */
@ -688,14 +710,14 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_RET: case OP_RET:
fprintf(stderr, "returning @ %d: ", top-1); fprintf(stderr, "returning @ %d: ", top-1);
fflush(stderr); fflush(stderr);
write_sexp(stderr, stack[top-1]); sexp_write(stack[top-1], cur_error_port);
fprintf(stderr, "...\n"); fprintf(stderr, "...\n");
/* print_stack(stack, top); */ /* print_stack(stack, top); */
/* top-1 */ /* top-1 */
/* stack: args ... n ip result */ /* stack: args ... n ip result */
cp = stack[top-2]; cp = stack[top-2];
ip = (unsigned char*) unbox_integer(stack[top-3]); ip = (unsigned char*) sexp_unbox_integer(stack[top-3]);
i = unbox_integer(stack[top-4]); i = sexp_unbox_integer(stack[top-4]);
stack[top-i-4] = stack[top-1]; stack[top-i-4] = stack[top-1];
top = top-i-3; top = top-i-3;
fprintf(stderr, "... done returning\n"); fprintf(stderr, "... done returning\n");
@ -703,7 +725,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
case OP_DONE: case OP_DONE:
fprintf(stderr, "finally returning @ %d: ", top-1); fprintf(stderr, "finally returning @ %d: ", top-1);
fflush(stderr); fflush(stderr);
write_sexp(stderr, stack[top-1]); sexp_write(stack[top-1], cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
goto end_loop; goto end_loop;
default: default:
@ -722,7 +744,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) {
bytecode bc; bytecode bc;
bc = compile(SEXP_NULL, 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);
} }
@ -733,12 +755,22 @@ sexp eval(sexp obj, env e) {
return res; return res;
} }
void scheme_init() {
if (! scheme_initialized_p) {
scheme_initialized_p = 1;
sexp_init();
cur_input_port = sexp_make_input_port(stdin);
cur_output_port = sexp_make_output_port(stdout);
cur_error_port = sexp_make_output_port(stderr);
}
}
int main (int argc, char **argv) { int main (int argc, char **argv) {
sexp obj, res, *stack; sexp obj, res, in, out, *stack;
env e; env e;
int i, quit=0; int i, quit=0;
sexp_init(); scheme_init();
e = make_standard_env(); e = make_standard_env();
stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE);
@ -754,19 +786,18 @@ int main (int argc, char **argv) {
} }
/* repl */ /* repl */
if (! quit) { while (! quit) {
fprintf(stdout, "> "); fprintf(stdout, "> ");
fflush(stdout); fflush(stdout);
while ((obj = read_sexp(stdin)) != SEXP_EOF) { obj = sexp_read(cur_input_port);
/* write_sexp(stdout, obj); */ if (obj == SEXP_EOF) {
quit = 1;
} else {
res = eval_in_stack(obj, e, stack, 0); res = eval_in_stack(obj, e, stack, 0);
if (res != SEXP_UNDEF) { if (res != SEXP_UNDEF) {
/* fprintf(stdout, "\n "); */ sexp_write(res, cur_output_port);
write_sexp(stdout, res); sexp_write_char('\n', cur_output_port);
fprintf(stdout, "\n");
} }
fprintf(stdout, "> ");
fflush(stdout);
} }
} }
return 0; return 0;

2
eval.h
View file

@ -12,6 +12,8 @@
#define INIT_BCODE_SIZE 128 #define INIT_BCODE_SIZE 128
#define INIT_STACK_SIZE 1024 #define INIT_STACK_SIZE 1024
#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))
typedef struct bytecode { typedef struct bytecode {
char tag; char tag;
unsigned int len; unsigned int len;

491
sexp.c
View file

@ -1,6 +1,6 @@
/* sexp.c -- sexp library implementation */ /* sexp.c -- standalone sexp library implementation */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include "sexp.h" #include "sexp.h"
@ -16,7 +16,7 @@ static struct huff_entry huff_table[] = {
}; };
#endif #endif
static int initialized_p = 0; static int sexp_initialized_p = 0;
static sexp the_dot_symbol; static sexp the_dot_symbol;
static sexp the_quote_symbol; static sexp the_quote_symbol;
@ -24,7 +24,7 @@ static sexp the_quasiquote_symbol;
static sexp the_unquote_symbol; static sexp the_unquote_symbol;
static sexp the_unquote_splicing_symbol; static sexp the_unquote_splicing_symbol;
static char separators[] = { static char sexp_separators[] = {
/* 1 2 3 4 5 6 7 8 9 a b c d e f */ /* 1 2 3 4 5 6 7 8 9 a b c d e f */
0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */
@ -36,7 +36,7 @@ static char separators[] = {
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 && separators[c]; return 0<c && c<0x60 && sexp_separators[c];
} }
static sexp* symbol_table = NULL; static sexp* symbol_table = NULL;
@ -47,26 +47,26 @@ static unsigned long symbol_table_primes[] = {
static int symbol_table_prime_index = 0; static int symbol_table_prime_index = 0;
static int symbol_table_count = 0; static int symbol_table_count = 0;
void free_sexp (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:
free_sexp(car(obj)); sexp_free(SEXP_CAR(obj));
free_sexp(cdr(obj)); sexp_free(SEXP_CDR(obj));
break; break;
case SEXP_VECTOR: case SEXP_VECTOR:
len = vector_length(obj); len = sexp_vector_length(obj);
elts = vector_data(obj); elts = sexp_vector_data(obj);
for (i=0; i<len; i++) { for (i=0; i<len; i++) {
free_sexp(elts[i]); sexp_free(elts[i]);
} }
SEXP_FREE(elts); SEXP_FREE(elts);
break; break;
case SEXP_STRING: case SEXP_STRING:
case SEXP_SYMBOL: case SEXP_SYMBOL:
SEXP_FREE(string_data(obj)); SEXP_FREE(sexp_string_data(obj));
break; break;
} }
SEXP_FREE(obj); SEXP_FREE(obj);
@ -75,7 +75,7 @@ void free_sexp (sexp obj) {
/*************************** list utilities ***************************/ /*************************** list utilities ***************************/
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; if (! pair) return SEXP_ERROR;
pair->tag = SEXP_PAIR; pair->tag = SEXP_PAIR;
@ -84,37 +84,21 @@ sexp cons(sexp head, sexp tail) {
return pair; return pair;
} }
sexp car(sexp obj) { sexp sexp_car(sexp obj) {
return (SEXP_PAIRP(obj)) ? SEXP_CAR(obj) : SEXP_ERROR; return (SEXP_PAIRP(obj)) ? SEXP_CAR(obj) : SEXP_ERROR;
} }
sexp cdr(sexp obj) { sexp sexp_cdr(sexp obj) {
return (SEXP_PAIRP(obj)) ? SEXP_CDR(obj) : SEXP_ERROR; return (SEXP_PAIRP(obj)) ? SEXP_CDR(obj) : SEXP_ERROR;
} }
sexp set_car(sexp obj, sexp val) { int sexp_listp (sexp obj) {
if (SEXP_PAIRP(obj))
return SEXP_CAR(obj) = val;
else {
sexp_debug("error: set-car! not a pair: ", obj);
return SEXP_ERROR;
}
}
sexp set_cdr(sexp obj, sexp val) {
if (SEXP_PAIRP(obj))
return SEXP_CDR(obj) = val;
else
return SEXP_ERROR;
}
int 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 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)
@ -125,7 +109,7 @@ int list_index (sexp ls, sexp elt) {
return -1; return -1;
} }
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;
@ -134,7 +118,7 @@ sexp memq (sexp x, sexp ls) {
return SEXP_FALSE; return SEXP_FALSE;
} }
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;
@ -143,22 +127,22 @@ sexp assq (sexp x, sexp ls) {
return SEXP_FALSE; return SEXP_FALSE;
} }
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 (! list_index(b, SEXP_CAR(a)) >= 0) if (! sexp_list_index(b, SEXP_CAR(a)) >= 0)
res = cons(SEXP_CAR(a), res); res = sexp_cons(SEXP_CAR(a), res);
return res; return res;
} }
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 = cons(SEXP_CAR(ls), res); res = sexp_cons(SEXP_CAR(ls), res);
return res; return res;
} }
sexp nreverse(sexp ls) { 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;
@ -166,52 +150,52 @@ sexp nreverse(sexp ls) {
return SEXP_ERROR; return SEXP_ERROR;
} else { } else {
b=ls; b=ls;
a=cdr(ls); a=SEXP_CDR(ls);
set_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=cdr(a); tmp=SEXP_CDR(a);
set_cdr(a, b); SEXP_CDR(a) = b;
} }
return b; return b;
} }
} }
sexp append(sexp a, sexp b) { sexp sexp_append(sexp a, sexp b) {
for (a=reverse(a); SEXP_PAIRP(a); a=SEXP_CDR(a)) for (a=sexp_reverse(a); SEXP_PAIRP(a); a=SEXP_CDR(a))
b = cons(SEXP_CAR(a), b); b = sexp_cons(SEXP_CAR(a), b);
return b; return b;
} }
sexp list(int count, ...) { sexp sexp_list(int count, ...) {
sexp res = SEXP_NULL; sexp res = SEXP_NULL;
int i; int i;
va_list ap; va_list ap;
va_start(ap, count); va_start(ap, count);
for (i=0; i<count; i++) for (i=0; i<count; i++)
res = cons(va_arg(ap, sexp), res); res = sexp_cons(va_arg(ap, sexp), res);
va_end(ap); va_end(ap);
return nreverse(res); return sexp_nreverse(res);
} }
unsigned long length(sexp ls) { unsigned long sexp_length(sexp ls) {
sexp x; sexp x;
unsigned long res; unsigned long res;
for (res=0, x=ls; SEXP_PAIRP(x); res++, x=cdr(x)) for (res=0, x=ls; SEXP_PAIRP(x); res++, x=SEXP_CDR(x))
; ;
return res; return res;
} }
/********************* strings, symbols, vectors **********************/ /********************* strings, symbols, vectors **********************/
sexp make_flonum(double f) { sexp sexp_make_flonum(double f) {
sexp x = SEXP_NEW(); sexp x = SEXP_NEW();
if (! x) return SEXP_ERROR; if (! x) return SEXP_ERROR;
x->tag = SEXP_FLONUM; x->tag = SEXP_FLONUM;
flonum_value(x) = f; sexp_flonum_value(x) = f;
return x; return x;
} }
sexp make_string(char *str) { sexp sexp_make_string(char *str) {
sexp s = SEXP_NEW(); sexp s = SEXP_NEW();
if (! s) return SEXP_ERROR; if (! s) return SEXP_ERROR;
unsigned long len = strlen(str); unsigned long len = strlen(str);
@ -227,12 +211,12 @@ sexp make_string(char *str) {
#define FNV_PRIME 16777619 #define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL #define FNV_OFFSET_BASIS 2166136261uL
int string_hash(char *str, int acc) { int sexp_string_hash(char *str, int acc) {
while (*str) {acc *= FNV_PRIME; acc ^= *str++;} while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
return acc; return acc;
} }
sexp intern(char *str) { sexp sexp_intern(char *str) {
struct huff_entry he; struct huff_entry he;
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell;
char c, *mystr, *p=str; char c, *mystr, *p=str;
@ -253,15 +237,15 @@ sexp intern(char *str) {
#endif #endif
normal_intern: normal_intern:
res = string_hash(p, res); res = sexp_string_hash(p, res);
d = symbol_table_primes[symbol_table_prime_index]; d = symbol_table_primes[symbol_table_prime_index];
cell = res % d; cell = res % d;
for (i=0; i<d; i++) { for (i=0; i<d; i++) {
if (! symbol_table[cell]) { if (! symbol_table[cell]) {
break; break;
} else if (strncmp(str, } else if (strncmp(str,
symbol_data(symbol_table[cell]), sexp_symbol_data(symbol_table[cell]),
symbol_length(symbol_table[cell])) == 0) { sexp_symbol_length(symbol_table[cell])) == 0) {
return symbol_table[cell]; return symbol_table[cell];
} }
cell = (cell * res + 1) % d; cell = (cell * res + 1) % d;
@ -290,7 +274,7 @@ sexp intern(char *str) {
return symbol_table[cell]; return symbol_table[cell];
} }
sexp make_vector(unsigned long len, sexp dflt) { sexp sexp_make_vector(unsigned long len, sexp dflt) {
int i; int i;
sexp v = SEXP_NEW(); sexp v = SEXP_NEW();
if (v == NULL) return SEXP_ERROR; if (v == NULL) return SEXP_ERROR;
@ -305,21 +289,21 @@ sexp make_vector(unsigned long len, sexp dflt) {
return v; return v;
} }
sexp list_to_vector(sexp ls) { sexp sexp_list_to_vector(sexp ls) {
sexp vec = make_vector(length(ls), SEXP_FALSE); sexp vec = sexp_make_vector(sexp_length(ls), SEXP_FALSE);
if (vec == SEXP_ERROR) return vec; if (vec == SEXP_ERROR) return vec;
sexp x; sexp x;
sexp *elts = vector_data(vec); sexp *elts = sexp_vector_data(vec);
int i; int i;
for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) for (i=0, x=ls; SEXP_PAIRP(x); i++, x=SEXP_CDR(x))
elts[i] = car(x); elts[i] = SEXP_CAR(x);
return vec; return vec;
} }
sexp vector(int count, ...) { sexp sexp_vector(int count, ...) {
sexp vec = make_vector(count, SEXP_FALSE); sexp vec = sexp_make_vector(count, SEXP_FALSE);
if (vec == SEXP_ERROR) return vec; if (vec == SEXP_ERROR) return vec;
sexp *elts = vector_data(vec); sexp *elts = sexp_vector_data(vec);
va_list ap; va_list ap;
int i; int i;
@ -332,70 +316,145 @@ sexp vector(int count, ...) {
/************************ reading and writing *************************/ /************************ reading and writing *************************/
void write_sexp (FILE *out, sexp obj) { #ifdef USE_STRING_STREAMS
int sstream_read(void *vec, char *dst, int n) {
int len = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1));
int pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2));
if (pos >= len) return 0;
if (n > (len - pos)) n = (len - pos);
memcpy(dst+pos, sexp_vector_ref((sexp) vec, sexp_make_integer(0)), n);
sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)n);
return n;
}
int sstream_write(void *vec, const char *src, int n) {
return n;
}
off_t sstream_seek(void *vec, off_t offset, int whence) {
int pos;
if (whence == SEEK_SET) {
pos = offset;
} else if (whence == SEEK_CUR) {
pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2)) + offset;
} else { /* SEEK_END */
pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1)) + offset;
}
sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)pos);
return pos;
}
int sstream_close(void *vec) {
sexp_free((sexp)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;
}
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;
}
sexp sexp_make_input_string_port(sexp str) {
FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
return sexp_make_input_port(in);
}
sexp sexp_make_output_string_port() {
return SEXP_ERROR;
}
sexp sexp_get_output_string(sexp port) {
return SEXP_ERROR;
}
#endif
void sexp_write (sexp obj, sexp out) {
unsigned long len, i, c, res; unsigned long len, i, c, res;
sexp x, *elts; sexp x, *elts;
char *str;
if (! obj) { if (! obj) {
fprintf(out, "#<null>"); 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:
fprintf(out, "("); sexp_write_char('(', out);
write_sexp(out, car(obj)); sexp_write(SEXP_CAR(obj), out);
for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) { for (x=SEXP_CDR(obj); SEXP_PAIRP(x); x=SEXP_CDR(x)) {
fprintf(out, " "); sexp_write_char(' ', out);
write_sexp(out, car(x)); sexp_write(SEXP_CAR(x), out);
} }
if (! SEXP_NULLP(x)) { if (! SEXP_NULLP(x)) {
fprintf(out, " . "); sexp_write_string(" . ", out);
write_sexp(out, x); sexp_write(x, out);
} }
fprintf(out, ")"); sexp_write_char(')', out);
break; break;
case SEXP_VECTOR: case SEXP_VECTOR:
len = vector_length(obj); len = sexp_vector_length(obj);
elts = vector_data(obj); elts = sexp_vector_data(obj);
if (len == 0) { if (len == 0) {
fprintf(out, "#()"); sexp_write_string("#()", out);
} else { } else {
fprintf(out, "#("); sexp_write_string("#(", out);
write_sexp(out, elts[0]); sexp_write(out, elts[0]);
for (i=1; i<len; i++) { for (i=1; i<len; i++) {
fprintf(out, " "); sexp_write_char(' ', out);
write_sexp(out, elts[i]); sexp_write(out, elts[i]);
} }
fprintf(out, ")"); sexp_write_char(')', out);
} }
break; break;
case SEXP_FLONUM: case SEXP_FLONUM:
fprintf(out, "%g", flonum_value(obj)); sexp_printf(out, "%g", sexp_flonum_value(obj)); break;
break;
case SEXP_PROCEDURE: case SEXP_PROCEDURE:
fprintf(out, "#<procedure>"); sexp_write_string("#<procedure>", out); break;
break; case SEXP_IPORT:
sexp_write_string("#<input-port>", out); break;
case SEXP_OPORT:
sexp_write_string("#<output-port>", out); break;
case SEXP_BYTECODE: case SEXP_BYTECODE:
fprintf(out, "#<bytecode>"); sexp_write_string("#<bytecode>", out); break;
break;
case SEXP_ENV: case SEXP_ENV:
fprintf(out, "#<env>"); sexp_write_string("#<env>", out); break;
break;
case SEXP_STRING: case SEXP_STRING:
fprintf(out, "\""); sexp_write_char('"', out);
i = sexp_string_length(obj);
str = sexp_string_data(obj);
/* FALLTHROUGH */ /* FALLTHROUGH */
case SEXP_SYMBOL: case SEXP_SYMBOL:
fprintf(out, "%s", string_data(obj)); if (obj->tag != SEXP_STRING) {
i = sexp_symbol_length(obj);
str = sexp_symbol_data(obj);
}
for ( ; i>=0; str++, i--) {
if (str[0] == '\\')
sexp_write_char('\\', out);
sexp_write_char(str[0], out);
}
if (obj->tag == SEXP_STRING) if (obj->tag == SEXP_STRING)
fprintf(out, "\""); sexp_write_char('"', out);
break; break;
} }
} else if (SEXP_INTEGERP(obj)) { } else if (SEXP_INTEGERP(obj)) {
fprintf(out, "%d", unbox_integer(obj)); sexp_printf(out, "%d", sexp_unbox_integer(obj));
} else if (SEXP_CHARP(obj)) { } else if (SEXP_CHARP(obj)) {
if (33 <= unbox_character(obj) < 127) { if (33 <= sexp_unbox_character(obj) < 127) {
fprintf(out, "#\\%c", unbox_character(obj)); sexp_printf(out, "#\\%c", sexp_unbox_character(obj));
} else { } else {
fprintf(out, "#\\x%02d", unbox_character(obj)); sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj));
} }
} else if (SEXP_SYMBOLP(obj)) { } else if (SEXP_SYMBOLP(obj)) {
@ -404,51 +463,45 @@ void write_sexp (FILE *out, sexp obj) {
c = ((sexp_uint_t)obj)>>3; c = ((sexp_uint_t)obj)>>3;
while (c) { while (c) {
#include "sexp-unhuff.c" #include "sexp-unhuff.c"
putc(res, out); sexp_write_char(res, out);
} }
} else }
#endif #endif
fprintf(out, "%s", symbol_data(obj));
} else { } else {
switch ((sexp_uint_t) obj) { switch ((sexp_uint_t) obj) {
case (sexp_uint_t) SEXP_NULL: case (sexp_uint_t) SEXP_NULL:
fprintf(out, "()"); sexp_write_string("()", out); break;
break;
case (sexp_uint_t) SEXP_TRUE: case (sexp_uint_t) SEXP_TRUE:
fprintf(out, "#t"); sexp_write_string("#t", out); break;
break;
case (sexp_uint_t) SEXP_FALSE: case (sexp_uint_t) SEXP_FALSE:
fprintf(out, "#f"); sexp_write_string("#f", out); break;
break;
case (sexp_uint_t) SEXP_EOF: case (sexp_uint_t) SEXP_EOF:
fprintf(out, "#<eof>"); sexp_write_string("#<eof>", out); break;
break;
case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_UNDEF:
fprintf(out, "#<undef>"); sexp_write_string("#<undef>", out); break;
break;
default: default:
fprintf(out, "#<error>"); sexp_write_string("#<error>", out);
} }
} }
} }
char* read_string(FILE *in) { char* sexp_read_string(sexp in) {
char *buf, *tmp, *res; char *buf, *tmp, *res;
char c; int c, len, size=128;
int len;
buf = SEXP_ALLOC(128); buf = SEXP_ALLOC(size); /* XXXX grow! */
tmp = buf; tmp = buf;
for (c=fgetc(in); (c != EOF) && (c != '"'); c=fgetc(in)) { for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) {
if (c == '\\') { if (c == EOF) {
c=fgetc(in); SEXP_FREE(buf);
return NULL;
} else if (c == '\\') {
c=sexp_read_char(in);
switch (c) { switch (c) {
case 'n': case 'n': c = '\n'; break;
c = '\n'; case 't': c = '\t'; break;
case 't':
c = '\t';
} }
*tmp++ = c; *tmp++ = c;
} else { } else {
@ -464,21 +517,20 @@ char* read_string(FILE *in) {
return res; return res;
} }
char* read_symbol(FILE *in, int init) { char* sexp_read_symbol(sexp in, int init) {
char *buf, *tmp, *res; char *buf, *tmp, *res;
char c; int c, len, size=128;
int len;
buf = SEXP_ALLOC(128); buf = SEXP_ALLOC(size);
tmp = buf; tmp = buf;
if (init != EOF) if (init != EOF)
*tmp++ = init; *tmp++ = init;
while (1) { while (1) {
c=fgetc(in); c=sexp_read_char(in);
if (c == EOF || is_separator(c)) { if (c == EOF || is_separator(c)) {
ungetc(c, in); sexp_push_char(c, in);
break; break;
} }
*tmp++ = c; *tmp++ = c;
@ -492,57 +544,56 @@ char* read_symbol(FILE *in, int init) {
return res; return res;
} }
sexp read_float_tail(FILE *in, long whole) { 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=fgetc(in); isdigit(c); c=fgetc(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 += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale;
ungetc(c, in); sexp_push_char(c, in);
return make_flonum(whole + res); return sexp_make_flonum(whole + res);
} }
sexp read_number(FILE *in, int base) { sexp sexp_read_number(sexp in, int base) {
sexp tmp; sexp tmp;
long res = 0, negativep = 0; long res = 0, negativep = 0, c;
int c;
c = fgetc(in); c = sexp_read_char(in);
if (c == '-') { if (c == '-') {
negativep = 1; negativep = 1;
} else if (isdigit(c)) { } else if (isdigit(c)) {
res = c - '0'; res = c - '0';
} }
for (c=fgetc(in); isxdigit(c); c=fgetc(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 + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10));
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");
return SEXP_ERROR; return SEXP_ERROR;
} }
tmp = read_float_tail(in, res); tmp = sexp_read_float_tail(in, res);
if (negativep && SEXP_FLONUMP(tmp)) if (negativep && SEXP_FLONUMP(tmp))
flonum_value(tmp) = -1 * flonum_value(tmp); sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp);
return tmp; return tmp;
} else { } else {
ungetc(c, in); sexp_push_char(c, in);
} }
return make_integer(negativep ? -res : res); return sexp_make_integer(negativep ? -res : res);
} }
sexp read_sexp_raw (FILE *in) { sexp sexp_read_raw (sexp in) {
sexp res, tmp, tmp2; sexp res, tmp, tmp2;
char *str; char *str;
int c1, c2; int c1, c2;
scan_loop: scan_loop:
switch (c1 = fgetc(in)) { switch (c1 = sexp_read_char(in)) {
case EOF: case EOF:
res = SEXP_EOF; res = SEXP_EOF;
break; break;
case ';': case ';':
while ((c1 = fgetc(in)) != EOF) while ((c1 = sexp_read_char(in)) != EOF)
if (c1 == '\n') if (c1 == '\n')
break; break;
/* fallthrough */ /* fallthrough */
@ -550,96 +601,98 @@ sexp read_sexp_raw (FILE *in) {
case '\t': case '\t':
case '\n': case '\n':
goto scan_loop; goto scan_loop;
break;
case '\'': case '\'':
res = read_sexp(in); res = sexp_read(in);
res = list2(the_quote_symbol, res); res = sexp_list2(the_quote_symbol, res);
break; break;
case '`': case '`':
res = read_sexp(in); res = sexp_read(in);
res = list2(the_quasiquote_symbol, res); res = sexp_list2(the_quasiquote_symbol, res);
break; break;
case ',': case ',':
if ((c1 = fgetc(in)) == '@') { if ((c1 = sexp_read_char(in)) == '@') {
res = read_sexp(in); res = sexp_read(in);
res = list2(the_unquote_splicing_symbol, res); res = sexp_list2(the_unquote_splicing_symbol, res);
} else { } else {
ungetc(c1, in); sexp_push_char(c1, in);
res = read_sexp(in); res = sexp_read(in);
res = list2(the_unquote_symbol, res); res = sexp_list2(the_unquote_symbol, res);
} }
break; break;
case '"': case '"':
str = read_string(in); str = sexp_read_string(in);
res = make_string(str); res = sexp_make_string(str);
SEXP_FREE(str); SEXP_FREE(str);
break; break;
case '(': case '(':
res = SEXP_NULL; res = SEXP_NULL;
tmp = read_sexp_raw(in); tmp = sexp_read_raw(in);
while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) {
if (tmp == SEXP_RAWDOT) { if (tmp == SEXP_RAWDOT) {
/* dotted list */ if (res == SEXP_NULL) {
free_sexp(tmp); fprintf(stderr, "sexp: dot before any elements in list\n");
tmp = read_sexp_raw(in); return SEXP_ERROR;
if (read_sexp(in) != SEXP_CLOSE) {
fprintf(stderr, "sexp: multiple tokens in dotted tail\n");
res = SEXP_ERROR;
} else { } else {
tmp2 = res; tmp = sexp_read_raw(in);
res = nreverse(res); if (sexp_read(in) != SEXP_CLOSE) {
set_cdr(tmp2, tmp); fprintf(stderr, "sexp: multiple tokens in dotted tail\n");
return res; sexp_free(res);
return SEXP_ERROR;
} else {
tmp2 = res;
res = sexp_nreverse(res);
SEXP_CDR(tmp2) = tmp;
return res;
}
} }
} else { } else {
res = cons(tmp, res); res = sexp_cons(tmp, res);
tmp = read_sexp_raw(in); tmp = sexp_read_raw(in);
} }
} }
if (tmp != SEXP_CLOSE) { if (tmp != SEXP_CLOSE) {
free_sexp(res); sexp_free(res);
res = SEXP_ERROR; res = SEXP_ERROR;
} }
res = nreverse(res); res = sexp_nreverse(res);
break; break;
case '#': case '#':
switch (c1=fgetc(in)) { switch (c1=sexp_read_char(in)) {
case 'b': case 'b':
res = read_number(in, 2); res = sexp_read_number(in, 2); break;
break;
case 'o': case 'o':
res = read_number(in, 8); res = sexp_read_number(in, 8); break;
break;
case 'd': case 'd':
res = read_number(in, 10); res = sexp_read_number(in, 10); break;
break;
case 'x': case 'x':
res = read_number(in, 16); res = sexp_read_number(in, 16); break;
break;
/* case 'e': */ /* case 'e': */
/* case 'i': */ /* case 'i': */
case 'f': case 'f':
case 't': case 't':
c2 = fgetc(in); c2 = sexp_read_char(in);
if (c2 == EOF || is_separator(c2)) { if (c2 == EOF || is_separator(c2)) {
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
} else { } else {
fprintf(stderr, "sexp: invalid syntax #%c%c\n", c1, c2); fprintf(stderr, "sexp: invalid syntax #%c%c\n", c1, c2);
res = SEXP_ERROR; res = SEXP_ERROR;
} }
ungetc(c2, in); sexp_push_char(c2, in);
break; break;
case ';':
sexp_read_raw(in);
goto scan_loop;
case '(': case '(':
ungetc(c1, in); sexp_push_char(c1, in);
res = read_sexp(in); res = sexp_read(in);
if (! listp(res)) { if (! sexp_listp(res)) {
if (res != SEXP_ERROR) { if (res != SEXP_ERROR) {
fprintf(stderr, "sexp: dotted list not allowed in vector syntax\n"); fprintf(stderr, "sexp: dotted list not allowed in vector syntax\n");
free_sexp(res); sexp_free(res);
res = SEXP_ERROR; res = SEXP_ERROR;
} }
} else { } else {
res = list_to_vector(res); res = sexp_list_to_vector(res);
} }
break; break;
default: default:
@ -649,16 +702,16 @@ sexp read_sexp_raw (FILE *in) {
} }
break; break;
case '.': case '.':
c1 = fgetc(in); c1 = sexp_read_char(in);
if (c1 == EOF || is_separator(c1)) { if (c1 == EOF || is_separator(c1)) {
res = SEXP_RAWDOT; res = SEXP_RAWDOT;
} else if (isdigit(c1)) { } else if (isdigit(c1)) {
ungetc(c1,in ); sexp_push_char(c1,in );
res = read_float_tail(in, 0); res = sexp_read_float_tail(in, 0);
} else { } else {
ungetc(c1, in); sexp_push_char(c1, in);
str = read_symbol(in, '.'); str = sexp_read_symbol(in, '.');
res = intern(str); res = sexp_intern(str);
SEXP_FREE(str); SEXP_FREE(str);
} }
break; break;
@ -667,51 +720,51 @@ sexp read_sexp_raw (FILE *in) {
break; break;
case '+': case '+':
case '-': case '-':
c2 = fgetc(in); c2 = sexp_read_char(in);
if (c2 == '.' || isdigit(c2)) { if (c2 == '.' || isdigit(c2)) {
ungetc(c2, in); sexp_push_char(c2, in);
res = read_number(in, 10); res = sexp_read_number(in, 10);
if (c1 == '-') res = sexp_mul(res, -1); if (c1 == '-') res = sexp_mul(res, -1);
} else { } else {
ungetc(c2, in); sexp_push_char(c2, in);
str = read_symbol(in, c1); str = sexp_read_symbol(in, c1);
res = intern(str); res = sexp_intern(str);
SEXP_FREE(str); SEXP_FREE(str);
} }
break; break;
case '0': case '1': case '2': case '3': case '4': case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '5': case '6': case '7': case '8': case '9':
ungetc(c1, in); sexp_push_char(c1, in);
res = read_number(in, 10); res = sexp_read_number(in, 10);
break; break;
default: default:
str = read_symbol(in, c1); str = sexp_read_symbol(in, c1);
res = intern(str); res = sexp_intern(str);
SEXP_FREE(str); SEXP_FREE(str);
break; break;
} }
return res; return res;
} }
sexp read_sexp (FILE *in) { sexp sexp_read (sexp in) {
sexp res = read_sexp_raw(in); sexp res = sexp_read_raw(in);
if ((res == SEXP_CLOSE) || (res == SEXP_RAWDOT)) if ((res == SEXP_CLOSE) || (res == SEXP_RAWDOT))
res = SEXP_ERROR; res = SEXP_ERROR;
return res; return res;
} }
void sexp_init() { void sexp_init() {
if (! initialized_p) { if (! sexp_initialized_p) {
initialized_p = 1; sexp_initialized_p = 1;
#ifdef USE_BOEHM #ifdef USE_BOEHM
GC_init(); GC_init();
#endif #endif
symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp));
the_dot_symbol = intern("."); the_dot_symbol = sexp_intern(".");
the_quote_symbol = intern("quote"); the_quote_symbol = sexp_intern("quote");
the_quasiquote_symbol = intern("quasiquote"); the_quasiquote_symbol = sexp_intern("quasiquote");
the_unquote_symbol = intern("unquote"); the_unquote_symbol = sexp_intern("unquote");
the_unquote_splicing_symbol = intern("unquote-splicing"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing");
} }
} }

143
sexp.h
View file

@ -1,6 +1,6 @@
/* sexp.h -- header for sexp library */ /* sexp.h -- header for sexp library */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_H #ifndef SEXP_H
#define SEXP_H #define SEXP_H
@ -20,7 +20,9 @@
#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
#define sexp_debug(msg, obj) (fprintf(stderr,msg), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n")) #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
#define SEXP_BSD
#endif
#ifdef USE_BOEHM #ifdef USE_BOEHM
#include "gc/include/gc.h" #include "gc/include/gc.h"
@ -70,6 +72,8 @@ enum sexp_types {
SEXP_VECTOR, SEXP_VECTOR,
SEXP_FLONUM, SEXP_FLONUM,
SEXP_BIGNUM, SEXP_BIGNUM,
SEXP_IPORT,
SEXP_OPORT,
/* the following are used only by the evaluator */ /* the following are used only by the evaluator */
SEXP_PROCEDURE, SEXP_PROCEDURE,
SEXP_ENV, SEXP_ENV,
@ -109,6 +113,8 @@ typedef long sexp_sint_t;
#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) #define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL)
#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) #define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR)
#define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) #define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM)
#define SEXP_IPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_IPORT)
#define SEXP_OPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPORT)
#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) #define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE)
#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV)
#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE)
@ -120,34 +126,57 @@ typedef long sexp_sint_t;
#ifdef USE_HUFF_SYMS #ifdef 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))
#else #else
#define SEXP_DOTP(x) ((x)==the_dot_symbol) #define SEXP_DOTP(x) ((x)==sexp_the_dot_symbol)
#endif #endif
#define make_integer(n) ((sexp) (((long) n<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG)) #define sexp_make_integer(n) ((sexp) (((long) n<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
#define unbox_integer(n) ((long) n>>SEXP_FIXNUM_BITS) #define sexp_unbox_integer(n) ((long) n>>SEXP_FIXNUM_BITS)
#define make_character(n) ((sexp) (((long) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG)) #define sexp_make_character(n) ((sexp) (((long) n<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
#define unbox_character(n) ((long) n>>SEXP_EXTENDED_BITS) #define sexp_unbox_character(n) ((long) n>>SEXP_EXTENDED_BITS)
#define flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) #define sexp_flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0])
#define vector_length(x) ((sexp_uint_t) x->data1) #define sexp_vector_length(x) ((sexp_uint_t) x->data1)
#define vector_data(x) ((sexp*) x->data2) #define sexp_vector_data(x) ((sexp*) (((sexp)x)->data2))
#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) #define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)])
#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v)) #define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v))
#define procedure_code(x) ((bytecode) ((sexp)x)->data1) #define sexp_procedure_code(x) ((bytecode) ((sexp)x)->data1)
#define procedure_vars(x) ((sexp) ((sexp)x)->data2) #define sexp_procedure_vars(x) ((sexp) ((sexp)x)->data2)
#define string_length(x) ((sexp_uint_t) x->data1) #define sexp_string_length(x) ((sexp_uint_t) x->data1)
#define string_data(x) ((char*) x->data2) #define sexp_string_data(x) ((char*) x->data2)
#define string_ref(x, i) (make_character(string_data(x)[unbox_integer(i)])) #define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)]))
#define string_set(x, i, v) (string_data(x)[unbox_integer(i)] = unbox_character(v)) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v))
#define symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) #define sexp_port_stream(p) ((FILE*) ((sexp)p)->data1)
#define symbol_length(x) ((sexp_uint_t) (symbol_pointer(x)->data1))
#define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) #ifdef USE_STRING_STREAMS
#ifdef SEXP_BSD
#define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close)
int sstream_read(void *vec, char *dst, int n);
int sstream_write(void *vec, const char *src, int n);
off_t sstream_seek(void *vec, off_t offset, int whence);
int sstream_close(void *vec);
#endif
#define sexp_read_char(p) (getc(sexp_port_stream(p)))
#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p)))
#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p)))
#define sexp_printf(p, s, ...) (fprintf(sexp_port_stream(p), s, __VA_ARGS__))
#else
sexp sexp_read_char(sexp port);
void sexp_push_char(sexp ch, sexp port);
void sexp_write_char(sexp ch, sexp port);
void sexp_write_string(sexp str, sexp port);
void sexp_printf(sexp port, sexp fmt, ...);
#endif
#define sexp_symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG))
#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))
@ -155,9 +184,10 @@ typedef long sexp_sint_t;
#define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG) #define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG)
#define sexp_mod(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG) #define sexp_mod(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<<SEXP_FIXNUM_BITS)+SEXP_FIXNUM_TAG)
#define list2(a, b) cons(a, cons(b, SEXP_NULL)) #define sexp_list1(a) sexp_cons(a, SEXP_NULL)
#define list3(a, b, c) cons(a, cons(b, cons(c, SEXP_NULL))) #define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL))
#define list4(a, b, c, d) cons(a, cons(b, cons(c, cons(d, 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_CAR(x) (((sexp)x)->data1) #define SEXP_CAR(x) (((sexp)x)->data1)
#define SEXP_CDR(x) (((sexp)x)->data2) #define SEXP_CDR(x) (((sexp)x)->data2)
@ -172,36 +202,41 @@ typedef long sexp_sint_t;
#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 cons(sexp head, sexp tail); sexp sexp_cons(sexp head, sexp tail);
sexp car(sexp obj); sexp sexp_car(sexp obj);
sexp cdr(sexp obj); sexp sexp_cdr(sexp obj);
sexp set_car(sexp obj, sexp val); sexp sexp_set_car(sexp obj, sexp val);
sexp set_cdr(sexp obj, sexp val); sexp sexp_set_cdr(sexp obj, sexp val);
int listp(sexp obj); int sexp_listp(sexp obj);
int list_index(sexp ls, sexp elt); int sexp_list_index(sexp ls, sexp elt);
sexp lset_diff(sexp a, sexp b); sexp sexp_lset_diff(sexp a, sexp b);
sexp reverse(sexp ls); sexp sexp_reverse(sexp ls);
sexp nreverse(sexp ls); sexp sexp_nreverse(sexp ls);
sexp append(sexp a, sexp b); sexp sexp_append(sexp a, sexp b);
sexp list(int count, ...); sexp sexp_list(int count, ...);
sexp memq(sexp x, sexp ls); sexp sexp_memq(sexp x, sexp ls);
sexp assq (sexp x, sexp ls); sexp sexp_assq(sexp x, sexp ls);
unsigned long length(sexp ls); unsigned long sexp_length(sexp ls);
sexp make_string(char *str); sexp sexp_make_string(char *str);
sexp make_flonum(double f); sexp sexp_make_flonum(double f);
int string_hash(char *str, int acc); int sexp_string_hash(char *str, int acc);
sexp intern(char *str); sexp sexp_intern(char *str);
sexp make_vector(unsigned long len, sexp dflt); sexp sexp_make_vector(unsigned long len, sexp dflt);
sexp list_to_vector(sexp ls); sexp sexp_list_to_vector(sexp ls);
sexp vector(int count, ...); sexp sexp_vector(int count, ...);
void write_sexp(FILE *out, sexp obj); void sexp_write(sexp obj, sexp out);
void free_sexp(sexp obj); void sexp_free(sexp obj);
char* read_string(FILE *in); char* sexp_read_string(sexp in);
char* read_symbol(FILE *in, int init); char* sexp_read_symbol(sexp in, int init);
sexp read_number(FILE *in, int base); sexp sexp_read_number(sexp in, int base);
sexp read_sexp_raw(FILE *in); sexp sexp_read_raw(sexp in);
sexp read_sexp(FILE *in); sexp sexp_read(sexp in);
sexp sexp_make_input_port(FILE* in);
sexp sexp_make_output_port(FILE* out);
sexp sexp_make_input_string_port(sexp str);
sexp sexp_make_output_string_port();
sexp sexp_get_output_string(sexp port);
void sexp_init(); void sexp_init();
#endif /* ! SEXP_H */ #endif /* ! SEXP_H */