implemented simple backtrace

include/picrin.h

@@ -185,6 +185,7 @@ void pic_export(pic_state *, pic_sym);
 noreturn void pic_abort(pic_state *, const char *);
 noreturn void pic_errorf(pic_state *, const char *, ...);
 void pic_warnf(pic_state *, const char *, ...);
+pic_str *pic_get_backtrace(pic_state *);
 
 /* obsoleted */
 noreturn static inline void pic_error(pic_state *pic, const char *msg)

src/backtrace.c

@@ -0,0 +1,57 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/string.h"
+#include "picrin/error.h"
+#include "picrin/proc.h"
+
+pic_str *
+pic_get_backtrace(pic_state *pic)
+{
+  int ai = pic_gc_arena_preserve(pic);
+  pic_callinfo *ci;
+  pic_str *trace;
+
+  assert(pic->err != NULL);
+
+  trace = pic_str_new(pic, NULL, 0);
+
+  switch (pic->err->type) {
+  case PIC_ERROR_OTHER:
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: "));
+    break;
+  case PIC_ERROR_FILE:
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: "));
+    break;
+  case PIC_ERROR_READ:
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: "));
+    break;
+  case PIC_ERROR_RAISED:
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: "));
+    break;
+  }
+
+  trace = pic_strcat(pic, trace, pic->err->msg);
+
+  /* TODO: print error irritants */
+
+  for (ci = pic->ci; ci != pic->cibase; --ci) {
+    struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
+
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "\n  at "));
+    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
+
+    if (pic_proc_func_p(proc)) {
+      trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)"));
+    } else if (pic_proc_irep_p(proc)) {
+      trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)")); /* TODO */
+    }
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, pic_obj_value(trace));
+
+  return trace;
+}

src/error.c

@@ -131,7 +131,7 @@ pic_error_raise(pic_state *pic)
 
   e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
   e->type = PIC_ERROR_RAISED;
-  e->msg = pic_str_new_cstr(pic, "raised");
+  e->msg = pic_str_new_cstr(pic, "object is raised");
   e->irrs = pic_list1(pic, v);
 
   pic_throw(pic, e);

tools/main.c

@@ -9,6 +9,7 @@
 
 #include "picrin.h"
 #include "picrin/pair.h"
+#include "picrin/string.h"
 #include "picrin/error.h"
 
 #if PIC_ENABLE_READLINE
@@ -124,7 +125,7 @@ repl(pic_state *pic)
       }
     }
     pic_catch {
-      printf("error: %s\n", pic_errmsg(pic));
+      printf("%s\n", pic_str_cstr(pic_get_backtrace(pic)));
       pic->err = NULL;
       code[0] = '\0';
     }