diff --git a/lispBM/lispBM/examples/evaluator.c b/lispBM/lispBM/examples/evaluator.c index e07e342c..9ee45fe1 100644 --- a/lispBM/lispBM/examples/evaluator.c +++ b/lispBM/lispBM/examples/evaluator.c @@ -250,7 +250,7 @@ int main(int argc, char **argv) { sleep_callback(10); } - cid = lbm_load_and_eval_program(&string_tok); + cid = lbm_load_and_eval_program(&string_tok,NULL); lbm_continue_eval(); diff --git a/lispBM/lispBM/include/eval_cps.h b/lispBM/lispBM/include/eval_cps.h index 9de91bbe..8c5fbe76 100644 --- a/lispBM/lispBM/include/eval_cps.h +++ b/lispBM/lispBM/include/eval_cps.h @@ -39,7 +39,7 @@ extern "C" { #define EVAL_CPS_CONTEXT_FLAG_TRAP (uint32_t)0x1 #define EVAL_CPS_CONTEXT_FLAG_CONST (uint32_t)0x2 #define EVAL_CPS_CONTEXT_FLAG_CONST_SYMBOL_STRINGS (uint32_t)0x4 -#define EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ (uint32_t)0x5 +#define EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ (uint32_t)0x8 /** The eval_context_t struct represents a lispbm process. * diff --git a/lispBM/lispBM/include/heap.h b/lispBM/lispBM/include/heap.h index 311f4ed2..fc9f536d 100644 --- a/lispBM/lispBM/include/heap.h +++ b/lispBM/lispBM/include/heap.h @@ -691,7 +691,7 @@ extern lbm_value lbm_enc_u32(uint32_t x); * \param x float value to encode. * \return result encoded value. */ -extern lbm_value lbm_enc_float(lbm_float x); +extern lbm_value lbm_enc_float(float x); /** Encode a 64 bit integer into an lbm_value. * \param x 64 bit integer to encode. diff --git a/lispBM/lispBM/include/lbm_defines.h b/lispBM/lispBM/include/lbm_defines.h index ccd3faa2..9c3b17ef 100644 --- a/lispBM/lispBM/include/lbm_defines.h +++ b/lispBM/lispBM/include/lbm_defines.h @@ -60,6 +60,7 @@ #define LBM_POINTER_TYPE_FIRST (lbm_uint)0x1000000000000000 #define LBM_TYPE_CONS (lbm_uint)0x1000000000000000 +#define LBM_TYPE_CONS_CONST (lbm_uint)0x1400000000000000 #define LBM_NON_CONS_POINTER_TYPE_FIRST (lbm_uint)0x2000000000000000 #define LBM_TYPE_U64 (lbm_uint)0x2800000000000000 #define LBM_TYPE_I64 (lbm_uint)0x3800000000000000 diff --git a/lispBM/lispBM/repl/repl.c b/lispBM/lispBM/repl/repl.c index 41728afb..87b24bc6 100644 --- a/lispBM/lispBM/repl/repl.c +++ b/lispBM/lispBM/repl/repl.c @@ -55,6 +55,24 @@ lbm_value variable_storage[VARIABLE_STORAGE_SIZE]; lbm_uint constants_memory[CONSTANT_MEMORY_SIZE]; lbm_prof_t prof_data[100]; +static lbm_uint sym_res; +static lbm_uint sym_loop; +static lbm_uint sym_break; +static lbm_uint sym_brk; +static lbm_uint sym_rst; +static lbm_uint sym_return; + +static lbm_value make_list(int num, ...) { + va_list arguments; + va_start (arguments, num); + lbm_value res = ENC_SYM_NIL; + for (int i = 0; i < num; i++) { + res = lbm_cons(va_arg(arguments, lbm_value), res); + } + va_end (arguments); + return lbm_list_destructive_reverse(res); +} + bool const_heap_write(lbm_uint ix, lbm_uint w) { if (ix >= CONSTANT_MEMORY_SIZE) return false; if (constants_memory[ix] == 0xffffffff) { @@ -276,10 +294,95 @@ bool dyn_load(const char *str, const char **code) { *code = "(define foldl (lambda (f i xs)" "(if (eq xs nil) i (foldl f (f i (car xs)) (cdr xs)))))"; res = true; + } else if (strncmp(str, "loopforeach", 11) == 0) { + *code = "(define loopforeach (macro (it lst body) (me-loopforeach it lst body)))"; + res = true; + } else if (strncmp(str, "looprange", 9) == 0) { + *code = "(define looprange (macro (it start end body) (me-looprange it start end body)))"; + res = true; } + return res; } +static lbm_value ext_me_loopforeach(lbm_value *args, lbm_uint argn) { + if (argn != 3) { + return ENC_SYM_EERROR; + } + + lbm_value it = args[0]; + lbm_value lst = args[1]; + lbm_value body = args[2]; + + // (let ((loop (lambda (it rst res break) (if (eq it nil) res (loop (car rst) (cdr rst) body break))))) (call-cc (lambda (brk) (loop (car lst) (cdr lst) nil brk)))) + + return make_list(3, + lbm_enc_sym(SYM_LET), + make_list(1, + make_list(2, + lbm_enc_sym(sym_loop), + make_list(3, + lbm_enc_sym(SYM_LAMBDA), + make_list(4, it, lbm_enc_sym(sym_rst), lbm_enc_sym(sym_res), lbm_enc_sym(sym_break)), + make_list(4, + lbm_enc_sym(SYM_IF), + make_list(3, lbm_enc_sym(SYM_EQ), it, ENC_SYM_NIL), + lbm_enc_sym(sym_res), + make_list(5, + lbm_enc_sym(sym_loop), + make_list(2, lbm_enc_sym(SYM_CAR), lbm_enc_sym(sym_rst)), + make_list(2, lbm_enc_sym(SYM_CDR), lbm_enc_sym(sym_rst)), + body, + lbm_enc_sym(sym_break)) + )))), + make_list(2, + lbm_enc_sym(SYM_CALLCC), + make_list(3, + lbm_enc_sym(SYM_LAMBDA), + make_list(1, lbm_enc_sym(sym_brk)), + make_list(5, + lbm_enc_sym(sym_loop), + make_list(2, lbm_enc_sym(SYM_CAR), lst), + make_list(2, lbm_enc_sym(SYM_CDR), lst), + ENC_SYM_NIL, + lbm_enc_sym(sym_brk))))); +} + +static lbm_value ext_me_looprange(lbm_value *args, lbm_uint argn) { + if (argn != 4) { + return ENC_SYM_EERROR; + } + + lbm_value it = args[0]; + lbm_value start = args[1]; + lbm_value end = args[2]; + lbm_value body = args[3]; + + // (let ((loop (lambda (it res break) (if (< it end) (loop (+ it 1) body break) res)))) (call-cc (lambda (brk) (loop start nil brk)))) + + return make_list(3, + lbm_enc_sym(SYM_LET), + make_list(1, + make_list(2, + lbm_enc_sym(sym_loop), + make_list(3, + lbm_enc_sym(SYM_LAMBDA), + make_list(3, it, lbm_enc_sym(sym_res), lbm_enc_sym(sym_break)), + make_list(4, + lbm_enc_sym(SYM_IF), + make_list(3, lbm_enc_sym(SYM_LT), it, end), + make_list(4, lbm_enc_sym(sym_loop), make_list(3, lbm_enc_sym(SYM_ADD), it, lbm_enc_i(1)), body, lbm_enc_sym(sym_break)), + lbm_enc_sym(sym_res))))), + make_list(2, + lbm_enc_sym(SYM_CALLCC), + make_list(3, + lbm_enc_sym(SYM_LAMBDA), + make_list(1, lbm_enc_sym(sym_brk)), + make_list(4, lbm_enc_sym(sym_loop), start, ENC_SYM_NIL, lbm_enc_sym(sym_brk))))); +} + + + lbm_value ext_block(lbm_value *args, lbm_uint argn) { printf("blocking CID: %d\n", (int32_t)lbm_get_current_cid()); @@ -592,6 +695,25 @@ int main(int argc, char **argv) { else printf("Error adding extension.\n"); + res = lbm_add_extension("me-loopforeach", ext_me_loopforeach); + if (res) + printf("Extension added.\n"); + else + printf("Error adding extension.\n"); + + res = lbm_add_extension("me-looprange", ext_me_looprange); + if (res) + printf("Extension added.\n"); + else + printf("Error adding extension.\n"); + + lbm_add_symbol_const("a01", &sym_res); + lbm_add_symbol_const("a02", &sym_loop); + lbm_add_symbol_const("break", &sym_break); + lbm_add_symbol_const("a03", &sym_brk); + lbm_add_symbol_const("a04", &sym_rst); + lbm_add_symbol_const("return", &sym_return); + /* Start evaluator thread */ if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) { printf("Error creating evaluation thread\n"); diff --git a/lispBM/lispBM/src/eval_cps.c b/lispBM/lispBM/src/eval_cps.c index a6173e1a..daf2b7e3 100644 --- a/lispBM/lispBM/src/eval_cps.c +++ b/lispBM/lispBM/src/eval_cps.c @@ -119,7 +119,6 @@ const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash const char* lbm_error_str_flash_error = "Error writing to flash"; const char* lbm_error_str_flash_full = "Flash memory is full"; - #define WITH_GC(y, x) \ (y) = (x); \ if (lbm_is_symbol_merror((y))) { \ @@ -1239,7 +1238,6 @@ static void advance_ctx(eval_context_t *ctx) { stack_push(&ctx->K, DONE); get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program); ctx->curr_env = ENC_SYM_NIL; - ctx->app_cont = false; } else { if (ctx_running == ctx) { // This should always be the case because of odd historical reasons. ok_ctx(); @@ -1609,7 +1607,6 @@ static void eval_callcc(eval_context_t *ctx) { acont), acont); ctx->curr_exp = app; - ctx->app_cont = false; } // (define sym exp) @@ -2531,7 +2528,6 @@ static void cont_closure_application_args(eval_context_t *ctx) { lbm_stack_drop(&ctx->K, 5); ctx->curr_env = clo_env; ctx->curr_exp = exp; - ctx->app_cont = false; } else if (!a_nil && p_nil) { // Application with extra arguments lbm_set_error_reason((char*)lbm_error_str_num_args); @@ -3361,7 +3357,6 @@ static void cont_read_eval_continue(eval_context_t *ctx) { stack_push_3(&ctx->K, stream, env, READ_EVAL_CONTINUE); stack_push_3(&ctx->K, stream, lbm_enc_u(1), READ_NEXT_TOKEN); - ctx->app_cont = false; ctx->curr_env = env; ctx->curr_exp = ctx->r; } @@ -3498,7 +3493,6 @@ static void cont_application_start(eval_context_t *ctx) { // No param closure ctx->curr_exp = cl[CLO_BODY]; ctx->curr_env = cl[CLO_ENV]; - ctx->app_cont = false; } else { ctx->app_cont = true; } @@ -3511,7 +3505,6 @@ static void cont_application_start(eval_context_t *ctx) { reserved[3] = CLOSURE_ARGS; ctx->curr_exp = arg0; ctx->curr_env = arg_env; - ctx->app_cont = false; } } break; case ENC_SYM_CONT:{ @@ -3545,7 +3538,6 @@ static void cont_application_start(eval_context_t *ctx) { memcpy(ctx->K.data, arr->data, arr->size); ctx->curr_exp = arg; - ctx->app_cont = false; break; } case ENC_SYM_MACRO:{ @@ -3582,8 +3574,6 @@ static void cont_application_start(eval_context_t *ctx) { lbm_value exp = get_cadr(get_cdr(ctx->r)); ctx->curr_exp = exp; ctx->curr_env = expand_env; - - ctx->app_cont = false; } break; default: error_ctx(ENC_SYM_EERROR); @@ -3598,7 +3588,6 @@ static void cont_eval_r(eval_context_t* ctx) { lbm_pop(&ctx->K, &env); ctx->curr_exp = ctx->r; ctx->curr_env = env; - ctx->app_cont = false; } /* progn + var stack diff --git a/lispBM/lispBM/src/fundamental.c b/lispBM/lispBM/src/fundamental.c index d269fb02..39c8a429 100644 --- a/lispBM/lispBM/src/fundamental.c +++ b/lispBM/lispBM/src/fundamental.c @@ -265,8 +265,12 @@ static lbm_value assoc_lookup(lbm_value key, lbm_value assoc) { lbm_value curr = assoc; while (lbm_is_cons(curr)) { lbm_value c = lbm_ref_cell(curr)->car; - if (struct_eq(lbm_ref_cell(c)->car, key)) { - return lbm_ref_cell(c)->cdr; + if (lbm_is_cons(c)) { + if (struct_eq(lbm_ref_cell(c)->car, key)) { + return lbm_ref_cell(c)->cdr; + } + } else { + return ENC_SYM_EERROR; } curr = lbm_ref_cell(curr)->cdr; } @@ -277,8 +281,12 @@ static lbm_value cossa_lookup(lbm_value key, lbm_value assoc) { lbm_value curr = assoc; while (lbm_is_cons(curr)) { lbm_value c = lbm_ref_cell(curr)->car; - if (struct_eq(lbm_ref_cell(c)->cdr, key)) { - return lbm_ref_cell(c)->car; + if (lbm_is_cons(c)) { + if (struct_eq(lbm_ref_cell(c)->cdr, key)) { + return lbm_ref_cell(c)->car; + } + } else { + return ENC_SYM_EERROR; } curr = lbm_ref_cell(curr)->cdr; } diff --git a/lispBM/lispBM/src/heap.c b/lispBM/lispBM/src/heap.c index 1f492fb9..411cc578 100644 --- a/lispBM/lispBM/src/heap.c +++ b/lispBM/lispBM/src/heap.c @@ -79,7 +79,7 @@ lbm_value lbm_enc_u32(uint32_t x) { #endif } -lbm_value lbm_enc_float(lbm_float x) { +lbm_value lbm_enc_float(float x) { #ifndef LBM64 lbm_uint t; memcpy(&t, &x, sizeof(lbm_float)); @@ -87,8 +87,8 @@ lbm_value lbm_enc_float(lbm_float x) { if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f; return lbm_set_ptr_type(f, LBM_TYPE_FLOAT); #else - uint32_t t; - memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/ + lbm_uint t = 0; + memcpy(&t, &x, sizeof(float)); return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT; #endif } diff --git a/lispBM/lispBM/tests/test_progn_var_5.lisp b/lispBM/lispBM/tests/test_progn_var_5.lisp new file mode 100644 index 00000000..49d047d1 --- /dev/null +++ b/lispBM/lispBM/tests/test_progn_var_5.lisp @@ -0,0 +1,9 @@ + +(defun f (x) { + (var a 10) + (var b 20) + (var a 100) + (+ a b x) + }) + +(check (= (f 1) 121)) diff --git a/lispBM/lispBM/tests/test_setq_3.lisp b/lispBM/lispBM/tests/test_setq_3.lisp new file mode 100644 index 00000000..e454792d --- /dev/null +++ b/lispBM/lispBM/tests/test_setq_3.lisp @@ -0,0 +1,16 @@ + +(def x 1) +(def y 2) +(def z 3) + +(defun f (x y z) { + (setq x 10) + (setq y 20) + (setq z 30) + (+ x y z) + }) + +(check (and (= (f 0 0 0) 60) + (= x 1) + (= y 2) + (= z 3))) diff --git a/lispBM/lispBM/tests/test_setq_4.lisp b/lispBM/lispBM/tests/test_setq_4.lisp new file mode 100644 index 00000000..887b84b3 --- /dev/null +++ b/lispBM/lispBM/tests/test_setq_4.lisp @@ -0,0 +1,8 @@ + +(defun f (x) { + (var a 10) + (setq a 100) + (+ x a) + }) + +(check (= (f 1) 101))