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