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

Merge commit '009da692a80074a0a931ce78416b3b70735d5842'

This commit is contained in:
Benjamin Vedder 2024-03-08 10:35:46 +01:00
parent c8be115bb5 009da692a8
commit 8a62f7a108
17 changed files with 9356 additions and 1363 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lispBM/lispBM/doc/images/list.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 7.0 KiB

After

Width:  |  Height:  |  Size: 43 KiB

2729
lispBM/lispBM/doc/lbmref.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

6
lispBM/lispBM/include/heap.h
View File

@ -510,6 +510,12 @@ lbm_value lbm_list_append(lbm_value list1, lbm_value list2);
* \return The list with the n first elements removed.
*/
lbm_value lbm_list_drop(unsigned int n, lbm_value ls);
/** Index into a list.
* \param l List to index into.
* \param n Position to read out of the list.
* \return Value at position n of l or nil if out of bounds.
*/
lbm_value lbm_index_list(lbm_value l, int32_t n);
// State and statistics
/** Get a copy of the heap statistics structure.

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

@ -339,7 +339,7 @@
#define SYM_SLEEP 0x30012
#define SYM_MERGE 0x30013
#define SYM_SORT 0x30014
#define SYM_REST_ARGS 0x30015
#define SYMBOL_KIND(X) ((X) >> 16)
#define SYMBOL_KIND_SPECIAL 0
@ -473,6 +473,7 @@
#define ENC_SYM_SLEEP ENC_SYM(SYM_SLEEP)
#define ENC_SYM_MERGE ENC_SYM(SYM_MERGE)
#define ENC_SYM_SORT ENC_SYM(SYM_SORT)
#define ENC_SYM_REST_ARGS ENC_SYM(SYM_REST_ARGS)
#define ENC_SYM_ADD ENC_SYM(SYM_ADD)
#define ENC_SYM_SUB ENC_SYM(SYM_SUB)

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

@ -132,6 +132,7 @@ bool lbm_symbol_list_entry_in_flash(char *str);
extern lbm_value symbol_x;
extern lbm_value symbol_y;
extern lbm_value symbol_rest_args;
#ifdef __cplusplus
}

161
lispBM/lispBM/repl/repl_exts.c
View File

@ -1,6 +1,6 @@
/*
Copyright 2024 Joel Svensson svenssonjoel@yahoo.se
2022 Benjamin Vedder benjamin@vedder.se
2022 Benjamin Vedder benjamin@vedder.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
@ -18,8 +18,11 @@
#include "repl_exts.h"
#include <unistd.h>
#include <stdio.h>
#include <dirent.h>
#include <sys/time.h>
#include <sys/wait.h>
// Macro expanders
@ -71,7 +74,7 @@ static lbm_value ext_me_defunret(lbm_value *argsi, lbm_uint argn) {
lbm_value body = argsi[2];
// (def name (lambda args (call-cc (lambda (return) body))))
return make_list(3,
lbm_enc_sym(SYM_DEFINE),
name,
@ -362,6 +365,147 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
return lbm_enc_sym(SYM_TRUE);
}
// ------------------------------------------------------------
// File IO
static const char *lbm_file_handle_desc = "File-Handle";
typedef struct {
FILE *fp;
} lbm_file_handle_t;
static bool file_handle_destructor(lbm_uint value) {
lbm_file_handle_t *h = (lbm_file_handle_t *)value;
if (h->fp) {
fclose(h->fp);
}
return true;
}
static bool is_file_handle(lbm_value h) {
return ((lbm_uint)lbm_get_custom_descriptor(h) == (lbm_uint)lbm_file_handle_desc);
}
static lbm_value ext_fopen(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
if (argn == 2 &&
lbm_is_array_r(args[0]) &&
lbm_is_array_r(args[1])) {
FILE *fp = NULL;
char *filename = lbm_dec_str(args[0]);
char *mode = lbm_dec_str(args[1]);
fp = fopen(filename, mode);
if (fp) {
lbm_file_handle_t *mem = lbm_malloc(sizeof(lbm_file_handle_t));
if (!mem) {
fclose(fp);
return ENC_SYM_MERROR;
}
mem->fp = fp;
lbm_custom_type_create((lbm_uint)mem,
file_handle_destructor,
lbm_file_handle_desc,
&res);
} else {
return ENC_SYM_NIL;
}
}
return res;
}
static lbm_value ext_fwrite(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
if (argn == 2 &&
is_file_handle(args[0]) &&
lbm_is_array_r(args[1])) {
lbm_file_handle_t *h = (lbm_file_handle_t*)lbm_get_custom_value(args[0]);
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[1]);
if (array) {
fwrite(array->data, 1, array->size, h->fp);
fflush(h->fp);
res = ENC_SYM_TRUE;
} else {
res = ENC_SYM_NIL;
}
}
return res;
}
static lbm_value ext_fwrite_str(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
if (argn == 2 &&
is_file_handle(args[0]) &&
lbm_is_array_r(args[1])) {
lbm_file_handle_t *h = (lbm_file_handle_t*)lbm_get_custom_value(args[0]);
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[1]);
if (array) {
fwrite(array->data, 1, strlen((char*)array->data), h->fp);
fflush(h->fp);
res = ENC_SYM_TRUE;
} else {
res = ENC_SYM_NIL;
}
}
return res;
}
static bool all_arrays(lbm_value *args, lbm_uint argn) {
bool r = true;
for (uint32_t i = 0; i < argn; i ++) {
r = r && lbm_is_array_r(args[i]);
}
return r;
}
static lbm_value ext_exec(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
int pid;
if (all_arrays(args, argn) && argn >= 1) {
char **strs = malloc(argn * sizeof(char*) + 1);
for (uint32_t i = 0; i < argn; i ++) {
strs[i] = lbm_dec_str(args[i]);
}
strs[argn] = NULL;
fflush(stdout);
int status = 0;
pid = fork();
if (pid == 0) {
execvp(strs[0], &strs[1]);
exit(0);
} else {
waitpid(pid, &status, 0);
res = ENC_SYM_TRUE;
}
}
return res;
}
static lbm_value ext_unsafe_call_system(lbm_value *args, lbm_uint argn) {
lbm_value res = ENC_SYM_TERROR;
if (argn == 1 && lbm_is_array_r(args[0])) {
int r = system(lbm_dec_str(args[0]));
if (r == 0) {
res = ENC_SYM_TRUE;
} else {
res = lbm_enc_i(r);
}
}
return res;
}
// ------------------------------------------------------------
// Init
@ -379,8 +523,13 @@ int init_exts(void) {
}
if (!lbm_runtime_extensions_init(false)) {
return 0;
}
}
lbm_add_extension("unsafe-call-system", ext_unsafe_call_system);
lbm_add_extension("exec", ext_exec);
lbm_add_extension("fopen", ext_fopen);
lbm_add_extension("fwrite", ext_fwrite);
lbm_add_extension("fwrite-str", ext_fwrite_str);
lbm_add_extension("print", ext_print);
lbm_add_extension("systime", ext_systime);
lbm_add_extension("secs-since", ext_secs_since);
@ -388,11 +537,11 @@ int init_exts(void) {
// Math
lbm_add_extension("rand", ext_rand);
lbm_add_extension("rand-max", ext_rand_max);
// Bit operations
lbm_add_extension("bits-enc-int", ext_bits_enc_int);
lbm_add_extension("bits-dec-int", ext_bits_dec_int);
// Macro expanders
lbm_add_extension("me-defun", ext_me_defun);
lbm_add_extension("me-defunret", ext_me_defunret);
@ -400,7 +549,7 @@ int init_exts(void) {
lbm_add_extension("me-loopwhile", ext_me_loopwhile);
lbm_add_extension("me-looprange", ext_me_looprange);
lbm_add_extension("me-loopforeach", ext_me_loopforeach);
return 1;
}

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

@ -91,15 +91,18 @@ static jmp_buf critical_error_jmp_buf;
#define LOOP_CONDITION CONTINUATION(42)
#define MERGE_REST CONTINUATION(43)
#define MERGE_LAYER CONTINUATION(44)
#define NUM_CONTINUATIONS 45
#define CLOSURE_ARGS_REST CONTINUATION(45)
#define NUM_CONTINUATIONS 46
#define FM_NEED_GC -1
#define FM_NO_MATCH -2
#define FM_PATTERN_ERROR -3
#define BL_OK 0
#define BL_NO_MEMORY -1
#define BL_INCORRECT_KEY -2
typedef enum {
BL_OK = 0,
BL_NO_MEMORY,
BL_INCORRECT_KEY
} binding_location_status;
#define FB_OK 0
#define FB_TYPE_ERROR -1
@ -1807,7 +1810,7 @@ static void eval_move_to_flash(eval_context_t *ctx) {
}
// Create a named location in an environment to later receive a value.
static int create_binding_location(lbm_value key, lbm_value *env) {
static binding_location_status create_binding_location(lbm_value key, lbm_value *env) {
if (lbm_is_symbol(key) &&
(key == ENC_SYM_NIL ||
@ -1846,22 +1849,23 @@ static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env,
while (lbm_is_cons(curr)) {
lbm_value new_env_tmp = env;
lbm_value key = get_caar(curr);
int r = create_binding_location(key, &new_env_tmp);
if (r < 0) {
binding_location_status r = create_binding_location(key, &new_env_tmp);
if (r != BL_OK) {
if (r == BL_NO_MEMORY) {
new_env_tmp = env;
lbm_gc_mark_phase(env);
gc();
r = create_binding_location(key, &new_env_tmp);
}
if (r < 0) {
if (r == BL_INCORRECT_KEY)
error_ctx(ENC_SYM_TERROR);
else if (r == BL_NO_MEMORY)
error_ctx(ENC_SYM_MERROR);
else
error_ctx(ENC_SYM_FATAL_ERROR);
return;
switch(r) {
case BL_OK:
break;
case BL_NO_MEMORY:
error_ctx(ENC_SYM_MERROR);
break;
case BL_INCORRECT_KEY:
error_ctx(ENC_SYM_TERROR);
break;
}
}
env = new_env_tmp;
@ -2316,16 +2320,24 @@ static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if ( nargs == 1) {
ctx->curr_exp = args[0];
lbm_stack_drop(&ctx->K, nargs+1);
} else if (nargs == 2) {
ctx->curr_exp = args[1];
ctx->curr_env = args[0];
} else {
lbm_set_error_reason((char*)lbm_error_str_num_args);
error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL);
}
lbm_stack_drop(&ctx->K, nargs+1);
}
static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (nargs == 1) {
lbm_value prg = args[0];
int prg_pos = 0;
if (nargs == 2) {
prg_pos = 1;
ctx->curr_env = args[0];
}
if (nargs == 1 || nargs == 2) {
lbm_value prg = args[prg_pos];
lbm_value app_cont;
lbm_value app_cont_prg;
lbm_value new_prg;
@ -2719,6 +2731,21 @@ static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
error_ctx(ENC_SYM_TERROR);
}
static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_value res;
if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS, ctx->curr_env)) {
if (nargs == 1 && lbm_is_number(args[0])) {
int32_t ix = lbm_dec_as_i32(args[0]);
res = lbm_index_list(res, ix);
}
ctx->r = res;
} else {
ctx->r = ENC_SYM_NIL;
}
lbm_stack_drop(&ctx->K, nargs+1);
ctx->app_cont = true;
}
/***************************************************/
/* Application lookup table */
@ -2746,6 +2773,7 @@ static const apply_fun fun_table[] =
apply_sleep,
apply_merge,
apply_sort,
apply_rest_args,
};
/***************************************************/
@ -2793,7 +2821,10 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c
fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
break;
default:
error_ctx(ENC_SYM_FATAL_ERROR);
// Symbols that are "special" but not in the way caught above
// ends up here.
lbm_set_error_reason("Symbol does not represent a function");
error_at_ctx(ENC_SYM_EERROR,fun_args[0]);
break;
}
}
@ -2810,6 +2841,9 @@ static void cont_closure_application_args(eval_context_t *ctx) {
lbm_value car_params, cdr_params;
get_car_and_cdr(params, &car_params, &cdr_params);
bool a_nil = args == ENC_SYM_NIL;
bool p_nil = cdr_params == ENC_SYM_NIL;
if (lbm_heap_num_free() < 2) {
gc();
if (lbm_heap_num_free() < 2) {
@ -2830,9 +2864,6 @@ static void cont_closure_application_args(eval_context_t *ctx) {
heap[cell1_ix].cdr = clo_env;
clo_env = cell1;
bool a_nil = args == ENC_SYM_NIL;
bool p_nil = cdr_params == ENC_SYM_NIL;
if (!a_nil && !p_nil) {
lbm_value car_args, cdr_args;
get_car_and_cdr(args, &car_args, &cdr_args);
@ -2842,6 +2873,31 @@ static void cont_closure_application_args(eval_context_t *ctx) {
stack_push(&ctx->K, CLOSURE_ARGS);
ctx->curr_exp = car_args;
ctx->curr_env = arg_env;
} else if (p_nil && !a_nil) {
if (lbm_heap_num_free() < 2) {
gc();
if (lbm_heap_num_free() < 2) {
error_ctx(ENC_SYM_MERROR);
}
}
lbm_value rest0 = lbm_heap_state.freelist;
lbm_uint rest0_ix = lbm_dec_ptr(rest0);
lbm_value rest1 = heap[rest0_ix].cdr;
lbm_uint rest1_ix = lbm_dec_ptr(rest1);
lbm_heap_state.freelist = heap[rest1_ix].cdr;
lbm_heap_state.num_alloc += 2;
heap[rest0_ix].car = ENC_SYM_REST_ARGS;
heap[rest0_ix].cdr = ENC_SYM_NIL;
heap[rest1_ix].car = rest0;
heap[rest1_ix].cdr = clo_env;
clo_env = rest1;
sptr[2] = clo_env;
sptr[3] = get_cdr(args);
sptr[4] = rest0; // last element of rest_args so far
stack_push(&ctx->K, CLOSURE_ARGS_REST);
ctx->curr_exp = get_car(args);
ctx->curr_env = arg_env;
} else if (a_nil && p_nil) {
// Arguments and parameters match up in number
lbm_stack_drop(&ctx->K, 5);
@ -2854,6 +2910,43 @@ static void cont_closure_application_args(eval_context_t *ctx) {
}
static void cont_closure_args_rest(eval_context_t *ctx) {
lbm_uint* sptr = get_stack_ptr(ctx, 5);
lbm_value arg_env = (lbm_value)sptr[0];
lbm_value exp = (lbm_value)sptr[1];
lbm_value clo_env = (lbm_value)sptr[2];
lbm_value args = (lbm_value)sptr[3];
lbm_value last = (lbm_value)sptr[4];
lbm_cons_t* heap = lbm_heap_state.heap;
lbm_value binding = lbm_heap_state.freelist;
if (binding == ENC_SYM_NIL) {
gc();
binding = lbm_heap_state.freelist;
if (binding == ENC_SYM_NIL) error_ctx(ENC_SYM_MERROR);
}
lbm_uint binding_ix = lbm_dec_ptr(binding);
lbm_heap_state.freelist = heap[binding_ix].cdr;
lbm_heap_state.num_alloc += 1;
heap[binding_ix].car = ctx->r;
heap[binding_ix].cdr = ENC_SYM_NIL;
lbm_set_cdr(last, binding);
sptr[4] = binding;
if (args == ENC_SYM_NIL) {
lbm_stack_drop(&ctx->K, 5);
ctx->curr_env = clo_env;
ctx->curr_exp = exp;
} else {
stack_push(&ctx->K, CLOSURE_ARGS_REST);
sptr[3] = get_cdr(args);
ctx->curr_exp = get_car(args);
ctx->curr_env = arg_env;
}
}
static void cont_application_args(eval_context_t *ctx) {
lbm_uint *sptr = get_stack_ptr(ctx, 3);
@ -2983,6 +3076,7 @@ static void cont_match(eval_context_t *ctx) {
if (lbm_is_symbol_nil(patterns)) {
// no more patterns
lbm_stack_drop(&ctx->K, 2);
ctx->r = ENC_SYM_NO_MATCH;
ctx->app_cont = true;
} else if (lbm_is_cons(patterns)) {
@ -3726,6 +3820,8 @@ static void cont_read_start_array(eval_context_t *ctx) {
lbm_set_error_reason("Out of memory while reading.");
lbm_channel_reader_close(str);
error_ctx(ENC_SYM_FATAL_ERROR);
// NOTE: If array is not created evaluation ends here.
// Static analysis seems unaware.
}
sptr[0] = array;
@ -3750,7 +3846,11 @@ static void cont_read_append_array(eval_context_t *ctx) {
error_ctx(ENC_SYM_MERROR);
}
lbm_array_header_t *arr = (lbm_array_header_t*)get_car(array); // TODO: Check
// get_car can return nil. Whose value is 0!
// So static Analysis is right about this being a potential NULL pointer.
// However, if the array was created correcly to begin with, it should be fine.
lbm_value arr_car = get_car(array);
lbm_array_header_t *arr = (lbm_array_header_t*)arr_car;
if (lbm_is_number(ctx->r)) {
((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);
@ -4535,6 +4635,7 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
cont_loop_condition,
cont_merge_rest,
cont_merge_layer,
cont_closure_args_rest,
};
/*********************************************************/

19
lispBM/lispBM/src/extensions/array_extensions.c
View File

@ -102,7 +102,6 @@ lbm_value array_extension_unsafe_free_array(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
if (lbm_memory_ptr_inside(array->data)) {
lbm_memory_free((lbm_uint *)array->data);
lbm_uint ptr = lbm_dec_ptr(args[0]);
@ -126,7 +125,6 @@ lbm_value array_extension_buffer_append_i8(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
@ -161,7 +159,6 @@ lbm_value array_extension_buffer_append_i16(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
@ -207,7 +204,6 @@ lbm_value array_extension_buffer_append_i24(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
@ -255,7 +251,6 @@ lbm_value array_extension_buffer_append_i32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
@ -298,7 +293,6 @@ lbm_value array_extension_buffer_append_u8(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
@ -337,7 +331,6 @@ lbm_value array_extension_buffer_append_u16(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
@ -383,7 +376,6 @@ lbm_value array_extension_buffer_append_u24(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
@ -431,7 +423,6 @@ lbm_value array_extension_buffer_append_u32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
@ -525,7 +516,6 @@ lbm_value array_extension_buffer_append_f32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
float f_value = (float)lbm_dec_as_float(args[2]);
lbm_value value = float_to_u(f_value);
@ -568,7 +558,6 @@ lbm_value array_extension_buffer_get_i8(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
@ -602,7 +591,6 @@ lbm_value array_extension_buffer_get_i16(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
@ -648,7 +636,6 @@ lbm_value array_extension_buffer_get_i32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
uint32_t value = 0;
@ -690,7 +677,6 @@ lbm_value array_extension_buffer_get_u8(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = 0;
@ -725,7 +711,6 @@ lbm_value array_extension_buffer_get_u16(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = 0;
@ -771,7 +756,6 @@ lbm_value array_extension_buffer_get_u24(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = 0;
@ -820,7 +804,6 @@ lbm_value array_extension_buffer_get_u32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
lbm_uint index = lbm_dec_as_u32(args[1]);
uint32_t value = 0;
@ -870,7 +853,6 @@ lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
uint32_t index = (uint32_t)lbm_dec_as_u32(args[1]);
uint32_t value = 0;
@ -907,7 +889,6 @@ lbm_value array_extension_buffer_length(lbm_value *args, lbm_uint argn) {
if (argn == 1 &&
lbm_is_array_r(args[0])) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array == NULL) return ENC_SYM_FATAL_ERROR;
res = lbm_enc_i((lbm_int)array->size);
}
return res;

89
lispBM/lispBM/src/extensions/string_extensions.c
View File

@ -211,39 +211,35 @@ static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
if (!split) {
if (lbm_is_number(args[1])) {
step = MAX(lbm_dec_as_i32(args[1]), 1);
lbm_value res = ENC_SYM_NIL;
int len = (int)strlen(str);
for (int i = len / step;i >= 0;i--) {
int ind_now = i * step;
if (ind_now >= len) {
continue;
}
int step_now = step;
while ((ind_now + step_now) > len) {
step_now--;
}
lbm_value tok;
if (lbm_create_array(&tok, (lbm_uint)step_now + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(tok);
memcpy(arr->data, str + ind_now, (unsigned int)step_now);
((char*)(arr->data))[step_now] = '\0';
res = lbm_cons(tok, res);
} else {
return ENC_SYM_MERROR;
}
}
return res;
} else {
return ENC_SYM_TERROR;
}
}
if (step > 0) {
lbm_value res = ENC_SYM_NIL;
int len = (int)strlen(str);
for (int i = len / step;i >= 0;i--) {
int ind_now = i * step;
if (ind_now >= len) {
continue;
}
int step_now = step;
while ((ind_now + step_now) > len) {
step_now--;
}
lbm_value tok;
if (lbm_create_array(&tok, (lbm_uint)step_now + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(tok);
memcpy(arr->data, str + ind_now, (unsigned int)step_now);
((char*)(arr->data))[step_now] = '\0';
res = lbm_cons(tok, res);
} else {
return ENC_SYM_MERROR;
}
}
return res;
} else {
lbm_value res = ENC_SYM_NIL;
lbm_value res = ENC_SYM_NIL;
const char *s = str;
while (*(s += strspn(s, split)) != '\0') {
size_t len = strcspn(s, split);
@ -257,10 +253,8 @@ static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
} else {
return ENC_SYM_MERROR;
}
s += len;
}
return lbm_list_destructive_reverse(res);
}
}
@ -291,7 +285,7 @@ static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
}
// See https://stackoverflow.com/questions/779875/what-function-is-to-replace-a-substring-from-a-string-in-c
char *result; // the return string
//char *result; // the return string
char *ins; // the next insert point
char *tmp; // varies
size_t len_rep; // length of rep (the string to remove)
@ -316,7 +310,7 @@ static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
lbm_value lbm_res;
if (lbm_create_array(&lbm_res, len_res)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
tmp = result = (char*)arr->data;
tmp = (char*)arr->data;
} else {
return ENC_SYM_MERROR;
}
@ -503,6 +497,34 @@ static lbm_value ext_str_len(lbm_value *args, lbm_uint argn) {
return lbm_enc_i((int)strlen_max(str, array->size));
}
static lbm_value ext_str_replicate(lbm_value *args, lbm_uint argn) {
if (argn != 2) {
lbm_set_error_reason((char*)lbm_error_str_num_args);
return ENC_SYM_EERROR;
}
lbm_value res = ENC_SYM_TERROR;
if (lbm_is_number(args[0]) &&
lbm_is_number(args[1])) {
uint32_t len = lbm_dec_as_u32(args[0]);
uint8_t c = lbm_dec_as_char(args[1]);
lbm_value lbm_res;
if (lbm_create_array(&lbm_res, len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
for (unsigned int i = 0;i < len;i++) {
((char*)(arr->data))[i] = (char)c;
}
((char*)(arr->data))[len] = '\0';
res = lbm_res;
} else {
res = ENC_SYM_MERROR;
}
}
return res;
}
bool lbm_string_extensions_init(void) {
@ -521,6 +543,7 @@ bool lbm_string_extensions_init(void) {
res = res && lbm_add_extension("to-str", ext_to_str);
res = res && lbm_add_extension("to-str-delim", ext_to_str_delim);
res = res && lbm_add_extension("str-len", ext_str_len);
res = res && lbm_add_extension("str-replicate", ext_str_replicate);
return res;
}

64
lispBM/lispBM/src/fundamental.c
View File

@ -23,6 +23,7 @@
#include "env.h"
#include "lbm_utils.h"
#include "lbm_custom_type.h"
#include "lbm_constants.h"
#include <stdio.h>
#include <math.h>
@ -334,27 +335,6 @@ static void array_create(lbm_value *args, lbm_uint nargs, lbm_value *result) {
}
}
static lbm_value index_list(lbm_value l, int32_t n) {
lbm_value curr = l;
if (n < 0) {
int32_t len = (int32_t)lbm_list_length(l);
n = len + n;
if (n < 0) return ENC_SYM_NIL;
}
while (lbm_is_cons(curr) &&
n > 0) {
curr = lbm_cdr(curr);
n --;
}
if (lbm_is_cons(curr)) {
return lbm_car(curr);
} else {
return ENC_SYM_NIL;
}
}
static lbm_value assoc_lookup(lbm_value key, lbm_value assoc) {
lbm_value curr = assoc;
while (lbm_is_cons(curr)) {
@ -467,14 +447,13 @@ static lbm_value fundamental_div(lbm_value *args, lbm_uint nargs, eval_context_t
static lbm_value fundamental_mod(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
(void) ctx;
lbm_uint res = args[0];
for (lbm_uint i = 1; i < nargs; i ++) {
res = mod2(res, args[i]);
if (lbm_type_of(res) == LBM_TYPE_SYMBOL) {
break;
}
if (nargs != 2) {
lbm_set_error_reason((char*)lbm_error_str_num_args);
return ENC_SYM_EERROR;
}
lbm_value res = args[0];
lbm_value arg2 = args[1];
res = mod2(res, arg2);
return res;
}
@ -774,7 +753,7 @@ static lbm_value fundamental_append(lbm_value *args, lbm_uint nargs, eval_contex
}
curr = args[i];
for (int j = n-1; j >= 0; j --) {
res = lbm_cons(index_list(curr,j),res);
res = lbm_cons(lbm_index_list(curr,j),res);
}
}
return(res);
@ -842,17 +821,20 @@ static lbm_value fundamental_symbol_to_string(lbm_value *args, lbm_uint nargs, e
static lbm_value fundamental_string_to_symbol(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
(void) ctx;
lbm_value result = ENC_SYM_EERROR;
if (nargs < 1 ||
lbm_is_array_r(args[0]))
return result;
lbm_array_header_t *arr = (lbm_array_header_t *)lbm_car(args[0]);
if (!arr) return ENC_SYM_FATAL_ERROR;
char *str = (char *)arr->data;
lbm_uint sym;
if (lbm_get_symbol_by_name(str, &sym)) {
result = lbm_enc_sym(sym);
} else if (lbm_add_symbol(str, &sym)) {
result = lbm_enc_sym(sym);
if (nargs == 1 &&
lbm_is_array_r(args[0])) {
lbm_array_header_t *arr = (lbm_array_header_t *)lbm_car(args[0]);
// TODO: String to symbol, string should be in LBM_memory..
// Some better sanity check is possible here.
// Check that array points into lbm_memory.
// Additionally check that it is a zero-terminated string.
char *str = (char *)arr->data;
lbm_uint sym;
if (lbm_get_symbol_by_name(str, &sym)) {
result = lbm_enc_sym(sym);
} else if (lbm_add_symbol(str, &sym)) {
result = lbm_enc_sym(sym);
}
}
return result;
}
@ -1009,7 +991,7 @@ static lbm_value fundamental_ix(lbm_value *args, lbm_uint nargs, eval_context_t
(void) ctx;
lbm_value result = ENC_SYM_EERROR;
if (nargs == 2 && IS_NUMBER(args[1])) {
result = index_list(args[0], lbm_dec_as_i32(args[1]));
result = lbm_index_list(args[0], lbm_dec_as_i32(args[1]));
}
return result;
}

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

@ -536,9 +536,8 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr
// all is as it should be (but no free cells)
return ENC_SYM_MERROR;
}
else {
return ENC_SYM_FATAL_ERROR;
}
// Unreachable, unless something very wrong
return ENC_SYM_FATAL_ERROR;
}
lbm_value lbm_heap_allocate_list(lbm_uint n) {
@ -1065,6 +1064,28 @@ lbm_value lbm_list_drop(unsigned int n, lbm_value ls) {
return curr;
}
lbm_value lbm_index_list(lbm_value l, int32_t n) {
lbm_value curr = l;
if (n < 0) {
int32_t len = (int32_t)lbm_list_length(l);
n = len + n;
if (n < 0) return ENC_SYM_NIL;
}
while (lbm_is_cons(curr) &&
n > 0) {
curr = lbm_cdr(curr);
n --;
}
if (lbm_is_cons(curr)) {
return lbm_car(curr);
} else {
return ENC_SYM_NIL;
}
}
// Arrays are part of the heap module because their lifespan is managed
// by the garbage collector. The data in the array is not stored

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

@ -76,6 +76,7 @@ special_sym const special_symbols[] = {
{"sort" , SYM_SORT},
{"gc" , SYM_PERFORM_GC},
{"loop" , SYM_LOOP},
{"rest-args" , SYM_REST_ARGS},
// pattern matching
{"?" , SYM_MATCH_ANY},
@ -243,8 +244,8 @@ int lbm_symrepr_init(void) {
symbol_table_size_strings = 0;
symbol_table_size_strings_flash = 0;
lbm_uint x;
lbm_uint y;
lbm_uint x = 0;
lbm_uint y = 0;
lbm_add_symbol("x", &x);
lbm_add_symbol("y", &y);
symbol_x = lbm_enc_sym(x);

6
lispBM/lispBM/tests/test_rest_args_1.lisp Normal file
View File

@ -0,0 +1,6 @@
(defun f (x) (rest-args))
(check (eq (f 1) nil))

6
lispBM/lispBM/tests/test_rest_args_2.lisp Normal file
View File

@ -0,0 +1,6 @@
(defun f (x)
(map (lambda (y) (+ x y)) (rest-args) ))
(check (eq (f 1 1 1) '(2 2)))

10
lispBM/lispBM/tests/test_rest_args_3.lisp Normal file
View File

@ -0,0 +1,10 @@
(defun f (x)
(lambda (y) (rest-args)))
(define g (f 1 2 3 4 5))
(check (and (eq (g 1) '(2 3 4 5))
(eq (g 1 2) '(2))))

10
lispBM/lispBM/tests/test_rest_args_4.lisp Normal file
View File

@ -0,0 +1,10 @@
(defun f (x)
(let ( (g (lambda (y) (rest-args))) )
(g 1 2 3 4 5 6)
))
(check (and (eq (f 1) '(2 3 4 5 6))
(eq (f 1 2) '(2 3 4 5 6))))