mirror of
https://github.com/janet-lang/janet
synced 2025-01-12 16:40:27 +00:00
Add functionality that allows the set macro to
take a tuple as an l-value. Remove the old multi-sym report in anticipation of a different mechanism.
This commit is contained in:
Calvin Rose
parent
92e9e64945
commit
eae4e0dede
@ -5,10 +5,10 @@
|
||||
(def solutions @{})
|
||||
(def len (length s))
|
||||
(for k 0 len
|
||||
(put tab s.k k))
|
||||
(put tab (s k) k))
|
||||
(for i 0 len
|
||||
(for j 0 len
|
||||
(def k (get tab (- 0 s.i s.j)))
|
||||
(def k (get tab (- 0 (s i) (s j))))
|
||||
(when (and k (not= k i) (not= k j) (not= i j))
|
||||
(put solutions {i true j true k true} true))))
|
||||
(map keys (keys solutions)))
|
||||
|
||||
@ -16,7 +16,7 @@
|
||||
(def cell-set (frequencies state))
|
||||
(def neighbor-set (frequencies (mapcat neighbors state)))
|
||||
(seq [coord :keys neighbor-set
|
||||
:let [count neighbor-set.coord]
|
||||
: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 @{})
|
||||
(each cell state (set cellset.cell true))
|
||||
(each cell state (put cellset cell true))
|
||||
(loop [x :range [x1 (+ 1 x2)]
|
||||
:after (print)
|
||||
y :range [y1 (+ 1 y2)]]
|
||||
|
||||
@ -553,7 +553,7 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) {
|
||||
}
|
||||
break;
|
||||
case JANET_SYMBOL:
|
||||
ret = janetc_sym_rvalue(opts, janet_unwrap_symbol(x));
|
||||
ret = janetc_resolve(opts.compiler, janet_unwrap_symbol(x));
|
||||
break;
|
||||
case JANET_ARRAY:
|
||||
ret = janetc_array(opts, x);
|
||||
|
||||
@ -240,10 +240,4 @@ 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
|
||||
|
||||
@ -29,14 +29,14 @@
|
||||
(array/push modifiers ith))
|
||||
(if (< i len) (recur (+ i 1)))))))
|
||||
(def start (fstart 0))
|
||||
(def args more.start)
|
||||
(def args (get more start))
|
||||
# Add function signature to docstring
|
||||
(var index 0)
|
||||
(def arglen (length args))
|
||||
(def buf (buffer "(" name))
|
||||
(while (< index arglen)
|
||||
(buffer/push-string buf " ")
|
||||
(string/pretty args.index 4 buf)
|
||||
(string/pretty (get args index) 4 buf)
|
||||
(set index (+ index 1)))
|
||||
(array/push modifiers (string buf ")\n\n" docstr))
|
||||
# Build return value
|
||||
@ -186,8 +186,8 @@
|
||||
(defn aux [i]
|
||||
(def restlen (- (length pairs) i))
|
||||
(if (= restlen 0) nil
|
||||
(if (= restlen 1) pairs.i
|
||||
(tuple 'if pairs.i
|
||||
(if (= restlen 1) (get pairs i)
|
||||
(tuple 'if (get pairs i)
|
||||
(get pairs (+ i 1))
|
||||
(aux (+ i 2))))))
|
||||
(aux 0))
|
||||
@ -202,8 +202,8 @@
|
||||
(defn aux [i]
|
||||
(def restlen (- (length pairs) i))
|
||||
(if (= restlen 0) nil
|
||||
(if (= restlen 1) pairs.i
|
||||
(tuple 'if (tuple = sym pairs.i)
|
||||
(if (= restlen 1) (get pairs i)
|
||||
(tuple 'if (tuple = sym (get pairs i))
|
||||
(get pairs (+ i 1))
|
||||
(aux (+ i 2))))))
|
||||
(if atm
|
||||
@ -254,8 +254,8 @@
|
||||
(while (> i 0)
|
||||
(-- i)
|
||||
(set ret (if (= ret true)
|
||||
forms.i
|
||||
(tuple 'if forms.i ret))))
|
||||
(get forms i)
|
||||
(tuple 'if (get forms i) ret))))
|
||||
ret)
|
||||
|
||||
(defmacro or
|
||||
@ -267,7 +267,7 @@
|
||||
(var i len)
|
||||
(while (> i 0)
|
||||
(-- i)
|
||||
(def fi forms.i)
|
||||
(def fi (get forms i))
|
||||
(set ret (if (idempotent? fi)
|
||||
(tuple 'if fi fi ret)
|
||||
(do
|
||||
@ -477,7 +477,7 @@
|
||||
(if (zero? len) (error "expected at least 1 binding"))
|
||||
(if (odd? len) (error "expected an even number of bindings"))
|
||||
(defn aux [i]
|
||||
(def bl bindings.i)
|
||||
(def bl (get bindings i))
|
||||
(def br (get bindings (+ 1 i)))
|
||||
(if (>= i len)
|
||||
tru
|
||||
@ -537,7 +537,7 @@
|
||||
(when (pos? len)
|
||||
(var [ret] args)
|
||||
(loop [i :range [0 len]]
|
||||
(def v args.i)
|
||||
(def v (get args i))
|
||||
(if (order v ret) (set ret v)))
|
||||
ret))
|
||||
|
||||
@ -581,17 +581,17 @@
|
||||
|
||||
(defn partition
|
||||
[a lo hi by]
|
||||
(def pivot a.hi)
|
||||
(def pivot (get a hi))
|
||||
(var i lo)
|
||||
(loop [j :range [lo hi]]
|
||||
(def aj a.j)
|
||||
(def aj (get a j))
|
||||
(when (by aj pivot)
|
||||
(def ai a.i)
|
||||
(set a.i aj)
|
||||
(set a.j ai)
|
||||
(def ai (get a i))
|
||||
(set (a i) aj)
|
||||
(set (a j) ai)
|
||||
(++ i)))
|
||||
(set a.hi a.i)
|
||||
(set a.i pivot)
|
||||
(set (a hi) (get a i))
|
||||
(set (a i) pivot)
|
||||
i)
|
||||
|
||||
(defn sort-help
|
||||
@ -627,19 +627,19 @@
|
||||
(if (= 0 ninds) (error "expected at least 1 indexed collection"))
|
||||
(var limit (length (get inds 0)))
|
||||
(loop [i :range [0 ninds]]
|
||||
(def l (length inds.i))
|
||||
(def l (length (get inds i)))
|
||||
(if (< l limit) (set limit l)))
|
||||
(def [i1 i2 i3 i4] inds)
|
||||
(def res (array/new limit))
|
||||
(case ninds
|
||||
1 (loop [i :range [0 limit]] (set res.i (f i1.i)))
|
||||
2 (loop [i :range [0 limit]] (set res.i (f i1.i i2.i)))
|
||||
3 (loop [i :range [0 limit]] (set res.i (f i1.i i2.i i3.i)))
|
||||
4 (loop [i :range [0 limit]] (set res.i (f i1.i i2.i i3.i i4.i)))
|
||||
1 (loop [i :range [0 limit]] (set (res i) (f (get i1 i))))
|
||||
2 (loop [i :range [0 limit]] (set (res i) (f (get i1 i) (get i2 i))))
|
||||
3 (loop [i :range [0 limit]] (set (res i) (f (get i1 i) (get i2 i) (get i3 i))))
|
||||
4 (loop [i :range [0 limit]] (set (res i) (f (get i1 i) (get i2 i) (get i3 i) (get i4 i))))
|
||||
(loop [i :range [0 limit]]
|
||||
(def args (array/new ninds))
|
||||
(loop [j :range [0 ninds]] (set args.j inds.j.i))
|
||||
(set res.i (f ;args))))
|
||||
(loop [j :range [0 ninds]] (set (args j) (get (get inds j) i)))
|
||||
(set (res i) (f ;args))))
|
||||
res)
|
||||
|
||||
(defn mapcat
|
||||
@ -716,7 +716,7 @@
|
||||
(var i 0)
|
||||
(var going true)
|
||||
(while (if (< i len) going)
|
||||
(def item ind.i)
|
||||
(def item (get ind i))
|
||||
(if (pred item) (set going false) (++ i)))
|
||||
(if going nil i))
|
||||
|
||||
@ -839,7 +839,7 @@
|
||||
(defn walk-dict [f form]
|
||||
(def ret @{})
|
||||
(loop [k :keys form]
|
||||
(put ret (f k) (f form.k)))
|
||||
(put ret (f k) (f (get form k))))
|
||||
ret)
|
||||
|
||||
(defn walk
|
||||
@ -916,7 +916,7 @@
|
||||
(var n (dec len))
|
||||
(def reversed (array/new len))
|
||||
(while (>= n 0)
|
||||
(array/push reversed t.n)
|
||||
(array/push reversed (get t n))
|
||||
(-- n))
|
||||
reversed)
|
||||
|
||||
@ -927,7 +927,7 @@ value, one key will be ignored."
|
||||
[ds]
|
||||
(def ret @{})
|
||||
(loop [k :keys ds]
|
||||
(put ret ds.k k))
|
||||
(put ret (get ds k) k))
|
||||
ret)
|
||||
|
||||
(defn zipcoll
|
||||
@ -939,15 +939,15 @@ value, one key will be ignored."
|
||||
(def lv (length vals))
|
||||
(def len (if (< lk lv) lk lv))
|
||||
(loop [i :range [0 len]]
|
||||
(put res keys.i vals.i))
|
||||
(put res (get keys i) (get vals i)))
|
||||
res)
|
||||
|
||||
(defn update
|
||||
"Accepts a key argument and passes its' associated value to a function.
|
||||
The key then, is associated to the function's return value"
|
||||
[coll a-key a-function & args]
|
||||
(def old-value coll.a-key)
|
||||
(set coll.a-key (a-function old-value ;args)))
|
||||
[ds key func & args]
|
||||
(def old (get ds key))
|
||||
(set (ds key) (func old ;args)))
|
||||
|
||||
(defn merge-into
|
||||
"Merges multiple tables/structs into a table. If a key appears in more than one
|
||||
@ -956,7 +956,7 @@ value, one key will be ignored."
|
||||
[tab & colls]
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(set tab.key c.key))
|
||||
(set (tab key) (get c key)))
|
||||
tab)
|
||||
|
||||
(defn merge
|
||||
@ -967,7 +967,7 @@ value, one key will be ignored."
|
||||
(def container @{})
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(set container.key c.key))
|
||||
(set (container key) (get c key)))
|
||||
container)
|
||||
|
||||
(defn keys
|
||||
@ -986,7 +986,7 @@ value, one key will be ignored."
|
||||
(def arr (array/new (length x)))
|
||||
(var k (next x nil))
|
||||
(while (not= nil k)
|
||||
(array/push arr x.k)
|
||||
(array/push arr (get x k))
|
||||
(set k (next x k)))
|
||||
arr)
|
||||
|
||||
@ -996,7 +996,7 @@ value, one key will be ignored."
|
||||
(def arr (array/new (length x)))
|
||||
(var k (next x nil))
|
||||
(while (not= nil k)
|
||||
(array/push arr (tuple k x.k))
|
||||
(array/push arr (tuple k (get x k)))
|
||||
(set k (next x k)))
|
||||
arr)
|
||||
|
||||
@ -1006,8 +1006,8 @@ value, one key will be ignored."
|
||||
(def freqs @{})
|
||||
(loop
|
||||
[x :in ind]
|
||||
(def n freqs.x)
|
||||
(set freqs.x (if n (+ 1 n) 1)))
|
||||
(def n (get freqs x))
|
||||
(set (freqs x) (if n (+ 1 n) 1)))
|
||||
freqs)
|
||||
|
||||
(defn interleave
|
||||
@ -1020,7 +1020,7 @@ value, one key will be ignored."
|
||||
(def len (min ;(map length cols)))
|
||||
(loop [i :range [0 len]
|
||||
ci :range [0 ncol]]
|
||||
(array/push res cols.ci.i)))
|
||||
(array/push res (get (get cols ci) i))))
|
||||
res)
|
||||
|
||||
(defn distinct
|
||||
@ -1028,7 +1028,7 @@ value, one key will be ignored."
|
||||
[xs]
|
||||
(def ret @[])
|
||||
(def seen @{})
|
||||
(loop [x :in xs] (if seen.x nil (do (set seen.x true) (array/push ret x))))
|
||||
(loop [x :in xs] (if (get seen x) nil (do (put seen x true) (array/push ret x))))
|
||||
ret)
|
||||
|
||||
(defn flatten-into
|
||||
@ -1052,7 +1052,7 @@ value, one key will be ignored."
|
||||
like @[k v k v ...]. Returns a new array."
|
||||
[dict]
|
||||
(def ret (array/new (* 2 (length dict))))
|
||||
(loop [k :keys dict] (array/push ret k dict.k))
|
||||
(loop [k :keys dict] (array/push ret k (get dict k)))
|
||||
ret)
|
||||
|
||||
(defn interpose
|
||||
@ -1064,7 +1064,7 @@ value, one key will be ignored."
|
||||
(if (> len 0) (put ret 0 (get ind 0)))
|
||||
(var i 1)
|
||||
(while (< i len)
|
||||
(array/push ret sep ind.i)
|
||||
(array/push ret sep (get ind i))
|
||||
(++ i))
|
||||
ret)
|
||||
|
||||
@ -1105,7 +1105,7 @@ value, one key will be ignored."
|
||||
(++ i)
|
||||
(if (= i len)
|
||||
(onmatch)
|
||||
(match-1 pattern.i (tuple get $arr i) aux seen))))
|
||||
(match-1 (get pattern i) (tuple get $arr i) aux seen))))
|
||||
,sentinel)))
|
||||
|
||||
(dictionary? pattern)
|
||||
@ -1142,7 +1142,7 @@ value, one key will be ignored."
|
||||
(= i len-1) (get cases i)
|
||||
(< i len-1) (do
|
||||
(def $res (gensym))
|
||||
~(if (= ,sentinel (def ,$res ,(match-1 cases.i $x (fn [] (get cases (inc i))) @{})))
|
||||
~(if (= ,sentinel (def ,$res ,(match-1 (get cases i) $x (fn [] (get cases (inc i))) @{})))
|
||||
,(aux (+ 2 i))
|
||||
,$res)))) 0)))
|
||||
|
||||
@ -1200,19 +1200,19 @@ value, one key will be ignored."
|
||||
(defn doc*
|
||||
"Get the documentation for a symbol in a given environment."
|
||||
[env sym]
|
||||
(def x env.sym)
|
||||
(def x (get env sym))
|
||||
(if (not x)
|
||||
(print "symbol " sym " not found.")
|
||||
(do
|
||||
(def bind-type
|
||||
(string " "
|
||||
(cond
|
||||
x:ref (string :var " (" (type (get x:ref 0)) ")")
|
||||
x:macro :macro
|
||||
(type x:value))
|
||||
(x :ref) (string :var " (" (type (get (x :ref) 0)) ")")
|
||||
(x :macro) :macro
|
||||
(type (x :value)))
|
||||
"\n"))
|
||||
(def sm x:source-map)
|
||||
(def d x:doc)
|
||||
(def sm (x :source-map))
|
||||
(def d (x :doc))
|
||||
(print "\n\n"
|
||||
(if d bind-type "")
|
||||
(if-let [[path start end] sm] (string " " path " (" start ":" end ")\n") "")
|
||||
@ -1239,7 +1239,7 @@ value, one key will be ignored."
|
||||
(def newt @{})
|
||||
(var key (next t nil))
|
||||
(while (not= nil key)
|
||||
(put newt (macex1 key) (on-value t.key))
|
||||
(put newt (macex1 key) (on-value (get t key)))
|
||||
(set key (next t key)))
|
||||
newt)
|
||||
|
||||
@ -1301,10 +1301,10 @@ value, one key will be ignored."
|
||||
|
||||
(defn dotup [t]
|
||||
(def h (get t 0))
|
||||
(def s specs.h)
|
||||
(def entry (or *env*.h {}))
|
||||
(def m entry:value)
|
||||
(def m? entry:macro)
|
||||
(def s (get specs h))
|
||||
(def entry (or (get *env* h) {}))
|
||||
(def m (entry :value))
|
||||
(def m? (entry :macro))
|
||||
(cond
|
||||
s (s t)
|
||||
m? (m ;(tuple/slice t 1))
|
||||
@ -1527,7 +1527,7 @@ value, one key will be ignored."
|
||||
(def res (compile form *env* "eval"))
|
||||
(if (= (type res) :function)
|
||||
(res)
|
||||
(error res:error)))
|
||||
(error (res :error))))
|
||||
|
||||
(do
|
||||
(def syspath (or (os/getenv "JANET_PATH") "/usr/local/lib/janet/"))
|
||||
@ -1600,17 +1600,17 @@ value, one key will be ignored."
|
||||
(def cache @{})
|
||||
(def loading @{})
|
||||
(fn require [path & args]
|
||||
(when loading.path
|
||||
(when (get loading path)
|
||||
(error (string "circular dependency: module " path " is loading")))
|
||||
(def {:exit exit-on-error} (table ;args))
|
||||
(if-let [check cache.path]
|
||||
(if-let [check (get cache path)]
|
||||
check
|
||||
(if-let [f (find-mod path)]
|
||||
(do
|
||||
# Normal janet module
|
||||
(def newenv (make-env))
|
||||
(set cache.path newenv)
|
||||
(set loading.path true)
|
||||
(put cache path newenv)
|
||||
(put loading path true)
|
||||
(defn chunks [buf _] (file/read f 1024 buf))
|
||||
(run-context newenv chunks
|
||||
(fn [sig x f source]
|
||||
@ -1619,7 +1619,7 @@ value, one key will be ignored."
|
||||
(if exit-on-error (os/exit 1))))
|
||||
path)
|
||||
(file/close f)
|
||||
(set loading.path false)
|
||||
(put loading path false)
|
||||
newenv)
|
||||
(do
|
||||
# Try native module
|
||||
@ -1637,7 +1637,7 @@ value, one key will be ignored."
|
||||
:prefix prefix} (table ;args))
|
||||
(def newenv (require path ;args))
|
||||
(def prefix (or (and as (string as "/")) prefix (string path "/")))
|
||||
(loop [[k v] :pairs newenv :when (not v:private)]
|
||||
(loop [[k v] :pairs newenv :when (not (v :private))]
|
||||
(def newv (table/setproto @{:private true} v))
|
||||
(put env (symbol prefix k) newv)))
|
||||
|
||||
@ -1680,5 +1680,5 @@ value, one key will be ignored."
|
||||
(def symbol-set @{})
|
||||
(loop [envi :in envs
|
||||
k :keys envi]
|
||||
(set symbol-set.k true))
|
||||
(put symbol-set k true))
|
||||
(sort (keys symbol-set)))
|
||||
|
||||
@ -1,107 +0,0 @@
|
||||
/*
|
||||
* Copyright (c) 2019 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_keywordv(sympart + 1, len - 1));
|
||||
} else {
|
||||
double index;
|
||||
if (janet_scan_number(sympart + 1, len - 1, &index)) {
|
||||
/* not a number */
|
||||
return janetc_resolve(c, janet_symbol(sympart + 1, len - 1));
|
||||
} else {
|
||||
/* is a number */
|
||||
return janetc_cslot(janet_wrap_number(index));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
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) {
|
||||
return multisym_do_parts(opts, 0, sym, janet_wrap_nil());
|
||||
}
|
||||
|
||||
/* 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);
|
||||
}
|
||||
@ -182,19 +182,47 @@ static const Janet *janetc_make_sourcemap(JanetCompiler *c) {
|
||||
}
|
||||
|
||||
static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) {
|
||||
/*JanetFopts subopts = janetc_fopts_default(opts.compiler);*/
|
||||
/*JanetSlot ret, dest;*/
|
||||
Janet head;
|
||||
if (argn != 2) {
|
||||
janetc_cerror(opts.compiler, "expected 2 arguments");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
head = argv[0];
|
||||
if (!janet_checktype(head, JANET_SYMBOL)) {
|
||||
janetc_cerror(opts.compiler, "expected symbol");
|
||||
JanetFopts subopts = janetc_fopts_default(opts.compiler);
|
||||
if (janet_checktype(argv[0], JANET_SYMBOL)) {
|
||||
/* Normal var - (set a 1) */
|
||||
const uint8_t *sym = janet_unwrap_symbol(argv[0]);
|
||||
JanetSlot 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;
|
||||
JanetSlot ret = janetc_value(subopts, argv[1]);
|
||||
janetc_copy(opts.compiler, dest, ret);
|
||||
return ret;
|
||||
} else if (janet_checktype(argv[0], JANET_TUPLE)) {
|
||||
/* Set a field (setf behavior) - (set (tab :key) 2) */
|
||||
const Janet *tup = janet_unwrap_tuple(argv[0]);
|
||||
/* Tuple must have 2 elements */
|
||||
if (janet_tuple_length(tup) != 2) {
|
||||
janetc_cerror(opts.compiler, "expected 2 element tuple for l-value to set");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
JanetSlot ds = janetc_value(subopts, tup[0]);
|
||||
JanetSlot key = janetc_value(subopts, tup[1]);
|
||||
/* Can't be tail position because we will emit a PUT instruction afterwards */
|
||||
/* Also can't drop either */
|
||||
opts.flags &= ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP);
|
||||
JanetSlot rvalue = janetc_value(opts, argv[1]);
|
||||
/* Emit the PUT instruction */
|
||||
janetc_emit_sss(opts.compiler, JOP_PUT, ds, key, rvalue, 0);
|
||||
return rvalue;
|
||||
} else {
|
||||
/* Error */
|
||||
janet_inspect(argv[0]);
|
||||
janetc_cerror(opts.compiler, "expected symbol or tuple for l-value to set");
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
}
|
||||
return janetc_sym_lvalue(opts, janet_unwrap_symbol(head), argv[1]);
|
||||
}
|
||||
|
||||
/* Add attributes to a global def or var table */
|
||||
|
||||
@ -76,6 +76,20 @@
|
||||
[name]
|
||||
(string "build" sep name modext))
|
||||
|
||||
(defn- make-define
|
||||
"Generate strings for adding custom defines to the compiler."
|
||||
[define value]
|
||||
(def prefix (if is-win "\\D" "-D"))
|
||||
(if value
|
||||
(string prefix define "=" value)
|
||||
(string prefix define)))
|
||||
|
||||
(defn- make-defines
|
||||
"Generate many defines. Takes a dictionary of defines. If a value is
|
||||
true, generates -DNAME (\\DNAME on windows), otherwise -DNAME=value."
|
||||
[defines]
|
||||
(seq [[d v] :pairs defines] (make-define d (if (not= v true) v))))
|
||||
|
||||
# Defaults
|
||||
(def OPTIMIZE 2)
|
||||
(def CC (if is-win "cl" "cc"))
|
||||
@ -85,18 +99,19 @@
|
||||
(defn- compile-c
|
||||
"Compile a C file into an object file."
|
||||
[opts src dest]
|
||||
(def cc (or opts:compiler CC))
|
||||
(def cflags (or opts:cflags CFLAGS))
|
||||
(def cc (or (opts :compiler) CC))
|
||||
(def cflags (or (opts :cflags) CFLAGS))
|
||||
(def defines (interpose " " (make-defines (or (opts :defines) {}))))
|
||||
(if (older-than dest src)
|
||||
(if is-win
|
||||
(shell cc " /nologo /c " cflags " /Fo" dest " " src)
|
||||
(shell cc " " cflags " -o " dest " -c " src))))
|
||||
(shell cc " " ;defines " /nologo /c " cflags " /Fo" dest " " src)
|
||||
(shell cc " " ;defines " " cflags " -o " dest " -c " src))))
|
||||
|
||||
(defn- link-c
|
||||
"Link a number of object files together."
|
||||
[opts target & objects]
|
||||
(def ld (or opts:linker LD))
|
||||
(def cflags (or opts:cflags CFLAGS))
|
||||
(def ld (or (opts :linker) LD))
|
||||
(def cflags (or (opts :cflags) CFLAGS))
|
||||
(def olist (string/join objects " "))
|
||||
(if (older-than-some target objects)
|
||||
(if is-win
|
||||
@ -129,17 +144,19 @@
|
||||
[& opts]
|
||||
(def opt-table (table ;opts))
|
||||
(mkdir "build")
|
||||
(loop [src :in opt-table:source]
|
||||
(def sources (opt-table :source))
|
||||
(def name (opt-table :name))
|
||||
(loop [src :in sources]
|
||||
(compile-c opt-table src (object-name src)))
|
||||
(def objects (map object-name opt-table:source))
|
||||
(when opt-table:embedded
|
||||
(loop [src :in opt-table:embedded]
|
||||
(def objects (map object-name sources))
|
||||
(when-let [embedded (opt-table :embedded)]
|
||||
(loop [src :in embedded]
|
||||
(def c-src (embed-c-name src))
|
||||
(def o-src (embed-o-name src))
|
||||
(array/push objects o-src)
|
||||
(create-buffer-c src c-src (embed-name src))
|
||||
(compile-c opt-table c-src o-src)))
|
||||
(link-c opt-table (lib-name opt-table:name) ;objects))
|
||||
(link-c opt-table (lib-name name) ;objects))
|
||||
|
||||
(defn clean
|
||||
"Remove all built artifacts."
|
||||
|
||||
@ -44,7 +44,7 @@
|
||||
"Trim leading newlines"
|
||||
[str]
|
||||
(var i 0)
|
||||
(while (= 10 str.i) (++ i))
|
||||
(while (= 10 (get str i)) (++ i))
|
||||
(string/slice str i))
|
||||
|
||||
(defn- html-escape
|
||||
@ -52,7 +52,7 @@
|
||||
[str]
|
||||
(def buf @"")
|
||||
(loop [byte :in str]
|
||||
(if-let [rep escapes.byte]
|
||||
(if-let [rep (get escapes byte)]
|
||||
(buffer/push-string buf rep)
|
||||
(buffer/push-byte buf byte)))
|
||||
buf)
|
||||
@ -90,7 +90,7 @@
|
||||
# Generate parts and print them to stdout
|
||||
(def parts (seq [[k entry]
|
||||
:in (sort (pairs (table/getproto _env)))
|
||||
:when (and entry:doc (not entry:private))]
|
||||
:when (and (get entry :doc) (not (get entry :private)))]
|
||||
(emit-item k entry)))
|
||||
(print
|
||||
prelude
|
||||
|
||||
@ -1,12 +1,10 @@
|
||||
#
|
||||
# Tool to dump a marshalled version of the janet core to stdout. The
|
||||
# image should eventually allow janet to be started from a pre-compiled
|
||||
# image rather than recompiled every time from the embedded source. More
|
||||
# work will go into shrinking the image (it isn't currently that large but
|
||||
# could be smaller), creating the mechanism to load the image, and modifying
|
||||
# the build process to compile janet with a build int image rather than
|
||||
# the build process to compile janet with a built image rather than
|
||||
# embedded source.
|
||||
#
|
||||
|
||||
# Get image. This image contains as much of the core library and documentation that
|
||||
# can be written to an image (no cfunctions, no abstracts (stdout, stdin, stderr)),
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
# Helper to generate core library mappings for janet
|
||||
# Used to help build the tmLanguage grammar.
|
||||
|
||||
(def allsyms (all-symbols))
|
||||
|
||||
@ -22,7 +23,7 @@
|
||||
[str]
|
||||
(def buf @"")
|
||||
(loop [byte :in str]
|
||||
(if-let [rep escapes.byte]
|
||||
(if-let [rep (get escapes byte)]
|
||||
(buffer/push-string buf rep)
|
||||
(buffer/push-byte buf byte)))
|
||||
buf)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user