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