/* * Copyright (c) 2022 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 #include #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 /* Docstrings should only exist during bootstrap */ #ifdef JANET_BOOTSTRAP #define JDOC(x) (x) #else #define JDOC(x) NULL #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" #define free_clib(c) ((void) (c), 0) #elif defined(JANET_WINDOWS) #include typedef HINSTANCE Clib; #define load_clib(name) LoadLibrary((name)) #define free_clib(c) FreeLibrary((c)) #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 typedef void *Clib; #define load_clib(name) dlopen((name), RTLD_NOW) #define free_clib(lib) dlclose((lib)) #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; } typedef struct { Clib clib; int closed; } JanetAbstractNative; static const JanetAbstractType janet_native_type = { "core/native", JANET_ATEND_NAME }; 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", x); } return cstr; } static int is_path_sep(char c) { #ifdef JANET_WINDOWS if (c == '\\') return 1; #endif return c == '/'; } /* Used for module system. */ JANET_CORE_FN(janet_core_expand_path, "(module/expand-path path template)", "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)") { 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); } JANET_CORE_FN(janet_core_dyn, "(dyn key &opt default)", "Get a dynamic binding. Returns the default value (or nil) if no binding found.") { 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; } JANET_CORE_FN(janet_core_setdyn, "(setdyn key value)", "Set a dynamic binding. Returns value.") { 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]; } JANET_CORE_FN(janet_core_native, "(native path &opt env)", "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.") { 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); } JANET_CORE_FN(janet_core_raw_native, "(raw-native path)", "Load a shared object or dll from the given path, and do not extract" " or run any code from it. This is different than `native`, which will " "run initialization code to get a module table. Returns a `core/native`.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); char *processed_name = get_processed_name(path); Clib lib = load_clib(processed_name); if (path != processed_name) janet_free(processed_name); if (!lib) janet_panic(error_clib()); JanetAbstractNative *anative = janet_abstract(&janet_native_type, sizeof(JanetAbstractNative)); anative->clib = lib; anative->closed = 0; return janet_wrap_abstract(anative); } JANET_CORE_FN(janet_core_native_lookup, "(native-lookup native symbol-name)", "Lookup a symbol from a native object. All symbol lookups will return a raw pointer " "if the symbol is found, else nil.") { janet_fixarity(argc, 2); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); const char *sym = janet_getcstring(argv, 1); if (anative->closed) janet_panic("native object already closed"); void *value = symbol_clib(anative->clib, sym); if (NULL == value) return janet_wrap_nil(); return janet_wrap_pointer(value); } JANET_CORE_FN(janet_core_native_close, "(native-close native)", "Free a native object. Dereferencing pointers to symbols in the object will have undefined " "behavior after freeing.") { janet_fixarity(argc, 1); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); if (anative->closed) janet_panic("native object already closed"); anative->closed = 1; free_clib(anative->clib); return janet_wrap_nil(); } JANET_CORE_FN(janet_core_describe, "(describe x)", "Returns a string that is a human-readable description of `x`. " "For recursive data structures, the string returned contains a " "pointer value from which the identity of `x` " "can be determined.") { 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); } JANET_CORE_FN(janet_core_string, "(string & xs)", "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.") { 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); } JANET_CORE_FN(janet_core_symbol, "(symbol & xs)", "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.") { 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); } JANET_CORE_FN(janet_core_keyword, "(keyword & xs)", "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.") { 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); } JANET_CORE_FN(janet_core_buffer, "(buffer & xs)", "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.") { 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); } JANET_CORE_FN(janet_core_is_abstract, "(abstract? x)", "Check if x is an abstract type.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktype(argv[0], JANET_ABSTRACT)); } JANET_CORE_FN(janet_core_scannumber, "(scan-number str &opt base)", "Parse a number from a byte sequence and return that number, either an 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. Optionally provide a base - if a base is provided, no " "radix specifier is expected at the beginning of the number.") { double number; janet_arity(argc, 1, 2); JanetByteView view = janet_getbytes(argv, 0); int32_t base = janet_optinteger(argv, argc, 1, 0); int valid = base == 0 || (base >= 2 && base <= 36); if (!valid) { janet_panicf("expected base between 2 and 36, got %d", base); } if (janet_scan_number_base(view.bytes, view.len, base, &number)) return janet_wrap_nil(); return janet_wrap_number(number); } JANET_CORE_FN(janet_core_tuple, "(tuple & items)", "Creates a new tuple that contains items. Returns the new tuple.") { return janet_wrap_tuple(janet_tuple_n(argv, argc)); } JANET_CORE_FN(janet_core_array, "(array & items)", "Create a new array that contains items. Returns the new array.") { JanetArray *array = janet_array(argc); array->count = argc; safe_memcpy(array->data, argv, argc * sizeof(Janet)); return janet_wrap_array(array); } JANET_CORE_FN(janet_core_slice, "(slice x &opt start end)", "Extract a sub-range of an indexed data structure or byte sequence.") { 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); } } JANET_CORE_FN(janet_core_table, "(table & kvs)", "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.") { 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); } JANET_CORE_FN(janet_core_getproto, "(getproto x)", "Get the prototype of a table or struct. Will return nil if `x` has no prototype.") { janet_fixarity(argc, 1); if (janet_checktype(argv[0], JANET_TABLE)) { JanetTable *t = janet_unwrap_table(argv[0]); return t->proto ? janet_wrap_table(t->proto) : janet_wrap_nil(); } if (janet_checktype(argv[0], JANET_STRUCT)) { JanetStruct st = janet_unwrap_struct(argv[0]); return janet_struct_proto(st) ? janet_wrap_struct(janet_struct_proto(st)) : janet_wrap_nil(); } janet_panicf("expected struct|table, got %v", argv[0]); } JANET_CORE_FN(janet_core_struct, "(struct & kvs)", "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.") { 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)); } JANET_CORE_FN(janet_core_gensym, "(gensym)", "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.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_symbol(janet_symbol_gen()); } JANET_CORE_FN(janet_core_gccollect, "(gccollect)", "Run garbage collection. You should probably not call this manually.") { (void) argv; (void) argc; janet_collect(); return janet_wrap_nil(); } JANET_CORE_FN(janet_core_gcsetinterval, "(gcsetinterval interval)", "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.") { 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(); } JANET_CORE_FN(janet_core_gcinterval, "(gcinterval)", "Returns the integer number of bytes to allocate before running an iteration " "of garbage collection.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_number((double) janet_vm.gc_interval); } JANET_CORE_FN(janet_core_type, "(type x)", "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.") { 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]); } } JANET_CORE_FN(janet_core_hash, "(hash value)", "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.") { janet_fixarity(argc, 1); return janet_wrap_number(janet_hash(argv[0])); } JANET_CORE_FN(janet_core_getline, "(getline &opt prompt buf env)", "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.") { 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); } JANET_CORE_FN(janet_core_trace, "(trace func)", "Enable tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags |= JANET_FUNCFLAG_TRACE; return argv[0]; } JANET_CORE_FN(janet_core_untrace, "(untrace func)", "Disables tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags &= ~JANET_FUNCFLAG_TRACE; return argv[0]; } JANET_CORE_FN(janet_core_check_int, "(int? x)", "Check if x can be exactly represented as a 32 bit signed two's complement integer.") { 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(); } JANET_CORE_FN(janet_core_check_nat, "(nat? x)", "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") { 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(); } JANET_CORE_FN(janet_core_signal, "(signal what x)", "Raise a signal with payload x. ") { 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); } #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) { JanetRegExt corelib_cfuns[] = { JANET_CORE_REG("native", janet_core_native), JANET_CORE_REG("raw-native", janet_core_raw_native), JANET_CORE_REG("native-lookup", janet_core_native_lookup), JANET_CORE_REG("native-close", janet_core_native_close), JANET_CORE_REG("describe", janet_core_describe), JANET_CORE_REG("string", janet_core_string), JANET_CORE_REG("symbol", janet_core_symbol), JANET_CORE_REG("keyword", janet_core_keyword), JANET_CORE_REG("buffer", janet_core_buffer), JANET_CORE_REG("abstract?", janet_core_is_abstract), JANET_CORE_REG("table", janet_core_table), JANET_CORE_REG("array", janet_core_array), JANET_CORE_REG("scan-number", janet_core_scannumber), JANET_CORE_REG("tuple", janet_core_tuple), JANET_CORE_REG("struct", janet_core_struct), JANET_CORE_REG("gensym", janet_core_gensym), JANET_CORE_REG("gccollect", janet_core_gccollect), JANET_CORE_REG("gcsetinterval", janet_core_gcsetinterval), JANET_CORE_REG("gcinterval", janet_core_gcinterval), JANET_CORE_REG("type", janet_core_type), JANET_CORE_REG("hash", janet_core_hash), JANET_CORE_REG("getline", janet_core_getline), JANET_CORE_REG("dyn", janet_core_dyn), JANET_CORE_REG("setdyn", janet_core_setdyn), JANET_CORE_REG("trace", janet_core_trace), JANET_CORE_REG("untrace", janet_core_untrace), JANET_CORE_REG("module/expand-path", janet_core_expand_path), JANET_CORE_REG("int?", janet_core_check_int), JANET_CORE_REG("nat?", janet_core_check_nat), JANET_CORE_REG("slice", janet_core_slice), JANET_CORE_REG("signal", janet_core_signal), JANET_CORE_REG("getproto", janet_core_getproto), JANET_REG_END }; janet_core_cfuns_ext(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_struct(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_EV janet_lib_ev(env); #endif #ifdef JANET_NET janet_lib_net(env); #endif #ifdef JANET_FFI janet_lib_ffi(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); /* Add replacement functions to registry? */ } } } return dict; }