Bug Summary

File:eval_cps.c
Warning:line 3714, column 25
Access to field 'data' results in a dereference of a null pointer (loaded from variable 'arr')

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple i386-pc-linux-gnu -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name eval_cps.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model pic -pic-level 2 -pic-is-pie -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu i686 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/home/joels/Current/lispbm -resource-dir /usr/lib/llvm-14/lib/clang/14.0.0 -I ./include -I ./include/extensions -I platform/linux/include -D _PRELUDE -internal-isystem /usr/lib/llvm-14/lib/clang/14.0.0/include -internal-isystem /usr/local/include -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/11/../../../../x86_64-linux-gnu/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -std=c99 -fdebug-compilation-dir=/home/joels/Current/lispbm -ferror-limit 19 -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=html -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /home/joels/Current/lispbm/test_reports/version_0.24.0/scan-build/2024-04-28-134646-49849-1 -x c src/eval_cps.c

src/eval_cps.c

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

./include/heap.h

1
2/*
3 Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se
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/** \file heap.h */
19
20#ifndef HEAP_H_
21#define HEAP_H_
22
23#include <string.h>
24#include <stdarg.h>
25
26#include "lbm_types.h"
27#include "symrepr.h"
28#include "stack.h"
29#include "lbm_memory.h"
30#include "lbm_defines.h"
31#include "lbm_channel.h"
32
33#ifdef __cplusplus
34extern "C" {
35#endif
36
37/*
38Planning for a more space efficient heap representation.
39TODO: Need to find a good reference to read up on this.
40 - List based heap
41 - Easy to implement and somewhat efficient
42
430000 0000 Size Free bits
44003F FFFF 4MB 10
45007F FFFF 8MB 9
4600FF FFFF 16MB 8
4701FF FFFF 32MB 7
4803FF FFFF 64MB 6 * Kind of heap size I am looking for
4907FF FFFF 128MB 5
500FFF FFFF 256MB 4
511FFF FFFF 512MB 3
52
53
54--- May 9 2021 ---
55Actually now I am much more interested in way smaller memories ;)
56
570000 0000 Size Free bits
580000 0FFF 4KB 20 |
590000 1FFF 8KB 19 |
600000 3FFF 16KB 18 |
610000 7FFF 32KB 17 |
620000 FFFF 64KB 16 |
630001 FFFF 128KB 15 |
640003 FFFF 256KB 14 | - This range is very interesting.
650007 FFFF 512KB 13
66000F FFFF 1MB 12
67001F FFFF 2MB 11
68003F FFFF 4MB 10
69007F FFFF 8MB 9
7000FF FFFF 16MB 8
7101FF FFFF 32MB 7
7203FF FFFF 64MB 6
7307FF FFFF 128MB 5
740FFF FFFF 256MB 4
751FFF FFFF 512MB 3
76
77Those are the kind of platforms that are fun... so a bunch of
78wasted bits in heap pointers if we run on small MCUs.
79
80-----------------
81
82it is also the case that not all addresses will be used if all "cells" are
83of the same size, 8 bytes...
84
85value 0: 0000 0000
86value 1: 0000 0008
87value 3: 0000 0010
88value 4: 0000 0018
89
90Means bits 0,1,2 will always be empty in a valid address.
91
92Cons cells also need to be have room for 2 pointers. So each ted cell from
93memory should be 8bytes.
94
95Things that needs to be represented within these bits:
96
97 - GC MARK one per cell
98 - TYPE: type of CAR and type of cons
99
100Types I would want:
101 - Full 32bit integer. Does not leave room for identification of type
102 - Float values. Same problem
103
104
105Free bits in pointers 64MB heap:
10631 30 29 28 27 26 2 1 0
1070 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0
108
109
110Information needed for each cell:
111 Meaning | bits total | bits per car | bits per cdr
112 GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted)
113 Type | 2x | x | x
114 Ptr/!ptr | 2 | 1 | 1
115
116
117Types (unboxed):
118 - Symbols
119 - 28bit integer ( will need signed shift right functionality )
120 - 28bit unsigned integer
121 - Character
122
123If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate.
1242 + 1 + 1 = 4 => 28bits for data.
125
126bit 0: ptr/!ptr
127bit 1: gc
128bit 2-3: type (if not ptr)
129bit 3 - 24 ptr (if ptr)
130bit 4 - 31 value (if value)
131
132An unboxed value can occupy a car or cdr field in a cons cell.
133
134types (boxed) extra information in pointer to cell can contain information
135 - 32 bit integer
136 - 32 bit unsigned integer
137 - 32 bit float
138
139boxed representation:
140 [ptr| cdr]
141 |
142 [Value | Aux + GC_MARK]
143
144Kinds of pointers:
145 - Pointer to cons cell.
146 - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed )
147 - integer
148 - unsigned integer
149 - symbol
150 - float
151 - Pointer to boxed value.
152 - 32 bit integer
153 - 32 bit unsigned integer
154 - 32 bit float
155 - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?)
156 - vector of int
157 - vector of uint
158 - vector of float
159 - vector of double
160 - String
161
16213 pointer"types" -> needs 4 bits
163for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap
164is also possible
165
166 a pointer to some off heap vector/string could be represented by
167
168 [ptr | cdr]
169 |
170 [full pointer | Aux + GC_MARK]
171 |
172 [VECTOR]
173
174Aux bits could be used for storing vector size. Up to 30bits should be available there
175>> This is problematic. Now the information that something is a vector is split up
176>> between 2 cons cells. This means GC needs both of these intact to be able to make
177>> proper decision.
178>> Will try to resolve this by adding some special symbols. But these must be symbols
179>> that cannot occur normally in programs. Then an array could be:
180
181 [Full pointer | ARRAY_SYM + GC_MARK]
182 |
183 [VECTOR]
184
185>> Boxed values same treatment as above.
186>> TODO: Could this be simpler?
187
188[ VALUE | TYPE_SYM + GC_MARK]
189
190
1910000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1921111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
193 */
194
195typedef enum {
196 LBM_FLASH_WRITE_OK,
197 LBM_FLASH_FULL,
198 LBM_FLASH_WRITE_ERROR
199} lbm_flash_status;
200
201/** Struct representing a heap cons-cell.
202 *
203 */
204typedef struct {
205 lbm_value car;
206 lbm_value cdr;
207} lbm_cons_t;
208
209/**
210 * Heap state
211 */
212typedef struct {
213 lbm_cons_t *heap;
214 lbm_value freelist; // list of free cons cells.
215 lbm_stack_t gc_stack;
216
217 lbm_uint heap_size; // In number of cells.
218 lbm_uint heap_bytes; // In bytes.
219
220 lbm_uint num_alloc; // Number of cells allocated.
221 lbm_uint num_alloc_arrays; // Number of arrays allocated.
222
223 lbm_uint gc_num; // Number of times gc has been performed.
224 lbm_uint gc_marked; // Number of cells marked by mark phase.
225 lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
226 lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
227 lbm_uint gc_least_free; // The smallest length of the freelist.
228 lbm_uint gc_last_free; // Number of elements on the freelist
229 // after most recent GC.
230} lbm_heap_state_t;
231
232extern lbm_heap_state_t lbm_heap_state;
233
234typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w);
235
236typedef struct {
237 lbm_uint *heap;
238 lbm_uint next; // next free index.
239 lbm_uint size; // in lbm_uint words. (cons-cells = words / 2)
240} lbm_const_heap_t;
241
242/**
243 * The header portion of an array stored in array and symbol memory.
244 * An array is always a byte array. use the array-extensions for
245 * storing and reading larger values from arrays.
246 */
247typedef struct {
248 lbm_uint size; /// Number of elements
249 lbm_uint *data; /// pointer to lbm_memory array or C array.
250} lbm_array_header_t;
251
252/** Lock GC mutex
253 * Locks a mutex during GC marking when using the pointer reversal algorithm.
254 * Does nothing when using stack based GC mark.
255 */
256void lbm_gc_lock(void);
257/* Unlock GC mutex
258 */
259void lbm_gc_unlock(void);
260
261/** Initialize heap storage.
262 * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4.
263 * \param num_cells Number of lbm_cons_t elements in the array.
264 * \param gc_stack_size Size of the gc_stack in number of words.
265 * \return 1 on success or 0 for failure.
266 */
267int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
268 lbm_uint gc_stack_size);
269
270/** Add GC time statistics to heap_stats
271 *
272 * \param dur Duration as reported by the timestamp callback.
273 */
274void lbm_heap_new_gc_time(lbm_uint dur);
275/** Add a new free_list length to the heap_stats.
276 * Calculates a new freelist length and updates
277 * the GC statistics.
278 */
279void lbm_heap_new_freelist_length(void);
280/** Check how many lbm_cons_t cells are on the free-list
281 *
282 * \return Number of free lbm_cons_t cells.
283 */
284lbm_uint lbm_heap_num_free(void);
285/** Check how many lbm_cons_t cells are allocated.
286 *
287 * \return Number of lbm_cons_t cells that are currently allocated.
288 */
289lbm_uint lbm_heap_num_allocated(void);
290/** Size of the heap in number of lbm_cons_t cells.
291 *
292 * \return Size of the heap in number of lbm_cons_t cells.
293 */
294lbm_uint lbm_heap_size(void);
295/** Size of the heap in bytes.
296 *
297 * \return Size of heap in bytes.
298 */
299lbm_uint lbm_heap_size_bytes(void);
300/** Allocate an lbm_cons_t cell from the heap.
301 *
302 * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
303 * \param car Value to write into car position of allocated cell.
304 * \param cdr Value to write into cdr position of allocated cell.
305 * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full.
306 */
307lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
308/** Allocate a list of n heap-cells.
309 * \param n The number of heap-cells to allocate.
310 * \return A list of heap-cells of Memory error if unable to allocate.
311 */
312lbm_value lbm_heap_allocate_list(lbm_uint n);
313/** Allocate a list of n heap-cells and initialize the values.
314 * \pram ls The result list is passed through this ptr.
315 * \param n The length of list to allocate.
316 * \param valist The values in a va_list to initialize the list with.
317 * \return True of False depending on success of allocation.
318 */
319lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist);
320/** Allocate a list of n heap-cells and initialize the values.
321 * \param n The length of list to allocate.
322 * \param ... The values to initialize the list with.
323 * \return allocated list or error symbol.
324 */
325lbm_value lbm_heap_allocate_list_init(unsigned int n, ...);
326/** Decode an lbm_value representing a string into a C string
327 *
328 * \param val Value
329 * \return allocated list or error symbol
330 */
331char *lbm_dec_str(lbm_value val);
332/** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer.
333 *
334 * \param val Value
335 * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel.
336 */
337lbm_char_channel_t *lbm_dec_channel(lbm_value val);
338/** Decode an lbm_value representing a custom type into a lbm_uint value.
339 *
340 * \param val Value.
341 * \return The custom type payload.
342 */
343lbm_uint lbm_dec_custom(lbm_value val);
344/** Decode a numerical value as if it is char
345 *
346 * \param val Value to decode
347 * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
348 */
349uint8_t lbm_dec_as_char(lbm_value a);
350/** Decode a numerical value as if it is unsigned
351 *
352 * \param val Value to decode
353 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
354 */
355uint32_t lbm_dec_as_u32(lbm_value val);
356/** Decode a numerical value as a signed integer.
357 *
358 * \param val Value to decode
359 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
360 */
361int32_t lbm_dec_as_i32(lbm_value val);
362/** Decode a numerical value as a float.
363 *
364 * \param val Value to decode.
365 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
366 */
367float lbm_dec_as_float(lbm_value val);
368/** Decode a numerical value as if it is a 64bit unsigned
369 *
370 * \param val Value to decode
371 * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
372 */
373uint64_t lbm_dec_as_u64(lbm_value val);
374/** Decode a numerical value as a 64bit signed integer.
375 *
376 * \param val Value to decode
377 * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
378 */
379int64_t lbm_dec_as_i64(lbm_value val);
380/** Decode a numerical value as a float.
381 *
382 * \param val Value to decode.
383 * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
384 */
385double lbm_dec_as_double(lbm_value val);
386
387lbm_uint lbm_dec_raw(lbm_value v);
388/** Allocates an lbm_cons_t cell from the heap and populates it.
389 *
390 * \param car The value to put in the car field of the allocated lbm_cons_t.
391 * \param cdr The value to put in the cdr field of the allocated lbm_cons_t.
392 * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full.
393 */
394lbm_value lbm_cons(lbm_value car, lbm_value cdr);
395
396/** Accesses the car field of an lbm_cons_t.
397 *
398 * \param cons Value
399 * \return The car field of the lbm_cons_t if cons is a reference to a heap cell.
400 * If cons is nil, the return value is nil. If the value
401 * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
402 */
403lbm_value lbm_car(lbm_value cons);
404/** Accesses the car field the car field of an lbm_cons_t.
405 *
406 * \param cons Value
407 * \return The car of car field or nil.
408 */
409lbm_value lbm_caar(lbm_value c);
410/** Accesses the car of the cdr of an cons cell
411 *
412 * \param c Value
413 * \return the cdr field or type error.
414 */
415lbm_value lbm_cadr(lbm_value c);
416/** Accesses the cdr field of an lbm_cons_t.
417 *
418 * \param cons Value
419 * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell.
420 * If cons is nil, the return value is nil. If the value
421 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
422 */
423lbm_value lbm_cdr(lbm_value cons);
424/** Accesses the cdr of an cdr field of an lbm_cons_t.
425 *
426 * \param cons Value
427 * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell.
428 * If cons is nil, the return value is nil. If the value
429 * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error.
430 */
431lbm_value lbm_cddr(lbm_value c);
432/** Update the value stored in the car field of a heap cell.
433 *
434 * \param c Value referring to a heap cell.
435 * \param v Value to replace the car field with.
436 * \return 1 on success and 0 if the c value does not refer to a heap cell.
437 */
438int lbm_set_car(lbm_value c, lbm_value v);
439/** Update the value stored in the cdr field of a heap cell.
440 *
441 * \param c Value referring to a heap cell.
442 * \param v Value to replace the cdr field with.
443 * \return 1 on success and 0 if the c value does not refer to a heap cell.
444 */
445int lbm_set_cdr(lbm_value c, lbm_value v);
446/** Update the value stored in the car and cdr fields of a heap cell.
447 *
448 * \param c Value referring to a heap cell.
449 * \param car_val Value to replace the car field with.
450 * \param cdr_val Value to replace the cdr field with.
451 * \return 1 on success and 0 if the c value does not refer to a heap cell.
452 */
453int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
454// List functions
455/** Calculate the length of a proper list
456 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
457 * may lead to the function not terminating.
458 *
459 * \param c A list
460 * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
461 */
462lbm_uint lbm_list_length(lbm_value c);
463
464/** Calculate the length of a proper list and evaluate a predicate for each element.
465 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
466 * may lead to the function not terminating.
467 *
468 * \param c A list
469 * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
470 * \param pred Predicate to evaluate for each element of the list.
471 */
472unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value));
473/** Reverse a proper list
474 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
475 * may lead to the function not terminating.
476 *
477 * \param list A list
478 * \return The list reversed or enc_sym(SYM_MERROR) if heap is full.
479 */
480lbm_value lbm_list_reverse(lbm_value list);
481/** Reverse a proper list destroying the original.
482 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
483 * may lead to the function not terminating.
484 *
485 * \param list A list
486 * \return The list reversed
487 */
488lbm_value lbm_list_destructive_reverse(lbm_value list);
489/** Copy a list
490 * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
491 * may lead to the function not terminating.
492 *
493 * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list
494 * \param list A list.
495 * \return Reversed list or enc_sym(SYM_MERROR) if heap is full.
496 */
497lbm_value lbm_list_copy(int *m, lbm_value list);
498
499/** A destructive append of two lists
500 *
501 * \param list1 A list
502 * \param list2 A list
503 * \return list1 with list2 appended at the end.
504 */
505lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
506
507/** Drop values from the head of a list.
508 * \param n Number of values to drop.
509 * \param ls List to drop values from.
510 * \return The list with the n first elements removed.
511 */
512lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
513/** Index into a list.
514 * \param l List to index into.
515 * \param n Position to read out of the list.
516 * \return Value at position n of l or nil if out of bounds.
517 */
518lbm_value lbm_index_list(lbm_value l, int32_t n);
519
520// State and statistics
521/** Get a copy of the heap statistics structure.
522 *
523 * \param A pointer to an lbm_heap_state_t to populate
524 * with the current statistics.
525 */
526void lbm_get_heap_state(lbm_heap_state_t *);
527/** Get the maximum stack level of the GC stack
528 * \return maximum value the gc stack sp reached so far.
529 */
530lbm_uint lbm_get_gc_stack_max(void);
531/** Get the size of the GC stack.
532 * \return the size of the gc stack.
533 */
534lbm_uint lbm_get_gc_stack_size(void);
535// Garbage collection
536/** Increment the counter that is counting the number of times GC ran
537 *
538 */
539void lbm_gc_state_inc(void);
540/** Set the freelist to NIL. Means that no memory will be available
541 * until after a garbage collection.
542 */
543void lbm_nil_freelist(void);
544/** Mark all heap cells reachable from an environment.
545 * \param environment.
546 */
547void lbm_gc_mark_env(lbm_value);
548/** Mark heap cells reachable from the lbm_value v.
549 * \param root
550 */
551void lbm_gc_mark_phase(lbm_value root);
552/** Performs lbm_gc_mark_phase on all the values of an array.
553 * This function is similar to lbm_gc_mark_roots but performs
554 * extra checks to not traverse into non-standard values.
555 * TODO: Check if this function is really needed.
556 * \param data Array of roots to traverse from.
557 * \param n Number of elements in roots-array.
558 */
559void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
560/** Performs lbm_gc_mark_phase on all the values in the roots array.
561 * \param roots pointer to array of roots.
562 * \param num_roots size of array of roots.
563 */
564void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
565/** Sweep up all non marked heap cells and place them on the free list.
566 *
567 * \return 1
568 */
569int lbm_gc_sweep_phase(void);
570
571// Array functionality
572/** Allocate an array in symbols and arrays memory (lispbm_memory.h)
573 * and create a heap cell that refers to this array.
574 * \param res The resulting lbm_value is returned through this argument.
575 * \param size Array size in number of 32 bit words.
576 * \param type The type information to encode onto the heap cell.
577 * \return 1 for success of 0 for failure.
578 */
579int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
580/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
581 * the lifetime of the array will be managed by GC.
582 * \param res lbm_value result pointer for storage of the result array.
583 * \param data C array.
584 * \param type The type tag to assign to the resulting LBM array.
585 * \param num_elt Number of elements in the array.
586 * \return 1 for success and 0 for failure.
587 */
588int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
589/** Get the size of an array value.
590 * \param arr lbm_value array to get size of.
591 * \return -1 for failure or length of array.
592 */
593lbm_int lbm_heap_array_get_size(lbm_value arr);
594/** Get a pointer to the data of an array for read only purposes.
595 * \param arr lbm_value array to get pointer from.
596 * \return NULL or valid pointer.
597 */
598const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr);
599/** Get a pointer to the data of an array for read/write purposes.
600 * \param arr lbm_value array to get pointer from.
601 * \return NULL or valid pointer.
602 */
603uint8_t *lbm_heap_array_get_data_rw(lbm_value arr);
604/** Explicitly free an array.
605 * This function needs to be used with care and knowledge.
606 * \param arr Array value.
607 */
608int lbm_heap_explicit_free_array(lbm_value arr);
609/** Query the size in bytes of an lbm_type.
610 * \param t Type
611 * \return Size in bytes of type or 0 if the type represents a composite.
612 */
613lbm_uint lbm_size_of(lbm_type t);
614
615int lbm_const_heap_init(const_heap_write_fun w_fun,
616 lbm_const_heap_t *heap,
617 lbm_uint *addr,
618 lbm_uint num_words);
619
620lbm_flash_status lbm_allocate_const_cell(lbm_value *res);
621lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res);
622lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val);
623lbm_flash_status write_const_car(lbm_value cell, lbm_value val);
624lbm_uint lbm_flash_memory_usage(void);
625
626/** Query the type information of a value.
627 *
628 * \param x Value to check the type of.
629 * \return The type information.
630 */
631static inline lbm_type lbm_type_of(lbm_value x) {
632 return (x & LBM_PTR_MASK0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu);
633}
634
635// type-of check that is safe in functional code
636static inline lbm_type lbm_type_of_functional(lbm_value x) {
637 return (x & LBM_PTR_MASK0x00000001u) ?
638 (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) :
639 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
640}
641
642static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
643 return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u);
644}
645
646static inline lbm_uint lbm_dec_ptr(lbm_value p) {
647 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2);
648}
649
650extern lbm_cons_t *lbm_heaps[2];
651
652static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) {
653 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
654 return lbm_dec_ptr(p) >> h;
655}
656
657static inline lbm_cons_t *lbm_dec_heap(lbm_value p) {
658 lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26;
659 return lbm_heaps[h];
660}
661
662static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
663 return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u);
664}
665
666static inline lbm_value lbm_enc_sym(lbm_uint s) {
667 return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u;
668}
669
670static inline lbm_value lbm_enc_i(lbm_int x) {
671 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u;
672}
673
674static inline lbm_value lbm_enc_u(lbm_uint x) {
675 return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu;
676}
677
678/** Encode 32 bit integer into an lbm_value.
679 * \param x Value to encode.
680 * \return result encoded value.
681 */
682extern lbm_value lbm_enc_i32(int32_t x);
683
684/** Encode 32 bit unsigned integer into an lbm_value.
685 * \param x Value to encode.
686 * \return result encoded value.
687 */
688extern lbm_value lbm_enc_u32(uint32_t x);
689
690/** Encode a float into an lbm_value.
691 * \param x float value to encode.
692 * \return result encoded value.
693 */
694extern lbm_value lbm_enc_float(float x);
695
696/** Encode a 64 bit integer into an lbm_value.
697 * \param x 64 bit integer to encode.
698 * \return result encoded value.
699 */
700extern lbm_value lbm_enc_i64(int64_t x);
701
702/** Encode a 64 bit unsigned integer into an lbm_value.
703 * \param x 64 bit unsigned integer to encode.
704 * \return result encoded value.
705 */
706extern lbm_value lbm_enc_u64(uint64_t x);
707
708/** Encode a double into an lbm_value.
709 * \param x double to encode.
710 * \return result encoded value.
711 */
712extern lbm_value lbm_enc_double(double x);
713
714static inline lbm_value lbm_enc_char(uint8_t x) {
715 return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u;
716}
717
718static inline lbm_int lbm_dec_i(lbm_value x) {
719 return (lbm_int)x >> LBM_VAL_SHIFT4;
720}
721
722static inline lbm_uint lbm_dec_u(lbm_value x) {
723 return x >> LBM_VAL_SHIFT4;
724}
725
726static inline uint8_t lbm_dec_char(lbm_value x) {
727 return (uint8_t)(x >> LBM_VAL_SHIFT4);
728}
729
730static inline lbm_uint lbm_dec_sym(lbm_value x) {
731 return x >> LBM_VAL_SHIFT4;
732}
733
734/** Decode an lbm_value representing a float.
735 * \param x Value to decode.
736 * \return decoded float.
737 */
738extern float lbm_dec_float(lbm_value x);
739
740/** Decode an lbm_value representing a double.
741 * \param x Value to decode.
742 * \return decoded float.
743 */
744extern double lbm_dec_double(lbm_value x);
745
746
747static inline uint32_t lbm_dec_u32(lbm_value x) {
748#ifndef LBM64
749 return (uint32_t)lbm_car(x);
750#else
751 return (uint32_t)(x >> LBM_VAL_SHIFT4);
752#endif
753}
754
755/** Decode an lbm_value representing a 64 bit unsigned integer.
756 * \param x Value to decode.
757 * \return decoded uint64_t.
758 */
759extern uint64_t lbm_dec_u64(lbm_value x);
760
761static inline int32_t lbm_dec_i32(lbm_value x) {
762#ifndef LBM64
763 return (int32_t)lbm_car(x);
764#else
765 return (int32_t)(x >> LBM_VAL_SHIFT4);
766#endif
767}
768
769/** Decode an lbm_value representing a 64 bit integer.
770 * \param x Value to decode.
771 * \return decoded int64_t.
772 */
773extern int64_t lbm_dec_i64(lbm_value x);
774
775/**
776 * Check if a value is a heap pointer
777 * \param x Value to check
778 * \return true if x is a pointer to a heap cell, false otherwise.
779 */
780static inline bool_Bool lbm_is_ptr(lbm_value x) {
781 return (x & LBM_PTR_MASK0x00000001u);
782}
783
784/**
785 * Check if a value is a Read/Writeable cons cell
786 * \param x Value to check
787 * \return true if x is a Read/Writeable cons cell, false otherwise.
788 */
789static inline bool_Bool lbm_is_cons_rw(lbm_value x) {
790 return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u);
791}
792
793/**
794 * Check if a value is a Readable cons cell
795 * \param x Value to check
796 * \return true if x is a readable cons cell, false otherwise.
797 */
798static inline bool_Bool lbm_is_cons(lbm_value x) {
799 return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u);
800}
801
802/** Check if a value represents a number
803 * \param x Value to check.
804 * \return true is x represents a number and false otherwise.
805 */
806static inline bool_Bool lbm_is_number(lbm_value x) {
807 return
808 (x & LBM_PTR_BIT0x00000001u) ?
809 ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) :
810 (x & LBM_VAL_TYPE_MASK0x0000000Cu);
811}
812
813/** Check if value is an array that can be READ
814 * \param x Value to check.
815 * \return true if x represents a readable array and false otherwise.
816 */
817static inline bool_Bool lbm_is_array_r(lbm_value x) {
818 lbm_type t = lbm_type_of(x);
819 return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u);
820}
821
822static inline bool_Bool lbm_is_array_rw(lbm_value x) {
823 return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u));
824}
825
826static inline bool_Bool lbm_is_channel(lbm_value x) {
827 return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u &&
828 lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u &&
829 lbm_dec_sym(lbm_cdr(x)) == SYM_CHANNEL_TYPE0x37);
830}
831static inline bool_Bool lbm_is_char(lbm_value x) {
832 return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u);
833}
834
835static inline bool_Bool lbm_is_special(lbm_value symrep) {
836 return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) &&
837 (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF));
838}
839
840static inline bool_Bool lbm_is_closure(lbm_value exp) {
841 return ((lbm_is_cons(exp)) &&
842 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
843 (lbm_dec_sym(lbm_car(exp)) == SYM_CLOSURE0x10F));
844}
845
846static inline bool_Bool lbm_is_continuation(lbm_value exp) {
847 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
848 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
849 (lbm_dec_sym(lbm_car(exp)) == SYM_CONT0x10E));
850}
851
852static inline bool_Bool lbm_is_macro(lbm_value exp) {
853 return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) &&
854 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
855 (lbm_dec_sym(lbm_car(exp)) == SYM_MACRO0x10D));
856}
857
858static inline bool_Bool lbm_is_match_binder(lbm_value exp) {
859 return (lbm_is_cons(exp) &&
860 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
861 ((lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_ANY0x41)));
862}
863
864static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) {
865 return (lbm_is_cons(exp) &&
866 (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) &&
867 (lbm_dec_sym(lbm_car(exp)) == SYM_COMMA0x73) &&
868 (lbm_type_of(lbm_car(lbm_cdr(exp))) == LBM_TYPE_SYMBOL0x00000000u));
869}
870
871static inline bool_Bool lbm_is_symbol(lbm_value exp) {
872 return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu);
873}
874
875static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) {
876 return !exp;// == ENC_SYM_NIL;
22
Assuming 'exp' is 0
23
Returning the value 1, which participates in a condition later
877}
878
879static inline bool_Bool lbm_is_symbol_true(lbm_value exp) {
880 return (lbm_is_symbol(exp) && lbm_dec_sym(exp) == SYM_TRUE0x2);
881}
882
883static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) {
884 return (lbm_is_symbol(exp) && lbm_dec_sym(exp) == SYM_EVAL0x30008);
885}
886
887static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) {
888 return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u));
889}
890
891static inline bool_Bool lbm_is_list(lbm_value x) {
892 return (lbm_is_cons(x) || lbm_is_symbol_nil(x));
893}
894
895static inline bool_Bool lbm_is_list_rw(lbm_value x) {
896 return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x));
897}
898
899static inline bool_Bool lbm_is_quoted_list(lbm_value x) {
900 return (lbm_is_cons(x) &&
901 lbm_is_symbol(lbm_car(x)) &&
902 (lbm_dec_sym(lbm_car(x)) == SYM_QUOTE0x100) &&
903 lbm_is_cons(lbm_cdr(x)) &&
904 lbm_is_cons(lbm_car(lbm_cdr(x))));
905}
906
907#ifndef LBM64
908#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0
909#else
910#define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0
911#endif
912
913/* all error signaling symbols are in the range 0x20 - 0x2F */
914static inline bool_Bool lbm_is_error(lbm_value v){
915 return (lbm_is_symbol(v) &&
916 ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20));
917}
918
919// ref_cell: returns a reference to the cell addressed by bits 3 - 26
920// Assumes user has checked that is_ptr was set
921static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) {
922 return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)];
923 //return &lbm_heap_state.heap[lbm_dec_ptr(addr)];
924}
925
926
927// lbm_uint a = lbm_heaps[0];
928// lbm_uint b = lbm_heaps[1];
929// lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1;
930// lbm_uint h = (a & i) | (b & ~i);
931
932#ifdef __cplusplus
933}
934#endif
935#endif