mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2024-11-29 03:19:54 +00:00
Code Issues 1 Releases Wiki Activity
5defc3b914
janet/src/core/corelib.c
Calvin Rose bbae43f259 Update copyright dates.
2021-05-31 13:46:02 -05:00

1276 lines
47 KiB
C
Raw Blame History

/*
* Copyright (c) 2021 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 <math.h>
#include "compile.h"
#include "state.h"
#include "util.h"
#endif
/* Generated bytes */
#ifndef JANET_BOOTSTRAP
extern const unsigned char *janet_core_image;
extern size_t janet_core_image_size;
#endif
/* Use LoadLibrary on windows or dlopen on posix to load dynamic libaries
* with native code. */
#if defined(JANET_NO_DYNAMIC_MODULES)
typedef int Clib;
#define load_clib(name) ((void) name, 0)
#define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL)
#define error_clib() "dynamic libraries not supported"
#elif defined(JANET_WINDOWS)
#include <windows.h>
typedef HINSTANCE Clib;
#define load_clib(name) LoadLibrary((name))
#define symbol_clib(lib, sym) GetProcAddress((lib), (sym))
static char error_clib_buf[256];
static char *error_clib(void) {
FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
error_clib_buf, sizeof(error_clib_buf), NULL);
error_clib_buf[strlen(error_clib_buf) - 1] = '\0';
return error_clib_buf;
}
#else
#include <dlfcn.h>
typedef void *Clib;
#define load_clib(name) dlopen((name), RTLD_NOW)
#define symbol_clib(lib, sym) dlsym((lib), (sym))
#define error_clib() dlerror()
#endif
static char *get_processed_name(const char *name) {
if (name[0] == '.') return (char *) name;
const char *c;
for (c = name; *c; c++) {
if (*c == '/') return (char *) name;
}
size_t l = (size_t)(c - name);
char *ret = janet_malloc(l + 3);
if (NULL == ret) {
JANET_OUT_OF_MEMORY;
}
ret[0] = '.';
ret[1] = '/';
memcpy(ret + 2, name, l + 1);
return ret;
}
JanetModule janet_native(const char *name, const uint8_t **error) {
char *processed_name = get_processed_name(name);
Clib lib = load_clib(processed_name);
JanetModule init;
JanetModconf getter;
if (name != processed_name) janet_free(processed_name);
if (!lib) {
*error = janet_cstring(error_clib());
return NULL;
}
init = (JanetModule) symbol_clib(lib, "_janet_init");
if (!init) {
*error = janet_cstring("could not find the _janet_init symbol");
return NULL;
}
getter = (JanetModconf) symbol_clib(lib, "_janet_mod_config");
if (!getter) {
*error = janet_cstring("could not find the _janet_mod_config symbol");
return NULL;
}
JanetBuildConfig modconf = getter();
JanetBuildConfig host = janet_config_current();
if (host.major != modconf.major ||
host.minor < modconf.minor ||
host.bits != modconf.bits) {
char errbuf[128];
sprintf(errbuf, "config mismatch - host %d.%.d.%d(%.4x) vs. module %d.%d.%d(%.4x)",
host.major,
host.minor,
host.patch,
host.bits,
modconf.major,
modconf.minor,
modconf.patch,
modconf.bits);
*error = janet_cstring(errbuf);
return NULL;
}
return init;
}
static const char *janet_dyncstring(const char *name, const char *dflt) {
Janet x = janet_dyn(name);
if (janet_checktype(x, JANET_NIL)) return dflt;
if (!janet_checktype(x, JANET_STRING)) {
janet_panicf("expected string, got %v", x);
}
const uint8_t *jstr = janet_unwrap_string(x);
const char *cstr = (const char *)jstr;
if (strlen(cstr) != (size_t) janet_string_length(jstr)) {
janet_panicf("string %v contains embedded 0s");
}
return cstr;
}
static int is_path_sep(char c) {
#ifdef JANET_WINDOWS
if (c == '\\') return 1;
#endif
return c == '/';
}
/* Used for module system. */
static Janet janet_core_expand_path(int32_t argc, Janet *argv) {
janet_fixarity(argc, 2);
const char *input = janet_getcstring(argv, 0);
const char *template = janet_getcstring(argv, 1);
const char *curfile = janet_dyncstring("current-file", "");
const char *syspath = janet_dyncstring("syspath", "");
JanetBuffer *out = janet_buffer(0);
size_t tlen = strlen(template);
/* Calculate name */
const char *name = input + strlen(input);
while (name > input) {
if (is_path_sep(*(name - 1))) break;
name--;
}
/* Calculate dirpath from current file */
const char *curname = curfile + strlen(curfile);
while (curname > curfile) {
if (is_path_sep(*curname)) break;
curname--;
}
const char *curdir;
int32_t curlen;
if (curname == curfile) {
/* Current file has one or zero path segments, so
* we are in the . directory. */
curdir = ".";
curlen = 1;
} else {
/* Current file has 2 or more segments, so we
* can cut off the last segment. */
curdir = curfile;
curlen = (int32_t)(curname - curfile);
}
for (size_t i = 0; i < tlen; i++) {
if (template[i] == ':') {
if (strncmp(template + i, ":all:", 5) == 0) {
janet_buffer_push_cstring(out, input);
i += 4;
} else if (strncmp(template + i, ":cur:", 5) == 0) {
janet_buffer_push_bytes(out, (const uint8_t *)curdir, curlen);
i += 4;
} else if (strncmp(template + i, ":dir:", 5) == 0) {
janet_buffer_push_bytes(out, (const uint8_t *)input,
(int32_t)(name - input));
i += 4;
} else if (strncmp(template + i, ":sys:", 5) == 0) {
janet_buffer_push_cstring(out, syspath);
i += 4;
} else if (strncmp(template + i, ":name:", 6) == 0) {
janet_buffer_push_cstring(out, name);
i += 5;
} else if (strncmp(template + i, ":native:", 8) == 0) {
#ifdef JANET_WINDOWS
janet_buffer_push_cstring(out, ".dll");
#else
janet_buffer_push_cstring(out, ".so");
#endif
i += 7;
} else {
janet_buffer_push_u8(out, (uint8_t) template[i]);
}
} else {
janet_buffer_push_u8(out, (uint8_t) template[i]);
}
}
/* Normalize */
uint8_t *scan = out->data;
uint8_t *print = scan;
uint8_t *scanend = scan + out->count;
int normal_section_count = 0;
int dot_count = 0;
while (scan < scanend) {
if (*scan == '.') {
if (dot_count >= 0) {
dot_count++;
} else {
*print++ = '.';
}
} else if (is_path_sep(*scan)) {
if (dot_count == 1) {
;
} else if (dot_count == 2) {
if (normal_section_count > 0) {
/* unprint last separator */
print--;
/* unprint last section */
while (print > out->data && !is_path_sep(*(print - 1)))
print--;
normal_section_count--;
} else {
*print++ = '.';
*print++ = '.';
*print++ = '/';
}
} else if (scan == out->data || dot_count != 0) {
while (dot_count > 0) {
--dot_count;
*print++ = '.';
}
if (scan > out->data) {
normal_section_count++;
}
*print++ = '/';
}
dot_count = 0;
} else {
while (dot_count > 0) {
--dot_count;
*print++ = '.';
}
dot_count = -1;
*print++ = *scan;
}
scan++;
}
out->count = (int32_t)(print - out->data);
return janet_wrap_buffer(out);
}
static Janet janet_core_dyn(int32_t argc, Janet *argv) {
janet_arity(argc, 1, 2);
Janet value;
if (janet_vm_fiber->env) {
value = janet_table_get(janet_vm_fiber->env, argv[0]);
} else {
value = janet_wrap_nil();
}
if (argc == 2 && janet_checktype(value, JANET_NIL)) {
return argv[1];
}
return value;
}
static Janet janet_core_setdyn(int32_t argc, Janet *argv) {
janet_fixarity(argc, 2);
if (!janet_vm_fiber->env) {
janet_vm_fiber->env = janet_table(2);
}
janet_table_put(janet_vm_fiber->env, argv[0], argv[1]);
return argv[1];
}
static Janet janet_core_native(int32_t argc, Janet *argv) {
JanetModule init;
janet_arity(argc, 1, 2);
const uint8_t *path = janet_getstring(argv, 0);
const uint8_t *error = NULL;
JanetTable *env;
if (argc == 2) {
env = janet_gettable(argv, 1);
} else {
env = janet_table(0);
}
init = janet_native((const char *)path, &error);
if (!init) {
janet_panicf("could not load native %S: %S", path, error);
}
init(env);
janet_table_put(env, janet_ckeywordv("native"), argv[0]);
return janet_wrap_table(env);
}
static Janet janet_core_describe(int32_t argc, Janet *argv) {
JanetBuffer *b = janet_buffer(0);
for (int32_t i = 0; i < argc; ++i)
janet_description_b(b, argv[i]);
return janet_stringv(b->data, b->count);
}
static Janet janet_core_string(int32_t argc, Janet *argv) {
JanetBuffer *b = janet_buffer(0);
for (int32_t i = 0; i < argc; ++i)
janet_to_string_b(b, argv[i]);
return janet_stringv(b->data, b->count);
}
static Janet janet_core_symbol(int32_t argc, Janet *argv) {
JanetBuffer *b = janet_buffer(0);
for (int32_t i = 0; i < argc; ++i)
janet_to_string_b(b, argv[i]);
return janet_symbolv(b->data, b->count);
}
static Janet janet_core_keyword(int32_t argc, Janet *argv) {
JanetBuffer *b = janet_buffer(0);
for (int32_t i = 0; i < argc; ++i)
janet_to_string_b(b, argv[i]);
return janet_keywordv(b->data, b->count);
}
static Janet janet_core_buffer(int32_t argc, Janet *argv) {
JanetBuffer *b = janet_buffer(0);
for (int32_t i = 0; i < argc; ++i)
janet_to_string_b(b, argv[i]);
return janet_wrap_buffer(b);
}
static Janet janet_core_is_abstract(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
return janet_wrap_boolean(janet_checktype(argv[0], JANET_ABSTRACT));
}
static Janet janet_core_scannumber(int32_t argc, Janet *argv) {
double number;
janet_fixarity(argc, 1);
JanetByteView view = janet_getbytes(argv, 0);
if (janet_scan_number(view.bytes, view.len, &number))
return janet_wrap_nil();
return janet_wrap_number(number);
}
static Janet janet_core_tuple(int32_t argc, Janet *argv) {
return janet_wrap_tuple(janet_tuple_n(argv, argc));
}
static Janet janet_core_array(int32_t argc, Janet *argv) {
JanetArray *array = janet_array(argc);
array->count = argc;
safe_memcpy(array->data, argv, argc * sizeof(Janet));
return janet_wrap_array(array);
}
static Janet janet_core_slice(int32_t argc, Janet *argv) {
JanetRange range;
JanetByteView bview;
JanetView iview;
if (janet_bytes_view(argv[0], &bview.bytes, &bview.len)) {
range = janet_getslice(argc, argv);
return janet_stringv(bview.bytes + range.start, range.end - range.start);
} else if (janet_indexed_view(argv[0], &iview.items, &iview.len)) {
range = janet_getslice(argc, argv);
return janet_wrap_tuple(janet_tuple_n(iview.items + range.start, range.end - range.start));
} else {
janet_panic_type(argv[0], 0, JANET_TFLAG_BYTES | JANET_TFLAG_INDEXED);
}
}
static Janet janet_core_table(int32_t argc, Janet *argv) {
int32_t i;
if (argc & 1)
janet_panic("expected even number of arguments");
JanetTable *table = janet_table(argc >> 1);
for (i = 0; i < argc; i += 2) {
janet_table_put(table, argv[i], argv[i + 1]);
}
return janet_wrap_table(table);
}
static Janet janet_core_struct(int32_t argc, Janet *argv) {
int32_t i;
if (argc & 1)
janet_panic("expected even number of arguments");
JanetKV *st = janet_struct_begin(argc >> 1);
for (i = 0; i < argc; i += 2) {
janet_struct_put(st, argv[i], argv[i + 1]);
}
return janet_wrap_struct(janet_struct_end(st));
}
static Janet janet_core_gensym(int32_t argc, Janet *argv) {
(void) argv;
janet_fixarity(argc, 0);
return janet_wrap_symbol(janet_symbol_gen());
}
static Janet janet_core_gccollect(int32_t argc, Janet *argv) {
(void) argv;
(void) argc;
janet_collect();
return janet_wrap_nil();
}
static Janet janet_core_gcsetinterval(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
size_t s = janet_getsize(argv, 0);
/* limit interval to 48 bits */
#ifdef JANET_64
if (s >> 48) {
janet_panic("interval too large");
}
#endif
janet_vm_gc_interval = s;
return janet_wrap_nil();
}
static Janet janet_core_gcinterval(int32_t argc, Janet *argv) {
(void) argv;
janet_fixarity(argc, 0);
return janet_wrap_number((double) janet_vm_gc_interval);
}
static Janet janet_core_type(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
JanetType t = janet_type(argv[0]);
if (t == JANET_ABSTRACT) {
return janet_ckeywordv(janet_abstract_type(janet_unwrap_abstract(argv[0]))->name);
} else {
return janet_ckeywordv(janet_type_names[t]);
}
}
static Janet janet_core_hash(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
return janet_wrap_number(janet_hash(argv[0]));
}
static Janet janet_core_getline(int32_t argc, Janet *argv) {
FILE *in = janet_dynfile("in", stdin);
FILE *out = janet_dynfile("out", stdout);
janet_arity(argc, 0, 3);
JanetBuffer *buf = (argc >= 2) ? janet_getbuffer(argv, 1) : janet_buffer(10);
if (argc >= 1) {
const char *prompt = (const char *) janet_getstring(argv, 0);
fprintf(out, "%s", prompt);
fflush(out);
}
{
buf->count = 0;
int c;
for (;;) {
c = fgetc(in);
if (feof(in) || c < 0) {
break;
}
janet_buffer_push_u8(buf, (uint8_t) c);
if (c == '\n') break;
}
}
return janet_wrap_buffer(buf);
}
static Janet janet_core_trace(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
JanetFunction *func = janet_getfunction(argv, 0);
func->gc.flags |= JANET_FUNCFLAG_TRACE;
return argv[0];
}
static Janet janet_core_untrace(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
JanetFunction *func = janet_getfunction(argv, 0);
func->gc.flags &= ~JANET_FUNCFLAG_TRACE;
return argv[0];
}
static Janet janet_core_check_int(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
double num = janet_unwrap_number(argv[0]);
return janet_wrap_boolean(num == (double)((int32_t)num));
ret_false:
return janet_wrap_false();
}
static Janet janet_core_check_nat(int32_t argc, Janet *argv) {
janet_fixarity(argc, 1);
if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
double num = janet_unwrap_number(argv[0]);
return janet_wrap_boolean(num >= 0 && (num == (double)((int32_t)num)));
ret_false:
return janet_wrap_false();
}
static Janet janet_core_signal(int32_t argc, Janet *argv) {
janet_arity(argc, 1, 2);
int sig;
if (janet_checkint(argv[0])) {
int32_t s = janet_unwrap_integer(argv[0]);
if (s < 0 || s > 9) {
janet_panicf("expected user signal between 0 and 9, got %d", s);
}
sig = JANET_SIGNAL_USER0 + s;
} else {
JanetKeyword kw = janet_getkeyword(argv, 0);
if (!janet_cstrcmp(kw, "yield")) {
sig = JANET_SIGNAL_YIELD;
} else if (!janet_cstrcmp(kw, "error")) {
sig = JANET_SIGNAL_ERROR;
} else if (!janet_cstrcmp(kw, "debug")) {
sig = JANET_SIGNAL_DEBUG;
} else {
janet_panicf("unknown signal, expected :yield, :error, or :debug, got %v", argv[0]);
}
}
Janet payload = argc == 2 ? argv[1] : janet_wrap_nil();
janet_signalv(sig, payload);
}
static const JanetReg corelib_cfuns[] = {
{
"native", janet_core_native,
JDOC("(native path &opt env)\n\n"
"Load a native module from the given path. The path "
"must be an absolute or relative path on the file system, and is "
"usually a .so file on Unix systems, and a .dll file on Windows. "
"Returns an environment table that contains functions and other values "
"from the native module.")
},
{
"describe", janet_core_describe,
JDOC("(describe x)\n\n"
"Returns a string that is a human-readable description of a value x.")
},
{
"string", janet_core_string,
JDOC("(string & xs)\n\n"
"Creates a string by concatenating the elements of `xs` together. If an "
"element is not a byte sequence, it is converted to bytes via `describe`. "
"Returns the new string.")
},
{
"symbol", janet_core_symbol,
JDOC("(symbol & xs)\n\n"
"Creates a symbol by concatenating the elements of `xs` together. If an "
"element is not a byte sequence, it is converted to bytes via `describe`. "
"Returns the new symbol.")
},
{
"keyword", janet_core_keyword,
JDOC("(keyword & xs)\n\n"
"Creates a keyword by concatenating the elements of `xs` together. If an "
"element is not a byte sequence, it is converted to bytes via `describe`. "
"Returns the new keyword.")
},
{
"buffer", janet_core_buffer,
JDOC("(buffer & xs)\n\n"
"Creates a buffer by concatenating the elements of `xs` together. If an "
"element is not a byte sequence, it is converted to bytes via `describe`. "
"Returns the new buffer.")
},
{
"abstract?", janet_core_is_abstract,
JDOC("(abstract? x)\n\n"
"Check if x is an abstract type.")
},
{
"table", janet_core_table,
JDOC("(table & kvs)\n\n"
"Creates a new table from a variadic number of keys and values. "
"kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has "
"an odd number of elements, an error will be thrown. Returns the "
"new table.")
},
{
"array", janet_core_array,
JDOC("(array & items)\n\n"
"Create a new array that contains items. Returns the new array.")
},
{
"scan-number", janet_core_scannumber,
JDOC("(scan-number str)\n\n"
"Parse a number from a byte sequence an return that number, either and integer "
"or a real. The number "
"must be in the same format as numbers in janet source code. Will return nil "
"on an invalid number.")
},
{
"tuple", janet_core_tuple,
JDOC("(tuple & items)\n\n"
"Creates a new tuple that contains items. Returns the new tuple.")
},
{
"struct", janet_core_struct,
JDOC("(struct & kvs)\n\n"
"Create a new struct from a sequence of key value pairs. "
"kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has "
"an odd number of elements, an error will be thrown. Returns the "
"new struct.")
},
{
"gensym", janet_core_gensym,
JDOC("(gensym)\n\n"
"Returns a new symbol that is unique across the runtime. This means it "
"will not collide with any already created symbols during compilation, so "
"it can be used in macros to generate automatic bindings.")
},
{
"gccollect", janet_core_gccollect,
JDOC("(gccollect)\n\n"
"Run garbage collection. You should probably not call this manually.")
},
{
"gcsetinterval", janet_core_gcsetinterval,
JDOC("(gcsetinterval interval)\n\n"
"Set an integer number of bytes to allocate before running garbage collection. "
"Low values for interval will be slower but use less memory. "
"High values will be faster but use more memory.")
},
{
"gcinterval", janet_core_gcinterval,
JDOC("(gcinterval)\n\n"
"Returns the integer number of bytes to allocate before running an iteration "
"of garbage collection.")
},
{
"type", janet_core_type,
JDOC("(type x)\n\n"
"Returns the type of `x` as a keyword. `x` is one of:\n\n"
"* :nil\n\n"
"* :boolean\n\n"
"* :number\n\n"
"* :array\n\n"
"* :tuple\n\n"
"* :table\n\n"
"* :struct\n\n"
"* :string\n\n"
"* :buffer\n\n"
"* :symbol\n\n"
"* :keyword\n\n"
"* :function\n\n"
"* :cfunction\n\n"
"* :fiber\n\n"
"or another keyword for an abstract type.")
},
{
"hash", janet_core_hash,
JDOC("(hash value)\n\n"
"Gets a hash for any value. The hash is an integer can be used "
"as a cheap hash function for all values. If two values are strictly equal, "
"then they will have the same hash value.")
},
{
"getline", janet_core_getline,
JDOC("(getline &opt prompt buf env)\n\n"
"Reads a line of input into a buffer, including the newline character, using a prompt. "
"An optional environment table can be provided for auto-complete. "
"Returns the modified buffer. "
"Use this function to implement a simple interface for a terminal program.")
},
{
"dyn", janet_core_dyn,
JDOC("(dyn key &opt default)\n\n"
"Get a dynamic binding. Returns the default value (or nil) if no binding found.")
},
{
"setdyn", janet_core_setdyn,
JDOC("(setdyn key value)\n\n"
"Set a dynamic binding. Returns value.")
},
{
"trace", janet_core_trace,
JDOC("(trace func)\n\n"
"Enable tracing on a function. Returns the function.")
},
{
"untrace", janet_core_untrace,
JDOC("(untrace func)\n\n"
"Disables tracing on a function. Returns the function.")
},
{
"module/expand-path", janet_core_expand_path,
JDOC("(module/expand-path path template)\n\n"
"Expands a path template as found in `module/paths` for `module/find`. "
"This takes in a path (the argument to require) and a template string, "
"to expand the path to a path that can be "
"used for importing files. The replacements are as follows:\n\n"
"* :all: -- the value of path verbatim\n\n"
"* :cur: -- the current file, or (dyn :current-file)\n\n"
"* :dir: -- the directory containing the current file\n\n"
"* :name: -- the name component of path, with extension if given\n\n"
"* :native: -- the extension used to load natives, .so or .dll\n\n"
"* :sys: -- the system path, or (dyn :syspath)")
},
{
"int?", janet_core_check_int,
JDOC("(int? x)\n\n"
"Check if x can be exactly represented as a 32 bit signed two's complement integer.")
},
{
"nat?", janet_core_check_nat,
JDOC("(nat? x)\n\n"
"Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.")
},
{
"slice", janet_core_slice,
JDOC("(slice x &opt start end)\n\n"
"Extract a sub-range of an indexed data structure or byte sequence.")
},
{
"signal", janet_core_signal,
JDOC("(signal what x)\n\n"
"Raise a signal with payload x. ")
},
{NULL, NULL, NULL}
};
#ifdef JANET_BOOTSTRAP
/* Utility for inline assembly */
static void janet_quick_asm(
JanetTable *env,
int32_t flags,
const char *name,
int32_t arity,
int32_t min_arity,
int32_t max_arity,
int32_t slots,
const uint32_t *bytecode,
size_t bytecode_size,
const char *doc) {
JanetFuncDef *def = janet_funcdef_alloc();
def->arity = arity;
def->min_arity = min_arity;
def->max_arity = max_arity;
def->flags = flags;
def->slotcount = slots;
def->bytecode = janet_malloc(bytecode_size);
def->bytecode_length = (int32_t)(bytecode_size / sizeof(uint32_t));
def->name = janet_cstring(name);
if (!def->bytecode) {
JANET_OUT_OF_MEMORY;
}
memcpy(def->bytecode, bytecode, bytecode_size);
janet_def_addflags(def);
janet_def(env, name, janet_wrap_function(janet_thunk(def)), doc);
}
/* Macros for easier inline assembly */
#define SSS(op, a, b, c) ((op) | ((a) << 8) | ((b) << 16) | ((c) << 24))
#define SS(op, a, b) ((op) | ((a) << 8) | ((b) << 16))
#define SSI(op, a, b, I) ((op) | ((a) << 8) | ((b) << 16) | ((uint32_t)(I) << 24))
#define S(op, a) ((op) | ((a) << 8))
#define SI(op, a, I) ((op) | ((a) << 8) | ((uint32_t)(I) << 16))
/* Templatize a varop */
static void templatize_varop(
JanetTable *env,
int32_t flags,
const char *name,
int32_t nullary,
int32_t unary,
uint32_t op,
const char *doc) {
/* Variadic operator assembly. Must be templatized for each different opcode. */
/* Reg 0: Argument tuple (args) */
/* Reg 1: Argument count (argn) */
/* Reg 2: Jump flag (jump?) */
/* Reg 3: Accumulator (accum) */
/* Reg 4: Next operand (operand) */
/* Reg 5: Loop iterator (i) */
uint32_t varop_asm[] = {
SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
/* Check nullary */
SSS(JOP_EQUALS_IMMEDIATE, 2, 1, 0), /* Check if numargs equal to 0 */
SI(JOP_JUMP_IF_NOT, 2, 3), /* If not 0, jump to next check */
/* Nullary */
SI(JOP_LOAD_INTEGER, 3, nullary), /* accum = nullary value */
S(JOP_RETURN, 3), /* return accum */
/* Check unary */
SSI(JOP_EQUALS_IMMEDIATE, 2, 1, 1), /* Check if numargs equal to 1 */
SI(JOP_JUMP_IF_NOT, 2, 5), /* If not 1, jump to next check */
/* Unary */
SI(JOP_LOAD_INTEGER, 3, unary), /* accum = unary value */
SSI(JOP_GET_INDEX, 4, 0, 0), /* operand = args[0] */
SSS(op, 3, 3, 4), /* accum = accum op operand */
S(JOP_RETURN, 3), /* return accum */
/* Mutli (2 or more) arity */
/* Prime loop */
SSI(JOP_GET_INDEX, 3, 0, 0), /* accum = args[0] */
SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */
/* Main loop */
SSS(JOP_IN, 4, 0, 5), /* operand = args[i] */
SSS(op, 3, 3, 4), /* accum = accum op operand */
SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */
SI(JOP_JUMP_IF_NOT, 2, -4), /* if not jump? go back 4 */
/* Done, do last and return accumulator */
S(JOP_RETURN, 3) /* return accum */
};
janet_quick_asm(
env,
flags | JANET_FUNCDEF_FLAG_VARARG,
name,
0,
0,
INT32_MAX,
6,
varop_asm,
sizeof(varop_asm),
doc);
}
/* Templatize variadic comparators */
static void templatize_comparator(
JanetTable *env,
int32_t flags,
const char *name,
int invert,
uint32_t op,
const char *doc) {
/* Reg 0: Argument tuple (args) */
/* Reg 1: Argument count (argn) */
/* Reg 2: Jump flag (jump?) */
/* Reg 3: Last value (last) */
/* Reg 4: Next operand (next) */
/* Reg 5: Loop iterator (i) */
uint32_t comparator_asm[] = {
SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
SSS(JOP_LESS_THAN_IMMEDIATE, 2, 1, 2), /* Check if numargs less than 2 */
SI(JOP_JUMP_IF, 2, 10), /* If numargs < 2, jump to done */
/* Prime loop */
SSI(JOP_GET_INDEX, 3, 0, 0), /* last = args[0] */
SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */
/* Main loop */
SSS(JOP_IN, 4, 0, 5), /* next = args[i] */
SSS(op, 2, 3, 4), /* jump? = last compare next */
SI(JOP_JUMP_IF_NOT, 2, 7), /* if not jump? goto fail (return false) */
SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
SS(JOP_MOVE_NEAR, 3, 4), /* last = next */
SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */
SI(JOP_JUMP_IF_NOT, 2, -6), /* if not jump? go back 6 */
/* Done, return true */
S(invert ? JOP_LOAD_FALSE : JOP_LOAD_TRUE, 3),
S(JOP_RETURN, 3),
/* Failed, return false */
S(invert ? JOP_LOAD_TRUE : JOP_LOAD_FALSE, 3),
S(JOP_RETURN, 3)
};
janet_quick_asm(
env,
flags | JANET_FUNCDEF_FLAG_VARARG,
name,
0,
0,
INT32_MAX,
6,
comparator_asm,
sizeof(comparator_asm),
doc);
}
/* Make the apply function */
static void make_apply(JanetTable *env) {
/* Reg 0: Function (fun) */
/* Reg 1: Argument tuple (args) */
/* Reg 2: Argument count (argn) */
/* Reg 3: Jump flag (jump?) */
/* Reg 4: Loop iterator (i) */
/* Reg 5: Loop values (x) */
uint32_t apply_asm[] = {
SS(JOP_LENGTH, 2, 1),
SSS(JOP_EQUALS_IMMEDIATE, 3, 2, 0), /* Immediate tail call if no args */
SI(JOP_JUMP_IF, 3, 9),
/* Prime loop */
SI(JOP_LOAD_INTEGER, 4, 0), /* i = 0 */
/* Main loop */
SSS(JOP_IN, 5, 1, 4), /* x = args[i] */
SSI(JOP_ADD_IMMEDIATE, 4, 4, 1), /* i++ */
SSI(JOP_EQUALS, 3, 4, 2), /* jump? = (i == argn) */
SI(JOP_JUMP_IF, 3, 3), /* if jump? go forward 3 */
S(JOP_PUSH, 5),
(JOP_JUMP | ((uint32_t)(-5) << 8)),
/* Push the array */
S(JOP_PUSH_ARRAY, 5),
/* Call the funciton */
S(JOP_TAILCALL, 0)
};
janet_quick_asm(env, JANET_FUN_APPLY | JANET_FUNCDEF_FLAG_VARARG,
"apply", 1, 1, INT32_MAX, 6, apply_asm, sizeof(apply_asm),
JDOC("(apply f & args)\n\n"
"Applies a function to a variable number of arguments. Each element in args "
"is used as an argument to f, except the last element in args, which is expected to "
"be an array-like. Each element in this last argument is then also pushed as an argument to "
"f. For example:\n\n"
"\t(apply + 1000 (range 10))\n\n"
"sums the first 10 integers and 1000."));
}
static const uint32_t error_asm[] = {
JOP_ERROR
};
static const uint32_t debug_asm[] = {
JOP_SIGNAL | (2 << 24),
JOP_RETURN
};
static const uint32_t yield_asm[] = {
JOP_SIGNAL | (3 << 24),
JOP_RETURN
};
static const uint32_t resume_asm[] = {
JOP_RESUME | (1 << 24),
JOP_RETURN
};
static const uint32_t cancel_asm[] = {
JOP_CANCEL | (1 << 24),
JOP_RETURN
};
static const uint32_t in_asm[] = {
JOP_IN | (1 << 24),
JOP_LOAD_NIL | (3 << 8),
JOP_EQUALS | (3 << 8) | (3 << 24),
JOP_JUMP_IF | (3 << 8) | (2 << 16),
JOP_RETURN,
JOP_RETURN | (2 << 8)
};
static const uint32_t get_asm[] = {
JOP_GET | (1 << 24),
JOP_LOAD_NIL | (3 << 8),
JOP_EQUALS | (3 << 8) | (3 << 24),
JOP_JUMP_IF | (3 << 8) | (2 << 16),
JOP_RETURN,
JOP_RETURN | (2 << 8)
};
static const uint32_t put_asm[] = {
JOP_PUT | (1 << 16) | (2 << 24),
JOP_RETURN
};
static const uint32_t length_asm[] = {
JOP_LENGTH,
JOP_RETURN
};
static const uint32_t bnot_asm[] = {
JOP_BNOT,
JOP_RETURN
};
static const uint32_t propagate_asm[] = {
JOP_PROPAGATE | (1 << 24),
JOP_RETURN
};
static const uint32_t next_asm[] = {
JOP_NEXT | (1 << 24),
JOP_RETURN
};
static const uint32_t modulo_asm[] = {
JOP_MODULO | (1 << 24),
JOP_RETURN
};
static const uint32_t remainder_asm[] = {
JOP_REMAINDER | (1 << 24),
JOP_RETURN
};
static const uint32_t cmp_asm[] = {
JOP_COMPARE | (1 << 24),
JOP_RETURN
};
#endif /* ifdef JANET_BOOTSTRAP */
/*
* Setup Environment
*/
static void janet_load_libs(JanetTable *env) {
janet_core_cfuns(env, NULL, corelib_cfuns);
janet_lib_io(env);
janet_lib_math(env);
janet_lib_array(env);
janet_lib_tuple(env);
janet_lib_buffer(env);
janet_lib_table(env);
janet_lib_fiber(env);
janet_lib_os(env);
janet_lib_parse(env);
janet_lib_compile(env);
janet_lib_debug(env);
janet_lib_string(env);
janet_lib_marsh(env);
#ifdef JANET_PEG
janet_lib_peg(env);
#endif
#ifdef JANET_ASSEMBLER
janet_lib_asm(env);
#endif
#ifdef JANET_INT_TYPES
janet_lib_inttypes(env);
#endif
#ifdef JANET_THREADS
janet_lib_thread(env);
#endif
#ifdef JANET_EV
janet_lib_ev(env);
#endif
#ifdef JANET_NET
janet_lib_net(env);
#endif
}
#ifdef JANET_BOOTSTRAP
JanetTable *janet_core_env(JanetTable *replacements) {
JanetTable *env = (NULL != replacements) ? replacements : janet_table(0);
janet_quick_asm(env, JANET_FUN_MODULO,
"mod", 2, 2, 2, 2, modulo_asm, sizeof(modulo_asm),
JDOC("(mod dividend divisor)\n\n"
"Returns the modulo of dividend / divisor."));
janet_quick_asm(env, JANET_FUN_REMAINDER,
"%", 2, 2, 2, 2, remainder_asm, sizeof(remainder_asm),
JDOC("(% dividend divisor)\n\n"
"Returns the remainder of dividend / divisor."));
janet_quick_asm(env, JANET_FUN_CMP,
"cmp", 2, 2, 2, 2, cmp_asm, sizeof(cmp_asm),
JDOC("(cmp x y)\n\n"
"Returns -1 if x is strictly less than y, 1 if y is strictly greater "
"than x, and 0 otherwise. To return 0, x and y must be the exact same type."));
janet_quick_asm(env, JANET_FUN_NEXT,
"next", 2, 1, 2, 2, next_asm, sizeof(next_asm),
JDOC("(next ds &opt key)\n\n"
"Gets the next key in a data structure. Can be used to iterate through "
"the keys of a data structure in an unspecified order. Keys are guaranteed "
"to be seen only once per iteration if they data structure is not mutated "
"during iteration. If key is nil, next returns the first key. If next "
"returns nil, there are no more keys to iterate through."));
janet_quick_asm(env, JANET_FUN_PROP,
"propagate", 2, 2, 2, 2, propagate_asm, sizeof(propagate_asm),
JDOC("(propagate x fiber)\n\n"
"Propagate a signal from a fiber to the current fiber. The resulting "
"stack trace from the current fiber will include frames from fiber. If "
"fiber is in a state that can be resumed, resuming the current fiber will "
"first resume fiber. This function can be used to re-raise an error without "
"losing the original stack trace."));
janet_quick_asm(env, JANET_FUN_DEBUG,
"debug", 1, 0, 1, 1, debug_asm, sizeof(debug_asm),
JDOC("(debug &opt x)\n\n"
"Throws a debug signal that can be caught by a parent fiber and used to inspect "
"the running state of the current fiber. Returns the value passed in by resume."));
janet_quick_asm(env, JANET_FUN_ERROR,
"error", 1, 1, 1, 1, error_asm, sizeof(error_asm),
JDOC("(error e)\n\n"
"Throws an error e that can be caught and handled by a parent fiber."));
janet_quick_asm(env, JANET_FUN_YIELD,
"yield", 1, 0, 1, 2, yield_asm, sizeof(yield_asm),
JDOC("(yield &opt x)\n\n"
"Yield a value to a parent fiber. When a fiber yields, its execution is paused until "
"another thread resumes it. The fiber will then resume, and the last yield call will "
"return the value that was passed to resume."));
janet_quick_asm(env, JANET_FUN_CANCEL,
"cancel", 2, 2, 2, 2, cancel_asm, sizeof(cancel_asm),
JDOC("(cancel fiber err)\n\n"
"Resume a fiber but have it immediately raise an error. This lets a programmer unwind a pending fiber. "
"Returns the same result as resume."));
janet_quick_asm(env, JANET_FUN_RESUME,
"resume", 2, 1, 2, 2, resume_asm, sizeof(resume_asm),
JDOC("(resume fiber &opt x)\n\n"
"Resume a new or suspended fiber and optionally pass in a value to the fiber that "
"will be returned to the last yield in the case of a pending fiber, or the argument to "
"the dispatch function in the case of a new fiber. Returns either the return result of "
"the fiber's dispatch function, or the value from the next yield call in fiber."));
janet_quick_asm(env, JANET_FUN_IN,
"in", 3, 2, 3, 4, in_asm, sizeof(in_asm),
JDOC("(in ds key &opt dflt)\n\n"
"Get value in ds at key, works on associative data structures. Arrays, tuples, tables, structs, "
"strings, symbols, and buffers are all associative and can be used. Arrays, tuples, strings, buffers, "
"and symbols must use integer keys that are in bounds or an error is raised. Structs and tables can "
"take any value as a key except nil and will return nil or dflt if not found."));
janet_quick_asm(env, JANET_FUN_GET,
"get", 3, 2, 3, 4, get_asm, sizeof(in_asm),
JDOC("(get ds key &opt dflt)\n\n"
"Get the value mapped to key in data structure ds, and return dflt or nil if not found. "
"Similar to in, but will not throw an error if the key is invalid for the data structure "
"unless the data structure is an abstract type. In that case, the abstract type getter may throw "
"an error."));
janet_quick_asm(env, JANET_FUN_PUT,
"put", 3, 3, 3, 3, put_asm, sizeof(put_asm),
JDOC("(put ds key value)\n\n"
"Associate a key with a value in any mutable associative data structure. Indexed data structures "
"(arrays and buffers) only accept non-negative integer keys, and will expand if an out of bounds "
"value is provided. In an array, extra space will be filled with nils, and in a buffer, extra "
"space will be filled with 0 bytes. In a table, putting a key that is contained in the table prototype "
"will hide the association defined by the prototype, but will not mutate the prototype table. Putting "
"a value nil into a table will remove the key from the table. Returns the data structure ds."));
janet_quick_asm(env, JANET_FUN_LENGTH,
"length", 1, 1, 1, 1, length_asm, sizeof(length_asm),
JDOC("(length ds)\n\n"
"Returns the length or count of a data structure in constant time as an integer. For "
"structs and tables, returns the number of key-value pairs in the data structure."));
janet_quick_asm(env, JANET_FUN_BNOT,
"bnot", 1, 1, 1, 1, bnot_asm, sizeof(bnot_asm),
JDOC("(bnot x)\n\nReturns the bit-wise inverse of integer x."));
make_apply(env);
/* Variadic ops */
templatize_varop(env, JANET_FUN_ADD, "+", 0, 0, JOP_ADD,
JDOC("(+ & xs)\n\n"
"Returns the sum of all xs. xs must be integers or real numbers only. If xs is empty, return 0."));
templatize_varop(env, JANET_FUN_SUBTRACT, "-", 0, 0, JOP_SUBTRACT,
JDOC("(- & xs)\n\n"
"Returns the difference of xs. If xs is empty, returns 0. If xs has one element, returns the "
"negative value of that element. Otherwise, returns the first element in xs minus the sum of "
"the rest of the elements."));
templatize_varop(env, JANET_FUN_MULTIPLY, "*", 1, 1, JOP_MULTIPLY,
JDOC("(* & xs)\n\n"
"Returns the product of all elements in xs. If xs is empty, returns 1."));
templatize_varop(env, JANET_FUN_DIVIDE, "/", 1, 1, JOP_DIVIDE,
JDOC("(/ & xs)\n\n"
"Returns the quotient of xs. If xs is empty, returns 1. If xs has one value x, returns "
"the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining "
"values."));
templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND,
JDOC("(band & xs)\n\n"
"Returns the bit-wise and of all values in xs. Each x in xs must be an integer."));
templatize_varop(env, JANET_FUN_BOR, "bor", 0, 0, JOP_BOR,
JDOC("(bor & xs)\n\n"
"Returns the bit-wise or of all values in xs. Each x in xs must be an integer."));
templatize_varop(env, JANET_FUN_BXOR, "bxor", 0, 0, JOP_BXOR,
JDOC("(bxor & xs)\n\n"
"Returns the bit-wise xor of all values in xs. Each in xs must be an integer."));
templatize_varop(env, JANET_FUN_LSHIFT, "blshift", 1, 1, JOP_SHIFT_LEFT,
JDOC("(blshift x & shifts)\n\n"
"Returns the value of x bit shifted left by the sum of all values in shifts. x "
"and each element in shift must be an integer."));
templatize_varop(env, JANET_FUN_RSHIFT, "brshift", 1, 1, JOP_SHIFT_RIGHT,
JDOC("(brshift x & shifts)\n\n"
"Returns the value of x bit shifted right by the sum of all values in shifts. x "
"and each element in shift must be an integer."));
templatize_varop(env, JANET_FUN_RSHIFTU, "brushift", 1, 1, JOP_SHIFT_RIGHT_UNSIGNED,
JDOC("(brushift x & shifts)\n\n"
"Returns the value of x bit shifted right by the sum of all values in shifts. x "
"and each element in shift must be an integer. The sign of x is not preserved, so "
"for positive shifts the return value will always be positive."));
/* Variadic comparators */
templatize_comparator(env, JANET_FUN_GT, ">", 0, JOP_GREATER_THAN,
JDOC("(> & xs)\n\n"
"Check if xs is in descending order. Returns a boolean."));
templatize_comparator(env, JANET_FUN_LT, "<", 0, JOP_LESS_THAN,
JDOC("(< & xs)\n\n"
"Check if xs is in ascending order. Returns a boolean."));
templatize_comparator(env, JANET_FUN_GTE, ">=", 0, JOP_GREATER_THAN_EQUAL,
JDOC("(>= & xs)\n\n"
"Check if xs is in non-ascending order. Returns a boolean."));
templatize_comparator(env, JANET_FUN_LTE, "<=", 0, JOP_LESS_THAN_EQUAL,
JDOC("(<= & xs)\n\n"
"Check if xs is in non-descending order. Returns a boolean."));
templatize_comparator(env, JANET_FUN_EQ, "=", 0, JOP_EQUALS,
JDOC("(= & xs)\n\n"
"Check if all values in xs are equal. Returns a boolean."));
templatize_comparator(env, JANET_FUN_NEQ, "not=", 1, JOP_EQUALS,
JDOC("(not= & xs)\n\n"
"Check if any values in xs are not equal. Returns a boolean."));
/* Platform detection */
janet_def(env, "janet/version", janet_cstringv(JANET_VERSION),
JDOC("The version number of the running janet program."));
janet_def(env, "janet/build", janet_cstringv(JANET_BUILD),
JDOC("The build identifier of the running janet program."));
janet_def(env, "janet/config-bits", janet_wrap_integer(JANET_CURRENT_CONFIG_BITS),
JDOC("The flag set of config options from janetconf.h which is used to check "
"if native modules are compatible with the host program."));
/* Allow references to the environment */
janet_def(env, "root-env", janet_wrap_table(env),
JDOC("The root environment used to create environments with (make-env)."));
janet_load_libs(env);
janet_gcroot(janet_wrap_table(env));
return env;
}
#else
JanetTable *janet_core_env(JanetTable *replacements) {
/* Memoize core env, ignoring replacements the second time around. */
if (NULL != janet_vm_core_env) {
return janet_vm_core_env;
}
JanetTable *dict = janet_core_lookup_table(replacements);
/* Unmarshal bytecode */
Janet marsh_out = janet_unmarshal(
janet_core_image,
janet_core_image_size,
0,
dict,
NULL);
/* Memoize */
janet_gcroot(marsh_out);
JanetTable *env = janet_unwrap_table(marsh_out);
janet_vm_core_env = env;
/* Invert image dict manually here. We can't do this in boot.janet as it
* breaks deterministic builds */
Janet lidv, midv;
lidv = midv = janet_wrap_nil();
janet_resolve(env, janet_csymbol("load-image-dict"), &lidv);
janet_resolve(env, janet_csymbol("make-image-dict"), &midv);
JanetTable *lid = janet_unwrap_table(lidv);
JanetTable *mid = janet_unwrap_table(midv);
for (int32_t i = 0; i < lid->capacity; i++) {
const JanetKV *kv = lid->data + i;
if (!janet_checktype(kv->key, JANET_NIL)) {
janet_table_put(mid, kv->value, kv->key);
}
}
return env;
}
#endif
JanetTable *janet_core_lookup_table(JanetTable *replacements) {
JanetTable *dict = janet_table(512);
janet_load_libs(dict);
/* Add replacements */
if (replacements != NULL) {
for (int32_t i = 0; i < replacements->capacity; i++) {
JanetKV kv = replacements->data[i];
if (!janet_checktype(kv.key, JANET_NIL)) {
janet_table_put(dict, kv.key, kv.value);
if (janet_checktype(kv.value, JANET_CFUNCTION)) {
janet_table_put(janet_vm_registry, kv.value, kv.key);
}
}
}
}
return dict;
}
Reference in New Issue View Git Blame Copy Permalink