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 CCFLAGS = -Wall -Wextra -Wshadow -pedantic -std=c99
ifndef PLATFORM ifndef PLATFORM
@ -52,16 +51,22 @@ ifeq ($(PLATFORM), pi) #for compiling natively on the pi
endif endif
SOURCE_DIR = src 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})
$(shell mkdir -p ${BUILD_DIR}/extensions)
SRC = src SRC = src
OBJ = obj OBJ = obj
SOURCES = $(wildcard $(SOURCE_DIR)/*.c) SOURCES = $(wildcard $(SOURCE_DIR)/*.c)
SOURCES += $(wildcard $(EXTENSIONS)/*.c)
OBJECTS = $(patsubst $(SOURCE_DIR)/%.c, $(BUILD_DIR)/%.o, $(SOURCES)) OBJECTS = $(patsubst $(SOURCE_DIR)/%.c, $(BUILD_DIR)/%.o, $(SOURCES))
PLATSRCS = $(wildcard $(PLATFORMSRC)/*.c) PLATSRCS = $(wildcard $(PLATFORMSRC)/*.c)
PLATOBJS = $(patsubst $(PLATFORMSRC)/%.c, $(BUILD_DIR)/%.o, $(PLATSRCS)) 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 xxd -i < src/prelude.lisp > src/prelude.xxd
$(BUILD_DIR)/%.o: $(SOURCE_DIR)/%.c 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 $(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: clean:
rm src/prelude.xxd rm src/prelude.xxd
rm -f ${BUILD_DIR}/*.o rm -f ${BUILD_DIR}/*.o
rm -f ${BUILD_DIR}/extensions/*.o
rm -f ${BUILD_DIR}/*.a 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. 13. Quasiquotation.
14. Concurrency. 14. Concurrency.
15. Message-passing. 15. Message-passing.
16. Pattern-matching 16. Pattern-matching.
## Documentation ## 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 4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com
## TODOs ## TODOs
1. (DONE) Write some tests that stresses the Garbage collector. 1. [x] Write some tests that stresses the Garbage collector.
2. (DONE) Implement some "reference to X type", for uint32, int32. 2. [x] Implement some "reference to X type", for uint32, int32.
3. (DONE) Write a small library of useful hofs. 3. [x] Write a small library of useful hofs.
4. (DONE) Improve handling of arguments in eval-cps. 4. [x] Improve handling of arguments in eval-cps.
5. (DONE) Code improvements with simplicity, clarity and readability in mind. 5. [x] 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. 6. [x] 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) 7. [x] 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) 8. [x] Add STM32f4 example code (repl implementation)
9. (DONE) Port to nrf52840_pca10056 - 256k ram platform (same changes as above). 9. [x] 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) 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. (DONE) Implement 'progn' facility. 11. [x] Implement 'progn' facility.
12. (DONE) Remove the "gensym" functionality havent found a use for it so far and it only complicates things. 12. [x] 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 13. [x] Add NRF52 example repl to repository
14. (DONE) Update all example REPLs after adding quasiquotation 14. [x] Update all example REPLs after adding quasiquotation
15. (DONE) The parser allocates heap memory, but there is no interfacing with the GC there. 15. [x] 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. 16. [x] 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). 17. [x] 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. 18. [x] It should be possible to reset the runtime system.
19. (DONE) Add messages to lisp process mailbox from C to unlock blocked proc. 19. [x] Add messages to lisp process mailbox from C to unlock blocked proc.
20. Spawn closures specifically instead of expressions in general. 20. [x] Spawn closures specifically instead of expressions in general.
21. Implement some looping structure for speed or just ease of use. 21. [ ] Implement some looping structure for speed or just ease of use.
## Vague or continuosly ongoing todos ## Vague or continuosly ongoing todos
1. Doxygen? 1. Doxygen?

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

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

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

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

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

@ -6,4 +6,4 @@
(fib0 n 0 1)))) (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/tokpar.c \
../../src/lispbm.c \ ../../src/lispbm.c \
../../src/lbm_c_interop.c \ ../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../platform/chibios/src/platform_mutex.c ../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \ CSRC = $(ALLCSRC) \

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

@ -138,6 +138,7 @@ LBMSRC = ../../src/env.c \
../../src/tokpar.c \ ../../src/tokpar.c \
../../src/lispbm.c \ ../../src/lispbm.c \
../../src/lbm_c_interop.c \ ../../src/lbm_c_interop.c \
../../src/lbm_variables.c \
../../platform/chibios/src/platform_mutex.c ../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \ 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. * \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); extern lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val);
// Internal use // Internal use
/** Extend an environment given a list of keys and a list of values. /** 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_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. /** 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. * \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)); (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) { static inline bool lbm_is_match_binder(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) && return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_VAL_TYPE_SYMBOL) && (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. * \return 1 on success and 0 on failure.
*/ */
extern int lbm_define(char *symbol, lbm_value value); 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 * 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. * 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). * 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 type What type are the elements of the array.
* \param num_elt Number of elements in 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 #endif

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

@ -23,18 +23,28 @@
/** LBM major version */ /** LBM major version */
#define LBM_MAJOR_VERSION 0 #define LBM_MAJOR_VERSION 0
/** LBM minor version */ /** LBM minor version */
#define LBM_MINOR_VERSION 3 #define LBM_MINOR_VERSION 4
/** LBM patch revision */ /** LBM patch revision */
#define LBM_PATCH_VERSION 0 #define LBM_PATCH_VERSION 0
/* Change log */ /* 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. - #var variables with more efficient storage and lookup.
variables are set using `setvar`. variables are set using `setvar`.
- Spawn optionally takes a number argument before the closure argument - Spawn optionally takes a number argument before the closure argument
to specify stack size. to specify stack size.
- Extensions are stored in an array and occupy a range of dedicated symbol values. - Extensions are stored in an array and occupy a range of dedicated symbol values.
*/
/* Feb 14 2022: version 0.2.0 /* Feb 14 2022: version 0.2.0
Added GEQ >= and LEQ <= comparisons. Added GEQ >= and LEQ <= comparisons.

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

@ -56,6 +56,9 @@
#define SYM_MATCH 0x13 #define SYM_MATCH 0x13
#define SYM_SEND 0x14 #define SYM_SEND 0x14
#define SYM_RECEIVE 0x15 #define SYM_RECEIVE 0x15
#define SYM_MACRO 0x16
#define SYM_CALLCC 0x17
#define SYM_CONT 0x18
#define SYM_ARRAY_TYPE 0x20 #define SYM_ARRAY_TYPE 0x20
#define SYM_BOXED_I_TYPE 0x21 #define SYM_BOXED_I_TYPE 0x21
@ -85,8 +88,9 @@
#define SYM_TYPE_ARRAY 0x56 #define SYM_TYPE_ARRAY 0x56
#define SYM_TYPE_SYMBOL 0x57 #define SYM_TYPE_SYMBOL 0x57
#define SYM_TYPE_CHAR 0x58 #define SYM_TYPE_CHAR 0x58
#define SYM_TYPE_REF 0x59 #define SYM_TYPE_BYTE 0x59
#define SYM_TYPE_STREAM 0x5A #define SYM_TYPE_REF 0x5A
#define SYM_TYPE_STREAM 0x5B
//Relevant for the tokenizer //Relevant for the tokenizer
#define SYM_OPENPAR 0x70 #define SYM_OPENPAR 0x70
@ -130,7 +134,7 @@
#define SYM_ARRAY_READ 0x130 #define SYM_ARRAY_READ 0x130
#define SYM_ARRAY_WRITE 0x131 #define SYM_ARRAY_WRITE 0x131
//#define SYM_ARRAY_CREATE 0x132 #define SYM_ARRAY_CREATE 0x132
#define SYM_SYMBOL_TO_STRING 0x140 #define SYM_SYMBOL_TO_STRING 0x140
#define SYM_STRING_TO_SYMBOL 0x141 #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/eval_cps.c \
$(LISPBM)/src/streams.c \ $(LISPBM)/src/streams.c \
$(LISPBM)/src/lbm_c_interop.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 \ LISPBM_INC = -I$(LISPBM)/include \
-I$(LISPBM)/include/extensions \
-I$(LISPBM)/src -I$(LISPBM)/src
LISPBM_FLAGS = -lm LISPBM_FLAGS = -lm

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

@ -26,6 +26,7 @@
#include <ctype.h> #include <ctype.h>
#include "lispbm.h" #include "lispbm.h"
#include "extensions/array_extensions.h"
#define EVAL_CPS_STACK_SIZE 256 #define EVAL_CPS_STACK_SIZE 256
#define GC_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); 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); res = lbm_add_extension("print", ext_print);
if (res) if (res)
printf("Extension added.\n"); printf("Extension added.\n");
@ -481,6 +486,8 @@ int main(int argc, char **argv) {
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE); lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
lbm_array_extensions_init();
lbm_add_extension("print", ext_print); lbm_add_extension("print", ext_print);
} else if (strncmp(str, ":prelude", 8) == 0) { } else if (strncmp(str, ":prelude", 8) == 0) {
@ -534,6 +541,15 @@ int main(int argc, char **argv) {
int num = atoi(str + 5); int num = atoi(str + 5);
lbm_step_n_eval((uint32_t)num); 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) { } else if (strncmp(str, ":array", 6) == 0) {
lbm_pause_eval_with_gc(30); lbm_pause_eval_with_gc(30);
while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) { while(lbm_get_eval_state() != EVAL_CPS_STATE_PAUSED) {
@ -542,10 +558,10 @@ int main(int argc, char **argv) {
printf("Evaluator paused\n"); printf("Evaluator paused\n");
lbm_value arr_val; 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_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_define("i-arr", arr_val);
lbm_continue_eval(); lbm_continue_eval();

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

@ -19,6 +19,7 @@
#include <ctype.h> #include <ctype.h>
#include <lbm_types.h> #include <lbm_types.h>
#include <string.h> #include <string.h>
#include <strings.h>
#include <stdint.h> #include <stdint.h>
#include <stdbool.h> #include <stdbool.h>
@ -119,7 +120,7 @@ int match_longest_key(char *string) {
for (int i = 0; i < NUM_CODES; i ++) { for (int i = 0; i < NUM_CODES; i ++) {
unsigned int s_len = strlen(codes[i][KEY]); unsigned int s_len = strlen(codes[i][KEY]);
if (s_len <= n) { 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) { if (s_len > longest_match_length) {
longest_match_ix = i; longest_match_ix = i;
longest_match_length = s_len; 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; return new_env;
} }
lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val) { lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val) {
lbm_value curr = env; 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); return lbm_enc_sym(SYM_NOT_FOUND);
} }
lbm_value lbm_env_build_params_args(lbm_value params, lbm_value lbm_env_build_params_args(lbm_value params,
lbm_value args, lbm_value args,
lbm_value env0) { lbm_value env0) {

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

@ -49,8 +49,11 @@
#define MATCH 12 #define MATCH 12
#define MATCH_MANY 13 #define MATCH_MANY 13
#define READ 14 #define READ 14
#define APPLICATION_START 15
#define EVAL_R 16
#define SET_VARIABLE 17 #define SET_VARIABLE 17
#define CHECK_STACK(x) \ #define CHECK_STACK(x) \
if (!(x)) { \ if (!(x)) { \
ctx->done=true; \ ctx->done=true; \
@ -886,6 +889,40 @@ static inline void eval_quote(eval_context_t *ctx) {
ctx->app_cont = true; 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) { static inline void eval_define(eval_context_t *ctx) {
lbm_value key = lbm_car(lbm_cdr(ctx->curr_exp)); lbm_value key = lbm_car(lbm_cdr(ctx->curr_exp));
lbm_value val_exp = lbm_car(lbm_cdr(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]; 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 cdr_fun = lbm_cdr(fun);
lbm_value cddr_fun = lbm_cdr(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_exp = exp;
ctx->curr_env = clo_env; // local_env; ctx->curr_env = clo_env; // local_env;
return; 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) { } else if (lbm_type_of(fun) == LBM_VAL_TYPE_SYMBOL) {
/* eval_cps specific operations */ /* eval_cps specific operations */
@ -1279,7 +1328,6 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_value aug_env; lbm_value aug_env;
WITH_GC(aug_env,lbm_cons(entry, clo_env),clo_env,entry); WITH_GC(aug_env,lbm_cons(entry, clo_env),clo_env,entry);
clo_env = aug_env; clo_env = aug_env;
curr_param = lbm_cdr(curr_param); curr_param = lbm_cdr(curr_param);
i ++; i ++;
} }
@ -1399,8 +1447,8 @@ static inline void cont_application_args(eval_context_t *ctx) {
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL && if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
rest == NIL) { rest == NIL) {
// no arguments // no arguments
CHECK_STACK(lbm_push_u32_2(&ctx->K, count, lbm_enc_u(APPLICATION))); CHECK_STACK(lbm_push_u32(&ctx->K, count));
ctx->app_cont = true; cont_application(ctx);
} else if (lbm_type_of(rest) == LBM_PTR_TYPE_CONS) { } 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))); 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); 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 */ /* Evaluator step function */
@ -1859,19 +1967,21 @@ static void evaluation_step(void){
ctx->app_cont = false; ctx->app_cont = false;
switch(lbm_dec_u(k)) { switch(lbm_dec_u(k)) {
case DONE: advance_ctx(); return; case DONE: advance_ctx(); return;
case SET_GLOBAL_ENV: cont_set_global_env(ctx); return; case SET_GLOBAL_ENV: cont_set_global_env(ctx); return;
case PROGN_REST: cont_progn_rest(ctx); return; case PROGN_REST: cont_progn_rest(ctx); return;
case WAIT: cont_wait(ctx); return; case WAIT: cont_wait(ctx); return;
case APPLICATION: cont_application(ctx); return; case APPLICATION: cont_application(ctx); return;
case APPLICATION_ARGS: cont_application_args(ctx); return; case APPLICATION_ARGS: cont_application_args(ctx); return;
case AND: cont_and(ctx); return; case AND: cont_and(ctx); return;
case OR: cont_or(ctx); return; case OR: cont_or(ctx); return;
case BIND_TO_KEY_REST: cont_bind_to_key_rest(ctx); return; case BIND_TO_KEY_REST: cont_bind_to_key_rest(ctx); return;
case IF: cont_if(ctx); return; case IF: cont_if(ctx); return;
case MATCH: cont_match(ctx); return; case MATCH: cont_match(ctx); return;
case MATCH_MANY: cont_match_many(ctx); return; case MATCH_MANY: cont_match_many(ctx); return;
case READ: cont_read(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; case SET_VARIABLE: cont_set_var(ctx); return;
default: default:
error_ctx(lbm_enc_sym(SYM_EERROR)); error_ctx(lbm_enc_sym(SYM_EERROR));
@ -1913,18 +2023,25 @@ static void evaluation_step(void){
case SYM_MATCH: eval_match(ctx); return; case SYM_MATCH: eval_match(ctx); return;
/* message passing primitives */ /* message passing primitives */
case SYM_RECEIVE: eval_receive(ctx); return; 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*/ default: break; /* May be general application form. Checked below*/
} }
} // If head is symbol } // If head is symbol
CHECK_STACK(lbm_push_u32_4(&ctx->K, /*
ctx->curr_env, * At this point head can be a closure, fundamental, extension or a macro.
lbm_enc_u(0), * Anything else would be an error.
lbm_cdr(ctx->curr_exp), */
lbm_enc_u(APPLICATION_ARGS)));
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 ctx->curr_exp = head; // evaluate the function
return; break;
default: default:
// BUG No applicable case! // BUG No applicable case!
error_ctx(lbm_enc_sym(SYM_EERROR)); 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; break;
case LBM_PTR_TYPE_BOXED_F: case LBM_PTR_TYPE_BOXED_F:
curr = lbm_cons(((lbm_uint*)data)[i], lbm_enc_sym(SYM_BOXED_F_TYPE)); 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); curr = lbm_set_ptr_type(curr, LBM_PTR_TYPE_BOXED_F);
break; break;
default: 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) { /* (array-create type size) */
// (void) args; void array_create(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
// (void) nargs; *result = lbm_enc_sym(SYM_EERROR);
// (void) result; 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) { 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: case SYM_ARRAY_WRITE:
array_write(args, nargs, &result); array_write(args, nargs, &result);
break; break;
// case SYM_ARRAY_CREATE: case SYM_ARRAY_CREATE:
// array_create(args, nargs, &result); array_create(args, nargs, &result);
// break; break;
case SYM_TYPE_OF: case SYM_TYPE_OF:
if (nargs != 1) return lbm_enc_sym(SYM_NIL); if (nargs != 1) return lbm_enc_sym(SYM_NIL);
lbm_value val = args[0]; 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; 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 // ref_cell: returns a reference to the cell addressed by bits 3 - 26
// Assumes user has checked that is_ptr was set // 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" #include "lbm_c_interop.h"
/****************************************************/ /****************************************************/
/* Interface for loading and running programs and */ /* Interface for loading and running programs and */
/* expressions */ /* expressions */
@ -177,7 +176,40 @@ int lbm_define(char *symbol, lbm_value value) {
return res; 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_array_header_t *array = NULL;
lbm_value cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS); 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; *value = cell;
return 1; 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" #include "symrepr.h"
#define NUM_SPECIAL_SYMBOLS 104 #define NUM_SPECIAL_SYMBOLS 109
#define NAME 0 #define NAME 0
#define ID 1 #define ID 1
#define NEXT 2 #define NEXT 2
@ -48,10 +48,15 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"read-program" , SYM_READ_PROGRAM}, {"read-program" , SYM_READ_PROGRAM},
//{"comma" , SYM_COMMA}, // should not be accessible to programmer //{"comma" , SYM_COMMA}, // should not be accessible to programmer
//{"splice" , SYM_COMMAAT}, //{"splice" , SYM_COMMAAT},
{"match" , SYM_MATCH}, {"match" , SYM_MATCH},
{"_" , SYM_DONTCARE}, {"_" , SYM_DONTCARE},
{"send" , SYM_SEND}, {"send" , SYM_SEND},
{"recv" , SYM_RECEIVE}, {"recv" , SYM_RECEIVE},
{"macro" , SYM_MACRO},
{"call-cc" , SYM_CALLCC},
{"continuation" , SYM_CONT},
// pattern matching
{"?" , SYM_MATCH_ANY}, {"?" , SYM_MATCH_ANY},
{"?i28" , SYM_MATCH_I28}, {"?i28" , SYM_MATCH_I28},
{"?u28" , SYM_MATCH_U28}, {"?u28" , SYM_MATCH_U28},
@ -99,6 +104,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"type-array" , SYM_TYPE_ARRAY}, {"type-array" , SYM_TYPE_ARRAY},
{"type-symbol" , SYM_TYPE_SYMBOL}, {"type-symbol" , SYM_TYPE_SYMBOL},
{"type-char" , SYM_TYPE_CHAR}, {"type-char" , SYM_TYPE_CHAR},
{"type-byte" , SYM_TYPE_BYTE},
{"type-ref" , SYM_TYPE_REF}, {"type-ref" , SYM_TYPE_REF},
{"type-stream" , SYM_TYPE_STREAM}, {"type-stream" , SYM_TYPE_STREAM},
// Fundamental operations // Fundamental operations
@ -128,7 +134,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"append" , SYM_APPEND}, {"append" , SYM_APPEND},
{"array-read" , SYM_ARRAY_READ}, {"array-read" , SYM_ARRAY_READ},
{"array-write" , SYM_ARRAY_WRITE}, {"array-write" , SYM_ARRAY_WRITE},
// {"array-create" , SYM_ARRAY_CREATE}, {"array-create" , SYM_ARRAY_CREATE},
{"type-of" , SYM_TYPE_OF}, {"type-of" , SYM_TYPE_OF},
{"sym2str" , SYM_SYMBOL_TO_STRING}, {"sym2str" , SYM_SYMBOL_TO_STRING},
{"str2sym" , SYM_STRING_TO_SYMBOL}, {"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); n = tok_string(str);
if (n >= 2) { if (n >= 2) {
// TODO: Proper error checking here! // 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_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); lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
char *data = (char *)arr->data; 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_INCLUDE = -I$(LISPBM)/platform/linux/include
PLATFORM_SRC = $(LISPBM)/platform/linux/src/platform_mutex.c 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 CC=gcc
SRC = src 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 -c -h 1024 test_take_iota_0.lisp"
"test_lisp_code_cps -h 512 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 -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 Expected fails: $expected_count
echo Actual fails: $((fail_count - expected_count)) echo Actual fails: $((fail_count - expected_count))
if [ $fail_count -gt 0 ] if [ $((fail_count - expected_count)) -gt 0 ]
then then
exit 1 exit 1
fi 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 <unistd.h>
#include "lispbm.h" #include "lispbm.h"
#include "extensions/array_extensions.h"
#define EVAL_CPS_STACK_SIZE 256 #define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256 #define GC_STACK_SIZE 256
#define PRINT_STACK_SIZE 256 #define PRINT_STACK_SIZE 256
#define EXTENSION_STORAGE_SIZE 256 #define EXTENSION_STORAGE_SIZE 256
#define VARIABLE_STORAGE_SIZE 256
uint32_t gc_stack_storage[GC_STACK_SIZE]; uint32_t gc_stack_storage[GC_STACK_SIZE];
uint32_t print_stack_storage[PRINT_STACK_SIZE]; uint32_t print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE]; extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
/* Tokenizer state for strings */ /* Tokenizer state for strings */
static lbm_tokenizer_string_state_t string_tok_state; 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; static lbm_tokenizer_char_stream_t string_tok;
void *eval_thd_wrapper(void *v) { void *eval_thd_wrapper(void *v) {
(void)v;
lbm_run_eval(); lbm_run_eval();
return NULL; return NULL;
} }
@ -226,6 +231,8 @@ int main(int argc, char **argv) {
return 0; return 0;
} }
lbm_array_extensions_init();
res = lbm_add_extension("ext-even", ext_even); res = lbm_add_extension("ext-even", ext_even);
if (res) if (res)
printf("Extension added.\n"); printf("Extension added.\n");
@ -245,6 +252,8 @@ int main(int argc, char **argv) {
lbm_set_timestamp_us_callback(timestamp_callback); lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_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)) { if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
printf("Error creating evaluation thread\n"); printf("Error creating evaluation thread\n");
return 1; 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))