mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2025-10-30 15:13:03 +00:00
Code Issues 1 Releases Wiki Activity

Replace unquote-splicing with a more general splce special form.

Browse Source 
This allows splicing behavior in normal function calls.
This commit is contained in:
Calvin Rose
2018-12-05 15:10:04 -05:00
parent 484597eaae
commit 89bd38890e
4 changed files with 90 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

43
src/core/compile.c
View File

@@ -321,12 +321,40 @@ JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds) {
/* Push slots load via janetc_toslots. */
void janetc_pushslots(JanetCompiler *c, JanetSlot *slots) {
int32_t i;
for (i = 0; i < janet_v_count(slots) - 2; i += 3)
janetc_emit_sss(c, JOP_PUSH_3, slots[i], slots[i+1], slots[i+2], 0);
if (i == janet_v_count(slots) - 2)
janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i+1], 0);
else if (i == janet_v_count(slots) - 1)
janetc_emit_s(c, JOP_PUSH, slots[i], 0);
int32_t count = janet_v_count(slots);
for (i = 0; i < count;) {
if (slots[i].flags & JANET_SLOT_SPLICED) {
janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i], 0);
i++;
} else if (i + 1 == count) {
janetc_emit_s(c, JOP_PUSH, slots[i], 0);
i++;
} else if (slots[i + 1].flags & JANET_SLOT_SPLICED) {
janetc_emit_s(c, JOP_PUSH, slots[i], 0);
janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i+1], 0);
i += 2;
} else if (i + 2 == count) {
janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i+1], 0);
i += 2;
} else if (slots[i + 2].flags & JANET_SLOT_SPLICED) {
janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i+1], 0);
janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i+2], 0);
i += 3;
} else {
janetc_emit_sss(c, JOP_PUSH_3, slots[i], slots[i+1], slots[i+2], 0);
i += 3;
}
}
}
/* Check if a list of slots has any spliced slots */
static int has_spliced(JanetSlot *slots) {
int32_t i;
for (i = 0; i < janet_v_count(slots); i++) {
if (slots[i].flags & JANET_SLOT_SPLICED)
return 1;
}
return 0;
}
/* Free slots loaded via janetc_toslots */
@@ -361,7 +389,7 @@ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) {
JanetSlot retslot;
JanetCompiler *c = opts.compiler;
int specialized = 0;
if (fun.flags & JANET_SLOT_CONSTANT) {
if (fun.flags & JANET_SLOT_CONSTANT && !has_spliced(slots)) {
if (janet_checktype(fun.constant, JANET_FUNCTION)) {
JanetFunction *f = janet_unwrap_function(fun.constant);
const JanetFunOptimizer *o = janetc_funopt(f->def->flags);
@@ -521,6 +549,7 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) {
ret = janetc_call(opts, janetc_toslots(c, tup + 1, janet_tuple_length(tup) - 1), head);
janetc_freeslot(c, head);
}
ret.flags &= ~JANET_SLOT_SPLICED;
}
break;
case JANET_SYMBOL:

54
src/core/core.janet
View File

@@ -40,7 +40,7 @@
(:= index (+ index 1)))
(array/push modifiers (string buf ")\n\n" docstr))
# Build return value
~(def ,name ;modifiers (fn ,name ;(tuple/slice more start)))))
~(def ,name ,;modifiers (fn ,name ,;(tuple/slice more start)))))
(defn defmacro :macro
"Define a macro."
@@ -60,7 +60,7 @@
(defmacro def-
"Define a private value that will not be exported."
[name & more]
~(def name :private ;more))
~(def name :private ,;more))
(defn defglobal
"Dynamically create a global def."
@@ -165,12 +165,12 @@
(defmacro when
"Evaluates the body when the condition is true. Otherwise returns nil."
[condition & body]
~(if ,condition (do ;body)))
~(if ,condition (do ,;body)))
(defmacro unless
"Shorthand for (when (not ... "
[condition & body]
~(if ,condition nil (do ;body)))
~(if ,condition nil (do ,;body)))
(defmacro cond
"Evaluates conditions sequentially until the first true condition
@@ -404,7 +404,7 @@
"Create a generator expression using the loop syntax. Returns a fiber
that yields all values inside the loop in order. See loop for details."
[head & body]
~(fiber/new (fn [&] (loop ,head (yield (do ;body))))))
~(fiber/new (fn [&] (loop ,head (yield (do ,;body))))))
(defmacro for
"Do a c style for loop for side effects. Returns nil."
@@ -416,21 +416,23 @@
[binding ind & body]
(apply loop [tuple binding :in ind] body))
(defn sum [xs]
(defmacro coro
"A wrapper for making fibers. Same as (fiber/new (fn [&] ...body))."
[& body]
(tuple fiber/new (tuple 'fn '[&] ;body)))
(defn sum
[xs]
(var accum 0)
(loop [x :in xs] (+= accum x))
accum)
(defn product [xs]
(defn product
[xs]
(var accum 1)
(loop [x :in xs] (*= accum x))
accum)
(defmacro coro
"A wrapper for making fibers. Same as (fiber/new (fn [&] ...body))."
[& body]
(tuple fiber/new (apply tuple 'fn '[&] body)))
(defmacro if-let
"Takes the first one or two forms in a vector and if both are true binds
all the forms with let and evaluates the first expression else
@@ -466,7 +468,7 @@
"Takes the first one or two forms in vector and if true binds
all the forms with let and evaluates the body"
[bindings & body]
~(if-let ,bindings (do ;body)))
~(if-let ,bindings (do ,;body)))
(defn comp
"Takes multiple functions and returns a function that is the composition
@@ -479,8 +481,8 @@
3 (let [[f g h] functions] (fn [x] (f (g (h x)))))
4 (let [[f g h i] functions] (fn [x] (f (g (h (i x))))))
(let [[f g h i j] functions]
(apply comp (fn [x] (f (g (h (i (j x))))))
(tuple/slice functions 5 -1)))))
(comp (fn [x] (f (g (h (i (j x))))))
;(tuple/slice functions 5 -1)))))
(defn identity
"A function that returns its first argument."
@@ -590,7 +592,7 @@
(loop [i :range [0 limit]]
(def args (array/new ninds))
(loop [j :range [0 ninds]] (:= args.j inds.j.i))
(:= res.i (apply f args))))
(:= res.i (f ;args))))
res)
(defn mapcat
@@ -696,7 +698,7 @@
(fn [& args]
(def ret @[])
(loop [f :in funs]
(array/push ret (apply f args)))
(array/push ret (f ;args)))
(tuple/slice ret 0)))
(defmacro juxt
@@ -738,7 +740,7 @@
"Partial function application."
[f & more]
(if (zero? (length more)) f
(fn [& r] (apply f (array/concat @[] more r)))))
(fn [& r] (f ;more ;r))))
(defn every?
"Returns true if each value in is truthy, otherwise the first
@@ -787,7 +789,7 @@ value, one key will be ignored."
The key then, is associated to the function's return value"
[coll a-key a-function & args]
(def old-value coll.a-key)
(:= coll.a-key (apply a-function old-value args)))
(:= coll.a-key (a-function old-value ;args)))
(defn merge-into
"Merges multiple tables/structs into a table. If a key appears in more than one
@@ -857,7 +859,7 @@ value, one key will be ignored."
(def res @[])
(def ncol (length cols))
(when (> ncol 0)
(def len (apply min (map length cols)))
(def len (min ;(map length cols)))
(loop [i :range [0 len]
ci :range [0 ncol]]
(array/push res cols.ci.i)))
@@ -1008,16 +1010,16 @@ value, one key will be ignored."
(defn expandall [t]
(def args (map macex1 (tuple/slice t 1)))
(apply tuple t.0 args))
(tuple t.0 ;args))
(defn expandfn [t]
(if (symbol? t.1)
(do
(def args (map macex1 (tuple/slice t 3)))
(apply tuple 'fn t.1 t.2 args))
(tuple 'fn t.1 t.2 ;args))
(do
(def args (map macex1 (tuple/slice t 2)))
(apply tuple 'fn t.1 args))))
(tuple 'fn t.1 ;args))))
(defn expandqq [t]
(defn qq [x]
@@ -1052,7 +1054,7 @@ value, one key will be ignored."
(def m? entry:macro)
(cond
s (s t)
m? (apply m (tuple/slice t 1))
m? (m ;(tuple/slice t 1))
(tuple/slice (map macex1 t))))
(def ret
@@ -1358,7 +1360,7 @@ value, one key will be ignored."
(defn import*
[env path & args]
(def targs (apply table args))
(def targs (table ;args))
(def {:as as
:prefix prefix} targs)
(def newenv (require path targs))
@@ -1383,7 +1385,7 @@ value, one key will be ignored."
x
(string x)))
args))
(apply tuple import* '_env (string path) argm))
(tuple import* '_env (string path) ;argm))
(defn repl
"Run a repl. The first parameter is an optional function to call to

2
src/core/parse.c
View File

@@ -171,7 +171,7 @@ static void popstate(JanetParser *p, Janet val) {
const char *which =
(c == '\'') ? "quote" :
(c == ',') ? "unquote" :
(c == ';') ? "unquote-splicing" :
(c == ';') ? "splice" :
(c == '~') ? "quasiquote" : "<unknown>";
t[0] = janet_csymbolv(which);
t[1] = val;

55
src/core/specials.c
View File

@@ -34,20 +34,26 @@ static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv)
return janetc_cslot(argv[0]);
}
static JanetSlot janetc_splice(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetSlot ret;
if (argn != 1) {
janetc_cerror(opts.compiler, "expected 1 argument");
return janetc_cslot(janet_wrap_nil());
}
ret = janetc_value(opts, argv[0]);
ret.flags |= JANET_SLOT_SPLICED;
return ret;
}
static JanetSlot qq_slots(JanetFopts opts, JanetSlot *slots, int makeop) {
JanetSlot target = janetc_gettarget(opts);
int32_t i;
for (i = 0; i < janet_v_count(slots); i++) {
JanetSlot s = slots[i];
int op = (s.flags & JANET_SLOT_SPLICED) ? JOP_PUSH_ARRAY : JOP_PUSH;
janetc_emit_s(opts.compiler, op, s, 0);
}
janetc_pushslots(opts.compiler, slots);
janetc_freeslots(opts.compiler, slots);
janetc_emit_s(opts.compiler, makeop, target, 1);
return target;
}
static JanetSlot quasiquote(JanetFopts opts, Janet x, int can_splice) {
static JanetSlot quasiquote(JanetFopts opts, Janet x) {
JanetSlot *slots = NULL;
switch (janet_type(x)) {
default:
@@ -59,20 +65,11 @@ static JanetSlot quasiquote(JanetFopts opts, Janet x, int can_splice) {
len = janet_tuple_length(tup);
if (len > 1 && janet_checktype(tup[0], JANET_SYMBOL)) {
const uint8_t *head = janet_unwrap_symbol(tup[0]);
if (!janet_cstrcmp(head, "unquote")) {
if (!janet_cstrcmp(head, "unquote"))
return janetc_value(janetc_fopts_default(opts.compiler), tup[1]);
} else if (!janet_cstrcmp(head, "unquote-splicing")) {
JanetSlot s;
if (!can_splice) {
janetc_cerror(opts.compiler, "cannot use unquote-splicing here");
}
s = janetc_value(janetc_fopts_default(opts.compiler), tup[1]);
s.flags |= JANET_SLOT_SPLICED;
return s;
}
}
for (i = 0; i < len; i++)
janet_v_push(slots, quasiquote(opts, tup[i], 1));
janet_v_push(slots, quasiquote(opts, tup[i]));
return qq_slots(opts, slots, JOP_MAKE_TUPLE);
}
case JANET_ARRAY:
@@ -80,7 +77,7 @@ static JanetSlot quasiquote(JanetFopts opts, Janet x, int can_splice) {
int32_t i;
JanetArray *array = janet_unwrap_array(x);
for (i = 0; i < array->count; i++)
janet_v_push(slots, quasiquote(opts, array->data[i], 1));
janet_v_push(slots, quasiquote(opts, array->data[i]));
return qq_slots(opts, slots, JOP_MAKE_ARRAY);
}
case JANET_TABLE:
@@ -90,8 +87,12 @@ static JanetSlot quasiquote(JanetFopts opts, Janet x, int can_splice) {
int32_t len, cap;
janet_dictionary_view(x, &kvs, &len, &cap);
while ((kv = janet_dictionary_next(kvs, cap, kv))) {
janet_v_push(slots, quasiquote(opts, kv->key, 0));
janet_v_push(slots, quasiquote(opts, kv->value, 0));
JanetSlot key = quasiquote(opts, kv->key);
JanetSlot value = quasiquote(opts, kv->value);
key.flags &= ~JANET_SLOT_SPLICED;
value.flags &= ~JANET_SLOT_SPLICED;
janet_v_push(slots, key);
janet_v_push(slots, value);
}
return qq_slots(opts, slots,
janet_checktype(x, JANET_TABLE) ? JOP_MAKE_TABLE : JOP_MAKE_STRUCT);
@@ -104,7 +105,7 @@ static JanetSlot janetc_quasiquote(JanetFopts opts, int32_t argn, const Janet *a
janetc_cerror(opts.compiler, "expected 1 argument");
return janetc_cslot(janet_wrap_nil());
}
return quasiquote(opts, argv[0], 0);
return quasiquote(opts, argv[0]);
}
static JanetSlot janetc_unquote(JanetFopts opts, int32_t argn, const Janet *argv) {
@@ -114,13 +115,6 @@ static JanetSlot janetc_unquote(JanetFopts opts, int32_t argn, const Janet *argv
return janetc_cslot(janet_wrap_nil());
}
static JanetSlot janetc_unquote_splicing(JanetFopts opts, int32_t argn, const Janet *argv) {
(void) argn;
(void) argv;
janetc_cerror(opts.compiler, "cannot use unquote-splicing here");
return janetc_cslot(janet_wrap_nil());
}
/* Preform destructuring. Be careful to
* keep the order registers are freed.
* Returns if the slot 'right' can be freed. */
@@ -661,8 +655,9 @@ static const JanetSpecial janetc_specials[] = {
{"if", janetc_if},
{"quasiquote", janetc_quasiquote},
{"quote", janetc_quote},
{"splice", janetc_splice},
{"unquote", janetc_unquote},
{"unquote", janetc_unquote},
{"unquote-splicing", janetc_unquote_splicing},
{"var", janetc_var},
{"while", janetc_while}
};