Bug Summary

File:eval_cps.c
Warning:line 4600, column 19
Access to field 'size' results in a dereference of a null pointer (loaded from variable 'src_arr')

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.26.0/scan-build/2024-08-06-173222-124214-1 -x c src/eval_cps.c

src/eval_cps.c

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

./include/heap.h

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