diff --git a/src/core/compile.c b/src/core/compile.c index 755da529..730348da 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -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: diff --git a/src/core/core.janet b/src/core/core.janet index cdc2ce3f..42b3c891 100644 --- a/src/core/core.janet +++ b/src/core/core.janet @@ -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 diff --git a/src/core/parse.c b/src/core/parse.c index 566a60e7..a4845c06 100644 --- a/src/core/parse.c +++ b/src/core/parse.c @@ -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" : ""; t[0] = janet_csymbolv(which); t[1] = val; diff --git a/src/core/specials.c b/src/core/specials.c index 1a7f0bd7..58c6d52b 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -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} };