1
0
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 2018-11-29 13:30:59 -05:00
parent 6e74617c05
commit b0c45fd15e
10 changed files with 238 additions and 201 deletions

View File

@ -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*)))

View File

@ -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)))

View File

@ -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)))

View File

@ -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);

View File

@ -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

View File

@ -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
View 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);
}

View File

@ -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 */

View File

@ -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")

View File

@ -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))