GCC Code Coverage Report

Directory: ../src/
File: /home/joels/Current/lispbm/src/eval_cps.c
Date: 2025-10-28 15:15:18
Exec Total Coverage
Lines: 3216 3430 93.8%
Functions: 214 221 96.8%
Branches: 1091 1392 78.4%
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 13532 void lbm_request_gc(void) {
287 13532 gc_requested = true;
288 13532 }
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 84 void lbm_set_eval_step_quota(uint32_t quota) {
319 84 eval_steps_refill = quota;
320 84 }
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 17199 static void usleep_nonsense(uint32_t us) {
329 (void) us;
330 17199 }
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 66567 void lbm_set_critical_error_callback(void (*fptr)(void)) {
358
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66567 if (fptr == NULL) critical_error_callback = critical_nonsense;
359 66566 else critical_error_callback = fptr;
360 66567 }
361
362 66567 void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
363
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66567 if (fptr == NULL) usleep_callback = usleep_nonsense;
364 66566 else usleep_callback = fptr;
365 66567 }
366
367 66567 void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
368
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66567 if (fptr == NULL) ctx_done_callback = ctx_done_nonsense;
369 66566 else ctx_done_callback = fptr;
370 66567 }
371
372 66567 void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
373
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66567 if (fptr == NULL) lbm_printf_callback = printf_nonsense;
374 66566 else lbm_printf_callback = fptr;
375 66567 }
376
377 66567 void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char **)) {
378
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66567 if (fptr == NULL) dynamic_load_callback = dynamic_load_nonsense;
379 66566 else dynamic_load_callback = fptr;
380 66567 }
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 10028 static unsigned int lbm_event_queue_item_count(void) {
392 10028 unsigned int res = lbm_events_max;
393
2/2
✓ Branch 0 taken 10023 times.
✓ Branch 1 taken 5 times.
 10028 if (!lbm_events_full) {
394
1/2
✓ Branch 0 taken 10023 times.
✗ Branch 1 not taken.
 10023 if (lbm_events_head >= lbm_events_tail) {
395 10023 res = lbm_events_head - lbm_events_tail;
396 } else {
397 ✗ res = lbm_events_max - lbm_events_tail + lbm_events_head;
398 }
399 }
400 10028 return res;
401 }
402
403 1 lbm_cid lbm_get_event_handler_pid(void) {
404 1 return lbm_event_handler_pid;
405 }
406
407 679 void lbm_set_event_handler_pid(lbm_cid pid) {
408 679 lbm_event_handler_pid = pid;
409 679 }
410
411 8 bool lbm_event_handler_exists(void) {
412 8 return(lbm_event_handler_pid > 0);
413 }
414
415 10285 static bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
416 10285 bool r = false;
417
1/2
✓ Branch 0 taken 10285 times.
✗ Branch 1 not taken.
 10285 if (lbm_events) {
418 10285 lbm_mutex_lock(&lbm_events_mutex);
419
2/2
✓ Branch 0 taken 10280 times.
✓ Branch 1 taken 5 times.
 10285 if (!lbm_events_full) {
420 lbm_event_t event;
421 10280 event.type = event_type;
422 10280 event.parameter = parameter;
423 10280 event.buf_ptr = buf_ptr;
424 10280 event.buf_len = buf_len;
425 10280 lbm_events[lbm_events_head] = event;
426 10280 lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
427 10280 lbm_events_full = lbm_events_head == lbm_events_tail;
428 10280 r = true;
429 }
430 10285 lbm_mutex_unlock(&lbm_events_mutex);
431 }
432 10285 return r;
433 }
434
435 5 bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
436 5 return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
437 }
438
439 36 bool lbm_event_unboxed(lbm_value unboxed) {
440 36 lbm_uint t = lbm_type_of(unboxed);
441
4/4
✓ Branch 0 taken 33 times.
✓ Branch 1 taken 3 times.
✓ Branch 2 taken 15 times.
✓ Branch 3 taken 18 times.
 36 if (t == LBM_TYPE_SYMBOL ||
442
2/2
✓ Branch 0 taken 8 times.
✓ Branch 1 taken 7 times.
 15 t == LBM_TYPE_I ||
443
2/2
✓ Branch 0 taken 7 times.
✓ Branch 1 taken 1 times.
 8 t == LBM_TYPE_U ||
444 t == LBM_TYPE_CHAR) {
445
2/2
✓ Branch 0 taken 32 times.
✓ Branch 1 taken 3 times.
 35 if (lbm_event_handler_pid > 0) {
446
1/2
✓ Branch 0 taken 32 times.
✗ Branch 1 not taken.
 32 if (lbm_mailbox_free_space_for_cid(lbm_event_handler_pid) > lbm_event_queue_item_count()) {
447 32 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
448 }
449 }
450 }
451 4 return false;
452 }
453
454 21810 bool lbm_event(lbm_flat_value_t *fv) {
455
2/2
✓ Branch 0 taken 9996 times.
✓ Branch 1 taken 11814 times.
 21810 if (lbm_event_handler_pid > 0) {
456
1/2
✓ Branch 0 taken 9996 times.
✗ Branch 1 not taken.
 9996 if (lbm_mailbox_free_space_for_cid(lbm_event_handler_pid) > lbm_event_queue_item_count()) {
457 9996 return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
458 }
459 }
460 11814 return false;
461 }
462
463 614525563 static bool lbm_event_pop(lbm_event_t *event) {
464 614525563 lbm_mutex_lock(&lbm_events_mutex);
465 614525562 bool r = false;
466
4/4
✓ Branch 0 taken 614515284 times.
✓ Branch 1 taken 10278 times.
✓ Branch 2 taken 2 times.
✓ Branch 3 taken 614515282 times.
 614525562 if (lbm_events_head != lbm_events_tail || lbm_events_full) {
467 10280 *event = lbm_events[lbm_events_tail];
468 10280 lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
469 10280 lbm_events_full = false;
470 10280 r = true;
471 }
472 614525562 lbm_mutex_unlock(&lbm_events_mutex);
473 614525563 return r;
474 }
475
476 6 bool lbm_event_queue_is_empty(void) {
477 6 lbm_mutex_lock(&lbm_events_mutex);
478 6 bool empty = false;
479
4/4
✓ Branch 0 taken 5 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 4 times.
✓ Branch 3 taken 1 times.
 6 if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
480 4 empty = true;
481 }
482 6 lbm_mutex_unlock(&lbm_events_mutex);
483 6 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 9 void lbm_toggle_verbose(void) {
500 9 lbm_verbose = !lbm_verbose;
501 9 }
502
503 66108 void lbm_set_verbose(bool verbose) {
504 66108 lbm_verbose = verbose;
505 66108 }
506
507 35 void lbm_set_hide_trapped_error(bool hide) {
508 35 lbm_hide_trapped_error = hide;
509 35 }
510
511 4088 lbm_cid lbm_get_current_cid(void) {
512 4088 lbm_cid cid = -1;
513
1/2
✓ Branch 0 taken 4088 times.
✗ Branch 1 not taken.
 4088 if (ctx_running)
514 4088 cid = ctx_running->id;
515 4088 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 10 void lbm_surrender_quota(void) {
528 10 eval_steps_quota = 0;
529 10 }
530 #endif
531
532 /****************************************************/
533 /* Utilities used locally in this file */
534
535 1157128 static inline lbm_array_header_t *assume_array(lbm_value a){
536 1157128 return (lbm_array_header_t*)lbm_ref_cell(a)->car;
537 }
538
539 13954254 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 10526 times.
✓ Branch 1 taken 13943728 times.
 13954254 if (!lbm_heap_num_free()) {
547 10526 lbm_value roots[3] = {head, tail, remember};
548 10526 lbm_gc_mark_roots(roots,3);
549 10526 gc();
550
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 10520 times.
 10526 if (!lbm_heap_num_free()) {
551 6 ERROR_CTX(ENC_SYM_MERROR);
552 }
553 }
554
555 13954248 res = lbm_heap_state.freelist;
556 13954248 lbm_uint heap_ix = lbm_dec_ptr(res);
557 13954248 lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
558 13954248 lbm_heap_state.num_free--;
559 13954248 lbm_heap_state.heap[heap_ix].car = head;
560 13954248 lbm_heap_state.heap[heap_ix].cdr = tail;
561 13954248 res = lbm_set_ptr_type(res, LBM_TYPE_CONS);
562 13954248 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 3335973633 static inline lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
597 3335973633 lbm_uint index = ctx->K.sp - n;
598 3335973633 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 83778268 static inline lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
604 83778268 ctx->K.sp -= n;
605 83778268 return &ctx->K.data[ctx->K.sp];
606 }
607
608 3631023740 static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
609
2/2
✓ Branch 0 taken 3631023736 times.
✓ Branch 1 taken 4 times.
 3631023740 if (ctx->K.sp + n < ctx->K.size) {
610 3631023736 lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
611 3631023736 ctx->K.sp += n;
612 3631023736 return ptr;
613 }
614 4 ERROR_CTX(ENC_SYM_STACK_ERROR);
615 }
616
617 22758 static void handle_flash_status(lbm_flash_status s) {
618
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 22758 times.
 22758 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 22758 times.
 22758 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 22758 }
627
628 264 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 264 flash_array_header.size = num_elt;
632 264 flash_array_header.data = (lbm_uint*)data;
633 264 lbm_uint flash_array_header_ptr = 0;
634 264 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 264 handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
638
2/2
✓ Branch 0 taken 180 times.
✓ Branch 1 taken 84 times.
 264 lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE : ENC_SYM_LISPARRAY_TYPE;
639 264 handle_flash_status(write_const_cdr(flash_cell, t));
640 264 }
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 489016381 static inline void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
650
2/2
✓ Branch 0 taken 461757066 times.
✓ Branch 1 taken 27259315 times.
 489016381 if (lbm_is_cons(a)) {
651 461757066 lbm_cons_t *cell = lbm_ref_cell(a);
652 461757066 *a_car = cell->car;
653 461757066 *a_cdr = cell->cdr;
654
2/2
✓ Branch 0 taken 27259299 times.
✓ Branch 1 taken 16 times.
 27259315 } else if (lbm_is_symbol_nil(a)) {
655 27259299 *a_car = *a_cdr = ENC_SYM_NIL;
656 } else {
657 16 ERROR_CTX(ENC_SYM_TERROR);
658 }
659 489016365 }
660
661 /* car cdr caar cadr replacements that are evaluator safe. */
662 51064318 static inline lbm_value get_car(lbm_value a) {
663
2/2
✓ Branch 0 taken 51064314 times.
✓ Branch 1 taken 4 times.
 51064318 if (lbm_is_cons(a)) {
664 51064314 lbm_cons_t *cell = lbm_ref_cell(a);
665 51064314 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 308516958 static inline lbm_value get_cdr(lbm_value a) {
673
2/2
✓ Branch 0 taken 308516872 times.
✓ Branch 1 taken 86 times.
 308516958 if (lbm_is_cons(a)) {
674 308516872 lbm_cons_t *cell = lbm_ref_cell(a);
675 308516872 return cell->cdr;
676
1/2
✓ Branch 0 taken 86 times.
✗ Branch 1 not taken.
 86 } else if (lbm_is_symbol_nil(a)) {
677 86 return a;
678 }
679 ✗ ERROR_CTX(ENC_SYM_TERROR);
680 }
681
682 100477948 static inline lbm_value get_cadr(lbm_value a) {
683
2/2
✓ Branch 0 taken 100477945 times.
✓ Branch 1 taken 3 times.
 100477948 if (lbm_is_cons(a)) {
684 100477945 lbm_cons_t *cell = lbm_ref_cell(a);
685 100477945 lbm_value tmp = cell->cdr;
686
2/2
✓ Branch 0 taken 100474752 times.
✓ Branch 1 taken 3193 times.
 100477945 if (lbm_is_cons(tmp)) {
687 100474752 return lbm_ref_cell(tmp)->car;
688
1/2
✓ Branch 0 taken 3193 times.
✗ Branch 1 not taken.
 3193 } else if (lbm_is_symbol_nil(tmp)) {
689 3193 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 308701429 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 418686 times.
✓ Branch 1 taken 308282743 times.
 308701429 if (lbm_heap_num_free() < 2) {
709 418686 lbm_gc_mark_phase(key);
710 418686 lbm_gc_mark_phase(val);
711 418686 lbm_gc_mark_phase(the_cdr);
712 418686 gc();
713
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 418602 times.
 418686 if (lbm_heap_num_free() < 2) {
714 84 ERROR_CTX(ENC_SYM_MERROR);
715 }
716 }
717 #endif
718 // If num_free is calculated correctly, freelist is definitely a cons-cell.
719 308701345 lbm_cons_t* heap = lbm_heap_state.heap;
720 308701345 lbm_value binding_cell = lbm_heap_state.freelist;
721 308701345 lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
722 308701345 lbm_value list_cell = heap[binding_cell_ix].cdr;
723 308701345 lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
724 308701345 lbm_heap_state.freelist = heap[list_cell_ix].cdr;
725 308701345 lbm_heap_state.num_free -= 2;
726 308701345 heap[binding_cell_ix].car = key;
727 308701345 heap[binding_cell_ix].cdr = val;
728 308701345 heap[list_cell_ix].car = binding_cell;
729 308701345 heap[list_cell_ix].cdr = the_cdr;
730 308701345 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 228029018 static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
747
2/2
✓ Branch 0 taken 647339413 times.
✓ Branch 1 taken 228029017 times.
 875368430 for (unsigned int i = 0; i < n; i ++) {
748
2/2
✓ Branch 0 taken 647281242 times.
✓ Branch 1 taken 58170 times.
 647339413 if (lbm_is_ptr(curr)) {
749 647281242 lbm_cons_t *cell = lbm_ref_cell(curr);
750 647281242 res[i] = cell->car;
751 647281242 curr = cell->cdr;
752 } else {
753 58170 res[i] = ENC_SYM_NIL;
754 }
755 }
756 228029017 return curr; // Rest of list is returned here.
757 }
758
759 672378104 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 672378104 res = fundamental_table[fundamental](args, arg_count, ctx);
765
2/2
✓ Branch 0 taken 1027103 times.
✓ Branch 1 taken 671351001 times.
 672378104 if (lbm_is_error(res)) {
766
2/2
✓ Branch 0 taken 1012866 times.
✓ Branch 1 taken 14237 times.
 1027103 if (lbm_is_symbol_merror(res)) {
767 1012866 gc();
768 1012866 res = fundamental_table[fundamental](args, arg_count, ctx);
769 }
770
2/2
✓ Branch 0 taken 14429 times.
✓ Branch 1 taken 1012674 times.
 1027103 if (lbm_is_error(res)) {
771 14429 ERROR_AT_CTX(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START | fundamental));
772 }
773 }
774 672363675 lbm_stack_drop(&ctx->K, arg_count+1);
775 672363675 ctx->app_cont = true;
776 672363675 ctx->r = res;
777 672363675 }
778
779 85 static void atomic_error(void) {
780 85 is_atomic = false;
781 85 lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
782 85 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 18341 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 18341 times.
 18341 if (is_atomic) atomic_error();
790 18341 ctx_running->timestamp = lbm_timestamp();
791 18341 ctx_running->sleep_us = sleep_us;
792 18341 ctx_running->state = state;
793 18341 ctx_running->app_cont = do_cont;
794 18341 enqueue_ctx(&blocked, ctx_running);
795 18341 ctx_running = NULL;
796 18341 }
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 455356 lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
810 455356 lbm_uint full_words = n / sizeof(lbm_uint);
811 455356 lbm_uint n_mod = n % sizeof(lbm_uint);
812
813
2/2
✓ Branch 0 taken 57140 times.
✓ Branch 1 taken 398216 times.
 455356 if (n_mod == 0) { // perfect fit.
814 57140 return lbm_write_const_raw((lbm_uint*)data, full_words, res);
815 } else {
816 398216 lbm_uint last_word = 0;
817 398216 memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
818
2/2
✓ Branch 0 taken 74006 times.
✓ Branch 1 taken 324210 times.
 398216 if (full_words >= 1) {
819 74006 lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
820
1/2
✓ Branch 0 taken 74006 times.
✗ Branch 1 not taken.
 74006 if ( s == LBM_FLASH_WRITE_OK) {
821 lbm_uint dummy;
822 74006 s = lbm_write_const_raw(&last_word, 1, &dummy);
823 }
824 74006 return s;
825 } else {
826 324210 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 24564 void print_environments(char *buf, unsigned int size) {
837
838 24564 lbm_value curr_l = ctx_running->curr_env;
839 24564 lbm_printf_callback("\tCurrent local environment:\n");
840
2/2
✓ Branch 0 taken 1020 times.
✓ Branch 1 taken 24564 times.
 25584 while (lbm_type_of(curr_l) == LBM_TYPE_CONS) {
841 1020 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
842 1020 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
843 1020 lbm_printf_callback("\t%s = %s\n", buf, buf+(size/2));
844 1020 curr_l = lbm_cdr(curr_l);
845 }
846 24564 lbm_printf_callback("\n\n");
847 24564 lbm_printf_callback("\tCurrent global environment:\n");
848 24564 lbm_value *glob_env = lbm_get_global_env();
849
850
2/2
✓ Branch 0 taken 786048 times.
✓ Branch 1 taken 24564 times.
 810612 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
851 786048 lbm_value curr_g = glob_env[i];;
852
2/2
✓ Branch 0 taken 137472 times.
✓ Branch 1 taken 786048 times.
 923520 while (lbm_type_of(curr_g) == LBM_TYPE_CONS) {
853
854 137472 lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
855 137472 lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
856 137472 lbm_printf_callback("\t%s = %s\n", buf, buf+(size/2));
857 137472 curr_g = lbm_cdr(curr_g);
858 }
859 }
860 24564 }
861
862 78206 void print_error_value(char *buf, uint32_t bufsize, char *pre, lbm_value v, bool lookup) {
863
864 78206 lbm_print_value(buf, bufsize, v);
865 78206 lbm_printf_callback("%s %s\n",pre, buf);
866
2/2
✓ Branch 0 taken 53069 times.
✓ Branch 1 taken 25137 times.
 78206 if (lookup) {
867
2/2
✓ Branch 0 taken 31943 times.
✓ Branch 1 taken 21126 times.
 53069 if (lbm_is_symbol(v)) {
868
2/2
✓ Branch 0 taken 3597 times.
✓ Branch 1 taken 28346 times.
 31943 if (lbm_dec_sym(v) >= RUNTIME_SYMBOLS_START) {
869 3597 lbm_value res = ENC_SYM_NIL;
870
4/4
✓ Branch 0 taken 3330 times.
✓ Branch 1 taken 267 times.
✓ Branch 2 taken 2120 times.
✓ Branch 3 taken 1210 times.
 6927 if (lbm_env_lookup_b(&res, v, ctx_running->curr_env) ||
871 3330 lbm_global_env_lookup(&res, v)) {
872 2387 lbm_print_value(buf, bufsize, res);
873 2387 lbm_printf_callback(" bound to: %s\n", buf);
874 } else {
875 1210 lbm_printf_callback(" UNDEFINED\n");
876 }
877 }
878 }
879 }
880 78206 }
881
882 25137 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 25137 char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES);
894
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 25137 times.
 25137 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 24511 times.
✓ Branch 1 taken 626 times.
 25137 if (trapped) {
899 24511 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," Error (trapped):", error, false);
900 } else {
901 626 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," Error:", error, false);
902 }
903
2/2
✓ Branch 0 taken 373 times.
✓ Branch 1 taken 24764 times.
 25137 if (lbm_is_symbol_merror(error)) {
904 373 lbm_printf_callback("\n Heap cells free: %d\n", lbm_heap_state.num_free);
905 373 lbm_printf_callback(" Mem longest free: %d\n\n", lbm_memory_longest_free());
906 }
907
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 25137 times.
 25137 if (name) {
908 ✗ lbm_printf_callback( " CTX: %d \"%s\"\n", cid, name);
909 } else {
910 25137 lbm_printf_callback( " CTX: %d\n", cid);
911 }
912 25137 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 3791 times.
✓ Branch 1 taken 21346 times.
 25137 if (lbm_error_has_suspect) {
916 3791 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," At:", lbm_error_suspect, true);
917 3791 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 24141 times.
✓ Branch 1 taken 996 times.
 25137 if (has_at) {
922 24141 print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES," In:", at, true);
923 }
924
925 25137 lbm_printf_callback("\n");
926
927
4/4
✓ Branch 0 taken 25053 times.
✓ Branch 1 taken 84 times.
✓ Branch 2 taken 191 times.
✓ Branch 3 taken 24862 times.
 25137 if (lbm_is_symbol(error) &&
928 error == ENC_SYM_RERROR) {
929 191 lbm_printf_callback(" Line: %u\n", row);
930 191 lbm_printf_callback(" Column: %u\n", col);
931
2/2
✓ Branch 0 taken 12397 times.
✓ Branch 1 taken 12549 times.
 24946 } else if (row0 >= 0) {
932
2/2
✓ Branch 0 taken 7 times.
✓ Branch 1 taken 12390 times.
 12397 if (row1 < 0) lbm_printf_callback(" Starting at row: %d\n", row0);
933 12390 else lbm_printf_callback(" Between row %d and %d\n", row0, row1);
934 }
935
936 25137 lbm_printf_callback("\n");
937
938
2/2
✓ Branch 0 taken 5375 times.
✓ Branch 1 taken 19762 times.
 25137 if (ctx_running->error_reason) {
939 5375 lbm_printf_callback(" Reason: %s\n\n", ctx_running->error_reason);
940 }
941
2/2
✓ Branch 0 taken 24564 times.
✓ Branch 1 taken 573 times.
 25137 if (lbm_verbose) {
942 24564 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->r);
943 24564 lbm_printf_callback(" Current intermediate result: %s\n\n", buf);
944
945 24564 print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES);
946
947 24564 lbm_printf_callback("\n Mailbox:\n");
948
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 24564 times.
 24564 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 24564 lbm_printf_callback("\n Stack:\n");
953
2/2
✓ Branch 0 taken 480102 times.
✓ Branch 1 taken 24564 times.
 504666 for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
954 480102 lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]);
955 480102 lbm_printf_callback(" %s\n", buf);
956 }
957 }
958 25137 lbm_free(buf);
959 }
960
961 /****************************************************/
962 /* Tokenizing and parsing */
963
964 939540 static bool create_string_channel(char *str, lbm_value *res, lbm_value dep) {
965
966 939540 lbm_char_channel_t *chan = NULL;
967 939540 lbm_string_channel_state_t *st = NULL;
968
969 939540 st = (lbm_string_channel_state_t*)lbm_malloc(sizeof(lbm_string_channel_state_t));
970
2/2
✓ Branch 0 taken 3629 times.
✓ Branch 1 taken 935911 times.
 939540 if (st == NULL) {
971 3629 return false;
972 }
973 935911 chan = (lbm_char_channel_t*)lbm_malloc(sizeof(lbm_char_channel_t));
974
2/2
✓ Branch 0 taken 388 times.
✓ Branch 1 taken 935523 times.
 935911 if (chan == NULL) {
975 388 lbm_free(st);
976 388 return false;
977 }
978
979 935523 lbm_create_string_char_channel(st, chan, str);
980 935523 lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
981
2/2
✓ Branch 0 taken 4298 times.
✓ Branch 1 taken 931225 times.
 935523 if (cell == ENC_SYM_MERROR) {
982 4298 lbm_free(st);
983 4298 lbm_free(chan);
984 4298 return false;
985 }
986
987 931225 lbm_char_channel_set_dependency(chan, dep);
988
989 931225 *res = cell;
990 931225 return true;
991 }
992
993 /****************************************************/
994 /* Queue functions */
995
996 3212754 static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
997 eval_context_t *curr;
998 3212754 curr = q->first;
999
1000
2/2
✓ Branch 0 taken 38569 times.
✓ Branch 1 taken 3212754 times.
 3251323 while (curr != NULL) {
1001 38569 f(curr, arg1, arg2);
1002 38569 curr = curr->next;
1003 }
1004 3212754 }
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 289 void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
1015 289 lbm_mutex_lock(&qmutex);
1016 289 queue_iterator_nm(&queue, f, arg1, arg2);
1017 289 lbm_mutex_unlock(&qmutex);
1018 289 }
1019
1020 289 void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
1021 289 lbm_mutex_lock(&qmutex);
1022 289 queue_iterator_nm(&blocked, f, arg1, arg2);
1023 289 lbm_mutex_unlock(&qmutex);
1024 289 }
1025
1026 607354754 static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
1027
2/2
✓ Branch 0 taken 596368454 times.
✓ Branch 1 taken 10986300 times.
 607354754 if (q->last == NULL) {
1028 596368454 ctx->prev = NULL;
1029 596368454 ctx->next = NULL;
1030 596368454 q->first = ctx;
1031 596368454 q->last = ctx;
1032 } else {
1033 10986300 ctx->prev = q->last;
1034 10986300 ctx->next = NULL;
1035 10986300 q->last->next = ctx;
1036 10986300 q->last = ctx;
1037 }
1038 607354754 }
1039
1040 193057 static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
1041 193057 lbm_mutex_lock(&qmutex);
1042 193057 enqueue_ctx_nm(q,ctx);
1043 193057 lbm_mutex_unlock(&qmutex);
1044 193057 }
1045
1046 54007 static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
1047 eval_context_t *curr;
1048 54007 curr = q->first;
1049
2/2
✓ Branch 0 taken 31063 times.
✓ Branch 1 taken 22944 times.
 54007 while (curr != NULL) {
1050
1/2
✓ Branch 0 taken 31063 times.
✗ Branch 1 not taken.
 31063 if (curr->id == cid) {
1051 31063 return curr;
1052 }
1053 ✗ curr = curr->next;
1054 }
1055 22944 return NULL;
1056 }
1057
1058 17914 static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
1059
1060 17914 bool res = false;
1061
2/4
✓ Branch 0 taken 17914 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 17914 times.
 17914 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 17914 eval_context_t *curr = q->first;
1071
1/2
✓ Branch 0 taken 17914 times.
✗ Branch 1 not taken.
 17914 while (curr) {
1072
1/2
✓ Branch 0 taken 17914 times.
✗ Branch 1 not taken.
 17914 if (curr->id == ctx->id) {
1073 17914 res = true;
1074 17914 eval_context_t *tmp = curr->next;
1075
1/2
✓ Branch 0 taken 17914 times.
✗ Branch 1 not taken.
 17914 if (curr->prev == NULL) {
1076
2/2
✓ Branch 0 taken 17913 times.
✓ Branch 1 taken 1 times.
 17914 if (curr->next == NULL) {
1077 17913 q->last = NULL;
1078 17913 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 17914 break;
1093 }
1094 ✗ curr = curr->next;
1095 }
1096 17914 return res;
1097 }
1098
1099 /* End execution of the running context. */
1100 69048 static void finish_ctx(void) {
1101
1102
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 69048 times.
 69048 if (!ctx_running) {
1103 ✗ return;
1104 }
1105
2/2
✓ Branch 0 taken 672 times.
✓ Branch 1 taken 68376 times.
 69048 if (ctx_running->id == lbm_event_handler_pid) {
1106 672 lbm_event_handler_pid = -1;
1107 }
1108 /* Drop the continuation stack immediately to free up lbm_memory */
1109 69048 lbm_stack_free(&ctx_running->K);
1110 69048 ctx_done_callback(ctx_running);
1111
1112 69048 lbm_free(ctx_running->name); //free name if in LBM_MEM
1113
1114 69048 lbm_memory_free((lbm_uint*)ctx_running->error_reason); //free error_reason if in LBM_MEM
1115
1116 69048 lbm_memory_free((lbm_uint*)ctx_running->mailbox);
1117 69048 lbm_memory_free((lbm_uint*)ctx_running);
1118 69048 ctx_running = NULL;
1119 }
1120
1121 595 static void context_exists(eval_context_t *ctx, void *cid, void *b) {
1122
2/2
✓ Branch 0 taken 119 times.
✓ Branch 1 taken 476 times.
 595 if (ctx->id == *(lbm_cid*)cid) {
1123 119 *(bool*)b = true;
1124 }
1125 595 }
1126
1127 3794 void lbm_set_error_suspect(lbm_value suspect) {
1128 3794 lbm_error_suspect = suspect;
1129 3794 lbm_error_has_suspect = true;
1130 3794 }
1131
1132 4064 void lbm_set_error_reason(const char *error_str) {
1133
2/2
✓ Branch 0 taken 4057 times.
✓ Branch 1 taken 7 times.
 4064 if (ctx_running != NULL) {
1134 4057 ctx_running->error_reason = error_str;
1135 }
1136 4064 }
1137
1138 // Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
1139 #ifdef LBM_USE_ERROR_LINENO
1140 683 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 24565 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 25137 times.
✓ Branch 1 taken 111 times.
✓ Branch 2 taken 24511 times.
✓ Branch 3 taken 626 times.
 25248 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 25137 times.
 25248 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 25137 print_error_message(err_val,
1149 has_at,
1150 at,
1151 row,
1152 column,
1153 25137 ctx_running->row0,
1154 25137 ctx_running->row1,
1155 25137 ctx_running->id,
1156 25137 ctx_running->name,
1157 print_trapped
1158 );
1159 }
1160 #ifdef LBM_USE_ERROR_LINENO
1161
2/2
✓ Branch 0 taken 572 times.
✓ Branch 1 taken 111 times.
 683 if (!lbm_hide_trapped_error) {
1162 572 lbm_printf_callback("eval_cps.c line number: %d\n", line_no);
1163 }
1164 #endif
1165
2/2
✓ Branch 0 taken 589 times.
✓ Branch 1 taken 24659 times.
 25248 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
1166
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 589 times.
 589 if (lbm_heap_num_free() < 3) {
1167 ✗ gc();
1168 }
1169
1170
1/2
✓ Branch 0 taken 589 times.
✗ Branch 1 not taken.
 589 if (lbm_heap_num_free() >= 3) {
1171 589 lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL);
1172 589 msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
1173 589 msg = lbm_cons(ENC_SYM_EXIT_ERROR, msg);
1174
1/2
✓ Branch 0 taken 589 times.
✗ Branch 1 not taken.
 589 if (!lbm_is_symbol_merror(msg)) {
1175 589 lbm_find_receiver_and_send(ctx_running->parent, msg);
1176 }
1177 }
1178 // context dies.
1179
3/4
✓ Branch 0 taken 24622 times.
✓ Branch 1 taken 37 times.
✓ Branch 2 taken 24622 times.
✗ Branch 3 not taken.
 24659 } 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 90931 times.
✗ Branch 1 not taken.
 90931 while (ctx_running->K.sp > 0) {
1182 90931 lbm_uint v = ctx_running->K.data[--ctx_running->K.sp];
1183
2/2
✓ Branch 0 taken 24622 times.
✓ Branch 1 taken 66309 times.
 90931 if (v == EXCEPTION_HANDLER) { // context continues executing.
1184 24622 lbm_value *sptr = get_stack_ptr(ctx_running, 2);
1185 24622 lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR);
1186 24622 stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER;
1187 24622 ctx_running->app_cont = true;
1188 24622 ctx_running->r = err_val;
1189 24622 longjmp(error_jmp_buf, 1);
1190 }
1191 }
1192 ✗ err_val = ENC_SYM_FATAL_ERROR;
1193 }
1194 626 ctx_running->r = err_val;
1195 626 finish_ctx();
1196 626 longjmp(error_jmp_buf, 1);
1197 }
1198
1199 #ifdef LBM_USE_ERROR_LINENO
1200 610 static noreturn void error_at_ctx(lbm_value err_val, lbm_value at, int line_no) {
1201 610 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 23629 static noreturn void error_at_ctx(lbm_value err_val, lbm_value at) {
1213 23629 error_ctx_base(err_val, true, at, 0, 0);
1214 }
1215
1216 768 static noreturn void error_ctx(lbm_value err_val) {
1217 768 error_ctx_base(err_val, false, 0, 0, 0);
1218 }
1219
1220 168 static noreturn void read_error_ctx(unsigned int row, unsigned int column) {
1221 168 error_ctx_base(ENC_SYM_RERROR, false, 0, row, column);
1222 }
1223 #endif
1224
1225 1 void lbm_critical_error(void) {
1226 1 longjmp(critical_error_jmp_buf, 1);
1227 }
1228
1229 // successfully finish a context
1230 68422 static void ok_ctx(void) {
1231
2/2
✓ Branch 0 taken 423 times.
✓ Branch 1 taken 67999 times.
 68422 if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
1232 lbm_value msg;
1233
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 423 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 423 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 423 lbm_find_receiver_and_send(ctx_running->parent, msg);
1238 }
1239 68422 finish_ctx();
1240 68422 }
1241
1242 616453095 static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
1243
2/2
✓ Branch 0 taken 9221860 times.
✓ Branch 1 taken 607231235 times.
 616453095 if (q->last == NULL) {
1244 9221860 return NULL;
1245 }
1246 // q->first should only be NULL if q->last is.
1247 607231235 eval_context_t *res = q->first;
1248
1249
2/2
✓ Branch 0 taken 596260514 times.
✓ Branch 1 taken 10970721 times.
 607231235 if (q->first == q->last) { // One thing in queue
1250 596260514 q->first = NULL;
1251 596260514 q->last = NULL;
1252 } else {
1253 10970721 q->first = q->first->next;
1254 10970721 q->first->prev = NULL;
1255 }
1256 607231235 res->prev = NULL;
1257 607231235 res->next = NULL;
1258 607231235 return res;
1259 }
1260
1261 616453094 static void wake_up_ctxs_nm(void) {
1262 lbm_uint t_now;
1263 616453094 t_now = lbm_timestamp();
1264 616453094 eval_context_queue_t *q = &blocked;
1265 616453094 eval_context_t *curr = q->first;
1266
1267
2/2
✓ Branch 0 taken 11029041 times.
✓ Branch 1 taken 616453094 times.
 627482135 while (curr != NULL) {
1268 lbm_uint t_diff;
1269 11029041 eval_context_t *next = curr->next;
1270
2/2
✓ Branch 0 taken 9855133 times.
✓ Branch 1 taken 1173908 times.
 11029041 if (LBM_IS_STATE_WAKE_UP_WAKABLE(curr->state)) {
1271
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 9855133 times.
 9855133 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 9855133 t_diff = t_now - curr->timestamp;
1280 }
1281
1282
2/2
✓ Branch 0 taken 105096 times.
✓ Branch 1 taken 9750037 times.
 9855133 if (t_diff >= curr->sleep_us) {
1283 105096 eval_context_t *wake_ctx = curr;
1284
2/2
✓ Branch 0 taken 96603 times.
✓ Branch 1 taken 8493 times.
 105096 if (curr == q->last) {
1285
2/2
✓ Branch 0 taken 7084 times.
✓ Branch 1 taken 89519 times.
 96603 if (curr->prev) {
1286 7084 q->last = curr->prev;
1287 7084 q->last->next = NULL;
1288 } else {
1289 89519 q->first = NULL;
1290 89519 q->last = NULL;
1291 }
1292
2/2
✓ Branch 0 taken 8492 times.
✓ Branch 1 taken 1 times.
 8493 } else if (curr->prev == NULL) {
1293 8492 q->first = curr->next;
1294 8492 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 105096 wake_ctx->next = NULL;
1302 105096 wake_ctx->prev = NULL;
1303
2/2
✓ Branch 0 taken 420 times.
✓ Branch 1 taken 104676 times.
 105096 if (LBM_IS_STATE_TIMEOUT(curr->state)) {
1304 420 mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT);
1305 420 wake_ctx->r = ENC_SYM_TIMEOUT;
1306 }
1307 105096 wake_ctx->state = LBM_THREAD_STATE_READY;
1308 105096 enqueue_ctx_nm(&queue, wake_ctx);
1309 }
1310 }
1311 11029041 curr = next;
1312 }
1313 616453094 }
1314
1315 105002 static void yield_ctx(lbm_uint sleep_us) {
1316
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 104918 times.
 105002 if (is_atomic) atomic_error();
1317 104918 ctx_running->timestamp = lbm_timestamp();
1318 104918 ctx_running->sleep_us = sleep_us;
1319 104918 ctx_running->state = LBM_THREAD_STATE_SLEEPING;
1320 104918 ctx_running->r = ENC_SYM_TRUE;
1321 104918 ctx_running->app_cont = true;
1322 104918 enqueue_ctx(&blocked,ctx_running);
1323 104918 ctx_running = NULL;
1324 104918 }
1325
1326 69882 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 69882 times.
 69882 if (!lbm_is_cons(program)) return -1;
1329
1330 69882 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 69882 ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
1339
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 69882 times.
 69882 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 69882 times.
 69882 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 84 times.
✓ Branch 1 taken 69798 times.
 69882 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1354 84 lbm_uint roots[2] = {program, env};
1355 84 lbm_gc_mark_roots(roots, 2);
1356 84 gc();
1357
1/2
✓ Branch 0 taken 84 times.
✗ Branch 1 not taken.
 84 if (!lbm_stack_allocate(&ctx->K, stack_size)) {
1358 84 lbm_memory_free((lbm_uint*)ctx);
1359 84 return -1;
1360 }
1361 }
1362
1363 69798 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 69798 mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
1372
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 69798 times.
 69798 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 69798 times.
 69798 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 431 times.
✓ Branch 1 taken 69367 times.
 69798 if (name) {
1386 431 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 431 ctx->name = lbm_malloc(name_len);
1395
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 431 times.
 431 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 431 times.
 431 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 431 memcpy(ctx->name, name, name_len);
1408 } else {
1409 69367 ctx->name = NULL;
1410 }
1411
1412 69798 lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
1413
1414 69798 ctx->program = lbm_cdr(program);
1415 69798 ctx->curr_exp = lbm_car(program);
1416 69798 ctx->curr_env = env;
1417 69798 ctx->r = ENC_SYM_NIL;
1418 69798 ctx->error_reason = NULL;
1419 69798 ctx->mailbox = mailbox;
1420 69798 ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE;
1421 69798 ctx->flags = context_flags;
1422 69798 ctx->num_mail = 0;
1423 69798 ctx->app_cont = false;
1424 69798 ctx->timestamp = 0;
1425 69798 ctx->sleep_us = 0;
1426 69798 ctx->state = LBM_THREAD_STATE_READY;
1427 69798 ctx->prev = NULL;
1428 69798 ctx->next = NULL;
1429
1430 69798 ctx->row0 = -1;
1431 69798 ctx->row1 = -1;
1432
1433 69798 ctx->id = cid;
1434 69798 ctx->parent = parent;
1435
1436
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 69798 times.
 69798 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 69798 enqueue_ctx(&queue,ctx);
1444
1445 69798 return ctx->id;
1446 }
1447
1448 66492 lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
1449 // Creates a parentless context.
1450 66492 return lbm_create_ctx_parent(program,
1451 env,
1452 stack_size,
1453 -1,
1454 EVAL_CPS_CONTEXT_FLAG_NOTHING,
1455 name);
1456 }
1457
1458 420 bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
1459
1460 420 lbm_value *mailbox = NULL;
1461 #ifdef LBM_ALWAYS_GC
1462 gc();
1463 #endif
1464 420 mailbox = (lbm_value*)lbm_memory_allocate(new_size);
1465
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 336 times.
 420 if (mailbox == NULL) {
1466 84 gc();
1467 84 mailbox = (lbm_value *)lbm_memory_allocate(new_size);
1468 }
1469
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 336 times.
 420 if (mailbox == NULL) {
1470 84 return false;
1471 }
1472
1473
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 336 times.
 336 for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
1474 ✗ mailbox[i] = ctx->mailbox[i];
1475 }
1476 336 lbm_memory_free(ctx->mailbox);
1477 336 ctx->mailbox = mailbox;
1478 336 ctx->mailbox_size = (uint32_t)new_size;
1479 336 return true;
1480 }
1481
1482 26995 static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {
1483
1484
2/2
✓ Branch 0 taken 47796 times.
✓ Branch 1 taken 26995 times.
 74791 for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
1485 47796 ctx->mailbox[i] = ctx->mailbox[i+1];
1486 }
1487 26995 ctx->num_mail --;
1488 26995 }
1489
1490 29855 static void mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {
1491
1492
2/2
✓ Branch 0 taken 1764 times.
✓ Branch 1 taken 28091 times.
 29855 if (ctx->num_mail >= ctx->mailbox_size) {
1493 1764 mailbox_remove_mail(ctx, 0);
1494 }
1495
1496 29855 ctx->mailbox[ctx->num_mail] = mail;
1497 29855 ctx->num_mail ++;
1498 29855 }
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 197921 static void advance_ctx(eval_context_t *ctx) {
1507
2/2
✓ Branch 0 taken 129749 times.
✓ Branch 1 taken 68172 times.
 197921 if (ctx->program) { // fast not-nil check, assume cons if not nil.
1508 129749 stack_reserve(ctx, 1)[0] = DONE;
1509 129749 lbm_cons_t *cell = lbm_ref_cell(ctx->program);
1510 129749 ctx->curr_exp = cell->car;
1511 129749 ctx->program = cell->cdr;
1512 129749 ctx->curr_env = ENC_SYM_NIL;
1513 } else {
1514
1/2
✓ Branch 0 taken 68172 times.
✗ Branch 1 not taken.
 68172 if (ctx_running == ctx) { // This should always be the case because of odd historical reasons.
1515 68172 ok_ctx();
1516 }
1517 }
1518 197921 }
1519
1520 252 bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
1521 252 return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
1522 }
1523
1524 84 bool lbm_unblock_ctx_r(lbm_cid cid) {
1525 84 lbm_mutex_lock(&blocking_extension_mutex);
1526 84 bool r = false;
1527 84 eval_context_t *found = NULL;
1528 84 lbm_mutex_lock(&qmutex);
1529 84 found = lookup_ctx_nm(&blocked, cid);
1530
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))) {
1531 84 drop_ctx_nm(&blocked,found);
1532 84 found->state = LBM_THREAD_STATE_READY;
1533 84 enqueue_ctx_nm(&queue,found);
1534 84 r = true;
1535 }
1536 84 lbm_mutex_unlock(&qmutex);
1537 84 lbm_mutex_unlock(&blocking_extension_mutex);
1538 84 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 337 static bool lbm_block_ctx_base(bool timeout, float t_s) {
1566 337 lbm_mutex_lock(&blocking_extension_mutex);
1567 337 blocking_extension = true;
1568
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 337 times.
 337 if (timeout) {
1569 ✗ blocking_extension_timeout_us = S_TO_US(t_s);
1570 ✗ blocking_extension_timeout = true;
1571 } else {
1572 337 blocking_extension_timeout = false;
1573 }
1574 337 return true;
1575 }
1576
1577 ✗ void lbm_block_ctx_from_extension_timeout(float s) {
1578 ✗ lbm_block_ctx_base(true, s);
1579 ✗ }
1580
1581 337 void lbm_block_ctx_from_extension(void) {
1582 337 lbm_block_ctx_base(false, 0);
1583 337 }
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 10028 static uint32_t lbm_mailbox_free_space_for_cid(lbm_cid cid) {
1601 10028 eval_context_t *found = NULL;
1602 10028 uint32_t res = 0;
1603
1604 10028 lbm_mutex_lock(&qmutex);
1605
1606 10028 found = lookup_ctx_nm(&blocked, cid);
1607
2/2
✓ Branch 0 taken 1641 times.
✓ Branch 1 taken 8387 times.
 10028 if (!found) {
1608 1641 found = lookup_ctx_nm(&queue, cid);
1609 }
1610
1/6
✗ Branch 0 not taken.
✓ Branch 1 taken 10028 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
 10028 if (!found && ctx_running && ctx_running->id == cid) {
1611 ✗ found = ctx_running;
1612 }
1613
1614
1/2
✓ Branch 0 taken 10028 times.
✗ Branch 1 not taken.
 10028 if (found) {
1615 10028 res = found->mailbox_size - found->num_mail;
1616 }
1617
1618 10028 lbm_mutex_unlock(&qmutex);
1619
1620 10028 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 29435 bool lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
1628 29435 lbm_mutex_lock(&qmutex);
1629 29435 eval_context_t *found = NULL;
1630 29435 int res = true;
1631
1632 29435 found = lookup_ctx_nm(&blocked, cid);
1633
2/2
✓ Branch 0 taken 17373 times.
✓ Branch 1 taken 12062 times.
 29435 if (found) {
1634
2/2
✓ Branch 0 taken 17326 times.
✓ Branch 1 taken 47 times.
 17373 if (LBM_IS_STATE_RECV(found->state)) { // only if unblock receivers here.
1635 17326 drop_ctx_nm(&blocked,found);
1636 17326 found->state = LBM_THREAD_STATE_READY;
1637 17326 enqueue_ctx_nm(&queue,found);
1638 }
1639 17373 mailbox_add_mail(found, msg);
1640 17373 goto find_receiver_end;
1641 }
1642
1643 12062 found = lookup_ctx_nm(&queue, cid);
1644
2/2
✓ Branch 0 taken 3074 times.
✓ Branch 1 taken 8988 times.
 12062 if (found) {
1645 3074 mailbox_add_mail(found, msg);
1646 3074 goto find_receiver_end;
1647 }
1648
1649 /* check the current context */
1650
2/4
✓ Branch 0 taken 8988 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 8988 times.
✗ Branch 3 not taken.
 8988 if (ctx_running && ctx_running->id == cid) {
1651 8988 mailbox_add_mail(ctx_running, msg);
1652 8988 goto find_receiver_end;
1653 }
1654 ✗ res = false;
1655 29435 find_receiver_end:
1656 29435 lbm_mutex_unlock(&qmutex);
1657 29435 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 493509 static inline lbm_value get_match_binder_variable(lbm_value exp) {
1663 493509 lbm_value var = ENC_SYM_NIL; // 0 false
1664
2/2
✓ Branch 0 taken 281700 times.
✓ Branch 1 taken 211809 times.
 493509 if (lbm_is_cons(exp)) {
1665 281700 lbm_cons_t *e_cell = lbm_ref_cell(exp);
1666 281700 lbm_value bt = e_cell->car;
1667
3/4
✓ Branch 0 taken 61760 times.
✓ Branch 1 taken 219940 times.
✓ Branch 2 taken 61760 times.
✗ Branch 3 not taken.
 281700 if (bt == ENC_SYM_MATCH_ANY && lbm_is_cons(e_cell->cdr)) {
1668 61760 var = lbm_ref_cell(e_cell->cdr)->car;
1669 }
1670 }
1671 493509 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 493509 static bool match(lbm_value p, lbm_value e, lbm_value *env) {
1678 493509 bool r = false;
1679 493509 lbm_value var = get_match_binder_variable(p);
1680
2/2
✓ Branch 0 taken 61760 times.
✓ Branch 1 taken 431749 times.
 493509 if (var) {
1681 #ifdef LBM_ALWAYS_GC
1682 lbm_gc_mark_phase(*env);
1683 gc();
1684 #endif
1685 61760 lbm_value ls = lbm_heap_allocate_list_init(2, var, ENC_SYM_NIL);
1686
2/2
✓ Branch 0 taken 42 times.
✓ Branch 1 taken 61718 times.
 61760 if (!lbm_is_ptr(ls)) {
1687 42 lbm_gc_mark_phase(*env);
1688 42 gc();
1689 42 ls = lbm_heap_allocate_list_init(2, var, ENC_SYM_NIL);
1690
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 42 times.
 42 if (!lbm_is_ptr(ls)) {
1691 ✗ ERROR_CTX(ls);
1692 }
1693 }
1694 61760 lbm_value c1 = ls;
1695 61760 lbm_value c2 = lbm_cdr(ls);
1696 61760 lbm_set_cdr(c1, e);
1697 61760 lbm_set_car_and_cdr(c2, c1, *env);
1698 61760 *env = c2;
1699 61760 r = true;
1700
2/2
✓ Branch 0 taken 206769 times.
✓ Branch 1 taken 224980 times.
 431749 } else if (lbm_is_symbol(p)) {
1701
2/2
✓ Branch 0 taken 3864 times.
✓ Branch 1 taken 202905 times.
 206769 if (p == ENC_SYM_DONTCARE) r = true;
1702 202905 else r = (p == e);
1703
4/4
✓ Branch 0 taken 219940 times.
✓ Branch 1 taken 5040 times.
✓ Branch 2 taken 216412 times.
✓ Branch 3 taken 3528 times.
 224980 } else if (lbm_is_cons(p) && lbm_is_cons(e) ) {
1704 216412 lbm_cons_t *p_cell = lbm_ref_cell(p);
1705 216412 lbm_cons_t *e_cell = lbm_ref_cell(e);
1706 216412 lbm_value headp = p_cell->car;
1707 216412 lbm_value tailp = p_cell->cdr;
1708 216412 lbm_value heade = e_cell->car;
1709 216412 lbm_value taile = e_cell->cdr;
1710 216412 r = match(headp, heade, env);
1711
4/4
✓ Branch 0 taken 75494 times.
✓ Branch 1 taken 140918 times.
✓ Branch 2 taken 74321 times.
✓ Branch 3 taken 1173 times.
 216412 r = r && match (tailp, taile, env);
1712 } else {
1713 8568 r = struct_eq(p, e);
1714 }
1715 493509 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 25483 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 25483 lbm_value curr_p = plist;
1725 25483 int n = 0;
1726
2/2
✓ Branch 0 taken 26995 times.
✓ Branch 1 taken 252 times.
 27247 for (int i = 0; i < (int)num; i ++ ) {
1727 26995 lbm_value curr_e = earr[i];
1728
2/2
✓ Branch 0 taken 57991 times.
✓ Branch 1 taken 1764 times.
 59755 while (lbm_is_cons(curr_p)) {
1729 lbm_value p[3];
1730 57991 lbm_value curr = lbm_ref_cell(curr_p)->car;
1731 57991 extract_n(curr, p, 3);
1732
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 57991 times.
 57991 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 25231 times.
✓ Branch 1 taken 32760 times.
 57991 if (match(p[0], curr_e, env)) {
1737 25231 *e = p[1];
1738 25231 return n;
1739 }
1740 32760 curr_p = lbm_ref_cell(curr_p)->cdr;
1741 }
1742 1764 curr_p = plist; /* search all patterns against next exp */
1743 1764 n ++;
1744 }
1745 252 return FM_NO_MATCH;
1746 }
1747
1748 /****************************************************/
1749 /* Garbage collection */
1750
1751 1643974 static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
1752 (void) arg1;
1753 (void) arg2;
1754 1643974 lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r};
1755 1643974 lbm_gc_mark_env(ctx->curr_env);
1756 1643974 lbm_gc_mark_roots(roots, 3);
1757 1643974 lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
1758 1643974 lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
1759 1643974 }
1760
1761 1606087 static int gc(void) {
1762
2/2
✓ Branch 0 taken 1606001 times.
✓ Branch 1 taken 86 times.
 1606087 if (ctx_running) {
1763 1606001 ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT;
1764 }
1765
1766 1606087 gc_requested = false;
1767 1606087 lbm_gc_state_inc();
1768
1769 // The freelist should generally be NIL when GC runs.
1770 1606087 lbm_nil_freelist();
1771 1606087 lbm_value *env = lbm_get_global_env();
1772
2/2
✓ Branch 0 taken 51394761 times.
✓ Branch 1 taken 1606086 times.
 53000847 for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
1773 51394761 lbm_gc_mark_env(env[i]);
1774 }
1775
1776 1606086 lbm_mutex_lock(&qmutex); // Lock the queues.
1777 // Any concurrent messing with the queues
1778 // while doing GC cannot possibly be good.
1779 1606086 queue_iterator_nm(&queue, mark_context, NULL, NULL);
1780 1606086 queue_iterator_nm(&blocked, mark_context, NULL, NULL);
1781
1782
2/2
✓ Branch 0 taken 1606001 times.
✓ Branch 1 taken 85 times.
 1606086 if (ctx_running) {
1783 1606001 mark_context(ctx_running, NULL, NULL);
1784 }
1785 1606086 lbm_mutex_unlock(&qmutex);
1786
1787 1606086 int r = lbm_gc_sweep_phase();
1788 1606086 lbm_heap_new_freelist_length();
1789 1606086 lbm_memory_update_min_free();
1790
1791
2/2
✓ Branch 0 taken 1606001 times.
✓ Branch 1 taken 85 times.
 1606086 if (ctx_running) {
1792 1606001 ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT;
1793 }
1794 1606086 return r;
1795 }
1796
1797 41944 int lbm_perform_gc(void) {
1798 41944 return gc();
1799 }
1800
1801 /****************************************************/
1802 /* Evaluation functions */
1803
1804
1805 1351469523 static void eval_symbol(eval_context_t *ctx) {
1806 1351469523 lbm_uint s = lbm_dec_sym(ctx->curr_exp);
1807
2/2
✓ Branch 0 taken 655030997 times.
✓ Branch 1 taken 696438526 times.
 1351469523 if (s >= RUNTIME_SYMBOLS_START) {
1808 655030997 lbm_value res = ENC_SYM_NIL;
1809
4/4
✓ Branch 0 taken 115575538 times.
✓ Branch 1 taken 539455460 times.
✓ Branch 2 taken 115558441 times.
✓ Branch 3 taken 17097 times.
 770606535 if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
1810 115575538 lbm_global_env_lookup(&res, ctx->curr_exp)) {
1811 655013901 ctx->r = res;
1812 655013901 ctx->app_cont = true;
1813 655013901 return;
1814 }
1815 // Dynamic load attempt
1816 // Only symbols of kind RUNTIME can be dynamically loaded.
1817 17097 const char *sym_str = lbm_get_name_by_symbol(s);
1818 17097 const char *code_str = NULL;
1819
2/2
✓ Branch 0 taken 276 times.
✓ Branch 1 taken 16821 times.
 17097 if (!dynamic_load_callback(sym_str, &code_str)) {
1820 276 ERROR_AT_CTX(ENC_SYM_NOT_FOUND, ctx->curr_exp);
1821 }
1822 16821 lbm_value *sptr = stack_reserve(ctx, 3);
1823 16821 sptr[0] = ctx->curr_exp;
1824 16821 sptr[1] = ctx->curr_env;
1825 16821 sptr[2] = RESUME;
1826
1827 16821 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 16821 times.
 16821 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 16821 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 16821 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 16821 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 16821 WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,
1846 ENC_SYM_EVAL,
1847 loader), loader);
1848 16821 ctx->curr_exp = evaluator;
1849 16821 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 696438526 ctx->r = ctx->curr_exp;
1853 696438526 ctx->app_cont = true;
1854 }
1855 }
1856
1857 // (quote e) => e
1858 14854955 static void eval_quote(eval_context_t *ctx) {
1859 14854955 ctx->r = get_cadr(ctx->curr_exp);
1860 14854955 ctx->app_cont = true;
1861 14854955 }
1862
1863 // a => a
1864 749572865 static void eval_selfevaluating(eval_context_t *ctx) {
1865 749572865 ctx->r = ctx->curr_exp;
1866 749572865 ctx->app_cont = true;
1867 749572865 }
1868
1869 // (progn e1 ... en)
1870 53770145 static void eval_progn(eval_context_t *ctx) {
1871 53770145 lbm_value exps = get_cdr(ctx->curr_exp);
1872
1873
2/2
✓ Branch 0 taken 53770061 times.
✓ Branch 1 taken 84 times.
 53770145 if (lbm_is_cons(exps)) {
1874 53770061 lbm_cons_t *cell = lbm_ref_cell(exps); // already checked that it's cons.
1875 53770061 ctx->curr_exp = cell->car;
1876
2/2
✓ Branch 0 taken 45359425 times.
✓ Branch 1 taken 8410636 times.
 53770061 if (lbm_is_cons(cell->cdr)) { // malformed progn not ending in nil is tolerated
1877 45359425 lbm_uint *sptr = stack_reserve(ctx, 4);
1878 45359425 sptr[0] = ctx->curr_env; // env to restore between expressions in progn
1879 45359425 sptr[1] = lbm_enc_u(0); // Has env been copied (needed for progn local bindings)
1880 45359425 sptr[2] = cell->cdr; // Requirement: sptr[2] is a cons.
1881 45359425 sptr[3] = PROGN_REST;
1882 }
1883
1/2
✓ Branch 0 taken 84 times.
✗ Branch 1 not taken.
 84 } else if (lbm_is_symbol_nil(exps)) { // Empty progn is nil
1884 84 ctx->r = ENC_SYM_NIL;
1885 84 ctx->app_cont = true;
1886 } else {
1887 ✗ ERROR_CTX(ENC_SYM_EERROR);
1888 }
1889 53770145 }
1890
1891 // (atomic e1 ... en)
1892 757 static void eval_atomic(eval_context_t *ctx) {
1893
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 757 times.
 757 if (is_atomic) atomic_error();
1894 757 stack_reserve(ctx, 1)[0] = EXIT_ATOMIC;
1895 757 is_atomic = true;
1896 757 eval_progn(ctx);
1897 757 }
1898
1899 // (call-cc (lambda (k) .... ))
1900 924 static void eval_callcc(eval_context_t *ctx) {
1901 lbm_value cont_array;
1902 924 lbm_uint *sptr0 = stack_reserve(ctx, 1);
1903
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 924 times.
 924 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 924 times.
 924 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 924 times.
✗ Branch 1 not taken.
 924 if (lbm_is_ptr(cont_array)) {
1912 924 lbm_array_header_t *arr = assume_array(cont_array);
1913 924 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 924 lbm_value acont = cons_with_gc(ENC_SYM_CONT, cont_array, ENC_SYM_NIL);
1918 924 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
1919 // Go directly into application evaluation without passing go
1920 924 lbm_uint *sptr = stack_reserve(ctx, 2);
1921 924 sptr0[0] = ctx->curr_env;
1922 924 sptr[0] = arg_list;
1923 924 sptr[1] = APPLICATION_START;
1924 924 ctx->curr_exp = get_cadr(ctx->curr_exp);
1925 } else {
1926 // failed to create continuation array.
1927 ✗ ERROR_CTX(ENC_SYM_MERROR);
1928 }
1929 924 }
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 2456 static void eval_call_cc_unsafe(eval_context_t *ctx) {
1937 2456 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 2456 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 2456 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 2456 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 2456 lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
1946 // Go directly into application evaluation without passing go
1947 2456 lbm_uint *sptr = stack_reserve(ctx, 3);
1948 2456 sptr[0] = ctx->curr_env;
1949 2456 sptr[1] = arg_list;
1950 2456 sptr[2] = APPLICATION_START;
1951 2456 ctx->curr_exp = get_cadr(ctx->curr_exp);
1952 2456 }
1953
1954 // (define sym exp)
1955 #define KEY 1
1956 #define VAL 2
1957 21248841 static void eval_define(eval_context_t *ctx) {
1958 lbm_value parts[3];
1959 21248841 lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
1960 21248841 lbm_uint *sptr = stack_reserve(ctx, 2);
1961
3/4
✓ Branch 0 taken 21248840 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 21248840 times.
✗ Branch 3 not taken.
 21248841 if (lbm_is_symbol(parts[KEY]) && lbm_is_symbol_nil(rest)) {
1962 21248840 lbm_uint sym_val = lbm_dec_sym(parts[KEY]);
1963 21248840 sptr[0] = parts[KEY];
1964
2/2
✓ Branch 0 taken 21248837 times.
✓ Branch 1 taken 3 times.
 21248840 if (sym_val >= RUNTIME_SYMBOLS_START) {
1965 21248837 sptr[1] = SET_GLOBAL_ENV;
1966
2/2
✓ Branch 0 taken 165 times.
✓ Branch 1 taken 21248672 times.
 21248837 if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST) {
1967 165 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
1968 }
1969 21248837 ctx->curr_exp = parts[VAL];
1970 21248837 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 459978 static void eval_lambda(eval_context_t *ctx) {
2055 #ifdef LBM_ALWAYS_GC
2056 gc();
2057 #endif
2058
1/2
✓ Branch 0 taken 461183 times.
✗ Branch 1 not taken.
 461183 for (int retry = 0; retry < 2; retry ++) {
2059
2/2
✓ Branch 0 taken 459978 times.
✓ Branch 1 taken 1205 times.
 461183 if (lbm_heap_num_free() >= 4) {
2060 459978 lbm_value clo = lbm_heap_state.freelist;
2061 459978 lbm_value lam = get_cdr(ctx->curr_exp);
2062 459978 lbm_uint ix = lbm_dec_ptr(clo);
2063 459978 lbm_cons_t *heap = lbm_heap_state.heap;
2064 459978 heap[ix].car = ENC_SYM_CLOSURE;
2065 459978 ix = lbm_dec_ptr(heap[ix].cdr);
2066 459978 get_car_and_cdr(lam, &heap[ix].car, &lam); // params
2067 459978 ix = lbm_dec_ptr(heap[ix].cdr);
2068 459978 get_car_and_cdr(lam, &heap[ix].car, &lam); // body
2069 459973 ix = lbm_dec_ptr(heap[ix].cdr);
2070 459973 heap[ix].car = ctx->curr_env;
2071 459973 lbm_heap_state.freelist = heap[ix].cdr;
2072 459973 heap[ix].cdr = ENC_SYM_NIL;
2073 459973 lbm_heap_state.num_free-=4;
2074 459973 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 459973 ctx->app_cont = true;
2091 #endif
2092 459973 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 83720691 static void eval_if(eval_context_t *ctx) {
2103 83720691 lbm_value cdr = get_cdr(ctx->curr_exp);
2104 83720691 lbm_value *sptr = stack_reserve(ctx, 3);
2105 83720691 get_car_and_cdr(cdr, &ctx->curr_exp, &sptr[0]);
2106 83720690 sptr[1] = ctx->curr_env;
2107 83720690 sptr[2] = IF;
2108 83720690 }
2109
2110 // (cond (cond-expr-1 expr-1)
2111 // ...
2112 // (cond-expr-N expr-N))
2113 6168 static void eval_cond(eval_context_t *ctx) {
2114 lbm_value cond1[2];
2115 6168 lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);
2116
2117 // end recursion at (cond )
2118
2/2
✓ Branch 0 taken 88 times.
✓ Branch 1 taken 6080 times.
 6168 if (lbm_is_symbol_nil(cond1[1])) {
2119 88 ctx->r = ENC_SYM_NIL;
2120 88 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 6080 lbm_uint len = lbm_list_length(cond1[1]);
2125
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6080 times.
 6080 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 6080 extract_n(cond1[1], cond_expr, 2);
2131 lbm_value rest;
2132
3/4
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 6074 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 6 times.
 6080 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 6080 lbm_value *sptr = stack_reserve(ctx, 3);
2136 6080 sptr[0] = rest;
2137 6080 sptr[1] = ctx->curr_env;
2138 6080 sptr[2] = IF;
2139 6080 ctx->curr_exp = cond_expr[0]; //condition;
2140 }
2141 6168 }
2142
2143 34892 static void eval_app_cont(eval_context_t *ctx) {
2144 34892 lbm_stack_drop(&ctx->K, 1);
2145 34892 ctx->app_cont = true;
2146 34892 }
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 122675252 static void create_binding_location(lbm_value key, lbm_value *env) {
2151
2/2
✓ Branch 0 taken 80672139 times.
✓ Branch 1 taken 42003113 times.
 122675252 if (lbm_is_symbol(key)) { // default case
2152
4/4
✓ Branch 0 taken 72271887 times.
✓ Branch 1 taken 8400252 times.
✓ Branch 2 taken 8400336 times.
✓ Branch 3 taken 63871551 times.
 80672139 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 63871551 lbm_value ls = lbm_heap_allocate_list_init(2,
2158 key,
2159 ENC_SYM_NIL);
2160
2/2
✓ Branch 0 taken 86883 times.
✓ Branch 1 taken 63784668 times.
 63871551 if (!lbm_is_ptr(ls)) {
2161 86883 lbm_gc_mark_phase(*env);
2162 86883 gc();
2163 86883 ls = lbm_heap_allocate_list_init(2,
2164 key,
2165 ENC_SYM_NIL);
2166
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 86883 times.
 86883 if (!lbm_is_ptr(ls)) ERROR_CTX(ENC_SYM_MERROR);
2167 }
2168 63871551 lbm_value binding = ls;
2169 63871551 lbm_cons_t *ls_ref = lbm_ref_cell(ls);
2170 63871551 lbm_value new_env = ls_ref->cdr;
2171 63871551 ls_ref->cdr = ENC_SYM_PLACEHOLDER; // known cons
2172 //lbm_set_cdr(binding, ENC_SYM_PLACEHOLDER);
2173 63871551 lbm_cons_t *new_env_ref = lbm_ref_cell(new_env); //known cons
2174 63871551 new_env_ref->car = binding;
2175 63871551 new_env_ref->cdr = *env;
2176 //lbm_set_car_and_cdr(new_env,binding, *env);
2177 63871551 *env = new_env;
2178
2/2
✓ Branch 0 taken 42003109 times.
✓ Branch 1 taken 4 times.
 42003113 } else if (lbm_is_cons(key)) { // deconstruct case
2179 42003109 create_binding_location(lbm_ref_cell(key)->car, env);
2180 42003109 create_binding_location(lbm_ref_cell(key)->cdr, env);
2181 } else {
2182 4 ERROR_CTX(ENC_SYM_EERROR);
2183 }
2184 }
2185
2186 36390490 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 36390488 times.
✓ Branch 1 taken 2 times.
 36390490 if (lbm_is_cons(binds)) {
2188 // Preallocate binding locations.
2189 36390488 lbm_value curr = binds;
2190
2/2
✓ Branch 0 taken 36735565 times.
✓ Branch 1 taken 36390485 times.
 73126050 while (lbm_is_cons(curr)) {
2191 36735565 lbm_value new_env_tmp = env;
2192 36735565 lbm_cons_t *cell = lbm_ref_cell(curr); // already checked that cons.
2193 36735565 lbm_value car_curr = cell->car;
2194 36735565 lbm_value cdr_curr = cell->cdr;
2195 36735565 lbm_value key = get_car(car_curr);
2196 36735565 create_binding_location(key, &new_env_tmp);
2197 36735562 env = new_env_tmp;
2198 36735562 curr = cdr_curr;
2199 }
2200
2201 36390485 lbm_cons_t *cell = lbm_ref_cell(binds); // already checked that cons.
2202 36390485 lbm_value car_binds = cell->car;
2203 36390485 lbm_value cdr_binds = cell->cdr;
2204 lbm_value key_val[2];
2205 36390485 extract_n(car_binds, key_val, 2);
2206
2207 36390485 lbm_uint *sptr = stack_reserve(ctx, 5);
2208 36390485 sptr[0] = exp;
2209 36390485 sptr[1] = cdr_binds;
2210 36390485 sptr[2] = env;
2211 36390485 sptr[3] = key_val[0];
2212 36390485 sptr[4] = BIND_TO_KEY_REST;
2213 36390485 ctx->curr_exp = key_val[1];
2214 36390485 ctx->curr_env = env;
2215 } else {
2216 2 ctx->curr_exp = exp;
2217 }
2218 36390487 }
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 1933471 static void eval_var(eval_context_t *ctx) {
2231
1/2
✓ Branch 0 taken 1933471 times.
✗ Branch 1 not taken.
 1933471 if (ctx->K.sp >= 4) { // Possibly in progn
2232 1933471 lbm_value sv = ctx->K.data[ctx->K.sp - 1];
2233
3/4
✓ Branch 0 taken 1933471 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 1933469 times.
✓ Branch 3 taken 2 times.
 1933471 if (IS_CONTINUATION(sv) && (sv == PROGN_REST)) {
2234 1933469 lbm_uint sp = ctx->K.sp;
2235 1933469 uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
2236
2/2
✓ Branch 0 taken 1897202 times.
✓ Branch 1 taken 36267 times.
 1933469 if (is_copied == 0) {
2237 lbm_value env;
2238
3/4
✓ Branch 0 taken 2172 times.
✓ Branch 1 taken 1895030 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 2172 times.
 1897202 WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]));
2239 1897202 ctx->K.data[sp-3] = lbm_enc_u(1);
2240 1897202 ctx->K.data[sp-4] = env;
2241 }
2242 1933469 lbm_value new_env = ctx->K.data[sp-4];
2243 1933469 lbm_value args = get_cdr(ctx->curr_exp);
2244 1933469 lbm_value key = get_car(args);
2245 1933469 create_binding_location(key, &new_env);
2246
2247 1933468 ctx->K.data[sp-4] = new_env;
2248
2249 1933468 lbm_value v_exp = get_cadr(args);
2250 1933468 lbm_value *sptr = stack_reserve(ctx, 3);
2251 1933468 sptr[0] = new_env;
2252 1933468 sptr[1] = key;
2253 1933468 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 1933468 ctx->curr_env = new_env;
2260 1933468 ctx->curr_exp = v_exp;
2261 1933468 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 6703752 static void eval_setq(eval_context_t *ctx) {
2271 lbm_value parts[3];
2272 6703752 extract_n(ctx->curr_exp, parts, 3);
2273 6703752 lbm_value *sptr = stack_reserve(ctx, 3);
2274 6703752 sptr[0] = ctx->curr_env;
2275 6703752 sptr[1] = parts[1];
2276 6703752 sptr[2] = SETQ;
2277 6703752 ctx->curr_exp = parts[2];
2278 6703752 }
2279
2280 1092 static void eval_move_to_flash(eval_context_t *ctx) {
2281 1092 lbm_value args = get_cdr(ctx->curr_exp);
2282 1092 lbm_value *sptr = stack_reserve(ctx,2);
2283 1092 sptr[0] = args;
2284 1092 sptr[1] = MOVE_TO_FLASH;
2285 1092 ctx->app_cont = true;
2286 1092 }
2287
2288 // (loop list-of-local-bindings
2289 // condition-exp
2290 // body-exp)
2291 840 static void eval_loop(eval_context_t *ctx) {
2292 840 lbm_value env = ctx->curr_env;
2293 lbm_value parts[3];
2294 840 extract_n(get_cdr(ctx->curr_exp), parts, 3);
2295 840 lbm_value *sptr = stack_reserve(ctx, 4);
2296 840 sptr[0] = parts[LOOP_BODY];
2297 840 sptr[1] = parts[LOOP_COND];
2298 840 sptr[2] = ENC_SYM_NIL;
2299 840 sptr[3] = LOOP_ENV_PREP;
2300 840 let_bind_values_eval(parts[LOOP_BINDS], ENC_SYM_NIL, env, ctx);
2301 840 }
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 25187 static void eval_trap(eval_context_t *ctx) {
2311
2312 25187 lbm_value expr = get_cadr(ctx->curr_exp);
2313 lbm_value retval;
2314
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 25187 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 25187 WITH_GC(retval, lbm_heap_allocate_list(2));
2315 25187 lbm_ref_cell(retval)->car = ENC_SYM_EXIT_OK;
2316 // lbm_set_car(retval, ENC_SYM_EXIT_OK); // Assume things will go well.
2317 25187 lbm_uint *sptr = stack_reserve(ctx,3);
2318 25187 sptr[0] = retval;
2319 25187 sptr[1] = ctx->flags;
2320 25187 sptr[2] = EXCEPTION_HANDLER;
2321 25187 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN;
2322 25187 ctx->curr_exp = expr;
2323 25187 }
2324
2325 // (let list-of-binding s
2326 // body-exp)
2327 36389650 static void eval_let(eval_context_t *ctx) {
2328 36389650 lbm_value env = ctx->curr_env;
2329 lbm_value parts[3];
2330 36389650 extract_n(ctx->curr_exp, parts, 3);
2331 36389650 let_bind_values_eval(parts[1], parts[2], env, ctx);
2332 36389647 }
2333
2334 // (and exp0 ... expN)
2335 47985076 static void eval_and(eval_context_t *ctx) {
2336 47985076 lbm_value rest = get_cdr(ctx->curr_exp);
2337
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 47984992 times.
 47985076 if (lbm_is_symbol_nil(rest)) {
2338 84 ctx->app_cont = true;
2339 84 ctx->r = ENC_SYM_TRUE;
2340 } else {
2341 47984992 lbm_value *sptr = stack_reserve(ctx, 3);
2342 47984992 get_car_and_cdr(rest, &ctx->curr_exp, &sptr[1]);
2343 47984991 sptr[0] = ctx->curr_env;
2344 47984991 sptr[2] = AND;
2345 }
2346 47985075 }
2347
2348 // (or exp0 ... expN)
2349 21821 static void eval_or(eval_context_t *ctx) {
2350 21821 lbm_value rest = get_cdr(ctx->curr_exp);
2351
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 21737 times.
 21821 if (lbm_is_symbol_nil(rest)) {
2352 84 ctx->app_cont = true;
2353 84 ctx->r = ENC_SYM_NIL;
2354 } else {
2355 21737 lbm_value *sptr = stack_reserve(ctx, 3);
2356 21737 get_car_and_cdr(rest, &ctx->curr_exp, &sptr[1]);
2357 21736 sptr[0] = ctx->curr_env;
2358 21736 sptr[2] = OR;
2359 }
2360 21820 }
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 26244 static void eval_match(eval_context_t *ctx) {
2376
2377 26244 lbm_value rest = get_cdr(ctx->curr_exp);
2378
2/2
✓ Branch 0 taken 26242 times.
✓ Branch 1 taken 2 times.
 26244 if (lbm_is_cons(rest)) {
2379 26242 lbm_cons_t *cell = lbm_ref_cell(rest);
2380 26242 lbm_value cdr_rest = cell->cdr;
2381 26242 ctx->curr_exp = cell->car;
2382 26242 lbm_value *sptr = stack_reserve(ctx, 3);
2383 26242 sptr[0] = cdr_rest;
2384 26242 sptr[1] = ctx->curr_env;
2385 26242 sptr[2] = MATCH;
2386 } else {
2387 // someone wrote the program (match)
2388 2 ERROR_CTX(ENC_SYM_EERROR);
2389 }
2390 26242 }
2391
2392 // Receive-timeout
2393 // (recv-to timeout (pattern expr)
2394 // (pattern expr))
2395 756 static void eval_receive_timeout(eval_context_t *ctx) {
2396
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 756 times.
 756 if (is_atomic) atomic_error();
2397 756 lbm_value timeout_val = get_cadr(ctx->curr_exp);
2398 756 lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
2399
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 588 times.
 756 if (lbm_is_symbol_nil(pats)) {
2400 168 lbm_set_error_reason((char*)lbm_error_str_num_args);
2401 168 ERROR_AT_CTX(ENC_SYM_EERROR, ctx->curr_exp);
2402 } else {
2403 588 lbm_value *sptr = stack_reserve(ctx, 2);
2404 588 sptr[0] = pats;
2405 588 sptr[1] = RECV_TO;
2406 588 ctx->curr_exp = timeout_val;
2407 }
2408 588 }
2409
2410 // Receive
2411 // (recv (pattern expr)
2412 // (pattern expr))
2413 42564 static void eval_receive(eval_context_t *ctx) {
2414
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 42563 times.
 42564 if (is_atomic) atomic_error();
2415 42563 lbm_value pats = get_cdr(ctx->curr_exp);
2416
2/2
✓ Branch 0 taken 42479 times.
✓ Branch 1 taken 84 times.
 42563 if (pats) { // non-nil check
2417
2/2
✓ Branch 0 taken 17584 times.
✓ Branch 1 taken 24895 times.
 42479 if (ctx->num_mail == 0) {
2418 17584 block_current_ctx(LBM_THREAD_STATE_RECV_BL,0,false);
2419 } else {
2420 24895 lbm_value *msgs = ctx->mailbox;
2421 24895 lbm_uint num = ctx->num_mail;
2422
2423 lbm_value e;
2424 24895 lbm_value new_env = ctx->curr_env;
2425 24895 int n = find_match(pats, msgs, num, &e, &new_env);
2426
1/2
✓ Branch 0 taken 24895 times.
✗ Branch 1 not taken.
 24895 if (n >= 0 ) { /* Match */
2427 24895 mailbox_remove_mail(ctx, (lbm_uint)n);
2428 24895 ctx->curr_env = new_env;
2429 24895 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 84 lbm_set_error_reason((char*)lbm_error_str_num_args);
2437 84 ERROR_AT_CTX(ENC_SYM_EERROR,ctx->curr_exp);
2438 }
2439 42479 }
2440
2441 /*********************************************************/
2442 /* Continuation functions */
2443
2444 // cont_set_global_env:
2445 //
2446 // s[sp-1] = Key-symbol
2447 //
2448 // ctx->r = Value
2449 21250208 static void cont_set_global_env(eval_context_t *ctx){
2450
2451 21250208 lbm_value val = ctx->r;
2452
2453 21250208 lbm_value key = ctx->K.data[--ctx->K.sp];
2454 21250208 lbm_uint dec_key = lbm_dec_sym(key);
2455 21250208 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
2456 21250208 lbm_value *global_env = lbm_get_global_env();
2457 21250208 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 6690 times.
✓ Branch 1 taken 21243518 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 6690 times.
 21250208 WITH_GC(new_env, lbm_env_set(orig_env,key,val));
2461
2462 21250208 global_env[ix_key] = new_env;
2463 21250208 ctx->r = val;
2464
2465 21250208 ctx->app_cont = true;
2466 21250208 }
2467
2468 // cont_resume:
2469 //
2470 // s[sp-2] = Expression
2471 // s[sp-1] = Environment
2472 //
2473 // ctx->r = Irrelevant.
2474 16815 static void cont_resume(eval_context_t *ctx) {
2475 16815 ctx->curr_env = ctx->K.data[--ctx->K.sp];
2476 16815 ctx->curr_exp = ctx->K.data[--ctx->K.sp];
2477 16815 }
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 53422429 static void cont_progn_rest(eval_context_t *ctx) {
2487 53422429 lbm_value *sptr = get_stack_ptr(ctx, 3);
2488
2489 53422429 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 53422429 lbm_cons_t *rest_cell = lbm_ref_cell(sptr[2]);
2494 53422429 lbm_value rest_cdr = rest_cell->cdr;
2495 53422429 ctx->curr_exp = rest_cell->car;;
2496 53422429 ctx->curr_env = env;
2497
2/2
✓ Branch 0 taken 8063865 times.
✓ Branch 1 taken 45358564 times.
 53422429 if (lbm_is_cons(rest_cdr)) {
2498 8063865 sptr[2] = rest_cdr; // Requirement: rest_cdr is a cons
2499 8063865 stack_reserve(ctx, 1)[0] = PROGN_REST;
2500 } else {
2501 // Nothing is pushed to stack for final element in progn. (tail-call req)
2502 45358564 lbm_stack_drop(&ctx->K, 3);
2503 }
2504 53422429 }
2505
2506 // cont_wait
2507 //
2508 // s[sp-1] = cid
2509 289 static void cont_wait(eval_context_t *ctx) {
2510
2511 289 lbm_value cid_val = ctx->K.data[--ctx->K.sp];
2512 289 lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);
2513
2514 289 bool exists = false;
2515
2516 289 lbm_blocked_iterator(context_exists, &cid, &exists);
2517 289 lbm_running_iterator(context_exists, &cid, &exists);
2518
2519
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 289 times.
 289 if (ctx_running->id == cid) {
2520 ✗ exists = true;
2521 }
2522
2523
2/2
✓ Branch 0 taken 119 times.
✓ Branch 1 taken 170 times.
 289 if (exists) {
2524 119 lbm_value *sptr = stack_reserve(ctx, 2);
2525 119 sptr[0] = lbm_enc_i(cid);
2526 119 sptr[1] = WAIT;
2527 119 ctx->r = ENC_SYM_TRUE;
2528 119 ctx->app_cont = true;
2529 119 yield_ctx(50000);
2530 } else {
2531 170 ctx->r = ENC_SYM_TRUE;
2532 170 ctx->app_cont = true;
2533 }
2534 289 }
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 840 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 840 lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/
2555
2556
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 840 times.
 840 if (!lbm_is_lisp_array_r(c)) {
2557 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
2558 }
2559
2560 lbm_value arg;
2561 840 lbm_uint arg_count = lbm_list_length(args);
2562
2/3
✓ Branch 0 taken 252 times.
✓ Branch 1 taken 588 times.
✗ Branch 2 not taken.
 840 switch (arg_count) {
2563 252 case 0:
2564 252 arg = ENC_SYM_NIL;
2565 252 break;
2566 588 case 1:
2567 588 arg = get_car(args);
2568 588 break;
2569 ✗ default:
2570 ✗ lbm_set_error_reason(lbm_error_str_num_args);
2571 ✗ ERROR_CTX(ENC_SYM_EERROR);
2572 }
2573
2574 840 lbm_stack_clear(&ctx->K);
2575
2576 840 lbm_array_header_t *arr = assume_array(c);
2577 840 ctx->K.sp = arr->size / sizeof(lbm_uint);
2578 840 memcpy(ctx->K.data, arr->data, arr->size);
2579
2580 840 lbm_value atomic = ctx->K.data[--ctx->K.sp];
2581 840 is_atomic = atomic ? 1 : 0;
2582
2583 840 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 252 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 252 lbm_value c = get_cadr(ctx->r); /* should be the stack_ptr*/
2600 252 lbm_value atomic = get_cadr(get_cdr(ctx->r));
2601
2602
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 252 times.
 252 if (!lbm_is_number(c)) {
2603 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
2604 }
2605
2606 252 lbm_uint sp = (lbm_uint)lbm_dec_i(c);
2607
2608 lbm_value arg;
2609 252 lbm_uint arg_count = lbm_list_length(args);
2610
2/3
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 168 times.
✗ Branch 2 not taken.
 252 switch (arg_count) {
2611 84 case 0:
2612 84 arg = ENC_SYM_NIL;
2613 84 break;
2614 168 case 1:
2615 168 arg = get_car(args);
2616 168 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 252 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 252 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 252 times.
✗ Branch 5 not taken.
 252 if (sp > 0 && sp <= ctx->K.sp && IS_CONTINUATION(ctx->K.data[sp-1])) {
2623 252 is_atomic = atomic ? 1 : 0; // works fine with nil/true
2624 252 ctx->K.sp = sp;
2625 252 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 26322 lbm_uint *sptr = stack_reserve(ctx, 2);
2650 // For EVAL_R, placed here already to protect from GC
2651 26658 sptr[0] = curr_env;
2652 // Placed here only to protect from GC, will be overriden.
2653 26658 sptr[1] = args;
2654
2655 26658 lbm_value curr_param = get_cadr(ctx->r);
2656 26658 lbm_value curr_arg = args;
2657 26658 lbm_value expand_env = curr_env;
2658
6/8
✓ Branch 0 taken 504 times.
✓ Branch 1 taken 336 times.
✓ Branch 2 taken 504 times.
✗ Branch 3 not taken.
✓ Branch 4 taken 74623 times.
✓ Branch 5 taken 26322 times.
✓ Branch 6 taken 74623 times.
✗ Branch 7 not taken.
 176912 while (lbm_is_cons(curr_param) &&
2659 75127 lbm_is_cons(curr_arg)) {
2660 75127 lbm_cons_t *param_cell = lbm_ref_cell(curr_param); // already checked that cons.
2661 75127 lbm_cons_t *arg_cell = lbm_ref_cell(curr_arg);
2662 75127 lbm_value car_curr_param = param_cell->car;
2663 75127 lbm_value cdr_curr_param = param_cell->cdr;
2664 75127 lbm_value car_curr_arg = arg_cell->car;
2665 75127 lbm_value cdr_curr_arg = arg_cell->cdr;
2666
2667 75127 lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
2668 75127 lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL);
2669 75127 expand_env = aug_env;
2670
2671 75127 curr_param = cdr_curr_param;
2672 75127 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 4327 times.
 6336 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 26658 sptr[1] = EVAL_R;
2686 26658 lbm_value exp = get_cadr(get_cdr(ctx->r));
2687 26658 ctx->curr_exp = exp;
2688 26658 ctx->curr_env = expand_env;
2689 26658 }
2690
2691 6704638 static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
2692
2693 6704638 lbm_uint s = lbm_dec_sym(key);
2694
2/2
✓ Branch 0 taken 6704554 times.
✓ Branch 1 taken 84 times.
 6704638 if (s >= RUNTIME_SYMBOLS_START) {
2695 6704554 lbm_value new_env = lbm_env_modify_binding(env, key, val);
2696
3/4
✓ Branch 0 taken 3896203 times.
✓ Branch 1 taken 2808351 times.
✓ Branch 2 taken 3896203 times.
✗ Branch 3 not taken.
 6704554 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2697 3896203 lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK;
2698 3896203 lbm_value *glob_env = lbm_get_global_env();
2699 3896203 new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
2700
2/2
✓ Branch 0 taken 3896118 times.
✓ Branch 1 taken 85 times.
 3896203 if (new_env != ENC_SYM_NOT_FOUND) {
2701 3896118 glob_env[ix_key] = new_env;
2702 }
2703 }
2704
3/4
✓ Branch 0 taken 85 times.
✓ Branch 1 taken 6704469 times.
✓ Branch 2 taken 85 times.
✗ Branch 3 not taken.
 6704554 if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
2705 85 lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
2706 85 ERROR_AT_CTX(ENC_SYM_NOT_FOUND, key);
2707 }
2708 6704469 return val;
2709 }
2710 84 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2711 return ENC_SYM_NIL; // unreachable
2712 }
2713
2714 1264 static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2715
4/4
✓ Branch 0 taken 1096 times.
✓ Branch 1 taken 168 times.
✓ Branch 2 taken 928 times.
✓ Branch 3 taken 168 times.
 1264 if (nargs == 2 && lbm_is_symbol(args[0])) {
2716 lbm_value res;
2717
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 928 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 928 WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env));
2718 928 ctx->r = args[1];
2719 928 lbm_stack_drop(&ctx->K, nargs+1);
2720 928 ctx->app_cont = true;
2721 } else {
2722
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 168 times.
 336 if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
2723 168 else lbm_set_error_reason((char*)lbm_error_str_num_args);
2724 336 ERROR_AT_CTX(ENC_SYM_EERROR, ENC_SYM_SETVAR);
2725 }
2726 928 }
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 998133 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 998049 times.
✓ Branch 1 taken 84 times.
 998133 if (nargs == 1) {
2735 998049 lbm_value chan = ENC_SYM_NIL;
2736
2/2
✓ Branch 0 taken 914740 times.
✓ Branch 1 taken 83309 times.
 998049 if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY) {
2737 914740 char *str = lbm_dec_str(args[0]);
2738
2/2
✓ Branch 0 taken 914404 times.
✓ Branch 1 taken 336 times.
 914740 if (str) {
2739 #ifdef LBM_ALWAYS_GC
2740 gc();
2741 #endif
2742
2/2
✓ Branch 0 taken 8315 times.
✓ Branch 1 taken 906089 times.
 914404 if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
2743 8315 gc();
2744
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8315 times.
 8315 if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
2745 ✗ ERROR_CTX(ENC_SYM_MERROR);
2746 }
2747 }
2748 } else {
2749 336 ERROR_CTX(ENC_SYM_EERROR);
2750 }
2751
1/2
✓ Branch 0 taken 83309 times.
✗ Branch 1 not taken.
 83309 } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL) {
2752 83309 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 33054 times.
✓ Branch 1 taken 50255 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 33054 times.
 83309 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 997713 lbm_value *sptr = get_stack_ptr(ctx, 2);
2766
2767 // If we are inside a reader, its settings are stored.
2768 997713 sptr[0] = lbm_enc_u(ctx->flags); // flags stored.
2769 997713 sptr[1] = chan;
2770 997713 lbm_value *rptr = stack_reserve(ctx,2);
2771
3/4
✓ Branch 0 taken 894167 times.
✓ Branch 1 taken 103546 times.
✓ Branch 2 taken 894167 times.
✗ Branch 3 not taken.
 997713 if (!program && !incremental) {
2772 894167 rptr[0] = READING_EXPRESSION;
2773
3/4
✓ Branch 0 taken 103546 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 34239 times.
✓ Branch 3 taken 69307 times.
 103546 } else if (program && !incremental) {
2774 34239 rptr[0] = READING_PROGRAM;
2775
2/4
✓ Branch 0 taken 69307 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 69307 times.
✗ Branch 3 not taken.
 69307 } else if (program && incremental) {
2776 69307 rptr[0] = READING_PROGRAM_INCREMENTALLY;
2777 } // the last combo is illegal
2778 997713 rptr[1] = READ_DONE;
2779
2780 // Each reader starts in a fresh situation
2781 997713 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
2782 997713 ctx->r = ENC_SYM_NIL; // set r to a known state.
2783
2784
2/2
✓ Branch 0 taken 103546 times.
✓ Branch 1 taken 894167 times.
 997713 if (program) {
2785
2/2
✓ Branch 0 taken 69307 times.
✓ Branch 1 taken 34239 times.
 103546 if (incremental) {
2786 69307 ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2787 69307 lbm_value *rptr1 = stack_reserve(ctx,3);
2788 69307 rptr1[0] = chan;
2789 69307 rptr1[1] = ctx->curr_env;
2790 69307 rptr1[2] = READ_EVAL_CONTINUE;
2791 } else {
2792 34239 ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
2793 34239 lbm_value *rptr1 = stack_reserve(ctx,4);
2794 34239 rptr1[0] = ENC_SYM_NIL;
2795 34239 rptr1[1] = ENC_SYM_NIL;
2796 34239 rptr1[2] = chan;
2797 34239 rptr1[3] = READ_APPEND_CONTINUE;
2798 }
2799 }
2800 997713 rptr = stack_reserve(ctx,3); // reuse of variable rptr
2801 997713 rptr[0] = chan;
2802 997713 rptr[1] = lbm_enc_u(1);
2803 997713 rptr[2] = READ_NEXT_TOKEN;
2804 997713 ctx->app_cont = true;
2805 } else {
2806 84 lbm_set_error_reason((char*)lbm_error_str_num_args);
2807 84 ERROR_CTX(ENC_SYM_EERROR);
2808 }
2809 997713 }
2810
2811 34491 static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2812 34491 apply_read_base(args,nargs,ctx,true,false);
2813 34239 }
2814
2815 69307 static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2816 69307 apply_read_base(args,nargs,ctx,true,true);
2817 69307 }
2818
2819 894335 static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2820 894335 apply_read_base(args,nargs,ctx,false,false);
2821 894167 }
2822
2823 3396 static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {
2824
2825 3396 lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE;
2826 3396 lbm_uint closure_pos = 0;
2827 3396 char *name = NULL;
2828 // allowed arguments:
2829 // (spawn opt-name opt-stack-size closure arg1 ... argN)
2830
2831
3/4
✓ Branch 0 taken 3396 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 2612 times.
✓ Branch 3 taken 784 times.
 6792 if (nargs >= 1 &&
2832 3396 lbm_is_closure(args[0])) {
2833 2612 closure_pos = 0;
2834
3/4
✓ Branch 0 taken 784 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 355 times.
✓ Branch 3 taken 429 times.
 1568 } else if (nargs >= 2 &&
2835
1/2
✓ Branch 0 taken 355 times.
✗ Branch 1 not taken.
 1139 lbm_is_number(args[0]) &&
2836 355 lbm_is_closure(args[1])) {
2837 355 stack_size = lbm_dec_as_u32(args[0]);
2838 355 closure_pos = 1;
2839
3/4
✓ Branch 0 taken 429 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 425 times.
✓ Branch 3 taken 4 times.
 858 } else if (nargs >= 2 &&
2840
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 424 times.
 854 lbm_is_array_r(args[0]) &&
2841 425 lbm_is_closure(args[1])) {
2842 1 name = lbm_dec_str(args[0]);
2843 1 closure_pos = 1;
2844
4/4
✓ Branch 0 taken 426 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 424 times.
✓ Branch 3 taken 2 times.
 854 } else if (nargs >= 3 &&
2845
2/2
✓ Branch 0 taken 422 times.
✓ Branch 1 taken 2 times.
 850 lbm_is_array_r(args[0]) &&
2846
1/2
✓ Branch 0 taken 422 times.
✗ Branch 1 not taken.
 846 lbm_is_number(args[1]) &&
2847 422 lbm_is_closure(args[2])) {
2848 422 stack_size = lbm_dec_as_u32(args[1]);
2849 422 closure_pos = 2;
2850 422 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 3390 extract_n(get_cdr(args[closure_pos]), cl, 3);
2860 3390 lbm_value curr_param = cl[CLO_PARAMS];
2861 3390 lbm_value clo_env = cl[CLO_ENV];
2862 3390 lbm_uint i = closure_pos + 1;
2863
3/4
✓ Branch 0 taken 2347 times.
✓ Branch 1 taken 3390 times.
✓ Branch 2 taken 2347 times.
✗ Branch 3 not taken.
 5737 while (lbm_is_cons(curr_param) && i <= nargs) {
2864 2347 lbm_value entry = cons_with_gc(lbm_ref_cell(curr_param)->car, args[i], clo_env);
2865 2347 lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL);
2866 2347 clo_env = aug_env;
2867 2347 curr_param = lbm_ref_cell(curr_param)->cdr;
2868 2347 i ++;
2869 }
2870
2871 3390 lbm_stack_drop(&ctx->K, nargs+1);
2872
2873 3390 lbm_value program = cons_with_gc(cl[CLO_BODY], ENC_SYM_NIL, clo_env);
2874
2875 3390 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 3390 ctx->r = lbm_enc_i(cid);
2882 3390 ctx->app_cont = true;
2883
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 3306 times.
 3390 if (cid == -1) ERROR_CTX(ENC_SYM_MERROR); // Kill parent and signal out of memory.
2884 3306 }
2885
2886 2381 static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2887 2381 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING);
2888 2294 }
2889
2890 1015 static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2891 1015 apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP);
2892 1012 }
2893
2894 85323 static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2895
4/4
✓ Branch 0 taken 85321 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 85320 times.
✓ Branch 3 taken 1 times.
 170643 if (nargs == 1 && lbm_is_number(args[0])) {
2896 85320 lbm_uint ts = lbm_dec_as_u32(args[0]);
2897 85320 lbm_stack_drop(&ctx->K, nargs+1);
2898 85320 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 85320 }
2904
2905 15169 static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2906
4/4
✓ Branch 0 taken 15167 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 15166 times.
✓ Branch 3 taken 1 times.
 30251 if (nargs == 1 && lbm_is_number(args[0])) {
2907 15166 lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
2908 15166 lbm_stack_drop(&ctx->K, nargs+1);
2909 15166 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 15082 }
2915
2916 172 static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2917
4/4
✓ Branch 0 taken 171 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 170 times.
✓ Branch 3 taken 1 times.
 342 if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I) {
2918 170 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2919 170 lbm_value *sptr = get_stack_ptr(ctx, 2);
2920 170 sptr[0] = lbm_enc_i(cid);
2921 170 sptr[1] = WAIT;
2922 170 ctx->r = ENC_SYM_TRUE;
2923 170 ctx->app_cont = true;
2924 170 yield_ctx(50000);
2925 } else {
2926 2 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_WAIT);
2927 }
2928 170 }
2929
2930 /* (eval expr)
2931 (eval env expr) */
2932 1145380 static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2933
2/2
✓ Branch 0 taken 1145378 times.
✓ Branch 1 taken 2 times.
 1145380 if ( nargs == 1) {
2934 1145378 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 1145379 lbm_stack_drop(&ctx->K, nargs+1);
2943 1145379 }
2944
2945 34915 static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2946
2/2
✓ Branch 0 taken 34912 times.
✓ Branch 1 taken 3 times.
 34915 if (nargs == 1) {
2947 // here ctx->r = args[0];
2948 34912 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 34912 int len = -1;
2955
3/4
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 34906 times.
✓ Branch 2 taken 6 times.
✗ Branch 3 not taken.
 34912 WITH_GC(prg_copy, lbm_list_copy(&len, prg));
2956 34906 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 34906 app_cont = cons_with_gc(ENC_SYM_APP_CONT, ENC_SYM_NIL, prg_copy);
2961 34906 app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL, prg_copy);
2962 34906 new_prg = lbm_list_append(app_cont_prg, ctx->program);
2963 34906 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 34906 stack_reserve(ctx, 1)[0] = DONE;
2967 34906 ctx->program = get_cdr(new_prg);
2968 34906 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 34906 }
2974
2975 18401 static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
2976
2/2
✓ Branch 0 taken 18400 times.
✓ Branch 1 taken 1 times.
 18401 if (nargs == 2) {
2977
2/2
✓ Branch 0 taken 18399 times.
✓ Branch 1 taken 1 times.
 18400 if (lbm_type_of(args[0]) == LBM_TYPE_I) {
2978 18399 lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
2979 18399 lbm_value msg = args[1];
2980 18399 bool r = lbm_find_receiver_and_send(cid, msg);
2981 /* return the status */
2982 18399 lbm_stack_drop(&ctx->K, nargs+1);
2983
1/2
✓ Branch 0 taken 18399 times.
✗ Branch 1 not taken.
 18399 ctx->r = r ? ENC_SYM_TRUE : ENC_SYM_NIL;
2984 18399 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 18399 }
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 88 static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3005 (void) ctx;
3006 88 lbm_value err_val = ENC_SYM_EERROR;
3007
2/2
✓ Branch 0 taken 87 times.
✓ Branch 1 taken 1 times.
 88 if (nargs >= 1) {
3008 87 err_val = args[0];
3009 }
3010 88 is_atomic = false;
3011 88 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 2707 static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3051
4/4
✓ Branch 0 taken 2706 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 2368 times.
✓ Branch 3 taken 338 times.
 2707 if (nargs == 2 && lbm_is_cons(args[1])) {
3052 2368 lbm_value *sptr = get_stack_ptr(ctx, 3);
3053
3054 2368 lbm_value f = args[0];
3055 2368 lbm_cons_t *args1_cell = lbm_ref_cell(args[1]);
3056 2368 lbm_value h = args1_cell->car;
3057 2368 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 2368 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 2368 WITH_GC(appli_1, lbm_heap_allocate_list(2));
3062
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 2368 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 2368 WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1);
3063
3064 // appli_1 is a list of length 2 here.
3065 2368 lbm_value appli_0 = lbm_ref_cell(appli_1)->cdr;
3066
3067 // appli is a list of length 2 here, so a cons
3068 2368 lbm_cons_t *cell = lbm_ref_cell(appli_0);
3069 2368 cell->car = h;
3070 2368 cell->cdr = ENC_SYM_NIL;
3071 //lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL);
3072 2368 cell = lbm_ref_cell(appli_1);
3073 2368 cell->car = ENC_SYM_QUOTE;
3074 //lbm_set_car(appli_1, ENC_SYM_QUOTE);
3075 2368 lbm_cons_t *appli_cell = lbm_ref_cell(appli);
3076 2368 cell = lbm_ref_cell(appli_cell->cdr);
3077 2368 cell->car = appli_1;
3078 2368 cell->cdr = ENC_SYM_NIL;
3079 //lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL);
3080 2368 appli_cell->car = f;
3081 //lbm_set_car(appli, f);
3082
3083 2368 lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, appli);
3084 2368 sptr[0] = t; // reuse stack space
3085 2368 sptr[1] = ctx->curr_env;
3086 2368 sptr[2] = elt;
3087 2368 lbm_value *rptr = stack_reserve(ctx,4);
3088 2368 rptr[0] = elt;
3089 2368 rptr[1] = appli;
3090 2368 rptr[2] = appli_0;
3091 2368 rptr[3] = MAP;
3092 2368 ctx->curr_exp = appli;
3093
4/4
✓ Branch 0 taken 338 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 336 times.
✓ Branch 3 taken 2 times.
 339 } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
3094 336 lbm_stack_drop(&ctx->K, 3);
3095 336 ctx->r = ENC_SYM_NIL;
3096 336 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 2704 }
3102
3103 428 static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3104
4/4
✓ Branch 0 taken 427 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 424 times.
✓ Branch 3 taken 3 times.
 428 if (nargs == 1 && lbm_is_list(args[0])) {
3105 424 lbm_value curr = args[0];
3106
3107 424 lbm_value new_list = ENC_SYM_NIL;
3108
2/2
✓ Branch 0 taken 9587 times.
✓ Branch 1 taken 424 times.
 10011 while (lbm_is_cons(curr)) {
3109 9587 lbm_cons_t *curr_cell = lbm_ref_cell(curr); // known cons.
3110 9587 lbm_value tmp = cons_with_gc(curr_cell->car, new_list, ENC_SYM_NIL);
3111 9587 new_list = tmp;
3112 9587 curr = curr_cell->cdr;
3113 }
3114 424 lbm_stack_drop(&ctx->K, 2);
3115 424 ctx->r = new_list;
3116 424 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 424 }
3122
3123 103917 static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3124
2/2
✓ Branch 0 taken 103833 times.
✓ Branch 1 taken 84 times.
 103917 if (nargs == 1) {
3125 #ifdef LBM_ALWAYS_GC
3126 gc();
3127 #endif
3128 103833 lbm_value v = flatten_value(args[0]);
3129
2/2
✓ Branch 0 taken 40 times.
✓ Branch 1 taken 103793 times.
 103833 if ( v == ENC_SYM_MERROR) {
3130 40 gc();
3131 40 v = flatten_value(args[0]);
3132 }
3133
3134
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 103749 times.
 103833 if (lbm_is_symbol(v)) {
3135 84 ERROR_AT_CTX(v, ENC_SYM_FLATTEN);
3136 } else {
3137 103749 lbm_stack_drop(&ctx->K, 2);
3138 103749 ctx->r = v;
3139 103749 ctx->app_cont = true;
3140 }
3141 103749 return;
3142 }
3143 84 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_FLATTEN);
3144 }
3145
3146 103674 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 103672 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 103670 times.
✓ Branch 3 taken 2 times.
 103674 if(nargs == 1 && (array = lbm_dec_array_r(args[0]))) {
3149 lbm_flat_value_t fv;
3150 103670 fv.buf = (uint8_t*)array->data;
3151 103670 fv.buf_size = array->size;
3152 103670 fv.buf_pos = 0;
3153
3154 lbm_value res;
3155
3156 103670 ctx->r = ENC_SYM_NIL;
3157
2/2
✓ Branch 0 taken 103664 times.
✓ Branch 1 taken 6 times.
 103670 if (lbm_unflatten_value(&fv, &res)) {
3158 103664 ctx->r = res;
3159 }
3160 103670 lbm_stack_drop(&ctx->K, 2);
3161 103670 ctx->app_cont = true;
3162 103670 return;
3163 }
3164 4 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_UNFLATTEN);
3165 }
3166
3167 254 static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3168
3/4
✓ Branch 0 taken 252 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 252 times.
✗ Branch 3 not taken.
 254 if (nargs == 2 && lbm_is_number(args[0])) {
3169 252 lbm_cid cid = lbm_dec_as_i32(args[0]);
3170
3171
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 252 times.
 252 if (ctx->id == cid) {
3172 ✗ ctx->r = args[1];
3173 ✗ finish_ctx();
3174 ✗ return;
3175 }
3176 252 lbm_mutex_lock(&qmutex);
3177 252 eval_context_t *found = NULL;
3178 252 found = lookup_ctx_nm(&blocked, cid);
3179
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 252 times.
 252 if (found)
3180 ✗ drop_ctx_nm(&blocked, found);
3181 else
3182 252 found = lookup_ctx_nm(&queue, cid);
3183
2/2
✓ Branch 0 taken 251 times.
✓ Branch 1 taken 1 times.
 252 if (found)
3184 251 drop_ctx_nm(&queue, found);
3185
3186
2/2
✓ Branch 0 taken 251 times.
✓ Branch 1 taken 1 times.
 252 if (found) {
3187 251 found->K.data[found->K.sp - 1] = KILL;
3188 251 found->r = args[1];
3189 251 found->app_cont = true;
3190 251 found->state = LBM_THREAD_STATE_READY;
3191 251 enqueue_ctx_nm(&queue,found);
3192 251 ctx->r = ENC_SYM_TRUE;
3193 } else {
3194 1 ctx->r = ENC_SYM_NIL;
3195 }
3196 252 lbm_stack_drop(&ctx->K, 3);
3197 252 ctx->app_cont = true;
3198 252 lbm_mutex_unlock(&qmutex);
3199 252 return;
3200 }
3201 2 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_KILL);
3202 }
3203
3204 848506 static lbm_value cmp_to_clo(lbm_value cmp) {
3205 lbm_value closure;
3206
3/4
✓ Branch 0 taken 900 times.
✓ Branch 1 taken 847606 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 900 times.
 848506 WITH_GC(closure, lbm_heap_allocate_list(4));
3207 848506 lbm_set_car(closure, ENC_SYM_CLOSURE);
3208 848506 lbm_value cl1 = lbm_cdr(closure);
3209 lbm_value par;
3210
3/4
✓ Branch 0 taken 1728 times.
✓ Branch 1 taken 846778 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 1728 times.
 848506 WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure);
3211 848506 lbm_set_car(cl1, par);
3212 848506 lbm_value cl2 = lbm_cdr(cl1);
3213 lbm_value body;
3214
3/4
✓ Branch 0 taken 10902 times.
✓ Branch 1 taken 837604 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 10902 times.
 848506 WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, cmp, symbol_x, symbol_y), closure);
3215 848506 lbm_set_car(cl2, body);
3216 848506 lbm_value cl3 = lbm_cdr(cl2);
3217 848506 lbm_set_car(cl3, ENC_SYM_NIL);
3218 848506 return closure;
3219 }
3220
3221 // (merge comparator list1 list2)
3222 1286 static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3223
6/6
✓ Branch 0 taken 1282 times.
✓ Branch 1 taken 4 times.
✓ Branch 2 taken 1276 times.
✓ Branch 3 taken 6 times.
✓ Branch 4 taken 1271 times.
✓ Branch 5 taken 5 times.
 1286 if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {
3224
3225
2/2
✓ Branch 0 taken 93 times.
✓ Branch 1 taken 1178 times.
 1271 if (!lbm_is_closure(args[0])) {
3226 93 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 1271 int len_a = -1;
3234 1271 int len_b = -1;
3235
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 1271 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 1271 WITH_GC(a, lbm_list_copy(&len_a, args[1]));
3236
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 1271 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 1271 WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a);
3237
3238
2/2
✓ Branch 0 taken 170 times.
✓ Branch 1 taken 1101 times.
 1271 if (len_a == 0) {
3239 170 ctx->r = b;
3240 170 lbm_stack_drop(&ctx->K, 4);
3241 170 ctx->app_cont = true;
3242 1271 return;
3243 }
3244
2/2
✓ Branch 0 taken 169 times.
✓ Branch 1 taken 932 times.
 1101 if (len_b == 0) {
3245 169 ctx->r = a;
3246 169 lbm_stack_drop(&ctx->K, 4);
3247 169 ctx->app_cont = true;
3248 169 return;
3249 }
3250
3251 932 args[1] = a; // keep safe by replacing the original on stack.
3252 932 args[2] = b;
3253
3254 lbm_value cl[3]; // Comparator closure
3255 932 extract_n(lbm_cdr(args[0]), cl, 3);
3256 932 lbm_value cmp_env = cl[CLO_ENV];
3257 932 lbm_uint len = lbm_list_length(cl[CLO_PARAMS]);
3258
1/2
✓ Branch 0 taken 932 times.
✗ Branch 1 not taken.
 932 if (len == 2) {
3259 932 lbm_value a_1 = a;
3260 932 lbm_value b_1 = b;
3261 932 lbm_value a_rest = lbm_cdr(a);
3262 932 lbm_value b_rest = lbm_cdr(b);
3263 932 lbm_value par1 = get_car(cl[CLO_PARAMS]);
3264 932 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 932 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 932 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)));
3268
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 932 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 932 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0);
3269 932 cmp_env = new_env;
3270 932 lbm_set_cdr(a_1, b_1);
3271 932 lbm_set_cdr(b_1, ENC_SYM_NIL);
3272 932 lbm_value cmp = cl[CLO_BODY];
3273
3274 932 lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
3275 932 lbm_uint *sptr = stack_reserve(ctx, 10);
3276 932 sptr[0] = ENC_SYM_NIL; // head of merged list
3277 932 sptr[1] = ENC_SYM_NIL; // last of merged list
3278 932 sptr[2] = a_1;
3279 932 sptr[3] = a_rest;
3280 932 sptr[4] = b_rest;
3281 932 sptr[5] = cmp;
3282 932 sptr[6] = cmp_env;
3283 932 sptr[7] = par1;
3284 932 sptr[8] = par2;
3285 932 sptr[9] = MERGE_REST;
3286 932 ctx->curr_exp = cl[CLO_BODY];
3287 932 ctx->curr_env = cmp_env;
3288 932 return;
3289 }
3290 }
3291 15 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_MERGE);
3292 }
3293
3294 // (sort comparator list)
3295 849432 static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3296
4/4
✓ Branch 0 taken 849429 times.
✓ Branch 1 taken 3 times.
✓ Branch 2 taken 849423 times.
✓ Branch 3 taken 6 times.
 849432 if (nargs == 2 && lbm_is_list(args[1])) {
3297
3298
2/2
✓ Branch 0 taken 848413 times.
✓ Branch 1 taken 1010 times.
 849423 if (!lbm_is_closure(args[0])) {
3299 848413 args[0] = cmp_to_clo(args[0]);
3300 }
3301
3302 849423 int len = -1;
3303 lbm_value list_copy;
3304
3/4
✓ Branch 0 taken 414 times.
✓ Branch 1 taken 849009 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 414 times.
 849423 WITH_GC(list_copy, lbm_list_copy(&len, args[1]));
3305
2/2
✓ Branch 0 taken 86 times.
✓ Branch 1 taken 849337 times.
 849423 if (len <= 1) {
3306 86 lbm_stack_drop(&ctx->K, 3);
3307 86 ctx->r = list_copy;
3308 86 ctx->app_cont = true;
3309 849423 return;
3310 }
3311
3312 849337 args[1] = list_copy; // Keep safe, original replaced on stack.
3313
3314 // Take the headmost 2, 1-element sublists.
3315 849337 lbm_value a = list_copy;
3316 849337 lbm_value b = lbm_cdr(a);
3317 849337 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 849337 extract_n(lbm_cdr(args[0]), cl, 3);
3324 849337 lbm_value cmp_env = cl[CLO_ENV];
3325
3326 849337 lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS]);
3327
1/2
✓ Branch 0 taken 849337 times.
✗ Branch 1 not taken.
 849337 if (cl_len == 2) {
3328 849337 lbm_value par1 = get_car(cl[CLO_PARAMS]);
3329 849337 lbm_value par2 = get_cadr(cl[CLO_PARAMS]);
3330 lbm_value new_env0;
3331 lbm_value new_env;
3332
3/4
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 849331 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 6 times.
 849337 WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
3333
3/4
✓ Branch 0 taken 48 times.
✓ Branch 1 taken 849289 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 48 times.
 849337 WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
3334 849337 cmp_env = new_env;
3335
3336 849337 lbm_value cmp = cl[CLO_BODY];
3337
3338 // Terminate the comparator argument list.
3339 849337 lbm_set_cdr(b, ENC_SYM_NIL);
3340
3341 849337 lbm_stack_drop(&ctx->K, 3); //TODO: optimize drop 3, alloc 20 into alloc 17
3342 849337 lbm_uint *sptr = stack_reserve(ctx, 20);
3343 849337 sptr[0] = cmp;
3344 849337 sptr[1] = cmp_env;
3345 849337 sptr[2] = par1;
3346 849337 sptr[3] = par2;
3347 849337 sptr[4] = ENC_SYM_NIL; // head of merged accumulation of sublists
3348 849337 sptr[5] = ENC_SYM_NIL; // last of merged accumulation of sublists
3349 849337 sptr[6] = rest;
3350 849337 sptr[7] = lbm_enc_i(1);
3351 849337 sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
3352 849337 sptr[9] = MERGE_LAYER;
3353 849337 sptr[10] = ENC_SYM_NIL; // head of merged sublist
3354 849337 sptr[11] = ENC_SYM_NIL; // last of merged sublist
3355 849337 sptr[12] = a;
3356 849337 sptr[13] = ENC_SYM_NIL; // no a_rest, 1 element lists in layer 1.
3357 849337 sptr[14] = ENC_SYM_NIL; // no b_rest, 1 element lists in layer 1.
3358 849337 sptr[15] = cmp;
3359 849337 sptr[16] = cmp_env;
3360 849337 sptr[17] = par1;
3361 849337 sptr[18] = par2;
3362 849337 sptr[19] = MERGE_REST;
3363 849337 ctx->curr_exp = cmp;
3364 849337 ctx->curr_env = cmp_env;
3365 849337 return;
3366 }
3367 }
3368 9 ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_SORT);
3369 }
3370
3371 1853394 static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3372 1853394 lbm_value res = ENC_SYM_NIL; //TODO: lbm_env_lookup does not set res in all cases.
3373
2/2
✓ Branch 0 taken 1851125 times.
✓ Branch 1 taken 2269 times.
 1853394 if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS, ctx->curr_env)) {
3374
3/4
✓ Branch 0 taken 168422 times.
✓ Branch 1 taken 1682703 times.
✓ Branch 2 taken 168422 times.
✗ Branch 3 not taken.
 1851125 if (nargs == 1 && lbm_is_number(args[0])) {
3375 168422 int32_t ix = lbm_dec_as_i32(args[0]);
3376 168422 res = lbm_index_list(res, ix);
3377 }
3378 1851125 ctx->r = res;
3379 } else {
3380 2269 ctx->r = ENC_SYM_NIL;
3381 }
3382 1853394 lbm_stack_drop(&ctx->K, nargs+1);
3383 1853394 ctx->app_cont = true;
3384 1853394 }
3385
3386 /* (rotate list-expr dist/dir-expr) */
3387 256 static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
3388
6/6
✓ Branch 0 taken 254 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 253 times.
✓ Branch 3 taken 1 times.
✓ Branch 4 taken 252 times.
✓ Branch 5 taken 1 times.
 256 if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
3389 252 int len = -1;
3390 lbm_value ls;
3391
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 252 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 252 WITH_GC(ls, lbm_list_copy(&len, args[0]));
3392 252 int dist = lbm_dec_as_i32(args[1]);
3393
3/4
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 84 times.
✓ Branch 2 taken 168 times.
✗ Branch 3 not taken.
 252 if (len > 0 && dist != 0) {
3394 168 int d = dist;
3395
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 84 times.
 168 if (dist > 0) {
3396 84 ls = lbm_list_destructive_reverse(ls);
3397 } else {
3398 84 d = -dist;
3399 }
3400
3401 168 lbm_value start = ls;
3402 168 lbm_value end = ENC_SYM_NIL;
3403 168 lbm_value curr = start;
3404
2/2
✓ Branch 0 taken 756 times.
✓ Branch 1 taken 168 times.
 924 while (lbm_is_cons(curr)) {
3405 756 end = curr;
3406 756 curr = lbm_ref_cell(curr)->cdr;
3407 }
3408
3409
2/2
✓ Branch 0 taken 336 times.
✓ Branch 1 taken 168 times.
 504 for (int i = 0; i < d; i ++) {
3410 336 lbm_value a = start;
3411 336 start = lbm_cdr(start);
3412 336 lbm_set_cdr(a, ENC_SYM_NIL);
3413 336 lbm_set_cdr(end, a);
3414 336 end = a;
3415 }
3416 168 ls = start;
3417
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 84 times.
 168 if (dist > 0) {
3418 84 ls = lbm_list_destructive_reverse(ls);
3419 }
3420 }
3421 252 lbm_stack_drop(&ctx->K, nargs+1);
3422 252 ctx->app_cont = true;
3423 252 ctx->r = ls;
3424 252 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 695268679 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 695268679 lbm_value fun = fun_args[0];
3470
3471 695268679 lbm_uint fun_val = lbm_dec_sym(fun);
3472 695268679 lbm_uint fun_kind = SYMBOL_KIND(fun_val);
3473
3474
4/4
✓ Branch 0 taken 869870 times.
✓ Branch 1 taken 672378098 times.
✓ Branch 2 taken 22020710 times.
✓ Branch 3 taken 1 times.
 695268679 switch (fun_kind) {
3475 869870 case SYMBOL_KIND_EXTENSION: {
3476 869870 extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr;
3477
3478 lbm_value ext_res;
3479
4/4
✓ Branch 0 taken 968 times.
✓ Branch 1 taken 868902 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 967 times.
 869870 WITH_GC(ext_res, f(&fun_args[1], arg_count));
3480
2/2
✓ Branch 0 taken 8444 times.
✓ Branch 1 taken 861425 times.
 869869 if (lbm_is_error(ext_res)) { //Error other than merror
3481 8444 ERROR_AT_CTX(ext_res, fun);
3482 }
3483 861425 lbm_stack_drop(&ctx->K, arg_count + 1);
3484
3485 861425 ctx->app_cont = true;
3486 861425 ctx->r = ext_res;
3487
3488
2/2
✓ Branch 0 taken 337 times.
✓ Branch 1 taken 861088 times.
 861425 if (blocking_extension) {
3489
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 337 times.
 337 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 337 blocking_extension = false;
3497
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 337 times.
 337 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 337 block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0,true);
3502 }
3503 337 lbm_mutex_unlock(&blocking_extension_mutex);
3504 }
3505 861425 } break;
3506 672378098 case SYMBOL_KIND_FUNDAMENTAL:
3507 672378098 call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx);
3508 672363668 break;
3509 22020710 case SYMBOL_KIND_APPFUN:
3510 22020710 fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
3511 22019457 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 695244550 }
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 164133963 static void cont_closure_application_args(eval_context_t *ctx) {
3531 164133963 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3532
3533 164133963 lbm_value arg_env = (lbm_value)sptr[0];
3534 164133963 lbm_value exp = (lbm_value)sptr[1];
3535 164133963 lbm_value clo_env = (lbm_value)sptr[2];
3536 164133963 lbm_value params = (lbm_value)sptr[3];
3537 164133963 lbm_value args = (lbm_value)sptr[4];
3538
3539 lbm_value car_params, cdr_params;
3540 164133963 get_car_and_cdr(params, &car_params, &cdr_params);
3541
3542 164133955 bool a_nil = lbm_is_symbol_nil(args);
3543 164133955 bool p_nil = lbm_is_symbol_nil(cdr_params);
3544
3545 164133955 lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);
3546
3547
4/4
✓ Branch 0 taken 81412167 times.
✓ Branch 1 taken 82721704 times.
✓ Branch 2 taken 81327475 times.
✓ Branch 3 taken 84692 times.
 164133871 if (!a_nil && !p_nil) {
3548 lbm_value car_args, cdr_args;
3549 81327475 get_car_and_cdr(args, &car_args, &cdr_args);
3550 81327475 sptr[2] = binder;
3551 81327475 sptr[3] = cdr_params;
3552 81327475 sptr[4] = cdr_args;
3553 81327475 stack_reserve(ctx,1)[0] = CLOSURE_ARGS;
3554 81327475 ctx->curr_exp = car_args;
3555 81327475 ctx->curr_env = arg_env;
3556
4/4
✓ Branch 0 taken 82721704 times.
✓ Branch 1 taken 84692 times.
✓ Branch 2 taken 82721702 times.
✓ Branch 3 taken 2 times.
 82806396 } else if (a_nil && p_nil) {
3557 // Arguments and parameters match up in number
3558 82721702 lbm_stack_drop(&ctx->K, 5);
3559 82721702 ctx->curr_env = binder;
3560 82721702 ctx->curr_exp = exp;
3561
2/2
✓ Branch 0 taken 84692 times.
✓ Branch 1 taken 2 times.
 84694 } else if (p_nil) {
3562 84692 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, binder);
3563 84692 sptr[2] = rest_binder;
3564 84692 sptr[3] = get_cdr(args);
3565 84692 sptr[4] = get_car(rest_binder); // last element of rest_args so far
3566 84692 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3567 84692 ctx->curr_exp = get_car(args);
3568 84692 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 164133869 }
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 8991086 static void cont_closure_args_rest(eval_context_t *ctx) {
3583 8991086 lbm_uint* sptr = get_stack_ptr(ctx, 5);
3584 8991086 lbm_value arg_env = (lbm_value)sptr[0];
3585 8991086 lbm_value exp = (lbm_value)sptr[1];
3586 8991086 lbm_value clo_env = (lbm_value)sptr[2];
3587 8991086 lbm_value args = (lbm_value)sptr[3];
3588 8991086 lbm_value last = (lbm_value)sptr[4];
3589 8991086 lbm_cons_t* heap = lbm_heap_state.heap;
3590 #ifdef LBM_ALWAYS_GC
3591 gc();
3592 #endif
3593 8991086 lbm_value binding = lbm_heap_state.freelist;
3594
2/2
✓ Branch 0 taken 1210 times.
✓ Branch 1 taken 8989876 times.
 8991086 if (binding == ENC_SYM_NIL) {
3595 1210 gc();
3596 1210 binding = lbm_heap_state.freelist;
3597
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1210 times.
 1210 if (binding == ENC_SYM_NIL) ERROR_CTX(ENC_SYM_MERROR);
3598 }
3599 8991086 lbm_uint binding_ix = lbm_dec_ptr(binding);
3600 8991086 lbm_heap_state.freelist = heap[binding_ix].cdr;
3601 8991086 lbm_heap_state.num_free -= 1;
3602 8991086 heap[binding_ix].car = ctx->r;
3603 8991086 heap[binding_ix].cdr = ENC_SYM_NIL;
3604
3605 8991086 lbm_set_cdr(last, binding);
3606 8991086 sptr[4] = binding;
3607
3608
2/2
✓ Branch 0 taken 924792 times.
✓ Branch 1 taken 8066294 times.
 8991086 if (args == ENC_SYM_NIL) {
3609 924792 lbm_stack_drop(&ctx->K, 5);
3610 924792 ctx->curr_env = clo_env;
3611 924792 ctx->curr_exp = exp;
3612 } else {
3613 8066294 stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
3614 8066294 sptr[3] = get_cdr(args);
3615 8066294 ctx->curr_exp = get_car(args);
3616 8066294 ctx->curr_env = arg_env;
3617 }
3618 8991086 }
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 2187972743 static void cont_application_args(eval_context_t *ctx) {
3630 2187972743 lbm_uint *sptr = get_stack_ptr(ctx, 3);
3631
3632 2187972743 lbm_value env = sptr[0];
3633 2187972743 lbm_value rest = sptr[1];
3634 2187972743 lbm_value count = sptr[2];
3635
3636 2187972743 ctx->curr_env = env;
3637 2187972743 sptr[0] = ctx->r; // Function 1st then Arguments
3638
2/2
✓ Branch 0 taken 1494384238 times.
✓ Branch 1 taken 693588505 times.
 2187972743 if (lbm_is_cons(rest)) { // rest is user input syntax, expensive check needed
3639 1494384238 lbm_cons_t *cell = lbm_ref_cell(rest);
3640 1494384238 sptr[1] = env;
3641 1494384238 sptr[2] = cell->cdr;
3642 1494384238 lbm_value *rptr = stack_reserve(ctx,2);
3643 1494384237 rptr[0] = count + (1 << LBM_VAL_SHIFT); // arithmetic on encoded value
3644 1494384237 rptr[1] = APPLICATION_ARGS;
3645 1494384237 ctx->curr_exp = cell->car;
3646 } else { // tollerant for incorrect list termination.
3647 // No more arguments
3648 693588505 lbm_stack_drop(&ctx->K, 2);
3649 693588505 lbm_uint nargs = lbm_dec_u(count);
3650 693588505 lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
3651 693588505 application(ctx,args, nargs);
3652 }
3653 2187948614 }
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 163239160 static void cont_and(eval_context_t *ctx) {
3660 163239160 lbm_value rest = ctx->K.data[--ctx->K.sp];
3661 163239160 lbm_value env = ctx->K.data[--ctx->K.sp];
3662
2/2
✓ Branch 0 taken 840929 times.
✓ Branch 1 taken 162398231 times.
 163239160 if (lbm_is_symbol_nil(ctx->r)) {
3663 840929 ctx->app_cont = true;
3664
2/2
✓ Branch 0 taken 115254170 times.
✓ Branch 1 taken 47144061 times.
 162398231 } else if (lbm_is_cons(rest)) {
3665 115254170 lbm_cons_t *r_cell = lbm_ref_cell(rest);
3666 115254170 lbm_value *sptr = stack_reserve(ctx, 3);
3667 115254170 sptr[0] = env;
3668 115254170 sptr[1] = r_cell->cdr;
3669 115254170 sptr[2] = AND;
3670 115254170 ctx->curr_env = env;
3671 115254170 ctx->curr_exp = r_cell->car;
3672 } else {
3673 47144061 ctx->app_cont = true;
3674 }
3675 163239160 }
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 48345 static void cont_or(eval_context_t *ctx) {
3682 48345 lbm_value rest = ctx->K.data[--ctx->K.sp];
3683 48345 lbm_value env = ctx->K.data[--ctx->K.sp];
3684
2/2
✓ Branch 0 taken 2568 times.
✓ Branch 1 taken 45777 times.
 48345 if (!lbm_is_symbol_nil(ctx->r)) {
3685 2568 ctx->app_cont = true;
3686
2/2
✓ Branch 0 taken 26609 times.
✓ Branch 1 taken 19168 times.
 45777 } else if (lbm_is_cons(rest)) {
3687 26609 lbm_value *sptr = stack_reserve(ctx, 3);
3688 26609 lbm_cons_t *r_cell = lbm_ref_cell(rest);
3689 26609 sptr[0] = env;
3690 26609 sptr[1] = r_cell->cdr;
3691 26609 sptr[2] = OR;
3692 26609 ctx->curr_exp = r_cell->car;
3693 26609 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 19168 ctx->app_cont = true;
3698 }
3699 48345 }
3700
3701 122674963 static void fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
3702
2/2
✓ Branch 0 taken 80671854 times.
✓ Branch 1 taken 42003109 times.
 122674963 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 63871265 times.
✓ Branch 1 taken 16800589 times.
 80671854 if (lbm_dec_sym(key) >= RUNTIME_SYMBOLS_START) {
3708 63871265 lbm_env_modify_binding(env,key,value);
3709 } else {
3710
4/4
✓ Branch 0 taken 8400253 times.
✓ Branch 1 taken 8400336 times.
✓ Branch 2 taken 8400252 times.
✓ Branch 3 taken 1 times.
 16800589 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 42003109 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 42003108 times.
✓ Branch 3 taken 1 times.
 84006218 } else if (lbm_is_cons(key) &&
3715 42003109 lbm_is_cons(value)) {
3716 42003108 fill_binding_location(lbm_ref_cell(key)->car, lbm_ref_cell(value)->car, env);
3717 42003108 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 36735297 static void cont_bind_to_key_rest(eval_context_t *ctx) {
3733
3734 36735297 lbm_value *sptr = get_stack_ptr(ctx, 4);
3735
3736 36735297 lbm_value rest = sptr[1];
3737 36735297 lbm_value env = sptr[2];
3738 36735297 lbm_value key = sptr[3];
3739
3740 36735297 fill_binding_location(key, ctx->r, env);
3741
3742
2/2
✓ Branch 0 taken 344909 times.
✓ Branch 1 taken 36390386 times.
 36735295 if (lbm_is_cons(rest)) {
3743 344909 lbm_value car_rest = lbm_ref_cell(rest)->car;
3744 lbm_value key_val[2];
3745 344909 extract_n(car_rest, key_val, 2);
3746
3747 344909 sptr[1] = lbm_ref_cell(rest)->cdr;
3748 344909 sptr[3] = key_val[0];
3749 344909 stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST;
3750 344909 ctx->curr_exp = key_val[1];
3751 344909 ctx->curr_env = env;
3752 } else {
3753 // Otherwise evaluate the expression in the populated env
3754 36390386 ctx->curr_exp = sptr[0];
3755 36390386 ctx->curr_env = env;
3756 36390386 lbm_stack_drop(&ctx->K, 4);
3757 }
3758 36735295 }
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 83726759 static void cont_if(eval_context_t *ctx) {
3767
3768 83726759 lbm_value arg = ctx->r;
3769
3770 83726759 lbm_value *sptr = pop_stack_ptr(ctx, 2);
3771
3772 83726759 ctx->curr_env = sptr[1];
3773
2/2
✓ Branch 0 taken 82577485 times.
✓ Branch 1 taken 1149274 times.
 83726759 if (lbm_is_symbol_nil(arg)) {
3774 82577485 ctx->curr_exp = get_cadr(sptr[0]); // else branch
3775 } else {
3776 1149274 ctx->curr_exp = get_car(sptr[0]); // then branch
3777 }
3778 83726758 }
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 143614 static void cont_match(eval_context_t *ctx) {
3787 143614 lbm_value e = ctx->r;
3788
3789 143614 lbm_uint *sptr = get_stack_ptr(ctx, 2);
3790 143614 lbm_value patterns = (lbm_value)sptr[0];
3791 143614 lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
3792 143614 lbm_value new_env = orig_env;
3793
3794
2/2
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 143612 times.
 143614 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 143612 times.
✗ Branch 1 not taken.
 143612 } else if (lbm_is_cons(patterns)) {
3800 143612 lbm_value match_case = lbm_ref_cell(patterns)->car;
3801 143612 lbm_value pattern = get_car(match_case);
3802 143612 lbm_value n1 = get_cadr(match_case);
3803 143612 lbm_value n2 = get_cdr(get_cdr(match_case));
3804 lbm_value body;
3805 143612 bool check_guard = false;
3806
2/2
✓ Branch 0 taken 15836 times.
✓ Branch 1 taken 127776 times.
 143612 if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
3807 15836 body = n1;
3808 } else {
3809 127776 body = get_car(n2);
3810 127776 check_guard = true;
3811 }
3812 143612 bool is_match = match(pattern, e, &new_env);
3813
2/2
✓ Branch 0 taken 27668 times.
✓ Branch 1 taken 115944 times.
 143612 if (is_match) {
3814
2/2
✓ Branch 0 taken 19464 times.
✓ Branch 1 taken 8204 times.
 27668 if (check_guard) {
3815 19464 lbm_value *rptr = stack_reserve(ctx,5);
3816 19464 sptr[0] = lbm_ref_cell(patterns)->cdr;
3817 19464 sptr[1] = ctx->curr_env;
3818 19464 rptr[0] = MATCH;
3819 19464 rptr[1] = new_env;
3820 19464 rptr[2] = body;
3821 19464 rptr[3] = e;
3822 19464 rptr[4] = MATCH_GUARD;
3823 19464 ctx->curr_env = new_env;
3824 19464 ctx->curr_exp = n1; // The guard
3825 } else {
3826 8204 lbm_stack_drop(&ctx->K, 2);
3827 8204 ctx->curr_env = new_env;
3828 8204 ctx->curr_exp = body;
3829 }
3830 } else {
3831 // set up for checking of next pattern
3832 115944 sptr[0] = get_cdr(patterns);
3833 115944 sptr[1] = orig_env;
3834 115944 stack_reserve(ctx,1)[0] = MATCH;
3835 // leave r unaltered
3836 115944 ctx->app_cont = true;
3837 }
3838 } else {
3839 ✗ ERROR_AT_CTX(ENC_SYM_TERROR, ENC_SYM_MATCH);
3840 }
3841 143614 }
3842
3843 672 static void cont_exit_atomic(eval_context_t *ctx) {
3844 672 is_atomic = false; // atomic blocks cannot nest!
3845 672 ctx->app_cont = true;
3846 672 }
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 7029 static void cont_map(eval_context_t *ctx) {
3859 7029 lbm_value *sptr = get_stack_ptr(ctx, 6);
3860 7029 lbm_value ls = sptr[0];
3861 7029 lbm_value env = sptr[1];
3862 7029 lbm_value t = sptr[3]; // known cons!
3863 7029 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 4661 times.
✓ Branch 1 taken 2368 times.
 7029 if (lbm_is_cons(ls)) {
3866 4661 lbm_cons_t *cell = lbm_ref_cell(ls); // already checked that cons.
3867 4661 lbm_value next = cell->car;
3868 4661 lbm_value rest = cell->cdr;
3869 4661 sptr[0] = rest;
3870 4661 stack_reserve(ctx,1)[0] = MAP;
3871 4661 lbm_ref_cell(sptr[5])->car = next; // update known cons
3872 //lbm_set_car(sptr[5], next); // new arguments
3873
3874 4661 lbm_value elt = cons_with_gc(ENC_SYM_NIL, ENC_SYM_NIL, ENC_SYM_NIL);
3875 4661 lbm_ref_cell(t)->cdr = elt;
3876 //lbm_set_cdr(t, elt);
3877 4661 sptr[3] = elt; // (r1 ... rN . (nil . nil))
3878 4661 ctx->curr_exp = sptr[4];
3879 4661 ctx->curr_env = env;
3880 } else {
3881 2368 ctx->r = sptr[2]; //head of result list
3882 2368 ctx->curr_env = env;
3883 2368 lbm_stack_drop(&ctx->K, 6);
3884 2368 ctx->app_cont = true;
3885 }
3886 7029 }
3887
3888 19464 static void cont_match_guard(eval_context_t *ctx) {
3889
2/2
✓ Branch 0 taken 1428 times.
✓ Branch 1 taken 18036 times.
 19464 if (lbm_is_symbol_nil(ctx->r)) {
3890 1428 lbm_value e = ctx->K.data[--ctx->K.sp];
3891 1428 lbm_stack_drop(&ctx->K, 2);
3892 1428 ctx->r = e;
3893 1428 ctx->app_cont = true;
3894 } else {
3895 18036 lbm_stack_drop(&ctx->K, 1);
3896 18036 lbm_value body = ctx->K.data[--ctx->K.sp];
3897 18036 lbm_value env = ctx->K.data[--ctx->K.sp];
3898 18036 lbm_stack_drop(&ctx->K, 3);
3899 18036 ctx->curr_env = env;
3900 18036 ctx->curr_exp = body;
3901 }
3902 19464 }
3903
3904 84 static void cont_terminate(eval_context_t *ctx) {
3905 84 ERROR_CTX(ctx->r);
3906 }
3907
3908 2775444 static void cont_loop(eval_context_t *ctx) {
3909 2775444 lbm_value *sptr = get_stack_ptr(ctx, 3);
3910 2775444 stack_reserve(ctx,1)[0] = LOOP_CONDITION;
3911 2775444 ctx->curr_env = sptr[2];
3912 2775444 ctx->curr_exp = sptr[1];
3913 2775444 }
3914
3915 2776284 static void cont_loop_condition(eval_context_t *ctx) {
3916
2/2
✓ Branch 0 taken 840 times.
✓ Branch 1 taken 2775444 times.
 2776284 if (lbm_is_symbol_nil(ctx->r)) {
3917 840 lbm_stack_drop(&ctx->K, 3);
3918 840 ctx->app_cont = true; // A loop returns nil? Makes sense to me... but in general?
3919 840 return;
3920 }
3921 2775444 lbm_value *sptr = get_stack_ptr(ctx, 3);
3922 2775444 stack_reserve(ctx,1)[0] = LOOP;
3923 2775444 ctx->curr_env = sptr[2];
3924 2775444 ctx->curr_exp = sptr[0];
3925 }
3926
3927 840 static void cont_loop_env_prep(eval_context_t *ctx) {
3928 840 lbm_value *sptr = get_stack_ptr(ctx, 3);
3929 840 sptr[2] = ctx->curr_env;
3930 840 stack_reserve(ctx,1)[0] = LOOP_CONDITION;
3931 840 ctx->curr_exp = sptr[1];
3932 840 }
3933
3934 26374839 static void cont_merge_rest(eval_context_t *ctx) {
3935 26374839 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 26374839 lbm_value a = sptr[2];
3950 26374839 lbm_value b = lbm_cdr(a);
3951 26374839 lbm_set_cdr(a, ENC_SYM_NIL); // terminate 1 element list
3952
3953
2/2
✓ Branch 0 taken 15306681 times.
✓ Branch 1 taken 11068158 times.
 26374839 if (ctx->r == ENC_SYM_NIL) { // Comparison false
3954
3955
2/2
✓ Branch 0 taken 5950743 times.
✓ Branch 1 taken 9355938 times.
 15306681 if (sptr[0] == ENC_SYM_NIL) {
3956 5950743 sptr[0] = b;
3957 5950743 sptr[1] = b;
3958 } else {
3959 9355938 lbm_set_cdr(sptr[1], b);
3960 9355938 sptr[1] = b;
3961 }
3962
2/2
✓ Branch 0 taken 7648385 times.
✓ Branch 1 taken 7658296 times.
 15306681 if (sptr[4] == ENC_SYM_NIL) {
3963 7648385 lbm_set_cdr(a, sptr[3]);
3964 7648385 lbm_set_cdr(sptr[1], a);
3965 7648385 ctx->r = sptr[0];
3966 7648385 lbm_stack_drop(&ctx->K, 9);
3967 7648385 ctx->app_cont = true;
3968 7648385 return;
3969 } else {
3970 7658296 b = sptr[4];
3971 7658296 sptr[4] = lbm_cdr(sptr[4]);
3972 7658296 lbm_set_cdr(b, ENC_SYM_NIL);
3973 }
3974 } else {
3975
2/2
✓ Branch 0 taken 3404467 times.
✓ Branch 1 taken 7663691 times.
 11068158 if (sptr[0] == ENC_SYM_NIL) {
3976 3404467 sptr[0] = a;
3977 3404467 sptr[1] = a;
3978 } else {
3979 7663691 lbm_set_cdr(sptr[1], a);
3980 7663691 sptr[1] = a;
3981 }
3982
3983
2/2
✓ Branch 0 taken 1706825 times.
✓ Branch 1 taken 9361333 times.
 11068158 if (sptr[3] == ENC_SYM_NIL) {
3984 1706825 lbm_set_cdr(b, sptr[4]);
3985 1706825 lbm_set_cdr(sptr[1], b);
3986 1706825 ctx->r = sptr[0];
3987 1706825 lbm_stack_drop(&ctx->K, 9);
3988 1706825 ctx->app_cont = true;
3989 1706825 return;
3990 } else {
3991 9361333 a = sptr[3];
3992 9361333 sptr[3] = lbm_cdr(sptr[3]);
3993 9361333 lbm_set_cdr(a, ENC_SYM_NIL);
3994 }
3995 }
3996 17019629 lbm_set_cdr(a, b);
3997 17019629 sptr[2] = a;
3998
3999 17019629 lbm_value par1 = sptr[7];
4000 17019629 lbm_value par2 = sptr[8];
4001 17019629 lbm_value cmp_body = sptr[5];
4002 17019629 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 17019629 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
4006 17019629 lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
4007
2/4
✓ Branch 0 taken 17019629 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 17019629 times.
 17019629 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
4008 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4009 }
4010 17019629 cmp_env = new_env;
4011
4012 17019629 stack_reserve(ctx,1)[0] = MERGE_REST;
4013 17019629 ctx->curr_exp = cmp_body;
4014 17019629 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 10203867 static void cont_merge_layer(eval_context_t *ctx) {
4030 10203867 lbm_uint *sptr = get_stack_ptr(ctx, 9);
4031 10203867 lbm_int layer = lbm_dec_i(sptr[7]);
4032 10203867 lbm_int len = lbm_dec_i(sptr[8]);
4033
4034 10203867 lbm_value r_curr = ctx->r;
4035
1/2
✓ Branch 0 taken 40861947 times.
✗ Branch 1 not taken.
 40861947 while (lbm_is_cons(r_curr)) {
4036 40861947 lbm_value next = lbm_ref_cell(r_curr)->cdr;
4037
2/2
✓ Branch 0 taken 10203867 times.
✓ Branch 1 taken 30658080 times.
 40861947 if (next == ENC_SYM_NIL) {
4038 10203867 break;
4039 }
4040 30658080 r_curr = next;
4041 }
4042
4043
2/2
✓ Branch 0 taken 3397069 times.
✓ Branch 1 taken 6806798 times.
 10203867 if (sptr[4] == ENC_SYM_NIL) {
4044 3397069 sptr[4] = ctx->r;
4045 3397069 sptr[5] = r_curr;
4046 } else {
4047 6806798 lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
4048 6806798 sptr[5] = r_curr;
4049 }
4050
4051 10203867 lbm_value layer_rest = sptr[6];
4052 // switch layer or done ?
4053
2/2
✓ Branch 0 taken 3397069 times.
✓ Branch 1 taken 6806798 times.
 10203867 if (layer_rest == ENC_SYM_NIL) {
4054
2/2
✓ Branch 0 taken 849333 times.
✓ Branch 1 taken 2547736 times.
 3397069 if (layer * 2 >= len) {
4055 849333 ctx->r = sptr[4];
4056 849333 ctx->app_cont = true;
4057 849333 lbm_stack_drop(&ctx->K, 9);
4058 849333 return;
4059 } else {
4060 // Setup for merges of the next layer
4061 2547736 layer = layer * 2;
4062 2547736 sptr[7] = lbm_enc_i(layer);
4063 2547736 layer_rest = sptr[4]; // continue on the accumulation of all sublists.
4064 2547736 sptr[5] = ENC_SYM_NIL;
4065 2547736 sptr[4] = ENC_SYM_NIL;
4066 }
4067 }
4068 // merge another sublist based on current layer.
4069 9354534 lbm_value a_list = layer_rest;
4070 // build sublist a
4071 9354534 lbm_value curr = layer_rest;
4072
2/2
✓ Branch 0 taken 13629127 times.
✓ Branch 1 taken 9354197 times.
 22983324 for (int i = 0; i < layer-1; i ++) {
4073
2/2
✓ Branch 0 taken 13628790 times.
✓ Branch 1 taken 337 times.
 13629127 if (lbm_is_cons(curr)) {
4074 13628790 curr = lbm_ref_cell(curr)->cdr;
4075 } else {
4076 337 break;
4077 }
4078 }
4079 9354534 layer_rest = lbm_cdr(curr);
4080 9354534 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
4081
4082 9354534 lbm_value b_list = layer_rest;
4083 // build sublist b
4084 9354534 curr = layer_rest;
4085
2/2
✓ Branch 0 taken 10223422 times.
✓ Branch 1 taken 7656043 times.
 17879465 for (int i = 0; i < layer-1; i ++) {
4086
2/2
✓ Branch 0 taken 8524931 times.
✓ Branch 1 taken 1698491 times.
 10223422 if (lbm_is_cons(curr)) {
4087 8524931 curr = lbm_ref_cell(curr)->cdr;
4088 } else {
4089 1698491 break;
4090 }
4091 }
4092 9354534 layer_rest = lbm_cdr(curr);
4093 9354534 lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.
4094
4095 9354534 sptr[6] = layer_rest;
4096
4097
2/2
✓ Branch 0 taken 849586 times.
✓ Branch 1 taken 8504948 times.
 9354534 if (b_list == ENC_SYM_NIL) {
4098 849586 stack_reserve(ctx,1)[0] = MERGE_LAYER;
4099 849586 ctx->r = a_list;
4100 849586 ctx->app_cont = true;
4101 849586 return;
4102 }
4103 // Set up for a merge of sublists.
4104
4105 8504948 lbm_value a_rest = lbm_cdr(a_list);
4106 8504948 lbm_value b_rest = lbm_cdr(b_list);
4107 8504948 lbm_value a = a_list;
4108 8504948 lbm_value b = b_list;
4109 8504948 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 8504948 lbm_set_cdr(b, ENC_SYM_NIL);
4114
4115 8504948 lbm_value cmp_body = sptr[0];
4116 8504948 lbm_value cmp_env = sptr[1];
4117 8504948 lbm_value par1 = sptr[2];
4118 8504948 lbm_value par2 = sptr[3];
4119 // Environment should be preallocated already at this point
4120 // and the operations below should never need GC.
4121 8504948 lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
4122 8504948 lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
4123
2/4
✓ Branch 0 taken 8504948 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 8504948 times.
 8504948 if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
4124 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4125 }
4126 8504948 cmp_env = new_env;
4127
4128 8504948 lbm_uint *merge_cont = stack_reserve(ctx, 11);
4129 8504948 merge_cont[0] = MERGE_LAYER;
4130 8504948 merge_cont[1] = ENC_SYM_NIL;
4131 8504948 merge_cont[2] = ENC_SYM_NIL;
4132 8504948 merge_cont[3] = a;
4133 8504948 merge_cont[4] = a_rest;
4134 8504948 merge_cont[5] = b_rest;
4135 8504948 merge_cont[6] = cmp_body;
4136 8504948 merge_cont[7] = cmp_env;
4137 8504948 merge_cont[8] = par1;
4138 8504948 merge_cont[9] = par2;
4139 8504948 merge_cont[10] = MERGE_REST;
4140 8504948 ctx->curr_exp = cmp_body;
4141 8504948 ctx->curr_env = cmp_env;
4142 8504948 return;
4143 }
4144
4145 /****************************************************/
4146 /* READER */
4147
4148 103499 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 33162 times.
✓ Branch 1 taken 70337 times.
 103499 if (lbm_is_symbol(ctx->r)) {
4172 33162 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4173
4/4
✓ Branch 0 taken 3 times.
✓ Branch 1 taken 33159 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 2 times.
 33162 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 103498 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 69236 times.
✓ Branch 3 taken 34262 times.
 103498 if (ctx->K.sp > 4 && (ctx->K.data[ctx->K.sp - 4] == READ_DONE) &&
4180
1/2
✓ Branch 0 taken 69236 times.
✗ Branch 1 not taken.
 69236 (ctx->K.data[ctx->K.sp - 5] == READING_PROGRAM_INCREMENTALLY)) {
4181 /* read and evaluate is done */
4182 69236 --ctx->K.sp; // Pop but do not use
4183 69236 lbm_value env = ctx->K.data[--ctx->K.sp];
4184 69236 --ctx->K.sp; // Pop but do not use
4185 69236 ctx->curr_env = env;
4186 69236 ctx->app_cont = true; // Program evaluated and result is in ctx->r.
4187
3/4
✓ Branch 0 taken 34262 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 34246 times.
✓ Branch 3 taken 16 times.
 34262 } else if (ctx->K.sp > 5 && (ctx->K.data[ctx->K.sp - 5] == READ_DONE) &&
4188
2/2
✓ Branch 0 taken 34238 times.
✓ Branch 1 taken 8 times.
 34246 (ctx->K.data[ctx->K.sp - 6] == READING_PROGRAM)) {
4189 /* successfully finished reading a program (CASE 2) */
4190 34238 ctx->r = ENC_SYM_CLOSEPAR;
4191 34238 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 103474 }
4204
4205 /* cont_read_next_token
4206 sp-2 : Stream
4207 sp-1 : Grab row
4208 */
4209 18157636 static void cont_read_next_token(eval_context_t *ctx) {
4210 18157636 lbm_value *sptr = get_stack_ptr(ctx, 2);
4211 18157636 lbm_value stream = sptr[0];
4212 18157636 lbm_value grab_row0 = sptr[1];
4213
4214 18157636 lbm_char_channel_t *chan = lbm_dec_channel(stream);
4215
2/4
✓ Branch 0 taken 18157636 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 18157636 times.
 18157636 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 16819257 times.
✓ Branch 1 taken 1338379 times.
✓ Branch 2 taken 37884 times.
✓ Branch 3 taken 16781373 times.
 18157636 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
4222 37884 lbm_stack_drop(&ctx->K, 2);
4223 37884 read_finish(chan, ctx);
4224 37859 return;
4225 }
4226 /* Eat whitespace and comments */
4227
2/2
✓ Branch 0 taken 3356 times.
✓ Branch 1 taken 18116396 times.
 18119752 if (!tok_clean_whitespace(chan)) {
4228 3356 sptr[0] = stream;
4229 3356 sptr[1] = lbm_enc_u(0);
4230 3356 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4231 3356 yield_ctx(EVAL_CPS_MIN_SLEEP);
4232 3356 return;
4233 }
4234 /* After eating whitespace we may be at end of file/stream */
4235
4/4
✓ Branch 0 taken 16782432 times.
✓ Branch 1 taken 1333964 times.
✓ Branch 2 taken 65615 times.
✓ Branch 3 taken 16716817 times.
 18116396 if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
4236 65615 lbm_stack_drop(&ctx->K, 2);
4237 65615 read_finish(chan, ctx);
4238 65615 return;
4239 }
4240
4241
2/2
✓ Branch 0 taken 1172847 times.
✓ Branch 1 taken 16877934 times.
 18050781 if (lbm_dec_u(grab_row0)) {
4242 1172847 ctx->row0 = (int32_t)lbm_channel_row(chan);
4243 1172847 ctx->row1 = -1; // a new start, end is unknown
4244 }
4245
4246 /* Attempt to extract tokens from the character stream */
4247 18050781 int n = 0;
4248 18050781 lbm_value res = ENC_SYM_NIL;
4249 18050781 unsigned int string_len = 0;
4250
4251 /*
4252 * SYNTAX
4253 */
4254 uint32_t tok_match;
4255 18050781 n = tok_syntax(chan, &tok_match);
4256
2/2
✓ Branch 0 taken 4752939 times.
✓ Branch 1 taken 13297842 times.
 18050781 if (n > 0) {
4257
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 4752939 times.
 4752939 if (!lbm_channel_drop(chan, (unsigned int)n)) {
4258 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4259 }
4260 4752939 lbm_value compound_read_start = READ_START_BYTEARRAY;
4261 4752939 lbm_value compound_value_opener = ENC_SYM_OPENBRACK;
4262 4752939 lbm_value compound_value_closer = ENC_SYM_CLOSEBRACK;
4263 4752939 ctx->app_cont = true;
4264
16/17
✓ Branch 0 taken 2257197 times.
✓ Branch 1 taken 2257173 times.
✓ Branch 2 taken 1550 times.
✓ Branch 3 taken 10407 times.
✓ Branch 4 taken 1547 times.
✓ Branch 5 taken 10404 times.
✓ Branch 6 taken 19237 times.
✓ Branch 7 taken 3277 times.
✓ Branch 8 taken 89746 times.
✓ Branch 9 taken 15323 times.
✓ Branch 10 taken 443 times.
✓ Branch 11 taken 41721 times.
✓ Branch 12 taken 24930 times.
✓ Branch 13 taken 9887 times.
✓ Branch 14 taken 9887 times.
✓ Branch 15 taken 210 times.
✗ Branch 16 not taken.
 4752939 switch(tok_match) {
4265 2257197 case TOKOPENPAR: {
4266 2257197 sptr[0] = ENC_SYM_NIL;
4267 2257197 sptr[1] = ENC_SYM_NIL;
4268 2257197 lbm_value *rptr = stack_reserve(ctx,5);
4269 2257197 rptr[0] = stream;
4270 2257197 rptr[1] = READ_APPEND_CONTINUE;
4271 2257197 rptr[2] = stream;
4272 2257197 rptr[3] = lbm_enc_u(0);
4273 2257197 rptr[4] = READ_NEXT_TOKEN;
4274 2257197 ctx->r = ENC_SYM_OPENPAR;
4275 2257197 } return;
4276 2257173 case TOKCLOSEPAR: {
4277 2257173 lbm_stack_drop(&ctx->K, 2);
4278 2257173 ctx->r = ENC_SYM_CLOSEPAR;
4279 2257173 } return;
4280 1550 case TOKOPENARRAY:
4281 1550 compound_read_start = READ_START_ARRAY; // switch to array reader
4282 1550 compound_value_opener = ENC_SYM_OPENARRAY; /* fall through */
4283 11957 case TOKOPENBRACK: {
4284 11957 sptr[0] = stream;
4285 11957 sptr[1] = compound_read_start;
4286 11957 lbm_value *rptr = stack_reserve(ctx, 3);
4287 11957 rptr[0] = stream;
4288 11957 rptr[1] = lbm_enc_u(0);
4289 11957 rptr[2] = READ_NEXT_TOKEN;
4290 11957 ctx->r = compound_value_opener;
4291 11957 } return;
4292 1547 case TOKCLOSEARRAY:
4293 1547 compound_value_closer = ENC_SYM_CLOSEARRAY; /* fall through */
4294 11951 case TOKCLOSEBRACK:
4295 11951 lbm_stack_drop(&ctx->K, 2);
4296 11951 ctx->r = compound_value_closer;
4297 11951 return;
4298 19237 case TOKDOT:
4299 19237 lbm_stack_drop(&ctx->K, 2);
4300 19237 ctx->r = ENC_SYM_DOT;
4301 19237 return;
4302 3277 case TOKDONTCARE:
4303 3277 lbm_stack_drop(&ctx->K, 2);
4304 3277 ctx->r = ENC_SYM_DONTCARE;
4305 3277 return;
4306 89746 case TOKQUOTE:
4307 89746 sptr[0] = ENC_SYM_QUOTE;
4308 89746 sptr[1] = WRAP_RESULT;
4309 89746 break;
4310 15323 case TOKBACKQUOTE: {
4311 15323 sptr[0] = QQ_EXPAND_START;
4312 15323 sptr[1] = stream;
4313 15323 lbm_value *rptr = stack_reserve(ctx, 2);
4314 15323 rptr[0] = lbm_enc_u(0);
4315 15323 rptr[1] = READ_NEXT_TOKEN;
4316 15323 ctx->app_cont = true;
4317 15323 } return;
4318 443 case TOKCOMMAAT:
4319 443 sptr[0] = ENC_SYM_COMMAAT;
4320 443 sptr[1] = WRAP_RESULT;
4321 443 break;
4322 41721 case TOKCOMMA:
4323 41721 sptr[0] = ENC_SYM_COMMA;
4324 41721 sptr[1] = WRAP_RESULT;
4325 41721 break;
4326 24930 case TOKMATCHANY:
4327 24930 lbm_stack_drop(&ctx->K, 2);
4328 24930 ctx->r = ENC_SYM_MATCH_ANY;
4329 24930 return;
4330 9887 case TOKOPENCURL: {
4331 9887 sptr[0] = ENC_SYM_NIL;
4332 9887 sptr[1] = ENC_SYM_NIL;
4333 9887 lbm_value *rptr = stack_reserve(ctx,2);
4334 9887 rptr[0] = stream;
4335 9887 rptr[1] = READ_APPEND_CONTINUE;
4336 9887 ctx->r = ENC_SYM_PROGN;
4337 9887 } return;
4338 9887 case TOKCLOSECURL:
4339 9887 lbm_stack_drop(&ctx->K, 2);
4340 9887 ctx->r = ENC_SYM_CLOSEPAR;
4341 9887 return;
4342 210 case TOKCONSTSTART: /* fall through */
4343 case TOKCONSTEND: {
4344
2/2
✓ Branch 0 taken 105 times.
✓ Branch 1 taken 105 times.
 210 if (tok_match == TOKCONSTSTART) ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST;
4345
2/2
✓ Branch 0 taken 105 times.
✓ Branch 1 taken 105 times.
 210 if (tok_match == TOKCONSTEND) ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST;
4346 210 sptr[0] = stream;
4347 210 sptr[1] = lbm_enc_u(0);
4348 210 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4349 210 ctx->app_cont = true;
4350 210 } return;
4351 ✗ default:
4352 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4353 }
4354 // read next token
4355 131910 lbm_value *rptr = stack_reserve(ctx, 3);
4356 131910 rptr[0] = stream;
4357 131910 rptr[1] = lbm_enc_u(0);
4358 131910 rptr[2] = READ_NEXT_TOKEN;
4359 131910 ctx->app_cont = true;
4360 131910 return;
4361
2/2
✓ Branch 0 taken 4 times.
✓ Branch 1 taken 13297838 times.
 13297842 } else if (n < 0) goto retry_token;
4362
4363 /*
4364 * STRING
4365 */
4366 13297838 n = tok_string(chan, &string_len);
4367
2/2
✓ Branch 0 taken 31580 times.
✓ Branch 1 taken 13266258 times.
 13297838 if (n >= 2) {
4368 31580 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 31578 times.
 31580 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 31580 times.
✗ Branch 1 not taken.
 31580 if (lbm_is_ptr(res)) {
4377 31580 lbm_array_header_t *arr = assume_array(res);
4378 31580 char *data = (char*)arr->data;
4379 31580 memset(data,0, string_len + 1);
4380 31580 memcpy(data, tokpar_sym_str, string_len);
4381 31580 lbm_stack_drop(&ctx->K, 2);
4382 31580 ctx->r = res;
4383 31580 ctx->app_cont = true;
4384 31580 return;
4385 } else {
4386 ✗ ERROR_CTX(ENC_SYM_MERROR);
4387 }
4388
2/2
✓ Branch 0 taken 106 times.
✓ Branch 1 taken 13266152 times.
 13266258 } else if (n < 0) goto retry_token;
4389
4390 /*
4391 * FLOAT
4392 */
4393 token_float f_val;
4394 13266152 n = tok_double(chan, &f_val);
4395
2/2
✓ Branch 0 taken 36234 times.
✓ Branch 1 taken 13229918 times.
 13266152 if (n > 0) {
4396 36234 lbm_channel_drop(chan, (unsigned int) n);
4397
2/3
✓ Branch 0 taken 27144 times.
✓ Branch 1 taken 9090 times.
✗ Branch 2 not taken.
 36234 switch(f_val.type) {
4398 27144 case TOKTYPEF32:
4399
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 27144 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 27144 WITH_GC(res, lbm_enc_float((float)f_val.value));
4400 27144 break;
4401 9090 case TOKTYPEF64:
4402 9090 res = lbm_enc_double(f_val.value);
4403 9090 break;
4404 ✗ default:
4405 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4406 }
4407 36234 lbm_stack_drop(&ctx->K, 2);
4408 36234 ctx->r = res;
4409 36234 ctx->app_cont = true;
4410 36234 return;
4411
2/2
✓ Branch 0 taken 254 times.
✓ Branch 1 taken 13229664 times.
 13229918 } else if (n < 0) goto retry_token;
4412
4413 /*
4414 * INTEGER
4415 */
4416 token_int int_result;
4417 13229664 n = tok_integer(chan, &int_result);
4418
2/2
✓ Branch 0 taken 10147226 times.
✓ Branch 1 taken 3082438 times.
 13229664 if (n > 0) {
4419 10147226 lbm_channel_drop(chan, (unsigned int)n);
4420
7/8
✓ Branch 0 taken 7992 times.
✓ Branch 1 taken 10082655 times.
✓ Branch 2 taken 10504 times.
✓ Branch 3 taken 11016 times.
✓ Branch 4 taken 13463 times.
✓ Branch 5 taken 11346 times.
✓ Branch 6 taken 10250 times.
✗ Branch 7 not taken.
 10147226 switch(int_result.type) {
4421 7992 case TOKTYPEBYTE:
4422
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 7992 times.
 7992 res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
4423 7992 break;
4424 10082655 case TOKTYPEI:
4425
2/2
✓ Branch 0 taken 4580 times.
✓ Branch 1 taken 10078075 times.
 10082655 res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
4426 10082655 break;
4427 10504 case TOKTYPEU:
4428
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 10336 times.
 10504 res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
4429 10504 break;
4430 11016 case TOKTYPEI32:
4431
3/8
✓ Branch 0 taken 172 times.
✓ Branch 1 taken 10844 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 11016 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 11016 WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)));
4432 11016 break;
4433 13463 case TOKTYPEU32:
4434
3/8
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 13295 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 13463 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 13463 WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)));
4435 13463 break;
4436 11346 case TOKTYPEI64:
4437
3/8
✓ Branch 0 taken 256 times.
✓ Branch 1 taken 11090 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 11346 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 11346 WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)));
4438 11346 break;
4439 10250 case TOKTYPEU64:
4440
3/8
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 10082 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 10250 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
✗ Branch 6 not taken.
✗ Branch 7 not taken.
 10250 WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)));
4441 10250 break;
4442 ✗ default:
4443 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4444 }
4445 10147226 lbm_stack_drop(&ctx->K, 2);
4446 10147226 ctx->r = res;
4447 10147226 ctx->app_cont = true;
4448 10147226 return;
4449
2/2
✓ Branch 0 taken 36 times.
✓ Branch 1 taken 3082402 times.
 3082438 } else if (n < 0) goto retry_token;
4450
4451 /*
4452 * SYMBOL
4453 */
4454 3082402 n = tok_symbol(chan);
4455
2/2
✓ Branch 0 taken 3079719 times.
✓ Branch 1 taken 2683 times.
 3082402 if (n > 0) {
4456 3079719 lbm_channel_drop(chan, (unsigned int) n);
4457 lbm_uint symbol_id;
4458
2/2
✓ Branch 0 taken 319827 times.
✓ Branch 1 taken 2759892 times.
 3079719 if (!lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
4459 319827 int r = 0;
4460
2/2
✓ Branch 0 taken 78110 times.
✓ Branch 1 taken 241717 times.
 319827 if (n > 4 &&
4461
2/2
✓ Branch 0 taken 1529 times.
✓ Branch 1 taken 76581 times.
 78110 tokpar_sym_str[0] == 'e' &&
4462
2/2
✓ Branch 0 taken 229 times.
✓ Branch 1 taken 1300 times.
 1529 tokpar_sym_str[1] == 'x' &&
4463
2/2
✓ Branch 0 taken 135 times.
✓ Branch 1 taken 94 times.
 229 tokpar_sym_str[2] == 't' &&
4464
2/2
✓ Branch 0 taken 42 times.
✓ Branch 1 taken 93 times.
 135 tokpar_sym_str[3] == '-') {
4465 lbm_uint ext_id;
4466 42 lbm_uint ext_name_len = (lbm_uint)n + 1;
4467 #ifdef LBM_ALWAYS_GC
4468 gc();
4469 #endif
4470 42 char *ext_name = lbm_malloc(ext_name_len);
4471
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 42 times.
 42 if (!ext_name) {
4472 ✗ gc();
4473 ✗ ext_name = lbm_malloc(ext_name_len);
4474 }
4475
1/2
✓ Branch 0 taken 42 times.
✗ Branch 1 not taken.
 42 if (ext_name) {
4476 42 memcpy(ext_name, tokpar_sym_str, ext_name_len);
4477 42 r = lbm_add_extension(ext_name, lbm_extensions_default);
4478
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 42 times.
 42 if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
4479 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4480 }
4481 42 symbol_id = ext_id;
4482 } else {
4483 ✗ ERROR_CTX(ENC_SYM_MERROR);
4484 }
4485 } else {
4486 319785 r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id);
4487 }
4488
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 319827 times.
 319827 if (!r) {
4489 ✗ READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4490 }
4491 }
4492 3079719 lbm_stack_drop(&ctx->K, 2);
4493 3079719 ctx->r = lbm_enc_sym(symbol_id);
4494 3079719 ctx->app_cont = true;
4495 3079719 return;
4496
2/2
✓ Branch 0 taken 559 times.
✓ Branch 1 taken 2124 times.
 2683 } else if (n == TOKENIZER_NEED_MORE) {
4497 559 goto retry_token;
4498
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 2123 times.
 2124 } 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 2123 n = tok_char(chan, &c_val);
4507
2/2
✓ Branch 0 taken 2037 times.
✓ Branch 1 taken 86 times.
 2123 if(n > 0) {
4508 2037 lbm_channel_drop(chan,(unsigned int) n);
4509 2037 lbm_stack_drop(&ctx->K, 2);
4510 2037 ctx->r = lbm_enc_char((uint8_t)c_val);
4511 2037 ctx->app_cont = true;
4512 2037 return;
4513
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 2 times.
 86 }else if (n < 0) goto retry_token;
4514
4515 2 READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4516
4517 1043 retry_token:
4518
2/2
✓ Branch 0 taken 871 times.
✓ Branch 1 taken 172 times.
 1043 if (n == TOKENIZER_NEED_MORE) {
4519 871 sptr[0] = stream;
4520 871 sptr[1] = lbm_enc_u(0);
4521 871 stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
4522 871 yield_ctx(EVAL_CPS_MIN_SLEEP);
4523 871 return;
4524 }
4525 172 READ_ERROR_CTX(lbm_channel_row(chan), lbm_channel_column(chan));
4526 }
4527
4528 10407 static void cont_read_start_bytearray(eval_context_t *ctx) {
4529 10407 lbm_value *sptr = get_stack_ptr(ctx, 1);
4530 10407 lbm_value stream = sptr[0];
4531
4532 10407 lbm_char_channel_t *str = lbm_dec_channel(stream);
4533
2/4
✓ Branch 0 taken 10407 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 10407 times.
 10407 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 173 times.
✓ Branch 1 taken 10234 times.
 10407 if (ctx->r == ENC_SYM_CLOSEBRACK) {
4539 lbm_value array;
4540
4541
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 173 times.
 173 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 173 lbm_stack_drop(&ctx->K, 1);
4550 173 ctx->r = array;
4551 173 ctx->app_cont = true;
4552
1/2
✓ Branch 0 taken 10234 times.
✗ Branch 1 not taken.
 10234 } else if (lbm_is_number(ctx->r)) {
4553 #ifdef LBM_ALWAYS_GC
4554 gc();
4555 #endif
4556 10234 lbm_uint num_free = lbm_memory_longest_free();
4557 10234 lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
4558
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 10234 times.
 10234 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 10234 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 10234 times.
 10234 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 10234 sptr[0] = array;
4584 10234 lbm_value *rptr = stack_reserve(ctx, 4);
4585 10234 rptr[0] = lbm_enc_u(initial_size);
4586 10234 rptr[1] = lbm_enc_u(0);
4587 10234 rptr[2] = stream;
4588 10234 rptr[3] = READ_APPEND_BYTEARRAY;
4589 10234 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 1116408 static void cont_read_append_bytearray(eval_context_t *ctx) {
4597 1116408 lbm_uint *sptr = get_stack_ptr(ctx, 4);
4598
4599 1116408 lbm_value array = sptr[0];
4600 1116408 lbm_value size = lbm_dec_as_u32(sptr[1]);
4601 1116408 lbm_value ix = lbm_dec_as_u32(sptr[2]);
4602 1116408 lbm_value stream = sptr[3];
4603
4604
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1116408 times.
 1116408 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 1116408 lbm_array_header_t *arr = assume_array(array);
4611
2/2
✓ Branch 0 taken 1106177 times.
✓ Branch 1 taken 10231 times.
 1116408 if (lbm_is_number(ctx->r)) {
4612 1106177 ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
4613
4614 1106177 sptr[2] = lbm_enc_u(ix + 1);
4615 1106177 lbm_value *rptr = stack_reserve(ctx, 4);
4616 1106177 rptr[0] = READ_APPEND_BYTEARRAY;
4617 1106177 rptr[1] = stream;
4618 1106177 rptr[2] = lbm_enc_u(0);
4619 1106177 rptr[3] = READ_NEXT_TOKEN;
4620 1106177 ctx->app_cont = true;
4621
3/4
✓ Branch 0 taken 10231 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 10230 times.
✓ Branch 3 taken 1 times.
 10231 } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK) {
4622 10230 lbm_uint array_size = ix / sizeof(lbm_uint);
4623
4624
2/2
✓ Branch 0 taken 8431 times.
✓ Branch 1 taken 1799 times.
 10230 if (ix % sizeof(lbm_uint) != 0) {
4625 8431 array_size = array_size + 1;
4626 }
4627 10230 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
4628 10230 arr->size = ix;
4629 10230 lbm_stack_drop(&ctx->K, 4);
4630 10230 ctx->r = array;
4631 10230 ctx->app_cont = true;
4632 } else {
4633 1 ERROR_CTX(ENC_SYM_TERROR);
4634 }
4635 1116407 }
4636
4637 // Lisp array syntax reading ////////////////////////////////////////
4638
4639 1550 static void cont_read_start_array(eval_context_t *ctx) {
4640 1550 lbm_value *sptr = get_stack_ptr(ctx, 1);
4641 1550 lbm_value stream = sptr[0];
4642
4643 1550 lbm_char_channel_t *str = lbm_dec_channel(stream);
4644
2/4
✓ Branch 0 taken 1550 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 1550 times.
 1550 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 86 times.
✓ Branch 1 taken 1464 times.
 1550 if (ctx->r == ENC_SYM_CLOSEARRAY) {
4650 lbm_value array;
4651
4652
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 86 times.
 86 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 86 lbm_stack_drop(&ctx->K, 1);
4661 86 ctx->r = array;
4662 86 ctx->app_cont = true;
4663 } else {
4664 #ifdef LBM_ALWAYS_GC
4665 gc();
4666 #endif
4667 1464 lbm_uint num = ((lbm_uint)((float)lbm_memory_longest_free() * 0.9) / sizeof(lbm_uint)) ;
4668 1464 lbm_uint initial_size = (lbm_uint)num;
4669
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1464 times.
 1464 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 1464 initial_size = sizeof(lbm_uint) * initial_size;
4680
4681
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1464 times.
 1464 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 1464 sptr[0] = array;
4691 1464 lbm_value *rptr = stack_reserve(ctx, 4);
4692 1464 rptr[0] = lbm_enc_u(initial_size);
4693 1464 rptr[1] = lbm_enc_u(0);
4694 1464 rptr[2] = stream;
4695 1464 rptr[3] = READ_APPEND_ARRAY;
4696 1464 ctx->app_cont = true;
4697 }
4698 }
4699
4700 6872 static void cont_read_append_array(eval_context_t *ctx) {
4701 6872 lbm_uint *sptr = get_stack_ptr(ctx, 4);
4702
4703 6872 lbm_value array = sptr[0];
4704 6872 lbm_value size = lbm_dec_as_u32(sptr[1]);
4705 6872 lbm_value ix = lbm_dec_as_u32(sptr[2]);
4706 6872 lbm_value stream = sptr[3];
4707
4708
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 6872 times.
 6872 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 6872 lbm_array_header_t *arr = assume_array(array);
4715
4/4
✓ Branch 0 taken 4744 times.
✓ Branch 1 taken 2128 times.
✓ Branch 2 taken 1461 times.
✓ Branch 3 taken 3283 times.
 6872 if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEARRAY) {
4716 1461 lbm_uint array_size = ix;
4717
4718
2/2
✓ Branch 0 taken 1037 times.
✓ Branch 1 taken 424 times.
 1461 if (ix % sizeof(lbm_uint) != 0) {
4719 1037 array_size = array_size + 1;
4720 }
4721 1461 lbm_memory_shrink((lbm_uint*)arr->data, array_size);
4722 1461 arr->size = ix * sizeof(lbm_uint);
4723 1461 lbm_stack_drop(&ctx->K, 4);
4724 1461 ctx->r = array;
4725 1461 ctx->app_cont = true;
4726 } else {
4727 5411 ((lbm_uint*)arr->data)[ix] = ctx->r;
4728
4729 5411 sptr[2] = lbm_enc_u(ix + 1);
4730 5411 lbm_value *rptr = stack_reserve(ctx, 4);
4731 5411 rptr[0] = READ_APPEND_ARRAY;
4732 5411 rptr[1] = stream;
4733 5411 rptr[2] = lbm_enc_u(0);
4734 5411 rptr[3] = READ_NEXT_TOKEN;
4735 5411 ctx->app_cont = true;
4736 }
4737 6872 }
4738
4739 // Lisp list syntax reading ////////////////////////////////////////
4740
4741 15645815 static void cont_read_append_continue(eval_context_t *ctx) {
4742 15645815 lbm_value *sptr = get_stack_ptr(ctx, 3);
4743
4744 15645815 lbm_value first_cell = sptr[0];
4745 15645815 lbm_value last_cell = sptr[1];
4746 15645815 lbm_value stream = sptr[2];
4747
4748 15645815 lbm_char_channel_t *str = lbm_dec_channel(stream);
4749
2/4
✓ Branch 0 taken 15645815 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 15645815 times.
 15645815 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 5277554 times.
✓ Branch 1 taken 10368261 times.
 15645815 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4756
4757
3/3
✓ Branch 0 taken 2282062 times.
✓ Branch 1 taken 19237 times.
✓ Branch 2 taken 2976255 times.
 5277554 switch(ctx->r) {
4758 2282062 case ENC_SYM_CLOSEPAR:
4759
2/2
✓ Branch 0 taken 2272901 times.
✓ Branch 1 taken 9161 times.
 2282062 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4760 2272901 lbm_set_cdr(last_cell, ENC_SYM_NIL); // terminate the list
4761 2272901 ctx->r = first_cell;
4762 } else {
4763 9161 ctx->r = ENC_SYM_NIL;
4764 }
4765 2282062 lbm_stack_drop(&ctx->K, 3);
4766 /* Skip reading another token and apply the continuation */
4767 2282062 ctx->app_cont = true;
4768 2282062 return;
4769 19237 case ENC_SYM_DOT: {
4770 19237 lbm_value *rptr = stack_reserve(ctx, 4);
4771 19237 rptr[0] = READ_DOT_TERMINATE;
4772 19237 rptr[1] = stream;
4773 19237 rptr[2] = lbm_enc_u(0);
4774 19237 rptr[3] = READ_NEXT_TOKEN;
4775 19237 ctx->app_cont = true;
4776 19237 } return;
4777 }
4778 }
4779 13344516 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 11052350 times.
✓ Branch 1 taken 2292160 times.
 13344510 if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
4788 11052350 lbm_set_cdr(last_cell, new_cell);
4789 11052350 last_cell = new_cell;
4790 } else {
4791 2292160 first_cell = last_cell = new_cell;
4792 }
4793 13344510 sptr[0] = first_cell;
4794 13344510 sptr[1] = last_cell;
4795 //sptr[2] = stream; // unchanged.
4796 13344510 lbm_value *rptr = stack_reserve(ctx, 4);
4797 13344510 rptr[0] = READ_APPEND_CONTINUE;
4798 13344510 rptr[1] = stream;
4799 13344510 rptr[2] = lbm_enc_u(0);
4800 13344510 rptr[3] = READ_NEXT_TOKEN;
4801 13344510 ctx->app_cont = true;
4802 }
4803
4804 244595 static void cont_read_eval_continue(eval_context_t *ctx) {
4805 lbm_value env;
4806 lbm_value stream;
4807 244595 lbm_value *sptr = get_stack_ptr(ctx, 2);
4808 244595 env = sptr[1];
4809 244595 stream = sptr[0];
4810 244595 lbm_char_channel_t *str = lbm_dec_channel(stream);
4811
2/4
✓ Branch 0 taken 244595 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 244595 times.
✗ Branch 3 not taken.
 244595 if (str && str->state) {
4812 244595 ctx->row1 = (lbm_int)str->row(str);
4813
2/2
✓ Branch 0 taken 18833 times.
✓ Branch 1 taken 225762 times.
 244595 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
4814
1/3
✗ Branch 0 not taken.
✗ Branch 1 not taken.
✓ Branch 2 taken 18833 times.
 18833 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 244595 lbm_value *rptr = stack_reserve(ctx, 6);
4827 244595 rptr[0] = READ_EVAL_CONTINUE;
4828 244595 rptr[1] = stream;
4829 244595 rptr[2] = lbm_enc_u(1);
4830 244595 rptr[3] = READ_NEXT_TOKEN;
4831 244595 rptr[4] = lbm_enc_u(ctx->flags);
4832 244595 rptr[5] = POP_READER_FLAGS;
4833
4834 244595 ctx->curr_env = env;
4835 244595 ctx->curr_exp = ctx->r;
4836 } else {
4837 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4838 }
4839 }
4840
4841 19235 static void cont_read_expect_closepar(eval_context_t *ctx) {
4842 19235 lbm_value res = ctx->K.data[--ctx->K.sp];
4843 19235 lbm_value stream = ctx->K.data[--ctx->K.sp];
4844
4845 19235 lbm_char_channel_t *str = lbm_dec_channel(stream);
4846
2/4
✓ Branch 0 taken 19235 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 19235 times.
 19235 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 19234 times.
✓ Branch 1 taken 1 times.
 19235 if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4850
1/2
✓ Branch 0 taken 19234 times.
✗ Branch 1 not taken.
 19234 ctx->r == ENC_SYM_CLOSEPAR) {
4851 19234 ctx->r = res;
4852 19234 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 19234 }
4860
4861 19237 static void cont_read_dot_terminate(eval_context_t *ctx) {
4862 19237 lbm_value *sptr = get_stack_ptr(ctx, 3);
4863
4864 19237 lbm_value last_cell = sptr[1];
4865 19237 lbm_value stream = sptr[2];
4866
4867 19237 lbm_char_channel_t *str = lbm_dec_channel(stream);
4868
2/4
✓ Branch 0 taken 19237 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 19237 times.
 19237 if (str == NULL || str->state == NULL) {
4869 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
4870
2/2
✓ Branch 0 taken 5140 times.
✓ Branch 1 taken 14097 times.
 19237 } else if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
4871
2/2
✓ Branch 0 taken 5139 times.
✓ Branch 1 taken 1 times.
 5140 (ctx->r == ENC_SYM_CLOSEPAR ||
4872
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 5139 times.
 5139 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 19235 times.
✓ Branch 1 taken 1 times.
 19236 } else if (lbm_is_cons(last_cell)) {
4877 19235 lbm_ref_cell(last_cell)->cdr = ctx->r;
4878 //lbm_set_cdr(last_cell, ctx->r);
4879 19235 ctx->r = sptr[0]; // first cell
4880 19235 lbm_value *rptr = stack_reserve(ctx, 3);
4881 19235 sptr[0] = stream;
4882 19235 sptr[1] = ctx->r;
4883 19235 sptr[2] = READ_EXPECT_CLOSEPAR;
4884 19235 rptr[0] = stream;
4885 19235 rptr[1] = lbm_enc_u(0);
4886 19235 rptr[2] = READ_NEXT_TOKEN;
4887 19235 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 19235 }
4894
4895 997433 static void cont_read_done(eval_context_t *ctx) {
4896 //lbm_value reader_mode = ctx->K.data[--ctx->K.sp];
4897 997433 --ctx->K.sp;
4898 997433 lbm_value stream = ctx->K.data[--ctx->K.sp];
4899 997433 lbm_value f_val = ctx->K.data[--ctx->K.sp];
4900
4901 997433 uint32_t flags = lbm_dec_as_u32(f_val);
4902 997433 ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
4903 997433 ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
4904
4905 997433 lbm_char_channel_t *str = lbm_dec_channel(stream);
4906
2/4
✓ Branch 0 taken 997433 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 997433 times.
 997433 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 997433 lbm_channel_reader_close(str);
4914
2/2
✓ Branch 0 taken 68138 times.
✓ Branch 1 taken 929295 times.
 997433 if (lbm_is_symbol(ctx->r)) {
4915 68138 lbm_uint sym_val = lbm_dec_sym(ctx->r);
4916
3/4
✓ Branch 0 taken 35028 times.
✓ Branch 1 taken 33110 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 35028 times.
 68138 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 997433 ctx->row0 = -1;
4922 997433 ctx->row1 = -1;
4923 997433 ctx->app_cont = true;
4924 }
4925 997433 }
4926
4927 131773 static void cont_wrap_result(eval_context_t *ctx) {
4928 lbm_value cell;
4929 131773 lbm_value wrapper = ctx->K.data[--ctx->K.sp];
4930
3/4
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 131772 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 1 times.
 131773 WITH_GC(cell, lbm_heap_allocate_list_init(2,
4931 wrapper,
4932 ctx->r));
4933 131773 ctx->r = cell;
4934 131773 ctx->app_cont = true;
4935 131773 }
4936
4937 // cont_application_start
4938 //
4939 // sptr[0] = env
4940 // sptr[1] = args
4941 //
4942 // ctx->r = function
4943 804521853 static void cont_application_start(eval_context_t *ctx) {
4944
2/2
✓ Branch 0 taken 693588812 times.
✓ Branch 1 taken 110933041 times.
 804521853 if (lbm_is_symbol(ctx->r)) {
4945 693588812 stack_reserve(ctx,1)[0] = lbm_enc_u(0);
4946 693588812 cont_application_args(ctx);
4947
2/2
✓ Branch 0 taken 110933037 times.
✓ Branch 1 taken 4 times.
 110933041 } else if (lbm_is_cons(ctx->r)) {
4948 110933037 lbm_uint *sptr = get_stack_ptr(ctx, 2);
4949 110933037 lbm_value args = (lbm_value)sptr[1];
4950
3/5
✓ Branch 0 taken 110906127 times.
✓ Branch 1 taken 588 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 26322 times.
✗ Branch 4 not taken.
 110933037 switch (lbm_ref_cell(ctx->r)->car) { // Already checked that is_cons
4951 110906127 case ENC_SYM_CLOSURE: {
4952 lbm_value cl[3];
4953 110906127 extract_n(get_cdr(ctx->r), cl, 3);
4954 110906127 lbm_value arg_env = (lbm_value)sptr[0];
4955 lbm_value arg0, arg_rest;
4956 110906127 get_car_and_cdr(args, &arg0, &arg_rest);
4957 110906127 sptr[1] = cl[CLO_BODY];
4958 110906127 bool a_nil = lbm_is_symbol_nil(args);
4959 110906127 bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS]);
4960 110906127 lbm_value *reserved = stack_reserve(ctx, 4);
4961
4962
4/4
✓ Branch 0 taken 83646851 times.
✓ Branch 1 taken 27259276 times.
✓ Branch 2 taken 82806751 times.
✓ Branch 3 taken 840100 times.
 110906127 if (!a_nil && !p_nil) {
4963 82806751 reserved[0] = cl[CLO_ENV];
4964 82806751 reserved[1] = cl[CLO_PARAMS];
4965 82806751 reserved[2] = arg_rest;
4966 82806751 reserved[3] = CLOSURE_ARGS;
4967 82806751 ctx->curr_exp = arg0;
4968 82806751 ctx->curr_env = arg_env;
4969
4/4
✓ Branch 0 taken 27259276 times.
✓ Branch 1 taken 840100 times.
✓ Branch 2 taken 27259274 times.
✓ Branch 3 taken 2 times.
 28099376 } else if (a_nil && p_nil) {
4970 // No params, No args
4971 27259274 lbm_stack_drop(&ctx->K, 6);
4972 27259274 ctx->curr_exp = cl[CLO_BODY];
4973 27259274 ctx->curr_env = cl[CLO_ENV];
4974
2/2
✓ Branch 0 taken 840100 times.
✓ Branch 1 taken 2 times.
 840102 } else if (p_nil) {
4975 840100 reserved[1] = get_cdr(args); // protect cdr(args) from allocate_binding
4976 840100 ctx->curr_exp = get_car(args); // protect car(args) from allocate binding
4977 840100 ctx->curr_env = arg_env;
4978 840100 lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, cl[CLO_ENV]);
4979 840100 reserved[0] = rest_binder;
4980 840100 reserved[2] = get_car(rest_binder);
4981 840100 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 110906125 } break;
4987 588 case ENC_SYM_CONT:{
4988 588 ctx->curr_exp = setup_cont(ctx, args);
4989 588 } break;
4990 ✗ case ENC_SYM_CONT_SP: {
4991 ✗ ctx->curr_exp = setup_cont_sp(ctx, args);
4992 ✗ return;
4993 } break;
4994 26322 case ENC_SYM_MACRO:{
4995 26322 lbm_value env = (lbm_value)sptr[0];
4996 26322 pop_stack_ptr(ctx, 2);
4997 setup_macro(ctx, args, env);
4998 26322 } 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 26658 static void cont_eval_r(eval_context_t* ctx) {
5009 26658 lbm_value env = ctx->K.data[--ctx->K.sp];
5010 26658 ctx->curr_exp = ctx->r;
5011 26658 ctx->curr_env = env;
5012 26658 }
5013
5014 1933450 static void cont_progn_var(eval_context_t* ctx) {
5015
5016 1933450 lbm_value key = ctx->K.data[--ctx->K.sp];
5017 1933450 lbm_value env = ctx->K.data[--ctx->K.sp];
5018 1933450 fill_binding_location(key, ctx->r, env);
5019
5020 1933450 ctx->curr_env = env; // evaluating value may build upon local env.
5021 1933450 ctx->app_cont = true;
5022 1933450 }
5023
5024 6703710 static void cont_setq(eval_context_t *ctx) {
5025 6703710 lbm_value sym = ctx->K.data[--ctx->K.sp];
5026 6703710 lbm_value env = ctx->K.data[--ctx->K.sp];
5027 lbm_value res;
5028
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 6703541 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 6703710 WITH_GC(res, perform_setvar(sym, ctx->r, env));
5029 6703541 ctx->r = res;
5030 6703541 ctx->app_cont = true;
5031 6703541 }
5032
5033 7455 lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {
5034
5035 lbm_value flash_cell;
5036 7455 lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
5037
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 7455 times.
 7455 if (s != LBM_FLASH_WRITE_OK)
5038 ✗ return s;
5039 7455 lbm_value new_val = val;
5040 7455 new_val &= ~LBM_PTR_VAL_MASK; // clear the value part of the ptr
5041 7455 new_val |= (flash_cell & LBM_PTR_VAL_MASK);
5042 7455 new_val |= LBM_PTR_TO_CONSTANT_BIT;
5043 7455 *res = new_val;
5044 7455 return s;
5045 }
5046
5047 2520 static void cont_move_to_flash(eval_context_t *ctx) {
5048
5049 2520 lbm_value args = ctx->K.data[--ctx->K.sp];
5050
5051
2/2
✓ Branch 0 taken 1092 times.
✓ Branch 1 taken 1428 times.
 2520 if (lbm_is_symbol_nil(args)) {
5052 // Done looping over arguments. return true.
5053 1092 ctx->r = ENC_SYM_TRUE;
5054 1092 ctx->app_cont = true;
5055 1092 return;
5056 }
5057
5058 lbm_value first_arg, rest;
5059 1428 get_car_and_cdr(args, &first_arg, &rest);
5060
5061 lbm_value val;
5062
2/4
✓ Branch 0 taken 1428 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 1428 times.
✗ Branch 3 not taken.
 1428 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 1428 lbm_value *rptr = stack_reserve(ctx, 2);
5065 1428 rptr[0] = rest;
5066 1428 rptr[1] = MOVE_TO_FLASH;
5067
2/2
✓ Branch 0 taken 1288 times.
✓ Branch 1 taken 140 times.
 1428 if (lbm_is_ptr(val) &&
5068
1/2
✓ Branch 0 taken 1288 times.
✗ Branch 1 not taken.
 1288 (!(val & LBM_PTR_TO_CONSTANT_BIT))) {
5069 1288 lbm_value * rptr1 = stack_reserve(ctx, 3);
5070 1288 rptr1[0] = first_arg;
5071 1288 rptr1[1] = SET_GLOBAL_ENV;
5072 1288 rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH;
5073 1288 ctx->r = val;
5074 }
5075 1428 ctx->app_cont = true;
5076 1428 return;
5077 }
5078 ✗ ERROR_CTX(ENC_SYM_EERROR);
5079 }
5080
5081 10796 static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {
5082
5083 10796 lbm_value val = ctx->r;
5084
5085
2/2
✓ Branch 0 taken 2568 times.
✓ Branch 1 taken 8228 times.
 10796 if (lbm_is_cons(val)) { // non-constant cons-cell
5086 2568 lbm_value *rptr = stack_reserve(ctx, 5);
5087 2568 rptr[0] = ENC_SYM_NIL; // fst cell of list
5088 2568 rptr[1] = ENC_SYM_NIL; // last cell of list
5089 2568 rptr[2] = get_cdr(val);
5090 2568 rptr[3] = MOVE_LIST_TO_FLASH;
5091 2568 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
5092 2568 ctx->r = lbm_ref_cell(val)->car; // already checked is_cons
5093 2568 ctx->app_cont = true;
5094 2568 return;
5095 }
5096
5097
3/4
✓ Branch 0 taken 764 times.
✓ Branch 1 taken 7464 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 764 times.
 8228 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 764 times.
✓ Branch 1 taken 7464 times.
 8228 if (lbm_is_ptr(val)) { // something that is not a cons but still a ptr type.
5104 764 lbm_cons_t *ref = lbm_ref_cell(val);
5105
1/2
✓ Branch 0 taken 764 times.
✗ Branch 1 not taken.
 764 if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL) {
5106
4/6
✓ Branch 0 taken 383 times.
✓ Branch 1 taken 117 times.
✓ Branch 2 taken 84 times.
✓ Branch 3 taken 180 times.
✗ Branch 4 not taken.
✗ Branch 5 not taken.
 764 switch (ref->cdr) {
5107 383 case ENC_SYM_RAW_I_TYPE: /* fall through */
5108 case ENC_SYM_RAW_U_TYPE:
5109 case ENC_SYM_RAW_F_TYPE: {
5110 383 lbm_value flash_cell = ENC_SYM_NIL;
5111 383 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5112 383 handle_flash_status(write_const_car(flash_cell, ref->car));
5113 383 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
5114 383 ctx->r = flash_cell;
5115 383 } break;
5116 117 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 117 lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
5122 lbm_uint flash_ptr;
5123
5124 117 handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
5125 117 lbm_value flash_cell = ENC_SYM_NIL;
5126 117 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5127 117 handle_flash_status(write_const_car(flash_cell, flash_ptr));
5128 117 handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
5129 117 ctx->r = flash_cell;
5130 #else
5131 // There are no indirect types in LBM64
5132 ✗ ERROR_CTX(ENC_SYM_FATAL_ERROR);
5133 #endif
5134 117 } break;
5135 84 case ENC_SYM_LISPARRAY_TYPE: {
5136 84 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
5137 84 lbm_uint size = arr->size / sizeof(lbm_uint);
5138 84 lbm_uint flash_addr = 0;
5139 84 lbm_value *arrdata = (lbm_value *)arr->data;
5140 84 lbm_value flash_cell = ENC_SYM_NIL;
5141 84 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5142 84 handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
5143 84 lift_array_flash(flash_cell,
5144 false,
5145 (char *)flash_addr,
5146 arr->size);
5147 // Move array contents to flash recursively
5148 84 lbm_value *rptr = stack_reserve(ctx, 5);
5149 84 rptr[0] = flash_cell;
5150 84 rptr[1] = lbm_enc_u(0);
5151 84 rptr[2] = val;
5152 84 rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH;
5153 84 rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
5154 84 ctx->r = arrdata[0];
5155 84 ctx->app_cont = true;
5156 84 return;
5157 }
5158 180 case ENC_SYM_ARRAY_TYPE: {
5159 180 lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
5160 // arbitrary address: flash_arr.
5161 180 lbm_uint flash_arr = 0;
5162 180 handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
5163 180 lbm_value flash_cell = ENC_SYM_NIL;
5164 180 handle_flash_status(request_flash_storage_cell(val, &flash_cell));
5165 180 lift_array_flash(flash_cell,
5166 true,
5167 (char *)flash_arr,
5168 arr->size);
5169 180 ctx->r = flash_cell;
5170 180 } 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 680 ctx->app_cont = true;
5180 680 return;
5181 }
5182
5183 // if no condition matches, nothing happens (id).
5184 7464 ctx->r = val;
5185 7464 ctx->app_cont = true;
5186 }
5187
5188 6523 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 6523 lbm_value *sptr = get_stack_ptr(ctx, 3);
5193
5194 6523 lbm_value fst = sptr[0];
5195 6523 lbm_value lst = sptr[1];
5196 6523 lbm_value val = sptr[2];
5197
5198
5199 6523 lbm_value new_lst = ENC_SYM_NIL;
5200 // Allocate element ptr storage after storing the element to flash.
5201 6523 handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL), &new_lst));
5202
5203
2/2
✓ Branch 0 taken 2568 times.
✓ Branch 1 taken 3955 times.
 6523 if (lbm_is_symbol_nil(fst)) {
5204 2568 lst = new_lst;
5205 2568 fst = new_lst;
5206 2568 handle_flash_status(write_const_car(lst, ctx->r));
5207 } else {
5208 3955 handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
5209 3955 handle_flash_status(write_const_car(new_lst, ctx->r));
5210 3955 lst = new_lst;
5211 }
5212
5213
2/2
✓ Branch 0 taken 3955 times.
✓ Branch 1 taken 2568 times.
 6523 if (lbm_is_cons(val)) {
5214 3955 sptr[0] = fst;
5215 3955 sptr[1] = lst;//rest_cell;
5216 3955 sptr[2] = lbm_ref_cell(val)->cdr;
5217 3955 lbm_value *rptr = stack_reserve(ctx, 2);
5218 3955 rptr[0] = MOVE_LIST_TO_FLASH;
5219 3955 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
5220 3955 ctx->r = lbm_ref_cell(val)->car; // already checked is_cons
5221 } else {
5222 2568 sptr[0] = fst;
5223 2568 sptr[1] = lst;
5224 2568 sptr[2] = CLOSE_LIST_IN_FLASH;
5225 2568 stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
5226 2568 ctx->r = val;
5227 }
5228 6523 ctx->app_cont = true;
5229 6523 }
5230
5231 2568 static void cont_close_list_in_flash(eval_context_t *ctx) {
5232 2568 lbm_value lst = ctx->K.data[--ctx->K.sp];
5233 2568 lbm_value fst = ctx->K.data[--ctx->K.sp];
5234 2568 lbm_value val = ctx->r;
5235 2568 handle_flash_status(write_const_cdr(lst, val));
5236 2568 ctx->r = fst;
5237 2568 ctx->app_cont = true;
5238 2568 }
5239
5240 252 static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
5241 252 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 252 lbm_array_header_t *src_arr = assume_array(sptr[2]);
5246 252 lbm_uint size = src_arr->size / sizeof(lbm_uint);
5247 252 lbm_value *srcdata = (lbm_value *)src_arr->data;
5248
5249 252 lbm_array_header_t *tgt_arr = assume_array(sptr[0]);
5250 252 lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
5251 252 lbm_uint ix = lbm_dec_as_u32(sptr[1]);
5252 252 handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
5253
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 168 times.
 252 if (ix >= size-1) {
5254 84 ctx->r = sptr[0];
5255 84 lbm_stack_drop(&ctx->K, 3);
5256 84 ctx->app_cont = true;
5257 84 return;
5258 }
5259 168 sptr[1] = lbm_enc_u(ix + 1);
5260 168 lbm_value *rptr = stack_reserve(ctx, 2);
5261 168 rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH;
5262 168 rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
5263 168 ctx->r = srcdata[ix+1];
5264 168 ctx->app_cont = true;
5265 168 return;
5266 }
5267
5268 15257 static void cont_qq_expand_start(eval_context_t *ctx) {
5269 15257 lbm_value *rptr = stack_reserve(ctx, 2);
5270 15257 rptr[0] = ctx->r;
5271 15257 rptr[1] = QQ_EXPAND;
5272 15257 ctx->r = ENC_SYM_NIL;
5273 15257 ctx->app_cont = true;
5274 15257 }
5275
5276 31015 static lbm_value quote_it(lbm_value qquoted) {
5277
3/4
✓ Branch 0 taken 29660 times.
✓ Branch 1 taken 1355 times.
✓ Branch 2 taken 29660 times.
✗ Branch 3 not taken.
 60675 if (lbm_is_symbol(qquoted) &&
5278 59320 lbm_is_special(qquoted)) return qquoted;
5279
5280 1355 lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL, ENC_SYM_NIL);
5281 1355 return cons_with_gc(ENC_SYM_QUOTE, val, ENC_SYM_NIL);
5282 }
5283
5284 113993 static bool is_append(lbm_value a) {
5285
1/2
✓ Branch 0 taken 113481 times.
✗ Branch 1 not taken.
 227474 return (lbm_is_cons(a) &&
5286
2/2
✓ Branch 0 taken 113481 times.
✓ Branch 1 taken 512 times.
 227474 lbm_is_symbol(lbm_ref_cell(a)->car) &&
5287
2/2
✓ Branch 0 taken 55981 times.
✓ Branch 1 taken 57500 times.
 113481 (lbm_ref_cell(a)->car == ENC_SYM_APPEND));
5288 }
5289
5290 192073 static lbm_value append(lbm_value front, lbm_value back) {
5291
2/2
✓ Branch 0 taken 103445 times.
✓ Branch 1 taken 88628 times.
 192073 if (lbm_is_symbol_nil(front)) return back;
5292
2/2
✓ Branch 0 taken 29660 times.
✓ Branch 1 taken 58968 times.
 88628 if (lbm_is_symbol_nil(back)) return front;
5293
5294
4/4
✓ Branch 0 taken 31346 times.
✓ Branch 1 taken 27622 times.
✓ Branch 2 taken 1355 times.
✓ Branch 3 taken 29991 times.
 90314 if (lbm_is_quoted_list(front) &&
5295 31346 lbm_is_quoted_list(back)) {
5296 1355 lbm_value f = get_cadr(front);
5297 1355 lbm_value b = get_cadr(back);
5298 1355 return quote_it(lbm_list_append(f, b));
5299 }
5300
5301
4/4
✓ Branch 0 taken 28607 times.
✓ Branch 1 taken 29006 times.
✓ Branch 2 taken 1239 times.
✓ Branch 3 taken 27368 times.
 86220 if (is_append(back) &&
5302
2/2
✓ Branch 0 taken 1233 times.
✓ Branch 1 taken 6 times.
 29846 lbm_is_quoted_list(get_cadr(back)) &&
5303 1239 lbm_is_quoted_list(front)) {
5304 1233 lbm_value ql = get_cadr(back);
5305 1233 lbm_value f = get_cadr(front);
5306 1233 lbm_value b = get_cadr(ql);
5307
5308 1233 lbm_value v = lbm_list_append(f, b);
5309 1233 lbm_set_car(get_cdr(ql), v);
5310 1233 return back;
5311 }
5312
5313
2/2
✓ Branch 0 taken 27374 times.
✓ Branch 1 taken 29006 times.
 56380 if (is_append(back)) {
5314 27374 back = get_cdr(back);
5315 27374 lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL);
5316 27374 return cons_with_gc(ENC_SYM_APPEND, new, ENC_SYM_NIL);
5317 }
5318
5319 lbm_value t0, t1;
5320
5321 29006 t0 = cons_with_gc(back, ENC_SYM_NIL, front);
5322 29006 t1 = cons_with_gc(front, t0, ENC_SYM_NIL);
5323 29006 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 103885 static void cont_qq_expand(eval_context_t *ctx) {
5353 103885 lbm_value qquoted = ctx->K.data[--ctx->K.sp];
5354
5355
2/2
✓ Branch 0 taken 74225 times.
✓ Branch 1 taken 29660 times.
 103885 switch(lbm_type_of(qquoted)) {
5356 74225 case LBM_TYPE_CONS: {
5357 74225 lbm_value car_val = get_car(qquoted);
5358 74225 lbm_value cdr_val = get_cdr(qquoted);
5359
4/4
✓ Branch 0 taken 15291 times.
✓ Branch 1 taken 58934 times.
✓ Branch 2 taken 84 times.
✓ Branch 3 taken 15207 times.
 74225 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5360 car_val == ENC_SYM_COMMA) {
5361 84 ctx->r = append(ctx->r, get_car(cdr_val));
5362 84 ctx->app_cont = true;
5363
4/4
✓ Branch 0 taken 15207 times.
✓ Branch 1 taken 58934 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 15206 times.
 74141 } 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 74140 lbm_value *rptr = stack_reserve(ctx, 6);
5369 74140 rptr[0] = ctx->r;
5370 74140 rptr[1] = QQ_APPEND;
5371 74140 rptr[2] = cdr_val;
5372 74140 rptr[3] = QQ_EXPAND;
5373 74140 rptr[4] = car_val;
5374 74140 rptr[5] = QQ_EXPAND_LIST;
5375 74140 ctx->app_cont = true;
5376 74140 ctx->r = ENC_SYM_NIL;
5377 }
5378
5379 74224 } break;
5380 29660 default: {
5381 29660 lbm_value res = quote_it(qquoted);
5382 29660 ctx->r = append(ctx->r, res);
5383 29660 ctx->app_cont = true;
5384 }
5385 }
5386 103884 }
5387
5388 88628 static void cont_qq_append(eval_context_t *ctx) {
5389 88628 lbm_value head = ctx->K.data[--ctx->K.sp];
5390 88628 ctx->r = append(head, ctx->r);
5391 88628 ctx->app_cont = true;
5392 88628 }
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 88628 static void cont_qq_expand_list(eval_context_t* ctx) {
5412 88628 lbm_value l = ctx->K.data[--ctx->K.sp];
5413
5414 88628 ctx->app_cont = true;
5415
2/2
✓ Branch 0 taken 56496 times.
✓ Branch 1 taken 32132 times.
 88628 switch(lbm_type_of(l)) {
5416 56496 case LBM_TYPE_CONS: {
5417 56496 lbm_value car_val = get_car(l);
5418 56496 lbm_value cdr_val = get_cdr(l);
5419
4/4
✓ Branch 0 taken 56495 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 41569 times.
✓ Branch 3 taken 14926 times.
 56496 if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5420 car_val == ENC_SYM_COMMA) {
5421 41569 lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL);
5422 41569 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL);
5423 41569 ctx->r = append(ctx->r, tmp);
5424 41569 return;
5425
4/4
✓ Branch 0 taken 14926 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 439 times.
✓ Branch 3 taken 14487 times.
 14927 } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
5426 car_val == ENC_SYM_COMMAAT) {
5427 439 lbm_value cadr_val = get_car(cdr_val);
5428 439 ctx->r = cadr_val;
5429 439 return;
5430 } else {
5431 14488 lbm_value *rptr = stack_reserve(ctx, 7);
5432 14488 rptr[0] = QQ_LIST;
5433 14488 rptr[1] = ctx->r;
5434 14488 rptr[2] = QQ_APPEND;
5435 14488 rptr[3] = cdr_val;
5436 14488 rptr[4] = QQ_EXPAND;
5437 14488 rptr[5] = car_val;
5438 14488 rptr[6] = QQ_EXPAND_LIST;
5439 14488 ctx->r = ENC_SYM_NIL;
5440 }
5441
5442 14488 } break;
5443 32132 default: {
5444 32132 lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL, ENC_SYM_NIL);
5445 32132 lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL, ENC_SYM_NIL);
5446 32132 lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE, tl, ENC_SYM_NIL);
5447 32132 ctx->r = append(ctx->r, tmp);
5448 }
5449 }
5450 }
5451
5452 14488 static void cont_qq_list(eval_context_t *ctx) {
5453 14488 lbm_value val = ctx->r;
5454 14488 lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL, ENC_SYM_NIL);
5455 14488 lbm_value tmp = cons_with_gc(ENC_SYM_LIST, apnd_app, ENC_SYM_NIL);
5456 14488 ctx->r = tmp;
5457 14488 ctx->app_cont = true;
5458 14488 }
5459
5460 248 static void cont_kill(eval_context_t *ctx) {
5461 (void) ctx;
5462 248 ok_ctx();
5463 248 }
5464
5465 244559 static void cont_pop_reader_flags(eval_context_t *ctx) {
5466 244559 lbm_value flags = ctx->K.data[--ctx->K.sp];
5467 244559 ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
5468 244559 ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
5469 // r is unchanged.
5470 244559 ctx->app_cont = true;
5471 244559 }
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 25187 static void cont_exception_handler(eval_context_t *ctx) {
5479 25187 lbm_value *sptr = pop_stack_ptr(ctx, 2);
5480 25187 lbm_value retval = sptr[0];
5481 25187 lbm_value flags = sptr[1];
5482 25187 lbm_set_car(get_cdr(retval), ctx->r);
5483 25187 ctx->flags = (uint32_t)flags;
5484 25187 ctx->r = retval;
5485 25187 ctx->app_cont = true;
5486 25187 }
5487
5488 // cont_recv_to:
5489 //
5490 // s[sp-1] = patterns
5491 //
5492 // ctx->r = timeout value
5493 588 static void cont_recv_to(eval_context_t *ctx) {
5494
1/2
✓ Branch 0 taken 588 times.
✗ Branch 1 not taken.
 588 if (lbm_is_number(ctx->r)) {
5495 588 lbm_value *sptr = get_stack_ptr(ctx, 1); // patterns at sptr[0]
5496 588 float timeout_time = lbm_dec_as_float(ctx->r);
5497
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 504 times.
 588 if (timeout_time < 0.0) timeout_time = 0.0; // clamp.
5498
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 420 times.
 588 if (ctx->num_mail > 0) {
5499 lbm_value e;
5500 168 lbm_value new_env = ctx->curr_env;
5501 168 int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
5502
1/2
✓ Branch 0 taken 168 times.
✗ Branch 1 not taken.
 168 if (n >= 0) { // match
5503 168 mailbox_remove_mail(ctx, (lbm_uint)n);
5504 168 ctx->curr_env = new_env;
5505 168 ctx->curr_exp = e;
5506 168 lbm_stack_drop(&ctx->K, 1);
5507 168 return;
5508 }
5509 }
5510 // If no mail or no match, go to sleep
5511 420 lbm_uint *rptr = stack_reserve(ctx,2);
5512 420 rptr[0] = ctx->r;
5513 420 rptr[1] = RECV_TO_RETRY;
5514 420 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 420 static void cont_recv_to_retry(eval_context_t *ctx) {
5527 420 lbm_value *sptr = get_stack_ptr(ctx, 2); //sptr[0] = patterns, sptr[1] = timeout
5528
5529
1/2
✓ Branch 0 taken 420 times.
✗ Branch 1 not taken.
 420 if (ctx->num_mail > 0) {
5530 lbm_value e;
5531 420 lbm_value new_env = ctx->curr_env;
5532 420 int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
5533
2/2
✓ Branch 0 taken 168 times.
✓ Branch 1 taken 252 times.
 420 if (n >= 0) { // match
5534 168 mailbox_remove_mail(ctx, (lbm_uint)n);
5535 168 ctx->curr_env = new_env;
5536 168 ctx->curr_exp = e;
5537 168 lbm_stack_drop(&ctx->K, 2);
5538 168 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 252 times.
✗ Branch 1 not taken.
 252 if (ctx->r == ENC_SYM_TIMEOUT) {
5546 252 lbm_stack_drop(&ctx->K, 2);
5547 252 ctx->app_cont = true;
5548 252 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 6091378442 static void evaluation_step(void){
5653 6091378442 eval_context_t *ctx = ctx_running;
5654
5655
2/2
✓ Branch 0 taken 2918589478 times.
✓ Branch 1 taken 3172788964 times.
 6091378442 if (ctx->app_cont) {
5656 2918589478 lbm_value k = ctx->K.data[--ctx->K.sp];
5657 2918589478 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 2918589478 lbm_uint decoded_k = DEC_CONTINUATION(k);
5663 2918589478 continuations[decoded_k](ctx);
5664 2918564782 return;
5665 }
5666
5667
2/2
✓ Branch 0 taken 1351469503 times.
✓ Branch 1 taken 1821319461 times.
 3172788964 if (lbm_is_symbol(ctx->curr_exp)) {
5668 1351469503 eval_symbol(ctx);
5669 1351469227 return;
5670 }
5671
2/2
✓ Branch 0 taken 1071772543 times.
✓ Branch 1 taken 749546918 times.
 1821319461 if (lbm_is_cons(ctx->curr_exp)) {
5672 1071772543 lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
5673 1071772543 lbm_value h = cell->car;
5674
4/4
✓ Branch 0 taken 1071762746 times.
✓ Branch 1 taken 9797 times.
✓ Branch 2 taken 267253806 times.
✓ Branch 3 taken 804508940 times.
 1071772543 if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK) == ENC_SPECIAL_FORMS_BIT)) {
5675 267253806 lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK;
5676 267253806 evaluators[eval_index](ctx);
5677 267253533 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 804518737 lbm_value *reserved = stack_reserve(ctx, 3);
5684 804518734 reserved[0] = ctx->curr_env; // INFER: stack_reserve aborts context if error.
5685 804518734 reserved[1] = cell->cdr;
5686 804518734 reserved[2] = APPLICATION_START;
5687 804518734 ctx->curr_exp = h; // evaluate the function
5688 804518734 return;
5689 }
5690
5691 749546918 eval_selfevaluating(ctx);
5692 749546918 return;
5693 }
5694
5695 // Placed down here since it depends on a lot of things.
5696 // (apply fun arg-list)
5697 16803119 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 16803117 times.
✓ Branch 2 taken 1 times.
✓ Branch 3 taken 1 times.
 16803119 if (nargs == 2 || lbm_is_list(args[1])) {
5699 16803118 lbm_value fun = args[0];
5700 16803118 lbm_value arg_list = args[1];
5701
5702 16803118 lbm_stack_drop(&ctx->K, nargs+1);
5703
5704
2/2
✓ Branch 0 taken 1681769 times.
✓ Branch 1 taken 15121349 times.
 16803118 if (lbm_is_symbol(fun)) {
5705
2/2
✓ Branch 0 taken 1596 times.
✓ Branch 1 taken 1680173 times.
 1681769 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 1596 lbm_value fun_and_args = cons_with_gc(fun, arg_list, ENC_SYM_NIL);
5716 1596 ctx->curr_exp = fun_and_args;
5717 1596 lbm_uint eval_index = lbm_dec_sym(fun) & SPECIAL_FORMS_INDEX_MASK;
5718 1596 evaluators[eval_index](ctx);
5719 1596 return;
5720 } else { // lbm_is_symbol(fun)
5721 1680173 stack_reserve(ctx, 1)[0] = fun;
5722 1680173 unsigned int arg_count = 0;
5723
2/2
✓ Branch 0 taken 16800527 times.
✓ Branch 1 taken 1680173 times.
 18480700 for (lbm_value current = arg_list; lbm_is_cons(current); current = lbm_ref_cell(current)->cdr) {
5724 16800527 stack_reserve(ctx, 1)[0] = lbm_ref_cell(current)->car;
5725 16800527 arg_count++;
5726 }
5727 1680173 lbm_value *fun_and_args = get_stack_ptr(ctx, arg_count + 1);
5728 1680173 application(ctx, fun_and_args, arg_count);
5729 1680173 return;
5730 }
5731
2/2
✓ Branch 0 taken 15121346 times.
✓ Branch 1 taken 3 times.
 15121349 } else if (lbm_is_cons(fun)) {
5732 15121346 lbm_cons_t *fun_cell = lbm_ref_cell(fun);
5733
5/5
✓ Branch 0 taken 15120505 times.
✓ Branch 1 taken 252 times.
✓ Branch 2 taken 252 times.
✓ Branch 3 taken 336 times.
✓ Branch 4 taken 1 times.
 15121346 switch (fun_cell->car) {
5734 15120505 case ENC_SYM_CLOSURE: {
5735 lbm_value closure[3];
5736 15120505 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 15120505 ctx->curr_exp = fun;
5741
5742 15120505 lbm_value env = closure[CLO_ENV];
5743
5744 15120505 lbm_value current_params = closure[CLO_PARAMS];
5745 15120505 lbm_value current_args = arg_list;
5746
5747 142800421 while (true) {
5748 157920926 bool more_params = lbm_is_cons(current_params);
5749 157920926 bool more_args = lbm_is_cons(current_args);
5750
4/4
✓ Branch 0 taken 142800422 times.
✓ Branch 1 taken 15120504 times.
✓ Branch 2 taken 142800421 times.
✓ Branch 3 taken 1 times.
 157920926 if (more_params && more_args) {
5751 142800421 lbm_cons_t *p_cell = lbm_ref_cell(current_params);
5752 142800421 lbm_cons_t *a_cell = lbm_ref_cell(current_args);
5753 142800421 lbm_value car_params = p_cell->car;
5754 142800421 lbm_value car_args = a_cell->car;
5755 142800421 lbm_value cdr_params = p_cell->cdr;
5756 142800421 lbm_value cdr_args = a_cell->cdr;
5757
5758 // More parameters to bind
5759 142800421 env = allocate_binding(
5760 car_params,
5761 car_args,
5762 env
5763 );
5764
5765 142800421 current_params = cdr_params;
5766 142800421 current_args = cdr_args;
5767
4/4
✓ Branch 0 taken 15120504 times.
✓ Branch 1 taken 1 times.
✓ Branch 2 taken 840252 times.
✓ Branch 3 taken 14280252 times.
 15120505 } else if (!more_params && more_args) {
5768 // More arguments but all parameters have been bound
5769 840252 env = allocate_binding(ENC_SYM_REST_ARGS, current_args, env);
5770 840252 break;
5771
3/4
✓ Branch 0 taken 14280252 times.
✓ Branch 1 taken 1 times.
✗ Branch 2 not taken.
✓ Branch 3 taken 14280252 times.
 14280253 } 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 15120504 ctx->curr_env = env;
5782 15120504 ctx->curr_exp = closure[CLO_BODY];
5783 15120504 return;
5784 } break;
5785 252 case ENC_SYM_CONT:{
5786 252 ctx->r = fun;
5787 252 ctx->r = setup_cont(ctx, arg_list);
5788 252 ctx->app_cont = true;
5789 252 return;
5790 } break;
5791 252 case ENC_SYM_CONT_SP: {
5792 252 ctx->r = fun;
5793 252 ctx->r = setup_cont_sp(ctx, arg_list);
5794 252 ctx->app_cont = true;
5795 252 return;
5796 } break;
5797 336 case ENC_SYM_MACRO:{
5798 336 ctx->r = fun;
5799 336 setup_macro(ctx, arg_list, ctx->curr_env);
5800 336 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 8 void lbm_reset_eval(void) {
5820 8 eval_cps_next_state_arg = 0;
5821 8 eval_cps_next_state = EVAL_CPS_STATE_RESET;
5822
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5823 8 }
5824
5825 66095 void lbm_pause_eval(void ) {
5826 66095 eval_cps_next_state_arg = 0;
5827 66095 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
5828
1/2
✓ Branch 0 taken 66095 times.
✗ Branch 1 not taken.
 66095 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5829 66095 }
5830
5831 66467 void lbm_pause_eval_with_gc(uint32_t num_free) {
5832 66467 eval_cps_next_state_arg = num_free;
5833 66467 eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
5834
1/2
✓ Branch 0 taken 66467 times.
✗ Branch 1 not taken.
 66467 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5835 66467 }
5836
5837 66482 void lbm_continue_eval(void) {
5838 66482 eval_cps_next_state = EVAL_CPS_STATE_RUNNING;
5839
1/2
✓ Branch 0 taken 66482 times.
✗ Branch 1 not taken.
 66482 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5840 66482 }
5841
5842 450 void lbm_kill_eval(void) {
5843 450 eval_cps_next_state = EVAL_CPS_STATE_KILL;
5844
1/2
✓ Branch 0 taken 450 times.
✗ Branch 1 not taken.
 450 if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
5845 450 }
5846
5847 442076 uint32_t lbm_get_eval_state(void) {
5848 442076 return eval_cps_run_state;
5849 }
5850
5851 // Only unblocks threads that are unblockable.
5852 // A sleeping thread is not unblockable.
5853 252 static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
5854 252 eval_context_t *found = NULL;
5855 252 lbm_mutex_lock(&qmutex);
5856
5857 252 found = lookup_ctx_nm(&blocked, cid);
5858
2/4
✓ Branch 0 taken 252 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 252 times.
✗ Branch 3 not taken.
 252 if (found && LBM_IS_STATE_UNBLOCKABLE(found->state)){
5859 252 drop_ctx_nm(&blocked,found);
5860
2/2
✓ Branch 0 taken 84 times.
✓ Branch 1 taken 168 times.
 252 if (lbm_is_error(v)) {
5861 84 get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
5862 84 found->app_cont = true;
5863 }
5864 252 found->r = v;
5865 252 found->state = LBM_THREAD_STATE_READY;
5866 252 enqueue_ctx_nm(&queue,found);
5867 }
5868 252 lbm_mutex_unlock(&qmutex);
5869 252 }
5870
5871 5 static void handle_event_define(lbm_value key, lbm_value val) {
5872 5 lbm_uint dec_key = lbm_dec_sym(key);
5873 5 lbm_uint ix_key = dec_key & GLOBAL_ENV_MASK;
5874 5 lbm_value *global_env = lbm_get_global_env();
5875 5 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
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 5 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 5 WITH_GC(new_env, lbm_env_set(orig_env,key,val));
5879
5880 5 global_env[ix_key] = new_env;
5881 5 }
5882
5883 10280 static lbm_value get_event_value(lbm_event_t *e) {
5884 lbm_value v;
5885
2/2
✓ Branch 0 taken 10248 times.
✓ Branch 1 taken 32 times.
 10280 if (e->buf_len > 0) {
5886 lbm_flat_value_t fv;
5887 10248 fv.buf = (uint8_t*)e->buf_ptr;
5888 10248 fv.buf_size = e->buf_len;
5889 10248 fv.buf_pos = 0;
5890 10248 lbm_unflatten_value(&fv, &v);
5891 // Free the flat value buffer. GC is unaware of its existence.
5892 10248 lbm_free(fv.buf);
5893 } else {
5894 32 v = (lbm_value)e->buf_ptr;
5895 }
5896 10280 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 616452874 static void process_events(void) {
5904
5905
2/2
✓ Branch 0 taken 1937848 times.
✓ Branch 1 taken 614515026 times.
 616452874 if (!lbm_events) {
5906 1937848 return;
5907 }
5908
5909 lbm_event_t e;
5910
2/2
✓ Branch 0 taken 10280 times.
✓ Branch 1 taken 614515026 times.
 614525306 while (lbm_event_pop(&e)) {
5911 10280 lbm_value event_val = get_event_value(&e);
5912
3/4
✓ Branch 0 taken 252 times.
✓ Branch 1 taken 5 times.
✓ Branch 2 taken 10023 times.
✗ Branch 3 not taken.
 10280 switch(e.type) {
5913 252 case LBM_EVENT_UNBLOCK_CTX:
5914 252 handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
5915 252 break;
5916 5 case LBM_EVENT_DEFINE:
5917 5 handle_event_define((lbm_value)e.parameter, event_val);
5918 5 break;
5919 10023 case LBM_EVENT_FOR_HANDLER:
5920
1/2
✓ Branch 0 taken 10023 times.
✗ Branch 1 not taken.
 10023 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 10023 lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
5925 }
5926 10023 break;
5927 }
5928 }
5929 }
5930
5931 66566 void lbm_add_eval_symbols(void) {
5932 66566 lbm_uint x = 0;
5933 66566 lbm_uint y = 0;
5934 66566 lbm_add_symbol("x", &x);
5935 66566 lbm_add_symbol("y", &y);
5936 66566 symbol_x = lbm_enc_sym(x);
5937 66566 symbol_y = lbm_enc_sym(y);
5938 66566 }
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 66566 void lbm_run_eval(void){
5945
2/2
✓ Branch 0 taken 1 times.
✓ Branch 1 taken 66566 times.
 66566 if (setjmp(critical_error_jmp_buf) > 0) {
5946 1 lbm_printf_callback("GC stack overflow!\n");
5947 1 critical_error_callback();
5948 // terminate evaluation thread.
5949 1 return;
5950 }
5951
5952 66566 setjmp(error_jmp_buf);
5953
5954
2/2
✓ Branch 0 taken 303635 times.
✓ Branch 1 taken 23011 times.
 265754 while (eval_running) {
5955
4/4
✓ Branch 0 taken 104049 times.
✓ Branch 1 taken 199586 times.
✓ Branch 2 taken 23101 times.
✓ Branch 3 taken 90942 times.
 303635 if (eval_cps_state_changed || eval_cps_run_state == EVAL_CPS_STATE_PAUSED) {
5956 212693 eval_cps_state_changed = false;
5957
4/4
✓ Branch 0 taken 8 times.
✓ Branch 1 taken 145753 times.
✓ Branch 2 taken 450 times.
✓ Branch 3 taken 66482 times.
 212693 switch (eval_cps_next_state) {
5958 8 case EVAL_CPS_STATE_RESET:
5959
1/2
✓ Branch 0 taken 8 times.
✗ Branch 1 not taken.
 8 if (eval_cps_run_state != EVAL_CPS_STATE_RESET) {
5960 8 is_atomic = false;
5961 8 blocked.first = NULL;
5962 8 blocked.last = NULL;
5963 8 queue.first = NULL;
5964 8 queue.last = NULL;
5965 8 ctx_running = NULL;
5966 #ifdef LBM_USE_TIME_QUOTA
5967 ✗ eval_time_quota = 0; // maybe timestamp here ?
5968 #else
5969 8 eval_steps_quota = eval_steps_refill;
5970 #endif
5971 8 eval_cps_run_state = EVAL_CPS_STATE_RESET;
5972
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 8 times.
 8 if (blocking_extension) {
5973 ✗ blocking_extension = false;
5974 ✗ lbm_mutex_unlock(&blocking_extension_mutex);
5975 }
5976 }
5977 8 usleep_callback(EVAL_CPS_MIN_SLEEP);
5978 8 continue;
5979 145753 case EVAL_CPS_STATE_PAUSED:
5980
2/2
✓ Branch 0 taken 132561 times.
✓ Branch 1 taken 55265 times.
 145753 if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED) {
5981
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 132561 times.
 132561 if (lbm_heap_num_free() < eval_cps_next_state_arg) {
5982 ✗ gc();
5983 }
5984 132561 eval_cps_next_state_arg = 0;
5985 132561 eval_cps_run_state = EVAL_CPS_STATE_PAUSED;
5986 }
5987 145753 usleep_callback(EVAL_CPS_MIN_SLEEP);
5988 41347 continue;
5989 450 case EVAL_CPS_STATE_KILL:
5990 450 eval_cps_run_state = EVAL_CPS_STATE_DEAD;
5991 450 eval_running = false;
5992 450 continue;
5993 66482 default: // running state
5994 66482 eval_cps_run_state = eval_cps_next_state;
5995 66482 break;
5996 }
5997 }
5998 19622603 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 19623735 uint32_t unsigned_difference = lbm_timestamp() - eval_current_quota;
6006 19623735 bool is_negative = unsigned_difference & (1u << 31);
6007
4/4
✓ Branch 0 taken 19616572 times.
✓ Branch 1 taken 7163 times.
✓ Branch 2 taken 19609036 times.
✓ Branch 3 taken 7536 times.
 19623735 if (is_negative && ctx_running) {
6008 19609036 evaluation_step();
6009 } else {
6010
2/2
✓ Branch 0 taken 449 times.
✓ Branch 1 taken 14250 times.
 14699 if (eval_cps_state_changed) break;
6011
1/2
✓ Branch 0 taken 14250 times.
✗ Branch 1 not taken.
 14250 if (!is_atomic) {
6012
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 14250 times.
 14250 if (gc_requested) {
6013 ✗ gc();
6014 }
6015 14250 process_events();
6016 14250 lbm_mutex_lock(&qmutex);
6017
2/2
✓ Branch 0 taken 7150 times.
✓ Branch 1 taken 7100 times.
 14250 if (ctx_running) {
6018 7150 enqueue_ctx_nm(&queue, ctx_running);
6019 7150 ctx_running = NULL;
6020 }
6021 14250 wake_up_ctxs_nm();
6022 14250 ctx_running = dequeue_ctx_nm(&queue);
6023 14250 lbm_mutex_unlock(&qmutex);
6024
2/2
✓ Branch 0 taken 6473 times.
✓ Branch 1 taken 7777 times.
 14250 if (!ctx_running) {
6025 6473 lbm_system_sleeping = true;
6026 //Fixed sleep interval to poll events regularly.
6027 6473 usleep_callback(EVAL_CPS_MIN_SLEEP);
6028 6473 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 14250 eval_current_quota = lbm_timestamp() + eval_time_refill;
6041 }
6042 #else
6043
4/4
✓ Branch 0 taken 6081205615 times.
✓ Branch 1 taken 607136201 times.
✓ Branch 2 taken 6071769402 times.
✓ Branch 3 taken 9436213 times.
 6688341816 if (eval_steps_quota && ctx_running) {
6044 6071769402 eval_steps_quota--;
6045 6071769402 evaluation_step();
6046 } else {
6047
2/2
✓ Branch 0 taken 131686 times.
✓ Branch 1 taken 616440728 times.
 616572414 if (eval_cps_state_changed) break;
6048 616440728 eval_steps_quota = eval_steps_refill;
6049
2/2
✓ Branch 0 taken 616438624 times.
✓ Branch 1 taken 2104 times.
 616440728 if (!is_atomic) {
6050
2/2
✓ Branch 0 taken 359 times.
✓ Branch 1 taken 616438265 times.
 616438624 if (gc_requested) {
6051 359 gc();
6052 }
6053 616438623 process_events();
6054 616438623 lbm_mutex_lock(&qmutex);
6055
2/2
✓ Branch 0 taken 607031515 times.
✓ Branch 1 taken 9407108 times.
 616438623 if (ctx_running) {
6056 607031515 enqueue_ctx_nm(&queue, ctx_running);
6057 607031515 ctx_running = NULL;
6058 }
6059 616438623 wake_up_ctxs_nm();
6060 616438623 ctx_running = dequeue_ctx_nm(&queue);
6061 616438623 lbm_mutex_unlock(&qmutex);
6062
2/2
✓ Branch 0 taken 9215186 times.
✓ Branch 1 taken 607223437 times.
 616438623 if (!ctx_running) {
6063 9215186 lbm_system_sleeping = true;
6064 //Fixed sleep interval to poll events regularly.
6065 9215186 usleep_callback(EVAL_CPS_MIN_SLEEP);
6066 9215147 lbm_system_sleeping = false;
6067 }
6068 }
6069 }
6070 #endif
6071 }
6072 }
6073 }
6074
6075 66566 bool lbm_eval_init(void) {
6076
2/2
✓ Branch 0 taken 66477 times.
✓ Branch 1 taken 89 times.
 66566 if (!qmutex_initialized) {
6077 66477 lbm_mutex_init(&qmutex);
6078 66477 qmutex_initialized = true;
6079 }
6080
2/2
✓ Branch 0 taken 66477 times.
✓ Branch 1 taken 89 times.
 66566 if (!lbm_events_mutex_initialized) {
6081 66477 lbm_mutex_init(&lbm_events_mutex);
6082 66477 lbm_events_mutex_initialized = true;
6083 }
6084
2/2
✓ Branch 0 taken 66477 times.
✓ Branch 1 taken 89 times.
 66566 if (!blocking_extension_mutex_initialized) {
6085 66477 lbm_mutex_init(&blocking_extension_mutex);
6086 66477 blocking_extension_mutex_initialized = true;
6087 }
6088
6089 66566 lbm_mutex_lock(&qmutex);
6090 66566 lbm_mutex_lock(&lbm_events_mutex);
6091
6092 66566 blocked.first = NULL;
6093 66566 blocked.last = NULL;
6094 66566 queue.first = NULL;
6095 66566 queue.last = NULL;
6096 66566 ctx_running = NULL;
6097
6098 66566 eval_cps_run_state = EVAL_CPS_STATE_RUNNING;
6099
6100 66566 lbm_mutex_unlock(&lbm_events_mutex);
6101 66566 lbm_mutex_unlock(&qmutex);
6102
6103
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 66566 times.
 66566 if (!lbm_init_env()) return false;
6104 66566 eval_running = true;
6105 66566 return true;
6106 }
6107
6108 66476 bool lbm_eval_init_events(unsigned int num_events) {
6109
6110 66476 lbm_mutex_lock(&lbm_events_mutex);
6111 66476 lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
6112 66476 bool r = false;
6113
1/2
✓ Branch 0 taken 66476 times.
✗ Branch 1 not taken.
 66476 if (lbm_events) {
6114 66476 lbm_events_max = num_events;
6115 66476 lbm_events_head = 0;
6116 66476 lbm_events_tail = 0;
6117 66476 lbm_events_full = false;
6118 66476 lbm_event_handler_pid = -1;
6119 66476 r = true;
6120 }
6121 66476 lbm_mutex_unlock(&lbm_events_mutex);
6122 66476 return r;
6123 }
6124