rusefi
/
bldc
mirror of https://github.com/rusefi/bldc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Squashed 'lispBM/lispBM/' changes from b3bdc6ae..f18a5c10 

f18a5c10 some get_cdr + get_car => get_cadr
127ed58b update to extensions. Just aligning some naming
792d9f08 lbmref regenerated
1b01b173 Accepting the setq_local_closure situation. It may be a perfectly ok mode of operation
66f28c18 added shallow env copy function experimentally
84684cc2 added failing test to expected to fail list
ec213f67 some streamlining and a test that illustrates shortcomings from the closure cheats.

git-subtree-dir: lispBM/lispBM
git-subtree-split: f18a5c108fc988e0e69719f343352a4cb91beff2
This commit is contained in:
Benjamin Vedder 2024-04-14 09:14:22 +02:00
parent b3ad9d3f27
commit 58bdeb1d95
7 changed files with 50 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
doc/lbmref.md
View File

@ -5057,7 +5057,7 @@ The `setcar` is a destructive update of the car field of a cons-cell.
```clj
(define apa '(42 . 2))
(define apa '(1 . 2))
(setcar apa 42)
apa
@ -5119,7 +5119,7 @@ The `setcdr` is a destructive update of the cdr field of a cons-cell.
```clj
(define apa '(1 . 42))
(define apa '(1 . 2))
(setcdr apa 42)
apa
@ -5590,7 +5590,7 @@ The `setassoc` function destructively updates a key-value mapping in an alist. T
```clj
(define apa (list '(1 . horse) '(2 . llama) '(3 . shark)))
(define apa (list '(1 . horse) '(2 . donkey) '(3 . shark)))
(setassoc apa 2 'llama)
```
@ -6092,7 +6092,7 @@ To clear a byte array the function bufclear can be used `(bufclear arr optByte o
<td>
```clj
(define data [255 170 170 170 170 170 1 1])
(define data [255 255 255 255 255 255 255 255])
```
@ -6100,7 +6100,7 @@ To clear a byte array the function bufclear can be used `(bufclear arr optByte o
<td>
```clj
[255 170 170 170 170 170 1 1]
[255 255 255 255 255 255 255 255]
```

1
src/env.c
View File

@ -37,6 +37,7 @@ lbm_value *lbm_get_global_env(void) {
return env_global;
}
// Copy the list structure of an environment.
lbm_value lbm_env_copy_spine(lbm_value env) {
lbm_value r = ENC_SYM_MERROR;

42
src/eval_cps.c
View File

@ -1303,8 +1303,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(ctx->program)) {
lbm_value *sptr = stack_reserve(ctx, 1);
sptr[0] = DONE;
stack_reserve(ctx, 1)[0] = DONE;;
get_car_and_cdr(ctx->program, &ctx->curr_exp, &ctx->program);
ctx->curr_env = ENC_SYM_NIL;
} else {
@ -1635,8 +1634,7 @@ static void eval_atomic(eval_context_t *ctx) {
lbm_set_error_reason("Atomic blocks cannot be nested!");
error_ctx(ENC_SYM_EERROR);
}
lbm_value *sptr = stack_reserve(ctx, 1);
sptr[0] = EXIT_ATOMIC;
stack_reserve(ctx, 1)[0] = EXIT_ATOMIC;
is_atomic ++;
eval_progn(ctx);
}
@ -1678,8 +1676,7 @@ static void eval_define(eval_context_t *ctx) {
if (sym_val >= RUNTIME_SYMBOLS_START) {
sptr[1] = SET_GLOBAL_ENV;
if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST) {
lbm_value *sptr2 = stack_reserve(ctx, 1);
sptr2[0] = MOVE_VAL_TO_FLASH_DISPATCH;
stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
}
ctx->curr_exp = parts[VAL];
return;
@ -1702,6 +1699,9 @@ static void eval_define(eval_context_t *ctx) {
However, one can try to write programs in such a way that closures are created
seldomly. If one does that the space-usage benefits of "correct" closures
may outweigh the performance gain of "incorrect" ones.
some obscure programs such as test_setq_local_closure.lisp does not
work properly due to this cheating.
*/
// (lambda param-list body-exp) -> (closure param-list body-exp env)
static void eval_lambda(eval_context_t *ctx) {
@ -2054,7 +2054,7 @@ static void eval_receive_timeout(eval_context_t *ctx) {
lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
error_ctx(ENC_SYM_EERROR);
}
lbm_value timeout_val = get_car(get_cdr(ctx->curr_exp));
lbm_value timeout_val = get_cadr(ctx->curr_exp);
if (!lbm_is_number(timeout_val)) {
error_ctx(ENC_SYM_EERROR);
}
@ -2123,8 +2123,7 @@ static void cont_progn_rest(eval_context_t *ctx) {
lbm_stack_drop(&ctx->K, 3);
} else {
sptr[2] = rest_cdr;
lbm_value *rptr = stack_reserve(ctx, 1);
rptr[0] = PROGN_REST;
stack_reserve(ctx, 1)[0] = PROGN_REST;
}
}
@ -2661,7 +2660,7 @@ static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_uint len = lbm_list_length(cl[CLO_PARAMS]);
if (len == 2) {
par1 = get_car(cl[CLO_PARAMS]);
par2 = get_car(get_cdr(cl[CLO_PARAMS]));
par2 = get_cadr(cl[CLO_PARAMS]);
lbm_value new_env0;
lbm_value new_env;
WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)));
@ -2745,7 +2744,7 @@ static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS]);
if (cl_len == 2) {
par1 = get_car(cl[CLO_PARAMS]);
par2 = get_car(get_cdr(cl[CLO_PARAMS]));
par2 = get_cadr(cl[CLO_PARAMS]);
lbm_value new_env0;
lbm_value new_env;
WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
@ -3787,14 +3786,17 @@ static void cont_read_next_token(eval_context_t *ctx) {
if (n > 0) {
lbm_channel_drop(chan, (unsigned int) n);
lbm_uint symbol_id;
if (lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
res = lbm_enc_sym(symbol_id);
} else {
int r = 0;
if (strncmp(tokpar_sym_str,"ext-",4) == 0) {
if (n > 4 &&
tokpar_sym_str[0] == 'e' &&
tokpar_sym_str[1] == 'x' &&
tokpar_sym_str[2] == 't' &&
tokpar_sym_str[3] == '-') {
lbm_uint ext_id;
lbm_uint ext_name_len = strlen(tokpar_sym_str)+1;
lbm_uint ext_name_len = (lbm_uint)n + 1;
char *ext_name = lbm_malloc(ext_name_len);
if (!ext_name) {
gc();
@ -4536,17 +4538,17 @@ lbm_value append(lbm_value front, lbm_value back) {
if (lbm_is_quoted_list(front) &&
lbm_is_quoted_list(back)) {
lbm_value f = get_car(get_cdr(front));
lbm_value b = get_car(get_cdr(back));
lbm_value f = get_cadr(front);
lbm_value b = get_cadr(back);
return quote_it(lbm_list_append(f, b));
}
if (is_append(back) &&
lbm_is_quoted_list(get_car(get_cdr(back))) &&
lbm_is_quoted_list(get_cadr(back)) &&
lbm_is_quoted_list(front)) {
lbm_value ql = get_car(get_cdr(back));
lbm_value f = get_car(get_cdr(front));
lbm_value b = get_car(get_cdr(ql));
lbm_value ql = get_cadr(back);
lbm_value f = get_cadr(front);
lbm_value b = get_cadr(ql);
lbm_value v = lbm_list_append(f, b);
lbm_set_car(get_cdr(ql), v);

6
src/extensions.c
View File

@ -72,7 +72,7 @@ extension_fptr lbm_get_extension(lbm_uint sym) {
}
bool lbm_clr_extension(lbm_uint sym_id) {
lbm_uint ext_id = sym_id - EXTENSION_SYMBOLS_START;
lbm_uint ext_id = SYMBOL_IX(sym_id);
if (ext_id >= ext_max) {
return false;
}
@ -100,9 +100,9 @@ bool lbm_add_extension(char *sym_str, extension_fptr ext) {
if (lbm_get_symbol_by_name(sym_str, &symbol)) {
if (lbm_is_extension(lbm_enc_sym(symbol))) {
// update the extension entry.
if (str_eq(extension_table[symbol - EXTENSION_SYMBOLS_START].name, sym_str)) {
if (str_eq(extension_table[SYMBOL_IX(symbol)].name, sym_str)) {
// Do not replace name ptr.
extension_table[symbol - EXTENSION_SYMBOLS_START].fptr = ext;
extension_table[SYMBOL_IX(symbol)].fptr = ext;
return true;
}
}

14
src/heap.c
View File

@ -513,31 +513,19 @@ lbm_uint lbm_heap_num_free(void) {
}
lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr) {
lbm_value res;
// it is a ptr replace freelist with cdr of freelist;
res = lbm_heap_state.freelist;
if (lbm_type_of(res) == LBM_TYPE_CONS) {
lbm_uint heap_ix = lbm_dec_ptr(res);
//lbm_cons_t *rc = lbm_ref_cell(res);
lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
lbm_heap_state.num_alloc++;
lbm_heap_state.heap[heap_ix].car = car;
lbm_heap_state.heap[heap_ix].cdr = cdr;
res = lbm_set_ptr_type(res, ptr_type);
return res;
}
else if ((lbm_type_of(res) == LBM_TYPE_SYMBOL) &&
(lbm_dec_sym(res) == SYM_NIL)) {
// all is as it should be (but no free cells)
return ENC_SYM_MERROR;
}
// Unreachable, unless something very wrong
return ENC_SYM_FATAL_ERROR;
return ENC_SYM_MERROR;
}
lbm_value lbm_heap_allocate_list(lbm_uint n) {

2
tests/run_tests.sh
View File

@ -22,7 +22,7 @@ expected_fails=("test_lisp_code_cps -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -i -s -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -i -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -i -s -h 512 test_take_iota_0.lisp"
)
)
success_count=0

17
tests/test_setq_local_closure.lisp Normal file
View File

@ -0,0 +1,17 @@
;; (a 10) is similar to a global but only global to the two functions
;; created in the let.
;; This may be a bit strange. But strangeness only observable through
;; imperative updates.
(define funs (let ( ( a 10) )
(list (lambda (x) { (setq a x) a})
(lambda () a))))
(define f (car funs))
(define g (car (cdr funs)))
(f 20)
(check (= (g) 20))