GCC Code Coverage Report

Directory: ../src/
File: /home/joels/Current/lispbm/src/eval_cps.c
Date: 2024-08-06 17:32:21
Exec Total Coverage
Lines: 2534 3146 80.5%
Functions: 176 209 84.2%
Branches: 768 1287 59.7%
Line Branch Exec Source
1 /*
2 Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
3
4 This program is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 3 of the License, or
7 (at your option) any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program. If not, see <http://www.gnu.org/licenses/>.
16 */
17
18 #include <lbm_memory.h>
19 #include <lbm_types.h>
20 #include "symrepr.h"
21 #include "heap.h"
22 #include "env.h"
23 #include "eval_cps.h"
24 #include "stack.h"
25 #include "fundamental.h"
26 #include "extensions.h"
27 #include "tokpar.h"
28 #include "lbm_channel.h"
29 #include "print.h"
30 #include "platform_mutex.h"
31 #include "lbm_flat_value.h"
32 #include "lbm_flags.h"
33
34 #ifdef VISUALIZE_HEAP
35 #include "heap_vis.h"
36 #endif
37
38 #include <setjmp.h>
39 #include <stdarg.h>
40
41 static jmp_buf error_jmp_buf;
42 static jmp_buf critical_error_jmp_buf;
43
44 #define S_TO_US(X) (lbm_uint)((X) * 1000000)
45
46 #define DEC_CONTINUATION(x) (((x) & ~LBM_CONTINUATION_INTERNAL) >> LBM_ADDRESS_SHIFT)
47 #define IS_CONTINUATION(x) (((x) & LBM_CONTINUATION_INTERNAL) == LBM_CONTINUATION_INTERNAL)
48 #define CONTINUATION(x) (((x) << LBM_ADDRESS_SHIFT) | LBM_CONTINUATION_INTERNAL)
49
50 #define DONE CONTINUATION(0)
51 #define SET_GLOBAL_ENV CONTINUATION(1)
52 #define BIND_TO_KEY_REST CONTINUATION(2)
53 #define IF CONTINUATION(3)
54 #define PROGN_REST CONTINUATION(4)
55 #define APPLICATION_ARGS CONTINUATION(5)
56 #define AND CONTINUATION(6)
57 #define OR CONTINUATION(7)
58 #define WAIT CONTINUATION(8)
59 #define MATCH CONTINUATION(9)
60 #define APPLICATION_START CONTINUATION(10)
61 #define EVAL_R CONTINUATION(11)
62 #define RESUME CONTINUATION(12)
63 #define CLOSURE_ARGS CONTINUATION(13)
64 #define EXIT_ATOMIC CONTINUATION(14)
65 #define READ_NEXT_TOKEN CONTINUATION(15)
66 #define READ_APPEND_CONTINUE CONTINUATION(16)
67 #define READ_EVAL_CONTINUE CONTINUATION(17)
68 #define READ_EXPECT_CLOSEPAR CONTINUATION(18)
69 #define READ_DOT_TERMINATE CONTINUATION(19)
70 #define READ_DONE CONTINUATION(20)
71 #define READ_QUOTE_RESULT CONTINUATION(21)
72 #define READ_COMMAAT_RESULT CONTINUATION(22)
73 #define READ_COMMA_RESULT CONTINUATION(23)
74 #define READ_START_ARRAY CONTINUATION(24)
75 #define READ_APPEND_ARRAY CONTINUATION(25)
76 #define MAP CONTINUATION(26)
77 #define MATCH_GUARD CONTINUATION(27)
78 #define TERMINATE CONTINUATION(28)
79 #define PROGN_VAR CONTINUATION(29)
80 #define SETQ CONTINUATION(30)
81 #define MOVE_TO_FLASH CONTINUATION(31)
82 #define MOVE_VAL_TO_FLASH_DISPATCH CONTINUATION(32)
83 #define MOVE_LIST_TO_FLASH CONTINUATION(33)
84 #define CLOSE_LIST_IN_FLASH CONTINUATION(34)
85 #define QQ_EXPAND_START CONTINUATION(35)
86 #define QQ_EXPAND CONTINUATION(36)
87 #define QQ_APPEND CONTINUATION(37)
88 #define QQ_EXPAND_LIST CONTINUATION(38)
89 #define QQ_LIST CONTINUATION(39)
90 #define KILL CONTINUATION(40)
91 #define LOOP CONTINUATION(41)
92 #define LOOP_CONDITION CONTINUATION(42)
93 #define MERGE_REST CONTINUATION(43)
94 #define MERGE_LAYER CONTINUATION(44)
95 #define CLOSURE_ARGS_REST CONTINUATION(45)
96 #define MOVE_ARRAY_ELTS_TO_FLASH CONTINUATION(46)
97 #define POP_READER_FLAGS CONTINUATION(47)
98 #define EXCEPTION_HANDLER CONTINUATION(48)
99 #define NUM_CONTINUATIONS 49
100
101 #define FM_NEED_GC -1
102 #define FM_NO_MATCH -2
103 #define FM_PATTERN_ERROR -3
104
105 typedef enum {
106 BL_OK = 0,
107 BL_NO_MEMORY,
108 BL_INCORRECT_KEY
109 } binding_location_status;
110
111 #define FB_OK 0
112 #define FB_TYPE_ERROR -1
113
114 const char* lbm_error_str_parse_eof = "End of parse stream.";
115 const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
116 const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
117 const char* lbm_error_str_num_args = "Incorrect number of arguments.";
118 const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
119 const char* lbm_error_str_no_number = "Argument(s) must be a number.";
120 const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
121 const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
122 const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
123 const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
124 const char* lbm_error_str_flash_error = "Error writing to flash.";
125 const char* lbm_error_str_flash_full = "Flash memory is full.";
126 const char* lbm_error_str_variable_not_bound = "Variable not bound.";
127
128 static lbm_value lbm_error_suspect;
129 static bool lbm_error_has_suspect = false;
130 #ifdef LBM_ALWAYS_GC
131
132 #define WITH_GC(y, x) \
133 gc(); \
134 (y) = (x); \
135 if (lbm_is_symbol_merror((y))) { \
136 error_ctx(ENC_SYM_MERROR); \
137 }
138
139 #define WITH_GC_RMBR_1(y, x, r) \
140 lbm_gc_mark_phase(r); \
141 gc(); \
142 (y) = (x); \
143 if (lbm_is_symbol_merror((y))) { \
144 error_ctx(ENC_SYM_MERROR); \
145 }
146
147 #else
148
149 #define WITH_GC(y, x) \
150 (y) = (x); \
151 if (lbm_is_symbol_merror((y))) { \
152 gc(); \
153 (y) = (x); \
154 if (lbm_is_symbol_merror((y))) { \
155 error_ctx(ENC_SYM_MERROR); \
156 } \
157 /* continue executing statements below */ \
158 }
159 #define WITH_GC_RMBR_1(y, x, r) \
160 (y) = (x); \
161 if (lbm_is_symbol_merror((y))) { \
162 lbm_gc_mark_phase(r); \
163 gc(); \
164 (y) = (x); \
165 if (lbm_is_symbol_merror((y))) { \
166 error_ctx(ENC_SYM_MERROR); \
167 } \
168 /* continue executing statements below */ \
169 }
170
171 #endif
172
173 typedef struct {
174 eval_context_t *first;
175 eval_context_t *last;
176 } eval_context_queue_t;
177
178 #ifdef CLEAN_UP_CLOSURES
179 static lbm_value clean_cl_env_symbol = ENC_SYM_NIL;
180 #endif
181
182 static int gc(void);
183 static void error_ctx(lbm_value);
184 static void error_at_ctx(lbm_value err_val, lbm_value at);
185 static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
186 static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
187
188 // The currently executing context.
189 eval_context_t *ctx_running = NULL;
190 volatile bool lbm_system_sleeping = false;
191
192 static volatile bool gc_requested = false;
193 2936 void lbm_request_gc(void) {
194 2936 gc_requested = true;
195 2936 }
196
197 /*
198 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
199 resolution of the timer used for sleep operations. If this is set
200 to 10KHz the resolution is 100us.
201
202 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
203 can be safely specified in a timeout directive (wonder if that
204 means sleep-period). The timedelta is set to 2.
205
206 If I have understood these correctly it means that the minimum
207 sleep duration possible is 2 * 100us = 200us.
208 */
209
210 #define EVAL_CPS_DEFAULT_STACK_SIZE 256
211 #define EVAL_CPS_MIN_SLEEP 200
212 #define EVAL_STEPS_QUOTA 10
213
214 static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA;
215 static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA;
216
217 ✗ void lbm_set_eval_step_quota(uint32_t quota) {
218 ✗ eval_steps_refill = quota;
219 ✗ }
220
221 static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD;
222 static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE;
223 static volatile uint32_t eval_cps_next_state_arg = 0;
224 static volatile bool eval_cps_state_changed = false;
225
226 ✗ static void usleep_nonsense(uint32_t us) {
227 (void) us;
228 ✗ }
229
230 ✗ static bool dynamic_load_nonsense(const char *sym, const char **code) {
231 (void) sym;
232 (void) code;
233 ✗ return false;
234 }
235
236 ✗ static uint32_t timestamp_nonsense(void) {
237 ✗ return 0;
238 }
239
240 ✗ static int printf_nonsense(const char *fmt, ...) {
241 (void) fmt;
242 ✗ return 0;
243 }
244
245 ✗ static void ctx_done_nonsense(eval_context_t *ctx) {
246 (void) ctx;
247 ✗ }
248
249 ✗ static void critical_nonsense(void) {
250 ✗ return;
251 }
252
253 static void (*critical_error_callback)(void) = critical_nonsense;
254 static void (*usleep_callback)(uint32_t) = usleep_nonsense;
255 static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
256 static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
257 static int (*printf_callback)(const char *, ...) = printf_nonsense;
258 static bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
259
260 ✗ void lbm_set_critical_error_callback(void (*fptr)(void)) {
261 ✗ if (fptr == NULL) critical_error_callback = critical_nonsense;
262 ✗ else critical_error_callback = fptr;
263 ✗ }
264
265 17444 void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
266
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 17444 times.
 17444 if (fptr == NULL) usleep_callback = usleep_nonsense;
267 17444 else usleep_callback = fptr;
268 17444 }
269
270 17444 void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
271
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 17444 times.
 17444 if (fptr == NULL) timestamp_us_callback = timestamp_nonsense;
272 17444 else timestamp_us_callback = fptr;
273 17444 }
274
275 17444 void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
276
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 17444 times.
 17444 if (fptr == NULL) ctx_done_callback = ctx_done_nonsense;
277 17444 else ctx_done_callback = fptr;
278 17444 }
279
280 17444 void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
281
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 17444 times.
 17444 if (fptr == NULL) printf_callback = printf_nonsense;
282 17444 else printf_callback = fptr;
283 17444 }
284
285 17444 void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char **)) {
286
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 17444 times.
 17444 if (fptr == NULL) dynamic_load_callback = dynamic_load_nonsense;
287 17444 else dynamic_load_callback = fptr;
288 17444 }
289
290 static volatile lbm_event_t *lbm_events = NULL;
291 static unsigned int lbm_events_head = 0;
292 static unsigned int lbm_events_tail = 0;
293 static unsigned int lbm_events_max = 0;
294 static bool lbm_events_full = false;
295 static mutex_t lbm_events_mutex;
296 static bool lbm_events_mutex_initialized = false;
297 static volatile lbm_cid lbm_event_handler_pid = -1;
298
299 ✗ lbm_cid lbm_get_event_handler_pid(void) {
300 ✗ return lbm_event_handler_pid;
301 }
302
303 224 void lbm_set_event_handler_pid(lbm_cid pid) {
304 224 lbm_event_handler_pid = pid;
305 224 }
306
307 ✗ bool lbm_event_handler_exists(void) {
308 ✗ return(lbm_event_handler_pid > 0);
309 }
310
311
312 8066 static bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
313 8066 bool r = false;
314
1/2
✓ Branch 0 taken 8066 times.
✗ Branch 1 not taken.
 8066 if (lbm_events) {
315 8066 mutex_lock(&lbm_events_mutex);
316
1/2
✓ Branch 0 taken 8066 times.
✗ Branch 1 not taken.
 8066 if (!lbm_events_full) {
317 lbm_event_t event;
318 8066 event.type = event_type;
319 8066 event.parameter = parameter;
320 8066 event.buf_ptr = buf_ptr;
321 8066 event.buf_len = buf_len;
322 8066 lbm_events[lbm_events_head] = event;
323 8066 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
324 8066 lbm_events_full = lbm_events_head == lbm_events_tail;
325 8066 r = true;
326 }
327 8066 mutex_unlock(&lbm_events_mutex);
328 }
329 8066 return r;
330 }
331
332 ✗ bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
333 ✗ return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
334 }
335
336 ✗ bool lbm_event_unboxed(lbm_value unboxed) {
337 ✗ lbm_uint t = lbm_type_of(unboxed);
338 ✗ if (t == LBM_TYPE_SYMBOL ||
339 ✗ t == LBM_TYPE_I ||
340 ✗ t == LBM_TYPE_U ||
341 t == LBM_TYPE_CHAR) {
342 ✗ if (lbm_event_handler_pid > 0) {
343 ✗ return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
344 }
345 }
346 ✗ return false;
347 }
348
349 8010 bool lbm_event(lbm_flat_value_t *fv) {
350
1/2
✓ Branch 0 taken 8010 times.
✗ Branch 1 not taken.
 8010 if (lbm_event_handler_pid > 0) {
351 8010 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
352 }
353 ✗ return false;
354 }
355
356 397130833 static bool lbm_event_pop(lbm_event_t *event) {
357 397130833 mutex_lock(&lbm_events_mutex);
358
3/4
✓ Branch 0 taken 397122776 times.
✓ Branch 1 taken 8057 times.
✓ Branch 2 taken 397122776 times.
✗ Branch 3 not taken.
 397130833 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
359 397122776 mutex_unlock(&lbm_events_mutex);
360 397122776 return false;
361 }
362 8057 *event = lbm_events[lbm_events_tail];
363 8057 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
364 8057 lbm_events_full = false;
365 8057 mutex_unlock(&lbm_events_mutex);
366 8057 return true;
367 }
368
369 ✗ bool lbm_event_queue_is_empty(void) {
370 ✗ mutex_lock(&lbm_events_mutex);
371 ✗ bool empty = false;
372 ✗ if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
373 ✗ empty = true;
374 }
375 ✗ mutex_unlock(&lbm_events_mutex);
376 ✗ return empty;
377 }
378
379 static bool eval_running = false;
380 static volatile bool blocking_extension = false;
381 static mutex_t blocking_extension_mutex;
382 static bool blocking_extension_mutex_initialized = false;
383 static lbm_uint blocking_extension_timeout_us = 0;
384 static bool blocking_extension_timeout = false;
385
386 static uint32_t is_atomic = 0;
387
388 /* Process queues */
389 static eval_context_queue_t blocked = {NULL, NULL};
390 static eval_context_queue_t queue = {NULL, NULL};
391
392 /* one mutex for all queue operations */
393 mutex_t qmutex;
394 bool qmutex_initialized = false;
395
396
397 // MODES
398 static volatile bool lbm_verbose = false;
399
400 ✗ void lbm_toggle_verbose(void) {
401 ✗ lbm_verbose = !lbm_verbose;
402 ✗ }
403
404 17444 void lbm_set_verbose(bool verbose) {
405 17444 lbm_verbose = verbose;
406 17444 }
407
408 784 lbm_cid lbm_get_current_cid(void) {
409
1/2
✓ Branch 0 taken 784 times.
✗ Branch 1 not taken.
 784 if (ctx_running)
410 784 return ctx_running->id;
411 else
412 ✗ return -1;
413 }
414
415 ✗ eval_context_t *lbm_get_current_context(void) {
416 ✗ return ctx_running;
417 }
418
419 /****************************************************/
420 /* Utilities used locally in this file */
421
422 915824 static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
423 #ifdef LBM_ALWAYS_GC
424 lbm_value roots[3] = {head, tail, remember};
425 lbm_gc_mark_roots(roots, 3);
426 gc();
427 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
428 res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
429 if (lbm_is_symbol_merror(res)) {
430 error_ctx(ENC_SYM_MERROR);
431 }
432 return res;
433 #else
434 915824 lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
435
2/2
✓ Branch 1 taken 8 times.
✓ Branch 2 taken 915816 times.
 915824 if (lbm_is_symbol_merror(res)) {
436 8 lbm_value roots[3] = {head, tail, remember};
437 8 lbm_gc_mark_roots(roots,3);
438 8 gc();
439 8 res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
440
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 8 times.
 8 if (lbm_is_symbol_merror(res)) {
441 ✗ error_ctx(ENC_SYM_MERROR);
442 }
443 }
444 915824 return res;
445 #endif
446 }
447
448 1945306822 static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
449
1/2
✓ Branch 0 taken 1945306822 times.
✗ Branch 1 not taken.
 1945306822 if (n <= ctx->K.sp) {
450 1945306822 lbm_uint index = ctx->K.sp - n;
451 1945306822 return &ctx->K.data[index];
452 }
453 ✗ error_ctx(ENC_SYM_STACK_ERROR);
454 ✗ return 0; // dead code cannot be reached, but C compiler doesn't realise.
455 }
456
457 // pop_stack_ptr is safe when no GC is performed and
458 // the values of the stack will be dropped.
459 74916068 static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
460
1/2
✓ Branch 0 taken 74916068 times.
✗ Branch 1 not taken.
 74916068 if (n <= ctx->K.sp) {
461 74916068 ctx->K.sp -= n;
462 74916068 return &ctx->K.data[ctx->K.sp];
463 }
464 ✗ error_ctx(ENC_SYM_STACK_ERROR);
465 ✗ return 0; // dead code cannot be reached, but C compiler doesn't realise.
466 }
467
468 2056905540 static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
469
1/2
✓ Branch 0 taken 2056905540 times.
✗ Branch 1 not taken.
 2056905540 if (ctx->K.sp + n < ctx->K.size) {
470 2056905540 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
471 2056905540 ctx->K.sp += n;
472 2056905540 return ptr;
473 }
474 ✗ error_ctx(ENC_SYM_STACK_ERROR);
475 ✗ return 0; // dead code cannot be reached, but C compiler doesn't realise.
476 }
477
478 6832 static void handle_flash_status(lbm_flash_status s) {
479
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6832 times.
 6832 if ( s == LBM_FLASH_FULL) {
480 ✗ lbm_set_error_reason((char*)lbm_error_str_flash_full);
481 ✗ error_ctx(ENC_SYM_EERROR);
482 }
483
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6832 times.
 6832 if (s == LBM_FLASH_WRITE_ERROR) {
484 ✗ lbm_set_error_reason((char*)lbm_error_str_flash_error);
485 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
486 }
487 6832 }
488
489 28 static void lift_array_flash(lbm_value flash_cell, bool bytearray, char *data, lbm_uint num_elt) {
490
491 lbm_array_header_t flash_array_header;
492 28 flash_array_header.size = num_elt;
493 28 flash_array_header.data = (lbm_uint*)data;
494 lbm_uint flash_array_header_ptr;
495 28 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
496 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
497 &flash_array_header_ptr));
498 28 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
499
1/2
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
 28 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE : ENC_SYM_LISPARRAY_TYPE;
500 28 handle_flash_status(write_const_cdr(flash_cell, t));
501 28 }
502
503 886135051 static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
504
2/2
✓ Branch 1 taken 886100331 times.
✓ Branch 2 taken 34720 times.
 886135051 if (lbm_is_ptr(a)) {
505 886100331 lbm_cons_t *cell = lbm_ref_cell(a);
506 886100331 *a_car = cell->car;
507 886100331 *a_cdr = cell->cdr;
508
1/2
✓ Branch 1 taken 34720 times.
✗ Branch 2 not taken.
 34720 } else if (lbm_is_symbol_nil(a)) {
509 34720 *a_car = *a_cdr = ENC_SYM_NIL;
510 } else {
511 ✗ error_ctx(ENC_SYM_TERROR);
512 }
513 886135051 }
514
515 /* car cdr caar cadr replacements that are evaluator safe. */
516 828236453 static lbm_value get_car(lbm_value a) {
517
1/2
✓ Branch 1 taken 828236453 times.
✗ Branch 2 not taken.
 828236453 if (lbm_is_ptr(a)) {
518 828236453 lbm_cons_t *cell = lbm_ref_cell(a);
519 828236453 return cell->car;
520 ✗ } else if (lbm_is_symbol_nil(a)) {
521 ✗ return a;
522 }
523 ✗ error_ctx(ENC_SYM_TERROR);
524 ✗ return(ENC_SYM_TERROR);
525 }
526
527 711050586 static lbm_value get_cdr(lbm_value a) {
528
1/2
✓ Branch 1 taken 711050586 times.
✗ Branch 2 not taken.
 711050586 if (lbm_is_ptr(a)) {
529 711050586 lbm_cons_t *cell = lbm_ref_cell(a);
530 711050586 return cell->cdr;
531 ✗ } else if (lbm_is_symbol_nil(a)) {
532 ✗ return a;
533 }
534 ✗ error_ctx(ENC_SYM_TERROR);
535 ✗ return(ENC_SYM_TERROR);
536 }
537
538 108169479 static lbm_value get_cadr(lbm_value a) {
539
1/2
✓ Branch 1 taken 108169479 times.
✗ Branch 2 not taken.
 108169479 if (lbm_is_ptr(a)) {
540 108169479 lbm_cons_t *cell = lbm_ref_cell(a);
541 108169479 lbm_value tmp = cell->cdr;
542
2/2
✓ Branch 1 taken 108159315 times.
✓ Branch 2 taken 10164 times.
 108169479 if (lbm_is_ptr(tmp)) {
543 108159315 return lbm_ref_cell(tmp)->car;
544
1/2
✓ Branch 1 taken 10164 times.
✗ Branch 2 not taken.
 10164 } else if (lbm_is_symbol_nil(tmp)) {
545 10164 return tmp;
546 }
547 ✗ } else if (lbm_is_symbol_nil(a)) {
548 ✗ return a;
549 }
550 ✗ error_ctx(ENC_SYM_TERROR);
551 ✗ return(ENC_SYM_TERROR);
552 }
553
554 10612 static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
555
556 #ifdef LBM_ALWAYS_GC
557 gc();
558 if (lbm_heap_num_free() < 4) {
559 error_ctx(ENC_SYM_MERROR);
560 }
561 #else
562
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 10612 times.
 10612 if (lbm_heap_num_free() < 4) {
563 ✗ gc();
564 ✗ if (lbm_heap_num_free() < 4) {
565 ✗ error_ctx(ENC_SYM_MERROR);
566 }
567 }
568 #endif
569 // The freelist will always contain just plain heap-cells.
570 // So dec_ptr is sufficient.
571 10612 lbm_value res = lbm_heap_state.freelist;
572
1/2
✓ Branch 1 taken 10612 times.
✗ Branch 2 not taken.
 10612 if (lbm_type_of(res) == LBM_TYPE_CONS) {
573 10612 lbm_cons_t *heap = lbm_heap_state.heap;
574 10612 lbm_uint ix = lbm_dec_ptr(res);
575 10612 heap[ix].car = ENC_SYM_CLOSURE;
576 10612 ix = lbm_dec_ptr(heap[ix].cdr);
577 10612 heap[ix].car = params;
578 10612 ix = lbm_dec_ptr(heap[ix].cdr);
579 10612 heap[ix].car = body;
580 10612 ix = lbm_dec_ptr(heap[ix].cdr);
581 10612 heap[ix].car = env;
582 10612 lbm_heap_state.freelist = heap[ix].cdr;
583 10612 heap[ix].cdr = ENC_SYM_NIL;
584 10612 lbm_heap_state.num_alloc+=4;
585 } else {
586 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
587 }
588 10612 return res;
589 }
590
591 // Allocate a binding and attach it to a list (if so desired)
592 222072076 static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
593
2/2
✓ Branch 1 taken 158144 times.
✓ Branch 2 taken 221913932 times.
 222072076 if (lbm_heap_num_free() < 2) {
594 158144 lbm_gc_mark_phase(key);
595 158144 lbm_gc_mark_phase(val);
596 158144 lbm_gc_mark_phase(the_cdr);
597 158144 gc();
598
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 158144 times.
 158144 if (lbm_heap_num_free() < 2) {
599 ✗ error_ctx(ENC_SYM_MERROR);
600 }
601 }
602 222072076 lbm_cons_t* heap = lbm_heap_state.heap;
603 222072076 lbm_value binding_cell = lbm_heap_state.freelist;
604 222072076 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
605 222072076 lbm_value list_cell = heap[binding_cell_ix].cdr;
606 222072076 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
607 222072076 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
608 222072076 lbm_heap_state.num_alloc += 2;
609 222072076 heap[binding_cell_ix].car = key;
610 222072076 heap[binding_cell_ix].cdr = val;
611 222072076 heap[list_cell_ix].car = binding_cell;
612 222072076 heap[list_cell_ix].cdr = the_cdr;
613 222072076 return list_cell;
614 }
615
616 #define CLO_PARAMS 0
617 #define CLO_BODY 1
618 #define CLO_ENV 2
619 #define LOOP_BINDS 0
620 #define LOOP_COND 1
621 #define LOOP_BODY 2
622
623 // (a b c) -> [a b c]
624 471755817 static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
625
2/2
✓ Branch 0 taken 1180002239 times.
✓ Branch 1 taken 471755817 times.
 1651758056 for (unsigned int i = 0; i < n; i ++) {
626
2/2
✓ Branch 1 taken 1180002211 times.
✓ Branch 2 taken 28 times.
 1180002239 if (lbm_is_ptr(curr)) {
627 1180002211 lbm_cons_t *cell = lbm_ref_cell(curr);
628 1180002211 res[i] = cell->car;
629 1180002211 curr = cell->cdr;
630 } else {
631 28 res[i] = ENC_SYM_NIL;
632 }
633 }
634 471755817 return curr; // Rest of list is returned here.
635 }
636
637 206159656 static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
638 lbm_value res;
639 206159656 res = fundamental_table[fundamental](args, arg_count, ctx);
640
2/2
✓ Branch 1 taken 209131 times.
✓ Branch 2 taken 205950525 times.
 206159656 if (lbm_is_error(res)) {
641
2/2
✓ Branch 1 taken 208879 times.
✓ Branch 2 taken 252 times.
 209131 if (lbm_is_symbol_merror(res)) {
642 208879 gc();
643 208879 res = fundamental_table[fundamental](args, arg_count, ctx);
644 }
645
2/2
✓ Branch 1 taken 288 times.
✓ Branch 2 taken 208843 times.
 209131 if (lbm_is_error(res)) {
646 288 error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START | fundamental));
647 }
648 }
649 206159368 lbm_stack_drop(&ctx->K, arg_count+1);
650 206159368 ctx->app_cont = true;
651 206159368 ctx->r = res;
652 206159368 }
653
654 // block_current_ctx blocks a context until it is
655 // woken up externally or a timeout period of time passes.
656 3028 static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool do_cont) {
657 3028 ctx_running->timestamp = timestamp_us_callback();
658 3028 ctx_running->sleep_us = sleep_us;
659 3028 ctx_running->state = state;
660 3028 ctx_running->app_cont = do_cont;
661 3028 enqueue_ctx(&blocked, ctx_running);
662 3028 ctx_running = NULL;
663 3028 }
664
665 28 lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
666 28 lbm_uint full_words = n / sizeof(lbm_uint);
667 28 lbm_uint n_mod = n % sizeof(lbm_uint);
668
669
1/2
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
 28 if (n_mod == 0) { // perfect fit.
670 28 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
671 } else {
672 ✗ lbm_uint last_word = 0;
673 ✗ memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
674 ✗ if (full_words >= 1) {
675 ✗ lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
676 ✗ if ( s == LBM_FLASH_WRITE_OK) {
677 lbm_uint dummy;
678 ✗ s = lbm_write_const_raw(&last_word, 1, &dummy);
679 }
680 ✗ return s;
681 } else {
682 ✗ return lbm_write_const_raw(&last_word, 1, res);
683 }
684 }
685 }
686
687 /****************************************************/
688 /* Error message creation */
689
690 #define ERROR_MESSAGE_BUFFER_SIZE_BYTES 256
691
692 8 void print_environments(char *buf, unsigned int size) {
693
694 8 lbm_value curr_l = ctx_running->curr_env;
695 8 printf_callback("\tCurrent local environment:\n");
696
2/2
✓ Branch 1 taken 4 times.
✓ Branch 2 taken 8 times.
 12 while (lbm_type_of(curr_l) == LBM_TYPE_CONS) {
697 4 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
698 4 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
699 4 printf_callback("\t%s = %s\n", buf, buf+(size/2));
700 4 curr_l = lbm_cdr(curr_l);
701 }
702 8 printf_callback("\n\n");
703 8 printf_callback("\tCurrent global environment:\n");
704 8 lbm_value *glob_env = lbm_get_global_env();
705
706
2/2
✓ Branch 0 taken 256 times.
✓ Branch 1 taken 8 times.
 264 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
707 256 lbm_value curr_g = glob_env[i];;
708
2/2
✓ Branch 1 taken 8 times.
✓ Branch 2 taken 256 times.
 264 while (lbm_type_of(curr_g) == LBM_TYPE_CONS) {
709
710 8 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
711 8 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
712 8 printf_callback("\t%s = %s\n", buf, buf+(size/2));
713 8 curr_g = lbm_cdr(curr_g);
714 }
715 }
716 8 }
717
718 8 void print_error_message(lbm_value error, bool has_at, lbm_value at, unsigned int row, unsigned int col, lbm_int row0, lbm_int row1) {
719
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (!printf_callback) return;
720
721 /* try to allocate a lbm_print_value buffer on the lbm_memory */
722 8 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES);
723
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (!buf) {
724 ✗ printf_callback("Error: Not enough free memory to create a human readable error message\n");
725 ✗ return;
726 }
727
728 8 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, error);
729 8 printf_callback( "*** Error: %s\n", buf);
730
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (has_at) {
731 8 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, at);
732 8 printf_callback("*** In: %s\n",buf);
733
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (lbm_error_has_suspect) {
734 ✗ lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, lbm_error_suspect);
735 ✗ lbm_error_has_suspect = false;
736 ✗ printf_callback("*** At: %s\n", buf);
737 } else {
738 8 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp);
739 8 printf_callback("*** After: %s\n",buf);
740 }
741 } else {
742 ✗ lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp);
743 ✗ printf_callback("*** Near: %s\n",buf);
744 }
745
746 8 printf_callback("\n");
747
748
2/4
✓ Branch 1 taken 8 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
✓ Branch 4 taken 8 times.
 8 if (lbm_is_symbol(error) &&
749 error == ENC_SYM_RERROR) {
750 ✗ printf_callback("*** Line: %u\n", row);
751 ✗ printf_callback("*** Column: %u\n", col);
752
2/4
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 8 times.
 8 } else if (row0 != -1 || row1 != -1 ) {
753 ✗ printf_callback("*** Between rows: (-1 unknown) \n");
754 ✗ printf_callback("*** Start: %d\n", (int32_t)row0);
755 ✗ printf_callback("*** End: %d\n", (int32_t)row1);
756 }
757
758 8 printf_callback("\n");
759
760
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (ctx_running->error_reason) {
761 ✗ printf_callback("Reason:\n %s\n\n", ctx_running->error_reason);
762 }
763
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (lbm_verbose) {
764 8 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp);
765 8 printf_callback(" In context: %d\n", ctx_running->id);
766 8 printf_callback(" Current intermediate result: %s\n\n", buf);
767
768 8 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES);
769 8 printf_callback("\n\n");
770
771 8 printf_callback(" Stack:\n");
772
2/2
✓ Branch 0 taken 172 times.
✓ Branch 1 taken 8 times.
 180 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
773 172 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]);
774 172 printf_callback(" %s\n", buf);
775 }
776 }
777 8 lbm_free(buf);
778 }
779
780 /****************************************************/
781 /* Tokenizing and parsing */
782
783 17438 bool create_string_channel(char *str, lbm_value *res) {
784
785 17438 lbm_char_channel_t *chan = NULL;
786 17438 lbm_string_channel_state_t *st = NULL;
787
788 17438 st = (lbm_string_channel_state_t*)lbm_memory_allocate(sizeof(lbm_string_channel_state_t) / sizeof(lbm_uint) +1);
789
2/2
✓ Branch 0 taken 10 times.
✓ Branch 1 taken 17428 times.
 17438 if (st == NULL) {
790 10 return false;
791 }
792 17428 chan = (lbm_char_channel_t*)lbm_memory_allocate(sizeof(lbm_char_channel_t) / sizeof(lbm_uint) + 1);
793
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 17260 times.
 17428 if (chan == NULL) {
794 168 lbm_memory_free((lbm_uint*)st);
795 168 return false;
796 }
797
798 17260 lbm_create_string_char_channel(st, chan, str);
799 17260 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
800
2/2
✓ Branch 1 taken 12 times.
✓ Branch 2 taken 17248 times.
 17260 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) {
801 12 lbm_memory_free((lbm_uint*)st);
802 12 lbm_memory_free((lbm_uint*)chan);
803 12 return false;
804 }
805
806 17248 *res = cell;
807 17248 return true;
808 }
809
810 17444 bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
811 17444 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
812
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 17444 times.
 17444 if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) {
813 ✗ return false;
814 }
815 17444 *res = cell;
816 17444 return true;
817 }
818
819
820 /****************************************************/
821 /* Queue functions */
822
823 2115690 static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
824 eval_context_t *curr;
825 2115690 curr = q->first;
826
827
2/2
✓ Branch 0 taken 3452 times.
✓ Branch 1 taken 2115690 times.
 2119142 while (curr != NULL) {
828 3452 f(curr, arg1, arg2);
829 3452 curr = curr->next;
830 }
831 2115690 }
832
833 28 void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
834 28 mutex_lock(&qmutex);
835 28 queue_iterator_nm(&queue, f, arg1, arg2);
836 28 mutex_unlock(&qmutex);
837 28 }
838
839 28 void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
840 28 mutex_lock(&qmutex);
841 28 queue_iterator_nm(&blocked, f, arg1, arg2);
842 28 mutex_unlock(&qmutex);
843 28 }
844
845 395898744 static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
846
2/2
✓ Branch 0 taken 395878007 times.
✓ Branch 1 taken 20737 times.
 395898744 if (q->last == NULL) {
847 395878007 ctx->prev = NULL;
848 395878007 ctx->next = NULL;
849 395878007 q->first = ctx;
850 395878007 q->last = ctx;
851 } else {
852 20737 ctx->prev = q->last;
853 20737 ctx->next = NULL;
854 20737 q->last->next = ctx;
855 20737 q->last = ctx;
856 }
857 395898744 }
858
859 50377 static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
860 50377 mutex_lock(&qmutex);
861 50377 enqueue_ctx_nm(q,ctx);
862 50377 mutex_unlock(&qmutex);
863 50377 }
864
865 20226 static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
866 eval_context_t *curr;
867 20226 curr = q->first;
868
2/2
✓ Branch 0 taken 3976 times.
✓ Branch 1 taken 16250 times.
 20226 while (curr != NULL) {
869
1/2
✓ Branch 0 taken 3976 times.
✗ Branch 1 not taken.
 3976 if (curr->id == cid) {
870 3976 return curr;
871 }
872 ✗ curr = curr->next;
873 }
874 16250 return NULL;
875 }
876
877 2944 static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
878
879 2944 bool res = false;
880
2/4
✓ Branch 0 taken 2944 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 2944 times.
 2944 if (q->first == NULL || q->last == NULL) {
881 ✗ if (!(q->last == NULL && q->first == NULL)) {
882 /* error state that should not happen */
883 ✗ return res;
884 }
885 /* Queue is empty */
886 ✗ return res;
887 }
888
889 2944 eval_context_t *curr = q->first;
890
1/2
✓ Branch 0 taken 2944 times.
✗ Branch 1 not taken.
 2944 while (curr) {
891
1/2
✓ Branch 0 taken 2944 times.
✗ Branch 1 not taken.
 2944 if (curr->id == ctx->id) {
892 2944 res = true;
893 2944 eval_context_t *tmp = curr->next;
894
1/2
✓ Branch 0 taken 2944 times.
✗ Branch 1 not taken.
 2944 if (curr->prev == NULL) {
895
2/2
✓ Branch 0 taken 2916 times.
✓ Branch 1 taken 28 times.
 2944 if (curr->next == NULL) {
896 2916 q->last = NULL;
897 2916 q->first = NULL;
898 } else {
899 28 q->first = tmp;
900 28 tmp->prev = NULL;
901 }
902 } else { /* curr->prev != NULL */
903 ✗ if (curr->next == NULL) {
904 ✗ q->last = curr->prev;
905 ✗ q->last->next = NULL;
906 } else {
907 ✗ curr->prev->next = tmp;
908 ✗ tmp->prev = curr->prev;
909 }
910 }
911 2944 break;
912 }
913 ✗ curr = curr->next;
914 }
915 2944 return res;
916 }
917
918 /* End execution of the running context. */
919 18019 static void finish_ctx(void) {
920
921
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18019 times.
 18019 if (!ctx_running) {
922 ✗ return;
923 }
924 /* Drop the continuation stack immediately to free up lbm_memory */
925 18019 lbm_stack_free(&ctx_running->K);
926 18019 ctx_done_callback(ctx_running);
927
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 18019 times.
 18019 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
928 ✗ lbm_free(ctx_running->name);
929 }
930
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 18019 times.
 18019 if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
931 ✗ lbm_memory_free((lbm_uint*)ctx_running->error_reason);
932 }
933 18019 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
934 18019 lbm_memory_free((lbm_uint*)ctx_running);
935 18019 ctx_running = NULL;
936 }
937
938 ✗ static void context_exists(eval_context_t *ctx, void *cid, void *b) {
939 ✗ if (ctx->id == *(lbm_cid*)cid) {
940 ✗ *(bool*)b = true;
941 }
942 ✗ }
943
944 ✗ bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
945
946 bool exists;
947 ✗ uint32_t i = 0;
948
949 do {
950 ✗ exists = false;
951 ✗ lbm_blocked_iterator(context_exists, &cid, &exists);
952 ✗ lbm_running_iterator(context_exists, &cid, &exists);
953
954 ✗ if (ctx_running &&
955 ✗ ctx_running->id == cid) {
956 ✗ exists = true;
957 }
958
959 ✗ if (exists) {
960 ✗ if (usleep_callback) {
961 ✗ usleep_callback(1000);
962 }
963 ✗ if (timeout_ms > 0) i ++;
964 }
965 ✗ } while (exists && i < timeout_ms);
966
967 ✗ if (exists) return false;
968 ✗ return true;
969 }
970
971 84 void lbm_set_error_suspect(lbm_value suspect) {
972 84 lbm_error_suspect = suspect;
973 84 lbm_error_has_suspect = true;
974 84 }
975
976 28 void lbm_set_error_reason(char *error_str) {
977
1/2
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
 28 if (ctx_running != NULL) {
978 28 ctx_running->error_reason = error_str;
979 }
980 28 }
981
982 // Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
983 372 static void error_ctx_base(lbm_value err_val, bool has_at, lbm_value at, unsigned int row, unsigned int column) {
984
985
2/2
✓ Branch 0 taken 196 times.
✓ Branch 1 taken 176 times.
 372 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
986
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 196 times.
 196 if (lbm_heap_num_free() < 3) {
987 ✗ gc();
988 }
989
990
1/2
✓ Branch 1 taken 196 times.
✗ Branch 2 not taken.
 196 if (lbm_heap_num_free() >= 3) {
991 196 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL);
992 196 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
993 196 msg = lbm_cons(ENC_SYM_EXIT_ERROR, msg);
994
1/2
✓ Branch 1 taken 196 times.
✗ Branch 2 not taken.
 196 if (!lbm_is_symbol_merror(msg)) {
995 196 lbm_find_receiver_and_send(ctx_running->parent, msg);
996 196 goto error_ctx_base_done;
997 }
998 }
999 }
1000
3/4
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 8 times.
✓ Branch 2 taken 168 times.
✗ Branch 3 not taken.
 176 if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN) &&
1001 (err_val != ENC_SYM_FATAL_ERROR)) {
1002 lbm_uint v;
1003
1/2
✓ Branch 0 taken 812 times.
✗ Branch 1 not taken.
 812 while (ctx_running->K.sp > 0) {
1004 812 lbm_pop(&ctx_running->K, &v);
1005
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 644 times.
 812 if (v == EXCEPTION_HANDLER) {
1006 168 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1007 168 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR);
1008 168 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER;
1009 168 ctx_running->app_cont = true;
1010 168 ctx_running->r = err_val;
1011 168 longjmp(error_jmp_buf, 1);
1012 }
1013 }
1014 ✗ err_val = ENC_SYM_FATAL_ERROR;
1015 }
1016 8 print_error_message(err_val,
1017 has_at,
1018 at,
1019 row,
1020 column,
1021 8 ctx_running->row0,
1022 8 ctx_running->row1);
1023 204 error_ctx_base_done:
1024 204 ctx_running->r = err_val;
1025 204 finish_ctx();
1026 204 longjmp(error_jmp_buf, 1);
1027 }
1028
1029 316 static void error_at_ctx(lbm_value err_val, lbm_value at) {
1030 316 error_ctx_base(err_val, true, at, 0, 0);
1031 ✗ }
1032
1033 56 static void error_ctx(lbm_value err_val) {
1034 56 error_ctx_base(err_val, false, 0, 0, 0);
1035 ✗ }
1036
1037 ✗ static void read_error_ctx(unsigned int row, unsigned int column) {
1038 ✗ error_ctx_base(ENC_SYM_RERROR, false, 0, row, column);
1039 ✗ }
1040
1041 ✗ void lbm_critical_error(void) {
1042 ✗ longjmp(critical_error_jmp_buf, 1);
1043 }
1044
1045 // successfully finish a context
1046 17815 static void ok_ctx(void) {
1047
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 17731 times.
 17815 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
1048 lbm_value msg;
1049
1/4
✗ Branch 3 not taken.
✓ Branch 4 taken 84 times.
✗ Branch 9 not taken.
✗ Branch 10 not taken.
 84 WITH_GC(msg, lbm_heap_allocate_list_init(3,
1050 ENC_SYM_EXIT_OK,
1051 lbm_enc_i(ctx_running->id),
1052 ctx_running->r));
1053 84 lbm_find_receiver_and_send(ctx_running->parent, msg);
1054 }
1055 17815 finish_ctx();
1056 17815 }
1057
1058 397122775 static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1059
2/2
✓ Branch 0 taken 1256180 times.
✓ Branch 1 taken 395866595 times.
 397122775 if (q->last == NULL) {
1060 1256180 return NULL;
1061 }
1062 // q->first should only be NULL if q->last is.
1063 395866595 eval_context_t *res = q->first;
1064
1065
2/2
✓ Branch 0 taken 395846198 times.
✓ Branch 1 taken 20397 times.
 395866595 if (q->first == q->last) { // One thing in queue
1066 395846198 q->first = NULL;
1067 395846198 q->last = NULL;
1068 } else {
1069 20397 q->first = q->first->next;
1070 20397 q->first->prev = NULL;
1071 }
1072 395866595 res->prev = NULL;
1073 395866595 res->next = NULL;
1074 395866595 return res;
1075 }
1076
1077 397122775 static void wake_up_ctxs_nm(void) {
1078 lbm_uint t_now;
1079
1080
1/2
✓ Branch 0 taken 397122775 times.
✗ Branch 1 not taken.
 397122775 if (timestamp_us_callback) {
1081 397122775 t_now = timestamp_us_callback();
1082 } else {
1083 ✗ t_now = 0;
1084 }
1085
1086 397122775 eval_context_queue_t *q = &blocked;
1087 397122775 eval_context_t *curr = q->first;
1088
1089
2/2
✓ Branch 0 taken 305936 times.
✓ Branch 1 taken 397122775 times.
 397428711 while (curr != NULL) {
1090 lbm_uint t_diff;
1091 305936 eval_context_t *next = curr->next;
1092
2/2
✓ Branch 0 taken 175799 times.
✓ Branch 1 taken 130137 times.
 305936 if (curr->state != LBM_THREAD_STATE_BLOCKED) {
1093
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 175799 times.
 175799 if ( curr->timestamp > t_now) {
1094 /* There was an overflow on the counter */
1095 #ifndef LBM64
1096 ✗ t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1097 #else
1098 t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1099 #endif
1100 } else {
1101 175799 t_diff = t_now - curr->timestamp;
1102 }
1103
1104
2/2
✓ Branch 0 taken 29089 times.
✓ Branch 1 taken 146710 times.
 175799 if (t_diff >= curr->sleep_us) {
1105 29089 eval_context_t *wake_ctx = curr;
1106
2/2
✓ Branch 0 taken 29076 times.
✓ Branch 1 taken 13 times.
 29089 if (curr == q->last) {
1107
2/2
✓ Branch 0 taken 299 times.
✓ Branch 1 taken 28777 times.
 29076 if (curr->prev) {
1108 299 q->last = curr->prev;
1109 299 q->last->next = NULL;
1110 } else {
1111 28777 q->first = NULL;
1112 28777 q->last = NULL;
1113 }
1114
1/2
✓ Branch 0 taken 13 times.
✗ Branch 1 not taken.
 13 } else if (curr->prev == NULL) {
1115 13 q->first = curr->next;
1116 13 q->first->prev = NULL;
1117 } else {
1118 ✗ curr->prev->next = curr->next;
1119 ✗ if (curr->next) {
1120 ✗ curr->next->prev = curr->prev;
1121 }
1122 }
1123 29089 wake_ctx->next = NULL;
1124 29089 wake_ctx->prev = NULL;
1125
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 29089 times.
 29089 if (curr->state == LBM_THREAD_STATE_TIMEOUT) {
1126 ✗ mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT);
1127 ✗ wake_ctx->r = ENC_SYM_TIMEOUT;
1128 }
1129 29089 wake_ctx->state = LBM_THREAD_STATE_READY;
1130 29089 enqueue_ctx_nm(&queue, wake_ctx);
1131 }
1132 }
1133 305936 curr = next;
1134 }
1135 397122775 }
1136
1137 29121 static void yield_ctx(lbm_uint sleep_us) {
1138
1/2
✓ Branch 0 taken 29121 times.
✗ Branch 1 not taken.
 29121 if (timestamp_us_callback) {
1139 29121 ctx_running->timestamp = timestamp_us_callback();
1140 29121 ctx_running->sleep_us = sleep_us;
1141 29121 ctx_running->state = LBM_THREAD_STATE_SLEEPING;
1142 } else {
1143 ✗ ctx_running->timestamp = 0;
1144 ✗ ctx_running->sleep_us = 0;
1145 ✗ ctx_running->state = LBM_THREAD_STATE_SLEEPING;
1146 }
1147 29121 ctx_running->r = ENC_SYM_TRUE;
1148 29121 ctx_running->app_cont = true;
1149 29121 enqueue_ctx(&blocked,ctx_running);
1150 29121 ctx_running = NULL;
1151 29121 }
1152
1153 18228 static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
1154
1155
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 18228 times.
 18228 if (!lbm_is_cons(program)) return -1;
1156
1157 18228 eval_context_t *ctx = NULL;
1158
1159 18228 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1160
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18228 times.
 18228 if (ctx == NULL) {
1161 ✗ lbm_uint roots[2] = {program, env};
1162 ✗ lbm_gc_mark_roots(roots, 2);
1163 ✗ gc();
1164 ✗ ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1165 }
1166
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18228 times.
 18228 if (ctx == NULL) return -1;
1167
1168
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 18228 times.
 18228 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1169 ✗ lbm_uint roots[2] = {program, env};
1170 ✗ lbm_gc_mark_roots(roots, 2);
1171 ✗ gc();
1172 ✗ if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1173 ✗ lbm_memory_free((lbm_uint*)ctx);
1174 ✗ return -1;
1175 }
1176 }
1177
1178 18228 lbm_value *mailbox = NULL;
1179 18228 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
1180
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18228 times.
 18228 if (mailbox == NULL) {
1181 ✗ lbm_value roots[2] = {program, env};
1182 ✗ lbm_gc_mark_roots(roots,2);
1183 ✗ gc();
1184 ✗ mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
1185 }
1186
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18228 times.
 18228 if (mailbox == NULL) {
1187 ✗ lbm_stack_free(&ctx->K);
1188 ✗ lbm_memory_free((lbm_uint*)ctx);
1189 ✗ return -1;
1190 }
1191
1192 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1193
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 18228 times.
 18228 if (name) {
1194 ✗ lbm_uint name_len = strlen(name) + 1;
1195 ✗ ctx->name = lbm_malloc(strlen(name) + 1);
1196 ✗ if (ctx->name == NULL) {
1197 ✗ lbm_value roots[2] = {program, env};
1198 ✗ lbm_gc_mark_roots(roots, 2);
1199 ✗ gc();
1200 ✗ ctx->name = lbm_malloc(strlen(name) + 1);
1201 }
1202 ✗ if (ctx->name == NULL) {
1203 ✗ lbm_stack_free(&ctx->K);
1204 ✗ lbm_memory_free((lbm_uint*)mailbox);
1205 ✗ lbm_memory_free((lbm_uint*)ctx);
1206 ✗ return -1;
1207 }
1208 ✗ memcpy(ctx->name, name, name_len+1);
1209 } else {
1210 18228 ctx->name = NULL;
1211 }
1212
1213 18228 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1214
1215 18228 ctx->program = lbm_cdr(program);
1216 18228 ctx->curr_exp = lbm_car(program);
1217 18228 ctx->curr_env = env;
1218 18228 ctx->r = ENC_SYM_NIL;
1219 18228 ctx->error_reason = NULL;
1220 18228 ctx->mailbox = mailbox;
1221 18228 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE;
1222 18228 ctx->flags = context_flags;
1223 18228 ctx->num_mail = 0;
1224 18228 ctx->app_cont = false;
1225 18228 ctx->timestamp = 0;
1226 18228 ctx->sleep_us = 0;
1227 18228 ctx->state = LBM_THREAD_STATE_READY;
1228 18228 ctx->prev = NULL;
1229 18228 ctx->next = NULL;
1230
1231 18228 ctx->row0 = -1;
1232 18228 ctx->row1 = -1;
1233
1234 18228 ctx->id = cid;
1235 18228 ctx->parent = parent;
1236
1237
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 18228 times.
 18228 if (!lbm_push(&ctx->K, DONE)) {
1238 ✗ lbm_memory_free((lbm_uint*)ctx->mailbox);
1239 ✗ lbm_stack_free(&ctx->K);
1240 ✗ lbm_memory_free((lbm_uint*)ctx);
1241 ✗ return -1;
1242 }
1243
1244 18228 enqueue_ctx(&queue,ctx);
1245
1246 18228 return ctx->id;
1247 }
1248
1249 17444 lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1250 // Creates a parentless context.
1251 17444 return lbm_create_ctx_parent(program,
1252 env,
1253 stack_size,
1254 -1,
1255 EVAL_CPS_CONTEXT_FLAG_NOTHING,
1256 name);
1257 }
1258
1259 28 bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1260
1261 28 lbm_value *mailbox = NULL;
1262 28 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1263
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (mailbox == NULL) {
1264 ✗ gc();
1265 ✗ mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1266 }
1267
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (mailbox == NULL) {
1268 ✗ return false;
1269 }
1270
1271
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1272 ✗ mailbox[i] = ctx->mailbox[i];
1273 }
1274 28 lbm_memory_free(ctx->mailbox);
1275 28 ctx->mailbox = mailbox;
1276 28 ctx->mailbox_size = (uint32_t)new_size;
1277 28 return true;
1278 }
1279
1280 6020 static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1281
1282
2/2
✓ Branch 0 taken 16051 times.
✓ Branch 1 taken 6020 times.
 22071 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1283 16051 ctx->mailbox[i] = ctx->mailbox[i+1];
1284 }
1285 6020 ctx->num_mail --;
1286 6020 }
1287
1288 6832 static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1289
1290
2/2
✓ Branch 0 taken 588 times.
✓ Branch 1 taken 6244 times.
 6832 if (ctx->num_mail >= ctx->mailbox_size) {
1291 588 mailbox_remove_mail(ctx, 0);
1292 }
1293
1294 6832 ctx->mailbox[ctx->num_mail] = mail;
1295 6832 ctx->num_mail ++;
1296 6832 return true;
1297 }
1298
1299 /* Advance execution to the next expression in the program */
1300 35623 static void advance_ctx(eval_context_t *ctx) {
1301
2/2
✓ Branch 1 taken 17808 times.
✓ Branch 2 taken 17815 times.
 35623 if (lbm_is_cons(ctx->program)) {
1302 17808 stack_reserve(ctx, 1)[0] = DONE;;
1303 17808 get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
1304 17808 ctx->curr_env = ENC_SYM_NIL;
1305 } else {
1306
1/2
✓ Branch 0 taken 17815 times.
✗ Branch 1 not taken.
 17815 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1307 17815 ok_ctx();
1308 }
1309 }
1310 35623 }
1311
1312 56 bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1313 56 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1314 }
1315
1316 28 bool lbm_unblock_ctx_r(lbm_cid cid) {
1317 28 mutex_lock(&blocking_extension_mutex);
1318 28 bool r = false;
1319 28 eval_context_t *found = NULL;
1320 28 mutex_lock(&qmutex);
1321 28 found = lookup_ctx_nm(&blocked, cid);
1322
1/2
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
 28 if (found) {
1323 28 drop_ctx_nm(&blocked,found);
1324 28 enqueue_ctx_nm(&queue,found);
1325 28 r = true;
1326 }
1327 28 mutex_unlock(&qmutex);
1328 28 mutex_unlock(&blocking_extension_mutex);
1329 28 return r;
1330 }
1331
1332 // unblock unboxed is also safe for rmbr:ed things.
1333 ✗ bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1334 ✗ mutex_lock(&blocking_extension_mutex);
1335 ✗ bool r = false;
1336 ✗ eval_context_t *found = NULL;
1337 ✗ mutex_lock(&qmutex);
1338 ✗ found = lookup_ctx_nm(&blocked, cid);
1339 ✗ if (found) {
1340 ✗ drop_ctx_nm(&blocked,found);
1341 ✗ found->r = unboxed;
1342 ✗ if (lbm_is_error(unboxed)) {
1343 ✗ get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
1344 ✗ found->app_cont = true;
1345 }
1346 ✗ enqueue_ctx_nm(&queue,found);
1347 ✗ r = true;
1348 }
1349 ✗ mutex_unlock(&qmutex);
1350 ✗ mutex_unlock(&blocking_extension_mutex);
1351 ✗ return r;
1352 }
1353
1354 84 static bool lbm_block_ctx_base(bool timeout, float t_s) {
1355 84 mutex_lock(&blocking_extension_mutex);
1356 84 blocking_extension = true;
1357
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 84 times.
 84 if (timeout) {
1358 ✗ blocking_extension_timeout_us = S_TO_US(t_s);
1359 ✗ blocking_extension_timeout = true;
1360 } else {
1361 84 blocking_extension_timeout = false;
1362 }
1363 84 return true;
1364 }
1365
1366 ✗ void lbm_block_ctx_from_extension_timeout(float s) {
1367 ✗ lbm_block_ctx_base(true, s);
1368 ✗ }
1369
1370 84 void lbm_block_ctx_from_extension(void) {
1371 84 lbm_block_ctx_base(false, 0);
1372 84 }
1373
1374 // todo: May need to pop rmbrs from stack, if present.
1375 // Suspect that the letting the discard cont run is really not a problem.
1376 // Either way will be quite confusing what happens to allocated things when undoing block.
1377 ✗ void lbm_undo_block_ctx_from_extension(void) {
1378 ✗ blocking_extension = false;
1379 ✗ blocking_extension_timeout_us = 0;
1380 ✗ blocking_extension_timeout = false;
1381 ✗ mutex_unlock(&blocking_extension_mutex);
1382 ✗ }
1383
1384 11501 lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1385 11501 mutex_lock(&qmutex);
1386 11501 eval_context_t *found = NULL;
1387 11501 bool found_blocked = false;
1388
1389 11501 found = lookup_ctx_nm(&blocked, cid);
1390
2/2
✓ Branch 0 taken 2860 times.
✓ Branch 1 taken 8641 times.
 11501 if (found) found_blocked = true;
1391
1392
2/2
✓ Branch 0 taken 8641 times.
✓ Branch 1 taken 2860 times.
 11501 if (found == NULL) {
1393 8641 found = lookup_ctx_nm(&queue, cid);
1394 }
1395
1396
2/2
✓ Branch 0 taken 3892 times.
✓ Branch 1 taken 7609 times.
 11501 if (found) {
1397
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 3892 times.
 3892 if (!mailbox_add_mail(found, msg)) {
1398 ✗ mutex_unlock(&qmutex);
1399 ✗ return ENC_SYM_NIL;
1400 }
1401
1402
2/2
✓ Branch 0 taken 2860 times.
✓ Branch 1 taken 1032 times.
 3892 if (found_blocked){
1403 2860 drop_ctx_nm(&blocked,found);
1404 2860 enqueue_ctx_nm(&queue,found);
1405 }
1406 3892 mutex_unlock(&qmutex);
1407 3892 return ENC_SYM_TRUE;
1408 }
1409
1410 /* check the current context */
1411
3/4
✓ Branch 0 taken 7609 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 2940 times.
✓ Branch 3 taken 4669 times.
 7609 if (ctx_running && ctx_running->id == cid) {
1412
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 2940 times.
 2940 if (!mailbox_add_mail(ctx_running, msg)) {
1413 ✗ mutex_unlock(&qmutex);
1414 ✗ return ENC_SYM_NIL;
1415 }
1416 2940 mutex_unlock(&qmutex);
1417 2940 return ENC_SYM_TRUE;
1418 }
1419 4669 mutex_unlock(&qmutex);
1420 4669 return ENC_SYM_NIL;
1421 }
1422
1423 /* Pattern matching is currently implemented as a recursive
1424 function and make use of stack relative to the size of
1425 expressions that are being matched. */
1426 23004 static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
1427
1428 lbm_value binding;
1429
1430
2/2
✓ Branch 1 taken 8668 times.
✓ Branch 2 taken 14336 times.
 23004 if (lbm_is_match_binder(p)) {
1431 8668 lbm_value var = get_cadr(p);
1432 8668 lbm_value bindertype = get_car(p);
1433
1434
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 8668 times.
 8668 if (!lbm_is_symbol(var)) return false;
1435
1436
1/2
✓ Branch 0 taken 8668 times.
✗ Branch 1 not taken.
 8668 switch (bindertype) {
1437 8668 case ENC_SYM_MATCH_ANY:
1438
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8668 times.
 8668 if ( var == ENC_SYM_DONTCARE) {
1439 ✗ return true;
1440 }
1441 8668 break;
1442 ✗ default: /* this should be an error case */
1443 ✗ return false;
1444 }
1445 8668 binding = lbm_cons(var, e);
1446
2/2
✓ Branch 1 taken 16 times.
✓ Branch 2 taken 8652 times.
 8668 if ( lbm_type_of(binding) == LBM_TYPE_SYMBOL ) {
1447 16 *gc = true;
1448 16 return false;
1449 }
1450 8652 *env = lbm_cons(binding, *env);
1451
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 8652 times.
 8652 if ( lbm_type_of(*env) == LBM_TYPE_SYMBOL ) {
1452 ✗ *gc = true;
1453 ✗ return false;
1454 }
1455 8652 return true;
1456 }
1457
1458
2/2
✓ Branch 1 taken 6048 times.
✓ Branch 2 taken 8288 times.
 14336 if (lbm_is_symbol(p)) {
1459
2/2
✓ Branch 0 taken 1344 times.
✓ Branch 1 taken 4704 times.
 6048 if (p == ENC_SYM_DONTCARE) return true;
1460 4704 return (p == e);
1461 }
1462
4/4
✓ Branch 1 taken 6608 times.
✓ Branch 2 taken 1680 times.
✓ Branch 3 taken 5544 times.
✓ Branch 4 taken 1064 times.
 14896 if (lbm_is_cons(p) &&
1463 6608 lbm_is_cons(e) ) {
1464
1465 lbm_value headp, tailp;
1466 lbm_value heade, taile;
1467 5544 get_car_and_cdr(p, &headp, &tailp);
1468 5544 get_car_and_cdr(e, &heade, &taile); // Static analysis warns, but execution does not
1469 // past this point unless head and tail get initialized.
1470
2/2
✓ Branch 1 taken 644 times.
✓ Branch 2 taken 4900 times.
 5544 if (!match(headp, heade, env, gc)) {
1471 644 return false;
1472 }
1473 4900 return match (tailp, taile, env, gc);
1474 }
1475 2744 return struct_eq(p, e);
1476 }
1477
1478 // Find match is not very picky about syntax.
1479 // A completely malformed recv form is most likely to
1480 // just return no_match.
1481 5434 static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1482
1483 // A pattern list is a list of pattern, expression lists.
1484 // ( (p1 e1) (p2 e2) ... (pn en))
1485 5434 lbm_value curr_p = plist;
1486 5434 int n = 0;
1487 5434 bool gc = false;
1488
2/2
✓ Branch 0 taken 5952 times.
✓ Branch 1 taken 2 times.
 5954 for (int i = 0; i < (int)num; i ++ ) {
1489 5952 lbm_value curr_e = earr[i];
1490
2/2
✓ Branch 1 taken 6624 times.
✓ Branch 2 taken 520 times.
 7144 while (!lbm_is_symbol_nil(curr_p)) {
1491 6624 lbm_value me = get_car(curr_p);
1492
2/2
✓ Branch 2 taken 5432 times.
✓ Branch 3 taken 1192 times.
 6624 if (match(get_car(me), curr_e, env, &gc)) {
1493
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5432 times.
 5432 if (gc) return FM_NEED_GC;
1494 5432 *e = get_cadr(me);
1495
1496
1/2
✗ Branch 3 not taken.
✓ Branch 4 taken 5432 times.
 5432 if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
1497 ✗ return FM_PATTERN_ERROR;
1498 }
1499 5432 return n;
1500 }
1501 1192 curr_p = get_cdr(curr_p);
1502 }
1503 520 curr_p = plist; /* search all patterns against next exp */
1504 520 n ++;
1505 }
1506
1507 2 return FM_NO_MATCH;
1508 }
1509
1510 /****************************************************/
1511 /* Garbage collection */
1512
1513 1061241 static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1514 (void) arg1;
1515 (void) arg2;
1516 1061241 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
1517 1061241 lbm_gc_mark_env(ctx->curr_env);
1518 1061241 lbm_gc_mark_roots(roots, 3);
1519 1061241 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1520 1061241 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1521 1061241 }
1522
1523 1057817 static int gc(void) {
1524
2/2
✓ Branch 0 taken 1057789 times.
✓ Branch 1 taken 28 times.
 1057817 if (ctx_running) {
1525 1057789 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT;
1526 }
1527
1528 1057817 gc_requested = false;
1529 1057817 lbm_gc_state_inc();
1530
1531 // The freelist should generally be NIL when GC runs.
1532 1057817 lbm_nil_freelist();
1533 1057817 lbm_value *env = lbm_get_global_env();
1534
2/2
✓ Branch 0 taken 33850144 times.
✓ Branch 1 taken 1057817 times.
 34907961 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
1535 33850144 lbm_gc_mark_env(env[i]);
1536 }
1537
1538 1057817 mutex_lock(&qmutex); // Lock the queues.
1539 // Any concurrent messing with the queues
1540 // while doing GC cannot possibly be good.
1541 1057817 queue_iterator_nm(&queue, mark_context, NULL, NULL);
1542 1057817 queue_iterator_nm(&blocked, mark_context, NULL, NULL);
1543
1544
2/2
✓ Branch 0 taken 1057789 times.
✓ Branch 1 taken 28 times.
 1057817 if (ctx_running) {
1545 1057789 mark_context(ctx_running, NULL, NULL);
1546 }
1547 1057817 mutex_unlock(&qmutex);
1548
1549 #ifdef VISUALIZE_HEAP
1550 heap_vis_gen_image();
1551 #endif
1552
1553 1057817 int r = lbm_gc_sweep_phase();
1554 1057817 lbm_heap_new_freelist_length();
1555
1556
2/2
✓ Branch 0 taken 1057789 times.
✓ Branch 1 taken 28 times.
 1057817 if (ctx_running) {
1557 1057789 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT;
1558 }
1559 1057817 return r;
1560 }
1561
1562 12908 int lbm_perform_gc(void) {
1563 12908 return gc();
1564 }
1565
1566 /****************************************************/
1567 /* Evaluation functions */
1568
1569
1570 845325353 static void eval_symbol(eval_context_t *ctx) {
1571 845325353 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1572
2/2
✓ Branch 0 taken 580256228 times.
✓ Branch 1 taken 265069125 times.
 845325353 if (s >= RUNTIME_SYMBOLS_START) {
1573 580256228 lbm_value res = ENC_SYM_NIL;
1574
4/4
✓ Branch 1 taken 106068173 times.
✓ Branch 2 taken 474188055 times.
✓ Branch 3 taken 106063637 times.
✓ Branch 4 taken 4536 times.
 686324401 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1575 106068173 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1576 580251692 ctx->r = res;
1577 580251692 ctx->app_cont = true;
1578 580251692 return;
1579 }
1580 // Dynamic load attempt
1581 // Only symbols of kind RUNTIME can be dynamically loaded.
1582 4536 const char *sym_str = lbm_get_name_by_symbol(s);
1583 4536 const char *code_str = NULL;
1584
2/2
✓ Branch 1 taken 28 times.
✓ Branch 2 taken 4508 times.
 4536 if (!dynamic_load_callback(sym_str, &code_str)) {
1585 28 error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp);
1586 }
1587 4508 lbm_value *sptr = stack_reserve(ctx, 3);
1588 4508 sptr[0] = ctx->curr_exp;
1589 4508 sptr[1] = ctx->curr_env;
1590 4508 sptr[2] = RESUME;
1591
1592 lbm_value chan;
1593
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 4508 times.
 4508 if (!create_string_channel((char *)code_str, &chan)) {
1594 ✗ gc();
1595 ✗ if (!create_string_channel((char *)code_str, &chan)) {
1596 ✗ error_ctx(ENC_SYM_MERROR);
1597 }
1598 }
1599
1600 // Here, chan has either been assigned or execution has terminated.
1601
1602 lbm_value loader;
1603
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 4508 times.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
 4508 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,
1604 ENC_SYM_READ,
1605 chan), chan);
1606 lbm_value evaluator;
1607
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 4508 times.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
 4508 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,
1608 ENC_SYM_EVAL,
1609 loader), loader);
1610 4508 ctx->curr_exp = evaluator;
1611 4508 ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env
1612 } else {
1613 //special symbols and extensions can be handled the same way.
1614 265069125 ctx->r = ctx->curr_exp;
1615 265069125 ctx->app_cont = true;
1616 }
1617 }
1618
1619 4648644 static void eval_quote(eval_context_t *ctx) {
1620 4648644 ctx->r = get_cadr(ctx->curr_exp);
1621 4648644 ctx->app_cont = true;
1622 4648644 }
1623
1624 638572873 static void eval_selfevaluating(eval_context_t *ctx) {
1625 638572873 ctx->r = ctx->curr_exp;
1626 638572873 ctx->app_cont = true;
1627 638572873 }
1628
1629 69931963 static void eval_progn(eval_context_t *ctx) {
1630 69931963 lbm_value exps = get_cdr(ctx->curr_exp);
1631
1632
2/2
✓ Branch 1 taken 69931935 times.
✓ Branch 2 taken 28 times.
 69931963 if (lbm_is_cons(exps)) {
1633 69931935 lbm_uint *sptr = stack_reserve(ctx, 4);
1634 69931935 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1635 69931935 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1636 69931935 sptr[3] = PROGN_REST;
1637 69931935 get_car_and_cdr(exps, &ctx->curr_exp, &sptr[2]);
1638
2/2
✓ Branch 1 taken 2802128 times.
✓ Branch 2 taken 67129807 times.
 69931935 if (lbm_is_symbol(sptr[2])) /* The only symbol it can be is nil */
1639 2802128 lbm_stack_drop(&ctx->K, 4);
1640
1/2
✓ Branch 1 taken 28 times.
✗ Branch 2 not taken.
 28 } else if (lbm_is_symbol_nil(exps)) {
1641 28 ctx->r = ENC_SYM_NIL;
1642 28 ctx->app_cont = true;
1643 } else {
1644 ✗ error_ctx(ENC_SYM_EERROR);
1645 }
1646 69931963 }
1647
1648 224 static void eval_atomic(eval_context_t *ctx) {
1649
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 224 times.
 224 if (is_atomic) {
1650 ✗ lbm_set_error_reason("Atomic blocks cannot be nested!");
1651 ✗ error_ctx(ENC_SYM_EERROR);
1652 }
1653 224 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC;
1654 224 is_atomic ++;
1655 224 eval_progn(ctx);
1656 224 }
1657
1658 /* (call-cc (lambda (k) .... )) */
1659 364 static void eval_callcc(eval_context_t *ctx) {
1660 lbm_value cont_array;
1661
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 364 times.
 364 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1662 ✗ gc();
1663 ✗ if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1664 ✗ error_ctx(ENC_SYM_MERROR);
1665 ✗ return; // dead return but static analysis doesn't know :)
1666 }
1667 }
1668 364 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(cont_array);
1669 364 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1670
1671 364 lbm_value acont = cons_with_gc(ENC_SYM_CONT, cont_array, ENC_SYM_NIL);
1672 364 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
1673 // Go directly into application evaluation without passing go
1674 364 lbm_uint *sptr = stack_reserve(ctx, 3);
1675 364 sptr[0] = ctx->curr_env;
1676 364 sptr[1] = arg_list;
1677 364 sptr[2] = APPLICATION_START;
1678 364 ctx->curr_exp = get_cadr(ctx->curr_exp);
1679 }
1680
1681 // (define sym exp)
1682 #define KEY 1
1683 #define VAL 2
1684 4243400 static void eval_define(eval_context_t *ctx) {
1685 lbm_value parts[3];
1686 4243400 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1687 4243400 lbm_uint *sptr = stack_reserve(ctx, 2);
1688
2/4
✓ Branch 1 taken 4243400 times.
✗ Branch 2 not taken.
✓ Branch 4 taken 4243400 times.
✗ Branch 5 not taken.
 4243400 if (lbm_is_symbol(parts[KEY]) && lbm_is_symbol_nil(rest)) {
1689 4243400 lbm_uint sym_val = lbm_dec_sym(parts[KEY]);
1690 4243400 sptr[0] = parts[KEY];
1691
1/2
✓ Branch 0 taken 4243400 times.
✗ Branch 1 not taken.
 4243400 if (sym_val >= RUNTIME_SYMBOLS_START) {
1692 4243400 sptr[1] = SET_GLOBAL_ENV;
1693
2/2
✓ Branch 0 taken 14 times.
✓ Branch 1 taken 4243386 times.
 4243400 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST) {
1694 14 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
1695 }
1696 4243400 ctx->curr_exp = parts[VAL];
1697 4243400 return;
1698 }
1699 }
1700 ✗ error_at_ctx(ENC_SYM_EERROR, ctx->curr_exp);
1701 }
1702
1703
1704 /* Eval lambda is cheating, a lot! It does this
1705 for performance reasons. The cheats are that
1706 1. When closure is created, a reference to the local env
1707 in which the lambda was evaluated is added to the closure.
1708 Ideally it should have created a list of free variables in the function
1709 and then looked up the values of these creating a new environment.
1710 2. The global env is considered global constant. As there is no copying
1711 of environment bindings into the closure, undefine may break closures.
1712
1713 Correct closure creation is a lot more expensive than what happens here.
1714 However, one can try to write programs in such a way that closures are created
1715 seldomly. If one does that the space-usage benefits of "correct" closures
1716 may outweigh the performance gain of "incorrect" ones.
1717
1718 some obscure programs such as test_setq_local_closure.lisp does not
1719 work properly due to this cheating.
1720 */
1721 // (lambda param-list body-exp) -> (closure param-list body-exp env)
1722 10612 static void eval_lambda(eval_context_t *ctx) {
1723 lbm_value vals[3];
1724 10612 extract_n(ctx->curr_exp, vals, 3);
1725 10612 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
1726 #ifdef CLEAN_UP_CLOSURES
1727 lbm_uint sym_id = 0;
1728 if (clean_cl_env_symbol) {
1729 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
1730 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1731 ctx->curr_exp = app;
1732 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
1733 clean_cl_env_symbol = lbm_enc_sym(sym_id);
1734 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
1735 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
1736 ctx->curr_exp = app;
1737 } else {
1738 ctx->app_cont = true;
1739 }
1740 #else
1741 10612 ctx->app_cont = true;
1742 #endif
1743 10612 }
1744
1745 // (if cond-expr then-expr else-expr)
1746 74914451 static void eval_if(eval_context_t *ctx) {
1747 74914451 lbm_value cdr = get_cdr(ctx->curr_exp);
1748 74914451 lbm_value *sptr = stack_reserve(ctx, 3);
1749 74914451 sptr[0] = get_cdr(cdr);
1750 74914451 sptr[1] = ctx->curr_env;
1751 74914451 sptr[2] = IF;
1752 74914451 ctx->curr_exp = get_car(cdr);
1753 74914451 }
1754
1755 // (cond (cond-expr-1 expr-1)
1756 // ...
1757 // (cond-expr-N expr-N))
1758 1316 static void eval_cond(eval_context_t *ctx) {
1759 lbm_value cond1[2];
1760 1316 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
1761
1762 // end recursion at (cond )
1763
2/2
✓ Branch 1 taken 28 times.
✓ Branch 2 taken 1288 times.
 1316 if (lbm_is_symbol_nil(cond1[1])) {
1764 28 ctx->r = ENC_SYM_NIL;
1765 28 ctx->app_cont = true;
1766 } else {
1767 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
1768 // Maybe dont bother?
1769 1288 lbm_uint len = lbm_list_length(cond1[1]);
1770
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1288 times.
 1288 if (len != 2) {
1771 ✗ lbm_set_error_reason("Incorrect syntax in cond");
1772 ✗ error_ctx(ENC_SYM_EERROR);
1773 }
1774 lbm_value cond_expr[2];
1775 1288 extract_n(cond1[1], cond_expr, 2);
1776 lbm_value rest;
1777
1/4
✗ Branch 3 not taken.
✓ Branch 4 taken 1288 times.
✗ Branch 9 not taken.
✗ Branch 10 not taken.
 1288 WITH_GC(rest, lbm_heap_allocate_list_init(2,
1778 cond_expr[1], // Then branch
1779 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)));
1780 1288 lbm_value *sptr = stack_reserve(ctx, 3);
1781 1288 sptr[0] = rest;
1782 1288 sptr[1] = ctx->curr_env;
1783 1288 sptr[2] = IF;
1784 1288 ctx->curr_exp = cond_expr[0]; //condition;
1785 }
1786 1316 }
1787
1788 602 static void eval_app_cont(eval_context_t *ctx) {
1789 602 lbm_stack_drop(&ctx->K, 1);
1790 602 ctx->app_cont = true;
1791 602 }
1792
1793 // Create a named location in an environment to later receive a value.
1794 292018730 static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
1795
1796
4/4
✓ Branch 1 taken 277984676 times.
✓ Branch 2 taken 14034054 times.
✓ Branch 3 taken 275177988 times.
✓ Branch 4 taken 2806688 times.
 292018730 if (lbm_is_symbol(key) &&
1797
2/2
✓ Branch 0 taken 2806722 times.
✓ Branch 1 taken 272371266 times.
 275177988 (key == ENC_SYM_NIL ||
1798 key == ENC_SYM_DONTCARE))
1799 5613410 return BL_OK;
1800
1801
2/2
✓ Branch 1 taken 272371266 times.
✓ Branch 2 taken 14034054 times.
 286405320 if (lbm_type_of(key) == LBM_TYPE_SYMBOL) { // default case
1802 lbm_value binding;
1803 lbm_value new_env_tmp;
1804 272371266 binding = lbm_cons(key, ENC_SYM_NIL);
1805 272371266 new_env_tmp = lbm_cons(binding, *env);
1806
4/4
✓ Branch 1 taken 272148178 times.
✓ Branch 2 taken 223088 times.
✓ Branch 4 taken 183582 times.
✓ Branch 5 taken 271964596 times.
 272371266 if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
1807 406670 return BL_NO_MEMORY;
1808 }
1809 271964596 *env = new_env_tmp;
1810
1/2
✓ Branch 1 taken 14034054 times.
✗ Branch 2 not taken.
 14034054 } else if (lbm_is_cons(key)) { // deconstruct case
1811 14034054 int r = create_binding_location_internal(get_car(key), env);
1812
2/2
✓ Branch 0 taken 14034026 times.
✓ Branch 1 taken 28 times.
 14034054 if (r == BL_OK) {
1813 14034026 r = create_binding_location_internal(get_cdr(key), env);
1814 }
1815 14034054 return r;
1816 }
1817 271964596 return BL_OK;
1818 }
1819
1820 263543980 static void create_binding_location(lbm_value key, lbm_value *env) {
1821
1822 263543980 lbm_value env_tmp = *env;
1823 263543980 binding_location_status r = create_binding_location_internal(key, &env_tmp);
1824
2/2
✓ Branch 0 taken 263137310 times.
✓ Branch 1 taken 406670 times.
 263543980 if (r != BL_OK) {
1825
1/2
✓ Branch 0 taken 406670 times.
✗ Branch 1 not taken.
 406670 if (r == BL_NO_MEMORY) {
1826 406670 env_tmp = *env;
1827 406670 lbm_gc_mark_phase(env_tmp);
1828 406670 gc();
1829 406670 r = create_binding_location_internal(key, &env_tmp);
1830 }
1831
1/4
✓ Branch 0 taken 406670 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 406670 switch(r) {
1832 406670 case BL_OK:
1833 406670 break;
1834 ✗ case BL_NO_MEMORY:
1835 ✗ error_ctx(ENC_SYM_MERROR);
1836 ✗ break;
1837 ✗ case BL_INCORRECT_KEY:
1838 ✗ error_ctx(ENC_SYM_TERROR);
1839 ✗ break;
1840 }
1841 263137310 }
1842 263543980 *env = env_tmp;
1843 263543980 }
1844
1845 123260760 static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
1846
1847
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 123260760 times.
 123260760 if (!lbm_is_cons(binds)) {
1848 // binds better be nil or there is a programmer error.
1849 ✗ ctx->curr_exp = exp;
1850 ✗ return;
1851 }
1852
1853 // Preallocate binding locations.
1854 123260760 lbm_value curr = binds;
1855
2/2
✓ Branch 1 taken 235262608 times.
✓ Branch 2 taken 123260760 times.
 358523368 while (lbm_is_cons(curr)) {
1856 235262608 lbm_value new_env_tmp = env;
1857 lbm_value car_curr, cdr_curr;
1858 235262608 get_car_and_cdr(curr, &car_curr, &cdr_curr);
1859 235262608 lbm_value key = get_car(car_curr);
1860 235262608 create_binding_location(key, &new_env_tmp);
1861 235262608 env = new_env_tmp;
1862 235262608 curr = cdr_curr;
1863 }
1864
1865 lbm_value car_binds;
1866 lbm_value cdr_binds;
1867 123260760 get_car_and_cdr(binds, &car_binds, &cdr_binds);
1868 lbm_value key_val[2];
1869 123260760 extract_n(car_binds, key_val, 2);
1870
1871 123260760 lbm_uint *sptr = stack_reserve(ctx, 5);
1872 123260760 sptr[0] = exp;
1873 123260760 sptr[1] = cdr_binds;
1874 123260760 sptr[2] = env;
1875 123260760 sptr[3] = key_val[0];
1876 123260760 sptr[4] = BIND_TO_KEY_REST;
1877 123260760 ctx->curr_exp = key_val[1];
1878 123260760 ctx->curr_env = env;
1879 }
1880
1881 // (var x (...)) - local binding inside of an progn
1882 // var has to take, place root-level nesting within progn.
1883 // (progn ... (var a 10) ...) OK!
1884 // (progn ... (something (var a 10)) ... ) NOT OK!
1885 /* progn stack
1886 sp-4 : env
1887 sp-3 : 0
1888 sp-2 : rest
1889 sp-1 : PROGN_REST
1890 */
1891 28281372 static void eval_var(eval_context_t *ctx) {
1892
1893
1/2
✓ Branch 0 taken 28281372 times.
✗ Branch 1 not taken.
 28281372 if (ctx->K.sp >= 4) { // Possibly in progn
1894 28281372 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
1895
2/4
✓ Branch 0 taken 28281372 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 28281372 times.
✗ Branch 3 not taken.
 28281372 if (IS_CONTINUATION(sv) && (sv == PROGN_REST)) {
1896 28281372 lbm_uint sp = ctx->K.sp;
1897 28281372 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
1898
2/2
✓ Branch 0 taken 28280952 times.
✓ Branch 1 taken 420 times.
 28281372 if (is_copied == 0) {
1899 lbm_value env;
1900
3/4
✓ Branch 2 taken 88832 times.
✓ Branch 3 taken 28192120 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 88832 times.
 28280952 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]));
1901 28280952 ctx->K.data[sp-3] = lbm_enc_u(1);
1902 28280952 ctx->K.data[sp-4] = env;
1903 }
1904 28281372 lbm_value new_env = ctx->K.data[sp-4];
1905 28281372 lbm_value args = get_cdr(ctx->curr_exp);
1906 28281372 lbm_value key = get_car(args);
1907 28281372 create_binding_location(key, &new_env);
1908 28281372 ctx->K.data[sp-4] = new_env;
1909
1910 28281372 lbm_value v_exp = get_cadr(args);
1911 28281372 lbm_value *sptr = stack_reserve(ctx, 3);
1912 28281372 sptr[0] = new_env;
1913 28281372 sptr[1] = key;
1914 28281372 sptr[2] = PROGN_VAR;
1915 // Activating the new environment before the evaluation of the value to be bound,
1916 // means that other variables with same name will be shadowed already in the value
1917 // body.
1918 // The way closures work, the var-variable needs to be in scope during val evaluation
1919 // for a recursive closure to be possible.
1920 28281372 ctx->curr_env = new_env;
1921 28281372 ctx->curr_exp = v_exp;
1922 28281372 return;
1923 }
1924 }
1925 ✗ lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
1926 ✗ error_ctx(ENC_SYM_EERROR);
1927 }
1928
1929 // (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
1930 1766856 static void eval_setq(eval_context_t *ctx) {
1931 lbm_value parts[3];
1932 1766856 extract_n(ctx->curr_exp, parts, 3);
1933 1766856 lbm_value *sptr = stack_reserve(ctx, 3);
1934 1766856 sptr[0] = ctx->curr_env;
1935 1766856 sptr[1] = parts[1];
1936 1766856 sptr[2] = SETQ;
1937 1766856 ctx->curr_exp = parts[2];
1938 1766856 }
1939
1940 308 static void eval_move_to_flash(eval_context_t *ctx) {
1941 308 lbm_value args = get_cdr(ctx->curr_exp);
1942 308 lbm_value *sptr = stack_reserve(ctx,2);
1943 308 sptr[0] = args;
1944 308 sptr[1] = MOVE_TO_FLASH;
1945 308 ctx->app_cont = true;
1946 308 }
1947
1948 // (loop list-of-local-bindings
1949 // condition-exp
1950 // body-exp)
1951 280 static void eval_loop(eval_context_t *ctx) {
1952 280 lbm_value env = ctx->curr_env;
1953 lbm_value parts[3];
1954 280 extract_n(get_cdr(ctx->curr_exp), parts, 3);
1955 280 lbm_value *sptr = stack_reserve(ctx, 3);
1956 280 sptr[0] = parts[LOOP_BODY];
1957 280 sptr[1] = parts[LOOP_COND];
1958 280 sptr[2] = LOOP_CONDITION;
1959 280 let_bind_values_eval(parts[LOOP_BINDS], parts[LOOP_COND], env, ctx);
1960 280 }
1961
1962 /* (trap expression)
1963 *
1964 * suggested use:
1965 * (match (trap expression)
1966 * ((exit-error (? err)) (error-handler err))
1967 * ((exit-ok (? v)) (value-handler v)))
1968 */
1969 336 static void eval_trap(eval_context_t *ctx) {
1970
1971 336 lbm_value expr = get_cadr(ctx->curr_exp);
1972 lbm_value retval;
1973
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 336 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 336 WITH_GC(retval, lbm_heap_allocate_list(2));
1974 336 lbm_set_car(retval, ENC_SYM_EXIT_OK); // Assume things will go well.
1975 336 lbm_uint *sptr = stack_reserve(ctx,3);
1976 336 sptr[0] = retval;
1977 336 sptr[1] = ctx->flags;
1978 336 sptr[2] = EXCEPTION_HANDLER;
1979 336 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN;
1980 336 ctx->curr_exp = expr;
1981 336 }
1982
1983 // (let list-of-binding s
1984 // body-exp)
1985 123260480 static void eval_let(eval_context_t *ctx) {
1986 123260480 lbm_value env = ctx->curr_env;
1987 lbm_value parts[3];
1988 123260480 extract_n(ctx->curr_exp, parts, 3);
1989 123260480 let_bind_values_eval(parts[1], parts[2], env, ctx);
1990 123260480 }
1991
1992 // (and exp0 ... expN)
1993 1970388 static void eval_and(eval_context_t *ctx) {
1994 1970388 lbm_value rest = get_cdr(ctx->curr_exp);
1995
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 1970388 times.
 1970388 if (lbm_is_symbol_nil(rest)) {
1996 ✗ ctx->app_cont = true;
1997 ✗ ctx->r = ENC_SYM_TRUE;
1998 } else {
1999 1970388 lbm_value *sptr = stack_reserve(ctx, 3);
2000 1970388 sptr[0] = ctx->curr_env;
2001 1970388 sptr[1] = get_cdr(rest);
2002 1970388 sptr[2] = AND;
2003 1970388 ctx->curr_exp = get_car(rest);
2004 }
2005 1970388 }
2006
2007 // (or exp0 ... expN)
2008 7196 static void eval_or(eval_context_t *ctx) {
2009 7196 lbm_value rest = get_cdr(ctx->curr_exp);
2010
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 7196 times.
 7196 if (lbm_is_symbol_nil(rest)) {
2011 ✗ ctx->app_cont = true;
2012 ✗ ctx->r = ENC_SYM_NIL;
2013 } else {
2014 7196 lbm_value *sptr = stack_reserve(ctx, 3);
2015 7196 sptr[0] = ctx->curr_env;
2016 7196 sptr[1] = get_cdr(rest);
2017 7196 sptr[2] = OR;
2018 7196 ctx->curr_exp = get_car(rest);
2019 }
2020 7196 }
2021
2022 // Pattern matching
2023 // format:
2024 // (match e (pattern body)
2025 // (pattern body)
2026 // ... )
2027 //
2028 // There can be an optional pattern guard:
2029 // (match e (pattern guard body)
2030 // ... )
2031 // a guard is a boolean expression.
2032 // Guards make match, pattern matching more complicated
2033 // than the recv pattern matching and requires staged execution
2034 // via the continuation system rather than a while loop over a list.
2035 3052 static void eval_match(eval_context_t *ctx) {
2036
2037 3052 lbm_value rest = get_cdr(ctx->curr_exp);
2038
1/4
✗ Branch 1 not taken.
✓ Branch 2 taken 3052 times.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
 3052 if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
2039 rest == ENC_SYM_NIL) {
2040 // Someone wrote the program (match)
2041 ✗ ctx->app_cont = true;
2042 ✗ ctx->r = ENC_SYM_NIL;
2043 } else {
2044 lbm_value cdr_rest;
2045 3052 get_car_and_cdr(rest, &ctx->curr_exp, &cdr_rest);
2046 3052 lbm_value *sptr = stack_reserve(ctx, 3);
2047 3052 sptr[0] = cdr_rest;
2048 3052 sptr[1] = ctx->curr_env;
2049 3052 sptr[2] = MATCH;
2050 }
2051 3052 }
2052
2053 8376 static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool timeout) {
2054
2/2
✓ Branch 0 taken 2942 times.
✓ Branch 1 taken 5434 times.
 8376 if (ctx->num_mail == 0) {
2055
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2942 times.
 2942 if (timeout) {
2056 ✗ block_current_ctx(LBM_THREAD_STATE_TIMEOUT, S_TO_US(timeout_time), false);
2057 } else {
2058 2942 block_current_ctx(LBM_THREAD_STATE_BLOCKED,0,false);
2059 }
2060 } else {
2061 5434 lbm_value *msgs = ctx->mailbox;
2062 5434 lbm_uint num = ctx->num_mail;
2063
2064
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 5434 times.
 5434 if (lbm_is_symbol_nil(pats)) {
2065 /* A receive statement without any patterns */
2066 ✗ ctx->app_cont = true;
2067 ✗ ctx->r = ENC_SYM_NIL;
2068 } else {
2069 /* The common case */
2070 lbm_value e;
2071 5434 lbm_value new_env = ctx->curr_env;
2072 5434 int n = find_match(pats, msgs, num, &e, &new_env);
2073
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5434 times.
 5434 if (n == FM_NEED_GC) {
2074 ✗ gc();
2075 ✗ new_env = ctx->curr_env;
2076 ✗ n = find_match(pats, msgs, num, &e, &new_env);
2077 ✗ if (n == FM_NEED_GC) {
2078 ✗ error_ctx(ENC_SYM_MERROR);
2079 }
2080 }
2081
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5434 times.
 5434 if (n == FM_PATTERN_ERROR) {
2082 ✗ lbm_set_error_reason("Incorrect pattern format for recv");
2083 ✗ error_at_ctx(ENC_SYM_EERROR,pats);
2084
2/2
✓ Branch 0 taken 5432 times.
✓ Branch 1 taken 2 times.
 5434 } else if (n >= 0 ) { /* Match */
2085 5432 mailbox_remove_mail(ctx, (lbm_uint)n);
2086 5432 ctx->curr_env = new_env;
2087 5432 ctx->curr_exp = e;
2088 } else { /* No match go back to sleep */
2089 2 ctx->r = ENC_SYM_NO_MATCH;
2090
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2 times.
 2 if (timeout) {
2091 ✗ block_current_ctx(LBM_THREAD_STATE_TIMEOUT,S_TO_US(timeout_time),false);
2092 } else {
2093 2 block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0,false);
2094 }
2095 }
2096 }
2097 }
2098 8376 return;
2099 }
2100
2101 ✗ static void eval_receive_timeout(eval_context_t *ctx) {
2102 ✗ if (is_atomic) {
2103 ✗ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2104 ✗ error_ctx(ENC_SYM_EERROR);
2105 }
2106 ✗ lbm_value timeout_val = get_cadr(ctx->curr_exp);
2107 ✗ if (!lbm_is_number(timeout_val)) {
2108 ✗ error_ctx(ENC_SYM_EERROR);
2109 }
2110 ✗ float timeout_time = lbm_dec_as_float(timeout_val);
2111 ✗ lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2112 ✗ receive_base(ctx, pats, timeout_time, true);
2113 ✗ }
2114
2115 // Receive
2116 // (recv (pattern expr)
2117 // (pattern expr))
2118 8376 static void eval_receive(eval_context_t *ctx) {
2119
2120
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8376 times.
 8376 if (is_atomic) {
2121 ✗ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2122 ✗ error_at_ctx(ENC_SYM_EERROR, ctx->curr_exp);
2123 }
2124 8376 lbm_value pats = get_cdr(ctx->curr_exp);
2125 8376 receive_base(ctx, pats, 0, false);
2126 8376 }
2127
2128 /*********************************************************/
2129 /* Continuation functions */
2130
2131 /* cont_set_global_env
2132 sp-1 : Key-symbol
2133 */
2134 4243848 static void cont_set_global_env(eval_context_t *ctx){
2135
2136 lbm_value key;
2137 4243848 lbm_value val = ctx->r;
2138
2139 4243848 lbm_pop(&ctx->K, &key);
2140 4243848 lbm_uint dec_key = lbm_dec_sym(key);
2141 4243848 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
2142 4243848 lbm_value *global_env = lbm_get_global_env();
2143 4243848 lbm_uint orig_env = global_env[ix_key];
2144 lbm_value new_env;
2145 // A key is a symbol and should not need to be remembered.
2146
3/4
✓ Branch 2 taken 2562 times.
✓ Branch 3 taken 4241286 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 2562 times.
 4243848 WITH_GC(new_env, lbm_env_set(orig_env,key,val));
2147
2148 4243848 global_env[ix_key] = new_env;
2149 4243848 ctx->r = val;
2150
2151 4243848 ctx->app_cont = true;
2152
2153 4243848 return;
2154 }
2155
2156 4508 static void cont_resume(eval_context_t *ctx) {
2157 4508 lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
2158 4508 }
2159
2160 69435231 static void cont_progn_rest(eval_context_t *ctx) {
2161 69435231 lbm_value *sptr = get_stack_ptr(ctx, 3);
2162
2163 69435231 lbm_value rest = sptr[2];
2164 69435231 lbm_value env = sptr[0];
2165
2166 lbm_value rest_car, rest_cdr;
2167 69435231 get_car_and_cdr(rest, &rest_car, &rest_cdr);
2168 69435231 ctx->curr_exp = rest_car;
2169 69435231 ctx->curr_env = env;
2170
2/2
✓ Branch 1 taken 67129653 times.
✓ Branch 2 taken 2305578 times.
 69435231 if (lbm_is_symbol_nil(rest_cdr)) {
2171 // allow for tail recursion
2172 67129653 lbm_stack_drop(&ctx->K, 3);
2173 } else {
2174 2305578 sptr[2] = rest_cdr;
2175 2305578 stack_reserve(ctx, 1)[0] = PROGN_REST;
2176 }
2177 69435231 }
2178
2179 28 static void cont_wait(eval_context_t *ctx) {
2180
2181 lbm_value cid_val;
2182 28 lbm_pop(&ctx->K, &cid_val);
2183 28 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2184
2185 28 bool exists = false;
2186
2187 28 lbm_blocked_iterator(context_exists, &cid, &exists);
2188 28 lbm_running_iterator(context_exists, &cid, &exists);
2189
2190
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (ctx_running->id == cid) {
2191 ✗ exists = true;
2192 }
2193
2194
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (exists) {
2195 ✗ lbm_value *sptr = stack_reserve(ctx, 2);
2196 ✗ sptr[0] = lbm_enc_i(cid);
2197 ✗ sptr[1] = WAIT;
2198 ✗ ctx->r = ENC_SYM_TRUE;
2199 ✗ ctx->app_cont = true;
2200 ✗ yield_ctx(50000);
2201 } else {
2202 28 ctx->r = ENC_SYM_TRUE;
2203 28 ctx->app_cont = true;
2204 }
2205 28 }
2206
2207 1767164 static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2208
2209 1767164 lbm_uint s = lbm_dec_sym(key);
2210
1/2
✓ Branch 0 taken 1767164 times.
✗ Branch 1 not taken.
 1767164 if (s >= RUNTIME_SYMBOLS_START) {
2211 1767164 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2212
3/4
✓ Branch 1 taken 841176 times.
✓ Branch 2 taken 925988 times.
✓ Branch 3 taken 841176 times.
✗ Branch 4 not taken.
 1767164 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2213 841176 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK;
2214 841176 lbm_value *glob_env = lbm_get_global_env();
2215 841176 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2216 841176 glob_env[ix_key] = new_env;
2217 }
2218
1/4
✗ Branch 1 not taken.
✓ Branch 2 taken 1767164 times.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
 1767164 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2219 ✗ lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2220 ✗ error_at_ctx(ENC_SYM_NOT_FOUND, key);
2221 }
2222 1767164 return val;
2223 }
2224 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2225 ✗ return ENC_SYM_NIL; // unreachable
2226 }
2227
2228 308 static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2229
2/4
✓ Branch 0 taken 308 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 308 times.
✗ Branch 4 not taken.
 308 if (nargs == 2 && lbm_is_symbol(args[0])) {
2230 lbm_value res;
2231
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 308 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 308 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env));
2232 308 ctx->r = args[1];
2233 308 lbm_stack_drop(&ctx->K, nargs+1);
2234 308 ctx->app_cont = true;
2235 } else {
2236 ✗ if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2237 ✗ else lbm_set_error_reason((char*)lbm_error_str_num_args);
2238 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2239 }
2240 308 }
2241
2242 34720 static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool program, bool incremental) {
2243
2/2
✓ Branch 0 taken 34692 times.
✓ Branch 1 taken 28 times.
 34720 if (nargs == 1) {
2244 34692 lbm_value chan = ENC_SYM_NIL;
2245
2/2
✓ Branch 1 taken 12740 times.
✓ Branch 2 taken 21952 times.
 34692 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY) {
2246
2/2
✓ Branch 2 taken 190 times.
✓ Branch 3 taken 12550 times.
 12740 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2247 190 gc();
2248
1/2
✗ Branch 2 not taken.
✓ Branch 3 taken 190 times.
 190 if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
2249 ✗ error_ctx(ENC_SYM_MERROR);
2250 }
2251 }
2252
1/2
✓ Branch 1 taken 21952 times.
✗ Branch 2 not taken.
 21952 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL) {
2253 21952 chan = args[0];
2254 } else {
2255 ✗ error_ctx(ENC_SYM_EERROR);
2256 }
2257 34692 lbm_value *sptr = get_stack_ptr(ctx, 2);
2258
2259 // If we are inside a reader, its settings are stored.
2260 34692 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2261 34692 sptr[1] = chan;
2262 34692 lbm_value *rptr = stack_reserve(ctx,1);
2263 34692 rptr[0] = READ_DONE;
2264
2265 // Each reader starts in a fresh situation
2266 34692 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
2267
2268
2/2
✓ Branch 0 taken 17920 times.
✓ Branch 1 taken 16772 times.
 34692 if (program) {
2269
2/2
✓ Branch 0 taken 8806 times.
✓ Branch 1 taken 9114 times.
 17920 if (incremental) {
2270 8806 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2271 8806 lbm_value *rptr1 = stack_reserve(ctx,3);
2272 8806 rptr1[0] = chan;
2273 8806 rptr1[1] = ctx->curr_env;
2274 8806 rptr1[2] = READ_EVAL_CONTINUE;
2275 } else {
2276 9114 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2277 9114 lbm_value *rptr1 = stack_reserve(ctx,4);
2278 9114 rptr1[0] = ENC_SYM_NIL;
2279 9114 rptr1[1] = ENC_SYM_NIL;
2280 9114 rptr1[2] = chan;
2281 9114 rptr1[3] = READ_APPEND_CONTINUE;
2282 }
2283 }
2284 34692 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2285 34692 rptr[0] = chan;
2286 34692 rptr[1] = lbm_enc_u(1);
2287 34692 rptr[2] = READ_NEXT_TOKEN;
2288 34692 ctx->app_cont = true;
2289 } else {
2290 28 lbm_set_error_reason((char*)lbm_error_str_num_args);
2291 28 error_ctx(ENC_SYM_EERROR);
2292 }
2293 34692 }
2294
2295 9142 static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2296 9142 apply_read_base(args,nargs,ctx,true,false);
2297 9114 }
2298
2299 8806 static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2300 8806 apply_read_base(args,nargs,ctx,true,true);
2301 8806 }
2302
2303 16772 static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2304 16772 apply_read_base(args,nargs,ctx,false,false);
2305 16772 }
2306
2307 784 static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2308
2309 784 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE;
2310 784 lbm_uint closure_pos = 0;
2311 784 char *name = NULL;
2312
2313
3/4
✓ Branch 0 taken 784 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 728 times.
✓ Branch 3 taken 56 times.
 1568 if (nargs >= 1 &&
2314 784 lbm_is_closure(args[0])) {
2315 728 closure_pos = 0;
2316
2/4
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 56 times.
✗ Branch 3 not taken.
 112 } else if (nargs >= 2 &&
2317
1/2
✓ Branch 1 taken 56 times.
✗ Branch 2 not taken.
 112 lbm_is_number(args[0]) &&
2318 56 lbm_is_closure(args[1])) {
2319 56 stack_size = lbm_dec_as_u32(args[0]);
2320 56 closure_pos = 1;
2321 ✗ } else if (nargs >= 2 &&
2322 ✗ lbm_is_array_r(args[0]) &&
2323 ✗ lbm_is_closure(args[1])) {
2324 ✗ name = lbm_dec_str(args[0]);
2325 ✗ closure_pos = 1;
2326 ✗ }else if (nargs >= 3 &&
2327 ✗ lbm_is_array_r(args[0]) &&
2328 ✗ lbm_is_number(args[1]) &&
2329 ✗ lbm_is_closure(args[2])) {
2330 ✗ stack_size = lbm_dec_as_u32(args[1]);
2331 ✗ closure_pos = 2;
2332 ✗ name = lbm_dec_str(args[0]);
2333 } else {
2334 ✗ if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP)
2335 ✗ error_at_ctx(ENC_SYM_TERROR,ENC_SYM_SPAWN_TRAP);
2336 else
2337 ✗ error_at_ctx(ENC_SYM_TERROR,ENC_SYM_SPAWN);
2338 }
2339
2340 lbm_value cl[3];
2341 784 extract_n(get_cdr(args[closure_pos]), cl, 3);
2342 784 lbm_value curr_param = cl[CLO_PARAMS];
2343 784 lbm_value clo_env = cl[CLO_ENV];
2344 784 lbm_uint i = closure_pos + 1;
2345
3/4
✓ Branch 1 taken 588 times.
✓ Branch 2 taken 784 times.
✓ Branch 3 taken 588 times.
✗ Branch 4 not taken.
 1372 while (lbm_is_cons(curr_param) && i <= nargs) {
2346 588 lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
2347 588 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL);
2348 588 clo_env = aug_env;
2349 588 curr_param = get_cdr(curr_param);
2350 588 i ++;
2351 }
2352
2353 784 lbm_stack_drop(&ctx->K, nargs+1);
2354
2355 784 lbm_value program = cons_with_gc(cl[CLO_BODY], ENC_SYM_NIL, clo_env);
2356
2357 784 lbm_cid cid = lbm_create_ctx_parent(program,
2358 clo_env,
2359 stack_size,
2360 lbm_get_current_cid(),
2361 context_flags,
2362 name);
2363 784 ctx->r = lbm_enc_i(cid);
2364 784 ctx->app_cont = true;
2365 784 }
2366
2367 504 static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2368 504 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING);
2369 504 }
2370
2371 280 static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2372 280 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP);
2373 280 }
2374
2375 28394 static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2376
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28394 times.
 28394 if (is_atomic) {
2377 ✗ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2378 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_YIELD);
2379 }
2380
2/4
✓ Branch 0 taken 28394 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 28394 times.
✗ Branch 4 not taken.
 56788 if (nargs == 1 && lbm_is_number(args[0])) {
2381 28394 lbm_uint ts = lbm_dec_as_u32(args[0]);
2382 28394 lbm_stack_drop(&ctx->K, nargs+1);
2383 28394 yield_ctx(ts);
2384 } else {
2385 ✗ lbm_set_error_reason((char*)lbm_error_str_no_number);
2386 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_YIELD);
2387 }
2388 28394 }
2389
2390 28 static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2391
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (is_atomic) {
2392 ✗ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2393 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SLEEP);
2394 }
2395
2/4
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 28 times.
✗ Branch 4 not taken.
 56 if (nargs == 1 && lbm_is_number(args[0])) {
2396 28 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2397 28 lbm_stack_drop(&ctx->K, nargs+1);
2398 28 yield_ctx(ts);
2399 } else {
2400 ✗ lbm_set_error_reason((char*)lbm_error_str_no_number);
2401 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_SLEEP);
2402 }
2403 28 }
2404
2405 28 static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2406
2/4
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 28 times.
✗ Branch 4 not taken.
 56 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I) {
2407 28 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2408 28 lbm_value *sptr = get_stack_ptr(ctx, 2);
2409 28 sptr[0] = lbm_enc_i(cid);
2410 28 sptr[1] = WAIT;
2411 28 ctx->r = ENC_SYM_TRUE;
2412 28 ctx->app_cont = true;
2413 28 yield_ctx(50000);
2414 } else {
2415 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_WAIT);
2416 }
2417 28 }
2418
2419 /* (eval expr)
2420 (eval env expr) */
2421 2061192 static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2422
1/2
✓ Branch 0 taken 2061192 times.
✗ Branch 1 not taken.
 2061192 if ( nargs == 1) {
2423 2061192 ctx->curr_exp = args[0];
2424 ✗ } else if (nargs == 2) {
2425 ✗ ctx->curr_exp = args[1];
2426 ✗ ctx->curr_env = args[0];
2427 } else {
2428 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
2429 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL);
2430 }
2431 2061192 lbm_stack_drop(&ctx->K, nargs+1);
2432 2061192 }
2433
2434 9338 static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2435 9338 int prg_pos = 0;
2436
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 9338 times.
 9338 if (nargs == 2) {
2437 ✗ prg_pos = 1;
2438 ✗ ctx->curr_env = args[0];
2439 }
2440
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 9338 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 9338 if (nargs == 1 || nargs == 2) {
2441 9338 lbm_value prg = args[prg_pos];
2442 lbm_value app_cont;
2443 lbm_value app_cont_prg;
2444 lbm_value new_prg;
2445 lbm_value prg_copy;
2446
2447 9338 int len = -1;
2448
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 9338 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 9338 WITH_GC(prg_copy, lbm_list_copy(&len, prg));
2449 9338 lbm_stack_drop(&ctx->K, nargs+1);
2450
2451
2/2
✓ Branch 0 taken 602 times.
✓ Branch 1 taken 8736 times.
 9338 if (ctx->K.sp > nargs+2) { // if there is a continuation
2452 602 app_cont = cons_with_gc(ENC_SYM_APP_CONT, ENC_SYM_NIL, prg_copy);
2453 602 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL, prg_copy);
2454 602 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2455 602 new_prg = lbm_list_append(prg_copy, new_prg);
2456 } else {
2457 8736 new_prg = lbm_list_append(prg_copy, ctx->program);
2458 }
2459
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 9338 times.
 9338 if (!lbm_is_list(new_prg)) {
2460 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL_PROGRAM);
2461 }
2462 9338 stack_reserve(ctx, 1)[0] = DONE;
2463 9338 ctx->program = get_cdr(new_prg);
2464 9338 ctx->curr_exp = get_car(new_prg);
2465 } else {
2466 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
2467 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL_PROGRAM);
2468 }
2469 9338 }
2470
2471 3220 static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2472
1/2
✓ Branch 0 taken 3220 times.
✗ Branch 1 not taken.
 3220 if (nargs == 2) {
2473
1/2
✓ Branch 1 taken 3220 times.
✗ Branch 2 not taken.
 3220 if (lbm_type_of(args[0]) == LBM_TYPE_I) {
2474 3220 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2475 3220 lbm_value msg = args[1];
2476 3220 lbm_value status = lbm_find_receiver_and_send(cid, msg);
2477 /* return the status */
2478 3220 lbm_stack_drop(&ctx->K, nargs+1);
2479 3220 ctx->r = status;
2480 3220 ctx->app_cont = true;
2481 } else {
2482 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_SEND);
2483 }
2484 } else {
2485 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
2486 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SEND);
2487 }
2488 3220 }
2489
2490 ✗ static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2491 ✗ lbm_value ok_val = ENC_SYM_TRUE;
2492 ✗ if (nargs >= 1) {
2493 ✗ ok_val = args[0];
2494 }
2495 ✗ ctx->r = ok_val;
2496 ✗ ok_ctx();
2497 ✗ }
2498
2499 ✗ static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2500 (void) ctx;
2501 ✗ lbm_value err_val = ENC_SYM_EERROR;
2502 ✗ if (nargs >= 1) {
2503 ✗ err_val = args[0];
2504 }
2505 ✗ error_at_ctx(err_val, ENC_SYM_EXIT_ERROR);
2506 ✗ }
2507
2508 // (map f arg-list)
2509 728 static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2510
3/4
✓ Branch 0 taken 728 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 616 times.
✓ Branch 4 taken 112 times.
 728 if (nargs == 2 && lbm_is_cons(args[1])) {
2511 616 lbm_value *sptr = get_stack_ptr(ctx, 3);
2512
2513 616 lbm_value f = args[0];
2514 616 lbm_value h = get_car(args[1]);
2515 616 lbm_value t = get_cdr(args[1]);
2516
2517 lbm_value appli_1;
2518 lbm_value appli;
2519
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 616 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 616 WITH_GC(appli_1, lbm_heap_allocate_list(2));
2520
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 616 times.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
 616 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1);
2521
2522 616 lbm_value appli_0 = get_cdr(appli_1);
2523
2524 616 lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL);
2525 616 lbm_set_car(appli_1, ENC_SYM_QUOTE);
2526
2527 616 lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL);
2528 616 lbm_set_car(appli, f);
2529
2530 616 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, appli);
2531 616 sptr[0] = t; // reuse stack space
2532 616 sptr[1] = ctx->curr_env;
2533 616 sptr[2] = elt;
2534 616 lbm_value *rptr = stack_reserve(ctx,4);
2535 616 rptr[0] = elt;
2536 616 rptr[1] = appli;
2537 616 rptr[2] = appli_0;
2538 616 rptr[3] = MAP;
2539 616 ctx->curr_exp = appli;
2540
2/4
✓ Branch 0 taken 112 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 112 times.
✗ Branch 4 not taken.
 112 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
2541 112 lbm_stack_drop(&ctx->K, 3);
2542 112 ctx->r = ENC_SYM_NIL;
2543 112 ctx->app_cont = true;
2544 112 return;
2545 } else {
2546 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
2547 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_MAP);
2548 }
2549 }
2550
2551 140 static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2552
2/4
✓ Branch 0 taken 140 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 140 times.
✗ Branch 4 not taken.
 140 if (nargs == 1 && lbm_is_list(args[0])) {
2553 140 lbm_value curr = args[0];
2554
2555 140 lbm_value new_list = ENC_SYM_NIL;
2556
2/2
✓ Branch 1 taken 3192 times.
✓ Branch 2 taken 140 times.
 3332 while (lbm_is_cons(curr)) {
2557 3192 lbm_value tmp = cons_with_gc(get_car(curr), new_list, ENC_SYM_NIL);
2558 3192 new_list = tmp;
2559 3192 curr = get_cdr(curr);
2560 }
2561 140 lbm_stack_drop(&ctx->K, 2);
2562 140 ctx->r = new_list;
2563 140 ctx->app_cont = true;
2564 } else {
2565 ✗ lbm_set_error_reason("Reverse requires a list argument");
2566 ✗ error_at_ctx(ENC_SYM_EERROR, ENC_SYM_REVERSE);
2567 }
2568 140 }
2569
2570 280 static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2571
1/2
✓ Branch 0 taken 280 times.
✗ Branch 1 not taken.
 280 if (nargs == 1) {
2572
2573 280 lbm_value v = flatten_value(args[0]);
2574
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 280 times.
 280 if ( v == ENC_SYM_MERROR) {
2575 ✗ gc();
2576 ✗ v = flatten_value(args[0]);
2577 }
2578
2579
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 280 times.
 280 if (lbm_is_symbol(v)) {
2580 ✗ error_at_ctx(v, ENC_SYM_FLATTEN);
2581 } else {
2582 280 lbm_stack_drop(&ctx->K, 2);
2583 280 ctx->r = v;
2584 280 ctx->app_cont = true;
2585 }
2586 280 return;
2587 }
2588 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_FLATTEN);
2589 }
2590
2591 252 static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2592
2/4
✓ Branch 0 taken 252 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 252 times.
✗ Branch 4 not taken.
 252 if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY) {
2593 lbm_array_header_t *array;
2594 252 array = (lbm_array_header_t *)get_car(args[0]);
2595
2596 lbm_flat_value_t fv;
2597 252 fv.buf = (uint8_t*)array->data;
2598 252 fv.buf_size = array->size;
2599 252 fv.buf_pos = 0;
2600
2601 lbm_value res;
2602
2603 252 ctx->r = ENC_SYM_NIL;
2604
1/2
✓ Branch 1 taken 252 times.
✗ Branch 2 not taken.
 252 if (lbm_unflatten_value(&fv, &res)) {
2605 252 ctx->r = res;
2606 }
2607 252 lbm_stack_drop(&ctx->K, 2);
2608 252 ctx->app_cont = true;
2609 252 return;
2610 }
2611 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_UNFLATTEN);
2612 }
2613
2614 ✗ static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2615 ✗ if (nargs == 2 && lbm_is_number(args[0])) {
2616 ✗ lbm_cid cid = lbm_dec_as_i32(args[0]);
2617
2618 ✗ if (ctx->id == cid) {
2619 ✗ ctx->r = args[1];
2620 ✗ finish_ctx();
2621 ✗ return;
2622 }
2623 ✗ mutex_lock(&qmutex);
2624 ✗ eval_context_t *found = NULL;
2625 ✗ found = lookup_ctx_nm(&blocked, cid);
2626 ✗ if (found)
2627 ✗ drop_ctx_nm(&blocked, found);
2628 else
2629 ✗ found = lookup_ctx_nm(&queue, cid);
2630 ✗ if (found)
2631 ✗ drop_ctx_nm(&queue, found);
2632
2633 ✗ if (found) {
2634 ✗ found->K.data[found->K.sp - 1] = KILL;
2635 ✗ found->r = args[1];
2636 ✗ found->app_cont = true;
2637 ✗ enqueue_ctx_nm(&queue,found);
2638 ✗ ctx->r = ENC_SYM_TRUE;
2639 } else {
2640 ✗ ctx->r = ENC_SYM_NIL;
2641 }
2642 ✗ lbm_stack_drop(&ctx->K, 3);
2643 ✗ ctx->app_cont = true;
2644 ✗ mutex_unlock(&qmutex);
2645 ✗ return;
2646 }
2647 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_KILL);
2648 }
2649
2650 // (merge comparator list1 list2)
2651 392 static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2652
3/6
✓ Branch 0 taken 392 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 392 times.
✗ Branch 4 not taken.
✓ Branch 6 taken 392 times.
✗ Branch 7 not taken.
 392 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
2653
2654
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 392 times.
 392 if (!lbm_is_closure(args[0])) {
2655 lbm_value closure;
2656 ✗ WITH_GC(closure, lbm_heap_allocate_list(4));
2657 ✗ lbm_set_car(closure, ENC_SYM_CLOSURE);
2658 ✗ lbm_value cl1 = lbm_cdr(closure);
2659 lbm_value par;
2660 ✗ WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure);
2661 ✗ lbm_set_car(cl1, par);
2662 ✗ lbm_value cl2 = lbm_cdr(cl1);
2663 lbm_value body;
2664 ✗ WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure);
2665 ✗ lbm_set_car(cl2, body);
2666 ✗ lbm_value cl3 = lbm_cdr(cl2);
2667 ✗ lbm_set_car(cl3, ENC_SYM_NIL);
2668
2669 // Replace operator on stack with closure and rest of the code is
2670 // compatible.
2671 ✗ args[0] = closure;
2672 }
2673
2674 // Copy input lists for functional behaviour at top-level
2675 // merge itself is in-place in the copied lists.
2676 lbm_value a;
2677 lbm_value b;
2678 392 int len_a = -1;
2679 392 int len_b = -1;
2680
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 392 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 392 WITH_GC(a, lbm_list_copy(&len_a, args[1]));
2681
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 392 times.
✗ Branch 8 not taken.
✗ Branch 9 not taken.
 392 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a);
2682
2683
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 336 times.
 392 if (len_a == 0) {
2684 56 ctx->r = b;
2685 56 lbm_stack_drop(&ctx->K, 4);
2686 56 ctx->app_cont = true;
2687 56 return;
2688 }
2689
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 280 times.
 336 if (len_b == 0) {
2690 56 ctx->r = a;
2691 56 lbm_stack_drop(&ctx->K, 4);
2692 56 ctx->app_cont = true;
2693 56 return;
2694 }
2695
2696 280 args[1] = a; // keep safe by replacing the original on stack.
2697 280 args[2] = b;
2698
2699 280 lbm_value a_1 = a;
2700 280 lbm_value a_rest = lbm_cdr(a);
2701 280 lbm_value b_1 = b;
2702 280 lbm_value b_rest = lbm_cdr(b);
2703
2704 lbm_value cl[3]; // Comparator closure
2705 280 extract_n(lbm_cdr(args[0]), cl, 3);
2706 280 lbm_value cmp_env = cl[CLO_ENV];
2707 280 lbm_value par1 = ENC_SYM_NIL;
2708 280 lbm_value par2 = ENC_SYM_NIL;
2709 280 lbm_uint len = lbm_list_length(cl[CLO_PARAMS]);
2710
1/2
✓ Branch 0 taken 280 times.
✗ Branch 1 not taken.
 280 if (len == 2) {
2711 280 par1 = get_car(cl[CLO_PARAMS]);
2712 280 par2 = get_cadr(cl[CLO_PARAMS]);
2713 lbm_value new_env0;
2714 lbm_value new_env;
2715
1/4
✗ Branch 3 not taken.
✓ Branch 4 taken 280 times.
✗ Branch 9 not taken.
✗ Branch 10 not taken.
 280 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)));
2716
1/4
✗ Branch 3 not taken.
✓ Branch 4 taken 280 times.
✗ Branch 10 not taken.
✗ Branch 11 not taken.
 280 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0);
2717 280 cmp_env = new_env;
2718 } else {
2719 ✗ error_at_ctx(ENC_SYM_TERROR, args[0]);
2720 }
2721 280 lbm_set_cdr(a_1, b_1);
2722 280 lbm_set_cdr(b_1, ENC_SYM_NIL);
2723 280 lbm_value cmp = cl[CLO_BODY];
2724
2725 280 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
2726 280 lbm_uint *sptr = stack_reserve(ctx, 10);
2727 280 sptr[0] = ENC_SYM_NIL; // head of merged list
2728 280 sptr[1] = ENC_SYM_NIL; // last of merged list
2729 280 sptr[2] = a_1;
2730 280 sptr[3] = a_rest;
2731 280 sptr[4] = b_rest;
2732 280 sptr[5] = cmp;
2733 280 sptr[6] = cmp_env;
2734 280 sptr[7] = par1;
2735 280 sptr[8] = par2;
2736 280 sptr[9] = MERGE_REST;
2737 280 ctx->curr_exp = cl[CLO_BODY];
2738 280 ctx->curr_env = cmp_env;
2739 280 return;
2740 }
2741 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_MERGE);
2742 }
2743
2744 // (sort comparator list)
2745 283136 static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2746
2/4
✓ Branch 0 taken 283136 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 283136 times.
✗ Branch 4 not taken.
 283136 if (nargs == 2 && lbm_is_list(args[1])) {
2747
2748
2/2
✓ Branch 1 taken 282800 times.
✓ Branch 2 taken 336 times.
 283136 if (!lbm_is_closure(args[0])) {
2749 lbm_value closure;
2750
3/4
✓ Branch 2 taken 288 times.
✓ Branch 3 taken 282512 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 288 times.
 282800 WITH_GC(closure, lbm_heap_allocate_list(4));
2751 282800 lbm_set_car(closure, ENC_SYM_CLOSURE);
2752 282800 lbm_value cl1 = lbm_cdr(closure);
2753 lbm_value par;
2754
3/4
✓ Branch 2 taken 332 times.
✓ Branch 3 taken 282468 times.
✗ Branch 8 not taken.
✓ Branch 9 taken 332 times.
 282800 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure);
2755 282800 lbm_set_car(cl1, par);
2756 282800 lbm_value cl2 = lbm_cdr(cl1);
2757 lbm_value body;
2758
3/4
✓ Branch 2 taken 2658 times.
✓ Branch 3 taken 280142 times.
✗ Branch 8 not taken.
✓ Branch 9 taken 2658 times.
 282800 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, args[0], symbol_x, symbol_y), closure);
2759 282800 lbm_set_car(cl2, body);
2760 282800 lbm_value cl3 = lbm_cdr(cl2);
2761 282800 lbm_set_car(cl3, ENC_SYM_NIL);
2762
2763 // Replace operator on stack with closure and rest of the code is
2764 // compatible.
2765 282800 args[0] = closure;
2766 }
2767
2768 283136 int len = -1;
2769 lbm_value list_copy;
2770
3/4
✓ Branch 2 taken 1320 times.
✓ Branch 3 taken 281816 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 1320 times.
 283136 WITH_GC(list_copy, lbm_list_copy(&len, args[1]));
2771
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 283108 times.
 283136 if (len <= 1) {
2772 28 lbm_stack_drop(&ctx->K, 3);
2773 28 ctx->r = list_copy;
2774 28 ctx->app_cont = true;
2775 28 return;
2776 }
2777
2778 283108 args[1] = list_copy; // Keep safe, original replaced on stack.
2779
2780 // Take the headmost 2, 1-element sublists.
2781 283108 lbm_value a = list_copy;
2782 283108 lbm_value b = lbm_cdr(a);
2783 283108 lbm_value rest = lbm_cdr(b);
2784 // Do not terminate b. keep rest of list safe from GC in the following
2785 // closure extraction.
2786 //lbm_set_cdr(a, b); // This is void
2787
2788 lbm_value cl[3]; // Comparator closure
2789 283108 extract_n(lbm_cdr(args[0]), cl, 3);
2790 283108 lbm_value cmp_env = cl[CLO_ENV];
2791 283108 lbm_value par1 = ENC_SYM_NIL;
2792 283108 lbm_value par2 = ENC_SYM_NIL;
2793 283108 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS]);
2794
1/2
✓ Branch 0 taken 283108 times.
✗ Branch 1 not taken.
 283108 if (cl_len == 2) {
2795 283108 par1 = get_car(cl[CLO_PARAMS]);
2796 283108 par2 = get_cadr(cl[CLO_PARAMS]);
2797 lbm_value new_env0;
2798 lbm_value new_env;
2799
3/4
✓ Branch 3 taken 68 times.
✓ Branch 4 taken 283040 times.
✗ Branch 9 not taken.
✓ Branch 10 taken 68 times.
 283108 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
2800
3/4
✓ Branch 3 taken 6 times.
✓ Branch 4 taken 283102 times.
✗ Branch 10 not taken.
✓ Branch 11 taken 6 times.
 283108 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
2801 283108 cmp_env = new_env;
2802 } else {
2803 ✗ error_at_ctx(ENC_SYM_TERROR, args[0]);
2804 }
2805 283108 lbm_value cmp = cl[CLO_BODY];
2806
2807 // Terminate the comparator argument list.
2808 283108 lbm_set_cdr(b, ENC_SYM_NIL);
2809
2810 283108 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
2811 283108 lbm_uint *sptr = stack_reserve(ctx, 20);
2812 283108 sptr[0] = cmp;
2813 283108 sptr[1] = cmp_env;
2814 283108 sptr[2] = par1;
2815 283108 sptr[3] = par2;
2816 283108 sptr[4] = ENC_SYM_NIL; // head of merged accumulation of sublists
2817 283108 sptr[5] = ENC_SYM_NIL; // last of merged accumulation of sublists
2818 283108 sptr[6] = rest;
2819 283108 sptr[7] = lbm_enc_i(1);
2820 283108 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
2821 283108 sptr[9] = MERGE_LAYER;
2822 283108 sptr[10] = ENC_SYM_NIL; // head of merged sublist
2823 283108 sptr[11] = ENC_SYM_NIL; // last of merged sublist
2824 283108 sptr[12] = a;
2825 283108 sptr[13] = ENC_SYM_NIL; // no a_rest, 1 element lists in layer 1.
2826 283108 sptr[14] = ENC_SYM_NIL; // no b_rest, 1 element lists in layer 1.
2827 283108 sptr[15] = cmp;
2828 283108 sptr[16] = cmp_env;
2829 283108 sptr[17] = par1;
2830 283108 sptr[18] = par2;
2831 283108 sptr[19] = MERGE_REST;
2832 283108 ctx->curr_exp = cmp;
2833 283108 ctx->curr_env = cmp_env;
2834 283108 return;
2835 }
2836 ✗ error_ctx(ENC_SYM_TERROR);
2837 }
2838
2839 56000252 static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2840 lbm_value res;
2841
2/2
✓ Branch 1 taken 56000224 times.
✓ Branch 2 taken 28 times.
 56000252 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS, ctx->curr_env)) {
2842
3/4
✓ Branch 0 taken 56000084 times.
✓ Branch 1 taken 140 times.
✓ Branch 3 taken 56000084 times.
✗ Branch 4 not taken.
 56000224 if (nargs == 1 && lbm_is_number(args[0])) {
2843 56000084 int32_t ix = lbm_dec_as_i32(args[0]);
2844 56000084 res = lbm_index_list(res, ix);
2845 }
2846 56000224 ctx->r = res;
2847 } else {
2848 28 ctx->r = ENC_SYM_NIL;
2849 }
2850 56000252 lbm_stack_drop(&ctx->K, nargs+1);
2851 56000252 ctx->app_cont = true;
2852 56000252 }
2853
2854 /* (rotate list-expr dist/dir-expr) */
2855 84 static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2856
3/6
✓ Branch 0 taken 84 times.
✗ Branch 1 not taken.
✓ Branch 3 taken 84 times.
✗ Branch 4 not taken.
✓ Branch 6 taken 84 times.
✗ Branch 7 not taken.
 84 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
2857 84 int len = -1;
2858 84 lbm_value ls = ENC_SYM_NIL;
2859
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 84 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 84 WITH_GC(ls, lbm_list_copy(&len, args[0]));
2860 84 int dist = lbm_dec_as_i32(args[1]);
2861
3/4
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 28 times.
✓ Branch 2 taken 56 times.
✗ Branch 3 not taken.
 84 if (len > 0 && dist != 0) {
2862 56 int d = dist;
2863
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 28 times.
 56 if (dist > 0) {
2864 28 ls = lbm_list_destructive_reverse(ls);
2865 } else {
2866 28 d = -dist;
2867 }
2868
2869 56 lbm_value start = ls;
2870 56 lbm_value end = ENC_SYM_NIL;
2871 56 lbm_value curr = start;
2872
2/2
✓ Branch 1 taken 252 times.
✓ Branch 2 taken 56 times.
 308 while (lbm_is_cons(curr)) {
2873 252 end = curr;
2874 252 curr = get_cdr(curr);
2875 }
2876
2877
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 56 times.
 168 for (int i = 0; i < d; i ++) {
2878 112 lbm_value a = start;
2879 112 start = lbm_cdr(start);
2880 112 lbm_set_cdr(a, ENC_SYM_NIL);
2881 112 lbm_set_cdr(end, a);
2882 112 end = a;
2883 }
2884 56 ls = start;
2885
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 28 times.
 56 if (dist > 0) {
2886 28 ls = lbm_list_destructive_reverse(ls);
2887 }
2888 }
2889 84 lbm_stack_drop(&ctx->K, nargs+1);
2890 84 ctx->app_cont = true;
2891 84 ctx->r = ls;
2892 84 return;
2893 }
2894 ✗ error_ctx(ENC_SYM_EERROR);
2895 }
2896
2897 /***************************************************/
2898 /* Application lookup table */
2899
2900 typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
2901 static const apply_fun fun_table[] =
2902 {
2903 apply_setvar,
2904 apply_read,
2905 apply_read_program,
2906 apply_read_eval_program,
2907 apply_spawn,
2908 apply_spawn_trap,
2909 apply_yield,
2910 apply_wait,
2911 apply_eval,
2912 apply_eval_program,
2913 apply_send,
2914 apply_ok,
2915 apply_error,
2916 apply_map,
2917 apply_reverse,
2918 apply_flatten,
2919 apply_unflatten,
2920 apply_kill,
2921 apply_sleep,
2922 apply_merge,
2923 apply_sort,
2924 apply_rest_args,
2925 apply_rotate,
2926 };
2927
2928 /***************************************************/
2929 /* Application of function that takes arguments */
2930 /* passed over the stack. */
2931
2932 264752018 static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
2933 /* If arriving here, we know that the fun is a symbol.
2934 * and can be a built in operation or an extension.
2935 */
2936 264752018 lbm_value fun = fun_args[0];
2937
2938 264752018 lbm_uint fun_val = lbm_dec_sym(fun);
2939 264752018 lbm_uint fun_kind = SYMBOL_KIND(fun_val);
2940
2941
3/4
✓ Branch 0 taken 169086 times.
✓ Branch 1 taken 206159656 times.
✓ Branch 2 taken 58423276 times.
✗ Branch 3 not taken.
 264752018 switch (fun_kind) {
2942 169086 case SYMBOL_KIND_EXTENSION: {
2943 169086 extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr;
2944
2945 lbm_value ext_res;
2946
3/4
✓ Branch 2 taken 144 times.
✓ Branch 3 taken 168942 times.
✗ Branch 7 not taken.
✓ Branch 8 taken 144 times.
 169086 WITH_GC(ext_res, f(&fun_args[1], arg_count));
2947
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 169086 times.
 169086 if (lbm_is_error(ext_res)) { //Error other than merror
2948 ✗ error_at_ctx(ext_res, fun);
2949 }
2950 169086 lbm_stack_drop(&ctx->K, arg_count + 1);
2951
2952 169086 ctx->app_cont = true;
2953 169086 ctx->r = ext_res;
2954
2955
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 169002 times.
 169086 if (blocking_extension) {
2956 84 blocking_extension = false;
2957
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 84 times.
 84 if (blocking_extension_timeout) {
2958 ✗ blocking_extension_timeout = false;
2959 ✗ block_current_ctx(LBM_THREAD_STATE_TIMEOUT, blocking_extension_timeout_us,true);
2960 } else {
2961 84 block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0,true);
2962 }
2963 84 mutex_unlock(&blocking_extension_mutex);
2964 }
2965 169086 } break;
2966 206159656 case SYMBOL_KIND_FUNDAMENTAL:
2967 206159656 call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx);
2968 206159368 break;
2969 58423276 case SYMBOL_KIND_APPFUN:
2970 58423276 fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
2971 58423248 break;
2972 ✗ default:
2973 // Symbols that are "special" but not in the way caught above
2974 // ends up here.
2975 ✗ lbm_set_error_reason("Symbol does not represent a function");
2976 ✗ error_at_ctx(ENC_SYM_EERROR,fun_args[0]);
2977 ✗ break;
2978 }
2979 264751702 }
2980
2981 194071852 static void cont_closure_application_args(eval_context_t *ctx) {
2982 194071852 lbm_uint* sptr = get_stack_ptr(ctx, 5);
2983
2984 194071852 lbm_value arg_env = (lbm_value)sptr[0];
2985 194071852 lbm_value exp = (lbm_value)sptr[1];
2986 194071852 lbm_value clo_env = (lbm_value)sptr[2];
2987 194071852 lbm_value params = (lbm_value)sptr[3];
2988 194071852 lbm_value args = (lbm_value)sptr[4];
2989
2990 lbm_value car_params, cdr_params;
2991 194071852 get_car_and_cdr(params, &car_params, &cdr_params);
2992
2993 194071852 bool a_nil = lbm_is_symbol_nil(args);
2994 194071852 bool p_nil = lbm_is_symbol_nil(cdr_params);
2995
2996 194071852 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
2997
2998
4/4
✓ Branch 0 taken 115182060 times.
✓ Branch 1 taken 78889792 times.
✓ Branch 2 taken 87181836 times.
✓ Branch 3 taken 28000224 times.
 194071852 if (!a_nil && !p_nil) {
2999 lbm_value car_args, cdr_args;
3000 87181836 get_car_and_cdr(args, &car_args, &cdr_args);
3001 87181836 sptr[2] = binder;
3002 87181836 sptr[3] = cdr_params;
3003 87181836 sptr[4] = cdr_args;
3004 87181836 stack_reserve(ctx,1)[0] = CLOSURE_ARGS;
3005 87181836 ctx->curr_exp = car_args;
3006 87181836 ctx->curr_env = arg_env;
3007
3/4
✓ Branch 0 taken 78889792 times.
✓ Branch 1 taken 28000224 times.
✓ Branch 2 taken 78889792 times.
✗ Branch 3 not taken.
 106890016 } else if (a_nil && p_nil) {
3008 // Arguments and parameters match up in number
3009 78889792 lbm_stack_drop(&ctx->K, 5);
3010 78889792 ctx->curr_env = binder;
3011 78889792 ctx->curr_exp = exp;
3012
1/2
✓ Branch 0 taken 28000224 times.
✗ Branch 1 not taken.
 28000224 } else if (p_nil) {
3013 28000224 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, binder);
3014 28000224 sptr[2] = rest_binder;
3015 28000224 sptr[3] = get_cdr(args);
3016 28000224 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3017 28000224 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3018 28000224 ctx->curr_exp = get_car(args);
3019 28000224 ctx->curr_env = arg_env;
3020 } else {
3021 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
3022 ✗ error_ctx(ENC_SYM_EERROR);
3023 }
3024 194071852 }
3025
3026
3027 196000840 static void cont_closure_args_rest(eval_context_t *ctx) {
3028 196000840 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3029 196000840 lbm_value arg_env = (lbm_value)sptr[0];
3030 196000840 lbm_value exp = (lbm_value)sptr[1];
3031 196000840 lbm_value clo_env = (lbm_value)sptr[2];
3032 196000840 lbm_value args = (lbm_value)sptr[3];
3033 196000840 lbm_value last = (lbm_value)sptr[4];
3034 196000840 lbm_cons_t* heap = lbm_heap_state.heap;
3035
3036 196000840 lbm_value binding = lbm_heap_state.freelist;
3037
2/2
✓ Branch 0 taken 174780 times.
✓ Branch 1 taken 195826060 times.
 196000840 if (binding == ENC_SYM_NIL) {
3038 174780 gc();
3039 174780 binding = lbm_heap_state.freelist;
3040
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 174780 times.
 174780 if (binding == ENC_SYM_NIL) error_ctx(ENC_SYM_MERROR);
3041 }
3042 196000840 lbm_uint binding_ix = lbm_dec_ptr(binding);
3043 196000840 lbm_heap_state.freelist = heap[binding_ix].cdr;
3044 196000840 lbm_heap_state.num_alloc += 1;
3045 196000840 heap[binding_ix].car = ctx->r;
3046 196000840 heap[binding_ix].cdr = ENC_SYM_NIL;
3047
3048
3049 196000840 lbm_set_cdr(last, binding);
3050 196000840 sptr[4] = binding;
3051
3052
2/2
✓ Branch 0 taken 28000224 times.
✓ Branch 1 taken 168000616 times.
 196000840 if (args == ENC_SYM_NIL) {
3053 28000224 lbm_stack_drop(&ctx->K, 5);
3054 28000224 ctx->curr_env = clo_env;
3055 28000224 ctx->curr_exp = exp;
3056 } else {
3057 168000616 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3058 168000616 sptr[3] = get_cdr(args);
3059 168000616 ctx->curr_exp = get_car(args);
3060 168000616 ctx->curr_env = arg_env;
3061 }
3062 196000840 }
3063
3064 861911177 static void cont_application_args(eval_context_t *ctx) {
3065 861911177 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3066
3067 861911177 lbm_value env = sptr[0];
3068 861911177 lbm_value rest = sptr[1];
3069 861911177 lbm_value count = sptr[2];
3070
3071 861911177 ctx->curr_env = env;
3072 861911177 sptr[0] = ctx->r; // Function 1st then Arguments
3073
2/2
✓ Branch 1 taken 597159159 times.
✓ Branch 2 taken 264752018 times.
 861911177 if (lbm_is_cons(rest)) {
3074 597159159 lbm_cons_t *cell = lbm_ref_cell(rest);
3075 597159159 sptr[1] = env;
3076 597159159 sptr[2] = cell->cdr;
3077 597159159 lbm_value *rptr = stack_reserve(ctx,2);
3078 597159159 rptr[0] = count + (1 << LBM_VAL_SHIFT);
3079 597159159 rptr[1] = APPLICATION_ARGS;
3080 597159159 ctx->curr_exp = cell->car;
3081 } else {
3082 // No more arguments
3083 264752018 lbm_stack_drop(&ctx->K, 2);
3084 264752018 lbm_uint nargs = lbm_dec_u(count);
3085 264752018 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3086 264752018 application(ctx,args, nargs);
3087 }
3088 861910861 }
3089
3090 3949652 static void cont_and(eval_context_t *ctx) {
3091 lbm_value env;
3092 lbm_value rest;
3093 3949652 lbm_value arg = ctx->r;
3094 3949652 lbm_pop_2(&ctx->K, &rest, &env);
3095
2/2
✓ Branch 1 taken 280056 times.
✓ Branch 2 taken 3669596 times.
 3949652 if (lbm_is_symbol_nil(arg)) {
3096 280056 ctx->app_cont = true;
3097 280056 ctx->r = ENC_SYM_NIL;
3098
2/2
✓ Branch 1 taken 1690332 times.
✓ Branch 2 taken 1979264 times.
 3669596 } else if (lbm_is_symbol_nil(rest)) {
3099 1690332 ctx->app_cont = true;
3100 } else {
3101 1979264 lbm_value *sptr = stack_reserve(ctx, 3);
3102 1979264 sptr[0] = env;
3103 1979264 sptr[1] = get_cdr(rest);
3104 1979264 sptr[2] = AND;
3105 1979264 ctx->curr_env = env;
3106 1979264 ctx->curr_exp = get_car(rest);
3107 }
3108 3949652 }
3109
3110 15988 static void cont_or(eval_context_t *ctx) {
3111 lbm_value env;
3112 lbm_value rest;
3113 15988 lbm_value arg = ctx->r;
3114 15988 lbm_pop_2(&ctx->K, &rest, &env);
3115
2/2
✓ Branch 1 taken 840 times.
✓ Branch 2 taken 15148 times.
 15988 if (!lbm_is_symbol_nil(arg)) {
3116 840 ctx->app_cont = true;
3117
2/2
✓ Branch 1 taken 6356 times.
✓ Branch 2 taken 8792 times.
 15148 } else if (lbm_is_symbol_nil(rest)) {
3118 6356 ctx->app_cont = true;
3119 6356 ctx->r = ENC_SYM_NIL;
3120 } else {
3121 8792 lbm_value *sptr = stack_reserve(ctx, 3);
3122 8792 sptr[0] = env;
3123 8792 sptr[1] = get_cdr(rest);
3124 8792 sptr[2] = OR;
3125 8792 ctx->curr_exp = get_car(rest);
3126 8792 ctx->curr_env = env;
3127 }
3128 15988 }
3129
3130 291545940 static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3131
2/2
✓ Branch 1 taken 277544960 times.
✓ Branch 2 taken 14000980 times.
 291545940 if (lbm_type_of(key) == LBM_TYPE_SYMBOL) {
3132
2/2
✓ Branch 0 taken 2800112 times.
✓ Branch 1 taken 274744848 times.
 277544960 if (key == ENC_SYM_DONTCARE) return FB_OK;
3133 274744848 lbm_env_modify_binding(env,key,value);
3134 274744848 return FB_OK;
3135
2/4
✓ Branch 1 taken 14000980 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 14000980 times.
✗ Branch 4 not taken.
 28001960 } else if (lbm_is_cons(key) &&
3136 14000980 lbm_is_cons(value)) {
3137 14000980 int r = fill_binding_location(get_car(key), get_car(value), env);
3138
1/2
✓ Branch 0 taken 14000980 times.
✗ Branch 1 not taken.
 14000980 if (r == FB_OK) {
3139 14000980 r = fill_binding_location(get_cdr(key), get_cdr(value), env);
3140 }
3141 14000980 return r;
3142 }
3143 ✗ return FB_TYPE_ERROR;
3144 }
3145
3146 235262608 static void cont_bind_to_key_rest(eval_context_t *ctx) {
3147
3148 235262608 lbm_value *sptr = get_stack_ptr(ctx, 4);
3149
3150 235262608 lbm_value rest = sptr[1];
3151 235262608 lbm_value env = sptr[2];
3152 235262608 lbm_value key = sptr[3];
3153
3154
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 235262608 times.
 235262608 if (fill_binding_location(key, ctx->r, env) < 0) {
3155 ✗ lbm_set_error_reason("Incorrect type of name/key in let-binding");
3156 ✗ error_at_ctx(ENC_SYM_TERROR, key);
3157 }
3158
3159
2/2
✓ Branch 1 taken 112001848 times.
✓ Branch 2 taken 123260760 times.
 235262608 if (lbm_is_cons(rest)) {
3160 112001848 lbm_value car_rest = get_car(rest);
3161 lbm_value key_val[2];
3162 112001848 extract_n(car_rest, key_val, 2);
3163
3164 112001848 sptr[1] = get_cdr(rest);
3165 112001848 sptr[3] = key_val[0];
3166 112001848 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST;
3167 112001848 ctx->curr_exp = key_val[1];
3168 112001848 ctx->curr_env = env;
3169 } else {
3170 // Otherwise evaluate the expression in the populated env
3171 123260760 ctx->curr_exp = sptr[0];
3172 123260760 ctx->curr_env = env;
3173 123260760 lbm_stack_drop(&ctx->K, 4);
3174 }
3175 235262608 }
3176
3177 74915732 static void cont_if(eval_context_t *ctx) {
3178
3179 74915732 lbm_value arg = ctx->r;
3180
3181 74915732 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3182
3183 74915732 ctx->curr_env = sptr[1];
3184
2/2
✓ Branch 1 taken 74902271 times.
✓ Branch 2 taken 13461 times.
 74915732 if (lbm_is_symbol_nil(arg)) {
3185 74902271 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3186 } else {
3187 13461 ctx->curr_exp = get_car(sptr[0]); // then branch
3188 }
3189 74915732 }
3190
3191 5936 static void cont_match(eval_context_t *ctx) {
3192 5936 lbm_value e = ctx->r;
3193 5936 bool do_gc = false;
3194
3195 5936 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3196 5936 lbm_value patterns = (lbm_value)sptr[0];
3197 5936 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3198 5936 lbm_value new_env = orig_env;
3199
3200
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 5936 times.
 5936 if (lbm_is_symbol_nil(patterns)) {
3201 // no more patterns
3202 ✗ lbm_stack_drop(&ctx->K, 2);
3203 ✗ ctx->r = ENC_SYM_NO_MATCH;
3204 ✗ ctx->app_cont = true;
3205
1/2
✓ Branch 1 taken 5936 times.
✗ Branch 2 not taken.
 5936 } else if (lbm_is_cons(patterns)) {
3206 5936 lbm_value match_case = get_car(patterns);
3207 5936 lbm_value pattern = get_car(match_case);
3208 5936 lbm_value n1 = get_cadr(match_case);
3209 5936 lbm_value n2 = get_cadr(get_cdr(match_case));
3210 lbm_value body;
3211 5936 bool check_guard = false;
3212
2/2
✓ Branch 1 taken 4676 times.
✓ Branch 2 taken 1260 times.
 5936 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3213 4676 body = n1;
3214 } else {
3215 1260 body = n2;
3216 1260 check_guard = true;
3217 }
3218
3219 5936 bool is_match = match(pattern, e, &new_env, &do_gc);
3220
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5936 times.
 5936 if (do_gc) {
3221 ✗ gc();
3222 ✗ do_gc = false;
3223 ✗ new_env = orig_env;
3224 ✗ is_match = match(pattern, e, &new_env, &do_gc);
3225 ✗ if (do_gc) {
3226 ✗ error_ctx(ENC_SYM_MERROR);
3227 }
3228 }
3229
2/2
✓ Branch 0 taken 3528 times.
✓ Branch 1 taken 2408 times.
 5936 if (is_match) {
3230
2/2
✓ Branch 0 taken 1260 times.
✓ Branch 1 taken 2268 times.
 3528 if (check_guard) {
3231 1260 lbm_value *rptr = stack_reserve(ctx,5);
3232 1260 sptr[0] = get_cdr(patterns);
3233 1260 sptr[1] = ctx->curr_env;
3234 1260 rptr[0] = MATCH;
3235 1260 rptr[1] = new_env;
3236 1260 rptr[2] = body;
3237 1260 rptr[3] = e;
3238 1260 rptr[4] = MATCH_GUARD;
3239 1260 ctx->curr_env = new_env;
3240 1260 ctx->curr_exp = n1; // The guard
3241 } else {
3242 2268 lbm_stack_drop(&ctx->K, 2);
3243 2268 ctx->curr_env = new_env;
3244 2268 ctx->curr_exp = body;
3245 }
3246 } else {
3247 // set up for checking of next pattern
3248 2408 sptr[0] = get_cdr(patterns);
3249 2408 sptr[1] = orig_env;
3250 2408 stack_reserve(ctx,1)[0] = MATCH;
3251 // leave r unaltered
3252 2408 ctx->app_cont = true;
3253 }
3254 } else {
3255 ✗ error_at_ctx(ENC_SYM_TERROR, ENC_SYM_MATCH);
3256 }
3257 5936 }
3258
3259 224 static void cont_exit_atomic(eval_context_t *ctx) {
3260 224 is_atomic --;
3261 224 ctx->app_cont = true;
3262 224 }
3263
3264 2016 static void cont_map(eval_context_t *ctx) {
3265 2016 lbm_value *sptr = get_stack_ptr(ctx, 6);
3266
3267 2016 lbm_value ls = sptr[0];
3268 2016 lbm_value env = sptr[1];
3269 2016 lbm_value t = sptr[3];
3270 2016 lbm_set_car(t, ctx->r); // update car field tailmost position.
3271
2/2
✓ Branch 1 taken 1400 times.
✓ Branch 2 taken 616 times.
 2016 if (lbm_is_cons(ls)) {
3272 lbm_value next, rest;
3273 1400 get_car_and_cdr(ls, &next, &rest);
3274 1400 sptr[0] = rest;
3275 1400 stack_reserve(ctx,1)[0] = MAP;
3276 1400 lbm_set_car(sptr[5], next); // new arguments
3277
3278 1400 lbm_value elt = cons_with_gc(ENC_SYM_NIL, ENC_SYM_NIL, ENC_SYM_NIL);
3279 1400 lbm_set_cdr(t, elt);
3280 1400 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3281 1400 ctx->curr_exp = sptr[4];
3282 1400 ctx->curr_env = env;
3283 } else {
3284 616 ctx->r = sptr[2]; //head of result list
3285 616 ctx->curr_env = env;
3286 616 lbm_stack_drop(&ctx->K, 6);
3287 616 ctx->app_cont = true;
3288 }
3289 2016 }
3290
3291 1260 static void cont_match_guard(eval_context_t *ctx) {
3292
2/2
✓ Branch 1 taken 476 times.
✓ Branch 2 taken 784 times.
 1260 if (lbm_is_symbol_nil(ctx->r)) {
3293 lbm_value e;
3294 476 lbm_pop(&ctx->K, &e);
3295 476 lbm_stack_drop(&ctx->K, 2);
3296 476 ctx->r = e;
3297 476 ctx->app_cont = true;
3298 } else {
3299 lbm_value body;
3300 lbm_value env;
3301 784 lbm_stack_drop(&ctx->K, 1);
3302 784 lbm_pop_2(&ctx->K, &body, &env);
3303 784 lbm_stack_drop(&ctx->K, 3);
3304 784 ctx->curr_env = env;
3305 784 ctx->curr_exp = body;
3306 }
3307 1260 }
3308
3309 28 static void cont_terminate(eval_context_t *ctx) {
3310 28 error_ctx(ctx->r);
3311 ✗ }
3312
3313 925148 static void cont_loop(eval_context_t *ctx) {
3314 925148 lbm_value *sptr = get_stack_ptr(ctx, 2);
3315 925148 stack_reserve(ctx,1)[0] = LOOP_CONDITION;
3316 925148 ctx->curr_exp = sptr[1];
3317 925148 }
3318
3319 925428 static void cont_loop_condition(eval_context_t *ctx) {
3320
2/2
✓ Branch 1 taken 280 times.
✓ Branch 2 taken 925148 times.
 925428 if (lbm_is_symbol_nil(ctx->r)) {
3321 280 lbm_stack_drop(&ctx->K, 2);
3322 280 ctx->app_cont = true; // A loop returns nil? Makes sense to me... but in general?
3323 280 return;
3324 }
3325 925148 lbm_value *sptr = get_stack_ptr(ctx, 2);
3326 925148 stack_reserve(ctx,1)[0] = LOOP;
3327 925148 ctx->curr_exp = sptr[0];
3328 }
3329
3330 8791412 static void cont_merge_rest(eval_context_t *ctx) {
3331 8791412 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3332
3333 // If comparator returns true (result is in ctx->r):
3334 // "a" should be moved to the last element position in merged list.
3335 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3336 // else
3337 // "b" should be moved to last element position in merged list.
3338 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3339 //
3340 // If a_rest or b_rest is NIL:
3341 // we are done, the remaining elements of
3342 // non_nil list should be appended to merged list.
3343 // else
3344 // Set up for a new comparator evaluation and recurse.
3345 8791412 lbm_value a = sptr[2];
3346 8791412 lbm_value b = lbm_cdr(a);
3347 8791412 lbm_set_cdr(a, ENC_SYM_NIL); // terminate 1 element list
3348
3349
2/2
✓ Branch 0 taken 5102188 times.
✓ Branch 1 taken 3689224 times.
 8791412 if (ctx->r == ENC_SYM_NIL) { // Comparison false
3350
3351
2/2
✓ Branch 0 taken 1983576 times.
✓ Branch 1 taken 3118612 times.
 5102188 if (sptr[0] == ENC_SYM_NIL) {
3352 1983576 sptr[0] = b;
3353 1983576 sptr[1] = b;
3354 } else {
3355 3118612 lbm_set_cdr(sptr[1], b);
3356 3118612 sptr[1] = b;
3357 }
3358
2/2
✓ Branch 0 taken 2549456 times.
✓ Branch 1 taken 2552732 times.
 5102188 if (sptr[4] == ENC_SYM_NIL) {
3359 2549456 lbm_set_cdr(a, sptr[3]);
3360 2549456 lbm_set_cdr(sptr[1], a);
3361 2549456 ctx->r = sptr[0];
3362 2549456 lbm_stack_drop(&ctx->K, 9);
3363 2549456 ctx->app_cont = true;
3364 2549456 return;
3365 } else {
3366 2552732 b = sptr[4];
3367 2552732 sptr[4] = lbm_cdr(sptr[4]);
3368 2552732 lbm_set_cdr(b, ENC_SYM_NIL);
3369 }
3370 } else {
3371
2/2
✓ Branch 0 taken 1134784 times.
✓ Branch 1 taken 2554440 times.
 3689224 if (sptr[0] == ENC_SYM_NIL) {
3372 1134784 sptr[0] = a;
3373 1134784 sptr[1] = a;
3374 } else {
3375 2554440 lbm_set_cdr(sptr[1], a);
3376 2554440 sptr[1] = a;
3377 }
3378
3379
2/2
✓ Branch 0 taken 568904 times.
✓ Branch 1 taken 3120320 times.
 3689224 if (sptr[3] == ENC_SYM_NIL) {
3380 568904 lbm_set_cdr(b, sptr[4]);
3381 568904 lbm_set_cdr(sptr[1], b);
3382 568904 ctx->r = sptr[0];
3383 568904 lbm_stack_drop(&ctx->K, 9);
3384 568904 ctx->app_cont = true;
3385 568904 return;
3386 } else {
3387 3120320 a = sptr[3];
3388 3120320 sptr[3] = lbm_cdr(sptr[3]);
3389 3120320 lbm_set_cdr(a, ENC_SYM_NIL);
3390 }
3391 }
3392 5673052 lbm_set_cdr(a, b);
3393 5673052 sptr[2] = a;
3394
3395 5673052 lbm_value par1 = sptr[7];
3396 5673052 lbm_value par2 = sptr[8];
3397 5673052 lbm_value cmp_body = sptr[5];
3398 5673052 lbm_value cmp_env = sptr[6];
3399 // Environment should be preallocated already at this point
3400 // and the operations below should never need GC.
3401 5673052 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3402 5673052 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3403
2/4
✓ Branch 1 taken 5673052 times.
✗ Branch 2 not taken.
✗ Branch 4 not taken.
✓ Branch 5 taken 5673052 times.
 5673052 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3404 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3405 }
3406 5673052 cmp_env = new_env;
3407
3408 5673052 stack_reserve(ctx,1)[0] = MERGE_REST;
3409 5673052 ctx->curr_exp = cmp_body;
3410 5673052 ctx->curr_env = cmp_env;
3411 }
3412
3413 // merge_layer stack contents
3414 // s[sp-9] = cmp
3415 // s[sp-8] = cmp_env
3416 // s[sp-7] = par1
3417 // s[sp-6] = par2
3418 // s[sp-5] = acc - first cell
3419 // s[sp-4] = acc - last cell
3420 // s[sp-3] = rest;
3421 // s[sp-2] = layer
3422 // s[sp-1] = length or original list
3423 //
3424 // ctx->r merged sublist
3425 3401272 static void cont_merge_layer(eval_context_t *ctx) {
3426 3401272 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3427 3401272 lbm_int layer = lbm_dec_i(sptr[7]);
3428 3401272 lbm_int len = lbm_dec_i(sptr[8]);
3429
3430 3401272 lbm_value r_curr = ctx->r;
3431
1/2
✓ Branch 1 taken 13620600 times.
✗ Branch 2 not taken.
 13620600 while (lbm_is_cons(r_curr)) {
3432 13620600 lbm_value next = lbm_cdr(r_curr);
3433
2/2
✓ Branch 0 taken 3401272 times.
✓ Branch 1 taken 10219328 times.
 13620600 if (next == ENC_SYM_NIL) {
3434 3401272 break;
3435 }
3436 10219328 r_curr = next;
3437 }
3438
3439
2/2
✓ Branch 0 taken 1132348 times.
✓ Branch 1 taken 2268924 times.
 3401272 if (sptr[4] == ENC_SYM_NIL) {
3440 1132348 sptr[4] = ctx->r;
3441 1132348 sptr[5] = r_curr;
3442 } else {
3443 2268924 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
3444 2268924 sptr[5] = r_curr;
3445 }
3446
3447 3401272 lbm_value layer_rest = sptr[6];
3448 // switch layer or done ?
3449
2/2
✓ Branch 0 taken 1132348 times.
✓ Branch 1 taken 2268924 times.
 3401272 if (layer_rest == ENC_SYM_NIL) {
3450
2/2
✓ Branch 0 taken 283108 times.
✓ Branch 1 taken 849240 times.
 1132348 if (layer * 2 >= len) {
3451 283108 ctx->r = sptr[4];
3452 283108 ctx->app_cont = true;
3453 283108 lbm_stack_drop(&ctx->K, 9);
3454 283108 return;
3455 } else {
3456 // Setup for merges of the next layer
3457 849240 layer = layer * 2;
3458 849240 sptr[7] = lbm_enc_i(layer);
3459 849240 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
3460 849240 sptr[5] = ENC_SYM_NIL;
3461 849240 sptr[4] = ENC_SYM_NIL;
3462 }
3463 }
3464 // merge another sublist based on current layer.
3465 3118164 lbm_value a_list = layer_rest;
3466 // build sublist a
3467 3118164 lbm_value curr = layer_rest;
3468
2/2
✓ Branch 0 taken 4543028 times.
✓ Branch 1 taken 3118052 times.
 7661080 for (int i = 0; i < layer-1; i ++) {
3469
2/2
✓ Branch 1 taken 4542916 times.
✓ Branch 2 taken 112 times.
 4543028 if (lbm_is_cons(curr)) {
3470 4542916 curr = lbm_cdr(curr);
3471 } else {
3472 112 break;
3473 }
3474 }
3475 3118164 layer_rest = lbm_cdr(curr);
3476 3118164 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
3477
3478 3118164 lbm_value b_list = layer_rest;
3479 // build sublist b
3480 3118164 curr = layer_rest;
3481
2/2
✓ Branch 0 taken 3407796 times.
✓ Branch 1 taken 2552004 times.
 5959800 for (int i = 0; i < layer-1; i ++) {
3482
2/2
✓ Branch 1 taken 2841636 times.
✓ Branch 2 taken 566160 times.
 3407796 if (lbm_is_cons(curr)) {
3483 2841636 curr = lbm_cdr(curr);
3484 } else {
3485 566160 break;
3486 }
3487 }
3488 3118164 layer_rest = lbm_cdr(curr);
3489 3118164 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
3490
3491 3118164 sptr[6] = layer_rest;
3492
3493
2/2
✓ Branch 0 taken 283192 times.
✓ Branch 1 taken 2834972 times.
 3118164 if (b_list == ENC_SYM_NIL) {
3494 283192 stack_reserve(ctx,1)[0] = MERGE_LAYER;
3495 283192 ctx->r = a_list;
3496 283192 ctx->app_cont = true;
3497 283192 return;
3498 }
3499 // Set up for a merge of sublists.
3500
3501 2834972 lbm_value a_rest = lbm_cdr(a_list);
3502 2834972 lbm_value b_rest = lbm_cdr(b_list);
3503 2834972 lbm_value a = a_list;
3504 2834972 lbm_value b = b_list;
3505 2834972 lbm_set_cdr(a, b);
3506 // Terminating the b list would be incorrect here
3507 // if there was any chance that the environment update below
3508 // performs GC.
3509 2834972 lbm_set_cdr(b, ENC_SYM_NIL);
3510
3511 2834972 lbm_value cmp_body = sptr[0];
3512 2834972 lbm_value cmp_env = sptr[1];
3513 2834972 lbm_value par1 = sptr[2];
3514 2834972 lbm_value par2 = sptr[3];
3515 // Environment should be preallocated already at this point
3516 // and the operations below should never need GC.
3517 2834972 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3518 2834972 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
3519
2/4
✓ Branch 1 taken 2834972 times.
✗ Branch 2 not taken.
✗ Branch 4 not taken.
✓ Branch 5 taken 2834972 times.
 2834972 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3520 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3521 }
3522 2834972 cmp_env = new_env;
3523
3524 2834972 lbm_uint *merge_cont = stack_reserve(ctx, 11);
3525 2834972 merge_cont[0] = MERGE_LAYER;
3526 2834972 merge_cont[1] = ENC_SYM_NIL;
3527 2834972 merge_cont[2] = ENC_SYM_NIL;
3528 2834972 merge_cont[3] = a;
3529 2834972 merge_cont[4] = a_rest;
3530 2834972 merge_cont[5] = b_rest;
3531 2834972 merge_cont[6] = cmp_body;
3532 2834972 merge_cont[7] = cmp_env;
3533 2834972 merge_cont[8] = par1;
3534 2834972 merge_cont[9] = par2;
3535 2834972 merge_cont[10] = MERGE_REST;
3536 2834972 ctx->curr_exp = cmp_body;
3537 2834972 ctx->curr_env = cmp_env;
3538 2834972 return;
3539 }
3540
3541 /****************************************************/
3542 /* READER */
3543
3544 17910 static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
3545
3546 /* Tokenizer reached "end of file"
3547 The parser could be in a state where it needs
3548 more tokens to correctly finish an expression.
3549
3550 Three cases
3551 1. The program / expression is malformed and the context should die.
3552 2. We are finished reading a program and should close off the
3553 internal representation with a closing parenthesis. Then
3554 apply continuation.
3555 3. We are finished reading an expression and should
3556 apply the continuation.
3557
3558 In case 3, we should find the READ_DONE at sp - 1.
3559 In case 2, we should find the READ_DONE at sp - 5.
3560
3561 */
3562
3563
2/2
✓ Branch 1 taken 8638 times.
✓ Branch 2 taken 9272 times.
 17910 if (lbm_is_symbol(ctx->r)) {
3564 8638 lbm_uint sym_val = lbm_dec_sym(ctx->r);
3565
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 8638 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 8638 if (sym_val >= TOKENIZER_SYMBOLS_START &&
3566 sym_val <= TOKENIZER_SYMBOLS_END) {
3567 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3568 }
3569 }
3570
3571
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 17910 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 17910 if (ctx->K.data[ctx->K.sp-1] == READ_DONE &&
3572 ✗ lbm_dec_u(ctx->K.data[ctx->K.sp-3]) == 0) {
3573 /* successfully finished reading an expression (CASE 3) */
3574 ✗ ctx->app_cont = true;
3575
3/4
✓ Branch 0 taken 17910 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 8796 times.
✓ Branch 3 taken 9114 times.
 17910 } else if (ctx->K.sp > 4 && ctx->K.data[ctx->K.sp - 4] == READ_DONE) {
3576 lbm_value env;
3577 lbm_value s;
3578 lbm_value sym;
3579 8796 lbm_pop_3(&ctx->K, &sym, &env, &s);
3580 8796 ctx->curr_env = env;
3581 8796 ctx->app_cont = true; // Program evaluated and result is in ctx->r.
3582
2/4
✓ Branch 0 taken 9114 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 9114 times.
✗ Branch 3 not taken.
 9114 } else if (ctx->K.sp > 5 && ctx->K.data[ctx->K.sp - 5] == READ_DONE) {
3583 /* successfully finished reading a program (CASE 2) */
3584 9114 ctx->r = ENC_SYM_CLOSEPAR;
3585 9114 ctx->app_cont = true;
3586 } else {
3587 /* Parsing failed */
3588 ✗ if (lbm_channel_row(str) == 1 &&
3589 ✗ lbm_channel_column(str) == 1 ){
3590 // eof at empty stream.
3591 ✗ ctx->r = ENC_SYM_NIL;
3592 ✗ ctx->app_cont = true;
3593 } else {
3594 ✗ lbm_set_error_reason((char*)lbm_error_str_parse_eof);
3595 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3596 }
3597 ✗ lbm_channel_reader_close(str);
3598 }
3599 17910 }
3600
3601 /* cont_read_next_token
3602 sp-2 : Stream
3603 sp-1 : Grab row
3604 */
3605 1471613 static void cont_read_next_token(eval_context_t *ctx) {
3606 1471613 lbm_value *sptr = get_stack_ptr(ctx, 2);
3607 1471613 lbm_value stream = sptr[0];
3608 1471613 lbm_value grab_row0 = sptr[1];
3609
3610 1471613 lbm_char_channel_t *chan = lbm_dec_channel(stream);
3611
2/4
✓ Branch 0 taken 1471613 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 1471613 times.
 1471613 if (chan == NULL || chan->state == NULL) {
3612 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3613 }
3614
3615
4/4
✓ Branch 1 taken 1171609 times.
✓ Branch 2 taken 300004 times.
✓ Branch 4 taken 644 times.
✓ Branch 5 taken 1170965 times.
 1471613 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3616 644 lbm_stack_drop(&ctx->K, 2);
3617 644 read_finish(chan, ctx);
3618 1471613 return;
3619 }
3620 /* Eat whitespace and comments */
3621
2/2
✓ Branch 1 taken 666 times.
✓ Branch 2 taken 1470303 times.
 1470969 if (!tok_clean_whitespace(chan)) {
3622 666 sptr[0] = stream;
3623 666 sptr[1] = lbm_enc_u(0);
3624 666 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
3625 666 yield_ctx(EVAL_CPS_MIN_SLEEP);
3626 666 return;
3627 }
3628 /* After eating whitespace we may be at end of file/stream */
3629
4/4
✓ Branch 1 taken 1171186 times.
✓ Branch 2 taken 299117 times.
✓ Branch 4 taken 17266 times.
✓ Branch 5 taken 1153920 times.
 1470303 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
3630 17266 lbm_stack_drop(&ctx->K, 2);
3631 17266 read_finish(chan, ctx);
3632 17266 return;
3633 }
3634
3635
2/2
✓ Branch 1 taken 51620 times.
✓ Branch 2 taken 1401417 times.
 1453037 if (lbm_dec_u(grab_row0)) {
3636 51620 ctx->row0 = (int32_t)lbm_channel_row(chan);
3637 }
3638
3639 /* Attempt to extract tokens from the character stream */
3640 1453037 int n = 0;
3641 1453037 lbm_value res = ENC_SYM_NIL;
3642 1453037 unsigned int string_len = 0;
3643
3644 /*
3645 * SYNTAX
3646 */
3647 uint32_t match;
3648 1453037 n = tok_syntax(chan, &match);
3649
2/2
✓ Branch 0 taken 575848 times.
✓ Branch 1 taken 877189 times.
 1453037 if (n > 0) {
3650
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 575848 times.
 575848 if (!lbm_channel_drop(chan, (unsigned int)n)) {
3651 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3652 }
3653 575848 ctx->app_cont = true;
3654 575848 lbm_uint do_next = 0;
3655
14/15
✓ Branch 0 taken 258720 times.
✓ Branch 1 taken 258720 times.
✓ Branch 2 taken 2800 times.
✓ Branch 3 taken 2800 times.
✓ Branch 4 taken 6048 times.
✓ Branch 5 taken 980 times.
✓ Branch 6 taken 17696 times.
✓ Branch 7 taken 4732 times.
✓ Branch 8 taken 56 times.
✓ Branch 9 taken 13020 times.
✓ Branch 10 taken 6524 times.
✓ Branch 11 taken 1848 times.
✓ Branch 12 taken 1848 times.
✓ Branch 13 taken 56 times.
✗ Branch 14 not taken.
 575848 switch(match) {
3656 258720 case TOKOPENPAR: {
3657 258720 sptr[0] = ENC_SYM_NIL;
3658 258720 sptr[1] = ENC_SYM_NIL;
3659 258720 lbm_value *rptr = stack_reserve(ctx,5);
3660 258720 rptr[0] = stream;
3661 258720 rptr[1] = READ_APPEND_CONTINUE;
3662 258720 rptr[2] = stream;
3663 258720 rptr[3] = lbm_enc_u(0);
3664 258720 rptr[4] = READ_NEXT_TOKEN;
3665 258720 ctx->r = ENC_SYM_OPENPAR;
3666 258720 } return;
3667 258720 case TOKCLOSEPAR: {
3668 258720 lbm_stack_drop(&ctx->K, 2);
3669 258720 ctx->r = ENC_SYM_CLOSEPAR;
3670 258720 } return;
3671 2800 case TOKOPENBRACK: {
3672 2800 sptr[0] = stream;
3673 2800 sptr[1] = READ_START_ARRAY;
3674 2800 lbm_value *rptr = stack_reserve(ctx, 3);
3675 2800 rptr[0] = stream;
3676 2800 rptr[1] = lbm_enc_u(0);
3677 2800 rptr[2] = READ_NEXT_TOKEN;
3678 2800 ctx->r = ENC_SYM_OPENBRACK;
3679 2800 } return;
3680 2800 case TOKCLOSEBRACK:
3681 2800 lbm_stack_drop(&ctx->K, 2);
3682 2800 ctx->r = ENC_SYM_CLOSEBRACK;
3683 2800 return;
3684 6048 case TOKDOT:
3685 6048 lbm_stack_drop(&ctx->K, 2);
3686 6048 ctx->r = ENC_SYM_DOT;
3687 6048 return;
3688 980 case TOKDONTCARE:
3689 980 lbm_stack_drop(&ctx->K, 2);
3690 980 ctx->r = ENC_SYM_DONTCARE;
3691 980 return;
3692 17696 case TOKQUOTE:
3693 17696 do_next = READ_QUOTE_RESULT;
3694 17696 break;
3695 4732 case TOKBACKQUOTE: {
3696 4732 sptr[0] = QQ_EXPAND_START;
3697 4732 sptr[1] = stream;
3698 4732 lbm_value *rptr = stack_reserve(ctx, 2);
3699 4732 rptr[0] = lbm_enc_u(0);
3700 4732 rptr[1] = READ_NEXT_TOKEN;
3701 4732 ctx->app_cont = true;
3702 4732 } return;
3703 56 case TOKCOMMAAT:
3704 56 do_next = READ_COMMAAT_RESULT;
3705 56 break;
3706 13020 case TOKCOMMA:
3707 13020 do_next = READ_COMMA_RESULT;
3708 13020 break;
3709 6524 case TOKMATCHANY:
3710 6524 lbm_stack_drop(&ctx->K, 2);
3711 6524 ctx->r = ENC_SYM_MATCH_ANY;
3712 6524 return;
3713 1848 case TOKOPENCURL: {
3714 1848 sptr[0] = ENC_SYM_NIL;
3715 1848 sptr[1] = ENC_SYM_NIL;
3716 1848 lbm_value *rptr = stack_reserve(ctx,2);
3717 1848 rptr[0] = stream;
3718 1848 rptr[1] = READ_APPEND_CONTINUE;
3719 1848 ctx->r = ENC_SYM_PROGN;
3720 1848 } return;
3721 1848 case TOKCLOSECURL:
3722 1848 lbm_stack_drop(&ctx->K, 2);
3723 1848 ctx->r = ENC_SYM_CLOSEPAR;
3724 1848 return;
3725 56 case TOKCONSTSTART: /* fall through */
3726 case TOKCONSTEND:
3727 case TOKCONSTSYMSTR: {
3728
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 28 times.
 56 if (match == TOKCONSTSTART) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST;
3729
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 28 times.
 56 if (match == TOKCONSTEND) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST;
3730
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 56 times.
 56 if (match == TOKCONSTSYMSTR) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS;
3731 56 sptr[0] = stream;
3732 56 sptr[1] = lbm_enc_u(0);
3733 56 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
3734 56 ctx->app_cont = true;
3735 56 } return;
3736 ✗ default:
3737 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3738 }
3739 30772 sptr[0] = do_next;
3740 30772 sptr[1] = stream;
3741 30772 lbm_value *rptr = stack_reserve(ctx, 2);
3742 30772 rptr[0] = lbm_enc_u(0);
3743 30772 rptr[1] = READ_NEXT_TOKEN;
3744 30772 ctx->app_cont = true;
3745 30772 return;
3746
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 877189 times.
 877189 } else if (n < 0) goto retry_token;
3747
3748 /*
3749 * STRING
3750 */
3751 877189 n = tok_string(chan, &string_len);
3752
2/2
✓ Branch 0 taken 4620 times.
✓ Branch 1 taken 872569 times.
 877189 if (n >= 2) {
3753 4620 lbm_channel_drop(chan, (unsigned int)n);
3754
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 4620 times.
 4620 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3755 ✗ gc();
3756 ✗ if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
3757 ✗ error_ctx(ENC_SYM_MERROR);
3758 ✗ return; // dead return but static analysis does not know that.
3759 }
3760 }
3761 4620 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(res);
3762 4620 char *data = (char*)arr->data;
3763 4620 memset(data,0, string_len + 1);
3764 4620 memcpy(data, tokpar_sym_str, string_len);
3765 4620 lbm_stack_drop(&ctx->K, 2);
3766 4620 ctx->r = res;
3767 4620 ctx->app_cont = true;
3768 4620 return;
3769
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 872569 times.
 872569 } else if (n < 0) goto retry_token;
3770
3771 /*
3772 * FLOAT
3773 */
3774 token_float f_val;
3775 872569 n = tok_double(chan, &f_val);
3776
2/2
✓ Branch 0 taken 6916 times.
✓ Branch 1 taken 865653 times.
 872569 if (n > 0) {
3777 6916 lbm_channel_drop(chan, (unsigned int) n);
3778
2/3
✓ Branch 0 taken 5124 times.
✓ Branch 1 taken 1792 times.
✗ Branch 2 not taken.
 6916 switch(f_val.type) {
3779 5124 case TOKTYPEF32:
3780
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 5124 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 5124 WITH_GC(res, lbm_enc_float((float)f_val.value));
3781 5124 break;
3782 1792 case TOKTYPEF64:
3783 1792 res = lbm_enc_double(f_val.value);
3784 1792 break;
3785 ✗ default:
3786 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3787 }
3788 6916 lbm_stack_drop(&ctx->K, 2);
3789 6916 ctx->r = res;
3790 6916 ctx->app_cont = true;
3791 6916 return;
3792
2/2
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 865651 times.
 865653 } else if (n < 0) goto retry_token;
3793
3794 /*
3795 * INTEGER
3796 */
3797 token_int int_result;
3798 865651 n = tok_integer(chan, &int_result);
3799
2/2
✓ Branch 0 taken 471408 times.
✓ Branch 1 taken 394243 times.
 865651 if (n > 0) {
3800 471408 lbm_channel_drop(chan, (unsigned int)n);
3801
7/8
✓ Branch 0 taken 1400 times.
✓ Branch 1 taken 457660 times.
✓ Branch 2 taken 2296 times.
✓ Branch 3 taken 2296 times.
✓ Branch 4 taken 3192 times.
✓ Branch 5 taken 2548 times.
✓ Branch 6 taken 2016 times.
✗ Branch 7 not taken.
 471408 switch(int_result.type) {
3802 1400 case TOKTYPEBYTE:
3803
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1400 times.
 1400 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
3804 1400 break;
3805 457660 case TOKTYPEI:
3806
2/2
✓ Branch 0 taken 672 times.
✓ Branch 1 taken 456988 times.
 457660 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
3807 457660 break;
3808 2296 case TOKTYPEU:
3809
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2296 times.
 2296 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
3810 2296 break;
3811 2296 case TOKTYPEI32:
3812
2/8
✗ Branch 0 not taken.
✓ Branch 1 taken 2296 times.
✗ Branch 4 not taken.
✓ Branch 5 taken 2296 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
 2296 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)));
3813 2296 break;
3814 3192 case TOKTYPEU32:
3815
2/8
✗ Branch 0 not taken.
✓ Branch 1 taken 3192 times.
✗ Branch 4 not taken.
✓ Branch 5 taken 3192 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
 3192 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)));
3816 3192 break;
3817 2548 case TOKTYPEI64:
3818
3/8
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 2520 times.
✗ Branch 4 not taken.
✓ Branch 5 taken 2548 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
 2548 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)));
3819 2548 break;
3820 2016 case TOKTYPEU64:
3821
2/8
✗ Branch 0 not taken.
✓ Branch 1 taken 2016 times.
✗ Branch 4 not taken.
✓ Branch 5 taken 2016 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
✗ Branch 11 not taken.
✗ Branch 12 not taken.
 2016 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)));
3822 2016 break;
3823 ✗ default:
3824 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3825 }
3826 471408 lbm_stack_drop(&ctx->K, 2);
3827 471408 ctx->r = res;
3828 471408 ctx->app_cont = true;
3829 471408 return;
3830
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 394243 times.
 394243 } else if (n < 0) goto retry_token;
3831
3832 /*
3833 * SYMBOL
3834 */
3835 394243 n = tok_symbol(chan);
3836
2/2
✓ Branch 0 taken 394100 times.
✓ Branch 1 taken 143 times.
 394243 if (n > 0) {
3837 394100 lbm_channel_drop(chan, (unsigned int) n);
3838 lbm_uint symbol_id;
3839
2/2
✓ Branch 1 taken 321650 times.
✓ Branch 2 taken 72450 times.
 394100 if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
3840 321650 res = lbm_enc_sym(symbol_id);
3841 } else {
3842 72450 int r = 0;
3843
2/2
✓ Branch 0 taken 21854 times.
✓ Branch 1 taken 50596 times.
 72450 if (n > 4 &&
3844
2/2
✓ Branch 0 taken 378 times.
✓ Branch 1 taken 21476 times.
 21854 tokpar_sym_str[0] == 'e' &&
3845
2/2
✓ Branch 0 taken 42 times.
✓ Branch 1 taken 336 times.
 378 tokpar_sym_str[1] == 'x' &&
3846
1/2
✓ Branch 0 taken 42 times.
✗ Branch 1 not taken.
 42 tokpar_sym_str[2] == 't' &&
3847
2/2
✓ Branch 0 taken 14 times.
✓ Branch 1 taken 28 times.
 56 tokpar_sym_str[3] == '-') {
3848 lbm_uint ext_id;
3849 14 lbm_uint ext_name_len = (lbm_uint)n + 1;
3850 14 char *ext_name = lbm_malloc(ext_name_len);
3851
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 14 times.
 14 if (!ext_name) {
3852 ✗ gc();
3853 ✗ ext_name = lbm_malloc(ext_name_len);
3854 }
3855
1/2
✓ Branch 0 taken 14 times.
✗ Branch 1 not taken.
 14 if (ext_name) {
3856 14 memcpy(ext_name, tokpar_sym_str, ext_name_len);
3857 14 r = lbm_add_extension(ext_name, lbm_extensions_default);
3858
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 14 times.
 14 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
3859 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3860 }
3861 14 symbol_id = ext_id;
3862 } else {
3863 ✗ error_ctx(ENC_SYM_MERROR);
3864 }
3865 } else {
3866
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 72436 times.
 72436 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS &&
3867 ✗ ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ) {
3868 ✗ r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true); //flash
3869 ✗ if (!r) {
3870 ✗ lbm_set_error_reason((char*)lbm_error_str_flash_error);
3871 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3872 }
3873 } else {
3874 72436 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false); //ram
3875
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 72436 times.
 72436 if (!r) {
3876 ✗ gc();
3877 ✗ r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false); //ram
3878 }
3879 }
3880 }
3881
1/2
✓ Branch 0 taken 72450 times.
✗ Branch 1 not taken.
 72450 if (r) {
3882 72450 res = lbm_enc_sym(symbol_id);
3883 } else {
3884 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3885 }
3886 }
3887 394100 lbm_stack_drop(&ctx->K, 2);
3888 394100 ctx->r = res;
3889 394100 ctx->app_cont = true;
3890 394100 return;
3891
2/2
✓ Branch 0 taken 3 times.
✓ Branch 1 taken 140 times.
 143 } else if (n == TOKENIZER_NEED_MORE) {
3892 3 goto retry_token;
3893
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 140 times.
 140 } else if (n <= TOKENIZER_STRING_ERROR) {
3894 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3895 }
3896
3897 /*
3898 * CHAR
3899 */
3900 char c_val;
3901 140 n = tok_char(chan, &c_val);
3902
1/2
✓ Branch 0 taken 140 times.
✗ Branch 1 not taken.
 140 if(n > 0) {
3903 140 lbm_channel_drop(chan,(unsigned int) n);
3904 140 lbm_stack_drop(&ctx->K, 2);
3905 140 ctx->r = lbm_enc_char((uint8_t)c_val);
3906 140 ctx->app_cont = true;
3907 140 return;
3908 ✗ }else if (n < 0) goto retry_token;
3909
3910 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3911
3912 5 retry_token:
3913
1/2
✓ Branch 0 taken 5 times.
✗ Branch 1 not taken.
 5 if (n == TOKENIZER_NEED_MORE) {
3914 5 sptr[0] = stream;
3915 5 sptr[1] = lbm_enc_u(0);
3916 5 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
3917 5 yield_ctx(EVAL_CPS_MIN_SLEEP);
3918 5 return;
3919 }
3920 ✗ read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
3921 }
3922
3923 2800 static void cont_read_start_array(eval_context_t *ctx) {
3924 2800 lbm_value *sptr = get_stack_ptr(ctx, 1);
3925 2800 lbm_value stream = sptr[0];
3926
3927 2800 lbm_char_channel_t *str = lbm_dec_channel(stream);
3928
2/4
✓ Branch 0 taken 2800 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 2800 times.
 2800 if (str == NULL || str->state == NULL) {
3929 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3930 }
3931
3932 2800 lbm_uint num_free = lbm_memory_longest_free();
3933 2800 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
3934
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2800 times.
 2800 if (initial_size == 0) {
3935 ✗ gc();
3936 ✗ num_free = lbm_memory_longest_free();
3937 ✗ initial_size = (lbm_uint)((float)num_free * 0.9);
3938 ✗ if (initial_size == 0) {
3939 ✗ lbm_channel_reader_close(str);
3940 ✗ error_ctx(ENC_SYM_MERROR);
3941 }
3942 }
3943
3944
1/2
✓ Branch 1 taken 2800 times.
✗ Branch 2 not taken.
 2800 if (lbm_is_number(ctx->r)) {
3945 lbm_value array;
3946 2800 initial_size = sizeof(lbm_uint) * initial_size;
3947
3948
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 2800 times.
 2800 if (!lbm_heap_allocate_array(&array, initial_size)) {
3949 ✗ lbm_set_error_reason("Out of memory while reading.");
3950 ✗ lbm_channel_reader_close(str);
3951 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
3952 // NOTE: If array is not created evaluation ends here.
3953 // Static analysis seems unaware.
3954 }
3955
3956 2800 sptr[0] = array;
3957 2800 lbm_value *rptr = stack_reserve(ctx, 4);
3958 2800 rptr[0] = lbm_enc_u(initial_size);
3959 2800 rptr[1] = lbm_enc_u(0);
3960 2800 rptr[2] = stream;
3961 2800 rptr[3] = READ_APPEND_ARRAY;
3962 2800 ctx->app_cont = true;
3963 } else {
3964 ✗ lbm_channel_reader_close(str);
3965 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
3966 }
3967 2800 }
3968
3969 366828 static void cont_read_append_array(eval_context_t *ctx) {
3970 366828 lbm_uint *sptr = get_stack_ptr(ctx, 4);
3971
3972 366828 lbm_value array = sptr[0];
3973 366828 lbm_value size = lbm_dec_as_u32(sptr[1]);
3974 366828 lbm_value ix = lbm_dec_as_u32(sptr[2]);
3975 366828 lbm_value stream = sptr[3];
3976
3977
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 366828 times.
 366828 if (ix >= (size - 1)) {
3978 ✗ error_ctx(ENC_SYM_MERROR);
3979 }
3980
3981 // get_car can return nil. Whose value is 0!
3982 // So static Analysis is right about this being a potential NULL pointer.
3983 // However, if the array was created correcly to begin with, it should be fine.
3984 366828 lbm_value arr_car = get_car(array);
3985 366828 lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
3986
3987
2/2
✓ Branch 1 taken 364028 times.
✓ Branch 2 taken 2800 times.
 366828 if (lbm_is_number(ctx->r)) {
3988 364028 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
3989
3990 364028 sptr[2] = lbm_enc_u(ix + 1);
3991 364028 lbm_value *rptr = stack_reserve(ctx, 4);
3992 364028 rptr[0] = READ_APPEND_ARRAY;
3993 364028 rptr[1] = stream;
3994 364028 rptr[2] = lbm_enc_u(0);
3995 364028 rptr[3] = READ_NEXT_TOKEN;
3996 364028 ctx->app_cont = true;
3997
2/4
✓ Branch 1 taken 2800 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 2800 times.
✗ Branch 4 not taken.
 2800 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK) {
3998 2800 lbm_uint array_size = ix / sizeof(lbm_uint);
3999
4000
2/2
✓ Branch 0 taken 2044 times.
✓ Branch 1 taken 756 times.
 2800 if (ix % sizeof(lbm_uint) != 0) {
4001 2044 array_size = array_size + 1;
4002 }
4003 2800 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
4004 2800 arr->size = ix;
4005 2800 lbm_stack_drop(&ctx->K, 4);
4006 2800 ctx->r = array;
4007 2800 ctx->app_cont = true;
4008 } else {
4009 ✗ error_ctx(ENC_SYM_TERROR);
4010 }
4011 366828 }
4012
4013 1006978 static void cont_read_append_continue(eval_context_t *ctx) {
4014 1006978 lbm_value *sptr = get_stack_ptr(ctx, 3);
4015
4016 1006978 lbm_value first_cell = sptr[0];
4017 1006978 lbm_value last_cell = sptr[1];
4018 1006978 lbm_value stream = sptr[2];
4019
4020 1006978 lbm_char_channel_t *str = lbm_dec_channel(stream);
4021
2/4
✓ Branch 0 taken 1006978 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 1006978 times.
 1006978 if (str == NULL || str->state == NULL) {
4022 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4023 }
4024
4025
2/2
✓ Branch 1 taken 639338 times.
✓ Branch 2 taken 367640 times.
 1006978 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4026
4027
3/3
✓ Branch 0 taken 263634 times.
✓ Branch 1 taken 6048 times.
✓ Branch 2 taken 369656 times.
 639338 switch(ctx->r) {
4028 263634 case ENC_SYM_CLOSEPAR:
4029
2/2
✓ Branch 1 taken 261254 times.
✓ Branch 2 taken 2380 times.
 263634 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4030 261254 lbm_set_cdr(last_cell, ENC_SYM_NIL); // terminate the list
4031 261254 ctx->r = first_cell;
4032 } else {
4033 2380 ctx->r = ENC_SYM_NIL;
4034 }
4035 263634 lbm_stack_drop(&ctx->K, 3);
4036 /* Skip reading another token and apply the continuation */
4037 263634 ctx->app_cont = true;
4038 263634 return;
4039 6048 case ENC_SYM_DOT: {
4040 6048 lbm_value *rptr = stack_reserve(ctx, 4);
4041 6048 rptr[0] = READ_DOT_TERMINATE;
4042 6048 rptr[1] = stream;
4043 6048 rptr[2] = lbm_enc_u(0);
4044 6048 rptr[3] = READ_NEXT_TOKEN;
4045 6048 ctx->app_cont = true;
4046 6048 } return;
4047 }
4048 }
4049 737296 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
4050
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 737296 times.
 737296 if (lbm_is_symbol_merror(new_cell)) {
4051 ✗ lbm_channel_reader_close(str);
4052 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4053 ✗ return;
4054 }
4055
2/2
✓ Branch 1 taken 469994 times.
✓ Branch 2 taken 267302 times.
 737296 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4056 469994 lbm_set_cdr(last_cell, new_cell);
4057 469994 last_cell = new_cell;
4058 } else {
4059 267302 first_cell = last_cell = new_cell;
4060 }
4061 737296 sptr[0] = first_cell;
4062 737296 sptr[1] = last_cell;
4063 737296 sptr[2] = stream; // unchanged.
4064 737296 lbm_value *rptr = stack_reserve(ctx, 4);
4065 737296 rptr[0] = READ_APPEND_CONTINUE;
4066 737296 rptr[1] = stream;
4067 737296 rptr[2] = lbm_enc_u(0);
4068 737296 rptr[3] = READ_NEXT_TOKEN;
4069 737296 ctx->app_cont = true;
4070 }
4071
4072 25760 static void cont_read_eval_continue(eval_context_t *ctx) {
4073 lbm_value env;
4074 lbm_value stream;
4075 25760 lbm_pop_2(&ctx->K, &env, &stream);
4076
4077 25760 lbm_char_channel_t *str = lbm_dec_channel(stream);
4078
2/4
✓ Branch 0 taken 25760 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 25760 times.
 25760 if (str == NULL || str->state == NULL) {
4079 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4080 }
4081
4082 25760 ctx->row1 = (lbm_int)str->row(str);
4083
4084
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 25760 times.
 25760 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4085
4086 ✗ switch(ctx->r) {
4087 ✗ case ENC_SYM_CLOSEPAR:
4088 ✗ ctx->app_cont = true;
4089 ✗ return;
4090 ✗ case ENC_SYM_DOT: {
4091 // This case is a bit mysterious.
4092 // A dot, may in reality be an error in this location.
4093 ✗ lbm_value *rptr = stack_reserve(ctx, 4);
4094 ✗ rptr[0] = READ_DOT_TERMINATE;
4095 ✗ rptr[1] = stream;
4096 ✗ rptr[2] = lbm_enc_u(0);
4097 ✗ rptr[3] = READ_NEXT_TOKEN;
4098 ✗ ctx->app_cont = true;
4099 ✗ } return;
4100 }
4101 }
4102
4103 25760 lbm_value *rptr = stack_reserve(ctx, 6);
4104 25760 rptr[0] = stream;
4105 25760 rptr[1] = env;
4106 25760 rptr[2] = READ_EVAL_CONTINUE;
4107 25760 rptr[3] = stream;
4108 25760 rptr[4] = lbm_enc_u(1);
4109 25760 rptr[5] = READ_NEXT_TOKEN;
4110 25760 rptr[6] = lbm_enc_u(ctx->flags);
4111 25760 rptr[7] = POP_READER_FLAGS;
4112 25760 ctx->curr_env = env;
4113 25760 ctx->curr_exp = ctx->r;
4114 }
4115
4116 6048 static void cont_read_expect_closepar(eval_context_t *ctx) {
4117 lbm_value res;
4118 lbm_value stream;
4119
4120 6048 lbm_pop_2(&ctx->K, &res, &stream);
4121
4122 6048 lbm_char_channel_t *str = lbm_dec_channel(stream);
4123
2/4
✓ Branch 0 taken 6048 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 6048 times.
 6048 if (str == NULL || str->state == NULL) {
4124 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4125 }
4126
4127
1/2
✓ Branch 1 taken 6048 times.
✗ Branch 2 not taken.
 6048 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4128
1/2
✓ Branch 0 taken 6048 times.
✗ Branch 1 not taken.
 6048 ctx->r == ENC_SYM_CLOSEPAR) {
4129 6048 ctx->r = res;
4130 6048 ctx->app_cont = true;
4131 } else {
4132 ✗ lbm_channel_reader_close(str);
4133 ✗ lbm_set_error_reason((char*)lbm_error_str_parse_close);
4134 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4135 }
4136 6048 }
4137
4138 6048 static void cont_read_dot_terminate(eval_context_t *ctx) {
4139 6048 lbm_value *sptr = get_stack_ptr(ctx, 3);
4140
4141 6048 lbm_value first_cell = sptr[0];
4142 6048 lbm_value last_cell = sptr[1];
4143 6048 lbm_value stream = sptr[2];
4144
4145 6048 lbm_char_channel_t *str = lbm_dec_channel(stream);
4146
2/4
✓ Branch 0 taken 6048 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 6048 times.
 6048 if (str == NULL || str->state == NULL) {
4147 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4148 }
4149
4150 6048 lbm_stack_drop(&ctx->K ,3);
4151
4152
2/2
✓ Branch 1 taken 1568 times.
✓ Branch 2 taken 4480 times.
 6048 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4153
1/2
✓ Branch 0 taken 1568 times.
✗ Branch 1 not taken.
 1568 (ctx->r == ENC_SYM_CLOSEPAR ||
4154
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1568 times.
 1568 ctx->r == ENC_SYM_DOT)) {
4155 ✗ lbm_channel_reader_close(str);
4156 ✗ lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4157 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4158 } else {
4159
1/2
✓ Branch 1 taken 6048 times.
✗ Branch 2 not taken.
 6048 if (lbm_is_cons(last_cell)) {
4160 6048 lbm_set_cdr(last_cell, ctx->r);
4161 6048 ctx->r = first_cell;
4162 6048 lbm_value *rptr = stack_reserve(ctx, 6);
4163 6048 rptr[0] = stream;
4164 6048 rptr[1] = ctx->r;
4165 6048 rptr[2] = READ_EXPECT_CLOSEPAR;
4166 6048 rptr[3] = stream;
4167 6048 rptr[4] = lbm_enc_u(0);
4168 6048 rptr[5] = READ_NEXT_TOKEN;
4169 6048 ctx->app_cont = true;
4170 } else {
4171 ✗ lbm_channel_reader_close(str);
4172 ✗ lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4173 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4174 }
4175 }
4176 6048 }
4177
4178 34682 static void cont_read_done(eval_context_t *ctx) {
4179 lbm_value stream;
4180 lbm_value f_val;
4181 34682 lbm_pop_2(&ctx->K, &stream ,&f_val);
4182
4183 34682 uint32_t flags = lbm_dec_as_u32(f_val);
4184 34682 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
4185 34682 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
4186
4187 34682 lbm_char_channel_t *str = lbm_dec_channel(stream);
4188
2/4
✓ Branch 0 taken 34682 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 34682 times.
 34682 if (str == NULL || str->state == NULL) {
4189 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4190 }
4191
4192 34682 lbm_channel_reader_close(str);
4193
2/2
✓ Branch 1 taken 20304 times.
✓ Branch 2 taken 14378 times.
 34682 if (lbm_is_symbol(ctx->r)) {
4194 20304 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4195
3/4
✓ Branch 0 taken 11676 times.
✓ Branch 1 taken 8628 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 11676 times.
 20304 if (sym_val >= TOKENIZER_SYMBOLS_START &&
4196 sym_val <= TOKENIZER_SYMBOLS_END) {
4197 ✗ read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4198 }
4199 }
4200
4201 34682 ctx->row0 = -1;
4202 34682 ctx->row1 = -1;
4203 34682 ctx->app_cont = true;
4204 34682 }
4205
4206 17696 static void cont_read_quote_result(eval_context_t *ctx) {
4207 lbm_value cell;
4208
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 17696 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 17696 WITH_GC(cell, lbm_heap_allocate_list_init(2,
4209 ENC_SYM_QUOTE,
4210 ctx->r));
4211 17696 ctx->r = cell;
4212 17696 ctx->app_cont = true;
4213 17696 }
4214
4215 56 static void cont_read_commaat_result(eval_context_t *ctx) {
4216 56 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL, ENC_SYM_NIL);
4217 56 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMAAT, cell2, ENC_SYM_NIL);
4218 56 ctx->r = cell1;
4219 56 ctx->app_cont = true;
4220 56 }
4221
4222 13020 static void cont_read_comma_result(eval_context_t *ctx) {
4223 13020 lbm_value cell2 = cons_with_gc(ctx->r,ENC_SYM_NIL,ENC_SYM_NIL);
4224 13020 lbm_value cell1 = cons_with_gc(ENC_SYM_COMMA, cell2, ENC_SYM_NIL);
4225 13020 ctx->r = cell1;
4226 13020 ctx->app_cont = true;
4227 13020 }
4228
4229 371682353 static void cont_application_start(eval_context_t *ctx) {
4230
4231 /* sptr[0] = env
4232 * sptr[1] = args
4233 * ctx->r = function
4234 */
4235
4236
2/2
✓ Branch 1 taken 264752004 times.
✓ Branch 2 taken 106930349 times.
 371682353 if (lbm_is_symbol(ctx->r)) {
4237 264752004 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4238 264752004 cont_application_args(ctx);
4239
1/2
✓ Branch 1 taken 106930349 times.
✗ Branch 2 not taken.
 106930349 } else if (lbm_is_cons(ctx->r)) {
4240 106930349 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4241 106930349 lbm_value args = (lbm_value)sptr[1];
4242
3/4
✓ Branch 1 taken 106924805 times.
✓ Branch 2 taken 196 times.
✓ Branch 3 taken 5348 times.
✗ Branch 4 not taken.
 106930349 switch (get_car(ctx->r)) {
4243 106924805 case ENC_SYM_CLOSURE: {
4244 lbm_value cl[3];
4245 106924805 extract_n(get_cdr(ctx->r), cl, 3);
4246 106924805 lbm_value arg_env = (lbm_value)sptr[0];
4247 lbm_value arg0, arg_rest;
4248 106924805 get_car_and_cdr(args, &arg0, &arg_rest);
4249 106924805 sptr[1] = cl[CLO_BODY];
4250 106924805 bool a_nil = lbm_is_symbol_nil(args);
4251 106924805 bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS]);
4252 106924805 lbm_value *reserved = stack_reserve(ctx, 4);
4253
4254
3/4
✓ Branch 0 taken 106890085 times.
✓ Branch 1 taken 34720 times.
✓ Branch 2 taken 106890085 times.
✗ Branch 3 not taken.
 106924805 if (!a_nil && !p_nil) {
4255 106890085 reserved[0] = cl[CLO_ENV];
4256 106890085 reserved[1] = cl[CLO_PARAMS];
4257 106890085 reserved[2] = arg_rest;
4258 106890085 reserved[3] = CLOSURE_ARGS;
4259 106890085 ctx->curr_exp = arg0;
4260 106890085 ctx->curr_env = arg_env;
4261
2/4
✓ Branch 0 taken 34720 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 34720 times.
✗ Branch 3 not taken.
 34720 } else if (a_nil && p_nil) {
4262 // No params, No args
4263 34720 lbm_stack_drop(&ctx->K, 6);
4264 34720 ctx->curr_exp = cl[CLO_BODY];
4265 34720 ctx->curr_env = cl[CLO_ENV];
4266 ✗ } else if (p_nil) {
4267 ✗ lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, cl[CLO_ENV]);
4268 ✗ reserved[0] = rest_binder;
4269 ✗ reserved[1] = get_cdr(args);
4270 ✗ reserved[2] = get_car(rest_binder);
4271 ✗ reserved[3] = CLOSURE_ARGS_REST;
4272 ✗ ctx->curr_exp = get_car(args);
4273 ✗ ctx->curr_env = arg_env;
4274 } else {
4275 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
4276 ✗ error_at_ctx(ENC_SYM_EERROR, ctx->r);
4277 }
4278 106924805 } break;
4279 196 case ENC_SYM_CONT:{
4280 /* Continuation created using call-cc.
4281 * ((SYM_CONT . cont-array) arg0 )
4282 */
4283 196 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
4284
4285
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 196 times.
 196 if (!lbm_is_lisp_array_r(c)) {
4286 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4287 }
4288
4289 196 lbm_uint arg_count = lbm_list_length(args);
4290
2/3
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 140 times.
✗ Branch 2 not taken.
 196 lbm_value arg = ENC_SYM_NIL;
4291 switch (arg_count) {
4292 56 case 0:
4293 56 arg = ENC_SYM_NIL;
4294 56 break;
4295 140 case 1:
4296 140 arg = get_car(args);
4297 140 break;
4298 ✗ default:
4299 ✗ lbm_set_error_reason((char*)lbm_error_str_num_args);
4300 ✗ error_ctx(ENC_SYM_EERROR);
4301 }
4302 196 lbm_stack_clear(&ctx->K);
4303
4304 196 lbm_array_header_t *arr = (lbm_array_header_t*)get_car(c);
4305
4306 196 ctx->K.sp = arr->size / sizeof(lbm_uint);
4307 196 memcpy(ctx->K.data, arr->data, arr->size);
4308
4309 196 ctx->curr_exp = arg;
4310 196 break;
4311 }
4312 5348 case ENC_SYM_MACRO:{
4313 /*
4314 * Perform macro expansion.
4315 * Macro expansion is really just evaluation in an
4316 * environment augmented with the unevaluated expressions passed
4317 * as arguments.
4318 */
4319 5348 lbm_value env = (lbm_value)sptr[0];
4320
4321 5348 lbm_value curr_param = get_cadr(ctx->r);
4322 5348 lbm_value curr_arg = args;
4323 5348 lbm_value expand_env = env;
4324
3/4
✓ Branch 1 taken 16128 times.
✓ Branch 2 taken 5348 times.
✓ Branch 3 taken 16128 times.
✗ Branch 4 not taken.
 37604 while (lbm_is_cons(curr_param) &&
4325 16128 lbm_is_cons(curr_arg)) {
4326 lbm_value car_curr_param, cdr_curr_param;
4327 lbm_value car_curr_arg, cdr_curr_arg;
4328 16128 get_car_and_cdr(curr_param, &car_curr_param, &cdr_curr_param);
4329 16128 get_car_and_cdr(curr_arg, &car_curr_arg, &cdr_curr_arg);
4330
4331 16128 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
4332 16128 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL);
4333 16128 expand_env = aug_env;
4334
4335 16128 curr_param = cdr_curr_param;
4336 16128 curr_arg = cdr_curr_arg;
4337 }
4338 /* Two rounds of evaluation is performed.
4339 * First to instantiate the arguments into the macro body.
4340 * Second to evaluate the resulting program.
4341 */
4342 5348 sptr[1] = EVAL_R;
4343 5348 lbm_value exp = get_cadr(get_cdr(ctx->r));
4344 5348 ctx->curr_exp = exp;
4345 5348 ctx->curr_env = expand_env;
4346 5348 } break;
4347 ✗ default:
4348 ✗ error_ctx(ENC_SYM_EERROR);
4349 }
4350 } else {
4351 ✗ error_ctx(ENC_SYM_EERROR);
4352 }
4353 371682325 }
4354
4355 5348 static void cont_eval_r(eval_context_t* ctx) {
4356 lbm_value env;
4357 5348 lbm_pop(&ctx->K, &env);
4358 5348 ctx->curr_exp = ctx->r;
4359 5348 ctx->curr_env = env;
4360 5348 }
4361
4362 28281372 static void cont_progn_var(eval_context_t* ctx) {
4363
4364 lbm_value key;
4365 lbm_value env;
4366
4367 28281372 lbm_pop_2(&ctx->K, &key, &env);
4368
4369
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 28281372 times.
 28281372 if (fill_binding_location(key, ctx->r, env) < 0) {
4370 ✗ lbm_set_error_reason("Incorrect type of name/key in let-binding");
4371 ✗ error_at_ctx(ENC_SYM_TERROR, key);
4372 }
4373
4374 28281372 ctx->app_cont = true;
4375 28281372 }
4376
4377 1766856 static void cont_setq(eval_context_t *ctx) {
4378 lbm_value sym;
4379 lbm_value env;
4380 1766856 lbm_pop_2(&ctx->K, &sym, &env);
4381 lbm_value res;
4382
1/4
✗ Branch 2 not taken.
✓ Branch 3 taken 1766856 times.
✗ Branch 7 not taken.
✗ Branch 8 not taken.
 1766856 WITH_GC(res, perform_setvar(sym, ctx->r, env));
4383 1766856 ctx->r = res;
4384 1766856 ctx->app_cont = true;
4385 1766856 }
4386
4387 2352 lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
4388
4389 lbm_value flash_cell;
4390 2352 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
4391
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2352 times.
 2352 if (s != LBM_FLASH_WRITE_OK)
4392 ✗ return s;
4393 2352 lbm_value new_val = val;
4394 2352 new_val &= ~LBM_PTR_VAL_MASK; // clear the value part of the ptr
4395 2352 new_val |= (flash_cell & LBM_PTR_VAL_MASK);
4396 2352 new_val |= LBM_PTR_TO_CONSTANT_BIT;
4397 2352 *res = new_val;
4398 2352 return s;
4399 }
4400
4401 728 static void cont_move_to_flash(eval_context_t *ctx) {
4402
4403 lbm_value args;
4404 728 lbm_pop(&ctx->K, &args);
4405
4406
2/2
✓ Branch 1 taken 308 times.
✓ Branch 2 taken 420 times.
 728 if (lbm_is_symbol_nil(args)) {
4407 // Done looping over arguments. return true.
4408 308 ctx->r = ENC_SYM_TRUE;
4409 308 ctx->app_cont = true;
4410 728 return;
4411 }
4412
4413 lbm_value first_arg, rest;
4414 420 get_car_and_cdr(args, &first_arg, &rest);
4415
4416 lbm_value val;
4417
2/4
✓ Branch 1 taken 420 times.
✗ Branch 2 not taken.
✓ Branch 4 taken 420 times.
✗ Branch 5 not taken.
 420 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
4418 // Prepare to copy the rest of the arguments when done with first.
4419 420 lbm_value *rptr = stack_reserve(ctx, 2);
4420 420 rptr[0] = rest;
4421 420 rptr[1] = MOVE_TO_FLASH;
4422
1/2
✓ Branch 1 taken 420 times.
✗ Branch 2 not taken.
 420 if (lbm_is_ptr(val) &&
4423
1/2
✓ Branch 0 taken 420 times.
✗ Branch 1 not taken.
 420 (!(val & LBM_PTR_TO_CONSTANT_BIT))) {
4424 420 lbm_value * rptr1 = stack_reserve(ctx, 3);
4425 420 rptr1[0] = first_arg;
4426 420 rptr1[1] = SET_GLOBAL_ENV;
4427 420 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH;
4428 420 ctx->r = val;
4429 }
4430 420 ctx->app_cont = true;
4431 420 return;
4432 }
4433 ✗ error_ctx(ENC_SYM_EERROR);
4434 }
4435
4436 3248 static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
4437
4438 3248 lbm_value val = ctx->r;
4439
4440
2/2
✓ Branch 1 taken 798 times.
✓ Branch 2 taken 2450 times.
 3248 if (lbm_is_cons(val)) {
4441 798 lbm_value *rptr = stack_reserve(ctx, 5);
4442 798 rptr[0] = ENC_SYM_NIL; // fst cell of list
4443 798 rptr[1] = ENC_SYM_NIL; // last cell of list
4444 798 rptr[2] = get_cdr(val);
4445 798 rptr[3] = MOVE_LIST_TO_FLASH;
4446 798 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
4447 798 ctx->r = get_car(val);
4448 798 ctx->app_cont = true;
4449 798 return;
4450 }
4451
4452
3/4
✓ Branch 1 taken 224 times.
✓ Branch 2 taken 2226 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 224 times.
 2450 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT)) {
4453 ✗ ctx->r = val;
4454 ✗ ctx->app_cont = true;
4455 ✗ return;
4456 }
4457
4458
2/2
✓ Branch 1 taken 224 times.
✓ Branch 2 taken 2226 times.
 2450 if (lbm_is_ptr(val)) {
4459 224 lbm_cons_t *ref = lbm_ref_cell(val);
4460
1/2
✓ Branch 1 taken 224 times.
✗ Branch 2 not taken.
 224 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL) {
4461
3/6
✓ Branch 0 taken 140 times.
✓ Branch 1 taken 56 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 28 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
 224 switch (ref->cdr) {
4462 140 case ENC_SYM_RAW_I_TYPE: /* fall through */
4463 case ENC_SYM_RAW_U_TYPE:
4464 case ENC_SYM_RAW_F_TYPE: {
4465 140 lbm_value flash_cell = ENC_SYM_NIL;
4466 140 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4467 140 handle_flash_status(write_const_car(flash_cell, ref->car));
4468 140 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4469 140 ctx->r = flash_cell;
4470 140 } break;
4471 56 case ENC_SYM_IND_I_TYPE: /* fall through */
4472 case ENC_SYM_IND_U_TYPE:
4473 case ENC_SYM_IND_F_TYPE: {
4474 #ifndef LBM64
4475 /* 64 bit values are in lbm mem on 32bit platforms. */
4476 56 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
4477 lbm_uint flash_ptr;
4478
4479 56 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
4480 56 lbm_value flash_cell = ENC_SYM_NIL;
4481 56 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4482 56 handle_flash_status(write_const_car(flash_cell, flash_ptr));
4483 56 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
4484 56 ctx->r = flash_cell;
4485 #else
4486 // There are no indirect types in LBM64
4487 error_ctx(ENC_SYM_FATAL_ERROR);
4488 #endif
4489 56 } break;
4490 ✗ case ENC_SYM_LISPARRAY_TYPE: {
4491 ✗ lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4492 ✗ lbm_uint size = arr->size / sizeof(lbm_uint);
4493 lbm_uint flash_addr;
4494 ✗ lbm_value *arrdata = (lbm_value *)arr->data;
4495 ✗ lbm_value flash_cell = ENC_SYM_NIL;
4496 ✗ handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4497 ✗ handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
4498 ✗ lift_array_flash(flash_cell,
4499 false,
4500 (char *)flash_addr,
4501 arr->size);
4502 // Move array contents to flash recursively
4503 ✗ lbm_value *rptr = stack_reserve(ctx, 5);
4504 ✗ rptr[0] = flash_cell;
4505 ✗ rptr[1] = lbm_enc_u(0);
4506 ✗ rptr[2] = val;
4507 ✗ rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH;
4508 ✗ rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
4509 ✗ ctx->r = arrdata[0];
4510 ✗ ctx->app_cont = true;
4511 ✗ return;
4512 }
4513 28 case ENC_SYM_ARRAY_TYPE: {
4514 28 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
4515 // arbitrary address: flash_arr.
4516 lbm_uint flash_arr;
4517 28 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
4518 28 lbm_value flash_cell = ENC_SYM_NIL;
4519 28 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
4520 28 lift_array_flash(flash_cell,
4521 true,
4522 (char *)flash_arr,
4523 arr->size);
4524 28 ctx->r = flash_cell;
4525 28 } break;
4526 ✗ case ENC_SYM_CHANNEL_TYPE: /* fall through */
4527 case ENC_SYM_CUSTOM_TYPE:
4528 ✗ lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
4529 ✗ error_ctx(ENC_SYM_EERROR);
4530 }
4531 224 } else {
4532 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4533 }
4534 224 ctx->app_cont = true;
4535 224 return;
4536 }
4537 2226 ctx->r = val;
4538 2226 ctx->app_cont = true;
4539 }
4540
4541 2016 static void cont_move_list_to_flash(eval_context_t *ctx) {
4542
4543 // ctx->r holds the value that should go in car
4544
4545 2016 lbm_value *sptr = get_stack_ptr(ctx, 3);
4546
4547 2016 lbm_value fst = sptr[0];
4548 2016 lbm_value lst = sptr[1];
4549 2016 lbm_value val = sptr[2];
4550
4551
4552 2016 lbm_value new_lst = ENC_SYM_NIL;
4553 // Allocate element ptr storage after storing the element to flash.
4554 2016 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL), &new_lst));
4555
4556
2/2
✓ Branch 1 taken 798 times.
✓ Branch 2 taken 1218 times.
 2016 if (lbm_is_symbol_nil(fst)) {
4557 798 lst = new_lst;
4558 798 fst = new_lst;
4559 798 handle_flash_status(write_const_car(lst, ctx->r));
4560 } else {
4561 1218 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
4562 1218 handle_flash_status(write_const_car(new_lst, ctx->r));
4563 1218 lst = new_lst;
4564 }
4565
4566
2/2
✓ Branch 1 taken 1218 times.
✓ Branch 2 taken 798 times.
 2016 if (lbm_is_cons(val)) {
4567 1218 sptr[0] = fst;
4568 1218 sptr[1] = lst;//rest_cell;
4569 1218 sptr[2] = get_cdr(val);
4570 1218 lbm_value *rptr = stack_reserve(ctx, 2);
4571 1218 rptr[0] = MOVE_LIST_TO_FLASH;
4572 1218 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
4573 1218 ctx->r = get_car(val);
4574 } else {
4575 798 sptr[0] = fst;
4576 798 sptr[1] = lst;
4577 798 sptr[2] = CLOSE_LIST_IN_FLASH;
4578 798 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
4579 798 ctx->r = val;
4580 }
4581 2016 ctx->app_cont = true;
4582 2016 }
4583
4584 798 static void cont_close_list_in_flash(eval_context_t *ctx) {
4585 lbm_value fst;
4586 lbm_value lst;
4587 798 lbm_pop_2(&ctx->K, &lst, &fst);
4588 798 lbm_value val = ctx->r;
4589 798 handle_flash_status(write_const_cdr(lst, val));
4590 798 ctx->r = fst;
4591 798 ctx->app_cont = true;
4592 798 }
4593
4594 ✗ static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
4595 ✗ lbm_value *sptr = get_stack_ptr(ctx, 3);
4596 // sptr[2] = source array in RAM
4597 // sptr[1] = current index
4598 // sptr[0] = target array in flash
4599 ✗ lbm_array_header_t *src_arr = (lbm_array_header_t*)get_car(sptr[2]);
4600 ✗ lbm_uint size = src_arr->size / sizeof(lbm_uint);
4601 ✗ lbm_value *srcdata = (lbm_value *)src_arr->data;
4602
4603 ✗ lbm_array_header_t *tgt_arr = (lbm_array_header_t*)get_car(sptr[0]);
4604 ✗ lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
4605 ✗ lbm_uint ix = lbm_dec_as_u32(sptr[1]);
4606 ✗ handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
4607 ✗ if (ix >= size-1) {
4608 ✗ ctx->r = sptr[0];
4609 ✗ lbm_stack_drop(&ctx->K, 3);
4610 ✗ ctx->app_cont = true;
4611 ✗ return;
4612 }
4613 ✗ sptr[1] = lbm_enc_u(ix + 1);
4614 ✗ lbm_value *rptr = stack_reserve(ctx, 2);
4615 ✗ rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH;
4616 ✗ rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
4617 ✗ ctx->r = srcdata[ix+1];
4618 ✗ ctx->app_cont = true;
4619 ✗ return;
4620 }
4621
4622 4732 static void cont_qq_expand_start(eval_context_t *ctx) {
4623 4732 lbm_value *rptr = stack_reserve(ctx, 2);
4624 4732 rptr[0] = ctx->r;
4625 4732 rptr[1] = QQ_EXPAND;
4626 4732 ctx->r = ENC_SYM_NIL;
4627 4732 ctx->app_cont = true;
4628 4732 }
4629
4630 9604 lbm_value quote_it(lbm_value qquoted) {
4631
3/4
✓ Branch 1 taken 9156 times.
✓ Branch 2 taken 448 times.
✓ Branch 3 taken 9156 times.
✗ Branch 4 not taken.
 18760 if (lbm_is_symbol(qquoted) &&
4632 18312 lbm_is_special(qquoted)) return qquoted;
4633
4634 448 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL, ENC_SYM_NIL);
4635 448 return cons_with_gc(ENC_SYM_QUOTE, val, ENC_SYM_NIL);
4636 }
4637
4638 35392 bool is_append(lbm_value a) {
4639
1/2
✓ Branch 1 taken 35336 times.
✗ Branch 2 not taken.
 70728 return (lbm_is_cons(a) &&
4640
4/4
✓ Branch 0 taken 35336 times.
✓ Branch 1 taken 56 times.
✓ Branch 4 taken 17472 times.
✓ Branch 5 taken 17864 times.
 70728 lbm_is_symbol(get_car(a)) &&
4641 35336 (get_car(a) == ENC_SYM_APPEND));
4642 }
4643
4644 59668 lbm_value append(lbm_value front, lbm_value back) {
4645
2/2
✓ Branch 1 taken 32172 times.
✓ Branch 2 taken 27496 times.
 59668 if (lbm_is_symbol_nil(front)) return back;
4646
2/2
✓ Branch 1 taken 9156 times.
✓ Branch 2 taken 18340 times.
 27496 if (lbm_is_symbol_nil(back)) return front;
4647
4648
4/4
✓ Branch 1 taken 9772 times.
✓ Branch 2 taken 8568 times.
✓ Branch 3 taken 448 times.
✓ Branch 4 taken 9324 times.
 28112 if (lbm_is_quoted_list(front) &&
4649 9772 lbm_is_quoted_list(back)) {
4650 448 lbm_value f = get_cadr(front);
4651 448 lbm_value b = get_cadr(back);
4652 448 return quote_it(lbm_list_append(f, b));
4653 }
4654
4655
4/4
✓ Branch 1 taken 8932 times.
✓ Branch 2 taken 8960 times.
✓ Branch 3 taken 392 times.
✓ Branch 4 taken 8540 times.
 26824 if (is_append(back) &&
4656
1/2
✓ Branch 2 taken 392 times.
✗ Branch 3 not taken.
 9324 lbm_is_quoted_list(get_cadr(back)) &&
4657 392 lbm_is_quoted_list(front)) {
4658 392 lbm_value ql = get_cadr(back);
4659 392 lbm_value f = get_cadr(front);
4660 392 lbm_value b = get_cadr(ql);
4661
4662 392 lbm_value v = lbm_list_append(f, b);
4663 392 lbm_set_car(get_cdr(ql), v);
4664 392 return back;
4665 }
4666
4667
2/2
✓ Branch 1 taken 8540 times.
✓ Branch 2 taken 8960 times.
 17500 if (is_append(back)) {
4668 8540 back = get_cdr(back);
4669 8540 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL);
4670 8540 return cons_with_gc(ENC_SYM_APPEND, new, ENC_SYM_NIL);
4671 }
4672
4673 lbm_value t0, t1;
4674
4675 8960 t0 = cons_with_gc(back, ENC_SYM_NIL, front);
4676 8960 t1 = cons_with_gc(front, t0, ENC_SYM_NIL);
4677 8960 return cons_with_gc(ENC_SYM_APPEND, t1, ENC_SYM_NIL);
4678 }
4679
4680 /* Bawden's qq-expand implementation
4681 (define (qq-expand x)
4682 (cond ((tag-comma? x)
4683 (tag-data x))
4684 ((tag-comma-atsign? x)
4685 (error "Illegal"))
4686 ((tag-backquote? x)
4687 (qq-expand
4688 (qq-expand (tag-data x))))
4689 ((pair? x)
4690 `(append
4691 ,(qq-expand-list (car x))
4692 ,(qq-expand (cdr x))))
4693 (else `',x)))
4694 */
4695 32228 static void cont_qq_expand(eval_context_t *ctx) {
4696 lbm_value qquoted;
4697 32228 lbm_pop(&ctx->K, &qquoted);
4698
4699
2/2
✓ Branch 1 taken 23072 times.
✓ Branch 2 taken 9156 times.
 32228 switch(lbm_type_of(qquoted)) {
4700 23072 case LBM_TYPE_CONS: {
4701 23072 lbm_value car_val = get_car(qquoted);
4702 23072 lbm_value cdr_val = get_cdr(qquoted);
4703
4/4
✓ Branch 1 taken 4760 times.
✓ Branch 2 taken 18312 times.
✓ Branch 3 taken 28 times.
✓ Branch 4 taken 4732 times.
 23072 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
4704 car_val == ENC_SYM_COMMA) {
4705 28 ctx->r = append(ctx->r, get_car(cdr_val));
4706 28 ctx->app_cont = true;
4707
3/4
✓ Branch 1 taken 4732 times.
✓ Branch 2 taken 18312 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 4732 times.
 23044 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
4708 car_val == ENC_SYM_COMMAAT) {
4709 ✗ error_ctx(ENC_SYM_RERROR);
4710 } else {
4711 23044 lbm_value *rptr = stack_reserve(ctx, 6);
4712 23044 rptr[0] = ctx->r;
4713 23044 rptr[1] = QQ_APPEND;
4714 23044 rptr[2] = cdr_val;
4715 23044 rptr[3] = QQ_EXPAND;
4716 23044 rptr[4] = car_val;
4717 23044 rptr[5] = QQ_EXPAND_LIST;
4718 23044 ctx->app_cont = true;
4719 23044 ctx->r = ENC_SYM_NIL;
4720 }
4721
4722 23072 } break;
4723 9156 default: {
4724 9156 lbm_value res = quote_it(qquoted);
4725 9156 ctx->r = append(ctx->r, res);
4726 9156 ctx->app_cont = true;
4727 }
4728 }
4729 32228 }
4730
4731 27496 static void cont_qq_append(eval_context_t *ctx) {
4732 lbm_value head;
4733 27496 lbm_pop(&ctx->K, &head);
4734 27496 ctx->r = append(head, ctx->r);
4735 27496 ctx->app_cont = true;
4736 27496 }
4737
4738 /* Bawden's qq-expand-list implementation
4739 (define (qq-expand-list x)
4740 (cond ((tag-comma? x)
4741 `(list ,(tag-data x)))
4742 ((tag-comma-atsign? x)
4743 (tag-data x))
4744 ((tag-backquote? x)
4745 (qq-expand-list
4746 (qq-expand (tag-data x))))
4747 ((pair? x)
4748 `(list
4749 (append
4750 ,(qq-expand-list (car x))
4751 ,(qq-expand (cdr x)))))
4752 (else `'(,x))))
4753 */
4754
4755 27496 static void cont_qq_expand_list(eval_context_t* ctx) {
4756 lbm_value l;
4757 27496 lbm_pop(&ctx->K, &l);
4758
4759 27496 ctx->app_cont = true;
4760
2/2
✓ Branch 1 taken 17500 times.
✓ Branch 2 taken 9996 times.
 27496 switch(lbm_type_of(l)) {
4761 17500 case LBM_TYPE_CONS: {
4762 17500 lbm_value car_val = get_car(l);
4763 17500 lbm_value cdr_val = get_cdr(l);
4764
3/4
✓ Branch 1 taken 17500 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 12992 times.
✓ Branch 4 taken 4508 times.
 17500 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
4765 car_val == ENC_SYM_COMMA) {
4766 12992 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL);
4767 12992 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL);
4768 12992 ctx->r = append(ctx->r, tmp);
4769 13048 return;
4770
3/4
✓ Branch 1 taken 4508 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 56 times.
✓ Branch 4 taken 4452 times.
 4508 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
4771 car_val == ENC_SYM_COMMAAT) {
4772 56 ctx->r = get_car(cdr_val);
4773 56 return;
4774 } else {
4775 4452 lbm_value *rptr = stack_reserve(ctx, 7);
4776 4452 rptr[0] = QQ_LIST;
4777 4452 rptr[1] = ctx->r;
4778 4452 rptr[2] = QQ_APPEND;
4779 4452 rptr[3] = cdr_val;
4780 4452 rptr[4] = QQ_EXPAND;
4781 4452 rptr[5] = car_val;
4782 4452 rptr[6] = QQ_EXPAND_LIST;
4783 4452 ctx->r = ENC_SYM_NIL;
4784 }
4785
4786 4452 } break;
4787 9996 default: {
4788 9996 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL, ENC_SYM_NIL);
4789 9996 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL, ENC_SYM_NIL);
4790 9996 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE, tl, ENC_SYM_NIL);
4791 9996 ctx->r = append(ctx->r, tmp);
4792 }
4793 }
4794 }
4795
4796 4452 static void cont_qq_list(eval_context_t *ctx) {
4797 4452 lbm_value val = ctx->r;
4798 4452 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL, ENC_SYM_NIL);
4799 4452 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, apnd_app, ENC_SYM_NIL);
4800 4452 ctx->r = tmp;
4801 4452 ctx->app_cont = true;
4802 4452 }
4803
4804 ✗ static void cont_kill(eval_context_t *ctx) {
4805 (void) ctx;
4806 ✗ finish_ctx();
4807 ✗ }
4808
4809 ✗ static void cont_pop_reader_flags(eval_context_t *ctx) {
4810 lbm_value flags;
4811 ✗ lbm_pop(&ctx->K, &flags);
4812 ✗ ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
4813 ✗ ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
4814 // r is unchanged.
4815 ✗ ctx->app_cont = true;
4816 ✗ }
4817
4818 336 static void cont_exception_handler(eval_context_t *ctx) {
4819 336 lbm_value *sptr = pop_stack_ptr(ctx, 2);
4820 336 lbm_value retval = sptr[0];
4821 336 lbm_value flags = sptr[1];
4822 336 lbm_set_car(get_cdr(retval), ctx->r);
4823 336 ctx->flags = flags;
4824 336 ctx->r = retval;
4825 336 ctx->app_cont = true;
4826 336 }
4827
4828 /*********************************************************/
4829 /* Continuations table */
4830 typedef void (*cont_fun)(eval_context_t *);
4831
4832 static const cont_fun continuations[NUM_CONTINUATIONS] =
4833 { advance_ctx, // CONT_DONE
4834 cont_set_global_env,
4835 cont_bind_to_key_rest,
4836 cont_if,
4837 cont_progn_rest,
4838 cont_application_args,
4839 cont_and,
4840 cont_or,
4841 cont_wait,
4842 cont_match,
4843 cont_application_start,
4844 cont_eval_r,
4845 cont_resume,
4846 cont_closure_application_args,
4847 cont_exit_atomic,
4848 cont_read_next_token,
4849 cont_read_append_continue,
4850 cont_read_eval_continue,
4851 cont_read_expect_closepar,
4852 cont_read_dot_terminate,
4853 cont_read_done,
4854 cont_read_quote_result,
4855 cont_read_commaat_result,
4856 cont_read_comma_result,
4857 cont_read_start_array,
4858 cont_read_append_array,
4859 cont_map,
4860 cont_match_guard,
4861 cont_terminate,
4862 cont_progn_var,
4863 cont_setq,
4864 cont_move_to_flash,
4865 cont_move_val_to_flash_dispatch,
4866 cont_move_list_to_flash,
4867 cont_close_list_in_flash,
4868 cont_qq_expand_start,
4869 cont_qq_expand,
4870 cont_qq_append,
4871 cont_qq_expand_list,
4872 cont_qq_list,
4873 cont_kill,
4874 cont_loop,
4875 cont_loop_condition,
4876 cont_merge_rest,
4877 cont_merge_layer,
4878 cont_closure_args_rest,
4879 cont_move_array_elts_to_flash,
4880 cont_pop_reader_flags,
4881 cont_exception_handler
4882 };
4883
4884 /*********************************************************/
4885 /* Evaluators lookup table (special forms) */
4886 typedef void (*evaluator_fun)(eval_context_t *);
4887
4888 static const evaluator_fun evaluators[] =
4889 {
4890 eval_quote,
4891 eval_define,
4892 eval_progn,
4893 eval_lambda,
4894 eval_if,
4895 eval_let,
4896 eval_and,
4897 eval_or,
4898 eval_match,
4899 eval_receive,
4900 eval_receive_timeout,
4901 eval_callcc,
4902 eval_atomic,
4903 eval_selfevaluating, // macro
4904 eval_selfevaluating, // cont
4905 eval_selfevaluating, // closure
4906 eval_cond,
4907 eval_app_cont,
4908 eval_var,
4909 eval_setq,
4910 eval_move_to_flash,
4911 eval_loop,
4912 eval_trap
4913 };
4914
4915
4916 /*********************************************************/
4917 /* Evaluator step function */
4918
4919 3958569036 static void evaluation_step(void){
4920 3958569036 eval_context_t *ctx = ctx_running;
4921 #ifdef VISUALIZE_HEAP
4922 heap_vis_gen_image();
4923 #endif
4924
4925
2/2
✓ Branch 0 taken 1793938795 times.
✓ Branch 1 taken 2164630241 times.
 3958569036 if (ctx->app_cont) {
4926 lbm_value k;
4927 1793938795 lbm_pop(&ctx->K, &k);
4928 1793938795 ctx->app_cont = false;
4929
4930 1793938795 lbm_uint decoded_k = DEC_CONTINUATION(k);
4931
4932
1/2
✓ Branch 0 taken 1793938795 times.
✗ Branch 1 not taken.
 1793938795 if (decoded_k < NUM_CONTINUATIONS) {
4933 1793938795 continuations[decoded_k](ctx);
4934 } else {
4935 ✗ error_ctx(ENC_SYM_FATAL_ERROR);
4936 }
4937 1793938451 return;
4938 }
4939
4940
2/2
✓ Branch 1 taken 845325353 times.
✓ Branch 2 taken 1319304888 times.
 2164630241 if (lbm_is_symbol(ctx->curr_exp)) {
4941 845325353 eval_symbol(ctx);
4942 845325325 return;
4943 }
4944
2/2
✓ Branch 1 taken 682698651 times.
✓ Branch 2 taken 636606237 times.
 1319304888 if (lbm_is_cons(ctx->curr_exp)) {
4945 682698651 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
4946 682698651 lbm_value h = cell->car;
4947
4/4
✓ Branch 1 taken 680736411 times.
✓ Branch 2 taken 1962240 times.
✓ Branch 3 taken 311016632 times.
✓ Branch 4 taken 369719779 times.
 682698651 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK) == ENC_SPECIAL_FORMS_BIT)) {
4948 311016632 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK;
4949 311016632 evaluators[eval_index](ctx);
4950 311016632 return;
4951 }
4952 /*
4953 * At this point head can be anything. It should evaluate
4954 * into a form that can be applied (closure, symbol, ...) though.
4955 */
4956 371682019 lbm_value *reserved = stack_reserve(ctx, 3);
4957 371682019 reserved[0] = ctx->curr_env;
4958 371682019 reserved[1] = cell->cdr;
4959 371682019 reserved[2] = APPLICATION_START;
4960 371682019 ctx->curr_exp = h; // evaluate the function
4961 371682019 return;
4962 }
4963
4964 636606237 eval_selfevaluating(ctx);
4965 636606237 return;
4966 }
4967
4968 17436 void lbm_pause_eval(void ) {
4969 17436 eval_cps_next_state_arg = 0;
4970 17436 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
4971
1/2
✓ Branch 0 taken 17436 times.
✗ Branch 1 not taken.
 17436 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
4972 17436 }
4973
4974 17444 void lbm_pause_eval_with_gc(uint32_t num_free) {
4975 17444 eval_cps_next_state_arg = num_free;
4976 17444 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
4977
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
4978 17444 }
4979
4980 17444 void lbm_continue_eval(void) {
4981 17444 eval_cps_next_state = EVAL_CPS_STATE_RUNNING;
4982
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
4983 17444 }
4984
4985 ✗ void lbm_kill_eval(void) {
4986 ✗ eval_cps_next_state = EVAL_CPS_STATE_KILL;
4987 ✗ if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
4988 ✗ }
4989
4990 119259 uint32_t lbm_get_eval_state(void) {
4991 119259 return eval_cps_run_state;
4992 }
4993
4994 // Will wake up thread that is sleeping as well.
4995 // Not sure this is good behavior.
4996 56 static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
4997 56 eval_context_t *found = NULL;
4998 56 mutex_lock(&qmutex);
4999
5000 56 found = lookup_ctx_nm(&blocked, cid);
5001
1/2
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
 56 if (found) {
5002 56 drop_ctx_nm(&blocked,found);
5003
2/2
✓ Branch 1 taken 28 times.
✓ Branch 2 taken 28 times.
 56 if (lbm_is_error(v)) {
5004 28 get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
5005 28 found->app_cont = true;
5006 }
5007 56 found->r = v;
5008 56 enqueue_ctx_nm(&queue,found);
5009 }
5010 56 mutex_unlock(&qmutex);
5011 56 }
5012
5013 ✗ static void handle_event_define(lbm_value key, lbm_value val) {
5014 ✗ lbm_uint dec_key = lbm_dec_sym(key);
5015 ✗ lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
5016 ✗ lbm_value *global_env = lbm_get_global_env();
5017 ✗ lbm_uint orig_env = global_env[ix_key];
5018 lbm_value new_env;
5019 // A key is a symbol and should not need to be remembered.
5020 ✗ WITH_GC(new_env, lbm_env_set(orig_env,key,val));
5021
5022 ✗ global_env[ix_key] = new_env;
5023 ✗ }
5024
5025 8057 static lbm_value get_event_value(lbm_event_t *e) {
5026 lbm_value v;
5027
1/2
✓ Branch 0 taken 8057 times.
✗ Branch 1 not taken.
 8057 if (e->buf_len > 0) {
5028 lbm_flat_value_t fv;
5029 8057 fv.buf = (uint8_t*)e->buf_ptr;
5030 8057 fv.buf_size = e->buf_len;
5031 8057 fv.buf_pos = 0;
5032
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 8057 times.
 8057 if (!lbm_unflatten_value(&fv, &v)) {
5033 ✗ lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED);
5034 ✗ v = ENC_SYM_EERROR;
5035 }
5036 // Free the flat value buffer. GC is unaware of its existence.
5037 8057 lbm_free(fv.buf);
5038 } else {
5039 ✗ v = (lbm_value)e->buf_ptr;
5040 }
5041 8057 return v;
5042 }
5043
5044 397122774 static void process_events(void) {
5045
5046
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 397122774 times.
 397122774 if (!lbm_events) return;
5047 lbm_event_t e;
5048
5049
2/2
✓ Branch 0 taken 8057 times.
✓ Branch 1 taken 397122774 times.
 794253605 while (lbm_event_pop(&e)) {
5050
5051 8057 lbm_value event_val = get_event_value(&e);
5052
2/4
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 8001 times.
✗ Branch 3 not taken.
 8057 switch(e.type) {
5053 56 case LBM_EVENT_UNBLOCK_CTX:
5054 56 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5055 56 break;
5056 ✗ case LBM_EVENT_DEFINE:
5057 ✗ handle_event_define((lbm_value)e.parameter, event_val);
5058 ✗ break;
5059 8001 case LBM_EVENT_FOR_HANDLER:
5060
1/2
✓ Branch 0 taken 8001 times.
✗ Branch 1 not taken.
 8001 if (lbm_event_handler_pid >= 0) {
5061 8001 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5062 }
5063 8001 break;
5064 }
5065 397130831 }
5066 }
5067
5068 /* eval_cps_run can be paused
5069 I think it would be better use a mailbox for
5070 communication between other threads and the run_eval
5071 but for now a set of variables will be used. */
5072 17444 void lbm_run_eval(void){
5073
5074
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 17444 times.
 17444 if (setjmp(critical_error_jmp_buf) > 0) {
5075 ✗ printf_callback("GC stack overflow!\n");
5076 ✗ critical_error_callback();
5077 // terminate evaluation thread.
5078 ✗ return;
5079 }
5080
5081 17444 setjmp(error_jmp_buf);
5082
5083
1/1
✓ Branch 0 taken 82987 times.
 81717 while (eval_running) {
5084
4/4
✓ Branch 0 taken 30662 times.
✓ Branch 1 taken 52325 times.
✓ Branch 2 taken 17796 times.
✓ Branch 3 taken 12866 times.
 82987 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED) {
5085 65191 eval_cps_state_changed = false;
5086
2/3
✓ Branch 0 taken 47747 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 17444 times.
 65191 switch (eval_cps_next_state) {
5087 47747 case EVAL_CPS_STATE_PAUSED:
5088
2/2
✓ Branch 0 taken 34880 times.
✓ Branch 1 taken 12867 times.
 47747 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED) {
5089
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 34880 times.
 34880 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5090 ✗ gc();
5091 }
5092 34880 eval_cps_next_state_arg = 0;
5093 }
5094 47747 eval_cps_run_state = EVAL_CPS_STATE_PAUSED;
5095 47747 usleep_callback(EVAL_CPS_MIN_SLEEP);
5096 29041 continue; /* jump back to start of eval_running loop */
5097 ✗ case EVAL_CPS_STATE_KILL:
5098 ✗ eval_cps_run_state = EVAL_CPS_STATE_DEAD;
5099 ✗ eval_running = false;
5100 ✗ continue;
5101 17444 default: // running state
5102 17444 eval_cps_run_state = eval_cps_next_state;
5103 17444 break;
5104 }
5105 17796 }
5106 while (true) {
5107
4/4
✓ Branch 0 taken 3959879252 times.
✓ Branch 1 taken 395848160 times.
✓ Branch 2 taken 3958569036 times.
✓ Branch 3 taken 1310216 times.
 4355727412 if (eval_steps_quota && ctx_running) {
5108 3958569036 eval_steps_quota--;
5109 3958569036 evaluation_step();
5110 } else {
5111
2/2
✓ Branch 0 taken 34860 times.
✓ Branch 1 taken 397123516 times.
 397158376 if (eval_cps_state_changed) break;
5112 397123516 eval_steps_quota = eval_steps_refill;
5113
2/2
✓ Branch 0 taken 742 times.
✓ Branch 1 taken 397122774 times.
 397123516 if (is_atomic) {
5114
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 742 times.
 742 if (!ctx_running) {
5115 ✗ lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION);
5116 ✗ is_atomic = 0;
5117 }
5118 } else {
5119
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 397122746 times.
 397122774 if (gc_requested) {
5120 28 gc();
5121 }
5122 397122774 process_events();
5123 397122774 mutex_lock(&qmutex);
5124
2/2
✓ Branch 0 taken 395816334 times.
✓ Branch 1 taken 1306440 times.
 397122774 if (ctx_running) {
5125 395816334 enqueue_ctx_nm(&queue, ctx_running);
5126 395816334 ctx_running = NULL;
5127 }
5128 397122774 wake_up_ctxs_nm();
5129 397122774 ctx_running = dequeue_ctx_nm(&queue);
5130 397122774 mutex_unlock(&qmutex);
5131
2/2
✓ Branch 0 taken 1256179 times.
✓ Branch 1 taken 395866595 times.
 397122774 if (!ctx_running) {
5132 1256179 lbm_system_sleeping = true;
5133 //Fixed sleep interval to poll events regularly.
5134 1256179 usleep_callback(EVAL_CPS_MIN_SLEEP);
5135 1256171 lbm_system_sleeping = false;
5136 }
5137 }
5138 }
5139 }
5140 }
5141 }
5142
5143 ✗ lbm_cid lbm_eval_program(lbm_value lisp) {
5144 ✗ return lbm_create_ctx(lisp, ENC_SYM_NIL, 256, NULL);
5145 }
5146
5147 ✗ lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
5148 ✗ return lbm_create_ctx(lisp, ENC_SYM_NIL, stack_size, NULL);
5149 }
5150
5151 17444 int lbm_eval_init() {
5152
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (!qmutex_initialized) {
5153 17444 mutex_init(&qmutex);
5154 17444 qmutex_initialized = true;
5155 }
5156
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (!lbm_events_mutex_initialized) {
5157 17444 mutex_init(&lbm_events_mutex);
5158 17444 lbm_events_mutex_initialized = true;
5159 }
5160
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (!blocking_extension_mutex_initialized) {
5161 17444 mutex_init(&blocking_extension_mutex);
5162 17444 blocking_extension_mutex_initialized = true;
5163 }
5164
5165 17444 mutex_lock(&qmutex);
5166 17444 mutex_lock(&lbm_events_mutex);
5167
5168 17444 blocked.first = NULL;
5169 17444 blocked.last = NULL;
5170 17444 queue.first = NULL;
5171 17444 queue.last = NULL;
5172 17444 ctx_running = NULL;
5173
5174 17444 eval_cps_run_state = EVAL_CPS_STATE_RUNNING;
5175
5176 17444 mutex_unlock(&lbm_events_mutex);
5177 17444 mutex_unlock(&qmutex);
5178
5179
1/2
✗ Branch 1 not taken.
✓ Branch 2 taken 17444 times.
 17444 if (!lbm_init_env()) return 0;
5180 17444 eval_running = true;
5181 17444 return 1;
5182 }
5183
5184 17444 bool lbm_eval_init_events(unsigned int num_events) {
5185
5186 17444 mutex_lock(&lbm_events_mutex);
5187 17444 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
5188 17444 bool r = false;
5189
1/2
✓ Branch 0 taken 17444 times.
✗ Branch 1 not taken.
 17444 if (lbm_events) {
5190 17444 lbm_events_max = num_events;
5191 17444 lbm_events_head = 0;
5192 17444 lbm_events_tail = 0;
5193 17444 lbm_events_full = false;
5194 17444 lbm_event_handler_pid = -1;
5195 17444 r = true;
5196 }
5197 17444 mutex_unlock(&lbm_events_mutex);
5198 17444 return r;
5199 }
5200