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

initial ffi support

Browse source
This commit is contained in:
Alex Shinn 2009-03-05 23:55:37 +09:00
parent fde01c5700
commit 1dd2afa685
6 changed files with 191 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
Makefile
View file

@ -10,13 +10,16 @@ GC_OBJ=./gc/gc.a
$GC_OBJ: ./gc/alloc.c $GC_OBJ: ./gc/alloc.c
cd gc && make test cd gc && make test
sexp.o: sexp.c sexp.h config.h sexp.o: sexp.c sexp.h config.h Makefile
gcc -c $(CFLAGS) -o $@ $< gcc -c $(CFLAGS) -o $@ $<
eval.o: eval.c debug.c eval.h sexp.h config.h eval.o: eval.c debug.c eval.h sexp.h config.h Makefile
gcc -c $(CFLAGS) -o $@ $< gcc -c $(CFLAGS) -o $@ $<
chibi-scheme: sexp.o eval.o $(GC_OBJ) # main.o: main.c eval.h sexp.h config.h Makefile
# gcc -c $(CFLAGS) -o $@ $<
chibi-scheme: eval.o sexp.o $(GC_OBJ)
gcc $(CFLAGS) -o $@ $^ gcc $(CFLAGS) -o $@ $^
clean: clean:

15
debug.c
View file

@ -3,13 +3,14 @@
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
static const char* reverse_opcode_names[] = static const char* reverse_opcode_names[] =
{"NOOP", "CALL", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", {"NOOP", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5",
"STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", "FCALL6", "FCALL7", "FCALLN", "JUMP_UNLESS", "JUMP", "RET", "DONE",
"VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF",
"PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE",
"SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "CAR", "CDR", "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP",
"SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP",
"INV", "LT", "LE", "GT", "GE", "EQN", "EQ"}; "OPORTP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL",
"DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ",};
void disasm (bytecode bc) { void disasm (bytecode bc) {
unsigned char *ip=bc->data, opcode; unsigned char *ip=bc->data, opcode;

241
eval.c
View file

@ -9,53 +9,7 @@
static int scheme_initialized_p = 0; static int scheme_initialized_p = 0;
static sexp cur_input_port, cur_output_port, cur_error_port; static sexp cur_input_port, cur_output_port, cur_error_port;
static sexp exception_handler;
static struct core_form core_forms[] = {
{SEXP_CORE, "define", CORE_DEFINE},
{SEXP_CORE, "set!", CORE_SET},
{SEXP_CORE, "lambda", CORE_LAMBDA},
{SEXP_CORE, "if", CORE_IF},
{SEXP_CORE, "begin", CORE_BEGIN},
{SEXP_CORE, "quote", CORE_QUOTE},
{SEXP_CORE, "define-syntax", CORE_DEFINE_SYNTAX},
{SEXP_CORE, "let-syntax", CORE_LET_SYNTAX},
{SEXP_CORE, "letrec-syntax", CORE_LETREC_SYNTAX},
};
static struct opcode opcodes[] = {
#define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL}
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, "car",0),
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, "set-car!",0),
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr",0),
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, "set-cdr!",0),
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-ref",0),
_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-set!",0),
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, "string-ref",0),
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, "string-set!",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_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, "<=", 0),
_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, ">", 0),
_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, ">=", 0),
_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, "=", 0),
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, "eq?", 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),
_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, "pair?", 0),
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, "null?", 0),
_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, "string?", 0),
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, "symbol?", 0),
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, "char?", 0),
_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, "vector?", 0),
_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, "procedure?", 0),
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, "eof-object?", 0),
#undef _OP
};
#ifdef USE_DEBUG #ifdef USE_DEBUG
#include "debug.c" #include "debug.c"
@ -131,21 +85,6 @@ env extend_env_closure (env e, sexp fv) {
return e2; return e2;
} }
env make_standard_env() {
int i;
env e = (env) SEXP_ALLOC(sizeof(struct env));
e->tag = SEXP_ENV;
e->parent = NULL;
e->bindings = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) {
env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i]));
}
for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) {
env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i]));
}
return e;
}
/************************* bytecode utilities ***************************/ /************************* bytecode utilities ***************************/
void shrink_bcode(bytecode *bc, unsigned int i) { void shrink_bcode(bytecode *bc, unsigned int i) {
@ -290,6 +229,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
emit(bc, i, ((opcode)o1)->op_inverse); emit(bc, i, ((opcode)o1)->op_inverse);
} else { } else {
analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d);
if (((opcode)o1)->op_class != OPC_ARITHMETIC) {
emit(bc, i, ((opcode)o1)->op_name);
(*d)--;
}
} }
} else { } else {
for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2);
@ -301,11 +244,20 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
(*d) -= sexp_length(SEXP_CDDR(obj)); (*d) -= sexp_length(SEXP_CDDR(obj));
} }
break; break;
case OPC_FOREIGN:
for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2);
o2 = SEXP_CDR(o2)) {
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
}
emit_push(bc, i, ((opcode)o1)->data);
emit(bc, i, ((opcode)o1)->op_name);
(*d) -= sexp_length(SEXP_CDR(obj));
break;
default: default:
errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class);
} }
} else { } else {
/* function call */ /* general procedure call */
analyze_app(obj, bc, i, e, params, fv, sv, d); analyze_app(obj, bc, i, e, params, fv, sv, d);
} }
} else if (SEXP_PAIRP(SEXP_CAR(obj))) { } else if (SEXP_PAIRP(SEXP_CAR(obj))) {
@ -585,38 +537,31 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top-1]=tmp; stack[top-1]=tmp;
break; break;
case OP_PAIRP: case OP_PAIRP:
stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_NULLP: case OP_NULLP:
stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_CHARP: case OP_CHARP:
stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_INTEGERP: case OP_INTEGERP:
stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_SYMBOLP: case OP_SYMBOLP:
stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_STRINGP: case OP_STRINGP:
stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_VECTORP: case OP_VECTORP:
stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_PROCEDUREP: case OP_PROCEDUREP:
stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
break; case OP_IPORTP:
stack[top-1]=SEXP_IPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_OPORTP:
stack[top-1]=SEXP_OPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_EOFP: case OP_EOFP:
stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break;
break;
case OP_CAR: case OP_CAR:
stack[top-1]=sexp_car(stack[top-1]); stack[top-1]=sexp_car(stack[top-1]); break;
break;
case OP_CDR: case OP_CDR:
stack[top-1]=sexp_cdr(stack[top-1]); stack[top-1]=sexp_cdr(stack[top-1]); break;
break;
case OP_SET_CAR: case OP_SET_CAR:
sexp_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;
@ -693,6 +638,21 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/* fprintf(stderr, "stack at %d\n", top); */ /* fprintf(stderr, "stack at %d\n", top); */
/* print_stack(stack, top); */ /* print_stack(stack, top); */
break; break;
case OP_FCALL0:
stack[top-1]=((sexp_proc0)stack[top-1])();
break;
case OP_FCALL1:
stack[top-2]=((sexp_proc1)stack[top-1])(stack[top-2]);
top--;
break;
case OP_FCALL2:
stack[top-3]=((sexp_proc2)stack[top-1])(stack[top-2],stack[top-3]);
top-=2;
break;
case OP_FCALL3:
stack[top-4]=((sexp_proc3)stack[top-1])(stack[top-2],stack[top-3],stack[top-4]);
top-=3;
break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]);
if (stack[--top] == SEXP_FALSE) { if (stack[--top] == SEXP_FALSE) {
@ -742,6 +702,85 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/************************** eval interface ****************************/ /************************** eval interface ****************************/
static const struct core_form core_forms[] = {
{SEXP_CORE, CORE_DEFINE, "define"},
{SEXP_CORE, CORE_SET, "set!"},
{SEXP_CORE, CORE_LAMBDA, "lambda"},
{SEXP_CORE, CORE_IF, "if"},
{SEXP_CORE, CORE_BEGIN, "begin"},
{SEXP_CORE, CORE_QUOTE, "quote"},
{SEXP_CORE, CORE_DEFINE_SYNTAX, "define-syntax"},
{SEXP_CORE, CORE_LET_SYNTAX, "let-syntax"},
{SEXP_CORE, CORE_LETREC_SYNTAX, "letrec-syntax"},
};
static const struct opcode opcodes[] = {
#define _OP(c,o,n,m,t,u,i,s) {SEXP_OPCODE, c, o, n, m, t, u, i, s, NULL, NULL}
#define _FN(o,n,t,u,s,f) {SEXP_OPCODE, OPC_FOREIGN, o, n, 0, t,u, 0, s, (sexp)f, NULL}
#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f)
#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f)
#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f)
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"),
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"),
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"),
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!"),
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref"),
_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_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_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<="),
_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">"),
_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">="),
_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_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?"),
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?"),
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?"),
_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?"),
_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"),
_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"),
_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"),
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"),
_FN1(SEXP_PAIR, "reverse", sexp_reverse),
_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
_FN2(0, SEXP_PAIR, "memq", sexp_memq),
_FN2(0, SEXP_PAIR, "assq", sexp_assq),
_FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff),
#undef _OP
#undef _FN
#undef _FN0
#undef _FN1
#undef _FN2
};
env make_standard_env() {
int i;
env e = (env) SEXP_ALLOC(sizeof(struct env));
e->tag = SEXP_ENV;
e->parent = NULL;
e->bindings = SEXP_NULL;
for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) {
env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i]));
}
for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) {
env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i]));
}
return e;
}
/************************** eval interface ****************************/
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, sexp_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);
@ -765,6 +804,22 @@ void scheme_init() {
} }
} }
void repl (env e, sexp *stack) {
sexp obj, res;
while (1) {
fprintf(stdout, "> ");
fflush(stdout);
obj = sexp_read(cur_input_port);
if (obj == SEXP_EOF)
break;
res = eval_in_stack(obj, e, stack, 0);
if (res != SEXP_UNDEF) {
sexp_write(res, cur_output_port);
sexp_write_char('\n', cur_output_port);
}
}
}
int main (int argc, char **argv) { int main (int argc, char **argv) {
sexp obj, res, in, out, *stack; sexp obj, res, in, out, *stack;
env e; env e;
@ -793,21 +848,7 @@ int main (int argc, char **argv) {
} }
} }
/* repl */ repl(e, stack);
while (! quit) {
fprintf(stdout, "> ");
fflush(stdout);
obj = sexp_read(cur_input_port);
if (obj == SEXP_EOF) {
quit = 1;
} else {
res = eval_in_stack(obj, e, stack, 0);
if (res != SEXP_UNDEF) {
sexp_write(res, cur_output_port);
sexp_write_char('\n', cur_output_port);
}
}
}
return 0; return 0;
} }

32
eval.h
View file

@ -2,8 +2,8 @@
/* 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 SCM_EVAL_H #ifndef SEXP_EVAL_H
#define SCM_EVAL_H #define SEXP_EVAL_H
#include "sexp.h" #include "sexp.h"
@ -14,6 +14,15 @@
#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)) #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 sexp (*sexp_proc0) ();
typedef sexp (*sexp_proc1) (sexp);
typedef sexp (*sexp_proc2) (sexp, sexp);
typedef sexp (*sexp_proc3) (sexp, sexp, sexp);
typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp);
typedef struct bytecode { typedef struct bytecode {
char tag; char tag;
unsigned int len; unsigned int len;
@ -37,15 +46,16 @@ typedef struct opcode {
char var_args_p; char var_args_p;
char arg1_type; char arg1_type;
char arg2_type; char arg2_type;
char* name;
char op_inverse; char op_inverse;
char* name;
sexp data;
sexp proc; sexp proc;
} *opcode; } *opcode;
typedef struct core_form { typedef struct core_form {
char tag; char tag;
char* name;
char code; char code;
char* name;
} *core_form; } *core_form;
enum core_form_names { enum core_form_names {
@ -69,11 +79,21 @@ enum opcode_classes {
OPC_ARITHMETIC_CMP, OPC_ARITHMETIC_CMP,
OPC_CONSTRUCTOR, OPC_CONSTRUCTOR,
OPC_ACCESSOR, OPC_ACCESSOR,
OPC_FOREIGN,
}; };
enum opcode_names { enum opcode_names {
OP_NOOP, OP_NOOP,
OP_CALL, OP_CALL,
OP_FCALL0,
OP_FCALL1,
OP_FCALL2,
OP_FCALL3,
OP_FCALL4,
OP_FCALL5,
OP_FCALL6,
OP_FCALL7,
OP_FCALLN,
OP_JUMP_UNLESS, OP_JUMP_UNLESS,
OP_JUMP, OP_JUMP,
OP_RET, OP_RET,
@ -102,6 +122,8 @@ enum opcode_names {
OP_CHARP, OP_CHARP,
OP_EOFP, OP_EOFP,
OP_PROCEDUREP, OP_PROCEDUREP,
OP_IPORTP,
OP_OPORTP,
OP_CAR, OP_CAR,
OP_CDR, OP_CDR,
OP_SET_CAR, OP_SET_CAR,
@ -139,5 +161,5 @@ 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);
sexp eval(sexp obj, env e); sexp eval(sexp obj, env e);
#endif /* ! SCM_EVAL_H */ #endif /* ! SEXP_EVAL_H */

12
sexp.c
View file

@ -252,25 +252,26 @@ sexp sexp_intern(char *str) {
} }
symbol_table_count++; symbol_table_count++;
resize:
if (symbol_table_count*5 > d*4) { if (symbol_table_count*5 > d*4) {
fprintf(stderr, "resizing symbol table!!!!!\n");
newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++] newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++]
* sizeof(sexp)); * sizeof(sexp));
/* XXXX rehash */
SEXP_FREE(symbol_table); SEXP_FREE(symbol_table);
symbol_table = newtable; symbol_table = newtable;
} }
new_entry:
sym = SEXP_NEW(); sym = SEXP_NEW();
if (! sym) return SEXP_ERROR; if (! sym) { return SEXP_ERROR; }
len = strlen(str); len = strlen(str);
mystr = SEXP_ALLOC(len+1); mystr = SEXP_ALLOC(len+1);
if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; }
memcpy(mystr, str, len+1); memcpy(mystr, str, len+1);
mystr[len]=0;
sym->tag = SEXP_SYMBOL; sym->tag = SEXP_SYMBOL;
sym->data1 = (void*) len; sym->data1 = (void*) len;
sym->data2 = (void*) mystr; sym->data2 = (void*) mystr;
symbol_table[cell] = (sexp) (((sexp_uint_t)sym) + 3); symbol_table[cell] = sym;
return symbol_table[cell]; return symbol_table[cell];
} }
@ -381,7 +382,8 @@ sexp sexp_get_output_string(sexp port) {
#endif #endif
void sexp_write (sexp obj, sexp out) { void sexp_write (sexp obj, sexp out) {
unsigned long len, i, c, res; unsigned long len, c, res;
long i;
sexp x, *elts; sexp x, *elts;
char *str; char *str;

5
sexp.h
View file

@ -63,6 +63,7 @@
#define SEXP_CHAR_TAG 6 #define SEXP_CHAR_TAG 6
enum sexp_types { enum sexp_types {
SEXP_OBJECT,
SEXP_FIXNUM, SEXP_FIXNUM,
SEXP_CHAR, SEXP_CHAR,
SEXP_BOOLEAN, SEXP_BOOLEAN,
@ -174,7 +175,7 @@ void sexp_write_string(sexp str, sexp port);
void sexp_printf(sexp port, sexp fmt, ...); void sexp_printf(sexp port, sexp fmt, ...);
#endif #endif
#define sexp_symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) #define sexp_symbol_pointer(x) (x)
#define sexp_symbol_length(x) ((sexp_uint_t) (sexp_symbol_pointer(x)->data1)) #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_symbol_data(x) ((char*) (sexp_symbol_pointer(x)->data2))
@ -205,8 +206,6 @@ void sexp_printf(sexp port, sexp fmt, ...);
sexp sexp_cons(sexp head, sexp tail); sexp sexp_cons(sexp head, sexp tail);
sexp sexp_car(sexp obj); sexp sexp_car(sexp obj);
sexp sexp_cdr(sexp obj); sexp sexp_cdr(sexp obj);
sexp sexp_set_car(sexp obj, sexp val);
sexp sexp_set_cdr(sexp obj, sexp val);
int sexp_listp(sexp obj); int sexp_listp(sexp obj);
int sexp_list_index(sexp ls, sexp elt); int sexp_list_index(sexp ls, sexp elt);