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:
parent
6e74617c05
commit
b0c45fd15e
@ -1,21 +1,21 @@
|
|||||||
# A game of life implementation
|
# A game of life implementation
|
||||||
|
|
||||||
(def- window
|
(def- window
|
||||||
(fora [x :range [-1 2]
|
(seq [x :range [-1 2]
|
||||||
y :range [-1 2]
|
y :range [-1 2]
|
||||||
:when (not (and (zero? x) (zero? y)))]
|
:when (not (and (zero? x) (zero? y)))]
|
||||||
(tuple x y)))
|
(tuple x y)))
|
||||||
|
|
||||||
(defn- neighbors
|
(defn- neighbors
|
||||||
[[x y]]
|
[[x y]]
|
||||||
(mapa (fn [[x1 y1]] (tuple (+ x x1) (+ y y1))) window))
|
(map (fn [[x1 y1]] (tuple (+ x x1) (+ y y1))) window))
|
||||||
|
|
||||||
(defn tick
|
(defn tick
|
||||||
"Get the next state in the Game Of Life."
|
"Get the next state in the Game Of Life."
|
||||||
[state]
|
[state]
|
||||||
(def cell-set (frequencies state))
|
(def cell-set (frequencies state))
|
||||||
(def neighbor-set (frequencies (mapcat neighbors state)))
|
(def neighbor-set (frequencies (mapcat neighbors state)))
|
||||||
(fora [coord :keys neighbor-set
|
(seq [coord :keys neighbor-set
|
||||||
:let [count (get neighbor-set coord)]
|
:let [count (get neighbor-set coord)]
|
||||||
:when (or (= count 3) (and (get cell-set coord) (= count 2)))]
|
:when (or (= count 3) (and (get cell-set coord) (= count 2)))]
|
||||||
coord))
|
coord))
|
||||||
@ -24,7 +24,7 @@
|
|||||||
"Draw cells in the game of life from (x1, y1) to (x2, y2)"
|
"Draw cells in the game of life from (x1, y1) to (x2, y2)"
|
||||||
[state x1 y1 x2 y2]
|
[state x1 y1 x2 y2]
|
||||||
(def cellset @{})
|
(def cellset @{})
|
||||||
(loop [cell :in state] (put cellset cell true))
|
(each cell state (put cellset cell true))
|
||||||
(loop [x :range [x1 (+ 1 x2)]
|
(loop [x :range [x1 (+ 1 x2)]
|
||||||
:after (print)
|
:after (print)
|
||||||
y :range [y1 (+ 1 y2)]]
|
y :range [y1 (+ 1 y2)]]
|
||||||
@ -37,7 +37,7 @@
|
|||||||
|
|
||||||
(var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)])
|
(var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)])
|
||||||
|
|
||||||
(loop [i :range [0 20]]
|
(for i 0 20
|
||||||
(print "generation " i)
|
(print "generation " i)
|
||||||
(draw *state* -7 -7 7 7)
|
(draw *state* -7 -7 7 7)
|
||||||
(:= *state* (tick *state*)))
|
(:= *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."
|
"Returns a list of prime numbers less than n."
|
||||||
[n]
|
[n]
|
||||||
(def list @[])
|
(def list @[])
|
||||||
(loop [i :range [2 n]]
|
(for i 2 n
|
||||||
(var isprime? true)
|
(var isprime? true)
|
||||||
(def len (length list))
|
(def len (length list))
|
||||||
(loop [j :range [0 len]]
|
(for j 0 len
|
||||||
(def trial (get list j))
|
(def trial (get list j))
|
||||||
(if (zero? (% i trial)) (:= isprime? false)))
|
(if (zero? (% i trial)) (:= isprime? false)))
|
||||||
(if isprime? (array.push list i)))
|
(if isprime? (array.push list i)))
|
||||||
|
@ -421,14 +421,6 @@ static JanetSlot janetc_bufferctor(JanetFopts opts, Janet x) {
|
|||||||
JOP_MAKE_BUFFER);
|
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
|
/* Expand a macro one time. Also get the special form compiler if we
|
||||||
* find that instead. */
|
* find that instead. */
|
||||||
static int macroexpand1(
|
static int macroexpand1(
|
||||||
@ -532,7 +524,7 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) {
|
|||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case JANET_SYMBOL:
|
case JANET_SYMBOL:
|
||||||
ret = janetc_symbol(opts, janet_unwrap_symbol(x));
|
ret = janetc_sym_rvalue(opts, janet_unwrap_symbol(x));
|
||||||
break;
|
break;
|
||||||
case JANET_ARRAY:
|
case JANET_ARRAY:
|
||||||
ret = janetc_array(opts, x);
|
ret = janetc_array(opts, x);
|
||||||
|
@ -237,4 +237,10 @@ JanetSlot janetc_cslot(Janet x);
|
|||||||
/* Search for a symbol */
|
/* Search for a symbol */
|
||||||
JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym);
|
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
|
#endif
|
||||||
|
@ -120,6 +120,7 @@
|
|||||||
(defn true? "Check if x is true." [x] (= x true))
|
(defn true? "Check if x is true." [x] (= x true))
|
||||||
(defn false? "Check if x is false." [x] (= x false))
|
(defn false? "Check if x is false." [x] (= x false))
|
||||||
(defn nil? "Check if x is nil." [x] (= x nil))
|
(defn nil? "Check if x is nil." [x] (= x nil))
|
||||||
|
(defn empty? "Check if xs is empty." [xs] (= 0 (length xs)))
|
||||||
(def atomic?
|
(def atomic?
|
||||||
"(atomic? x)\n\nCheck if x is a value that evaluates to itself when compiled."
|
"(atomic? x)\n\nCheck if x is a value that evaluates to itself when compiled."
|
||||||
(do
|
(do
|
||||||
@ -257,10 +258,10 @@
|
|||||||
|
|
||||||
(defmacro loop
|
(defmacro loop
|
||||||
"A general purpose loop macro. This macro is similar to the Common Lisp
|
"A general purpose loop macro. This macro is similar to the Common Lisp
|
||||||
loop macro, although intentonally much smaller in scope.
|
loop macro, although intentionally much smaller in scope.
|
||||||
The head of the loop shoud be a tuple that contains a sequence of
|
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
|
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
|
\tbinding :verb object/expression\n\n
|
||||||
Where binding is a binding as passed to def, :verb is one of a set of keywords,
|
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
|
and object is any janet expression. The available verbs are:\n\n
|
||||||
@ -388,7 +389,7 @@
|
|||||||
(error (string "unexpected loop verb: " verb)))))))
|
(error (string "unexpected loop verb: " verb)))))))
|
||||||
(tuple 'do (doone 0 nil) nil))
|
(tuple 'do (doone 0 nil) nil))
|
||||||
|
|
||||||
(defmacro fora
|
(defmacro seq
|
||||||
"Similar to loop, but accumulates the loop body into an array and returns that.
|
"Similar to loop, but accumulates the loop body into an array and returns that.
|
||||||
See loop for details."
|
See loop for details."
|
||||||
[head & body]
|
[head & body]
|
||||||
@ -400,18 +401,6 @@
|
|||||||
(tuple.prepend body 'do)))
|
(tuple.prepend body 'do)))
|
||||||
$accum))
|
$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
|
(defmacro generate
|
||||||
"Create a generator expression using the loop syntax. Returns a fiber
|
"Create a generator expression using the loop syntax. Returns a fiber
|
||||||
that yields all values inside the loop in order. See loop for details."
|
that yields all values inside the loop in order. See loop for details."
|
||||||
@ -421,6 +410,16 @@
|
|||||||
(tuple 'fn '[&]
|
(tuple 'fn '[&]
|
||||||
(tuple 'loop head (tuple yield (tuple.prepend body 'do))))))
|
(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]
|
(defn sum [xs]
|
||||||
(var accum 0)
|
(var accum 0)
|
||||||
(loop [x :in xs] (+= accum x))
|
(loop [x :in xs] (+= accum x))
|
||||||
@ -498,7 +497,8 @@
|
|||||||
(fn [x] (not (f x))))
|
(fn [x] (not (f x))))
|
||||||
|
|
||||||
(defn extreme
|
(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."
|
Returns nil if args is empty."
|
||||||
[order args]
|
[order args]
|
||||||
(def len (length args))
|
(def len (length args))
|
||||||
@ -514,6 +514,16 @@
|
|||||||
(defn max-order [& args] (extreme order> args))
|
(defn max-order [& args] (extreme order> args))
|
||||||
(defn min-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
|
### Indexed Combinators
|
||||||
@ -551,23 +561,20 @@
|
|||||||
(sort-help a 0 (- (length a) 1) (or by order<)))))
|
(sort-help a 0 (- (length a) 1) (or by order<)))))
|
||||||
|
|
||||||
(defn sorted
|
(defn sorted
|
||||||
"Returns the sorted version of an indexed data structure."
|
"Returns a new sorted array without modifying the old one."
|
||||||
[ind by t &]
|
[ind by]
|
||||||
(def sa (sort (array.slice ind 0) by))
|
(sort (array.slice ind) by))
|
||||||
(if (= :tuple (or t (type ind)))
|
|
||||||
(tuple.slice sa 0)
|
|
||||||
sa))
|
|
||||||
|
|
||||||
(defn reduce
|
(defn reduce
|
||||||
"Reduce, also know as fold-left in many languages, transforms
|
"Reduce, also know as fold-left in many languages, transforms
|
||||||
an indexed type (array, tuple) with a function to produce a value."
|
an indexed type (array, tuple) with a function to produce a value."
|
||||||
[f init ind &]
|
[f init ind]
|
||||||
(var res init)
|
(var res init)
|
||||||
(loop [x :in ind]
|
(loop [x :in ind]
|
||||||
(:= res (f res x)))
|
(:= res (f res x)))
|
||||||
res)
|
res)
|
||||||
|
|
||||||
(defn mapa
|
(defn map
|
||||||
"Map a function over every element in an indexed data structure and
|
"Map a function over every element in an indexed data structure and
|
||||||
return an array of the results."
|
return an array of the results."
|
||||||
[f & inds]
|
[f & inds]
|
||||||
@ -590,39 +597,29 @@
|
|||||||
(put res i (apply f args))))
|
(put res i (apply f args))))
|
||||||
res)
|
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
|
(defn mapcat
|
||||||
"Map a function over every element in an array or tuple and
|
"Map a function over every element in an array or tuple and
|
||||||
use array to concatenate the results. Returns the type given
|
use array to concatenate the results."
|
||||||
as the third argument, or same type as the input indexed structure."
|
[f ind]
|
||||||
[f ind t &]
|
|
||||||
(def res @[])
|
(def res @[])
|
||||||
(loop [x :in ind]
|
(loop [x :in ind]
|
||||||
(array.concat res (f x)))
|
(array.concat res (f x)))
|
||||||
(if (= :tuple (or t (type ind)))
|
res)
|
||||||
(tuple.slice res 0)
|
|
||||||
res))
|
|
||||||
|
|
||||||
(defn filter
|
(defn filter
|
||||||
"Given a predicate, take only elements from an array or tuple for
|
"Given a predicate, take only elements from an array or tuple for
|
||||||
which (pred element) is truthy. Returns the type given as the
|
which (pred element) is truthy. Returns a new array."
|
||||||
third argument, or the same type as the input indexed structure."
|
|
||||||
[pred ind t &]
|
[pred ind t &]
|
||||||
(def res @[])
|
(def res @[])
|
||||||
(loop [item :in ind]
|
(loop [item :in ind]
|
||||||
(if (pred item)
|
(if (pred item)
|
||||||
(array.push res item)))
|
(array.push res item)))
|
||||||
(if (= :tuple (or t (type ind)))
|
res)
|
||||||
(tuple.slice res 0)
|
|
||||||
res))
|
|
||||||
|
|
||||||
(defn range
|
(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]
|
[& args]
|
||||||
(case (length args)
|
(case (length args)
|
||||||
1 (do
|
1 (do
|
||||||
@ -635,7 +632,12 @@
|
|||||||
(def arr (array.new n))
|
(def arr (array.new n))
|
||||||
(loop [i :range [n m]] (put arr (- i n) i))
|
(loop [i :range [n m]] (put arr (- i n) i))
|
||||||
arr)
|
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
|
(defn find-index
|
||||||
"Find the index of indexed type for which pred is true. Returns nil if not found."
|
"Find the index of indexed type for which pred is true. Returns nil if not found."
|
||||||
@ -657,11 +659,11 @@
|
|||||||
|
|
||||||
(defn take-until
|
(defn take-until
|
||||||
"Given a predicate, take only elements from an indexed type that satisfy
|
"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]
|
[pred ind]
|
||||||
(def i (find-index pred ind))
|
(def i (find-index pred ind))
|
||||||
(if i
|
(if i
|
||||||
(tuple.slice ind 0 i)
|
(array.slice ind 0 i)
|
||||||
ind))
|
ind))
|
||||||
|
|
||||||
(defn take-while
|
(defn take-while
|
||||||
@ -674,7 +676,7 @@
|
|||||||
the predicate, and abort on first failure. Returns a new tuple."
|
the predicate, and abort on first failure. Returns a new tuple."
|
||||||
[pred ind]
|
[pred ind]
|
||||||
(def i (find-index pred ind))
|
(def i (find-index pred ind))
|
||||||
(tuple.slice ind i))
|
(array.slice ind i))
|
||||||
|
|
||||||
(defn drop-while
|
(defn drop-while
|
||||||
"Same as (drop-until (complement pred) ind)."
|
"Same as (drop-until (complement pred) ind)."
|
||||||
@ -682,6 +684,8 @@
|
|||||||
(drop-until (complement pred) ind))
|
(drop-until (complement pred) ind))
|
||||||
|
|
||||||
(defn juxt*
|
(defn juxt*
|
||||||
|
"Returns the juxtaposition of functions. In other words,
|
||||||
|
((juxt* a b c) x) evaluates to ((a x) (b x) (c x))."
|
||||||
[& funs]
|
[& funs]
|
||||||
(fn [& args]
|
(fn [& args]
|
||||||
(def ret @[])
|
(def ret @[])
|
||||||
@ -690,6 +694,7 @@
|
|||||||
(tuple.slice ret 0)))
|
(tuple.slice ret 0)))
|
||||||
|
|
||||||
(defmacro juxt
|
(defmacro juxt
|
||||||
|
"Macro form of juxt*. Same behavior but more efficient."
|
||||||
[& funs]
|
[& funs]
|
||||||
(def parts @['tuple])
|
(def parts @['tuple])
|
||||||
(def $args (gensym))
|
(def $args (gensym))
|
||||||
@ -729,39 +734,26 @@
|
|||||||
(if (zero? (length more)) f
|
(if (zero? (length more)) f
|
||||||
(fn [& r] (apply f (array.concat @[] more r)))))
|
(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 res true)
|
||||||
(var i 0)
|
(loop [x :in ind :while res]
|
||||||
(def len (length ind))
|
(if (pred x) (:= res false)))
|
||||||
(while (< i len)
|
|
||||||
(def item (get ind i))
|
|
||||||
(if (pred item)
|
|
||||||
(++ i)
|
|
||||||
(do (:= res false) (:= i len))))
|
|
||||||
res)
|
res)
|
||||||
|
|
||||||
(defn array.reverse
|
(defn reverse
|
||||||
"Reverses the order of the elements in a given array or tuple and returns a new array."
|
"Reverses the order of the elements in a given array or tuple and returns a new array."
|
||||||
[t]
|
[t]
|
||||||
(var n (dec (length t)))
|
(def len (length t))
|
||||||
(var reversed @[])
|
(var n (dec len))
|
||||||
|
(def reversed (array.new len))
|
||||||
(while (>= n 0)
|
(while (>= n 0)
|
||||||
(array.push reversed (get t n))
|
(array.push reversed (get t n))
|
||||||
(-- n))
|
(-- n))
|
||||||
reversed)
|
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
|
(defn invert
|
||||||
"Returns a table of where the keys of an associative data structure
|
"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
|
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
|
(defn zipcoll
|
||||||
"Creates an table or tuple from two arrays/tuples. If a third argument of
|
"Creates an table or tuple from two arrays/tuples. If a third argument of
|
||||||
:struct is given result is struct else is table."
|
:struct is given result is struct else is table. Returns a new table."
|
||||||
[keys vals t &]
|
[keys vals]
|
||||||
(def res @{})
|
(def res @{})
|
||||||
(def lk (length keys))
|
(def lk (length keys))
|
||||||
(def lv (length vals))
|
(def lv (length vals))
|
||||||
(def len (if (< lk lv) lk lv))
|
(def len (if (< lk lv) lk lv))
|
||||||
(loop [i :range [0 len]]
|
(loop [i :range [0 len]]
|
||||||
(put res (get keys i) (get vals i)))
|
(put res (get keys i) (get vals i)))
|
||||||
(if (= :struct t)
|
res)
|
||||||
(table.to-struct res)
|
|
||||||
res))
|
|
||||||
|
|
||||||
(defn update
|
(defn update
|
||||||
"Accepts a key argument and passes its' associated value to a function.
|
"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))
|
(def old-value (get coll a-key))
|
||||||
(put coll a-key (apply a-function old-value args)))
|
(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
|
(defn merge
|
||||||
"Merges multiple tables/structs to one. If a key appears in more than one
|
"Merges multiple tables/structs to one. If a key appears in more than one
|
||||||
collection, then later values replace any previous ones.
|
collection, then later values replace any previous ones.
|
||||||
The type of the first collection determines the type of the resulting
|
Returns a new table."
|
||||||
collection"
|
|
||||||
[& colls]
|
[& colls]
|
||||||
(def container @{})
|
(def container @{})
|
||||||
(loop [c :in colls
|
(loop [c :in colls
|
||||||
key :keys c]
|
key :keys c]
|
||||||
(put container key (get c key)))
|
(put container key (get c key)))
|
||||||
(if (table? (get colls 0)) container (table.to-struct container)))
|
container)
|
||||||
|
|
||||||
(defn keys
|
(defn keys
|
||||||
"Get the keys of an associative data structure."
|
"Get the keys of an associative data structure."
|
||||||
@ -836,7 +836,7 @@ value, one key will be ignored."
|
|||||||
arr)
|
arr)
|
||||||
|
|
||||||
(defn frequencies
|
(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]
|
[ind]
|
||||||
(def freqs @{})
|
(def freqs @{})
|
||||||
(loop
|
(loop
|
||||||
@ -852,10 +852,10 @@ value, one key will be ignored."
|
|||||||
(def res @[])
|
(def res @[])
|
||||||
(def ncol (length cols))
|
(def ncol (length cols))
|
||||||
(when (> ncol 0)
|
(when (> ncol 0)
|
||||||
(def len (apply min (mapa length cols)))
|
(def len (apply min (map length cols)))
|
||||||
(loop [i :range [0 len]]
|
(loop [i :range [0 len]
|
||||||
(loop [ci :range [0 ncol]]
|
ci :range [0 ncol]]
|
||||||
(array.push res (get (get cols ci) i)))))
|
(array.push res (get (get cols ci) i))))
|
||||||
res)
|
res)
|
||||||
|
|
||||||
###
|
###
|
||||||
@ -941,8 +941,8 @@ value, one key will be ignored."
|
|||||||
|
|
||||||
(defn expand-bindings [x]
|
(defn expand-bindings [x]
|
||||||
(case (type x)
|
(case (type x)
|
||||||
:array (mapa expand-bindings x)
|
:array (map expand-bindings x)
|
||||||
:tuple (map expand-bindings x)
|
:tuple (tuple.slice (map expand-bindings x))
|
||||||
:table (dotable x expand-bindings)
|
:table (dotable x expand-bindings)
|
||||||
:struct (table.to-struct (dotable x expand-bindings))
|
:struct (table.to-struct (dotable x expand-bindings))
|
||||||
(macroexpand-1 x)))
|
(macroexpand-1 x)))
|
||||||
@ -958,16 +958,16 @@ value, one key will be ignored."
|
|||||||
0))
|
0))
|
||||||
|
|
||||||
(defn expandall [t]
|
(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))
|
(apply tuple (get t 0) args))
|
||||||
|
|
||||||
(defn expandfn [t]
|
(defn expandfn [t]
|
||||||
(if (symbol? (get t 1))
|
(if (symbol? (get t 1))
|
||||||
(do
|
(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))
|
(apply tuple 'fn (get t 1) (get t 2) args))
|
||||||
(do
|
(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))))
|
(apply tuple 'fn (get t 1) args))))
|
||||||
|
|
||||||
(def specs
|
(def specs
|
||||||
@ -989,12 +989,12 @@ value, one key will be ignored."
|
|||||||
(cond
|
(cond
|
||||||
s (s t)
|
s (s t)
|
||||||
m? (apply m (tuple.slice t 1))
|
m? (apply m (tuple.slice t 1))
|
||||||
(map macroexpand-1 t)))
|
(tuple.slice (map macroexpand-1 t))))
|
||||||
|
|
||||||
(def ret
|
(def ret
|
||||||
(case (type x)
|
(case (type x)
|
||||||
:tuple (dotup x)
|
:tuple (dotup x)
|
||||||
:array (mapa macroexpand-1 x)
|
:array (map macroexpand-1 x)
|
||||||
:struct (table.to-struct (dotable x macroexpand-1))
|
:struct (table.to-struct (dotable x macroexpand-1))
|
||||||
:table (dotable x macroexpand-1)
|
:table (dotable x macroexpand-1)
|
||||||
x))
|
x))
|
||||||
@ -1154,7 +1154,7 @@ value, one key will be ignored."
|
|||||||
(var good true)
|
(var good true)
|
||||||
(def f
|
(def f
|
||||||
(fiber.new
|
(fiber.new
|
||||||
(fn _thunk [&]
|
(fn []
|
||||||
(def res (compile source env where))
|
(def res (compile source env where))
|
||||||
(if (= (type res) :function)
|
(if (= (type res) :function)
|
||||||
(res)
|
(res)
|
||||||
@ -1211,7 +1211,7 @@ value, one key will be ignored."
|
|||||||
"\n")
|
"\n")
|
||||||
(when f
|
(when f
|
||||||
(loop
|
(loop
|
||||||
[nf :in (array.reverse (fiber.lineage f))
|
[nf :in (reverse (fiber.lineage f))
|
||||||
:before (file.write stderr " (fiber)\n")
|
:before (file.write stderr " (fiber)\n")
|
||||||
{:function func
|
{:function func
|
||||||
:tail tail
|
:tail tail
|
||||||
@ -1291,7 +1291,7 @@ value, one key will be ignored."
|
|||||||
(def last (get parts (- (length parts) 1)))
|
(def last (get parts (- (length parts) 1)))
|
||||||
(def normname (string.replace-all "." "/" path))
|
(def normname (string.replace-all "." "/" path))
|
||||||
(array.push
|
(array.push
|
||||||
(mapa (fn [x]
|
(map (fn [x]
|
||||||
(def y (string.replace "??" last x))
|
(def y (string.replace "??" last x))
|
||||||
(string.replace "?" normname y))
|
(string.replace "?" normname y))
|
||||||
paths)
|
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) {
|
static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) {
|
||||||
JanetFopts subopts = janetc_fopts_default(opts.compiler);
|
/*JanetFopts subopts = janetc_fopts_default(opts.compiler);*/
|
||||||
JanetSlot ret, dest;
|
/*JanetSlot ret, dest;*/
|
||||||
Janet head;
|
Janet head;
|
||||||
if (argn != 2) {
|
if (argn != 2) {
|
||||||
janetc_cerror(opts.compiler, "expected 2 arguments");
|
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");
|
janetc_cerror(opts.compiler, "expected symbol");
|
||||||
return janetc_cslot(janet_wrap_nil());
|
return janetc_cslot(janet_wrap_nil());
|
||||||
}
|
}
|
||||||
dest = janetc_resolve(opts.compiler, janet_unwrap_symbol(head));
|
return janetc_sym_lvalue(opts, janet_unwrap_symbol(head), argv[1]);
|
||||||
if (!(dest.flags & JANET_SLOT_MUTABLE)) {
|
/*dest = janetc_resolve(opts.compiler, janet_unwrap_symbol(head));*/
|
||||||
janetc_cerror(opts.compiler, "cannot set constant");
|
/*if (!(dest.flags & JANET_SLOT_MUTABLE)) {*/
|
||||||
return janetc_cslot(janet_wrap_nil());
|
/*janetc_cerror(opts.compiler, "cannot set constant");*/
|
||||||
}
|
/*return janetc_cslot(janet_wrap_nil());*/
|
||||||
subopts.flags = JANET_FOPTS_HINT;
|
/*}*/
|
||||||
subopts.hint = dest;
|
/*subopts.flags = JANET_FOPTS_HINT;*/
|
||||||
ret = janetc_value(subopts, argv[1]);
|
/*subopts.hint = dest;*/
|
||||||
janetc_copy(opts.compiler, dest, ret);
|
/*ret = janetc_value(subopts, argv[1]);*/
|
||||||
return ret;
|
/*janetc_copy(opts.compiler, dest, ret);*/
|
||||||
|
/*return ret;*/
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Add attributes to a global def or var table */
|
/* Add attributes to a global def or var table */
|
||||||
|
@ -167,13 +167,13 @@
|
|||||||
(testmarsh (fn name [x] x) "marshal function 1")
|
(testmarsh (fn name [x] x) "marshal function 1")
|
||||||
(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2")
|
(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2")
|
||||||
(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3")
|
(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 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 1")
|
||||||
(testmarsh (fiber.new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
|
(testmarsh (fiber.new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
|
||||||
|
|
||||||
# Large functions
|
# 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))
|
(array.push manydefs (tuple * 10000 3 5 7 9))
|
||||||
(def f (compile (tuple.prepend manydefs 'do) *env*))
|
(def f (compile (tuple.prepend manydefs 'do) *env*))
|
||||||
(assert (= (f) (* 10000 3 5 7 9)) "long function compilation")
|
(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")
|
(assert (= 7 (case :a :b 5 :c 6 :u 10 7)), "case with default")
|
||||||
|
|
||||||
# Testing the loop and for macros
|
# Testing the loop and for macros
|
||||||
(def xs (apply tuple (for [x :range [0 10] :when (even? x)] (tuple (/ x 2) x))))
|
(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))) "for macro 1")
|
(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1")
|
||||||
|
|
||||||
# Some testing for not=
|
# Some testing for not=
|
||||||
(assert (not= 1 1 0) "not= 1")
|
(assert (not= 1 1 0) "not= 1")
|
||||||
(assert (not= 0 1 1) "not= 2")
|
(assert (not= 0 1 1) "not= 2")
|
||||||
|
|
||||||
# Closure in while loop
|
# 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 (= 0 ((get closures 0))) "closure in loop 0")
|
||||||
(assert (= 1 ((get closures 1))) "closure in loop 1")
|
(assert (= 1 ((get closures 1))) "closure in loop 1")
|
||||||
(assert (= 2 ((get closures 2))) "closure in loop 2")
|
(assert (= 2 ((get closures 2))) "closure in loop 2")
|
||||||
|
@ -41,10 +41,10 @@
|
|||||||
|
|
||||||
# Looping idea
|
# Looping idea
|
||||||
(def xs
|
(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))
|
(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
|
# Generators
|
||||||
(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x))
|
(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x))
|
||||||
|
Loading…
Reference in New Issue
Block a user