initial exception handling support

include/picrin/error.h

@@ -0,0 +1,18 @@
+#ifndef ERROR_H__
+#define ERROR_H__
+
+struct pic_error {
+  PIC_OBJECT_HEADER
+  enum pic_error_kind {
+    PIC_ERROR_OTHER,
+    PIC_ERROR_FILE,
+    PIC_ERROR_READ
+  } type;
+  char *msg;
+  pic_value irrs;
+};
+
+#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
+#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
+
+#endif

include/picrin/value.h

@@ -87,6 +87,7 @@ enum pic_tt {
   PIC_TT_BLOB,
   PIC_TT_PROC,
   PIC_TT_PORT,
+  PIC_TT_ERROR,
   PIC_TT_ENV,
   PIC_TT_CONT
 };

src/codegen.c

@@ -640,7 +640,8 @@ codegen(codegen_state *state, pic_value obj, bool tailpos)
   case PIC_TT_PROC:
   case PIC_TT_UNDEF:
   case PIC_TT_EOF:
-  case PIC_TT_PORT: {
+  case PIC_TT_PORT:
+  case PIC_TT_ERROR: {
     pic_error(pic, "invalid expression given");
   }
   }

src/error.c

@@ -2,6 +2,8 @@
 #include <stdio.h>
 
 #include "picrin.h"
+#include "picrin/proc.h"
+#include "picrin/error.h"
 
 void
 pic_error(pic_state *pic, const char *msg)
@@ -32,3 +34,157 @@ pic_warn(pic_state *pic, const char *msg)
 {
   fprintf(stderr, "warn: %s\n", msg);
 }
+
+void
+pic_raise(pic_state *pic, pic_value obj)
+{
+  pic_value a;
+  struct pic_proc *handler;
+
+  if (pic->ridx == 0) {
+    pic_abort(pic, "logic flaw: no exception handler remains");
+  }
+
+  handler = pic->rescue[--pic->ridx];
+  pic_gc_protect(pic, pic_obj_value(handler));
+
+  a = pic_apply_argv(pic, handler, 1, obj);
+  /* when the handler returns */
+  pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a);
+}
+
+static pic_value
+pic_error_with_exception_handler(pic_state *pic)
+{
+  pic_value v, w;
+  struct pic_proc *handler, *thunk;
+
+  pic_get_args(pic, "oo", &v, &w);
+
+  if (! pic_proc_p(v)){
+    pic_error(pic, "expected procedure");
+  }
+  handler = pic_proc_ptr(v);
+
+  if (! pic_proc_p(v)) {
+    pic_error(pic, "expected procedure");
+  }
+  thunk = pic_proc_ptr(w);
+
+  if (pic->ridx >= pic->rlen) {
+    pic->rescue = (struct pic_proc **)pic_realloc(pic, pic->rescue, pic->rlen * 2);
+    pic->rlen *= 2;
+  }
+  pic->rescue[pic->ridx++] = handler;
+
+  v = pic_apply_argv(pic, thunk, 0);
+  pic->ridx--;
+  return v;
+}
+
+static pic_value
+pic_error_raise(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  pic_raise(pic, v);
+
+  /* the function never returns */
+  return pic_undef_value();
+}
+
+static pic_value
+pic_error_raise_continuable(pic_state *pic)
+{
+  pic_value v, a;
+  struct pic_proc *handler;
+
+  pic_get_args(pic, "o", &v);
+
+  if (pic->ridx == 0) {
+    pic_abort(pic, "logic flaw: no exception handler remains");
+  }
+
+  handler = pic->rescue[--pic->ridx];
+  a = pic_apply_argv(pic, handler, 1, v);
+  pic->rescue[pic->ridx++] = handler;
+
+  return a;
+}
+
+static pic_value
+pic_error_error_object_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_error_p(v));
+}
+
+static pic_value
+pic_error_error_object_message(pic_state *pic)
+{
+  struct pic_error *e;
+
+  pic_get_args(pic, "e", &e);
+
+  return pic_str_new_cstr(pic, e->msg);
+}
+
+static pic_value
+pic_error_error_object_irritants(pic_state *pic)
+{
+  struct pic_error *e;
+
+  pic_get_args(pic, "e", &e);
+
+  return e->irrs;
+}
+
+static pic_value
+pic_error_read_error_p(pic_state *pic)
+{
+  pic_value v;
+  struct pic_error *e;
+
+  pic_get_args(pic, "o", &v);
+
+  if (! pic_error_p(v)) {
+    return pic_false_value();
+  }
+
+  e = pic_error_ptr(v);
+  return pic_bool_value(e->type == PIC_ERROR_READ);
+}
+
+static pic_value
+pic_error_file_error_p(pic_state *pic)
+{
+  pic_value v;
+  struct pic_error *e;
+
+  pic_get_args(pic, "o", &v);
+
+  if (! pic_error_p(v)) {
+    return pic_false_value();
+  }
+
+  e = pic_error_ptr(v);
+  return pic_bool_value(e->type == PIC_ERROR_FILE);
+}
+
+void
+pic_init_error(pic_state *pic)
+{
+  pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
+  pic_defun(pic, "raise", pic_error_raise);
+  pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
+  pic_defun(pic, "error-object?", pic_error_error_object_p);
+  pic_defun(pic, "error-object-message", pic_error_error_object_message);
+  pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
+  pic_defun(pic, "read-error?", pic_error_read_error_p);
+  pic_defun(pic, "file-error?", pic_error_file_error_p);
+}

src/expand.c

@@ -147,6 +147,7 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
   }
   case PIC_TT_PROC:
   case PIC_TT_PORT:
+  case PIC_TT_ERROR:
   case PIC_TT_ENV:
   case PIC_TT_CONT:
   case PIC_TT_UNDEF:

src/gc.c

@@ -7,6 +7,7 @@
 #include "picrin/port.h"
 #include "picrin/blob.h"
 #include "picrin/cont.h"
+#include "picrin/error.h"
 
 #if GC_DEBUG
 # include <stdio.h>
@@ -207,6 +208,10 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   case PIC_TT_PORT: {
     break;
   }
+  case PIC_TT_ERROR: {
+    gc_mark(pic, ((struct pic_error *)obj)->irrs);
+    break;
+  }
   case PIC_TT_STRING: {
     break;
   }
@@ -363,6 +368,10 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
+  case PIC_TT_ERROR: {
+    pic_free(pic, ((struct pic_error *)obj)->msg);
+    break;
+  }
   case PIC_TT_CONT: {
     struct pic_cont *cont = (struct pic_cont *)obj;
     pic_free(pic, cont->stk_ptr);

src/init.c

@@ -17,6 +17,7 @@ void pic_init_vector(pic_state *);
 void pic_init_blob(pic_state *);
 void pic_init_cont(pic_state *);
 void pic_init_char(pic_state *);
+void pic_init_error(pic_state *);
 
 void
 pic_load_stdlib(pic_state *pic)
@@ -83,6 +84,7 @@ pic_init_core(pic_state *pic)
   pic_init_blob(pic); DONE;
   pic_init_cont(pic); DONE;
   pic_init_char(pic); DONE;
+  pic_init_error(pic); DONE;
 
   pic_load_stdlib(pic); DONE;
 }

src/port.c

@@ -88,6 +88,9 @@ write(pic_state *pic, pic_value obj)
     }
     printf(")");
     break;
+  case PIC_TT_ERROR:
+    printf("#<error %p>", pic_ptr(obj));
+    break;
   case PIC_TT_ENV:
     printf("#<env %p>", pic_env_ptr(obj));
     break;

t/exception.scm

@@ -0,0 +1,11 @@
+(write
+ (call/cc
+  (lambda (k)
+    (with-exception-handler
+     (lambda (x)
+       (write "condition: ")
+       (write x)
+       (newline)
+       (k 'exception))
+     (lambda ()
+       (+ 1 (raise 'an-error)))))))