GCC Code Coverage Report

Directory: ../src/
File: /home/joels/Current/lispbm/src/eval_cps.c
Date: 2025-08-08 18:10:24
Exec Total Coverage
Lines: 3186 3441 92.6%
Functions: 212 223 95.1%
Branches: 1069 1394 76.7%
Line Branch Exec Source
1 /*
2 Copyright 2018, 2020 - 2025 Joel Svensson svenssonjoel@yahoo.se
3 2025 Rasmus Söderhielm rasmus.soderhielm@gmail.com
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19 #include <lbm_memory.h>
20 #include <lbm_types.h>
21 #include "symrepr.h"
22 #include "heap.h"
23 #include "env.h"
24 #include "eval_cps.h"
25 #include "stack.h"
26 #include "fundamental.h"
27 #include "extensions.h"
28 #include "tokpar.h"
29 #include "lbm_channel.h"
30 #include "print.h"
31 #include "platform_mutex.h"
32 #include "lbm_flat_value.h"
33
34 #include <setjmp.h>
35 #include <stdarg.h>
36 #include <stdnoreturn.h>
37
38 #if __STDC_VERSION__ < 201112L
39 // Lower than C11
40 #undef noreturn
41 #define noreturn __attribute__ ((__noreturn__))
42 #endif
43
44 static jmp_buf error_jmp_buf;
45 static jmp_buf critical_error_jmp_buf;
46
47 #define S_TO_US(X) (lbm_uint)((X) * 1000000)
48
49 #define DEC_CONTINUATION(x) (((x) & ~LBM_CONTINUATION_INTERNAL) >> LBM_ADDRESS_SHIFT)
50 #define IS_CONTINUATION(x) (((x) & LBM_CONTINUATION_INTERNAL) == LBM_CONTINUATION_INTERNAL)
51 #define CONTINUATION(x) (((x) << LBM_ADDRESS_SHIFT) | LBM_CONTINUATION_INTERNAL)
52
53 #define DONE CONTINUATION(0)
54 #define SET_GLOBAL_ENV CONTINUATION(1)
55 #define BIND_TO_KEY_REST CONTINUATION(2)
56 #define IF CONTINUATION(3)
57 #define PROGN_REST CONTINUATION(4)
58 #define APPLICATION_ARGS CONTINUATION(5)
59 #define AND CONTINUATION(6)
60 #define OR CONTINUATION(7)
61 #define WAIT CONTINUATION(8)
62 #define MATCH CONTINUATION(9)
63 #define APPLICATION_START CONTINUATION(10)
64 #define EVAL_R CONTINUATION(11)
65 #define RESUME CONTINUATION(12)
66 #define CLOSURE_ARGS CONTINUATION(13)
67 #define EXIT_ATOMIC CONTINUATION(14)
68 #define READ_NEXT_TOKEN CONTINUATION(15)
69 #define READ_APPEND_CONTINUE CONTINUATION(16)
70 #define READ_EVAL_CONTINUE CONTINUATION(17)
71 #define READ_EXPECT_CLOSEPAR CONTINUATION(18)
72 #define READ_DOT_TERMINATE CONTINUATION(19)
73 #define READ_DONE CONTINUATION(20)
74 #define READ_START_BYTEARRAY CONTINUATION(21)
75 #define READ_APPEND_BYTEARRAY CONTINUATION(22)
76 #define MAP CONTINUATION(23)
77 #define MATCH_GUARD CONTINUATION(24)
78 #define TERMINATE CONTINUATION(25)
79 #define PROGN_VAR CONTINUATION(26)
80 #define SETQ CONTINUATION(27)
81 #define MOVE_TO_FLASH CONTINUATION(28)
82 #define MOVE_VAL_TO_FLASH_DISPATCH CONTINUATION(29)
83 #define MOVE_LIST_TO_FLASH CONTINUATION(30)
84 #define CLOSE_LIST_IN_FLASH CONTINUATION(31)
85 #define QQ_EXPAND_START CONTINUATION(32)
86 #define QQ_EXPAND CONTINUATION(33)
87 #define QQ_APPEND CONTINUATION(34)
88 #define QQ_EXPAND_LIST CONTINUATION(35)
89 #define QQ_LIST CONTINUATION(36)
90 #define KILL CONTINUATION(37)
91 #define LOOP CONTINUATION(38)
92 #define LOOP_CONDITION CONTINUATION(39)
93 #define MERGE_REST CONTINUATION(40)
94 #define MERGE_LAYER CONTINUATION(41)
95 #define CLOSURE_ARGS_REST CONTINUATION(42)
96 #define MOVE_ARRAY_ELTS_TO_FLASH CONTINUATION(43)
97 #define POP_READER_FLAGS CONTINUATION(44)
98 #define EXCEPTION_HANDLER CONTINUATION(45)
99 #define RECV_TO CONTINUATION(46)
100 #define WRAP_RESULT CONTINUATION(47)
101 #define RECV_TO_RETRY CONTINUATION(48)
102 #define READ_START_ARRAY CONTINUATION(49)
103 #define READ_APPEND_ARRAY CONTINUATION(50)
104 #define LOOP_ENV_PREP CONTINUATION(51)
105 #define NUM_CONTINUATIONS 52
106
107 #define FM_NEED_GC -1
108 #define FM_NO_MATCH -2
109 #define FM_PATTERN_ERROR -3
110
111 typedef enum {
112 BL_OK = 0,
113 BL_NO_MEMORY,
114 BL_INCORRECT_KEY
115 } binding_location_status;
116
117 #define FB_OK 0
118 #define FB_TYPE_ERROR -1
119
120 #ifdef LBM_USE_ERROR_LINENO
121 #define ERROR_AT_CTX(err_val, at) error_at_ctx(err_val, at, __LINE__)
122 #define ERROR_CTX(err_val) error_ctx(err_val, __LINE__)
123 #define READ_ERROR_CTX(row, col) read_error_ctx(row, col, __LINE__)
124 #else
125 #define ERROR_AT_CTX(err_val, at) error_at_ctx(err_val, at)
126 #define ERROR_CTX(err_val) error_ctx(err_val)
127 #define READ_ERROR_CTX(row, col) read_error_ctx(row, col)
128 #endif
129
130 // ////////////////////////////////////////////////////////////
131 // Local variables used in sort and merge
132 lbm_value symbol_x = ENC_SYM_NIL;
133 lbm_value symbol_y = ENC_SYM_NIL;
134 #ifdef CLEAN_UP_CLOSURES
135 static lbm_value clean_cl_env_symbol = ENC_SYM_NIL;
136 #endif
137
138 // ////////////////////////////////////////////////////////////
139 // Error strings
140 const char* lbm_error_str_parse_eof = "End of parse stream.";
141 const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
142 const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
143 const char* lbm_error_str_num_args = "Incorrect number of arguments.";
144 const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
145 const char* lbm_error_str_no_number = "Argument(s) must be a number.";
146 const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
147 const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
148 const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
149 const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
150 const char* lbm_error_str_flash_error = "Error writing to flash.";
151 const char* lbm_error_str_flash_full = "Flash memory is full.";
152 const char* lbm_error_str_variable_not_bound = "Variable not bound.";
153 const char* lbm_error_str_read_no_mem = "Out of memory while reading.";
154 const char* lbm_error_str_qq_expand = "Quasiquotation expansion error.";
155 const char* lbm_error_str_not_applicable = "Value is not applicable.";
156 const char* lbm_error_str_built_in = "Cannot redefine built-in.";
157
158 static lbm_value lbm_error_suspect;
159 static bool lbm_error_has_suspect = false;
160
161
162 // ////////////////////////////////////////////////////////////
163 // Prototypes for locally used functions (static)
164 static uint32_t lbm_mailbox_free_space_for_cid(lbm_cid cid);
165 static void apply_apply(lbm_value *args, lbm_uint nargs, eval_context_t *ctx);
166 static int gc(void);
167 #ifdef LBM_USE_ERROR_LINENO
168 static void error_ctx(lbm_value, int line_no);
169 static void error_at_ctx(lbm_value err_val, lbm_value at, int line_no);
170 #else
171 static void error_ctx(lbm_value);
172 static void error_at_ctx(lbm_value err_val, lbm_value at);
173 #endif
174 static void mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
175
176 // TODO: Optimize, In a large number of cases
177 // where WITH_GC is used, it is not really required to check is_symbol_merror.
178 // Just checking is_symbol should be enough.
179 // Given the number of calls to WITH_GC this could save some code
180 // space and potentially also be a slight speedup.
181 // TODO: profile.
182 #ifdef LBM_ALWAYS_GC
183 #define WITH_GC(y, x) \
184 gc(); \
185 (y) = (x); \
186 if (lbm_is_symbol_merror((y))) { \
187 ERROR_CTX(ENC_SYM_MERROR); \
188 }
189
190 #define WITH_GC_RMBR_1(y, x, r) \
191 lbm_gc_mark_phase(r); \
192 gc(); \
193 (y) = (x); \
194 if (lbm_is_symbol_merror((y))) { \
195 ERROR_CTX(ENC_SYM_MERROR); \
196 }
197
198 #else
199
200 #define WITH_GC(y, x) \
201 (y) = (x); \
202 if (lbm_is_symbol_merror((y))) { \
203 gc(); \
204 (y) = (x); \
205 if (lbm_is_symbol_merror((y))) { \
206 ERROR_CTX(ENC_SYM_MERROR); \
207 } \
208 /* continue executing statements below */ \
209 }
210 #define WITH_GC_RMBR_1(y, x, r) \
211 (y) = (x); \
212 if (lbm_is_symbol_merror((y))) { \
213 lbm_gc_mark_phase(r); \
214 gc(); \
215 (y) = (x); \
216 if (lbm_is_symbol_merror((y))) { \
217 ERROR_CTX(ENC_SYM_MERROR); \
218 } \
219 /* continue executing statements below */ \
220 }
221 #endif
222
223 // ////////////////////////////////////////////////////////////
224 // Context queues
225 typedef struct {
226 eval_context_t *first;
227 eval_context_t *last;
228 } eval_context_queue_t;
229
230 static eval_context_queue_t blocked = {NULL, NULL};
231 static eval_context_queue_t queue = {NULL, NULL};
232
233 mutex_t qmutex;
234 bool qmutex_initialized = false;
235
236 static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
237
238 // The currently executing context.
239 eval_context_t *ctx_running = NULL;
240 volatile bool lbm_system_sleeping = false;
241
242 static volatile bool gc_requested = false;
243 7605 void lbm_request_gc(void) {
244 7605 gc_requested = true;
245 7605 }
246
247 /*
248 On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
249 resolution of the timer used for sleep operations. If this is set
250 to 10KHz the resolution is 100us.
251
252 The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
253 can be safely specified in a timeout directive (wonder if that
254 means sleep-period). The timedelta is set to 2.
255
256 If I have understood these correctly it means that the minimum
257 sleep duration possible is 2 * 100us = 200us.
258 */
259
260 #define EVAL_CPS_DEFAULT_STACK_SIZE 256
261 #define EVAL_TIME_QUOTA 400 // time in used, if time quota
262 #define EVAL_CPS_MIN_SLEEP 200
263 #define EVAL_STEPS_QUOTA 10
264
265 #ifdef LBM_USE_TIME_QUOTA
266 static volatile uint32_t eval_time_refill = EVAL_TIME_QUOTA;
267 static uint32_t eval_time_quota = EVAL_TIME_QUOTA;
268 static uint32_t eval_current_quota = 0;
269 1 void lbm_set_eval_time_quota(uint32_t quota) {
270 1 eval_time_refill = quota;
271 1 }
272 #else
273 static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA;
274 static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA;
275 56 void lbm_set_eval_step_quota(uint32_t quota) {
276 56 eval_steps_refill = quota;
277 56 }
278 #endif
279
280 static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD;
281 static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE;
282 static volatile uint32_t eval_cps_next_state_arg = 0;
283 static volatile bool eval_cps_state_changed = false;
284
285 ✗ static void usleep_nonsense(uint32_t us) {
286 (void) us;
287 ✗ }
288
289 ✗ static bool dynamic_load_nonsense(const char *sym, const char **code) {
290 (void) sym;
291 (void) code;
292 ✗ return false;
293 }
294
295 ✗ static uint32_t timestamp_nonsense(void) {
296 ✗ return 0;
297 }
298
299 ✗ static int printf_nonsense(const char *fmt, ...) {
300 (void) fmt;
301 ✗ return 0;
302 }
303
304 ✗ static void ctx_done_nonsense(eval_context_t *ctx) {
305 (void) ctx;
306 ✗ }
307
308 ✗ static void critical_nonsense(void) {
309 ✗ return;
310 }
311
312 static void (*critical_error_callback)(void) = critical_nonsense;
313 static void (*usleep_callback)(uint32_t) = usleep_nonsense;
314 static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
315 static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
316 int (*lbm_printf_callback)(const char *, ...) = printf_nonsense;
317 static bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
318
319 44370 void lbm_set_critical_error_callback(void (*fptr)(void)) {
320
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) critical_error_callback = critical_nonsense;
321 44370 else critical_error_callback = fptr;
322 44370 }
323
324 44370 void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
325
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) usleep_callback = usleep_nonsense;
326 44370 else usleep_callback = fptr;
327 44370 }
328
329 44370 void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
330
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) timestamp_us_callback = timestamp_nonsense;
331 44370 else timestamp_us_callback = fptr;
332 44370 }
333
334 44370 void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
335
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) ctx_done_callback = ctx_done_nonsense;
336 44370 else ctx_done_callback = fptr;
337 44370 }
338
339 44370 void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
340
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) lbm_printf_callback = printf_nonsense;
341 44370 else lbm_printf_callback = fptr;
342 44370 }
343
344 44370 void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char **)) {
345
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (fptr == NULL) dynamic_load_callback = dynamic_load_nonsense;
346 44370 else dynamic_load_callback = fptr;
347 44370 }
348
349 static volatile lbm_event_t *lbm_events = NULL;
350 static unsigned int lbm_events_head = 0;
351 static unsigned int lbm_events_tail = 0;
352 static unsigned int lbm_events_max = 0;
353 static bool lbm_events_full = false;
354 static mutex_t lbm_events_mutex;
355 static bool lbm_events_mutex_initialized = false;
356 static volatile lbm_cid lbm_event_handler_pid = -1;
357
358 6696 static unsigned int lbm_event_queue_item_count(void) {
359 6696 unsigned int res = lbm_events_max;
360
2/2
✓ Branch 0 taken 6691 times.
✓ Branch 1 taken 5 times.
 6696 if (!lbm_events_full) {
361
1/2
✓ Branch 0 taken 6691 times.
✗ Branch 1 not taken.
 6691 if (lbm_events_head >= lbm_events_tail) {
362 6691 res = lbm_events_head - lbm_events_tail;
363 } else {
364 ✗ res = lbm_events_max - lbm_events_tail + lbm_events_head;
365 }
366 }
367 6696 return res;
368 }
369
370 1 lbm_cid lbm_get_event_handler_pid(void) {
371 1 return lbm_event_handler_pid;
372 }
373
374 455 void lbm_set_event_handler_pid(lbm_cid pid) {
375 455 lbm_event_handler_pid = pid;
376 455 }
377
378 8 bool lbm_event_handler_exists(void) {
379 8 return(lbm_event_handler_pid > 0);
380 }
381
382 6869 static bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
383 6869 bool r = false;
384
1/2
✓ Branch 0 taken 6869 times.
✗ Branch 1 not taken.
 6869 if (lbm_events) {
385 6869 mutex_lock(&lbm_events_mutex);
386
2/2
✓ Branch 0 taken 6864 times.
✓ Branch 1 taken 5 times.
 6869 if (!lbm_events_full) {
387 lbm_event_t event;
388 6864 event.type = event_type;
389 6864 event.parameter = parameter;
390 6864 event.buf_ptr = buf_ptr;
391 6864 event.buf_len = buf_len;
392 6864 lbm_events[lbm_events_head] = event;
393 6864 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
394 6864 lbm_events_full = lbm_events_head == lbm_events_tail;
395 6864 r = true;
396 }
397 6869 mutex_unlock(&lbm_events_mutex);
398 }
399 6869 return r;
400 }
401
402 5 bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
403 5 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
404 }
405
406 36 bool lbm_event_unboxed(lbm_value unboxed) {
407 36 lbm_uint t = lbm_type_of(unboxed);
408
4/4
✓ Branch 0 taken 33 times.
✓ Branch 1 taken 3 times.
✓ Branch 2 taken 15 times.
✓ Branch 3 taken 18 times.
 36 if (t == LBM_TYPE_SYMBOL ||
409
2/2
✓ Branch 0 taken 8 times.
✓ Branch 1 taken 7 times.
 15 t == LBM_TYPE_I ||
410
2/2
✓ Branch 0 taken 7 times.
✓ Branch 1 taken 1 times.
 8 t == LBM_TYPE_U ||
411 t == LBM_TYPE_CHAR) {
412
2/2
✓ Branch 0 taken 32 times.
✓ Branch 1 taken 3 times.
 35 if (lbm_event_handler_pid > 0) {
413
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 32 times.
 32 if (lbm_mailbox_free_space_for_cid(lbm_event_handler_pid) <= lbm_event_queue_item_count()) {
414 ✗ return false;
415 }
416 32 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
417 }
418 }
419 4 return false;
420 }
421
422 15103 bool lbm_event(lbm_flat_value_t *fv) {
423
2/2
✓ Branch 0 taken 6664 times.
✓ Branch 1 taken 8439 times.
 15103 if (lbm_event_handler_pid > 0) {
424
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6664 times.
 6664 if (lbm_mailbox_free_space_for_cid(lbm_event_handler_pid) <= lbm_event_queue_item_count()) {
425 ✗ return false;
426 }
427 6664 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
428 }
429 8439 return false;
430 }
431
432 408068689 static bool lbm_event_pop(lbm_event_t *event) {
433 408068689 mutex_lock(&lbm_events_mutex);
434
4/4
✓ Branch 0 taken 408061826 times.
✓ Branch 1 taken 6863 times.
✓ Branch 2 taken 408061825 times.
✓ Branch 3 taken 1 times.
 408068689 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
435 408061825 mutex_unlock(&lbm_events_mutex);
436 408061825 return false;
437 }
438 6864 *event = lbm_events[lbm_events_tail];
439 6864 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
440 6864 lbm_events_full = false;
441 6864 mutex_unlock(&lbm_events_mutex);
442 6864 return true;
443 }
444
445 6 bool lbm_event_queue_is_empty(void) {
446 6 mutex_lock(&lbm_events_mutex);
447 6 bool empty = false;
448
4/4
✓ Branch 0 taken 5 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 4 times.
✓ Branch 3 taken 1 times.
 6 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
449 4 empty = true;
450 }
451 6 mutex_unlock(&lbm_events_mutex);
452 6 return empty;
453 }
454
455 static bool eval_running = false;
456 static volatile bool blocking_extension = false;
457 static mutex_t blocking_extension_mutex;
458 static bool blocking_extension_mutex_initialized = false;
459 static lbm_uint blocking_extension_timeout_us = 0;
460 static bool blocking_extension_timeout = false;
461
462 static bool is_atomic = false;
463
464 // MODES
465 static volatile bool lbm_verbose = false;
466 static volatile bool lbm_hide_trapped_error = false;
467
468 9 void lbm_toggle_verbose(void) {
469 9 lbm_verbose = !lbm_verbose;
470 9 }
471
472 44072 void lbm_set_verbose(bool verbose) {
473 44072 lbm_verbose = verbose;
474 44072 }
475
476 3 void lbm_set_hide_trapped_error(bool hide) {
477 3 lbm_hide_trapped_error = hide;
478 3 }
479
480 2548 lbm_cid lbm_get_current_cid(void) {
481
1/2
✓ Branch 0 taken 2548 times.
✗ Branch 1 not taken.
 2548 if (ctx_running)
482 2548 return ctx_running->id;
483 else
484 ✗ return -1;
485 }
486
487 1 eval_context_t *lbm_get_current_context(void) {
488 1 return ctx_running;
489 }
490
491 #ifdef LBM_USE_TIME_QUOTA
492 ✗ void lbm_surrender_quota(void) {
493 // dummy;
494 ✗ }
495 #else
496 10 void lbm_surrender_quota(void) {
497 10 eval_steps_quota = 0;
498 10 }
499 #endif
500
501 /****************************************************/
502 /* Utilities used locally in this file */
503
504 771264 static inline lbm_array_header_t *assume_array(lbm_value a){
505 771264 return (lbm_array_header_t*)lbm_ref_cell(a)->car;
506 }
507
508 8966797 static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
509 #ifdef LBM_ALWAYS_GC
510 lbm_value always_gc_roots[3] = {head, tail, remember};
511 lbm_gc_mark_roots(always_gc_roots,3);
512 gc();
513 #endif
514 8966797 lbm_value res = lbm_heap_state.freelist;
515
2/2
✓ Branch 0 taken 6795 times.
✓ Branch 1 taken 8960002 times.
 8966797 if (lbm_is_symbol_nil(res)) {
516 6795 lbm_value roots[3] = {head, tail, remember};
517 6795 lbm_gc_mark_roots(roots,3);
518 6795 gc();
519 6795 res = lbm_heap_state.freelist;
520
2/2
✓ Branch 0 taken 4 times.
✓ Branch 1 taken 6791 times.
 6795 if (lbm_is_symbol_nil(res)) {
521 4 ERROR_CTX(ENC_SYM_MERROR);
522 }
523 }
524 8966793 lbm_uint heap_ix = lbm_dec_ptr(res);
525 8966793 lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
526 8966793 lbm_heap_state.num_alloc++;
527 8966793 lbm_heap_state.heap[heap_ix].car = head;
528 8966793 lbm_heap_state.heap[heap_ix].cdr = tail;
529 8966793 res = lbm_set_ptr_type(res, LBM_TYPE_CONS);
530 8966793 return res;
531 }
532
533 // ////////////////////////////////////////////////////////////
534 // Stack and CPS
535
536 // The CPS system is dependent on a diciplined use of a continuation
537 // stack! Continuations are pushed and popped from this stack and
538 // between the point in time when a continuation is pushed and when it is popped
539 // significant stack "traffic" may have occurred.
540 //
541 // In the evaluator, functions called things line "eval_X" usually sets up
542 // a stack-frame for a future exection of a "cont_X" continuation.
543 // Some kind of proof is needed that Things that pushed in a continuation setup-phase
544 // are all popped (no more, no less) in a continuation execution phase.
545 // continuations "cont_X" also may set up more continuations and in that
546 // case they may modify the stack in place or reuse in part or full the
547 // stack-frame associated with "cont_X"
548 //
549 // TODO: for each "eval_X" and "cont_X" pair write an argument or some kind
550 // of test that illustrates correct usage of the stack discipline.
551 //
552 // For now the argument of stack discipline being honored is that all tests
553 // pass and no tests end up in stack underflow.
554 //
555 // Stack overflow is easy to end up in, just write a non-tail-recursive but recursive funtions
556 // and run it for a suitably large input.
557 //
558 // * Potentially tricky situation is "trap" used on a call to a non-tail-recursive function that
559 // ends out exhausting stack.
560 // # Trap rewinds the stack to the point of trap so it should be perfectly safe to trap even in this situation.
561
562 // get_stack_ptr and pop_stack_ptr does in no tests reach
563 // the error condition. The check n <= sp is not really needed.
564 2222781431 static inline lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
565 2222781431 lbm_uint index = ctx->K.sp - n;
566 2222781431 return &ctx->K.data[index];
567 }
568
569 // pop_stack_ptr is safe when no GC is performed and
570 // the values of the stack will be dropped.
571 55811737 static inline lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
572 55811737 ctx->K.sp -= n;
573 55811737 return &ctx->K.data[ctx->K.sp];
574 }
575
576 2420026408 static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
577
2/2
✓ Branch 0 taken 2420026405 times.
✓ Branch 1 taken 3 times.
 2420026408 if (ctx->K.sp + n < ctx->K.size) {
578 2420026405 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
579 2420026405 ctx->K.sp += n;
580 2420026405 return ptr;
581 }
582 3 ERROR_CTX(ENC_SYM_STACK_ERROR);
583 }
584
585 13943 static void handle_flash_status(lbm_flash_status s) {
586
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 13943 times.
 13943 if ( s == LBM_FLASH_FULL) {
587 ✗ lbm_set_error_reason((char*)lbm_error_str_flash_full);
588 ✗ ERROR_CTX(ENC_SYM_EERROR);
589 }
590
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 13943 times.
 13943 if (s == LBM_FLASH_WRITE_ERROR) {
591 ✗ lbm_set_error_reason((char*)lbm_error_str_flash_error);
592 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
593 }
594 13943 }
595
596 168 static void lift_array_flash(lbm_value flash_cell, bool bytearray, char *data, lbm_uint num_elt) {
597
598 lbm_array_header_t flash_array_header;
599 168 flash_array_header.size = num_elt;
600 168 flash_array_header.data = (lbm_uint*)data;
601 168 lbm_uint flash_array_header_ptr = 0;
602 168 handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
603 sizeof(lbm_array_header_t) / sizeof(lbm_uint),
604 &flash_array_header_ptr));
605 168 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
606
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 56 times.
 168 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE : ENC_SYM_LISPARRAY_TYPE;
607 168 handle_flash_status(write_const_cdr(flash_cell, t));
608 168 }
609
610 // ////////////////////////////////////////////////////////////
611 // get_car and lbm_car
612
613 // lbm_car is a lower level operation that extracts a car field from a cons cell
614 // without any consideration of any additional type-tags associated with the cell.
615 // get_car is for list cons-cells only.
616
617 326089103 static inline void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
618
2/2
✓ Branch 0 taken 307860076 times.
✓ Branch 1 taken 18229027 times.
 326089103 if (lbm_is_cons(a)) {
619 307860076 lbm_cons_t *cell = lbm_ref_cell(a);
620 307860076 *a_car = cell->car;
621 307860076 *a_cdr = cell->cdr;
622
2/2
✓ Branch 0 taken 18229013 times.
✓ Branch 1 taken 14 times.
 18229027 } else if (lbm_is_symbol_nil(a)) {
623 18229013 *a_car = *a_cdr = ENC_SYM_NIL;
624 } else {
625 14 ERROR_CTX(ENC_SYM_TERROR);
626 }
627 326089089 }
628
629 /* car cdr caar cadr replacements that are evaluator safe. */
630 34006354 static inline lbm_value get_car(lbm_value a) {
631
2/2
✓ Branch 0 taken 34006351 times.
✓ Branch 1 taken 3 times.
 34006354 if (lbm_is_cons(a)) {
632 34006351 lbm_cons_t *cell = lbm_ref_cell(a);
633 34006351 return cell->car;
634
2/2
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 1 times.
 3 } else if (lbm_is_symbol_nil(a)) {
635 2 return a;
636 }
637 1 ERROR_CTX(ENC_SYM_TERROR);
638 }
639
640 216038674 static inline lbm_value get_cdr(lbm_value a) {
641
2/2
✓ Branch 0 taken 216038619 times.
✓ Branch 1 taken 56 times.
 216038674 if (lbm_is_cons(a)) {
642 216038619 lbm_cons_t *cell = lbm_ref_cell(a);
643 216038619 return cell->cdr;
644
1/2
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
 56 } else if (lbm_is_symbol_nil(a)) {
645 56 return a;
646 }
647 ✗ ERROR_CTX(ENC_SYM_TERROR);
648 }
649
650 66987236 static inline lbm_value get_cadr(lbm_value a) {
651
2/2
✓ Branch 0 taken 66987234 times.
✓ Branch 1 taken 2 times.
 66987236 if (lbm_is_cons(a)) {
652 66987234 lbm_cons_t *cell = lbm_ref_cell(a);
653 66987234 lbm_value tmp = cell->cdr;
654
2/2
✓ Branch 0 taken 66987037 times.
✓ Branch 1 taken 197 times.
 66987234 if (lbm_is_cons(tmp)) {
655 66987037 return lbm_ref_cell(tmp)->car;
656
1/2
✓ Branch 0 taken 197 times.
✗ Branch 1 not taken.
 197 } else if (lbm_is_symbol_nil(tmp)) {
657 197 return tmp;
658 }
659
1/2
✓ Branch 0 taken 2 times.
✗ Branch 1 not taken.
 2 } else if (lbm_is_symbol_nil(a)) {
660 2 return a;
661 }
662 ✗ ERROR_CTX(ENC_SYM_TERROR);
663 }
664
665 // Allocate a binding and attach it to a list (if so desired)
666 205712579 static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
667 #ifdef LBM_ALWAYS_GC
668 lbm_gc_mark_phase(key);
669 lbm_gc_mark_phase(val);
670 lbm_gc_mark_phase(the_cdr);
671 gc();
672 if (lbm_heap_num_free() < 2) {
673 ERROR_CTX(ENC_SYM_MERROR);
674 }
675 #else
676
2/2
✓ Branch 0 taken 273186 times.
✓ Branch 1 taken 205439393 times.
 205712579 if (lbm_heap_num_free() < 2) {
677 273186 lbm_gc_mark_phase(key);
678 273186 lbm_gc_mark_phase(val);
679 273186 lbm_gc_mark_phase(the_cdr);
680 273186 gc();
681
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 273130 times.
 273186 if (lbm_heap_num_free() < 2) {
682 56 ERROR_CTX(ENC_SYM_MERROR);
683 }
684 }
685 #endif
686 // If num_free is calculated correctly, freelist is definitely a cons-cell.
687 205712523 lbm_cons_t* heap = lbm_heap_state.heap;
688 205712523 lbm_value binding_cell = lbm_heap_state.freelist;
689 205712523 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
690 205712523 lbm_value list_cell = heap[binding_cell_ix].cdr;
691 205712523 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
692 205712523 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
693 205712523 lbm_heap_state.num_alloc += 2;
694 205712523 heap[binding_cell_ix].car = key;
695 205712523 heap[binding_cell_ix].cdr = val;
696 205712523 heap[list_cell_ix].car = binding_cell;
697 205712523 heap[list_cell_ix].cdr = the_cdr;
698 205712523 return list_cell;
699 }
700
701 #define CLO_PARAMS 0
702 #define CLO_BODY 1
703 #define CLO_ENV 2
704 #define LOOP_BINDS 0
705 #define LOOP_COND 1
706 #define LOOP_BODY 2
707
708 // TODO: extract_n could be a good place to do some error checking.
709 // extract_n is often used to extract components of a list that
710 // makes up a special form application. If there are not n items
711 // present that could be an indication of a syntax error in the
712 // special form application.
713 // (a b c) -> [a b c]
714 152126277 static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
715
2/2
✓ Branch 0 taken 431884015 times.
✓ Branch 1 taken 152126277 times.
 584010292 for (unsigned int i = 0; i < n; i ++) {
716
2/2
✓ Branch 0 taken 431845476 times.
✓ Branch 1 taken 38539 times.
 431884015 if (lbm_is_ptr(curr)) {
717 431845476 lbm_cons_t *cell = lbm_ref_cell(curr);
718 431845476 res[i] = cell->car;
719 431845476 curr = cell->cdr;
720 } else {
721 38539 res[i] = ENC_SYM_NIL;
722 }
723 }
724 152126277 return curr; // Rest of list is returned here.
725 }
726
727 448059972 static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
728 lbm_value res;
729 #ifdef LBM_ALWAYS_GC
730 gc();
731 #endif
732 448059972 res = fundamental_table[fundamental](args, arg_count, ctx);
733
2/2
✓ Branch 0 taken 633317 times.
✓ Branch 1 taken 447426655 times.
 448059972 if (lbm_is_error(res)) {
734
2/2
✓ Branch 0 taken 623778 times.
✓ Branch 1 taken 9539 times.
 633317 if (lbm_is_symbol_merror(res)) {
735 623778 gc();
736 623778 res = fundamental_table[fundamental](args, arg_count, ctx);
737 }
738
2/2
✓ Branch 0 taken 9667 times.
✓ Branch 1 taken 623650 times.
 633317 if (lbm_is_error(res)) {
739 9667 ERROR_AT_CTX(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START | fundamental));
740 }
741 }
742 448050305 lbm_stack_drop(&ctx->K, arg_count+1);
743 448050305 ctx->app_cont = true;
744 448050305 ctx->r = res;
745 448050305 }
746
747 57 static void atomic_error(void) {
748 57 is_atomic = false;
749 57 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
750 57 ERROR_CTX(ENC_SYM_EERROR);
751 }
752
753 // block_current_ctx blocks a context until it is
754 // woken up externally or a timeout period of time passes.
755 // Blocking while in an atomic block would have bad consequences.
756 12242 static void block_current_ctx(uint32_t state, lbm_uint sleep_us, bool do_cont) {
757
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 12242 times.
 12242 if (is_atomic) atomic_error();
758 12242 ctx_running->timestamp = timestamp_us_callback();
759 12242 ctx_running->sleep_us = sleep_us;
760 12242 ctx_running->state = state;
761 12242 ctx_running->app_cont = do_cont;
762 12242 enqueue_ctx(&blocked, ctx_running);
763 12242 ctx_running = NULL;
764 12242 }
765
766 // reblock an essentially already blocked context.
767 // Same as block but sets no new timestamp or sleep_us.
768 ✗ static void reblock_current_ctx(uint32_t state, bool do_cont) {
769 ✗ if (is_atomic) atomic_error();
770 ✗ ctx_running->state = state;
771 ✗ ctx_running->app_cont = do_cont;
772 ✗ enqueue_ctx(&blocked, ctx_running);
773 ✗ ctx_running = NULL;
774 ✗ }
775
776
777 302753 lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
778 302753 lbm_uint full_words = n / sizeof(lbm_uint);
779 302753 lbm_uint n_mod = n % sizeof(lbm_uint);
780
781
2/2
✓ Branch 0 taken 34086 times.
✓ Branch 1 taken 268667 times.
 302753 if (n_mod == 0) { // perfect fit.
782 34086 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
783 } else {
784 268667 lbm_uint last_word = 0;
785 268667 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
786
2/2
✓ Branch 0 taken 39064 times.
✓ Branch 1 taken 229603 times.
 268667 if (full_words >= 1) {
787 39064 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
788
1/2
✓ Branch 0 taken 39064 times.
✗ Branch 1 not taken.
 39064 if ( s == LBM_FLASH_WRITE_OK) {
789 lbm_uint dummy;
790 39064 s = lbm_write_const_raw(&last_word, 1, &dummy);
791 }
792 39064 return s;
793 } else {
794 229603 return lbm_write_const_raw(&last_word, 1, res);
795 }
796 }
797 }
798
799 /****************************************************/
800 /* Error message creation */
801
802 #define ERROR_MESSAGE_BUFFER_SIZE_BYTES 256
803
804 16376 void print_environments(char *buf, unsigned int size) {
805
806 16376 lbm_value curr_l = ctx_running->curr_env;
807 16376 lbm_printf_callback("\tCurrent local environment:\n");
808
2/2
✓ Branch 0 taken 680 times.
✓ Branch 1 taken 16376 times.
 17056 while (lbm_type_of(curr_l) == LBM_TYPE_CONS) {
809 680 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
810 680 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
811 680 lbm_printf_callback("\t%s = %s\n", buf, buf+(size/2));
812 680 curr_l = lbm_cdr(curr_l);
813 }
814 16376 lbm_printf_callback("\n\n");
815 16376 lbm_printf_callback("\tCurrent global environment:\n");
816 16376 lbm_value *glob_env = lbm_get_global_env();
817
818
2/2
✓ Branch 0 taken 524032 times.
✓ Branch 1 taken 16376 times.
 540408 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
819 524032 lbm_value curr_g = glob_env[i];;
820
2/2
✓ Branch 0 taken 91648 times.
✓ Branch 1 taken 524032 times.
 615680 while (lbm_type_of(curr_g) == LBM_TYPE_CONS) {
821
822 91648 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
823 91648 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
824 91648 lbm_printf_callback("\t%s = %s\n", buf, buf+(size/2));
825 91648 curr_g = lbm_cdr(curr_g);
826 }
827 }
828 16376 }
829
830 52635 void print_error_value(char *buf, uint32_t bufsize, char *pre, lbm_value v, bool lookup) {
831
832 52635 lbm_print_value(buf, bufsize, v);
833 52635 lbm_printf_callback("%s %s\n",pre, buf);
834
2/2
✓ Branch 0 taken 35711 times.
✓ Branch 1 taken 16924 times.
 52635 if (lookup) {
835
2/2
✓ Branch 0 taken 21472 times.
✓ Branch 1 taken 14239 times.
 35711 if (lbm_is_symbol(v)) {
836
2/2
✓ Branch 0 taken 2405 times.
✓ Branch 1 taken 19067 times.
 21472 if (lbm_dec_sym(v) >= RUNTIME_SYMBOLS_START) {
837 2405 lbm_value res = ENC_SYM_NIL;
838
4/4
✓ Branch 0 taken 2228 times.
✓ Branch 1 taken 177 times.
✓ Branch 2 taken 1413 times.
✓ Branch 3 taken 815 times.
 4633 if (lbm_env_lookup_b(&res, v, ctx_running->curr_env) ||
839 2228 lbm_global_env_lookup(&res, v)) {
840 1590 lbm_print_value(buf, bufsize, res);
841 1590 lbm_printf_callback(" bound to: %s\n", buf);
842 } else {
843 815 lbm_printf_callback(" UNDEFINED\n");
844 }
845 }
846 }
847 }
848 52635 }
849
850 16924 static void print_error_message(lbm_value error,
851 bool has_at,
852 lbm_value at,
853 unsigned int row,
854 unsigned int col,
855 lbm_int row0,
856 lbm_int row1,
857 lbm_int cid,
858 char *name,
859 bool trapped) {
860 /* try to allocate a lbm_print_value buffer on the lbm_memory */
861 16924 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES);
862
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 16924 times.
 16924 if (!buf) {
863 ✗ lbm_printf_callback("Error: Not enough memory to show a human readable error message\n");
864 ✗ return;
865 }
866
2/2
✓ Branch 0 taken 16504 times.
✓ Branch 1 taken 420 times.
 16924 if (trapped) {
867 16504 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," Error (trapped):", error, false);
868 } else {
869 420 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," Error:", error, false);
870 }
871
2/2
✓ Branch 0 taken 249 times.
✓ Branch 1 taken 16675 times.
 16924 if (lbm_is_symbol_merror(error)) {
872 249 lbm_printf_callback("\n Heap cells free: %d\n", lbm_heap_state.heap_size - lbm_heap_state.num_alloc);
873 249 lbm_printf_callback(" Mem longest free: %d\n\n", lbm_memory_longest_free());
874 }
875
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 16924 times.
 16924 if (name) {
876 ✗ lbm_printf_callback( " CTX: %d \"%s\"\n", cid, name);
877 } else {
878 16924 lbm_printf_callback( " CTX: %d\n", cid);
879 }
880 16924 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," Current:", ctx_running->curr_exp, true);
881 // An error can have both a set suspect that can be more detailed than the "at"
882 // show both if present!
883
2/2
✓ Branch 0 taken 2553 times.
✓ Branch 1 taken 14371 times.
 16924 if (lbm_error_has_suspect) {
884 2553 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," At:", lbm_error_suspect, true);
885 2553 lbm_error_has_suspect = false;
886 }
887 // TODO: Should perhaps be called has_in and be meant to capture a bit
888 // of the surrounding of where the error happened.
889
2/2
✓ Branch 0 taken 16234 times.
✓ Branch 1 taken 690 times.
 16924 if (has_at) {
890 16234 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," In:", at, true);
891 }
892
893 16924 lbm_printf_callback("\n");
894
895
4/4
✓ Branch 0 taken 16868 times.
✓ Branch 1 taken 56 times.
✓ Branch 2 taken 144 times.
✓ Branch 3 taken 16724 times.
 16924 if (lbm_is_symbol(error) &&
896 error == ENC_SYM_RERROR) {
897 144 lbm_printf_callback(" Line: %u\n", row);
898 144 lbm_printf_callback(" Column: %u\n", col);
899
2/2
✓ Branch 0 taken 8414 times.
✓ Branch 1 taken 8366 times.
 16780 } else if (row0 >= 0) {
900
2/2
✓ Branch 0 taken 5 times.
✓ Branch 1 taken 8409 times.
 8414 if (row1 < 0) lbm_printf_callback(" Starting at row: %d\n", row0);
901 8409 else lbm_printf_callback(" Between row %d and %d\n", row0, row1);
902 }
903
904 16924 lbm_printf_callback("\n");
905
906
2/2
✓ Branch 0 taken 3644 times.
✓ Branch 1 taken 13280 times.
 16924 if (ctx_running->error_reason) {
907 3644 lbm_printf_callback(" Reason: %s\n\n", ctx_running->error_reason);
908 }
909
2/2
✓ Branch 0 taken 16376 times.
✓ Branch 1 taken 548 times.
 16924 if (lbm_verbose) {
910 16376 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->r);
911 16376 lbm_printf_callback(" Current intermediate result: %s\n\n", buf);
912
913 16376 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES);
914
915 16376 lbm_printf_callback("\n Mailbox:\n");
916
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 16376 times.
 16376 for (unsigned int i = 0; i < ctx_running->num_mail; i ++) {
917 ✗ lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->mailbox[i]);
918 ✗ lbm_printf_callback(" %s\n", buf);
919 }
920 16376 lbm_printf_callback("\n Stack:\n");
921
2/2
✓ Branch 0 taken 320068 times.
✓ Branch 1 taken 16376 times.
 336444 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
922 320068 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]);
923 320068 lbm_printf_callback(" %s\n", buf);
924 }
925 }
926 16924 lbm_free(buf);
927 }
928
929 /****************************************************/
930 /* Tokenizing and parsing */
931
932 624787 static bool create_string_channel(char *str, lbm_value *res, lbm_value dep) {
933
934 624787 lbm_char_channel_t *chan = NULL;
935 624787 lbm_string_channel_state_t *st = NULL;
936
937 624787 st = (lbm_string_channel_state_t*)lbm_malloc(sizeof(lbm_string_channel_state_t));
938
2/2
✓ Branch 0 taken 2236 times.
✓ Branch 1 taken 622551 times.
 624787 if (st == NULL) {
939 2236 return false;
940 }
941 622551 chan = (lbm_char_channel_t*)lbm_malloc(sizeof(lbm_char_channel_t));
942
2/2
✓ Branch 0 taken 226 times.
✓ Branch 1 taken 622325 times.
 622551 if (chan == NULL) {
943 226 lbm_free(st);
944 226 return false;
945 }
946
947 622325 lbm_create_string_char_channel(st, chan, str);
948 622325 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
949
2/2
✓ Branch 0 taken 2872 times.
✓ Branch 1 taken 619453 times.
 622325 if (cell == ENC_SYM_MERROR) {
950 2872 lbm_free(st);
951 2872 lbm_free(chan);
952 2872 return false;
953 }
954
955 619453 lbm_char_channel_set_dependency(chan, dep);
956
957 619453 *res = cell;
958 619453 return true;
959 }
960
961 /****************************************************/
962 /* Queue functions */
963
964 2026276 static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
965 eval_context_t *curr;
966 2026276 curr = q->first;
967
968
2/2
✓ Branch 0 taken 25051 times.
✓ Branch 1 taken 2026276 times.
 2051327 while (curr != NULL) {
969 25051 f(curr, arg1, arg2);
970 25051 curr = curr->next;
971 }
972 2026276 }
973
974 2 void lbm_all_ctxs_iterator(ctx_fun f, void *arg1, void *arg2) {
975 2 mutex_lock(&qmutex);
976 2 queue_iterator_nm(&blocked, f, arg1, arg2);
977 2 queue_iterator_nm(&queue, f, arg1, arg2);
978
1/2
✓ Branch 0 taken 2 times.
✗ Branch 1 not taken.
 2 if (ctx_running) f(ctx_running, arg1, arg2);
979 2 mutex_unlock(&qmutex);
980 2 }
981
982 171 void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
983 171 mutex_lock(&qmutex);
984 171 queue_iterator_nm(&queue, f, arg1, arg2);
985 171 mutex_unlock(&qmutex);
986 171 }
987
988 171 void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
989 171 mutex_lock(&qmutex);
990 171 queue_iterator_nm(&blocked, f, arg1, arg2);
991 171 mutex_unlock(&qmutex);
992 171 }
993
994 405003516 static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
995
2/2
✓ Branch 0 taken 397577193 times.
✓ Branch 1 taken 7426323 times.
 405003516 if (q->last == NULL) {
996 397577193 ctx->prev = NULL;
997 397577193 ctx->next = NULL;
998 397577193 q->first = ctx;
999 397577193 q->last = ctx;
1000 } else {
1001 7426323 ctx->prev = q->last;
1002 7426323 ctx->next = NULL;
1003 7426323 q->last->next = ctx;
1004 7426323 q->last = ctx;
1005 }
1006 405003516 }
1007
1008 127580 static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
1009 127580 mutex_lock(&qmutex);
1010 127580 enqueue_ctx_nm(q,ctx);
1011 127580 mutex_unlock(&qmutex);
1012 127580 }
1013
1014 36025 static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
1015 eval_context_t *curr;
1016 36025 curr = q->first;
1017
2/2
✓ Branch 0 taken 20724 times.
✓ Branch 1 taken 15301 times.
 36025 while (curr != NULL) {
1018
1/2
✓ Branch 0 taken 20724 times.
✗ Branch 1 not taken.
 20724 if (curr->id == cid) {
1019 20724 return curr;
1020 }
1021 ✗ curr = curr->next;
1022 }
1023 15301 return NULL;
1024 }
1025
1026 11955 static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
1027
1028 11955 bool res = false;
1029
2/4
✓ Branch 0 taken 11955 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 11955 times.
 11955 if (q->first == NULL || q->last == NULL) {
1030 ✗ if (!(q->last == NULL && q->first == NULL)) {
1031 /* error state that should not happen */
1032 ✗ return res;
1033 }
1034 /* Queue is empty */
1035 ✗ return res;
1036 }
1037
1038 11955 eval_context_t *curr = q->first;
1039
1/2
✓ Branch 0 taken 11955 times.
✗ Branch 1 not taken.
 11955 while (curr) {
1040
1/2
✓ Branch 0 taken 11955 times.
✗ Branch 1 not taken.
 11955 if (curr->id == ctx->id) {
1041 11955 res = true;
1042 11955 eval_context_t *tmp = curr->next;
1043
1/2
✓ Branch 0 taken 11955 times.
✗ Branch 1 not taken.
 11955 if (curr->prev == NULL) {
1044
1/2
✓ Branch 0 taken 11955 times.
✗ Branch 1 not taken.
 11955 if (curr->next == NULL) {
1045 11955 q->last = NULL;
1046 11955 q->first = NULL;
1047 } else {
1048 ✗ q->first = tmp;
1049 ✗ tmp->prev = NULL;
1050 }
1051 } else { /* curr->prev != NULL */
1052 ✗ if (curr->next == NULL) {
1053 ✗ q->last = curr->prev;
1054 ✗ q->last->next = NULL;
1055 } else {
1056 ✗ curr->prev->next = tmp;
1057 ✗ tmp->prev = curr->prev;
1058 }
1059 }
1060 11955 break;
1061 }
1062 ✗ curr = curr->next;
1063 }
1064 11955 return res;
1065 }
1066
1067 /* End execution of the running context. */
1068 46004 static void finish_ctx(void) {
1069
1070
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46004 times.
 46004 if (!ctx_running) {
1071 ✗ return;
1072 }
1073
2/2
✓ Branch 0 taken 448 times.
✓ Branch 1 taken 45556 times.
 46004 if (ctx_running->id == lbm_event_handler_pid) {
1074 448 lbm_event_handler_pid = -1;
1075 }
1076 /* Drop the continuation stack immediately to free up lbm_memory */
1077 46004 lbm_stack_free(&ctx_running->K);
1078 46004 ctx_done_callback(ctx_running);
1079
1080 46004 lbm_free(ctx_running->name); //free name if in LBM_MEM
1081
1082 46004 lbm_memory_free((lbm_uint*)ctx_running->error_reason); //free error_reason if in LBM_MEM
1083
1084 46004 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
1085 46004 lbm_memory_free((lbm_uint*)ctx_running);
1086 46004 ctx_running = NULL;
1087 }
1088
1089 285 static void context_exists(eval_context_t *ctx, void *cid, void *b) {
1090
2/2
✓ Branch 0 taken 57 times.
✓ Branch 1 taken 228 times.
 285 if (ctx->id == *(lbm_cid*)cid) {
1091 57 *(bool*)b = true;
1092 }
1093 285 }
1094
1095 2553 void lbm_set_error_suspect(lbm_value suspect) {
1096 2553 lbm_error_suspect = suspect;
1097 2553 lbm_error_has_suspect = true;
1098 2553 }
1099
1100 2729 void lbm_set_error_reason(const char *error_str) {
1101
2/2
✓ Branch 0 taken 2722 times.
✓ Branch 1 taken 7 times.
 2729 if (ctx_running != NULL) {
1102 2722 ctx_running->error_reason = error_str;
1103 }
1104 2729 }
1105
1106 // Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
1107 #ifdef LBM_USE_ERROR_LINENO
1108 552 static noreturn void error_ctx_base(lbm_value err_val, bool has_at, lbm_value at, unsigned int row, unsigned int column, int line_no) {
1109 #else
1110 16377 static noreturn void error_ctx_base(lbm_value err_val, bool has_at, lbm_value at, unsigned int row, unsigned int column) {
1111 #endif
1112
4/4
✓ Branch 0 taken 16924 times.
✓ Branch 1 taken 5 times.
✓ Branch 2 taken 16504 times.
✓ Branch 3 taken 420 times.
 16929 bool print_trapped = !lbm_hide_trapped_error && (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN);
1113
1114
2/2
✓ Branch 0 taken 5 times.
✓ Branch 1 taken 16924 times.
 16929 if (!(lbm_hide_trapped_error &&
1115
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5 times.
 5 (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN))) {
1116 16924 print_error_message(err_val,
1117 has_at,
1118 at,
1119 row,
1120 column,
1121 16924 ctx_running->row0,
1122 16924 ctx_running->row1,
1123 16924 ctx_running->id,
1124 16924 ctx_running->name,
1125 print_trapped
1126 );
1127 }
1128 #ifdef LBM_USE_ERROR_LINENO
1129
2/2
✓ Branch 0 taken 547 times.
✓ Branch 1 taken 5 times.
 552 if (!lbm_hide_trapped_error) {
1130 547 lbm_printf_callback("eval_cps.c line number: %d\n", line_no);
1131 }
1132 #endif
1133
2/2
✓ Branch 0 taken 393 times.
✓ Branch 1 taken 16536 times.
 16929 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
1134
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 393 times.
 393 if (lbm_heap_num_free() < 3) {
1135 ✗ gc();
1136 }
1137
1138
1/2
✓ Branch 0 taken 393 times.
✗ Branch 1 not taken.
 393 if (lbm_heap_num_free() >= 3) {
1139 393 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL);
1140 393 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
1141 393 msg = lbm_cons(ENC_SYM_EXIT_ERROR, msg);
1142
1/2
✓ Branch 0 taken 393 times.
✗ Branch 1 not taken.
 393 if (!lbm_is_symbol_merror(msg)) {
1143 393 lbm_find_receiver_and_send(ctx_running->parent, msg);
1144 }
1145 }
1146 // context dies.
1147
3/4
✓ Branch 0 taken 16509 times.
✓ Branch 1 taken 27 times.
✓ Branch 2 taken 16509 times.
✗ Branch 3 not taken.
 16536 } else if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN) &&
1148 (err_val != ENC_SYM_FATAL_ERROR)) {
1149
1/2
✓ Branch 0 taken 61113 times.
✗ Branch 1 not taken.
 61113 while (ctx_running->K.sp > 0) {
1150 61113 lbm_uint v = ctx_running->K.data[--ctx_running->K.sp];
1151
2/2
✓ Branch 0 taken 16509 times.
✓ Branch 1 taken 44604 times.
 61113 if (v == EXCEPTION_HANDLER) { // context continues executing.
1152 16509 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1153 16509 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR);
1154 16509 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER;
1155 16509 ctx_running->app_cont = true;
1156 16509 ctx_running->r = err_val;
1157 16509 longjmp(error_jmp_buf, 1);
1158 }
1159 }
1160 ✗ err_val = ENC_SYM_FATAL_ERROR;
1161 }
1162 420 ctx_running->r = err_val;
1163 420 finish_ctx();
1164 420 longjmp(error_jmp_buf, 1);
1165 }
1166
1167 #ifdef LBM_USE_ERROR_LINENO
1168 486 static noreturn void error_at_ctx(lbm_value err_val, lbm_value at, int line_no) {
1169 486 error_ctx_base(err_val, true, at, 0, 0, line_no);
1170 }
1171
1172 34 static noreturn void error_ctx(lbm_value err_val, int line_no) {
1173 34 error_ctx_base(err_val, false, 0, 0, 0, line_no);
1174 }
1175
1176 32 static noreturn void read_error_ctx(unsigned int row, unsigned int column, int line_no) {
1177 32 error_ctx_base(ENC_SYM_RERROR, false, 0, row, column, line_no);
1178 }
1179 #else
1180 15753 static noreturn void error_at_ctx(lbm_value err_val, lbm_value at) {
1181 15753 error_ctx_base(err_val, true, at, 0, 0);
1182 }
1183
1184 512 static noreturn void error_ctx(lbm_value err_val) {
1185 512 error_ctx_base(err_val, false, 0, 0, 0);
1186 }
1187
1188 112 static noreturn void read_error_ctx(unsigned int row, unsigned int column) {
1189 112 error_ctx_base(ENC_SYM_RERROR, false, 0, row, column);
1190 }
1191 #endif
1192
1193 ✗ void lbm_critical_error(void) {
1194 ✗ longjmp(critical_error_jmp_buf, 1);
1195 }
1196
1197 // successfully finish a context
1198 45584 static void ok_ctx(void) {
1199
2/2
✓ Branch 0 taken 283 times.
✓ Branch 1 taken 45301 times.
 45584 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
1200 lbm_value msg;
1201
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 283 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 283 WITH_GC(msg, lbm_heap_allocate_list_init(3,
1202 ENC_SYM_EXIT_OK,
1203 lbm_enc_i(ctx_running->id),
1204 ctx_running->r));
1205 283 lbm_find_receiver_and_send(ctx_running->parent, msg);
1206 }
1207 45584 finish_ctx();
1208 45584 }
1209
1210 409455144 static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1211
2/2
✓ Branch 0 taken 4532868 times.
✓ Branch 1 taken 404922276 times.
 409455144 if (q->last == NULL) {
1212 4532868 return NULL;
1213 }
1214 // q->first should only be NULL if q->last is.
1215 404922276 eval_context_t *res = q->first;
1216
1217
2/2
✓ Branch 0 taken 397506284 times.
✓ Branch 1 taken 7415992 times.
 404922276 if (q->first == q->last) { // One thing in queue
1218 397506284 q->first = NULL;
1219 397506284 q->last = NULL;
1220 } else {
1221 7415992 q->first = q->first->next;
1222 7415992 q->first->prev = NULL;
1223 }
1224 404922276 res->prev = NULL;
1225 404922276 res->next = NULL;
1226 404922276 return res;
1227 }
1228
1229 409455141 static void wake_up_ctxs_nm(void) {
1230 lbm_uint t_now;
1231
1232
1/2
✓ Branch 0 taken 409455141 times.
✗ Branch 1 not taken.
 409455141 if (timestamp_us_callback) {
1233 409455141 t_now = timestamp_us_callback();
1234 } else {
1235 ✗ t_now = 0;
1236 }
1237
1238 409455141 eval_context_queue_t *q = &blocked;
1239 409455141 eval_context_t *curr = q->first;
1240
1241
2/2
✓ Branch 0 taken 6851326 times.
✓ Branch 1 taken 409455141 times.
 416306467 while (curr != NULL) {
1242 lbm_uint t_diff;
1243 6851326 eval_context_t *next = curr->next;
1244
2/2
✓ Branch 0 taken 6297383 times.
✓ Branch 1 taken 553943 times.
 6851326 if (LBM_IS_STATE_WAKE_UP_WAKABLE(curr->state)) {
1245
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6297383 times.
 6297383 if ( curr->timestamp > t_now) {
1246 /* There was an overflow on the counter */
1247 #ifndef LBM64
1248 ✗ t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
1249 #else
1250 ✗ t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
1251 #endif
1252 } else {
1253 6297383 t_diff = t_now - curr->timestamp;
1254 }
1255
1256
2/2
✓ Branch 0 taken 68914 times.
✓ Branch 1 taken 6228469 times.
 6297383 if (t_diff >= curr->sleep_us) {
1257 68914 eval_context_t *wake_ctx = curr;
1258
2/2
✓ Branch 0 taken 63258 times.
✓ Branch 1 taken 5656 times.
 68914 if (curr == q->last) {
1259
2/2
✓ Branch 0 taken 4668 times.
✓ Branch 1 taken 58590 times.
 63258 if (curr->prev) {
1260 4668 q->last = curr->prev;
1261 4668 q->last->next = NULL;
1262 } else {
1263 58590 q->first = NULL;
1264 58590 q->last = NULL;
1265 }
1266
1/2
✓ Branch 0 taken 5656 times.
✗ Branch 1 not taken.
 5656 } else if (curr->prev == NULL) {
1267 5656 q->first = curr->next;
1268 5656 q->first->prev = NULL;
1269 } else {
1270 ✗ curr->prev->next = curr->next;
1271 ✗ if (curr->next) {
1272 ✗ curr->next->prev = curr->prev;
1273 }
1274 }
1275 68914 wake_ctx->next = NULL;
1276 68914 wake_ctx->prev = NULL;
1277
2/2
✓ Branch 0 taken 280 times.
✓ Branch 1 taken 68634 times.
 68914 if (LBM_IS_STATE_TIMEOUT(curr->state)) {
1278 280 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT);
1279 280 wake_ctx->r = ENC_SYM_TIMEOUT;
1280 }
1281 68914 wake_ctx->state = LBM_THREAD_STATE_READY;
1282 68914 enqueue_ctx_nm(&queue, wake_ctx);
1283 }
1284 }
1285 6851326 curr = next;
1286 }
1287 409455141 }
1288
1289 68877 static void yield_ctx(lbm_uint sleep_us) {
1290
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 68821 times.
 68877 if (is_atomic) atomic_error();
1291
1/2
✓ Branch 0 taken 68821 times.
✗ Branch 1 not taken.
 68821 if (timestamp_us_callback) {
1292 68821 ctx_running->timestamp = timestamp_us_callback();
1293 68821 ctx_running->sleep_us = sleep_us;
1294 68821 ctx_running->state = LBM_THREAD_STATE_SLEEPING;
1295 } else {
1296 ✗ ctx_running->timestamp = 0;
1297 ✗ ctx_running->sleep_us = 0;
1298 ✗ ctx_running->state = LBM_THREAD_STATE_SLEEPING;
1299 }
1300 68821 ctx_running->r = ENC_SYM_TRUE;
1301 68821 ctx_running->app_cont = true;
1302 68821 enqueue_ctx(&blocked,ctx_running);
1303 68821 ctx_running = NULL;
1304 68821 }
1305
1306 46573 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) {
1307
1308
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46573 times.
 46573 if (!lbm_is_cons(program)) return -1;
1309
1310 46573 eval_context_t *ctx = NULL;
1311 #ifdef LBM_ALWAYS_GC
1312 {
1313 lbm_uint roots[2] = {program, env};
1314 lbm_gc_mark_roots(roots, 2);
1315 gc();
1316 }
1317 #endif
1318 46573 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1319
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46573 times.
 46573 if (ctx == NULL) {
1320 ✗ lbm_uint roots[2] = {program, env};
1321 ✗ lbm_gc_mark_roots(roots, 2);
1322 ✗ gc();
1323 ✗ ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1324 }
1325
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46573 times.
 46573 if (ctx == NULL) return -1;
1326 #ifdef LBM_ALWAYS_GC
1327 {
1328 lbm_uint roots[2] = {program, env};
1329 lbm_gc_mark_roots(roots, 2);
1330 gc();
1331 }
1332 #endif
1333
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 46517 times.
 46573 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1334 56 lbm_uint roots[2] = {program, env};
1335 56 lbm_gc_mark_roots(roots, 2);
1336 56 gc();
1337
1/2
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
 56 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1338 56 lbm_memory_free((lbm_uint*)ctx);
1339 56 return -1;
1340 }
1341 }
1342
1343 46517 lbm_value *mailbox = NULL;
1344 #ifdef LBM_ALWAYS_GC
1345 {
1346 lbm_uint roots[2] = {program, env};
1347 lbm_gc_mark_roots(roots, 2);
1348 gc();
1349 }
1350 #endif
1351 46517 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
1352
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46517 times.
 46517 if (mailbox == NULL) {
1353 ✗ lbm_value roots[2] = {program, env};
1354 ✗ lbm_gc_mark_roots(roots,2);
1355 ✗ gc();
1356 ✗ mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
1357 }
1358
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46517 times.
 46517 if (mailbox == NULL) {
1359 ✗ lbm_stack_free(&ctx->K);
1360 ✗ lbm_memory_free((lbm_uint*)ctx);
1361 ✗ return -1;
1362 }
1363
1364 // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
1365
2/2
✓ Branch 0 taken 291 times.
✓ Branch 1 taken 46226 times.
 46517 if (name) {
1366 291 lbm_uint name_len = strlen(name) + 1;
1367 #ifdef LBM_ALWAYS_GC
1368 {
1369 lbm_uint roots[2] = {program, env};
1370 lbm_gc_mark_roots(roots, 2);
1371 gc();
1372 }
1373 #endif
1374 291 ctx->name = lbm_malloc(name_len);
1375
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 291 times.
 291 if (ctx->name == NULL) {
1376 ✗ lbm_value roots[2] = {program, env};
1377 ✗ lbm_gc_mark_roots(roots, 2);
1378 ✗ gc();
1379 ✗ ctx->name = lbm_malloc(name_len);
1380 }
1381
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 291 times.
 291 if (ctx->name == NULL) {
1382 ✗ lbm_stack_free(&ctx->K);
1383 ✗ lbm_memory_free((lbm_uint*)mailbox);
1384 ✗ lbm_memory_free((lbm_uint*)ctx);
1385 ✗ return -1;
1386 }
1387 291 memcpy(ctx->name, name, name_len);
1388 } else {
1389 46226 ctx->name = NULL;
1390 }
1391
1392 46517 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1393
1394 46517 ctx->program = lbm_cdr(program);
1395 46517 ctx->curr_exp = lbm_car(program);
1396 46517 ctx->curr_env = env;
1397 46517 ctx->r = ENC_SYM_NIL;
1398 46517 ctx->error_reason = NULL;
1399 46517 ctx->mailbox = mailbox;
1400 46517 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE;
1401 46517 ctx->flags = context_flags;
1402 46517 ctx->num_mail = 0;
1403 46517 ctx->app_cont = false;
1404 46517 ctx->timestamp = 0;
1405 46517 ctx->sleep_us = 0;
1406 46517 ctx->state = LBM_THREAD_STATE_READY;
1407 46517 ctx->prev = NULL;
1408 46517 ctx->next = NULL;
1409
1410 46517 ctx->row0 = -1;
1411 46517 ctx->row1 = -1;
1412
1413 46517 ctx->id = cid;
1414 46517 ctx->parent = parent;
1415
1416
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 46517 times.
 46517 if (!lbm_push(&ctx->K, DONE)) {
1417 ✗ lbm_memory_free((lbm_uint*)ctx->mailbox);
1418 ✗ lbm_stack_free(&ctx->K);
1419 ✗ lbm_memory_free((lbm_uint*)ctx);
1420 ✗ return -1;
1421 }
1422
1423 46517 enqueue_ctx(&queue,ctx);
1424
1425 46517 return ctx->id;
1426 }
1427
1428 44320 lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1429 // Creates a parentless context.
1430 44320 return lbm_create_ctx_parent(program,
1431 env,
1432 stack_size,
1433 -1,
1434 EVAL_CPS_CONTEXT_FLAG_NOTHING,
1435 name);
1436 }
1437
1438 280 bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1439
1440 280 lbm_value *mailbox = NULL;
1441 #ifdef LBM_ALWAYS_GC
1442 gc();
1443 #endif
1444 280 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1445
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 224 times.
 280 if (mailbox == NULL) {
1446 56 gc();
1447 56 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1448 }
1449
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 224 times.
 280 if (mailbox == NULL) {
1450 56 return false;
1451 }
1452
1453
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 224 times.
 224 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1454 ✗ mailbox[i] = ctx->mailbox[i];
1455 }
1456 224 lbm_memory_free(ctx->mailbox);
1457 224 ctx->mailbox = mailbox;
1458 224 ctx->mailbox_size = (uint32_t)new_size;
1459 224 return true;
1460 }
1461
1462 18007 static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1463
1464
2/2
✓ Branch 0 taken 31866 times.
✓ Branch 1 taken 18007 times.
 49873 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1465 31866 ctx->mailbox[i] = ctx->mailbox[i+1];
1466 }
1467 18007 ctx->num_mail --;
1468 18007 }
1469
1470 19915 static void mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1471
1472
2/2
✓ Branch 0 taken 1176 times.
✓ Branch 1 taken 18739 times.
 19915 if (ctx->num_mail >= ctx->mailbox_size) {
1473 1176 mailbox_remove_mail(ctx, 0);
1474 }
1475
1476 19915 ctx->mailbox[ctx->num_mail] = mail;
1477 19915 ctx->num_mail ++;
1478 19915 }
1479
1480 /**************************************************************
1481 * Advance execution to the next expression in the program.
1482 * Assumes programs are not malformed. Apply_eval_program
1483 * ensures programs are lists ending in nil. The reader
1484 * ensures this likewise.
1485 *************************************************************/
1486 131919 static void advance_ctx(eval_context_t *ctx) {
1487
2/2
✓ Branch 0 taken 86504 times.
✓ Branch 1 taken 45415 times.
 131919 if (ctx->program) { // fast not-nil check, assume cons if not nil.
1488 86504 stack_reserve(ctx, 1)[0] = DONE;
1489 86504 lbm_cons_t *cell = lbm_ref_cell(ctx->program);
1490 86504 ctx->curr_exp = cell->car;
1491 86504 ctx->program = cell->cdr;
1492 86504 ctx->curr_env = ENC_SYM_NIL;
1493 } else {
1494
1/2
✓ Branch 0 taken 45415 times.
✗ Branch 1 not taken.
 45415 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1495 45415 ok_ctx();
1496 }
1497 }
1498 131919 }
1499
1500 168 bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1501 168 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1502 }
1503
1504 56 bool lbm_unblock_ctx_r(lbm_cid cid) {
1505 56 mutex_lock(&blocking_extension_mutex);
1506 56 bool r = false;
1507 56 eval_context_t *found = NULL;
1508 56 mutex_lock(&qmutex);
1509 56 found = lookup_ctx_nm(&blocked, cid);
1510
2/4
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 56 times.
✗ Branch 3 not taken.
 56 if (found && (LBM_IS_STATE_UNBLOCKABLE(found->state))) {
1511 56 drop_ctx_nm(&blocked,found);
1512 56 found->state = LBM_THREAD_STATE_READY;
1513 56 enqueue_ctx_nm(&queue,found);
1514 56 r = true;
1515 }
1516 56 mutex_unlock(&qmutex);
1517 56 mutex_unlock(&blocking_extension_mutex);
1518 56 return r;
1519 }
1520
1521 // unblock unboxed is also safe for rmbr:ed things.
1522 // TODO: What happens if we unblock and the value is "merror"
1523 ✗ bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
1524 ✗ mutex_lock(&blocking_extension_mutex);
1525 ✗ bool r = false;
1526 ✗ eval_context_t *found = NULL;
1527 ✗ mutex_lock(&qmutex);
1528 ✗ found = lookup_ctx_nm(&blocked, cid);
1529 ✗ if (found && (LBM_IS_STATE_UNBLOCKABLE(found->state))) {
1530 ✗ drop_ctx_nm(&blocked,found);
1531 ✗ found->r = unboxed;
1532 ✗ if (lbm_is_error(unboxed)) {
1533 ✗ get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
1534 ✗ found->app_cont = true;
1535 }
1536 ✗ found->state = LBM_THREAD_STATE_READY;
1537 ✗ enqueue_ctx_nm(&queue,found);
1538 ✗ r = true;
1539 }
1540 ✗ mutex_unlock(&qmutex);
1541 ✗ mutex_unlock(&blocking_extension_mutex);
1542 ✗ return r;
1543 }
1544
1545 224 static bool lbm_block_ctx_base(bool timeout, float t_s) {
1546 224 mutex_lock(&blocking_extension_mutex);
1547 224 blocking_extension = true;
1548
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 224 times.
 224 if (timeout) {
1549 ✗ blocking_extension_timeout_us = S_TO_US(t_s);
1550 ✗ blocking_extension_timeout = true;
1551 } else {
1552 224 blocking_extension_timeout = false;
1553 }
1554 224 return true;
1555 }
1556
1557 ✗ void lbm_block_ctx_from_extension_timeout(float s) {
1558 ✗ lbm_block_ctx_base(true, s);
1559 ✗ }
1560
1561 224 void lbm_block_ctx_from_extension(void) {
1562 224 lbm_block_ctx_base(false, 0);
1563 224 }
1564
1565 // todo: May need to pop rmbrs from stack, if present.
1566 // Suspect that the letting the discard cont run is really not a problem.
1567 // Either way will be quite confusing what happens to allocated things when undoing block.
1568 ✗ void lbm_undo_block_ctx_from_extension(void) {
1569 ✗ blocking_extension = false;
1570 ✗ blocking_extension_timeout_us = 0;
1571 ✗ blocking_extension_timeout = false;
1572 ✗ mutex_unlock(&blocking_extension_mutex);
1573 ✗ }
1574
1575 // TODO: very similar iteration patterns.
1576 // Try to break out common part from free_space and from find_and_send
1577 /** mailbox_free_space_for_cid is used to get the available
1578 * space in a given context's mailbox.
1579 */
1580 6696 static uint32_t lbm_mailbox_free_space_for_cid(lbm_cid cid) {
1581 6696 eval_context_t *found = NULL;
1582 6696 uint32_t res = 0;
1583
1584 6696 mutex_lock(&qmutex);
1585
1586 6696 found = lookup_ctx_nm(&blocked, cid);
1587
2/2
✓ Branch 0 taken 1092 times.
✓ Branch 1 taken 5604 times.
 6696 if (!found) {
1588 1092 found = lookup_ctx_nm(&queue, cid);
1589 }
1590
4/6
✓ Branch 0 taken 3 times.
✓ Branch 1 taken 6693 times.
✓ Branch 2 taken 3 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 3 times.
✗ Branch 5 not taken.
 6696 if (!found && ctx_running && ctx_running->id == cid) {
1591 3 found = ctx_running;
1592 }
1593
1594
1/2
✓ Branch 0 taken 6696 times.
✗ Branch 1 not taken.
 6696 if (found) {
1595 6696 res = found->mailbox_size - found->num_mail;
1596 }
1597
1598 6696 mutex_unlock(&qmutex);
1599
1600 6696 return res;
1601 }
1602
1603 /** find_receiver_and_send is used for message passing where
1604 * the semantics is that the oldest message is dropped if the
1605 * receiver mailbox is full.
1606 */
1607 19635 bool lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1608 19635 mutex_lock(&qmutex);
1609 19635 eval_context_t *found = NULL;
1610 19635 int res = true;
1611
1612 19635 found = lookup_ctx_nm(&blocked, cid);
1613
2/2
✓ Branch 0 taken 11593 times.
✓ Branch 1 taken 8042 times.
 19635 if (found) {
1614
2/2
✓ Branch 0 taken 11564 times.
✓ Branch 1 taken 29 times.
 11593 if (LBM_IS_STATE_RECV(found->state)) { // only if unblock receivers here.
1615 11564 drop_ctx_nm(&blocked,found);
1616 11564 found->state = LBM_THREAD_STATE_READY;
1617 11564 enqueue_ctx_nm(&queue,found);
1618 }
1619 11593 mailbox_add_mail(found, msg);
1620 11593 goto find_receiver_end;
1621 }
1622
1623 8042 found = lookup_ctx_nm(&queue, cid);
1624
2/2
✓ Branch 0 taken 2047 times.
✓ Branch 1 taken 5995 times.
 8042 if (found) {
1625 2047 mailbox_add_mail(found, msg);
1626 2047 goto find_receiver_end;
1627 }
1628
1629 /* check the current context */
1630
2/4
✓ Branch 0 taken 5995 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 5995 times.
✗ Branch 3 not taken.
 5995 if (ctx_running && ctx_running->id == cid) {
1631 5995 mailbox_add_mail(ctx_running, msg);
1632 5995 goto find_receiver_end;
1633 }
1634 ✗ res = false;
1635 19635 find_receiver_end:
1636 19635 mutex_unlock(&qmutex);
1637 19635 return res;
1638 }
1639
1640 // a match binder looks like (? x) or (? _) for example.
1641 // It is a list of two elements where the first is a ? and the second is a symbol.
1642 315623 static inline lbm_value get_match_binder_variable(lbm_value exp) {
1643 315623 lbm_value var = ENC_SYM_NIL; // 0 false
1644
2/2
✓ Branch 0 taken 178143 times.
✓ Branch 1 taken 137480 times.
 315623 if (lbm_is_cons(exp)) {
1645 178143 lbm_cons_t *e_cell = lbm_ref_cell(exp);
1646 178143 lbm_value bt = e_cell->car;
1647
3/4
✓ Branch 0 taken 37899 times.
✓ Branch 1 taken 140244 times.
✓ Branch 2 taken 37899 times.
✗ Branch 3 not taken.
 178143 if (bt == ENC_SYM_MATCH_ANY && lbm_is_cons(e_cell->cdr)) {
1648 37899 var = lbm_ref_cell(e_cell->cdr)->car;
1649 }
1650 }
1651 315623 return var;
1652 }
1653
1654 /* Pattern matching is currently implemented as a recursive
1655 function and make use of stack relative to the size of
1656 expressions that are being matched. */
1657 315623 static bool match(lbm_value p, lbm_value e, lbm_value *env) {
1658 315623 bool r = false;
1659 315623 lbm_value var = get_match_binder_variable(p);
1660
2/2
✓ Branch 0 taken 37899 times.
✓ Branch 1 taken 277724 times.
 315623 if (var) {
1661 #ifdef LBM_ALWAYS_GC
1662 lbm_gc_mark_phase(*env);
1663 gc();
1664 #endif
1665 37899 lbm_value ls = lbm_heap_allocate_list_init(2, var, ENC_SYM_NIL);
1666
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 37871 times.
 37899 if (!lbm_is_ptr(ls)) {
1667 28 lbm_gc_mark_phase(*env);
1668 28 gc();
1669 28 ls = lbm_heap_allocate_list_init(2, var, ENC_SYM_NIL);
1670
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (!lbm_is_ptr(ls)) {
1671 ✗ ERROR_CTX(ls);
1672 }
1673 }
1674 37899 lbm_value c1 = ls;
1675 37899 lbm_value c2 = lbm_cdr(ls);
1676 37899 lbm_set_cdr(c1, e);
1677 37899 lbm_set_car_and_cdr(c2, c1, *env);
1678 37899 *env = c2;
1679 37899 r = true;
1680
2/2
✓ Branch 0 taken 134120 times.
✓ Branch 1 taken 143604 times.
 277724 } else if (lbm_is_symbol(p)) {
1681
2/2
✓ Branch 0 taken 2576 times.
✓ Branch 1 taken 131544 times.
 134120 if (p == ENC_SYM_DONTCARE) r = true;
1682 131544 else r = (p == e);
1683
4/4
✓ Branch 0 taken 140244 times.
✓ Branch 1 taken 3360 times.
✓ Branch 2 taken 137892 times.
✓ Branch 3 taken 2352 times.
 143604 } else if (lbm_is_cons(p) && lbm_is_cons(e) ) {
1684 137892 lbm_cons_t *p_cell = lbm_ref_cell(p);
1685 137892 lbm_cons_t *e_cell = lbm_ref_cell(e);
1686 137892 lbm_value headp = p_cell->car;
1687 137892 lbm_value tailp = p_cell->cdr;
1688 137892 lbm_value heade = e_cell->car;
1689 137892 lbm_value taile = e_cell->cdr;
1690 137892 r = match(headp, heade, env);
1691
4/4
✓ Branch 0 taken 46384 times.
✓ Branch 1 taken 91508 times.
✓ Branch 2 taken 46268 times.
✓ Branch 3 taken 116 times.
 137892 r = r && match (tailp, taile, env);
1692 } else {
1693 5712 r = struct_eq(p, e);
1694 }
1695 315623 return r;
1696 }
1697
1698 // Find match is not very picky about syntax.
1699 // A completely malformed recv form is most likely to
1700 // just return no_match.
1701 16999 static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
1702 // A pattern list is a list of pattern, expression lists.
1703 // ( (p1 e1) (p2 e2) ... (pn en))
1704 16999 lbm_value curr_p = plist;
1705 16999 int n = 0;
1706
2/2
✓ Branch 0 taken 18007 times.
✓ Branch 1 taken 168 times.
 18175 for (int i = 0; i < (int)num; i ++ ) {
1707 18007 lbm_value curr_e = earr[i];
1708
2/2
✓ Branch 0 taken 38419 times.
✓ Branch 1 taken 1176 times.
 39595 while (!lbm_is_symbol_nil(curr_p)) {
1709 lbm_value p[3];
1710 38419 lbm_value curr = get_car(curr_p);
1711 38419 extract_n(curr, p, 3);
1712
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 38419 times.
 38419 if (!lbm_is_symbol_nil(p[2])) { // A rare syntax check. maybe drop?
1713 ✗ lbm_set_error_reason("Incorrect pattern format for recv");
1714 ✗ ERROR_AT_CTX(ENC_SYM_EERROR,curr);
1715 }
1716
2/2
✓ Branch 0 taken 16831 times.
✓ Branch 1 taken 21588 times.
 38419 if (match(p[0], curr_e, env)) {
1717 16831 *e = p[1];
1718 16831 return n;
1719 }
1720 21588 curr_p = get_cdr(curr_p);
1721 }
1722 1176 curr_p = plist; /* search all patterns against next exp */
1723 1176 n ++;
1724 }
1725 168 return FM_NO_MATCH;
1726 }
1727
1728 /****************************************************/
1729 /* Garbage collection */
1730
1731 1037673 static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1732 (void) arg1;
1733 (void) arg2;
1734 1037673 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r};
1735 1037673 lbm_gc_mark_env(ctx->curr_env);
1736 1037673 lbm_gc_mark_roots(roots, 3);
1737 1037673 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1738 1037673 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1739 1037673 }
1740
1741 1012965 static int gc(void) {
1742
2/2
✓ Branch 0 taken 1012908 times.
✓ Branch 1 taken 57 times.
 1012965 if (ctx_running) {
1743 1012908 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT;
1744 }
1745
1746 1012965 gc_requested = false;
1747 1012965 lbm_gc_state_inc();
1748
1749 // The freelist should generally be NIL when GC runs.
1750 1012965 lbm_nil_freelist();
1751 1012965 lbm_value *env = lbm_get_global_env();
1752
2/2
✓ Branch 0 taken 32414880 times.
✓ Branch 1 taken 1012965 times.
 33427845 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
1753 32414880 lbm_gc_mark_env(env[i]);
1754 }
1755
1756 1012965 mutex_lock(&qmutex); // Lock the queues.
1757 // Any concurrent messing with the queues
1758 // while doing GC cannot possibly be good.
1759 1012965 queue_iterator_nm(&queue, mark_context, NULL, NULL);
1760 1012965 queue_iterator_nm(&blocked, mark_context, NULL, NULL);
1761
1762
2/2
✓ Branch 0 taken 1012908 times.
✓ Branch 1 taken 57 times.
 1012965 if (ctx_running) {
1763 1012908 mark_context(ctx_running, NULL, NULL);
1764 }
1765 1012965 mutex_unlock(&qmutex);
1766
1767 1012965 int r = lbm_gc_sweep_phase();
1768 1012965 lbm_heap_new_freelist_length();
1769 1012965 lbm_memory_update_min_free();
1770
1771
2/2
✓ Branch 0 taken 1012908 times.
✓ Branch 1 taken 57 times.
 1012965 if (ctx_running) {
1772 1012908 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT;
1773 }
1774 1012965 return r;
1775 }
1776
1777 27892 int lbm_perform_gc(void) {
1778 27892 return gc();
1779 }
1780
1781 /****************************************************/
1782 /* Evaluation functions */
1783
1784
1785 900576870 static void eval_symbol(eval_context_t *ctx) {
1786 900576870 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1787
2/2
✓ Branch 0 taken 436479106 times.
✓ Branch 1 taken 464097765 times.
 900576871 if (s >= RUNTIME_SYMBOLS_START) {
1788 436479106 lbm_value res = ENC_SYM_NIL;
1789
4/4
✓ Branch 0 taken 77064223 times.
✓ Branch 1 taken 359414885 times.
✓ Branch 2 taken 77052846 times.
✓ Branch 3 taken 11377 times.
 513543329 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1790 77064223 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1791 436467731 ctx->r = res;
1792 436467731 ctx->app_cont = true;
1793 436467731 return;
1794 }
1795 // Dynamic load attempt
1796 // Only symbols of kind RUNTIME can be dynamically loaded.
1797 11377 const char *sym_str = lbm_get_name_by_symbol(s);
1798 11377 const char *code_str = NULL;
1799
2/2
✓ Branch 0 taken 177 times.
✓ Branch 1 taken 11200 times.
 11377 if (!dynamic_load_callback(sym_str, &code_str)) {
1800 177 ERROR_AT_CTX(ENC_SYM_NOT_FOUND, ctx->curr_exp);
1801 }
1802 11200 lbm_value *sptr = stack_reserve(ctx, 3);
1803 11200 sptr[0] = ctx->curr_exp;
1804 11200 sptr[1] = ctx->curr_env;
1805 11200 sptr[2] = RESUME;
1806
1807 11200 lbm_value chan = ENC_SYM_NIL;
1808 #ifdef LBM_ALWAYS_GC
1809 gc();
1810 #endif
1811
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 11200 times.
 11200 if (!create_string_channel((char *)code_str, &chan, ENC_SYM_NIL)) {
1812 ✗ gc();
1813 ✗ if (!create_string_channel((char *)code_str, &chan, ENC_SYM_NIL)) {
1814 ✗ ERROR_CTX(ENC_SYM_MERROR);
1815 }
1816 }
1817
1818 // Here, chan has either been assigned or execution has terminated.
1819
1820 lbm_value loader;
1821
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 11200 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 11200 WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,
1822 ENC_SYM_READ,
1823 chan), chan);
1824 lbm_value evaluator;
1825
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 11200 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 11200 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,
1826 ENC_SYM_EVAL,
1827 loader), loader);
1828 11200 ctx->curr_exp = evaluator;
1829 11200 ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env
1830 } else {
1831 //special symbols and extensions can be handled the same way.
1832 464097765 ctx->r = ctx->curr_exp;
1833 464097765 ctx->app_cont = true;
1834 }
1835 }
1836
1837 // (quote e) => e
1838 9885742 static void eval_quote(eval_context_t *ctx) {
1839 9885742 ctx->r = get_cadr(ctx->curr_exp);
1840 9885742 ctx->app_cont = true;
1841 9885742 }
1842
1843 // a => a
1844 499991945 static void eval_selfevaluating(eval_context_t *ctx) {
1845 499991945 ctx->r = ctx->curr_exp;
1846 499991945 ctx->app_cont = true;
1847 499991945 }
1848
1849 // (progn e1 ... en)
1850 36035307 static void eval_progn(eval_context_t *ctx) {
1851 36035307 lbm_value exps = get_cdr(ctx->curr_exp);
1852
1853
2/2
✓ Branch 0 taken 36035251 times.
✓ Branch 1 taken 56 times.
 36035307 if (lbm_is_cons(exps)) {
1854 36035251 lbm_cons_t *cell = lbm_ref_cell(exps); // already checked that it's cons.
1855 36035251 ctx->curr_exp = cell->car;
1856
2/2
✓ Branch 0 taken 30430308 times.
✓ Branch 1 taken 5604943 times.
 36035251 if (lbm_is_cons(cell->cdr)) { // malformed progn not ending in nil is tolerated
1857 30430308 lbm_uint *sptr = stack_reserve(ctx, 4);
1858 30430308 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1859 30430308 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1860 30430308 sptr[2] = cell->cdr; // Requirement: sptr[2] is a cons.
1861 30430308 sptr[3] = PROGN_REST;
1862 }
1863
1/2
✓ Branch 0 taken 56 times.
✗ Branch 1 not taken.
 56 } else if (lbm_is_symbol_nil(exps)) { // Empty progn is nil
1864 56 ctx->r = ENC_SYM_NIL;
1865 56 ctx->app_cont = true;
1866 } else {
1867 ✗ ERROR_CTX(ENC_SYM_EERROR);
1868 }
1869 36035307 }
1870
1871 // (atomic e1 ... en)
1872 505 static void eval_atomic(eval_context_t *ctx) {
1873
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 505 times.
 505 if (is_atomic) atomic_error();
1874 505 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC;
1875 505 is_atomic = true;
1876 505 eval_progn(ctx);
1877 505 }
1878
1879 // (call-cc (lambda (k) .... ))
1880 616 static void eval_callcc(eval_context_t *ctx) {
1881 lbm_value cont_array;
1882 616 lbm_uint *sptr0 = stack_reserve(ctx, 1);
1883
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 616 times.
 616 sptr0[0] = is_atomic ? ENC_SYM_TRUE : ENC_SYM_NIL;
1884 #ifdef LBM_ALWAYS_GC
1885 gc();
1886 #endif
1887
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 616 times.
 616 if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
1888 ✗ gc();
1889 ✗ lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp);
1890 }
1891
1/2
✓ Branch 0 taken 616 times.
✗ Branch 1 not taken.
 616 if (lbm_is_ptr(cont_array)) {
1892 616 lbm_array_header_t *arr = assume_array(cont_array);
1893 616 memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
1894 // The stored stack contains the is_atomic flag.
1895 // This flag is overwritten in the following execution path.
1896
1897 616 lbm_value acont = cons_with_gc(ENC_SYM_CONT, cont_array, ENC_SYM_NIL);
1898 616 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
1899 // Go directly into application evaluation without passing go
1900 616 lbm_uint *sptr = stack_reserve(ctx, 2);
1901 616 sptr0[0] = ctx->curr_env;
1902 616 sptr[0] = arg_list;
1903 616 sptr[1] = APPLICATION_START;
1904 616 ctx->curr_exp = get_cadr(ctx->curr_exp);
1905 } else {
1906 // failed to create continuation array.
1907 ✗ ERROR_CTX(ENC_SYM_MERROR);
1908 }
1909 616 }
1910
1911 // (call-cc-unsafe (lambda (k) ... ))
1912 // cc-unsafe: continuation should not be bound to any global directly or indirectly.
1913 // invoking the continuation must check that target SP holds a continuation that
1914 // can be applied using app_cont, otherwise error. The continuation need not be correct
1915 // in case user globally bound the continuation, but it may rule out disastrous failure.
1916 1626 static void eval_call_cc_unsafe(eval_context_t *ctx) {
1917 1626 lbm_uint sp = ctx->K.sp;
1918 // The stored stack contains the is_atomic flag.
1919 // This flag is overwritten in the following execution path.
1920 lbm_value acont;
1921
2/8
✗ Branch 0 not taken.
✓ Branch 1 taken 1626 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 1626 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 1626 WITH_GC(acont, lbm_heap_allocate_list_init(3,
1922 ENC_SYM_CONT_SP,
1923 lbm_enc_i((int32_t)sp),
1924 is_atomic ? ENC_SYM_TRUE : ENC_SYM_NIL, ENC_SYM_NIL));
1925 1626 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
1926 // Go directly into application evaluation without passing go
1927 1626 lbm_uint *sptr = stack_reserve(ctx, 3);
1928 1626 sptr[0] = ctx->curr_env;
1929 1626 sptr[1] = arg_list;
1930 1626 sptr[2] = APPLICATION_START;
1931 1626 ctx->curr_exp = get_cadr(ctx->curr_exp);
1932 1626 }
1933
1934 // (define sym exp)
1935 #define KEY 1
1936 #define VAL 2
1937 14145442 static void eval_define(eval_context_t *ctx) {
1938 lbm_value parts[3];
1939 14145442 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1940 14145442 lbm_uint *sptr = stack_reserve(ctx, 2);
1941
3/4
✓ Branch 0 taken 14145441 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 14145441 times.
✗ Branch 3 not taken.
 14145442 if (lbm_is_symbol(parts[KEY]) && lbm_is_symbol_nil(rest)) {
1942 14145441 lbm_uint sym_val = lbm_dec_sym(parts[KEY]);
1943 14145441 sptr[0] = parts[KEY];
1944
2/2
✓ Branch 0 taken 14145438 times.
✓ Branch 1 taken 3 times.
 14145441 if (sym_val >= RUNTIME_SYMBOLS_START) {
1945 14145438 sptr[1] = SET_GLOBAL_ENV;
1946
2/2
✓ Branch 0 taken 43 times.
✓ Branch 1 taken 14145395 times.
 14145438 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST) {
1947 43 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
1948 }
1949 14145438 ctx->curr_exp = parts[VAL];
1950 14145438 return;
1951 } else {
1952 3 lbm_set_error_reason((char*)lbm_error_str_built_in);
1953 }
1954 }
1955 4 ERROR_AT_CTX(ENC_SYM_EERROR, ctx->curr_exp);
1956 }
1957
1958 #if false
1959 /* Allocate closure is only used in eval_lambda currently.
1960 Inlining it should use no extra storage.
1961 */
1962 static inline lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
1963
1964 #ifdef LBM_ALWAYS_GC
1965 gc();
1966 if (lbm_heap_num_free() < 4) {
1967 ERROR_CTX(ENC_SYM_MERROR);
1968 }
1969 #else
1970 if (lbm_heap_num_free() < 4) {
1971 gc();
1972 if (lbm_heap_num_free() < 4) {
1973 ERROR_CTX(ENC_SYM_MERROR);
1974 }
1975 }
1976 #endif
1977 // The freelist will always contain just plain heap-cells.
1978 // So dec_ptr is sufficient.
1979 lbm_value res = lbm_heap_state.freelist;
1980 // CONS check is not needed. If num_free is correct, then freelist is a cons-cell.
1981 lbm_cons_t *heap = lbm_heap_state.heap;
1982 lbm_uint ix = lbm_dec_ptr(res);
1983 heap[ix].car = ENC_SYM_CLOSURE;
1984 ix = lbm_dec_ptr(heap[ix].cdr);
1985 heap[ix].car = params;
1986 ix = lbm_dec_ptr(heap[ix].cdr);
1987 heap[ix].car = body;
1988 ix = lbm_dec_ptr(heap[ix].cdr);
1989 heap[ix].car = env;
1990 lbm_heap_state.freelist = heap[ix].cdr;
1991 heap[ix].cdr = ENC_SYM_NIL;
1992 lbm_heap_state.num_alloc+=4;
1993 return res;
1994 }
1995
1996 /* Eval lambda is cheating, a lot! It does this
1997 for performance reasons. The cheats are that
1998 1. When closure is created, a reference to the local env
1999 in which the lambda was evaluated is added to the closure.
2000 Ideally it should have created a list of free variables in the function
2001 and then looked up the values of these creating a new environment.
2002 2. The global env is considered global constant. As there is no copying
2003 of environment bindings into the closure, undefine may break closures.
2004
2005 some obscure programs such as test_setq_local_closure.lisp does not
2006 work properly due to this cheating.
2007 */
2008 // (lambda param-list body-exp) -> (closure param-list body-exp env)
2009
2010
2011 static void eval_lambda(eval_context_t *ctx) {
2012 lbm_value vals[3];
2013 extract_n(ctx->curr_exp, vals, 3);
2014 ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
2015 #ifdef CLEAN_UP_CLOSURES
2016 lbm_uint sym_id = 0;
2017 if (clean_cl_env_symbol) {
2018 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
2019 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
2020 ctx->curr_exp = app;
2021 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
2022 clean_cl_env_symbol = lbm_enc_sym(sym_id);
2023 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
2024 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
2025 ctx->curr_exp = app;
2026 } else {
2027 ctx->app_cont = true;
2028 }
2029 #else
2030 ctx->app_cont = true;
2031 #endif
2032 }
2033 #else
2034 427128 static void eval_lambda(eval_context_t *ctx) {
2035 #ifdef LBM_ALWAYS_GC
2036 gc();
2037 #endif
2038
1/2
✓ Branch 0 taken 428332 times.
✗ Branch 1 not taken.
 428332 for (int retry = 0; retry < 2; retry ++) {
2039
2/2
✓ Branch 0 taken 427128 times.
✓ Branch 1 taken 1204 times.
 428332 if (lbm_heap_num_free() >= 4) {
2040 427128 lbm_value clo = lbm_heap_state.freelist;
2041 427128 lbm_value lam = get_cdr(ctx->curr_exp);
2042 427128 lbm_uint ix = lbm_dec_ptr(clo);
2043 427128 lbm_cons_t *heap = lbm_heap_state.heap;
2044 427128 heap[ix].car = ENC_SYM_CLOSURE;
2045 427128 ix = lbm_dec_ptr(heap[ix].cdr);
2046 427128 get_car_and_cdr(lam, &heap[ix].car, &lam); // params
2047 427128 ix = lbm_dec_ptr(heap[ix].cdr);
2048 427128 get_car_and_cdr(lam, &heap[ix].car, &lam); // body
2049 427123 ix = lbm_dec_ptr(heap[ix].cdr);
2050 427123 heap[ix].car = ctx->curr_env;
2051 427123 lbm_heap_state.freelist = heap[ix].cdr;
2052 427123 heap[ix].cdr = ENC_SYM_NIL;
2053 427123 lbm_heap_state.num_alloc+=4;
2054 427123 ctx->r = clo;
2055 #ifdef CLEAN_UP_CLOSURES
2056 lbm_uint sym_id = 0;
2057 if (clean_cl_env_symbol) {
2058 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
2059 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
2060 ctx->curr_exp = app;
2061 } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
2062 clean_cl_env_symbol = lbm_enc_sym(sym_id);
2063 lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
2064 lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
2065 ctx->curr_exp = app;
2066 } else {
2067 ctx->app_cont = true;
2068 }
2069 #else
2070 427123 ctx->app_cont = true;
2071 #endif
2072 427123 return;
2073 } else {
2074 1204 gc();
2075 }
2076 }
2077 ✗ ERROR_CTX(ENC_SYM_MERROR);
2078 }
2079 #endif
2080
2081 // (if cond-expr then-expr else-expr)
2082 55778797 static void eval_if(eval_context_t *ctx) {
2083 55778797 lbm_value cdr = get_cdr(ctx->curr_exp);
2084 55778797 lbm_value *sptr = stack_reserve(ctx, 3);
2085 55778797 get_car_and_cdr(cdr, &ctx->curr_exp, &sptr[0]);
2086 55778796 sptr[1] = ctx->curr_env;
2087 55778796 sptr[2] = IF;
2088 55778796 }
2089
2090 // (cond (cond-expr-1 expr-1)
2091 // ...
2092 // (cond-expr-N expr-N))
2093 2632 static void eval_cond(eval_context_t *ctx) {
2094 lbm_value cond1[2];
2095 2632 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
2096
2097 // end recursion at (cond )
2098
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 2576 times.
 2632 if (lbm_is_symbol_nil(cond1[1])) {
2099 56 ctx->r = ENC_SYM_NIL;
2100 56 ctx->app_cont = true;
2101 } else {
2102 // Cond is one of the few places where a bit of syntax checking takes place at runtime..
2103 // Maybe dont bother?
2104 2576 lbm_uint len = lbm_list_length(cond1[1]);
2105
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2576 times.
 2576 if (len != 2) {
2106 ✗ lbm_set_error_reason("Incorrect syntax in cond");
2107 ✗ ERROR_CTX(ENC_SYM_EERROR);
2108 }
2109 lbm_value cond_expr[2];
2110 2576 extract_n(cond1[1], cond_expr, 2);
2111 lbm_value rest;
2112
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 2576 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 2576 WITH_GC(rest, lbm_heap_allocate_list_init(2,
2113 cond_expr[1], // Then branch
2114 cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)));
2115 2576 lbm_value *sptr = stack_reserve(ctx, 3);
2116 2576 sptr[0] = rest;
2117 2576 sptr[1] = ctx->curr_env;
2118 2576 sptr[2] = IF;
2119 2576 ctx->curr_exp = cond_expr[0]; //condition;
2120 }
2121 2632 }
2122
2123 23263 static void eval_app_cont(eval_context_t *ctx) {
2124 23263 lbm_stack_drop(&ctx->K, 1);
2125 23263 ctx->app_cont = true;
2126 23263 }
2127
2128 // Create a named location in an environment to later receive a value.
2129 // Protects env from GC, other data is the obligation of the caller.
2130 81781396 static void create_binding_location(lbm_value key, lbm_value *env) {
2131
2/2
✓ Branch 0 taken 53779319 times.
✓ Branch 1 taken 28002077 times.
 81781396 if (lbm_is_symbol(key)) { // default case
2132
4/4
✓ Branch 0 taken 48179151 times.
✓ Branch 1 taken 5600168 times.
✓ Branch 2 taken 5600224 times.
✓ Branch 3 taken 42578927 times.
 53779319 if (key == ENC_SYM_NIL || key == ENC_SYM_DONTCARE) return;
2133 #ifdef LBM_ALWAYS_GC
2134 lbm_gc_mark_phase(*env);
2135 gc();
2136 #endif
2137 42578927 lbm_value ls = lbm_heap_allocate_list_init(2,
2138 key,
2139 ENC_SYM_NIL);
2140
2/2
✓ Branch 0 taken 57924 times.
✓ Branch 1 taken 42521003 times.
 42578927 if (!lbm_is_ptr(ls)) {
2141 57924 lbm_gc_mark_phase(*env);
2142 57924 gc();
2143 57924 ls = lbm_heap_allocate_list_init(2,
2144 key,
2145 ENC_SYM_NIL);
2146
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 57924 times.
 57924 if (!lbm_is_ptr(ls)) ERROR_CTX(ENC_SYM_MERROR);
2147 }
2148 42578927 lbm_value binding = ls;
2149 42578927 lbm_cons_t *ls_ref = lbm_ref_cell(ls);
2150 42578927 lbm_value new_env = ls_ref->cdr;
2151 42578927 ls_ref->cdr = ENC_SYM_PLACEHOLDER; // known cons
2152 //lbm_set_cdr(binding, ENC_SYM_PLACEHOLDER);
2153 42578927 lbm_cons_t *new_env_ref = lbm_ref_cell(new_env); //known cons
2154 42578927 new_env_ref->car = binding;
2155 42578927 new_env_ref->cdr = *env;
2156 //lbm_set_car_and_cdr(new_env,binding, *env);
2157 42578927 *env = new_env;
2158
2/2
✓ Branch 0 taken 28002073 times.
✓ Branch 1 taken 4 times.
 28002077 } else if (lbm_is_cons(key)) { // deconstruct case
2159 28002073 create_binding_location(lbm_ref_cell(key)->car, env);
2160 28002073 create_binding_location(lbm_ref_cell(key)->cdr, env);
2161 } else {
2162 4 ERROR_CTX(ENC_SYM_EERROR);
2163 }
2164 }
2165
2166 24260014 static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
2167
2/2
✓ Branch 0 taken 24260012 times.
✓ Branch 1 taken 2 times.
 24260014 if (lbm_is_cons(binds)) {
2168 // Preallocate binding locations.
2169 24260012 lbm_value curr = binds;
2170
2/2
✓ Branch 0 taken 24489723 times.
✓ Branch 1 taken 24260009 times.
 48749732 while (lbm_is_cons(curr)) {
2171 24489723 lbm_value new_env_tmp = env;
2172 24489723 lbm_cons_t *cell = lbm_ref_cell(curr); // already checked that cons.
2173 24489723 lbm_value car_curr = cell->car;
2174 24489723 lbm_value cdr_curr = cell->cdr;
2175 24489723 lbm_value key = get_car(car_curr);
2176 24489723 create_binding_location(key, &new_env_tmp);
2177 24489720 env = new_env_tmp;
2178 24489720 curr = cdr_curr;
2179 }
2180
2181 24260009 lbm_cons_t *cell = lbm_ref_cell(binds); // already checked that cons.
2182 24260009 lbm_value car_binds = cell->car;
2183 24260009 lbm_value cdr_binds = cell->cdr;
2184 lbm_value key_val[2];
2185 24260009 extract_n(car_binds, key_val, 2);
2186
2187 24260009 lbm_uint *sptr = stack_reserve(ctx, 5);
2188 24260009 sptr[0] = exp;
2189 24260009 sptr[1] = cdr_binds;
2190 24260009 sptr[2] = env;
2191 24260009 sptr[3] = key_val[0];
2192 24260009 sptr[4] = BIND_TO_KEY_REST;
2193 24260009 ctx->curr_exp = key_val[1];
2194 24260009 ctx->curr_env = env;
2195 } else {
2196 2 ctx->curr_exp = exp;
2197 }
2198 24260011 }
2199
2200 // (var x (...)) - local binding inside of an progn
2201 // var has to take, place root-level nesting within progn.
2202 // (progn ... (var a 10) ...) OK!
2203 // (progn ... (something (var a 10)) ... ) NOT OK!
2204 /* progn stack
2205 sp-4 : env
2206 sp-3 : 0
2207 sp-2 : rest
2208 sp-1 : PROGN_REST
2209 */
2210 1287528 static void eval_var(eval_context_t *ctx) {
2211
1/2
✓ Branch 0 taken 1287528 times.
✗ Branch 1 not taken.
 1287528 if (ctx->K.sp >= 4) { // Possibly in progn
2212 1287528 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
2213
3/4
✓ Branch 0 taken 1287528 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 1287527 times.
✓ Branch 3 taken 1 times.
 1287528 if (IS_CONTINUATION(sv) && (sv == PROGN_REST)) {
2214 1287527 lbm_uint sp = ctx->K.sp;
2215 1287527 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
2216
2/2
✓ Branch 0 taken 1264063 times.
✓ Branch 1 taken 23464 times.
 1287527 if (is_copied == 0) {
2217 lbm_value env;
2218
3/4
✓ Branch 0 taken 1448 times.
✓ Branch 1 taken 1262615 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 1448 times.
 1264063 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]));
2219 1264063 ctx->K.data[sp-3] = lbm_enc_u(1);
2220 1264063 ctx->K.data[sp-4] = env;
2221 }
2222 1287527 lbm_value new_env = ctx->K.data[sp-4];
2223 1287527 lbm_value args = get_cdr(ctx->curr_exp);
2224 1287527 lbm_value key = get_car(args);
2225 1287527 create_binding_location(key, &new_env);
2226
2227 1287526 ctx->K.data[sp-4] = new_env;
2228
2229 1287526 lbm_value v_exp = get_cadr(args);
2230 1287526 lbm_value *sptr = stack_reserve(ctx, 3);
2231 1287526 sptr[0] = new_env;
2232 1287526 sptr[1] = key;
2233 1287526 sptr[2] = PROGN_VAR;
2234 // Activating the new environment before the evaluation of the value to be bound.
2235 // This would normally shadow the existing value, but create_binding_location sets
2236 // the binding to be $placeholder, which is ignored when looking up the value.
2237 // The way closures work, the var-variable needs to be in scope during val
2238 // evaluation for a recursive closure to be possible.
2239 1287526 ctx->curr_env = new_env;
2240 1287526 ctx->curr_exp = v_exp;
2241 1287526 return;
2242 }
2243 }
2244 1 lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
2245 1 ERROR_CTX(ENC_SYM_EERROR);
2246 }
2247
2248 // (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
2249 // does not error when given incorrect number of arguments.
2250 4593083 static void eval_setq(eval_context_t *ctx) {
2251 lbm_value parts[3];
2252 4593083 extract_n(ctx->curr_exp, parts, 3);
2253 4593083 lbm_value *sptr = stack_reserve(ctx, 3);
2254 4593083 sptr[0] = ctx->curr_env;
2255 4593083 sptr[1] = parts[1];
2256 4593083 sptr[2] = SETQ;
2257 4593083 ctx->curr_exp = parts[2];
2258 4593083 }
2259
2260 728 static void eval_move_to_flash(eval_context_t *ctx) {
2261 728 lbm_value args = get_cdr(ctx->curr_exp);
2262 728 lbm_value *sptr = stack_reserve(ctx,2);
2263 728 sptr[0] = args;
2264 728 sptr[1] = MOVE_TO_FLASH;
2265 728 ctx->app_cont = true;
2266 728 }
2267
2268 // (loop list-of-local-bindings
2269 // condition-exp
2270 // body-exp)
2271 560 static void eval_loop(eval_context_t *ctx) {
2272 560 lbm_value env = ctx->curr_env;
2273 lbm_value parts[3];
2274 560 extract_n(get_cdr(ctx->curr_exp), parts, 3);
2275 560 lbm_value *sptr = stack_reserve(ctx, 4);
2276 560 sptr[0] = parts[LOOP_BODY];
2277 560 sptr[1] = parts[LOOP_COND];
2278 560 sptr[2] = ENC_SYM_NIL;
2279 560 sptr[3] = LOOP_ENV_PREP;
2280 560 let_bind_values_eval(parts[LOOP_BINDS], ENC_SYM_NIL, env, ctx);
2281 560 }
2282
2283 /* (trap expression)
2284 *
2285 * suggested use:
2286 * (match (trap expression)
2287 * ((exit-error (? err)) (error-handler err))
2288 * ((exit-ok (? v)) (value-handler v)))
2289 */
2290 16896 static void eval_trap(eval_context_t *ctx) {
2291
2292 16896 lbm_value expr = get_cadr(ctx->curr_exp);
2293 lbm_value retval;
2294
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 16896 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 16896 WITH_GC(retval, lbm_heap_allocate_list(2));
2295 16896 lbm_ref_cell(retval)->car = ENC_SYM_EXIT_OK;
2296 // lbm_set_car(retval, ENC_SYM_EXIT_OK); // Assume things will go well.
2297 16896 lbm_uint *sptr = stack_reserve(ctx,3);
2298 16896 sptr[0] = retval;
2299 16896 sptr[1] = ctx->flags;
2300 16896 sptr[2] = EXCEPTION_HANDLER;
2301 16896 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN;
2302 16896 ctx->curr_exp = expr;
2303 16896 }
2304
2305 // (let list-of-binding s
2306 // body-exp)
2307 24259454 static void eval_let(eval_context_t *ctx) {
2308 24259454 lbm_value env = ctx->curr_env;
2309 lbm_value parts[3];
2310 24259454 extract_n(ctx->curr_exp, parts, 3);
2311 24259454 let_bind_values_eval(parts[1], parts[2], env, ctx);
2312 24259451 }
2313
2314 // (and exp0 ... expN)
2315 31980154 static void eval_and(eval_context_t *ctx) {
2316 31980154 lbm_value rest = get_cdr(ctx->curr_exp);
2317
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 31980098 times.
 31980154 if (lbm_is_symbol_nil(rest)) {
2318 56 ctx->app_cont = true;
2319 56 ctx->r = ENC_SYM_TRUE;
2320 } else {
2321 31980098 lbm_value *sptr = stack_reserve(ctx, 3);
2322 31980098 get_car_and_cdr(rest, &ctx->curr_exp, &sptr[1]);
2323 31980098 sptr[0] = ctx->curr_env;
2324 31980098 sptr[2] = AND;
2325 }
2326 31980154 }
2327
2328 // (or exp0 ... expN)
2329 14582 static void eval_or(eval_context_t *ctx) {
2330 14582 lbm_value rest = get_cdr(ctx->curr_exp);
2331
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 14526 times.
 14582 if (lbm_is_symbol_nil(rest)) {
2332 56 ctx->app_cont = true;
2333 56 ctx->r = ENC_SYM_NIL;
2334 } else {
2335 14526 lbm_value *sptr = stack_reserve(ctx, 3);
2336 14526 get_car_and_cdr(rest, &ctx->curr_exp, &sptr[1]);
2337 14526 sptr[0] = ctx->curr_env;
2338 14526 sptr[2] = OR;
2339 }
2340 14582 }
2341
2342 // Pattern matching
2343 // format:
2344 // (match e (pattern body)
2345 // (pattern body)
2346 // ... )
2347 //
2348 // There can be an optional pattern guard:
2349 // (match e (pattern guard body)
2350 // ... )
2351 // a guard is a boolean expression.
2352 // Guards make match, pattern matching more complicated
2353 // than the recv pattern matching and requires staged execution
2354 // via the continuation system rather than a while loop over a list.
2355 16184 static void eval_match(eval_context_t *ctx) {
2356
2357 16184 lbm_value rest = get_cdr(ctx->curr_exp);
2358
2/2
✓ Branch 0 taken 16182 times.
✓ Branch 1 taken 2 times.
 16184 if (lbm_is_cons(rest)) {
2359 16182 lbm_cons_t *cell = lbm_ref_cell(rest);
2360 16182 lbm_value cdr_rest = cell->cdr;
2361 16182 ctx->curr_exp = cell->car;
2362 16182 lbm_value *sptr = stack_reserve(ctx, 3);
2363 16182 sptr[0] = cdr_rest;
2364 16182 sptr[1] = ctx->curr_env;
2365 16182 sptr[2] = MATCH;
2366 } else {
2367 // someone wrote the program (match)
2368 2 ERROR_CTX(ENC_SYM_EERROR);
2369 }
2370 16182 }
2371
2372 // Receive-timeout
2373 // (recv-to timeout (pattern expr)
2374 // (pattern expr))
2375 504 static void eval_receive_timeout(eval_context_t *ctx) {
2376
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 504 times.
 504 if (is_atomic) atomic_error();
2377 504 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2378 504 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2379
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 392 times.
 504 if (lbm_is_symbol_nil(pats)) {
2380 112 lbm_set_error_reason((char*)lbm_error_str_num_args);
2381 112 ERROR_AT_CTX(ENC_SYM_EERROR, ctx->curr_exp);
2382 } else {
2383 392 lbm_value *sptr = stack_reserve(ctx, 2);
2384 392 sptr[0] = pats;
2385 392 sptr[1] = RECV_TO;
2386 392 ctx->curr_exp = timeout_val;
2387 }
2388 392 }
2389
2390 // Receive
2391 // (recv (pattern expr)
2392 // (pattern expr))
2393 28402 static void eval_receive(eval_context_t *ctx) {
2394
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 28401 times.
 28402 if (is_atomic) atomic_error();
2395 28401 lbm_value pats = get_cdr(ctx->curr_exp);
2396
2/2
✓ Branch 0 taken 28345 times.
✓ Branch 1 taken 56 times.
 28401 if (pats) { // non-nil check
2397
2/2
✓ Branch 0 taken 11738 times.
✓ Branch 1 taken 16607 times.
 28345 if (ctx->num_mail == 0) {
2398 11738 block_current_ctx(LBM_THREAD_STATE_RECV_BL,0,false);
2399 } else {
2400 16607 lbm_value *msgs = ctx->mailbox;
2401 16607 lbm_uint num = ctx->num_mail;
2402
2403 lbm_value e;
2404 16607 lbm_value new_env = ctx->curr_env;
2405 16607 int n = find_match(pats, msgs, num, &e, &new_env);
2406
1/2
✓ Branch 0 taken 16607 times.
✗ Branch 1 not taken.
 16607 if (n >= 0 ) { /* Match */
2407 16607 mailbox_remove_mail(ctx, (lbm_uint)n);
2408 16607 ctx->curr_env = new_env;
2409 16607 ctx->curr_exp = e;
2410 } else { /* No match go back to sleep */
2411 ✗ ctx->r = ENC_SYM_NO_MATCH;
2412 ✗ block_current_ctx(LBM_THREAD_STATE_RECV_BL, 0,false);
2413 }
2414 }
2415 } else {
2416 56 lbm_set_error_reason((char*)lbm_error_str_num_args);
2417 56 ERROR_AT_CTX(ENC_SYM_EERROR,ctx->curr_exp);
2418 }
2419 28345 }
2420
2421 /*********************************************************/
2422 /* Continuation functions */
2423
2424 // cont_set_global_env:
2425 //
2426 // s[sp-1] = Key-symbol
2427 //
2428 // ctx->r = Value
2429 14146306 static void cont_set_global_env(eval_context_t *ctx){
2430
2431 14146306 lbm_value val = ctx->r;
2432
2433 14146306 lbm_value key = ctx->K.data[--ctx->K.sp];
2434 14146306 lbm_uint dec_key = lbm_dec_sym(key);
2435 14146306 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
2436 14146306 lbm_value *global_env = lbm_get_global_env();
2437 14146306 lbm_uint orig_env = global_env[ix_key];
2438 lbm_value new_env;
2439 // A key is a symbol and should not need to be remembered.
2440
3/4
✓ Branch 0 taken 4460 times.
✓ Branch 1 taken 14141846 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 4460 times.
 14146306 WITH_GC(new_env, lbm_env_set(orig_env,key,val));
2441
2442 14146306 global_env[ix_key] = new_env;
2443 14146306 ctx->r = val;
2444
2445 14146306 ctx->app_cont = true;
2446 14146306 }
2447
2448 // cont_resume:
2449 //
2450 // s[sp-2] = Expression
2451 // s[sp-1] = Environment
2452 //
2453 // ctx->r = Irrelevant.
2454 11196 static void cont_resume(eval_context_t *ctx) {
2455 11196 ctx->curr_env = ctx->K.data[--ctx->K.sp];
2456 11196 ctx->curr_exp = ctx->K.data[--ctx->K.sp];
2457 11196 }
2458
2459 // cont_progn_rest:
2460 //
2461 // s[sp-3] = Environment to evaluate each expression in.
2462 // s[sp-2] = Flag indicating if env has been copied.
2463 // s[sp-1] = list of expressions to evaluate.
2464 //
2465 // ctx->r = Result of last evaluated expression.
2466 35822547 static void cont_progn_rest(eval_context_t *ctx) {
2467 35822547 lbm_value *sptr = get_stack_ptr(ctx, 3);
2468
2469 35822547 lbm_value env = sptr[0];
2470 // eval_progn and cont_progn_rest both ensure that sptr[2] is a list
2471 // whenever cont_progn_rest is called.
2472
2473 35822547 lbm_cons_t *rest_cell = lbm_ref_cell(sptr[2]);
2474 35822547 lbm_value rest_cdr = rest_cell->cdr;
2475 35822547 ctx->curr_exp = rest_cell->car;;
2476 35822547 ctx->curr_env = env;
2477
2/2
✓ Branch 0 taken 5392833 times.
✓ Branch 1 taken 30429714 times.
 35822547 if (lbm_is_cons(rest_cdr)) {
2478 5392833 sptr[2] = rest_cdr; // Requirement: rest_cdr is a cons
2479 5392833 stack_reserve(ctx, 1)[0] = PROGN_REST;
2480 } else {
2481 // Nothing is pushed to stack for final element in progn. (tail-call req)
2482 30429714 lbm_stack_drop(&ctx->K, 3);
2483 }
2484 35822547 }
2485
2486 // cont_wait
2487 //
2488 // s[sp-1] = cid
2489 171 static void cont_wait(eval_context_t *ctx) {
2490
2491 171 lbm_value cid_val = ctx->K.data[--ctx->K.sp];
2492 171 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2493
2494 171 bool exists = false;
2495
2496 171 lbm_blocked_iterator(context_exists, &cid, &exists);
2497 171 lbm_running_iterator(context_exists, &cid, &exists);
2498
2499
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 171 times.
 171 if (ctx_running->id == cid) {
2500 ✗ exists = true;
2501 }
2502
2503
2/2
✓ Branch 0 taken 57 times.
✓ Branch 1 taken 114 times.
 171 if (exists) {
2504 57 lbm_value *sptr = stack_reserve(ctx, 2);
2505 57 sptr[0] = lbm_enc_i(cid);
2506 57 sptr[1] = WAIT;
2507 57 ctx->r = ENC_SYM_TRUE;
2508 57 ctx->app_cont = true;
2509 57 yield_ctx(50000);
2510 } else {
2511 114 ctx->r = ENC_SYM_TRUE;
2512 114 ctx->app_cont = true;
2513 }
2514 171 }
2515
2516 /***************************************************/
2517 /* Application helper functions. */
2518
2519
2520 /**
2521 * @brief Setup application of cont object (created by call-cc)
2522 *
2523 * The "function" form, e.g. `(SYM_CONT . cont-array)`, is expected to be stored
2524 * in `ctx->r`.
2525 *
2526 * @param args List of the arguments to apply with.
2527 * @return lbm_value The resulting argument value which should either be
2528 * evaluated or passed on directly depending on how you use this.
2529 */
2530 560 static lbm_value setup_cont(eval_context_t *ctx, lbm_value args) {
2531 /* Continuation created using call-cc.
2532 * ((SYM_CONT . cont-array) arg0 )
2533 */
2534 560 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
2535
2536
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 560 times.
 560 if (!lbm_is_lisp_array_r(c)) {
2537 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
2538 }
2539
2540 lbm_value arg;
2541 560 lbm_uint arg_count = lbm_list_length(args);
2542
2/3
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 392 times.
✗ Branch 2 not taken.
 560 switch (arg_count) {
2543 168 case 0:
2544 168 arg = ENC_SYM_NIL;
2545 168 break;
2546 392 case 1:
2547 392 arg = get_car(args);
2548 392 break;
2549 ✗ default:
2550 ✗ lbm_set_error_reason(lbm_error_str_num_args);
2551 ✗ ERROR_CTX(ENC_SYM_EERROR);
2552 }
2553
2554 560 lbm_stack_clear(&ctx->K);
2555
2556 560 lbm_array_header_t *arr = assume_array(c);
2557 560 ctx->K.sp = arr->size / sizeof(lbm_uint);
2558 560 memcpy(ctx->K.data, arr->data, arr->size);
2559
2560 560 lbm_value atomic = ctx->K.data[--ctx->K.sp];
2561 560 is_atomic = atomic ? 1 : 0;
2562
2563 560 return arg;
2564 }
2565
2566 /**
2567 * @brief Setup application of cont sp object (created by call-cc-unsafe)
2568 *
2569 * The "function" form, e.g. `(SYM_CONT_SP . stack_ptr)` is expected to be
2570 * stored in `ctx->r`.
2571 *
2572 * @param args List of the arguments to apply with.
2573 * @return lbm_value The resulting argument value which should either be
2574 * evaluated or passed on directly depending on how you use this.
2575 */
2576 168 static lbm_value setup_cont_sp(eval_context_t *ctx, lbm_value args) {
2577 // continuation created using call-cc-unsafe
2578 // ((SYM_CONT_SP . stack_ptr) arg0 )
2579 168 lbm_value c = get_cadr(ctx->r); /* should be the stack_ptr*/
2580 168 lbm_value atomic = get_cadr(get_cdr(ctx->r));
2581
2582
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 168 times.
 168 if (!lbm_is_number(c)) {
2583 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
2584 }
2585
2586 168 lbm_uint sp = (lbm_uint)lbm_dec_i(c);
2587
2588 lbm_value arg;
2589 168 lbm_uint arg_count = lbm_list_length(args);
2590
2/3
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 112 times.
✗ Branch 2 not taken.
 168 switch (arg_count) {
2591 56 case 0:
2592 56 arg = ENC_SYM_NIL;
2593 56 break;
2594 112 case 1:
2595 112 arg = get_car(args);
2596 112 break;
2597 ✗ default:
2598 ✗ lbm_set_error_reason(lbm_error_str_num_args);
2599 ✗ ERROR_CTX(ENC_SYM_EERROR);
2600 }
2601
2602
3/6
✓ Branch 0 taken 168 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 168 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 168 times.
✗ Branch 5 not taken.
 168 if (sp > 0 && sp <= ctx->K.sp && IS_CONTINUATION(ctx->K.data[sp-1])) {
2603 168 is_atomic = atomic ? 1 : 0; // works fine with nil/true
2604 168 ctx->K.sp = sp;
2605 168 return arg;
2606 } else {
2607 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
2608 }
2609 }
2610
2611 /**
2612 * @brief Setup application of macro
2613 *
2614 * The macro form, e.g. `(macro (...) ...)`, is expected to be stored in
2615 * `ctx->r`.
2616 *
2617 * @param args List of the arguments to apply the macro with.
2618 * @param curr_env The environment to re-evaluate the result of the macro
2619 * experssion in.
2620 */
2621 static inline __attribute__ ((always_inline)) void setup_macro(eval_context_t *ctx, lbm_value args, lbm_value curr_env) {
2622 /*
2623 * Perform macro expansion.
2624 * Macro expansion is really just evaluation in an
2625 * environment augmented with the unevaluated expressions passed
2626 * as arguments.
2627 */
2628
2629 13474 lbm_uint *sptr = stack_reserve(ctx, 2);
2630 // For EVAL_R, placed here already to protect from GC
2631 13698 sptr[0] = curr_env;
2632 // Placed here only to protect from GC, will be overriden.
2633 13698 sptr[1] = args;
2634
2635 13698 lbm_value curr_param = get_cadr(ctx->r);
2636 13698 lbm_value curr_arg = args;
2637 13698 lbm_value expand_env = curr_env;
2638
6/8
✓ Branch 0 taken 336 times.
✓ Branch 1 taken 224 times.
✓ Branch 2 taken 336 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 40907 times.
✓ Branch 5 taken 13474 times.
✓ Branch 6 taken 40907 times.
✗ Branch 7 not taken.
 96184 while (lbm_is_cons(curr_param) &&
2639 41243 lbm_is_cons(curr_arg)) {
2640 41243 lbm_cons_t *param_cell = lbm_ref_cell(curr_param); // already checked that cons.
2641 41243 lbm_cons_t *arg_cell = lbm_ref_cell(curr_arg);
2642 41243 lbm_value car_curr_param = param_cell->car;
2643 41243 lbm_value cdr_curr_param = param_cell->cdr;
2644 41243 lbm_value car_curr_arg = arg_cell->car;
2645 41243 lbm_value cdr_curr_arg = arg_cell->cdr;
2646
2647 41243 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
2648 41243 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL);
2649 41243 expand_env = aug_env;
2650
2651 41243 curr_param = cdr_curr_param;
2652 41243 curr_arg = cdr_curr_arg;
2653 }
2654 /* Two rounds of evaluation is performed.
2655 * First to instantiate the arguments into the macro body.
2656 * Second to evaluate the resulting program.
2657 */
2658
2659 13698 sptr[1] = EVAL_R;
2660 13698 lbm_value exp = get_cadr(get_cdr(ctx->r));
2661 13698 ctx->curr_exp = exp;
2662 13698 ctx->curr_env = expand_env;
2663 13698 }
2664
2665 4593675 static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2666
2667 4593675 lbm_uint s = lbm_dec_sym(key);
2668
2/2
✓ Branch 0 taken 4593619 times.
✓ Branch 1 taken 56 times.
 4593675 if (s >= RUNTIME_SYMBOLS_START) {
2669 4593619 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2670
3/4
✓ Branch 0 taken 2721483 times.
✓ Branch 1 taken 1872136 times.
✓ Branch 2 taken 2721483 times.
✗ Branch 3 not taken.
 4593619 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2671 2721483 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK;
2672 2721483 lbm_value *glob_env = lbm_get_global_env();
2673 2721483 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2674
2/2
✓ Branch 0 taken 2721426 times.
✓ Branch 1 taken 57 times.
 2721483 if (new_env != ENC_SYM_NOT_FOUND) {
2675 2721426 glob_env[ix_key] = new_env;
2676 }
2677 }
2678
3/4
✓ Branch 0 taken 57 times.
✓ Branch 1 taken 4593562 times.
✓ Branch 2 taken 57 times.
✗ Branch 3 not taken.
 4593619 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2679 57 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2680 57 ERROR_AT_CTX(ENC_SYM_NOT_FOUND, key);
2681 }
2682 4593562 return val;
2683 }
2684 56 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2685 return ENC_SYM_NIL; // unreachable
2686 }
2687
2688 844 static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2689
4/4
✓ Branch 0 taken 732 times.
✓ Branch 1 taken 112 times.
✓ Branch 2 taken 620 times.
✓ Branch 3 taken 112 times.
 844 if (nargs == 2 && lbm_is_symbol(args[0])) {
2690 lbm_value res;
2691
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 620 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 620 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env));
2692 620 ctx->r = args[1];
2693 620 lbm_stack_drop(&ctx->K, nargs+1);
2694 620 ctx->app_cont = true;
2695 } else {
2696
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 112 times.
 224 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2697 112 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2698 224 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2699 }
2700 620 }
2701
2702
2703 #define READING_EXPRESSION ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U)
2704 #define READING_PROGRAM ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U)
2705 #define READING_PROGRAM_INCREMENTALLY ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U)
2706
2707 664049 static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool program, bool incremental) {
2708
2/2
✓ Branch 0 taken 663993 times.
✓ Branch 1 taken 56 times.
 664049 if (nargs == 1) {
2709 663993 lbm_value chan = ENC_SYM_NIL;
2710
2/2
✓ Branch 0 taken 608477 times.
✓ Branch 1 taken 55516 times.
 663993 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY) {
2711 608477 char *str = lbm_dec_str(args[0]);
2712
2/2
✓ Branch 0 taken 608253 times.
✓ Branch 1 taken 224 times.
 608477 if (str) {
2713 #ifdef LBM_ALWAYS_GC
2714 gc();
2715 #endif
2716
2/2
✓ Branch 0 taken 5334 times.
✓ Branch 1 taken 602919 times.
 608253 if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
2717 5334 gc();
2718
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5334 times.
 5334 if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
2719 ✗ ERROR_CTX(ENC_SYM_MERROR);
2720 }
2721 }
2722 } else {
2723 224 ERROR_CTX(ENC_SYM_EERROR);
2724 }
2725
1/2
✓ Branch 0 taken 55516 times.
✗ Branch 1 not taken.
 55516 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL) {
2726 55516 chan = args[0];
2727 // Streaming transfers can freeze the evaluator if the stream is cut while
2728 // the reader is reading inside of an atomic block.
2729 // It is generally not advisable to read in an atomic block but now it is also
2730 // enforced in the case where it can cause problems.
2731
3/4
✓ Branch 0 taken 22036 times.
✓ Branch 1 taken 33480 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 22036 times.
 55516 if (lbm_channel_may_block(lbm_dec_channel(chan)) && is_atomic) {
2732 ✗ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
2733 ✗ is_atomic = false;
2734 ✗ ERROR_CTX(ENC_SYM_EERROR);
2735 }
2736 } else {
2737 ✗ ERROR_CTX(ENC_SYM_EERROR);
2738 }
2739 663769 lbm_value *sptr = get_stack_ptr(ctx, 2);
2740
2741 // If we are inside a reader, its settings are stored.
2742 663769 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2743 663769 sptr[1] = chan;
2744 663769 lbm_value *rptr = stack_reserve(ctx,2);
2745
3/4
✓ Branch 0 taken 596112 times.
✓ Branch 1 taken 67657 times.
✓ Branch 2 taken 596112 times.
✗ Branch 3 not taken.
 663769 if (!program && !incremental) {
2746 596112 rptr[0] = READING_EXPRESSION;
2747
3/4
✓ Branch 0 taken 67657 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 22828 times.
✓ Branch 3 taken 44829 times.
 67657 } else if (program && !incremental) {
2748 22828 rptr[0] = READING_PROGRAM;
2749
2/4
✓ Branch 0 taken 44829 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 44829 times.
✗ Branch 3 not taken.
 44829 } else if (program && incremental) {
2750 44829 rptr[0] = READING_PROGRAM_INCREMENTALLY;
2751 } // the last combo is illegal
2752 663769 rptr[1] = READ_DONE;
2753
2754 // Each reader starts in a fresh situation
2755 663769 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
2756 663769 ctx->r = ENC_SYM_NIL; // set r to a known state.
2757
2758
2/2
✓ Branch 0 taken 67657 times.
✓ Branch 1 taken 596112 times.
 663769 if (program) {
2759
2/2
✓ Branch 0 taken 44829 times.
✓ Branch 1 taken 22828 times.
 67657 if (incremental) {
2760 44829 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2761 44829 lbm_value *rptr1 = stack_reserve(ctx,3);
2762 44829 rptr1[0] = chan;
2763 44829 rptr1[1] = ctx->curr_env;
2764 44829 rptr1[2] = READ_EVAL_CONTINUE;
2765 } else {
2766 22828 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2767 22828 lbm_value *rptr1 = stack_reserve(ctx,4);
2768 22828 rptr1[0] = ENC_SYM_NIL;
2769 22828 rptr1[1] = ENC_SYM_NIL;
2770 22828 rptr1[2] = chan;
2771 22828 rptr1[3] = READ_APPEND_CONTINUE;
2772 }
2773 }
2774 663769 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2775 663769 rptr[0] = chan;
2776 663769 rptr[1] = lbm_enc_u(1);
2777 663769 rptr[2] = READ_NEXT_TOKEN;
2778 663769 ctx->app_cont = true;
2779 } else {
2780 56 lbm_set_error_reason((char*)lbm_error_str_num_args);
2781 56 ERROR_CTX(ENC_SYM_EERROR);
2782 }
2783 663769 }
2784
2785 22996 static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2786 22996 apply_read_base(args,nargs,ctx,true,false);
2787 22828 }
2788
2789 44829 static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2790 44829 apply_read_base(args,nargs,ctx,true,true);
2791 44829 }
2792
2793 596224 static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2794 596224 apply_read_base(args,nargs,ctx,false,false);
2795 596112 }
2796
2797 2259 static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2798
2799 2259 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE;
2800 2259 lbm_uint closure_pos = 0;
2801 2259 char *name = NULL;
2802 // allowed arguments:
2803 // (spawn opt-name opt-stack-size closure arg1 ... argN)
2804
2805
3/4
✓ Branch 0 taken 2259 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 1743 times.
✓ Branch 3 taken 516 times.
 4518 if (nargs >= 1 &&
2806 2259 lbm_is_closure(args[0])) {
2807 1743 closure_pos = 0;
2808
3/4
✓ Branch 0 taken 516 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 227 times.
✓ Branch 3 taken 289 times.
 1032 } else if (nargs >= 2 &&
2809
1/2
✓ Branch 0 taken 227 times.
✗ Branch 1 not taken.
 743 lbm_is_number(args[0]) &&
2810 227 lbm_is_closure(args[1])) {
2811 227 stack_size = lbm_dec_as_u32(args[0]);
2812 227 closure_pos = 1;
2813
3/4
✓ Branch 0 taken 289 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 285 times.
✓ Branch 3 taken 4 times.
 578 } else if (nargs >= 2 &&
2814
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 284 times.
 574 lbm_is_array_r(args[0]) &&
2815 285 lbm_is_closure(args[1])) {
2816 1 name = lbm_dec_str(args[0]);
2817 1 closure_pos = 1;
2818
4/4
✓ Branch 0 taken 286 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 284 times.
✓ Branch 3 taken 2 times.
 574 } else if (nargs >= 3 &&
2819
2/2
✓ Branch 0 taken 282 times.
✓ Branch 1 taken 2 times.
 570 lbm_is_array_r(args[0]) &&
2820
1/2
✓ Branch 0 taken 282 times.
✗ Branch 1 not taken.
 566 lbm_is_number(args[1]) &&
2821 282 lbm_is_closure(args[2])) {
2822 282 stack_size = lbm_dec_as_u32(args[1]);
2823 282 closure_pos = 2;
2824 282 name = lbm_dec_str(args[0]);
2825 } else {
2826
2/2
✓ Branch 0 taken 3 times.
✓ Branch 1 taken 3 times.
 6 if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP)
2827 3 ERROR_AT_CTX(ENC_SYM_TERROR,ENC_SYM_SPAWN_TRAP);
2828 else
2829 3 ERROR_AT_CTX(ENC_SYM_TERROR,ENC_SYM_SPAWN);
2830 }
2831
2832 lbm_value cl[3];
2833 2253 extract_n(get_cdr(args[closure_pos]), cl, 3);
2834 2253 lbm_value curr_param = cl[CLO_PARAMS];
2835 2253 lbm_value clo_env = cl[CLO_ENV];
2836 2253 lbm_uint i = closure_pos + 1;
2837
3/4
✓ Branch 0 taken 1571 times.
✓ Branch 1 taken 2253 times.
✓ Branch 2 taken 1571 times.
✗ Branch 3 not taken.
 3824 while (lbm_is_cons(curr_param) && i <= nargs) {
2838 1571 lbm_value entry = cons_with_gc(lbm_ref_cell(curr_param)->car, args[i], clo_env);
2839 1571 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL);
2840 1571 clo_env = aug_env;
2841 1571 curr_param = lbm_ref_cell(curr_param)->cdr;
2842 1571 i ++;
2843 }
2844
2845 2253 lbm_stack_drop(&ctx->K, nargs+1);
2846
2847 2253 lbm_value program = cons_with_gc(cl[CLO_BODY], ENC_SYM_NIL, clo_env);
2848
2849 2253 lbm_cid cid = lbm_create_ctx_parent(program,
2850 clo_env,
2851 stack_size,
2852 lbm_get_current_cid(),
2853 context_flags,
2854 name);
2855 2253 ctx->r = lbm_enc_i(cid);
2856 2253 ctx->app_cont = true;
2857
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 2197 times.
 2253 if (cid == -1) ERROR_CTX(ENC_SYM_MERROR); // Kill parent and signal out of memory.
2858 2197 }
2859
2860 1580 static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2861 1580 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING);
2862 1521 }
2863
2864 679 static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2865 679 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP);
2866 676 }
2867
2868 56909 static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2869
4/4
✓ Branch 0 taken 56907 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 56906 times.
✓ Branch 3 taken 1 times.
 113815 if (nargs == 1 && lbm_is_number(args[0])) {
2870 56906 lbm_uint ts = lbm_dec_as_u32(args[0]);
2871 56906 lbm_stack_drop(&ctx->K, nargs+1);
2872 56906 yield_ctx(ts);
2873 } else {
2874 3 lbm_set_error_reason((char*)lbm_error_str_no_number);
2875 3 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_YIELD);
2876 }
2877 56906 }
2878
2879 10084 static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2880
4/4
✓ Branch 0 taken 10082 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 10081 times.
✓ Branch 3 taken 1 times.
 20109 if (nargs == 1 && lbm_is_number(args[0])) {
2881 10081 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2882 10081 lbm_stack_drop(&ctx->K, nargs+1);
2883 10081 yield_ctx(ts);
2884 } else {
2885 3 lbm_set_error_reason((char*)lbm_error_str_no_number);
2886 3 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_SLEEP);
2887 }
2888 10025 }
2889
2890 116 static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2891
4/4
✓ Branch 0 taken 115 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 114 times.
✓ Branch 3 taken 1 times.
 230 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I) {
2892 114 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2893 114 lbm_value *sptr = get_stack_ptr(ctx, 2);
2894 114 sptr[0] = lbm_enc_i(cid);
2895 114 sptr[1] = WAIT;
2896 114 ctx->r = ENC_SYM_TRUE;
2897 114 ctx->app_cont = true;
2898 114 yield_ctx(50000);
2899 } else {
2900 2 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_WAIT);
2901 }
2902 114 }
2903
2904 /* (eval expr)
2905 (eval env expr) */
2906 763579 static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2907
2/2
✓ Branch 0 taken 763577 times.
✓ Branch 1 taken 2 times.
 763579 if ( nargs == 1) {
2908 763577 ctx->curr_exp = args[0];
2909
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 1 times.
 2 } else if (nargs == 2) {
2910 1 ctx->curr_exp = args[1];
2911 1 ctx->curr_env = args[0];
2912 } else {
2913 1 lbm_set_error_reason((char*)lbm_error_str_num_args);
2914 1 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_EVAL);
2915 }
2916 763578 lbm_stack_drop(&ctx->K, nargs+1);
2917 763578 }
2918
2919 23277 static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2920
2/2
✓ Branch 0 taken 23276 times.
✓ Branch 1 taken 1 times.
 23277 if (nargs == 1) {
2921 23276 lbm_value prg = args[0]; // No check that this is a program.
2922 lbm_value app_cont;
2923 lbm_value app_cont_prg;
2924 lbm_value new_prg;
2925 lbm_value prg_copy;
2926
2927 23276 int len = -1;
2928
3/4
✓ Branch 0 taken 4 times.
✓ Branch 1 taken 23272 times.
✓ Branch 2 taken 4 times.
✗ Branch 3 not taken.
 23276 WITH_GC(prg_copy, lbm_list_copy(&len, prg));
2929 23272 lbm_stack_drop(&ctx->K, nargs+1);
2930 // There is always a continuation (DONE).
2931 // If ctx->program is nil, the stack should contain DONE.
2932 // after adding an intermediate done for prg, stack becomes DONE, DONE.
2933 23272 app_cont = cons_with_gc(ENC_SYM_APP_CONT, ENC_SYM_NIL, prg_copy);
2934 23272 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL, prg_copy);
2935 23272 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2936 23272 new_prg = lbm_list_append(prg_copy, new_prg);
2937 // new_prg is guaranteed to be a cons cell or nil
2938 // even if the eval-program application is syntactically broken.
2939 23272 stack_reserve(ctx, 1)[0] = DONE;
2940 23272 ctx->program = get_cdr(new_prg);
2941 23272 ctx->curr_exp = get_car(new_prg);
2942 } else {
2943 1 lbm_set_error_reason((char*)lbm_error_str_num_args);
2944 1 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_EVAL_PROGRAM);
2945 }
2946 23272 }
2947
2948 12269 static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2949
2/2
✓ Branch 0 taken 12268 times.
✓ Branch 1 taken 1 times.
 12269 if (nargs == 2) {
2950
2/2
✓ Branch 0 taken 12267 times.
✓ Branch 1 taken 1 times.
 12268 if (lbm_type_of(args[0]) == LBM_TYPE_I) {
2951 12267 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2952 12267 lbm_value msg = args[1];
2953 12267 bool r = lbm_find_receiver_and_send(cid, msg);
2954 /* return the status */
2955 12267 lbm_stack_drop(&ctx->K, nargs+1);
2956
1/2
✓ Branch 0 taken 12267 times.
✗ Branch 1 not taken.
 12267 ctx->r = r ? ENC_SYM_TRUE : ENC_SYM_NIL;
2957 12267 ctx->app_cont = true;
2958 } else {
2959 1 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_SEND);
2960 }
2961 } else {
2962 1 lbm_set_error_reason((char*)lbm_error_str_num_args);
2963 1 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_SEND);
2964 }
2965 12267 }
2966
2967 2 static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2968 2 lbm_value ok_val = ENC_SYM_TRUE;
2969
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 1 times.
 2 if (nargs >= 1) {
2970 1 ok_val = args[0];
2971 }
2972 2 is_atomic = false;
2973 2 ctx->r = ok_val;
2974 2 ok_ctx();
2975 2 }
2976
2977 60 static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2978 (void) ctx;
2979 60 lbm_value err_val = ENC_SYM_EERROR;
2980
2/2
✓ Branch 0 taken 59 times.
✓ Branch 1 taken 1 times.
 60 if (nargs >= 1) {
2981 59 err_val = args[0];
2982 }
2983 60 is_atomic = false;
2984 60 ERROR_AT_CTX(err_val, ENC_SYM_EXIT_ERROR);
2985 }
2986
2987 // ////////////////////////////////////////////////////////////
2988 // Map takes a function f and a list ls as arguments.
2989 // The function f is applied to each element of ls.
2990 //
2991 // Normally when applying a function to an argument this happens:
2992 // 1. the function is evaluated
2993 // 2. the argument is evaluated
2994 // 3. the result of evaluating the function is applied to the result of evaluating
2995 // the argument.
2996 //
2997 // When doing (map f arg-list) I assume one means to apply f to each element of arg-list
2998 // exactly as those elements are. That is, no evaluation of the argument.
2999 // The implementation of map below makes sure that the elements of the arg-list are not
3000 // evaluated by wrapping them each in a `quote`.
3001 //
3002 // Map creates a structure in memory that looks like this (f (quote dummy . nil) . nil).
3003 // Then, for each element from arg-list (example a1 ... aN) the object
3004 // (f (quote aM . nil) . nil) is created by substituting dummy for an element of the list.
3005 // after this substitution the evaluator is fired up to evaluate the entire (f (quote aM . nil) . nil)
3006 // structure resulting in an element for the result list.
3007 //
3008 // Here comes the fun part, if you (map quote arg-list), then the object
3009 // (quote (quote aM . nil) . nil) is created and evaluated. Now note that quote just gives back
3010 // exactly what you give to it when evaluated.
3011 // So (quote (quote aM . nil) . nil) gives you as result (quote aM . nil) and now also note that
3012 // this is a list, and a list is really just an address on the heap!
3013 // This leads to the very fun behavior that:
3014 //
3015 // # (map quote '(1 2 3 4))
3016 // > ((quote 4) (quote 4) (quote 4) (quote 4))
3017 //
3018 // A potential fix is to instead of creating the object (f (quote aM . nil) . nil)
3019 // we create the object (f var) for some unique var and then extend the environment
3020 // for each round of evaluation with a binding var => aM.
3021
3022 // (map f arg-list)
3023 1808 static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3024
4/4
✓ Branch 0 taken 1807 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 1581 times.
✓ Branch 3 taken 226 times.
 1808 if (nargs == 2 && lbm_is_cons(args[1])) {
3025 1581 lbm_value *sptr = get_stack_ptr(ctx, 3);
3026
3027 1581 lbm_value f = args[0];
3028 1581 lbm_cons_t *args1_cell = lbm_ref_cell(args[1]);
3029 1581 lbm_value h = args1_cell->car;
3030 1581 lbm_value t = args1_cell->cdr;
3031
3032 lbm_value appli_1;
3033 lbm_value appli;
3034
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 1581 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 1581 WITH_GC(appli_1, lbm_heap_allocate_list(2));
3035
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 1581 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 1581 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1);
3036
3037 1581 lbm_value appli_0 = get_cdr(appli_1);
3038
3039 // appli is a list of length 2 here, so a cons
3040 1581 lbm_cons_t *cell = lbm_ref_cell(appli_0);
3041 1581 cell->car = h;
3042 1581 cell->cdr = ENC_SYM_NIL;
3043 //lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL);
3044 1581 cell = lbm_ref_cell(appli_1);
3045 1581 cell->car = ENC_SYM_QUOTE;
3046 //lbm_set_car(appli_1, ENC_SYM_QUOTE);
3047 1581 lbm_cons_t *appli_cell = lbm_ref_cell(appli);
3048 1581 cell = lbm_ref_cell(appli_cell->cdr);
3049 1581 cell->car = appli_1;
3050 1581 cell->cdr = ENC_SYM_NIL;
3051 //lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL);
3052 1581 appli_cell->car = f;
3053 //lbm_set_car(appli, f);
3054
3055 1581 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, appli);
3056 1581 sptr[0] = t; // reuse stack space
3057 1581 sptr[1] = ctx->curr_env;
3058 1581 sptr[2] = elt;
3059 1581 lbm_value *rptr = stack_reserve(ctx,4);
3060 1581 rptr[0] = elt;
3061 1581 rptr[1] = appli;
3062 1581 rptr[2] = appli_0;
3063 1581 rptr[3] = MAP;
3064 1581 ctx->curr_exp = appli;
3065
4/4
✓ Branch 0 taken 226 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 224 times.
✓ Branch 3 taken 2 times.
 227 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
3066 224 lbm_stack_drop(&ctx->K, 3);
3067 224 ctx->r = ENC_SYM_NIL;
3068 224 ctx->app_cont = true;
3069 } else {
3070 3 lbm_set_error_reason((char*)lbm_error_str_num_args);
3071 3 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_MAP);
3072 }
3073 1805 }
3074
3075 285 static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3076
4/4
✓ Branch 0 taken 284 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 281 times.
✓ Branch 3 taken 3 times.
 285 if (nargs == 1 && lbm_is_list(args[0])) {
3077 281 lbm_value curr = args[0];
3078
3079 281 lbm_value new_list = ENC_SYM_NIL;
3080
2/2
✓ Branch 0 taken 6387 times.
✓ Branch 1 taken 281 times.
 6668 while (lbm_is_cons(curr)) {
3081 6387 lbm_cons_t *curr_cell = lbm_ref_cell(curr); // known cons.
3082 6387 lbm_value tmp = cons_with_gc(curr_cell->car, new_list, ENC_SYM_NIL);
3083 6387 new_list = tmp;
3084 6387 curr = curr_cell->cdr;
3085 }
3086 281 lbm_stack_drop(&ctx->K, 2);
3087 281 ctx->r = new_list;
3088 281 ctx->app_cont = true;
3089 } else {
3090 4 lbm_set_error_reason("Reverse requires a list argument");
3091 4 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_REVERSE);
3092 }
3093 281 }
3094
3095 69244 static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3096
2/2
✓ Branch 0 taken 69188 times.
✓ Branch 1 taken 56 times.
 69244 if (nargs == 1) {
3097 #ifdef LBM_ALWAYS_GC
3098 gc();
3099 #endif
3100 69188 lbm_value v = flatten_value(args[0]);
3101
2/2
✓ Branch 0 taken 32 times.
✓ Branch 1 taken 69156 times.
 69188 if ( v == ENC_SYM_MERROR) {
3102 32 gc();
3103 32 v = flatten_value(args[0]);
3104 }
3105
3106
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 69132 times.
 69188 if (lbm_is_symbol(v)) {
3107 56 ERROR_AT_CTX(v, ENC_SYM_FLATTEN);
3108 } else {
3109 69132 lbm_stack_drop(&ctx->K, 2);
3110 69132 ctx->r = v;
3111 69132 ctx->app_cont = true;
3112 }
3113 69132 return;
3114 }
3115 56 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_FLATTEN);
3116 }
3117
3118 69080 static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3119 lbm_array_header_t *array;
3120
4/4
✓ Branch 0 taken 69078 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 69076 times.
✓ Branch 3 taken 2 times.
 69080 if(nargs == 1 && (array = lbm_dec_array_r(args[0]))) {
3121 lbm_flat_value_t fv;
3122 69076 fv.buf = (uint8_t*)array->data;
3123 69076 fv.buf_size = array->size;
3124 69076 fv.buf_pos = 0;
3125
3126 lbm_value res;
3127
3128 69076 ctx->r = ENC_SYM_NIL;
3129
1/2
✓ Branch 0 taken 69076 times.
✗ Branch 1 not taken.
 69076 if (lbm_unflatten_value(&fv, &res)) {
3130 69076 ctx->r = res;
3131 }
3132 69076 lbm_stack_drop(&ctx->K, 2);
3133 69076 ctx->app_cont = true;
3134 69076 return;
3135 }
3136 4 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_UNFLATTEN);
3137 }
3138
3139 170 static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3140
3/4
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 168 times.
✗ Branch 3 not taken.
 170 if (nargs == 2 && lbm_is_number(args[0])) {
3141 168 lbm_cid cid = lbm_dec_as_i32(args[0]);
3142
3143
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 168 times.
 168 if (ctx->id == cid) {
3144 ✗ ctx->r = args[1];
3145 ✗ finish_ctx();
3146 ✗ return;
3147 }
3148 168 mutex_lock(&qmutex);
3149 168 eval_context_t *found = NULL;
3150 168 found = lookup_ctx_nm(&blocked, cid);
3151
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 168 times.
 168 if (found)
3152 ✗ drop_ctx_nm(&blocked, found);
3153 else
3154 168 found = lookup_ctx_nm(&queue, cid);
3155
2/2
✓ Branch 0 taken 167 times.
✓ Branch 1 taken 1 times.
 168 if (found)
3156 167 drop_ctx_nm(&queue, found);
3157
3158
2/2
✓ Branch 0 taken 167 times.
✓ Branch 1 taken 1 times.
 168 if (found) {
3159 167 found->K.data[found->K.sp - 1] = KILL;
3160 167 found->r = args[1];
3161 167 found->app_cont = true;
3162 167 found->state = LBM_THREAD_STATE_READY;
3163 167 enqueue_ctx_nm(&queue,found);
3164 167 ctx->r = ENC_SYM_TRUE;
3165 } else {
3166 1 ctx->r = ENC_SYM_NIL;
3167 }
3168 168 lbm_stack_drop(&ctx->K, 3);
3169 168 ctx->app_cont = true;
3170 168 mutex_unlock(&qmutex);
3171 168 return;
3172 }
3173 2 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_KILL);
3174 }
3175
3176 565678 static lbm_value cmp_to_clo(lbm_value cmp) {
3177 lbm_value closure;
3178
3/4
✓ Branch 0 taken 600 times.
✓ Branch 1 taken 565078 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 600 times.
 565678 WITH_GC(closure, lbm_heap_allocate_list(4));
3179 565678 lbm_set_car(closure, ENC_SYM_CLOSURE);
3180 565678 lbm_value cl1 = lbm_cdr(closure);
3181 lbm_value par;
3182
3/4
✓ Branch 0 taken 1152 times.
✓ Branch 1 taken 564526 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 1152 times.
 565678 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure);
3183 565678 lbm_set_car(cl1, par);
3184 565678 lbm_value cl2 = lbm_cdr(cl1);
3185 lbm_value body;
3186
3/4
✓ Branch 0 taken 7268 times.
✓ Branch 1 taken 558410 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 7268 times.
 565678 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, cmp, symbol_x, symbol_y), closure);
3187 565678 lbm_set_car(cl2, body);
3188 565678 lbm_value cl3 = lbm_cdr(cl2);
3189 565678 lbm_set_car(cl3, ENC_SYM_NIL);
3190 565678 return closure;
3191 }
3192
3193 // (merge comparator list1 list2)
3194 866 static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3195
6/6
✓ Branch 0 taken 862 times.
✓ Branch 1 taken 4 times.
✓ Branch 2 taken 856 times.
✓ Branch 3 taken 6 times.
✓ Branch 4 taken 851 times.
✓ Branch 5 taken 5 times.
 866 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
3196
3197
2/2
✓ Branch 0 taken 65 times.
✓ Branch 1 taken 786 times.
 851 if (!lbm_is_closure(args[0])) {
3198 65 args[0] = cmp_to_clo(args[0]);
3199 }
3200
3201 // Copy input lists for functional behaviour at top-level
3202 // merge itself is in-place in the copied lists.
3203 lbm_value a;
3204 lbm_value b;
3205 851 int len_a = -1;
3206 851 int len_b = -1;
3207
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 851 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 851 WITH_GC(a, lbm_list_copy(&len_a, args[1]));
3208
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 851 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 851 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a);
3209
3210
2/2
✓ Branch 0 taken 114 times.
✓ Branch 1 taken 737 times.
 851 if (len_a == 0) {
3211 114 ctx->r = b;
3212 114 lbm_stack_drop(&ctx->K, 4);
3213 114 ctx->app_cont = true;
3214 851 return;
3215 }
3216
2/2
✓ Branch 0 taken 113 times.
✓ Branch 1 taken 624 times.
 737 if (len_b == 0) {
3217 113 ctx->r = a;
3218 113 lbm_stack_drop(&ctx->K, 4);
3219 113 ctx->app_cont = true;
3220 113 return;
3221 }
3222
3223 624 args[1] = a; // keep safe by replacing the original on stack.
3224 624 args[2] = b;
3225
3226 lbm_value cl[3]; // Comparator closure
3227 624 extract_n(lbm_cdr(args[0]), cl, 3);
3228 624 lbm_value cmp_env = cl[CLO_ENV];
3229 624 lbm_uint len = lbm_list_length(cl[CLO_PARAMS]);
3230
1/2
✓ Branch 0 taken 624 times.
✗ Branch 1 not taken.
 624 if (len == 2) {
3231 624 lbm_value a_1 = a;
3232 624 lbm_value b_1 = b;
3233 624 lbm_value a_rest = lbm_cdr(a);
3234 624 lbm_value b_rest = lbm_cdr(b);
3235 624 lbm_value par1 = get_car(cl[CLO_PARAMS]);
3236 624 lbm_value par2 = get_cadr(cl[CLO_PARAMS]);
3237 lbm_value new_env0;
3238 lbm_value new_env;
3239
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 624 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 624 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)));
3240
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 624 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 624 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0);
3241 624 cmp_env = new_env;
3242 624 lbm_set_cdr(a_1, b_1);
3243 624 lbm_set_cdr(b_1, ENC_SYM_NIL);
3244 624 lbm_value cmp = cl[CLO_BODY];
3245
3246 624 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
3247 624 lbm_uint *sptr = stack_reserve(ctx, 10);
3248 624 sptr[0] = ENC_SYM_NIL; // head of merged list
3249 624 sptr[1] = ENC_SYM_NIL; // last of merged list
3250 624 sptr[2] = a_1;
3251 624 sptr[3] = a_rest;
3252 624 sptr[4] = b_rest;
3253 624 sptr[5] = cmp;
3254 624 sptr[6] = cmp_env;
3255 624 sptr[7] = par1;
3256 624 sptr[8] = par2;
3257 624 sptr[9] = MERGE_REST;
3258 624 ctx->curr_exp = cl[CLO_BODY];
3259 624 ctx->curr_env = cmp_env;
3260 624 return;
3261 }
3262 }
3263 15 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_MERGE);
3264 }
3265
3266 // (sort comparator list)
3267 566295 static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3268
4/4
✓ Branch 0 taken 566293 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 566287 times.
✓ Branch 3 taken 6 times.
 566295 if (nargs == 2 && lbm_is_list(args[1])) {
3269
3270
2/2
✓ Branch 0 taken 565613 times.
✓ Branch 1 taken 674 times.
 566287 if (!lbm_is_closure(args[0])) {
3271 565613 args[0] = cmp_to_clo(args[0]);
3272 }
3273
3274 566287 int len = -1;
3275 lbm_value list_copy;
3276
3/4
✓ Branch 0 taken 276 times.
✓ Branch 1 taken 566011 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 276 times.
 566287 WITH_GC(list_copy, lbm_list_copy(&len, args[1]));
3277
2/2
✓ Branch 0 taken 58 times.
✓ Branch 1 taken 566229 times.
 566287 if (len <= 1) {
3278 58 lbm_stack_drop(&ctx->K, 3);
3279 58 ctx->r = list_copy;
3280 58 ctx->app_cont = true;
3281 566287 return;
3282 }
3283
3284 566229 args[1] = list_copy; // Keep safe, original replaced on stack.
3285
3286 // Take the headmost 2, 1-element sublists.
3287 566229 lbm_value a = list_copy;
3288 566229 lbm_value b = lbm_cdr(a);
3289 566229 lbm_value rest = lbm_cdr(b);
3290 // Do not terminate b. keep rest of list safe from GC in the following
3291 // closure extraction.
3292 //lbm_set_cdr(a, b); // This is void
3293
3294 lbm_value cl[3]; // Comparator closure
3295 566229 extract_n(lbm_cdr(args[0]), cl, 3);
3296 566229 lbm_value cmp_env = cl[CLO_ENV];
3297
3298 566229 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS]);
3299
1/2
✓ Branch 0 taken 566229 times.
✗ Branch 1 not taken.
 566229 if (cl_len == 2) {
3300 566229 lbm_value par1 = get_car(cl[CLO_PARAMS]);
3301 566229 lbm_value par2 = get_cadr(cl[CLO_PARAMS]);
3302 lbm_value new_env0;
3303 lbm_value new_env;
3304
3/4
✓ Branch 0 taken 4 times.
✓ Branch 1 taken 566225 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 4 times.
 566229 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
3305
3/4
✓ Branch 0 taken 32 times.
✓ Branch 1 taken 566197 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 32 times.
 566229 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
3306 566229 cmp_env = new_env;
3307
3308 566229 lbm_value cmp = cl[CLO_BODY];
3309
3310 // Terminate the comparator argument list.
3311 566229 lbm_set_cdr(b, ENC_SYM_NIL);
3312
3313 566229 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
3314 566229 lbm_uint *sptr = stack_reserve(ctx, 20);
3315 566229 sptr[0] = cmp;
3316 566229 sptr[1] = cmp_env;
3317 566229 sptr[2] = par1;
3318 566229 sptr[3] = par2;
3319 566229 sptr[4] = ENC_SYM_NIL; // head of merged accumulation of sublists
3320 566229 sptr[5] = ENC_SYM_NIL; // last of merged accumulation of sublists
3321 566229 sptr[6] = rest;
3322 566229 sptr[7] = lbm_enc_i(1);
3323 566229 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
3324 566229 sptr[9] = MERGE_LAYER;
3325 566229 sptr[10] = ENC_SYM_NIL; // head of merged sublist
3326 566229 sptr[11] = ENC_SYM_NIL; // last of merged sublist
3327 566229 sptr[12] = a;
3328 566229 sptr[13] = ENC_SYM_NIL; // no a_rest, 1 element lists in layer 1.
3329 566229 sptr[14] = ENC_SYM_NIL; // no b_rest, 1 element lists in layer 1.
3330 566229 sptr[15] = cmp;
3331 566229 sptr[16] = cmp_env;
3332 566229 sptr[17] = par1;
3333 566229 sptr[18] = par2;
3334 566229 sptr[19] = MERGE_REST;
3335 566229 ctx->curr_exp = cmp;
3336 566229 ctx->curr_env = cmp_env;
3337 566229 return;
3338 }
3339 }
3340 8 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_SORT);
3341 }
3342
3343 1232896 static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3344 1232896 lbm_value res = ENC_SYM_NIL; //TODO: lbm_env_lookup does not set res in all cases.
3345
2/2
✓ Branch 0 taken 1232728 times.
✓ Branch 1 taken 168 times.
 1232896 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS, ctx->curr_env)) {
3346
3/4
✓ Branch 0 taken 112280 times.
✓ Branch 1 taken 1120448 times.
✓ Branch 2 taken 112280 times.
✗ Branch 3 not taken.
 1232728 if (nargs == 1 && lbm_is_number(args[0])) {
3347 112280 int32_t ix = lbm_dec_as_i32(args[0]);
3348 112280 res = lbm_index_list(res, ix);
3349 }
3350 1232728 ctx->r = res;
3351 } else {
3352 168 ctx->r = ENC_SYM_NIL;
3353 }
3354 1232896 lbm_stack_drop(&ctx->K, nargs+1);
3355 1232896 ctx->app_cont = true;
3356 1232896 }
3357
3358 /* (rotate list-expr dist/dir-expr) */
3359 172 static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3360
6/6
✓ Branch 0 taken 170 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 169 times.
✓ Branch 3 taken 1 times.
✓ Branch 4 taken 168 times.
✓ Branch 5 taken 1 times.
 172 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
3361 168 int len = -1;
3362 lbm_value ls;
3363
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 168 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 168 WITH_GC(ls, lbm_list_copy(&len, args[0]));
3364 168 int dist = lbm_dec_as_i32(args[1]);
3365
3/4
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 56 times.
✓ Branch 2 taken 112 times.
✗ Branch 3 not taken.
 168 if (len > 0 && dist != 0) {
3366 112 int d = dist;
3367
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 56 times.
 112 if (dist > 0) {
3368 56 ls = lbm_list_destructive_reverse(ls);
3369 } else {
3370 56 d = -dist;
3371 }
3372
3373 112 lbm_value start = ls;
3374 112 lbm_value end = ENC_SYM_NIL;
3375 112 lbm_value curr = start;
3376
2/2
✓ Branch 0 taken 504 times.
✓ Branch 1 taken 112 times.
 616 while (lbm_is_cons(curr)) {
3377 504 end = curr;
3378 504 curr = lbm_ref_cell(curr)->cdr;
3379 }
3380
3381
2/2
✓ Branch 0 taken 224 times.
✓ Branch 1 taken 112 times.
 336 for (int i = 0; i < d; i ++) {
3382 224 lbm_value a = start;
3383 224 start = lbm_cdr(start);
3384 224 lbm_set_cdr(a, ENC_SYM_NIL);
3385 224 lbm_set_cdr(end, a);
3386 224 end = a;
3387 }
3388 112 ls = start;
3389
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 56 times.
 112 if (dist > 0) {
3390 56 ls = lbm_list_destructive_reverse(ls);
3391 }
3392 }
3393 168 lbm_stack_drop(&ctx->K, nargs+1);
3394 168 ctx->app_cont = true;
3395 168 ctx->r = ls;
3396 168 return;
3397 }
3398 4 ERROR_CTX(ENC_SYM_EERROR);
3399 }
3400
3401 /***************************************************/
3402 /* Application lookup table */
3403
3404 typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
3405 static const apply_fun fun_table[] =
3406 {
3407 apply_setvar,
3408 apply_read,
3409 apply_read_program,
3410 apply_read_eval_program,
3411 apply_spawn,
3412 apply_spawn_trap,
3413 apply_yield,
3414 apply_wait,
3415 apply_eval,
3416 apply_eval_program,
3417 apply_send,
3418 apply_ok,
3419 apply_error,
3420 apply_map,
3421 apply_reverse,
3422 apply_flatten,
3423 apply_unflatten,
3424 apply_kill,
3425 apply_sleep,
3426 apply_merge,
3427 apply_sort,
3428 apply_rest_args,
3429 apply_rotate,
3430 apply_apply,
3431 };
3432
3433 /***************************************************/
3434 /* Application of function that takes arguments */
3435 /* passed over the stack. */
3436
3437 463341028 static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
3438 /* If arriving here, we know that the fun is a symbol.
3439 * and can be a built in operation or an extension.
3440 */
3441 463341028 lbm_value fun = fun_args[0];
3442
3443 463341028 lbm_uint fun_val = lbm_dec_sym(fun);
3444 463341028 lbm_uint fun_kind = SYMBOL_KIND(fun_val);
3445
3446
4/4
✓ Branch 0 taken 604758 times.
✓ Branch 1 taken 448059927 times.
✓ Branch 2 taken 14676342 times.
✓ Branch 3 taken 1 times.
 463341028 switch (fun_kind) {
3447 604758 case SYMBOL_KIND_EXTENSION: {
3448 604758 extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr;
3449
3450 lbm_value ext_res;
3451
4/4
✓ Branch 0 taken 350 times.
✓ Branch 1 taken 604407 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 349 times.
 604758 WITH_GC(ext_res, f(&fun_args[1], arg_count));
3452
2/2
✓ Branch 0 taken 5648 times.
✓ Branch 1 taken 599108 times.
 604756 if (lbm_is_error(ext_res)) { //Error other than merror
3453 5648 ERROR_AT_CTX(ext_res, fun);
3454 }
3455 599108 lbm_stack_drop(&ctx->K, arg_count + 1);
3456
3457 599108 ctx->app_cont = true;
3458 599108 ctx->r = ext_res;
3459
3460
2/2
✓ Branch 0 taken 224 times.
✓ Branch 1 taken 598884 times.
 599108 if (blocking_extension) {
3461
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 224 times.
 224 if (is_atomic) {
3462 // Check atomic_error explicitly so that the mutex
3463 // can be released if there is an error.
3464 ✗ blocking_extension = false;
3465 ✗ mutex_unlock(&blocking_extension_mutex);
3466 ✗ atomic_error();
3467 }
3468 224 blocking_extension = false;
3469
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 224 times.
 224 if (blocking_extension_timeout) {
3470 ✗ blocking_extension_timeout = false;
3471 ✗ block_current_ctx(LBM_THREAD_STATE_TIMEOUT, blocking_extension_timeout_us,true);
3472 } else {
3473 224 block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0,true);
3474 }
3475 224 mutex_unlock(&blocking_extension_mutex);
3476 }
3477 599108 } break;
3478 448059927 case SYMBOL_KIND_FUNDAMENTAL:
3479 448059927 call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx);
3480 448050261 break;
3481 14676342 case SYMBOL_KIND_APPFUN:
3482 14676342 fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
3483 14675489 break;
3484 1 default:
3485 // Symbols that are "special" but not in the way caught above
3486 // ends up here.
3487 1 lbm_set_error_reason("Symbol does not represent a function");
3488 1 ERROR_AT_CTX(ENC_SYM_EERROR,fun_args[0]);
3489 break;
3490 }
3491 463324858 }
3492
3493 // cont_cloure_application_args
3494 //
3495 // s[sp-5] = environment to evaluate the args in.
3496 // s[sp-4] = body
3497 // s[sp-3] = closure environment
3498 // s[sp-2] = parameter list
3499 // s[sp-1] = args list
3500 //
3501 // ctx->r = evaluated argument.
3502 109335616 static void cont_closure_application_args(eval_context_t *ctx) {
3503 109335616 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3504
3505 109335616 lbm_value arg_env = (lbm_value)sptr[0];
3506 109335616 lbm_value exp = (lbm_value)sptr[1];
3507 109335616 lbm_value clo_env = (lbm_value)sptr[2];
3508 109335616 lbm_value params = (lbm_value)sptr[3];
3509 109335616 lbm_value args = (lbm_value)sptr[4];
3510
3511 lbm_value car_params, cdr_params;
3512 109335616 get_car_and_cdr(params, &car_params, &cdr_params);
3513
3514 109335608 bool a_nil = lbm_is_symbol_nil(args);
3515 109335608 bool p_nil = lbm_is_symbol_nil(cdr_params);
3516
3517 109335608 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
3518
3519
4/4
✓ Branch 0 taken 54236260 times.
✓ Branch 1 taken 55099292 times.
✓ Branch 2 taken 54179794 times.
✓ Branch 3 taken 56466 times.
 109335552 if (!a_nil && !p_nil) {
3520 lbm_value car_args, cdr_args;
3521 54179794 get_car_and_cdr(args, &car_args, &cdr_args);
3522 54179794 sptr[2] = binder;
3523 54179794 sptr[3] = cdr_params;
3524 54179794 sptr[4] = cdr_args;
3525 54179794 stack_reserve(ctx,1)[0] = CLOSURE_ARGS;
3526 54179794 ctx->curr_exp = car_args;
3527 54179794 ctx->curr_env = arg_env;
3528
4/4
✓ Branch 0 taken 55099292 times.
✓ Branch 1 taken 56466 times.
✓ Branch 2 taken 55099290 times.
✓ Branch 3 taken 2 times.
 55155758 } else if (a_nil && p_nil) {
3529 // Arguments and parameters match up in number
3530 55099290 lbm_stack_drop(&ctx->K, 5);
3531 55099290 ctx->curr_env = binder;
3532 55099290 ctx->curr_exp = exp;
3533
2/2
✓ Branch 0 taken 56466 times.
✓ Branch 1 taken 2 times.
 56468 } else if (p_nil) {
3534 56466 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, binder);
3535 56466 sptr[2] = rest_binder;
3536 56466 sptr[3] = get_cdr(args);
3537 56466 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3538 56466 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3539 56466 ctx->curr_exp = get_car(args);
3540 56466 ctx->curr_env = arg_env;
3541 } else {
3542 2 lbm_set_error_reason((char*)lbm_error_str_num_args);
3543 2 ERROR_CTX(ENC_SYM_EERROR);
3544 }
3545 109335550 }
3546
3547 // cont_closure_args_rest
3548 //
3549 // s[sp-5] = environment to evaluate args in
3550 // s[sp-4] = body
3551 // s[sp-3] = closure environment
3552 // s[sp-2] = argument list
3553 // s[sp-1] = last cell in rest-args list so far.
3554 5994034 static void cont_closure_args_rest(eval_context_t *ctx) {
3555 5994034 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3556 5994034 lbm_value arg_env = (lbm_value)sptr[0];
3557 5994034 lbm_value exp = (lbm_value)sptr[1];
3558 5994034 lbm_value clo_env = (lbm_value)sptr[2];
3559 5994034 lbm_value args = (lbm_value)sptr[3];
3560 5994034 lbm_value last = (lbm_value)sptr[4];
3561 5994034 lbm_cons_t* heap = lbm_heap_state.heap;
3562 #ifdef LBM_ALWAYS_GC
3563 gc();
3564 #endif
3565 5994034 lbm_value binding = lbm_heap_state.freelist;
3566
2/2
✓ Branch 0 taken 870 times.
✓ Branch 1 taken 5993164 times.
 5994034 if (binding == ENC_SYM_NIL) {
3567 870 gc();
3568 870 binding = lbm_heap_state.freelist;
3569
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 870 times.
 870 if (binding == ENC_SYM_NIL) ERROR_CTX(ENC_SYM_MERROR);
3570 }
3571 5994034 lbm_uint binding_ix = lbm_dec_ptr(binding);
3572 5994034 lbm_heap_state.freelist = heap[binding_ix].cdr;
3573 5994034 lbm_heap_state.num_alloc += 1;
3574 5994034 heap[binding_ix].car = ctx->r;
3575 5994034 heap[binding_ix].cdr = ENC_SYM_NIL;
3576
3577 5994034 lbm_set_cdr(last, binding);
3578 5994034 sptr[4] = binding;
3579
3580
2/2
✓ Branch 0 taken 616522 times.
✓ Branch 1 taken 5377512 times.
 5994034 if (args == ENC_SYM_NIL) {
3581 616522 lbm_stack_drop(&ctx->K, 5);
3582 616522 ctx->curr_env = clo_env;
3583 616522 ctx->curr_exp = exp;
3584 } else {
3585 5377512 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3586 5377512 sptr[3] = get_cdr(args);
3587 5377512 ctx->curr_exp = get_car(args);
3588 5377512 ctx->curr_env = arg_env;
3589 }
3590 5994034 }
3591
3592
3593 // cont_application_args
3594 // Functions that take arguments passed on the stack, fundamental and apply_f.
3595 //
3596 // s[sp-3] = environment to evaluate arguments in.
3597 // s[sp-2] = argument list (user input syntax)
3598 // s[sp-1] = count
3599 //
3600 // ctx->r = function
3601 1458399885 static void cont_application_args(eval_context_t *ctx) {
3602 1458399885 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3603
3604 1458399886 lbm_value env = sptr[0];
3605 1458399886 lbm_value rest = sptr[1];
3606 1458399886 lbm_value count = sptr[2];
3607
3608 1458399886 ctx->curr_env = env;
3609 1458399886 sptr[0] = ctx->r; // Function 1st then Arguments
3610
2/2
✓ Branch 0 taken 996178974 times.
✓ Branch 1 taken 462220913 times.
 1458399886 if (lbm_is_cons(rest)) { // rest is user input syntax, expensive check needed
3611 996178974 lbm_cons_t *cell = lbm_ref_cell(rest);
3612 996178974 sptr[1] = env;
3613 996178974 sptr[2] = cell->cdr;
3614 996178974 lbm_value *rptr = stack_reserve(ctx,2);
3615 996178973 rptr[0] = count + (1 << LBM_VAL_SHIFT); // arithmetic on encoded value
3616 996178973 rptr[1] = APPLICATION_ARGS;
3617 996178973 ctx->curr_exp = cell->car;
3618 } else { // tollerant for incorrect list termination.
3619 // No more arguments
3620 462220913 lbm_stack_drop(&ctx->K, 2);
3621 462220913 lbm_uint nargs = lbm_dec_u(count);
3622 462220913 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3623 462220913 application(ctx,args, nargs);
3624 }
3625 1458383715 }
3626
3627 // cont_and
3628 //
3629 // s[sp-2] = environment to evaluate args in.
3630 // s[sp-1] = rest of argument list (user input syntax)
3631 108806930 static void cont_and(eval_context_t *ctx) {
3632 108806930 lbm_value rest = ctx->K.data[--ctx->K.sp];
3633 108806930 lbm_value env = ctx->K.data[--ctx->K.sp];
3634
2/2
✓ Branch 0 taken 560195 times.
✓ Branch 1 taken 108246735 times.
 108806930 if (lbm_is_symbol_nil(ctx->r)) {
3635 560195 ctx->app_cont = true;
3636
2/2
✓ Branch 0 taken 76826833 times.
✓ Branch 1 taken 31419902 times.
 108246735 } else if (lbm_is_cons(rest)) {
3637 76826833 lbm_cons_t *r_cell = lbm_ref_cell(rest);
3638 76826833 lbm_value *sptr = stack_reserve(ctx, 3);
3639 76826833 sptr[0] = env;
3640 76826833 sptr[1] = r_cell->cdr;
3641 76826833 sptr[2] = AND;
3642 76826833 ctx->curr_env = env;
3643 76826833 ctx->curr_exp = r_cell->car;
3644 } else {
3645 31419902 ctx->app_cont = true;
3646 }
3647 108806930 }
3648
3649 // cont_or
3650 //
3651 // s[sp-2] = environment to evaluate args in.
3652 // s[sp-1] = rest of argument list (user input syntax)
3653 32342 static void cont_or(eval_context_t *ctx) {
3654 32342 lbm_value rest = ctx->K.data[--ctx->K.sp];
3655 32342 lbm_value env = ctx->K.data[--ctx->K.sp];
3656
2/2
✓ Branch 0 taken 1712 times.
✓ Branch 1 taken 30630 times.
 32342 if (!lbm_is_symbol_nil(ctx->r)) {
3657 1712 ctx->app_cont = true;
3658
2/2
✓ Branch 0 taken 17816 times.
✓ Branch 1 taken 12814 times.
 30630 } else if (lbm_is_cons(rest)) {
3659 17816 lbm_value *sptr = stack_reserve(ctx, 3);
3660 17816 lbm_cons_t *r_cell = lbm_ref_cell(rest);
3661 17816 sptr[0] = env;
3662 17816 sptr[1] = r_cell->cdr;
3663 17816 sptr[2] = OR;
3664 17816 ctx->curr_exp = r_cell->car;
3665 17816 ctx->curr_env = env;
3666 } else {
3667 // if we end up here we have traversed all arguments
3668 // and seen no non-nil. (see top case).
3669 12814 ctx->app_cont = true;
3670 }
3671 32342 }
3672
3673 81781220 static void fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3674
2/2
✓ Branch 0 taken 53779147 times.
✓ Branch 1 taken 28002073 times.
 81781220 if (lbm_type_of(key) == LBM_TYPE_SYMBOL) {
3675 // NILs dual role makes it hard to detect the difference
3676 // between the end of a structural key or an attempt to use NIL as the key
3677 // or as part of big key.
3678 // NIL has been given the same role as dont care.
3679
2/2
✓ Branch 0 taken 42578754 times.
✓ Branch 1 taken 11200393 times.
 53779147 if (lbm_dec_sym(key) >= RUNTIME_SYMBOLS_START) {
3680 42578754 lbm_env_modify_binding(env,key,value);
3681 } else {
3682
4/4
✓ Branch 0 taken 5600169 times.
✓ Branch 1 taken 5600224 times.
✓ Branch 2 taken 5600168 times.
✓ Branch 3 taken 1 times.
 11200393 if (key == ENC_SYM_DONTCARE || key == ENC_SYM_NIL) return;
3683 1 lbm_set_error_reason((char*)lbm_error_str_built_in);
3684 1 ERROR_AT_CTX(ENC_SYM_EERROR, key);
3685 }
3686
3/4
✓ Branch 0 taken 28002073 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 28002072 times.
✓ Branch 3 taken 1 times.
 56004146 } else if (lbm_is_cons(key) &&
3687 28002073 lbm_is_cons(value)) {
3688 28002072 fill_binding_location(lbm_ref_cell(key)->car, lbm_ref_cell(value)->car, env);
3689 28002072 fill_binding_location(lbm_ref_cell(key)->cdr, lbm_ref_cell(value)->cdr, env);
3690 } else {
3691 1 lbm_set_error_reason("Incorrect type of key in binding");
3692 1 ERROR_AT_CTX(ENC_SYM_TERROR, key);
3693 }
3694 }
3695
3696 // cont_bind_to_key_rest
3697 //
3698 // s[sp-4] = expression to evaluate in final env
3699 // s[sp-3] = rest of list of bindings
3700 // s[sp-2] = env to evaluate values in (Modified along the way)
3701 // s[sp-1] = key
3702 //
3703 // ctx->r = evaluated value to bind to key
3704 24489550 static void cont_bind_to_key_rest(eval_context_t *ctx) {
3705
3706 24489550 lbm_value *sptr = get_stack_ptr(ctx, 4);
3707
3708 24489550 lbm_value rest = sptr[1];
3709 24489550 lbm_value env = sptr[2];
3710 24489550 lbm_value key = sptr[3];
3711
3712 24489550 fill_binding_location(key, ctx->r, env);
3713
3714
2/2
✓ Branch 0 taken 229599 times.
✓ Branch 1 taken 24259949 times.
 24489548 if (lbm_is_cons(rest)) {
3715 229599 lbm_value car_rest = lbm_ref_cell(rest)->car;
3716 lbm_value key_val[2];
3717 229599 extract_n(car_rest, key_val, 2);
3718
3719 229599 sptr[1] = lbm_ref_cell(rest)->cdr;
3720 229599 sptr[3] = key_val[0];
3721 229599 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST;
3722 229599 ctx->curr_exp = key_val[1];
3723 229599 ctx->curr_env = env;
3724 } else {
3725 // Otherwise evaluate the expression in the populated env
3726 24259949 ctx->curr_exp = sptr[0];
3727 24259949 ctx->curr_env = env;
3728 24259949 lbm_stack_drop(&ctx->K, 4);
3729 }
3730 24489548 }
3731
3732 // cont_if
3733 //
3734 // s[sp-2] = then/else list (user input syntax)
3735 // s[sp-1] = environment
3736 //
3737 // ctx->r = evaluated condition
3738 55781366 static void cont_if(eval_context_t *ctx) {
3739
3740 55781366 lbm_value arg = ctx->r;
3741
3742 55781366 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3743
3744 55781366 ctx->curr_env = sptr[1];
3745
2/2
✓ Branch 0 taken 55083737 times.
✓ Branch 1 taken 697629 times.
 55781366 if (lbm_is_symbol_nil(arg)) {
3746 55083737 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3747 } else {
3748 697629 ctx->curr_exp = get_car(sptr[0]); // then branch
3749 }
3750 55781365 }
3751
3752 92928 static void cont_match(eval_context_t *ctx) {
3753 92928 lbm_value e = ctx->r;
3754
3755 92928 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3756 92928 lbm_value patterns = (lbm_value)sptr[0];
3757 92928 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3758 92928 lbm_value new_env = orig_env;
3759
3760
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 92928 times.
 92928 if (lbm_is_symbol_nil(patterns)) {
3761 // no more patterns
3762 ✗ lbm_stack_drop(&ctx->K, 2);
3763 ✗ ctx->r = ENC_SYM_NO_MATCH;
3764 ✗ ctx->app_cont = true;
3765
1/2
✓ Branch 0 taken 92928 times.
✗ Branch 1 not taken.
 92928 } else if (lbm_is_cons(patterns)) {
3766 92928 lbm_value match_case = lbm_ref_cell(patterns)->car;
3767 92928 lbm_value pattern = get_car(match_case);
3768 92928 lbm_value n1 = get_cadr(match_case);
3769 92928 lbm_value n2 = get_cdr(get_cdr(match_case));
3770 lbm_value body;
3771 92928 bool check_guard = false;
3772
2/2
✓ Branch 0 taken 8632 times.
✓ Branch 1 taken 84296 times.
 92928 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3773 8632 body = n1;
3774 } else {
3775 84296 body = get_car(n2);
3776 84296 check_guard = true;
3777 }
3778 92928 bool is_match = match(pattern, e, &new_env);
3779
2/2
✓ Branch 0 taken 17134 times.
✓ Branch 1 taken 75794 times.
 92928 if (is_match) {
3780
2/2
✓ Branch 0 taken 12976 times.
✓ Branch 1 taken 4158 times.
 17134 if (check_guard) {
3781 12976 lbm_value *rptr = stack_reserve(ctx,5);
3782 12976 sptr[0] = lbm_ref_cell(patterns)->cdr;
3783 12976 sptr[1] = ctx->curr_env;
3784 12976 rptr[0] = MATCH;
3785 12976 rptr[1] = new_env;
3786 12976 rptr[2] = body;
3787 12976 rptr[3] = e;
3788 12976 rptr[4] = MATCH_GUARD;
3789 12976 ctx->curr_env = new_env;
3790 12976 ctx->curr_exp = n1; // The guard
3791 } else {
3792 4158 lbm_stack_drop(&ctx->K, 2);
3793 4158 ctx->curr_env = new_env;
3794 4158 ctx->curr_exp = body;
3795 }
3796 } else {
3797 // set up for checking of next pattern
3798 75794 sptr[0] = get_cdr(patterns);
3799 75794 sptr[1] = orig_env;
3800 75794 stack_reserve(ctx,1)[0] = MATCH;
3801 // leave r unaltered
3802 75794 ctx->app_cont = true;
3803 }
3804 } else {
3805 ✗ ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_MATCH);
3806 }
3807 92928 }
3808
3809 448 static void cont_exit_atomic(eval_context_t *ctx) {
3810 448 is_atomic = false; // atomic blocks cannot nest!
3811 448 ctx->app_cont = true;
3812 448 }
3813
3814 // cont_map:
3815 //
3816 // sptr[0]: s[sp-6] = Rest of the input list.
3817 // sptr[1]: s[sp-5] = Environment to restore for the eval of each application.
3818 // sptr[2]: s[sp-4] = Result list.
3819 // sptr[3]: s[sp-3] = Cell that goes into result list after being populated with application result.
3820 // sptr[4]: s[sp-2] = Ref to application.
3821 // sptr[5]: s[sp-1] = Ref to application argument.
3822 //
3823 // ctx->r = eval result of previous application.
3824 4725 static void cont_map(eval_context_t *ctx) {
3825 4725 lbm_value *sptr = get_stack_ptr(ctx, 6);
3826 4725 lbm_value ls = sptr[0];
3827 4725 lbm_value env = sptr[1];
3828 4725 lbm_value t = sptr[3]; // known cons!
3829 4725 lbm_ref_cell(t)->car = ctx->r;
3830 //lbm_set_car(t, ctx->r); // update car field tailmost position.
3831
2/2
✓ Branch 0 taken 3144 times.
✓ Branch 1 taken 1581 times.
 4725 if (lbm_is_cons(ls)) {
3832 3144 lbm_cons_t *cell = lbm_ref_cell(ls); // already checked that cons.
3833 3144 lbm_value next = cell->car;
3834 3144 lbm_value rest = cell->cdr;
3835 3144 sptr[0] = rest;
3836 3144 stack_reserve(ctx,1)[0] = MAP;
3837 3144 lbm_ref_cell(sptr[5])->car = next; // update known cons
3838 //lbm_set_car(sptr[5], next); // new arguments
3839
3840 3144 lbm_value elt = cons_with_gc(ENC_SYM_NIL, ENC_SYM_NIL, ENC_SYM_NIL);
3841 3144 lbm_ref_cell(t)->cdr = elt;
3842 //lbm_set_cdr(t, elt);
3843 3144 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3844 3144 ctx->curr_exp = sptr[4];
3845 3144 ctx->curr_env = env;
3846 } else {
3847 1581 ctx->r = sptr[2]; //head of result list
3848 1581 ctx->curr_env = env;
3849 1581 lbm_stack_drop(&ctx->K, 6);
3850 1581 ctx->app_cont = true;
3851 }
3852 4725 }
3853
3854 12976 static void cont_match_guard(eval_context_t *ctx) {
3855
2/2
✓ Branch 0 taken 952 times.
✓ Branch 1 taken 12024 times.
 12976 if (lbm_is_symbol_nil(ctx->r)) {
3856 952 lbm_value e = ctx->K.data[--ctx->K.sp];
3857 952 lbm_stack_drop(&ctx->K, 2);
3858 952 ctx->r = e;
3859 952 ctx->app_cont = true;
3860 } else {
3861 12024 lbm_stack_drop(&ctx->K, 1);
3862 12024 lbm_value body = ctx->K.data[--ctx->K.sp];
3863 12024 lbm_value env = ctx->K.data[--ctx->K.sp];
3864 12024 lbm_stack_drop(&ctx->K, 3);
3865 12024 ctx->curr_env = env;
3866 12024 ctx->curr_exp = body;
3867 }
3868 12976 }
3869
3870 56 static void cont_terminate(eval_context_t *ctx) {
3871 56 ERROR_CTX(ctx->r);
3872 }
3873
3874 1850296 static void cont_loop(eval_context_t *ctx) {
3875 1850296 lbm_value *sptr = get_stack_ptr(ctx, 3);
3876 1850296 stack_reserve(ctx,1)[0] = LOOP_CONDITION;
3877 1850296 ctx->curr_env = sptr[2];
3878 1850296 ctx->curr_exp = sptr[1];
3879 1850296 }
3880
3881 1850856 static void cont_loop_condition(eval_context_t *ctx) {
3882
2/2
✓ Branch 0 taken 560 times.
✓ Branch 1 taken 1850296 times.
 1850856 if (lbm_is_symbol_nil(ctx->r)) {
3883 560 lbm_stack_drop(&ctx->K, 3);
3884 560 ctx->app_cont = true; // A loop returns nil? Makes sense to me... but in general?
3885 560 return;
3886 }
3887 1850296 lbm_value *sptr = get_stack_ptr(ctx, 3);
3888 1850296 stack_reserve(ctx,1)[0] = LOOP;
3889 1850296 ctx->curr_env = sptr[2];
3890 1850296 ctx->curr_exp = sptr[0];
3891 }
3892
3893 560 static void cont_loop_env_prep(eval_context_t *ctx) {
3894 560 lbm_value *sptr = get_stack_ptr(ctx, 3);
3895 560 sptr[2] = ctx->curr_env;
3896 560 stack_reserve(ctx,1)[0] = LOOP_CONDITION;
3897 560 ctx->curr_exp = sptr[1];
3898 560 }
3899
3900 17583248 static void cont_merge_rest(eval_context_t *ctx) {
3901 17583248 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3902
3903 // If comparator returns true (result is in ctx->r):
3904 // "a" should be moved to the last element position in merged list.
3905 // A new element from "a_rest" should be moved into comparator argument 1 pos.
3906 // else
3907 // "b" should be moved to last element position in merged list.
3908 // A new element from "b_rest" should be moved into comparator argument 2 pos.
3909 //
3910 // If a_rest or b_rest is NIL:
3911 // we are done, the remaining elements of
3912 // non_nil list should be appended to merged list.
3913 // else
3914 // Set up for a new comparator evaluation and recurse.
3915 17583248 lbm_value a = sptr[2];
3916 17583248 lbm_value b = lbm_cdr(a);
3917 17583248 lbm_set_cdr(a, ENC_SYM_NIL); // terminate 1 element list
3918
3919
2/2
✓ Branch 0 taken 10204483 times.
✓ Branch 1 taken 7378765 times.
 17583248 if (ctx->r == ENC_SYM_NIL) { // Comparison false
3920
3921
2/2
✓ Branch 0 taken 3967181 times.
✓ Branch 1 taken 6237302 times.
 10204483 if (sptr[0] == ENC_SYM_NIL) {
3922 3967181 sptr[0] = b;
3923 3967181 sptr[1] = b;
3924 } else {
3925 6237302 lbm_set_cdr(sptr[1], b);
3926 6237302 sptr[1] = b;
3927 }
3928
2/2
✓ Branch 0 taken 5098942 times.
✓ Branch 1 taken 5105541 times.
 10204483 if (sptr[4] == ENC_SYM_NIL) {
3929 5098942 lbm_set_cdr(a, sptr[3]);
3930 5098942 lbm_set_cdr(sptr[1], a);
3931 5098942 ctx->r = sptr[0];
3932 5098942 lbm_stack_drop(&ctx->K, 9);
3933 5098942 ctx->app_cont = true;
3934 5098942 return;
3935 } else {
3936 5105541 b = sptr[4];
3937 5105541 sptr[4] = lbm_cdr(sptr[4]);
3938 5105541 lbm_set_cdr(b, ENC_SYM_NIL);
3939 }
3940 } else {
3941
2/2
✓ Branch 0 taken 2269641 times.
✓ Branch 1 taken 5109124 times.
 7378765 if (sptr[0] == ENC_SYM_NIL) {
3942 2269641 sptr[0] = a;
3943 2269641 sptr[1] = a;
3944 } else {
3945 5109124 lbm_set_cdr(sptr[1], a);
3946 5109124 sptr[1] = a;
3947 }
3948
3949
2/2
✓ Branch 0 taken 1137880 times.
✓ Branch 1 taken 6240885 times.
 7378765 if (sptr[3] == ENC_SYM_NIL) {
3950 1137880 lbm_set_cdr(b, sptr[4]);
3951 1137880 lbm_set_cdr(sptr[1], b);
3952 1137880 ctx->r = sptr[0];
3953 1137880 lbm_stack_drop(&ctx->K, 9);
3954 1137880 ctx->app_cont = true;
3955 1137880 return;
3956 } else {
3957 6240885 a = sptr[3];
3958 6240885 sptr[3] = lbm_cdr(sptr[3]);
3959 6240885 lbm_set_cdr(a, ENC_SYM_NIL);
3960 }
3961 }
3962 11346426 lbm_set_cdr(a, b);
3963 11346426 sptr[2] = a;
3964
3965 11346426 lbm_value par1 = sptr[7];
3966 11346426 lbm_value par2 = sptr[8];
3967 11346426 lbm_value cmp_body = sptr[5];
3968 11346426 lbm_value cmp_env = sptr[6];
3969 // Environment should be preallocated already at this point
3970 // and the operations below should never need GC.
3971 11346426 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
3972 11346426 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
3973
2/4
✓ Branch 0 taken 11346426 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 11346426 times.
 11346426 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
3974 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
3975 }
3976 11346426 cmp_env = new_env;
3977
3978 11346426 stack_reserve(ctx,1)[0] = MERGE_REST;
3979 11346426 ctx->curr_exp = cmp_body;
3980 11346426 ctx->curr_env = cmp_env;
3981 }
3982
3983 // merge_layer stack contents
3984 // s[sp-9] = cmp
3985 // s[sp-8] = cmp_env
3986 // s[sp-7] = par1
3987 // s[sp-6] = par2
3988 // s[sp-5] = acc - first cell
3989 // s[sp-4] = acc - last cell
3990 // s[sp-3] = rest;
3991 // s[sp-2] = layer
3992 // s[sp-1] = length or original list
3993 //
3994 // ctx->r merged sublist
3995 6802595 static void cont_merge_layer(eval_context_t *ctx) {
3996 6802595 lbm_uint *sptr = get_stack_ptr(ctx, 9);
3997 6802595 lbm_int layer = lbm_dec_i(sptr[7]);
3998 6802595 lbm_int len = lbm_dec_i(sptr[8]);
3999
4000 6802595 lbm_value r_curr = ctx->r;
4001
1/2
✓ Branch 0 taken 27241347 times.
✗ Branch 1 not taken.
 27241347 while (lbm_is_cons(r_curr)) {
4002 27241347 lbm_value next = lbm_ref_cell(r_curr)->cdr;
4003
2/2
✓ Branch 0 taken 6802595 times.
✓ Branch 1 taken 20438752 times.
 27241347 if (next == ENC_SYM_NIL) {
4004 6802595 break;
4005 }
4006 20438752 r_curr = next;
4007 }
4008
4009
2/2
✓ Branch 0 taken 2264721 times.
✓ Branch 1 taken 4537874 times.
 6802595 if (sptr[4] == ENC_SYM_NIL) {
4010 2264721 sptr[4] = ctx->r;
4011 2264721 sptr[5] = r_curr;
4012 } else {
4013 4537874 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
4014 4537874 sptr[5] = r_curr;
4015 }
4016
4017 6802595 lbm_value layer_rest = sptr[6];
4018 // switch layer or done ?
4019
2/2
✓ Branch 0 taken 2264721 times.
✓ Branch 1 taken 4537874 times.
 6802595 if (layer_rest == ENC_SYM_NIL) {
4020
2/2
✓ Branch 0 taken 566225 times.
✓ Branch 1 taken 1698496 times.
 2264721 if (layer * 2 >= len) {
4021 566225 ctx->r = sptr[4];
4022 566225 ctx->app_cont = true;
4023 566225 lbm_stack_drop(&ctx->K, 9);
4024 566225 return;
4025 } else {
4026 // Setup for merges of the next layer
4027 1698496 layer = layer * 2;
4028 1698496 sptr[7] = lbm_enc_i(layer);
4029 1698496 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
4030 1698496 sptr[5] = ENC_SYM_NIL;
4031 1698496 sptr[4] = ENC_SYM_NIL;
4032 }
4033 }
4034 // merge another sublist based on current layer.
4035 6236370 lbm_value a_list = layer_rest;
4036 // build sublist a
4037 6236370 lbm_value curr = layer_rest;
4038
2/2
✓ Branch 0 taken 9086099 times.
✓ Branch 1 taken 6236145 times.
 15322244 for (int i = 0; i < layer-1; i ++) {
4039
2/2
✓ Branch 0 taken 9085874 times.
✓ Branch 1 taken 225 times.
 9086099 if (lbm_is_cons(curr)) {
4040 9085874 curr = lbm_ref_cell(curr)->cdr;
4041 } else {
4042 225 break;
4043 }
4044 }
4045 6236370 layer_rest = lbm_cdr(curr);
4046 6236370 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
4047
4048 6236370 lbm_value b_list = layer_rest;
4049 // build sublist b
4050 6236370 curr = layer_rest;
4051
2/2
✓ Branch 0 taken 6815626 times.
✓ Branch 1 taken 5104039 times.
 11919665 for (int i = 0; i < layer-1; i ++) {
4052
2/2
✓ Branch 0 taken 5683295 times.
✓ Branch 1 taken 1132331 times.
 6815626 if (lbm_is_cons(curr)) {
4053 5683295 curr = lbm_ref_cell(curr)->cdr;
4054 } else {
4055 1132331 break;
4056 }
4057 }
4058 6236370 layer_rest = lbm_cdr(curr);
4059 6236370 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
4060
4061 6236370 sptr[6] = layer_rest;
4062
4063
2/2
✓ Branch 0 taken 566394 times.
✓ Branch 1 taken 5669976 times.
 6236370 if (b_list == ENC_SYM_NIL) {
4064 566394 stack_reserve(ctx,1)[0] = MERGE_LAYER;
4065 566394 ctx->r = a_list;
4066 566394 ctx->app_cont = true;
4067 566394 return;
4068 }
4069 // Set up for a merge of sublists.
4070
4071 5669976 lbm_value a_rest = lbm_cdr(a_list);
4072 5669976 lbm_value b_rest = lbm_cdr(b_list);
4073 5669976 lbm_value a = a_list;
4074 5669976 lbm_value b = b_list;
4075 5669976 lbm_set_cdr(a, b);
4076 // Terminating the b list would be incorrect here
4077 // if there was any chance that the environment update below
4078 // performs GC.
4079 5669976 lbm_set_cdr(b, ENC_SYM_NIL);
4080
4081 5669976 lbm_value cmp_body = sptr[0];
4082 5669976 lbm_value cmp_env = sptr[1];
4083 5669976 lbm_value par1 = sptr[2];
4084 5669976 lbm_value par2 = sptr[3];
4085 // Environment should be preallocated already at this point
4086 // and the operations below should never need GC.
4087 5669976 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
4088 5669976 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
4089
2/4
✓ Branch 0 taken 5669976 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 5669976 times.
 5669976 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
4090 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4091 }
4092 5669976 cmp_env = new_env;
4093
4094 5669976 lbm_uint *merge_cont = stack_reserve(ctx, 11);
4095 5669976 merge_cont[0] = MERGE_LAYER;
4096 5669976 merge_cont[1] = ENC_SYM_NIL;
4097 5669976 merge_cont[2] = ENC_SYM_NIL;
4098 5669976 merge_cont[3] = a;
4099 5669976 merge_cont[4] = a_rest;
4100 5669976 merge_cont[5] = b_rest;
4101 5669976 merge_cont[6] = cmp_body;
4102 5669976 merge_cont[7] = cmp_env;
4103 5669976 merge_cont[8] = par1;
4104 5669976 merge_cont[9] = par2;
4105 5669976 merge_cont[10] = MERGE_REST;
4106 5669976 ctx->curr_exp = cmp_body;
4107 5669976 ctx->curr_env = cmp_env;
4108 5669976 return;
4109 }
4110
4111 /****************************************************/
4112 /* READER */
4113
4114 67651 static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {
4115
4116 /* Tokenizer reached "end of file"
4117 The parser could be in a state where it needs
4118 more tokens to correctly finish an expression.
4119
4120 Four cases
4121 1. The program / expression is malformed and the context should die.
4122 2. We are finished reading a program and should close off the
4123 internal representation with a closing parenthesis. Then
4124 apply continuation.
4125 3. We are finished reading an expression and should
4126 apply the continuation
4127 4. We are finished read-and-evaluating
4128
4129 In case 2, we should find the READ_DONE at sp - 5.
4130 In case 3, we should find the READ_DONE at sp - 1.
4131 In case 4, we should find the READ_DONE at sp - 4.
4132
4133 case 3 should not end up here, but rather end up in
4134 cont_read_done.
4135 */
4136
4137
2/2
✓ Branch 0 taken 22094 times.
✓ Branch 1 taken 45557 times.
 67651 if (lbm_is_symbol(ctx->r)) {
4138 22094 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4139
3/4
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 22093 times.
✓ Branch 2 taken 1 times.
✗ Branch 3 not taken.
 22094 if (sym_val >= TOKENIZER_SYMBOLS_START &&
4140 sym_val <= TOKENIZER_SYMBOLS_END) {
4141 1 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4142 }
4143 }
4144
4145
3/4
✓ Branch 0 taken 67650 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 44800 times.
✓ Branch 3 taken 22850 times.
 67650 if (ctx->K.sp > 4 && (ctx->K.data[ctx->K.sp - 4] == READ_DONE) &&
4146
1/2
✓ Branch 0 taken 44800 times.
✗ Branch 1 not taken.
 44800 (ctx->K.data[ctx->K.sp - 5] == READING_PROGRAM_INCREMENTALLY)) {
4147 /* read and evaluate is done */
4148 44800 --ctx->K.sp; // Pop but do not use
4149 44800 lbm_value env = ctx->K.data[--ctx->K.sp];
4150 44800 --ctx->K.sp; // Pop but do not use
4151 44800 ctx->curr_env = env;
4152 44800 ctx->app_cont = true; // Program evaluated and result is in ctx->r.
4153
3/4
✓ Branch 0 taken 22850 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 22836 times.
✓ Branch 3 taken 14 times.
 22850 } else if (ctx->K.sp > 5 && (ctx->K.data[ctx->K.sp - 5] == READ_DONE) &&
4154
2/2
✓ Branch 0 taken 22828 times.
✓ Branch 1 taken 8 times.
 22836 (ctx->K.data[ctx->K.sp - 6] == READING_PROGRAM)) {
4155 /* successfully finished reading a program (CASE 2) */
4156 22828 ctx->r = ENC_SYM_CLOSEPAR;
4157 22828 ctx->app_cont = true;
4158 } else {
4159
2/4
✓ Branch 0 taken 22 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 22 times.
 22 if (lbm_channel_row(str) == 1 && lbm_channel_column(str) == 1) {
4160 // (read "") evaluates to nil.
4161 ✗ ctx->r = ENC_SYM_NIL;
4162 ✗ ctx->app_cont = true;
4163 } else {
4164 22 lbm_channel_reader_close(str);
4165 22 lbm_set_error_reason((char*)lbm_error_str_parse_eof);
4166 22 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4167 }
4168 }
4169 67628 }
4170
4171 /* cont_read_next_token
4172 sp-2 : Stream
4173 sp-1 : Grab row
4174 */
4175 11653050 static void cont_read_next_token(eval_context_t *ctx) {
4176 11653050 lbm_value *sptr = get_stack_ptr(ctx, 2);
4177 11653050 lbm_value stream = sptr[0];
4178 11653050 lbm_value grab_row0 = sptr[1];
4179
4180 11653050 lbm_char_channel_t *chan = lbm_dec_channel(stream);
4181
2/4
✓ Branch 0 taken 11653050 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 11653050 times.
 11653050 if (chan == NULL || chan->state == NULL) {
4182 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4183 return; // INFER does not understant that error_ctx longjmps
4184 // out of this function.
4185 }
4186
4187
4/4
✓ Branch 0 taken 10761114 times.
✓ Branch 1 taken 891936 times.
✓ Branch 2 taken 23914 times.
✓ Branch 3 taken 10737200 times.
 11653050 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
4188 23914 lbm_stack_drop(&ctx->K, 2);
4189 23914 read_finish(chan, ctx);
4190 23891 return;
4191 }
4192 /* Eat whitespace and comments */
4193
2/2
✓ Branch 0 taken 1667 times.
✓ Branch 1 taken 11627469 times.
 11629136 if (!tok_clean_whitespace(chan)) {
4194 1667 sptr[0] = stream;
4195 1667 sptr[1] = lbm_enc_u(0);
4196 1667 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4197 1667 yield_ctx(EVAL_CPS_MIN_SLEEP);
4198 1667 return;
4199 }
4200 /* After eating whitespace we may be at end of file/stream */
4201
4/4
✓ Branch 0 taken 10738134 times.
✓ Branch 1 taken 889335 times.
✓ Branch 2 taken 43737 times.
✓ Branch 3 taken 10694397 times.
 11627469 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
4202 43737 lbm_stack_drop(&ctx->K, 2);
4203 43737 read_finish(chan, ctx);
4204 43737 return;
4205 }
4206
4207
2/2
✓ Branch 0 taken 763363 times.
✓ Branch 1 taken 10820369 times.
 11583732 if (lbm_dec_u(grab_row0)) {
4208 763363 ctx->row0 = (int32_t)lbm_channel_row(chan);
4209 763363 ctx->row1 = -1; // a new start, end is unknown
4210 }
4211
4212 /* Attempt to extract tokens from the character stream */
4213 11583732 int n = 0;
4214 11583732 lbm_value res = ENC_SYM_NIL;
4215 11583732 unsigned int string_len = 0;
4216
4217 /*
4218 * SYNTAX
4219 */
4220 uint32_t tok_match;
4221 11583732 n = tok_syntax(chan, &tok_match);
4222
2/2
✓ Branch 0 taken 2938267 times.
✓ Branch 1 taken 8645465 times.
 11583732 if (n > 0) {
4223
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 2938267 times.
 2938267 if (!lbm_channel_drop(chan, (unsigned int)n)) {
4224 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4225 }
4226 2938267 lbm_value compound_read_start = READ_START_BYTEARRAY;
4227 2938267 lbm_value compound_value_opener = ENC_SYM_OPENBRACK;
4228 2938267 lbm_value compound_value_closer = ENC_SYM_CLOSEBRACK;
4229 2938267 ctx->app_cont = true;
4230
16/17
✓ Branch 0 taken 1390281 times.
✓ Branch 1 taken 1390266 times.
✓ Branch 2 taken 1038 times.
✓ Branch 3 taken 6940 times.
✓ Branch 4 taken 1035 times.
✓ Branch 5 taken 6937 times.
✓ Branch 6 taken 12826 times.
✓ Branch 7 taken 2184 times.
✓ Branch 8 taken 58663 times.
✓ Branch 9 taken 10205 times.
✓ Branch 10 taken 283 times.
✓ Branch 11 taken 27791 times.
✓ Branch 12 taken 16636 times.
✓ Branch 13 taken 6530 times.
✓ Branch 14 taken 6530 times.
✓ Branch 15 taken 122 times.
✗ Branch 16 not taken.
 2938267 switch(tok_match) {
4231 1390281 case TOKOPENPAR: {
4232 1390281 sptr[0] = ENC_SYM_NIL;
4233 1390281 sptr[1] = ENC_SYM_NIL;
4234 1390281 lbm_value *rptr = stack_reserve(ctx,5);
4235 1390281 rptr[0] = stream;
4236 1390281 rptr[1] = READ_APPEND_CONTINUE;
4237 1390281 rptr[2] = stream;
4238 1390281 rptr[3] = lbm_enc_u(0);
4239 1390281 rptr[4] = READ_NEXT_TOKEN;
4240 1390281 ctx->r = ENC_SYM_OPENPAR;
4241 1390281 } return;
4242 1390266 case TOKCLOSEPAR: {
4243 1390266 lbm_stack_drop(&ctx->K, 2);
4244 1390266 ctx->r = ENC_SYM_CLOSEPAR;
4245 1390266 } return;
4246 1038 case TOKOPENARRAY:
4247 1038 compound_read_start = READ_START_ARRAY; // switch to array reader
4248 1038 compound_value_opener = ENC_SYM_OPENARRAY; /* fall through */
4249 7978 case TOKOPENBRACK: {
4250 7978 sptr[0] = stream;
4251 7978 sptr[1] = compound_read_start;
4252 7978 lbm_value *rptr = stack_reserve(ctx, 3);
4253 7978 rptr[0] = stream;
4254 7978 rptr[1] = lbm_enc_u(0);
4255 7978 rptr[2] = READ_NEXT_TOKEN;
4256 7978 ctx->r = compound_value_opener;
4257 7978 } return;
4258 1035 case TOKCLOSEARRAY:
4259 1035 compound_value_closer = ENC_SYM_CLOSEARRAY; /* fall through */
4260 7972 case TOKCLOSEBRACK:
4261 7972 lbm_stack_drop(&ctx->K, 2);
4262 7972 ctx->r = compound_value_closer;
4263 7972 return;
4264 12826 case TOKDOT:
4265 12826 lbm_stack_drop(&ctx->K, 2);
4266 12826 ctx->r = ENC_SYM_DOT;
4267 12826 return;
4268 2184 case TOKDONTCARE:
4269 2184 lbm_stack_drop(&ctx->K, 2);
4270 2184 ctx->r = ENC_SYM_DONTCARE;
4271 2184 return;
4272 58663 case TOKQUOTE:
4273 58663 sptr[0] = ENC_SYM_QUOTE;
4274 58663 sptr[1] = WRAP_RESULT;
4275 58663 break;
4276 10205 case TOKBACKQUOTE: {
4277 10205 sptr[0] = QQ_EXPAND_START;
4278 10205 sptr[1] = stream;
4279 10205 lbm_value *rptr = stack_reserve(ctx, 2);
4280 10205 rptr[0] = lbm_enc_u(0);
4281 10205 rptr[1] = READ_NEXT_TOKEN;
4282 10205 ctx->app_cont = true;
4283 10205 } return;
4284 283 case TOKCOMMAAT:
4285 283 sptr[0] = ENC_SYM_COMMAAT;
4286 283 sptr[1] = WRAP_RESULT;
4287 283 break;
4288 27791 case TOKCOMMA:
4289 27791 sptr[0] = ENC_SYM_COMMA;
4290 27791 sptr[1] = WRAP_RESULT;
4291 27791 break;
4292 16636 case TOKMATCHANY:
4293 16636 lbm_stack_drop(&ctx->K, 2);
4294 16636 ctx->r = ENC_SYM_MATCH_ANY;
4295 16636 return;
4296 6530 case TOKOPENCURL: {
4297 6530 sptr[0] = ENC_SYM_NIL;
4298 6530 sptr[1] = ENC_SYM_NIL;
4299 6530 lbm_value *rptr = stack_reserve(ctx,2);
4300 6530 rptr[0] = stream;
4301 6530 rptr[1] = READ_APPEND_CONTINUE;
4302 6530 ctx->r = ENC_SYM_PROGN;
4303 6530 } return;
4304 6530 case TOKCLOSECURL:
4305 6530 lbm_stack_drop(&ctx->K, 2);
4306 6530 ctx->r = ENC_SYM_CLOSEPAR;
4307 6530 return;
4308 122 case TOKCONSTSTART: /* fall through */
4309 case TOKCONSTEND: {
4310
2/2
✓ Branch 0 taken 61 times.
✓ Branch 1 taken 61 times.
 122 if (tok_match == TOKCONSTSTART) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST;
4311
2/2
✓ Branch 0 taken 61 times.
✓ Branch 1 taken 61 times.
 122 if (tok_match == TOKCONSTEND) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST;
4312 122 sptr[0] = stream;
4313 122 sptr[1] = lbm_enc_u(0);
4314 122 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4315 122 ctx->app_cont = true;
4316 122 } return;
4317 ✗ default:
4318 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4319 }
4320 // read next token
4321 86737 lbm_value *rptr = stack_reserve(ctx, 3);
4322 86737 rptr[0] = stream;
4323 86737 rptr[1] = lbm_enc_u(0);
4324 86737 rptr[2] = READ_NEXT_TOKEN;
4325 86737 ctx->app_cont = true;
4326 86737 return;
4327
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8645465 times.
 8645465 } else if (n < 0) goto retry_token;
4328
4329 /*
4330 * STRING
4331 */
4332 8645465 n = tok_string(chan, &string_len);
4333
2/2
✓ Branch 0 taken 20985 times.
✓ Branch 1 taken 8624480 times.
 8645465 if (n >= 2) {
4334 20985 lbm_channel_drop(chan, (unsigned int)n);
4335 #ifdef LBM_ALWAYS_GC
4336 gc();
4337 #endif
4338
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 20984 times.
 20985 if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
4339 1 gc();
4340 1 lbm_heap_allocate_array(&res, (unsigned int)(string_len+1));
4341 }
4342
1/2
✓ Branch 0 taken 20985 times.
✗ Branch 1 not taken.
 20985 if (lbm_is_ptr(res)) {
4343 20985 lbm_array_header_t *arr = assume_array(res);
4344 20985 char *data = (char*)arr->data;
4345 20985 memset(data,0, string_len + 1);
4346 20985 memcpy(data, tokpar_sym_str, string_len);
4347 20985 lbm_stack_drop(&ctx->K, 2);
4348 20985 ctx->r = res;
4349 20985 ctx->app_cont = true;
4350 20985 return;
4351 } else {
4352 ✗ ERROR_CTX(ENC_SYM_MERROR);
4353 }
4354
2/2
✓ Branch 0 taken 60 times.
✓ Branch 1 taken 8624420 times.
 8624480 } else if (n < 0) goto retry_token;
4355
4356 /*
4357 * FLOAT
4358 */
4359 token_float f_val;
4360 8624420 n = tok_double(chan, &f_val);
4361
2/2
✓ Branch 0 taken 24068 times.
✓ Branch 1 taken 8600352 times.
 8624420 if (n > 0) {
4362 24068 lbm_channel_drop(chan, (unsigned int) n);
4363
2/3
✓ Branch 0 taken 18015 times.
✓ Branch 1 taken 6053 times.
✗ Branch 2 not taken.
 24068 switch(f_val.type) {
4364 18015 case TOKTYPEF32:
4365
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 18015 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 18015 WITH_GC(res, lbm_enc_float((float)f_val.value));
4366 18015 break;
4367 6053 case TOKTYPEF64:
4368 6053 res = lbm_enc_double(f_val.value);
4369 6053 break;
4370 ✗ default:
4371 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4372 }
4373 24068 lbm_stack_drop(&ctx->K, 2);
4374 24068 ctx->r = res;
4375 24068 ctx->app_cont = true;
4376 24068 return;
4377
2/2
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 8600350 times.
 8600352 } else if (n < 0) goto retry_token;
4378
4379 /*
4380 * INTEGER
4381 */
4382 token_int int_result;
4383 8600350 n = tok_integer(chan, &int_result);
4384
2/2
✓ Branch 0 taken 6737850 times.
✓ Branch 1 taken 1862500 times.
 8600350 if (n > 0) {
4385 6737850 lbm_channel_drop(chan, (unsigned int)n);
4386
7/8
✓ Branch 0 taken 5332 times.
✓ Branch 1 taken 6694799 times.
✓ Branch 2 taken 7004 times.
✓ Branch 3 taken 7344 times.
✓ Branch 4 taken 8975 times.
✓ Branch 5 taken 7562 times.
✓ Branch 6 taken 6834 times.
✗ Branch 7 not taken.
 6737850 switch(int_result.type) {
4387 5332 case TOKTYPEBYTE:
4388
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5332 times.
 5332 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
4389 5332 break;
4390 6694799 case TOKTYPEI:
4391
2/2
✓ Branch 0 taken 3053 times.
✓ Branch 1 taken 6691746 times.
 6694799 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
4392 6694799 break;
4393 7004 case TOKTYPEU:
4394
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 6892 times.
 7004 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
4395 7004 break;
4396 7344 case TOKTYPEI32:
4397
3/8
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 7232 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 7344 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 7344 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)));
4398 7344 break;
4399 8975 case TOKTYPEU32:
4400
3/8
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 8863 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 8975 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 8975 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)));
4401 8975 break;
4402 7562 case TOKTYPEI64:
4403
3/8
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 7394 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 7562 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 7562 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)));
4404 7562 break;
4405 6834 case TOKTYPEU64:
4406
3/8
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 6722 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 6834 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 6834 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)));
4407 6834 break;
4408 ✗ default:
4409 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4410 }
4411 6737850 lbm_stack_drop(&ctx->K, 2);
4412 6737850 ctx->r = res;
4413 6737850 ctx->app_cont = true;
4414 6737850 return;
4415
2/2
✓ Branch 0 taken 3 times.
✓ Branch 1 taken 1862497 times.
 1862500 } else if (n < 0) goto retry_token;
4416
4417 /*
4418 * SYMBOL
4419 */
4420 1862497 n = tok_symbol(chan);
4421
2/2
✓ Branch 0 taken 1861033 times.
✓ Branch 1 taken 1464 times.
 1862497 if (n > 0) {
4422 1861033 lbm_channel_drop(chan, (unsigned int) n);
4423 lbm_uint symbol_id;
4424
2/2
✓ Branch 0 taken 213173 times.
✓ Branch 1 taken 1647860 times.
 1861033 if (!lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
4425 213173 int r = 0;
4426
2/2
✓ Branch 0 taken 52094 times.
✓ Branch 1 taken 161079 times.
 213173 if (n > 4 &&
4427
2/2
✓ Branch 0 taken 1063 times.
✓ Branch 1 taken 51031 times.
 52094 tokpar_sym_str[0] == 'e' &&
4428
2/2
✓ Branch 0 taken 143 times.
✓ Branch 1 taken 920 times.
 1063 tokpar_sym_str[1] == 'x' &&
4429
2/2
✓ Branch 0 taken 86 times.
✓ Branch 1 taken 57 times.
 143 tokpar_sym_str[2] == 't' &&
4430
2/2
✓ Branch 0 taken 28 times.
✓ Branch 1 taken 58 times.
 86 tokpar_sym_str[3] == '-') {
4431 lbm_uint ext_id;
4432 28 lbm_uint ext_name_len = (lbm_uint)n + 1;
4433 #ifdef LBM_ALWAYS_GC
4434 gc();
4435 #endif
4436 28 char *ext_name = lbm_malloc(ext_name_len);
4437
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (!ext_name) {
4438 ✗ gc();
4439 ✗ ext_name = lbm_malloc(ext_name_len);
4440 }
4441
1/2
✓ Branch 0 taken 28 times.
✗ Branch 1 not taken.
 28 if (ext_name) {
4442 28 memcpy(ext_name, tokpar_sym_str, ext_name_len);
4443 28 r = lbm_add_extension(ext_name, lbm_extensions_default);
4444
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 28 times.
 28 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
4445 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4446 }
4447 28 symbol_id = ext_id;
4448 } else {
4449 ✗ ERROR_CTX(ENC_SYM_MERROR);
4450 }
4451 } else {
4452 213145 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id);
4453 }
4454
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 213173 times.
 213173 if (!r) {
4455 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4456 }
4457 }
4458 1861033 lbm_stack_drop(&ctx->K, 2);
4459 1861033 ctx->r = lbm_enc_sym(symbol_id);
4460 1861033 ctx->app_cont = true;
4461 1861033 return;
4462
2/2
✓ Branch 0 taken 44 times.
✓ Branch 1 taken 1420 times.
 1464 } else if (n == TOKENIZER_NEED_MORE) {
4463 44 goto retry_token;
4464
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1420 times.
 1420 } else if (n <= TOKENIZER_STRING_ERROR) {
4465 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4466 }
4467
4468 /*
4469 * CHAR
4470 */
4471 char c_val;
4472 1420 n = tok_char(chan, &c_val);
4473
2/2
✓ Branch 0 taken 1362 times.
✓ Branch 1 taken 58 times.
 1420 if(n > 0) {
4474 1362 lbm_channel_drop(chan,(unsigned int) n);
4475 1362 lbm_stack_drop(&ctx->K, 2);
4476 1362 ctx->r = lbm_enc_char((uint8_t)c_val);
4477 1362 ctx->app_cont = true;
4478 1362 return;
4479
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 2 times.
 58 }else if (n < 0) goto retry_token;
4480
4481 2 READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4482
4483 165 retry_token:
4484
2/2
✓ Branch 0 taken 51 times.
✓ Branch 1 taken 114 times.
 165 if (n == TOKENIZER_NEED_MORE) {
4485 51 sptr[0] = stream;
4486 51 sptr[1] = lbm_enc_u(0);
4487 51 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4488 51 yield_ctx(EVAL_CPS_MIN_SLEEP);
4489 51 return;
4490 }
4491 114 READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4492 }
4493
4494 6940 static void cont_read_start_bytearray(eval_context_t *ctx) {
4495 6940 lbm_value *sptr = get_stack_ptr(ctx, 1);
4496 6940 lbm_value stream = sptr[0];
4497
4498 6940 lbm_char_channel_t *str = lbm_dec_channel(stream);
4499
2/4
✓ Branch 0 taken 6940 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 6940 times.
 6940 if (str == NULL || str->state == NULL) {
4500 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4501 return; // INFER does not understand that error_ctx longjmps out
4502 // of this function here.
4503 }
4504
2/2
✓ Branch 0 taken 115 times.
✓ Branch 1 taken 6825 times.
 6940 if (ctx->r == ENC_SYM_CLOSEBRACK) {
4505 lbm_value array;
4506
4507
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 115 times.
 115 if (!lbm_heap_allocate_array(&array, 0)) {
4508 ✗ gc();
4509 ✗ if (!lbm_heap_allocate_array(&array, 0)) {
4510 ✗ lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
4511 ✗ lbm_channel_reader_close(str);
4512 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR); // Terminates ctx
4513 }
4514 }
4515 115 lbm_stack_drop(&ctx->K, 1);
4516 115 ctx->r = array;
4517 115 ctx->app_cont = true;
4518
1/2
✓ Branch 0 taken 6825 times.
✗ Branch 1 not taken.
 6825 } else if (lbm_is_number(ctx->r)) {
4519 #ifdef LBM_ALWAYS_GC
4520 gc();
4521 #endif
4522 6825 lbm_uint num_free = lbm_memory_longest_free();
4523 6825 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
4524
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6825 times.
 6825 if (initial_size == 0) {
4525 ✗ gc();
4526 ✗ num_free = lbm_memory_longest_free();
4527 ✗ initial_size = (lbm_uint)((float)num_free * 0.9);
4528 ✗ if (initial_size == 0) {
4529 ✗ lbm_channel_reader_close(str);
4530 ✗ ERROR_CTX(ENC_SYM_MERROR);
4531 }
4532 }
4533 lbm_value array;
4534 6825 initial_size = sizeof(lbm_uint) * initial_size;
4535
4536 // Keep in mind that this allocation can fail for both
4537 // lbm_memory and heap reasons.
4538
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6825 times.
 6825 if (!lbm_heap_allocate_array(&array, initial_size)) {
4539 ✗ gc();
4540 ✗ if (!lbm_heap_allocate_array(&array, initial_size)) {
4541 ✗ lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
4542 ✗ lbm_channel_reader_close(str);
4543 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4544 // NOTE: If array is not created evaluation ends here.
4545 // Static analysis seems unaware.
4546 }
4547 }
4548
4549 6825 sptr[0] = array;
4550 6825 lbm_value *rptr = stack_reserve(ctx, 4);
4551 6825 rptr[0] = lbm_enc_u(initial_size);
4552 6825 rptr[1] = lbm_enc_u(0);
4553 6825 rptr[2] = stream;
4554 6825 rptr[3] = READ_APPEND_BYTEARRAY;
4555 6825 ctx->app_cont = true;
4556 } else {
4557 ✗ lbm_channel_reader_close(str);
4558 ✗ READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4559 }
4560 }
4561
4562 744175 static void cont_read_append_bytearray(eval_context_t *ctx) {
4563 744175 lbm_uint *sptr = get_stack_ptr(ctx, 4);
4564
4565 744175 lbm_value array = sptr[0];
4566 744175 lbm_value size = lbm_dec_as_u32(sptr[1]);
4567 744175 lbm_value ix = lbm_dec_as_u32(sptr[2]);
4568 744175 lbm_value stream = sptr[3];
4569
4570
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 744175 times.
 744175 if (ix >= (size - 1)) {
4571 ✗ ERROR_CTX(ENC_SYM_MERROR);
4572 }
4573
4574 // if sptr[0] is not an array something is very very wrong.
4575 // Not robust against a garbage on stack. But how would garbage get onto stack?
4576 744175 lbm_array_header_t *arr = assume_array(array);
4577
2/2
✓ Branch 0 taken 737353 times.
✓ Branch 1 taken 6822 times.
 744175 if (lbm_is_number(ctx->r)) {
4578 737353 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
4579
4580 737353 sptr[2] = lbm_enc_u(ix + 1);
4581 737353 lbm_value *rptr = stack_reserve(ctx, 4);
4582 737353 rptr[0] = READ_APPEND_BYTEARRAY;
4583 737353 rptr[1] = stream;
4584 737353 rptr[2] = lbm_enc_u(0);
4585 737353 rptr[3] = READ_NEXT_TOKEN;
4586 737353 ctx->app_cont = true;
4587
3/4
✓ Branch 0 taken 6822 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 6821 times.
✓ Branch 3 taken 1 times.
 6822 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK) {
4588 6821 lbm_uint array_size = ix / sizeof(lbm_uint);
4589
4590
2/2
✓ Branch 0 taken 5869 times.
✓ Branch 1 taken 952 times.
 6821 if (ix % sizeof(lbm_uint) != 0) {
4591 5869 array_size = array_size + 1;
4592 }
4593 6821 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
4594 6821 arr->size = ix;
4595 6821 lbm_stack_drop(&ctx->K, 4);
4596 6821 ctx->r = array;
4597 6821 ctx->app_cont = true;
4598 } else {
4599 1 ERROR_CTX(ENC_SYM_TERROR);
4600 }
4601 744174 }
4602
4603 // Lisp array syntax reading ////////////////////////////////////////
4604
4605 1038 static void cont_read_start_array(eval_context_t *ctx) {
4606 1038 lbm_value *sptr = get_stack_ptr(ctx, 1);
4607 1038 lbm_value stream = sptr[0];
4608
4609 1038 lbm_char_channel_t *str = lbm_dec_channel(stream);
4610
2/4
✓ Branch 0 taken 1038 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 1038 times.
 1038 if (str == NULL || str->state == NULL) {
4611 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4612 return; // INFER does not understand that error_ctx longjmps out
4613 // of this function here.
4614 }
4615
2/2
✓ Branch 0 taken 58 times.
✓ Branch 1 taken 980 times.
 1038 if (ctx->r == ENC_SYM_CLOSEARRAY) {
4616 lbm_value array;
4617
4618
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 58 times.
 58 if (!lbm_heap_allocate_lisp_array(&array, 0)) {
4619 ✗ gc();
4620 ✗ if (!lbm_heap_allocate_lisp_array(&array, 0)) {
4621 ✗ lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
4622 ✗ lbm_channel_reader_close(str);
4623 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR); // Terminates ctx
4624 }
4625 }
4626 58 lbm_stack_drop(&ctx->K, 1);
4627 58 ctx->r = array;
4628 58 ctx->app_cont = true;
4629 } else {
4630 #ifdef LBM_ALWAYS_GC
4631 gc();
4632 #endif
4633 980 lbm_uint num = ((lbm_uint)((float)lbm_memory_longest_free() * 0.9) / sizeof(lbm_uint)) ;
4634 980 lbm_uint initial_size = (lbm_uint)num;
4635
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 980 times.
 980 if (initial_size == 0) {
4636 ✗ gc();
4637 ✗ num = ((lbm_uint)((float)lbm_memory_longest_free() * 0.9) / sizeof(lbm_uint)) ;
4638 ✗ initial_size = (lbm_uint)num;
4639 ✗ if (initial_size == 0) {
4640 ✗ lbm_channel_reader_close(str);
4641 ✗ ERROR_CTX(ENC_SYM_MERROR);
4642 }
4643 }
4644 lbm_value array;
4645 980 initial_size = sizeof(lbm_uint) * initial_size;
4646
4647
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 980 times.
 980 if (!lbm_heap_allocate_lisp_array(&array, initial_size)) {
4648 ✗ gc();
4649 ✗ if (!lbm_heap_allocate_lisp_array(&array, initial_size)) {
4650 ✗ lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
4651 ✗ lbm_channel_reader_close(str);
4652 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4653 }
4654 }
4655
4656 980 sptr[0] = array;
4657 980 lbm_value *rptr = stack_reserve(ctx, 4);
4658 980 rptr[0] = lbm_enc_u(initial_size);
4659 980 rptr[1] = lbm_enc_u(0);
4660 980 rptr[2] = stream;
4661 980 rptr[3] = READ_APPEND_ARRAY;
4662 980 ctx->app_cont = true;
4663 }
4664 }
4665
4666 4592 static void cont_read_append_array(eval_context_t *ctx) {
4667 4592 lbm_uint *sptr = get_stack_ptr(ctx, 4);
4668
4669 4592 lbm_value array = sptr[0];
4670 4592 lbm_value size = lbm_dec_as_u32(sptr[1]);
4671 4592 lbm_value ix = lbm_dec_as_u32(sptr[2]);
4672 4592 lbm_value stream = sptr[3];
4673
4674
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 4592 times.
 4592 if (ix >= (size - 1)) {
4675 ✗ ERROR_CTX(ENC_SYM_MERROR);
4676 }
4677
4678 // if sptr[0] is not an array something is very very wrong.
4679 // Not robust against a garbage on stack. But how would garbage get onto stack?
4680 4592 lbm_array_header_t *arr = assume_array(array);
4681
4/4
✓ Branch 0 taken 3162 times.
✓ Branch 1 taken 1430 times.
✓ Branch 2 taken 977 times.
✓ Branch 3 taken 2185 times.
 4592 if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEARRAY) {
4682 977 lbm_uint array_size = ix;
4683
4684
2/2
✓ Branch 0 taken 721 times.
✓ Branch 1 taken 256 times.
 977 if (ix % sizeof(lbm_uint) != 0) {
4685 721 array_size = array_size + 1;
4686 }
4687 977 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
4688 977 arr->size = ix * sizeof(lbm_uint);
4689 977 lbm_stack_drop(&ctx->K, 4);
4690 977 ctx->r = array;
4691 977 ctx->app_cont = true;
4692 } else {
4693 3615 ((lbm_uint*)arr->data)[ix] = ctx->r;
4694
4695 3615 sptr[2] = lbm_enc_u(ix + 1);
4696 3615 lbm_value *rptr = stack_reserve(ctx, 4);
4697 3615 rptr[0] = READ_APPEND_ARRAY;
4698 3615 rptr[1] = stream;
4699 3615 rptr[2] = lbm_enc_u(0);
4700 3615 rptr[3] = READ_NEXT_TOKEN;
4701 3615 ctx->app_cont = true;
4702 }
4703 4592 }
4704
4705 // Lisp list syntax reading ////////////////////////////////////////
4706
4707 10000770 static void cont_read_append_continue(eval_context_t *ctx) {
4708 10000770 lbm_value *sptr = get_stack_ptr(ctx, 3);
4709
4710 10000770 lbm_value first_cell = sptr[0];
4711 10000770 lbm_value last_cell = sptr[1];
4712 10000770 lbm_value stream = sptr[2];
4713
4714 10000770 lbm_char_channel_t *str = lbm_dec_channel(stream);
4715
2/4
✓ Branch 0 taken 10000770 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 10000770 times.
 10000770 if (str == NULL || str->state == NULL) {
4716 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4717 return; // INFER does not understand that execution
4718 // jumps out on error_ctx with a longjmp.
4719 }
4720
4721
2/2
✓ Branch 0 taken 3213170 times.
✓ Branch 1 taken 6787600 times.
 10000770 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4722
4723
3/3
✓ Branch 0 taken 1406797 times.
✓ Branch 1 taken 12826 times.
✓ Branch 2 taken 1793547 times.
 3213170 switch(ctx->r) {
4724 1406797 case ENC_SYM_CLOSEPAR:
4725
2/2
✓ Branch 0 taken 1400726 times.
✓ Branch 1 taken 6071 times.
 1406797 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4726 1400726 lbm_set_cdr(last_cell, ENC_SYM_NIL); // terminate the list
4727 1400726 ctx->r = first_cell;
4728 } else {
4729 6071 ctx->r = ENC_SYM_NIL;
4730 }
4731 1406797 lbm_stack_drop(&ctx->K, 3);
4732 /* Skip reading another token and apply the continuation */
4733 1406797 ctx->app_cont = true;
4734 1406797 return;
4735 12826 case ENC_SYM_DOT: {
4736 12826 lbm_value *rptr = stack_reserve(ctx, 4);
4737 12826 rptr[0] = READ_DOT_TERMINATE;
4738 12826 rptr[1] = stream;
4739 12826 rptr[2] = lbm_enc_u(0);
4740 12826 rptr[3] = READ_NEXT_TOKEN;
4741 12826 ctx->app_cont = true;
4742 12826 } return;
4743 }
4744 }
4745 8581147 lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
4746 // Does not return if merror. So we cannot get a read-error here
4747 // unless we write the a version of cons_with_gc here.
4748 //if (lbm_is_symbol_merror(new_cell)) {
4749 // lbm_channel_reader_close(str);
4750 // read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
4751 // return;
4752 //}
4753
2/2
✓ Branch 0 taken 7167576 times.
✓ Branch 1 taken 1413567 times.
 8581143 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4754 7167576 lbm_set_cdr(last_cell, new_cell);
4755 7167576 last_cell = new_cell;
4756 } else {
4757 1413567 first_cell = last_cell = new_cell;
4758 }
4759 8581143 sptr[0] = first_cell;
4760 8581143 sptr[1] = last_cell;
4761 //sptr[2] = stream; // unchanged.
4762 8581143 lbm_value *rptr = stack_reserve(ctx, 4);
4763 8581143 rptr[0] = READ_APPEND_CONTINUE;
4764 8581143 rptr[1] = stream;
4765 8581143 rptr[2] = lbm_enc_u(0);
4766 8581143 rptr[3] = READ_NEXT_TOKEN;
4767 8581143 ctx->app_cont = true;
4768 }
4769
4770 144508 static void cont_read_eval_continue(eval_context_t *ctx) {
4771 lbm_value env;
4772 lbm_value stream;
4773 144508 lbm_value *sptr = get_stack_ptr(ctx, 2);
4774 144508 env = sptr[1];
4775 144508 stream = sptr[0];
4776 144508 lbm_char_channel_t *str = lbm_dec_channel(stream);
4777
2/4
✓ Branch 0 taken 144508 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 144508 times.
✗ Branch 3 not taken.
 144508 if (str && str->state) {
4778 144508 ctx->row1 = (lbm_int)str->row(str);
4779
2/2
✓ Branch 0 taken 11205 times.
✓ Branch 1 taken 133303 times.
 144508 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4780
2/3
✓ Branch 0 taken 2 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 11203 times.
 11205 switch(ctx->r) {
4781 2 case ENC_SYM_CLOSEPAR:
4782 2 lbm_stack_drop(&ctx->K, 2);
4783 2 ctx->app_cont = true;
4784 2 return;
4785 ✗ case ENC_SYM_DOT:
4786 // A dot here is a syntax error.
4787 ✗ lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4788 ✗ READ_ERROR_CTX(lbm_channel_row(str),lbm_channel_column(str));
4789 return;
4790 }
4791 }
4792 144506 lbm_value *rptr = stack_reserve(ctx, 6);
4793 144506 rptr[0] = READ_EVAL_CONTINUE;
4794 144506 rptr[1] = stream;
4795 144506 rptr[2] = lbm_enc_u(1);
4796 144506 rptr[3] = READ_NEXT_TOKEN;
4797 144506 rptr[4] = lbm_enc_u(ctx->flags);
4798 144506 rptr[5] = POP_READER_FLAGS;
4799
4800 144506 ctx->curr_env = env;
4801 144506 ctx->curr_exp = ctx->r;
4802 } else {
4803 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4804 }
4805 }
4806
4807 12824 static void cont_read_expect_closepar(eval_context_t *ctx) {
4808 12824 lbm_value res = ctx->K.data[--ctx->K.sp];
4809 12824 lbm_value stream = ctx->K.data[--ctx->K.sp];
4810
4811 12824 lbm_char_channel_t *str = lbm_dec_channel(stream);
4812
2/4
✓ Branch 0 taken 12824 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 12824 times.
 12824 if (str == NULL || str->state == NULL) { // TODO: De Morgan these conditions.
4813 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4814 } else {
4815
2/2
✓ Branch 0 taken 12823 times.
✓ Branch 1 taken 1 times.
 12824 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4816
1/2
✓ Branch 0 taken 12823 times.
✗ Branch 1 not taken.
 12823 ctx->r == ENC_SYM_CLOSEPAR) {
4817 12823 ctx->r = res;
4818 12823 ctx->app_cont = true;
4819 } else {
4820 1 lbm_channel_reader_close(str);
4821 1 lbm_set_error_reason((char*)lbm_error_str_parse_close);
4822 1 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4823 }
4824 }
4825 12823 }
4826
4827 12826 static void cont_read_dot_terminate(eval_context_t *ctx) {
4828 12826 lbm_value *sptr = get_stack_ptr(ctx, 3);
4829
4830 12826 lbm_value last_cell = sptr[1];
4831 12826 lbm_value stream = sptr[2];
4832
4833 12826 lbm_char_channel_t *str = lbm_dec_channel(stream);
4834
2/4
✓ Branch 0 taken 12826 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 12826 times.
 12826 if (str == NULL || str->state == NULL) {
4835 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4836
2/2
✓ Branch 0 taken 3426 times.
✓ Branch 1 taken 9400 times.
 12826 } else if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4837
2/2
✓ Branch 0 taken 3425 times.
✓ Branch 1 taken 1 times.
 3426 (ctx->r == ENC_SYM_CLOSEPAR ||
4838
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 3425 times.
 3425 ctx->r == ENC_SYM_DOT)) {
4839 1 lbm_channel_reader_close(str);
4840 1 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4841 1 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4842
2/2
✓ Branch 0 taken 12824 times.
✓ Branch 1 taken 1 times.
 12825 } else if (lbm_is_cons(last_cell)) {
4843 12824 lbm_ref_cell(last_cell)->cdr = ctx->r;
4844 //lbm_set_cdr(last_cell, ctx->r);
4845 12824 ctx->r = sptr[0]; // first cell
4846 12824 lbm_value *rptr = stack_reserve(ctx, 3);
4847 12824 sptr[0] = stream;
4848 12824 sptr[1] = ctx->r;
4849 12824 sptr[2] = READ_EXPECT_CLOSEPAR;
4850 12824 rptr[0] = stream;
4851 12824 rptr[1] = lbm_enc_u(0);
4852 12824 rptr[2] = READ_NEXT_TOKEN;
4853 12824 ctx->app_cont = true;
4854 } else {
4855 1 lbm_channel_reader_close(str);
4856 1 lbm_set_error_reason((char*)lbm_error_str_parse_dot);
4857 1 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4858 }
4859 12824 }
4860
4861 663594 static void cont_read_done(eval_context_t *ctx) {
4862 //lbm_value reader_mode = ctx->K.data[--ctx->K.sp];
4863 663594 --ctx->K.sp;
4864 663594 lbm_value stream = ctx->K.data[--ctx->K.sp];
4865 663594 lbm_value f_val = ctx->K.data[--ctx->K.sp];
4866
4867 663594 uint32_t flags = lbm_dec_as_u32(f_val);
4868 663594 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
4869 663594 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
4870
4871 663594 lbm_char_channel_t *str = lbm_dec_channel(stream);
4872
2/4
✓ Branch 0 taken 663594 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 663594 times.
 663594 if (str == NULL || str->state == NULL) {
4873 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4874 } else {
4875 // the "else" is there to make INFER understand
4876 // that this only happens if str is non-null.
4877 // the "else" is unnecessary though as
4878 // error_ctx longjmps out.
4879 663594 lbm_channel_reader_close(str);
4880
2/2
✓ Branch 0 taken 45414 times.
✓ Branch 1 taken 618180 times.
 663594 if (lbm_is_symbol(ctx->r)) {
4881 45414 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4882
4/4
✓ Branch 0 taken 23354 times.
✓ Branch 1 taken 22060 times.
✓ Branch 2 taken 2 times.
✓ Branch 3 taken 23352 times.
 45414 if (sym_val >= TOKENIZER_SYMBOLS_START &&
4883 sym_val <= TOKENIZER_SYMBOLS_END) {
4884 2 READ_ERROR_CTX(lbm_channel_row(str), lbm_channel_column(str));
4885 }
4886 }
4887 663592 ctx->row0 = -1;
4888 663592 ctx->row1 = -1;
4889 663592 ctx->app_cont = true;
4890 }
4891 663592 }
4892
4893 86600 static void cont_wrap_result(eval_context_t *ctx) {
4894 lbm_value cell;
4895 86600 lbm_value wrapper = ctx->K.data[--ctx->K.sp];
4896
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 86600 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 86600 WITH_GC(cell, lbm_heap_allocate_list_init(2,
4897 wrapper,
4898 ctx->r));
4899 86600 ctx->r = cell;
4900 86600 ctx->app_cont = true;
4901 86600 }
4902
4903 536179962 static void cont_application_start(eval_context_t *ctx) {
4904
4905 /* sptr[0] = env
4906 * sptr[1] = args
4907 * ctx->r = function
4908 */
4909
4910
2/2
✓ Branch 0 taken 462221101 times.
✓ Branch 1 taken 73958861 times.
 536179962 if (lbm_is_symbol(ctx->r)) {
4911 462221101 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4912 462221101 cont_application_args(ctx);
4913
2/2
✓ Branch 0 taken 73958858 times.
✓ Branch 1 taken 4 times.
 73958861 } else if (lbm_is_cons(ctx->r)) {
4914 73958858 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4915 73958858 lbm_value args = (lbm_value)sptr[1];
4916
3/5
✓ Branch 0 taken 73944992 times.
✓ Branch 1 taken 392 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 13474 times.
✗ Branch 4 not taken.
 73958858 switch (lbm_ref_cell(ctx->r)->car) { // Already checked that is_cons
4917 73944992 case ENC_SYM_CLOSURE: {
4918 lbm_value cl[3];
4919 73944992 extract_n(get_cdr(ctx->r), cl, 3);
4920 73944992 lbm_value arg_env = (lbm_value)sptr[0];
4921 lbm_value arg0, arg_rest;
4922 73944992 get_car_and_cdr(args, &arg0, &arg_rest);
4923 73944992 sptr[1] = cl[CLO_BODY];
4924 73944992 bool a_nil = lbm_is_symbol_nil(args);
4925 73944992 bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS]);
4926 73944992 lbm_value *reserved = stack_reserve(ctx, 4);
4927
4928
4/4
✓ Branch 0 taken 55716060 times.
✓ Branch 1 taken 18228932 times.
✓ Branch 2 taken 55156004 times.
✓ Branch 3 taken 560056 times.
 73944992 if (!a_nil && !p_nil) {
4929 55156004 reserved[0] = cl[CLO_ENV];
4930 55156004 reserved[1] = cl[CLO_PARAMS];
4931 55156004 reserved[2] = arg_rest;
4932 55156004 reserved[3] = CLOSURE_ARGS;
4933 55156004 ctx->curr_exp = arg0;
4934 55156004 ctx->curr_env = arg_env;
4935
4/4
✓ Branch 0 taken 18228932 times.
✓ Branch 1 taken 560056 times.
✓ Branch 2 taken 18228930 times.
✓ Branch 3 taken 2 times.
 18788988 } else if (a_nil && p_nil) {
4936 // No params, No args
4937 18228930 lbm_stack_drop(&ctx->K, 6);
4938 18228930 ctx->curr_exp = cl[CLO_BODY];
4939 18228930 ctx->curr_env = cl[CLO_ENV];
4940
2/2
✓ Branch 0 taken 560056 times.
✓ Branch 1 taken 2 times.
 560058 } else if (p_nil) {
4941 560056 reserved[1] = get_cdr(args); // protect cdr(args) from allocate_binding
4942 560056 ctx->curr_exp = get_car(args); // protect car(args) from allocate binding
4943 560056 ctx->curr_env = arg_env;
4944 560056 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, cl[CLO_ENV]);
4945 560056 reserved[0] = rest_binder;
4946 560056 reserved[2] = get_car(rest_binder);
4947 560056 reserved[3] = CLOSURE_ARGS_REST;
4948 } else {
4949 2 lbm_set_error_reason((char*)lbm_error_str_num_args);
4950 2 ERROR_AT_CTX(ENC_SYM_EERROR, ctx->r);
4951 }
4952 73944990 } break;
4953 392 case ENC_SYM_CONT:{
4954 392 ctx->curr_exp = setup_cont(ctx, args);
4955 392 } break;
4956 ✗ case ENC_SYM_CONT_SP: {
4957 ✗ ctx->curr_exp = setup_cont_sp(ctx, args);
4958 ✗ return;
4959 } break;
4960 13474 case ENC_SYM_MACRO:{
4961 13474 lbm_value env = (lbm_value)sptr[0];
4962 13474 pop_stack_ptr(ctx, 2);
4963 setup_macro(ctx, args, env);
4964 13474 } break;
4965 ✗ default:
4966 ✗ ERROR_CTX(ENC_SYM_EERROR);
4967 }
4968 } else {
4969 4 lbm_set_error_reason(lbm_error_str_not_applicable);
4970 4 ERROR_AT_CTX(ENC_SYM_EERROR, ctx->r);
4971 }
4972 }
4973
4974 13698 static void cont_eval_r(eval_context_t* ctx) {
4975 13698 lbm_value env = ctx->K.data[--ctx->K.sp];
4976 13698 ctx->curr_exp = ctx->r;
4977 13698 ctx->curr_env = env;
4978 13698 }
4979
4980 1287526 static void cont_progn_var(eval_context_t* ctx) {
4981
4982 1287526 lbm_value key = ctx->K.data[--ctx->K.sp];
4983 1287526 lbm_value env = ctx->K.data[--ctx->K.sp];
4984 1287526 fill_binding_location(key, ctx->r, env);
4985
4986 1287526 ctx->curr_env = env; // evaluating value may build upon local env.
4987 1287526 ctx->app_cont = true;
4988 1287526 }
4989
4990 4593055 static void cont_setq(eval_context_t *ctx) {
4991 4593055 lbm_value sym = ctx->K.data[--ctx->K.sp];
4992 4593055 lbm_value env = ctx->K.data[--ctx->K.sp];
4993 lbm_value res;
4994
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 4592942 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 4593055 WITH_GC(res, perform_setvar(sym, ctx->r, env));
4995 4592942 ctx->r = res;
4996 4592942 ctx->app_cont = true;
4997 4592942 }
4998
4999 4573 lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
5000
5001 lbm_value flash_cell;
5002 4573 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
5003
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 4573 times.
 4573 if (s != LBM_FLASH_WRITE_OK)
5004 ✗ return s;
5005 4573 lbm_value new_val = val;
5006 4573 new_val &= ~LBM_PTR_VAL_MASK; // clear the value part of the ptr
5007 4573 new_val |= (flash_cell & LBM_PTR_VAL_MASK);
5008 4573 new_val |= LBM_PTR_TO_CONSTANT_BIT;
5009 4573 *res = new_val;
5010 4573 return s;
5011 }
5012
5013 1680 static void cont_move_to_flash(eval_context_t *ctx) {
5014
5015 1680 lbm_value args = ctx->K.data[--ctx->K.sp];
5016
5017
2/2
✓ Branch 0 taken 728 times.
✓ Branch 1 taken 952 times.
 1680 if (lbm_is_symbol_nil(args)) {
5018 // Done looping over arguments. return true.
5019 728 ctx->r = ENC_SYM_TRUE;
5020 728 ctx->app_cont = true;
5021 728 return;
5022 }
5023
5024 lbm_value first_arg, rest;
5025 952 get_car_and_cdr(args, &first_arg, &rest);
5026
5027 lbm_value val;
5028
2/4
✓ Branch 0 taken 952 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 952 times.
✗ Branch 3 not taken.
 952 if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
5029 // Prepare to copy the rest of the arguments when done with first.
5030 952 lbm_value *rptr = stack_reserve(ctx, 2);
5031 952 rptr[0] = rest;
5032 952 rptr[1] = MOVE_TO_FLASH;
5033
2/2
✓ Branch 0 taken 812 times.
✓ Branch 1 taken 140 times.
 952 if (lbm_is_ptr(val) &&
5034
1/2
✓ Branch 0 taken 812 times.
✗ Branch 1 not taken.
 812 (!(val & LBM_PTR_TO_CONSTANT_BIT))) {
5035 812 lbm_value * rptr1 = stack_reserve(ctx, 3);
5036 812 rptr1[0] = first_arg;
5037 812 rptr1[1] = SET_GLOBAL_ENV;
5038 812 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH;
5039 812 ctx->r = val;
5040 }
5041 952 ctx->app_cont = true;
5042 952 return;
5043 }
5044 ✗ ERROR_CTX(ENC_SYM_EERROR);
5045 }
5046
5047 6663 static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
5048
5049 6663 lbm_value val = ctx->r;
5050
5051
2/2
✓ Branch 0 taken 1599 times.
✓ Branch 1 taken 5064 times.
 6663 if (lbm_is_cons(val)) { // non-constant cons-cell
5052 1599 lbm_value *rptr = stack_reserve(ctx, 5);
5053 1599 rptr[0] = ENC_SYM_NIL; // fst cell of list
5054 1599 rptr[1] = ENC_SYM_NIL; // last cell of list
5055 1599 rptr[2] = get_cdr(val);
5056 1599 rptr[3] = MOVE_LIST_TO_FLASH;
5057 1599 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
5058 1599 ctx->r = lbm_ref_cell(val)->car; // already checked is_cons
5059 1599 ctx->app_cont = true;
5060 1599 return;
5061 }
5062
5063
3/4
✓ Branch 0 taken 420 times.
✓ Branch 1 taken 4644 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 420 times.
 5064 if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT)) { // constant pointer cons or not.
5064 //ctx->r unchanged
5065 ✗ ctx->app_cont = true;
5066 ✗ return;
5067 }
5068
5069
2/2
✓ Branch 0 taken 420 times.
✓ Branch 1 taken 4644 times.
 5064 if (lbm_is_ptr(val)) { // something that is not a cons but still a ptr type.
5070 420 lbm_cons_t *ref = lbm_ref_cell(val);
5071
1/2
✓ Branch 0 taken 420 times.
✗ Branch 1 not taken.
 420 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL) {
5072
4/6
✓ Branch 0 taken 196 times.
✓ Branch 1 taken 56 times.
✓ Branch 2 taken 56 times.
✓ Branch 3 taken 112 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
 420 switch (ref->cdr) {
5073 196 case ENC_SYM_RAW_I_TYPE: /* fall through */
5074 case ENC_SYM_RAW_U_TYPE:
5075 case ENC_SYM_RAW_F_TYPE: {
5076 196 lbm_value flash_cell = ENC_SYM_NIL;
5077 196 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5078 196 handle_flash_status(write_const_car(flash_cell, ref->car));
5079 196 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
5080 196 ctx->r = flash_cell;
5081 196 } break;
5082 56 case ENC_SYM_IND_I_TYPE: /* fall through */
5083 case ENC_SYM_IND_U_TYPE:
5084 case ENC_SYM_IND_F_TYPE: {
5085 #ifndef LBM64
5086 /* 64 bit values are in lbm mem on 32bit platforms. */
5087 56 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
5088 lbm_uint flash_ptr;
5089
5090 56 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
5091 56 lbm_value flash_cell = ENC_SYM_NIL;
5092 56 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5093 56 handle_flash_status(write_const_car(flash_cell, flash_ptr));
5094 56 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
5095 56 ctx->r = flash_cell;
5096 #else
5097 // There are no indirect types in LBM64
5098 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
5099 #endif
5100 56 } break;
5101 56 case ENC_SYM_LISPARRAY_TYPE: {
5102 56 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
5103 56 lbm_uint size = arr->size / sizeof(lbm_uint);
5104 56 lbm_uint flash_addr = 0;
5105 56 lbm_value *arrdata = (lbm_value *)arr->data;
5106 56 lbm_value flash_cell = ENC_SYM_NIL;
5107 56 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5108 56 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
5109 56 lift_array_flash(flash_cell,
5110 false,
5111 (char *)flash_addr,
5112 arr->size);
5113 // Move array contents to flash recursively
5114 56 lbm_value *rptr = stack_reserve(ctx, 5);
5115 56 rptr[0] = flash_cell;
5116 56 rptr[1] = lbm_enc_u(0);
5117 56 rptr[2] = val;
5118 56 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH;
5119 56 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
5120 56 ctx->r = arrdata[0];
5121 56 ctx->app_cont = true;
5122 56 return;
5123 }
5124 112 case ENC_SYM_ARRAY_TYPE: {
5125 112 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
5126 // arbitrary address: flash_arr.
5127 112 lbm_uint flash_arr = 0;
5128 112 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
5129 112 lbm_value flash_cell = ENC_SYM_NIL;
5130 112 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5131 112 lift_array_flash(flash_cell,
5132 true,
5133 (char *)flash_arr,
5134 arr->size);
5135 112 ctx->r = flash_cell;
5136 112 } break;
5137 ✗ case ENC_SYM_CHANNEL_TYPE: /* fall through */
5138 case ENC_SYM_CUSTOM_TYPE:
5139 ✗ lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
5140 ✗ ERROR_CTX(ENC_SYM_EERROR);
5141 }
5142 } else {
5143 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
5144 }
5145 364 ctx->app_cont = true;
5146 364 return;
5147 }
5148
5149 // if no condition matches, nothing happens (id).
5150 4644 ctx->r = val;
5151 4644 ctx->app_cont = true;
5152 }
5153
5154 4041 static void cont_move_list_to_flash(eval_context_t *ctx) {
5155
5156 // ctx->r holds the value that should go in car
5157
5158 4041 lbm_value *sptr = get_stack_ptr(ctx, 3);
5159
5160 4041 lbm_value fst = sptr[0];
5161 4041 lbm_value lst = sptr[1];
5162 4041 lbm_value val = sptr[2];
5163
5164
5165 4041 lbm_value new_lst = ENC_SYM_NIL;
5166 // Allocate element ptr storage after storing the element to flash.
5167 4041 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL), &new_lst));
5168
5169
2/2
✓ Branch 0 taken 1599 times.
✓ Branch 1 taken 2442 times.
 4041 if (lbm_is_symbol_nil(fst)) {
5170 1599 lst = new_lst;
5171 1599 fst = new_lst;
5172 1599 handle_flash_status(write_const_car(lst, ctx->r));
5173 } else {
5174 2442 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
5175 2442 handle_flash_status(write_const_car(new_lst, ctx->r));
5176 2442 lst = new_lst;
5177 }
5178
5179
2/2
✓ Branch 0 taken 2442 times.
✓ Branch 1 taken 1599 times.
 4041 if (lbm_is_cons(val)) {
5180 2442 sptr[0] = fst;
5181 2442 sptr[1] = lst;//rest_cell;
5182 2442 sptr[2] = lbm_ref_cell(val)->cdr;
5183 2442 lbm_value *rptr = stack_reserve(ctx, 2);
5184 2442 rptr[0] = MOVE_LIST_TO_FLASH;
5185 2442 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
5186 2442 ctx->r = lbm_ref_cell(val)->car; // already checked is_cons
5187 } else {
5188 1599 sptr[0] = fst;
5189 1599 sptr[1] = lst;
5190 1599 sptr[2] = CLOSE_LIST_IN_FLASH;
5191 1599 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
5192 1599 ctx->r = val;
5193 }
5194 4041 ctx->app_cont = true;
5195 4041 }
5196
5197 1599 static void cont_close_list_in_flash(eval_context_t *ctx) {
5198 1599 lbm_value lst = ctx->K.data[--ctx->K.sp];
5199 1599 lbm_value fst = ctx->K.data[--ctx->K.sp];
5200 1599 lbm_value val = ctx->r;
5201 1599 handle_flash_status(write_const_cdr(lst, val));
5202 1599 ctx->r = fst;
5203 1599 ctx->app_cont = true;
5204 1599 }
5205
5206 168 static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
5207 168 lbm_value *sptr = get_stack_ptr(ctx, 3);
5208 // sptr[2] = source array in RAM
5209 // sptr[1] = current index
5210 // sptr[0] = target array in flash
5211 168 lbm_array_header_t *src_arr = assume_array(sptr[2]);
5212 168 lbm_uint size = src_arr->size / sizeof(lbm_uint);
5213 168 lbm_value *srcdata = (lbm_value *)src_arr->data;
5214
5215 168 lbm_array_header_t *tgt_arr = assume_array(sptr[0]);
5216 168 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
5217 168 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
5218 168 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
5219
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 112 times.
 168 if (ix >= size-1) {
5220 56 ctx->r = sptr[0];
5221 56 lbm_stack_drop(&ctx->K, 3);
5222 56 ctx->app_cont = true;
5223 56 return;
5224 }
5225 112 sptr[1] = lbm_enc_u(ix + 1);
5226 112 lbm_value *rptr = stack_reserve(ctx, 2);
5227 112 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH;
5228 112 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
5229 112 ctx->r = srcdata[ix+1];
5230 112 ctx->app_cont = true;
5231 112 return;
5232 }
5233
5234 10139 static void cont_qq_expand_start(eval_context_t *ctx) {
5235 10139 lbm_value *rptr = stack_reserve(ctx, 2);
5236 10139 rptr[0] = ctx->r;
5237 10139 rptr[1] = QQ_EXPAND;
5238 10139 ctx->r = ENC_SYM_NIL;
5239 10139 ctx->app_cont = true;
5240 10139 }
5241
5242 20499 lbm_value quote_it(lbm_value qquoted) {
5243
3/4
✓ Branch 0 taken 19603 times.
✓ Branch 1 taken 896 times.
✓ Branch 2 taken 19603 times.
✗ Branch 3 not taken.
 40102 if (lbm_is_symbol(qquoted) &&
5244 39206 lbm_is_special(qquoted)) return qquoted;
5245
5246 896 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL, ENC_SYM_NIL);
5247 896 return cons_with_gc(ENC_SYM_QUOTE, val, ENC_SYM_NIL);
5248 }
5249
5250 75500 bool is_append(lbm_value a) {
5251
1/2
✓ Branch 0 taken 75164 times.
✗ Branch 1 not taken.
 150664 return (lbm_is_cons(a) &&
5252
2/2
✓ Branch 0 taken 75164 times.
✓ Branch 1 taken 336 times.
 150664 lbm_is_symbol(lbm_ref_cell(a)->car) &&
5253
2/2
✓ Branch 0 taken 37078 times.
✓ Branch 1 taken 38086 times.
 75164 (lbm_ref_cell(a)->car == ENC_SYM_APPEND));
5254 }
5255
5256 127141 lbm_value append(lbm_value front, lbm_value back) {
5257
2/2
✓ Branch 0 taken 68500 times.
✓ Branch 1 taken 58641 times.
 127141 if (lbm_is_symbol_nil(front)) return back;
5258
2/2
✓ Branch 0 taken 19603 times.
✓ Branch 1 taken 39038 times.
 58641 if (lbm_is_symbol_nil(back)) return front;
5259
5260
4/4
✓ Branch 0 taken 20723 times.
✓ Branch 1 taken 18315 times.
✓ Branch 2 taken 896 times.
✓ Branch 3 taken 19827 times.
 59761 if (lbm_is_quoted_list(front) &&
5261 20723 lbm_is_quoted_list(back)) {
5262 896 lbm_value f = get_cadr(front);
5263 896 lbm_value b = get_cadr(back);
5264 896 return quote_it(lbm_list_append(f, b));
5265 }
5266
5267
4/4
✓ Branch 0 taken 18931 times.
✓ Branch 1 taken 19211 times.
✓ Branch 2 taken 784 times.
✓ Branch 3 taken 18147 times.
 57073 if (is_append(back) &&
5268
1/2
✓ Branch 0 taken 784 times.
✗ Branch 1 not taken.
 19715 lbm_is_quoted_list(get_cadr(back)) &&
5269 784 lbm_is_quoted_list(front)) {
5270 784 lbm_value ql = get_cadr(back);
5271 784 lbm_value f = get_cadr(front);
5272 784 lbm_value b = get_cadr(ql);
5273
5274 784 lbm_value v = lbm_list_append(f, b);
5275 784 lbm_set_car(get_cdr(ql), v);
5276 784 return back;
5277 }
5278
5279
2/2
✓ Branch 0 taken 18147 times.
✓ Branch 1 taken 19211 times.
 37358 if (is_append(back)) {
5280 18147 back = get_cdr(back);
5281 18147 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL);
5282 18147 return cons_with_gc(ENC_SYM_APPEND, new, ENC_SYM_NIL);
5283 }
5284
5285 lbm_value t0, t1;
5286
5287 19211 t0 = cons_with_gc(back, ENC_SYM_NIL, front);
5288 19211 t1 = cons_with_gc(front, t0, ENC_SYM_NIL);
5289 19211 return cons_with_gc(ENC_SYM_APPEND, t1, ENC_SYM_NIL);
5290 }
5291
5292 // ////////////////////////////////////////////////////////////
5293 // Quasiquotation expansion that takes place at read time
5294 // and is based on the paper by Bawden "Quasiquotation in lisp".
5295 // Bawden, Alan. "Quasiquotation in Lisp." PEPM. 1999.
5296 //
5297 // cont_qq_expand and cont_qq_expand_list corresponds (mostly) to
5298 // qq-expand and qq-expand-list in the paper.
5299 // One difference is that the case where a backquote is nested
5300 // inside of a backqoute is handled via the recursion through the
5301 // reader.
5302
5303 /* Bawden's qq-expand implementation
5304 (define (qq-expand x)
5305 (cond ((tag-comma? x)
5306 (tag-data x))
5307 ((tag-comma-atsign? x)
5308 (error "Illegal"))
5309 ((tag-backquote? x)
5310 (qq-expand
5311 (qq-expand (tag-data x))))
5312 ((pair? x)
5313 `(append
5314 ,(qq-expand-list (car x))
5315 ,(qq-expand (cdr x))))
5316 (else `',x)))
5317 */
5318 68780 static void cont_qq_expand(eval_context_t *ctx) {
5319 68780 lbm_value qquoted = ctx->K.data[--ctx->K.sp];
5320
5321
2/2
✓ Branch 0 taken 49177 times.
✓ Branch 1 taken 19603 times.
 68780 switch(lbm_type_of(qquoted)) {
5322 49177 case LBM_TYPE_CONS: {
5323 49177 lbm_value car_val = get_car(qquoted);
5324 49177 lbm_value cdr_val = get_cdr(qquoted);
5325
4/4
✓ Branch 0 taken 10085 times.
✓ Branch 1 taken 39092 times.
✓ Branch 2 taken 56 times.
✓ Branch 3 taken 10029 times.
 49177 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5326 car_val == ENC_SYM_COMMA) {
5327 56 ctx->r = append(ctx->r, get_car(cdr_val));
5328 56 ctx->app_cont = true;
5329
3/4
✓ Branch 0 taken 10029 times.
✓ Branch 1 taken 39092 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 10029 times.
 49121 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5330 car_val == ENC_SYM_COMMAAT) {
5331 ✗ lbm_set_error_reason((char*)lbm_error_str_qq_expand);
5332 ✗ ERROR_AT_CTX(ENC_SYM_RERROR, qquoted);
5333 } else {
5334 49121 lbm_value *rptr = stack_reserve(ctx, 6);
5335 49121 rptr[0] = ctx->r;
5336 49121 rptr[1] = QQ_APPEND;
5337 49121 rptr[2] = cdr_val;
5338 49121 rptr[3] = QQ_EXPAND;
5339 49121 rptr[4] = car_val;
5340 49121 rptr[5] = QQ_EXPAND_LIST;
5341 49121 ctx->app_cont = true;
5342 49121 ctx->r = ENC_SYM_NIL;
5343 }
5344
5345 49177 } break;
5346 19603 default: {
5347 19603 lbm_value res = quote_it(qquoted);
5348 19603 ctx->r = append(ctx->r, res);
5349 19603 ctx->app_cont = true;
5350 }
5351 }
5352 68780 }
5353
5354 58641 static void cont_qq_append(eval_context_t *ctx) {
5355 58641 lbm_value head = ctx->K.data[--ctx->K.sp];
5356 58641 ctx->r = append(head, ctx->r);
5357 58641 ctx->app_cont = true;
5358 58641 }
5359
5360 /* Bawden's qq-expand-list implementation
5361 (define (qq-expand-list x)
5362 (cond ((tag-comma? x)
5363 `(list ,(tag-data x)))
5364 ((tag-comma-atsign? x)
5365 (tag-data x))
5366 ((tag-backquote? x)
5367 (qq-expand-list
5368 (qq-expand (tag-data x))))
5369 ((pair? x)
5370 `(list
5371 (append
5372 ,(qq-expand-list (car x))
5373 ,(qq-expand (cdr x)))))
5374 (else `'(,x))))
5375 */
5376
5377 58641 static void cont_qq_expand_list(eval_context_t* ctx) {
5378 58641 lbm_value l = ctx->K.data[--ctx->K.sp];
5379
5380 58641 ctx->app_cont = true;
5381
2/2
✓ Branch 0 taken 37467 times.
✓ Branch 1 taken 21174 times.
 58641 switch(lbm_type_of(l)) {
5382 37467 case LBM_TYPE_CONS: {
5383 37467 lbm_value car_val = get_car(l);
5384 37467 lbm_value cdr_val = get_cdr(l);
5385
3/4
✓ Branch 0 taken 37467 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 27667 times.
✓ Branch 3 taken 9800 times.
 37467 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5386 car_val == ENC_SYM_COMMA) {
5387 27667 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL);
5388 27667 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL);
5389 27667 ctx->r = append(ctx->r, tmp);
5390 27667 return;
5391
3/4
✓ Branch 0 taken 9800 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 280 times.
✓ Branch 3 taken 9520 times.
 9800 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5392 car_val == ENC_SYM_COMMAAT) {
5393 280 lbm_value cadr_val = get_car(cdr_val);
5394 280 ctx->r = cadr_val;
5395 280 return;
5396 } else {
5397 9520 lbm_value *rptr = stack_reserve(ctx, 7);
5398 9520 rptr[0] = QQ_LIST;
5399 9520 rptr[1] = ctx->r;
5400 9520 rptr[2] = QQ_APPEND;
5401 9520 rptr[3] = cdr_val;
5402 9520 rptr[4] = QQ_EXPAND;
5403 9520 rptr[5] = car_val;
5404 9520 rptr[6] = QQ_EXPAND_LIST;
5405 9520 ctx->r = ENC_SYM_NIL;
5406 }
5407
5408 9520 } break;
5409 21174 default: {
5410 21174 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL, ENC_SYM_NIL);
5411 21174 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL, ENC_SYM_NIL);
5412 21174 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE, tl, ENC_SYM_NIL);
5413 21174 ctx->r = append(ctx->r, tmp);
5414 }
5415 }
5416 }
5417
5418 9520 static void cont_qq_list(eval_context_t *ctx) {
5419 9520 lbm_value val = ctx->r;
5420 9520 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL, ENC_SYM_NIL);
5421 9520 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, apnd_app, ENC_SYM_NIL);
5422 9520 ctx->r = tmp;
5423 9520 ctx->app_cont = true;
5424 9520 }
5425
5426 167 static void cont_kill(eval_context_t *ctx) {
5427 (void) ctx;
5428 167 ok_ctx();
5429 167 }
5430
5431 144494 static void cont_pop_reader_flags(eval_context_t *ctx) {
5432 144494 lbm_value flags = ctx->K.data[--ctx->K.sp];
5433 144494 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
5434 144494 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
5435 // r is unchanged.
5436 144494 ctx->app_cont = true;
5437 144494 }
5438
5439 // cont_exception_handler
5440 //
5441 // s[sp-2] retval - a list of 2 elements created by eval_trap
5442 // s[sp-1] flags - context flags stored by eval_trap
5443 //
5444 16896 static void cont_exception_handler(eval_context_t *ctx) {
5445 16896 lbm_value *sptr = pop_stack_ptr(ctx, 2);
5446 16896 lbm_value retval = sptr[0];
5447 16896 lbm_value flags = sptr[1];
5448 16896 lbm_set_car(get_cdr(retval), ctx->r);
5449 16896 ctx->flags = (uint32_t)flags;
5450 16896 ctx->r = retval;
5451 16896 ctx->app_cont = true;
5452 16896 }
5453
5454 // cont_recv_to:
5455 //
5456 // s[sp-1] = patterns
5457 //
5458 // ctx->r = timeout value
5459 392 static void cont_recv_to(eval_context_t *ctx) {
5460
1/2
✓ Branch 0 taken 392 times.
✗ Branch 1 not taken.
 392 if (lbm_is_number(ctx->r)) {
5461 392 lbm_value *sptr = get_stack_ptr(ctx, 1); // patterns at sptr[0]
5462 392 float timeout_time = lbm_dec_as_float(ctx->r);
5463
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 336 times.
 392 if (timeout_time < 0.0) timeout_time = 0.0; // clamp.
5464
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 280 times.
 392 if (ctx->num_mail > 0) {
5465 lbm_value e;
5466 112 lbm_value new_env = ctx->curr_env;
5467 112 int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
5468
1/2
✓ Branch 0 taken 112 times.
✗ Branch 1 not taken.
 112 if (n >= 0) { // match
5469 112 mailbox_remove_mail(ctx, (lbm_uint)n);
5470 112 ctx->curr_env = new_env;
5471 112 ctx->curr_exp = e;
5472 112 lbm_stack_drop(&ctx->K, 1);
5473 112 return;
5474 }
5475 }
5476 // If no mail or no match, go to sleep
5477 280 lbm_uint *rptr = stack_reserve(ctx,2);
5478 280 rptr[0] = ctx->r;
5479 280 rptr[1] = RECV_TO_RETRY;
5480 280 block_current_ctx(LBM_THREAD_STATE_RECV_TO,S_TO_US(timeout_time),true);
5481 } else {
5482 ✗ ERROR_CTX(ENC_SYM_TERROR);
5483 }
5484 }
5485
5486 // cont_recv_to_retry
5487 //
5488 // s[sp-2] = patterns
5489 // s[sp-1] = timeout value
5490 //
5491 // ctx->r = nonsense | timeout symbol
5492 280 static void cont_recv_to_retry(eval_context_t *ctx) {
5493 280 lbm_value *sptr = get_stack_ptr(ctx, 2); //sptr[0] = patterns, sptr[1] = timeout
5494
5495
1/2
✓ Branch 0 taken 280 times.
✗ Branch 1 not taken.
 280 if (ctx->num_mail > 0) {
5496 lbm_value e;
5497 280 lbm_value new_env = ctx->curr_env;
5498 280 int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
5499
2/2
✓ Branch 0 taken 112 times.
✓ Branch 1 taken 168 times.
 280 if (n >= 0) { // match
5500 112 mailbox_remove_mail(ctx, (lbm_uint)n);
5501 112 ctx->curr_env = new_env;
5502 112 ctx->curr_exp = e;
5503 112 lbm_stack_drop(&ctx->K, 2);
5504 112 return;
5505 }
5506 }
5507
5508 // No message matched but the timeout was reached.
5509 // This is like having a recv-to with no case that matches
5510 // the timeout symbol.
5511
1/2
✓ Branch 0 taken 168 times.
✗ Branch 1 not taken.
 168 if (ctx->r == ENC_SYM_TIMEOUT) {
5512 168 lbm_stack_drop(&ctx->K, 2);
5513 168 ctx->app_cont = true;
5514 168 return;
5515 }
5516
5517 ✗ stack_reserve(ctx,1)[0] = RECV_TO_RETRY;
5518 ✗ reblock_current_ctx(LBM_THREAD_STATE_RECV_TO,true);
5519 }
5520
5521
5522 /*********************************************************/
5523 /* Continuations table */
5524 typedef void (*cont_fun)(eval_context_t *);
5525
5526 static const cont_fun continuations[NUM_CONTINUATIONS] =
5527 { advance_ctx, // CONT_DONE
5528 cont_set_global_env,
5529 cont_bind_to_key_rest,
5530 cont_if,
5531 cont_progn_rest,
5532 cont_application_args,
5533 cont_and,
5534 cont_or,
5535 cont_wait,
5536 cont_match,
5537 cont_application_start,
5538 cont_eval_r,
5539 cont_resume,
5540 cont_closure_application_args,
5541 cont_exit_atomic,
5542 cont_read_next_token,
5543 cont_read_append_continue,
5544 cont_read_eval_continue,
5545 cont_read_expect_closepar,
5546 cont_read_dot_terminate,
5547 cont_read_done,
5548 cont_read_start_bytearray,
5549 cont_read_append_bytearray,
5550 cont_map,
5551 cont_match_guard,
5552 cont_terminate,
5553 cont_progn_var,
5554 cont_setq,
5555 cont_move_to_flash,
5556 cont_move_val_to_flash_dispatch,
5557 cont_move_list_to_flash,
5558 cont_close_list_in_flash,
5559 cont_qq_expand_start,
5560 cont_qq_expand,
5561 cont_qq_append,
5562 cont_qq_expand_list,
5563 cont_qq_list,
5564 cont_kill,
5565 cont_loop,
5566 cont_loop_condition,
5567 cont_merge_rest,
5568 cont_merge_layer,
5569 cont_closure_args_rest,
5570 cont_move_array_elts_to_flash,
5571 cont_pop_reader_flags,
5572 cont_exception_handler,
5573 cont_recv_to,
5574 cont_wrap_result,
5575 cont_recv_to_retry,
5576 cont_read_start_array,
5577 cont_read_append_array,
5578 cont_loop_env_prep,
5579 };
5580
5581 /*********************************************************/
5582 /* Evaluators lookup table (special forms) */
5583 typedef void (*evaluator_fun)(eval_context_t *);
5584
5585 static const evaluator_fun evaluators[] =
5586 {
5587 eval_quote,
5588 eval_define,
5589 eval_progn,
5590 eval_lambda,
5591 eval_if,
5592 eval_let,
5593 eval_and,
5594 eval_or,
5595 eval_match,
5596 eval_receive,
5597 eval_receive_timeout,
5598 eval_callcc,
5599 eval_atomic,
5600 eval_selfevaluating, // macro
5601 eval_selfevaluating, // cont
5602 eval_selfevaluating, // closure
5603 eval_cond,
5604 eval_app_cont,
5605 eval_var,
5606 eval_setq,
5607 eval_move_to_flash,
5608 eval_loop,
5609 eval_trap,
5610 eval_call_cc_unsafe,
5611 eval_selfevaluating, // cont_sp
5612 };
5613
5614
5615 /*********************************************************/
5616 /* Evaluator step function */
5617
5618 4059960309 static void evaluation_step(void){
5619 4059960309 eval_context_t *ctx = ctx_running;
5620
5621
2/2
✓ Branch 0 taken 1944716492 times.
✓ Branch 1 taken 2115243817 times.
 4059960309 if (ctx->app_cont) {
5622 1944716492 lbm_value k = ctx->K.data[--ctx->K.sp];
5623 1944716492 ctx->app_cont = false;
5624
5625 1944716492 lbm_uint decoded_k = DEC_CONTINUATION(k);
5626 // If app_cont is true, then top of stack must be a valid continuation!
5627 // If top of stack is not a valid continuation CRASH!
5628 1944716492 continuations[decoded_k](ctx);
5629 1944699927 return;
5630 }
5631
5632
2/2
✓ Branch 0 taken 900576753 times.
✓ Branch 1 taken 1214667065 times.
 2115243817 if (lbm_is_symbol(ctx->curr_exp)) {
5633 900576753 eval_symbol(ctx);
5634 900576576 return;
5635 }
5636
2/2
✓ Branch 0 taken 714692645 times.
✓ Branch 1 taken 499974421 times.
 1214667065 if (lbm_is_cons(ctx->curr_exp)) {
5637 714692645 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
5638 714692645 lbm_value h = cell->car;
5639
4/4
✓ Branch 0 taken 714687434 times.
✓ Branch 1 taken 5211 times.
✓ Branch 2 taken 178514756 times.
✓ Branch 3 taken 536172678 times.
 714692645 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK) == ENC_SPECIAL_FORMS_BIT)) {
5640 178514756 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK;
5641 178514756 evaluators[eval_index](ctx);
5642 178514570 return;
5643 }
5644 /*
5645 * At this point head can be anything. It should evaluate
5646 * into a form that can be applied (closure, symbol, ...) though.
5647 */
5648 536177889 lbm_value *reserved = stack_reserve(ctx, 3);
5649 536177888 reserved[0] = ctx->curr_env; // INFER: stack_reserve aborts context if error.
5650 536177888 reserved[1] = cell->cdr;
5651 536177888 reserved[2] = APPLICATION_START;
5652 536177888 ctx->curr_exp = h; // evaluate the function
5653 536177888 return;
5654 }
5655
5656 499974421 eval_selfevaluating(ctx);
5657 499974423 return;
5658 }
5659
5660 // Placed down here since it depends on a lot of things.
5661 // (apply fun arg-list)
5662 11202078 static void apply_apply(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
5663
4/4
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 11202076 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 1 times.
 11202078 if (nargs == 2 || lbm_is_list(args[1])) {
5664 11202077 lbm_value fun = args[0];
5665 11202077 lbm_value arg_list = args[1];
5666
5667 11202077 lbm_stack_drop(&ctx->K, nargs+1);
5668
5669
2/2
✓ Branch 0 taken 1121179 times.
✓ Branch 1 taken 10080898 times.
 11202077 if (lbm_is_symbol(fun)) {
5670
2/2
✓ Branch 0 taken 1064 times.
✓ Branch 1 taken 1120115 times.
 1121179 if ((fun & ENC_SPECIAL_FORMS_MASK) == ENC_SPECIAL_FORMS_BIT) {
5671 // Since the special form evaluators are responsible for conditionally
5672 // evaluating their arguments there is no easy way to prevent them
5673 // evaluating their arguments. Therefore we compromise and allow them to do
5674 // so, even if this isn't always how you would expect apply to work.
5675 // For instance, `(apply and '(a))` would try evaluating the symbol `a`,
5676 // instead of just returning the symbol `a` outright.
5677
5678 // Evaluator functions expect the current expression to equal the special
5679 // form, i.e. including the function symbol.
5680 1064 lbm_value fun_and_args = cons_with_gc(fun, arg_list, ENC_SYM_NIL);
5681 1064 ctx->curr_exp = fun_and_args;
5682 1064 lbm_uint eval_index = lbm_dec_sym(fun) & SPECIAL_FORMS_INDEX_MASK;
5683 1064 evaluators[eval_index](ctx);
5684 1064 return;
5685 } else { // lbm_is_symbol(fun)
5686 1120115 stack_reserve(ctx, 1)[0] = fun;
5687 1120115 size_t arg_count = 0;
5688
2/2
✓ Branch 0 taken 11200379 times.
✓ Branch 1 taken 1120115 times.
 12320494 for (lbm_value current = arg_list; lbm_is_cons(current); current = lbm_ref_cell(current)->cdr) {
5689 11200379 stack_reserve(ctx, 1)[0] = lbm_ref_cell(current)->car;
5690 11200379 arg_count++;
5691 }
5692 1120115 lbm_value *fun_and_args = get_stack_ptr(ctx, arg_count + 1);
5693 1120115 application(ctx, fun_and_args, arg_count);
5694 1120115 return;
5695 }
5696
2/2
✓ Branch 0 taken 10080896 times.
✓ Branch 1 taken 2 times.
 10080898 } else if (lbm_is_cons(fun)) {
5697
4/5
✓ Branch 0 taken 10080336 times.
✓ Branch 1 taken 168 times.
✓ Branch 2 taken 168 times.
✓ Branch 3 taken 224 times.
✗ Branch 4 not taken.
 10080896 switch (lbm_ref_cell(fun)->car) {
5698 10080336 case ENC_SYM_CLOSURE: {
5699 lbm_value closure[3];
5700 10080336 extract_n(get_cdr(fun), closure, 3);
5701
5702 // Only placed here to protect from GC. Will be overriden later.
5703 // ctx->r = arg_list; // Should already be placed there.
5704 10080336 ctx->curr_exp = fun;
5705
5706 10080336 lbm_value env = closure[CLO_ENV];
5707
5708 10080336 lbm_value current_params = closure[CLO_PARAMS];
5709 10080336 lbm_value current_args = arg_list;
5710
5711 95200280 while (true) {
5712 105280616 bool params_empty = !lbm_is_cons(current_params);
5713 105280616 bool args_empty = !lbm_is_cons(current_args);
5714
3/4
✓ Branch 0 taken 95200280 times.
✓ Branch 1 taken 10080336 times.
✓ Branch 2 taken 95200280 times.
✗ Branch 3 not taken.
 105280616 if (!params_empty && !args_empty) {
5715 95200280 lbm_cons_t *p_cell = lbm_ref_cell(current_params);
5716 95200280 lbm_cons_t *a_cell = lbm_ref_cell(current_args);
5717 95200280 lbm_value car_params = p_cell->car;
5718 95200280 lbm_value car_args = a_cell->car;
5719 95200280 lbm_value cdr_params = p_cell->cdr;
5720 95200280 lbm_value cdr_args = a_cell->cdr;
5721 //get_car_and_cdr(current_params, &car_params, &cdr_params);
5722 //get_car_and_cdr(current_args, &car_args, &cdr_args);
5723
5724 // More parameters to bind
5725 95200280 env = allocate_binding(
5726 car_params,
5727 car_args,
5728 env
5729 );
5730
5731 95200280 current_params = cdr_params;
5732 95200280 current_args = cdr_args;
5733
3/4
✓ Branch 0 taken 10080336 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 560168 times.
✓ Branch 3 taken 9520168 times.
 10080336 } else if (params_empty && !args_empty) {
5734 // More arguments but all parameters have been bound
5735 560168 env = allocate_binding(ENC_SYM_REST_ARGS, current_args, env);
5736 560168 break;
5737
2/4
✓ Branch 0 taken 9520168 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 9520168 times.
 9520168 } else if (params_empty && args_empty) {
5738 // All parameters and arguments have been bound
5739 break;
5740 } else {
5741 // More parameters to bind but no arguments left
5742 ✗ lbm_set_error_reason(lbm_error_str_num_args);
5743 ✗ ERROR_AT_CTX(ENC_SYM_EERROR, fun);
5744 }
5745 }
5746
5747 10080336 ctx->curr_env = env;
5748 10080336 ctx->curr_exp = closure[CLO_BODY];
5749 10080336 return;
5750 } break;
5751 168 case ENC_SYM_CONT:{
5752 168 ctx->r = fun;
5753 168 ctx->r = setup_cont(ctx, arg_list);
5754 168 ctx->app_cont = true;
5755 168 return;
5756 } break;
5757 168 case ENC_SYM_CONT_SP: {
5758 168 ctx->r = fun;
5759 168 ctx->r = setup_cont_sp(ctx, arg_list);
5760 168 ctx->app_cont = true;
5761 168 return;
5762 } break;
5763 224 case ENC_SYM_MACRO:{
5764 224 ctx->r = fun;
5765 224 setup_macro(ctx, arg_list, ctx->curr_env);
5766 224 return;
5767 } break;
5768 ✗ default: {
5769 ✗ lbm_set_error_reason(lbm_error_str_not_applicable);
5770 ✗ ERROR_AT_CTX(ENC_SYM_EERROR, fun);
5771 } break;
5772 }
5773 } else {
5774 2 lbm_set_error_reason(lbm_error_str_not_applicable);
5775 2 ERROR_AT_CTX(ENC_SYM_EERROR, fun);
5776 }
5777 } else {
5778 1 lbm_set_error_reason(lbm_error_str_incorrect_arg);
5779 1 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_APPLY);
5780 }
5781 }
5782
5783 // Reset has a built in pause.
5784 // so after reset, continue.
5785 8 void lbm_reset_eval(void) {
5786 8 eval_cps_next_state_arg = 0;
5787 8 eval_cps_next_state = EVAL_CPS_STATE_RESET;
5788
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5789 8 }
5790
5791 44070 void lbm_pause_eval(void ) {
5792 44070 eval_cps_next_state_arg = 0;
5793 44070 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
5794
1/2
✓ Branch 0 taken 44070 times.
✗ Branch 1 not taken.
 44070 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5795 44070 }
5796
5797 44295 void lbm_pause_eval_with_gc(uint32_t num_free) {
5798 44295 eval_cps_next_state_arg = num_free;
5799 44295 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
5800
1/2
✓ Branch 0 taken 44295 times.
✗ Branch 1 not taken.
 44295 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5801 44295 }
5802
5803 44309 void lbm_continue_eval(void) {
5804 44309 eval_cps_next_state = EVAL_CPS_STATE_RUNNING;
5805
1/2
✓ Branch 0 taken 44309 times.
✗ Branch 1 not taken.
 44309 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5806 44309 }
5807
5808 68 void lbm_kill_eval(void) {
5809 68 eval_cps_next_state = EVAL_CPS_STATE_KILL;
5810
1/2
✓ Branch 0 taken 68 times.
✗ Branch 1 not taken.
 68 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5811 68 }
5812
5813 318039 uint32_t lbm_get_eval_state(void) {
5814 318039 return eval_cps_run_state;
5815 }
5816
5817 // Only unblocks threads that are unblockable.
5818 // A sleeping thread is not unblockable.
5819 168 static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
5820 168 eval_context_t *found = NULL;
5821 168 mutex_lock(&qmutex);
5822
5823 168 found = lookup_ctx_nm(&blocked, cid);
5824
2/4
✓ Branch 0 taken 168 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 168 times.
✗ Branch 3 not taken.
 168 if (found && LBM_IS_STATE_UNBLOCKABLE(found->state)){
5825 168 drop_ctx_nm(&blocked,found);
5826
2/2
✓ Branch 0 taken 56 times.
✓ Branch 1 taken 112 times.
 168 if (lbm_is_error(v)) {
5827 56 get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
5828 56 found->app_cont = true;
5829 }
5830 168 found->r = v;
5831 168 found->state = LBM_THREAD_STATE_READY;
5832 168 enqueue_ctx_nm(&queue,found);
5833 }
5834 168 mutex_unlock(&qmutex);
5835 168 }
5836
5837 5 static void handle_event_define(lbm_value key, lbm_value val) {
5838 5 lbm_uint dec_key = lbm_dec_sym(key);
5839 5 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
5840 5 lbm_value *global_env = lbm_get_global_env();
5841 5 lbm_uint orig_env = global_env[ix_key];
5842 lbm_value new_env;
5843 // A key is a symbol and should not need to be remembered.
5844
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 5 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 5 WITH_GC(new_env, lbm_env_set(orig_env,key,val));
5845
5846 5 global_env[ix_key] = new_env;
5847 5 }
5848
5849 6864 static lbm_value get_event_value(lbm_event_t *e) {
5850 lbm_value v;
5851
2/2
✓ Branch 0 taken 6832 times.
✓ Branch 1 taken 32 times.
 6864 if (e->buf_len > 0) {
5852 lbm_flat_value_t fv;
5853 6832 fv.buf = (uint8_t*)e->buf_ptr;
5854 6832 fv.buf_size = e->buf_len;
5855 6832 fv.buf_pos = 0;
5856 6832 lbm_unflatten_value(&fv, &v);
5857 // Free the flat value buffer. GC is unaware of its existence.
5858 6832 lbm_free(fv.buf);
5859 } else {
5860 32 v = (lbm_value)e->buf_ptr;
5861 }
5862 6864 return v;
5863 }
5864
5865 // In a scenario where C is enqueuing events and other LBM threads
5866 // are sendind mail to event handler concurrently, old events will
5867 // be dropped as the backpressure mechanism wont detect this scenario.
5868 // TODO: Low prio pondering on robust solutions.
5869 409454902 static void process_events(void) {
5870
5871
2/2
✓ Branch 0 taken 1393215 times.
✓ Branch 1 taken 408061687 times.
 409454902 if (!lbm_events) {
5872 1393215 return;
5873 }
5874
5875 lbm_event_t e;
5876
2/2
✓ Branch 0 taken 6864 times.
✓ Branch 1 taken 408061687 times.
 816130238 while (lbm_event_pop(&e)) {
5877 6864 lbm_value event_val = get_event_value(&e);
5878
3/4
✗ Branch 0 not taken.
✓ Branch 1 taken 168 times.
✓ Branch 2 taken 5 times.
✓ Branch 3 taken 6691 times.
 6864 switch(e.type) {
5879 168 case LBM_EVENT_UNBLOCK_CTX:
5880 168 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5881 168 break;
5882 5 case LBM_EVENT_DEFINE:
5883 5 handle_event_define((lbm_value)e.parameter, event_val);
5884 5 break;
5885 6691 case LBM_EVENT_FOR_HANDLER:
5886
1/2
✓ Branch 0 taken 6691 times.
✗ Branch 1 not taken.
 6691 if (lbm_event_handler_pid >= 0) {
5887 //If multiple events for handler, this is wasteful!
5888 // TODO: Find the event_handler once and send all mails.
5889 // However, do it with as little new code as possible.
5890 6691 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5891 }
5892 6691 break;
5893 }
5894 }
5895 }
5896
5897 44370 void lbm_add_eval_symbols(void) {
5898 44370 lbm_uint x = 0;
5899 44370 lbm_uint y = 0;
5900 44370 lbm_add_symbol("x", &x);
5901 44370 lbm_add_symbol("y", &y);
5902 44370 symbol_x = lbm_enc_sym(x);
5903 44370 symbol_y = lbm_enc_sym(y);
5904 44370 }
5905
5906 /* eval_cps_run can be paused
5907 I think it would be better use a mailbox for
5908 communication between other threads and the run_eval
5909 but for now a set of variables will be used. */
5910 44370 void lbm_run_eval(void){
5911
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (setjmp(critical_error_jmp_buf) > 0) {
5912 ✗ lbm_printf_callback("GC stack overflow!\n");
5913 ✗ critical_error_callback();
5914 // terminate evaluation thread.
5915 ✗ return;
5916 }
5917
5918 44370 setjmp(error_jmp_buf);
5919
5920
2/2
✓ Branch 0 taken 248538 times.
✓ Branch 1 taken 80695 times.
 329233 while (eval_running) {
5921
4/4
✓ Branch 0 taken 104393 times.
✓ Branch 1 taken 158453 times.
✓ Branch 2 taken 54433 times.
✓ Branch 3 taken 61198 times.
 248538 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED) {
5922 187340 eval_cps_state_changed = false;
5923
4/4
✓ Branch 0 taken 8 times.
✓ Branch 1 taken 142955 times.
✓ Branch 2 taken 68 times.
✓ Branch 3 taken 44309 times.
 187340 switch (eval_cps_next_state) {
5924 8 case EVAL_CPS_STATE_RESET:
5925
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (eval_cps_run_state != EVAL_CPS_STATE_RESET) {
5926 8 is_atomic = false;
5927 8 blocked.first = NULL;
5928 8 blocked.last = NULL;
5929 8 queue.first = NULL;
5930 8 queue.last = NULL;
5931 8 ctx_running = NULL;
5932 #ifdef LBM_USE_TIME_QUOTA
5933 ✗ eval_time_quota = 0; // maybe timestamp here ?
5934 #else
5935 8 eval_steps_quota = eval_steps_refill;
5936 #endif
5937 8 eval_cps_run_state = EVAL_CPS_STATE_RESET;
5938
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (blocking_extension) {
5939 ✗ blocking_extension = false;
5940 ✗ mutex_unlock(&blocking_extension_mutex);
5941 }
5942 }
5943 8 usleep_callback(EVAL_CPS_MIN_SLEEP);
5944 8 continue;
5945 142955 case EVAL_CPS_STATE_PAUSED:
5946
2/2
✓ Branch 0 taken 88364 times.
✓ Branch 1 taken 80642 times.
 142955 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED) {
5947
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 88364 times.
 88364 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5948 ✗ gc();
5949 }
5950 88364 eval_cps_next_state_arg = 0;
5951 88364 eval_cps_run_state = EVAL_CPS_STATE_PAUSED;
5952 }
5953 142955 usleep_callback(EVAL_CPS_MIN_SLEEP);
5954 179532 continue;
5955 68 case EVAL_CPS_STATE_KILL:
5956 68 eval_cps_run_state = EVAL_CPS_STATE_DEAD;
5957 68 eval_running = false;
5958 68 continue;
5959 44309 default: // running state
5960 44309 eval_cps_run_state = eval_cps_next_state;
5961 44309 break;
5962 }
5963 }
5964 11089458 while (true) {
5965 #ifdef LBM_USE_TIME_QUOTA
5966 // Is "negative" (closer to max value) when the quota timestamp is "ahead
5967 // of" the current timestamp. It handles the quota being very large while
5968 // the current timestamp has overflowed back to being small, giving a
5969 // "positive" (closer to min value) result, meaning the context will be
5970 // switched.
5971 11090420 uint32_t unsigned_difference = timestamp_us_callback() - eval_current_quota;
5972 11090418 bool is_negative = unsigned_difference & (1u << 31);
5973
4/4
✓ Branch 0 taken 11086418 times.
✓ Branch 1 taken 4000 times.
✓ Branch 2 taken 11083120 times.
✓ Branch 3 taken 3298 times.
 11090418 if (is_negative && ctx_running) {
5974 11083120 evaluation_step();
5975 } else {
5976
2/2
✓ Branch 0 taken 187 times.
✓ Branch 1 taken 7111 times.
 7298 if (eval_cps_state_changed) break;
5977 // On overflow of timer, task will get a no-quota.
5978 // Could lead to busy-wait here until timestamp and quota
5979 // are on same side of overflow.
5980 7111 eval_current_quota = timestamp_us_callback() + eval_time_refill;
5981
1/2
✓ Branch 0 taken 7111 times.
✗ Branch 1 not taken.
 7111 if (!is_atomic) {
5982
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 7110 times.
 7111 if (gc_requested) {
5983 1 gc();
5984 }
5985 7111 process_events();
5986 7111 mutex_lock(&qmutex);
5987
2/2
✓ Branch 0 taken 3687 times.
✓ Branch 1 taken 3424 times.
 7111 if (ctx_running) {
5988 3687 enqueue_ctx_nm(&queue, ctx_running);
5989 3687 ctx_running = NULL;
5990 }
5991 7111 wake_up_ctxs_nm();
5992 7111 ctx_running = dequeue_ctx_nm(&queue);
5993 7111 mutex_unlock(&qmutex);
5994
2/2
✓ Branch 0 taken 3071 times.
✓ Branch 1 taken 4041 times.
 7112 if (!ctx_running) {
5995 3071 lbm_system_sleeping = true;
5996 //Fixed sleep interval to poll events regularly.
5997 3071 usleep_callback(EVAL_CPS_MIN_SLEEP);
5998 2850 lbm_system_sleeping = false;
5999 }
6000 }
6001 }
6002 #else
6003
4/4
✓ Branch 0 taken 4053553372 times.
✓ Branch 1 taken 404861064 times.
✓ Branch 2 taken 4048877111 times.
✓ Branch 3 taken 4676261 times.
 4458414436 if (eval_steps_quota && ctx_running) {
6004 4048877111 eval_steps_quota--;
6005 4048877111 evaluation_step();
6006 } else {
6007
2/2
✓ Branch 0 taken 88139 times.
✓ Branch 1 taken 409449186 times.
 409537325 if (eval_cps_state_changed) break;
6008 409449186 eval_steps_quota = eval_steps_refill;
6009
2/2
✓ Branch 0 taken 409447786 times.
✓ Branch 1 taken 1400 times.
 409449186 if (!is_atomic) {
6010
2/2
✓ Branch 0 taken 214 times.
✓ Branch 1 taken 409447572 times.
 409447786 if (gc_requested) {
6011 214 gc();
6012 }
6013 409447786 process_events();
6014 409447786 mutex_lock(&qmutex);
6015
2/2
✓ Branch 0 taken 404791247 times.
✓ Branch 1 taken 4656539 times.
 409447786 if (ctx_running) {
6016 404791247 enqueue_ctx_nm(&queue, ctx_running);
6017 404791248 ctx_running = NULL;
6018 }
6019 409447787 wake_up_ctxs_nm();
6020 409447787 ctx_running = dequeue_ctx_nm(&queue);
6021 409447787 mutex_unlock(&qmutex);
6022
2/2
✓ Branch 0 taken 4529678 times.
✓ Branch 1 taken 404918109 times.
 409447787 if (!ctx_running) {
6023 4529678 lbm_system_sleeping = true;
6024 //Fixed sleep interval to poll events regularly.
6025 4529678 usleep_callback(EVAL_CPS_MIN_SLEEP);
6026 4529647 lbm_system_sleeping = false;
6027 }
6028 }
6029 }
6030 #endif
6031 }
6032 }
6033 }
6034
6035 44370 bool lbm_eval_init(void) {
6036
2/2
✓ Branch 0 taken 44302 times.
✓ Branch 1 taken 68 times.
 44370 if (!qmutex_initialized) {
6037 44302 mutex_init(&qmutex);
6038 44302 qmutex_initialized = true;
6039 }
6040
2/2
✓ Branch 0 taken 44302 times.
✓ Branch 1 taken 68 times.
 44370 if (!lbm_events_mutex_initialized) {
6041 44302 mutex_init(&lbm_events_mutex);
6042 44302 lbm_events_mutex_initialized = true;
6043 }
6044
2/2
✓ Branch 0 taken 44302 times.
✓ Branch 1 taken 68 times.
 44370 if (!blocking_extension_mutex_initialized) {
6045 44302 mutex_init(&blocking_extension_mutex);
6046 44302 blocking_extension_mutex_initialized = true;
6047 }
6048
6049 44370 mutex_lock(&qmutex);
6050 44370 mutex_lock(&lbm_events_mutex);
6051
6052 44370 blocked.first = NULL;
6053 44370 blocked.last = NULL;
6054 44370 queue.first = NULL;
6055 44370 queue.last = NULL;
6056 44370 ctx_running = NULL;
6057
6058 44370 eval_cps_run_state = EVAL_CPS_STATE_RUNNING;
6059
6060 44370 mutex_unlock(&lbm_events_mutex);
6061 44370 mutex_unlock(&qmutex);
6062
6063
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 44370 times.
 44370 if (!lbm_init_env()) return false;
6064 44370 eval_running = true;
6065 44370 return true;
6066 }
6067
6068 44304 bool lbm_eval_init_events(unsigned int num_events) {
6069
6070 44304 mutex_lock(&lbm_events_mutex);
6071 44304 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
6072 44304 bool r = false;
6073
1/2
✓ Branch 0 taken 44304 times.
✗ Branch 1 not taken.
 44304 if (lbm_events) {
6074 44304 lbm_events_max = num_events;
6075 44304 lbm_events_head = 0;
6076 44304 lbm_events_tail = 0;
6077 44304 lbm_events_full = false;
6078 44304 lbm_event_handler_pid = -1;
6079 44304 r = true;
6080 }
6081 44304 mutex_unlock(&lbm_events_mutex);
6082 44304 return r;
6083 }
6084