Update boot.dst for better functionality (require, macros,

documentation, cond, let, etc.)

src/compiler/boot.dst

@@ -1,14 +1,82 @@
-(def defmacro macro
-  (fn [name & more] (tuple 'def name 'macro (tuple-prepend (tuple-prepend more name) 'fn))))
 
-(defmacro defn
+# Capture the current env
- [name & more] 
+(var *env*
- (tuple 'def name (tuple-prepend (tuple-prepend more name) 'fn)))
+ "A var that points to the current environment."
+ _env)
+
+(def defn macro
+ "Define a function"
+  (fn [name & more] 
+   (def fstart (fn recur [i]
+    (def ith (ast-unwrap1 (get more i)))
+    (def t (type ith))
+    (def tuple? (= t :tuple))
+    (def array? (= t :array))
+    (if (if tuple? tuple? array?) i (recur (+ i 1)))))
+   (def start (fstart 0))
+   (def fnbody (tuple-prepend (tuple-prepend (tuple-slice more start) name) 'fn))
+   (def formargs (array-concat ['def name] (array-slice more 0 start) [fnbody]))
+   (apply tuple formargs)))
+
+(def defmacro macro
+ "Define a macro."
+ (do
+  (def defn* (get (get _env 'defn) 'value))
+  (fn [name & more] 
+   (def args (array-concat [] name 'macro more))
+   (apply defn* args))))
 
 (defmacro when
+ "(when cond & body)
+ Evaluates the body when the condition is true. Otherwise returns nil."
  [cond & body] 
  (tuple 'if cond (tuple-prepend body 'do)))
 
+(defmacro cond
+ "(cond & body)
+ Evaluates conditions sequentially until the first true condition
+ is found, and then executes the corresponding body. If there are an
+ odd number of forms, the last expression is executed if no forms
+ are matched. If there are no matches, return nil."
+ [& pairs]
+  (defn aux [i]
+    (def restlen (- (length pairs) i))
+    (if (= restlen 0) nil
+     (if (= restlen 1) (get pairs i)
+      (tuple 'if (get pairs i)
+       (get pairs (+ i 1))
+       (aux (+ i 2))))))
+  (aux 0))
+
+(defn doc
+ "(doc sym)
+ Shows documentation for the given symbol."
+ [sym]
+ (def x (get *env* sym))
+ (if (not x)
+  (print "symbol " x " not found.")
+  (do
+   (def d (get x 'doc))
+   (print "\n" (if d d "no documentation found.") "\n"))))
+
+(defmacro select
+"(select dispatch & body)
+ Select the body that equals the dispatch value. When pairs
+ has an odd number of arguments, the last is the default expression.
+ If no match is found, returns nil"
+ [dispatch & pairs]
+  (def sym (gensym))
+  (defn aux [i]
+    (def restlen (- (length pairs) i))
+    (if (= restlen 0) nil
+     (if (= restlen 1) (get pairs i)
+      (tuple 'if (tuple = sym (get pairs i))
+       (get pairs (+ i 1))
+       (aux (+ i 2))))))
+  (tuple 'do
+   (tuple 'def sym dispatch)
+   (aux 0)))
+
 (defmacro or [x y] (tuple 'if x true y))
 (defmacro and [x y] (tuple 'if x y false))
 
@@ -53,44 +121,18 @@
   })
 
 (defn doseq [s] 
- (def s (seq s))
+ (def {:more more :next next} (seq s))
- (def more? (get s :more))
+ (while (more) (next)))
- (def getnext (get s :next))
- (while (more?)
-    (getnext)))
 
 (defn map [f s]
- (def s (seq s))
+ (def {:more more :next next} (seq s))
- (def more (get s :more))
+ {:more more :next (fn [] (f (next)))})
- (def getnext (get s :next))
- {
-  :more more
-  :next (fn [] (f (getnext)))
- })
 
 (defn reduce [f start s]
-  (def s (seq s))
+  (def {:more more :next next} (seq s))
-  (def more? (get s :more))
+  (if (more)
-  (def getnext (get s :next))
+   (reduce f (f start (next)) s)
-  (var ret start)
+   start))
-  (while (more?)
-    (varset! ret (f ret (getnext))))
-  ret)
-
-(defmacro for [head & body]
-  (def head (ast-unwrap1 head))
-  (def sym (get head 0))
-  (def start (get head 1))
-  (def end (get head 2))
-  (def _inc (get head 3))
-  (def inc (if _inc _inc 1))
-  (def endsym (gensym))
-  (tuple 'do
-    (tuple 'var sym start)
-    (tuple 'def endsym end)
-    (tuple 'while (tuple '< sym endsym)
-     (tuple-prepend body 'do)
-     (tuple 'varset! sym (tuple '+ sym inc)))))
 
 (defn even? [x] (== 0 (% x 2)))
 (defn odd? [x] (== 1 (% x 2)))
@@ -98,11 +140,13 @@
 (defmacro let [bindings & body]
   (def head (ast-unwrap1 bindings))
   (when (odd? (length head)) (error "expected even number of bindings to let"))
-  (var accum ['do])
+  (def len (length head))
-  (for [i 0 (length head) 2]
+  (var [i accum] [0 ['do]])
+  (while (< i len)
    (array-push accum (tuple 'def 
                      (get head i)
-                     (get head (+ 1 i)))))
+                     (get head (+ 1 i))))
+   (varset! i (+ i 2)))
   (array-push accum (tuple-prepend body 'do))
   (apply tuple accum))
 
@@ -136,106 +180,130 @@
         ret)
  })
 
+(defmacro for [head & body]
+  (def head (ast-unwrap1 head))
+  (def sym (get head 0))
+  (def start (get head 1))
+  (def end (get head 2))
+  (def _inc (get head 3))
+  (def inc (if _inc _inc 1))
+  (def endsym (gensym))
+  (tuple 'do
+    (tuple 'var sym start)
+    (tuple 'def endsym end)
+    (tuple 'while (tuple '< sym endsym)
+     (tuple-prepend body 'do)
+     (tuple 'varset! sym (tuple '+ sym inc)))))
+
 # Compile time
 
-(var *read* nil)
+(defn make-env [parent]
-(var *onvalue* identity)
+ (def parent (if parent parent _env))
-(var *env* (setproto @{} _env))
+ (def newenv (setproto @{} parent))
+ newenv)
+(put _env '_env nil)
 
-(def require-loading @{})
+(def run-context 
+ "(run-context env chunks onvalue onerr)
+ Run a context. This evaluates expressions of dst in an environment,
+ and is encapsulates the parsing, compilation, and evaluation of dst.
+ env is the environment to evaluate the code in, chunks is a function
+ that returns strings or buffers of source code (from a repl, file,
+ network connection, etc. onvalue and onerr are callbacks that are
+ invoked when a result is returned and when an error is produced,
+ respectively.
  
-(defn onerr [t e]
+ This function can be used to implemement a repl very easily, simply
- (print (string t " error: " e)))
+ pass a function that reads line from stdin to chunks, and print to
-
+ onvalue."
-(defn char-stream [getchunk]
+(do
- (fiber (fn []
+(defn val-stream [chunks onerr]
+ (var going true)
+ (def chars (fiber (fn []
    (def buf @"")
    (var len 1)
    (while (< 0 len)
       (buffer-clear buf)
-      (getchunk buf) 
+      (chunks buf) 
       (varset! len (length buf))
       (for [i 0 len]
         (yield (get buf i))))
    0)))
-
+ (var temp nil)
-(defn val-stream [chars ondone]
+ (var tempval nil)
- (fiber (fn []
+ (def f (fiber (fn []
     (def p (parser 1)) 
-    (var going true)
     (while going
-      (def s (parser-status p)) 
+      (select (parser-status p)
-      (if (= s :full)
+       :full (yield (parser-produce p))
-       (yield (parser-produce p))
+       :error (onerr "parse" (parser-error p))
-       (if (= s :error)
+       (select (fiber-status chars)
-        (onerr "parse" (parser-error p))
+        :new (parser-byte p (resume chars))
+        :pending (parser-byte p (resume chars))
+        (varset! going false)))))))
+ (defn more [] (if temp true 
   (do 
-         (def stat (fiber-status chars))
+   (varset! temp true)
-         (if (or (= :new stat) (= :pending stat))
+   (varset! tempval (resume f))
-          (parser-byte p (resume chars))
+   going)))
-          (varset! going false))))))
+ (defn next [] (if temp
-    (ondone))))
+  (do (varset! temp nil) tempval)
+  (resume f)))
+ {:more more :next next})
 
-(defn require [path]
+(fn [env chunks onvalue onerr]
- (when (get require-loading path)
+ (defn doone [source]
-  (error (string "circular dependency: module " path " is already loading")))
+  (def f (fiber (fn []
- (def oldread *read*)
+    (def res (compile source env))
- (def oldonvalue *onvalue*)
+    (if (= (type res) :function)
+      (res)
+      (onerr "compile" (get res :error))))))
+  (def res (resume f))
+  (if (= (fiber-status f) :error)
+   (onerr "runtime" res)
+   (onvalue res)))
  (def oldenv *env*)
- (def f (file-open path))
+ (varset! *env* env) 
- (defn getter [buf] (file-read f 1024 buf) buf)
+ (doseq (map doone (val-stream chunks onerr)))
- (defn resetter []
-    (put require-loading path nil)
-    (varset! *read* oldread)
-    (varset! *onvalue* oldonvalue)
  (varset! *env* oldenv)
-    (file-close f)
+ env)))
-    nil)
- (def cs (char-stream getter))
- (def vs (val-stream cs resetter))
- (varset! *onvalue* identity)
- (varset! *read* (fn [] (resume vs)))
- (varset! *env* (setproto @{} _env))
- *env*)
 
-(defn dorepl []
+(def require (do
- (def oldread *read*)
+ (def cache @{})
- (defn getter [buf]
+ (def loading @{})
+ (fn [path]
+   (when (get loading path)
+    (error (string "circular dependency: module " path " is loading")))
+   (def check (get cache path))
+   (if check check (do
+     (def newenv (make-env))
+     (put cache path newenv)
+     (put loading path true)
+     (def f (file-open path))
+     (defn chunks [buf] (file-read f 1024 buf))
+     (run-context newenv chunks identity
+      (fn [t x] (print (string t " error: " x))))
+     (file-close f)
+     (put loading path nil)
+     newenv)))))
+
+(defn import [path & args]
+ (def env (require path))
+ (def {
+  :prefix prefix
+  } (apply table args))
+ (defn one [pair]
+  (def [k v] pair)
+  (put *env* (symbol (if prefix prefix "") k) v))
+ (doseq (map one (pairs env))))
+
+(defn repl []
+ (def newenv (make-env))
+ (defn chunks [buf]
     (file-write stdout ">> ")
     (file-read stdin :line buf))
- (defn resetter []
+ (defn onvalue [x]
-    (varset! *read* oldread)
+  (put newenv '_ @{'value x})
-    nil)
+  (describe x))
- (def cs (char-stream getter))
+ (run-context newenv chunks onvalue
- (def vs (val-stream cs resetter))
+  (fn [t x] (print (string t " error: " x)))))
- (varset! *onvalue* (fn [ret]
-  (put *env* '_ @{'value ret})
-  (describe ret)))
- (varset! *read* (fn [] (resume vs))))
-
-(defn dostring [str]
- (def oldread *read*)
- (defn getter [buf]
-    (buffer-push-string buf str)
-    (buffer-push-string buf "\n"))
- (defn resetter []
-    (varset! *read* oldread)
-    nil)
- (def cs (char-stream getter))
- (def vs (val-stream cs resetter))
- (varset! *onvalue* identity)
- (varset! *read* (fn [] (resume vs))))
-
-(defn init-loop []
- (while *read*
-  (def wrapper (fiber (fn []
-    (while *read*
-      (def source (*read*))
-      (def res (compile source *env*))
-      (if (= (type res) :function)
-        (*onvalue* (res))
-        (onerr "compile" (get res :error)))))))
-  (def eb (resume wrapper))
-  (if (= (fiber-status wrapper) :error) (onerr "runtime" eb wrapper))))
-
-(defn init-repl [] (dorepl) (init-loop))

src/core/array.c

@@ -184,6 +184,31 @@ static int cfun_slice(DstArgs args) {
     return dst_return(args, dst_wrap_array(ret));
 }
 
+static int cfun_concat(DstArgs args) {
+    int32_t i;
+    DstArray *array;
+    if (args.n < 1 || !dst_checktype(args.v[0], DST_ARRAY)) return dst_throw(args, "expected array");
+    array = dst_unwrap_array(args.v[0]);
+    for (i = 1; i < args.n; i++) {
+        switch (dst_type(args.v[i])) {
+            default:
+                dst_array_push(array, args.v[i]);
+                break;
+            case DST_ARRAY:
+            case DST_TUPLE:
+                {
+                    int32_t j, len;       
+                    const Dst *vals;
+                    dst_seq_view(args.v[i], &vals, &len);
+                    for (j = 0; j < len; j++)
+                        dst_array_push(array, vals[j]);
+                }
+                break;
+        }
+    }
+    return dst_return(args, args.v[0]);
+}
+
 /* Load the array module */
 int dst_lib_array(DstArgs args) {
     DstTable *env = dst_env_arg(args);
@@ -193,5 +218,6 @@ int dst_lib_array(DstArgs args) {
     dst_env_def(env, "array-setcount", dst_wrap_cfunction(cfun_setcount));
     dst_env_def(env, "array-ensure", dst_wrap_cfunction(cfun_ensure));
     dst_env_def(env, "array-slice", dst_wrap_cfunction(cfun_slice));
+    dst_env_def(env, "array-concat", dst_wrap_cfunction(cfun_concat));
     return 0;
 }

src/mainclient/init.dst

@@ -1,7 +1,7 @@
 (do
 
-(var dorepl false)
+(var should-repl false)
-(var nofile true)
+(var no-file true)
 
 # Flag handlers
 (def handlers {
@@ -13,7 +13,7 @@
         (print "  -r Enter the repl after running all scripts")
         (exit 0))
   "v" (fn [] (print VERSION) (exit 0))
-  "r" (fn [] (varset! dorepl true))
+  "r" (fn [] (varset! should-repl true))
 })
 
 (defn dohandler [n]
@@ -27,11 +27,11 @@
  (if (= "-" (string-slice arg 0 1))
   (dohandler (string-slice arg 1 2))
   (do
-   (varset! nofile false)
+   (varset! no-file false)
-   (require arg)
+   (require arg))))
-   (init-loop))))
 
-(when (or dorepl nofile) 
+(when (or should-repl no-file) 
  (print (string "Dst " VERSION "  Copyright (C) 2017-2018 Calvin Rose"))
- (init-repl))
+ (repl))
+
 )