You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

builtins.c 11KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460
  1. #include "vm/builtins.h"
  2. #include <stdio.h>
  3. static void print_val(struct l2_vm *vm, struct l2_io_writer *out, struct l2_vm_value *val) {
  4. switch (l2_value_get_type(val)) {
  5. case L2_VAL_TYPE_NONE:
  6. l2_io_printf(out, "(none)");
  7. break;
  8. case L2_VAL_TYPE_ATOM:
  9. if (val->atom == vm->values[vm->ktrue].atom) {
  10. l2_io_printf(out, "(true)");
  11. } else if (val->atom == vm->values[vm->kfalse].atom) {
  12. l2_io_printf(out, "(false)");
  13. } else {
  14. l2_io_printf(out, "(atom %u)", val->atom);
  15. }
  16. break;
  17. case L2_VAL_TYPE_REAL:
  18. l2_io_printf(out, "%g", val->real);
  19. break;
  20. case L2_VAL_TYPE_BUFFER:
  21. if (val->buffer != NULL) {
  22. out->write(out, val->buffer, val->extra.buf_length);
  23. }
  24. break;
  25. case L2_VAL_TYPE_ARRAY:
  26. out->write(out, "[", 1);
  27. l2_word *data;
  28. if (val->flags & L2_VAL_SBO) {
  29. data = val->shortarray;
  30. } else {
  31. data = val->array->data;
  32. }
  33. for (size_t i = 0; i < val->extra.arr_length; ++i) {
  34. if (i != 0) {
  35. out->write(out, " ", 1);
  36. }
  37. print_val(vm, out, &vm->values[data[i]]);
  38. }
  39. out->write(out, "]", 1);
  40. break;
  41. case L2_VAL_TYPE_NAMESPACE:
  42. l2_io_printf(out, "(namespace)");
  43. break;
  44. case L2_VAL_TYPE_FUNCTION:
  45. case L2_VAL_TYPE_CFUNCTION:
  46. l2_io_printf(out, "(function)");
  47. break;
  48. case L2_VAL_TYPE_ERROR:
  49. l2_io_printf(out, "(error: %s)", val->error);
  50. break;
  51. case L2_VAL_TYPE_CONTINUATION:
  52. l2_io_printf(out, "(continuation)");
  53. break;
  54. }
  55. }
  56. #define X(name, identity, op) \
  57. l2_word name(struct l2_vm *vm, l2_word argc, l2_word *argv) { \
  58. if (argc == 0) { \
  59. l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
  60. vm->values[id].real = identity; \
  61. return id; \
  62. } \
  63. struct l2_vm_value *first = &vm->values[argv[0]]; \
  64. if (l2_value_get_type(first) != L2_VAL_TYPE_REAL) { \
  65. return l2_vm_type_error(vm, first); \
  66. } \
  67. if (argc == 1) { \
  68. l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
  69. vm->values[id].real = identity op first->real; \
  70. return id; \
  71. } \
  72. double sum = first->real; \
  73. for (l2_word i = 1; i < argc; ++i) { \
  74. struct l2_vm_value *val = &vm->values[argv[i]]; \
  75. if (l2_value_get_type(val) != L2_VAL_TYPE_REAL) { \
  76. return l2_vm_type_error(vm, val); \
  77. } \
  78. sum = sum op val->real; \
  79. } \
  80. l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
  81. vm->values[id].real = sum; \
  82. return id; \
  83. }
  84. X(l2_builtin_add, 0, +)
  85. X(l2_builtin_sub, 0, -)
  86. X(l2_builtin_mul, 1, *)
  87. X(l2_builtin_div, 1, /)
  88. #undef X
  89. l2_word l2_builtin_eq(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  90. if (argc < 2) {
  91. return vm->ktrue;
  92. }
  93. for (l2_word i = 1; i < argc; ++i) {
  94. if (argv[i - 1] == argv[i]) continue;
  95. struct l2_vm_value *a = &vm->values[argv[i - 1]];
  96. struct l2_vm_value *b = &vm->values[argv[i]];
  97. if (l2_value_get_type(a) != l2_value_get_type(b)) {
  98. return vm->kfalse;
  99. }
  100. enum l2_value_type typ = l2_value_get_type(a);
  101. if (typ == L2_VAL_TYPE_ATOM) {
  102. if (a->atom != b->atom) {
  103. return vm->kfalse;
  104. }
  105. } else if (typ == L2_VAL_TYPE_REAL) {
  106. if (a->real != b->real) {
  107. return vm->kfalse;
  108. }
  109. } else if (typ == L2_VAL_TYPE_BUFFER) {
  110. if (a->buffer == NULL && b->buffer == NULL) continue;
  111. if (a->buffer == NULL || b->buffer == NULL) {
  112. return vm->kfalse;
  113. }
  114. if (a->extra.buf_length != b->extra.buf_length) {
  115. return vm->kfalse;
  116. }
  117. if (memcmp(a->buffer, b->buffer, a->extra.buf_length) != 0) {
  118. return vm->kfalse;
  119. }
  120. } else {
  121. return vm->kfalse;
  122. }
  123. }
  124. return vm->ktrue;
  125. }
  126. l2_word l2_builtin_neq(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  127. l2_word ret_id = l2_builtin_eq(vm, argc, argv);
  128. if (ret_id == vm->ktrue) {
  129. return vm->kfalse;
  130. } else if (ret_id == vm->kfalse) {
  131. return vm->ktrue;
  132. } else {
  133. return ret_id;
  134. }
  135. }
  136. #define X(name, op) \
  137. l2_word name(struct l2_vm *vm, l2_word argc, l2_word *argv) { \
  138. if (argc < 2) { \
  139. return vm->ktrue; \
  140. } \
  141. struct l2_vm_value *lhs = &vm->values[argv[0]]; \
  142. if (l2_value_get_type(lhs) != L2_VAL_TYPE_REAL) { \
  143. return l2_vm_type_error(vm, lhs); \
  144. } \
  145. for (l2_word i = 1; i < argc; ++i) { \
  146. struct l2_vm_value *rhs = &vm->values[argv[i]]; \
  147. if (l2_value_get_type(rhs) != L2_VAL_TYPE_REAL) { \
  148. return l2_vm_type_error(vm, rhs); \
  149. } \
  150. if (!(lhs->real op rhs->real)) { \
  151. return vm->kfalse; \
  152. } \
  153. lhs = rhs; \
  154. } \
  155. return vm->ktrue; \
  156. }
  157. X(l2_builtin_lt, <)
  158. X(l2_builtin_lteq, <=)
  159. X(l2_builtin_gt, >)
  160. X(l2_builtin_gteq, >=)
  161. #undef X
  162. l2_word l2_builtin_land(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  163. for (l2_word i = 0; i < argc; ++i) {
  164. struct l2_vm_value *val = &vm->values[argv[i]];
  165. if (l2_value_get_type(val) == L2_VAL_TYPE_ERROR) {
  166. return argv[i];
  167. }
  168. if (!l2_vm_val_is_true(vm, val)) {
  169. return vm->kfalse;
  170. }
  171. }
  172. return vm->ktrue;
  173. }
  174. l2_word l2_builtin_lor(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  175. for (l2_word i = 0; i < argc; ++i) {
  176. struct l2_vm_value *val = &vm->values[argv[i]];
  177. if (l2_value_get_type(val) == L2_VAL_TYPE_ERROR) {
  178. return argv[i];
  179. }
  180. if (l2_vm_val_is_true(vm, val)) {
  181. return vm->ktrue;
  182. }
  183. }
  184. return vm->kfalse;
  185. }
  186. l2_word l2_builtin_first(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  187. for (l2_word i = 0; i < argc; ++i) {
  188. if (l2_value_get_type(&vm->values[argv[i]]) != L2_VAL_TYPE_NONE) {
  189. return argv[i];
  190. }
  191. }
  192. return vm->knone;
  193. }
  194. l2_word l2_builtin_print(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  195. for (size_t i = 0; i < argc; ++i) {
  196. if (i != 0) {
  197. vm->std_output->write(vm->std_output, " ", 1);
  198. }
  199. struct l2_vm_value *val = &vm->values[argv[i]];
  200. print_val(vm, vm->std_output, val);
  201. }
  202. vm->std_output->write(vm->std_output, "\n", 1);
  203. return 0;
  204. }
  205. l2_word l2_builtin_len(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  206. if (argc != 1) {
  207. return l2_vm_error(vm, "Expected 1 argument");
  208. }
  209. l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
  210. struct l2_vm_value *ret = &vm->values[ret_id];
  211. ret->real = 0;
  212. struct l2_vm_value *val = &vm->values[argv[0]];
  213. switch (l2_value_get_type(val)) {
  214. case L2_VAL_TYPE_NONE:
  215. case L2_VAL_TYPE_ATOM:
  216. case L2_VAL_TYPE_REAL:
  217. case L2_VAL_TYPE_FUNCTION:
  218. case L2_VAL_TYPE_CFUNCTION:
  219. case L2_VAL_TYPE_ERROR:
  220. case L2_VAL_TYPE_CONTINUATION:
  221. break;
  222. case L2_VAL_TYPE_BUFFER:
  223. ret->real = val->extra.buf_length;
  224. break;
  225. case L2_VAL_TYPE_ARRAY:
  226. ret->real = val->extra.arr_length;
  227. break;
  228. case L2_VAL_TYPE_NAMESPACE:
  229. if (val->ns) {
  230. ret->real = val->ns->len;
  231. }
  232. }
  233. return ret_id;
  234. }
  235. l2_word l2_builtin_if(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  236. if (argc != 2 && argc != 3) {
  237. return l2_vm_error(vm, "Expected 2 or 3 arguments");
  238. }
  239. if (l2_vm_val_is_true(vm, &vm->values[argv[0]])) {
  240. l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
  241. struct l2_vm_value *ret = &vm->values[ret_id];
  242. ret->extra.cont_call = argv[1];
  243. return ret_id;
  244. } else if (argc == 3) {
  245. l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
  246. struct l2_vm_value *ret = &vm->values[ret_id];
  247. ret->extra.cont_call = argv[2];
  248. return ret_id;
  249. } else {
  250. return 0;
  251. }
  252. }
  253. struct loop_context {
  254. struct l2_vm_contcontext base;
  255. l2_word func;
  256. };
  257. static l2_word loop_callback(struct l2_vm *vm, l2_word retval, l2_word cont) {
  258. struct l2_vm_value *val = &vm->values[retval];
  259. if (l2_value_get_type(val) == L2_VAL_TYPE_ATOM && val->atom == vm->values[vm->kstop].atom) {
  260. return vm->knone;
  261. } else {
  262. return cont;
  263. }
  264. }
  265. static void loop_marker(
  266. struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
  267. struct loop_context *ctx = data;
  268. mark(vm, ctx->func);
  269. }
  270. l2_word l2_builtin_loop(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  271. if (argc != 1) {
  272. return l2_vm_error(vm, "Expected 1 argument");
  273. }
  274. struct loop_context *ctx = malloc(sizeof(*ctx));
  275. if (ctx == NULL) {
  276. return l2_vm_error(vm, "Allocation failure");
  277. }
  278. ctx->base.callback = loop_callback;
  279. ctx->base.marker = loop_marker;
  280. ctx->base.args = vm->knone;
  281. ctx->func = argv[0];
  282. l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
  283. struct l2_vm_value *cont = &vm->values[cont_id];
  284. cont->extra.cont_call = ctx->func;
  285. cont->cont = &ctx->base;
  286. return cont_id;
  287. }
  288. struct while_context {
  289. struct l2_vm_contcontext base;
  290. l2_word cond, body;
  291. };
  292. static l2_word while_callback(struct l2_vm *vm, l2_word retval, l2_word cont_id) {
  293. struct l2_vm_value *cont = &vm->values[cont_id];
  294. struct while_context *ctx = (struct while_context *)cont->cont;
  295. struct l2_vm_value *ret = &vm->values[retval];
  296. if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
  297. return retval;
  298. }
  299. if (cont->extra.cont_call == ctx->cond) {
  300. if (l2_vm_val_is_true(vm, ret)) {
  301. cont->extra.cont_call = ctx->body;
  302. return cont_id;
  303. } else {
  304. return retval;
  305. }
  306. } else {
  307. if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
  308. return retval;
  309. } else {
  310. cont->extra.cont_call = ctx->cond;
  311. return cont_id;
  312. }
  313. }
  314. }
  315. static void while_marker(
  316. struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
  317. struct while_context *ctx = data;
  318. mark(vm, ctx->cond);
  319. mark(vm, ctx->body);
  320. }
  321. l2_word l2_builtin_while(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  322. if (argc != 2) {
  323. return l2_vm_error(vm, "Expected 2 arguments");
  324. }
  325. struct while_context *ctx = malloc(sizeof(*ctx));
  326. if (ctx == NULL) {
  327. return l2_vm_error(vm, "Allocation failure");
  328. }
  329. ctx->base.callback = while_callback;
  330. ctx->base.marker = while_marker;
  331. ctx->base.args = vm->knone;
  332. ctx->cond = argv[0];
  333. ctx->body = argv[1];
  334. l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
  335. struct l2_vm_value *cont = &vm->values[cont_id];
  336. cont->extra.cont_call = ctx->cond;
  337. cont->cont = &ctx->base;
  338. return cont_id;
  339. }
  340. struct for_context {
  341. struct l2_vm_contcontext base;
  342. l2_word iter;
  343. l2_word func;
  344. };
  345. static l2_word for_callback(struct l2_vm *vm, l2_word retval, l2_word cont_id) {
  346. struct l2_vm_value *cont = &vm->values[cont_id];
  347. struct for_context *ctx = (struct for_context *)cont->cont;
  348. struct l2_vm_value *ret = &vm->values[retval];
  349. if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
  350. return retval;
  351. }
  352. struct l2_vm_value *args = &vm->values[cont->cont->args];
  353. if (cont->extra.cont_call == ctx->iter) {
  354. if (
  355. l2_value_get_type(ret) == L2_VAL_TYPE_ATOM &&
  356. ret->atom == vm->values[vm->kstop].atom) {
  357. return vm->knone;
  358. } else {
  359. cont->extra.cont_call = ctx->func;
  360. args->extra.arr_length = 1;
  361. args->shortarray[0] = retval;
  362. return cont_id;
  363. }
  364. } else {
  365. cont->extra.cont_call = ctx->iter;
  366. args->extra.arr_length = 0;
  367. return cont_id;
  368. }
  369. }
  370. static void for_marker(
  371. struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
  372. struct for_context *ctx = data;
  373. mark(vm, ctx->iter);
  374. mark(vm, ctx->func);
  375. }
  376. l2_word l2_builtin_for(struct l2_vm *vm, l2_word argc, l2_word *argv) {
  377. if (argc != 2) {
  378. return l2_vm_error(vm, "Expected 2 arguments");
  379. }
  380. l2_word args_id = l2_vm_alloc(vm, L2_VAL_TYPE_ARRAY, L2_VAL_SBO);
  381. struct l2_vm_value *args = &vm->values[args_id];
  382. args->extra.arr_length = 0;
  383. struct for_context *ctx = malloc(sizeof(*ctx));
  384. ctx->base.callback = for_callback;
  385. ctx->base.marker = for_marker;
  386. ctx->base.args = args_id;
  387. ctx->iter = argv[0];
  388. ctx->func = argv[1];
  389. l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
  390. struct l2_vm_value *cont = &vm->values[cont_id];
  391. cont->extra.cont_call = ctx->iter;
  392. cont->cont = &ctx->base;
  393. return cont_id;
  394. }