mirror of
https://github.com/janet-lang/janet
synced 2024-11-24 17:27:18 +00:00
Multisyms for easier access into structures.
This commit is contained in:
Calvin Rose
parent
6e74617c05
commit
b0c45fd15e
@ -1,21 +1,21 @@
|
||||
# A game of life implementation
|
||||
|
||||
(def- window
|
||||
(fora [x :range [-1 2]
|
||||
(seq [x :range [-1 2]
|
||||
y :range [-1 2]
|
||||
:when (not (and (zero? x) (zero? y)))]
|
||||
(tuple x y)))
|
||||
|
||||
(defn- neighbors
|
||||
[[x y]]
|
||||
(mapa (fn [[x1 y1]] (tuple (+ x x1) (+ y y1))) window))
|
||||
(map (fn [[x1 y1]] (tuple (+ x x1) (+ y y1))) window))
|
||||
|
||||
(defn tick
|
||||
"Get the next state in the Game Of Life."
|
||||
[state]
|
||||
(def cell-set (frequencies state))
|
||||
(def neighbor-set (frequencies (mapcat neighbors state)))
|
||||
(fora [coord :keys neighbor-set
|
||||
(seq [coord :keys neighbor-set
|
||||
:let [count (get neighbor-set coord)]
|
||||
:when (or (= count 3) (and (get cell-set coord) (= count 2)))]
|
||||
coord))
|
||||
@ -24,7 +24,7 @@
|
||||
"Draw cells in the game of life from (x1, y1) to (x2, y2)"
|
||||
[state x1 y1 x2 y2]
|
||||
(def cellset @{})
|
||||
(loop [cell :in state] (put cellset cell true))
|
||||
(each cell state (put cellset cell true))
|
||||
(loop [x :range [x1 (+ 1 x2)]
|
||||
:after (print)
|
||||
y :range [y1 (+ 1 y2)]]
|
||||
@ -37,7 +37,7 @@
|
||||
|
||||
(var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)])
|
||||
|
||||
(loop [i :range [0 20]]
|
||||
(for i 0 20
|
||||
(print "generation " i)
|
||||
(draw *state* -7 -7 7 7)
|
||||
(:= *state* (tick *state*)))
|
||||
|
||||
@ -1,73 +0,0 @@
|
||||
# Simpler iteration primitives example.
|
||||
|
||||
(defn- iter-for
|
||||
[prelude binding start end body]
|
||||
(def $end (gensym))
|
||||
(tuple 'do
|
||||
prelude
|
||||
(tuple 'var binding start)
|
||||
(tuple 'def $end end)
|
||||
(tuple 'while (tuple < binding $end)
|
||||
body
|
||||
(tuple '++ binding))))
|
||||
|
||||
(defn- iter-keys
|
||||
[prelude binding tab body]
|
||||
(tuple 'do
|
||||
prelude
|
||||
(tuple 'var binding (tuple next tab nil))
|
||||
(tuple 'while (tuple not= nil binding)
|
||||
body
|
||||
(tuple := binding (tuple next tab binding)))))
|
||||
|
||||
(defmacro do-range
|
||||
"Iterate over a half open integer range."
|
||||
[binding start end & body]
|
||||
(def $iter (gensym))
|
||||
(iter-for nil $iter start end
|
||||
(apply tuple 'do (tuple 'def binding $iter) body)))
|
||||
|
||||
(defmacro each
|
||||
"Iterate over an indexed data structure."
|
||||
[binding ind & body]
|
||||
(def $iter (gensym))
|
||||
(def $ind (gensym))
|
||||
(iter-for (tuple 'def $ind ind)
|
||||
$iter 0 (tuple length $ind)
|
||||
(apply tuple 'do (tuple 'def binding (tuple get $ind $iter)) body)))
|
||||
|
||||
|
||||
(defmacro each-key
|
||||
"Iterate over keys of a table or structure."
|
||||
[binding tab & body]
|
||||
(def $tab (gensym))
|
||||
(def $key (gensym))
|
||||
(iter-keys
|
||||
(tuple 'def $tab tab)
|
||||
$key
|
||||
$tab
|
||||
(apply tuple 'do (tuple 'def binding $key) body)))
|
||||
|
||||
(defmacro each-value
|
||||
"Iterate over values of a table or structure."
|
||||
[binding tab & body]
|
||||
(def $tab (gensym))
|
||||
(def $key (gensym))
|
||||
(iter-keys
|
||||
(tuple 'def $tab tab)
|
||||
$key
|
||||
$tab
|
||||
(apply tuple 'do (tuple 'def binding (tuple 'get $tab $key)) body)))
|
||||
|
||||
(defmacro each-pair
|
||||
"Iterate over keys and values of a table or structure."
|
||||
[k v tab & body]
|
||||
(def $tab (gensym))
|
||||
(def $key (gensym))
|
||||
(iter-keys
|
||||
(tuple 'def $tab tab)
|
||||
$key
|
||||
$tab
|
||||
(apply tuple 'do
|
||||
(tuple 'def k $key)
|
||||
(tuple 'def v (tuple 'get $tab $key)) body)))
|
||||
@ -4,10 +4,10 @@
|
||||
"Returns a list of prime numbers less than n."
|
||||
[n]
|
||||
(def list @[])
|
||||
(loop [i :range [2 n]]
|
||||
(for i 2 n
|
||||
(var isprime? true)
|
||||
(def len (length list))
|
||||
(loop [j :range [0 len]]
|
||||
(for j 0 len
|
||||
(def trial (get list j))
|
||||
(if (zero? (% i trial)) (:= isprime? false)))
|
||||
(if isprime? (array.push list i)))
|
||||
|
||||
@ -421,14 +421,6 @@ static JanetSlot janetc_bufferctor(JanetFopts opts, Janet x) {
|
||||
JOP_MAKE_BUFFER);
|
||||
}
|
||||
|
||||
static JanetSlot janetc_symbol(JanetFopts opts, const uint8_t *sym) {
|
||||
if (janet_string_length(sym) && sym[0] != ':') {
|
||||
return janetc_resolve(opts.compiler, sym);
|
||||
} else {
|
||||
return janetc_cslot(janet_wrap_symbol(sym));
|
||||
}
|
||||
}
|
||||
|
||||
/* Expand a macro one time. Also get the special form compiler if we
|
||||
* find that instead. */
|
||||
static int macroexpand1(
|
||||
@ -532,7 +524,7 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) {
|
||||
}
|
||||
break;
|
||||
case JANET_SYMBOL:
|
||||
ret = janetc_symbol(opts, janet_unwrap_symbol(x));
|
||||
ret = janetc_sym_rvalue(opts, janet_unwrap_symbol(x));
|
||||
break;
|
||||
case JANET_ARRAY:
|
||||
ret = janetc_array(opts, x);
|
||||
|
||||
@ -237,4 +237,10 @@ JanetSlot janetc_cslot(Janet x);
|
||||
/* Search for a symbol */
|
||||
JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym);
|
||||
|
||||
/* Compile a symbol (or mutltisym) when used as an rvalue. */
|
||||
JanetSlot janetc_sym_rvalue(JanetFopts opts, const uint8_t *sym);
|
||||
|
||||
/* Compile an assignment to a symbol (or multisym) */
|
||||
JanetSlot janetc_sym_lvalue(JanetFopts opts, const uint8_t *sym, Janet value);
|
||||
|
||||
#endif
|
||||
|
||||
@ -120,6 +120,7 @@
|
||||
(defn true? "Check if x is true." [x] (= x true))
|
||||
(defn false? "Check if x is false." [x] (= x false))
|
||||
(defn nil? "Check if x is nil." [x] (= x nil))
|
||||
(defn empty? "Check if xs is empty." [xs] (= 0 (length xs)))
|
||||
(def atomic?
|
||||
"(atomic? x)\n\nCheck if x is a value that evaluates to itself when compiled."
|
||||
(do
|
||||
@ -257,10 +258,10 @@
|
||||
|
||||
(defmacro loop
|
||||
"A general purpose loop macro. This macro is similar to the Common Lisp
|
||||
loop macro, although intentonally much smaller in scope.
|
||||
The head of the loop shoud be a tuple that contains a sequence of
|
||||
loop macro, although intentionally much smaller in scope.
|
||||
The head of the loop should be a tuple that contains a sequence of
|
||||
either bindings or conditionals. A binding is a sequence of three values
|
||||
that define someting to loop over. They are formatted like:\n\n
|
||||
that define something to loop over. They are formatted like:\n\n
|
||||
\tbinding :verb object/expression\n\n
|
||||
Where binding is a binding as passed to def, :verb is one of a set of keywords,
|
||||
and object is any janet expression. The available verbs are:\n\n
|
||||
@ -388,7 +389,7 @@
|
||||
(error (string "unexpected loop verb: " verb)))))))
|
||||
(tuple 'do (doone 0 nil) nil))
|
||||
|
||||
(defmacro fora
|
||||
(defmacro seq
|
||||
"Similar to loop, but accumulates the loop body into an array and returns that.
|
||||
See loop for details."
|
||||
[head & body]
|
||||
@ -400,18 +401,6 @@
|
||||
(tuple.prepend body 'do)))
|
||||
$accum))
|
||||
|
||||
(defmacro for
|
||||
"Similar to loop, but accumulates the loop body into a tuple and returns that.
|
||||
See loop for details."
|
||||
[head & body]
|
||||
(def $accum (gensym))
|
||||
(tuple 'do
|
||||
(tuple 'def $accum @[])
|
||||
(tuple 'loop head
|
||||
(tuple array.push $accum
|
||||
(tuple.prepend body 'do)))
|
||||
(tuple tuple.slice $accum 0)))
|
||||
|
||||
(defmacro generate
|
||||
"Create a generator expression using the loop syntax. Returns a fiber
|
||||
that yields all values inside the loop in order. See loop for details."
|
||||
@ -421,6 +410,16 @@
|
||||
(tuple 'fn '[&]
|
||||
(tuple 'loop head (tuple yield (tuple.prepend body 'do))))))
|
||||
|
||||
(defmacro for
|
||||
"Do a c style for loop for side effects. Returns nil."
|
||||
[binding start end & body]
|
||||
(apply loop [tuple binding :range [tuple start end]] body))
|
||||
|
||||
(defmacro each
|
||||
"Loop over each value in ind. Returns nil."
|
||||
[binding ind & body]
|
||||
(apply loop [tuple binding :in ind] body))
|
||||
|
||||
(defn sum [xs]
|
||||
(var accum 0)
|
||||
(loop [x :in xs] (+= accum x))
|
||||
@ -498,7 +497,8 @@
|
||||
(fn [x] (not (f x))))
|
||||
|
||||
(defn extreme
|
||||
"Returns the most extreme value in args based on the orderer order.
|
||||
"Returns the most extreme value in args based on the function order.
|
||||
order should take two values and return true or false (a comparison).
|
||||
Returns nil if args is empty."
|
||||
[order args]
|
||||
(def len (length args))
|
||||
@ -514,6 +514,16 @@
|
||||
(defn max-order [& args] (extreme order> args))
|
||||
(defn min-order [& args] (extreme order< args))
|
||||
|
||||
(defn first
|
||||
"Get the first element from an indexed data structure."
|
||||
[xs]
|
||||
(get xs 0))
|
||||
|
||||
(defn last
|
||||
"Get the last element from an indexed data structure."
|
||||
[xs]
|
||||
(get xs (- (length xs) 1)))
|
||||
|
||||
###
|
||||
###
|
||||
### Indexed Combinators
|
||||
@ -551,23 +561,20 @@
|
||||
(sort-help a 0 (- (length a) 1) (or by order<)))))
|
||||
|
||||
(defn sorted
|
||||
"Returns the sorted version of an indexed data structure."
|
||||
[ind by t &]
|
||||
(def sa (sort (array.slice ind 0) by))
|
||||
(if (= :tuple (or t (type ind)))
|
||||
(tuple.slice sa 0)
|
||||
sa))
|
||||
"Returns a new sorted array without modifying the old one."
|
||||
[ind by]
|
||||
(sort (array.slice ind) by))
|
||||
|
||||
(defn reduce
|
||||
"Reduce, also know as fold-left in many languages, transforms
|
||||
an indexed type (array, tuple) with a function to produce a value."
|
||||
[f init ind &]
|
||||
[f init ind]
|
||||
(var res init)
|
||||
(loop [x :in ind]
|
||||
(:= res (f res x)))
|
||||
res)
|
||||
|
||||
(defn mapa
|
||||
(defn map
|
||||
"Map a function over every element in an indexed data structure and
|
||||
return an array of the results."
|
||||
[f & inds]
|
||||
@ -590,39 +597,29 @@
|
||||
(put res i (apply f args))))
|
||||
res)
|
||||
|
||||
(defn map
|
||||
"Map a function over every element in an indexed data structure and
|
||||
return a tuple of the results."
|
||||
[f & inds]
|
||||
(tuple.slice (apply mapa f inds) 0))
|
||||
|
||||
(defn mapcat
|
||||
"Map a function over every element in an array or tuple and
|
||||
use array to concatenate the results. Returns the type given
|
||||
as the third argument, or same type as the input indexed structure."
|
||||
[f ind t &]
|
||||
use array to concatenate the results."
|
||||
[f ind]
|
||||
(def res @[])
|
||||
(loop [x :in ind]
|
||||
(array.concat res (f x)))
|
||||
(if (= :tuple (or t (type ind)))
|
||||
(tuple.slice res 0)
|
||||
res))
|
||||
res)
|
||||
|
||||
(defn filter
|
||||
"Given a predicate, take only elements from an array or tuple for
|
||||
which (pred element) is truthy. Returns the type given as the
|
||||
third argument, or the same type as the input indexed structure."
|
||||
which (pred element) is truthy. Returns a new array."
|
||||
[pred ind t &]
|
||||
(def res @[])
|
||||
(loop [item :in ind]
|
||||
(if (pred item)
|
||||
(array.push res item)))
|
||||
(if (= :tuple (or t (type ind)))
|
||||
(tuple.slice res 0)
|
||||
res))
|
||||
res)
|
||||
|
||||
(defn range
|
||||
"Create an array of values [0, n)."
|
||||
"Create an array of values [start, end) with a given step.
|
||||
With one argument returns a range [0, end). With two arguments, returns
|
||||
a range [start, end). With three, returns a range with optional step size."
|
||||
[& args]
|
||||
(case (length args)
|
||||
1 (do
|
||||
@ -635,7 +632,12 @@
|
||||
(def arr (array.new n))
|
||||
(loop [i :range [n m]] (put arr (- i n) i))
|
||||
arr)
|
||||
(error "expected 1 to 2 arguments to range")))
|
||||
3 (do
|
||||
(def [n m s] args)
|
||||
(def arr (array.new n))
|
||||
(loop [i :range [n m s]] (put arr (- i n) i))
|
||||
arr)
|
||||
(error "expected 1 to 3 arguments to range")))
|
||||
|
||||
(defn find-index
|
||||
"Find the index of indexed type for which pred is true. Returns nil if not found."
|
||||
@ -657,11 +659,11 @@
|
||||
|
||||
(defn take-until
|
||||
"Given a predicate, take only elements from an indexed type that satisfy
|
||||
the predicate, and abort on first failure. Returns a new tuple."
|
||||
the predicate, and abort on first failure. Returns a new array."
|
||||
[pred ind]
|
||||
(def i (find-index pred ind))
|
||||
(if i
|
||||
(tuple.slice ind 0 i)
|
||||
(array.slice ind 0 i)
|
||||
ind))
|
||||
|
||||
(defn take-while
|
||||
@ -674,7 +676,7 @@
|
||||
the predicate, and abort on first failure. Returns a new tuple."
|
||||
[pred ind]
|
||||
(def i (find-index pred ind))
|
||||
(tuple.slice ind i))
|
||||
(array.slice ind i))
|
||||
|
||||
(defn drop-while
|
||||
"Same as (drop-until (complement pred) ind)."
|
||||
@ -682,6 +684,8 @@
|
||||
(drop-until (complement pred) ind))
|
||||
|
||||
(defn juxt*
|
||||
"Returns the juxtaposition of functions. In other words,
|
||||
((juxt* a b c) x) evaluates to ((a x) (b x) (c x))."
|
||||
[& funs]
|
||||
(fn [& args]
|
||||
(def ret @[])
|
||||
@ -690,6 +694,7 @@
|
||||
(tuple.slice ret 0)))
|
||||
|
||||
(defmacro juxt
|
||||
"Macro form of juxt*. Same behavior but more efficient."
|
||||
[& funs]
|
||||
(def parts @['tuple])
|
||||
(def $args (gensym))
|
||||
@ -729,39 +734,26 @@
|
||||
(if (zero? (length more)) f
|
||||
(fn [& r] (apply f (array.concat @[] more r)))))
|
||||
|
||||
(defn every? [pred ind]
|
||||
(defn every?
|
||||
"Returns true if the predicate pred is true for every
|
||||
value in ind, otherwise false."
|
||||
[pred ind]
|
||||
(var res true)
|
||||
(var i 0)
|
||||
(def len (length ind))
|
||||
(while (< i len)
|
||||
(def item (get ind i))
|
||||
(if (pred item)
|
||||
(++ i)
|
||||
(do (:= res false) (:= i len))))
|
||||
(loop [x :in ind :while res]
|
||||
(if (pred x) (:= res false)))
|
||||
res)
|
||||
|
||||
(defn array.reverse
|
||||
(defn reverse
|
||||
"Reverses the order of the elements in a given array or tuple and returns a new array."
|
||||
[t]
|
||||
(var n (dec (length t)))
|
||||
(var reversed @[])
|
||||
(def len (length t))
|
||||
(var n (dec len))
|
||||
(def reversed (array.new len))
|
||||
(while (>= n 0)
|
||||
(array.push reversed (get t n))
|
||||
(-- n))
|
||||
reversed)
|
||||
|
||||
(defn tuple.reverse
|
||||
"Reverses the order of the elements given an array or tuple and returns a tuple"
|
||||
[t]
|
||||
(tuple.slice (array.reverse t) 0))
|
||||
|
||||
(defn reverse
|
||||
"Reverses order of elements in a given array or tuple"
|
||||
[t]
|
||||
((case (type t)
|
||||
:tuple tuple.reverse
|
||||
:array array.reverse) t))
|
||||
|
||||
(defn invert
|
||||
"Returns a table of where the keys of an associative data structure
|
||||
are the values, and the values of the keys. If multiple keys have the same
|
||||
@ -774,17 +766,16 @@ value, one key will be ignored."
|
||||
|
||||
(defn zipcoll
|
||||
"Creates an table or tuple from two arrays/tuples. If a third argument of
|
||||
:struct is given result is struct else is table."
|
||||
[keys vals t &]
|
||||
:struct is given result is struct else is table. Returns a new table."
|
||||
[keys vals]
|
||||
(def res @{})
|
||||
(def lk (length keys))
|
||||
(def lv (length vals))
|
||||
(def len (if (< lk lv) lk lv))
|
||||
(loop [i :range [0 len]]
|
||||
(put res (get keys i) (get vals i)))
|
||||
(if (= :struct t)
|
||||
(table.to-struct res)
|
||||
res))
|
||||
res)
|
||||
|
||||
|
||||
(defn update
|
||||
"Accepts a key argument and passes its' associated value to a function.
|
||||
@ -793,17 +784,26 @@ value, one key will be ignored."
|
||||
(def old-value (get coll a-key))
|
||||
(put coll a-key (apply a-function old-value args)))
|
||||
|
||||
(defn merge-into
|
||||
"Merges multiple tables/structs into a table. If a key appears in more than one
|
||||
collection, then later values replace any previous ones.
|
||||
Returns the original table."
|
||||
[tab & colls]
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(put tab key (get c key)))
|
||||
tab)
|
||||
|
||||
(defn merge
|
||||
"Merges multiple tables/structs to one. If a key appears in more than one
|
||||
collection, then later values replace any previous ones.
|
||||
The type of the first collection determines the type of the resulting
|
||||
collection"
|
||||
Returns a new table."
|
||||
[& colls]
|
||||
(def container @{})
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(put container key (get c key)))
|
||||
(if (table? (get colls 0)) container (table.to-struct container)))
|
||||
container)
|
||||
|
||||
(defn keys
|
||||
"Get the keys of an associative data structure."
|
||||
@ -836,7 +836,7 @@ value, one key will be ignored."
|
||||
arr)
|
||||
|
||||
(defn frequencies
|
||||
"Get the number of occurences of each value in a indexed structure."
|
||||
"Get the number of occurrences of each value in a indexed structure."
|
||||
[ind]
|
||||
(def freqs @{})
|
||||
(loop
|
||||
@ -852,10 +852,10 @@ value, one key will be ignored."
|
||||
(def res @[])
|
||||
(def ncol (length cols))
|
||||
(when (> ncol 0)
|
||||
(def len (apply min (mapa length cols)))
|
||||
(loop [i :range [0 len]]
|
||||
(loop [ci :range [0 ncol]]
|
||||
(array.push res (get (get cols ci) i)))))
|
||||
(def len (apply min (map length cols)))
|
||||
(loop [i :range [0 len]
|
||||
ci :range [0 ncol]]
|
||||
(array.push res (get (get cols ci) i))))
|
||||
res)
|
||||
|
||||
###
|
||||
@ -941,8 +941,8 @@ value, one key will be ignored."
|
||||
|
||||
(defn expand-bindings [x]
|
||||
(case (type x)
|
||||
:array (mapa expand-bindings x)
|
||||
:tuple (map expand-bindings x)
|
||||
:array (map expand-bindings x)
|
||||
:tuple (tuple.slice (map expand-bindings x))
|
||||
:table (dotable x expand-bindings)
|
||||
:struct (table.to-struct (dotable x expand-bindings))
|
||||
(macroexpand-1 x)))
|
||||
@ -958,16 +958,16 @@ value, one key will be ignored."
|
||||
0))
|
||||
|
||||
(defn expandall [t]
|
||||
(def args (mapa macroexpand-1 (tuple.slice t 1)))
|
||||
(def args (map macroexpand-1 (tuple.slice t 1)))
|
||||
(apply tuple (get t 0) args))
|
||||
|
||||
(defn expandfn [t]
|
||||
(if (symbol? (get t 1))
|
||||
(do
|
||||
(def args (mapa macroexpand-1 (tuple.slice t 3)))
|
||||
(def args (map macroexpand-1 (tuple.slice t 3)))
|
||||
(apply tuple 'fn (get t 1) (get t 2) args))
|
||||
(do
|
||||
(def args (mapa macroexpand-1 (tuple.slice t 2)))
|
||||
(def args (map macroexpand-1 (tuple.slice t 2)))
|
||||
(apply tuple 'fn (get t 1) args))))
|
||||
|
||||
(def specs
|
||||
@ -989,12 +989,12 @@ value, one key will be ignored."
|
||||
(cond
|
||||
s (s t)
|
||||
m? (apply m (tuple.slice t 1))
|
||||
(map macroexpand-1 t)))
|
||||
(tuple.slice (map macroexpand-1 t))))
|
||||
|
||||
(def ret
|
||||
(case (type x)
|
||||
:tuple (dotup x)
|
||||
:array (mapa macroexpand-1 x)
|
||||
:array (map macroexpand-1 x)
|
||||
:struct (table.to-struct (dotable x macroexpand-1))
|
||||
:table (dotable x macroexpand-1)
|
||||
x))
|
||||
@ -1154,7 +1154,7 @@ value, one key will be ignored."
|
||||
(var good true)
|
||||
(def f
|
||||
(fiber.new
|
||||
(fn _thunk [&]
|
||||
(fn []
|
||||
(def res (compile source env where))
|
||||
(if (= (type res) :function)
|
||||
(res)
|
||||
@ -1211,7 +1211,7 @@ value, one key will be ignored."
|
||||
"\n")
|
||||
(when f
|
||||
(loop
|
||||
[nf :in (array.reverse (fiber.lineage f))
|
||||
[nf :in (reverse (fiber.lineage f))
|
||||
:before (file.write stderr " (fiber)\n")
|
||||
{:function func
|
||||
:tail tail
|
||||
@ -1291,7 +1291,7 @@ value, one key will be ignored."
|
||||
(def last (get parts (- (length parts) 1)))
|
||||
(def normname (string.replace-all "." "/" path))
|
||||
(array.push
|
||||
(mapa (fn [x]
|
||||
(map (fn [x]
|
||||
(def y (string.replace "??" last x))
|
||||
(string.replace "?" normname y))
|
||||
paths)
|
||||
|
||||
111
src/core/multisym.c
Normal file
111
src/core/multisym.c
Normal file
@ -0,0 +1,111 @@
|
||||
/*
|
||||
* Copyright (c) 2018 Calvin Rose
|
||||
*
|
||||
* Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
* of this software and associated documentation files (the "Software"), to
|
||||
* deal in the Software without restriction, including without limitation the
|
||||
* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
* sell copies of the Software, and to permit persons to whom the Software is
|
||||
* furnished to do so, subject to the following conditions:
|
||||
*
|
||||
* The above copyright notice and this permission notice shall be included in
|
||||
* all copies or substantial portions of the Software.
|
||||
*
|
||||
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
* IN THE SOFTWARE.
|
||||
*/
|
||||
|
||||
#include <janet/janet.h>
|
||||
#include "compile.h"
|
||||
#include "emit.h"
|
||||
#include "vector.h"
|
||||
|
||||
/* Parse a part of a symbol that can be used for building up code. */
|
||||
static JanetSlot multisym_parse_part(JanetCompiler *c, const uint8_t *sympart, int32_t len) {
|
||||
if (sympart[0] == ':') {
|
||||
return janetc_cslot(janet_symbolv(sympart, len));
|
||||
} else {
|
||||
int err = 0;
|
||||
int32_t num = janet_scan_integer(sympart + 1, len - 1, &err);
|
||||
if (err) {
|
||||
return janetc_resolve(c, janet_symbol(sympart + 1, len - 1));
|
||||
} else {
|
||||
return janetc_cslot(janet_wrap_integer(num));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static JanetSlot multisym_do_parts(JanetFopts opts, int put, const uint8_t *sym, Janet rvalue) {
|
||||
JanetSlot slot;
|
||||
JanetFopts subopts = janetc_fopts_default(opts.compiler);
|
||||
int i, j;
|
||||
for (i = 1, j = 0; sym[i]; i++) {
|
||||
if (sym[i] == ':' || sym[i] == '@') {
|
||||
if (j) {
|
||||
JanetSlot target = janetc_gettarget(subopts);
|
||||
JanetSlot value = multisym_parse_part(opts.compiler, sym + j, i - j);
|
||||
janetc_emit_sss(opts.compiler, JOP_GET, target, slot, value, 1);
|
||||
slot = target;
|
||||
} else {
|
||||
const uint8_t *nextsym = janet_symbol(sym + j, i - j);
|
||||
slot = janetc_resolve(opts.compiler, nextsym);
|
||||
}
|
||||
j = i;
|
||||
}
|
||||
}
|
||||
|
||||
if (j) {
|
||||
/* multisym (outermost get or put) */
|
||||
JanetSlot target = janetc_gettarget(opts);
|
||||
JanetSlot key = multisym_parse_part(opts.compiler, sym + j, i - j);
|
||||
if (put) {
|
||||
subopts.flags = JANET_FOPTS_HINT;
|
||||
subopts.hint = target;
|
||||
JanetSlot r_slot = janetc_value(subopts, rvalue);
|
||||
janetc_emit_sss(opts.compiler, JOP_PUT, slot, key, r_slot, 0);
|
||||
janetc_copy(opts.compiler, target, r_slot);
|
||||
} else {
|
||||
janetc_emit_sss(opts.compiler, JOP_GET, target, slot, key, 1);
|
||||
}
|
||||
return target;
|
||||
} else {
|
||||
/* normal symbol */
|
||||
if (put) {
|
||||
JanetSlot ret, dest;
|
||||
dest = janetc_resolve(opts.compiler, sym);
|
||||
if (!(dest.flags & JANET_SLOT_MUTABLE)) {
|
||||
janetc_cerror(opts.compiler, "cannot set constant");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
subopts.flags = JANET_FOPTS_HINT;
|
||||
subopts.hint = dest;
|
||||
ret = janetc_value(subopts, rvalue);
|
||||
janetc_copy(opts.compiler, dest, ret);
|
||||
return ret;
|
||||
}
|
||||
return janetc_resolve(opts.compiler, sym);
|
||||
}
|
||||
}
|
||||
|
||||
/* Check if a symbol is a multisym, and if so, transform
|
||||
* it and emit the code for treating it as a bunch of nested
|
||||
* gets. */
|
||||
JanetSlot janetc_sym_rvalue(JanetFopts opts, const uint8_t *sym) {
|
||||
if (janet_string_length(sym) && sym[0] != ':') {
|
||||
return multisym_do_parts(opts, 0, sym, janet_wrap_nil());
|
||||
} else {
|
||||
/* keyword */
|
||||
return janetc_cslot(janet_wrap_symbol(sym));
|
||||
}
|
||||
}
|
||||
|
||||
/* Check if a symbol is a multisym, and if so, transform
|
||||
* it into the correct 'put' expression. */
|
||||
JanetSlot janetc_sym_lvalue(JanetFopts opts, const uint8_t *sym, Janet value) {
|
||||
return multisym_do_parts(opts, 1, sym, value);
|
||||
}
|
||||
@ -92,8 +92,8 @@ static int destructure(JanetCompiler *c,
|
||||
}
|
||||
|
||||
static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) {
|
||||
JanetFopts subopts = janetc_fopts_default(opts.compiler);
|
||||
JanetSlot ret, dest;
|
||||
/*JanetFopts subopts = janetc_fopts_default(opts.compiler);*/
|
||||
/*JanetSlot ret, dest;*/
|
||||
Janet head;
|
||||
if (argn != 2) {
|
||||
janetc_cerror(opts.compiler, "expected 2 arguments");
|
||||
@ -104,16 +104,17 @@ static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv)
|
||||
janetc_cerror(opts.compiler, "expected symbol");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
dest = janetc_resolve(opts.compiler, janet_unwrap_symbol(head));
|
||||
if (!(dest.flags & JANET_SLOT_MUTABLE)) {
|
||||
janetc_cerror(opts.compiler, "cannot set constant");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
subopts.flags = JANET_FOPTS_HINT;
|
||||
subopts.hint = dest;
|
||||
ret = janetc_value(subopts, argv[1]);
|
||||
janetc_copy(opts.compiler, dest, ret);
|
||||
return ret;
|
||||
return janetc_sym_lvalue(opts, janet_unwrap_symbol(head), argv[1]);
|
||||
/*dest = janetc_resolve(opts.compiler, janet_unwrap_symbol(head));*/
|
||||
/*if (!(dest.flags & JANET_SLOT_MUTABLE)) {*/
|
||||
/*janetc_cerror(opts.compiler, "cannot set constant");*/
|
||||
/*return janetc_cslot(janet_wrap_nil());*/
|
||||
/*}*/
|
||||
/*subopts.flags = JANET_FOPTS_HINT;*/
|
||||
/*subopts.hint = dest;*/
|
||||
/*ret = janetc_value(subopts, argv[1]);*/
|
||||
/*janetc_copy(opts.compiler, dest, ret);*/
|
||||
/*return ret;*/
|
||||
}
|
||||
|
||||
/* Add attributes to a global def or var table */
|
||||
|
||||
@ -167,13 +167,13 @@
|
||||
(testmarsh (fn name [x] x) "marshal function 1")
|
||||
(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2")
|
||||
(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3")
|
||||
(testmarsh mapa "marshal function 4")
|
||||
(testmarsh map "marshal function 4")
|
||||
(testmarsh reduce "marshal function 5")
|
||||
(testmarsh (fiber.new (fn [] (yield 1) 2)) "marshal simple fiber 1")
|
||||
(testmarsh (fiber.new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
|
||||
|
||||
# Large functions
|
||||
(def manydefs (fora [i :range [0 300]] (tuple 'def (gensym) (string "value_" i))))
|
||||
(def manydefs (seq [i :range [0 300]] (tuple 'def (gensym) (string "value_" i))))
|
||||
(array.push manydefs (tuple * 10000 3 5 7 9))
|
||||
(def f (compile (tuple.prepend manydefs 'do) *env*))
|
||||
(assert (= (f) (* 10000 3 5 7 9)) "long function compilation")
|
||||
@ -206,15 +206,15 @@
|
||||
(assert (= 7 (case :a :b 5 :c 6 :u 10 7)), "case with default")
|
||||
|
||||
# Testing the loop and for macros
|
||||
(def xs (apply tuple (for [x :range [0 10] :when (even? x)] (tuple (/ x 2) x))))
|
||||
(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "for macro 1")
|
||||
(def xs (apply tuple (seq [x :range [0 10] :when (even? x)] (tuple (/ x 2) x))))
|
||||
(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1")
|
||||
|
||||
# Some testing for not=
|
||||
(assert (not= 1 1 0) "not= 1")
|
||||
(assert (not= 0 1 1) "not= 2")
|
||||
|
||||
# Closure in while loop
|
||||
(def closures (for [i :range [0 5]] (fn [] i)))
|
||||
(def closures (seq [i :range [0 5]] (fn [] i)))
|
||||
(assert (= 0 ((get closures 0))) "closure in loop 0")
|
||||
(assert (= 1 ((get closures 1))) "closure in loop 1")
|
||||
(assert (= 2 ((get closures 2))) "closure in loop 2")
|
||||
|
||||
@ -41,10 +41,10 @@
|
||||
|
||||
# Looping idea
|
||||
(def xs
|
||||
(for [x :in '[-1 0 1], y :in '[-1 0 1] :when (not= x y 0)] (tuple x y)))
|
||||
(seq [x :in '[-1 0 1], y :in '[-1 0 1] :when (not= x y 0)] (tuple x y)))
|
||||
(def txs (apply tuple xs))
|
||||
|
||||
(assert (= txs '[[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) "nested for")
|
||||
(assert (= txs '[[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) "nested seq")
|
||||
|
||||
# Generators
|
||||
(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user