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

Merge commit '21f14aea6621784f3a0328a1ca37bb84cb8fdd7d'

This commit is contained in:
Benjamin Vedder 2022-02-21 12:02:15 +01:00
parent f5b84dd559 21f14aea66
commit 6c9bb736a2
37 changed files with 1285 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lispBM/lispBM/.clang_complete Normal file
View File

@ -0,0 +1 @@
-I./include

16
lispBM/lispBM/Makefile
View File

@ -1,4 +1,3 @@
CCFLAGS = -Wall -Wextra -Wshadow -pedantic -std=c99
ifndef PLATFORM
@ -52,16 +51,22 @@ ifeq ($(PLATFORM), pi) #for compiling natively on the pi
endif
SOURCE_DIR = src
INCLUDE_DIR = include
INCLUDE_DIR = -I./include -I./include/extensions
EXTENSIONS = src/extensions
$(shell mkdir -p ${BUILD_DIR})
$(shell mkdir -p ${BUILD_DIR}/extensions)
SRC = src
OBJ = obj
SOURCES = $(wildcard $(SOURCE_DIR)/*.c)
SOURCES += $(wildcard $(EXTENSIONS)/*.c)
OBJECTS = $(patsubst $(SOURCE_DIR)/%.c, $(BUILD_DIR)/%.o, $(SOURCES))
PLATSRCS = $(wildcard $(PLATFORMSRC)/*.c)
PLATOBJS = $(patsubst $(PLATFORMSRC)/%.c, $(BUILD_DIR)/%.o, $(PLATSRCS))
@ -85,14 +90,17 @@ src/prelude.xxd: src/prelude.lisp
xxd -i < src/prelude.lisp > src/prelude.xxd
$(BUILD_DIR)/%.o: $(SOURCE_DIR)/%.c src/prelude.xxd
$(CC) -I$(INCLUDE_DIR) -I$(PLATFORMINC) $(CCFLAGS) -c $< -o $@
$(CC) $(INCLUDE_DIR) -I$(PLATFORMINC) $(CCFLAGS) -c $< -o $@
$(BUILD_DIR)/heap_vis.o: $(SOURCE_DIR)/visual/heap_vis.c
$(CC) -I$(INCLUDE_DIR) -I$(PLAFORMINC) $(CCFLAGS) -c $< -o $@
$(CC) $(INCLUDE_DIR) -I$(PLAFORMINC) $(CCFLAGS) -c $< -o $@
test:
cd tests && ./run_tests.sh
clean:
rm src/prelude.xxd
rm -f ${BUILD_DIR}/*.o
rm -f ${BUILD_DIR}/extensions/*.o
rm -f ${BUILD_DIR}/*.a

44
lispBM/lispBM/README.md
View File

@ -30,7 +30,7 @@ All programming languages need a mascot, so here is the LispBM llama by [PixiLad
13. Quasiquotation.
14. Concurrency.
15. Message-passing.
16. Pattern-matching
16. Pattern-matching.
## Documentation
@ -48,27 +48,27 @@ There are [demonstrations on YouTube](https://youtube.com/playlist?list=PLtf_3Ta
4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com
## TODOs
1. (DONE) Write some tests that stresses the Garbage collector.
2. (DONE) Implement some "reference to X type", for uint32, int32.
3. (DONE) Write a small library of useful hofs.
4. (DONE) Improve handling of arguments in eval-cps.
5. (DONE) Code improvements with simplicity, clarity and readability in mind.
6. (DONE) Implement a small dedicated lisp reader/parser to replace MPC. MPC eats way to much memory for small platforms.
7. (DONE) Port to STM32f4 - 128K ram platform (will need big changes). (surely there will be some more bugs)
8. (DONE) Add STM32f4 example code (repl implementation)
9. (DONE) Port to nrf52840_pca10056 - 256k ram platform (same changes as above).
10. (DONE) Reduce size of builtins.c and put platform specific built in functions elsewhere. (Builtins.c will be removed an replaced by fundamentals.c)
11. (DONE) Implement 'progn' facility.
12. (DONE) Remove the "gensym" functionality havent found a use for it so far and it only complicates things.
13. (DONE) Add NRF52 example repl to repository
14. (DONE) Update all example REPLs after adding quasiquotation
15. (DONE) The parser allocates heap memory, but there is no interfacing with the GC there.
16. (DONE) The parser uses a lot of stack memory, fix by making tail recursive and accumulating lists onto heap directly.
17. (DONE) Rename files with names that may conflict with common stuff (memory.h, memory.c).
18. (DONE) It should be possible to reset the runtime system.
19. (DONE) Add messages to lisp process mailbox from C to unlock blocked proc.
20. Spawn closures specifically instead of expressions in general.
21. Implement some looping structure for speed or just ease of use.
1. [x] Write some tests that stresses the Garbage collector.
2. [x] Implement some "reference to X type", for uint32, int32.
3. [x] Write a small library of useful hofs.
4. [x] Improve handling of arguments in eval-cps.
5. [x] Code improvements with simplicity, clarity and readability in mind.
6. [x] Implement a small dedicated lisp reader/parser to replace MPC. MPC eats way to much memory for small platforms.
7. [x] Port to STM32f4 - 128K ram platform (will need big changes). (surely there will be some more bugs)
8. [x] Add STM32f4 example code (repl implementation)
9. [x] Port to nrf52840_pca10056 - 256k ram platform (same changes as above).
10. [x] Reduce size of builtins.c and put platform specific built in functions elsewhere. (Builtins.c will be removed an replaced by fundamentals.c)
11. [x] Implement 'progn' facility.
12. [x] Remove the "gensym" functionality havent found a use for it so far and it only complicates things.
13. [x] Add NRF52 example repl to repository
14. [x] Update all example REPLs after adding quasiquotation
15. [x] The parser allocates heap memory, but there is no interfacing with the GC there.
16. [x] The parser uses a lot of stack memory, fix by making tail recursive and accumulating lists onto heap directly.
17. [x] Rename files with names that may conflict with common stuff (memory.h, memory.c).
18. [x] It should be possible to reset the runtime system.
19. [x] Add messages to lisp process mailbox from C to unlock blocked proc.
20. [x] Spawn closures specifically instead of expressions in general.
21. [ ] Implement some looping structure for speed or just ease of use.
## Vague or continuosly ongoing todos
1. Doxygen?

1
lispBM/lispBM/benchmarks/bench_chibi/Makefile
View File

@ -138,6 +138,7 @@ LBMSRC = ../../src/compression.c \
../../src/tokpar.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

15
lispBM/lispBM/benchmarks/bench_chibi/main.c
View File

@ -38,9 +38,13 @@
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
#define HEAP_SIZE 2048
#define VARIABLE_STORAGE_SIZE 256
#define EXTENSION_STORAGE_SIZE 256
uint32_t gc_stack_storage[GC_STACK_SIZE];
uint32_t print_stack_storage[PRINT_STACK_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
static lbm_cons_t heap[HEAP_SIZE] __attribute__ ((aligned (8)));
@ -203,7 +207,9 @@ int main(void) {
gc_stack_storage, GC_STACK_SIZE,
memory_array, LBM_MEMORY_SIZE_8K,
bitmap_array, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE)) {
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE)) {
chprintf(chp,"LispBM Init failed.\r\n");
return 0;
}
@ -212,6 +218,8 @@ int main(void) {
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
res = lbm_add_extension("print", ext_print);
if (res)
chprintf(chp,"Extension added.\r\n");
@ -315,7 +323,10 @@ int main(void) {
gc_stack_storage, GC_STACK_SIZE,
memory_array, LBM_MEMORY_SIZE_8K,
bitmap_array, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE);
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
lbm_add_extension("print", ext_print);

2
lispBM/lispBM/benchmarks/fibonacci_tail.lisp
View File

@ -6,4 +6,4 @@
(fib0 n 0 1))))
(fib 23)
(fib 100)

1
lispBM/lispBM/chibios-examples/repl-ChibiOS/Makefile
View File

@ -138,6 +138,7 @@ LBMSRC = ../../src/compression.c \
../../src/tokpar.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

1
lispBM/lispBM/chibios-examples/xmas_dac/Makefile
View File

@ -138,6 +138,7 @@ LBMSRC = ../../src/env.c \
../../src/tokpar.c \
../../src/lispbm.c \
../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \

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

@ -69,7 +69,6 @@ extern lbm_value lbm_env_set(lbm_value env, lbm_value key, lbm_value val);
* \return The modified environment of Success and lbm_enc_sym(SYM_NOT_FOUND) if the key does not exist.
*/
extern lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val);
// Internal use
/** Extend an environment given a list of keys and a list of values.
*

25
lispBM/lispBM/include/extensions/array_extensions.h Normal file
View File

@ -0,0 +1,25 @@
/*
Copyright 2022 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
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#ifndef ARRAY_EXTENSIONS_H_
#define ARRAY_EXTENSIONS_H_
#include <stdbool.h>
extern bool lbm_array_extensions_init(void);
#endif

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

@ -335,6 +335,7 @@ extern lbm_int lbm_dec_as_i(lbm_value val);
*/
extern lbm_float lbm_dec_as_f(lbm_value val);
extern lbm_uint lbm_dec_raw(lbm_value v);
/** Allocates an lbm_cons_t cell from the heap and populates it.
*
* \param car The value to put in the car field of the allocated lbm_cons_t.
@ -595,6 +596,18 @@ static inline bool lbm_is_closure(lbm_value exp) {
(lbm_dec_sym(lbm_car(exp)) == SYM_CLOSURE));
}
static inline bool lbm_is_continuation(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_VAL_TYPE_SYMBOL) &&
(lbm_dec_sym(lbm_car(exp)) == SYM_CONT));
}
static inline bool lbm_is_macro(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_VAL_TYPE_SYMBOL) &&
(lbm_dec_sym(lbm_car(exp)) == SYM_MACRO));
}
static inline bool lbm_is_match_binder(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_VAL_TYPE_SYMBOL) &&

21
lispBM/lispBM/include/lbm_c_interop.h
View File

@ -87,7 +87,13 @@ extern int lbm_send_message(lbm_cid cid, lbm_value msg);
* \return 1 on success and 0 on failure.
*/
extern int lbm_define(char *symbol, lbm_value value);
/** Create a LispBM array from a C array. The array should be created while the evaluator
/** Remove a definition from the global environment.
*
* \param symbol Name of symbol to undefine in the environment.
* \return 1 if removed any bindings, 0 otherwise.
*/
extern int lbm_undefine(char *symbol);
/** Share a C array with LBM. The array should be created while the evaluator
* is paused and the array should be bound to something before un-pausing. Send the array in
* a message with \ref lbm_send_message or define it in the global with \ref lbm_define.
* The data is stored in the array as C values (not encoded as lbm values).
@ -97,8 +103,17 @@ extern int lbm_define(char *symbol, lbm_value value);
* \param type What type are the elements of the array.
* \param num_elt Number of elements in the array.
*/
extern int lbm_create_array(lbm_value *value, char *data, lbm_type type, uint32_t num_elt);
extern int lbm_share_array(lbm_value *value, char *data, lbm_type type, uint32_t num_elt);
/** Create an array to access from both LBM and C. This function should be called while the evaluator
* is paused and the array should be bound to something before un-pausing. Send the array in
* a message with \ref lbm_send_message or define it in the global with \ref lbm_define.
* The data is stored in lbm_memory as C values (not encoded as lbm values).
*
* \param value Result array value.
* \param type What type are the elements of the array.
* \param num_elt Number of elements in the array.
*/
extern int lbm_create_array(lbm_value *value, lbm_type type, uint32_t num_elt);
#endif

14
lispBM/lispBM/include/lbm_version.h
View File

@ -23,18 +23,28 @@
/** LBM major version */
#define LBM_MAJOR_VERSION 0
/** LBM minor version */
#define LBM_MINOR_VERSION 3
#define LBM_MINOR_VERSION 4
/** LBM patch revision */
#define LBM_PATCH_VERSION 0
/* Change log */
/* Feb 16 2022: version 0.3.0
/* Feb 20 2022: Version (0.4.0)
- Adds support for macros.
- Adds call-cc for escaping and abortive continuations.
*/
/* Feb 17 2022: version 0.3.0
- Added lbm_undefine to c_interop.
- Added lbm_share_array to c_interop.
- Added lbm_create_array to c_interop.
- #var variables with more efficient storage and lookup.
variables are set using `setvar`.
- Spawn optionally takes a number argument before the closure argument
to specify stack size.
- Extensions are stored in an array and occupy a range of dedicated symbol values.
*/
/* Feb 14 2022: version 0.2.0
Added GEQ >= and LEQ <= comparisons.

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

@ -56,6 +56,9 @@
#define SYM_MATCH 0x13
#define SYM_SEND 0x14
#define SYM_RECEIVE 0x15
#define SYM_MACRO 0x16
#define SYM_CALLCC 0x17
#define SYM_CONT 0x18
#define SYM_ARRAY_TYPE 0x20
#define SYM_BOXED_I_TYPE 0x21
@ -85,8 +88,9 @@
#define SYM_TYPE_ARRAY 0x56
#define SYM_TYPE_SYMBOL 0x57
#define SYM_TYPE_CHAR 0x58
#define SYM_TYPE_REF 0x59
#define SYM_TYPE_STREAM 0x5A
#define SYM_TYPE_BYTE 0x59
#define SYM_TYPE_REF 0x5A
#define SYM_TYPE_STREAM 0x5B
//Relevant for the tokenizer
#define SYM_OPENPAR 0x70
@ -130,7 +134,7 @@
#define SYM_ARRAY_READ 0x130
#define SYM_ARRAY_WRITE 0x131
//#define SYM_ARRAY_CREATE 0x132
#define SYM_ARRAY_CREATE 0x132
#define SYM_SYMBOL_TO_STRING 0x140
#define SYM_STRING_TO_SYMBOL 0x141

5
lispBM/lispBM/lispbm.mk
View File

@ -16,9 +16,12 @@ LISPBM_SRC = $(LISPBM)/src/env.c \
$(LISPBM)/src/eval_cps.c \
$(LISPBM)/src/streams.c \
$(LISPBM)/src/lbm_c_interop.c \
$(LISPBM)/src/lbm_variables.c
$(LISPBM)/src/lbm_variables.c \
$(LISPBM)/src/extensions/array_extensions.c
LISPBM_INC = -I$(LISPBM)/include \
-I$(LISPBM)/include/extensions \
-I$(LISPBM)/src
LISPBM_FLAGS = -lm

20
lispBM/lispBM/repl-cps/repl.c
View File

@ -26,6 +26,7 @@
#include <ctype.h>
#include "lispbm.h"
#include "extensions/array_extensions.h"
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
@ -352,6 +353,10 @@ int main(int argc, char **argv) {
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (!lbm_array_extensions_init()) {
printf("error adding array extensions");
}
res = lbm_add_extension("print", ext_print);
if (res)
printf("Extension added.\n");
@ -481,6 +486,8 @@ int main(int argc, char **argv) {
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
lbm_array_extensions_init();
lbm_add_extension("print", ext_print);
} else if (strncmp(str, ":prelude", 8) == 0) {
@ -534,6 +541,15 @@ int main(int argc, char **argv) {
int num = atoi(str + 5);
lbm_step_n_eval((uint32_t)num);
} else if (strncmp(str, ":undef", 6) == 0) {
lbm_pause_eval();
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
sleep_callback(10);
}
char *sym = str + 7;
printf("undefining: %s\n", sym);
printf("%s\n", lbm_undefine(sym) ? "Cleared bindings" : "No definition found");
lbm_continue_eval();
} else if (strncmp(str, ":array", 6) == 0) {
lbm_pause_eval_with_gc(30);
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
@ -542,10 +558,10 @@ int main(int argc, char **argv) {
printf("Evaluator paused\n");
lbm_value arr_val;
lbm_create_array(&arr_val, char_array, LBM_VAL_TYPE_CHAR,1024);
lbm_share_array(&arr_val, char_array, LBM_VAL_TYPE_CHAR,1024);
lbm_define("c-arr", arr_val);
lbm_create_array(&arr_val, (char *)word_array, LBM_PTR_TYPE_BOXED_I,1024);
lbm_share_array(&arr_val, (char *)word_array, LBM_PTR_TYPE_BOXED_I,1024);
lbm_define("i-arr", arr_val);
lbm_continue_eval();

3
lispBM/lispBM/src/compression.c
View File

@ -19,6 +19,7 @@
#include <ctype.h>
#include <lbm_types.h>
#include <string.h>
#include <strings.h>
#include <stdint.h>
#include <stdbool.h>
@ -119,7 +120,7 @@ int match_longest_key(char *string) {
for (int i = 0; i < NUM_CODES; i ++) {
unsigned int s_len = strlen(codes[i][KEY]);
if (s_len <= n) {
if (strncmp(codes[i][KEY], string, s_len) == 0) {
if (strncasecmp(codes[i][KEY], string, s_len) == 0) {
if (s_len > longest_match_length) {
longest_match_ix = i;
longest_match_length = s_len;

2
lispBM/lispBM/src/env.c
View File

@ -103,7 +103,6 @@ lbm_value lbm_env_set(lbm_value env, lbm_value key, lbm_value val) {
return new_env;
}
lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val) {
lbm_value curr = env;
@ -119,7 +118,6 @@ lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val) {
return lbm_enc_sym(SYM_NOT_FOUND);
}
lbm_value lbm_env_build_params_args(lbm_value params,
lbm_value args,
lbm_value env0) {

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

@ -49,8 +49,11 @@
#define MATCH 12
#define MATCH_MANY 13
#define READ 14
#define APPLICATION_START 15
#define EVAL_R 16
#define SET_VARIABLE 17
#define CHECK_STACK(x) \
if (!(x)) { \
ctx->done=true; \
@ -886,6 +889,40 @@ static inline void eval_quote(eval_context_t *ctx) {
ctx->app_cont = true;
}
static inline void eval_macro(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_callcc(eval_context_t *ctx) {
lbm_value continuation = NIL;
for (int i = (int)ctx->K.sp; i > 0; i --) {
CONS_WITH_GC(continuation, ctx->K.data[i-1], continuation, continuation);
}
lbm_value acont = NIL;
CONS_WITH_GC(acont, continuation, acont, continuation);
CONS_WITH_GC(acont, lbm_enc_sym(SYM_CONT), acont, acont);
/* Create an application */
lbm_value fun_arg = lbm_car(lbm_cdr(ctx->curr_exp));
lbm_value app = NIL;
CONS_WITH_GC(app, acont, app, acont);
CONS_WITH_GC(app, fun_arg, app, app);
//ctx->r = NIL;
ctx->curr_exp = app;
ctx->app_cont = false;
}
static inline void eval_continuation(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_define(eval_context_t *ctx) {
lbm_value key = lbm_car(lbm_cdr(ctx->curr_exp));
lbm_value val_exp = lbm_car(lbm_cdr(lbm_cdr(ctx->curr_exp)));
@ -1189,7 +1226,7 @@ static inline void cont_application(eval_context_t *ctx) {
}
lbm_value fun = fun_args[0];
if (lbm_type_of(fun) == LBM_PTR_TYPE_CONS) { // a closure (it better be)
if (lbm_is_closure(fun)) { // a closure (it better be)
lbm_value cdr_fun = lbm_cdr(fun);
lbm_value cddr_fun = lbm_cdr(cdr_fun);
@ -1218,6 +1255,18 @@ static inline void cont_application(eval_context_t *ctx) {
ctx->curr_exp = exp;
ctx->curr_env = clo_env; // local_env;
return;
} else if (lbm_is_continuation(fun)) {
lbm_value c = lbm_car(lbm_cdr(fun)); /* should be the continuation */
lbm_value arg = fun_args[1];
lbm_stack_clear(&ctx->K);
while (lbm_type_of(c) == LBM_PTR_TYPE_CONS) {
lbm_push_u32(&ctx->K, lbm_car(c));
c = lbm_cdr(c);
}
ctx->r = arg;
ctx->app_cont = true;
return;
} else if (lbm_type_of(fun) == LBM_VAL_TYPE_SYMBOL) {
/* eval_cps specific operations */
@ -1279,7 +1328,6 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_value aug_env;
WITH_GC(aug_env,lbm_cons(entry, clo_env),clo_env,entry);
clo_env = aug_env;
curr_param = lbm_cdr(curr_param);
i ++;
}
@ -1399,8 +1447,8 @@ static inline void cont_application_args(eval_context_t *ctx) {
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
rest == NIL) {
// no arguments
CHECK_STACK(lbm_push_u32_2(&ctx->K, count, lbm_enc_u(APPLICATION)));
ctx->app_cont = true;
CHECK_STACK(lbm_push_u32(&ctx->K, count));
cont_application(ctx);
} else if (lbm_type_of(rest) == LBM_PTR_TYPE_CONS) {
CHECK_STACK(lbm_push_u32_4(&ctx->K, env, lbm_enc_u(lbm_dec_u(count) + 1), lbm_cdr(rest), lbm_enc_u(APPLICATION_ARGS)));
ctx->curr_exp = lbm_car(rest);
@ -1842,6 +1890,66 @@ static inline void cont_read(eval_context_t *ctx) {
}
}
static inline void cont_application_start(eval_context_t *ctx) {
lbm_value args;
lbm_pop_u32(&ctx->K, &args);
if (lbm_is_macro(ctx->r)) {
/*
* Perform macro expansion.
* Macro expansion is really just evaluation in an
* environment augmented with the unevaluated expressions passed
* as arguments.
*/
lbm_value env;
lbm_pop_u32(&ctx->K, &env);
lbm_value curr_param = (lbm_car(lbm_cdr(ctx->r)));
lbm_value curr_arg = args;
lbm_value expand_env = env;
while (lbm_type_of(curr_param) == LBM_PTR_TYPE_CONS &&
lbm_type_of(curr_arg) == LBM_PTR_TYPE_CONS) {
lbm_value entry;
WITH_GC(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), expand_env,NIL);
lbm_value aug_env;
WITH_GC(aug_env,lbm_cons(entry, expand_env),expand_env,entry);
expand_env = aug_env;
curr_param = lbm_cdr(curr_param);
curr_arg = lbm_cdr(curr_arg);
}
/* Two rounds of evaluation is performed.
* First to instantiate the arguments into the macro body.
* Second to evaluate the resulting program.
*/
CHECK_STACK(lbm_push_u32_2(&ctx->K,
env,
lbm_enc_u(EVAL_R)));
lbm_value exp = lbm_car(lbm_cdr(lbm_cdr(ctx->r)));
ctx->curr_exp = exp;
ctx->curr_env = expand_env;
ctx->app_cont = false;
} else {
CHECK_STACK(lbm_push_u32_2(&ctx->K,
lbm_enc_u(0),
args));
cont_application_args(ctx);
}
}
static inline void cont_eval_r(eval_context_t* ctx) {
lbm_value env;
lbm_pop_u32(&ctx->K, &env);
ctx->curr_exp = ctx->r;
ctx->curr_env = env;
ctx->app_cont = false;
}
/*********************************************************/
/* Evaluator step function */
@ -1859,19 +1967,21 @@ static void evaluation_step(void){
ctx->app_cont = false;
switch(lbm_dec_u(k)) {
case DONE: advance_ctx(); return;
case SET_GLOBAL_ENV: cont_set_global_env(ctx); return;
case PROGN_REST: cont_progn_rest(ctx); return;
case WAIT: cont_wait(ctx); return;
case APPLICATION: cont_application(ctx); return;
case APPLICATION_ARGS: cont_application_args(ctx); return;
case AND: cont_and(ctx); return;
case OR: cont_or(ctx); return;
case BIND_TO_KEY_REST: cont_bind_to_key_rest(ctx); return;
case IF: cont_if(ctx); return;
case MATCH: cont_match(ctx); return;
case MATCH_MANY: cont_match_many(ctx); return;
case READ: cont_read(ctx); return;
case DONE: advance_ctx(); return;
case SET_GLOBAL_ENV: cont_set_global_env(ctx); return;
case PROGN_REST: cont_progn_rest(ctx); return;
case WAIT: cont_wait(ctx); return;
case APPLICATION: cont_application(ctx); return;
case APPLICATION_ARGS: cont_application_args(ctx); return;
case AND: cont_and(ctx); return;
case OR: cont_or(ctx); return;
case BIND_TO_KEY_REST: cont_bind_to_key_rest(ctx); return;
case IF: cont_if(ctx); return;
case MATCH: cont_match(ctx); return;
case MATCH_MANY: cont_match_many(ctx); return;
case READ: cont_read(ctx); return;
case APPLICATION_START: cont_application_start(ctx); return;
case EVAL_R: cont_eval_r(ctx); return;
case SET_VARIABLE: cont_set_var(ctx); return;
default:
error_ctx(lbm_enc_sym(SYM_EERROR));
@ -1913,18 +2023,25 @@ static void evaluation_step(void){
case SYM_MATCH: eval_match(ctx); return;
/* message passing primitives */
case SYM_RECEIVE: eval_receive(ctx); return;
case SYM_MACRO: eval_macro(ctx); return;
case SYM_CALLCC: eval_callcc(ctx); return;
case SYM_CONT: eval_continuation(ctx); return;
default: break; /* May be general application form. Checked below*/
}
} // If head is symbol
CHECK_STACK(lbm_push_u32_4(&ctx->K,
ctx->curr_env,
lbm_enc_u(0),
lbm_cdr(ctx->curr_exp),
lbm_enc_u(APPLICATION_ARGS)));
/*
* At this point head can be a closure, fundamental, extension or a macro.
* Anything else would be an error.
*/
CHECK_STACK(lbm_push_u32_3(&ctx->K,
ctx->curr_env,
lbm_cdr(ctx->curr_exp),
lbm_enc_u(APPLICATION_START)));
ctx->curr_exp = head; // evaluate the function
return;
break;
default:
// BUG No applicable case!
error_ctx(lbm_enc_sym(SYM_EERROR));

761
lispBM/lispBM/src/extensions/array_extensions.c Normal file
View File

@ -0,0 +1,761 @@
/*
Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
Copyright 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
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include "extensions/array_extensions.h"
#include "extensions.h"
#include "symrepr.h"
#include <math.h>
static lbm_uint little_endian = 0;
static lbm_uint big_endian = 0;
static lbm_value array_extension_buffer_append_i8(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_i16(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_i32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_u8(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_u16(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_u32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_append_f32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_i8(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_i16(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_i32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_u8(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_u16(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_u32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn);
bool lbm_array_extensions_init(void) {
if (!lbm_get_symbol_by_name("little-endian", &little_endian)) {
if (!lbm_add_symbol_const("little-endian", &little_endian)) {
return false;
}
}
if (!lbm_get_symbol_by_name("big-endian", &big_endian)) {
if (!lbm_add_symbol_const("big-endian", &big_endian)) {
return false;
}
}
bool res = true;
res = res && lbm_add_extension("buffer-append-i8", array_extension_buffer_append_i8);
res = res && lbm_add_extension("buffer-append-i16", array_extension_buffer_append_i16);
res = res && lbm_add_extension("buffer-append-i32", array_extension_buffer_append_i32);
res = res && lbm_add_extension("buffer-append-u8", array_extension_buffer_append_u8);
res = res && lbm_add_extension("buffer-append-u16", array_extension_buffer_append_u16);
res = res && lbm_add_extension("buffer-append-u32", array_extension_buffer_append_u32);
res = res && lbm_add_extension("buffer-append-f32", array_extension_buffer_append_f32);
res = res && lbm_add_extension("buffer-get-i8", array_extension_buffer_get_i8);
res = res && lbm_add_extension("buffer-get-i16", array_extension_buffer_get_i16);
res = res && lbm_add_extension("buffer-get-i32", array_extension_buffer_get_i32);
res = res && lbm_add_extension("buffer-get-u8", array_extension_buffer_get_u8);
res = res && lbm_add_extension("buffer-get-u16", array_extension_buffer_get_u16);
res = res && lbm_add_extension("buffer-get-u32", array_extension_buffer_get_u32);
res = res && lbm_add_extension("buffer-get-f32", array_extension_buffer_get_f32);
return res;
}
lbm_value array_extension_buffer_append_i8(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
if (argn == 3) {
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_int value = lbm_dec_as_i(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
data[index] = (uint8_t) value;
res = lbm_enc_sym(SYM_TRUE);
}
return res;
}
lbm_value array_extension_buffer_append_i16(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[3]) == little_endian) {
be = false;
}
/* fall through */
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_int value = lbm_dec_as_i(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index+1 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
data[index+1] = (uint8_t)value;
data[index] = (uint8_t)(value >> 8);
} else {
data[index] = (uint8_t)value;
data[index +1] = (uint8_t)(value >> 8);
}
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_append_i32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[3]) == little_endian) {
be = false;
}
/* fall through */
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_int value = lbm_dec_as_i(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
data[index+3] = (uint8_t) value;
data[index+2] = (uint8_t) (value >> 8);
data[index+1] = (uint8_t) (value >> 16);
data[index] = (uint8_t) (value >> 24);
} else {
data[index] = (uint8_t) value;
data[index+1] = (uint8_t) (value >> 8);
data[index+2] = (uint8_t) (value >> 16);
data[index+3] = (uint8_t) (value >> 24);
}
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_append_u8(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
switch(argn) {
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint value = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
data[index] = (uint8_t)value;
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_append_u16(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[3]) == little_endian) {
be = false;
}
/* fall through */
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint value = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index+1 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
data[index+1] = (uint8_t)value;
data[index] = (uint8_t)(value >> 8);
} else {
data[index] = (uint8_t)value;
data[index +1] = (uint8_t)(value >> 8);
}
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_append_u32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[3]) == little_endian) {
be = false;
}
/* fall through */
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint value = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
data[index+3] = (uint8_t)value;
data[index+2] = (uint8_t)(value >> 8);
data[index+1] = (uint8_t)(value >> 16);
data[index] = (uint8_t)(value >> 24);
} else {
data[index] = (uint8_t)value;
data[index+1] = (uint8_t)(value >> 8);
data[index+2] = (uint8_t)(value >> 16);
data[index+3] = (uint8_t)(value >> 24);
}
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
static lbm_uint float32_to_u32(float number) {
// Set subnormal numbers to 0 as they are not handled properly
// using this method.
if (fabsf(number) < 1.5e-38) {
number = 0.0;
}
int e = 0;
float sig = frexpf(number, &e);
float sig_abs = fabsf(sig);
uint32_t sig_i = 0;
if (sig_abs >= 0.5) {
sig_i = (uint32_t)((sig_abs - 0.5f) * 2.0f * 8388608.0f);
e += 126;
}
uint32_t res = ((e & 0xFF) << 23) | (sig_i & 0x7FFFFF);
if (sig < 0) {
res |= 1U << 31;
}
return res;
}
static float u32_to_float32(uint32_t v) {
int e = (v >> 23) & 0xFF;
uint32_t sig_i = v & 0x7FFFFF;
bool neg = v & (1U << 31);
float sig = 0.0;
if (e != 0 || sig_i != 0) {
sig = (float)sig_i / (8388608.0 * 2.0) + 0.5;
e -= 126;
}
if (neg) {
sig = -sig;
}
return ldexpf(sig, e);
}
lbm_value array_extension_buffer_append_f32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[3]) == little_endian) {
be = false;
}
/* fall through */
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1]) ||
!lbm_is_number(args[2])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
float f_value = lbm_dec_as_f(args[1]);
lbm_value value = float32_to_u32(f_value);
lbm_uint index = lbm_dec_as_u(args[2]);
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
data[index+3] = (uint8_t)value;
data[index+2] = (uint8_t)(value >> 8);
data[index+1] = (uint8_t)(value >> 16);
data[index] = (uint8_t)(value >> 24);
} else {
data[index] = (uint8_t)value;
data[index+1] = (uint8_t)(value >> 8);
data[index+2] = (uint8_t)(value >> 16);
data[index+3] = (uint8_t)(value >> 24);
}
res = lbm_enc_sym(SYM_TRUE);
break;
default:
break;
}
return res;
}
/* (buffer-get-i8 buffer index) */
/* (buffer-get-i16 buffer index little-endian) */
lbm_value array_extension_buffer_get_i8(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
if (argn == 2) {
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
value = data[index];
res = lbm_enc_i((lbm_int)value);
}
return res;
}
lbm_value array_extension_buffer_get_i16(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[2]) == little_endian) {
be = false;
}
/* fall through */
case 2:
if (lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index+1 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
value =
(lbm_uint) data[index+1] |
(lbm_uint) data[index] << 8;
} else {
value =
(lbm_uint) data[index] |
(lbm_uint) data[index+1] << 8;
}
res = lbm_enc_i((lbm_int)value);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_get_i32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[2]) == little_endian) {
be = false;
}
/* fall through */
case 2:
if (lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
value =
(lbm_uint) data[index+3] |
(lbm_uint) data[index+2] << 8 |
(lbm_uint) data[index+1] << 16 |
(lbm_uint) data[index] << 24;
} else {
value =
(lbm_uint) data[index] |
(lbm_uint) data[index+1] << 8 |
(lbm_uint) data[index+2] << 16 |
(lbm_uint) data[index+3] << 24;
}
res = lbm_enc_I((lbm_int)value);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_get_u8(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
if (argn == 2) {
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
value = data[index];
res = lbm_enc_u(value);
}
return res;
}
lbm_value array_extension_buffer_get_u16(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[2]) == little_endian) {
be = false;
}
/* fall through */
case 2:
if (lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index+1 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
value =
(lbm_uint) data[index+1] |
(lbm_uint) data[index] << 8;
} else {
value =
(lbm_uint) data[index] |
(lbm_uint) data[index+1] << 8;
}
res = lbm_enc_u(value);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_get_u32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[2]) == little_endian) {
be = false;
}
/* fall through */
case 2:
if (lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
value =
(lbm_uint) data[index+3] |
(lbm_uint) data[index+2] << 8 |
(lbm_uint) data[index+1] << 16 |
(lbm_uint) data[index] << 24;
} else {
value =
(lbm_uint) data[index] |
(lbm_uint) data[index+1] << 8 |
(lbm_uint) data[index+2] << 16 |
(lbm_uint) data[index+3] << 24;
}
res = lbm_enc_U(value);
break;
default:
break;
}
return res;
}
lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
bool be = true;
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
lbm_dec_sym(args[2]) == little_endian) {
be = false;
}
/* fall through */
case 2:
if (lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
!lbm_is_number(args[1])) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (array->elt_type != LBM_VAL_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
if (index+3 >= array->size) {
return res;
}
uint8_t *data = (uint8_t*)array->data;
if (be) {
value =
(lbm_uint) data[index+3] |
(lbm_uint) data[index+2] << 8 |
(lbm_uint) data[index+1] << 16 |
(lbm_uint) data[index] << 24;
} else {
value =
(lbm_uint) data[index] |
(lbm_uint) data[index+1] << 8 |
(lbm_uint) data[index+2] << 16 |
(lbm_uint) data[index+3] << 24;
}
res = lbm_enc_F(u32_to_float32(value));
break;
default:
break;
}
return res;
}
/*
void buffer_append_int16(uint8_t* buffer, int16_t number, int32_t *index);
void buffer_append_uint16(uint8_t* buffer, uint16_t number, int32_t *index);
void buffer_append_int32(uint8_t* buffer, int32_t number, int32_t *index);
void buffer_append_uint32(uint8_t* buffer, uint32_t number, int32_t *index);
void buffer_append_float16(uint8_t* buffer, float number, float scale, int32_t *index);
void buffer_append_float32(uint8_t* buffer, float number, float scale, int32_t *index);
void buffer_append_float32_auto(uint8_t* buffer, float number, int32_t *index);
int16_t buffer_get_int16(const uint8_t *buffer, int32_t *index);
uint16_t buffer_get_uint16(const uint8_t *buffer, int32_t *index);
int32_t buffer_get_int32(const uint8_t *buffer, int32_t *index);
uint32_t buffer_get_uint32(const uint8_t *buffer, int32_t *index);
float buffer_get_float16(const uint8_t *buffer, float scale, int32_t *index);
float buffer_get_float32(const uint8_t *buffer, float scale, int32_t *index);
float buffer_get_float32_auto(const uint8_t *buffer, int32_t *index);
*/

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

@ -437,7 +437,7 @@ void array_read(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
break;
case LBM_PTR_TYPE_BOXED_F:
curr = lbm_cons(((lbm_uint*)data)[i], lbm_enc_sym(SYM_BOXED_F_TYPE));
if (lbm_type_of(*result) == LBM_VAL_TYPE_SYMBOL) return;
if (lbm_type_of(curr) == LBM_VAL_TYPE_SYMBOL) return;
curr = lbm_set_ptr_type(curr, LBM_PTR_TYPE_BOXED_F);
break;
default:
@ -524,12 +524,39 @@ void array_write(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
}
//void array_create(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
// (void) args;
// (void) nargs;
// (void) result;
//
//}
/* (array-create type size) */
void array_create(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
*result = lbm_enc_sym(SYM_EERROR);
lbm_value array;
if (nargs == 2) {
if (lbm_type_of(args[0]) == LBM_VAL_TYPE_SYMBOL &&
lbm_is_number(args[1])) {
switch(lbm_dec_sym(args[0])) {
case SYM_TYPE_CHAR: /* fall through */
case SYM_TYPE_BYTE:
if (lbm_heap_allocate_array(&array, lbm_dec_as_u(args[1]), LBM_VAL_TYPE_BYTE))
*result = array;
break;
case SYM_TYPE_I32:
if (lbm_heap_allocate_array(&array, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_I))
*result = array;
break;
case SYM_TYPE_U32:
if (lbm_heap_allocate_array(&array, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_U))
*result = array;
break;
case SYM_TYPE_FLOAT:
if (lbm_heap_allocate_array(&array, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_F))
*result = array;
break;
default:
break;
}
}
}
}
lbm_value index_list(lbm_value l, unsigned int n) {
@ -979,9 +1006,9 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
case SYM_ARRAY_WRITE:
array_write(args, nargs, &result);
break;
// case SYM_ARRAY_CREATE:
// array_create(args, nargs, &result);
// break;
case SYM_ARRAY_CREATE:
array_create(args, nargs, &result);
break;
case SYM_TYPE_OF:
if (nargs != 1) return lbm_enc_sym(SYM_NIL);
lbm_value val = args[0];

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

@ -125,6 +125,26 @@ lbm_float lbm_dec_as_f(lbm_value a) {
return 0;
}
lbm_uint lbm_dec_raw(lbm_value v) {
lbm_uint res = 0;
switch (lbm_type_of(v)) {
case LBM_VAL_TYPE_CHAR: /* fall through */
case LBM_VAL_TYPE_I: /* fall through */
case LBM_VAL_TYPE_U: /* fall through */
res = (v >> LBM_VAL_SHIFT);
break;
case LBM_PTR_TYPE_BOXED_I: /* fall through */
case LBM_PTR_TYPE_BOXED_U: /* fall through */
case LBM_PTR_TYPE_BOXED_F: /* fall through */
res = lbm_car(v);
break;
default:
break;
}
return res;
}
// ref_cell: returns a reference to the cell addressed by bits 3 - 26
// Assumes user has checked that is_ptr was set

40
lispBM/lispBM/src/lbm_c_interop.c
View File

@ -18,7 +18,6 @@
#include "lbm_c_interop.h"
/****************************************************/
/* Interface for loading and running programs and */
/* expressions */
@ -177,7 +176,40 @@ int lbm_define(char *symbol, lbm_value value) {
return res;
}
int lbm_create_array(lbm_value *value, char *data, lbm_type type, uint32_t num_elt) {
int lbm_undefine(char *symbol) {
lbm_uint sym_id;
if (!lbm_get_symbol_by_name(symbol, &sym_id))
return 0;
lbm_value *env = lbm_get_env_ptr();
lbm_value curr;
lbm_value prev = *env;
int res = 0;
while (lbm_dec_sym(lbm_car(lbm_car(prev))) == sym_id ) {
*env =lbm_cdr(prev);
prev = lbm_cdr(prev);
res = 1;
}
curr = lbm_cdr(prev);
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
if (lbm_dec_sym(lbm_car(lbm_car(curr))) == sym_id) {
/* drop the curr mapping from the env */
lbm_set_cdr(prev, lbm_cdr(curr));
res = 1;
}
prev = curr;
curr = lbm_cdr(curr);
}
return res;
}
int lbm_share_array(lbm_value *value, char *data, lbm_type type, uint32_t num_elt) {
lbm_array_header_t *array = NULL;
lbm_value cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
@ -202,3 +234,7 @@ int lbm_create_array(lbm_value *value, char *data, lbm_type type, uint32_t num_e
*value = cell;
return 1;
}
int lbm_create_array(lbm_value *value, lbm_type type, uint32_t num_elt) {
return lbm_heap_allocate_array(value, type, num_elt);
}

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

@ -24,7 +24,7 @@
#include "symrepr.h"
#define NUM_SPECIAL_SYMBOLS 104
#define NUM_SPECIAL_SYMBOLS 109
#define NAME 0
#define ID 1
#define NEXT 2
@ -48,10 +48,15 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"read-program" , SYM_READ_PROGRAM},
//{"comma" , SYM_COMMA}, // should not be accessible to programmer
//{"splice" , SYM_COMMAAT},
{"match" , SYM_MATCH},
{"_" , SYM_DONTCARE},
{"send" , SYM_SEND},
{"recv" , SYM_RECEIVE},
{"match" , SYM_MATCH},
{"_" , SYM_DONTCARE},
{"send" , SYM_SEND},
{"recv" , SYM_RECEIVE},
{"macro" , SYM_MACRO},
{"call-cc" , SYM_CALLCC},
{"continuation" , SYM_CONT},
// pattern matching
{"?" , SYM_MATCH_ANY},
{"?i28" , SYM_MATCH_I28},
{"?u28" , SYM_MATCH_U28},
@ -99,6 +104,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"type-array" , SYM_TYPE_ARRAY},
{"type-symbol" , SYM_TYPE_SYMBOL},
{"type-char" , SYM_TYPE_CHAR},
{"type-byte" , SYM_TYPE_BYTE},
{"type-ref" , SYM_TYPE_REF},
{"type-stream" , SYM_TYPE_STREAM},
// Fundamental operations
@ -128,7 +134,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"append" , SYM_APPEND},
{"array-read" , SYM_ARRAY_READ},
{"array-write" , SYM_ARRAY_WRITE},
// {"array-create" , SYM_ARRAY_CREATE},
{"array-create" , SYM_ARRAY_CREATE},
{"type-of" , SYM_TYPE_OF},
{"sym2str" , SYM_SYMBOL_TO_STRING},
{"str2sym" , SYM_STRING_TO_SYMBOL},

1
lispBM/lispBM/src/tokpar.c
View File

@ -539,6 +539,7 @@ lbm_value lbm_get_next_token(lbm_tokenizer_char_stream_t *str) {
n = tok_string(str);
if (n >= 2) {
// TODO: Proper error checking here!
// TODO: Check if anything has to be allocated for the empty string
lbm_heap_allocate_array(&res, (unsigned int)(n-2)+1, LBM_VAL_TYPE_CHAR);
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
char *data = (char *)arr->data;

2
lispBM/lispBM/tests/Makefile
View File

@ -7,7 +7,7 @@ include $(LISPBM)/lispbm.mk
PLATFORM_INCLUDE = -I$(LISPBM)/platform/linux/include
PLATFORM_SRC = $(LISPBM)/platform/linux/src/platform_mutex.c
CCFLAGS = -g -m32 -O2 -Wall -Wconversion -pedantic -std=c11
CCFLAGS = -g -m32 -O2 -Wall -Wextra -Wshadow -Wconversion -pedantic -std=c99
CC=gcc
SRC = src

6
lispBM/lispBM/tests/run_tests.sh
View File

@ -31,6 +31,10 @@ expected_fails=("test_lisp_code_cps -h 512 test_qq_4.lisp"
"test_lisp_code_cps -c -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -c -h 512 test_take_iota_0.lisp"
"test_lisp_code_cps -h 512 test_array_extensions_0.lisp"
"test_lisp_code_cps -c -h 512 test_array_extensions_0.lisp"
"test_lisp_code_cps -h 512 test_array_extensions_1.lisp"
"test_lisp_code_cps -c -h 512 test_array_extensions_1.lisp"
)
@ -128,7 +132,7 @@ echo Tests failed: $fail_count
echo Expected fails: $expected_count
echo Actual fails: $((fail_count - expected_count))
if [ $fail_count -gt 0 ]
if [ $((fail_count - expected_count)) -gt 0 ]
then
exit 1
fi

23
lispBM/lispBM/tests/test_array_extensions_0.lisp Normal file
View File

@ -0,0 +1,23 @@
(define arr (array-create type-byte 10))
(buffer-append-i8 arr 70 0)
(buffer-append-i8 arr 69 1)
(buffer-append-i8 arr 68 2)
(buffer-append-i8 arr 67 3)
(buffer-append-i8 arr 66 4)
(buffer-append-i8 arr 65 5)
(buffer-append-i8 arr 64 6)
(buffer-append-i8 arr 63 7)
(buffer-append-i8 arr 62 8)
(buffer-append-i8 arr 61 9)
(and (= (buffer-get-i8 arr 0) 70)
(= (buffer-get-i8 arr 1) 69)
(= (buffer-get-i8 arr 2) 68)
(= (buffer-get-i8 arr 3) 67)
(= (buffer-get-i8 arr 4) 66)
(= (buffer-get-i8 arr 5) 65)
(= (buffer-get-i8 arr 6) 64)
(= (buffer-get-i8 arr 7) 63)
(= (buffer-get-i8 arr 8) 62)
(= (buffer-get-i8 arr 9) 61))

24
lispBM/lispBM/tests/test_array_extensions_1.lisp Normal file
View File

@ -0,0 +1,24 @@
(define arr (array-create type-byte 10))
(buffer-append-u8 arr 70 0)
(buffer-append-u8 arr 69 1)
(buffer-append-u8 arr 68 2)
(buffer-append-u8 arr 67 3)
(buffer-append-u8 arr 66 4)
(buffer-append-u8 arr 65 5)
(buffer-append-u8 arr 64 6)
(buffer-append-u8 arr 63 7)
(buffer-append-u8 arr 62 8)
(buffer-append-u8 arr 61 9)
(= (buffer-get-u8 arr 0) 70u28)
(and (num-eq (buffer-get-u8 arr 0) 70)
(num-eq (buffer-get-u8 arr 1) 69)
(num-eq (buffer-get-u8 arr 2) 68)
(num-eq (buffer-get-u8 arr 3) 67)
(num-eq (buffer-get-u8 arr 4) 66)
(num-eq (buffer-get-u8 arr 5) 65)
(num-eq (buffer-get-u8 arr 6) 64)
(num-eq (buffer-get-u8 arr 7) 63)
(num-eq (buffer-get-u8 arr 8) 62)
(num-eq (buffer-get-u8 arr 9) 61))

14
lispBM/lispBM/tests/test_array_extensions_2.lisp Normal file
View File

@ -0,0 +1,14 @@
(define arr (array-create type-byte 16))
(buffer-append-u32 arr 16777215 0)
(buffer-append-u32 arr 0xFFFFFFFF 4)
(buffer-append-u32 arr 10 8)
(buffer-append-u32 arr 0xDEADBEEF 12)
(and (num-eq (buffer-get-u32 arr 0) 16777215)
(num-eq (buffer-get-u32 arr 4) 0xFFFFFFFF)
(num-eq (buffer-get-u32 arr 8) 10)
(num-eq (buffer-get-u32 arr 12) 0xDEADBEEF))

11
lispBM/lispBM/tests/test_array_extensions_3.lisp Normal file
View File

@ -0,0 +1,11 @@
(define arr (array-create type-byte 16))
(buffer-append-i32 arr 16777215 0)
(buffer-append-i32 arr 0xFFFFFFFF 4)
(buffer-append-i32 arr 10 8)
(buffer-append-i32 arr 0xDEADBEEF 12)
(and (num-eq (buffer-get-i32 arr 0) 16777215)
(num-eq (buffer-get-i32 arr 4) 0xFFFFFFFF)
(num-eq (buffer-get-i32 arr 8) 10)
(num-eq (buffer-get-i32 arr 12) 0xDEADBEEF))

11
lispBM/lispBM/tests/test_array_extensions_4.lisp Normal file
View File

@ -0,0 +1,11 @@
(define arr (array-create type-byte 16))
(buffer-append-f32 arr 3.14 0)
(buffer-append-f32 arr 666.666 4)
(buffer-append-f32 arr 100 8)
(buffer-append-f32 arr 42 12)
(and (num-eq (buffer-get-f32 arr 0) 3.14)
(num-eq (buffer-get-f32 arr 4) 666.666)
(num-eq (buffer-get-f32 arr 8) 100)
(num-eq (buffer-get-f32 arr 12) 42))

14
lispBM/lispBM/tests/test_callcc_0.lisp Normal file
View File

@ -0,0 +1,14 @@
(define f (lambda (cc x)
(if (= x 0)
(cc 1000)
x)))
(define g (lambda (x y)
(+ x (call-cc (lambda (cc)
(f cc y))))))
(and (= (g 1 0) 1001)
(= (g 1 1) 2))

1
lispBM/lispBM/tests/test_hex_0.lisp Normal file
View File

@ -0,0 +1 @@
(= 0xFF 0xFF)

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

@ -26,15 +26,19 @@
#include <unistd.h>
#include "lispbm.h"
#include "extensions/array_extensions.h"
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256
#define EXTENSION_STORAGE_SIZE 256
#define VARIABLE_STORAGE_SIZE 256
uint32_t gc_stack_storage[GC_STACK_SIZE];
uint32_t print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
/* Tokenizer state for strings */
static lbm_tokenizer_string_state_t string_tok_state;
@ -46,6 +50,7 @@ static tokenizer_compressed_state_t comp_tok_state;
static lbm_tokenizer_char_stream_t string_tok;
void *eval_thd_wrapper(void *v) {
(void)v;
lbm_run_eval();
return NULL;
}
@ -226,6 +231,8 @@ int main(int argc, char **argv) {
return 0;
}
lbm_array_extensions_init();
res = lbm_add_extension("ext-even", ext_even);
if (res)
printf("Extension added.\n");
@ -245,6 +252,8 @@ int main(int argc, char **argv) {
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
printf("Error creating evaluation thread\n");
return 1;

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

@ -0,0 +1,6 @@
(define defun (macro (name args body)
`(define ,name (lambda ,args ,body))))
(defun f (x y) (+ x y))
(= (f 1 2) 3)

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

@ -0,0 +1,6 @@
(define #apa 10)
(define #bepa 20)
(define #cepa 30)
(and (= #bepa 20)
(= (+ #apa #bepa #cepa) 60))