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