core: Throw exceptions rather than asserts.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 28 Dec 2016 21:26:33 +0000 (22:26 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 28 Dec 2016 21:26:33 +0000 (22:26 +0100)
* 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.

lib.c
mes.c

diff --git a/lib.c b/lib.c
index f5b04ba62e7410ce44cf9d6f637f4c2ec4c6d1c0..16c58297e24cb3ad98589b35e6e5256e45af0d45 100644 (file)
--- a/lib.c
+++ b/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;
 }
diff --git a/mes.c b/mes.c
index 919a27b427fd2243984110d10ef09b3c9e65e5d5..959a79365398536f444c34f3f2ebbbd4c39c447d 100644 (file)
--- a/mes.c
+++ b/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 ();