Add error reporting to repl (initial stack traces)

Makefile

@@ -25,7 +25,7 @@
 PREFIX?=/usr/local
 BINDIR=$(PREFIX)/bin
 
-CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -Os -s
+CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -O3 -s
 CLIBS=-lm -ldl
 PREFIX=/usr/local
 DST_TARGET=dst

src/compiler/boot.dst

@@ -2,7 +2,7 @@
 # Copyright 2018 (C) Calvin Rose
 
 (var *env* 
- "The current environment. Is dynamically bound."
+ "The current environment."
  _env)
 
 (def defn :macro
@@ -39,6 +39,7 @@
  (apply1 tuple (array-concat
   ['defn name :private] more)))
 
+# Basic predicates
 (defn even? [x] (== 0 (% x 2)))
 (defn odd? [x] (== 1 (% x 2)))
 (defn nil? [x] (= x nil))
@@ -46,8 +47,6 @@
 (defn pos? [x] (> x 0))
 (defn neg? [x] (< x 0))
 (defn one? [x] (== x 1))
-(defn inc [x] (+ x 1))
-(defn dec [x] (- x 1))
 (def atomic? (do
   (def non-atomic-types {
    :array true
@@ -57,7 +56,9 @@
   })
   (fn [x] (not (get non-atomic-types (type x))))))
 
-# C style macros for imperative sugar
+# C style macros and functions for imperative sugar
+(defn inc [x] (+ x 1))
+(defn dec [x] (- x 1))
 (defmacro ++ [x] (tuple ':= x (tuple + x 1)))
 (defmacro -- [x] (tuple ':= x (tuple - x 1)))
 (defmacro += [x n] (tuple ':= x (tuple + x n)))
@@ -266,6 +267,10 @@ If no match is found, returns nil"
         ret)
  })
 
+(defn partial [f & more]
+ (if (zero? (length more)) f
+  (fn [& r] (apply1 f (array-concat [] more r)))))
+
 (defmacro for [head & body]
   (def head (ast-unwrap1 head))
   (def sym (get head 0))
@@ -281,6 +286,23 @@ If no match is found, returns nil"
      (tuple-prepend body 'do)
      (tuple ':= sym (tuple '+ sym inc)))))
 
+(defn juxt*
+  [& funs]
+  (def len (length funs))
+  (fn [& args]
+   (def ret [])
+   (for [i 0 len]
+    (array-push ret (apply1 (get funs i) args)))
+   (apply1 tuple ret)))
+
+(defmacro juxt
+ [& funs]
+ (def parts ['tuple])
+ (def $args (gensym))
+ (for [i 0 (length funs)]
+  (array-push parts (tuple apply1 (get funs i) $args)))
+ (tuple 'fn ['& $args] (apply1 tuple parts)))
+
 (defmacro ->
  [x & forms]
  (defn fop [last nextform]
@@ -514,11 +536,36 @@ onvalue."
   (def res (resume f))
    (if good
     (if (= (fiber-status f) :error)
-     (onerr "runtime" res)
+     (onerr "runtime" res f)
      (onvalue res))))
  (foreach (val-stream chunks onerr) doone)
  env)))
 
+(defn default-error-handler
+ [t x f]
+ (print)
+ (file-write stdout "error: ")
+ (pp x)
+ (when f
+  (def st (fiber-stack f))
+  (def len (length st))
+  (for [i 0 len]
+   (def {
+    :function func
+    :tail tail
+    :pc pc
+    :c c
+    :name name
+    } (get st i))
+   (file-write stdout "  in")
+   (when c (file-write stdout " cfunction"))
+   (when name (file-write stdout (string " " name))) 
+   (when func (file-write stdout (string " " func)))
+   (when pc (file-write stdout (string " (pc=" pc ")")))
+   (when tail (file-write stdout " (tailcall)"))
+   (file-write stdout "\n")))
+ (print))
+
 (def require (do
  (def cache @{})
  (def loading @{})
@@ -534,8 +581,7 @@ onvalue."
      (defn chunks [buf] (file-read f 1024 buf))
      (def oldenv *env*)
      (:= *env* newenv)
-     (run-context newenv chunks identity
-      (fn [t x] (print (string t " error: " x))))
+     (run-context newenv chunks identity default-error-handler)
      (file-close f)
      (:= *env* oldenv)
      (put loading path nil)
@@ -551,7 +597,7 @@ onvalue."
    (put env (symbol (if prefix prefix "") k) v)))))
 
 (defmacro import [path & args]
- (apply1 tuple (array-concat [import* '_env path] args))) 
+ (apply tuple import* '_env path args)) 
 
 (defn repl [getchunk]
  (def newenv (make-env))
@@ -562,5 +608,5 @@ onvalue."
  (defn onvalue [x]
   (put newenv '_ @{:value x})
   (pp x))
- (run-context newenv (if getchunk getchunk chunks) onvalue
-  (fn [t x] (print (string t " error: " x)))))
+ (run-context newenv (if getchunk getchunk chunks)
+  onvalue default-error-handler))

src/compiler/specials.c

@@ -589,6 +589,7 @@ DstSlot dstc_fn(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
     def = dstc_pop_funcdef(c);
     def->arity = arity;
     if (varargs) def->flags |= DST_FUNCDEF_FLAG_VARARG;
+    if (selfref) def->name = dst_unwrap_symbol(head);
     defindex = dstc_addfuncdef(c, def);
 
     /* Ensure enough slots for vararg function. */

src/compiler/stl.c

@@ -41,8 +41,6 @@ static const DstReg cfuns[] = {
     {"array", dst_core_array},
     {"tuple", dst_core_tuple},
     {"struct", dst_core_struct},
-    {"fiber", dst_core_fiber},
-    {"fiber-status", dst_core_fiber_status},
     {"buffer", dst_core_buffer},
     {"gensym", dst_core_gensym},
     {"get", dst_core_get},
@@ -110,6 +108,7 @@ DstTable *dst_stl_env() {
         dst_lib_tuple(args);
         dst_lib_buffer(args);
         dst_lib_table(args);
+        dst_lib_fiber(args);
         dst_lib_parse(args);
         dst_lib_compile(args);
         dst_lib_asm(args);

src/core/bytecode.c

@@ -215,6 +215,7 @@ DstFuncDef *dst_funcdef_alloc() {
     def->source = NULL;
     def->sourcepath = NULL;
     def->sourcemap = NULL;
+    def->name = NULL;
     def->defs = NULL;
     def->defs_length = 0;
     def->constants_length = 0;

src/core/corelib.c

@@ -134,15 +134,6 @@ int dst_core_struct(DstArgs args) {
     return dst_return(args, dst_wrap_struct(dst_struct_end(st)));
 }
 
-int dst_core_fiber(DstArgs args) {
-    DstFiber *fiber;
-    if (args.n < 1) return dst_throw(args, "expected at least 1 argument");
-    if (!dst_checktype(args.v[0], DST_FUNCTION))
-        return dst_throw(args, "expected a function");
-    fiber = dst_fiber(dst_unwrap_function(args.v[0]), 64);
-    return dst_return(args, dst_wrap_fiber(fiber));
-}
-
 int dst_core_gensym(DstArgs args) {
     if (args.n > 1) return dst_throw(args, "expected one argument");
     if (args.n == 0) {
@@ -198,33 +189,6 @@ int dst_core_setproto(DstArgs args) {
     return dst_return(args, args.v[0]);
 }
 
-int dst_core_fiber_status(DstArgs args) {
-    const char *status = "";
-    if (args.n != 1) return dst_throw(args, "expected 1 argument");
-    if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber");
-    switch(dst_unwrap_fiber(args.v[0])->status) {
-        case DST_FIBER_PENDING:
-            status = ":pending";
-            break;
-        case DST_FIBER_NEW:
-            status = ":new";
-            break;
-        case DST_FIBER_ALIVE:
-            status = ":alive";
-            break;
-        case DST_FIBER_DEAD:
-            status = ":dead";
-            break;
-        case DST_FIBER_ERROR:
-            status = ":error";
-            break;
-        case DST_FIBER_DEBUG:
-            status = ":debug";
-            break;
-    }
-    return dst_return(args, dst_csymbolv(status));
-}
-
 int dst_core_put(DstArgs args) {
     Dst ds, key, value;
     DstArgs subargs = args;

src/core/fiber.c

@@ -133,6 +133,7 @@ void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) {
     newframe->pc = func->def->bytecode;
     newframe->func = func;
     newframe->env = NULL;
+    newframe->flags = 0;
 
     /* Check varargs */
     if (func->def->flags & DST_FUNCDEF_FLAG_VARARG) {
@@ -211,6 +212,7 @@ void dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func) {
     /* Set frame stuff */
     dst_fiber_frame(fiber)->func = func;
     dst_fiber_frame(fiber)->pc = func->def->bytecode;
+    dst_fiber_frame(fiber)->flags |= DST_STACKFRAME_TAILCALL;
 }
 
 /* Push a stack frame to a fiber for a c function */
@@ -235,6 +237,7 @@ void dst_fiber_cframe(DstFiber *fiber) {
     newframe->pc = NULL;
     newframe->func = NULL;
     newframe->env = NULL;
+    newframe->flags = 0;
 }
 
 /* Pop a stack frame from the fiber. Returns the new stack frame, or
@@ -251,3 +254,108 @@ void dst_fiber_popframe(DstFiber *fiber) {
     fiber->stacktop = fiber->stackstart = fiber->frame;
     fiber->frame = frame->prevframe;
 }
+
+/* CFuns */
+
+static int cfun_fiber(DstArgs args) {
+    DstFiber *fiber;
+    if (args.n < 1) return dst_throw(args, "expected at least 1 argument");
+    if (!dst_checktype(args.v[0], DST_FUNCTION))
+        return dst_throw(args, "expected a function");
+    fiber = dst_fiber(dst_unwrap_function(args.v[0]), 64);
+    return dst_return(args, dst_wrap_fiber(fiber));
+}
+
+static int cfun_status(DstArgs args) {
+    const char *status = "";
+    if (args.n != 1) return dst_throw(args, "expected 1 argument");
+    if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber");
+    switch(dst_unwrap_fiber(args.v[0])->status) {
+        case DST_FIBER_PENDING:
+            status = ":pending";
+            break;
+        case DST_FIBER_NEW:
+            status = ":new";
+            break;
+        case DST_FIBER_ALIVE:
+            status = ":alive";
+            break;
+        case DST_FIBER_DEAD:
+            status = ":dead";
+            break;
+        case DST_FIBER_ERROR:
+            status = ":error";
+            break;
+        case DST_FIBER_DEBUG:
+            status = ":debug";
+            break;
+    }
+    return dst_return(args, dst_csymbolv(status));
+}
+
+/* Extract info from one stack frame */
+static Dst doframe(DstStackFrame *frame) {
+    int32_t off;
+    DstTable *t = dst_table(3);
+    DstFuncDef *def = NULL;
+    if (frame->func) {
+        dst_table_put(t, dst_csymbolv(":function"), dst_wrap_function(frame->func));
+        def = frame->func->def;
+        if (def->name) {
+            dst_table_put(t, dst_csymbolv(":name"), dst_wrap_string(def->name));
+        }
+    } else {
+        dst_table_put(t, dst_csymbolv(":c"), dst_wrap_true());
+    }
+    if (frame->flags & DST_STACKFRAME_TAILCALL) {
+        dst_table_put(t, dst_csymbolv(":tail"), dst_wrap_true());
+    }
+    if (frame->pc) {
+        off = frame->pc - def->bytecode;
+        dst_table_put(t, dst_csymbolv(":pc"), dst_wrap_integer(off));
+        if (def->sourcemap) {
+            DstSourceMapping mapping = def->sourcemap[off];
+            dst_table_put(t, dst_csymbolv(":source-start"), dst_wrap_integer(mapping.start));
+            dst_table_put(t, dst_csymbolv(":source-end"), dst_wrap_integer(mapping.end));
+        }
+        if (def->source) {
+            dst_table_put(t, dst_csymbolv(":source"), dst_wrap_string(def->source));
+        } else if (def->sourcepath) {
+            dst_table_put(t, dst_csymbolv(":sourcepath"), dst_wrap_string(def->sourcepath));
+        }
+    }
+    return dst_wrap_table(t);
+}
+
+static int cfun_stack(DstArgs args) {
+    DstFiber *fiber;
+    DstArray *array;
+    if (args.n != 1) return dst_throw(args, "expected 1 argument");
+    if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber");
+    fiber = dst_unwrap_fiber(args.v[0]);
+    array = dst_array(0);
+    {
+        int32_t i = fiber->frame;
+        DstStackFrame *frame;
+        while (i > 0) {
+            frame = (DstStackFrame *)(fiber->data + i - DST_FRAME_SIZE);
+            dst_array_push(array, doframe(frame));
+            i = frame->prevframe;
+        }
+    }
+    return dst_return(args, dst_wrap_array(array));
+}
+
+static const DstReg cfuns[] = {
+    {"fiber", cfun_fiber},
+    {"fiber-status", cfun_status},
+    {"fiber-stack", cfun_stack},
+    {NULL, NULL}
+};
+
+/* Module entry point */
+int dst_lib_fiber(DstArgs args) {
+    DstTable *env = dst_env_arg(args);
+    dst_env_cfuns(env, cfuns);
+    return 0;
+}

src/core/gc.c

@@ -162,6 +162,8 @@ static void dst_mark_funcdef(DstFuncDef *def) {
         dst_mark_string(def->source);
     if (def->sourcepath)
         dst_mark_string(def->sourcepath);
+    if (def->name)
+        dst_mark_string(def->name);
 }
 
 static void dst_mark_function(DstFunction *func) {

src/core/string.c

@@ -103,21 +103,21 @@ const uint8_t *dst_cstring(const char *str) {
 }
 
 /* Temporary buffer size */
-#define DST_BUFSIZE 36
+#define BUFSIZE 36
 
 static int32_t real_to_string_impl(uint8_t *buf, double x) {
     /* Use 16 decimal places to ignore one ulp errors for now */
-    int count = snprintf((char *) buf, DST_BUFSIZE, "%.16gR", x);
+    int count = snprintf((char *) buf, BUFSIZE, "%.16gR", x);
     return (int32_t) count;
 }
 
 static void real_to_string_b(DstBuffer *buffer, double x) {
-    dst_buffer_ensure(buffer, buffer->count + DST_BUFSIZE);
+    dst_buffer_ensure(buffer, buffer->count + BUFSIZE);
     buffer->count += real_to_string_impl(buffer->data + buffer->count, x);
 }
 
 static const uint8_t *real_to_string(double x) {
-    uint8_t buf[DST_BUFSIZE];
+    uint8_t buf[BUFSIZE];
     return dst_string(buf, real_to_string_impl(buf, x));
 }
 
@@ -152,12 +152,12 @@ static int32_t integer_to_string_impl(uint8_t *buf, int32_t x) {
 }
 
 static void integer_to_string_b(DstBuffer *buffer, int32_t x) {
-    dst_buffer_extra(buffer, DST_BUFSIZE);
+    dst_buffer_extra(buffer, BUFSIZE);
     buffer->count += integer_to_string_impl(buffer->data + buffer->count, x);
 }
 
 static const uint8_t *integer_to_string(int32_t x) {
-    uint8_t buf[DST_BUFSIZE];
+    uint8_t buf[BUFSIZE];
     return dst_string(buf, integer_to_string_impl(buf, x));
 }
 
@@ -191,19 +191,19 @@ static int32_t string_description_impl(uint8_t *buf, const char *title, void *po
 }
 
 static void string_description_b(DstBuffer *buffer, const char *title, void *pointer) {
-    dst_buffer_ensure(buffer, buffer->count + DST_BUFSIZE);
+    dst_buffer_ensure(buffer, buffer->count + BUFSIZE);
     buffer->count += string_description_impl(buffer->data + buffer->count, title, pointer);
 }
 
 /* Describes a pointer with a title (string_description("bork",  myp) returns 
  * a string "<bork 0x12345678>") */
 static const uint8_t *string_description(const char *title, void *pointer) {
-    uint8_t buf[DST_BUFSIZE];
+    uint8_t buf[BUFSIZE];
     return dst_string(buf, string_description_impl(buf, title, pointer));
 }
 
 #undef HEX
-#undef DST_BUFSIZE
+#undef BUFSIZE
 
 /* TODO - add more characters to escape. 
  *

src/include/dst/dstcorelib.h

@@ -87,7 +87,6 @@ int dst_core_tuple(DstArgs args);
 int dst_core_array(DstArgs args);
 int dst_core_table(DstArgs args);
 int dst_core_struct(DstArgs args);
-int dst_core_fiber(DstArgs args);
 int dst_core_buffer(DstArgs args);
 int dst_core_gensym(DstArgs args);
 int dst_core_length(DstArgs args);
@@ -95,8 +94,6 @@ int dst_core_get(DstArgs args);
 int dst_core_rawget(DstArgs args);
 int dst_core_getproto(DstArgs args);
 int dst_core_setproto(DstArgs args);
-int dst_core_fiber_status(DstArgs args);
-int dst_core_fiber_location(DstArgs args);
 int dst_core_put(DstArgs args);
 int dst_core_gccollect(DstArgs args);
 int dst_core_gcsetinterval(DstArgs args);
@@ -113,6 +110,7 @@ int dst_lib_array(DstArgs args);
 int dst_lib_tuple(DstArgs args);
 int dst_lib_buffer(DstArgs args);
 int dst_lib_table(DstArgs args);
+int dst_lib_fiber(DstArgs args);
 
 /* Useful for compiler */
 Dst dst_op_add(Dst lhs, Dst rhs);

src/include/dst/dsttypes.h

@@ -335,12 +335,16 @@ struct DstFiber {
     } status;
 };
 
+/* Mark if a stack frame is a tail call for debugging */
+#define DST_STACKFRAME_TAILCALL 1
+
 /* A stack frame on the fiber. Is stored along with the stack values. */
 struct DstStackFrame {
     DstFunction *func;
     uint32_t *pc;
-    int32_t prevframe;
     DstFuncEnv *env;
+    int32_t prevframe;
+    uint32_t flags;
 };
 
 /* Number of Dsts a frame takes up in the stack */
@@ -395,6 +399,7 @@ struct DstFuncDef {
     DstSourceMapping *sourcemap;
     const uint8_t *source;
     const uint8_t *sourcepath;
+    const uint8_t *name;
 
     uint32_t flags;
     int32_t slotcount; /* The amount of stack space required for the function */