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 15fd3dea..02887bfd 

02887bfd Change implementation of car family in evaluator for immediate termination on error
7517c2e1 bug fix in wait-for and addition of a few tests
275a8e46 removed pointless usage of WITH_GC
143d024c bumped version
a4836c7d closing a number of warnings when building 64bits. some still remain
e61c28e9 closing some warnings on 64bit build - lots to go
68a09916 a small amount of cleaning.
bd91e152 wait-for + trigger mechanism has been added, but is untested
70c82228 adding tests of undefine
003887d8 fix severe bug in undefine
bdc30576 Added two undefine tests
4e694bc8 experimental wake-up lbm task framework, work in progress
38068776 cleaning and refactoring
7e814674 cleaning and consolidating
b05615fa cleaning and consolidation of functionality
2b986f7c small refactor for
ce05734d removed dead code in evaluation of the progn continuation
9eeae272 made global env a static variable in env.c
1eacbf3f refactoring. may save a few cpu cycles in list allocation and GC

git-subtree-dir: lispBM/lispBM
git-subtree-split: 02887bfd12a8d98f2e6f73b3dbd38b9ec222358a
This commit is contained in:
Benjamin Vedder 2023-06-12 11:49:07 +02:00
parent 2e82399a2f
commit f6eeba8336
32 changed files with 650 additions and 390 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
doc/lbmref.md
View File

@ -1013,64 +1013,6 @@ Functions can be moved to flash storage as well:
(move-to-flash f)
```
### make-env
The `make-env` form allows you to create an environment as a value.
The form of an `make-env` expression is `(make-env exp)`. When
The result of running `(make-env exp)` is the resulting environment after
evaluating the expression `exp`. The resulting environment is an association list.
`make-env` can be used to encapsulate a set of bindings under a name.
Example:
```clj
(define my-env (make-env {
(defun f (x) (+ x 1))
(defun g (x y) (+ x y))
}))
```
See `in-env` for how to evaluate expressions inside of a provided environment.
---
### in-env
The `in-env` form allows the evaluation in an environment that has
been augmented by an environment (association list) provided.
The form of an `in-env` expression is `(in-env env-expr expr)`. Here the
expression `expr` is evaluated with the local environemnt augmented with
the result of `env-expr`. The resulting environment of a `make-env` application
is compatible with the `env-expr` of `in-env` but any association list is ok.
Example:
```clj
(define my-env '( (a . 10) (b . 20)))
(in-env my-env (+ a b))
```
The example above evaluates to 30.
Example combining `in-env` and `make-env`:
```clj
(define lib
(make-env {
(define a 10)
(define b 20)
(define c 30)
}))
(in-env lib (+ a b))
```
---
## Lists and cons cells

9
include/eval_cps.h
View File

@ -58,6 +58,7 @@ typedef struct eval_context_s{
lbm_uint sleep_us;
lbm_cid id;
lbm_cid parent;
lbm_uint wait_mask;
/* while reading */
lbm_int row0;
lbm_int row1;
@ -75,7 +76,7 @@ typedef struct {
lbm_event_type_t type;
lbm_uint parameter;
lbm_uint buf_ptr;
uint32_t buf_len;
lbm_uint buf_len;
} lbm_event_t;
/** Fundamental operation type */
@ -142,6 +143,12 @@ bool lbm_event(lbm_flat_value_t *fv);
* \return true on success.
*/
bool lbm_event_unboxed(lbm_value unboxed);
/** Trigger a flag to wake up all tasks waiting on that flag.
* \param wait_for_flags Flags to trigger.
*/
void lbm_trigger_flags(uint32_t wait_for_flags);
/** Remove a context that has finished executing and free up its associated memory.
*
* \param cid Context id of context to free.

6
include/heap.h
View File

@ -334,7 +334,7 @@ lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr);
* \param n The number of heap-cells to allocate.
* \return A list of heap-cells of Memory error if unable to allocate.
*/
lbm_value lbm_heap_allocate_list(unsigned int n);
lbm_value lbm_heap_allocate_list(lbm_uint n);
/** Allocate a list of n heap-cells and initialize the values.
* \pram ls The result list is passed through this ptr.
* \param n The length of list to allocate.
@ -484,7 +484,7 @@ int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
* \param c A list
* \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
*/
unsigned int lbm_list_length(lbm_value c);
lbm_uint lbm_list_length(lbm_value c);
/** Calculate the length of a proper list and evaluate a predicate for each element.
* \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
@ -688,7 +688,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(float x);
extern lbm_value lbm_enc_float(lbm_float x);
/** Encode a 64 bit integer into an lbm_value.
* \param x 64 bit integer to encode.

4
include/lbm_defines.h
View File

@ -208,7 +208,8 @@
#define SYM_EXIT_ERROR 0x15C
#define SYM_MAP 0x15D
#define SYM_REVERSE 0x15E
#define APPLY_FUNS_END 0x15E
#define SYM_WAIT_FOR 0x15F
#define APPLY_FUNS_END 0x15F
#define FUNDAMENTALS_START 0x20E
#define SYM_ADD 0x20E
@ -385,6 +386,7 @@
#define ENC_SYM_EXIT_ERROR ENC_SYM(SYM_EXIT_ERROR)
#define ENC_SYM_MAP ENC_SYM(SYM_MAP)
#define ENC_SYM_REVERSE ENC_SYM(SYM_REVERSE)
#define ENC_SYM_WAIT_FOR ENC_SYM(SYM_WAIT_FOR)
#define ENC_SYM_GET_ENV ENC_SYM(SYM_GET_ENV)
#define ENC_SYM_SET_ENV ENC_SYM(SYM_SET_ENV)

4
include/lbm_flat_value.h
View File

@ -24,8 +24,8 @@
typedef struct {
uint8_t *buf;
size_t buf_size;
uint32_t buf_pos;
lbm_uint buf_size;
lbm_uint buf_pos;
} lbm_flat_value_t;
// Arity
#define S_CONS 0x1 // 2 car, cdr

7
include/lbm_version.h
View File

@ -27,12 +27,17 @@ extern "C" {
/** LBM major version */
#define LBM_MAJOR_VERSION 0
/** LBM minor version */
#define LBM_MINOR_VERSION 13
#define LBM_MINOR_VERSION 14
/** LBM patch revision */
#define LBM_PATCH_VERSION 0
/*! \page changelog Changelog
JUN 8 2023: Version 0.14.0
- wait-for that blocks code unless a flag is set.
- Bug fix in undefine.
- Lots of cleaning and refactoring.
MAJ 5 2023: Version 0.13.0
- Changed behavior of closure application to zero args. Used to be equivalent
to application to nil.

44
repl/repl.c
View File

@ -260,7 +260,7 @@ bool dyn_load(const char *str, const char **code) {
lbm_value ext_block(lbm_value *args, lbm_uint argn) {
printf("blocking CID: %d\n", lbm_get_current_cid());
printf("blocking CID: %d\n", (int32_t)lbm_get_current_cid());
lbm_block_ctx_from_extension();
return lbm_enc_sym(SYM_TRUE);
}
@ -342,33 +342,21 @@ lbm_value ext_unflatten(lbm_value *args, lbm_uint argn) {
char output[128];
static lbm_value ext_range(lbm_value *args, lbm_uint argn) {
if (argn != 2 || lbm_type_of(args[0]) != LBM_TYPE_I || lbm_type_of(args[1]) != LBM_TYPE_I) {
return lbm_enc_sym(SYM_EERROR);
}
lbm_int start = lbm_dec_i(args[0]);
lbm_int end = lbm_dec_i(args[1]);
if (start > end || (end - start) > 100) {
return lbm_enc_sym(SYM_EERROR);
}
lbm_value res = lbm_enc_sym(SYM_NIL);
for (lbm_int i = end;i >= start;i--) {
res = lbm_cons(lbm_enc_i(i), res);
}
return res;
}
static bool test_destruct(lbm_uint value) {
printf("destroying custom value\n");
free((lbm_uint*)value);
return true;
}
static lbm_value ext_trigger(lbm_value *args, lbm_uint argn) {
if (argn == 1 && lbm_is_number(args[0])) {
lbm_trigger_flags(lbm_dec_as_u32(args[0]));
return ENC_SYM_TRUE;
} else {
return ENC_SYM_EERROR;
}
}
static lbm_value ext_custom(lbm_value *args, lbm_uint argn) {
lbm_uint *mem = (lbm_uint*)malloc(1000*sizeof(lbm_uint));
@ -469,7 +457,7 @@ void lookup_local(eval_context_t *ctx, void *arg1, void *arg2) {
if (lbm_env_lookup_b(&res, (lbm_value)arg1, ctx->curr_env)) {
lbm_print_value(output, 1024, res);
printf("CTX %d: %s = %s\n", ctx->id, (char *)arg2, output);
printf("CTX %d: %s = %s\n", (int32_t)ctx->id, (char *)arg2, output);
} else {
printf("not found\n");
}
@ -596,6 +584,12 @@ int main(int argc, char **argv) {
else
printf("Error adding extension.\n");
res = lbm_add_extension("trigger", ext_trigger);
if (res)
printf("Extension added.\n");
else
printf("Error adding extension.\n");
/* Start evaluator thread */
if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
@ -671,7 +665,7 @@ int main(int argc, char **argv) {
sleep_callback(10);
}
lbm_cid cid = lbm_load_and_eval_program_incremental(&string_tok);
(void)lbm_load_and_eval_program_incremental(&string_tok);
lbm_continue_eval();
//printf("started ctx: %"PRI_UINT"\n", cid);
@ -854,7 +848,7 @@ int main(int argc, char **argv) {
lbm_create_string_char_channel(&string_tok_state,
&string_tok,
str);
lbm_cid cid = lbm_load_and_eval_expression(&string_tok);
(void)lbm_load_and_eval_expression(&string_tok);
lbm_continue_eval();
//printf("started ctx: %"PRI_UINT"\n", cid);

2
src/env.c
View File

@ -22,7 +22,7 @@
#include "heap.h"
#include "print.h"
lbm_value env_global;
static lbm_value env_global;
int lbm_init_env(void) {
env_global = ENC_SYM_NIL;

566
src/eval_cps.c
View File

File diff suppressed because it is too large Load Diff

22
src/extensions/array_extensions.c
View File

@ -913,7 +913,7 @@ lbm_value array_extension_buffer_length(lbm_value *args, lbm_uint argn) {
return res;
}
//TODO: Have to think about 32 vs 64 bit here
static lbm_value array_extensions_bufclear(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_EERROR;
@ -931,25 +931,25 @@ static lbm_value array_extensions_bufclear(lbm_value *args, lbm_uint argn) {
clear_byte = (uint8_t)lbm_dec_as_u32(args[1]);
}
unsigned int start = 0;
uint32_t start = 0;
if (argn >= 3) {
if (!lbm_is_number(args[2])) {
return res;
}
unsigned int start_new = lbm_dec_as_u32(args[2]);
uint32_t start_new = lbm_dec_as_u32(args[2]);
if (start_new < array->size) {
start = start_new;
} else {
return res;
}
}
unsigned int len = array->size - start;
// Truncates size on 64 bit build
uint32_t len = (uint32_t)array->size - start;
if (argn >= 4) {
if (!lbm_is_number(args[3])) {
return res;
}
unsigned int len_new = lbm_dec_as_u32(args[3]);
uint32_t len_new = lbm_dec_as_u32(args[3]);
if (len_new <= len) {
len = len_new;
}
@ -971,19 +971,19 @@ static lbm_value array_extensions_bufcpy(lbm_value *args, lbm_uint argn) {
lbm_array_header_t *array1 = (lbm_array_header_t *)lbm_car(args[0]);
unsigned int start1 = lbm_dec_as_u32(args[1]);
uint32_t start1 = lbm_dec_as_u32(args[1]);
lbm_array_header_t *array2 = (lbm_array_header_t *)lbm_car(args[2]);
unsigned int start2 = lbm_dec_as_u32(args[3]);
unsigned int len = lbm_dec_as_u32(args[4]);
uint32_t start2 = lbm_dec_as_u32(args[3]);
uint32_t len = lbm_dec_as_u32(args[4]);
if (start1 < array1->size && start2 < array2->size) {
if (len > (array1->size - start1)) {
len = (array1->size - start1);
len = ((uint32_t)array1->size - start1);
}
if (len > (array2->size - start2)) {
len = (array2->size - start2);
len = ((uint32_t)array2->size - start2);
}
memcpy((char*)array1->data + start1, (char*)array2->data + start2, len);

8
src/extensions/matvec_extensions.c
View File

@ -25,7 +25,7 @@ static const char *vector_float_desc = "Vector-Float";
static const char *matrix_float_desc = "Matrix-Float";
typedef struct {
unsigned int size;
lbm_uint size;
float data[1];
} vector_float_t;
@ -184,7 +184,7 @@ static lbm_value ext_axpy(lbm_value *args, lbm_uint argn ) {
if (X->size == Y->size) {
unsigned int res_size = X->size;
lbm_uint res_size = X->size;
res = vector_float_allocate(res_size);
if (!lbm_is_symbol_merror(res)) {
@ -214,7 +214,7 @@ static lbm_value ext_dot(lbm_value *args, lbm_uint argn) {
vector_float_t *Y = (vector_float_t*)lbm_get_custom_value(y);
if (X->size == Y->size) {
unsigned int res_size = X->size;
lbm_uint res_size = X->size;
float f_res = 0;
for (unsigned i = 0; i < res_size; i ++) {
@ -306,7 +306,7 @@ static lbm_value ext_matrix_to_list(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
if (argn == 1 && is_matrix_float(args[0])) {
matrix_float_t *lmat = (matrix_float_t*)lbm_get_custom_value(args[0]);
unsigned int size = lmat->rows * lmat->cols;
lbm_uint size = lmat->rows * lmat->cols;
res = lbm_heap_allocate_list(size);
if (lbm_is_cons(res)) {

11
src/extensions/string_extensions.c
View File

@ -134,7 +134,7 @@ static lbm_value ext_str_to_i(lbm_value *args, lbm_uint argn) {
base = (int)lbm_dec_as_u32(args[1]);
}
return lbm_enc_i32(strtol(str, NULL, base));
return lbm_enc_i32((int32_t)strtol(str, NULL, base));
}
static lbm_value ext_str_to_f(lbm_value *args, lbm_uint argn) {
@ -160,15 +160,15 @@ static lbm_value ext_str_part(lbm_value *args, lbm_uint argn) {
return ENC_SYM_EERROR;
}
size_t len = strlen(str);
uint32_t len = (uint32_t)strlen(str);
unsigned int start = lbm_dec_as_u32(args[1]);
uint32_t start = lbm_dec_as_u32(args[1]);
if (start >= len) {
return ENC_SYM_EERROR;
}
unsigned int n = len - start;
uint32_t n = len - start;
if (argn == 3) {
if (!lbm_is_number(args[2])) {
return ENC_SYM_EERROR;
@ -257,6 +257,7 @@ static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
}
}
// Todo: Clean this up for 64bit
static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
if (argn != 2 && argn != 3) {
return ENC_SYM_EERROR;
@ -413,7 +414,7 @@ static lbm_value ext_str_cmp(lbm_value *args, lbm_uint argn) {
// TODO: This is very similar to ext-print. Maybe they can share code.
static lbm_value to_str(char *delimiter, lbm_value *args, lbm_uint argn) {
const int str_len = 300;
char *str = lbm_malloc(str_len);
char *str = lbm_malloc((lbm_uint)str_len);
if (!str) {
return ENC_SYM_MERROR;
}

14
src/fundamental.c
View File

@ -665,24 +665,30 @@ 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();
lbm_value new_env = env;
lbm_value result = ENC_SYM_EERROR;
if (nargs == 1 && lbm_is_symbol(args[0])) {
result = lbm_env_drop_binding(env, args[0]);
if (result == ENC_SYM_NOT_FOUND) {
return env;
}
*lbm_get_env_ptr() = result;
} else if (nargs == 1 && lbm_is_cons(args[0])) {
lbm_value curr = args[0];
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value key = lbm_car(curr);
result = lbm_env_drop_binding(env, key);
result = lbm_env_drop_binding(new_env, key);
if (result != ENC_SYM_NOT_FOUND) {
new_env = result;
}
curr = lbm_cdr(curr);
}
*lbm_get_env_ptr() = result;
*lbm_get_env_ptr() = new_env;
}
return result;
return new_env;
}
static lbm_value fundamental_buf_create(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {

83
src/heap.c
View File

@ -1,6 +1,6 @@
/*
Copyright 2018, 2020, 2022 Joel Svensson svenssonjoel@yahoo.se
2022 Benjamin Vedder
Copyright 2018, 2020, 2022, 2023 Joel Svensson svenssonjoel@yahoo.se
2022 Benjamin Vedder
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
@ -79,7 +79,7 @@ lbm_value lbm_enc_u32(uint32_t x) {
#endif
}
lbm_value lbm_enc_float(float x) {
lbm_value lbm_enc_float(lbm_float x) {
#ifndef LBM64
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
@ -427,7 +427,7 @@ static int generate_freelist(size_t num_cells) {
for (i = 1; i < num_cells; i ++) {
t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
t->car = ENC_SYM_RECOVERED; // all cars in free list are "RECOVERED"
t->cdr = lbm_enc_cons_ptr(i);
t->cdr = lbm_enc_cons_ptr(i);
}
// Replace the incorrect pointer at the last cell.
@ -506,12 +506,13 @@ 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_heap_state.freelist = lbm_cdr(lbm_heap_state.freelist);
lbm_cons_t *rc = lbm_ref_cell(res);
lbm_heap_state.freelist = rc->cdr;
lbm_heap_state.num_alloc++;
lbm_ref_cell(res)->car = car;
lbm_ref_cell(res)->cdr = cdr;
rc->car = car;
rc->cdr = cdr;
res = lbm_set_ptr_type(res, ptr_type);
return res;
@ -526,53 +527,49 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr
}
}
lbm_value lbm_heap_allocate_list(unsigned int n) {
lbm_value lbm_heap_allocate_list(lbm_uint n) {
if (n == 0) return ENC_SYM_NIL;
if (lbm_heap_num_free() < n) return ENC_SYM_MERROR;
lbm_value res = lbm_heap_state.freelist;
if (lbm_type_of(res) == LBM_TYPE_CONS) {
lbm_value curr = lbm_heap_state.freelist;
lbm_value res = curr;
if (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value curr = res;
unsigned int count = 1;
while (lbm_type_of(curr) == LBM_TYPE_CONS && count < n) {
lbm_ref_cell(curr)->car = ENC_SYM_NIL;
curr = lbm_cdr(curr);
lbm_cons_t *c_cell = NULL;
lbm_uint count = 0;
do {
c_cell = lbm_ref_cell(curr);
c_cell->car = ENC_SYM_NIL;
curr = c_cell->cdr;
count ++;
}
lbm_set_car(curr, ENC_SYM_NIL);
lbm_heap_state.freelist = lbm_cdr(curr);
lbm_set_cdr(curr, ENC_SYM_NIL);
} while (count < n);
lbm_heap_state.freelist = curr;
c_cell->cdr = ENC_SYM_NIL;
lbm_heap_state.num_alloc+=count;
return res;
} else {
return ENC_SYM_FATAL_ERROR;
}
return ENC_SYM_FATAL_ERROR;
}
lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist) {
if (n == 0) {
return ENC_SYM_NIL;
}
if (lbm_heap_num_free() < n) {
return ENC_SYM_MERROR;
}
if (n == 0) return ENC_SYM_NIL;
if (lbm_heap_num_free() < n) return ENC_SYM_MERROR;
lbm_value res = lbm_heap_state.freelist;
if (lbm_type_of(res) == LBM_TYPE_CONS) {
lbm_value curr = lbm_heap_state.freelist;
lbm_value res = curr;
if (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value curr = res;
unsigned int count = 1;
while (lbm_type_of(curr) == LBM_TYPE_CONS && count < n) {
lbm_ref_cell(curr)->car = va_arg(valist, lbm_value);
curr = lbm_cdr(curr);
lbm_cons_t *c_cell = NULL;
unsigned int count = 0;
do {
c_cell = lbm_ref_cell(curr);
c_cell->car = va_arg(valist, lbm_value);
curr = c_cell->cdr;
count ++;
}
lbm_set_car(curr, va_arg(valist, lbm_value));
lbm_heap_state.freelist = lbm_cdr(curr);
lbm_set_cdr(curr, ENC_SYM_NIL);
} while (count < n);
lbm_heap_state.freelist = curr;
c_cell->cdr = ENC_SYM_NIL;
lbm_heap_state.num_alloc+=count;
va_end(valist);
return res;
}
return ENC_SYM_FATAL_ERROR;
@ -640,8 +637,8 @@ int lbm_gc_mark_phase(int num, ... ) { //lbm_value env) {
if (t_ptr >= LBM_NON_CONS_POINTER_TYPE_FIRST &&
t_ptr <= LBM_NON_CONS_POINTER_TYPE_LAST) continue;
res &= lbm_push(s, lbm_ref_cell(curr)->cdr);
res &= lbm_push(s, lbm_ref_cell(curr)->car);
res &= lbm_push(s, cell->cdr);
res &= lbm_push(s, cell->car);
if (!res) break;
}
@ -877,8 +874,8 @@ int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) {
}
/* calculate length of a proper list */
unsigned int lbm_list_length(lbm_value c) {
unsigned int len = 0;
lbm_uint lbm_list_length(lbm_value c) {
lbm_uint len = 0;
while (lbm_is_cons(c)){
len ++;

2
src/lbm_channel.c
View File

@ -368,7 +368,7 @@ void lbm_create_string_char_channel(lbm_string_channel_state_t *st,
char *str) {
st->str = str;
st->length = strlen(str);
st->length = (unsigned int)strlen(str);
st->read_pos = 0;
st->write_pos = 0;
st->more = false;

16
src/lbm_flat_value.c
View File

@ -274,9 +274,15 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
}
case S_FLOAT_VALUE: {
lbm_uint tmp;
if (extract_word(v, &tmp)) {
float f;
memcpy(&f, &tmp, sizeof(float));
bool b;
#ifndef LBM64
b = extract_word(v, &tmp);
#else
b = extract_dword(v, &tmp);
#endif
if (b) {
lbm_float f;
memcpy(&f, &tmp, sizeof(lbm_float));
lbm_value im = lbm_enc_float(f);
if (lbm_is_symbol_merror(im)) {
return UNFLATTEN_GC_RETRY;
@ -287,7 +293,7 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
return UNFLATTEN_MALFORMED;
}
case S_I32_VALUE: {
lbm_uint tmp;
uint32_t tmp;
if (extract_word(v, &tmp)) {
lbm_value im = lbm_enc_i32((int32_t)tmp);
if (lbm_is_symbol_merror(im)) {
@ -299,7 +305,7 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
return UNFLATTEN_MALFORMED;
}
case S_U32_VALUE: {
lbm_uint tmp;
uint32_t tmp;
if (extract_word(v, &tmp)) {
lbm_value im = lbm_enc_u32(tmp);
if (lbm_is_symbol_merror(im)) {

2
src/lbm_memory.c
View File

@ -81,7 +81,7 @@ int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
memory_base_address = (lbm_uint)data;
memory_size = data_size;
memory_num_free = data_size;
memory_reserve_level = (lbm_uint)(0.1 * data_size);
memory_reserve_level = (lbm_uint)(0.1 * (lbm_float)data_size);
res = 1;
}
mutex_unlock(&lbm_mem_mutex);

8
src/print.c
View File

@ -135,15 +135,15 @@ int print_emit_symbol(lbm_char_channel_t *chan, lbm_value sym) {
return print_emit_string(chan, str_ptr);
}
int print_emit_i(lbm_char_channel_t *chan, int32_t v) {
int print_emit_i(lbm_char_channel_t *chan, lbm_int v) {
char buf[EMIT_BUFFER_SIZE];
snprintf(buf, EMIT_BUFFER_SIZE, "%"PRIi32, v);
snprintf(buf, EMIT_BUFFER_SIZE, "%"PRI_INT, v);
return print_emit_string(chan, buf);
}
int print_emit_u(lbm_char_channel_t *chan, uint32_t v, bool ps) {
int print_emit_u(lbm_char_channel_t *chan, lbm_uint v, bool ps) {
char buf[EMIT_BUFFER_SIZE];
snprintf(buf, EMIT_BUFFER_SIZE, "%"PRIu32"%s", v, ps ? "u" : "");
snprintf(buf, EMIT_BUFFER_SIZE, "%"PRI_UINT"%s", v, ps ? "u" : "");
return print_emit_string(chan, buf);
}

1
src/symrepr.c
View File

@ -66,6 +66,7 @@ special_sym const special_symbols[] = {
{"exit-error" , SYM_EXIT_ERROR},
{"map" , SYM_MAP},
{"reverse" , SYM_REVERSE},
{"wait-for" , SYM_WAIT_FOR},
{"gc" , SYM_PERFORM_GC},
// pattern matching

23
tests/test_lisp_code_cps.c
View File

@ -113,9 +113,9 @@ void context_done_callback(eval_context_t *ctx) {
if (test_cid == ctx->id)
experiment_done = true;
int res = lbm_print_value(output, 128, t);
(void)lbm_print_value(output, 128, t);
printf("Thread %d finished: %s\n", ctx->id, output);
printf("Thread %d finished: %s\n", (int32_t)ctx->id, output);
}
bool dyn_load(const char *str, const char **code) {
@ -347,7 +347,7 @@ LBM_EXTENSION(ext_check, args, argn) {
printf("Test: Failed!\n");
printf("Result: %s\n", output);
}
return res;
return ENC_SYM_TRUE;
}
char *const_prg = "(define a 10) (+ a 1)";
@ -357,13 +357,18 @@ LBM_EXTENSION(ext_const_prg, args, argn) {
(void) argn;
lbm_value v = ENC_SYM_NIL;
char *str = const_prg;
if (!lbm_share_const_array(&v, const_prg, strlen(const_prg)+1))
return ENC_SYM_NIL;
return v;
}
LBM_EXTENSION(ext_trigger, args, argn) {
if (argn == 1 && lbm_is_number(args[0])) {
lbm_trigger_flags(lbm_dec_as_u32(args[0]));
return ENC_SYM_TRUE;
}
return ENC_SYM_NIL;
}
int main(int argc, char **argv) {
@ -681,6 +686,14 @@ int main(int argc, char **argv) {
return 0;
}
res = lbm_add_extension("trigger", ext_trigger);
if (res)
printf("Extension added.\n");
else {
printf("Error adding extension.\n");
return 0;
}
lbm_set_dynamic_load_callback(dyn_load);
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);

6
tests/test_undefine_1.lisp Normal file
View File

@ -0,0 +1,6 @@
(setvar 'apa 1)
(define bepa 2)
(undefine 'apa)
(check (= bepa 2))

7
tests/test_undefine_2.lisp Normal file
View File

@ -0,0 +1,7 @@
(define apa 1)
(setvar 'bepa 2)
(undefine 'apa)
(check (= bepa 2))

19
tests/test_undefine_3.lisp Normal file
View File

@ -0,0 +1,19 @@
(define a 10)
(defun f (n)
(if (= n 0) 0
(progn
(define b 100)
(undefine 'b)
(f (- n 1)))))
(f 10000)
(define b 75)
(check (and (= a 10)
(= b 75)))

15
tests/test_undefine_4.lisp Normal file
View File

@ -0,0 +1,15 @@
(setvar 'a 10)
(defun f (n)
(if (= n 0) 0
(progn
(setvar 'b 100)
(undefine 'b)
(f (- n 1)))))
(f 10000)
(define b 75)
(check (and (= a 10)
(= b 75)))

18
tests/test_undefine_5.lisp Normal file
View File

@ -0,0 +1,18 @@
(define a 10)
(defun f (n)
(if (= n 0) 0
(progn
(define b 100)
(undefine 'b)
(f (- n 1)))))
(f 10000)
(define c 5)
(f 10000)
(define b 75)
(check (and (= a 10)
(= b 75)
(= c 5)))

19
tests/test_undefine_6.lisp Normal file
View File

@ -0,0 +1,19 @@
(define a 10)
(defun f (n)
(if (= n 0) 0
(progn
(set 'a 10)
(define b 100)
(undefine 'b)
(f (- n 1)))))
(f 10000)
(undefine 'a)
(define c 5)
(f 10000)
(define b 75)
(check (and (= b 75)
(= c 5)))

5
tests/test_undefine_7.lisp Normal file
View File

@ -0,0 +1,5 @@
(define a 10)
(undefine 'kurt)
(check (= a 10))

7
tests/test_undefine_8.lisp Normal file
View File

@ -0,0 +1,7 @@
(define a 10)
(define b 20)
(undefine (list 'a))
(check (= b 20))

7
tests/test_undefine_9.lisp Normal file
View File

@ -0,0 +1,7 @@
(define a 10)
(define b 20)
(undefine (list 'a 'kurt 'russel))
(check (= b 20))

12
tests/test_wait_for_1.lisp Normal file
View File

@ -0,0 +1,12 @@
(defun f () {
(wait-for (shl 1 9))
(check 't)
})
(spawn f)
(trigger (shl 1 9))

16
tests/test_wait_for_2.lisp Normal file
View File

@ -0,0 +1,16 @@
(defun g () {
(wait-for (shl 1 3))
(check 't)
})
(defun f () {
(wait-for (shl 1 9))
(trigger (shl 1 3))
})
(spawn f)
(spawn g)
(trigger (shl 1 9))

19
tests/test_wait_for_3.lisp Normal file
View File

@ -0,0 +1,19 @@
(def a 0)
(defun g () {
(wait-for (shl 1 9))
(def a (+ a 1))
})
(defun f () {
(wait-for (shl 1 9))
(def a (+ a 1))
})
(spawn f)
(spawn g)
(yield 10000)
(trigger (shl 1 9))
(yield 10000)
(check (= a 2))