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

adding initial test suite

Browse source
This commit is contained in:
Alex Shinn 2009-03-15 14:07:28 +09:00
parent f42a866d94
commit f3a4e8c310
11 changed files with 130 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
Makefile
View file

@ -29,3 +29,13 @@ cleaner: clean
rm -f chibi-scheme
rm -rf *.dSYM
test: chibi-scheme
for f in tests/*.scm; do \
./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
if diff -q $${f%.scm}.out $${f%.scm}.res; then \
echo "[PASS] $${f%.scm}"; \
else \
echo "[FAIL] $${f%.scm}"; \
fi; \
done

54
eval.c
View file

@ -282,7 +282,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
&& (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)
&& sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) {
/* let */
tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj)));
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj))));
e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)+(tmp1-1));
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, 0);
@ -330,7 +330,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e,
case OPC_CONSTRUCTOR:
case OPC_ACCESSOR:
case OPC_GENERIC:
tmp1 = sexp_length(SEXP_CDR(obj));
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
if (tmp1 == 0) {
errx(1, "opcode with no arguments: %s", op->name);
} else if (tmp1 == 1) {
@ -355,7 +355,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e,
}
break;
case OPC_IO:
tmp1 = sexp_length(SEXP_CDR(obj));
tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
if (tmp1 == op->num_args && op->var_args_p) {
emit(bc, i, OP_PARAMETER);
emit_word(bc, i, (sexp_uint_t) op->data);
@ -378,7 +378,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e,
}
emit_push(bc, i, op->data);
emit(bc, i, op->op_name);
(*d) -= (sexp_length(SEXP_CDR(obj))-1);
(*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1);
break;
default:
errx(1, "unknown opcode class: %d", op->op_class);
@ -418,7 +418,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e,
void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e,
sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) {
sexp o1;
unsigned long len = sexp_length(SEXP_CDR(obj));
sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj)));
/* push the arguments onto the stack */
for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) {
@ -430,10 +430,8 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e,
/* maybe overwrite the current frame */
if (tailp) {
fprintf(stderr, "compiling tail call: %d + %d + 3 = %d\n",
sexp_length(params), (*d), sexp_length(params)+(*d)+3);
emit(bc, i, OP_TAIL_CALL);
emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)+3));
emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3));
emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
} else {
/* normal call */
@ -514,7 +512,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0);
/* push the closed vars */
emit_push(bc, i, SEXP_UNDEF);
emit_push(bc, i, sexp_make_integer(sexp_length(fv2)));
emit_push(bc, i, sexp_length(fv2));
emit(bc, i, OP_MAKE_VECTOR);
(*d)++;
for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) {
@ -528,7 +526,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body,
}
/* push the additional procedure info and make the closure */
emit_push(bc, i, obj);
emit_push(bc, i, sexp_make_integer(sexp_length(formals)));
emit_push(bc, i, sexp_length(formals));
emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1));
emit(bc, i, OP_MAKE_PROCEDURE);
}
@ -600,7 +598,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
}
}
obj = sexp_reverse(ls);
j = sexp_length(internals);
j = sexp_unbox_integer(sexp_length(internals));
if (SEXP_PAIRP(internals)) {
/* sexp_write_string("internals: ", cur_error_port); */
/* sexp_write(internals, cur_error_port); */
@ -642,7 +640,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
sexp sexp_save_stack(sexp *stack, unsigned int to) {
sexp res, *data;
int i;
res = sexp_make_vector(to, SEXP_UNDEF);
res = sexp_make_vector(sexp_make_integer(to), SEXP_UNDEF);
data = sexp_vector_data(res);
for (i=0; i<to; i++)
data[i] = stack[i];
@ -739,7 +737,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top-=3;
break;
case OP_MAKE_VECTOR:
stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]);
stack[top-2]=sexp_make_vector(stack[top-1], stack[top-2]);
top--;
break;
case OP_PUSH:
@ -924,7 +922,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
/* print_stack(stack, top); */
tmp1 = stack[top-1];
tmp2 = stack[top-2];
i = sexp_length(tmp2);
i = sexp_unbox_integer(sexp_length(tmp2));
top += (i-2);
for ( ; SEXP_PAIRP(tmp2); tmp2=SEXP_CDR(tmp2), top--)
stack[top-1] = SEXP_CAR(tmp2);
@ -938,13 +936,14 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
stack[top] = sexp_make_integer(1);
stack[top+1] = sexp_make_integer(ip);
stack[top+2] = cp;
tmp2 = sexp_save_stack(stack, top+3);
/* fprintf(stderr, "saved: ", top); */
/* sexp_write(tmp2, cur_error_port); */
/* fprintf(stderr, "\n", top); */
tmp2 = sexp_make_vector(sexp_make_integer(1), SEXP_UNDEF);
sexp_vector_set(tmp2, sexp_make_integer(1), sexp_save_stack(stack, top+3));
stack[top-1] = sexp_make_procedure(0, (int) sexp_make_integer(1),
continuation_resumer,
sexp_vector(1, tmp2));
tmp2);
top+=3;
bc = sexp_procedure_code(tmp1);
ip = bc->data;
@ -1164,6 +1163,7 @@ _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"),
{SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL},
{SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL},
{SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL},
_FN1(SEXP_PAIR, "length", sexp_length),
_FN1(SEXP_PAIR, "reverse", sexp_reverse),
_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file),
@ -1269,18 +1269,13 @@ int main (int argc, char **argv) {
env_define(e, err_handler_sym, err_handler);
exception_handler_cell = env_cell(e, err_handler_sym);
fprintf(stderr, "current-input-port: %d => %d\n", &cur_input_port, cur_input_port);
/* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) {
switch (argv[i][1]) {
case 'e':
case 'p':
if (! init_loaded) {
if (stream = fopen(sexp_init_file, "r")) {
sexp_load(sexp_make_input_port(stream));
fclose(stream);
}
sexp_load(sexp_make_string(sexp_init_file));
init_loaded = 1;
}
obj = sexp_read_from_string(argv[i+1]);
@ -1301,14 +1296,13 @@ int main (int argc, char **argv) {
}
if (! quit) {
if (! init_loaded) {
if (stream = fopen(sexp_init_file, "r")) {
sexp_load(sexp_make_input_port(stream));
fclose(stream);
}
init_loaded = 1;
}
repl(e, stack);
if (! init_loaded)
sexp_load(sexp_make_string(sexp_init_file));
if (i < argc)
for ( ; i < argc; i++)
sexp_load(sexp_make_string(argv[i]));
else
repl(e, stack);
}
return 0;
}

6
init.scm
View file

@ -68,6 +68,12 @@
(map1 cdr lol '())
(cons (apply1 proc (map1 car lol '())) res))))
;; math utilities
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
(define (negative? x) (< x 0))
;; syntax
(define-syntax let

35
sexp.c
View file

@ -160,23 +160,11 @@ sexp sexp_append(sexp a, sexp b) {
return b;
}
sexp sexp_list(int count, ...) {
sexp res = SEXP_NULL;
int i;
va_list ap;
va_start(ap, count);
for (i=0; i<count; i++)
res = sexp_cons(va_arg(ap, sexp), res);
va_end(ap);
return sexp_nreverse(res);
}
unsigned long sexp_length(sexp ls) {
sexp x;
unsigned long res;
for (res=0, x=ls; SEXP_PAIRP(x); res++, x=SEXP_CDR(x))
sexp sexp_length(sexp ls) {
sexp_uint_t res=0;
for ( ; SEXP_PAIRP(ls); res++, ls=SEXP_CDR(ls))
;
return res;
return sexp_make_integer(res);
}
/********************* strings, symbols, vectors **********************/
@ -264,17 +252,17 @@ sexp sexp_intern(char *str) {
return symbol_table[cell];
}
sexp sexp_make_vector(unsigned int len, sexp dflt) {
int i;
sexp sexp_make_vector(sexp len, sexp dflt) {
sexp v, *x;
if (! len) return the_empty_vector;
int i, clen = sexp_unbox_integer(len);
if (! clen) return the_empty_vector;
v = SEXP_NEW();
x = (void*) SEXP_ALLOC(len*sizeof(sexp));
for (i=0; i<len; i++) {
x = (void*) SEXP_ALLOC(clen*sizeof(sexp));
for (i=0; i<clen; i++) {
x[i] = dflt;
}
v->tag = SEXP_VECTOR;
v->data1 = (void*) len;
v->data1 = (void*) clen;
v->data2 = (void*) x;
return v;
}
@ -289,7 +277,7 @@ sexp sexp_list_to_vector(sexp ls) {
}
sexp sexp_vector(int count, ...) {
sexp vec = sexp_make_vector(count, SEXP_UNDEF);
sexp vec = sexp_make_vector(sexp_make_integer(count), SEXP_UNDEF);
sexp *elts = sexp_vector_data(vec);
va_list ap;
int i;
@ -593,6 +581,7 @@ sexp sexp_read_raw (sexp in) {
/* ... FALLTHROUGH ... */
case ' ':
case '\t':
case '\r':
case '\n':
goto scan_loop;
case '\'':

5
sexp.h
View file

@ -225,15 +225,14 @@ sexp sexp_lset_diff(sexp a, sexp b);
sexp sexp_reverse(sexp ls);
sexp sexp_nreverse(sexp ls);
sexp sexp_append(sexp a, sexp b);
sexp sexp_list(int count, ...);
sexp sexp_memq(sexp x, sexp ls);
sexp sexp_assq(sexp x, sexp ls);
unsigned long sexp_length(sexp ls);
sexp sexp_length(sexp ls);
sexp sexp_make_string(char *str);
sexp sexp_make_flonum(double f);
int sexp_string_hash(char *str, int acc);
sexp sexp_intern(char *str);
sexp sexp_make_vector(unsigned int len, sexp dflt);
sexp sexp_make_vector(sexp len, sexp dflt);
sexp sexp_list_to_vector(sexp ls);
sexp sexp_vector(int count, ...);
void sexp_write(sexp obj, sexp out);

1
tests/test00-fact-3.res Normal file
View file

@ -0,0 +1 @@
(fact 3) => 6

14
tests/test00-fact-3.scm Normal file
View file

@ -0,0 +1,14 @@
(define (fact-helper x res)
(if (zero? x)
res
(fact-helper (- x 1) (* res x))))
(define (fact x)
(fact-helper x 1))
(display "(fact 3) => ")
(write (fact 3))
(newline)

8
tests/test01-apply.res Normal file
View file

@ -0,0 +1,8 @@
11
(11 10 9 8 7 6 5 4 3 2 1)
(1 2 3 4)
100
100
100
100
100

18
tests/test01-apply.scm Normal file
View file

@ -0,0 +1,18 @@
(define foo
(lambda (a b c d e f g h)
(+ (+ (* a b) (* c d)) (+ (* e f) (* g h)))))
(define (writeln x)
(write x)
(newline))
(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11))))
(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))
(writeln (append (list 1 2) (list 3 4)))
(writeln (foo 1 2 3 4 5 6 7 8))
(writeln (apply foo (list 1 2 3 4 5 6 7 8)))
(writeln (apply foo 1 (list 2 3 4 5 6 7 8)))
(writeln (apply foo 1 2 3 4 (list 5 6 7 8)))
(writeln (apply foo 1 2 3 4 5 (list 6 7 8)))

1
tests/test02-callcc.res Normal file
View file

@ -0,0 +1 @@
543

34
tests/test02-callcc.scm Normal file
View file

@ -0,0 +1,34 @@
(define fail
(lambda () 999999))
(define in-range
(lambda (a b)
(call-with-current-continuation
(lambda (cont)
(enumerate a b cont)))))
(define enumerate
(lambda (a b cont)
(if (< b a)
(fail)
(let ((save fail))
(begin
(set! fail
(lambda ()
(begin
(set! fail save)
(enumerate (+ a 1) b cont))))
(cont a))))))
(write
(let ((x (in-range 2 9))
(y (in-range 2 9))
(z (in-range 2 9)))
(if (= (* x x)
(+ (* y y) (* z z)))
(+ (* x 100) (+ (* y 10) z))
(fail))))
(newline)