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 "state.h"
27 #include "fiber.h"
28 #endif
29
30 #ifndef JANET_SINGLE_THREADED
31 #ifndef JANET_WINDOWS
32 #include <pthread.h>
33 #else
34 #include <windows.h>
35 #endif
36 #endif
37
janet_top_level_signal(const char * msg)38 JANET_NO_RETURN static void janet_top_level_signal(const char *msg) {
39 #ifdef JANET_TOP_LEVEL_SIGNAL
40 JANET_TOP_LEVEL_SIGNAL(msg);
41 #else
42 fputs(msg, stdout);
43 # ifdef JANET_SINGLE_THREADED
44 exit(-1);
45 # elif defined(JANET_WINDOWS)
46 ExitThread(-1);
47 # else
48 pthread_exit(NULL);
49 # endif
50 #endif
51 }
52
janet_signalv(JanetSignal sig,Janet message)53 void janet_signalv(JanetSignal sig, Janet message) {
54 if (janet_vm.return_reg != NULL) {
55 *janet_vm.return_reg = message;
56 if (NULL != janet_vm.fiber) {
57 janet_vm.fiber->flags |= JANET_FIBER_DID_LONGJUMP;
58 }
59 #if defined(JANET_BSD) || defined(JANET_APPLE)
60 _longjmp(*janet_vm.signal_buf, sig);
61 #else
62 longjmp(*janet_vm.signal_buf, sig);
63 #endif
64 } else {
65 const char *str = (const char *)janet_formatc("janet top level signal - %v\n", message);
66 janet_top_level_signal(str);
67 }
68 }
69
janet_panicv(Janet message)70 void janet_panicv(Janet message) {
71 janet_signalv(JANET_SIGNAL_ERROR, message);
72 }
73
janet_panicf(const char * format,...)74 void janet_panicf(const char *format, ...) {
75 va_list args;
76 const uint8_t *ret;
77 JanetBuffer buffer;
78 int32_t len = 0;
79 while (format[len]) len++;
80 janet_buffer_init(&buffer, len);
81 va_start(args, format);
82 janet_formatbv(&buffer, format, args);
83 va_end(args);
84 ret = janet_string(buffer.data, buffer.count);
85 janet_buffer_deinit(&buffer);
86 janet_panics(ret);
87 }
88
janet_panic(const char * message)89 void janet_panic(const char *message) {
90 janet_panicv(janet_cstringv(message));
91 }
92
janet_panics(const uint8_t * message)93 void janet_panics(const uint8_t *message) {
94 janet_panicv(janet_wrap_string(message));
95 }
96
janet_panic_type(Janet x,int32_t n,int expected)97 void janet_panic_type(Janet x, int32_t n, int expected) {
98 janet_panicf("bad slot #%d, expected %T, got %v", n, expected, x);
99 }
100
janet_panic_abstract(Janet x,int32_t n,const JanetAbstractType * at)101 void janet_panic_abstract(Janet x, int32_t n, const JanetAbstractType *at) {
102 janet_panicf("bad slot #%d, expected %s, got %v", n, at->name, x);
103 }
104
janet_fixarity(int32_t arity,int32_t fix)105 void janet_fixarity(int32_t arity, int32_t fix) {
106 if (arity != fix)
107 janet_panicf("arity mismatch, expected %d, got %d", fix, arity);
108 }
109
janet_arity(int32_t arity,int32_t min,int32_t max)110 void janet_arity(int32_t arity, int32_t min, int32_t max) {
111 if (min >= 0 && arity < min)
112 janet_panicf("arity mismatch, expected at least %d, got %d", min, arity);
113 if (max >= 0 && arity > max)
114 janet_panicf("arity mismatch, expected at most %d, got %d", max, arity);
115 }
116
117 #define DEFINE_GETTER(name, NAME, type) \
118 type janet_get##name(const Janet *argv, int32_t n) { \
119 Janet x = argv[n]; \
120 if (!janet_checktype(x, JANET_##NAME)) { \
121 janet_panic_type(x, n, JANET_TFLAG_##NAME); \
122 } \
123 return janet_unwrap_##name(x); \
124 }
125
126 #define DEFINE_OPT(name, NAME, type) \
127 type janet_opt##name(const Janet *argv, int32_t argc, int32_t n, type dflt) { \
128 if (n >= argc) return dflt; \
129 if (janet_checktype(argv[n], JANET_NIL)) return dflt; \
130 return janet_get##name(argv, n); \
131 }
132
133 #define DEFINE_OPTLEN(name, NAME, type) \
134 type janet_opt##name(const Janet *argv, int32_t argc, int32_t n, int32_t dflt_len) { \
135 if (n >= argc || janet_checktype(argv[n], JANET_NIL)) {\
136 return janet_##name(dflt_len); \
137 }\
138 return janet_get##name(argv, n); \
139 }
140
janet_getmethod(const uint8_t * method,const JanetMethod * methods,Janet * out)141 int janet_getmethod(const uint8_t *method, const JanetMethod *methods, Janet *out) {
142 while (methods->name) {
143 if (!janet_cstrcmp(method, methods->name)) {
144 *out = janet_wrap_cfunction(methods->cfun);
145 return 1;
146 }
147 methods++;
148 }
149 return 0;
150 }
151
janet_nextmethod(const JanetMethod * methods,Janet key)152 Janet janet_nextmethod(const JanetMethod *methods, Janet key) {
153 if (!janet_checktype(key, JANET_NIL)) {
154 while (methods->name) {
155 if (janet_keyeq(key, methods->name)) {
156 methods++;
157 break;
158 }
159 methods++;
160 }
161 }
162 if (methods->name) {
163 return janet_ckeywordv(methods->name);
164 } else {
165 return janet_wrap_nil();
166 }
167 }
168
DEFINE_GETTER(number,NUMBER,double)169 DEFINE_GETTER(number, NUMBER, double)
170 DEFINE_GETTER(array, ARRAY, JanetArray *)
171 DEFINE_GETTER(tuple, TUPLE, const Janet *)
172 DEFINE_GETTER(table, TABLE, JanetTable *)
173 DEFINE_GETTER(struct, STRUCT, const JanetKV *)
174 DEFINE_GETTER(string, STRING, const uint8_t *)
175 DEFINE_GETTER(keyword, KEYWORD, const uint8_t *)
176 DEFINE_GETTER(symbol, SYMBOL, const uint8_t *)
177 DEFINE_GETTER(buffer, BUFFER, JanetBuffer *)
178 DEFINE_GETTER(fiber, FIBER, JanetFiber *)
179 DEFINE_GETTER(function, FUNCTION, JanetFunction *)
180 DEFINE_GETTER(cfunction, CFUNCTION, JanetCFunction)
181 DEFINE_GETTER(boolean, BOOLEAN, int)
182 DEFINE_GETTER(pointer, POINTER, void *)
183
184 DEFINE_OPT(number, NUMBER, double)
185 DEFINE_OPT(tuple, TUPLE, const Janet *)
186 DEFINE_OPT(struct, STRUCT, const JanetKV *)
187 DEFINE_OPT(string, STRING, const uint8_t *)
188 DEFINE_OPT(keyword, KEYWORD, const uint8_t *)
189 DEFINE_OPT(symbol, SYMBOL, const uint8_t *)
190 DEFINE_OPT(fiber, FIBER, JanetFiber *)
191 DEFINE_OPT(function, FUNCTION, JanetFunction *)
192 DEFINE_OPT(cfunction, CFUNCTION, JanetCFunction)
193 DEFINE_OPT(boolean, BOOLEAN, int)
194 DEFINE_OPT(pointer, POINTER, void *)
195
196 DEFINE_OPTLEN(buffer, BUFFER, JanetBuffer *)
197 DEFINE_OPTLEN(table, TABLE, JanetTable *)
198 DEFINE_OPTLEN(array, ARRAY, JanetArray *)
199
200 const char *janet_optcstring(const Janet *argv, int32_t argc, int32_t n, const char *dflt) {
201 if (n >= argc || janet_checktype(argv[n], JANET_NIL)) {
202 return dflt;
203 }
204 return janet_getcstring(argv, n);
205 }
206
207 #undef DEFINE_GETTER
208 #undef DEFINE_OPT
209 #undef DEFINE_OPTLEN
210
janet_getcstring(const Janet * argv,int32_t n)211 const char *janet_getcstring(const Janet *argv, int32_t n) {
212 const uint8_t *jstr = janet_getstring(argv, n);
213 const char *cstr = (const char *)jstr;
214 if (strlen(cstr) != (size_t) janet_string_length(jstr)) {
215 janet_panic("string contains embedded 0s");
216 }
217 return cstr;
218 }
219
janet_getnat(const Janet * argv,int32_t n)220 int32_t janet_getnat(const Janet *argv, int32_t n) {
221 Janet x = argv[n];
222 if (!janet_checkint(x)) goto bad;
223 int32_t ret = janet_unwrap_integer(x);
224 if (ret < 0) goto bad;
225 return ret;
226 bad:
227 janet_panicf("bad slot #%d, expected non-negative 32 bit signed integer, got %v", n, x);
228 }
229
janet_checkabstract(Janet x,const JanetAbstractType * at)230 JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at) {
231 if (!janet_checktype(x, JANET_ABSTRACT)) return NULL;
232 JanetAbstract a = janet_unwrap_abstract(x);
233 if (janet_abstract_type(a) != at) return NULL;
234 return a;
235 }
236
janet_strlike_cmp(JanetType type,Janet x,const char * cstring)237 static int janet_strlike_cmp(JanetType type, Janet x, const char *cstring) {
238 if (janet_type(x) != type) return 0;
239 return !janet_cstrcmp(janet_unwrap_string(x), cstring);
240 }
241
janet_keyeq(Janet x,const char * cstring)242 int janet_keyeq(Janet x, const char *cstring) {
243 return janet_strlike_cmp(JANET_KEYWORD, x, cstring);
244 }
245
janet_streq(Janet x,const char * cstring)246 int janet_streq(Janet x, const char *cstring) {
247 return janet_strlike_cmp(JANET_STRING, x, cstring);
248 }
249
janet_symeq(Janet x,const char * cstring)250 int janet_symeq(Janet x, const char *cstring) {
251 return janet_strlike_cmp(JANET_SYMBOL, x, cstring);
252 }
253
janet_getinteger(const Janet * argv,int32_t n)254 int32_t janet_getinteger(const Janet *argv, int32_t n) {
255 Janet x = argv[n];
256 if (!janet_checkint(x)) {
257 janet_panicf("bad slot #%d, expected 32 bit signed integer, got %v", n, x);
258 }
259 return janet_unwrap_integer(x);
260 }
261
janet_getinteger64(const Janet * argv,int32_t n)262 int64_t janet_getinteger64(const Janet *argv, int32_t n) {
263 Janet x = argv[n];
264 if (!janet_checkint64(x)) {
265 janet_panicf("bad slot #%d, expected 64 bit signed integer, got %v", n, x);
266 }
267 return (int64_t) janet_unwrap_number(x);
268 }
269
janet_getsize(const Janet * argv,int32_t n)270 size_t janet_getsize(const Janet *argv, int32_t n) {
271 Janet x = argv[n];
272 if (!janet_checksize(x)) {
273 janet_panicf("bad slot #%d, expected size, got %v", n, x);
274 }
275 return (size_t) janet_unwrap_number(x);
276 }
277
janet_gethalfrange(const Janet * argv,int32_t n,int32_t length,const char * which)278 int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const char *which) {
279 int32_t raw = janet_getinteger(argv, n);
280 int32_t not_raw = raw;
281 if (not_raw < 0) not_raw += length + 1;
282 if (not_raw < 0 || not_raw > length)
283 janet_panicf("%s index %d out of range [%d,%d]", which, raw, -length - 1, length);
284 return not_raw;
285 }
286
janet_getargindex(const Janet * argv,int32_t n,int32_t length,const char * which)287 int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which) {
288 int32_t raw = janet_getinteger(argv, n);
289 int32_t not_raw = raw;
290 if (not_raw < 0) not_raw += length;
291 if (not_raw < 0 || not_raw > length)
292 janet_panicf("%s index %d out of range [%d,%d)", which, raw, -length, length);
293 return not_raw;
294 }
295
janet_getindexed(const Janet * argv,int32_t n)296 JanetView janet_getindexed(const Janet *argv, int32_t n) {
297 Janet x = argv[n];
298 JanetView view;
299 if (!janet_indexed_view(x, &view.items, &view.len)) {
300 janet_panic_type(x, n, JANET_TFLAG_INDEXED);
301 }
302 return view;
303 }
304
janet_getbytes(const Janet * argv,int32_t n)305 JanetByteView janet_getbytes(const Janet *argv, int32_t n) {
306 Janet x = argv[n];
307 JanetByteView view;
308 if (!janet_bytes_view(x, &view.bytes, &view.len)) {
309 janet_panic_type(x, n, JANET_TFLAG_BYTES);
310 }
311 return view;
312 }
313
janet_getdictionary(const Janet * argv,int32_t n)314 JanetDictView janet_getdictionary(const Janet *argv, int32_t n) {
315 Janet x = argv[n];
316 JanetDictView view;
317 if (!janet_dictionary_view(x, &view.kvs, &view.len, &view.cap)) {
318 janet_panic_type(x, n, JANET_TFLAG_DICTIONARY);
319 }
320 return view;
321 }
322
janet_getabstract(const Janet * argv,int32_t n,const JanetAbstractType * at)323 void *janet_getabstract(const Janet *argv, int32_t n, const JanetAbstractType *at) {
324 Janet x = argv[n];
325 if (!janet_checktype(x, JANET_ABSTRACT)) {
326 janet_panic_abstract(x, n, at);
327 }
328 void *abstractx = janet_unwrap_abstract(x);
329 if (janet_abstract_type(abstractx) != at) {
330 janet_panic_abstract(x, n, at);
331 }
332 return abstractx;
333 }
334
janet_getslice(int32_t argc,const Janet * argv)335 JanetRange janet_getslice(int32_t argc, const Janet *argv) {
336 janet_arity(argc, 1, 3);
337 JanetRange range;
338 int32_t length = janet_length(argv[0]);
339 if (argc == 1) {
340 range.start = 0;
341 range.end = length;
342 } else if (argc == 2) {
343 range.start = janet_checktype(argv[1], JANET_NIL)
344 ? 0
345 : janet_gethalfrange(argv, 1, length, "start");
346 range.end = length;
347 } else {
348 range.start = janet_checktype(argv[1], JANET_NIL)
349 ? 0
350 : janet_gethalfrange(argv, 1, length, "start");
351 range.end = janet_checktype(argv[2], JANET_NIL)
352 ? length
353 : janet_gethalfrange(argv, 2, length, "end");
354 if (range.end < range.start)
355 range.end = range.start;
356 }
357 return range;
358 }
359
janet_dyn(const char * name)360 Janet janet_dyn(const char *name) {
361 if (!janet_vm.fiber) {
362 if (!janet_vm.top_dyns) return janet_wrap_nil();
363 return janet_table_get(janet_vm.top_dyns, janet_ckeywordv(name));
364 }
365 if (janet_vm.fiber->env) {
366 return janet_table_get(janet_vm.fiber->env, janet_ckeywordv(name));
367 } else {
368 return janet_wrap_nil();
369 }
370 }
371
janet_setdyn(const char * name,Janet value)372 void janet_setdyn(const char *name, Janet value) {
373 if (!janet_vm.fiber) {
374 if (!janet_vm.top_dyns) janet_vm.top_dyns = janet_table(10);
375 janet_table_put(janet_vm.top_dyns, janet_ckeywordv(name), value);
376 } else {
377 if (!janet_vm.fiber->env) {
378 janet_vm.fiber->env = janet_table(1);
379 }
380 janet_table_put(janet_vm.fiber->env, janet_ckeywordv(name), value);
381 }
382 }
383
janet_getflags(const Janet * argv,int32_t n,const char * flags)384 uint64_t janet_getflags(const Janet *argv, int32_t n, const char *flags) {
385 uint64_t ret = 0;
386 const uint8_t *keyw = janet_getkeyword(argv, n);
387 int32_t klen = janet_string_length(keyw);
388 int32_t flen = (int32_t) strlen(flags);
389 if (flen > 64) {
390 flen = 64;
391 }
392 for (int32_t j = 0; j < klen; j++) {
393 for (int32_t i = 0; i < flen; i++) {
394 if (((uint8_t) flags[i]) == keyw[j]) {
395 ret |= 1ULL << i;
396 goto found;
397 }
398 }
399 janet_panicf("unexpected flag %c, expected one of \"%s\"", (char) keyw[j], flags);
400 found:
401 ;
402 }
403 return ret;
404 }
405
janet_optnat(const Janet * argv,int32_t argc,int32_t n,int32_t dflt)406 int32_t janet_optnat(const Janet *argv, int32_t argc, int32_t n, int32_t dflt) {
407 if (argc <= n) return dflt;
408 if (janet_checktype(argv[n], JANET_NIL)) return dflt;
409 return janet_getnat(argv, n);
410 }
411
janet_optinteger(const Janet * argv,int32_t argc,int32_t n,int32_t dflt)412 int32_t janet_optinteger(const Janet *argv, int32_t argc, int32_t n, int32_t dflt) {
413 if (argc <= n) return dflt;
414 if (janet_checktype(argv[n], JANET_NIL)) return dflt;
415 return janet_getinteger(argv, n);
416 }
417
janet_optinteger64(const Janet * argv,int32_t argc,int32_t n,int64_t dflt)418 int64_t janet_optinteger64(const Janet *argv, int32_t argc, int32_t n, int64_t dflt) {
419 if (argc <= n) return dflt;
420 if (janet_checktype(argv[n], JANET_NIL)) return dflt;
421 return janet_getinteger64(argv, n);
422 }
423
janet_optsize(const Janet * argv,int32_t argc,int32_t n,size_t dflt)424 size_t janet_optsize(const Janet *argv, int32_t argc, int32_t n, size_t dflt) {
425 if (argc <= n) return dflt;
426 if (janet_checktype(argv[n], JANET_NIL)) return dflt;
427 return janet_getsize(argv, n);
428 }
429
janet_optabstract(const Janet * argv,int32_t argc,int32_t n,const JanetAbstractType * at,void * dflt)430 void *janet_optabstract(const Janet *argv, int32_t argc, int32_t n, const JanetAbstractType *at, void *dflt) {
431 if (argc <= n) return dflt;
432 if (janet_checktype(argv[n], JANET_NIL)) return dflt;
433 return janet_getabstract(argv, n, at);
434 }
435
436 /* Some definitions for function-like macros */
437
438 JANET_API JanetStructHead *(janet_struct_head)(const JanetKV *st) {
439 return janet_struct_head(st);
440 }
441
442 JANET_API JanetAbstractHead *(janet_abstract_head)(const void *abstract) {
443 return janet_abstract_head(abstract);
444 }
445
446 JANET_API JanetStringHead *(janet_string_head)(const uint8_t *s) {
447 return janet_string_head(s);
448 }
449
450 JANET_API JanetTupleHead *(janet_tuple_head)(const Janet *tuple) {
451 return janet_tuple_head(tuple);
452 }
453