Add macroexpand and macroexpand1

src/compiler/boot.dst

@@ -1,6 +1,10 @@
 # Bootstrap the dst environment
 # Copyright 2018 (C) Calvin Rose
 
+(var *env* 
+ "The current environment. Is dynamically bound."
+ _env)
+
 (def defn :macro
  "Define a function"
   (fn [name & more] 
@@ -18,7 +22,7 @@
 (def defmacro :macro
  "Define a macro."
  (do
-  (def defn* (get (get _env 'defn) 'value))
+  (def defn* (get (get _env 'defn) :value))
   (fn [name & more] 
    (def args (array-concat [] name :macro more))
    (apply1 defn* args))))
@@ -355,11 +359,95 @@ If no match is found, returns nil"
   (foreach s (fn [x] (put tab x true)))
   (keys tab))
 
+(defn macroexpand1
+ "Expand macros in a form, but do not recursively expand macros."
+ [x]
+
+ (defn doarray [a] 
+  (def len (length a))
+  (def newa [])
+  (for [i 0 len] 
+   (array-push newa (macroexpand1 (get a i))))
+  newa)
+
+ (defn dotable [t]
+  (def newt @{})
+  (var key (next t nil))
+  (while (not= nil key)
+   (put newt (macroexpand1 key) (macroexpand1 (get t key)))
+   (:= key (next t key)))
+  newt)
+
+ (defn expandlast [t]
+  (def len (length t))
+  (def last (get t (- len 1)))
+  (tuple-append (tuple-slice t 0 -2) (macroexpand1 last)))
+
+ (defn expandall [t]
+  (def args (doarray (tuple-slice t 1)))
+  (apply tuple (get t 0) args))
+
+ (defn expandfn [t]
+  (def args (doarray (tuple-slice t 2)))
+  (apply tuple 'fn (get t 1) args))
+
+  (def specs {
+      ':= expandlast
+      'ast-quote identity
+      'def expandlast
+      'do expandall
+      'fn expandfn
+      'if expandall
+      'quote identity
+      'var expandlast
+      'while expandall
+   }) 
+
+ (defn dotup [t]
+  (def h (get t 0))
+  (def s (get specs h))
+  (def entry (get *env* h))
+  (def m (get entry :value))
+  (def m? (get entry :macro))
+  (cond
+   s (s t)
+   m? (apply1 m (tuple-slice t 1))
+   (apply1 tuple (doarray t))))
+
+ (defn doarray* [a]
+  (def res (doarray a))
+  (if (= (apply tuple res) (apply tuple a)) a res))
+
+ (defn dotable* [t]
+  (def res (dotable t))
+  (if (= (table-to-struct res) (table-to-struct t)) t res))
+
+ (def ux (ast-unwrap1 x))
+ (select (type ux)
+  :tuple (dotup ux)
+  :array (doarray* ux)
+  :struct (table-to-struct (dotable ux))
+  :table (dotable* ux)
+  ux))
+
+(defn macroexpand
+ "Expand macros completely."
+ [x]
+ (var previous x)
+ (var current (macroexpand1 x))
+ (var counter 0)
+ (while (not= current previous)
+  (if (> (++ counter) 200)
+   (error "macro expansion too nested"))
+  (:= previous current)
+  (:= current (macroexpand1 current)))
+ current)
+
 (defn make-env [parent safe]
  (def parent (if parent parent _env))
  (def newenv (setproto @{} parent))
  (if (not safe)
-   (put newenv '_env @{'value newenv}))
+   (put newenv '_env @{:value newenv}))
  newenv)
 
 (def run-context 
@@ -444,9 +532,12 @@ onvalue."
      (put loading path true)
      (def f (file-open path))
      (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))))
      (file-close f)
+     (:= *env* oldenv)
      (put loading path nil)
      newenv)))))
 
@@ -469,7 +560,7 @@ onvalue."
     (file-flush stdout)
     (file-read stdin :line buf))
  (defn onvalue [x]
-  (put newenv '_ @{'value x})
+  (put newenv '_ @{:value x})
   (pp x))
  (run-context newenv (if getchunk getchunk chunks) onvalue
   (fn [t x] (print (string t " error: " x)))))

src/compiler/compile.c

@@ -263,7 +263,7 @@ DstSlot dstc_resolve(
             dstc_error(c, ast, dst_formatc("unknown symbol %q", sym));
             return dstc_cslot(dst_wrap_nil());
         }
-        ref = dst_get(check, dst_csymbolv("ref"));
+        ref = dst_get(check, dst_csymbolv(":ref"));
         if (dst_checktype(ref, DST_ARRAY)) {
             DstSlot ret = dstc_cslot(ref);
             /* TODO save type info */
@@ -271,7 +271,7 @@ DstSlot dstc_resolve(
             ret.flags &= ~DST_SLOT_CONSTANT;
             return ret;
         } else {
-            Dst value = dst_get(check, dst_csymbolv("value"));
+            Dst value = dst_get(check, dst_csymbolv(":value"));
             return dstc_cslot(value);
         }
     }
@@ -819,7 +819,7 @@ recur:
                             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"));
+                                fn = dst_get(entry, dst_csymbolv(":value"));
                                 if (!dst_checktype(fn, DST_FUNCTION)) break;
                                 if (macrorecur++ > DST_RECURSION_GUARD) {
                                     dstc_cerror(c, ast, "macro expansion recursed too deeply");

src/compiler/specials.c

@@ -228,7 +228,7 @@ static void varleaf(
         reftab->proto = attr;
         DstArray *ref = dst_array(1);
         dst_array_push(ref, dst_wrap_nil());
-        dst_table_put(reftab, dst_csymbolv("ref"), dst_wrap_array(ref));
+        dst_table_put(reftab, dst_csymbolv(":ref"), dst_wrap_array(ref));
         dst_table_put(c->env, dst_wrap_symbol(sym), dst_wrap_table(reftab));
         refslot = dstc_cslot(dst_wrap_array(ref));
         refarrayslot = refslot;
@@ -266,7 +266,7 @@ static void defleaf(
         DstTable *tab = dst_table(2);
         tab->proto = attr;
         int32_t tableindex, valsymindex, valueindex;
-        DstSlot valsym = dstc_cslot(dst_csymbolv("value"));
+        DstSlot valsym = dstc_cslot(dst_csymbolv(":value"));
         DstSlot tabslot = dstc_cslot(dst_wrap_table(tab));
 
         /* Add env entry to env */

src/compiler/stl.c

@@ -109,6 +109,7 @@ DstTable *dst_stl_env() {
         dst_lib_array(args);
         dst_lib_tuple(args);
         dst_lib_buffer(args);
+        dst_lib_table(args);
         dst_lib_parse(args);
         dst_lib_compile(args);
         dst_lib_asm(args);

src/core/table.c

@@ -235,4 +235,25 @@ void dst_table_merge_struct(DstTable *table, const DstKV *other) {
     dst_table_mergekv(table, other, dst_struct_capacity(other));
 }
 
+static int cfun_tostruct(DstArgs args) {
+    DstTable *t;
+    if (args.n != 1 || !dst_checktype(args.v[0], DST_TABLE)) {
+        return dst_throw(args, "expected table");
+    }
+    t = dst_unwrap_table(args.v[0]);
+    return dst_return(args, dst_wrap_struct(dst_table_to_struct(t)));
+}
+
+static const DstReg cfuns[] = {
+    {"table-to-struct", cfun_tostruct},
+    {NULL, NULL}
+};
+
+/* Load the table module */
+int dst_lib_table(DstArgs args) {
+    DstTable *env = dst_env_arg(args);
+    dst_env_cfuns(env, cfuns);
+    return 0;
+}
+
 #undef dst_table_maphash

src/core/util.c

@@ -112,7 +112,7 @@ int dst_cstrcmp(const uint8_t *str, const char *other) {
 /* Add a module definition */
 void dst_env_def(DstTable *env, const char *name, Dst val) {
     DstTable *subt = dst_table(1);
-    dst_table_put(subt, dst_csymbolv("value"), val);
+    dst_table_put(subt, dst_csymbolv(":value"), val);
     dst_table_put(env, dst_csymbolv(name), dst_wrap_table(subt));
 }
 
@@ -121,7 +121,7 @@ void dst_env_var(DstTable *env, const char *name, Dst val) {
     DstArray *array = dst_array(1);
     DstTable *subt = dst_table(1);
     dst_array_push(array, val);
-    dst_table_put(subt, dst_csymbolv("ref"), dst_wrap_array(array));
+    dst_table_put(subt, dst_csymbolv(":ref"), dst_wrap_array(array));
     dst_table_put(env, dst_csymbolv(name), dst_wrap_table(subt));
 }
 
@@ -139,11 +139,11 @@ Dst dst_env_resolve(DstTable *env, const char *name) {
     Dst ref;
     Dst entry = dst_table_get(env, dst_csymbolv(name));
     if (dst_checktype(entry, DST_NIL)) return dst_wrap_nil();
-    ref = dst_get(entry, dst_csymbolv("ref"));
+    ref = dst_get(entry, dst_csymbolv(":ref"));
     if (dst_checktype(ref, DST_ARRAY)) {
         return dst_getindex(ref, 0);
     }
-    return dst_get(entry, dst_csymbolv("value"));
+    return dst_get(entry, dst_csymbolv(":value"));
 }
 
 /* Get module from the arguments passed to library */

src/include/dst/dstcorelib.h

@@ -112,6 +112,7 @@ int dst_lib_math(DstArgs args);
 int dst_lib_array(DstArgs args);
 int dst_lib_tuple(DstArgs args);
 int dst_lib_buffer(DstArgs args);
+int dst_lib_table(DstArgs args);
 
 /* Useful for compiler */
 Dst dst_op_add(Dst lhs, Dst rhs);

src/parser/ast.c

@@ -152,6 +152,7 @@ static Dst astunwrap_table(DstTable *other) {
     }
     if (!prescan) return dst_wrap_table(other);
     table = dst_table(other->capacity);
+    table->proto = other->proto;
     iter = NULL;
     while ((iter = dst_table_next(other, iter))) {
         if (iter == prescan) break;