core: Throw exceptions rather than asserts.
* lib.c (error): Throw instead of assert. (check_formals, check_apply): Update. * mes.c (scm_symbol_unbound_variable, scm_symbol_not_a_pair, scm_symbol_system_error, scm_symbol_wrong_number_of_args, scm_symbol_wrong_type_arg, scm_symbol_unbound_variable): New symbols. (car, cdr, set_cdr_x, set_env_x, eval_apply, gc_up_arena): Update.
This commit is contained in:
parent
2675f711a3
commit
cb1fa49767
25
lib.c
25
lib.c
|
@ -71,19 +71,19 @@ string_to_cstring (SCM s)
|
|||
return buf;
|
||||
}
|
||||
|
||||
int
|
||||
error (char const* msg, SCM x)
|
||||
SCM
|
||||
error (SCM key, SCM x)
|
||||
{
|
||||
fprintf (stderr, msg);
|
||||
if (x) stderr_ (x);
|
||||
fprintf (stderr, "\n");
|
||||
assert(!msg);
|
||||
SCM throw;
|
||||
if ((throw = assq_ref_cache (cell_symbol_throw, r0)) != cell_undefined)
|
||||
return apply (throw, cons (key, cons (x, cell_nil)), r0);
|
||||
assert (!"error");
|
||||
}
|
||||
|
||||
SCM
|
||||
assert_defined (SCM x, SCM e)
|
||||
{
|
||||
if (e == cell_undefined) error ("eval: unbound variable: ", x);
|
||||
if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
|
||||
return e;
|
||||
}
|
||||
|
||||
|
@ -96,7 +96,8 @@ check_formals (SCM f, SCM formals, SCM args)
|
|||
{
|
||||
char buf[1024];
|
||||
sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
|
||||
error (buf, f);
|
||||
SCM e = MAKE_STRING (cstring_to_list (buf));
|
||||
return error (cell_symbol_wrong_number_of_args, cons (e, f));
|
||||
}
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
@ -106,11 +107,12 @@ check_apply (SCM f, SCM e)
|
|||
{
|
||||
char const* type = 0;
|
||||
if (f == cell_f || f == cell_t) type = "bool";
|
||||
if (f == cell_nil) type = "nil";
|
||||
if (f == cell_unspecified) type = "*unspecified*";
|
||||
if (f == cell_undefined) type = "*undefined*";
|
||||
if (TYPE (f) == CHAR) type = "char";
|
||||
if (TYPE (f) == NUMBER) type = "number";
|
||||
if (TYPE (f) == STRING) type = "string";
|
||||
if (f == cell_unspecified) type = "*unspecified*";
|
||||
if (f == cell_undefined) type = "*undefined*";
|
||||
|
||||
if (type)
|
||||
{
|
||||
|
@ -119,7 +121,8 @@ check_apply (SCM f, SCM e)
|
|||
fprintf (stderr, " [");
|
||||
stderr_ (e);
|
||||
fprintf (stderr, "]\n");
|
||||
error (buf, f);
|
||||
SCM e = MAKE_STRING (cstring_to_list (buf));
|
||||
return error (cell_symbol_wrong_type_arg, cons (e, f));
|
||||
}
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
|
19
mes.c
19
mes.c
|
@ -114,7 +114,13 @@ scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
|
|||
scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
|
||||
scm scm_symbol_write = {SYMBOL, "write"};
|
||||
scm scm_symbol_display = {SYMBOL, "display"};
|
||||
|
||||
scm scm_symbol_throw = {SYMBOL, "throw"};
|
||||
scm scm_symbol_not_a_pair = {SYMBOL, "not-a-pair"};
|
||||
scm scm_symbol_system_error = {SYMBOL, "system-error"};
|
||||
scm scm_symbol_wrong_number_of_args = {SYMBOL, "wrong-number-of-args"};
|
||||
scm scm_symbol_wrong_type_arg = {SYMBOL, "wrong-type-arg"};
|
||||
scm scm_symbol_unbound_variable = {SYMBOL, "unbound-variable"};
|
||||
|
||||
scm scm_symbol_argv = {SYMBOL, "%argv"};
|
||||
scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"};
|
||||
|
@ -214,7 +220,6 @@ SCM r3 = 0; // continuation
|
|||
#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
|
||||
#define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
|
||||
|
||||
int error (char const* msg, SCM x);
|
||||
SCM vm_call (function0_t f, SCM p1, SCM a);
|
||||
|
||||
SCM
|
||||
|
@ -269,14 +274,14 @@ cons (SCM x, SCM y)
|
|||
SCM
|
||||
car (SCM x)
|
||||
{
|
||||
if (TYPE (x) != PAIR) error ("car: not pair: ", x);
|
||||
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
|
||||
return CAR (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
cdr (SCM x)
|
||||
{
|
||||
if (TYPE (x) != PAIR) error ("cdr: not pair: ", x);
|
||||
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
|
||||
return CDR (x);
|
||||
}
|
||||
SCM
|
||||
|
@ -330,7 +335,7 @@ set_car_x (SCM x, SCM e)
|
|||
SCM
|
||||
set_cdr_x (SCM x, SCM e)
|
||||
{
|
||||
if (TYPE (x) != PAIR) error ("set-cdr!: not pair: ", x);
|
||||
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
|
||||
CDR (x) = e;
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
@ -339,7 +344,7 @@ SCM
|
|||
set_env_x (SCM x, SCM e, SCM a)
|
||||
{
|
||||
SCM p = assert_defined (x, assq (x, a));
|
||||
if (TYPE (p) != PAIR) error ("set-env!: not pair: ", x);
|
||||
if (TYPE (p) != PAIR) error (cell_symbol_not_a_pair, cons (p, x));
|
||||
return set_cdr_x (p, e);
|
||||
}
|
||||
|
||||
|
@ -490,7 +495,7 @@ eval_apply ()
|
|||
r1 = cdr (r1);
|
||||
goto call_with_current_continuation;
|
||||
}
|
||||
default: error ("cannot apply special: ", car (r1));
|
||||
default: check_apply (cell_f, car (r1));
|
||||
}
|
||||
}
|
||||
case SYMBOL:
|
||||
|
@ -926,7 +931,7 @@ gc_up_arena ()
|
|||
{
|
||||
ARENA_SIZE *= 2;
|
||||
void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
|
||||
if (!p) error (strerror (errno), MAKE_NUMBER (g_free));
|
||||
if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
|
||||
g_cells = (scm*)p;
|
||||
g_cells++;
|
||||
gc_init_news ();
|
||||
|
|
Loading…
Reference in New Issue