Remove redundancies in stacktraces.

There was an implementation for stacktraces in both
run.c and in core.janet, status-pp. The commit removes
the one in core.janet in favor of the C based stacktrace, which
is exposed via debug/stacktrace. Lots of reshuffling of run-context
ensued as well, which resulted in an api that is a bit cleaner.

src/core/core.janet

@@ -1385,17 +1385,51 @@ value, one key will be ignored."
   (def newenv (table/setproto @{} parent))
   newenv)
 
+(defn bad-parse
+  "Default handler for a parse error."
+  [p where]
+  (file/write stderr
+              "parse error in "
+              where
+              " around byte "
+              (string (parser/where p))
+              (or (parser/error p) "unmatched delimiter")))
+
+(defn bad-compile
+  "Default handler for a compile error."
+  [msg macrof where]
+  (file/write stderr msg " while compiling " where "\n")
+  (when macrof (debug/stacktrace macrof)))
+
+(defn getline
+  "Read a line from stdin into a buffer."
+  [buf p]
+  (file/read stdin :line buf))
+
 (defn run-context
   "Run a context. This evaluates expressions of janet in an environment,
-  and is encapsulates the parsing, compilation, and evaluation of janet.
+  and is encapsulates the parsing, compilation, and evaluation.
-  env is the environment to evaluate the code in, chunks is a function
+  opts is a table or struct of options. The options are as follows:\n\n\t
-  that returns strings or buffers of source code (from a repl, file,
+  :chunks - callback to read into a buffer - default is getline\n\t
-  network connection, etc. onstatus is a callback that is
+  :on-parse-error - callback when parsing fails - default is bad-parse\n\t
-  invoked when a result is returned or any other signal is raised.
+  :env - the environment to compile against - default is *env*\n\t
+  :source - string path of source for better errors - default is \"<anonymous>\"\n\t
+  :on-compile-error - callback when compilation fails - default is bad-compile\n\t
+  :on-status - callback when a value is evaluated - default is debug/stacktrace"
+  [opts]
 
-  This function can be used to implement a repl very easily, simply
+  (def {:env env
-  pass a function that reads line from stdin to chunks, status-pp to onstatus"
+        :chunks chunks
-  [env chunks onstatus where &]
+        :on-status onstatus
+        :on-compile-error on-compile-error
+        :on-parse-error on-parse-error
+        :source where} opts)
+  (default env *env*)
+  (default chunks getline)
+  (default onstatus debug/stacktrace)
+  (default on-compile-error bad-compile)
+  (default on-parse-error bad-parse)
+  (default where "<anonymous>")
 
   # Are we done yet?
   (var going true)
@@ -1415,17 +1449,14 @@ value, one key will be ignored."
             (do
               (set good false)
               (def {:error err :start start :end end :fiber errf} res)
-              (onstatus
+              (def msg
-                :compile
                 (if (<= 0 start)
-                  (string err "\n  at (" start ":" end ")")
+                  (string "compile error: " err " at (" start ":" end ")")
-                  err)
+                  err))
-                errf
+              (on-compile-error msg errf where))))
-                where))))
         :a))
     (def res (resume f nil))
-    (when good
+    (when good (if going (onstatus f res))))
-      (if going (onstatus (fiber/status f) res f where))))
 
   (def oldenv *env*)
   (set *env* env)
@@ -1444,73 +1475,19 @@ value, one key will be ignored."
       (while (parser/has-more p)
         (eval1 (parser/produce p)))
       (when (= (parser/status p) :error)
-        (onstatus :parse
+        (on-parse-error p where))))
-                  (string (parser/error p)
-                          " around byte " (parser/where p))
-                  nil
-                  where))))
 
   (if (= (parser/status p) :pending)
-        (onstatus :parse
+        (on-parse-error p where))
-                  (string "unmatched delimiters " (parser/state p))
-                  nil
-                  where))
 
   (set *env* oldenv)
 
   env)
 
-(defn status-pp
-  "Pretty print a signal and associated state. Can be used as the
-  onsignal argument to run-context."
-  [sig x f source]
-  (def title
-    (case sig
-      :parse "parse error"
-      :compile "compile error"
-      :error "error"
-      (string "status " sig)))
-  (file/write stderr
-              (string title " in " source ": ")
-              (if (bytes? x) x (string/pretty x))
-              "\n")
-  (when f
-    (loop
-      [nf :in (reverse (debug/lineage f))
-       {:function func
-        :tail tail
-        :pc pc
-        :c c
-        :name name
-        :source source
-        :source-start start
-        :source-end end} :in (debug/stack nf)]
-      (file/write stderr "  in")
-      (when c (file/write stderr " cfunction"))
-      (if name
-        (file/write stderr " " name)
-        (when func (file/write stderr " <anonymous>")))
-      (if source
-        (do
-          (file/write stderr " [" source "]")
-          (if start
-            (file/write
-              stderr
-              " at ("
-              (string start)
-              ":"
-              (string end)
-              ")"))))
-      (if (and (not start) pc)
-        (file/write stderr " (pc=" (string pc) ")"))
-      (when tail (file/write stderr " (tailcall)"))
-      (file/write stderr "\n"))))
-
 (defn eval-string
   "Evaluates a string in the current environment. If more control over the
   environment is needed, use run-context."
   [str env &]
-  (default env *env*)
   (var state (string str))
   (defn chunks [buf _]
     (def ret state)
@@ -1519,12 +1496,15 @@ value, one key will be ignored."
       (buffer/push-string buf str)
       (buffer/push-string buf "\n")))
   (var returnval nil)
-  (run-context env chunks
+  (run-context {:env env
-               (fn [sig x f source]
+                :chunks chunks
-                 (if (= sig :dead)
+                :on-compile-error error
-                   (set returnval x)
+                :on-parse-error error
-                   (status-pp sig x f source)))
+                :on-status (fn [f val]
-               "eval")
+                             (set returnval val)
+                             (if-not (= (fiber/status f) :dead)
+                               (debug/stacktrace f val)))
+                :source "eval"})
   returnval)
 
 (defn eval
@@ -1612,15 +1592,17 @@ value, one key will be ignored."
         (def newenv (make-env))
         (put module/loading modpath true)
         (defn chunks [buf _] (file/read f 2048 buf))
-        (run-context newenv chunks
+        (run-context {:env newenv
-                     (fn [sig x f source]
+                      :chunks chunks
-                       (when (not= sig :dead)
+                      :on-status (fn [f x]
-                         (status-pp sig x f source)
+                                   (when (not= (fiber/status f) :dead)
-                         (if exit-on-error (os/exit 1))))
+                                     (debug/stacktrace f x)
-                     modpath)
+                                     (if exit-on-error (os/exit 1))))
+                      :source modpath})
         (file/close f)
         (put module/loading modpath false)
         (put module/cache modpath newenv)
+        (put module/cache path newenv)
         newenv)
       (do
         # Try native module
@@ -1629,6 +1611,7 @@ value, one key will be ignored."
           (error (string "could not open file for module " path)))
         (def e (make-env))
         (native n e)
+        (put module/cache n e)
         (put module/cache path e)
         e))))
 
@@ -1667,14 +1650,16 @@ value, one key will be ignored."
   caught."
   [chunks onsignal &]
   (def newenv (make-env))
-  (default chunks (fn [buf _] (file/read stdin :line buf)))
+  (default onsignal (fn [f x]
-  (default onsignal (fn [sig x f source]
+                      (case (fiber/status f)
-                      (case sig
                         :dead (do
                                 (put newenv '_ @{:value x})
                                 (print (string/pretty x 20)))
-                        (status-pp sig x f source))))
+                        (debug/stacktrace f x))))
-  (run-context newenv chunks onsignal "repl"))
+  (run-context {:env newenv
+                :chunks chunks
+                :on-status onsignal
+                :source "repl"}))
 
 (defmacro meta
   "Add metadata to the current environment."

src/core/debug.c

@@ -25,6 +25,7 @@
 #include "gc.h"
 #include "state.h"
 #include "util.h"
+#include "vector.h"
 #endif
 
 /* Implements functionality to build a debugger from within janet.
@@ -90,6 +91,74 @@ void janet_debug_find(
     }
 }
 
+/* Error reporting. This can be emulated from within Janet, but for
+ * consitency with the top level code it is defined once. */
+void janet_stacktrace(JanetFiber *fiber, Janet err) {
+    int32_t fi;
+    const char *errstr = (const char *)janet_to_string(err);
+    JanetFiber **fibers = NULL;
+    int wrote_error = 0;
+
+    while (fiber) {
+        janet_v_push(fibers, fiber);
+        fiber = fiber->child;
+    }
+
+    for (fi = janet_v_count(fibers) - 1; fi >= 0; fi--) {
+        fiber = fibers[fi];
+        int32_t i = fiber->frame;
+        while (i > 0) {
+            JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE);
+            JanetFuncDef *def = NULL;
+            i = frame->prevframe;
+
+            /* Print prelude to stack frame */
+            if (!wrote_error) {
+                JanetFiberStatus status = janet_fiber_status(fiber);
+                const char *prefix = status == JANET_STATUS_ERROR ? "" : "status ";
+                fprintf(stderr, "%s%s: %s\n",
+                        prefix,
+                        janet_status_names[status],
+                        errstr);
+                wrote_error = 1;
+            }
+
+            fprintf(stderr, "  in");
+
+            if (frame->func) {
+                def = frame->func->def;
+                fprintf(stderr, " %s", def->name ? (const char *)def->name : "<anonymous>");
+                if (def->source) {
+                    fprintf(stderr, " [%s]", (const char *)def->source);
+                }
+            } else {
+                JanetCFunction cfun = (JanetCFunction)(frame->pc);
+                if (cfun) {
+                    Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun));
+                    if (!janet_checktype(name, JANET_NIL))
+                        fprintf(stderr, " %s", (const char *)janet_to_string(name));
+                    else
+                        fprintf(stderr, " <cfunction>");
+                }
+            }
+            if (frame->flags & JANET_STACKFRAME_TAILCALL)
+                fprintf(stderr, " (tailcall)");
+            if (frame->func && frame->pc) {
+                int32_t off = (int32_t) (frame->pc - def->bytecode);
+                if (def->sourcemap) {
+                    JanetSourceMapping mapping = def->sourcemap[off];
+                    fprintf(stderr, " at (%d:%d)", mapping.start, mapping.end);
+                } else {
+                    fprintf(stderr, " pc=%d", off);
+                }
+            }
+            fprintf(stderr, "\n");
+        }
+    }
+
+    janet_v_free(fibers);
+}
+
 /*
  * CFuns
  */
@@ -218,6 +287,13 @@ static Janet cfun_debug_stack(int32_t argc, Janet *argv) {
     return janet_wrap_array(array);
 }
 
+static Janet cfun_debug_stacktrace(int32_t argc, Janet *argv) {
+    janet_fixarity(argc, 2);
+    JanetFiber *fiber = janet_getfiber(argv, 0);
+    janet_stacktrace(fiber, argv[1]);
+    return argv[0];
+}
+
 static Janet cfun_debug_argstack(int32_t argc, Janet *argv) {
     janet_fixarity(argc, 1);
     JanetFiber *fiber = janet_getfiber(argv, 0);
@@ -280,6 +356,13 @@ static const JanetReg debug_cfuns[] = {
                 "\t:slots - array of all values in each slot\n"
                 "\t:tail - boolean indicating a tail call")
     },
+    {
+        "debug/stacktrace", cfun_debug_stacktrace,
+        JDOC("(debug/stacktrace fiber err)\n\n"
+                "Prints a nice looking stacktrace for a fiber. The error message "
+                "err must be passed to the function as fiber's do not keep track of "
+                "the last error they have thrown. Returns the fiber.")
+    },
     {
         "debug/lineage", cfun_debug_lineage,
         JDOC("(debug/lineage fib)\n\n"

src/core/run.c

@@ -23,63 +23,8 @@
 #ifndef JANET_AMALG
 #include <janet/janet.h>
 #include "state.h"
-#include "vector.h"
 #endif
 
-/* Error reporting */
-void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err) {
-    int32_t fi;
-    const char *errstr = (const char *)janet_to_string(err);
-    JanetFiber **fibers = NULL;
-    fprintf(stderr, "%s error: %s\n", errtype, errstr);
-
-    while (fiber) {
-        janet_v_push(fibers, fiber);
-        fiber = fiber->child;
-    }
-
-    for (fi = janet_v_count(fibers) - 1; fi >= 0; fi--) {
-        fiber = fibers[fi];
-        int32_t i = fiber->frame;
-        while (i > 0) {
-            JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE);
-            JanetFuncDef *def = NULL;
-            i = frame->prevframe;
-            fprintf(stderr, "  in");
-            if (frame->func) {
-                def = frame->func->def;
-                fprintf(stderr, " %s", def->name ? (const char *)def->name : "<anonymous>");
-                if (def->source) {
-                    fprintf(stderr, " [%s]", (const char *)def->source);
-                }
-            } else {
-                JanetCFunction cfun = (JanetCFunction)(frame->pc);
-                if (cfun) {
-                    Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun));
-                    if (!janet_checktype(name, JANET_NIL))
-                        fprintf(stderr, " %s", (const char *)janet_to_string(name));
-                    else
-                        fprintf(stderr, " <cfunction>");
-                }
-            }
-            if (frame->flags & JANET_STACKFRAME_TAILCALL)
-                fprintf(stderr, " (tailcall)");
-            if (frame->func && frame->pc) {
-                int32_t off = (int32_t) (frame->pc - def->bytecode);
-                if (def->sourcemap) {
-                    JanetSourceMapping mapping = def->sourcemap[off];
-                    fprintf(stderr, " at (%d:%d)", mapping.start, mapping.end);
-                } else {
-                    fprintf(stderr, " pc=%d", off);
-                }
-            }
-            fprintf(stderr, "\n");
-        }
-    }
-
-    janet_v_free(fibers);
-}
-
 /* Run a string */
 int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char *sourcePath, Janet *out) {
     JanetParser parser;
@@ -90,6 +35,7 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
     Janet ret = janet_wrap_nil();
     const uint8_t *where = sourcePath ? janet_cstring(sourcePath) : NULL;
     if (where) janet_gcroot(janet_wrap_string(where));
+    if (NULL == sourcePath) sourcePath = "<unknown>";
     janet_parser_init(&parser);
 
     while (!errflags && !done) {
@@ -103,13 +49,12 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
                 JanetFiber *fiber = janet_fiber(f, 64, 0, NULL);
                 JanetSignal status = janet_continue(fiber, janet_wrap_nil(), &ret);
                 if (status != JANET_SIGNAL_OK) {
-                    janet_stacktrace(fiber, "runtime", ret);
+                    janet_stacktrace(fiber, ret);
                     errflags |= 0x01;
                 }
             } else {
-                fprintf(stderr, "source path: %s\n", sourcePath);
+                fprintf(stderr, "compile error in %s: %s\n", sourcePath,
-                janet_stacktrace(cres.macrofiber, "compile",
+                        (const char *)cres.error);
-                        janet_wrap_string(cres.error));
                 errflags |= 0x02;
             }
         }
@@ -118,13 +63,15 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
         switch (janet_parser_status(&parser)) {
             case JANET_PARSE_ERROR:
                 errflags |= 0x04;
-                fprintf(stderr, "parse error: %s\n", janet_parser_error(&parser));
+                fprintf(stderr, "parse error in %s: %s\n",
+                        sourcePath, janet_parser_error(&parser));
                 break;
             case JANET_PARSE_PENDING:
                 if (index >= len) {
                     if (dudeol) {
                         errflags |= 0x04;
-                        fprintf(stderr, "internal parse error: unexpected end of source\n");
+                        fprintf(stderr, "internal parse error in %s: unexpected end of source\n",
+                                sourcePath);
                     } else {
                         dudeol = 1;
                         janet_parser_consume(&parser, '\n');

src/include/janet/janet.h

@@ -1114,7 +1114,7 @@ JANET_API void janet_deinit(void);
 JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out);
 JANET_API JanetSignal janet_pcall(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f);
 JANET_API Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv);
-JANET_API void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err);
+JANET_API void janet_stacktrace(JanetFiber *fiber, Janet err);
 
 /* C Library helpers */
 typedef enum {