Bug Summary

File:eval_cps.c
Warning:line 2163, column 17
Assigned value is garbage or undefined

Annotated Source Code

Press '?' to see keyboard shortcuts

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