Add macros in compiler.

src/compiler/compile.c

@@ -731,29 +731,6 @@ static DstSlot dstc_call(DstFopts opts, DstAst *ast, DstSM *sms, DstSlot fun) {
     return retslot;
 }
 
-/* Compile a tuple */
-DstSlot dstc_tuple(DstFopts opts, DstAst *ast, Dst x) {
-    Dst headval;
-    DstSlot head;
-    DstCompiler *c = opts.compiler;
-    DstFopts subopts = dstc_fopts_default(c);
-    const Dst *tup = dst_unwrap_tuple(x);
-    /* Empty tuple is tuple literal */
-    if (dst_tuple_length(tup) == 0) return dstc_cslot(x);
-    /* Symbols could be specials */
-    headval = dst_ast_unwrap1(tup[0]);
-    if (dst_checktype(headval, DST_SYMBOL)) {
-        const DstSpecial *s = dstc_special(dst_unwrap_symbol(headval));
-        if (NULL != s) {
-            return s->compile(opts, ast, dst_tuple_length(tup) - 1, tup + 1);
-        }
-    }
-    /* Compile the head of the tuple */
-    subopts.flags = DST_FUNCTION | DST_CFUNCTION;
-    head = dstc_value(subopts, tup[0]);
-    return dstc_call(opts, ast, dstc_toslots(c, tup + 1, dst_tuple_length(tup) - 1), head);
-}
-
 static DstSlot dstc_array(DstFopts opts, DstAst *ast, Dst x) {
     DstCompiler *c = opts.compiler;
     DstArray *a = dst_unwrap_array(x);
@@ -770,7 +747,11 @@ static DstSlot dstc_tablector(DstFopts opts, DstAst *ast, Dst x, DstCFunction cf
 /* Compile a single value */
 DstSlot dstc_value(DstFopts opts, Dst x) {
     DstSlot ret;
-    DstAst *ast = dst_ast_node(x);
+    DstAst *ast;
+    DstCompiler *c = opts.compiler;
+    opts.compiler->recursion_guard--;
+recur:
+    ast = dst_ast_node(x);
     x = dst_ast_unwrap1(x);
     if (dstc_iserr(&opts)) {
         return dstc_cslot(dst_wrap_nil());
@@ -779,7 +760,6 @@ DstSlot dstc_value(DstFopts opts, Dst x) {
         dstc_cerror(opts.compiler, ast, "recursed too deeply");
         return dstc_cslot(dst_wrap_nil());
     }
-    opts.compiler->recursion_guard--;
     switch (dst_type(x)) {
         default:
             ret = dstc_cslot(x);
@@ -791,7 +771,52 @@ DstSlot dstc_value(DstFopts opts, Dst x) {
                 break;
             }
         case DST_TUPLE:
-            ret = dstc_tuple(opts, ast, x);
+            {
+                int compiled = 0;
+                Dst headval;
+                DstSlot head;
+                DstFopts subopts = dstc_fopts_default(c);
+                const Dst *tup = dst_unwrap_tuple(x);
+                /* Empty tuple is tuple literal */
+                if (dst_tuple_length(tup) == 0) {
+                    compiled = 1;
+                    ret = dstc_cslot(x);
+                } else {
+                    /* Symbols could be specials */
+                    headval = dst_ast_unwrap1(tup[0]);
+                    if (dst_checktype(headval, DST_SYMBOL)) {
+                        const DstSpecial *s = dstc_special(dst_unwrap_symbol(headval));
+                        if (NULL != s) {
+                            ret = s->compile(opts, ast, dst_tuple_length(tup) - 1, tup + 1);
+                            compiled = 1;
+                        } else {
+                            /* Check macro */
+                            DstTable *env = c->env;
+                            int status;
+                            Dst fn;
+                            Dst entry = dst_table_get(env, headval);
+                            for (;;) {
+                                if (dst_checktype(entry, DST_NIL)) break;
+                                if (dst_checktype(dst_get(entry, dst_csymbolv("macro")), DST_NIL)) break;
+                                fn = dst_get(entry, dst_csymbolv("value"));
+                                if (!dst_checktype(fn, DST_FUNCTION)) break;
+                                status = dst_call(fn, &x, dst_tuple_length(tup) - 1, tup + 1);
+                                if (status) {
+                                    dstc_cerror(c, ast, "error in macro expansion");
+                                }
+                                /* Tail recur on the value */
+                                goto recur;
+                            }
+                        }
+                    }
+                    if (!compiled) {
+                        /* Compile the head of the tuple */
+                        subopts.flags = DST_FUNCTION | DST_CFUNCTION;
+                        head = dstc_value(subopts, tup[0]);
+                        ret = dstc_call(opts, ast, dstc_toslots(c, tup + 1, dst_tuple_length(tup) - 1), head);
+                    }
+                }
+            }
             break;
         case DST_ARRAY:
             ret = dstc_array(opts, ast, x); 
@@ -881,7 +906,6 @@ DstFuncDef *dstc_pop_funcdef(DstCompiler *c) {
     return def;
 }
 
-
 /* Initialize a compiler */
 static void dstc_init(DstCompiler *c, DstTable *env) {
     c->scopes = NULL;

src/core/buffer.c

@@ -179,10 +179,24 @@ static int cfun_chars(DstArgs args) {
     return dst_return(args, args.v[0]);
 }
 
+static int cfun_clear(DstArgs args) {
+    DstBuffer *buffer;
+    if (args.n < 1 || !dst_checktype(args.v[0], DST_BUFFER)) return dst_throw(args, "expected buffer");
+    buffer = dst_unwrap_buffer(args.v[0]);
+    buffer->count = 0;
+    return dst_return(args, args.v[0]);
+}
+
+static const DstReg cfuns[] = {
+    {"buffer-push-byte", cfun_u8},
+    {"buffer-push-integer", cfun_int},
+    {"buffer-push-string", cfun_chars},
+    {"buffer-clear", cfun_clear},
+    {NULL, NULL}
+};
+
 int dst_lib_buffer(DstArgs args) {
     DstTable *env = dst_env_arg(args);
-    dst_env_def(env, "buffer-push-byte", dst_wrap_cfunction(cfun_u8));
-    dst_env_def(env, "buffer-push-integer", dst_wrap_cfunction(cfun_int));
-    dst_env_def(env, "buffer-push-string", dst_wrap_cfunction(cfun_chars));
+    dst_env_cfuns(env, cfuns);
     return 0;
 }

src/core/gc.c

@@ -28,6 +28,7 @@
 void *dst_vm_blocks;
 uint32_t dst_vm_gc_interval;
 uint32_t dst_vm_next_collection;
+int dst_vm_gc_suspend = 0;
 
 /* Roots */
 Dst *dst_vm_roots;
@@ -303,6 +304,7 @@ void *dst_gcalloc(DstMemoryType type, size_t size) {
 /* Run garbage collection */
 void dst_collect() {
     uint32_t i;
+    if (dst_vm_gc_suspend) return;
     if (dst_vm_fiber)
         dst_mark_fiber(dst_vm_fiber);
     for (i = 0; i < dst_vm_root_count; i++)

src/core/io.c

@@ -231,11 +231,11 @@ static int dst_io_fclose(DstArgs args) {
 #endif
 
 static const DstReg cfuns[] = {
-    {"fopen", dst_io_fopen},
-    {"fclose", dst_io_fclose},
-    {"fread", dst_io_fread},
-    {"fwrite", dst_io_fwrite},
-    {"fflush", dst_io_fflush},
+    {"file-open", dst_io_fopen},
+    {"file-close", dst_io_fclose},
+    {"file-read", dst_io_fread},
+    {"file-write", dst_io_fwrite},
+    {"file-flush", dst_io_fflush},
     {NULL, NULL}
 };
 

src/core/tuple.c

@@ -125,9 +125,35 @@ static int cfun_slice(DstArgs args) {
     return dst_return(args, dst_wrap_tuple(dst_tuple_end(ret)));
 }
 
+static int cfun_prepend(DstArgs args) {
+    const Dst *t;
+    Dst *n;
+    if (args.n != 2) return dst_throw(args, "expected 2 arguments");
+    if (!dst_checktype(args.v[0], DST_TUPLE)) return dst_throw(args, "expected tuple");
+    t = dst_unwrap_tuple(args.v[0]);
+    n = dst_tuple_begin(dst_tuple_length(t) + 1);
+    memcpy(n + 1, t, sizeof(Dst) * dst_tuple_length(t));
+    n[0] = args.v[1];
+    return dst_return(args, dst_wrap_tuple(dst_tuple_end(n)));
+}
+
+static int cfun_append(DstArgs args) {
+    const Dst *t;
+    Dst *n;
+    if (args.n != 2) return dst_throw(args, "expected 2 arguments");
+    if (!dst_checktype(args.v[0], DST_TUPLE)) return dst_throw(args, "expected tuple");
+    t = dst_unwrap_tuple(args.v[0]);
+    n = dst_tuple_begin(dst_tuple_length(t) + 1);
+    memcpy(n, t, sizeof(Dst) * dst_tuple_length(t));
+    n[dst_tuple_length(t)] = args.v[1];
+    return dst_return(args, dst_wrap_tuple(dst_tuple_end(n)));
+}
+
 /* Load the tuple module */
 int dst_lib_tuple(DstArgs args) {
     DstTable *env = dst_env_arg(args);
     dst_env_def(env, "tuple-slice", dst_wrap_cfunction(cfun_slice));
+    dst_env_def(env, "tuple-append", dst_wrap_cfunction(cfun_append));
+    dst_env_def(env, "tuple-prepend", dst_wrap_cfunction(cfun_prepend));
     return 0;
 }

src/core/vm.c

@@ -685,6 +685,36 @@ int dst_run(Dst callee, Dst *returnreg) {
     return 1;
 }
 
+/* Run from inside a cfunction. This should only be used for
+ * short functions as it prevents re-entering the current fiber
+ * and suspend garbage collection. */
+int dst_call(Dst callee, Dst *returnreg, int32_t argn, const Dst *argv) {
+    int ret;
+    int lock;
+    DstFiber *oldfiber = dst_vm_fiber;
+    lock = dst_vm_gc_suspend++;
+    dst_vm_fiber = dst_fiber(0);
+    dst_fiber_pushn(dst_vm_fiber, argv, argn);
+    if (dst_checktype(callee, DST_CFUNCTION)) {
+        DstArgs args;
+        *returnreg = dst_wrap_nil();
+        dst_fiber_cframe(dst_vm_fiber);
+        args.n = argn;
+        args.v = dst_vm_fiber->data + dst_vm_fiber->frame;
+        args.ret = returnreg;
+        ret = dst_unwrap_cfunction(callee)(args);
+    } else if (dst_checktype(callee, DST_FUNCTION)) {
+        dst_fiber_funcframe(dst_vm_fiber, dst_unwrap_function(callee));
+        ret = dst_continue(returnreg);
+    } else {
+        *returnreg = dst_cstringv("expected function");
+        ret = 1;
+    }
+    dst_vm_fiber = oldfiber;
+    dst_vm_gc_suspend = lock;
+    return ret;
+}
+
 /* Setup functions */
 int dst_init() {
     /* Garbage collection */

src/include/dst/dst.h

@@ -164,6 +164,8 @@ int dst_gcunroot(Dst root);
 int dst_gcunrootall(Dst root);
 #define dst_maybe_collect() do {\
     if (dst_vm_next_collection >= dst_vm_gc_interval) dst_collect(); } while (0)
+#define dst_gclock() (dst_vm_gc_suspend++)
+#define dst_gcunlock() (dst_vm_gc_suspend--)
 
 /* Functions */
 DstFuncDef *dst_funcdef_alloc();
@@ -191,6 +193,7 @@ DstCFunction dst_native(const char *name, const uint8_t **error);
 int dst_init();
 void dst_deinit();
 int dst_run(Dst callee, Dst *returnreg);
+int dst_call(Dst callee, Dst *returnreg, int32_t argn, const Dst *argv);
 
 /* C Function helpers */
 #define dst_throw(a, e) (*((a).ret) = dst_cstringv(e), 1)

src/include/dst/dststate.h

@@ -41,6 +41,7 @@ extern const char *dst_type_names[16];
 extern void *dst_vm_blocks;
 extern uint32_t dst_vm_gc_interval;
 extern uint32_t dst_vm_next_collection;
+extern int dst_vm_gc_suspend;
 
 /* Immutable value cache */
 extern const uint8_t **dst_vm_cache;

test/boot.dst

@@ -1,67 +0,0 @@
-
-# This file is executed without any macro expansion (macros are not
-# yet defined). Cannot use macros or anything outside the stl.
-
-(var macros @{})
-
-# Helper for macro expansion
-(def macroexpand (fn recur [x]
-    (def x (ast-unwrap x))
-	(if (= (type x) :tuple)
-		(if (> (length x) 0)
-			(do
-				(def first (get x 0))
-                (def rest (array-slice x 1))
-                (def macro (get macros first))
-                (if macro (recur (apply macro rest)) x))
-            x)
-		x)))
-
-# Function to create macros
-(def _defmacro (fn [name f]
-    (set macros name f)
-	f))
-
-# Make defn
-(_defmacro "defn" (fn [name &]
-	(tuple 'def name (apply tuple 'fn &))))
-
-# Make defmacro
-(_defmacro "defmacro" (fn [name &]
-	(tuple global-macro (string name) (apply tuple 'fn &))))
-
-# Comment returns nil
-(_defmacro "comment" (fn [] nil))
-
-# The source file to read from
-(var *sourcefile* stdin)
-
-# The *read* macro gets the next form from the source file, and
-# returns it. It is a var and therefor can be overwritten.
-(var *read* (fn []
-	(def b (buffer))
-	(def p (parser))
-	(while (not (parse-hasvalue p))
-		(read *sourcefile* 1 b)
-		(if (= (length b) 0)
-			(error "parse error: unexpected end of source"))
-		(parse-charseq p b)
-		(if (= (parse-status p) :error)
-			(error (string "parse error: " (parse-consume p))))
-		(clear b))
-	(parse-consume p)))
-
-# Evaluates a form by macro-expanding it, compiling it, and
-# then executing it.
-(def eval (fn [x]
-	(def func (compile (macroexpand x)))
-	(if (= :function (type func))
-		(func)
-		(error (string "compiler error: " func)))))
-
-# A simple repl for testing.
-(while true
-	(def t (thread (fn []
-		(while true
-			(print (eval (*read*)))))))
-	(print (tran t)))

test/repl.dst

@@ -0,0 +1,14 @@
+# Bootstrap the language 
+
+# Helper for macro expansion
+(def macroexpand (fn recur [x]
+    (def y (ast-unwrap x))
+	(if (= (type y) :tuple)
+		(if (> (length y) 0)
+			(do
+				(def first (get y 0))
+                (def rest (array-slice y 1))
+                (def macro (get _env first))
+                (if macro (recur (apply macro rest)) x))
+            x)
+		x)))

test/scratch.dst

@@ -1,18 +1,34 @@
-(def fib (asm '{
-  bytecode [
-    (load-integer 2 2)
-    (less-than 2 0 2)
-    (jump-if-not 2 2)
-    (return 0)
-    (load-self 1)
-    (add-immediate 0 0 -1)
-    (push 0)
-    (call 2 1)
-    (add-immediate 0 0 -1)
-    (push 0)
-    (call 3 1)
-    (add-integer 0 2 3)
-    (return 0)
-  ]
-  arity 1
-}))
+(def mapnil
+ " (mapnil f a) 
+ Map a function over a tuple or array and return nil."
+ (fn [f t]
+  (var i 0)
+  (def len (length t))
+  (while (< i len)
+    (f (get t i))
+    (varset! i (+ i 1)))))
+
+(def mapt 
+ " (mapt f t)
+ Map a function over a tuple or array and produce a new tuple."
+ (fn [f t]
+  (var i 0)
+  (def len (length t))
+  (def accum [])
+  (while (< i len)
+    (array-push accum (f (get t i)))
+    (varset! i (+ i 1)))
+  (apply tuple accum)))
+    
+(def mapa 
+ " (mapa f a) 
+ Map a function over a tuple or array and produce a new array."
+ (fn [f t]
+  (var i 0)
+  (def len (length t))
+  (def accum [])
+  (while (< i len)
+    (array-push accum (f (get t i)))
+    (varset! i (+ i 1)))
+  accum))
+

test/suite0.dst

@@ -59,6 +59,7 @@
 	(fn [x] (+ x x))
 	+) "type ordering")
 
+(assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal")
 (assert (= (get {} 1) nil) "get nil from empty struct")
 (assert (= (get @{} 1) nil) "get nil from empty table")
 (assert (= (get {:boop :bap} :boop) :bap) "get non nil from struct")
@@ -259,6 +260,35 @@
 		(varset! count (+ 1 count)))
 	(assert (= (length syms) 128) "many symbols")))
 
+# Macros
+
+(def defmacro macro (fn [name & more]
+  (tuple 'def name 'macro (tuple-prepend (tuple-prepend more name) 'fn))))
+(defmacro defn 
+  [name & more]
+  (tuple 
+   'def
+   name 
+   (tuple-prepend (tuple-prepend more name) 'fn)))
+
+(defmacro when [cond & body] (tuple 'if cond (tuple-prepend body 'do)))
+
+(defn dub [x] (+ x x))
+(assert (= 2 (dub 1)) "defn macro")
+(do 
+ (defn trip [x] (+ x x x))
+ (assert (= 3 (trip 1)) "defn macro triple"))
+(do
+ (var i 0)
+ (when true
+  (varset! i (+ i 1))
+  (varset! i (+ i 1))
+  (varset! i (+ i 1))
+  (varset! i (+ i 1))
+  (varset! i (+ i 1))
+  (varset! i (+ i 1)))
+ (assert (= i 6) "when macro"))
+
 # report
 
 (print "\n" num-tests-passed " of " num-tests-run " tests passed\n")