From 319bae781aee272fec5df3a68806e5411d7ffb61 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Thu, 6 Apr 2023 20:33:01 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 3fc70a5c..99c9dbf5 99c9dbf5 assoc/cossa fix and refactoring/renaming of internal funktions git-subtree-dir: lispBM/lispBM git-subtree-split: 99c9dbf5c450eea8eeb6325bbdbfdf56929abc5e --- include/heap.h | 10 +++---- src/eval_cps.c | 52 ++++++++++++++++----------------- src/fundamental.c | 19 ++++++------ src/heap.c | 18 ++++++------ tests/test_assoc_4.lisp | 10 +++++++ tests/test_move_to_flash_4.lisp | 8 +++++ 6 files changed, 68 insertions(+), 49 deletions(-) create mode 100644 tests/test_assoc_4.lisp create mode 100644 tests/test_move_to_flash_4.lisp diff --git a/include/heap.h b/include/heap.h index 0b50288f..36d455f0 100644 --- a/include/heap.h +++ b/include/heap.h @@ -767,11 +767,11 @@ static inline bool lbm_is_ptr(lbm_value x) { return (x & LBM_PTR_MASK); } -static inline bool lbm_is_cons(lbm_value x) { +static inline bool lbm_is_cons_rw(lbm_value x) { return (lbm_type_of(x) == LBM_TYPE_CONS); } -static inline bool lbm_is_cons_general(lbm_value x) { +static inline bool lbm_is_cons(lbm_value x) { lbm_type t = lbm_type_of(x); return (t == LBM_TYPE_CONS || t == (LBM_TYPE_CONS | LBM_PTR_TO_CONSTANT_BIT)); @@ -811,7 +811,7 @@ static inline bool lbm_is_special(lbm_value symrep) { } static inline bool lbm_is_closure(lbm_value exp) { - return ((lbm_is_cons_general(exp)) && + return ((lbm_is_cons(exp)) && (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL) && (lbm_dec_sym(lbm_car(exp)) == SYM_CLOSURE)); } @@ -865,8 +865,8 @@ static inline bool lbm_is_list(lbm_value x) { return (lbm_is_cons(x) || lbm_is_symbol_nil(x)); } -static inline bool lbm_is_list_general(lbm_value x) { - return (lbm_is_cons_general(x) || lbm_is_symbol_nil(x)); +static inline bool lbm_is_list_rw(lbm_value x) { + return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x)); } static inline bool lbm_is_quoted_list(lbm_value x) { diff --git a/src/eval_cps.c b/src/eval_cps.c index 5ee21420..7d9c7c3f 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -830,7 +830,7 @@ static void yield_ctx(lbm_uint sleep_us) { static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags) { - if (!lbm_is_cons_general(program)) return -1; + if (!lbm_is_cons(program)) return -1; eval_context_t *ctx = NULL; ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t)); @@ -947,7 +947,7 @@ static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) { /* Advance execution to the next expression in the program */ static void advance_ctx(eval_context_t *ctx) { - if (lbm_is_cons_general(ctx->program)) { + if (lbm_is_cons(ctx->program)) { lbm_push(&ctx->K, DONE); ctx->curr_exp = lbm_car(ctx->program); ctx->curr_env = ENC_SYM_NIL; @@ -1093,8 +1093,8 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) { if (lbm_dec_sym(p) == SYM_DONTCARE) return true; return (p == e); } - if (lbm_is_cons_general(p) && - lbm_is_cons_general(e) ) { + if (lbm_is_cons(p) && + lbm_is_cons(e) ) { lbm_value headp = lbm_car(p); lbm_value heade = lbm_car(e); @@ -1113,7 +1113,7 @@ static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value bool gc = false; for (int i = 0; i < (int)num; i ++ ) { lbm_value curr_e = earr[i]; - while (lbm_is_cons_general(curr_p)) { + while (lbm_is_cons(curr_p)) { lbm_value me = lbm_car(curr_p); if (match(lbm_car(me), curr_e, env, &gc)) { if (gc) return FM_NEED_GC; @@ -1293,7 +1293,7 @@ static void eval_progn(eval_context_t *ctx) { lbm_value exps = lbm_cdr(ctx->curr_exp); lbm_value env = ctx->curr_env; - if (lbm_is_cons_general(exps)) { + if (lbm_is_cons(exps)) { lbm_uint *sptr = lbm_stack_reserve(&ctx->K, 4); if (!sptr) { error_ctx(ENC_SYM_STACK_ERROR); @@ -1495,7 +1495,7 @@ static int create_binding_location(lbm_value key, lbm_value *env) { return BL_NO_MEMORY; } *env = new_env_tmp; - } else if (lbm_is_cons_general(key)) { // deconstruct case + } else if (lbm_is_cons(key)) { // deconstruct case int r = create_binding_location(lbm_car(key), env); if (r == BL_OK) { r = create_binding_location(lbm_cdr(key), env); @@ -1513,14 +1513,14 @@ static void eval_let(eval_context_t *ctx) { lbm_value curr = binds; lbm_value new_env = orig_env; - if (!lbm_is_cons_general(binds)) { + if (!lbm_is_cons(binds)) { // binds better be nil or there is a programmer error. ctx->curr_exp = exp; return; } // Implements letrec by "preallocating" the key parts - while (lbm_is_cons_general(curr)) { + while (lbm_is_cons(curr)) { lbm_value new_env_tmp = new_env; lbm_value key = lbm_caar(curr); int r = create_binding_location(key, &new_env_tmp); @@ -1876,7 +1876,7 @@ static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ct lbm_value curr_param = params; lbm_uint i = closure_pos + 1; - while (lbm_is_cons_general(curr_param) && + while (lbm_is_cons(curr_param) && i <= nargs) { lbm_value entry; @@ -1970,7 +1970,7 @@ static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t * } else { new_prg = lbm_list_append(prg_copy, ctx->program); } - if (!lbm_is_list_general(new_prg)) { + if (!lbm_is_list(new_prg)) { error_ctx(ENC_SYM_EERROR); return; } @@ -2021,7 +2021,7 @@ static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { } static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { - if (nargs == 2 && lbm_is_list_general(args[1])) { + if (nargs == 2 && lbm_is_list(args[1])) { if (lbm_is_symbol_nil(args[1])) { lbm_stack_drop(&ctx->K, 3); ctx->r = ENC_SYM_NIL; @@ -2089,11 +2089,11 @@ static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { } static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { - if (nargs == 1 && lbm_is_list_general(args[0])) { + if (nargs == 1 && lbm_is_list(args[0])) { lbm_value curr = args[0]; lbm_value new_list = ENC_SYM_NIL; - while (lbm_is_cons_general(curr)) { + while (lbm_is_cons(curr)) { lbm_value tmp; WITH_GC_RMBR(tmp, lbm_cons(lbm_car(curr), new_list), 1, new_list); new_list = tmp; @@ -2231,7 +2231,7 @@ static void cont_closure_application_args(eval_context_t *ctx) { lbm_value params = (lbm_value)sptr[3]; lbm_value args = (lbm_value)sptr[4]; - if (lbm_is_cons_general(params)) { + if (lbm_is_cons(params)) { lbm_value ls; WITH_GC(ls, lbm_heap_allocate_list(2)); lbm_value entry = ls; @@ -2308,7 +2308,7 @@ static void cont_application_args(eval_context_t *ctx) { error_ctx(ENC_SYM_FATAL_ERROR); return; } - } else if (lbm_is_cons_general(rest)) { + } else if (lbm_is_cons(rest)) { sptr[1] = env; sptr[2] = lbm_enc_u(lbm_dec_u(count) + 1); CHECK_STACK(lbm_push_2(&ctx->K,lbm_cdr(rest), APPLICATION_ARGS)); @@ -2353,8 +2353,8 @@ static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) if (key == ENC_SYM_DONTCARE) return FB_OK; lbm_env_modify_binding(env,key,value); return FB_OK; - } else if (lbm_is_cons_general(key) && - lbm_is_cons_general(value)) { + } else if (lbm_is_cons(key) && + lbm_is_cons(value)) { int r = fill_binding_location(lbm_car(key), lbm_car(value), env); if (r == FB_OK) { r = fill_binding_location(lbm_cdr(key), lbm_cdr(value), env); @@ -2381,7 +2381,7 @@ static void cont_bind_to_key_rest(eval_context_t *ctx) { return; } - if (lbm_is_cons_general(rest)) { + if (lbm_is_cons(rest)) { lbm_value keyn = lbm_caar(rest); lbm_value valn_exp = lbm_cadr(lbm_car(rest)); @@ -2471,7 +2471,7 @@ static void cont_match(eval_context_t *ctx) { /* no more patterns */ ctx->r = ENC_SYM_NO_MATCH; ctx->app_cont = true; - } else if (lbm_is_cons_general(patterns)) { + } else if (lbm_is_cons(patterns)) { lbm_value match_case = lbm_car(patterns); lbm_value pattern = lbm_car(match_case); lbm_value n1 = lbm_cadr(match_case); @@ -2544,7 +2544,7 @@ static void cont_map_first(eval_context_t *ctx) { CONS_WITH_GC(elt, ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); sptr[2] = elt; // head of result list sptr[3] = elt; // tail of result list - if (lbm_is_cons_general(ls)) { + if (lbm_is_cons(ls)) { lbm_value rest = lbm_cdr(ls); lbm_value next = lbm_car(ls); sptr[0] = rest; @@ -2574,7 +2574,7 @@ static void cont_map_rest(eval_context_t *ctx) { CONS_WITH_GC(elt, ctx->r, ENC_SYM_NIL, ENC_SYM_NIL); lbm_set_cdr(t, elt); sptr[3] = elt; // update tail of result list. - if (lbm_is_cons_general(ls)) { + if (lbm_is_cons(ls)) { lbm_value rest = lbm_cdr(ls); lbm_value next = lbm_car(ls); sptr[0] = rest; @@ -3146,7 +3146,7 @@ static void cont_read_dot_terminate(eval_context_t *ctx) { done_reading(ctx->id); return; } else { - if (lbm_is_cons_general(last_cell)) { + if (lbm_is_cons(last_cell)) { lbm_set_cdr(last_cell, ctx->r); ctx->r = first_cell; CHECK_STACK(lbm_push_3(&ctx->K, @@ -3243,7 +3243,7 @@ static void cont_application_start(eval_context_t *ctx) { } lbm_value args = (lbm_value)sptr[1]; - if (lbm_is_cons_general(ctx->r)) { + if (lbm_is_cons(ctx->r)) { switch (lbm_car(ctx->r)) { case ENC_SYM_MACRO:{ /* @@ -3257,8 +3257,8 @@ static void cont_application_start(eval_context_t *ctx) { lbm_value curr_param = lbm_cadr(ctx->r); lbm_value curr_arg = args; lbm_value expand_env = env; - while (lbm_is_cons_general(curr_param) && - lbm_is_cons_general(curr_arg)) { + while (lbm_is_cons(curr_param) && + lbm_is_cons(curr_arg)) { lbm_value entry; WITH_GC_RMBR(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), 1, expand_env); diff --git a/src/fundamental.c b/src/fundamental.c index 0ae32e35..9310e054 100644 --- a/src/fundamental.c +++ b/src/fundamental.c @@ -249,12 +249,12 @@ static lbm_value index_list(lbm_value l, int32_t n) { if (n < 0) return ENC_SYM_NIL; } - while (lbm_is_cons_general(curr) && + while (lbm_is_cons(curr) && n > 0) { curr = lbm_cdr(curr); n --; } - if (lbm_is_cons_general(curr)) { + if (lbm_is_cons(curr)) { return lbm_car(curr); } else { return ENC_SYM_NIL; @@ -263,7 +263,7 @@ static lbm_value index_list(lbm_value l, int32_t n) { static lbm_value assoc_lookup(lbm_value key, lbm_value assoc) { lbm_value curr = assoc; - while (lbm_is_cons_general(curr)) { + 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; @@ -275,7 +275,7 @@ static lbm_value assoc_lookup(lbm_value key, lbm_value assoc) { static lbm_value cossa_lookup(lbm_value key, lbm_value assoc) { lbm_value curr = assoc; - while (lbm_is_cons_general(curr)) { + 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; @@ -613,7 +613,7 @@ static lbm_value fundamental_cons(lbm_value *args, lbm_uint nargs, eval_context_ static lbm_value fundamental_car(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; if (nargs == 1) { - if (lbm_is_cons_general(args[0])) { + if (lbm_is_cons(args[0])) { lbm_cons_t *cell = lbm_ref_cell(args[0]); return cell->car; } @@ -624,7 +624,7 @@ static lbm_value fundamental_car(lbm_value *args, lbm_uint nargs, eval_context_t static lbm_value fundamental_cdr(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; if (nargs == 1) { - if (lbm_is_cons_general(args[0])) { + if (lbm_is_cons(args[0])) { lbm_cons_t *cell = lbm_ref_cell(args[0]); return cell->cdr; } @@ -646,12 +646,12 @@ static lbm_value fundamental_list(lbm_value *args, lbm_uint nargs, eval_context_ static lbm_value fundamental_append(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; if (nargs == 0) return ENC_SYM_NIL; - if (nargs == 1 && !lbm_is_list_general(args[0])) return ENC_SYM_TERROR; + if (nargs == 1 && !lbm_is_list(args[0])) return ENC_SYM_TERROR; lbm_value res = args[nargs-1]; for (int i = (int)nargs -2; i >= 0; i --) { lbm_value curr = args[i]; - if (!lbm_is_list_general(curr)) return ENC_SYM_TERROR; + if (!lbm_is_list(curr)) return ENC_SYM_TERROR; int n = 0; while (lbm_type_of_functional(curr) == LBM_TYPE_CONS) { n++; @@ -665,6 +665,7 @@ static lbm_value fundamental_append(lbm_value *args, lbm_uint nargs, eval_contex return(res); } +// TODO: See if trouble static lbm_value fundamental_undefine(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; lbm_value env = lbm_get_env(); @@ -1128,7 +1129,7 @@ static lbm_value fundamental_type_of(lbm_value *args, lbm_uint nargs, eval_conte static lbm_value fundamental_list_length(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; lbm_value result = ENC_SYM_EERROR; - if (nargs == 1 && lbm_is_list_general(args[0])) { + if (nargs == 1 && lbm_is_list(args[0])) { int32_t len = (int32_t)lbm_list_length(args[0]); result = lbm_enc_i(len); } diff --git a/src/heap.c b/src/heap.c index 499029a0..e8646f7c 100644 --- a/src/heap.c +++ b/src/heap.c @@ -862,7 +862,7 @@ int lbm_set_car(lbm_value c, lbm_value v) { int lbm_set_cdr(lbm_value c, lbm_value v) { int r = 0; - if (lbm_type_of(c) == LBM_TYPE_CONS){ + if (lbm_is_cons_rw(c)){ lbm_cons_t *cell = lbm_ref_cell(c); cell->cdr = v; r = 1; @@ -872,7 +872,7 @@ int lbm_set_cdr(lbm_value c, lbm_value v) { int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) { int r = 0; - if (lbm_type_of(c) == LBM_TYPE_CONS) { + if (lbm_is_cons_rw(c)) { lbm_cons_t *cell = lbm_ref_cell(c); cell->car = car_val; cell->cdr = cdr_val; @@ -885,7 +885,7 @@ int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) { unsigned int lbm_list_length(lbm_value c) { unsigned int len = 0; - while (lbm_is_cons_general(c)){ + while (lbm_is_cons(c)){ len ++; c = lbm_cdr(c); } @@ -898,7 +898,7 @@ unsigned int lbm_list_length_pred(lbm_value c, bool *pres, bool (*pred)(lbm_valu bool res = true; unsigned int len = 0; - while (lbm_type_of(c) == LBM_TYPE_CONS){ + while (lbm_is_cons(c)){ len ++; res = res && pred(lbm_car(c)); c = lbm_cdr(c); @@ -916,7 +916,7 @@ lbm_value lbm_list_reverse(lbm_value list) { lbm_value curr = list; lbm_value new_list = ENC_SYM_NIL; - while (lbm_is_cons_general(curr)) { + while (lbm_is_cons(curr)) { new_list = lbm_cons(lbm_car(curr), new_list); if (lbm_type_of(new_list) == LBM_TYPE_SYMBOL) { @@ -934,7 +934,7 @@ lbm_value lbm_list_destructive_reverse(lbm_value list) { lbm_value curr = list; lbm_value last_cell = ENC_SYM_NIL; - while (lbm_type_of(curr) == LBM_TYPE_CONS) { + while (lbm_is_cons_rw(curr)) { lbm_value next = lbm_cdr(curr); lbm_set_cdr(curr, last_cell); last_cell = curr; @@ -949,7 +949,7 @@ lbm_value lbm_list_copy(lbm_value list) { lbm_value curr = list; - while (lbm_is_cons_general(curr)) { + while (lbm_is_cons(curr)) { lbm_value c = lbm_cons (lbm_car(curr), res); if (lbm_type_of(c) == LBM_TYPE_SYMBOL) { return ENC_SYM_MERROR; @@ -965,8 +965,8 @@ lbm_value lbm_list_copy(lbm_value list) { // Destructive update of list1. lbm_value lbm_list_append(lbm_value list1, lbm_value list2) { - if(lbm_is_list(list1) && - lbm_is_list_general(list2)) { + if(lbm_is_list_rw(list1) && + lbm_is_list(list2)) { lbm_value curr = list1; while(lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_CONS) { diff --git a/tests/test_assoc_4.lisp b/tests/test_assoc_4.lisp new file mode 100644 index 00000000..ab04d180 --- /dev/null +++ b/tests/test_assoc_4.lisp @@ -0,0 +1,10 @@ +(def a '( + (test1 . 1) + (test2 . 2) + (test3 . 3) +)) + +(move-to-flash a) + +(check (and (eq (assoc a 'test2) 2) + (eq (cossa a 3) 'test3))) diff --git a/tests/test_move_to_flash_4.lisp b/tests/test_move_to_flash_4.lisp new file mode 100644 index 00000000..c9764666 --- /dev/null +++ b/tests/test_move_to_flash_4.lisp @@ -0,0 +1,8 @@ +(defun test (a b) + (cond + ((= a 0) a) + (t b) +)) + +(move-to-flash test) +(check (= (test 10 2) 2))