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

Merge commit '38a42ba20326836b12798ba3b5ea718deea50977'

This commit is contained in:
Benjamin Vedder 2024-01-22 14:54:32 +01:00
parent 924f85765f 38a42ba203
commit 6e8dc4d7aa
12 changed files with 494 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
lispBM/lispBM/doc/lbmref.md
View File

@ -2,9 +2,9 @@
## About Symbols
Symbols are very important and fundamental to LispBM and also perhaps
Symbols are very important and central to LispBM and also perhaps
a bit different from identifiers/names used in languages such as C, so
a short intro could be good here.
a short intro on symbols could be good here.
A symbol can be thought of as a name and can be used to give names
to functions or values (variables). A symbol can also be treated and
@ -37,20 +37,20 @@ should not be able to redefine and trying to redefine them leads to an error.
Symbols that start with `ext-` are special and reserved for use together
with extensions that are loaded and bound at runtime.
Examples of symbols used as data are `nil` and `t`. `nil` is used the
represent nothing, the empty list or other similar things and `t`
Examples of symbols used as data are `nil` and `t`. `nil` representds
"nothing", the empty list or other similar things and `t`
represents true. But any symbol can be used as data by quoting it
`'`, see <a href="#quotes-and-quasiquotation"> Quotes and
Quasiquotation </a>.
### Valid symbol names
A symbol is string of characters following the rules:
A symbol is a string of characters following the rules:
1. The first character is a one of 'a' - 'z' or 'A' - 'Z' or '+-*/=<>#!'.
2. The rest of the characters are in 'a' - 'z' or 'A' - 'Z' or '0' - '9' or '+-*/=<>!?_'.
3. At most 256 characters long.
Note that lower-case and upper-case alphabetical letters are considers identical
Note that lower-case and upper-case alphabetical letters are considered identical
so the symbol `apa` is the same symbol as `APA`.
examples of valid symbols
@ -386,7 +386,7 @@ the argument.
### nil
Represents the empty list. The nil value is also considered to be false by
conditionals
conditionals.
The example below creates a one element list by allocating a cons cell and putting a value (1) in the <a href="#car"> car </a> field
and nil in the <a href="#cdr"> cdr </a> field.
@ -874,7 +874,6 @@ These two programs are thus equivalent:
(define a 10)
(define b 20)
(+ a b))
```
And
@ -951,7 +950,7 @@ The code above evaluates to 11.
<a name="read-program"> <h3>read-program</h3> </a>
Parses a string containing multiple sequenced expressed. The resulting list of
Parses a string containing multiple sequenced expressions. The resulting list of
expressions can be evaluated as a program using <a href="#eval-program">eval-program</a>.
The form of a read-program expression is `(read-program string)`.
@ -1170,7 +1169,7 @@ Example that combines to lists.
### ix
Index into a list using the `ix`. the form of an `ix` expression
Index into a list using the `ix` function. The form of an `ix` expression
is `(ix list-expr index-expr)`. Indexing starts from 0 and if you index out of bounds the result is nil.
Example that evaluates to 2.
@ -1365,9 +1364,9 @@ alist. The form of a `setassoc` expression is `(setassoc alist-expr key-expr val
### bufcreate
Create an array of bytes. The
form of an `bufcreate` expression is `(bufcreate size-expr)`
form of a `bufcreate` expression is `(bufcreate size-expr)`
Example that creates a 10 element buffer caled data:
Example that creates a 10 element buffer called data:
```clj
(define data (bufcreate 10))
@ -1672,19 +1671,21 @@ An example that atomically perfoms operations a,b and c.
### exit-ok
The `exit-ok` function terminates the thread in a "successful" way and returnes a result
specified by the programmer. The form of an `exit-ok` expression is `(exit-ok value)`.
If the process that calls `exit-ok` was created using `spawn-trap` a message of the form
The `exit-ok` function terminates the thread in a "successful" way and
returnes a result specified by the programmer. The form of an
`exit-ok` expression is `(exit-ok value)`. If the process that calls
`exit-ok` was created using `spawn-trap` a message of the form
`(exit-ok tid value)` is be sent to the parent of this process.
---
### exit-error
The `exit-error` function terminates the thread with an error specified by the programmer.
The form of an `exit-error` expression is `(exit-error err_val)`. If the process that
calls `exit-error` was created using `spawn-trap` a message of the form
`(exit-error tid err_val)` is sent to the parent of this process.
The `exit-error` function terminates the thread with an error
specified by the programmer. The form of an `exit-error` expression
is `(exit-error err_val)`. If the process that calls `exit-error` was
created using `spawn-trap` a message of the form `(exit-error tid
err_val)` is sent to the parent of this process.
---

199
lispBM/lispBM/include/lbm_defines.h
View File

@ -199,102 +199,117 @@
#define SYM_LOOP 0x115
#define SPECIAL_FORMS_END 0x115
// Fundamental built in operations that take their
// arguments on stack. Fundamentals do not handle
// their own GC and they are not allowed to create
// continuations.
#define SYM_ADD 0x20000
#define SYM_SUB 0x20001
#define SYM_MUL 0x20002
#define SYM_DIV 0x20003
#define SYM_MOD 0x20004
#define SYM_EQ 0x20005
#define SYM_NOT_EQ 0x20006
#define SYM_NUMEQ 0x20007
#define SYM_NUM_NOT_EQ 0x20008
#define SYM_LT 0x20009
#define SYM_GT 0x2000A
#define SYM_LEQ 0x2000B
#define SYM_GEQ 0x2000C
#define SYM_NOT 0x2000D
#define SYM_PERFORM_GC 0x2000E
#define SYM_SELF 0x2000F
#define SYM_SET_MAILBOX_SIZE 0x20010
#define SYM_CONS 0x20011
#define SYM_CAR 0x20012
#define SYM_CDR 0x20013
#define SYM_LIST 0x20014
#define SYM_APPEND 0x20015
#define SYM_UNDEFINE 0x20016
#define SYM_ARRAY_CREATE 0x20017
#define SYM_SYMBOL_TO_STRING 0x20018
#define SYM_STRING_TO_SYMBOL 0x20019
#define SYM_SYMBOL_TO_UINT 0x2001A
#define SYM_UINT_TO_SYMBOL 0x2001B
#define SYM_SET_CAR 0x2001C
#define SYM_SET_CDR 0x2001D
#define SYM_SET_IX 0x2001E
#define SYM_ASSOC 0x2001F
#define SYM_ACONS 0x20020
#define SYM_SET_ASSOC 0x20021
#define SYM_COSSA 0x20022
#define SYM_IX 0x20023
#define SYM_TO_I 0x20024
#define SYM_TO_I32 0x20025
#define SYM_TO_U 0x20026
#define SYM_TO_U32 0x20027
#define SYM_TO_FLOAT 0x20028
#define SYM_TO_I64 0x20029
#define SYM_TO_U64 0x2002A
#define SYM_TO_DOUBLE 0x2002B
#define SYM_TO_BYTE 0x2002C
#define SYM_SHL 0x2002D
#define SYM_SHR 0x2002E
#define SYM_BITWISE_AND 0x2002F
#define SYM_BITWISE_OR 0x20030
#define SYM_BITWISE_XOR 0x20031
#define SYM_BITWISE_NOT 0x20032
#define SYM_CUSTOM_DESTRUCT 0x20033
#define SYM_TYPE_OF 0x20034
#define SYM_LIST_LENGTH 0x20035
#define SYM_RANGE 0x20036
#define SYM_REG_EVENT_HANDLER 0x20037
#define SYM_TAKE 0x20038
#define SYM_DROP 0x20039
// Apply funs:
// Get their arguments in evaluated form.
// Get their arguments in evaluated form on the stack.
// Consecutive value symbols for lookup-application
#define APPLY_FUNS_START 0x150
#define SYM_SETVAR 0x150
#define SYM_READ 0x151
#define SYM_READ_PROGRAM 0x152
#define SYM_READ_AND_EVAL_PROGRAM 0x153
#define SYM_SPAWN 0x154
#define SYM_SPAWN_TRAP 0x155
#define SYM_YIELD 0x156
#define SYM_WAIT 0x157
#define SYM_EVAL 0x158
#define SYM_EVAL_PROGRAM 0x159
#define SYM_SEND 0x15A
#define SYM_EXIT_OK 0x15B
#define SYM_EXIT_ERROR 0x15C
#define SYM_MAP 0x15D
#define SYM_REVERSE 0x15E
#define SYM_FLATTEN 0x15F
#define SYM_UNFLATTEN 0x160
#define SYM_KILL 0x161
#define SYM_SLEEP 0x162
#define SYM_MERGE 0x163
#define SYM_SORT 0x164
#define APPLY_FUNS_END 0x164
// apply funs handle their own GC needs and can
// create continuations.
#define SYM_SETVAR 0x30000
#define SYM_READ 0x30001
#define SYM_READ_PROGRAM 0x30002
#define SYM_READ_AND_EVAL_PROGRAM 0x30003
#define SYM_SPAWN 0x30004
#define SYM_SPAWN_TRAP 0x30005
#define SYM_YIELD 0x30006
#define SYM_WAIT 0x30007
#define SYM_EVAL 0x30008
#define SYM_EVAL_PROGRAM 0x30009
#define SYM_SEND 0x3000A
#define SYM_EXIT_OK 0x3000B
#define SYM_EXIT_ERROR 0x3000C
#define SYM_MAP 0x3000D
#define SYM_REVERSE 0x3000E
#define SYM_FLATTEN 0x3000F
#define SYM_UNFLATTEN 0x30010
#define SYM_KILL 0x30011
#define SYM_SLEEP 0x30012
#define SYM_MERGE 0x30013
#define SYM_SORT 0x30014
#define FUNDAMENTALS_START 0x20E
#define SYM_ADD 0x20E
#define SYM_SUB 0x20F
#define SYM_MUL 0x210
#define SYM_DIV 0x211
#define SYM_MOD 0x212
#define SYM_EQ 0x213
#define SYM_NOT_EQ 0x214
#define SYM_NUMEQ 0x215
#define SYM_NUM_NOT_EQ 0x216
#define SYM_LT 0x217
#define SYM_GT 0x218
#define SYM_LEQ 0x219
#define SYM_GEQ 0x21A
#define SYM_NOT 0x21B
#define SYM_PERFORM_GC 0x21C
#define SYM_SELF 0x21D
#define SYM_SET_MAILBOX_SIZE 0x21E
#define SYM_CONS 0x21F
#define SYM_CAR 0x220
#define SYM_CDR 0x221
#define SYM_LIST 0x222
#define SYM_APPEND 0x223
#define SYM_UNDEFINE 0x224
#define SYM_ARRAY_CREATE 0x225
#define SYM_SYMBOL_TO_STRING 0x226
#define SYM_STRING_TO_SYMBOL 0x227
#define SYM_SYMBOL_TO_UINT 0x228
#define SYM_UINT_TO_SYMBOL 0x229
#define SYM_SET_CAR 0x22A
#define SYM_SET_CDR 0x22B
#define SYM_SET_IX 0x22C
#define SYM_ASSOC 0x22D
#define SYM_ACONS 0x22E
#define SYM_SET_ASSOC 0x22F
#define SYM_COSSA 0x230
#define SYM_IX 0x231
#define SYM_TO_I 0x232
#define SYM_TO_I32 0x233
#define SYM_TO_U 0x234
#define SYM_TO_U32 0x235
#define SYM_TO_FLOAT 0x236
#define SYM_TO_I64 0x237
#define SYM_TO_U64 0x238
#define SYM_TO_DOUBLE 0x239
#define SYM_TO_BYTE 0x23A
#define SYM_SHL 0x23B
#define SYM_SHR 0x23C
#define SYM_BITWISE_AND 0x23D
#define SYM_BITWISE_OR 0x23E
#define SYM_BITWISE_XOR 0x23F
#define SYM_BITWISE_NOT 0x240
#define SYM_CUSTOM_DESTRUCT 0x241 /* run the destructor of a custom type */
#define SYM_TYPE_OF 0x242
#define SYM_LIST_LENGTH 0x243
#define SYM_RANGE 0x244
#define SYM_REG_EVENT_HANDLER 0x245
#define SYM_TAKE 0x246
#define SYM_DROP 0x247
#define FUNDAMENTALS_END 0x249
#define SPECIAL_SYMBOLS_START 0
#define SPECIAL_SYMBOLS_END 0xFFFF
#define EXTENSION_SYMBOLS_START 0x10000
#define EXTENSION_SYMBOLS_END 0x1FFFF
#define VARIABLE_SYMBOLS_START 0x20000
#define VARIABLE_SYMBOLS_END 0x2FFFF
#define RUNTIME_SYMBOLS_START 0x30000
#define MAX_SYMBOL_VALUE 0x0FFFFFFF
#define SYMBOL_KIND(X) ((X) >> 16)
#define SYMBOL_KIND_SPECIAL 0
#define SYMBOL_KIND_EXTENSION 1
#define SYMBOL_KIND_FUNDAMENTAL 2
#define SYMBOL_KIND_APPFUN 3
#define SYMBOL_IX(X) ((X) & 0xFFFF)
#define SPECIAL_SYMBOLS_START 0
#define SPECIAL_SYMBOLS_END 0xFFFF
#define EXTENSION_SYMBOLS_START 0x10000
#define EXTENSION_SYMBOLS_END 0x1FFFF
#define FUNDAMENTAL_SYMBOLS_START 0x20000
#define FUNDAMENTAL_SYMBOLS_END 0x2FFFF
#define APPFUN_SYMBOLS_START 0x30000
#define APPFUN_SYMBOLS_END 0x3FFFF
#define RUNTIME_SYMBOLS_START 0x40000
#define MAX_SYMBOL_VALUE 0x0FFFFFFF
// This leaves 268173312 runtime symbols available.
/* ------------------------------------------------------------
Encoded Symbols

16
lispBM/lispBM/include/symrepr.h
View File

@ -72,20 +72,6 @@ int lbm_add_symbol_flash(char *name, lbm_uint* id);
\return 1 for success and 0 for failure.
*/
int lbm_str_to_symbol(char *name, lbm_uint *sym_id);
/** Add a variable-symbol to the symbol table. The symbol name string is copied to arrays and symbols memory.
*
* \param name String representation of the symbol.
* \param id Resulting id is returned through this argument.
* \return 1 for success and 0 for failure.
*/
int lbm_add_variable_symbol(char *name, lbm_uint* id);
/** Add a variable-symbol to the symbol table. The symbol name is
* considered to be a statically allocated constant.
* \param name String representation of the symbol.
* \param id Resulting id is returned through this argument.
* \return 1 for success and 0 for failure.
*/
int lbm_add_variable_symbol_const(char *name, lbm_uint* id);
/** Add a symbol to the symbol table. The name is assumed to be a statically allocated string.
*
* \param name Statically allocated name string.
@ -113,8 +99,6 @@ int lbm_get_symbol_by_name(char *name, lbm_uint *id);
*/
const char* lbm_get_name_by_symbol(lbm_uint id);
lbm_uint lbm_get_num_variables(void);
/**
*
* \return The total amount of lbm_memory space occupied by the symbol table in bytes.

216
lispBM/lispBM/src/eval_cps.c
View File

@ -1,4 +1,4 @@
/*
/*
Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
@ -122,6 +122,24 @@ const char* lbm_error_str_variable_not_bound = "Variable not bound.";
static lbm_value lbm_error_suspect;
static bool lbm_error_has_suspect = false;
#ifdef LBM_ALWAYS_GC
#define WITH_GC(y, x) \
gc(); \
(y) = (x); \
if (lbm_is_symbol_merror((y))) { \
error_ctx(ENC_SYM_MERROR); \
}
#define WITH_GC_RMBR_1(y, x, r) \
lbm_gc_mark_phase(r); \
gc(); \
(y) = (x); \
if (lbm_is_symbol_merror((y))) { \
error_ctx(ENC_SYM_MERROR); \
}
#else
#define WITH_GC(y, x) \
(y) = (x); \
@ -145,6 +163,8 @@ static bool lbm_error_has_suspect = false;
/* continue executing statements below */ \
}
#endif
typedef struct {
eval_context_t *first;
eval_context_t *last;
@ -377,6 +397,17 @@ eval_context_t *lbm_get_current_context(void) {
/* Utilities used locally in this file */
static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
#ifdef LBM_ALWAYS_GC
lbm_value roots[3] = {head, tail, remember};
lbm_gc_mark_roots(roots, 3);
gc();
lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
if (lbm_is_symbol_merror(res)) {
error_ctx(ENC_SYM_MERROR);
}
return res;
#else
lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
if (lbm_is_symbol_merror(res)) {
lbm_value roots[3] = {head, tail, remember};
@ -388,6 +419,7 @@ static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember
}
}
return res;
#endif
}
static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
@ -455,8 +487,10 @@ static void stack_push(lbm_stack_t *s, lbm_uint val) {
static void stack_push_2(lbm_stack_t *s, lbm_uint v1, lbm_uint v2) {
if (s->sp + 1 < s->size) {
s->data[s->sp++] = v1;
s->data[s->sp++] = v2;
lbm_uint *t = &s->data[s->sp];
t[0] = v1;
t[1] = v2;
s->sp += 2;
if (s->sp > s->max_sp) s->max_sp = s->sp;
return;
}
@ -465,9 +499,11 @@ static void stack_push_2(lbm_stack_t *s, lbm_uint v1, lbm_uint v2) {
static void stack_push_3(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3) {
if (s->sp + 2 < s->size) {
s->data[s->sp++] = v1;
s->data[s->sp++] = v2;
s->data[s->sp++] = v3;
lbm_uint *t = &s->data[s->sp];
t[0] = v1;
t[1] = v2;
t[2] = v3;
s->sp += 3;
if (s->sp > s->max_sp) s->max_sp = s->sp;
return;
}
@ -476,10 +512,12 @@ static void stack_push_3(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3)
static void stack_push_4(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3, lbm_uint v4) {
if (s->sp + 3 < s->size) {
s->data[s->sp++] = v1;
s->data[s->sp++] = v2;
s->data[s->sp++] = v3;
s->data[s->sp++] = v4;
lbm_uint *t = &s->data[s->sp];
t[0] = v1;
t[1] = v2;
t[2] = v3;
t[3] = v4;
s->sp += 4;
if (s->sp > s->max_sp) s->max_sp = s->sp;
return;
}
@ -571,24 +609,34 @@ static lbm_value get_cddr(lbm_value a) {
static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
#ifdef LBM_ALWAYS_GC
gc();
if (lbm_heap_num_free() < 4) {
error_ctx(ENC_SYM_MERROR);
}
#else
if (lbm_heap_num_free() < 4) {
gc();
if (lbm_heap_num_free() < 4) {
error_ctx(ENC_SYM_MERROR);
}
}
#endif
// The freelist will always contain just plain heap-cells.
// So dec_ptr is sufficient.
lbm_value res = lbm_heap_state.freelist;
if (lbm_type_of(res) == LBM_TYPE_CONS) {
lbm_cons_t *cell = lbm_ref_cell(res);
cell->car = ENC_SYM_CLOSURE;
cell = lbm_ref_cell(cell->cdr);
cell->car = params;
cell = lbm_ref_cell(cell->cdr);
cell->car = body;
cell = lbm_ref_cell(cell->cdr);
cell->car = env;
lbm_heap_state.freelist = cell->cdr;
cell->cdr = ENC_SYM_NIL;
lbm_cons_t *heap = lbm_heap_state.heap;
lbm_uint ix = lbm_dec_ptr(res);
heap[ix].car = ENC_SYM_CLOSURE;
ix = lbm_dec_ptr(heap[ix].cdr);
heap[ix].car = params;
ix = lbm_dec_ptr(heap[ix].cdr);
heap[ix].car = body;
ix = lbm_dec_ptr(heap[ix].cdr);
heap[ix].car = env;
lbm_heap_state.freelist = heap[ix].cdr;
heap[ix].cdr = ENC_SYM_NIL;
lbm_heap_state.num_alloc+=4;
} else {
error_ctx(ENC_SYM_FATAL_ERROR);
@ -625,7 +673,7 @@ static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg
res = fundamental_table[fundamental](args, arg_count, ctx);
}
if (lbm_is_error(res)) {
error_at_ctx(res, lbm_enc_sym(fundamental+FUNDAMENTALS_START));
error_at_ctx(res, lbm_enc_sym(EXTENSION_SYMBOLS_START | fundamental));
}
}
lbm_stack_drop(&ctx->K, arg_count+1);
@ -1536,25 +1584,20 @@ int lbm_perform_gc(void) {
static void eval_symbol(eval_context_t *ctx) {
lbm_uint s = lbm_dec_sym(ctx->curr_exp);
if (s >= RUNTIME_SYMBOLS_START) {
lbm_value res;
lbm_value res = ENC_SYM_NIL;
if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
lbm_global_env_lookup(&res, ctx->curr_exp)) {
ctx->r = res;
ctx->app_cont = true;
return;
}
} else if (s <= EXTENSION_SYMBOLS_END) {
//special symbols and extensions can be handled the same way.
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
return;
}
// Dynamic load attempt
const char *sym_str = lbm_get_name_by_symbol(s);
const char *code_str = NULL;
if (!dynamic_load_callback(sym_str, &code_str)) {
error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp);
} else {
// Dynamic load attempt
// Only symbols of kind RUNTIME can be dynamically loaded.
const char *sym_str = lbm_get_name_by_symbol(s);
const char *code_str = NULL;
if (!dynamic_load_callback(sym_str, &code_str)) {
error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp);
}
stack_push_3(&ctx->K, ctx->curr_exp, ctx->curr_env, RESUME);
lbm_value chan;
@ -1575,6 +1618,10 @@ static void eval_symbol(eval_context_t *ctx) {
loader), loader);
ctx->curr_exp = evaluator;
ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env
} else {
//special symbols and extensions can be handled the same way.
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
}
@ -2701,19 +2748,11 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c
lbm_value fun = fun_args[0];
lbm_uint fun_val = lbm_dec_sym(fun);
lbm_uint apply_val = fun_val - APPLY_FUNS_START;
lbm_uint fund_val = fun_val - FUNDAMENTALS_START;
lbm_uint fun_kind = SYMBOL_KIND(fun_val);
if (apply_val <= (APPLY_FUNS_END - APPLY_FUNS_START)) {
fun_table[apply_val](&fun_args[1], arg_count, ctx);
} else if (fund_val <= (FUNDAMENTALS_END - FUNDAMENTALS_START)) {
call_fundamental(fund_val, &fun_args[1], arg_count, ctx);
} else {
// It may be an extension
extension_fptr f = lbm_get_extension(fun_val);
if (f == NULL) {
error_at_ctx(ENC_SYM_EERROR,fun);
}
switch (fun_kind) {
case SYMBOL_KIND_EXTENSION: {
extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr;
lbm_value ext_res;
WITH_GC(ext_res, f(&fun_args[1], arg_count));
@ -2735,6 +2774,16 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c
ctx->app_cont = true;
ctx->r = ext_res;
}
} break;
case SYMBOL_KIND_FUNDAMENTAL:
call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx);
break;
case SYMBOL_KIND_APPFUN:
fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
break;
default:
error_ctx(ENC_SYM_FATAL_ERROR);
break;
}
}
@ -2756,20 +2805,20 @@ static void cont_closure_application_args(eval_context_t *ctx) {
error_ctx(ENC_SYM_MERROR);
}
}
lbm_cons_t* heap = lbm_heap_state.heap;
lbm_value cell0 = lbm_heap_state.freelist;
lbm_cons_t *cell0_r = lbm_ref_cell(cell0);
lbm_value cell1 = cell0_r->cdr;
lbm_cons_t *cell1_r = lbm_ref_cell(cell1);
lbm_heap_state.freelist = cell1_r->cdr;
lbm_uint cell0_ix = lbm_dec_ptr(cell0);
lbm_value cell1 = heap[cell0_ix].cdr;
lbm_uint cell1_ix = lbm_dec_ptr(cell1);
lbm_heap_state.freelist = heap[cell1_ix].cdr;
lbm_heap_state.num_alloc += 2;
cell0_r->car = car_params;
cell0_r->cdr = ctx->r;
cell1_r->car = cell0;
cell1_r->cdr = clo_env;
heap[cell0_ix].car = car_params;
heap[cell0_ix].cdr = ctx->r;
heap[cell1_ix].car = cell0;
heap[cell1_ix].cdr = clo_env;
clo_env = cell1;
// TODO: We are NOT going to implement a lazy sweep.
bool a_nil = args == ENC_SYM_NIL;
bool p_nil = cdr_params == ENC_SYM_NIL;
@ -2910,12 +2959,12 @@ static void cont_if(eval_context_t *ctx) {
static void cont_match(eval_context_t *ctx) {
lbm_value e = ctx->r;
lbm_value patterns;
lbm_value new_env;
lbm_value orig_env;
bool do_gc = false;
lbm_pop_2(&ctx->K, &orig_env, &patterns); // restore enclosing environment
new_env = orig_env;
lbm_uint *sptr = get_stack_ptr(ctx, 2);
lbm_value patterns = (lbm_value)sptr[0];
lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
lbm_value new_env = orig_env;
if (lbm_is_symbol_nil(patterns)) {
// no more patterns
@ -2937,8 +2986,6 @@ static void cont_match(eval_context_t *ctx) {
bool is_match = match(pattern, e, &new_env, &do_gc);
if (do_gc) {
lbm_uint roots[3] = {orig_env, patterns, e};
lbm_gc_mark_roots(roots, 3);
gc();
do_gc = false;
new_env = orig_env;
@ -2949,23 +2996,26 @@ static void cont_match(eval_context_t *ctx) {
}
if (is_match) {
if (check_guard) {
lbm_value *sptr = stack_reserve(ctx,7);
lbm_value *rptr = stack_reserve(ctx,5);
sptr[0] = get_cdr(patterns);
sptr[1] = ctx->curr_env;
sptr[2] = MATCH;
sptr[3] = new_env;
sptr[4] = body;
sptr[5] = e;
sptr[6] = MATCH_GUARD;
rptr[0] = MATCH;
rptr[1] = new_env;
rptr[2] = body;
rptr[3] = e;
rptr[4] = MATCH_GUARD;
ctx->curr_env = new_env;
ctx->curr_exp = n1; // The guard
} else {
lbm_stack_drop(&ctx->K, 2);
ctx->curr_env = new_env;
ctx->curr_exp = body;
}
} else {
// set up for checking of next pattern
stack_push_3(&ctx->K, get_cdr(patterns),orig_env, MATCH);
sptr[0] = get_cdr(patterns);
sptr[1] = orig_env;
stack_push(&ctx->K, MATCH);
// leave r unaltered
ctx->app_cont = true;
}
@ -3116,12 +3166,11 @@ static void cont_merge_rest(eval_context_t *ctx) {
lbm_value cmp_env = sptr[6];
// Environment should be preallocated already at this point
// and the operations below should never need GC.
// maybe rewrite this as a more efficient update and
// a fatal error if that is not possible.
lbm_value new_env0;
lbm_value new_env;
WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
error_ctx(ENC_SYM_FATAL_ERROR);
}
cmp_env = new_env;
stack_push(&ctx->K, MERGE_REST);
@ -3233,12 +3282,11 @@ static void cont_merge_layer(eval_context_t *ctx) {
lbm_value par2 = sptr[3];
// Environment should be preallocated already at this point
// and the operations below should never need GC.
// maybe rewrite this as a more efficient update and
// a fatal error if that is not possible.
lbm_value new_env0;
lbm_value new_env;
WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
error_ctx(ENC_SYM_FATAL_ERROR);
}
cmp_env = new_env;
lbm_uint *merge_cont = stack_reserve(ctx, 11);
@ -3576,7 +3624,7 @@ static void cont_read_next_token(eval_context_t *ctx) {
if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
error_ctx(ENC_SYM_FATAL_ERROR);
}
symbol_id = ext_id + EXTENSION_SYMBOLS_START;
symbol_id = ext_id;
} else {
error_ctx(ENC_SYM_MERROR);
}
@ -4289,7 +4337,7 @@ lbm_value append(lbm_value front, lbm_value back) {
lbm_value t0, t1;
t0 = cons_with_gc(back, ENC_SYM_NIL, ENC_SYM_NIL);
t0 = cons_with_gc(back, ENC_SYM_NIL, front);
t1 = cons_with_gc(front, t0, ENC_SYM_NIL);
return cons_with_gc(ENC_SYM_APPEND, t1, ENC_SYM_NIL);
}
@ -4376,9 +4424,7 @@ static void cont_qq_expand_list(eval_context_t* ctx) {
if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(car_val) == SYM_COMMA) {
lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL);
//WITH_GC(tl, lbm_cons(get_car(cdr_val), ENC_SYM_NIL));
lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL);
//WITH_GC_RMBR_1(tmp, lbm_cons(ENC_SYM_LIST, tl), tl);
ctx->r = append(ctx->r, tmp);
ctx->app_cont = true;
return;

11
lispBM/lispBM/src/extensions.c
View File

@ -25,7 +25,6 @@
#include "extensions.h"
static lbm_uint ext_offset = EXTENSION_SYMBOLS_START;
static lbm_uint ext_max = 0;
static lbm_uint ext_num = 0;
static lbm_uint next_extension_ix = 0;
@ -64,7 +63,7 @@ lbm_uint lbm_get_num_extensions(void) {
}
extension_fptr lbm_get_extension(lbm_uint sym) {
lbm_uint ext_next = sym - ext_offset;
lbm_uint ext_next = sym - EXTENSION_SYMBOLS_START;
if (ext_next >= ext_max) {
return NULL;
}
@ -72,7 +71,7 @@ extension_fptr lbm_get_extension(lbm_uint sym) {
}
bool lbm_clr_extension(lbm_uint sym_id) {
lbm_uint ext_id = sym_id - ext_offset;
lbm_uint ext_id = sym_id - EXTENSION_SYMBOLS_START;
if (ext_id >= ext_max) {
return false;
}
@ -85,7 +84,7 @@ bool lbm_lookup_extension_id(char *sym_str, lbm_uint *ix) {
for (lbm_uint i = 0; i < ext_max; i ++) {
if(extension_table[i].name) {
if (strcmp(extension_table[i].name, sym_str) == 0) {
*ix = i;
*ix = i + EXTENSION_SYMBOLS_START;
return true;
}
}
@ -100,9 +99,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 (strcmp(extension_table[symbol - ext_offset].name, sym_str) == 0) {
if (strcmp(extension_table[symbol - EXTENSION_SYMBOLS_START].name, sym_str) == 0) {
// Do not replace name ptr.
extension_table[symbol - ext_offset].fptr = ext;
extension_table[symbol - EXTENSION_SYMBOLS_START].fptr = ext;
return true;
}
}

23
lispBM/lispBM/src/heap.c
View File

@ -528,19 +528,19 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr
res = lbm_heap_state.freelist;
if (lbm_type_of(res) == LBM_TYPE_CONS) {
lbm_cons_t *rc = lbm_ref_cell(res);
lbm_heap_state.freelist = rc->cdr;
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++;
rc->car = car;
rc->cdr = cdr;
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(lbm_heap_state.freelist) == LBM_TYPE_SYMBOL) &&
(lbm_dec_sym(lbm_heap_state.freelist) == SYM_NIL)) {
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;
}
@ -691,6 +691,7 @@ void lbm_gc_mark_phase(lbm_value root) {
}
#else
extern eval_context_t *ctx_running;
void lbm_gc_mark_phase(lbm_value root) {
lbm_stack_t *s = &lbm_heap_state.gc_stack;
@ -867,7 +868,6 @@ int lbm_gc_sweep_phase(void) {
lbm_heap_state.gc_recovered ++;
}
}
return 1;
}
@ -1152,7 +1152,6 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size){
// Convert a C array into an lbm_array.
// if the array is in LBM_MEMORY, the lifetime will be managed by the GC.
// TODO: Use lbm_malloc for header data
int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) {
lbm_array_header_t *array = NULL;
@ -1165,13 +1164,15 @@ int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) {
array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
if (array == NULL) return 0;
if (array == NULL) {
*value = ENC_SYM_MERROR;
return 0;
}
array->data = (lbm_uint*)data;
array->size = num_elt;
lbm_set_car(cell, (lbm_uint)array);
//lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
*value = cell;

23
lispBM/lispBM/src/symrepr.c
View File

@ -1,5 +1,5 @@
/*
Copyright 2018, 2021 2022 Joel Svensson svenssonjoel@yahoo.se
Copyright 2018, 2021, 2022, 2024 Joel Svensson svenssonjoel@yahoo.se
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@ -227,7 +227,6 @@ special_sym const special_symbols[] = {
static lbm_uint *symlist = NULL;
static lbm_uint next_symbol_id = RUNTIME_SYMBOLS_START;
static lbm_uint next_variable_symbol_id = VARIABLE_SYMBOLS_START;
static lbm_uint symbol_table_size_list = 0;
static lbm_uint symbol_table_size_list_flash = 0;
static lbm_uint symbol_table_size_strings = 0;
@ -239,7 +238,6 @@ lbm_value symbol_y = ENC_SYM_NIL;
int lbm_symrepr_init(void) {
symlist = NULL;
next_symbol_id = RUNTIME_SYMBOLS_START;
next_variable_symbol_id = VARIABLE_SYMBOLS_START;
symbol_table_size_list = 0;
symbol_table_size_list_flash = 0;
symbol_table_size_strings = 0;
@ -277,21 +275,28 @@ const char *lookup_symrepr_name_memory(lbm_uint id) {
// Lookup symbol name given a symbol id
const char *lbm_get_name_by_symbol(lbm_uint id) {
if (id < SPECIAL_SYMBOLS_END) {
lbm_uint sym_kind = SYMBOL_KIND(id);
switch (sym_kind) {
case SYMBOL_KIND_SPECIAL: /* fall through */
case SYMBOL_KIND_FUNDAMENTAL:
case SYMBOL_KIND_APPFUN:
for (unsigned int i = 0; i < NUM_SPECIAL_SYMBOLS; i ++) {
if (id == special_symbols[i].id) {
return (special_symbols[i].name);
}
}
return NULL;
} else if (id - EXTENSION_SYMBOLS_START < EXTENSION_SYMBOLS_END) {
break;
case SYMBOL_KIND_EXTENSION: {
unsigned int ext_id = id - EXTENSION_SYMBOLS_START;
if (ext_id < lbm_get_max_extensions()) {
return extension_table[ext_id].name;
return extension_table[ext_id].name;
}
return NULL;
} break;
default:
return lookup_symrepr_name_memory(id);
}
return lookup_symrepr_name_memory(id);
}
lbm_uint *lbm_get_symbol_list_entry_by_name(char *name) {
@ -465,10 +470,6 @@ lbm_uint lbm_get_symbol_table_size_names_flash(void) {
return symbol_table_size_strings_flash * sizeof(lbm_uint);
}
lbm_uint lbm_get_num_variables(void) {
return next_variable_symbol_id - VARIABLE_SYMBOLS_START;
}
bool lbm_symbol_in_flash(char *str) {
return !lbm_memory_ptr_inside((lbm_uint*)str);
}

5
lispBM/lispBM/tests/Makefile
View File

@ -17,6 +17,11 @@ OBJ = obj
SOURCES = $(wildcard *.c)
EXECS = $(patsubst %.c, %.exe, $(SOURCES))
gc: CCFLAGS += -m32 -DLBM_ALWAYS_GC
gc: $(EXECS)
mv test_lisp_code_cps.exe test_lisp_code_cps
all: CCFLAGS += -m32
all: $(EXECS)
mv test_lisp_code_cps.exe test_lisp_code_cps

147
lispBM/lispBM/tests/run_tests_gc.sh Executable file
View File

@ -0,0 +1,147 @@
#!/bin/bash
echo "BUILDING"
make clean
make gc
echo "PERFORMING TESTS:"
expected_fails=("test_lisp_code_cps -t 360 -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -s -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -s -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -i -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -i -s -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -i -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -t 360 -i -s -h 512 test_take_iota_0.lisp"
)
success_count=0
fail_count=0
failing_tests=()
result=0
for exe in *.exe; do
if [ "$exe" = "test_gensym.exe" ]; then
continue
fi
./$exe
result=$?
echo "------------------------------------------------------------"
if [ $result -eq 1 ]
then
success_count=$((success_count+1))
echo $exe SUCCESS
else
fail_count=$((fail_count+1))
echo $exe FAILED
fi
echo "------------------------------------------------------------"
done
test_config=("-t 360 -h 32768"
"-t 360 -i -h 32768"
"-t 360 -s -h 32768"
"-t 360 -i -s -h 32768"
"-t 360 -h 16384"
"-t 360 -i -h 16384"
"-t 360 -s -h 16384"
"-t 360 -i -s -h 16384"
"-t 360 -h 8192"
"-t 360 -i -h 8192"
"-t 360 -s -h 8192"
"-t 360 -i -s -h 8192"
"-t 360 -h 4096"
"-t 360 -i -h 4096"
"-t 360 -s -h 4096"
"-t 360 -i -s -h 4096"
"-t 360 -h 2048"
"-t 360 -i -h 2048"
"-t 360 -s -h 2048"
"-t 360 -i -s -h 2048"
"-t 360 -h 1024"
"-t 360 -i -h 1024"
"-t 360 -s -h 1024"
"-t 360 -i -s -h 1024"
"-t 360 -h 512"
"-t 360 -i -h 512"
"-t 360 -s -h 512"
"-t 360 -i -s -h 512")
#"test_lisp_code_cps_nc"
for prg in "test_lisp_code_cps" ; do
for arg in "${test_config[@]}"; do
for lisp in *.lisp; do
./$prg $arg $lisp
result=$?
echo "------------------------------------------------------------"
#echo $arg
if [ $result -eq 1 ]
then
success_count=$((success_count+1))
echo $lisp SUCCESS
else
#!/bin/bash
# foo=('foo bar' 'foo baz' 'bar baz')
# bar=$(printf ",%s" "${foo[@]}")
# bar=${bar:1}
# echo $bar
str=$(printf "%s " "$prg $arg $lisp")
#echo $str
failing_tests+=("$prg $arg $lisp")
fail_count=$((fail_count+1))
#echo $failing_tests
echo $lisp FAILED
fi
echo "------------------------------------------------------------"
done
done
done
# echo -e $failing_tests
expected_count=0
for (( i = 0; i < ${#failing_tests[@]}; i++ ))
do
expected=false
for (( j = 0; j < ${#expected_fails[@]}; j++))
do
if [[ "${failing_tests[$i]}" == "${expected_fails[$j]}" ]] ;
then
expected=true
fi
done
if $expected ; then
expected_count=$((expected_count+1))
echo "(OK - expected to fail)" ${failing_tests[$i]}
else
echo "(FAILURE)" ${failing_tests[$i]}
fi
done
echo Tests passed: $success_count
echo Tests failed: $fail_count
echo Expected fails: $expected_count
echo Actual fails: $((fail_count - expected_count))
if [ $((fail_count - expected_count)) -gt 0 ]
then
exit 1
fi

20
lispBM/lispBM/tests/test_lisp_code_cps.c
View File

@ -49,6 +49,7 @@
lbm_extension_t extensions[EXTENSION_STORAGE_SIZE];
lbm_uint constants_memory[CONSTANT_MEMORY_SIZE];
static uint32_t timeout = 10;
void const_heap_init(void) {
for (int i = 0; i < CONSTANT_MEMORY_SIZE; i ++) {
@ -338,6 +339,7 @@ LBM_EXTENSION(ext_check, args, argn) {
}
int res = lbm_print_value(output, 128, t);
printf("Checking result value: %s\n", output);
if (checks == 2) {
experiment_done = true;
@ -401,8 +403,11 @@ int main(int argc, char **argv) {
int c;
opterr = 1;
while (( c = getopt(argc, argv, "igsch:")) != -1) {
while (( c = getopt(argc, argv, "igsch:t:")) != -1) {
switch (c) {
case 't':
timeout = (uint32_t)atoi((char *)optarg);
break;
case 'h':
heap_size = (unsigned int)atoi((char *)optarg);
break;
@ -752,15 +757,19 @@ int main(int argc, char **argv) {
}
}
printf("Program loaded\n");
int i = 0;
uint32_t i = 0;
bool timed_out = false;
while (!experiment_done) {
if (i == 10000) break;
if (i >= timeout * 1000) {
timed_out = true;
break;
}
sleep_callback(1000);
i ++;
}
if (i == 10000) {
printf ("experiment failed due to taking longer than 10 seconds\n");
if (timed_out) {
printf ("experiment failed due to taking longer than %u seconds\n", timeout);
experiment_success = false;
return FAIL;
}
@ -778,6 +787,7 @@ int main(int argc, char **argv) {
free(heap_storage);
printf("Experiment done: ");
printf("Check was executed %u times\n", checks);
if (experiment_success) {
printf("SUCCESS\n");
return 1;

19
lispBM/lispBM/tests/test_match_guard_10.lisp Normal file
View File

@ -0,0 +1,19 @@
(defun larger ( x ) {
(gc)
(> x 10)
})
(defun smaller ( x ) {
(gc)
(< x 10)
})
(defun f (x)
(match x
( ((? x) . ((? y) . _)) (smaller x) (list y 'smaller))
( ((? x) . ((? y) . _)) (larger x) (list y 'larger))
( _ 'whatever)))
(check (and (eq (f '(0 1 2 3)) '(1 smaller))
(eq (f '(11 9 8 7)) '(9 larger))))

21
lispBM/lispBM/tests/test_match_guard_11.lisp Normal file
View File

@ -0,0 +1,21 @@
(defun larger ( x ) {
(gc)
(> x 10)
})
(defun smaller ( x ) {
(gc)
(< x 10)
})
(defun f (x)
(atomic
(var z "apa")
(match x
( ((? x) . ((? y) . _)) (smaller z) (list y 'smaller))
( ((? x) . ((? y) . _)) (larger z) (list y 'larger))
( _ 'whatever))))
(check (and (eq (f '(0 1 2 3)) 'whatever)
(eq (f '(11 9 8 7)) 'whatever)))