Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

exceptions don't print by default

Browse source
This commit is contained in:
Alex Shinn 2009-04-08 17:04:48 +09:00
parent 820c13e752
commit b36c0d2e3a
4 changed files with 76 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
eval.c
View file

@ -337,6 +337,8 @@ static sexp analyze_var_ref (sexp x, sexp context) {
cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF);
}
}
if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell)))
return sexp_compile_error("invalid use of syntax as value", sexp_list1(x));
return sexp_make_ref(x, cell);
}
@ -437,8 +439,10 @@ static sexp analyze_define_syntax (sexp x, sexp context) {
return sexp_compile_error("non-top-level define-syntax", sexp_list1(x));
proc = eval_in_context(sexp_caddr(x), context);
analyze_check_exception(proc);
cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID);
sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
if (sexp_procedurep(proc)) {
cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID);
sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
}
return SEXP_VOID;
}
@ -447,9 +451,10 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
proc = eval_in_context(sexp_cadar(ls), eval_ctx);
analyze_check_exception(proc);
sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)),
sexp_cons(sexp_caar(ls),
sexp_make_macro(proc, sexp_context_env(eval_ctx))));
if (sexp_procedurep(proc))
sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)),
sexp_cons(sexp_caar(ls),
sexp_make_macro(proc, sexp_context_env(eval_ctx))));
}
return SEXP_VOID;
}
@ -497,7 +502,7 @@ static sexp analyze (sexp x, sexp context) {
case CORE_IF:
res = analyze_if(x, context); break;
case CORE_BEGIN:
res = analyze_seq(x, context); break;
res = analyze_seq(sexp_cdr(x), context); break;
case CORE_QUOTE:
res = sexp_make_lit(sexp_cadr(x)); break;
case CORE_DEFINE_SYNTAX:
@ -1014,16 +1019,17 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break;
case OP_ERROR:
call_error_handler:
tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
sexp_print_exception(_ARG1, tmp1);
self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
stack[top] = (sexp) 1;
stack[top+1] = sexp_make_integer(ip+4);
stack[top+2] = self;
top += 3;
stack[top+3] = sexp_make_integer(fp);
top += 4;
self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
bc = sexp_procedure_code(self);
ip = sexp_bytecode_data(bc);
cp = sexp_procedure_vars(self);
fp = top-4;
/* sexp_print_stack(stack, top, fp, tmp1); */
break;
case OP_RESUMECC:
tmp1 = stack[fp-1];
@ -1327,6 +1333,8 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
top--;
break;
case OP_DIV:
if (_ARG2 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL);
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
_ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1),
sexp_integer_to_flonum(_ARG2));
@ -1343,7 +1351,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break;
case OP_QUOTIENT:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
if (_ARG1 == sexp_make_integer(0))
if (_ARG2 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL);
_ARG2 = sexp_fx_div(_ARG1, _ARG2);
top--;
@ -1352,7 +1360,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
break;
case OP_REMAINDER:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
if (_ARG1 == sexp_make_integer(0))
if (_ARG2 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL);
tmp1 = sexp_fx_rem(_ARG1, _ARG2);
top--;
@ -1559,9 +1567,14 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) {
sexp sexp_load (sexp source, sexp env) {
sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env);
out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
tmp = sexp_env_bindings(env);
sexp_context_tailp(context) = 0;
in = sexp_open_input_file(source);
if (sexp_exceptionp(in)) {
sexp_print_exception(in, out);
return in;
}
while ((x=sexp_read(in)) != (sexp) SEXP_EOF) {
res = eval_in_context(x, context);
if (sexp_exceptionp(res))
@ -1571,7 +1584,6 @@ sexp sexp_load (sexp source, sexp env) {
res = SEXP_VOID;
sexp_close_port(in);
#ifdef USE_WARN_UNDEFS
out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
if (sexp_oportp(out))
sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
#endif
@ -1770,7 +1782,7 @@ sexp eval_in_context (sexp obj, sexp context) {
sexp_print_exception(thunk, env_global_ref(sexp_context_env(context),
the_cur_err_symbol,
SEXP_FALSE));
return SEXP_VOID;
return thunk;
}
return apply(thunk, SEXP_NULL, context);
}

24
main.c
View file

@ -31,13 +31,24 @@ void repl (sexp context) {
}
void run_main (int argc, char **argv) {
sexp env, obj, out=NULL, res, context, err_handler;
sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler;
sexp_uint_t i, quit=0, init_loaded=0;
env = sexp_make_standard_env(sexp_make_integer(5));
env_define(env, the_interaction_env_symbol, env);
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err_cell = env_cell(env, the_cur_err_symbol);
perr_cell = env_cell(env, sexp_intern("print-exception"));
context = sexp_make_context(NULL, env);
sexp_context_tailp(context) = 0;
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
emit(OP_GLOBAL_KNOWN_REF, context);
emit_word((sexp_uint_t)err_cell, context);
emit(OP_LOCAL_REF, context);
emit_word(0, context);
emit(OP_FCALL2, context);
emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context);
}
emit_push(SEXP_VOID, context);
emit(OP_DONE, context);
err_handler = sexp_make_procedure(sexp_make_integer(0),
@ -54,11 +65,12 @@ void run_main (int argc, char **argv) {
case 'p':
if (! init_loaded++)
sexp_load(sexp_c_string(sexp_init_file), env);
obj = sexp_read_from_string(argv[i+1]);
res = eval_in_context(obj, context);
if (argv[i][1] == 'p') {
if (! out)
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
res = sexp_read_from_string(argv[i+1]);
if (! sexp_exceptionp(res))
res = eval_in_context(res, context);
if (sexp_exceptionp(res)) {
sexp_print_exception(res, out);
} else if (argv[i][1] == 'p') {
sexp_write(res, out);
sexp_write_char('\n', out);
}

1
opcodes.c
View file

@ -82,6 +82,7 @@ _FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port),
_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env),
_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env),
_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load),
_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception),
_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci),

50
sexp.c
View file

@ -760,44 +760,48 @@ void sexp_write (sexp obj, sexp out) {
char* sexp_read_string(sexp in) {
char *buf, *tmp, *res;
int c, len, size=128;
int c, i=0, size=128;
buf = sexp_alloc(size); /* XXXX grow! */
tmp = buf;
buf = sexp_alloc(size);
for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) {
if (c == EOF) {
sexp_free(buf);
return NULL;
} else if (c == '\\') {
}
if (c == '\\') {
c=sexp_read_char(in);
switch (c) {
case 'n': c = '\n'; break;
case 't': c = '\t'; break;
}
*tmp++ = c;
buf[i++] = c;
} else {
*tmp++ = c;
buf[i++] = c;
}
if (i >= size) {
tmp = sexp_alloc(2*size);
memcpy(tmp, buf, i);
sexp_free(buf);
buf = tmp;
}
}
*tmp++ = '\0';
len = tmp - buf;
res = sexp_alloc(len);
memcpy(res, buf, len);
buf[i] = '\0';
res = sexp_alloc(i);
memcpy(res, buf, i);
sexp_free(buf);
return res;
}
char* sexp_read_symbol(sexp in, int init) {
char *buf, *tmp, *res;
int c, len, size=128;
int c, i=0, size=128;
buf = sexp_alloc(size);
tmp = buf;
if (init != EOF)
*tmp++ = init;
buf[i++] = init;
while (1) {
c=sexp_read_char(in);
@ -805,13 +809,18 @@ char* sexp_read_symbol(sexp in, int init) {
sexp_push_char(c, in);
break;
}
*tmp++ = c;
buf[i++] = c;
if (i >= size) {
tmp = sexp_alloc(2*size);
memcpy(tmp, buf, i);
sexp_free(buf);
buf = tmp;
}
}
*tmp++ = '\0';
len = tmp - buf;
res = sexp_alloc(len);
memcpy(res, buf, len);
buf[i] = '\0';
res = sexp_alloc(i);
memcpy(res, buf, i);
sexp_free(buf);
return res;
}
@ -916,7 +925,10 @@ sexp sexp_read_raw (sexp in) {
break;
case '"':
str = sexp_read_string(in);
res = sexp_c_string(str);
if (! str)
res = sexp_read_error("premature end of string", SEXP_NULL, in);
else
res = sexp_c_string(str);
sexp_free(str);
break;
case '(':