mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2024-06-15 18:00:01 +00:00
Code Issues 1 Releases Wiki Activity
1c6fda1a5c
janet/src/core/specials.c
Calvin Rose 1c6fda1a5c Address #1076 - unexpected shadowing behavior 
While the old behavior was reasonable, it is not spelled out anywhere
in the documentation and was incidental rather than intentional.
Parameters of the same name of the function should probably take
precedence on name collision, following the principle of least surprise.
2023-03-12 10:30:59 -05:00

1048 lines
37 KiB
C
Raw Blame History

/*
* Copyright (c) 2023 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.
*/
#ifndef JANET_AMALG
#include "features.h"
#include <janet.h>
#include "compile.h"
#include "util.h"
#include "vector.h"
#include "emit.h"
#endif
static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv) {
if (argn != 1) {
janetc_cerror(opts.compiler, "expected 1 argument to quote");
return janetc_cslot(janet_wrap_nil());
}
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 to splice");
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);
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 depth, int level) {
if (depth == 0) {
janetc_cerror(opts.compiler, "quasiquote too deeply nested");
return janetc_cslot(janet_wrap_nil());
}
JanetSlot *slots = NULL;
JanetFopts subopts = opts;
subopts.flags &= ~JANET_FOPTS_HINT;
switch (janet_type(x)) {
default:
return janetc_cslot(x);
case JANET_TUPLE: {
int32_t i, len;
const Janet *tup = janet_unwrap_tuple(x);
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 (level == 0) {
return janetc_value(janetc_fopts_default(opts.compiler), tup[1]);
} else {
level--;
}
} else if (!janet_cstrcmp(head, "quasiquote")) {
level++;
}
}
for (i = 0; i < len; i++)
janet_v_push(slots, quasiquote(subopts, tup[i], depth - 1, level));
return qq_slots(opts, slots, (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR)
? JOP_MAKE_BRACKET_TUPLE
: JOP_MAKE_TUPLE);
}
case JANET_ARRAY: {
int32_t i;
JanetArray *array = janet_unwrap_array(x);
for (i = 0; i < array->count; i++)
janet_v_push(slots, quasiquote(subopts, array->data[i], depth - 1, level));
return qq_slots(opts, slots, JOP_MAKE_ARRAY);
}
case JANET_TABLE:
case JANET_STRUCT: {
const JanetKV *kv = NULL, *kvs = NULL;
int32_t len, cap = 0;
janet_dictionary_view(x, &kvs, &len, &cap);
while ((kv = janet_dictionary_next(kvs, cap, kv))) {
JanetSlot key = quasiquote(subopts, kv->key, depth - 1, level);
JanetSlot value = quasiquote(subopts, kv->value, depth - 1, level);
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);
}
}
}
static JanetSlot janetc_quasiquote(JanetFopts opts, int32_t argn, const Janet *argv) {
if (argn != 1) {
janetc_cerror(opts.compiler, "expected 1 argument to quasiquote");
return janetc_cslot(janet_wrap_nil());
}
return quasiquote(opts, argv[0], JANET_RECURSION_GUARD, 0);
}
static JanetSlot janetc_unquote(JanetFopts opts, int32_t argn, const Janet *argv) {
(void) argn;
(void) argv;
janetc_cerror(opts.compiler, "cannot use unquote here");
return janetc_cslot(janet_wrap_nil());
}
/* Perform destructuring. Be careful to
* keep the order registers are freed.
* Returns if the slot 'right' can be freed. */
static int destructure(JanetCompiler *c,
Janet left,
JanetSlot right,
int (*leaf)(JanetCompiler *c,
const uint8_t *sym,
JanetSlot s,
JanetTable *attr),
JanetTable *attr) {
switch (janet_type(left)) {
default:
janetc_error(c, janet_formatc("unexpected type in destruction, got %v", left));
return 1;
case JANET_SYMBOL:
/* Leaf, assign right to left */
return leaf(c, janet_unwrap_symbol(left), right, attr);
case JANET_TUPLE:
case JANET_ARRAY: {
int32_t len = 0;
const Janet *values = NULL;
janet_indexed_view(left, &values, &len);
for (int32_t i = 0; i < len; i++) {
JanetSlot nextright = janetc_farslot(c);
Janet subval = values[i];
if (janet_checktype(subval, JANET_SYMBOL) && !janet_cstrcmp(janet_unwrap_symbol(subval), "&")) {
if (i + 1 >= len) {
janetc_cerror(c, "expected symbol following '& in destructuring pattern");
return 1;
}
if (i + 2 < len) {
int32_t num_extra = len - i - 1;
Janet *extra = janet_tuple_begin(num_extra);
janet_tuple_flag(extra) |= JANET_TUPLE_FLAG_BRACKETCTOR;
for (int32_t j = 0; j < num_extra; ++j) {
extra[j] = values[j + i + 1];
}
janetc_error(c, janet_formatc("expected a single symbol follow '& in destructuring pattern, found %q", janet_wrap_tuple(janet_tuple_end(extra))));
return 1;
}
if (!janet_checktype(values[i + 1], JANET_SYMBOL)) {
janetc_error(c, janet_formatc("expected symbol following '& in destructuring pattern, found %q", values[i + 1]));
return 1;
}
JanetSlot argi = janetc_farslot(c);
JanetSlot arg = janetc_farslot(c);
JanetSlot len = janetc_farslot(c);
janetc_emit_si(c, JOP_LOAD_INTEGER, argi, i, 0);
janetc_emit_ss(c, JOP_LENGTH, len, right, 0);
/* loop condition - reuse arg slot for the condition result */
int32_t label_loop_start = janetc_emit_sss(c, JOP_LESS_THAN, arg, argi, len, 0);
int32_t label_loop_cond_jump = janetc_emit_si(c, JOP_JUMP_IF_NOT, arg, 0, 0);
/* loop body */
janetc_emit_sss(c, JOP_GET, arg, right, argi, 0);
janetc_emit_s(c, JOP_PUSH, arg, 0);
janetc_emit_ssi(c, JOP_ADD_IMMEDIATE, argi, argi, 1, 0);
/* loop - jump back to the start of the loop */
int32_t label_loop_loop = janet_v_count(c->buffer);
janetc_emit(c, JOP_JUMP);
int32_t label_loop_exit = janet_v_count(c->buffer);
c->buffer[label_loop_cond_jump] |= (label_loop_exit - label_loop_cond_jump) << 16;
c->buffer[label_loop_loop] |= (label_loop_start - label_loop_loop) << 8;
janetc_freeslot(c, argi);
janetc_freeslot(c, arg);
janetc_freeslot(c, len);
janetc_emit_s(c, JOP_MAKE_TUPLE, nextright, 1);
leaf(c, janet_unwrap_symbol(values[i + 1]), nextright, attr);
janetc_freeslot(c, nextright);
break;
}
if (i < 0x100) {
janetc_emit_ssu(c, JOP_GET_INDEX, nextright, right, (uint8_t) i, 1);
} else {
JanetSlot k = janetc_cslot(janet_wrap_integer(i));
janetc_emit_sss(c, JOP_IN, nextright, right, k, 1);
}
if (destructure(c, subval, nextright, leaf, attr))
janetc_freeslot(c, nextright);
}
}
return 1;
case JANET_TABLE:
case JANET_STRUCT: {
const JanetKV *kvs = NULL;
int32_t cap = 0, len = 0;
janet_dictionary_view(left, &kvs, &len, &cap);
for (int32_t i = 0; i < cap; i++) {
if (janet_checktype(kvs[i].key, JANET_NIL)) continue;
JanetSlot nextright = janetc_farslot(c);
JanetSlot k = janetc_value(janetc_fopts_default(c), kvs[i].key);
janetc_emit_sss(c, JOP_IN, nextright, right, k, 1);
if (destructure(c, kvs[i].value, nextright, leaf, attr))
janetc_freeslot(c, nextright);
}
}
return 1;
}
}
/* Create a source map for definitions. */
static const Janet *janetc_make_sourcemap(JanetCompiler *c) {
Janet *tup = janet_tuple_begin(3);
tup[0] = c->source ? janet_wrap_string(c->source) : janet_wrap_nil();
tup[1] = janet_wrap_integer(c->current_mapping.line);
tup[2] = janet_wrap_integer(c->current_mapping.column);
return janet_tuple_end(tup);
}
static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) {
if (argn != 2) {
janetc_cerror(opts.compiler, "expected 2 arguments");
return janetc_cslot(janet_wrap_nil());
}
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 */
janetc_cerror(opts.compiler, "expected symbol or tuple for l-value to set");
return janetc_cslot(janet_wrap_nil());
}
}
/* Add attributes to a global def or var table */
static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv) {
int32_t i;
JanetTable *tab = janet_table(2);
const char *binding_name = janet_type(argv[0]) == JANET_SYMBOL
? ((const char *)janet_unwrap_symbol(argv[0]))
: "<multiple bindings>";
for (i = 1; i < argn - 1; i++) {
Janet attr = argv[i];
switch (janet_type(attr)) {
case JANET_TUPLE:
janetc_cerror(c, "unexpected form - did you intend to use defn?");
break;
default:
janetc_error(c, janet_formatc("cannot add metadata %v to binding %s", attr, binding_name));
break;
case JANET_KEYWORD:
janet_table_put(tab, attr, janet_wrap_true());
break;
case JANET_STRING:
janet_table_put(tab, janet_ckeywordv("doc"), attr);
break;
case JANET_STRUCT:
janet_table_merge_struct(tab, janet_unwrap_struct(attr));
break;
}
}
return tab;
}
static JanetSlot dohead(JanetCompiler *c, JanetFopts opts, Janet *head, int32_t argn, const Janet *argv) {
JanetFopts subopts = janetc_fopts_default(c);
JanetSlot ret;
if (argn < 2) {
janetc_cerror(c, "expected at least 2 arguments");
return janetc_cslot(janet_wrap_nil());
}
*head = argv[0];
subopts.flags = opts.flags & ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP);
subopts.hint = opts.hint;
ret = janetc_value(subopts, argv[argn - 1]);
return ret;
}
/* Def or var a symbol in a local scope */
static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, JanetSlot ret) {
int isUnnamedRegister = !(ret.flags & JANET_SLOT_NAMED) &&
ret.index > 0 &&
ret.envindex >= 0;
if (!isUnnamedRegister) {
/* Slot is not able to be named */
JanetSlot localslot = janetc_farslot(c);
janetc_copy(c, localslot, ret);
ret = localslot;
}
ret.flags |= flags;
janetc_nameslot(c, head, ret);
return !isUnnamedRegister;
}
static int varleaf(
JanetCompiler *c,
const uint8_t *sym,
JanetSlot s,
JanetTable *reftab) {
if (c->scope->flags & JANET_SCOPE_TOP) {
/* Global var, generate var */
JanetSlot refslot;
JanetTable *entry = janet_table_clone(reftab);
Janet redef_kw = janet_ckeywordv("redef");
int is_redef = janet_truthy(janet_table_get(c->env, redef_kw));
JanetArray *ref;
JanetBinding old_binding;
if (is_redef && (old_binding = janet_resolve_ext(c->env, sym),
old_binding.type == JANET_BINDING_VAR)) {
ref = janet_unwrap_array(old_binding.value);
} else {
ref = janet_array(1);
janet_array_push(ref, janet_wrap_nil());
}
janet_table_put(entry, janet_ckeywordv("ref"), janet_wrap_array(ref));
janet_table_put(entry, janet_ckeywordv("source-map"),
janet_wrap_tuple(janetc_make_sourcemap(c)));
janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry));
refslot = janetc_cslot(janet_wrap_array(ref));
janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0);
return 1;
} else {
return namelocal(c, sym, JANET_SLOT_MUTABLE, s);
}
}
static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
Janet head;
JanetTable *attr_table = handleattr(c, argn, argv);
JanetSlot ret = dohead(c, opts, &head, argn, argv);
if (c->result.status == JANET_COMPILE_ERROR)
return janetc_cslot(janet_wrap_nil());
destructure(c, argv[0], ret, varleaf, attr_table);
return ret;
}
static int defleaf(
JanetCompiler *c,
const uint8_t *sym,
JanetSlot s,
JanetTable *tab) {
if (c->scope->flags & JANET_SCOPE_TOP) {
JanetTable *entry = janet_table_clone(tab);
janet_table_put(entry, janet_ckeywordv("source-map"),
janet_wrap_tuple(janetc_make_sourcemap(c)));
Janet redef_kw = janet_ckeywordv("redef");
int is_redef = janet_truthy(janet_table_get(c->env, redef_kw));
if (is_redef) janet_table_put(entry, redef_kw, janet_wrap_true());
if (is_redef) {
JanetBinding binding = janet_resolve_ext(c->env, sym);
JanetArray *ref;
if (binding.type == JANET_BINDING_DYNAMIC_DEF || binding.type == JANET_BINDING_DYNAMIC_MACRO) {
ref = janet_unwrap_array(binding.value);
} else {
ref = janet_array(1);
janet_array_push(ref, janet_wrap_nil());
}
janet_table_put(entry, janet_ckeywordv("ref"), janet_wrap_array(ref));
JanetSlot refslot = janetc_cslot(janet_wrap_array(ref));
janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0);
} else {
JanetSlot valsym = janetc_cslot(janet_ckeywordv("value"));
JanetSlot tabslot = janetc_cslot(janet_wrap_table(entry));
janetc_emit_sss(c, JOP_PUT, tabslot, valsym, s, 0);
}
/* Add env entry to env */
janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry));
}
return namelocal(c, sym, 0, s);
}
static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
Janet head;
opts.flags &= ~JANET_FOPTS_HINT;
JanetTable *attr_table = handleattr(c, argn, argv);
JanetSlot ret = dohead(c, opts, &head, argn, argv);
if (c->result.status == JANET_COMPILE_ERROR)
return janetc_cslot(janet_wrap_nil());
destructure(c, argv[0], ret, defleaf, attr_table);
return ret;
}
/*
* :condition
* ...
* jump-if-not condition :right
* :left
* ...
* jump done (only if not tail)
* :right
* ...
* :done
*/
static JanetSlot janetc_if(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
int32_t labelr, labeljr, labeld, labeljd;
JanetFopts condopts, bodyopts;
JanetSlot cond, left, right, target;
Janet truebody, falsebody;
JanetScope condscope, tempscope;
const int tail = opts.flags & JANET_FOPTS_TAIL;
const int drop = opts.flags & JANET_FOPTS_DROP;
if (argn < 2 || argn > 3) {
janetc_cerror(c, "expected 2 or 3 arguments to if");
return janetc_cslot(janet_wrap_nil());
}
/* Get the bodies of the if expression */
truebody = argv[1];
falsebody = argn > 2 ? argv[2] : janet_wrap_nil();
/* Get options */
condopts = janetc_fopts_default(c);
bodyopts = opts;
/* Set target for compilation */
target = (drop || tail)
? janetc_cslot(janet_wrap_nil())
: janetc_gettarget(opts);
/* Compile condition */
janetc_scope(&condscope, c, 0, "if");
cond = janetc_value(condopts, argv[0]);
/* Check constant condition. */
/* TODO: Use type info for more short circuits */
if (cond.flags & JANET_SLOT_CONSTANT) {
if (!janet_truthy(cond.constant)) {
/* Swap the true and false bodies */
Janet temp = falsebody;
falsebody = truebody;
truebody = temp;
}
janetc_scope(&tempscope, c, 0, "if-true");
right = janetc_value(bodyopts, truebody);
if (!drop && !tail) janetc_copy(c, target, right);
janetc_popscope(c);
if (!janet_checktype(falsebody, JANET_NIL)) {
janetc_throwaway(bodyopts, falsebody);
}
janetc_popscope(c);
return target;
}
/* Compile jump to right */
labeljr = janetc_emit_si(c, JOP_JUMP_IF_NOT, cond, 0, 0);
/* Condition left body */
janetc_scope(&tempscope, c, 0, "if-true");
left = janetc_value(bodyopts, truebody);
if (!drop && !tail) janetc_copy(c, target, left);
janetc_popscope(c);
/* Compile jump to done */
labeljd = janet_v_count(c->buffer);
if (!tail) janetc_emit(c, JOP_JUMP);
/* Compile right body */
labelr = janet_v_count(c->buffer);
janetc_scope(&tempscope, c, 0, "if-false");
right = janetc_value(bodyopts, falsebody);
if (!drop && !tail) janetc_copy(c, target, right);
janetc_popscope(c);
/* Pop main scope */
janetc_popscope(c);
/* Write jumps - only add jump lengths if jump actually emitted */
labeld = janet_v_count(c->buffer);
c->buffer[labeljr] |= (labelr - labeljr) << 16;
if (!tail) c->buffer[labeljd] |= (labeld - labeljd) << 8;
if (tail) target.flags |= JANET_SLOT_RETURNED;
return target;
}
/* Compile a do form. Do forms execute their body sequentially and
* evaluate to the last expression in the body. */
static JanetSlot janetc_do(JanetFopts opts, int32_t argn, const Janet *argv) {
int32_t i;
JanetSlot ret = janetc_cslot(janet_wrap_nil());
JanetCompiler *c = opts.compiler;
JanetFopts subopts = janetc_fopts_default(c);
JanetScope tempscope;
janetc_scope(&tempscope, c, 0, "do");
for (i = 0; i < argn; i++) {
if (i != argn - 1) {
subopts.flags = JANET_FOPTS_DROP;
} else {
subopts = opts;
}
ret = janetc_value(subopts, argv[i]);
if (i != argn - 1) {
janetc_freeslot(c, ret);
}
}
janetc_popscope_keepslot(c, ret);
return ret;
}
/* Compile an upscope form. Upscope forms execute their body sequentially and
* evaluate to the last expression in the body, but without lexical scope. */
static JanetSlot janetc_upscope(JanetFopts opts, int32_t argn, const Janet *argv) {
int32_t i;
JanetSlot ret = janetc_cslot(janet_wrap_nil());
JanetCompiler *c = opts.compiler;
JanetFopts subopts = janetc_fopts_default(c);
for (i = 0; i < argn; i++) {
if (i != argn - 1) {
subopts.flags = JANET_FOPTS_DROP;
} else {
subopts = opts;
}
ret = janetc_value(subopts, argv[i]);
if (i != argn - 1) {
janetc_freeslot(c, ret);
}
}
return ret;
}
/* Add a funcdef to the top most function scope */
static int32_t janetc_addfuncdef(JanetCompiler *c, JanetFuncDef *def) {
JanetScope *scope = c->scope;
while (scope) {
if (scope->flags & JANET_SCOPE_FUNCTION)
break;
scope = scope->parent;
}
janet_assert(scope, "could not add funcdef");
janet_v_push(scope->defs, def);
return janet_v_count(scope->defs) - 1;
}
/*
* break
*
* jump :end or retn if in function
*/
static JanetSlot janetc_break(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
JanetScope *scope = c->scope;
if (argn > 1) {
janetc_cerror(c, "expected at most 1 argument");
return janetc_cslot(janet_wrap_nil());
}
/* Find scope to break from */
while (scope) {
if (scope->flags & (JANET_SCOPE_FUNCTION | JANET_SCOPE_WHILE))
break;
scope = scope->parent;
}
if (NULL == scope) {
janetc_cerror(c, "break must occur in while loop or closure");
return janetc_cslot(janet_wrap_nil());
}
/* Emit code to break from that scope */
JanetFopts subopts = janetc_fopts_default(c);
if (scope->flags & JANET_SCOPE_FUNCTION) {
if (!(scope->flags & JANET_SCOPE_WHILE) && argn) {
/* Closure body with return argument */
subopts.flags |= JANET_FOPTS_TAIL;
JanetSlot ret = janetc_value(subopts, argv[0]);
ret.flags |= JANET_SLOT_RETURNED;
return ret;
} else {
/* while loop IIFE or no argument */
if (argn) {
subopts.flags |= JANET_FOPTS_DROP;
janetc_value(subopts, argv[0]);
}
janetc_emit(c, JOP_RETURN_NIL);
JanetSlot s = janetc_cslot(janet_wrap_nil());
s.flags |= JANET_SLOT_RETURNED;
return s;
}
} else {
if (argn) {
subopts.flags |= JANET_FOPTS_DROP;
janetc_value(subopts, argv[0]);
}
/* Tag the instruction so the while special can turn it into a proper jump */
janetc_emit(c, 0x80 | JOP_JUMP);
return janetc_cslot(janet_wrap_nil());
}
}
/* Check if a form matches the pattern (not= nil _) */
static int janetc_check_notnil_form(Janet x, Janet *capture) {
if (!janet_checktype(x, JANET_TUPLE)) return 0;
JanetTuple tup = janet_unwrap_tuple(x);
if (!janet_checktype(tup[0], JANET_FUNCTION)) return 0;
if (3 != janet_tuple_length(tup)) return 0;
JanetFunction *fun = janet_unwrap_function(tup[0]);
uint32_t tag = fun->def->flags & JANET_FUNCDEF_FLAG_TAG;
if (tag != JANET_FUN_NEQ) return 0;
if (!janet_checktype(tup[1], JANET_NIL)) return 0;
*capture = tup[2];
return 1;
}
/*
* :whiletop
* ...
* :condition
* jump-if-not cond :done
* ...
* jump :whiletop
* :done
*/
static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
JanetSlot cond;
JanetFopts subopts = janetc_fopts_default(c);
JanetScope tempscope;
int32_t labelwt, labeld, labeljt, labelc, i;
int infinite = 0;
int is_notnil_form = 0;
uint8_t ifjmp = JOP_JUMP_IF;
uint8_t ifnjmp = JOP_JUMP_IF_NOT;
if (argn < 2) {
janetc_cerror(c, "expected at least 2 arguments");
return janetc_cslot(janet_wrap_nil());
}
labelwt = janet_v_count(c->buffer);
janetc_scope(&tempscope, c, JANET_SCOPE_WHILE, "while");
/* Check for `(not= nil _)` in condition, and if so, use the
* jmpnl or jmpnn instructions. This let's us implement `(each ...)`
* more efficiently. */
Janet condform = argv[0];
if (janetc_check_notnil_form(condform, &condform)) {
is_notnil_form = 1;
ifjmp = JOP_JUMP_IF_NOT_NIL;
ifnjmp = JOP_JUMP_IF_NIL;
}
/* Compile condition */
cond = janetc_value(subopts, condform);
/* Check for constant condition */
if (cond.flags & JANET_SLOT_CONSTANT) {
/* Loop never executes */
int never_executes = is_notnil_form
? janet_checktype(cond.constant, JANET_NIL)
: !janet_truthy(cond.constant);
if (never_executes) {
janetc_popscope(c);
return janetc_cslot(janet_wrap_nil());
}
/* Infinite loop */
infinite = 1;
}
/* Infinite loop does not need to check condition */
labelc = infinite
? 0
: janetc_emit_si(c, ifnjmp, cond, 0, 0);
/* Compile body */
for (i = 1; i < argn; i++) {
subopts.flags = JANET_FOPTS_DROP;
janetc_freeslot(c, janetc_value(subopts, argv[i]));
}
/* Check if closure created in while scope. If so,
* recompile in a function scope. */
if (tempscope.flags & JANET_SCOPE_CLOSURE) {
subopts = janetc_fopts_default(c);
tempscope.flags |= JANET_SCOPE_UNUSED;
janetc_popscope(c);
if (c->buffer) janet_v__cnt(c->buffer) = labelwt;
if (c->mapbuffer) janet_v__cnt(c->mapbuffer) = labelwt;
janetc_scope(&tempscope, c, JANET_SCOPE_FUNCTION, "while-iife");
/* Recompile in the function scope */
cond = janetc_value(subopts, condform);
if (!(cond.flags & JANET_SLOT_CONSTANT)) {
/* If not an infinite loop, return nil when condition false */
janetc_emit_si(c, ifjmp, cond, 2, 0);
janetc_emit(c, JOP_RETURN_NIL);
}
for (i = 1; i < argn; i++) {
subopts.flags = JANET_FOPTS_DROP;
janetc_freeslot(c, janetc_value(subopts, argv[i]));
}
/* But now add tail recursion */
int32_t tempself = janetc_regalloc_temp(&tempscope.ra, JANETC_REGTEMP_0);
janetc_emit(c, JOP_LOAD_SELF | (tempself << 8));
janetc_emit(c, JOP_TAILCALL | (tempself << 8));
janetc_regalloc_freetemp(&c->scope->ra, tempself, JANETC_REGTEMP_0);
/* Compile function */
JanetFuncDef *def = janetc_pop_funcdef(c);
def->name = janet_cstring("_while");
janet_def_addflags(def);
int32_t defindex = janetc_addfuncdef(c, def);
/* And then load the closure and call it. */
int32_t cloreg = janetc_regalloc_temp(&c->scope->ra, JANETC_REGTEMP_0);
janetc_emit(c, JOP_CLOSURE | (cloreg << 8) | (defindex << 16));
janetc_emit(c, JOP_CALL | (cloreg << 8) | (cloreg << 16));
janetc_regalloc_freetemp(&c->scope->ra, cloreg, JANETC_REGTEMP_0);
c->scope->flags |= JANET_SCOPE_CLOSURE;
return janetc_cslot(janet_wrap_nil());
}
/* Compile jump to :whiletop */
labeljt = janet_v_count(c->buffer);
janetc_emit(c, JOP_JUMP);
/* Calculate jumps */
labeld = janet_v_count(c->buffer);
if (!infinite) c->buffer[labelc] |= (uint32_t)(labeld - labelc) << 16;
c->buffer[labeljt] |= (uint32_t)(labelwt - labeljt) << 8;
/* Calculate breaks */
for (int32_t i = labelwt; i < labeld; i++) {
if (c->buffer[i] == (0x80 | JOP_JUMP)) {
c->buffer[i] = JOP_JUMP | ((labeld - i) << 8);
}
}
/* Pop scope and return nil slot */
janetc_popscope(c);
return janetc_cslot(janet_wrap_nil());
}
static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
JanetFuncDef *def;
JanetSlot ret;
Janet head;
JanetScope fnscope;
int32_t paramcount, argi, parami, arity, min_arity = 0, max_arity, defindex, i;
JanetFopts subopts = janetc_fopts_default(c);
const Janet *params;
const char *errmsg = NULL;
/* Function flags */
int vararg = 0;
int structarg = 0;
int allow_extra = 0;
int selfref = 0;
int seenamp = 0;
int seenopt = 0;
int namedargs = 0;
/* Begin function */
c->scope->flags |= JANET_SCOPE_CLOSURE;
janetc_scope(&fnscope, c, JANET_SCOPE_FUNCTION, "function");
if (argn == 0) {
errmsg = "expected at least 1 argument to function literal";
goto error;
}
/* Read function parameters */
parami = 0;
head = argv[0];
if (janet_checktype(head, JANET_SYMBOL)) {
selfref = 1;
parami = 1;
}
if (parami >= argn || !janet_checktype(argv[parami], JANET_TUPLE)) {
errmsg = "expected function parameters";
goto error;
}
/* Keep track of destructured parameters */
JanetSlot *destructed_params = NULL;
JanetSlot *named_params = NULL;
JanetTable *named_table = NULL;
JanetSlot named_slot;
/* Compile function parameters */
params = janet_unwrap_tuple(argv[parami]);
paramcount = janet_tuple_length(params);
arity = paramcount;
for (i = 0; i < paramcount; i++) {
Janet param = params[i];
if (namedargs) {
arity--;
if (!janet_checktype(param, JANET_SYMBOL)) {
errmsg = "only named arguments can follow &named";
goto error;
}
Janet key = janet_wrap_keyword(janet_unwrap_symbol(param));
janet_table_put(named_table, key, param);
janet_v_push(named_params, janetc_farslot(c));
} else if (janet_checktype(param, JANET_SYMBOL)) {
/* Check for varargs and unfixed arity */
const uint8_t *sym = janet_unwrap_symbol(param);
if (sym[0] == '&') {
if (!janet_cstrcmp(sym, "&")) {
if (seenamp) {
errmsg = "& in unexpected location";
goto error;
} else if (i == paramcount - 1) {
allow_extra = 1;
arity--;
} else if (i == paramcount - 2) {
vararg = 1;
arity -= 2;
} else {
errmsg = "& in unexpected location";
goto error;
}
seenamp = 1;
} else if (!janet_cstrcmp(sym, "&opt")) {
if (seenopt) {
errmsg = "only one &opt allowed";
goto error;
} else if (i == paramcount - 1) {
errmsg = "&opt cannot be last item in parameter list";
goto error;
}
min_arity = i;
arity--;
seenopt = 1;
} else if (!janet_cstrcmp(sym, "&keys")) {
if (seenamp) {
errmsg = "&keys in unexpected location";
goto error;
} else if (i == paramcount - 2) {
vararg = 1;
structarg = 1;
arity -= 2;
} else {
errmsg = "&keys in unexpected location";
goto error;
}
seenamp = 1;
} else if (!janet_cstrcmp(sym, "&named")) {
if (seenamp) {
errmsg = "&named in unexpected location";
goto error;
}
vararg = 1;
structarg = 1;
arity--;
seenamp = 1;
namedargs = 1;
named_table = janet_table(10);
named_slot = janetc_farslot(c);
} else {
janetc_nameslot(c, sym, janetc_farslot(c));
}
} else {
janetc_nameslot(c, sym, janetc_farslot(c));
}
} else {
janet_v_push(destructed_params, janetc_farslot(c));
}
}
/* Compile destructed params */
int32_t j = 0;
for (i = 0; i < paramcount; i++) {
Janet param = params[i];
if (!janet_checktype(param, JANET_SYMBOL)) {
JanetSlot reg = destructed_params[j++];
destructure(c, param, reg, defleaf, NULL);
janetc_freeslot(c, reg);
}
}
janet_v_free(destructed_params);
/* Compile named arguments */
if (namedargs) {
Janet param = janet_wrap_table(named_table);
destructure(c, param, named_slot, defleaf, NULL);
janetc_freeslot(c, named_slot);
janet_v_free(named_params);
}
max_arity = (vararg || allow_extra) ? INT32_MAX : arity;
if (!seenopt) min_arity = arity;
/* Check for self ref (also avoid if arguments shadow own name) */
if (selfref) {
/* Check if the parameters shadow the function name. If so, don't
* emit JOP_LOAD_SELF and add a binding since that most users
* seem to expect that function parameters take precedence over the
* function name */
const uint8_t *sym = janet_unwrap_symbol(head);
int32_t len = janet_v_count(c->scope->syms);
int found = 0;
for (int32_t i = 0; i < len; i++) {
if (c->scope->syms[i].sym == sym) {
found = 1;
}
}
if (!found) {
JanetSlot slot = janetc_farslot(c);
slot.flags = JANET_SLOT_NAMED | JANET_FUNCTION;
janetc_emit_s(c, JOP_LOAD_SELF, slot, 1);
janetc_nameslot(c, sym, slot);
}
}
/* Compile function body */
if (parami + 1 == argn) {
janetc_emit(c, JOP_RETURN_NIL);
} else {
for (argi = parami + 1; argi < argn; argi++) {
subopts.flags = (argi == (argn - 1)) ? JANET_FOPTS_TAIL : JANET_FOPTS_DROP;
janetc_value(subopts, argv[argi]);
if (c->result.status == JANET_COMPILE_ERROR)
goto error2;
}
}
/* Build function */
def = janetc_pop_funcdef(c);
def->arity = arity;
def->min_arity = min_arity;
def->max_arity = max_arity;
if (vararg) def->flags |= JANET_FUNCDEF_FLAG_VARARG;
if (structarg) def->flags |= JANET_FUNCDEF_FLAG_STRUCTARG;
if (selfref) def->name = janet_unwrap_symbol(head);
janet_def_addflags(def);
defindex = janetc_addfuncdef(c, def);
/* Ensure enough slots for vararg function. */
if (arity + vararg > def->slotcount) def->slotcount = arity + vararg;
/* Instantiate closure */
ret = janetc_gettarget(opts);
janetc_emit_su(c, JOP_CLOSURE, ret, defindex, 1);
return ret;
error:
janetc_cerror(c, errmsg);
error2:
janetc_popscope(c);
return janetc_cslot(janet_wrap_nil());
}
/* Keep in lexicographic order */
static const JanetSpecial janetc_specials[] = {
{"break", janetc_break},
{"def", janetc_def},
{"do", janetc_do},
{"fn", janetc_fn},
{"if", janetc_if},
{"quasiquote", janetc_quasiquote},
{"quote", janetc_quote},
{"set", janetc_varset},
{"splice", janetc_splice},
{"unquote", janetc_unquote},
{"upscope", janetc_upscope},
{"var", janetc_var},
{"while", janetc_while}
};
/* Find a special */
const JanetSpecial *janetc_special(const uint8_t *name) {
return janet_strbinsearch(
&janetc_specials,
sizeof(janetc_specials) / sizeof(JanetSpecial),
sizeof(JanetSpecial),
name);
}
Reference in New Issue View Git Blame Copy Permalink