mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
fixing offby1 error in closure rep
This commit is contained in:
Alex Shinn
parent
d609e52e5f
commit
abecbd70f0
6 changed files with 42 additions and 626 deletions
8
Makefile
8
Makefile
|
|
@ -3,19 +3,21 @@
|
|||
|
||||
all: chibi-scheme
|
||||
|
||||
CFLAGS=-g -Os
|
||||
|
||||
GC_OBJ=./gc/gc.a
|
||||
|
||||
$GC_OBJ: ./gc/alloc.c
|
||||
cd gc && make test
|
||||
|
||||
sexp.o: sexp.c sexp.h config.h
|
||||
gcc -c -g -Os -o $@ $<
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c debug.c eval.h sexp.h config.h
|
||||
gcc -c -g -Os -o $@ $<
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
chibi-scheme: sexp.o eval.o $(GC_OBJ)
|
||||
gcc -g -Os -o $@ $^
|
||||
gcc $(CFLAGS) -o $@ $^
|
||||
|
||||
clean:
|
||||
rm -f *.o
|
||||
|
|
|
|||
54
eval.c
54
eval.c
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
#include "eval.h"
|
||||
|
||||
/* ******************************************************************** */
|
||||
/************************************************************************/
|
||||
|
||||
static struct core_form core_forms[] = {
|
||||
{SEXP_CORE, "define", CORE_DEFINE},
|
||||
|
|
@ -19,17 +19,19 @@ static struct core_form core_forms[] = {
|
|||
};
|
||||
|
||||
static struct opcode opcodes[] = {
|
||||
{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG, NULL},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV, 0},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0, NULL},
|
||||
{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL},
|
||||
#define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL}
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 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_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),
|
||||
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0),
|
||||
#undef _OP
|
||||
};
|
||||
|
||||
#ifdef USE_DEBUG
|
||||
|
|
@ -145,6 +147,8 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) {
|
|||
*i += sizeof(unsigned long);
|
||||
}
|
||||
|
||||
#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(unsigned long)obj))
|
||||
|
||||
sexp make_procedure(sexp bc, sexp vars) {
|
||||
sexp proc = SEXP_NEW();
|
||||
if (! proc) return SEXP_ERROR;
|
||||
|
|
@ -409,8 +413,7 @@ 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;
|
||||
sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls;
|
||||
sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL);
|
||||
env e2 = extend_env_closure(e, formals);
|
||||
int k;
|
||||
fprintf(stderr, "%d free-vars\n", length(fv2));
|
||||
|
|
@ -452,7 +455,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
|
|||
emit(&bc, &i, OP_PUSH);
|
||||
emit_word(&bc, &i, (unsigned long) SEXP_NULL);
|
||||
emit(&bc, &i, OP_STACK_REF);
|
||||
emit_word(&bc, &i, j+3);
|
||||
emit_word(&bc, &i, j+4);
|
||||
emit(&bc, &i, OP_CONS);
|
||||
emit(&bc, &i, OP_STACK_SET);
|
||||
emit_word(&bc, &i, j+4);
|
||||
|
|
@ -466,7 +469,6 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
|
|||
if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP);
|
||||
}
|
||||
emit(&bc, &i, done_p ? OP_DONE : OP_RET);
|
||||
/* fprintf(stderr, "shrinking\n"); */
|
||||
shrink_bcode(&bc, i);
|
||||
fprintf(stderr, "done compiling:\n");
|
||||
print_bytecode(bc);
|
||||
|
|
@ -482,7 +484,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
int i;
|
||||
|
||||
loop:
|
||||
/* fprintf(stderr, "opcode: %d, ip: %d\n", *ip, ip); */
|
||||
/* fprintf(stderr, "opcode: %s (%d), ip: %d\n", reverse_opcode_names[*ip], *ip, ip); */
|
||||
/* print_bytecode(bc); */
|
||||
switch (*ip++) {
|
||||
case OP_NOOP:
|
||||
|
|
@ -617,17 +619,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
if (! SEXP_PROCEDUREP(tmp))
|
||||
errx(2, "non-procedure application: %p", tmp);
|
||||
stack[top-1] = (sexp) i;
|
||||
stack[top] = (sexp) (ip+4);
|
||||
stack[top] = make_integer(ip+4);
|
||||
stack[top+1] = cp;
|
||||
top+=2;
|
||||
bc = procedure_code(tmp);
|
||||
print_bytecode(bc);
|
||||
disasm(bc);
|
||||
ip = bc->data;
|
||||
cp = procedure_vars(tmp);
|
||||
fprintf(stderr, "... calling procedure at %p\ncp: ", ip);
|
||||
write_sexp(stderr, cp);
|
||||
fprintf(stderr, "\n");
|
||||
/* print_stack(stack, top); */
|
||||
fprintf(stderr, "stack at %d\n", top);
|
||||
print_stack(stack, top);
|
||||
break;
|
||||
case OP_JUMP_UNLESS:
|
||||
fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]);
|
||||
|
|
@ -652,13 +656,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
/* top-1 */
|
||||
/* stack: args ... n ip result */
|
||||
cp = stack[top-2];
|
||||
fprintf(stderr, "1\n");
|
||||
ip = (unsigned char*) stack[top-3];
|
||||
fprintf(stderr, "2\n");
|
||||
ip = (unsigned char*) unbox_integer(stack[top-3]);
|
||||
i = unbox_integer(stack[top-4]);
|
||||
fprintf(stderr, "3 (i=%d)\n", i);
|
||||
stack[top-i-4] = stack[top-1];
|
||||
fprintf(stderr, "4\n");
|
||||
top = top-i-3;
|
||||
fprintf(stderr, "... done returning\n");
|
||||
break;
|
||||
|
|
@ -673,7 +673,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
stack[top] = SEXP_ERROR;
|
||||
goto end_loop;
|
||||
}
|
||||
fprintf(stderr, "looping\n");
|
||||
/* print_stack(stack, top); */
|
||||
goto loop;
|
||||
|
||||
end_loop:
|
||||
|
|
@ -683,8 +683,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
/************************** eval interface ****************************/
|
||||
|
||||
sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) {
|
||||
bytecode bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1);
|
||||
fprintf(stderr, "evaling\n");
|
||||
bytecode bc;
|
||||
bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1);
|
||||
return vm(bc, e, stack, top);
|
||||
}
|
||||
|
||||
|
|
|
|||
6
eval.h
6
eval.h
|
|
@ -107,6 +107,7 @@ enum opcode_names {
|
|||
/**************************** prototypes ******************************/
|
||||
|
||||
bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p);
|
||||
|
||||
void analyze_app (sexp obj, bytecode *bc, unsigned int *i,
|
||||
env e, sexp params, sexp fv, sexp sv, unsigned int *d);
|
||||
void analyze_lambda (sexp name, sexp formals, sexp body,
|
||||
|
|
@ -115,5 +116,10 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
|
|||
void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e,
|
||||
sexp params, sexp fv, sexp sv, unsigned int *d);
|
||||
|
||||
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(sexp obj, env e);
|
||||
|
||||
#endif /* ! SCM_EVAL_H */
|
||||
|
||||
|
|
|
|||
594
sexp-orig.c
594
sexp-orig.c
|
|
@ -1,594 +0,0 @@
|
|||
|
||||
/* #include <ctype.h> */
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdarg.h>
|
||||
|
||||
/* simple tagging
|
||||
* ends in 00: pointer
|
||||
* 1: fixnum
|
||||
* 010: symbol
|
||||
* 0110: char
|
||||
* 1110: other immediate object (NULL, TRUE, FALSE)
|
||||
*/
|
||||
|
||||
enum sexp_tags {
|
||||
SEXP_PAIR,
|
||||
SEXP_SYMBOL,
|
||||
SEXP_STRING,
|
||||
SEXP_VECTOR,
|
||||
};
|
||||
|
||||
/* would need a proper header for GC */
|
||||
typedef struct sexp_struct {
|
||||
char tag;
|
||||
void *data1;
|
||||
void *data2;
|
||||
} *sexp;
|
||||
|
||||
#define MAKE_IMMEDIATE(n) ((sexp) ((n<<3) + 6))
|
||||
#define SEXP_NULL MAKE_IMMEDIATE(0)
|
||||
#define SEXP_FALSE MAKE_IMMEDIATE(1)
|
||||
#define SEXP_TRUE MAKE_IMMEDIATE(2)
|
||||
#define SEXP_EOF MAKE_IMMEDIATE(3)
|
||||
#define SEXP_UNDEF MAKE_IMMEDIATE(4)
|
||||
#define SEXP_CLOSE MAKE_IMMEDIATE(5) /* internal use */
|
||||
#define SEXP_ERROR MAKE_IMMEDIATE(6)
|
||||
|
||||
#define SEXP_NULLP(x) ((x) == SEXP_NULL)
|
||||
#define SEXP_POINTERP(x) (((int) x & 3) == 0)
|
||||
#define SEXP_INTEGERP(x) (((int) x & 3) == 1)
|
||||
#define SEXP_CHARP(x) (((int) x & 7) == 2)
|
||||
|
||||
#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_PAIR)
|
||||
#define SEXP_SYMBOLP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_SYMBOL)
|
||||
#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_STRING)
|
||||
|
||||
#define SEXP_ALLOC(size) (malloc(size))
|
||||
#define SEXP_FREE free
|
||||
#define SEXP_NEW() ((sexp) SEXP_ALLOC(sizeof(sexp)))
|
||||
|
||||
#define make_integer(n) ((sexp) (((int) n<<2) + 1))
|
||||
#define unbox_integer(n) ((int) n>>2)
|
||||
#define make_character(n) ((sexp) (((int) n<<3) + 2))
|
||||
#define unbox_character(n) ((int) n>>3)
|
||||
|
||||
#define vector_length(x) ((int) x->data1)
|
||||
#define vector_data(x) ((sexp*) x->data2)
|
||||
|
||||
#define string_length(x) ((int) x->data1)
|
||||
#define string_data(x) ((char*) x->data2)
|
||||
|
||||
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;
|
||||
return pair;
|
||||
}
|
||||
|
||||
sexp car(sexp obj) {
|
||||
return (SEXP_PAIRP(obj)) ? obj->data1 : SEXP_ERROR;
|
||||
}
|
||||
|
||||
sexp cdr(sexp obj) {
|
||||
return (SEXP_PAIRP(obj)) ? obj->data2 : SEXP_ERROR;
|
||||
}
|
||||
|
||||
sexp set_car(sexp obj, sexp val) {
|
||||
if (SEXP_PAIRP(obj)) {
|
||||
return obj->data1 = val;
|
||||
} else {
|
||||
return SEXP_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
sexp set_cdr(sexp obj, sexp val) {
|
||||
if (SEXP_PAIRP(obj)) {
|
||||
return obj->data2 = val;
|
||||
} else {
|
||||
return SEXP_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
sexp nreverse(sexp ls) {
|
||||
sexp a;
|
||||
sexp b;
|
||||
sexp tmp;
|
||||
|
||||
if (ls == SEXP_NULL) {
|
||||
return ls;
|
||||
} else if (! SEXP_PAIRP(ls)) {
|
||||
return SEXP_ERROR;
|
||||
} else {
|
||||
b = ls;
|
||||
a=cdr(ls);
|
||||
set_cdr(b, SEXP_NULL);
|
||||
for ( ; SEXP_PAIRP(a); ) {
|
||||
tmp = cdr(a);
|
||||
set_cdr(a, b);
|
||||
b = a;
|
||||
a = tmp;
|
||||
}
|
||||
return b;
|
||||
}
|
||||
}
|
||||
|
||||
sexp list(int count, ...) {
|
||||
sexp res = SEXP_NULL;
|
||||
sexp elt;
|
||||
int i;
|
||||
va_list ap;
|
||||
|
||||
va_start(ap, count);
|
||||
for (i=0; i<count; i++) {
|
||||
res = cons(va_arg(ap, sexp), res);
|
||||
}
|
||||
va_end(ap);
|
||||
return nreverse(res);
|
||||
}
|
||||
|
||||
int length(sexp ls) {
|
||||
sexp x;
|
||||
int res;
|
||||
for (res=0, x=ls; SEXP_PAIRP(x); res++, x=cdr(x))
|
||||
;
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp make_string(char *str) {
|
||||
sexp s = SEXP_NEW();
|
||||
if (! s) return SEXP_ERROR;
|
||||
int len = strlen(str);
|
||||
char *mystr = SEXP_ALLOC(len+1);
|
||||
if (! mystr) { SEXP_FREE(s); return SEXP_ERROR; }
|
||||
strncpy(mystr, str, len+1);
|
||||
s->tag = SEXP_STRING;
|
||||
s->data1 = (void*) len;
|
||||
s->data2 = (void*) mystr;
|
||||
return s;
|
||||
}
|
||||
|
||||
sexp intern(char *str) {
|
||||
sexp sym = SEXP_NEW();
|
||||
if (! sym) return SEXP_ERROR;
|
||||
int len = strlen(str);
|
||||
char *mystr = SEXP_ALLOC(len+1);
|
||||
if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; }
|
||||
strncpy(mystr, str, len+1);
|
||||
sym->tag = SEXP_SYMBOL;
|
||||
sym->data1 = (void*) len;
|
||||
sym->data2 = (void*) mystr;
|
||||
return sym;
|
||||
}
|
||||
|
||||
sexp make_vector(int len, sexp dflt) {
|
||||
int i;
|
||||
sexp v = SEXP_NEW();
|
||||
if (v == NULL) return SEXP_ERROR;
|
||||
sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp));
|
||||
if (x == NULL) return SEXP_ERROR;
|
||||
for (i=0; i<len; i++) {
|
||||
x[i] = dflt;
|
||||
}
|
||||
v->tag = SEXP_VECTOR;
|
||||
v->data1 = (void*) len;
|
||||
v->data2 = (void*) x;
|
||||
return v;
|
||||
}
|
||||
|
||||
sexp list_to_vector(sexp ls) {
|
||||
sexp vec = make_vector(length(ls), SEXP_FALSE);
|
||||
if (vec == SEXP_ERROR) return vec;
|
||||
sexp x;
|
||||
sexp *elts = vector_data(vec);
|
||||
int i;
|
||||
for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) {
|
||||
elts[i] = car(x);
|
||||
}
|
||||
return vec;
|
||||
}
|
||||
|
||||
sexp vector(int count, ...) {
|
||||
sexp vec = make_vector(count, SEXP_FALSE);
|
||||
if (vec == SEXP_ERROR) return vec;
|
||||
sexp *elts = vector_data(vec);
|
||||
va_list ap;
|
||||
int i;
|
||||
|
||||
va_start(ap, count);
|
||||
for (i=0; i<count; i++) {
|
||||
elts[i] = va_arg(ap, sexp);
|
||||
}
|
||||
va_end(ap);
|
||||
return vec;
|
||||
}
|
||||
|
||||
void write_sexp (FILE *out, sexp obj) {
|
||||
int len, i;
|
||||
sexp x;
|
||||
|
||||
if (SEXP_POINTERP(obj)) {
|
||||
|
||||
switch (obj->tag) {
|
||||
case SEXP_PAIR:
|
||||
fprintf(out, "(");
|
||||
write_sexp(out, car(obj));
|
||||
for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) {
|
||||
fprintf(out, " ");
|
||||
write_sexp(out, car(x));
|
||||
}
|
||||
if (! SEXP_NULLP(x)) {
|
||||
fprintf(out, " . ");
|
||||
write_sexp(out, x);
|
||||
}
|
||||
fprintf(out, ")");
|
||||
break;
|
||||
case SEXP_VECTOR:
|
||||
len = vector_length(obj);
|
||||
sexp *elts = vector_data(obj);
|
||||
if (len == 0) {
|
||||
fprintf(out, "#()");
|
||||
} else {
|
||||
fprintf(out, "#(");
|
||||
write_sexp(out, elts[0]);
|
||||
for (i=1; i<len; i++) {
|
||||
fprintf(out, " ");
|
||||
write_sexp(out, elts[i]);
|
||||
}
|
||||
fprintf(out, ")");
|
||||
}
|
||||
break;
|
||||
case SEXP_STRING:
|
||||
fprintf(out, "\"");
|
||||
/* FALLTHROUGH */
|
||||
case SEXP_SYMBOL:
|
||||
fprintf(out, "%s", string_data(obj));
|
||||
if (obj->tag == SEXP_STRING) {
|
||||
fprintf(out, "\"");
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
} else if (SEXP_INTEGERP(obj)) {
|
||||
|
||||
fprintf(out, "%d", unbox_integer(obj));
|
||||
|
||||
} else if (SEXP_CHARP(obj)) {
|
||||
|
||||
if (33 <= unbox_character(obj) < 127) {
|
||||
fprintf(out, "#\\%c", unbox_character(obj));
|
||||
} else {
|
||||
fprintf(out, "#\\x%02d", unbox_character(obj));
|
||||
}
|
||||
|
||||
} else {
|
||||
|
||||
switch ((int) obj) {
|
||||
case (int) SEXP_NULL:
|
||||
fprintf(out, "()");
|
||||
break;
|
||||
case (int) SEXP_TRUE:
|
||||
fprintf(out, "#t");
|
||||
break;
|
||||
case (int) SEXP_FALSE:
|
||||
fprintf(out, "#f");
|
||||
break;
|
||||
case (int) SEXP_EOF:
|
||||
fprintf(out, "#<eof>");
|
||||
break;
|
||||
case (int) SEXP_UNDEF:
|
||||
fprintf(out, "#<undef>");
|
||||
break;
|
||||
default:
|
||||
fprintf(out, "#<error>");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void* free_sexp (sexp obj) {
|
||||
int len, i;
|
||||
sexp *elts;
|
||||
|
||||
if (SEXP_POINTERP(obj)) {
|
||||
switch (obj->tag) {
|
||||
case SEXP_PAIR:
|
||||
free_sexp(car(obj));
|
||||
free_sexp(cdr(obj));
|
||||
break;
|
||||
case SEXP_VECTOR:
|
||||
len = vector_length(obj);
|
||||
elts = vector_data(obj);
|
||||
for (i=0; i<len; i++) {
|
||||
free_sexp(elts[i]);
|
||||
}
|
||||
SEXP_FREE(elts);
|
||||
break;
|
||||
case SEXP_STRING:
|
||||
case SEXP_SYMBOL:
|
||||
free(string_data(obj));
|
||||
break;
|
||||
}
|
||||
|
||||
SEXP_FREE(obj);
|
||||
}
|
||||
}
|
||||
|
||||
enum sexp_tokens {
|
||||
TOK_OPEN_LIST,
|
||||
TOK_OPEN_VECTOR,
|
||||
TOK_CLOSE,
|
||||
TOK_START_STRING,
|
||||
TOK_SYMBOL,
|
||||
TOK_NUMBER,
|
||||
TOK_QUOTE,
|
||||
TOK_QUASIQUOTE,
|
||||
TOK_UNQUOTE,
|
||||
TOK_UNQUOTE_SPLICING,
|
||||
TOK_EOF,
|
||||
TOK_TRUE,
|
||||
TOK_FALSE,
|
||||
TOK_ERROR,
|
||||
};
|
||||
|
||||
char* read_string(FILE *in) {
|
||||
char *buf, *tmp, *res;
|
||||
char c;
|
||||
int len;
|
||||
|
||||
buf = SEXP_ALLOC(128);
|
||||
tmp = buf;
|
||||
|
||||
for (c=fgetc(in); (c != EOF) && (c != '"'); c=fgetc(in)) {
|
||||
if (c == '\\') {
|
||||
c=fgetc(in);
|
||||
switch (c) {
|
||||
case 'n':
|
||||
c = '\n';
|
||||
case 't':
|
||||
c = '\t';
|
||||
}
|
||||
*tmp++ = c;
|
||||
} else {
|
||||
*tmp++ = c;
|
||||
}
|
||||
}
|
||||
|
||||
*tmp++ = '\0';
|
||||
len = tmp - buf;
|
||||
res = SEXP_ALLOC(len);
|
||||
strncpy(res, buf, len);
|
||||
SEXP_FREE(buf);
|
||||
return res;
|
||||
}
|
||||
|
||||
char* read_symbol(FILE *in) {
|
||||
char *buf, *tmp, *res;
|
||||
char c;
|
||||
int len;
|
||||
|
||||
buf = SEXP_ALLOC(128);
|
||||
tmp = buf;
|
||||
|
||||
while (1) {
|
||||
c=fgetc(in);
|
||||
switch (c) {
|
||||
case '(': case ')': case ';': case ' ': case '\t': case '\r': case '\n':
|
||||
case '\'': case '"': case ',': case EOF:
|
||||
ungetc(c, in);
|
||||
goto done;
|
||||
break;
|
||||
}
|
||||
*tmp++ = c;
|
||||
}
|
||||
done:
|
||||
|
||||
*tmp++ = '\0';
|
||||
len = tmp - buf;
|
||||
res = SEXP_ALLOC(len);
|
||||
strncpy(res, buf, len);
|
||||
SEXP_FREE(buf);
|
||||
return res;
|
||||
}
|
||||
|
||||
int read_number(FILE *in) {
|
||||
int res = 0;
|
||||
int negativep = 0;
|
||||
char c;
|
||||
|
||||
c = fgetc(in);
|
||||
if (c == '-') {
|
||||
negativep = 1;
|
||||
} else if (isdigit(c)) {
|
||||
res = c - '0';
|
||||
}
|
||||
|
||||
for (c=fgetc(in); isdigit(c); c=fgetc(in)) {
|
||||
res = res * 10 + (c - '0');
|
||||
}
|
||||
ungetc(c, in);
|
||||
|
||||
return negativep ? -res : res;
|
||||
}
|
||||
|
||||
int read_token (FILE *in) {
|
||||
int c;
|
||||
scan_loop:
|
||||
while (isspace(c=fgetc(in)))
|
||||
;
|
||||
if (c == EOF)
|
||||
return TOK_EOF;
|
||||
switch (c) {
|
||||
case ';':
|
||||
while ((c=fgetc(in)) != '\n')
|
||||
;
|
||||
goto scan_loop;
|
||||
break;
|
||||
case '\'':
|
||||
return TOK_QUOTE;
|
||||
case '`':
|
||||
return TOK_QUASIQUOTE;
|
||||
case '"':
|
||||
return TOK_START_STRING;
|
||||
case '(':
|
||||
return TOK_OPEN_LIST;
|
||||
case ')':
|
||||
return TOK_CLOSE;
|
||||
case ',':
|
||||
c = fgetc(in);
|
||||
if (c == '@') {
|
||||
return TOK_UNQUOTE_SPLICING;
|
||||
} else {
|
||||
ungetc(c, in);
|
||||
return TOK_UNQUOTE;
|
||||
}
|
||||
case '#':
|
||||
c = fgetc(in);
|
||||
switch (c) {
|
||||
case '(':
|
||||
return TOK_OPEN_VECTOR;
|
||||
case 't':
|
||||
return TOK_TRUE;
|
||||
case 'f':
|
||||
return TOK_FALSE;
|
||||
/* case ';': */
|
||||
/* read_sexp(in); */
|
||||
/* goto scan_loop; */
|
||||
/* case 'b': */
|
||||
/* return TOK_BINARY; */
|
||||
/* case 'o': */
|
||||
/* return TOK_OCTAL; */
|
||||
/* case 'o': */
|
||||
/* return TOK_DECIMAL; */
|
||||
/* case 'x': */
|
||||
/* return TOK_HEXADECIMAL; */
|
||||
/* case 'e': */
|
||||
/* return TOK_EXACT; */
|
||||
/* case 'i': */
|
||||
/* return TOK_INEXACT; */
|
||||
default:
|
||||
return TOK_ERROR;
|
||||
}
|
||||
/* case '+': */
|
||||
/* case '-': */
|
||||
default:
|
||||
ungetc(c, in);
|
||||
return (isdigit(c) || c == '+' || c == '-') ? TOK_NUMBER : TOK_SYMBOL;
|
||||
}
|
||||
}
|
||||
|
||||
sexp read_sexp (FILE *in) {
|
||||
sexp res, tmp, tmp2;
|
||||
char *str;
|
||||
int tok = read_token(in);
|
||||
|
||||
switch (tok) {
|
||||
case TOK_EOF:
|
||||
res = SEXP_EOF;
|
||||
break;
|
||||
case TOK_TRUE:
|
||||
res = SEXP_TRUE;
|
||||
break;
|
||||
case TOK_FALSE:
|
||||
res = SEXP_FALSE;
|
||||
break;
|
||||
case TOK_QUOTE:
|
||||
res = read_sexp(in);
|
||||
res = list(2, intern("quote"), res);
|
||||
break;
|
||||
case TOK_QUASIQUOTE:
|
||||
res = read_sexp(in);
|
||||
res = list(2, intern("quasiquote"), res);
|
||||
break;
|
||||
case TOK_UNQUOTE:
|
||||
res = read_sexp(in);
|
||||
res = list(2, intern("unquote"), res);
|
||||
break;
|
||||
case TOK_UNQUOTE_SPLICING:
|
||||
res = read_sexp(in);
|
||||
res = list(2, intern("unquote-splicing"), res);
|
||||
break;
|
||||
case TOK_OPEN_LIST:
|
||||
case TOK_OPEN_VECTOR:
|
||||
res = SEXP_NULL;
|
||||
tmp = read_sexp(in);
|
||||
while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) {
|
||||
if ((tok == TOK_OPEN_LIST) && SEXP_SYMBOLP(tmp)
|
||||
&& (strncmp(string_data(tmp), ".", 2) == 0)) {
|
||||
/* dotted list */
|
||||
free_sexp(tmp);
|
||||
tmp = read_sexp(in);
|
||||
if (read_token(in) != TOK_CLOSE) {
|
||||
res = SEXP_ERROR;
|
||||
} else {
|
||||
tmp2 = res;
|
||||
res = nreverse(res);
|
||||
set_cdr(tmp2, tmp);
|
||||
return res;
|
||||
}
|
||||
} else {
|
||||
res = cons(tmp, res);
|
||||
tmp = read_sexp(in);
|
||||
}
|
||||
}
|
||||
if (tmp != SEXP_CLOSE) {
|
||||
free_sexp(res);
|
||||
res = SEXP_ERROR;
|
||||
}
|
||||
res = nreverse(res);
|
||||
if (tok == TOK_OPEN_VECTOR) {
|
||||
tmp = res;
|
||||
res = list_to_vector(tmp);
|
||||
free_sexp(tmp);
|
||||
}
|
||||
break;
|
||||
case TOK_START_STRING:
|
||||
str = read_string(in);
|
||||
res = make_string(str);
|
||||
free(str);
|
||||
break;
|
||||
case TOK_SYMBOL:
|
||||
str = read_symbol(in);
|
||||
res = intern(str);
|
||||
free(str);
|
||||
break;
|
||||
case TOK_NUMBER:
|
||||
res = make_integer(read_number(in));
|
||||
break;
|
||||
case TOK_CLOSE:
|
||||
res = SEXP_CLOSE;
|
||||
break;
|
||||
case TOK_ERROR:
|
||||
default:
|
||||
res = SEXP_ERROR;
|
||||
break;
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
int main (int argc, char **argv) {
|
||||
sexp obj;
|
||||
|
||||
/* sample object */
|
||||
/* write_sexp(stdout, list(6, */
|
||||
/* intern("foo"), */
|
||||
/* make_integer(2), */
|
||||
/* make_string("bar"), */
|
||||
/* make_character('d'), */
|
||||
/* vector(2, intern("baz"), intern("qux")), */
|
||||
/* SEXP_TRUE)); */
|
||||
/* fprintf(stdout, "\n"); */
|
||||
|
||||
/* rpl (repl without the eval) */
|
||||
fprintf(stdout, "> ");
|
||||
fflush(stdout);
|
||||
while ((obj = read_sexp(stdin)) != SEXP_EOF) {
|
||||
write_sexp(stdout, obj);
|
||||
fprintf(stdout, "\n> ");
|
||||
fflush(stdout);
|
||||
}
|
||||
fprintf(stdout, "\n");
|
||||
return 0;
|
||||
}
|
||||
4
sexp.c
4
sexp.c
|
|
@ -102,9 +102,11 @@ sexp cdr(sexp obj) {
|
|||
sexp set_car(sexp obj, sexp val) {
|
||||
if (SEXP_PAIRP(obj))
|
||||
return SEXP_CAR(obj) = val;
|
||||
else
|
||||
else {
|
||||
sexp_debug("error: set-car! not a pair: ", obj);
|
||||
return SEXP_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
sexp set_cdr(sexp obj, sexp val) {
|
||||
if (SEXP_PAIRP(obj))
|
||||
|
|
|
|||
2
sexp.h
2
sexp.h
|
|
@ -19,7 +19,7 @@
|
|||
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
|
||||
#endif
|
||||
|
||||
#define sexp_debug(msg, obj, ...) (fprintf(stderr,msg,__VA_ARGS__), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n"))
|
||||
#define sexp_debug(msg, obj) (fprintf(stderr,msg), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n"))
|
||||
|
||||
#ifdef USE_BOEHM
|
||||
#include "gc/include/gc.h"
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue