GCC Code Coverage Report

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