mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2025-04-05 06:46:56 +00:00
Code Issues 1 Releases Wiki Activity

Merge branch 'master' of github.com:bakpakin/dst

Browse Source
This commit is contained in:
Calvin Rose 2018-03-25 21:12:43 -04:00
commit 6ace978ab8
6 changed files with 128 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
examples/lazyseqs.dst
View File

@ -136,8 +136,7 @@ body once, and then memoizes the result."
# data structures as their values are references to this
# data structures. Same is true for iterators
(defn filter2 [pred coll]
(tail (iter2lazy (filter pred coll))))
(defn filter2 [pred coll] (iter2lazy (filter pred coll)))
# be careful with the filter function. First element in (filter pos? arr) is nil
# last element is false

42
examples/maxtriangle.dst Normal file
View File

@ -0,0 +1,42 @@
# Find the maximum path from the top (root)
# of the triangle to the leaves of the triangle.
(defn vmap2 [f m1 m2]
(def len (length m1))
(def arr @[])
(for [i 0 len] (array-push arr (f (get m1 i) (get m2 i))))
arr)
(defn reduce [s f c]
(var res s)
(for [i 0 (length c)]
(:= res (f res (get c i))))
res)
(defn max1 [l r] (if (< l r) r l))
(defn myfold [xs ys]
(def xs1 (tuple-prepend xs 0))
(def xs2 (tuple-append xs 0))
(def m1 (vmap2 + xs1 ys))
(def m2 (vmap2 + xs2 ys))
(vmap2 max1 m1 m2))
(defn max [a]
(var m (get a 0))
(for [i 0 (length a)]
(if (< m (get a i))
(:= m (get a i))))
m)
(defn maxpath [t]
(max (reduce () myfold t)))
(def triangle @[
@[3]
@[7 10]
@[4 3 7]
@[8 9 1 3]
])
(print (maxpath triangle))

22
examples/utils.dst Normal file
View File

@ -0,0 +1,22 @@
(defn put-in [coll keys val]
(defn assoc [the-coll n]
(if-let [current-key (get keys n)
current-val (get the-coll current-key)]
(put the-coll current-key (assoc current-val (inc n)))
val))
(assoc coll 0))
(defn update-in [coll keys an-fn]
(def new-keys (array-slice coll 0 -2) )
(def last-key (get (array-slice coll -1 -2) 0))
(defn assoc [the-coll n]
(if-let [current-key (get keys n)
current-val (get the-coll current-key)]
(put the-coll current-key (assoc current-val (inc n)))
( update the-coll last-key an-fn )))
(assoc coll new-keys 0))
;; (defn update-in-test [ ] (update-in @{:a "x" :b {:y {"pipa" 3}}} [:b :y "pipa"] type))

78
src/compiler/boot.dst
View File

@ -1,13 +1,13 @@
# Bootstrap the dst environment
# Copyright 2018 (C) Calvin Rose
(var *env*
(var *env*
"The current environment."
_env)
(def defn :macro
"Define a function"
(fn [name & more]
(fn [name & more]
(def fstart (fn recur [i]
(def ith (ast-unwrap1 (get more i)))
(def t (type ith))
@ -24,8 +24,8 @@
(do
(def defn* (get (get _env 'defn) :value))
(fn [name & more]
(def args (array-concat @[] name :macro more))
(apply1 defn* args))))
(apply1 defn* (array-concat
@[name :macro] more)))))
(defmacro defmacro-
"Define a private macro that will not be exported."
@ -86,7 +86,7 @@
(defmacro when
"Evaluates the body when the condition is true. Otherwise returns nil."
[cond & body]
[cond & body]
(tuple 'if cond (tuple-prepend body 'do)))
(defmacro cond
@ -140,21 +140,21 @@ If no match is found, returns nil"
(tuple 'def sym dispatch)
(aux 0)))
(defmacro and [& forms]
(defmacro and [& forms]
(def len (length forms))
(if (= len 0) true ((fn aux [i]
(cond
(>= (inc i) len) (get forms i)
(tuple 'if (get forms i) (aux (inc i)) false))) 0)))
(defmacro or [& forms]
(defmacro or [& forms]
(def len (length forms))
(if (= len 0) false ((fn aux [i]
(cond
(>= (inc i) len) (get forms i)
(tuple 'if (get forms i) true (aux (inc i))))) 0)))
(defn identity
(defn identity
"A function that returns its first argument."
[x] x)
@ -167,7 +167,7 @@ If no match is found, returns nil"
:next (fn []
(def ret (get x i))
(:= i (+ i 1))
ret)
ret)
})
(def iters {
:array array-iter
@ -184,20 +184,20 @@ If no match is found, returns nil"
:next (fn []
(def ret i)
(:= i (+ i 1))
ret)
ret)
})
(defn range [top] (range2 0 top))
(defn doiter [itr]
(defn doiter [itr]
(def {:more more :next next} (iter itr))
(while (more) (next)))
(defn foreach [itr f]
(defn foreach [itr f]
(def {:more more :next next} (iter itr))
(while (more) (f (next))))
(defn iter2array [itr]
(defn iter2array [itr]
(def {:more more :next next} (iter itr))
(def a @[])
(while (more) (array-push a (next)))
@ -238,7 +238,7 @@ If no match is found, returns nil"
(var i 0)
(var accum @['do])
(while (< i len)
(array-push accum (tuple 'def
(array-push accum (tuple 'def
(get head i)
(get head (+ 1 i))))
(:= i (+ i 2)))
@ -368,26 +368,30 @@ If no match is found, returns nil"
(tuple 'when (tuple not condition) exp-1))
(defmacro if-let
"Takes the first one or two forms in a vector and if true binds
"Takes the first one or two forms in a vector and if both are true binds
all the forms with let and evaluates the first expression else
evaluates the second"
[bindings then else]
(def head (ast-unwrap1 bindings))
(tuple 'let head
(tuple 'if (and (get head 1) (if (get head 2) (get head 3) true))
(tuple 'let bindings
(tuple 'if (tuple 'and (tuple 'get bindings 1)
(tuple 'if
(tuple '> (tuple 'length bindings) 2)
(tuple 'get bindings 3) 'true))
then
else)))
(defmacro when-let
"Takes the first one or two forms in vector and if true binds
all the forms with let and evaluates body"
all the forms with let and evaluates the body"
[bindings & body]
(def head (ast-unwrap1 bindings))
(tuple 'let head
(tuple 'let bindings
(tuple
'when
(and (get head 1) (if (get head 2) (get head 3) true))
(apply1 tuple (array-concat @['do] (ast-unwrap1 body))))))
(tuple 'and (tuple 'get bindings 1)
(tuple 'if
(tuple '> (tuple 'length bindings) 2)
(tuple 'get bindings 3) 'true))
(apply1 tuple (array-concat @['do] body)))))
(defn comp
"Takes multiple functions and returns a function that is the composition
@ -404,21 +408,21 @@ If no match is found, returns nil"
(tuple-slice functions 5 -1)))))
(defn zipcoll
"Creates an table or tuple from two arrays/tuples. Result is table if no
third argument is given"
"Creates an table or tuple from two arrays/tuples. If a third argument of
:struct is givent resault is struct else is table."
[coll-1 coll-2 the-type]
(var zipping-table @{})
(def {:more more1 :next next1} (iter coll-1))
(def {:more more2 :next next2} (iter coll-2))
(while (and (more1) (more2))
(put zipping-table (next1) (next2)))
(if (= :struct the-type)
(if (struct? the-type)
(table-to-struct zipping-table)
zipping-table))
(defn update
"Accepts a key argument and passes its associated value to a function.
The key, then is associated to that value"
"Accepts a key argument and passes its' associated value to a function.
The key then, is associated to the function's return value"
[coll a-key a-function & args]
(def old-value (get coll a-key))
(put coll a-key (apply a-function old-value args)))
@ -477,8 +481,8 @@ third argument is given"
:struct (fn [pp seen buf x] (pp-dict pp seen buf x "{" "}"))
})
(defn- default_printer [pp seen buf x]
(buffer-push-string buf (describe x))
(defn- default_printer [pp seen buf x]
(buffer-push-string buf (describe x))
buf)
(defn- pp1 [seen buf x]
@ -498,7 +502,7 @@ third argument is given"
"Expand macros in a form, but do not recursively expand macros."
[x]
(defn doarray [a]
(defn doarray [a]
(def len (length a))
(def newa @[])
(for [i 0 len]
@ -536,7 +540,7 @@ third argument is given"
'quote identity
'var expandlast
'while expandall
})
})
(defn dotup [t]
(def h (get t 0))
@ -589,7 +593,7 @@ third argument is given"
(put newenv '_env @{:value newenv :private true})
newenv)
(def run-context
(def run-context
"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
@ -597,7 +601,7 @@ 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."
@ -610,7 +614,7 @@ onvalue."
(var len 1)
(while (< 0 len)
(buffer-clear buf)
(chunks buf)
(chunks buf)
(:= len (length buf))
(for [i 0 len]
(yield (get buf i))))
@ -678,7 +682,7 @@ onvalue."
} (get st i))
(file-write stdout " in")
(when c (file-write stdout " cfunction"))
(when name (file-write stdout (string " " name)))
(when name (file-write stdout (string " " name)))
(when func (file-write stdout (string " " func)))
(when pc (file-write stdout (string " (pc=" pc ")")))
(when tail (file-write stdout " (tailcall)"))
@ -712,7 +716,7 @@ onvalue."
(put env (symbol (if prefix prefix "") k) v)))))
(defmacro import [path & args]
(apply tuple import* '_env path args))
(apply tuple import* '_env path args))
(defn repl [getchunk]
(def newenv (make-env))

26
src/compiler/specials.c
View File

@ -45,7 +45,7 @@ DstSlot dstc_astquote(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv)
}
static void destructure(DstCompiler *c, Dst left, DstSlot right,
void (*leaf)(DstCompiler *c,
void (*leaf)(DstCompiler *c,
DstAst *ast,
const uint8_t *sym,
DstSlot s,
@ -72,7 +72,7 @@ static void destructure(DstCompiler *c, Dst left, DstSlot right,
localright = dstc_preread(c, ast, 0xFF, 1, right);
localsub = dstc_lslotn(c, 0xFF, 3);
if (i < 0x100) {
dstc_emit(c, ast,
dstc_emit(c, ast,
(i << 24) |
(localright << 16) |
(localsub << 8) |
@ -80,7 +80,7 @@ static void destructure(DstCompiler *c, Dst left, DstSlot right,
} else {
DstSlot islot = dstc_cslot(dst_wrap_integer(i));
int32_t locali = dstc_preread(c, ast, 0xFF, 2, islot);
dstc_emit(c, ast,
dstc_emit(c, ast,
(locali << 24) |
(localright << 16) |
(localsub << 8) |
@ -111,7 +111,7 @@ static void destructure(DstCompiler *c, Dst left, DstSlot right,
localright = dstc_preread(c, ast, 0xFF, 1, right);
localsub = dstc_lslotn(c, 0xFF, 3);
int32_t localk = dstc_preread(c, ast, 0xFF, 2, kslot);
dstc_emit(c, ast,
dstc_emit(c, ast,
(localk << 24) |
(localright << 16) |
(localsub << 8) |
@ -211,7 +211,7 @@ static DstSlot namelocal(DstCompiler *c, DstAst *ast, Dst head, int32_t flags, D
ret = localslot;
}
ret.flags |= flags;
dstc_nameslot(c, dst_unwrap_symbol(head), ret);
dstc_nameslot(c, dst_unwrap_symbol(head), ret);
return ret;
}
@ -276,7 +276,7 @@ static void defleaf(
tableindex = dstc_preread(c, ast, 0xFF, 1, tabslot);
valsymindex = dstc_preread(c, ast, 0xFF, 2, valsym);
valueindex = dstc_preread(c, ast, 0xFF, 3, s);
dstc_emit(c, ast,
dstc_emit(c, ast,
(valueindex << 24) |
(valsymindex << 16) |
(tableindex << 8) |
@ -352,7 +352,7 @@ DstSlot dstc_if(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
}
/* Set target for compilation */
target = (drop || tail)
target = (drop || tail)
? dstc_cslot(dst_wrap_nil())
: dstc_gettarget(opts);
@ -366,7 +366,7 @@ DstSlot dstc_if(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
/* Condition left body */
dstc_scope(c, 0);
left = dstc_value(bodyopts, truebody);
if (!drop && !tail) dstc_copy(c, ast, target, left);
if (!drop && !tail) dstc_copy(c, ast, target, left);
dstc_popscope(c);
/* Compile jump to done */
@ -377,7 +377,7 @@ DstSlot dstc_if(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
labelr = dst_v_count(c->buffer);
dstc_scope(c, 0);
right = dstc_value(bodyopts, falsebody);
if (!drop && !tail) dstc_copy(c, ast, target, right);
if (!drop && !tail) dstc_copy(c, ast, target, right);
dstc_popscope(c);
/* Write jumps - only add jump lengths if jump actually emitted */
@ -584,7 +584,7 @@ DstSlot dstc_fn(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
dstc_freeslot(c, s);
if (dstc_iserr(&opts)) return dstc_cslot(dst_wrap_nil());
}
/* Build function */
def = dstc_pop_funcdef(c);
def->arity = arity;
@ -603,9 +603,9 @@ DstSlot dstc_fn(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
(defindex << 16) |
(localslot << 8) |
DOP_CLOSURE);
if (ret.index != localslot) {
dstc_emit(c, ast,
dstc_emit(c, ast,
(ret.index << 16) |
(localslot << 8) |
DOP_MOVE_FAR);
@ -614,7 +614,7 @@ DstSlot dstc_fn(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) {
return ret;
}
/* Keep in lexographic order */
/* Keep in lexicographic order */
static const DstSpecial dstc_specials[] = {
{":=", dstc_varset},
{"ast-quote", dstc_astquote},

18
src/core/tuple.c
View File

@ -127,25 +127,25 @@ static int cfun_slice(DstArgs args) {
static int cfun_prepend(DstArgs args) {
const Dst *t;
int32_t len;
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));
if (!dst_seq_view(args.v[0], &t, &len)) return dst_throw(args, "expected tuple/array");
n = dst_tuple_begin(len + 1);
memcpy(n + 1, t, sizeof(Dst) * len);
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;
int32_t len;
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];
if (!dst_seq_view(args.v[0], &t, &len)) return dst_throw(args, "expected tuple/array");
n = dst_tuple_begin(len + 1);
memcpy(n, t, sizeof(Dst) * len);
n[len] = args.v[1];
return dst_return(args, dst_wrap_tuple(dst_tuple_end(n)));
}