mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 15:07:34 +02:00
wow, looks like all tests pass...
This commit is contained in:
parent
373e2788cc
commit
45fe39b2db
13 changed files with 102 additions and 48 deletions
|
@ -12,7 +12,6 @@ junk*
|
|||
*.tar.bz2
|
||||
*.log
|
||||
*.err
|
||||
*.res
|
||||
*.out
|
||||
gc
|
||||
gc6.8
|
||||
|
|
55
eval.c
55
eval.c
|
@ -103,17 +103,19 @@ static sexp sexp_flatten_dot (sexp ls) {
|
|||
return sexp_nreverse(sexp_reverse_flatten_dot(ls));
|
||||
}
|
||||
|
||||
static int sexp_param_index (sexp params, sexp name) {
|
||||
int i=0;
|
||||
while (sexp_pairp(params)) {
|
||||
if (sexp_car(params) == name)
|
||||
static int sexp_param_index (sexp lambda, sexp name) {
|
||||
sexp ls = sexp_lambda_params(lambda);
|
||||
int i = 0;
|
||||
for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
|
||||
if (sexp_car(ls) == name)
|
||||
return i;
|
||||
params = sexp_cdr(params);
|
||||
i++;
|
||||
}
|
||||
if (params == name)
|
||||
if (ls == name)
|
||||
return i;
|
||||
return -1;
|
||||
ls = sexp_lambda_locals(lambda);
|
||||
for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--)
|
||||
if (sexp_car(ls) == name)
|
||||
return i;
|
||||
return -10000;
|
||||
}
|
||||
|
||||
/************************* bytecode utilities ***************************/
|
||||
|
@ -150,8 +152,10 @@ static void emit(char c, sexp context) {
|
|||
}
|
||||
|
||||
static void emit_word(sexp_uint_t val, sexp context) {
|
||||
unsigned char *data;
|
||||
expand_bcode(context, sizeof(sexp));
|
||||
*((sexp_uint_t*)(&(sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)]))) = val;
|
||||
data = sexp_bytecode_data(sexp_context_bc(context));
|
||||
*((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val;
|
||||
sexp_context_pos(context) += sizeof(sexp);
|
||||
}
|
||||
|
||||
|
@ -324,6 +328,7 @@ static sexp analyze_lambda (sexp x, sexp context) {
|
|||
sexp_lambda_params(res) = sexp_cadr(x);
|
||||
sexp_lambda_fv(res) = SEXP_NULL;
|
||||
sexp_lambda_sv(res) = SEXP_NULL;
|
||||
sexp_lambda_locals(res) = SEXP_NULL;
|
||||
context = sexp_child_context(context, res);
|
||||
sexp_context_env(context)
|
||||
= extend_env(sexp_context_env(context),
|
||||
|
@ -514,12 +519,10 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda,
|
|||
sexp fv, sexp context, int unboxp) {
|
||||
sexp_uint_t i;
|
||||
sexp loc = sexp_cdr(cell);
|
||||
sexp_debug("cell: ", cell);
|
||||
if (loc == lambda && sexp_lambdap(lambda)) {
|
||||
/* local ref */
|
||||
sexp_debug("params: ", sexp_lambda_params(lambda));
|
||||
emit(OP_LOCAL_REF, context);
|
||||
emit_word(sexp_param_index(sexp_lambda_params(lambda), name), context);
|
||||
emit_word(sexp_param_index(lambda, name), context);
|
||||
} else {
|
||||
/* closure ref */
|
||||
for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
|
||||
|
@ -642,9 +645,12 @@ static void generate_lambda (sexp lambda, sexp context) {
|
|||
fv = sexp_lambda_fv(lambda);
|
||||
ctx = sexp_new_context(sexp_context_stack(context));
|
||||
sexp_context_lambda(ctx) = lambda;
|
||||
/* allocate space for local vars */
|
||||
for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
emit_push(SEXP_UNDEF, ctx);
|
||||
/* box mutable vars */
|
||||
for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
||||
k = sexp_param_index(sexp_lambda_params(lambda), sexp_car(ls));
|
||||
k = sexp_param_index(lambda, sexp_car(ls));
|
||||
if (k >= 0) {
|
||||
emit(OP_LOCAL_REF, ctx);
|
||||
emit_word(k, ctx);
|
||||
|
@ -710,7 +716,7 @@ static sexp diff_free_vars (sexp fv, sexp params) {
|
|||
/* sexp_debug("diff-free-vars: ", fv); */
|
||||
/* sexp_debug("params: ", params); */
|
||||
for ( ; sexp_pairp(fv); fv=sexp_cdr(fv))
|
||||
if (sexp_param_index(params, sexp_ref_name(sexp_car(fv))) < 0)
|
||||
if (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)
|
||||
sexp_push(res, sexp_car(fv));
|
||||
/* sexp_debug(" => ", res); */
|
||||
return res;
|
||||
|
@ -720,7 +726,7 @@ static sexp free_vars (sexp x, sexp fv) {
|
|||
sexp fv1, fv2;
|
||||
if (sexp_lambdap(x)) {
|
||||
fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL);
|
||||
fv2 = diff_free_vars(fv1, sexp_lambda_params(x));
|
||||
fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x)));
|
||||
sexp_lambda_fv(x) = fv2;
|
||||
fv = union_free_vars(fv2, fv);
|
||||
} else if (sexp_pairp(x)) {
|
||||
|
@ -763,6 +769,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env,
|
|||
sexp_lambda_params(lambda) = params;
|
||||
sexp_lambda_fv(lambda) = SEXP_NULL;
|
||||
sexp_lambda_sv(lambda) = SEXP_NULL;
|
||||
sexp_lambda_locals(lambda) = SEXP_NULL;
|
||||
sexp_context_lambda(context) = lambda;
|
||||
sexp_context_top(context) = top;
|
||||
env = extend_env(env, params, lambda);
|
||||
|
@ -1396,6 +1403,10 @@ sexp compile (sexp x, sexp context) {
|
|||
|
||||
sexp eval_in_context (sexp obj, sexp context) {
|
||||
sexp thunk = compile(obj, context);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(obj, cur_error_port);
|
||||
return SEXP_UNDEF;
|
||||
}
|
||||
return apply(thunk, SEXP_NULL, context);
|
||||
}
|
||||
|
||||
|
@ -1431,10 +1442,14 @@ void repl (sexp context) {
|
|||
obj = sexp_read(cur_input_port);
|
||||
if (obj == SEXP_EOF)
|
||||
break;
|
||||
res = eval_in_context(obj, context);
|
||||
if (res != SEXP_UNDEF) {
|
||||
sexp_write(res, cur_output_port);
|
||||
sexp_write_char('\n', cur_output_port);
|
||||
if (sexp_exceptionp(obj)) {
|
||||
sexp_print_exception(obj, cur_error_port);
|
||||
} else {
|
||||
res = eval_in_context(obj, context);
|
||||
if (res != SEXP_UNDEF) {
|
||||
sexp_write(res, cur_output_port);
|
||||
sexp_write_char('\n', cur_output_port);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
76
sexp.c
76
sexp.c
|
@ -36,7 +36,9 @@ static char sexp_separators[] = {
|
|||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */
|
||||
};
|
||||
|
||||
#define digit_value(c) (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10))
|
||||
static int digit_value (c) {
|
||||
return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10));
|
||||
}
|
||||
|
||||
static int is_separator(int c) {
|
||||
/* return (!((c-9)&(~3))) | (~(c^4)); */
|
||||
|
@ -133,9 +135,12 @@ sexp sexp_print_exception(sexp exn, sexp out) {
|
|||
}
|
||||
|
||||
static sexp sexp_read_error(char *message, sexp irritants, sexp port) {
|
||||
return sexp_make_exception(the_read_error_symbol, sexp_make_string(message),
|
||||
sexp name = (sexp_port_name(port)
|
||||
? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE);
|
||||
return sexp_make_exception(the_read_error_symbol,
|
||||
sexp_make_string(message),
|
||||
irritants,
|
||||
sexp_make_string(sexp_port_name(port)),
|
||||
name,
|
||||
sexp_make_integer(sexp_port_line(port)));
|
||||
}
|
||||
|
||||
|
@ -382,6 +387,7 @@ sexp sexp_get_output_string(sexp port) {
|
|||
sexp sexp_make_input_port(FILE* in) {
|
||||
sexp p = sexp_alloc_type(port, SEXP_IPORT);
|
||||
sexp_port_stream(p) = in;
|
||||
sexp_port_name(p) = NULL;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
}
|
||||
|
@ -389,6 +395,7 @@ sexp sexp_make_input_port(FILE* in) {
|
|||
sexp sexp_make_output_port(FILE* out) {
|
||||
sexp p = sexp_alloc_type(port, SEXP_OPORT);
|
||||
sexp_port_stream(p) = out;
|
||||
sexp_port_name(p) = NULL;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
}
|
||||
|
@ -480,7 +487,12 @@ void sexp_write (sexp obj, sexp out) {
|
|||
} else if (sexp_integerp(obj)) {
|
||||
sexp_printf(out, "%ld", sexp_unbox_integer(obj));
|
||||
} else if (sexp_charp(obj)) {
|
||||
if ((33 <= sexp_unbox_character(obj)) && (sexp_unbox_character(obj) < 127))
|
||||
if (obj == sexp_make_character(' '))
|
||||
sexp_write_string("#\\space", out);
|
||||
else if (obj == sexp_make_character('\n'))
|
||||
sexp_write_string("#\\newline", out);
|
||||
else if ((33 <= sexp_unbox_character(obj))
|
||||
&& (sexp_unbox_character(obj) < 127))
|
||||
sexp_printf(out, "#\\%c", sexp_unbox_character(obj));
|
||||
else
|
||||
sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj));
|
||||
|
@ -700,49 +712,59 @@ sexp sexp_read_raw (sexp in) {
|
|||
res = sexp_read_number(in, 10); break;
|
||||
case 'x':
|
||||
res = sexp_read_number(in, 16); break;
|
||||
/* case 'e': */
|
||||
/* case 'i': */
|
||||
case 'e':
|
||||
res = sexp_read(in);
|
||||
if (sexp_flonump(res))
|
||||
res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res));
|
||||
break;
|
||||
case 'i':
|
||||
res = sexp_read(in);
|
||||
if (sexp_integerp(res))
|
||||
res = sexp_make_flonum(sexp_unbox_integer(res));
|
||||
break;
|
||||
case 'f':
|
||||
case 't':
|
||||
c2 = sexp_read_char(in);
|
||||
if (c2 == EOF || is_separator(c2)) {
|
||||
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
|
||||
sexp_push_char(c2, in);
|
||||
} else {
|
||||
return sexp_read_error("invalid syntax #%c%c",
|
||||
sexp_list2(sexp_make_character(c1),
|
||||
sexp_make_character(c2)),
|
||||
in);
|
||||
res = sexp_read_error("invalid syntax #%c%c",
|
||||
sexp_list2(sexp_make_character(c1),
|
||||
sexp_make_character(c2)),
|
||||
in);
|
||||
}
|
||||
sexp_push_char(c2, in);
|
||||
break;
|
||||
case ';':
|
||||
sexp_read_raw(in);
|
||||
goto scan_loop;
|
||||
case '\\':
|
||||
c1 = sexp_read_char(in);
|
||||
c2 = sexp_read_char(in);
|
||||
if (c2 == EOF || is_separator(c2)) {
|
||||
sexp_push_char(c2, in);
|
||||
str = sexp_read_symbol(in, c1);
|
||||
if (str[0] == '\0')
|
||||
res =
|
||||
sexp_read_error("unexpected end of character literal", SEXP_NULL, in);
|
||||
if (str[1] == '\0') {
|
||||
res = sexp_make_character(c1);
|
||||
} else if ((c1 == 'x' || c1 == 'X') && isxdigit(c2)) {
|
||||
c1 = sexp_read_char(in);
|
||||
res = sexp_make_character(16 * digit_value(c2) + digit_value(c1));
|
||||
} else if ((c1 == 'x' || c1 == 'X') &&
|
||||
isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') {
|
||||
res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1]));
|
||||
} else {
|
||||
str = sexp_read_symbol(in, c1);
|
||||
if (strcasecmp(str, "space") == 0)
|
||||
res = sexp_make_character(' ');
|
||||
else if (strcasecmp(str, "newline") == 0)
|
||||
res = sexp_make_character('\r');
|
||||
res = sexp_make_character('\n');
|
||||
else if (strcasecmp(str, "return") == 0)
|
||||
res = sexp_make_character('\r');
|
||||
else if (strcasecmp(str, "tab") == 0)
|
||||
res = sexp_make_character('\t');
|
||||
else {
|
||||
return sexp_read_error("unknown character name",
|
||||
sexp_list1(sexp_make_string(str)),
|
||||
in);
|
||||
res = sexp_read_error("unknown character name",
|
||||
sexp_list1(sexp_make_string(str)),
|
||||
in);
|
||||
}
|
||||
}
|
||||
sexp_free(str);
|
||||
break;
|
||||
case '(':
|
||||
sexp_push_char(c1, in);
|
||||
|
@ -750,17 +772,17 @@ sexp sexp_read_raw (sexp in) {
|
|||
if (! sexp_listp(res)) {
|
||||
if (! sexp_exceptionp(res)) {
|
||||
sexp_deep_free(res);
|
||||
return sexp_read_error("dotted list not allowed in vector syntax",
|
||||
SEXP_NULL,
|
||||
in);
|
||||
res = sexp_read_error("dotted list not allowed in vector syntax",
|
||||
SEXP_NULL,
|
||||
in);
|
||||
}
|
||||
} else {
|
||||
res = sexp_list_to_vector(res);
|
||||
}
|
||||
break;
|
||||
default:
|
||||
return sexp_read_error("invalid # syntax",
|
||||
sexp_list1(sexp_make_character(c1)), in);
|
||||
res = sexp_read_error("invalid # syntax",
|
||||
sexp_list1(sexp_make_character(c1)), in);
|
||||
}
|
||||
break;
|
||||
case '.':
|
||||
|
|
8
tests/test03-nested-closure.scm
Normal file
8
tests/test03-nested-closure.scm
Normal file
|
@ -0,0 +1,8 @@
|
|||
|
||||
((lambda (a b)
|
||||
((lambda (c d e)
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline))
|
||||
(- a 2) (+ b 2) 10000))
|
||||
3 5)
|
||||
|
1
tests/test05-internal-define.res
Normal file
1
tests/test05-internal-define.res
Normal file
|
@ -0,0 +1 @@
|
|||
1000 1003
|
8
tests/test05-internal-define.scm
Normal file
8
tests/test05-internal-define.scm
Normal file
|
@ -0,0 +1,8 @@
|
|||
|
||||
(let ((a 1000))
|
||||
(define b (+ a 3))
|
||||
(write a)
|
||||
(display " ")
|
||||
(write b)
|
||||
(newline))
|
||||
|
1
tests/test07-mutation.res
Normal file
1
tests/test07-mutation.res
Normal file
|
@ -0,0 +1 @@
|
|||
11357
|
Loading…
Add table
Reference in a new issue