mirror of
https://github.com/janet-lang/janet
synced 2024-12-25 16:00:27 +00:00
Update boot.dst for better functionality (require, macros,
documentation, cond, let, etc.)
This commit is contained in:
Calvin Rose
parent
1ba93c5112
commit
3b2658150e
@ -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)))))
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
@ -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))
|
||||
|
||||
)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user