1
0
mirror of https://github.com/janet-lang/janet synced 2025-01-26 15:16:51 +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 2019-01-06 19:33:27 -05:00
parent 92e9e64945
commit eae4e0dede
11 changed files with 138 additions and 207 deletions

View File

@ -5,10 +5,10 @@
(def solutions @{}) (def solutions @{})
(def len (length s)) (def len (length s))
(for k 0 len (for k 0 len
(put tab s.k k)) (put tab (s k) k))
(for i 0 len (for i 0 len
(for j 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)) (when (and k (not= k i) (not= k j) (not= i j))
(put solutions {i true j true k true} true)))) (put solutions {i true j true k true} true))))
(map keys (keys solutions))) (map keys (keys solutions)))

View File

@ -16,7 +16,7 @@
(def cell-set (frequencies state)) (def cell-set (frequencies state))
(def neighbor-set (frequencies (mapcat neighbors state))) (def neighbor-set (frequencies (mapcat neighbors state)))
(seq [coord :keys neighbor-set (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)))] :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 @{})
(each cell state (set 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)]]

View File

@ -553,7 +553,7 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) {
} }
break; break;
case JANET_SYMBOL: case JANET_SYMBOL:
ret = janetc_sym_rvalue(opts, janet_unwrap_symbol(x)); ret = janetc_resolve(opts.compiler, janet_unwrap_symbol(x));
break; break;
case JANET_ARRAY: case JANET_ARRAY:
ret = janetc_array(opts, x); ret = janetc_array(opts, x);

View File

@ -240,10 +240,4 @@ 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

@ -29,14 +29,14 @@
(array/push modifiers ith)) (array/push modifiers ith))
(if (< i len) (recur (+ i 1))))))) (if (< i len) (recur (+ i 1)))))))
(def start (fstart 0)) (def start (fstart 0))
(def args more.start) (def args (get more start))
# Add function signature to docstring # Add function signature to docstring
(var index 0) (var index 0)
(def arglen (length args)) (def arglen (length args))
(def buf (buffer "(" name)) (def buf (buffer "(" name))
(while (< index arglen) (while (< index arglen)
(buffer/push-string buf " ") (buffer/push-string buf " ")
(string/pretty args.index 4 buf) (string/pretty (get args index) 4 buf)
(set index (+ index 1))) (set index (+ index 1)))
(array/push modifiers (string buf ")\n\n" docstr)) (array/push modifiers (string buf ")\n\n" docstr))
# Build return value # Build return value
@ -186,8 +186,8 @@
(defn aux [i] (defn aux [i]
(def restlen (- (length pairs) i)) (def restlen (- (length pairs) i))
(if (= restlen 0) nil (if (= restlen 0) nil
(if (= restlen 1) pairs.i (if (= restlen 1) (get pairs i)
(tuple 'if pairs.i (tuple 'if (get pairs i)
(get pairs (+ i 1)) (get pairs (+ i 1))
(aux (+ i 2)))))) (aux (+ i 2))))))
(aux 0)) (aux 0))
@ -202,8 +202,8 @@
(defn aux [i] (defn aux [i]
(def restlen (- (length pairs) i)) (def restlen (- (length pairs) i))
(if (= restlen 0) nil (if (= restlen 0) nil
(if (= restlen 1) pairs.i (if (= restlen 1) (get pairs i)
(tuple 'if (tuple = sym pairs.i) (tuple 'if (tuple = sym (get pairs i))
(get pairs (+ i 1)) (get pairs (+ i 1))
(aux (+ i 2)))))) (aux (+ i 2))))))
(if atm (if atm
@ -254,8 +254,8 @@
(while (> i 0) (while (> i 0)
(-- i) (-- i)
(set ret (if (= ret true) (set ret (if (= ret true)
forms.i (get forms i)
(tuple 'if forms.i ret)))) (tuple 'if (get forms i) ret))))
ret) ret)
(defmacro or (defmacro or
@ -267,7 +267,7 @@
(var i len) (var i len)
(while (> i 0) (while (> i 0)
(-- i) (-- i)
(def fi forms.i) (def fi (get forms i))
(set ret (if (idempotent? fi) (set ret (if (idempotent? fi)
(tuple 'if fi fi ret) (tuple 'if fi fi ret)
(do (do
@ -477,7 +477,7 @@
(if (zero? len) (error "expected at least 1 binding")) (if (zero? len) (error "expected at least 1 binding"))
(if (odd? len) (error "expected an even number of bindings")) (if (odd? len) (error "expected an even number of bindings"))
(defn aux [i] (defn aux [i]
(def bl bindings.i) (def bl (get bindings i))
(def br (get bindings (+ 1 i))) (def br (get bindings (+ 1 i)))
(if (>= i len) (if (>= i len)
tru tru
@ -537,7 +537,7 @@
(when (pos? len) (when (pos? len)
(var [ret] args) (var [ret] args)
(loop [i :range [0 len]] (loop [i :range [0 len]]
(def v args.i) (def v (get args i))
(if (order v ret) (set ret v))) (if (order v ret) (set ret v)))
ret)) ret))
@ -581,17 +581,17 @@
(defn partition (defn partition
[a lo hi by] [a lo hi by]
(def pivot a.hi) (def pivot (get a hi))
(var i lo) (var i lo)
(loop [j :range [lo hi]] (loop [j :range [lo hi]]
(def aj a.j) (def aj (get a j))
(when (by aj pivot) (when (by aj pivot)
(def ai a.i) (def ai (get a i))
(set a.i aj) (set (a i) aj)
(set a.j ai) (set (a j) ai)
(++ i))) (++ i)))
(set a.hi a.i) (set (a hi) (get a i))
(set a.i pivot) (set (a i) pivot)
i) i)
(defn sort-help (defn sort-help
@ -627,19 +627,19 @@
(if (= 0 ninds) (error "expected at least 1 indexed collection")) (if (= 0 ninds) (error "expected at least 1 indexed collection"))
(var limit (length (get inds 0))) (var limit (length (get inds 0)))
(loop [i :range [0 ninds]] (loop [i :range [0 ninds]]
(def l (length inds.i)) (def l (length (get inds i)))
(if (< l limit) (set limit l))) (if (< l limit) (set limit l)))
(def [i1 i2 i3 i4] inds) (def [i1 i2 i3 i4] inds)
(def res (array/new limit)) (def res (array/new limit))
(case ninds (case ninds
1 (loop [i :range [0 limit]] (set res.i (f i1.i))) 1 (loop [i :range [0 limit]] (set (res i) (f (get i1 i))))
2 (loop [i :range [0 limit]] (set res.i (f i1.i i2.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 i1.i i2.i i3.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 i1.i i2.i i3.i i4.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]] (loop [i :range [0 limit]]
(def args (array/new ninds)) (def args (array/new ninds))
(loop [j :range [0 ninds]] (set args.j inds.j.i)) (loop [j :range [0 ninds]] (set (args j) (get (get inds j) i)))
(set res.i (f ;args)))) (set (res i) (f ;args))))
res) res)
(defn mapcat (defn mapcat
@ -716,7 +716,7 @@
(var i 0) (var i 0)
(var going true) (var going true)
(while (if (< i len) going) (while (if (< i len) going)
(def item ind.i) (def item (get ind i))
(if (pred item) (set going false) (++ i))) (if (pred item) (set going false) (++ i)))
(if going nil i)) (if going nil i))
@ -839,7 +839,7 @@
(defn walk-dict [f form] (defn walk-dict [f form]
(def ret @{}) (def ret @{})
(loop [k :keys form] (loop [k :keys form]
(put ret (f k) (f form.k))) (put ret (f k) (f (get form k))))
ret) ret)
(defn walk (defn walk
@ -916,7 +916,7 @@
(var n (dec len)) (var n (dec len))
(def reversed (array/new len)) (def reversed (array/new len))
(while (>= n 0) (while (>= n 0)
(array/push reversed t.n) (array/push reversed (get t n))
(-- n)) (-- n))
reversed) reversed)
@ -927,7 +927,7 @@ value, one key will be ignored."
[ds] [ds]
(def ret @{}) (def ret @{})
(loop [k :keys ds] (loop [k :keys ds]
(put ret ds.k k)) (put ret (get ds k) k))
ret) ret)
(defn zipcoll (defn zipcoll
@ -939,15 +939,15 @@ value, one key will be ignored."
(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 keys.i vals.i)) (put res (get keys i) (get vals i)))
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.
The key then, is associated to the function's return value" The key then, is associated to the function's return value"
[coll a-key a-function & args] [ds key func & args]
(def old-value coll.a-key) (def old (get ds key))
(set coll.a-key (a-function old-value ;args))) (set (ds key) (func old ;args)))
(defn merge-into (defn merge-into
"Merges multiple tables/structs into a table. If a key appears in more than one "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] [tab & colls]
(loop [c :in colls (loop [c :in colls
key :keys c] key :keys c]
(set tab.key c.key)) (set (tab key) (get c key)))
tab) tab)
(defn merge (defn merge
@ -967,7 +967,7 @@ value, one key will be ignored."
(def container @{}) (def container @{})
(loop [c :in colls (loop [c :in colls
key :keys c] key :keys c]
(set container.key c.key)) (set (container key) (get c key)))
container) container)
(defn keys (defn keys
@ -986,7 +986,7 @@ value, one key will be ignored."
(def arr (array/new (length x))) (def arr (array/new (length x)))
(var k (next x nil)) (var k (next x nil))
(while (not= nil k) (while (not= nil k)
(array/push arr x.k) (array/push arr (get x k))
(set k (next x k))) (set k (next x k)))
arr) arr)
@ -996,7 +996,7 @@ value, one key will be ignored."
(def arr (array/new (length x))) (def arr (array/new (length x)))
(var k (next x nil)) (var k (next x nil))
(while (not= nil k) (while (not= nil k)
(array/push arr (tuple k x.k)) (array/push arr (tuple k (get x k)))
(set k (next x k))) (set k (next x k)))
arr) arr)
@ -1006,8 +1006,8 @@ value, one key will be ignored."
(def freqs @{}) (def freqs @{})
(loop (loop
[x :in ind] [x :in ind]
(def n freqs.x) (def n (get freqs x))
(set freqs.x (if n (+ 1 n) 1))) (set (freqs x) (if n (+ 1 n) 1)))
freqs) freqs)
(defn interleave (defn interleave
@ -1020,7 +1020,7 @@ value, one key will be ignored."
(def len (min ;(map length cols))) (def len (min ;(map length cols)))
(loop [i :range [0 len] (loop [i :range [0 len]
ci :range [0 ncol]] ci :range [0 ncol]]
(array/push res cols.ci.i))) (array/push res (get (get cols ci) i))))
res) res)
(defn distinct (defn distinct
@ -1028,7 +1028,7 @@ value, one key will be ignored."
[xs] [xs]
(def ret @[]) (def ret @[])
(def seen @{}) (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) ret)
(defn flatten-into (defn flatten-into
@ -1052,7 +1052,7 @@ value, one key will be ignored."
like @[k v k v ...]. Returns a new array." like @[k v k v ...]. Returns a new array."
[dict] [dict]
(def ret (array/new (* 2 (length 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) ret)
(defn interpose (defn interpose
@ -1064,7 +1064,7 @@ value, one key will be ignored."
(if (> len 0) (put ret 0 (get ind 0))) (if (> len 0) (put ret 0 (get ind 0)))
(var i 1) (var i 1)
(while (< i len) (while (< i len)
(array/push ret sep ind.i) (array/push ret sep (get ind i))
(++ i)) (++ i))
ret) ret)
@ -1105,7 +1105,7 @@ value, one key will be ignored."
(++ i) (++ i)
(if (= i len) (if (= i len)
(onmatch) (onmatch)
(match-1 pattern.i (tuple get $arr i) aux seen)))) (match-1 (get pattern i) (tuple get $arr i) aux seen))))
,sentinel))) ,sentinel)))
(dictionary? pattern) (dictionary? pattern)
@ -1142,7 +1142,7 @@ value, one key will be ignored."
(= i len-1) (get cases i) (= i len-1) (get cases i)
(< i len-1) (do (< i len-1) (do
(def $res (gensym)) (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)) ,(aux (+ 2 i))
,$res)))) 0))) ,$res)))) 0)))
@ -1200,19 +1200,19 @@ value, one key will be ignored."
(defn doc* (defn doc*
"Get the documentation for a symbol in a given environment." "Get the documentation for a symbol in a given environment."
[env sym] [env sym]
(def x env.sym) (def x (get env sym))
(if (not x) (if (not x)
(print "symbol " sym " not found.") (print "symbol " sym " not found.")
(do (do
(def bind-type (def bind-type
(string " " (string " "
(cond (cond
x:ref (string :var " (" (type (get x:ref 0)) ")") (x :ref) (string :var " (" (type (get (x :ref) 0)) ")")
x:macro :macro (x :macro) :macro
(type x:value)) (type (x :value)))
"\n")) "\n"))
(def sm x:source-map) (def sm (x :source-map))
(def d x:doc) (def d (x :doc))
(print "\n\n" (print "\n\n"
(if d bind-type "") (if d bind-type "")
(if-let [[path start end] sm] (string " " path " (" start ":" end ")\n") "") (if-let [[path start end] sm] (string " " path " (" start ":" end ")\n") "")
@ -1239,7 +1239,7 @@ value, one key will be ignored."
(def newt @{}) (def newt @{})
(var key (next t nil)) (var key (next t nil))
(while (not= nil key) (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))) (set key (next t key)))
newt) newt)
@ -1301,10 +1301,10 @@ value, one key will be ignored."
(defn dotup [t] (defn dotup [t]
(def h (get t 0)) (def h (get t 0))
(def s specs.h) (def s (get specs h))
(def entry (or *env*.h {})) (def entry (or (get *env* h) {}))
(def m entry:value) (def m (entry :value))
(def m? entry:macro) (def m? (entry :macro))
(cond (cond
s (s t) s (s t)
m? (m ;(tuple/slice t 1)) m? (m ;(tuple/slice t 1))
@ -1527,7 +1527,7 @@ value, one key will be ignored."
(def res (compile form *env* "eval")) (def res (compile form *env* "eval"))
(if (= (type res) :function) (if (= (type res) :function)
(res) (res)
(error res:error))) (error (res :error))))
(do (do
(def syspath (or (os/getenv "JANET_PATH") "/usr/local/lib/janet/")) (def syspath (or (os/getenv "JANET_PATH") "/usr/local/lib/janet/"))
@ -1600,17 +1600,17 @@ value, one key will be ignored."
(def cache @{}) (def cache @{})
(def loading @{}) (def loading @{})
(fn require [path & args] (fn require [path & args]
(when loading.path (when (get loading path)
(error (string "circular dependency: module " path " is loading"))) (error (string "circular dependency: module " path " is loading")))
(def {:exit exit-on-error} (table ;args)) (def {:exit exit-on-error} (table ;args))
(if-let [check cache.path] (if-let [check (get cache path)]
check check
(if-let [f (find-mod path)] (if-let [f (find-mod path)]
(do (do
# Normal janet module # Normal janet module
(def newenv (make-env)) (def newenv (make-env))
(set cache.path newenv) (put cache path newenv)
(set loading.path true) (put loading path true)
(defn chunks [buf _] (file/read f 1024 buf)) (defn chunks [buf _] (file/read f 1024 buf))
(run-context newenv chunks (run-context newenv chunks
(fn [sig x f source] (fn [sig x f source]
@ -1619,7 +1619,7 @@ value, one key will be ignored."
(if exit-on-error (os/exit 1)))) (if exit-on-error (os/exit 1))))
path) path)
(file/close f) (file/close f)
(set loading.path false) (put loading path false)
newenv) newenv)
(do (do
# Try native module # Try native module
@ -1637,7 +1637,7 @@ value, one key will be ignored."
:prefix prefix} (table ;args)) :prefix prefix} (table ;args))
(def newenv (require path ;args)) (def newenv (require path ;args))
(def prefix (or (and as (string as "/")) prefix (string path "/"))) (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)) (def newv (table/setproto @{:private true} v))
(put env (symbol prefix k) newv))) (put env (symbol prefix k) newv)))
@ -1680,5 +1680,5 @@ value, one key will be ignored."
(def symbol-set @{}) (def symbol-set @{})
(loop [envi :in envs (loop [envi :in envs
k :keys envi] k :keys envi]
(set symbol-set.k true)) (put symbol-set k true))
(sort (keys symbol-set))) (sort (keys symbol-set)))

View File

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

View File

@ -182,19 +182,47 @@ static const Janet *janetc_make_sourcemap(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);*/
/*JanetSlot ret, dest;*/
Janet head;
if (argn != 2) { if (argn != 2) {
janetc_cerror(opts.compiler, "expected 2 arguments"); janetc_cerror(opts.compiler, "expected 2 arguments");
return janetc_cslot(janet_wrap_nil()); return janetc_cslot(janet_wrap_nil());
} }
head = argv[0]; JanetFopts subopts = janetc_fopts_default(opts.compiler);
if (!janet_checktype(head, JANET_SYMBOL)) { if (janet_checktype(argv[0], JANET_SYMBOL)) {
janetc_cerror(opts.compiler, "expected 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_cslot(janet_wrap_nil());
} }
return janetc_sym_lvalue(opts, janet_unwrap_symbol(head), argv[1]);
} }
/* Add attributes to a global def or var table */ /* Add attributes to a global def or var table */

View File

@ -76,6 +76,20 @@
[name] [name]
(string "build" sep name modext)) (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 # Defaults
(def OPTIMIZE 2) (def OPTIMIZE 2)
(def CC (if is-win "cl" "cc")) (def CC (if is-win "cl" "cc"))
@ -85,18 +99,19 @@
(defn- compile-c (defn- compile-c
"Compile a C file into an object file." "Compile a C file into an object file."
[opts src dest] [opts src dest]
(def cc (or opts:compiler CC)) (def cc (or (opts :compiler) CC))
(def cflags (or opts:cflags CFLAGS)) (def cflags (or (opts :cflags) CFLAGS))
(def defines (interpose " " (make-defines (or (opts :defines) {}))))
(if (older-than dest src) (if (older-than dest src)
(if is-win (if is-win
(shell cc " /nologo /c " cflags " /Fo" dest " " src) (shell cc " " ;defines " /nologo /c " cflags " /Fo" dest " " src)
(shell cc " " cflags " -o " dest " -c " src)))) (shell cc " " ;defines " " cflags " -o " dest " -c " src))))
(defn- link-c (defn- link-c
"Link a number of object files together." "Link a number of object files together."
[opts target & objects] [opts target & objects]
(def ld (or opts:linker LD)) (def ld (or (opts :linker) LD))
(def cflags (or opts:cflags CFLAGS)) (def cflags (or (opts :cflags) CFLAGS))
(def olist (string/join objects " ")) (def olist (string/join objects " "))
(if (older-than-some target objects) (if (older-than-some target objects)
(if is-win (if is-win
@ -129,17 +144,19 @@
[& opts] [& opts]
(def opt-table (table ;opts)) (def opt-table (table ;opts))
(mkdir "build") (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))) (compile-c opt-table src (object-name src)))
(def objects (map object-name opt-table:source)) (def objects (map object-name sources))
(when opt-table:embedded (when-let [embedded (opt-table :embedded)]
(loop [src :in opt-table:embedded] (loop [src :in embedded]
(def c-src (embed-c-name src)) (def c-src (embed-c-name src))
(def o-src (embed-o-name src)) (def o-src (embed-o-name src))
(array/push objects o-src) (array/push objects o-src)
(create-buffer-c src c-src (embed-name src)) (create-buffer-c src c-src (embed-name src))
(compile-c opt-table c-src o-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 (defn clean
"Remove all built artifacts." "Remove all built artifacts."

View File

@ -44,7 +44,7 @@
"Trim leading newlines" "Trim leading newlines"
[str] [str]
(var i 0) (var i 0)
(while (= 10 str.i) (++ i)) (while (= 10 (get str i)) (++ i))
(string/slice str i)) (string/slice str i))
(defn- html-escape (defn- html-escape
@ -52,7 +52,7 @@
[str] [str]
(def buf @"") (def buf @"")
(loop [byte :in str] (loop [byte :in str]
(if-let [rep escapes.byte] (if-let [rep (get escapes byte)]
(buffer/push-string buf rep) (buffer/push-string buf rep)
(buffer/push-byte buf byte))) (buffer/push-byte buf byte)))
buf) buf)
@ -90,7 +90,7 @@
# Generate parts and print them to stdout # Generate parts and print them to stdout
(def parts (seq [[k entry] (def parts (seq [[k entry]
:in (sort (pairs (table/getproto _env))) :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))) (emit-item k entry)))
(print (print
prelude prelude

View File

@ -1,12 +1,10 @@
#
# Tool to dump a marshalled version of the janet core to stdout. The # 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 should eventually allow janet to be started from a pre-compiled
# image rather than recompiled every time from the embedded source. More # 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 # 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 # 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. # embedded source.
#
# Get image. This image contains as much of the core library and documentation that # 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)), # can be written to an image (no cfunctions, no abstracts (stdout, stdin, stderr)),

View File

@ -1,4 +1,5 @@
# Helper to generate core library mappings for janet # Helper to generate core library mappings for janet
# Used to help build the tmLanguage grammar.
(def allsyms (all-symbols)) (def allsyms (all-symbols))
@ -22,7 +23,7 @@
[str] [str]
(def buf @"") (def buf @"")
(loop [byte :in str] (loop [byte :in str]
(if-let [rep escapes.byte] (if-let [rep (get escapes byte)]
(buffer/push-string buf rep) (buffer/push-string buf rep)
(buffer/push-byte buf byte))) (buffer/push-byte buf byte)))
buf) buf)