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 "util.h"
27 #include "state.h"
28 #include "gc.h"
29 #ifdef JANET_WINDOWS
30 #include <windows.h>
31 #else
32 #include <unistd.h>
33 #include <sys/types.h>
34 #include <sys/stat.h>
35 #include <fcntl.h>
36 #endif
37 #endif
38
39 #include <inttypes.h>
40
41 /* Base 64 lookup table for digits */
42 const char janet_base64[65] =
43 "0123456789"
44 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
45 "abcdefghijklmnopqrstuvwxyz"
46 "_=";
47
48 /* The JANET value types in order. These types can be used as
49 * mnemonics instead of a bit pattern for type checking */
50 const char *const janet_type_names[16] = {
51 "number",
52 "nil",
53 "boolean",
54 "fiber",
55 "string",
56 "symbol",
57 "keyword",
58 "array",
59 "tuple",
60 "table",
61 "struct",
62 "buffer",
63 "function",
64 "cfunction",
65 "abstract",
66 "pointer"
67 };
68
69 const char *const janet_signal_names[14] = {
70 "ok",
71 "error",
72 "debug",
73 "yield",
74 "user0",
75 "user1",
76 "user2",
77 "user3",
78 "user4",
79 "user5",
80 "user6",
81 "user7",
82 "user8",
83 "user9"
84 };
85
86 const char *const janet_status_names[16] = {
87 "dead",
88 "error",
89 "debug",
90 "pending",
91 "user0",
92 "user1",
93 "user2",
94 "user3",
95 "user4",
96 "user5",
97 "user6",
98 "user7",
99 "user8",
100 "user9",
101 "new",
102 "alive"
103 };
104
105 #ifndef JANET_PRF
106
janet_string_calchash(const uint8_t * str,int32_t len)107 int32_t janet_string_calchash(const uint8_t *str, int32_t len) {
108 const uint8_t *end = str + len;
109 uint32_t hash = 5381;
110 while (str < end)
111 hash = (hash << 5) + hash + *str++;
112 return (int32_t) hash;
113 }
114
115 #else
116
117 /*
118 Public domain siphash implementation sourced from:
119
120 https://raw.githubusercontent.com/veorq/SipHash/master/halfsiphash.c
121
122 We have made a few alterations, such as hardcoding the output size
123 and then removing dead code.
124 */
125 #define cROUNDS 2
126 #define dROUNDS 4
127
128 #define ROTL(x, b) (uint32_t)(((x) << (b)) | ((x) >> (32 - (b))))
129
130 #define U8TO32_LE(p) \
131 (((uint32_t)((p)[0])) | ((uint32_t)((p)[1]) << 8) | \
132 ((uint32_t)((p)[2]) << 16) | ((uint32_t)((p)[3]) << 24))
133
134 #define SIPROUND \
135 do { \
136 v0 += v1; \
137 v1 = ROTL(v1, 5); \
138 v1 ^= v0; \
139 v0 = ROTL(v0, 16); \
140 v2 += v3; \
141 v3 = ROTL(v3, 8); \
142 v3 ^= v2; \
143 v0 += v3; \
144 v3 = ROTL(v3, 7); \
145 v3 ^= v0; \
146 v2 += v1; \
147 v1 = ROTL(v1, 13); \
148 v1 ^= v2; \
149 v2 = ROTL(v2, 16); \
150 } while (0)
151
halfsiphash(const uint8_t * in,const size_t inlen,const uint8_t * k)152 static uint32_t halfsiphash(const uint8_t *in, const size_t inlen, const uint8_t *k) {
153
154 uint32_t v0 = 0;
155 uint32_t v1 = 0;
156 uint32_t v2 = UINT32_C(0x6c796765);
157 uint32_t v3 = UINT32_C(0x74656462);
158 uint32_t k0 = U8TO32_LE(k);
159 uint32_t k1 = U8TO32_LE(k + 4);
160 uint32_t m;
161 int i;
162 const uint8_t *end = in + inlen - (inlen % sizeof(uint32_t));
163 const int left = inlen & 3;
164 uint32_t b = ((uint32_t)inlen) << 24;
165 v3 ^= k1;
166 v2 ^= k0;
167 v1 ^= k1;
168 v0 ^= k0;
169
170 for (; in != end; in += 4) {
171 m = U8TO32_LE(in);
172 v3 ^= m;
173
174 for (i = 0; i < cROUNDS; ++i)
175 SIPROUND;
176
177 v0 ^= m;
178 }
179
180 switch (left) {
181 case 3:
182 b |= ((uint32_t)in[2]) << 16;
183 /* fallthrough */
184 case 2:
185 b |= ((uint32_t)in[1]) << 8;
186 /* fallthrough */
187 case 1:
188 b |= ((uint32_t)in[0]);
189 break;
190 case 0:
191 break;
192 }
193
194 v3 ^= b;
195
196 for (i = 0; i < cROUNDS; ++i)
197 SIPROUND;
198
199 v0 ^= b;
200
201 v2 ^= 0xff;
202
203 for (i = 0; i < dROUNDS; ++i)
204 SIPROUND;
205
206 b = v1 ^ v3;
207 return b;
208 }
209 /* end of siphash */
210
211 static uint8_t hash_key[JANET_HASH_KEY_SIZE] = {0};
212
janet_init_hash_key(uint8_t new_key[JANET_HASH_KEY_SIZE])213 void janet_init_hash_key(uint8_t new_key[JANET_HASH_KEY_SIZE]) {
214 memcpy(hash_key, new_key, sizeof(hash_key));
215 }
216
217 /* Calculate hash for string */
218
janet_string_calchash(const uint8_t * str,int32_t len)219 int32_t janet_string_calchash(const uint8_t *str, int32_t len) {
220 uint32_t hash;
221 hash = halfsiphash(str, len, hash_key);
222 return (int32_t)hash;
223 }
224
225 #endif
226
janet_hash_mix(uint32_t input,uint32_t more)227 uint32_t janet_hash_mix(uint32_t input, uint32_t more) {
228 uint32_t mix1 = (more + 0x9e3779b9 + (input << 6) + (input >> 2));
229 return input ^ (0x9e3779b9 + (mix1 << 6) + (mix1 >> 2));
230 }
231
232 /* Computes hash of an array of values */
janet_array_calchash(const Janet * array,int32_t len)233 int32_t janet_array_calchash(const Janet *array, int32_t len) {
234 const Janet *end = array + len;
235 uint32_t hash = 33;
236 while (array < end) {
237 hash = janet_hash_mix(hash, janet_hash(*array++));
238 }
239 return (int32_t) hash;
240 }
241
242 /* Computes hash of an array of values */
janet_kv_calchash(const JanetKV * kvs,int32_t len)243 int32_t janet_kv_calchash(const JanetKV *kvs, int32_t len) {
244 const JanetKV *end = kvs + len;
245 uint32_t hash = 33;
246 while (kvs < end) {
247 hash = janet_hash_mix(hash, janet_hash(kvs->key));
248 hash = janet_hash_mix(hash, janet_hash(kvs->value));
249 kvs++;
250 }
251 return (int32_t) hash;
252 }
253
254 /* Calculate next power of 2. May overflow. If n is 0,
255 * will return 0. */
janet_tablen(int32_t n)256 int32_t janet_tablen(int32_t n) {
257 n |= n >> 1;
258 n |= n >> 2;
259 n |= n >> 4;
260 n |= n >> 8;
261 n |= n >> 16;
262 return n + 1;
263 }
264
265 /* Avoid some undefined behavior that was common in the code base. */
safe_memcpy(void * dest,const void * src,size_t len)266 void safe_memcpy(void *dest, const void *src, size_t len) {
267 if (!len) return;
268 memcpy(dest, src, len);
269 }
270
271 /* Helper to find a value in a Janet struct or table. Returns the bucket
272 * containing the key, or the first empty bucket if there is no such key. */
janet_dict_find(const JanetKV * buckets,int32_t cap,Janet key)273 const JanetKV *janet_dict_find(const JanetKV *buckets, int32_t cap, Janet key) {
274 int32_t index = janet_maphash(cap, janet_hash(key));
275 int32_t i;
276 const JanetKV *first_bucket = NULL;
277 /* Higher half */
278 for (i = index; i < cap; i++) {
279 const JanetKV *kv = buckets + i;
280 if (janet_checktype(kv->key, JANET_NIL)) {
281 if (janet_checktype(kv->value, JANET_NIL)) {
282 return kv;
283 } else if (NULL == first_bucket) {
284 first_bucket = kv;
285 }
286 } else if (janet_equals(kv->key, key)) {
287 return buckets + i;
288 }
289 }
290 /* Lower half */
291 for (i = 0; i < index; i++) {
292 const JanetKV *kv = buckets + i;
293 if (janet_checktype(kv->key, JANET_NIL)) {
294 if (janet_checktype(kv->value, JANET_NIL)) {
295 return kv;
296 } else if (NULL == first_bucket) {
297 first_bucket = kv;
298 }
299 } else if (janet_equals(kv->key, key)) {
300 return buckets + i;
301 }
302 }
303 return first_bucket;
304 }
305
306 /* Get a value from a janet struct or table. */
janet_dictionary_get(const JanetKV * data,int32_t cap,Janet key)307 Janet janet_dictionary_get(const JanetKV *data, int32_t cap, Janet key) {
308 const JanetKV *kv = janet_dict_find(data, cap, key);
309 if (kv && !janet_checktype(kv->key, JANET_NIL)) {
310 return kv->value;
311 }
312 return janet_wrap_nil();
313 }
314
315 /* Iterate through a struct or dictionary generically */
janet_dictionary_next(const JanetKV * kvs,int32_t cap,const JanetKV * kv)316 const JanetKV *janet_dictionary_next(const JanetKV *kvs, int32_t cap, const JanetKV *kv) {
317 const JanetKV *end = kvs + cap;
318 kv = (kv == NULL) ? kvs : kv + 1;
319 while (kv < end) {
320 if (!janet_checktype(kv->key, JANET_NIL))
321 return kv;
322 kv++;
323 }
324 return NULL;
325 }
326
327 /* Compare a janet string with a cstring. More efficient than loading
328 * c string as a janet string. */
janet_cstrcmp(const uint8_t * str,const char * other)329 int janet_cstrcmp(const uint8_t *str, const char *other) {
330 int32_t len = janet_string_length(str);
331 int32_t index;
332 for (index = 0; index < len; index++) {
333 uint8_t c = str[index];
334 uint8_t k = ((const uint8_t *)other)[index];
335 if (c < k) return -1;
336 if (c > k) return 1;
337 if (k == '\0') break;
338 }
339 return (other[index] == '\0') ? 0 : -1;
340 }
341
342 /* Do a binary search on a static array of structs. Each struct must
343 * have a string as its first element, and the struct must be sorted
344 * lexicographically by that element. */
janet_strbinsearch(const void * tab,size_t tabcount,size_t itemsize,const uint8_t * key)345 const void *janet_strbinsearch(
346 const void *tab,
347 size_t tabcount,
348 size_t itemsize,
349 const uint8_t *key) {
350 size_t low = 0;
351 size_t hi = tabcount;
352 const char *t = (const char *)tab;
353 while (low < hi) {
354 size_t mid = low + ((hi - low) / 2);
355 const char **item = (const char **)(t + mid * itemsize);
356 const char *name = *item;
357 int comp = janet_cstrcmp(key, name);
358 if (comp < 0) {
359 hi = mid;
360 } else if (comp > 0) {
361 low = mid + 1;
362 } else {
363 return (const void *)item;
364 }
365 }
366 return NULL;
367 }
368
369 /* Add sourcemapping and documentation to a binding table */
janet_add_meta(JanetTable * table,const char * doc,const char * source_file,int32_t source_line)370 static void janet_add_meta(JanetTable *table, const char *doc, const char *source_file, int32_t source_line) {
371 if (doc) {
372 janet_table_put(table, janet_ckeywordv("doc"), janet_cstringv(doc));
373 }
374 if (source_file && source_line) {
375 Janet triple[3];
376 triple[0] = janet_cstringv(source_file);
377 triple[1] = janet_wrap_integer(source_line);
378 triple[2] = janet_wrap_integer(1);
379 Janet value = janet_wrap_tuple(janet_tuple_n(triple, 3));
380 janet_table_put(table, janet_ckeywordv("source-map"), value);
381 }
382 }
383
384 /* Add a def to an environment */
janet_def_sm(JanetTable * env,const char * name,Janet val,const char * doc,const char * source_file,int32_t source_line)385 void janet_def_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) {
386 JanetTable *subt = janet_table(2);
387 janet_table_put(subt, janet_ckeywordv("value"), val);
388 janet_add_meta(subt, doc, source_file, source_line);
389 janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt));
390 }
janet_def(JanetTable * env,const char * name,Janet value,const char * doc)391 void janet_def(JanetTable *env, const char *name, Janet value, const char *doc) {
392 janet_def_sm(env, name, value, doc, NULL, 0);
393 }
394
395 /* Add a var to the environment */
janet_var_sm(JanetTable * env,const char * name,Janet val,const char * doc,const char * source_file,int32_t source_line)396 void janet_var_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) {
397 JanetArray *array = janet_array(1);
398 JanetTable *subt = janet_table(2);
399 janet_array_push(array, val);
400 janet_table_put(subt, janet_ckeywordv("ref"), janet_wrap_array(array));
401 janet_add_meta(subt, doc, source_file, source_line);
402 janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt));
403 }
janet_var(JanetTable * env,const char * name,Janet val,const char * doc)404 void janet_var(JanetTable *env, const char *name, Janet val, const char *doc) {
405 janet_var_sm(env, name, val, doc, NULL, 0);
406 }
407
408 /* Registry functions */
409
410 /* Put the registry in sorted order. */
janet_registry_sort(void)411 static void janet_registry_sort(void) {
412 for (size_t i = 1; i < janet_vm.registry_count; i++) {
413 JanetCFunRegistry reg = janet_vm.registry[i];
414 size_t j;
415 for (j = i; j > 0; j--) {
416 if ((void *)(janet_vm.registry[j - 1].cfun) < (void *)(reg.cfun)) break;
417 janet_vm.registry[j] = janet_vm.registry[j - 1];
418 }
419 janet_vm.registry[j] = reg;
420 }
421 janet_vm.registry_dirty = 0;
422 }
423
janet_registry_put(JanetCFunction key,const char * name,const char * name_prefix,const char * source_file,int32_t source_line)424 void janet_registry_put(
425 JanetCFunction key,
426 const char *name,
427 const char *name_prefix,
428 const char *source_file,
429 int32_t source_line) {
430 if (janet_vm.registry_count == janet_vm.registry_cap) {
431 size_t newcap = (janet_vm.registry_count + 1) * 2;
432 /* Size it nicely with core by default */
433 if (newcap < 512) {
434 newcap = 512;
435 }
436 void *newmem = janet_realloc(janet_vm.registry, newcap * sizeof(JanetCFunRegistry));
437 if (NULL == newmem) {
438 JANET_OUT_OF_MEMORY;
439 }
440 janet_vm.registry = newmem;
441 janet_vm.registry_cap = newcap;
442 }
443 JanetCFunRegistry value = {
444 key,
445 name,
446 name_prefix,
447 source_file,
448 source_line
449 };
450 janet_vm.registry[janet_vm.registry_count++] = value;
451 janet_vm.registry_dirty = 1;
452 }
453
janet_registry_get(JanetCFunction key)454 JanetCFunRegistry *janet_registry_get(JanetCFunction key) {
455 if (janet_vm.registry_dirty) {
456 janet_registry_sort();
457 }
458 for (size_t i = 0; i < janet_vm.registry_count; i++) {
459 if (janet_vm.registry[i].cfun == key) {
460 return janet_vm.registry + i;
461 }
462 }
463 JanetCFunRegistry *lo = janet_vm.registry;
464 JanetCFunRegistry *hi = lo + janet_vm.registry_count;
465 while (lo < hi) {
466 JanetCFunRegistry *mid = lo + (hi - lo) / 2;
467 if (mid->cfun == key) {
468 return mid;
469 }
470 if ((void *)(mid->cfun) > (void *)(key)) {
471 hi = mid;
472 } else {
473 lo = mid + 1;
474 }
475 }
476 return NULL;
477 }
478
479 typedef struct {
480 char *buf;
481 size_t plen;
482 } NameBuf;
483
namebuf_init(NameBuf * namebuf,const char * prefix)484 static void namebuf_init(NameBuf *namebuf, const char *prefix) {
485 size_t plen = strlen(prefix);
486 namebuf->plen = plen;
487 namebuf->buf = janet_malloc(namebuf->plen + 256);
488 if (NULL == namebuf->buf) {
489 JANET_OUT_OF_MEMORY;
490 }
491 memcpy(namebuf->buf, prefix, plen);
492 namebuf->buf[plen] = '/';
493 }
494
namebuf_deinit(NameBuf * namebuf)495 static void namebuf_deinit(NameBuf *namebuf) {
496 janet_free(namebuf->buf);
497 }
498
namebuf_name(NameBuf * namebuf,const char * suffix)499 static char *namebuf_name(NameBuf *namebuf, const char *suffix) {
500 size_t slen = strlen(suffix);
501 namebuf->buf = janet_realloc(namebuf->buf, namebuf->plen + 2 + slen);
502 if (NULL == namebuf->buf) {
503 JANET_OUT_OF_MEMORY;
504 }
505 memcpy(namebuf->buf + namebuf->plen + 1, suffix, slen);
506 namebuf->buf[namebuf->plen + 1 + slen] = '\0';
507 return (char *)(namebuf->buf);
508 }
509
janet_cfuns(JanetTable * env,const char * regprefix,const JanetReg * cfuns)510 void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) {
511 while (cfuns->name) {
512 Janet fun = janet_wrap_cfunction(cfuns->cfun);
513 if (env) janet_def(env, cfuns->name, fun, cfuns->documentation);
514 janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0);
515 cfuns++;
516 }
517 }
518
janet_cfuns_ext(JanetTable * env,const char * regprefix,const JanetRegExt * cfuns)519 void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) {
520 while (cfuns->name) {
521 Janet fun = janet_wrap_cfunction(cfuns->cfun);
522 if (env) janet_def_sm(env, cfuns->name, fun, cfuns->documentation, cfuns->source_file, cfuns->source_line);
523 janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line);
524 cfuns++;
525 }
526 }
527
janet_cfuns_prefix(JanetTable * env,const char * regprefix,const JanetReg * cfuns)528 void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns) {
529 NameBuf nb;
530 if (env) namebuf_init(&nb, regprefix);
531 while (cfuns->name) {
532 Janet fun = janet_wrap_cfunction(cfuns->cfun);
533 if (env) janet_def(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation);
534 janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0);
535 cfuns++;
536 }
537 if (env) namebuf_deinit(&nb);
538 }
539
janet_cfuns_ext_prefix(JanetTable * env,const char * regprefix,const JanetRegExt * cfuns)540 void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) {
541 NameBuf nb;
542 if (env) namebuf_init(&nb, regprefix);
543 while (cfuns->name) {
544 Janet fun = janet_wrap_cfunction(cfuns->cfun);
545 if (env) janet_def_sm(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation, cfuns->source_file, cfuns->source_line);
546 janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line);
547 cfuns++;
548 }
549 if (env) namebuf_deinit(&nb);
550 }
551
552 /* Register a value in the global registry */
janet_register(const char * name,JanetCFunction cfun)553 void janet_register(const char *name, JanetCFunction cfun) {
554 janet_registry_put(cfun, name, NULL, NULL, 0);
555 }
556
557 /* Abstract type introspection */
558
janet_register_abstract_type(const JanetAbstractType * at)559 void janet_register_abstract_type(const JanetAbstractType *at) {
560 Janet sym = janet_csymbolv(at->name);
561 Janet check = janet_table_get(janet_vm.abstract_registry, sym);
562 if (!janet_checktype(check, JANET_NIL) && at != janet_unwrap_pointer(check)) {
563 janet_panicf("cannot register abstract type %s, "
564 "a type with the same name exists", at->name);
565 }
566 janet_table_put(janet_vm.abstract_registry, sym, janet_wrap_pointer((void *) at));
567 }
568
janet_get_abstract_type(Janet key)569 const JanetAbstractType *janet_get_abstract_type(Janet key) {
570 Janet wrapped = janet_table_get(janet_vm.abstract_registry, key);
571 if (janet_checktype(wrapped, JANET_NIL)) {
572 return NULL;
573 }
574 return (JanetAbstractType *)(janet_unwrap_pointer(wrapped));
575 }
576
577 #ifndef JANET_BOOTSTRAP
janet_core_def_sm(JanetTable * env,const char * name,Janet x,const void * p,const void * sf,int32_t sl)578 void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p, const void *sf, int32_t sl) {
579 (void) sf;
580 (void) sl;
581 (void) p;
582 Janet key = janet_csymbolv(name);
583 janet_table_put(env, key, x);
584 if (janet_checktype(x, JANET_CFUNCTION)) {
585 janet_registry_put(janet_unwrap_cfunction(x), name, NULL, NULL, 0);
586 }
587 }
588
janet_core_cfuns_ext(JanetTable * env,const char * regprefix,const JanetRegExt * cfuns)589 void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) {
590 (void) regprefix;
591 while (cfuns->name) {
592 Janet fun = janet_wrap_cfunction(cfuns->cfun);
593 janet_table_put(env, janet_csymbolv(cfuns->name), fun);
594 janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line);
595 cfuns++;
596 }
597 }
598 #endif
599
janet_resolve_ext(JanetTable * env,const uint8_t * sym)600 JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) {
601 Janet ref;
602 JanetTable *entry_table;
603 Janet entry = janet_table_get(env, janet_wrap_symbol(sym));
604 JanetBinding binding = {
605 JANET_BINDING_NONE,
606 janet_wrap_nil(),
607 JANET_BINDING_DEP_NONE
608 };
609
610 /* Check environment for entry */
611 if (!janet_checktype(entry, JANET_TABLE))
612 return binding;
613 entry_table = janet_unwrap_table(entry);
614
615 /* deprecation check */
616 Janet deprecate = janet_table_get(entry_table, janet_ckeywordv("deprecated"));
617 if (janet_checktype(deprecate, JANET_KEYWORD)) {
618 JanetKeyword depkw = janet_unwrap_keyword(deprecate);
619 if (!janet_cstrcmp(depkw, "relaxed")) {
620 binding.deprecation = JANET_BINDING_DEP_RELAXED;
621 } else if (!janet_cstrcmp(depkw, "normal")) {
622 binding.deprecation = JANET_BINDING_DEP_NORMAL;
623 } else if (!janet_cstrcmp(depkw, "strict")) {
624 binding.deprecation = JANET_BINDING_DEP_STRICT;
625 }
626 } else if (!janet_checktype(deprecate, JANET_NIL)) {
627 binding.deprecation = JANET_BINDING_DEP_NORMAL;
628 }
629
630 if (!janet_checktype(
631 janet_table_get(entry_table, janet_ckeywordv("macro")),
632 JANET_NIL)) {
633 binding.value = janet_table_get(entry_table, janet_ckeywordv("value"));
634 binding.type = JANET_BINDING_MACRO;
635 return binding;
636 }
637
638 ref = janet_table_get(entry_table, janet_ckeywordv("ref"));
639 if (janet_checktype(ref, JANET_ARRAY)) {
640 binding.value = ref;
641 binding.type = JANET_BINDING_VAR;
642 return binding;
643 }
644
645 binding.value = janet_table_get(entry_table, janet_ckeywordv("value"));
646 binding.type = JANET_BINDING_DEF;
647 return binding;
648 }
649
janet_resolve(JanetTable * env,const uint8_t * sym,Janet * out)650 JanetBindingType janet_resolve(JanetTable *env, const uint8_t *sym, Janet *out) {
651 JanetBinding binding = janet_resolve_ext(env, sym);
652 *out = binding.value;
653 return binding.type;
654 }
655
656 /* Resolve a symbol in the core environment. */
janet_resolve_core(const char * name)657 Janet janet_resolve_core(const char *name) {
658 JanetTable *env = janet_core_env(NULL);
659 Janet out = janet_wrap_nil();
660 janet_resolve(env, janet_csymbol(name), &out);
661 return out;
662 }
663
664 /* Read both tuples and arrays as c pointers + int32_t length. Return 1 if the
665 * view can be constructed, 0 if an invalid type. */
janet_indexed_view(Janet seq,const Janet ** data,int32_t * len)666 int janet_indexed_view(Janet seq, const Janet **data, int32_t *len) {
667 if (janet_checktype(seq, JANET_ARRAY)) {
668 *data = janet_unwrap_array(seq)->data;
669 *len = janet_unwrap_array(seq)->count;
670 return 1;
671 } else if (janet_checktype(seq, JANET_TUPLE)) {
672 *data = janet_unwrap_tuple(seq);
673 *len = janet_tuple_length(janet_unwrap_tuple(seq));
674 return 1;
675 }
676 return 0;
677 }
678
679 /* Read both strings and buffer as unsigned character array + int32_t len.
680 * Returns 1 if the view can be constructed and 0 if the type is invalid. */
janet_bytes_view(Janet str,const uint8_t ** data,int32_t * len)681 int janet_bytes_view(Janet str, const uint8_t **data, int32_t *len) {
682 if (janet_checktype(str, JANET_STRING) || janet_checktype(str, JANET_SYMBOL) ||
683 janet_checktype(str, JANET_KEYWORD)) {
684 *data = janet_unwrap_string(str);
685 *len = janet_string_length(janet_unwrap_string(str));
686 return 1;
687 } else if (janet_checktype(str, JANET_BUFFER)) {
688 *data = janet_unwrap_buffer(str)->data;
689 *len = janet_unwrap_buffer(str)->count;
690 return 1;
691 }
692 return 0;
693 }
694
695 /* Read both structs and tables as the entries of a hashtable with
696 * identical structure. Returns 1 if the view can be constructed and
697 * 0 if the type is invalid. */
janet_dictionary_view(Janet tab,const JanetKV ** data,int32_t * len,int32_t * cap)698 int janet_dictionary_view(Janet tab, const JanetKV **data, int32_t *len, int32_t *cap) {
699 if (janet_checktype(tab, JANET_TABLE)) {
700 *data = janet_unwrap_table(tab)->data;
701 *cap = janet_unwrap_table(tab)->capacity;
702 *len = janet_unwrap_table(tab)->count;
703 return 1;
704 } else if (janet_checktype(tab, JANET_STRUCT)) {
705 *data = janet_unwrap_struct(tab);
706 *cap = janet_struct_capacity(janet_unwrap_struct(tab));
707 *len = janet_struct_length(janet_unwrap_struct(tab));
708 return 1;
709 }
710 return 0;
711 }
712
janet_checkint(Janet x)713 int janet_checkint(Janet x) {
714 if (!janet_checktype(x, JANET_NUMBER))
715 return 0;
716 double dval = janet_unwrap_number(x);
717 return janet_checkintrange(dval);
718 }
719
janet_checkint64(Janet x)720 int janet_checkint64(Janet x) {
721 if (!janet_checktype(x, JANET_NUMBER))
722 return 0;
723 double dval = janet_unwrap_number(x);
724 return janet_checkint64range(dval);
725 }
726
janet_checksize(Janet x)727 int janet_checksize(Janet x) {
728 if (!janet_checktype(x, JANET_NUMBER))
729 return 0;
730 double dval = janet_unwrap_number(x);
731 if (dval != (double)((size_t) dval)) return 0;
732 if (SIZE_MAX > JANET_INTMAX_INT64) {
733 return dval <= JANET_INTMAX_INT64;
734 } else {
735 return dval <= SIZE_MAX;
736 }
737 }
738
janet_get_core_table(const char * name)739 JanetTable *janet_get_core_table(const char *name) {
740 JanetTable *env = janet_core_env(NULL);
741 Janet out = janet_wrap_nil();
742 JanetBindingType bt = janet_resolve(env, janet_csymbol(name), &out);
743 if (bt == JANET_BINDING_NONE) return NULL;
744 if (!janet_checktype(out, JANET_TABLE)) return NULL;
745 return janet_unwrap_table(out);
746 }
747
748 /* Sort keys of a dictionary type */
janet_sorted_keys(const JanetKV * dict,int32_t cap,int32_t * index_buffer)749 int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *index_buffer) {
750
751 /* First, put populated indices into index_buffer */
752 int32_t next_index = 0;
753 for (int32_t i = 0; i < cap; i++) {
754 if (!janet_checktype(dict[i].key, JANET_NIL)) {
755 index_buffer[next_index++] = i;
756 }
757 }
758
759 /* Next, sort those (simple insertion sort here for now) */
760 for (int32_t i = 1; i < next_index; i++) {
761 int32_t index_to_insert = index_buffer[i];
762 Janet lhs = dict[index_to_insert].key;
763 for (int32_t j = i - 1; j >= 0; j--) {
764 index_buffer[j + 1] = index_buffer[j];
765 Janet rhs = dict[index_buffer[j]].key;
766 if (janet_compare(lhs, rhs) >= 0) {
767 index_buffer[j + 1] = index_to_insert;
768 break;
769 } else if (j == 0) {
770 index_buffer[0] = index_to_insert;
771 }
772 }
773 }
774
775 /* Return number of indices found */
776 return next_index;
777
778 }
779
780 /* Clock shims for various platforms */
781 #ifdef JANET_GETTIME
782 /* For macos */
783 #ifdef __MACH__
784 #include <mach/clock.h>
785 #include <mach/mach.h>
786 #endif
787 #ifdef JANET_WINDOWS
janet_gettime(struct timespec * spec)788 int janet_gettime(struct timespec *spec) {
789 FILETIME ftime;
790 GetSystemTimeAsFileTime(&ftime);
791 int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32);
792 /* Windows epoch is January 1, 1601 apparently */
793 wintime -= 116444736000000000LL;
794 spec->tv_sec = wintime / 10000000LL;
795 /* Resolution is 100 nanoseconds. */
796 spec->tv_nsec = wintime % 10000000LL * 100;
797 return 0;
798 }
799 #elif defined(__MACH__)
janet_gettime(struct timespec * spec)800 int janet_gettime(struct timespec *spec) {
801 clock_serv_t cclock;
802 mach_timespec_t mts;
803 host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock);
804 clock_get_time(cclock, &mts);
805 mach_port_deallocate(mach_task_self(), cclock);
806 spec->tv_sec = mts.tv_sec;
807 spec->tv_nsec = mts.tv_nsec;
808 return 0;
809 }
810 #else
janet_gettime(struct timespec * spec)811 int janet_gettime(struct timespec *spec) {
812 return clock_gettime(CLOCK_REALTIME, spec);
813 }
814 #endif
815 #endif
816
817 /* Setting C99 standard makes this not available, but it should
818 * work/link properly if we detect a BSD */
819 #if defined(JANET_BSD) || defined(MAC_OS_X_VERSION_10_7)
820 void arc4random_buf(void *buf, size_t nbytes);
821 #endif
822
janet_cryptorand(uint8_t * out,size_t n)823 int janet_cryptorand(uint8_t *out, size_t n) {
824 #ifdef JANET_WINDOWS
825 for (size_t i = 0; i < n; i += sizeof(unsigned int)) {
826 unsigned int v;
827 if (rand_s(&v))
828 return -1;
829 for (int32_t j = 0; (j < sizeof(unsigned int)) && (i + j < n); j++) {
830 out[i + j] = v & 0xff;
831 v = v >> 8;
832 }
833 }
834 return 0;
835 #elif defined(JANET_LINUX) || ( defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_7) )
836 /* We should be able to call getrandom on linux, but it doesn't seem
837 to be uniformly supported on linux distros.
838 On Mac, arc4random_buf wasn't available on until 10.7.
839 In these cases, use this fallback path for now... */
840 int rc;
841 int randfd;
842 RETRY_EINTR(randfd, open("/dev/urandom", O_RDONLY | O_CLOEXEC));
843 if (randfd < 0)
844 return -1;
845 while (n > 0) {
846 ssize_t nread;
847 RETRY_EINTR(nread, read(randfd, out, n));
848 if (nread <= 0) {
849 RETRY_EINTR(rc, close(randfd));
850 return -1;
851 }
852 out += nread;
853 n -= nread;
854 }
855 RETRY_EINTR(rc, close(randfd));
856 return 0;
857 #elif defined(JANET_BSD) || defined(MAC_OS_X_VERSION_10_7)
858 arc4random_buf(out, n);
859 return 0;
860 #else
861 (void) n;
862 (void) out;
863 return -1;
864 #endif
865 }
866
867
868 /* Alloc function macro fills */
869 void *(janet_malloc)(size_t size) {
870 return janet_malloc(size);
871 }
872
873 void (janet_free)(void *ptr) {
874 janet_free(ptr);
875 }
876
877 void *(janet_calloc)(size_t nmemb, size_t size) {
878 return janet_calloc(nmemb, size);
879 }
880
881 void *(janet_realloc)(void *ptr, size_t size) {
882 return janet_realloc(ptr, size);
883 }
884