mirror of https://github.com/rusefi/bldc.git
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:
parent
b3ad9d3f27
commit
58bdeb1d95
|
@ -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]
|
||||
```
|
||||
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
14
src/heap.c
|
@ -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) {
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
Loading…
Reference in New Issue