| File: | eval_cps.c |
| Warning: | line 2998, column 13 Assigned value is garbage or undefined |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
| 1 | /* | ||||||||
| 2 | Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se | ||||||||
| 3 | |||||||||
| 4 | This program is free software: you can redistribute it and/or modify | ||||||||
| 5 | it under the terms of the GNU General Public License as published by | ||||||||
| 6 | the Free Software Foundation, either version 3 of the License, or | ||||||||
| 7 | (at your option) any later version. | ||||||||
| 8 | |||||||||
| 9 | This program is distributed in the hope that it will be useful, | ||||||||
| 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||||
| 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||||
| 12 | GNU General Public License for more details. | ||||||||
| 13 | |||||||||
| 14 | You should have received a copy of the GNU General Public License | ||||||||
| 15 | along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||||||
| 16 | */ | ||||||||
| 17 | |||||||||
| 18 | #include <lbm_memory.h> | ||||||||
| 19 | #include <lbm_types.h> | ||||||||
| 20 | #include "symrepr.h" | ||||||||
| 21 | #include "heap.h" | ||||||||
| 22 | #include "env.h" | ||||||||
| 23 | #include "eval_cps.h" | ||||||||
| 24 | #include "stack.h" | ||||||||
| 25 | #include "fundamental.h" | ||||||||
| 26 | #include "extensions.h" | ||||||||
| 27 | #include "tokpar.h" | ||||||||
| 28 | #include "lbm_channel.h" | ||||||||
| 29 | #include "print.h" | ||||||||
| 30 | #include "platform_mutex.h" | ||||||||
| 31 | #include "lbm_flat_value.h" | ||||||||
| 32 | #include "lbm_flags.h" | ||||||||
| 33 | |||||||||
| 34 | #ifdef VISUALIZE_HEAP | ||||||||
| 35 | #include "heap_vis.h" | ||||||||
| 36 | #endif | ||||||||
| 37 | |||||||||
| 38 | #include <setjmp.h> | ||||||||
| 39 | #include <stdarg.h> | ||||||||
| 40 | |||||||||
| 41 | static jmp_buf error_jmp_buf; | ||||||||
| 42 | static jmp_buf critical_error_jmp_buf; | ||||||||
| 43 | |||||||||
| 44 | #define S_TO_US(X)(lbm_uint)((X) * 1000000) (lbm_uint)((X) * 1000000) | ||||||||
| 45 | |||||||||
| 46 | #define DEC_CONTINUATION(x)(((x) & ~0xF8000001u) >> 2) (((x) & ~LBM_CONTINUATION_INTERNAL0xF8000001u) >> LBM_ADDRESS_SHIFT2) | ||||||||
| 47 | #define IS_CONTINUATION(x)(((x) & 0xF8000001u) == 0xF8000001u) (((x) & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u) | ||||||||
| 48 | #define CONTINUATION(x)(((x) << 2) | 0xF8000001u) (((x) << LBM_ADDRESS_SHIFT2) | LBM_CONTINUATION_INTERNAL0xF8000001u) | ||||||||
| 49 | |||||||||
| 50 | #define DONE(((0) << 2) | 0xF8000001u) CONTINUATION(0)(((0) << 2) | 0xF8000001u) | ||||||||
| 51 | #define SET_GLOBAL_ENV(((1) << 2) | 0xF8000001u) CONTINUATION(1)(((1) << 2) | 0xF8000001u) | ||||||||
| 52 | #define BIND_TO_KEY_REST(((2) << 2) | 0xF8000001u) CONTINUATION(2)(((2) << 2) | 0xF8000001u) | ||||||||
| 53 | #define IF(((3) << 2) | 0xF8000001u) CONTINUATION(3)(((3) << 2) | 0xF8000001u) | ||||||||
| 54 | #define PROGN_REST(((4) << 2) | 0xF8000001u) CONTINUATION(4)(((4) << 2) | 0xF8000001u) | ||||||||
| 55 | #define APPLICATION_ARGS(((5) << 2) | 0xF8000001u) CONTINUATION(5)(((5) << 2) | 0xF8000001u) | ||||||||
| 56 | #define AND(((6) << 2) | 0xF8000001u) CONTINUATION(6)(((6) << 2) | 0xF8000001u) | ||||||||
| 57 | #define OR(((7) << 2) | 0xF8000001u) CONTINUATION(7)(((7) << 2) | 0xF8000001u) | ||||||||
| 58 | #define WAIT(((8) << 2) | 0xF8000001u) CONTINUATION(8)(((8) << 2) | 0xF8000001u) | ||||||||
| 59 | #define MATCH(((9) << 2) | 0xF8000001u) CONTINUATION(9)(((9) << 2) | 0xF8000001u) | ||||||||
| 60 | #define APPLICATION_START(((10) << 2) | 0xF8000001u) CONTINUATION(10)(((10) << 2) | 0xF8000001u) | ||||||||
| 61 | #define EVAL_R(((11) << 2) | 0xF8000001u) CONTINUATION(11)(((11) << 2) | 0xF8000001u) | ||||||||
| 62 | #define RESUME(((12) << 2) | 0xF8000001u) CONTINUATION(12)(((12) << 2) | 0xF8000001u) | ||||||||
| 63 | #define CLOSURE_ARGS(((13) << 2) | 0xF8000001u) CONTINUATION(13)(((13) << 2) | 0xF8000001u) | ||||||||
| 64 | #define EXIT_ATOMIC(((14) << 2) | 0xF8000001u) CONTINUATION(14)(((14) << 2) | 0xF8000001u) | ||||||||
| 65 | #define READ_NEXT_TOKEN(((15) << 2) | 0xF8000001u) CONTINUATION(15)(((15) << 2) | 0xF8000001u) | ||||||||
| 66 | #define READ_APPEND_CONTINUE(((16) << 2) | 0xF8000001u) CONTINUATION(16)(((16) << 2) | 0xF8000001u) | ||||||||
| 67 | #define READ_EVAL_CONTINUE(((17) << 2) | 0xF8000001u) CONTINUATION(17)(((17) << 2) | 0xF8000001u) | ||||||||
| 68 | #define READ_EXPECT_CLOSEPAR(((18) << 2) | 0xF8000001u) CONTINUATION(18)(((18) << 2) | 0xF8000001u) | ||||||||
| 69 | #define READ_DOT_TERMINATE(((19) << 2) | 0xF8000001u) CONTINUATION(19)(((19) << 2) | 0xF8000001u) | ||||||||
| 70 | #define READ_DONE(((20) << 2) | 0xF8000001u) CONTINUATION(20)(((20) << 2) | 0xF8000001u) | ||||||||
| 71 | #define READ_QUOTE_RESULT(((21) << 2) | 0xF8000001u) CONTINUATION(21)(((21) << 2) | 0xF8000001u) | ||||||||
| 72 | #define READ_COMMAAT_RESULT(((22) << 2) | 0xF8000001u) CONTINUATION(22)(((22) << 2) | 0xF8000001u) | ||||||||
| 73 | #define READ_COMMA_RESULT(((23) << 2) | 0xF8000001u) CONTINUATION(23)(((23) << 2) | 0xF8000001u) | ||||||||
| 74 | #define READ_START_ARRAY(((24) << 2) | 0xF8000001u) CONTINUATION(24)(((24) << 2) | 0xF8000001u) | ||||||||
| 75 | #define READ_APPEND_ARRAY(((25) << 2) | 0xF8000001u) CONTINUATION(25)(((25) << 2) | 0xF8000001u) | ||||||||
| 76 | #define MAP(((26) << 2) | 0xF8000001u) CONTINUATION(26)(((26) << 2) | 0xF8000001u) | ||||||||
| 77 | #define MATCH_GUARD(((27) << 2) | 0xF8000001u) CONTINUATION(27)(((27) << 2) | 0xF8000001u) | ||||||||
| 78 | #define TERMINATE(((28) << 2) | 0xF8000001u) CONTINUATION(28)(((28) << 2) | 0xF8000001u) | ||||||||
| 79 | #define PROGN_VAR(((29) << 2) | 0xF8000001u) CONTINUATION(29)(((29) << 2) | 0xF8000001u) | ||||||||
| 80 | #define SETQ(((30) << 2) | 0xF8000001u) CONTINUATION(30)(((30) << 2) | 0xF8000001u) | ||||||||
| 81 | #define MOVE_TO_FLASH(((31) << 2) | 0xF8000001u) CONTINUATION(31)(((31) << 2) | 0xF8000001u) | ||||||||
| 82 | #define MOVE_VAL_TO_FLASH_DISPATCH(((32) << 2) | 0xF8000001u) CONTINUATION(32)(((32) << 2) | 0xF8000001u) | ||||||||
| 83 | #define MOVE_LIST_TO_FLASH(((33) << 2) | 0xF8000001u) CONTINUATION(33)(((33) << 2) | 0xF8000001u) | ||||||||
| 84 | #define CLOSE_LIST_IN_FLASH(((34) << 2) | 0xF8000001u) CONTINUATION(34)(((34) << 2) | 0xF8000001u) | ||||||||
| 85 | #define QQ_EXPAND_START(((35) << 2) | 0xF8000001u) CONTINUATION(35)(((35) << 2) | 0xF8000001u) | ||||||||
| 86 | #define QQ_EXPAND(((36) << 2) | 0xF8000001u) CONTINUATION(36)(((36) << 2) | 0xF8000001u) | ||||||||
| 87 | #define QQ_APPEND(((37) << 2) | 0xF8000001u) CONTINUATION(37)(((37) << 2) | 0xF8000001u) | ||||||||
| 88 | #define QQ_EXPAND_LIST(((38) << 2) | 0xF8000001u) CONTINUATION(38)(((38) << 2) | 0xF8000001u) | ||||||||
| 89 | #define QQ_LIST(((39) << 2) | 0xF8000001u) CONTINUATION(39)(((39) << 2) | 0xF8000001u) | ||||||||
| 90 | #define KILL(((40) << 2) | 0xF8000001u) CONTINUATION(40)(((40) << 2) | 0xF8000001u) | ||||||||
| 91 | #define LOOP(((41) << 2) | 0xF8000001u) CONTINUATION(41)(((41) << 2) | 0xF8000001u) | ||||||||
| 92 | #define LOOP_CONDITION(((42) << 2) | 0xF8000001u) CONTINUATION(42)(((42) << 2) | 0xF8000001u) | ||||||||
| 93 | #define MERGE_REST(((43) << 2) | 0xF8000001u) CONTINUATION(43)(((43) << 2) | 0xF8000001u) | ||||||||
| 94 | #define MERGE_LAYER(((44) << 2) | 0xF8000001u) CONTINUATION(44)(((44) << 2) | 0xF8000001u) | ||||||||
| 95 | #define CLOSURE_ARGS_REST(((45) << 2) | 0xF8000001u) CONTINUATION(45)(((45) << 2) | 0xF8000001u) | ||||||||
| 96 | #define MOVE_ARRAY_ELTS_TO_FLASH(((46) << 2) | 0xF8000001u) CONTINUATION(46)(((46) << 2) | 0xF8000001u) | ||||||||
| 97 | #define POP_READER_FLAGS(((47) << 2) | 0xF8000001u) CONTINUATION(47)(((47) << 2) | 0xF8000001u) | ||||||||
| 98 | #define EXCEPTION_HANDLER(((48) << 2) | 0xF8000001u) CONTINUATION(48)(((48) << 2) | 0xF8000001u) | ||||||||
| 99 | #define NUM_CONTINUATIONS49 49 | ||||||||
| 100 | |||||||||
| 101 | #define FM_NEED_GC-1 -1 | ||||||||
| 102 | #define FM_NO_MATCH-2 -2 | ||||||||
| 103 | #define FM_PATTERN_ERROR-3 -3 | ||||||||
| 104 | |||||||||
| 105 | typedef enum { | ||||||||
| 106 | BL_OK = 0, | ||||||||
| 107 | BL_NO_MEMORY, | ||||||||
| 108 | BL_INCORRECT_KEY | ||||||||
| 109 | } binding_location_status; | ||||||||
| 110 | |||||||||
| 111 | #define FB_OK0 0 | ||||||||
| 112 | #define FB_TYPE_ERROR-1 -1 | ||||||||
| 113 | |||||||||
| 114 | const char* lbm_error_str_parse_eof = "End of parse stream."; | ||||||||
| 115 | const char* lbm_error_str_parse_dot = "Incorrect usage of '.'."; | ||||||||
| 116 | const char* lbm_error_str_parse_close = "Expected closing parenthesis."; | ||||||||
| 117 | const char* lbm_error_str_num_args = "Incorrect number of arguments."; | ||||||||
| 118 | const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block."; | ||||||||
| 119 | const char* lbm_error_str_no_number = "Argument(s) must be a number."; | ||||||||
| 120 | const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false)."; | ||||||||
| 121 | const char* lbm_error_str_incorrect_arg = "Incorrect argument."; | ||||||||
| 122 | const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn."; | ||||||||
| 123 | const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash."; | ||||||||
| 124 | const char* lbm_error_str_flash_error = "Error writing to flash."; | ||||||||
| 125 | const char* lbm_error_str_flash_full = "Flash memory is full."; | ||||||||
| 126 | const char* lbm_error_str_variable_not_bound = "Variable not bound."; | ||||||||
| 127 | |||||||||
| 128 | static lbm_value lbm_error_suspect; | ||||||||
| 129 | static bool_Bool lbm_error_has_suspect = false0; | ||||||||
| 130 | #ifdef LBM_ALWAYS_GC | ||||||||
| 131 | |||||||||
| 132 | #define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4) | 0x00000000u)); } } \ | ||||||||
| 133 | gc(); \ | ||||||||
| 134 | (y) = (x); \ | ||||||||
| 135 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 136 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \ | ||||||||
| 137 | } | ||||||||
| 138 | |||||||||
| 139 | #define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase (r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx ((((0x23) << 4) | 0x00000000u)); } } \ | ||||||||
| 140 | lbm_gc_mark_phase(r); \ | ||||||||
| 141 | gc(); \ | ||||||||
| 142 | (y) = (x); \ | ||||||||
| 143 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 144 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \ | ||||||||
| 145 | } | ||||||||
| 146 | |||||||||
| 147 | #else | ||||||||
| 148 | |||||||||
| 149 | #define WITH_GC(y, x)(y) = (x); if (lbm_is_symbol_merror((y))) { gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx((((0x23) << 4) | 0x00000000u)); } } \ | ||||||||
| 150 | (y) = (x); \ | ||||||||
| 151 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 152 | gc(); \ | ||||||||
| 153 | (y) = (x); \ | ||||||||
| 154 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 155 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \ | ||||||||
| 156 | } \ | ||||||||
| 157 | /* continue executing statements below */ \ | ||||||||
| 158 | } | ||||||||
| 159 | #define WITH_GC_RMBR_1(y, x, r)(y) = (x); if (lbm_is_symbol_merror((y))) { lbm_gc_mark_phase (r); gc(); (y) = (x); if (lbm_is_symbol_merror((y))) { error_ctx ((((0x23) << 4) | 0x00000000u)); } } \ | ||||||||
| 160 | (y) = (x); \ | ||||||||
| 161 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 162 | lbm_gc_mark_phase(r); \ | ||||||||
| 163 | gc(); \ | ||||||||
| 164 | (y) = (x); \ | ||||||||
| 165 | if (lbm_is_symbol_merror((y))) { \ | ||||||||
| 166 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); \ | ||||||||
| 167 | } \ | ||||||||
| 168 | /* continue executing statements below */ \ | ||||||||
| 169 | } | ||||||||
| 170 | |||||||||
| 171 | #endif | ||||||||
| 172 | |||||||||
| 173 | typedef struct { | ||||||||
| 174 | eval_context_t *first; | ||||||||
| 175 | eval_context_t *last; | ||||||||
| 176 | } eval_context_queue_t; | ||||||||
| 177 | |||||||||
| 178 | #ifdef CLEAN_UP_CLOSURES | ||||||||
| 179 | static lbm_value clean_cl_env_symbol = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | ||||||||
| 180 | #endif | ||||||||
| 181 | |||||||||
| 182 | static int gc(void); | ||||||||
| 183 | static void error_ctx(lbm_value); | ||||||||
| 184 | static void error_at_ctx(lbm_value err_val, lbm_value at); | ||||||||
| 185 | static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx); | ||||||||
| 186 | static bool_Bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail); | ||||||||
| 187 | |||||||||
| 188 | // The currently executing context. | ||||||||
| 189 | eval_context_t *ctx_running = NULL((void*)0); | ||||||||
| 190 | volatile bool_Bool lbm_system_sleeping = false0; | ||||||||
| 191 | |||||||||
| 192 | static volatile bool_Bool gc_requested = false0; | ||||||||
| 193 | void lbm_request_gc(void) { | ||||||||
| 194 | gc_requested = true1; | ||||||||
| 195 | } | ||||||||
| 196 | |||||||||
| 197 | /* | ||||||||
| 198 | On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the | ||||||||
| 199 | resolution of the timer used for sleep operations. If this is set | ||||||||
| 200 | to 10KHz the resolution is 100us. | ||||||||
| 201 | |||||||||
| 202 | The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that | ||||||||
| 203 | can be safely specified in a timeout directive (wonder if that | ||||||||
| 204 | means sleep-period). The timedelta is set to 2. | ||||||||
| 205 | |||||||||
| 206 | If I have understood these correctly it means that the minimum | ||||||||
| 207 | sleep duration possible is 2 * 100us = 200us. | ||||||||
| 208 | */ | ||||||||
| 209 | |||||||||
| 210 | #define EVAL_CPS_DEFAULT_STACK_SIZE256 256 | ||||||||
| 211 | #define EVAL_CPS_MIN_SLEEP200 200 | ||||||||
| 212 | #define EVAL_STEPS_QUOTA10 10 | ||||||||
| 213 | |||||||||
| 214 | static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA10; | ||||||||
| 215 | static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA10; | ||||||||
| 216 | |||||||||
| 217 | void lbm_set_eval_step_quota(uint32_t quota) { | ||||||||
| 218 | eval_steps_refill = quota; | ||||||||
| 219 | } | ||||||||
| 220 | |||||||||
| 221 | static uint32_t eval_cps_run_state = EVAL_CPS_STATE_DEAD8; | ||||||||
| 222 | static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE0; | ||||||||
| 223 | static volatile uint32_t eval_cps_next_state_arg = 0; | ||||||||
| 224 | static volatile bool_Bool eval_cps_state_changed = false0; | ||||||||
| 225 | |||||||||
| 226 | static void usleep_nonsense(uint32_t us) { | ||||||||
| 227 | (void) us; | ||||||||
| 228 | } | ||||||||
| 229 | |||||||||
| 230 | static bool_Bool dynamic_load_nonsense(const char *sym, const char **code) { | ||||||||
| 231 | (void) sym; | ||||||||
| 232 | (void) code; | ||||||||
| 233 | return false0; | ||||||||
| 234 | } | ||||||||
| 235 | |||||||||
| 236 | static uint32_t timestamp_nonsense(void) { | ||||||||
| 237 | return 0; | ||||||||
| 238 | } | ||||||||
| 239 | |||||||||
| 240 | static int printf_nonsense(const char *fmt, ...) { | ||||||||
| 241 | (void) fmt; | ||||||||
| 242 | return 0; | ||||||||
| 243 | } | ||||||||
| 244 | |||||||||
| 245 | static void ctx_done_nonsense(eval_context_t *ctx) { | ||||||||
| 246 | (void) ctx; | ||||||||
| 247 | } | ||||||||
| 248 | |||||||||
| 249 | static void critical_nonsense(void) { | ||||||||
| 250 | return; | ||||||||
| 251 | } | ||||||||
| 252 | |||||||||
| 253 | static void (*critical_error_callback)(void) = critical_nonsense; | ||||||||
| 254 | static void (*usleep_callback)(uint32_t) = usleep_nonsense; | ||||||||
| 255 | static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense; | ||||||||
| 256 | static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense; | ||||||||
| 257 | static int (*printf_callback)(const char *, ...) = printf_nonsense; | ||||||||
| 258 | static bool_Bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense; | ||||||||
| 259 | |||||||||
| 260 | void lbm_set_critical_error_callback(void (*fptr)(void)) { | ||||||||
| 261 | if (fptr == NULL((void*)0)) critical_error_callback = critical_nonsense; | ||||||||
| 262 | else critical_error_callback = fptr; | ||||||||
| 263 | } | ||||||||
| 264 | |||||||||
| 265 | void lbm_set_usleep_callback(void (*fptr)(uint32_t)) { | ||||||||
| 266 | if (fptr == NULL((void*)0)) usleep_callback = usleep_nonsense; | ||||||||
| 267 | else usleep_callback = fptr; | ||||||||
| 268 | } | ||||||||
| 269 | |||||||||
| 270 | void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) { | ||||||||
| 271 | if (fptr == NULL((void*)0)) timestamp_us_callback = timestamp_nonsense; | ||||||||
| 272 | else timestamp_us_callback = fptr; | ||||||||
| 273 | } | ||||||||
| 274 | |||||||||
| 275 | void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) { | ||||||||
| 276 | if (fptr == NULL((void*)0)) ctx_done_callback = ctx_done_nonsense; | ||||||||
| 277 | else ctx_done_callback = fptr; | ||||||||
| 278 | } | ||||||||
| 279 | |||||||||
| 280 | void lbm_set_printf_callback(int (*fptr)(const char*, ...)){ | ||||||||
| 281 | if (fptr == NULL((void*)0)) printf_callback = printf_nonsense; | ||||||||
| 282 | else printf_callback = fptr; | ||||||||
| 283 | } | ||||||||
| 284 | |||||||||
| 285 | void lbm_set_dynamic_load_callback(bool_Bool (*fptr)(const char *, const char **)) { | ||||||||
| 286 | if (fptr == NULL((void*)0)) dynamic_load_callback = dynamic_load_nonsense; | ||||||||
| 287 | else dynamic_load_callback = fptr; | ||||||||
| 288 | } | ||||||||
| 289 | |||||||||
| 290 | static volatile lbm_event_t *lbm_events = NULL((void*)0); | ||||||||
| 291 | static unsigned int lbm_events_head = 0; | ||||||||
| 292 | static unsigned int lbm_events_tail = 0; | ||||||||
| 293 | static unsigned int lbm_events_max = 0; | ||||||||
| 294 | static bool_Bool lbm_events_full = false0; | ||||||||
| 295 | static mutex_t lbm_events_mutex; | ||||||||
| 296 | static bool_Bool lbm_events_mutex_initialized = false0; | ||||||||
| 297 | static volatile lbm_cid lbm_event_handler_pid = -1; | ||||||||
| 298 | |||||||||
| 299 | lbm_cid lbm_get_event_handler_pid(void) { | ||||||||
| 300 | return lbm_event_handler_pid; | ||||||||
| 301 | } | ||||||||
| 302 | |||||||||
| 303 | void lbm_set_event_handler_pid(lbm_cid pid) { | ||||||||
| 304 | lbm_event_handler_pid = pid; | ||||||||
| 305 | } | ||||||||
| 306 | |||||||||
| 307 | bool_Bool lbm_event_handler_exists(void) { | ||||||||
| 308 | return(lbm_event_handler_pid > 0); | ||||||||
| 309 | } | ||||||||
| 310 | |||||||||
| 311 | |||||||||
| 312 | static bool_Bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) { | ||||||||
| 313 | bool_Bool r = false0; | ||||||||
| 314 | if (lbm_events) { | ||||||||
| 315 | mutex_lock(&lbm_events_mutex); | ||||||||
| 316 | if (!lbm_events_full) { | ||||||||
| 317 | lbm_event_t event; | ||||||||
| 318 | event.type = event_type; | ||||||||
| 319 | event.parameter = parameter; | ||||||||
| 320 | event.buf_ptr = buf_ptr; | ||||||||
| 321 | event.buf_len = buf_len; | ||||||||
| 322 | lbm_events[lbm_events_head] = event; | ||||||||
| 323 | lbm_events_head = (lbm_events_head + 1) % lbm_events_max; | ||||||||
| 324 | lbm_events_full = lbm_events_head == lbm_events_tail; | ||||||||
| 325 | r = true1; | ||||||||
| 326 | } | ||||||||
| 327 | mutex_unlock(&lbm_events_mutex); | ||||||||
| 328 | } | ||||||||
| 329 | return r; | ||||||||
| 330 | } | ||||||||
| 331 | |||||||||
| 332 | bool_Bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) { | ||||||||
| 333 | return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size); | ||||||||
| 334 | } | ||||||||
| 335 | |||||||||
| 336 | bool_Bool lbm_event_unboxed(lbm_value unboxed) { | ||||||||
| 337 | lbm_uint t = lbm_type_of(unboxed); | ||||||||
| 338 | if (t == LBM_TYPE_SYMBOL0x00000000u || | ||||||||
| 339 | t == LBM_TYPE_I0x00000008u || | ||||||||
| 340 | t == LBM_TYPE_U0x0000000Cu || | ||||||||
| 341 | t == LBM_TYPE_CHAR0x00000004u) { | ||||||||
| 342 | if (lbm_event_handler_pid > 0) { | ||||||||
| 343 | return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0); | ||||||||
| 344 | } | ||||||||
| 345 | } | ||||||||
| 346 | return false0; | ||||||||
| 347 | } | ||||||||
| 348 | |||||||||
| 349 | bool_Bool lbm_event(lbm_flat_value_t *fv) { | ||||||||
| 350 | if (lbm_event_handler_pid > 0) { | ||||||||
| 351 | return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size); | ||||||||
| 352 | } | ||||||||
| 353 | return false0; | ||||||||
| 354 | } | ||||||||
| 355 | |||||||||
| 356 | static bool_Bool lbm_event_pop(lbm_event_t *event) { | ||||||||
| 357 | mutex_lock(&lbm_events_mutex); | ||||||||
| 358 | if (lbm_events_head == lbm_events_tail && !lbm_events_full) { | ||||||||
| 359 | mutex_unlock(&lbm_events_mutex); | ||||||||
| 360 | return false0; | ||||||||
| 361 | } | ||||||||
| 362 | *event = lbm_events[lbm_events_tail]; | ||||||||
| 363 | lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max; | ||||||||
| 364 | lbm_events_full = false0; | ||||||||
| 365 | mutex_unlock(&lbm_events_mutex); | ||||||||
| 366 | return true1; | ||||||||
| 367 | } | ||||||||
| 368 | |||||||||
| 369 | bool_Bool lbm_event_queue_is_empty(void) { | ||||||||
| 370 | mutex_lock(&lbm_events_mutex); | ||||||||
| 371 | bool_Bool empty = false0; | ||||||||
| 372 | if (lbm_events_head == lbm_events_tail && !lbm_events_full) { | ||||||||
| 373 | empty = true1; | ||||||||
| 374 | } | ||||||||
| 375 | mutex_unlock(&lbm_events_mutex); | ||||||||
| 376 | return empty; | ||||||||
| 377 | } | ||||||||
| 378 | |||||||||
| 379 | static bool_Bool eval_running = false0; | ||||||||
| 380 | static volatile bool_Bool blocking_extension = false0; | ||||||||
| 381 | static mutex_t blocking_extension_mutex; | ||||||||
| 382 | static bool_Bool blocking_extension_mutex_initialized = false0; | ||||||||
| 383 | static lbm_uint blocking_extension_timeout_us = 0; | ||||||||
| 384 | static bool_Bool blocking_extension_timeout = false0; | ||||||||
| 385 | |||||||||
| 386 | static uint32_t is_atomic = 0; | ||||||||
| 387 | |||||||||
| 388 | /* Process queues */ | ||||||||
| 389 | static eval_context_queue_t blocked = {NULL((void*)0), NULL((void*)0)}; | ||||||||
| 390 | static eval_context_queue_t queue = {NULL((void*)0), NULL((void*)0)}; | ||||||||
| 391 | |||||||||
| 392 | /* one mutex for all queue operations */ | ||||||||
| 393 | mutex_t qmutex; | ||||||||
| 394 | bool_Bool qmutex_initialized = false0; | ||||||||
| 395 | |||||||||
| 396 | |||||||||
| 397 | // MODES | ||||||||
| 398 | static volatile bool_Bool lbm_verbose = false0; | ||||||||
| 399 | |||||||||
| 400 | void lbm_toggle_verbose(void) { | ||||||||
| 401 | lbm_verbose = !lbm_verbose; | ||||||||
| 402 | } | ||||||||
| 403 | |||||||||
| 404 | void lbm_set_verbose(bool_Bool verbose) { | ||||||||
| 405 | lbm_verbose = verbose; | ||||||||
| 406 | } | ||||||||
| 407 | |||||||||
| 408 | lbm_cid lbm_get_current_cid(void) { | ||||||||
| 409 | if (ctx_running) | ||||||||
| 410 | return ctx_running->id; | ||||||||
| 411 | else | ||||||||
| 412 | return -1; | ||||||||
| 413 | } | ||||||||
| 414 | |||||||||
| 415 | eval_context_t *lbm_get_current_context(void) { | ||||||||
| 416 | return ctx_running; | ||||||||
| 417 | } | ||||||||
| 418 | |||||||||
| 419 | /****************************************************/ | ||||||||
| 420 | /* Utilities used locally in this file */ | ||||||||
| 421 | |||||||||
| 422 | static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) { | ||||||||
| 423 | #ifdef LBM_ALWAYS_GC | ||||||||
| 424 | lbm_value roots[3] = {head, tail, remember}; | ||||||||
| 425 | lbm_gc_mark_roots(roots, 3); | ||||||||
| 426 | gc(); | ||||||||
| 427 | lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail); | ||||||||
| 428 | res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail); | ||||||||
| 429 | if (lbm_is_symbol_merror(res)) { | ||||||||
| 430 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); | ||||||||
| 431 | } | ||||||||
| 432 | return res; | ||||||||
| 433 | #else | ||||||||
| 434 | lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail); | ||||||||
| 435 | if (lbm_is_symbol_merror(res)) { | ||||||||
| 436 | lbm_value roots[3] = {head, tail, remember}; | ||||||||
| 437 | lbm_gc_mark_roots(roots,3); | ||||||||
| 438 | gc(); | ||||||||
| 439 | res = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, head, tail); | ||||||||
| 440 | if (lbm_is_symbol_merror(res)) { | ||||||||
| 441 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); | ||||||||
| 442 | } | ||||||||
| 443 | } | ||||||||
| 444 | return res; | ||||||||
| 445 | #endif | ||||||||
| 446 | } | ||||||||
| 447 | |||||||||
| 448 | static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) { | ||||||||
| 449 | if (n <= ctx->K.sp) { | ||||||||
| 450 | lbm_uint index = ctx->K.sp - n; | ||||||||
| 451 | return &ctx->K.data[index]; | ||||||||
| 452 | } | ||||||||
| 453 | error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u)); | ||||||||
| 454 | return 0; // dead code cannot be reached, but C compiler doesn't realise. | ||||||||
| 455 | } | ||||||||
| 456 | |||||||||
| 457 | // pop_stack_ptr is safe when no GC is performed and | ||||||||
| 458 | // the values of the stack will be dropped. | ||||||||
| 459 | static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) { | ||||||||
| 460 | if (n <= ctx->K.sp) { | ||||||||
| 461 | ctx->K.sp -= n; | ||||||||
| 462 | return &ctx->K.data[ctx->K.sp]; | ||||||||
| 463 | } | ||||||||
| 464 | error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u)); | ||||||||
| 465 | return 0; // dead code cannot be reached, but C compiler doesn't realise. | ||||||||
| 466 | } | ||||||||
| 467 | |||||||||
| 468 | static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) { | ||||||||
| 469 | if (ctx->K.sp + n < ctx->K.size) { | ||||||||
| 470 | lbm_uint *ptr = &ctx->K.data[ctx->K.sp]; | ||||||||
| 471 | ctx->K.sp += n; | ||||||||
| 472 | return ptr; | ||||||||
| 473 | } | ||||||||
| 474 | error_ctx(ENC_SYM_STACK_ERROR(((0x27) << 4) | 0x00000000u)); | ||||||||
| 475 | return 0; // dead code cannot be reached, but C compiler doesn't realise. | ||||||||
| 476 | } | ||||||||
| 477 | |||||||||
| 478 | static void handle_flash_status(lbm_flash_status s) { | ||||||||
| 479 | if ( s == LBM_FLASH_FULL) { | ||||||||
| 480 | lbm_set_error_reason((char*)lbm_error_str_flash_full); | ||||||||
| 481 | error_ctx(ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u)); | ||||||||
| 482 | } | ||||||||
| 483 | if (s == LBM_FLASH_WRITE_ERROR) { | ||||||||
| 484 | lbm_set_error_reason((char*)lbm_error_str_flash_error); | ||||||||
| 485 | error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u)); | ||||||||
| 486 | } | ||||||||
| 487 | } | ||||||||
| 488 | |||||||||
| 489 | static void lift_array_flash(lbm_value flash_cell, bool_Bool bytearray, char *data, lbm_uint num_elt) { | ||||||||
| 490 | |||||||||
| 491 | lbm_array_header_t flash_array_header; | ||||||||
| 492 | flash_array_header.size = num_elt; | ||||||||
| 493 | flash_array_header.data = (lbm_uint*)data; | ||||||||
| 494 | lbm_uint flash_array_header_ptr; | ||||||||
| 495 | handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header, | ||||||||
| 496 | sizeof(lbm_array_header_t) / sizeof(lbm_uint), | ||||||||
| 497 | &flash_array_header_ptr)); | ||||||||
| 498 | handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr)); | ||||||||
| 499 | lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u) : ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u); | ||||||||
| 500 | handle_flash_status(write_const_cdr(flash_cell, t)); | ||||||||
| 501 | } | ||||||||
| 502 | |||||||||
| 503 | static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) { | ||||||||
| 504 | if (lbm_is_ptr(a)) { | ||||||||
| 505 | lbm_cons_t *cell = lbm_ref_cell(a); | ||||||||
| 506 | *a_car = cell->car; | ||||||||
| 507 | *a_cdr = cell->cdr; | ||||||||
| 508 | } else if (lbm_is_symbol_nil(a)) { | ||||||||
| 509 | *a_car = *a_cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | ||||||||
| 510 | } else { | ||||||||
| 511 | error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 512 | } | ||||||||
| 513 | } | ||||||||
| 514 | |||||||||
| 515 | /* car cdr caar cadr replacements that are evaluator safe. */ | ||||||||
| 516 | static lbm_value get_car(lbm_value a) { | ||||||||
| 517 | if (lbm_is_ptr(a)) { | ||||||||
| 518 | lbm_cons_t *cell = lbm_ref_cell(a); | ||||||||
| 519 | return cell->car; | ||||||||
| 520 | } else if (lbm_is_symbol_nil(a)) { | ||||||||
| 521 | return a; | ||||||||
| 522 | } | ||||||||
| 523 | error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 524 | return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 525 | } | ||||||||
| 526 | |||||||||
| 527 | static lbm_value get_cdr(lbm_value a) { | ||||||||
| 528 | if (lbm_is_ptr(a)) { | ||||||||
| 529 | lbm_cons_t *cell = lbm_ref_cell(a); | ||||||||
| 530 | return cell->cdr; | ||||||||
| 531 | } else if (lbm_is_symbol_nil(a)) { | ||||||||
| 532 | return a; | ||||||||
| 533 | } | ||||||||
| 534 | error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 535 | return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 536 | } | ||||||||
| 537 | |||||||||
| 538 | static lbm_value get_cadr(lbm_value a) { | ||||||||
| 539 | if (lbm_is_ptr(a)) { | ||||||||
| 540 | lbm_cons_t *cell = lbm_ref_cell(a); | ||||||||
| 541 | lbm_value tmp = cell->cdr; | ||||||||
| 542 | if (lbm_is_ptr(tmp)) { | ||||||||
| 543 | return lbm_ref_cell(tmp)->car; | ||||||||
| 544 | } else if (lbm_is_symbol_nil(tmp)) { | ||||||||
| 545 | return tmp; | ||||||||
| 546 | } | ||||||||
| 547 | } else if (lbm_is_symbol_nil(a)) { | ||||||||
| 548 | return a; | ||||||||
| 549 | } | ||||||||
| 550 | error_ctx(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 551 | return(ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u)); | ||||||||
| 552 | } | ||||||||
| 553 | |||||||||
| 554 | static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) { | ||||||||
| 555 | |||||||||
| 556 | #ifdef LBM_ALWAYS_GC | ||||||||
| 557 | gc(); | ||||||||
| 558 | if (lbm_heap_num_free() < 4) { | ||||||||
| 559 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); | ||||||||
| 560 | } | ||||||||
| 561 | #else | ||||||||
| 562 | if (lbm_heap_num_free() < 4) { | ||||||||
| 563 | gc(); | ||||||||
| 564 | if (lbm_heap_num_free() < 4) { | ||||||||
| 565 | error_ctx(ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); | ||||||||
| 566 | } | ||||||||
| 567 | } | ||||||||
| 568 | #endif | ||||||||
| 569 | // The freelist will always contain just plain heap-cells. | ||||||||
| 570 | // So dec_ptr is sufficient. | ||||||||
| 571 | lbm_value res = lbm_heap_state.freelist; | ||||||||
| 572 | if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) { | ||||||||
| 573 | lbm_cons_t *heap = lbm_heap_state.heap; | ||||||||
| 574 | lbm_uint ix = lbm_dec_ptr(res); | ||||||||
| 575 | heap[ix].car = ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u); | ||||||||
| 576 | ix = lbm_dec_ptr(heap[ix].cdr); | ||||||||
| 577 | heap[ix].car = params; | ||||||||
| 578 | ix = lbm_dec_ptr(heap[ix].cdr); | ||||||||
| 579 | heap[ix].car = body; | ||||||||
| 580 | ix = lbm_dec_ptr(heap[ix].cdr); | ||||||||
| 581 | heap[ix].car = env; | ||||||||
| 582 | lbm_heap_state.freelist = heap[ix].cdr; | ||||||||
| 583 | heap[ix].cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | ||||||||
| 584 | lbm_heap_state.num_alloc+=4; | ||||||||
| 585 | } else { | ||||||||
| 586 | error_ctx(ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u)); | ||||||||
| 587 | } | ||||||||
| 588 | return res; | ||||||||
| 589 | } | ||||||||
| 590 | |||||||||
| 591 | // Allocate a binding and attach it to a list (if so desired) | ||||||||
| 592 | static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) { | ||||||||
| 593 | if (lbm_heap_num_free() < 2) { | ||||||||
| 594 | 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
| ||||||||
| 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 |