1 /*
2 * Copyright (c) 2021 Calvin Rose
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a copy
5 * of this software and associated documentation files (the "Software"), to
6 * deal in the Software without restriction, including without limitation the
7 * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
8 * sell copies of the Software, and to permit persons to whom the Software is
9 * furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
20 * IN THE SOFTWARE.
21 */
22
23 #ifndef JANET_AMALG
24 #include "features.h"
25 #include <janet.h>
26 #include <math.h>
27 #include "compile.h"
28 #include "state.h"
29 #include "util.h"
30 #endif
31
32 /* Generated bytes */
33 #ifndef JANET_BOOTSTRAP
34 extern const unsigned char *janet_core_image;
35 extern size_t janet_core_image_size;
36 #endif
37
38 /* Docstrings should only exist during bootstrap */
39 #ifdef JANET_BOOTSTRAP
40 #define JDOC(x) (x)
41 #else
42 #define JDOC(x) NULL
43 #endif
44
45 /* Use LoadLibrary on windows or dlopen on posix to load dynamic libaries
46 * with native code. */
47 #if defined(JANET_NO_DYNAMIC_MODULES)
48 typedef int Clib;
49 #define load_clib(name) ((void) name, 0)
50 #define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL)
51 #define error_clib() "dynamic libraries not supported"
52 #elif defined(JANET_WINDOWS)
53 #include <windows.h>
54 typedef HINSTANCE Clib;
55 #define load_clib(name) LoadLibrary((name))
56 #define symbol_clib(lib, sym) GetProcAddress((lib), (sym))
57 static char error_clib_buf[256];
error_clib(void)58 static char *error_clib(void) {
59 FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
60 NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
61 error_clib_buf, sizeof(error_clib_buf), NULL);
62 error_clib_buf[strlen(error_clib_buf) - 1] = '\0';
63 return error_clib_buf;
64 }
65 #else
66 #include <dlfcn.h>
67 typedef void *Clib;
68 #define load_clib(name) dlopen((name), RTLD_NOW)
69 #define symbol_clib(lib, sym) dlsym((lib), (sym))
70 #define error_clib() dlerror()
71 #endif
72
get_processed_name(const char * name)73 static char *get_processed_name(const char *name) {
74 if (name[0] == '.') return (char *) name;
75 const char *c;
76 for (c = name; *c; c++) {
77 if (*c == '/') return (char *) name;
78 }
79 size_t l = (size_t)(c - name);
80 char *ret = janet_malloc(l + 3);
81 if (NULL == ret) {
82 JANET_OUT_OF_MEMORY;
83 }
84 ret[0] = '.';
85 ret[1] = '/';
86 memcpy(ret + 2, name, l + 1);
87 return ret;
88 }
89
janet_native(const char * name,const uint8_t ** error)90 JanetModule janet_native(const char *name, const uint8_t **error) {
91 char *processed_name = get_processed_name(name);
92 Clib lib = load_clib(processed_name);
93 JanetModule init;
94 JanetModconf getter;
95 if (name != processed_name) janet_free(processed_name);
96 if (!lib) {
97 *error = janet_cstring(error_clib());
98 return NULL;
99 }
100 init = (JanetModule) symbol_clib(lib, "_janet_init");
101 if (!init) {
102 *error = janet_cstring("could not find the _janet_init symbol");
103 return NULL;
104 }
105 getter = (JanetModconf) symbol_clib(lib, "_janet_mod_config");
106 if (!getter) {
107 *error = janet_cstring("could not find the _janet_mod_config symbol");
108 return NULL;
109 }
110 JanetBuildConfig modconf = getter();
111 JanetBuildConfig host = janet_config_current();
112 if (host.major != modconf.major ||
113 host.minor < modconf.minor ||
114 host.bits != modconf.bits) {
115 char errbuf[128];
116 sprintf(errbuf, "config mismatch - host %d.%.d.%d(%.4x) vs. module %d.%d.%d(%.4x)",
117 host.major,
118 host.minor,
119 host.patch,
120 host.bits,
121 modconf.major,
122 modconf.minor,
123 modconf.patch,
124 modconf.bits);
125 *error = janet_cstring(errbuf);
126 return NULL;
127 }
128 return init;
129 }
130
janet_dyncstring(const char * name,const char * dflt)131 static const char *janet_dyncstring(const char *name, const char *dflt) {
132 Janet x = janet_dyn(name);
133 if (janet_checktype(x, JANET_NIL)) return dflt;
134 if (!janet_checktype(x, JANET_STRING)) {
135 janet_panicf("expected string, got %v", x);
136 }
137 const uint8_t *jstr = janet_unwrap_string(x);
138 const char *cstr = (const char *)jstr;
139 if (strlen(cstr) != (size_t) janet_string_length(jstr)) {
140 janet_panicf("string %v contains embedded 0s", x);
141 }
142 return cstr;
143 }
144
is_path_sep(char c)145 static int is_path_sep(char c) {
146 #ifdef JANET_WINDOWS
147 if (c == '\\') return 1;
148 #endif
149 return c == '/';
150 }
151
152 /* Used for module system. */
153 JANET_CORE_FN(janet_core_expand_path,
154 "(module/expand-path path template)",
155 "Expands a path template as found in `module/paths` for `module/find`. "
156 "This takes in a path (the argument to require) and a template string, "
157 "to expand the path to a path that can be "
158 "used for importing files. The replacements are as follows:\n\n"
159 "* :all: -- the value of path verbatim\n\n"
160 "* :cur: -- the current file, or (dyn :current-file)\n\n"
161 "* :dir: -- the directory containing the current file\n\n"
162 "* :name: -- the name component of path, with extension if given\n\n"
163 "* :native: -- the extension used to load natives, .so or .dll\n\n"
164 "* :sys: -- the system path, or (dyn :syspath)") {
165 janet_fixarity(argc, 2);
166 const char *input = janet_getcstring(argv, 0);
167 const char *template = janet_getcstring(argv, 1);
168 const char *curfile = janet_dyncstring("current-file", "");
169 const char *syspath = janet_dyncstring("syspath", "");
170 JanetBuffer *out = janet_buffer(0);
171 size_t tlen = strlen(template);
172
173 /* Calculate name */
174 const char *name = input + strlen(input);
175 while (name > input) {
176 if (is_path_sep(*(name - 1))) break;
177 name--;
178 }
179
180 /* Calculate dirpath from current file */
181 const char *curname = curfile + strlen(curfile);
182 while (curname > curfile) {
183 if (is_path_sep(*curname)) break;
184 curname--;
185 }
186 const char *curdir;
187 int32_t curlen;
188 if (curname == curfile) {
189 /* Current file has one or zero path segments, so
190 * we are in the . directory. */
191 curdir = ".";
192 curlen = 1;
193 } else {
194 /* Current file has 2 or more segments, so we
195 * can cut off the last segment. */
196 curdir = curfile;
197 curlen = (int32_t)(curname - curfile);
198 }
199
200 for (size_t i = 0; i < tlen; i++) {
201 if (template[i] == ':') {
202 if (strncmp(template + i, ":all:", 5) == 0) {
203 janet_buffer_push_cstring(out, input);
204 i += 4;
205 } else if (strncmp(template + i, ":cur:", 5) == 0) {
206 janet_buffer_push_bytes(out, (const uint8_t *)curdir, curlen);
207 i += 4;
208 } else if (strncmp(template + i, ":dir:", 5) == 0) {
209 janet_buffer_push_bytes(out, (const uint8_t *)input,
210 (int32_t)(name - input));
211 i += 4;
212 } else if (strncmp(template + i, ":sys:", 5) == 0) {
213 janet_buffer_push_cstring(out, syspath);
214 i += 4;
215 } else if (strncmp(template + i, ":name:", 6) == 0) {
216 janet_buffer_push_cstring(out, name);
217 i += 5;
218 } else if (strncmp(template + i, ":native:", 8) == 0) {
219 #ifdef JANET_WINDOWS
220 janet_buffer_push_cstring(out, ".dll");
221 #else
222 janet_buffer_push_cstring(out, ".so");
223 #endif
224 i += 7;
225 } else {
226 janet_buffer_push_u8(out, (uint8_t) template[i]);
227 }
228 } else {
229 janet_buffer_push_u8(out, (uint8_t) template[i]);
230 }
231 }
232
233 /* Normalize */
234 uint8_t *scan = out->data;
235 uint8_t *print = scan;
236 uint8_t *scanend = scan + out->count;
237 int normal_section_count = 0;
238 int dot_count = 0;
239 while (scan < scanend) {
240 if (*scan == '.') {
241 if (dot_count >= 0) {
242 dot_count++;
243 } else {
244 *print++ = '.';
245 }
246 } else if (is_path_sep(*scan)) {
247 if (dot_count == 1) {
248 ;
249 } else if (dot_count == 2) {
250 if (normal_section_count > 0) {
251 /* unprint last separator */
252 print--;
253 /* unprint last section */
254 while (print > out->data && !is_path_sep(*(print - 1)))
255 print--;
256 normal_section_count--;
257 } else {
258 *print++ = '.';
259 *print++ = '.';
260 *print++ = '/';
261 }
262 } else if (scan == out->data || dot_count != 0) {
263 while (dot_count > 0) {
264 --dot_count;
265 *print++ = '.';
266 }
267 if (scan > out->data) {
268 normal_section_count++;
269 }
270 *print++ = '/';
271 }
272 dot_count = 0;
273 } else {
274 while (dot_count > 0) {
275 --dot_count;
276 *print++ = '.';
277 }
278 dot_count = -1;
279 *print++ = *scan;
280 }
281 scan++;
282 }
283 out->count = (int32_t)(print - out->data);
284 return janet_wrap_buffer(out);
285 }
286
287 JANET_CORE_FN(janet_core_dyn,
288 "(dyn key &opt default)",
289 "Get a dynamic binding. Returns the default value (or nil) if no binding found.") {
290 janet_arity(argc, 1, 2);
291 Janet value;
292 if (janet_vm.fiber->env) {
293 value = janet_table_get(janet_vm.fiber->env, argv[0]);
294 } else {
295 value = janet_wrap_nil();
296 }
297 if (argc == 2 && janet_checktype(value, JANET_NIL)) {
298 return argv[1];
299 }
300 return value;
301 }
302
303 JANET_CORE_FN(janet_core_setdyn,
304 "(setdyn key value)",
305 "Set a dynamic binding. Returns value.") {
306 janet_fixarity(argc, 2);
307 if (!janet_vm.fiber->env) {
308 janet_vm.fiber->env = janet_table(2);
309 }
310 janet_table_put(janet_vm.fiber->env, argv[0], argv[1]);
311 return argv[1];
312 }
313
314 JANET_CORE_FN(janet_core_native,
315 "(native path &opt env)",
316 "Load a native module from the given path. The path "
317 "must be an absolute or relative path on the file system, and is "
318 "usually a .so file on Unix systems, and a .dll file on Windows. "
319 "Returns an environment table that contains functions and other values "
320 "from the native module.") {
321 JanetModule init;
322 janet_arity(argc, 1, 2);
323 const uint8_t *path = janet_getstring(argv, 0);
324 const uint8_t *error = NULL;
325 JanetTable *env;
326 if (argc == 2) {
327 env = janet_gettable(argv, 1);
328 } else {
329 env = janet_table(0);
330 }
331 init = janet_native((const char *)path, &error);
332 if (!init) {
333 janet_panicf("could not load native %S: %S", path, error);
334 }
335 init(env);
336 janet_table_put(env, janet_ckeywordv("native"), argv[0]);
337 return janet_wrap_table(env);
338 }
339
340 JANET_CORE_FN(janet_core_describe,
341 "(describe x)",
342 "Returns a string that is a human-readable description of a value x.") {
343 JanetBuffer *b = janet_buffer(0);
344 for (int32_t i = 0; i < argc; ++i)
345 janet_description_b(b, argv[i]);
346 return janet_stringv(b->data, b->count);
347 }
348
349 JANET_CORE_FN(janet_core_string,
350 "(string & xs)",
351 "Creates a string by concatenating the elements of `xs` together. If an "
352 "element is not a byte sequence, it is converted to bytes via `describe`. "
353 "Returns the new string.") {
354 JanetBuffer *b = janet_buffer(0);
355 for (int32_t i = 0; i < argc; ++i)
356 janet_to_string_b(b, argv[i]);
357 return janet_stringv(b->data, b->count);
358 }
359
360 JANET_CORE_FN(janet_core_symbol,
361 "(symbol & xs)",
362 "Creates a symbol by concatenating the elements of `xs` together. If an "
363 "element is not a byte sequence, it is converted to bytes via `describe`. "
364 "Returns the new symbol.") {
365 JanetBuffer *b = janet_buffer(0);
366 for (int32_t i = 0; i < argc; ++i)
367 janet_to_string_b(b, argv[i]);
368 return janet_symbolv(b->data, b->count);
369 }
370
371 JANET_CORE_FN(janet_core_keyword,
372 "(keyword & xs)",
373 "Creates a keyword by concatenating the elements of `xs` together. If an "
374 "element is not a byte sequence, it is converted to bytes via `describe`. "
375 "Returns the new keyword.") {
376 JanetBuffer *b = janet_buffer(0);
377 for (int32_t i = 0; i < argc; ++i)
378 janet_to_string_b(b, argv[i]);
379 return janet_keywordv(b->data, b->count);
380 }
381
382 JANET_CORE_FN(janet_core_buffer,
383 "(buffer & xs)",
384 "Creates a buffer by concatenating the elements of `xs` together. If an "
385 "element is not a byte sequence, it is converted to bytes via `describe`. "
386 "Returns the new buffer.") {
387 JanetBuffer *b = janet_buffer(0);
388 for (int32_t i = 0; i < argc; ++i)
389 janet_to_string_b(b, argv[i]);
390 return janet_wrap_buffer(b);
391 }
392
393 JANET_CORE_FN(janet_core_is_abstract,
394 "(abstract? x)",
395 "Check if x is an abstract type.") {
396 janet_fixarity(argc, 1);
397 return janet_wrap_boolean(janet_checktype(argv[0], JANET_ABSTRACT));
398 }
399
400 JANET_CORE_FN(janet_core_scannumber,
401 "(scan-number str &opt base)",
402 "Parse a number from a byte sequence and return that number, either an integer "
403 "or a real. The number "
404 "must be in the same format as numbers in janet source code. Will return nil "
405 "on an invalid number. Optionally provide a base - if a base is provided, no "
406 "radix specifier is expected at the beginning of the number.") {
407 double number;
408 janet_arity(argc, 1, 2);
409 JanetByteView view = janet_getbytes(argv, 0);
410 int32_t base = janet_optinteger(argv, argc, 1, 0);
411 int valid = base == 0 || (base >= 2 && base <= 36);
412 if (!valid) {
413 janet_panicf("expected base between 2 and 36, got %d", base);
414 }
415 if (janet_scan_number_base(view.bytes, view.len, base, &number))
416 return janet_wrap_nil();
417 return janet_wrap_number(number);
418 }
419
420 JANET_CORE_FN(janet_core_tuple,
421 "(tuple & items)",
422 "Creates a new tuple that contains items. Returns the new tuple.") {
423 return janet_wrap_tuple(janet_tuple_n(argv, argc));
424 }
425
426 JANET_CORE_FN(janet_core_array,
427 "(array & items)",
428 "Create a new array that contains items. Returns the new array.") {
429 JanetArray *array = janet_array(argc);
430 array->count = argc;
431 safe_memcpy(array->data, argv, argc * sizeof(Janet));
432 return janet_wrap_array(array);
433 }
434
435 JANET_CORE_FN(janet_core_slice,
436 "(slice x &opt start end)",
437 "Extract a sub-range of an indexed data structure or byte sequence.") {
438 JanetRange range;
439 JanetByteView bview;
440 JanetView iview;
441 if (janet_bytes_view(argv[0], &bview.bytes, &bview.len)) {
442 range = janet_getslice(argc, argv);
443 return janet_stringv(bview.bytes + range.start, range.end - range.start);
444 } else if (janet_indexed_view(argv[0], &iview.items, &iview.len)) {
445 range = janet_getslice(argc, argv);
446 return janet_wrap_tuple(janet_tuple_n(iview.items + range.start, range.end - range.start));
447 } else {
448 janet_panic_type(argv[0], 0, JANET_TFLAG_BYTES | JANET_TFLAG_INDEXED);
449 }
450 }
451
452 JANET_CORE_FN(janet_core_table,
453 "(table & kvs)",
454 "Creates a new table from a variadic number of keys and values. "
455 "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has "
456 "an odd number of elements, an error will be thrown. Returns the "
457 "new table.") {
458 int32_t i;
459 if (argc & 1)
460 janet_panic("expected even number of arguments");
461 JanetTable *table = janet_table(argc >> 1);
462 for (i = 0; i < argc; i += 2) {
463 janet_table_put(table, argv[i], argv[i + 1]);
464 }
465 return janet_wrap_table(table);
466 }
467
468 JANET_CORE_FN(janet_core_getproto,
469 "(getproto x)",
470 "Get the prototype of a table or struct. Will return nil if `x` has no prototype.") {
471 janet_fixarity(argc, 1);
472 if (janet_checktype(argv[0], JANET_TABLE)) {
473 JanetTable *t = janet_unwrap_table(argv[0]);
474 return t->proto
475 ? janet_wrap_table(t->proto)
476 : janet_wrap_nil();
477 }
478 if (janet_checktype(argv[0], JANET_STRUCT)) {
479 JanetStruct st = janet_unwrap_struct(argv[0]);
480 return janet_struct_proto(st)
481 ? janet_wrap_struct(janet_struct_proto(st))
482 : janet_wrap_nil();
483 }
484 janet_panicf("expected struct|table, got %v", argv[0]);
485 }
486
487 JANET_CORE_FN(janet_core_struct,
488 "(struct & kvs)",
489 "Create a new struct from a sequence of key value pairs. "
490 "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has "
491 "an odd number of elements, an error will be thrown. Returns the "
492 "new struct.") {
493 int32_t i;
494 if (argc & 1) {
495 janet_panic("expected even number of arguments");
496 }
497 JanetKV *st = janet_struct_begin(argc >> 1);
498 for (i = 0; i < argc; i += 2) {
499 janet_struct_put(st, argv[i], argv[i + 1]);
500 }
501 return janet_wrap_struct(janet_struct_end(st));
502 }
503
504 JANET_CORE_FN(janet_core_gensym,
505 "(gensym)",
506 "Returns a new symbol that is unique across the runtime. This means it "
507 "will not collide with any already created symbols during compilation, so "
508 "it can be used in macros to generate automatic bindings.") {
509 (void) argv;
510 janet_fixarity(argc, 0);
511 return janet_wrap_symbol(janet_symbol_gen());
512 }
513
514 JANET_CORE_FN(janet_core_gccollect,
515 "(gccollect)",
516 "Run garbage collection. You should probably not call this manually.") {
517 (void) argv;
518 (void) argc;
519 janet_collect();
520 return janet_wrap_nil();
521 }
522
523 JANET_CORE_FN(janet_core_gcsetinterval,
524 "(gcsetinterval interval)",
525 "Set an integer number of bytes to allocate before running garbage collection. "
526 "Low values for interval will be slower but use less memory. "
527 "High values will be faster but use more memory.") {
528 janet_fixarity(argc, 1);
529 size_t s = janet_getsize(argv, 0);
530 /* limit interval to 48 bits */
531 #ifdef JANET_64
532 if (s >> 48) {
533 janet_panic("interval too large");
534 }
535 #endif
536 janet_vm.gc_interval = s;
537 return janet_wrap_nil();
538 }
539
540 JANET_CORE_FN(janet_core_gcinterval,
541 "(gcinterval)",
542 "Returns the integer number of bytes to allocate before running an iteration "
543 "of garbage collection.") {
544 (void) argv;
545 janet_fixarity(argc, 0);
546 return janet_wrap_number((double) janet_vm.gc_interval);
547 }
548
549 JANET_CORE_FN(janet_core_type,
550 "(type x)",
551 "Returns the type of `x` as a keyword. `x` is one of:\n\n"
552 "* :nil\n\n"
553 "* :boolean\n\n"
554 "* :number\n\n"
555 "* :array\n\n"
556 "* :tuple\n\n"
557 "* :table\n\n"
558 "* :struct\n\n"
559 "* :string\n\n"
560 "* :buffer\n\n"
561 "* :symbol\n\n"
562 "* :keyword\n\n"
563 "* :function\n\n"
564 "* :cfunction\n\n"
565 "* :fiber\n\n"
566 "or another keyword for an abstract type.") {
567 janet_fixarity(argc, 1);
568 JanetType t = janet_type(argv[0]);
569 if (t == JANET_ABSTRACT) {
570 return janet_ckeywordv(janet_abstract_type(janet_unwrap_abstract(argv[0]))->name);
571 } else {
572 return janet_ckeywordv(janet_type_names[t]);
573 }
574 }
575
576 JANET_CORE_FN(janet_core_hash,
577 "(hash value)",
578 "Gets a hash for any value. The hash is an integer can be used "
579 "as a cheap hash function for all values. If two values are strictly equal, "
580 "then they will have the same hash value.") {
581 janet_fixarity(argc, 1);
582 return janet_wrap_number(janet_hash(argv[0]));
583 }
584
585 JANET_CORE_FN(janet_core_getline,
586 "(getline &opt prompt buf env)",
587 "Reads a line of input into a buffer, including the newline character, using a prompt. "
588 "An optional environment table can be provided for auto-complete. "
589 "Returns the modified buffer. "
590 "Use this function to implement a simple interface for a terminal program.") {
591 FILE *in = janet_dynfile("in", stdin);
592 FILE *out = janet_dynfile("out", stdout);
593 janet_arity(argc, 0, 3);
594 JanetBuffer *buf = (argc >= 2) ? janet_getbuffer(argv, 1) : janet_buffer(10);
595 if (argc >= 1) {
596 const char *prompt = (const char *) janet_getstring(argv, 0);
597 fprintf(out, "%s", prompt);
598 fflush(out);
599 }
600 {
601 buf->count = 0;
602 int c;
603 for (;;) {
604 c = fgetc(in);
605 if (feof(in) || c < 0) {
606 break;
607 }
608 janet_buffer_push_u8(buf, (uint8_t) c);
609 if (c == '\n') break;
610 }
611 }
612 return janet_wrap_buffer(buf);
613 }
614
615 JANET_CORE_FN(janet_core_trace,
616 "(trace func)",
617 "Enable tracing on a function. Returns the function.") {
618 janet_fixarity(argc, 1);
619 JanetFunction *func = janet_getfunction(argv, 0);
620 func->gc.flags |= JANET_FUNCFLAG_TRACE;
621 return argv[0];
622 }
623
624 JANET_CORE_FN(janet_core_untrace,
625 "(untrace func)",
626 "Disables tracing on a function. Returns the function.") {
627 janet_fixarity(argc, 1);
628 JanetFunction *func = janet_getfunction(argv, 0);
629 func->gc.flags &= ~JANET_FUNCFLAG_TRACE;
630 return argv[0];
631 }
632
633 JANET_CORE_FN(janet_core_check_int,
634 "(int? x)",
635 "Check if x can be exactly represented as a 32 bit signed two's complement integer.") {
636 janet_fixarity(argc, 1);
637 if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
638 double num = janet_unwrap_number(argv[0]);
639 return janet_wrap_boolean(num == (double)((int32_t)num));
640 ret_false:
641 return janet_wrap_false();
642 }
643
644 JANET_CORE_FN(janet_core_check_nat,
645 "(nat? x)",
646 "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") {
647 janet_fixarity(argc, 1);
648 if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
649 double num = janet_unwrap_number(argv[0]);
650 return janet_wrap_boolean(num >= 0 && (num == (double)((int32_t)num)));
651 ret_false:
652 return janet_wrap_false();
653 }
654
655 JANET_CORE_FN(janet_core_signal,
656 "(signal what x)",
657 "Raise a signal with payload x. ") {
658 janet_arity(argc, 1, 2);
659 int sig;
660 if (janet_checkint(argv[0])) {
661 int32_t s = janet_unwrap_integer(argv[0]);
662 if (s < 0 || s > 9) {
663 janet_panicf("expected user signal between 0 and 9, got %d", s);
664 }
665 sig = JANET_SIGNAL_USER0 + s;
666 } else {
667 JanetKeyword kw = janet_getkeyword(argv, 0);
668 if (!janet_cstrcmp(kw, "yield")) {
669 sig = JANET_SIGNAL_YIELD;
670 } else if (!janet_cstrcmp(kw, "error")) {
671 sig = JANET_SIGNAL_ERROR;
672 } else if (!janet_cstrcmp(kw, "debug")) {
673 sig = JANET_SIGNAL_DEBUG;
674 } else {
675 janet_panicf("unknown signal, expected :yield, :error, or :debug, got %v", argv[0]);
676 }
677 }
678 Janet payload = argc == 2 ? argv[1] : janet_wrap_nil();
679 janet_signalv(sig, payload);
680 }
681
682 #ifdef JANET_BOOTSTRAP
683
684 /* Utility for inline assembly */
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)685 static void janet_quick_asm(
686 JanetTable *env,
687 int32_t flags,
688 const char *name,
689 int32_t arity,
690 int32_t min_arity,
691 int32_t max_arity,
692 int32_t slots,
693 const uint32_t *bytecode,
694 size_t bytecode_size,
695 const char *doc) {
696 JanetFuncDef *def = janet_funcdef_alloc();
697 def->arity = arity;
698 def->min_arity = min_arity;
699 def->max_arity = max_arity;
700 def->flags = flags;
701 def->slotcount = slots;
702 def->bytecode = janet_malloc(bytecode_size);
703 def->bytecode_length = (int32_t)(bytecode_size / sizeof(uint32_t));
704 def->name = janet_cstring(name);
705 if (!def->bytecode) {
706 JANET_OUT_OF_MEMORY;
707 }
708 memcpy(def->bytecode, bytecode, bytecode_size);
709 janet_def_addflags(def);
710 janet_def(env, name, janet_wrap_function(janet_thunk(def)), doc);
711 }
712
713 /* Macros for easier inline assembly */
714 #define SSS(op, a, b, c) ((op) | ((a) << 8) | ((b) << 16) | ((c) << 24))
715 #define SS(op, a, b) ((op) | ((a) << 8) | ((b) << 16))
716 #define SSI(op, a, b, I) ((op) | ((a) << 8) | ((b) << 16) | ((uint32_t)(I) << 24))
717 #define S(op, a) ((op) | ((a) << 8))
718 #define SI(op, a, I) ((op) | ((a) << 8) | ((uint32_t)(I) << 16))
719
720 /* Templatize a varop */
templatize_varop(JanetTable * env,int32_t flags,const char * name,int32_t nullary,int32_t unary,uint32_t op,const char * doc)721 static void templatize_varop(
722 JanetTable *env,
723 int32_t flags,
724 const char *name,
725 int32_t nullary,
726 int32_t unary,
727 uint32_t op,
728 const char *doc) {
729
730 /* Variadic operator assembly. Must be templatized for each different opcode. */
731 /* Reg 0: Argument tuple (args) */
732 /* Reg 1: Argument count (argn) */
733 /* Reg 2: Jump flag (jump?) */
734 /* Reg 3: Accumulator (accum) */
735 /* Reg 4: Next operand (operand) */
736 /* Reg 5: Loop iterator (i) */
737 uint32_t varop_asm[] = {
738 SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
739
740 /* Check nullary */
741 SSS(JOP_EQUALS_IMMEDIATE, 2, 1, 0), /* Check if numargs equal to 0 */
742 SI(JOP_JUMP_IF_NOT, 2, 3), /* If not 0, jump to next check */
743 /* Nullary */
744 SI(JOP_LOAD_INTEGER, 3, nullary), /* accum = nullary value */
745 S(JOP_RETURN, 3), /* return accum */
746
747 /* Check unary */
748 SSI(JOP_EQUALS_IMMEDIATE, 2, 1, 1), /* Check if numargs equal to 1 */
749 SI(JOP_JUMP_IF_NOT, 2, 5), /* If not 1, jump to next check */
750 /* Unary */
751 SI(JOP_LOAD_INTEGER, 3, unary), /* accum = unary value */
752 SSI(JOP_GET_INDEX, 4, 0, 0), /* operand = args[0] */
753 SSS(op, 3, 3, 4), /* accum = accum op operand */
754 S(JOP_RETURN, 3), /* return accum */
755
756 /* Mutli (2 or more) arity */
757 /* Prime loop */
758 SSI(JOP_GET_INDEX, 3, 0, 0), /* accum = args[0] */
759 SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */
760 /* Main loop */
761 SSS(JOP_IN, 4, 0, 5), /* operand = args[i] */
762 SSS(op, 3, 3, 4), /* accum = accum op operand */
763 SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
764 SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */
765 SI(JOP_JUMP_IF_NOT, 2, -4), /* if not jump? go back 4 */
766
767 /* Done, do last and return accumulator */
768 S(JOP_RETURN, 3) /* return accum */
769 };
770
771 janet_quick_asm(
772 env,
773 flags | JANET_FUNCDEF_FLAG_VARARG,
774 name,
775 0,
776 0,
777 INT32_MAX,
778 6,
779 varop_asm,
780 sizeof(varop_asm),
781 doc);
782 }
783
784 /* Templatize variadic comparators */
templatize_comparator(JanetTable * env,int32_t flags,const char * name,int invert,uint32_t op,const char * doc)785 static void templatize_comparator(
786 JanetTable *env,
787 int32_t flags,
788 const char *name,
789 int invert,
790 uint32_t op,
791 const char *doc) {
792
793 /* Reg 0: Argument tuple (args) */
794 /* Reg 1: Argument count (argn) */
795 /* Reg 2: Jump flag (jump?) */
796 /* Reg 3: Last value (last) */
797 /* Reg 4: Next operand (next) */
798 /* Reg 5: Loop iterator (i) */
799 uint32_t comparator_asm[] = {
800 SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
801 SSS(JOP_LESS_THAN_IMMEDIATE, 2, 1, 2), /* Check if numargs less than 2 */
802 SI(JOP_JUMP_IF, 2, 10), /* If numargs < 2, jump to done */
803
804 /* Prime loop */
805 SSI(JOP_GET_INDEX, 3, 0, 0), /* last = args[0] */
806 SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */
807
808 /* Main loop */
809 SSS(JOP_IN, 4, 0, 5), /* next = args[i] */
810 SSS(op, 2, 3, 4), /* jump? = last compare next */
811 SI(JOP_JUMP_IF_NOT, 2, 7), /* if not jump? goto fail (return false) */
812 SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
813 SS(JOP_MOVE_NEAR, 3, 4), /* last = next */
814 SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */
815 SI(JOP_JUMP_IF_NOT, 2, -6), /* if not jump? go back 6 */
816
817 /* Done, return true */
818 S(invert ? JOP_LOAD_FALSE : JOP_LOAD_TRUE, 3),
819 S(JOP_RETURN, 3),
820
821 /* Failed, return false */
822 S(invert ? JOP_LOAD_TRUE : JOP_LOAD_FALSE, 3),
823 S(JOP_RETURN, 3)
824 };
825
826 janet_quick_asm(
827 env,
828 flags | JANET_FUNCDEF_FLAG_VARARG,
829 name,
830 0,
831 0,
832 INT32_MAX,
833 6,
834 comparator_asm,
835 sizeof(comparator_asm),
836 doc);
837 }
838
839 /* Make the apply function */
make_apply(JanetTable * env)840 static void make_apply(JanetTable *env) {
841 /* Reg 0: Function (fun) */
842 /* Reg 1: Argument tuple (args) */
843 /* Reg 2: Argument count (argn) */
844 /* Reg 3: Jump flag (jump?) */
845 /* Reg 4: Loop iterator (i) */
846 /* Reg 5: Loop values (x) */
847 uint32_t apply_asm[] = {
848 SS(JOP_LENGTH, 2, 1),
849 SSS(JOP_EQUALS_IMMEDIATE, 3, 2, 0), /* Immediate tail call if no args */
850 SI(JOP_JUMP_IF, 3, 9),
851
852 /* Prime loop */
853 SI(JOP_LOAD_INTEGER, 4, 0), /* i = 0 */
854
855 /* Main loop */
856 SSS(JOP_IN, 5, 1, 4), /* x = args[i] */
857 SSI(JOP_ADD_IMMEDIATE, 4, 4, 1), /* i++ */
858 SSI(JOP_EQUALS, 3, 4, 2), /* jump? = (i == argn) */
859 SI(JOP_JUMP_IF, 3, 3), /* if jump? go forward 3 */
860 S(JOP_PUSH, 5),
861 (JOP_JUMP | ((uint32_t)(-5) << 8)),
862
863 /* Push the array */
864 S(JOP_PUSH_ARRAY, 5),
865
866 /* Call the funciton */
867 S(JOP_TAILCALL, 0)
868 };
869 janet_quick_asm(env, JANET_FUN_APPLY | JANET_FUNCDEF_FLAG_VARARG,
870 "apply", 1, 1, INT32_MAX, 6, apply_asm, sizeof(apply_asm),
871 JDOC("(apply f & args)\n\n"
872 "Applies a function to a variable number of arguments. Each element in args "
873 "is used as an argument to f, except the last element in args, which is expected to "
874 "be an array-like. Each element in this last argument is then also pushed as an argument to "
875 "f. For example:\n\n"
876 "\t(apply + 1000 (range 10))\n\n"
877 "sums the first 10 integers and 1000."));
878 }
879
880 static const uint32_t error_asm[] = {
881 JOP_ERROR
882 };
883 static const uint32_t debug_asm[] = {
884 JOP_SIGNAL | (2 << 24),
885 JOP_RETURN
886 };
887 static const uint32_t yield_asm[] = {
888 JOP_SIGNAL | (3 << 24),
889 JOP_RETURN
890 };
891 static const uint32_t resume_asm[] = {
892 JOP_RESUME | (1 << 24),
893 JOP_RETURN
894 };
895 static const uint32_t cancel_asm[] = {
896 JOP_CANCEL | (1 << 24),
897 JOP_RETURN
898 };
899 static const uint32_t in_asm[] = {
900 JOP_IN | (1 << 24),
901 JOP_LOAD_NIL | (3 << 8),
902 JOP_EQUALS | (3 << 8) | (3 << 24),
903 JOP_JUMP_IF | (3 << 8) | (2 << 16),
904 JOP_RETURN,
905 JOP_RETURN | (2 << 8)
906 };
907 static const uint32_t get_asm[] = {
908 JOP_GET | (1 << 24),
909 JOP_LOAD_NIL | (3 << 8),
910 JOP_EQUALS | (3 << 8) | (3 << 24),
911 JOP_JUMP_IF | (3 << 8) | (2 << 16),
912 JOP_RETURN,
913 JOP_RETURN | (2 << 8)
914 };
915 static const uint32_t put_asm[] = {
916 JOP_PUT | (1 << 16) | (2 << 24),
917 JOP_RETURN
918 };
919 static const uint32_t length_asm[] = {
920 JOP_LENGTH,
921 JOP_RETURN
922 };
923 static const uint32_t bnot_asm[] = {
924 JOP_BNOT,
925 JOP_RETURN
926 };
927 static const uint32_t propagate_asm[] = {
928 JOP_PROPAGATE | (1 << 24),
929 JOP_RETURN
930 };
931 static const uint32_t next_asm[] = {
932 JOP_NEXT | (1 << 24),
933 JOP_RETURN
934 };
935 static const uint32_t modulo_asm[] = {
936 JOP_MODULO | (1 << 24),
937 JOP_RETURN
938 };
939 static const uint32_t remainder_asm[] = {
940 JOP_REMAINDER | (1 << 24),
941 JOP_RETURN
942 };
943 static const uint32_t cmp_asm[] = {
944 JOP_COMPARE | (1 << 24),
945 JOP_RETURN
946 };
947 #endif /* ifdef JANET_BOOTSTRAP */
948
949 /*
950 * Setup Environment
951 */
952
janet_load_libs(JanetTable * env)953 static void janet_load_libs(JanetTable *env) {
954 JanetRegExt corelib_cfuns[] = {
955 JANET_CORE_REG("native", janet_core_native),
956 JANET_CORE_REG("describe", janet_core_describe),
957 JANET_CORE_REG("string", janet_core_string),
958 JANET_CORE_REG("symbol", janet_core_symbol),
959 JANET_CORE_REG("keyword", janet_core_keyword),
960 JANET_CORE_REG("buffer", janet_core_buffer),
961 JANET_CORE_REG("abstract?", janet_core_is_abstract),
962 JANET_CORE_REG("table", janet_core_table),
963 JANET_CORE_REG("array", janet_core_array),
964 JANET_CORE_REG("scan-number", janet_core_scannumber),
965 JANET_CORE_REG("tuple", janet_core_tuple),
966 JANET_CORE_REG("struct", janet_core_struct),
967 JANET_CORE_REG("gensym", janet_core_gensym),
968 JANET_CORE_REG("gccollect", janet_core_gccollect),
969 JANET_CORE_REG("gcsetinterval", janet_core_gcsetinterval),
970 JANET_CORE_REG("gcinterval", janet_core_gcinterval),
971 JANET_CORE_REG("type", janet_core_type),
972 JANET_CORE_REG("hash", janet_core_hash),
973 JANET_CORE_REG("getline", janet_core_getline),
974 JANET_CORE_REG("dyn", janet_core_dyn),
975 JANET_CORE_REG("setdyn", janet_core_setdyn),
976 JANET_CORE_REG("trace", janet_core_trace),
977 JANET_CORE_REG("untrace", janet_core_untrace),
978 JANET_CORE_REG("module/expand-path", janet_core_expand_path),
979 JANET_CORE_REG("int?", janet_core_check_int),
980 JANET_CORE_REG("nat?", janet_core_check_nat),
981 JANET_CORE_REG("slice", janet_core_slice),
982 JANET_CORE_REG("signal", janet_core_signal),
983 JANET_CORE_REG("getproto", janet_core_getproto),
984 JANET_REG_END
985 };
986 janet_core_cfuns_ext(env, NULL, corelib_cfuns);
987 janet_lib_io(env);
988 janet_lib_math(env);
989 janet_lib_array(env);
990 janet_lib_tuple(env);
991 janet_lib_buffer(env);
992 janet_lib_table(env);
993 janet_lib_struct(env);
994 janet_lib_fiber(env);
995 janet_lib_os(env);
996 janet_lib_parse(env);
997 janet_lib_compile(env);
998 janet_lib_debug(env);
999 janet_lib_string(env);
1000 janet_lib_marsh(env);
1001 #ifdef JANET_PEG
1002 janet_lib_peg(env);
1003 #endif
1004 #ifdef JANET_ASSEMBLER
1005 janet_lib_asm(env);
1006 #endif
1007 #ifdef JANET_INT_TYPES
1008 janet_lib_inttypes(env);
1009 #endif
1010 #ifdef JANET_EV
1011 janet_lib_ev(env);
1012 #endif
1013 #ifdef JANET_NET
1014 janet_lib_net(env);
1015 #endif
1016 }
1017
1018 #ifdef JANET_BOOTSTRAP
1019
janet_core_env(JanetTable * replacements)1020 JanetTable *janet_core_env(JanetTable *replacements) {
1021 JanetTable *env = (NULL != replacements) ? replacements : janet_table(0);
1022 janet_quick_asm(env, JANET_FUN_MODULO,
1023 "mod", 2, 2, 2, 2, modulo_asm, sizeof(modulo_asm),
1024 JDOC("(mod dividend divisor)\n\n"
1025 "Returns the modulo of dividend / divisor."));
1026 janet_quick_asm(env, JANET_FUN_REMAINDER,
1027 "%", 2, 2, 2, 2, remainder_asm, sizeof(remainder_asm),
1028 JDOC("(% dividend divisor)\n\n"
1029 "Returns the remainder of dividend / divisor."));
1030 janet_quick_asm(env, JANET_FUN_CMP,
1031 "cmp", 2, 2, 2, 2, cmp_asm, sizeof(cmp_asm),
1032 JDOC("(cmp x y)\n\n"
1033 "Returns -1 if x is strictly less than y, 1 if y is strictly greater "
1034 "than x, and 0 otherwise. To return 0, x and y must be the exact same type."));
1035 janet_quick_asm(env, JANET_FUN_NEXT,
1036 "next", 2, 1, 2, 2, next_asm, sizeof(next_asm),
1037 JDOC("(next ds &opt key)\n\n"
1038 "Gets the next key in a data structure. Can be used to iterate through "
1039 "the keys of a data structure in an unspecified order. Keys are guaranteed "
1040 "to be seen only once per iteration if they data structure is not mutated "
1041 "during iteration. If key is nil, next returns the first key. If next "
1042 "returns nil, there are no more keys to iterate through."));
1043 janet_quick_asm(env, JANET_FUN_PROP,
1044 "propagate", 2, 2, 2, 2, propagate_asm, sizeof(propagate_asm),
1045 JDOC("(propagate x fiber)\n\n"
1046 "Propagate a signal from a fiber to the current fiber. The resulting "
1047 "stack trace from the current fiber will include frames from fiber. If "
1048 "fiber is in a state that can be resumed, resuming the current fiber will "
1049 "first resume fiber. This function can be used to re-raise an error without "
1050 "losing the original stack trace."));
1051 janet_quick_asm(env, JANET_FUN_DEBUG,
1052 "debug", 1, 0, 1, 1, debug_asm, sizeof(debug_asm),
1053 JDOC("(debug &opt x)\n\n"
1054 "Throws a debug signal that can be caught by a parent fiber and used to inspect "
1055 "the running state of the current fiber. Returns the value passed in by resume."));
1056 janet_quick_asm(env, JANET_FUN_ERROR,
1057 "error", 1, 1, 1, 1, error_asm, sizeof(error_asm),
1058 JDOC("(error e)\n\n"
1059 "Throws an error e that can be caught and handled by a parent fiber."));
1060 janet_quick_asm(env, JANET_FUN_YIELD,
1061 "yield", 1, 0, 1, 2, yield_asm, sizeof(yield_asm),
1062 JDOC("(yield &opt x)\n\n"
1063 "Yield a value to a parent fiber. When a fiber yields, its execution is paused until "
1064 "another thread resumes it. The fiber will then resume, and the last yield call will "
1065 "return the value that was passed to resume."));
1066 janet_quick_asm(env, JANET_FUN_CANCEL,
1067 "cancel", 2, 2, 2, 2, cancel_asm, sizeof(cancel_asm),
1068 JDOC("(cancel fiber err)\n\n"
1069 "Resume a fiber but have it immediately raise an error. This lets a programmer unwind a pending fiber. "
1070 "Returns the same result as resume."));
1071 janet_quick_asm(env, JANET_FUN_RESUME,
1072 "resume", 2, 1, 2, 2, resume_asm, sizeof(resume_asm),
1073 JDOC("(resume fiber &opt x)\n\n"
1074 "Resume a new or suspended fiber and optionally pass in a value to the fiber that "
1075 "will be returned to the last yield in the case of a pending fiber, or the argument to "
1076 "the dispatch function in the case of a new fiber. Returns either the return result of "
1077 "the fiber's dispatch function, or the value from the next yield call in fiber."));
1078 janet_quick_asm(env, JANET_FUN_IN,
1079 "in", 3, 2, 3, 4, in_asm, sizeof(in_asm),
1080 JDOC("(in ds key &opt dflt)\n\n"
1081 "Get value in ds at key, works on associative data structures. Arrays, tuples, tables, structs, "
1082 "strings, symbols, and buffers are all associative and can be used. Arrays, tuples, strings, buffers, "
1083 "and symbols must use integer keys that are in bounds or an error is raised. Structs and tables can "
1084 "take any value as a key except nil and will return nil or dflt if not found."));
1085 janet_quick_asm(env, JANET_FUN_GET,
1086 "get", 3, 2, 3, 4, get_asm, sizeof(in_asm),
1087 JDOC("(get ds key &opt dflt)\n\n"
1088 "Get the value mapped to key in data structure ds, and return dflt or nil if not found. "
1089 "Similar to in, but will not throw an error if the key is invalid for the data structure "
1090 "unless the data structure is an abstract type. In that case, the abstract type getter may throw "
1091 "an error."));
1092 janet_quick_asm(env, JANET_FUN_PUT,
1093 "put", 3, 3, 3, 3, put_asm, sizeof(put_asm),
1094 JDOC("(put ds key value)\n\n"
1095 "Associate a key with a value in any mutable associative data structure. Indexed data structures "
1096 "(arrays and buffers) only accept non-negative integer keys, and will expand if an out of bounds "
1097 "value is provided. In an array, extra space will be filled with nils, and in a buffer, extra "
1098 "space will be filled with 0 bytes. In a table, putting a key that is contained in the table prototype "
1099 "will hide the association defined by the prototype, but will not mutate the prototype table. Putting "
1100 "a value nil into a table will remove the key from the table. Returns the data structure ds."));
1101 janet_quick_asm(env, JANET_FUN_LENGTH,
1102 "length", 1, 1, 1, 1, length_asm, sizeof(length_asm),
1103 JDOC("(length ds)\n\n"
1104 "Returns the length or count of a data structure in constant time as an integer. For "
1105 "structs and tables, returns the number of key-value pairs in the data structure."));
1106 janet_quick_asm(env, JANET_FUN_BNOT,
1107 "bnot", 1, 1, 1, 1, bnot_asm, sizeof(bnot_asm),
1108 JDOC("(bnot x)\n\nReturns the bit-wise inverse of integer x."));
1109 make_apply(env);
1110
1111 /* Variadic ops */
1112 templatize_varop(env, JANET_FUN_ADD, "+", 0, 0, JOP_ADD,
1113 JDOC("(+ & xs)\n\n"
1114 "Returns the sum of all xs. xs must be integers or real numbers only. If xs is empty, return 0."));
1115 templatize_varop(env, JANET_FUN_SUBTRACT, "-", 0, 0, JOP_SUBTRACT,
1116 JDOC("(- & xs)\n\n"
1117 "Returns the difference of xs. If xs is empty, returns 0. If xs has one element, returns the "
1118 "negative value of that element. Otherwise, returns the first element in xs minus the sum of "
1119 "the rest of the elements."));
1120 templatize_varop(env, JANET_FUN_MULTIPLY, "*", 1, 1, JOP_MULTIPLY,
1121 JDOC("(* & xs)\n\n"
1122 "Returns the product of all elements in xs. If xs is empty, returns 1."));
1123 templatize_varop(env, JANET_FUN_DIVIDE, "/", 1, 1, JOP_DIVIDE,
1124 JDOC("(/ & xs)\n\n"
1125 "Returns the quotient of xs. If xs is empty, returns 1. If xs has one value x, returns "
1126 "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining "
1127 "values."));
1128 templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND,
1129 JDOC("(band & xs)\n\n"
1130 "Returns the bit-wise and of all values in xs. Each x in xs must be an integer."));
1131 templatize_varop(env, JANET_FUN_BOR, "bor", 0, 0, JOP_BOR,
1132 JDOC("(bor & xs)\n\n"
1133 "Returns the bit-wise or of all values in xs. Each x in xs must be an integer."));
1134 templatize_varop(env, JANET_FUN_BXOR, "bxor", 0, 0, JOP_BXOR,
1135 JDOC("(bxor & xs)\n\n"
1136 "Returns the bit-wise xor of all values in xs. Each in xs must be an integer."));
1137 templatize_varop(env, JANET_FUN_LSHIFT, "blshift", 1, 1, JOP_SHIFT_LEFT,
1138 JDOC("(blshift x & shifts)\n\n"
1139 "Returns the value of x bit shifted left by the sum of all values in shifts. x "
1140 "and each element in shift must be an integer."));
1141 templatize_varop(env, JANET_FUN_RSHIFT, "brshift", 1, 1, JOP_SHIFT_RIGHT,
1142 JDOC("(brshift x & shifts)\n\n"
1143 "Returns the value of x bit shifted right by the sum of all values in shifts. x "
1144 "and each element in shift must be an integer."));
1145 templatize_varop(env, JANET_FUN_RSHIFTU, "brushift", 1, 1, JOP_SHIFT_RIGHT_UNSIGNED,
1146 JDOC("(brushift x & shifts)\n\n"
1147 "Returns the value of x bit shifted right by the sum of all values in shifts. x "
1148 "and each element in shift must be an integer. The sign of x is not preserved, so "
1149 "for positive shifts the return value will always be positive."));
1150
1151 /* Variadic comparators */
1152 templatize_comparator(env, JANET_FUN_GT, ">", 0, JOP_GREATER_THAN,
1153 JDOC("(> & xs)\n\n"
1154 "Check if xs is in descending order. Returns a boolean."));
1155 templatize_comparator(env, JANET_FUN_LT, "<", 0, JOP_LESS_THAN,
1156 JDOC("(< & xs)\n\n"
1157 "Check if xs is in ascending order. Returns a boolean."));
1158 templatize_comparator(env, JANET_FUN_GTE, ">=", 0, JOP_GREATER_THAN_EQUAL,
1159 JDOC("(>= & xs)\n\n"
1160 "Check if xs is in non-ascending order. Returns a boolean."));
1161 templatize_comparator(env, JANET_FUN_LTE, "<=", 0, JOP_LESS_THAN_EQUAL,
1162 JDOC("(<= & xs)\n\n"
1163 "Check if xs is in non-descending order. Returns a boolean."));
1164 templatize_comparator(env, JANET_FUN_EQ, "=", 0, JOP_EQUALS,
1165 JDOC("(= & xs)\n\n"
1166 "Check if all values in xs are equal. Returns a boolean."));
1167 templatize_comparator(env, JANET_FUN_NEQ, "not=", 1, JOP_EQUALS,
1168 JDOC("(not= & xs)\n\n"
1169 "Check if any values in xs are not equal. Returns a boolean."));
1170
1171 /* Platform detection */
1172 janet_def(env, "janet/version", janet_cstringv(JANET_VERSION),
1173 JDOC("The version number of the running janet program."));
1174 janet_def(env, "janet/build", janet_cstringv(JANET_BUILD),
1175 JDOC("The build identifier of the running janet program."));
1176 janet_def(env, "janet/config-bits", janet_wrap_integer(JANET_CURRENT_CONFIG_BITS),
1177 JDOC("The flag set of config options from janetconf.h which is used to check "
1178 "if native modules are compatible with the host program."));
1179
1180 /* Allow references to the environment */
1181 janet_def(env, "root-env", janet_wrap_table(env),
1182 JDOC("The root environment used to create environments with (make-env)."));
1183
1184 janet_load_libs(env);
1185 janet_gcroot(janet_wrap_table(env));
1186 return env;
1187 }
1188
1189 #else
1190
janet_core_env(JanetTable * replacements)1191 JanetTable *janet_core_env(JanetTable *replacements) {
1192 /* Memoize core env, ignoring replacements the second time around. */
1193 if (NULL != janet_vm.core_env) {
1194 return janet_vm.core_env;
1195 }
1196
1197 JanetTable *dict = janet_core_lookup_table(replacements);
1198
1199 /* Unmarshal bytecode */
1200 Janet marsh_out = janet_unmarshal(
1201 janet_core_image,
1202 janet_core_image_size,
1203 0,
1204 dict,
1205 NULL);
1206
1207 /* Memoize */
1208 janet_gcroot(marsh_out);
1209 JanetTable *env = janet_unwrap_table(marsh_out);
1210 janet_vm.core_env = env;
1211
1212 /* Invert image dict manually here. We can't do this in boot.janet as it
1213 * breaks deterministic builds */
1214 Janet lidv, midv;
1215 lidv = midv = janet_wrap_nil();
1216 janet_resolve(env, janet_csymbol("load-image-dict"), &lidv);
1217 janet_resolve(env, janet_csymbol("make-image-dict"), &midv);
1218 JanetTable *lid = janet_unwrap_table(lidv);
1219 JanetTable *mid = janet_unwrap_table(midv);
1220 for (int32_t i = 0; i < lid->capacity; i++) {
1221 const JanetKV *kv = lid->data + i;
1222 if (!janet_checktype(kv->key, JANET_NIL)) {
1223 janet_table_put(mid, kv->value, kv->key);
1224 }
1225 }
1226
1227 return env;
1228 }
1229
1230 #endif
1231
janet_core_lookup_table(JanetTable * replacements)1232 JanetTable *janet_core_lookup_table(JanetTable *replacements) {
1233 JanetTable *dict = janet_table(512);
1234 janet_load_libs(dict);
1235
1236 /* Add replacements */
1237 if (replacements != NULL) {
1238 for (int32_t i = 0; i < replacements->capacity; i++) {
1239 JanetKV kv = replacements->data[i];
1240 if (!janet_checktype(kv.key, JANET_NIL)) {
1241 janet_table_put(dict, kv.key, kv.value);
1242 /* Add replacement functions to registry? */
1243 }
1244 }
1245 }
1246
1247 return dict;
1248 }
1249