diff --git a/src/compiler/boot.dst b/src/compiler/boot.dst index db0cbdb5..12a7704d 100644 --- a/src/compiler/boot.dst +++ b/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 - [name & more] - (tuple 'def name (tuple-prepend (tuple-prepend more name) 'fn))) +# Capture the current env +(var *env* + "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? (get s :more)) - (def getnext (get s :next)) - (while (more?) - (getnext))) + (def {:more more :next next} (seq s)) + (while (more) (next))) (defn map [f s] - (def s (seq s)) - (def more (get s :more)) - (def getnext (get s :next)) - { - :more more - :next (fn [] (f (getnext))) - }) + (def {:more more :next next} (seq s)) + {:more more :next (fn [] (f (next)))}) (defn reduce [f start s] - (def s (seq s)) - (def more? (get s :more)) - (def getnext (get s :next)) - (var ret 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))))) + (def {:more more :next next} (seq s)) + (if (more) + (reduce f (f start (next)) s) + start)) (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]) - (for [i 0 (length head) 2] + (def len (length head)) + (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) -(var *onvalue* identity) -(var *env* (setproto @{} _env)) +(defn make-env [parent] + (def parent (if parent parent _env)) + (def newenv (setproto @{} parent)) + newenv) +(put _env '_env nil) -(def require-loading @{}) - -(defn onerr [t e] - (print (string t " error: " e))) - -(defn char-stream [getchunk] - (fiber (fn [] +(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. + + This function can be used to implemement a repl very easily, simply + pass a function that reads line from stdin to chunks, and print to + onvalue." +(do +(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))) - -(defn val-stream [chars ondone] - (fiber (fn [] + (var temp nil) + (var tempval nil) + (def f (fiber (fn [] (def p (parser 1)) - (var going true) (while going - (def s (parser-status p)) - (if (= s :full) - (yield (parser-produce p)) - (if (= s :error) - (onerr "parse" (parser-error p)) - (do - (def stat (fiber-status chars)) - (if (or (= :new stat) (= :pending stat)) - (parser-byte p (resume chars)) - (varset! going false)))))) - (ondone)))) + (select (parser-status p) + :full (yield (parser-produce p)) + :error (onerr "parse" (parser-error p)) + (select (fiber-status chars) + :new (parser-byte p (resume chars)) + :pending (parser-byte p (resume chars)) + (varset! going false))))))) + (defn more [] (if temp true + (do + (varset! temp true) + (varset! tempval (resume f)) + going))) + (defn next [] (if temp + (do (varset! temp nil) tempval) + (resume f))) + {:more more :next next}) -(defn require [path] - (when (get require-loading path) - (error (string "circular dependency: module " path " is already loading"))) - (def oldread *read*) - (def oldonvalue *onvalue*) +(fn [env chunks onvalue onerr] + (defn doone [source] + (def f (fiber (fn [] + (def res (compile source env)) + (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)) - (defn getter [buf] (file-read f 1024 buf) buf) - (defn resetter [] - (put require-loading path nil) - (varset! *read* oldread) - (varset! *onvalue* oldonvalue) - (varset! *env* oldenv) - (file-close f) - 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*) + (varset! *env* env) + (doseq (map doone (val-stream chunks onerr))) + (varset! *env* oldenv) + env))) -(defn dorepl [] - (def oldread *read*) - (defn getter [buf] +(def require (do + (def cache @{}) + (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 [] - (varset! *read* oldread) - nil) - (def cs (char-stream getter)) - (def vs (val-stream cs resetter)) - (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)) + (defn onvalue [x] + (put newenv '_ @{'value x}) + (describe x)) + (run-context newenv chunks onvalue + (fn [t x] (print (string t " error: " x))))) diff --git a/src/core/array.c b/src/core/array.c index 6fda5fc7..29d69baf 100644 --- a/src/core/array.c +++ b/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; } diff --git a/src/mainclient/init.dst b/src/mainclient/init.dst index a114c8e9..a6050ebf 100644 --- a/src/mainclient/init.dst +++ b/src/mainclient/init.dst @@ -1,7 +1,7 @@ (do -(var dorepl false) -(var nofile true) +(var should-repl false) +(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) - (require arg) - (init-loop)))) + (varset! no-file false) + (require arg)))) -(when (or dorepl nofile) +(when (or should-repl no-file) (print (string "Dst " VERSION " Copyright (C) 2017-2018 Calvin Rose")) - (init-repl)) + (repl)) + )