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

Merge commit '9a624330155a43f2a980fd22dae6de911840e34e'

This commit is contained in:
Benjamin Vedder 2022-03-25 15:47:05 +01:00
parent 7d2b5a2e84 9a62433015
commit 80d6068d8f
71 changed files with 2641 additions and 1139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
lispBM/lispBM/Makefile
View File

@ -13,8 +13,14 @@ else
AR=${CROSS_COMPILE}ar
endif
ifeq ($(PLATFORM),linux-x86-64)
$(error WILL NOT SUPPORT 64bit platforms)
ifeq ($(PLATFORM),linux-x64)
BUILD_DIR = build/linux-x64
CCFLAGS += -g -O2 -DLBM64
CCFLAGS += -D_PRELUDE
PLATFORMSRC = platform/linux/src
PLATFORMINC = platform/linux/include
CC=gcc
AR=ar
endif
ifeq ($(PLATFORM), zynq)

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

@ -135,17 +135,17 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
for (lbm_uint i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_PTR_TYPE_ARRAY) {
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_VAL_TYPE_CHAR:
case LBM_TYPE_CHAR:
chprintf(chp,"%s", (char*)array + 8);
break;
default:
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_VAL_TYPE_CHAR) {
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
if (lbm_dec_char(t) =='\n') {
chprintf(chp, "\r\n");
} else {
@ -262,7 +262,7 @@ int main(void) {
} else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
chprintf(chp,"Environment:\r\n");
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_print_value(outbuf,1024, lbm_car(curr));
curr = lbm_cdr(curr);

10
lispBM/lispBM/chibios-examples/repl-ChibiOS/main.c
View File

@ -128,17 +128,17 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
for (lbm_uint i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_PTR_TYPE_ARRAY) {
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_VAL_TYPE_CHAR:
chprintf(chp,"%s", (char*)array + 8);
case LBM_TYPE_CHAR:
chprintf(chp,"%s", (char*)array->data);
break;
default:
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_VAL_TYPE_CHAR) {
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
if (lbm_dec_char(t) =='\n') {
chprintf(chp, "\r\n");
} else {
@ -255,7 +255,7 @@ int main(void) {
} else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
chprintf(chp,"Environment:\r\n");
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_print_value(outbuf,1024, lbm_car(curr));
curr = lbm_cdr(curr);

6
lispBM/lispBM/chibios-examples/xmas_dac/main.c
View File

@ -230,17 +230,17 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
for (lbm_uint i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_PTR_TYPE_ARRAY) {
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_VAL_TYPE_CHAR:
case LBM_TYPE_CHAR:
chprintf(chp,"%s", (char*)array + 8);
break;
default:
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_VAL_TYPE_CHAR) {
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
if (lbm_dec_char(t) =='\n') {
chprintf(chp, "\r\n");
} else {

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

@ -754,9 +754,9 @@ You can also read code:
(read "(lambda (x) (+ x 1))")
```
That lambda you just read in from a string can be directly applied to an
argument.
argument if using an application of eval to evaluate the read lambda into a closure.
```clj
((read "(lambda (x) (+ x 1))") 10)
((eval (read "(lambda (x) (+ x 1))")) 10)
```
The code above evaluates to 11.

8
lispBM/lispBM/include/eval_cps.h
View File

@ -41,8 +41,8 @@ typedef struct eval_context_s{
bool app_cont;
lbm_stack_t K;
/* Process control */
uint32_t timestamp;
uint32_t sleep_us;
lbm_uint timestamp;
lbm_uint sleep_us;
lbm_cid id;
/* List structure */
struct eval_context_s *prev;
@ -86,7 +86,7 @@ extern int lbm_remove_done_ctx(lbm_cid cid, lbm_value *v);
* \param timeout_ms timeout in ms or 0 for no timeout.
* \return Result computed by the program running in the context.
*/
extern bool lbm_wait_ctx(lbm_cid cid, uint32_t timeout_ms);
extern bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms);
/** Creates a context and initializes it with the provided program. The context
@ -161,7 +161,7 @@ extern int lbm_set_error_reason(char *error_str);
* \param stack_size Stack size for the context.
* \return
*/
extern lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, uint32_t stack_size);
extern lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size);
/** Iterate over all ready contexts and apply function on each context.
*
* \param f Function to apply to each context.

22
lispBM/lispBM/include/exp_kind.h
View File

@ -50,21 +50,21 @@ typedef enum {
static inline lbm_exp_kind lbm_exp_kind_of(lbm_value exp) {
switch (lbm_type_of(exp)) {
case LBM_VAL_TYPE_SYMBOL:
case LBM_TYPE_SYMBOL:
if (!lbm_is_special(exp))
return EXP_VARIABLE;
// fall through
case LBM_PTR_TYPE_BOXED_F:
case LBM_PTR_TYPE_BOXED_U:
case LBM_PTR_TYPE_BOXED_I:
case LBM_VAL_TYPE_I:
case LBM_VAL_TYPE_U:
case LBM_VAL_TYPE_CHAR:
case LBM_PTR_TYPE_ARRAY:
case LBM_TYPE_FLOAT:
case LBM_TYPE_U32:
case LBM_TYPE_I32:
case LBM_TYPE_I:
case LBM_TYPE_U:
case LBM_TYPE_CHAR:
case LBM_TYPE_ARRAY:
return EXP_SELF_EVALUATING;
case LBM_PTR_TYPE_CONS: {
case LBM_TYPE_CONS: {
lbm_value head = lbm_car(exp);
if (lbm_type_of(head) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(head) == LBM_TYPE_SYMBOL) {
lbm_uint sym_id = lbm_dec_sym(head);
switch(sym_id){
case SYM_AND: return EXP_AND;
@ -79,7 +79,7 @@ static inline lbm_exp_kind lbm_exp_kind_of(lbm_value exp) {
}
} // end if symbol
if (lbm_type_of(lbm_cdr(exp)) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(lbm_cdr(exp)) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(lbm_cdr(exp)) == SYM_NIL) {
return EXP_NO_ARGS;
} else {

5
lispBM/lispBM/include/extensions.h
View File

@ -24,6 +24,9 @@
#include "heap.h"
#include "lbm_types.h"
#define LBM_EXTENSION(name, argv, argn) \
__attribute__((aligned(LBM_STORABLE_ADDRESS_ALIGNMENT))) lbm_value name(lbm_value *(argv), lbm_uint (argn))
/** Type representing an extension function.
* \param Pointer to array of lbm_values.
* \param Number of arguments.
@ -56,7 +59,7 @@ extern bool lbm_add_extension(char *sym_str, extension_fptr ext);
* \return true if the lbm_value respresents an extension otherwise false.
*/
static inline bool lbm_is_extension(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_VAL_TYPE_SYMBOL) &&
return ((lbm_type_of(exp) == LBM_TYPE_SYMBOL) &&
(lbm_get_extension(lbm_dec_sym(exp)) != NULL));
}
#endif

26
lispBM/lispBM/include/extensions/math_extensions.h Normal file
View File

@ -0,0 +1,26 @@
/*
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/>.
*/
#ifndef MATH_EXTENSIONS_H_
#define MATH_EXTENSIONS_H_
#include <stdbool.h>
bool lbm_math_extensions_init(void);
#endif

26
lispBM/lispBM/include/extensions/string_extensions.h Normal file
View File

@ -0,0 +1,26 @@
/*
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/>.
*/
#ifndef STRING_EXTENSIONS_H_
#define STRING_EXTENSIONS_H_
#include <stdbool.h>
bool lbm_string_extensions_init(void);
#endif

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

@ -25,6 +25,7 @@
#include "symrepr.h"
#include "streams.h"
#include "stack.h"
#include "lbm_memory.h"
/*
Planning for a more space efficient heap representation.
@ -183,24 +184,31 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
0000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8
1111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?)
*/
#ifndef LBM64
#define LBM_CONS_CELL_SIZE 8
#define LBM_ADDRESS_SHIFT 3
#define LBM_ADDRESS_SHIFT 2
#define LBM_VAL_SHIFT 4
#define LBM_PTR_MASK 0x00000001u
#define LBM_PTR_BIT 0x00000001u
#define LBM_PTR_VAL_MASK 0x03FFFFF8u
#define LBM_PTR_VAL_MASK 0x03FFFFFCu
#define LBM_PTR_TYPE_MASK 0xFC000000u
#define LBM_PTR_TYPE_CONS 0x10000000u
#define LBM_PTR_TYPE_BOXED_U 0x20000000u
#define LBM_PTR_TYPE_BOXED_I 0x30000000u
#define LBM_PTR_TYPE_BOXED_F 0x40000000u
#define LBM_POINTER_TYPE_FIRST 0x10000000u
#define LBM_TYPE_CONS 0x10000000u
#define LBM_NON_CONS_POINTER_TYPE_FIRST 0x20000000u
#define LBM_TYPE_U32 0x20000000u
#define LBM_TYPE_I32 0x30000000u
#define LBM_TYPE_I64 0x40000000u
#define LBM_TYPE_U64 0x50000000u
#define LBM_TYPE_FLOAT 0x60000000u
#define LBM_TYPE_DOUBLE 0x70000000u
#define LBM_NON_CONS_POINTER_TYPE_LAST 0x70000000u
#define LBM_POINTER_TYPE_LAST 0x70000000u
#define LBM_PTR_TYPE_ARRAY 0xD0000000u
#define LBM_PTR_TYPE_REF 0xE0000000u
#define LBM_PTR_TYPE_STREAM 0xF0000000u
#define LBM_TYPE_ARRAY 0xD0000000u
#define LBM_TYPE_REF 0xE0000000u
#define LBM_TYPE_STREAM 0xF0000000u
#define LBM_GC_MASK 0x00000002u
#define LBM_GC_MARKED 0x00000002u
@ -208,12 +216,51 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
#define LBM_VAL_MASK 0xFFFFFFF0u
#define LBM_VAL_TYPE_MASK 0x0000000Cu
// gc ptr
#define LBM_VAL_TYPE_SYMBOL 0x00000000u // 00 0 0
/// Character or byte.
#define LBM_VAL_TYPE_CHAR 0x00000004u // 01 0 0
#define LBM_VAL_TYPE_BYTE 0x00000004u
#define LBM_VAL_TYPE_U 0x00000008u // 10 0 0
#define LBM_VAL_TYPE_I 0x0000000Cu // 11 0 0
#define LBM_TYPE_SYMBOL 0x00000000u // 00 0 0
#define LBM_TYPE_CHAR 0x00000004u // 01 0 0
#define LBM_TYPE_BYTE 0x00000004u
#define LBM_TYPE_U 0x00000008u // 10 0 0
#define LBM_TYPE_I 0x0000000Cu // 11 0 0
#else /* 64 bit Version */
#define LBM_ADDRESS_SHIFT 2
#define LBM_VAL_SHIFT 8
#define LBM_PTR_MASK (lbm_uint)0x1
#define LBM_PTR_BIT (lbm_uint)0x1
#define LBM_PTR_VAL_MASK (lbm_uint)0x03FFFFFFFFFFFFFC
#define LBM_PTR_TYPE_MASK (lbm_uint)0xFC00000000000000
#define LBM_POINTER_TYPE_FIRST (lbm_uint)0x1000000000000000
#define LBM_TYPE_CONS (lbm_uint)0x1000000000000000
#define LBM_NON_CONS_POINTER_TYPE_FIRST (lbm_uint)0xA000000000000000
#define LBM_TYPE_U64 (lbm_uint)0xA000000000000000
#define LBM_TYPE_I64 (lbm_uint)0xB000000000000000
#define LBM_TYPE_DOUBLE (lbm_uint)0xC000000000000000
#define LBM_TYPE_ARRAY (lbm_uint)0xD000000000000000
#define LBM_TYPE_REF (lbm_uint)0xE000000000000000
#define LBM_TYPE_STREAM (lbm_uint)0xF000000000000000
#define LBM_NON_CONS_POINTER_TYPE_LAST (lbm_uint)0xF000000000000000
#define LBM_POINTER_TYPE_LAST (lbm_uint)0xF000000000000000
#define LBM_GC_MASK (lbm_uint)0x2
#define LBM_GC_MARKED (lbm_uint)0x2
/* 8 - 2 free bits to encode type information into */
#define LBM_VAL_MASK (lbm_uint)0xFFFFFFFFFFFFFF00
#define LBM_VAL_TYPE_MASK (lbm_uint)0xFC
// gc ptr
#define LBM_TYPE_SYMBOL (lbm_uint)0x0 // 00 00 00 0 0
#define LBM_TYPE_CHAR (lbm_uint)0x4 // 00 00 01 0 0
#define LBM_TYPE_BYTE (lbm_uint)0x4
#define LBM_TYPE_U (lbm_uint)0x8 // 00 00 10 0 0
#define LBM_TYPE_I (lbm_uint)0xC // 00 00 11 0 0
#define LBM_TYPE_U32 (lbm_uint)0x14// 00 01 01 0 0
#define LBM_TYPE_I32 (lbm_uint)0x18// 00 01 10 0 0
#define LBM_TYPE_FLOAT (lbm_uint)0x1C// 00 01 11 0 0
#endif
/** Struct representing a heap cons-cell.
*
@ -231,21 +278,23 @@ typedef struct {
lbm_value freelist; // list of free cons cells.
lbm_stack_t gc_stack;
uint32_t heap_size; // In number of cells.
uint32_t heap_bytes; // In bytes.
lbm_uint heap_size; // In number of cells.
lbm_uint heap_bytes; // In bytes.
uint32_t num_alloc; // Number of cells allocated.
uint32_t num_alloc_arrays; // Number of arrays allocated.
lbm_uint num_alloc; // Number of cells allocated.
lbm_uint num_alloc_arrays; // Number of arrays allocated.
uint32_t gc_num; // Number of times gc has been performed.
uint32_t gc_marked; // Number of cells marked by mark phase.
uint32_t gc_recovered; // Number of cells recovered by sweep phase.
uint32_t gc_recovered_arrays;// Number of arrays recovered by sweep.
uint32_t gc_least_free; // The smallest length of the freelist.
lbm_uint gc_num; // Number of times gc has been performed.
lbm_uint gc_marked; // Number of cells marked by mark phase.
lbm_uint gc_recovered; // Number of cells recovered by sweep phase.
lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep.
lbm_uint gc_least_free; // The smallest length of the freelist.
lbm_uint gc_last_free; // Number of elements on the freelist
// after most recent GC.
uint64_t gc_time_acc;
uint32_t gc_min_duration;
uint32_t gc_max_duration;
lbm_uint gc_time_acc;
lbm_uint gc_min_duration;
lbm_uint gc_max_duration;
} lbm_heap_state_t;
/**
@ -253,8 +302,8 @@ typedef struct {
*/
typedef struct {
lbm_type elt_type; /// Type of elements: VAL_TYPE_FLOAT, U, I or CHAR
uint32_t size; /// Number of elements
uint32_t *data; /// pointer to lbm_memory array or C array.
lbm_uint size; /// Number of elements
lbm_uint *data; /// pointer to lbm_memory array or C array.
} lbm_array_header_t;
/** Initialize heap storage.
@ -264,39 +313,39 @@ typedef struct {
* \param gc_stack_size Size of the gc_stack in number of words.
* \return 1 on success or 0 for failure.
*/
extern int lbm_heap_init(lbm_cons_t *addr, uint32_t num_cells,
uint32_t *gc_stack_storage, uint32_t gc_stack_size);
extern int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
lbm_uint *gc_stack_storage, lbm_uint gc_stack_size);
/** Add GC time statistics to heap_stats
*
* \param dur Duration as reported by the timestamp callback.
*/
extern void lbm_heap_new_gc_time(uint32_t dur);
extern void lbm_heap_new_gc_time(lbm_uint dur);
/** Add a new free_list length to the heap_stats.
*
* \param l Current length of freelist.
* Calculates a new freelist length and updates
* the GC statistics.
*/
extern void lbm_heap_new_freelist_length(uint32_t l);
extern void lbm_heap_new_freelist_length(void);
/** Check how many lbm_cons_t cells are on the free-list
*
* \return Number of free lbm_cons_t cells.
*/
extern unsigned int lbm_heap_num_free(void);
extern lbm_uint lbm_heap_num_free(void);
/** Check how many lbm_cons_t cells are allocated.
*
* \return Number of lbm_cons_t cells that are currently allocated.
*/
extern unsigned int lbm_heap_num_allocated(void);
extern lbm_uint lbm_heap_num_allocated(void);
/** Size of the heap in number of lbm_cons_t cells.
*
* \return Size of the heap in number of lbm_cons_t cells.
*/
extern unsigned int lbm_heap_size(void);
extern lbm_uint lbm_heap_size(void);
/** Size of the heap in bytes.
*
* \return Size of heap in bytes.
*/
extern unsigned int lbm_heap_size_bytes(void);
extern lbm_uint lbm_heap_size_bytes(void);
/** Allocate an lbm_cons_t cell from the heap.
*
* \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS).
@ -316,24 +365,48 @@ extern char *lbm_dec_str(lbm_value val);
* \return A pointer to an lbm_stream_t or NULL if the value does not encode a stream.
*/
extern lbm_stream_t *lbm_dec_stream(lbm_value val);
/** Decode a numerical value as if it is char
*
* \param val Value to decode
* \return The value encoded in val casted to a char. Returns 0 if val does not encode a number.
*/
extern char lbm_dec_as_char(lbm_value a);
/** Decode a numerical value as if it is unsigned
*
* \param val Value to decode
* \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
*/
extern lbm_uint lbm_dec_as_u(lbm_value val);
extern uint32_t lbm_dec_as_u32(lbm_value val);
/** Decode a numerical value as a signed integer.
*
* \param val Value to decode
* \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
*/
extern lbm_int lbm_dec_as_i(lbm_value val);
extern int32_t lbm_dec_as_i32(lbm_value val);
/** Decode a numerical value as a float.
*
* \param val Value to decode.
* \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
*/
extern lbm_float lbm_dec_as_f(lbm_value val);
extern float lbm_dec_as_float(lbm_value val);
/** Decode a numerical value as if it is a 64bit unsigned
*
* \param val Value to decode
* \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number.
*/
extern uint64_t lbm_dec_as_u64(lbm_value val);
/** Decode a numerical value as a 64bit signed integer.
*
* \param val Value to decode
* \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number.
*/
extern int64_t lbm_dec_as_i64(lbm_value val);
/** Decode a numerical value as a float.
*
* \param val Value to decode.
* \return The value encoded in val casted to a float. Returns 0 if val does not encode a number.
*/
extern double lbm_dec_as_double(lbm_value val);
extern lbm_uint lbm_dec_raw(lbm_value v);
/** Allocates an lbm_cons_t cell from the heap and populates it.
@ -450,7 +523,7 @@ extern int lbm_gc_mark_phase2(lbm_value env);
* \param n Number of elements in roots-array.
* \return 1 on success or 0 for failure.
*/
extern int lbm_gc_mark_aux(lbm_uint *data, unsigned int n);
extern int lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
/** Sweep up all non marked heap cells and place them on the free list.
*
@ -466,7 +539,7 @@ extern int lbm_gc_sweep_phase(void);
* \param type The type information to encode onto the heap cell.
* \return 1 for success of 0 for failure.
*/
extern int lbm_heap_allocate_array(lbm_value *res, unsigned int size, lbm_type type);
extern int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type);
/** Query the type information of a value.
*
@ -482,7 +555,7 @@ static inline bool lbm_is_ptr(lbm_value x) {
}
static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) {
return ((x << LBM_ADDRESS_SHIFT) | LBM_PTR_TYPE_CONS | LBM_PTR_BIT);
return ((x << LBM_ADDRESS_SHIFT) | LBM_TYPE_CONS | LBM_PTR_BIT);
}
static inline lbm_uint lbm_dec_ptr(lbm_value p) {
@ -490,43 +563,117 @@ static inline lbm_uint lbm_dec_ptr(lbm_value p) {
}
static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) {
return (LBM_PTR_VAL_MASK & p) | t | LBM_PTR_BIT;
return ((LBM_PTR_VAL_MASK & p) | t | LBM_PTR_BIT);
}
static inline lbm_value lbm_enc_sym(uint32_t s) {
return (s << LBM_VAL_SHIFT) | LBM_VAL_TYPE_SYMBOL;
static inline lbm_value lbm_enc_sym(lbm_uint s) {
return (s << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL;
}
static inline lbm_value lbm_enc_i(lbm_int x) {
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_VAL_TYPE_I;
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_TYPE_I;
}
static inline lbm_value lbm_enc_u(lbm_uint x) {
return (x << LBM_VAL_SHIFT) | LBM_VAL_TYPE_U;
return (x << LBM_VAL_SHIFT) | LBM_TYPE_U;
}
static inline lbm_value lbm_enc_I(lbm_int x) {
lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_BOXED_I_TYPE));
if (lbm_type_of(i) == LBM_VAL_TYPE_SYMBOL) return i;
return lbm_set_ptr_type(i, LBM_PTR_TYPE_BOXED_I);
static inline lbm_value lbm_enc_i32(int32_t x) {
#ifndef LBM64
lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i;
return lbm_set_ptr_type(i, LBM_TYPE_I32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32;
#endif
}
static inline lbm_value lbm_enc_U(lbm_uint x) {
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_BOXED_U_TYPE));
if (lbm_type_of(u) == LBM_VAL_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_PTR_TYPE_BOXED_U);
static inline lbm_value lbm_enc_u32(uint32_t x) {
#ifndef LBM64
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32;
#endif
}
static inline lbm_value lbm_enc_F(lbm_float x) {
static inline lbm_value lbm_enc_float(float x) {
#ifndef LBM64
lbm_uint t;
memcpy(&t, &x, sizeof(float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_BOXED_F_TYPE));
if (lbm_type_of(f) == LBM_VAL_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_PTR_TYPE_BOXED_F);
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_FLOAT);
#else
uint32_t t;
memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/
return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT;
#endif
}
static inline lbm_value lbm_enc_i64(int64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_I_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_I64);
}
}
return res;
#else
lbm_value u = lbm_cons((uint64_t)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_I64);
#endif
}
static inline lbm_value lbm_enc_u64(uint64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_U_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_U64);
}
}
return res;
#else
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U64);
#endif
}
static inline lbm_value lbm_enc_double(double x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_F_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_DOUBLE);
}
}
return res;
#else
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE);
#endif
}
static inline lbm_value lbm_enc_char(char x) {
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_VAL_TYPE_CHAR;
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_TYPE_CHAR;
}
static inline lbm_int lbm_dec_i(lbm_value x) {
@ -545,21 +692,73 @@ static inline lbm_uint lbm_dec_sym(lbm_value x) {
return x >> LBM_VAL_SHIFT;
}
static inline lbm_float lbm_dec_F(lbm_value x) { // Use only when knowing that x is a VAL_TYPE_F
lbm_float f_tmp;
static inline float lbm_dec_float(lbm_value x) {
#ifndef LBM64
float f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(lbm_float));
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#else
uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT);
float f_tmp;
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#endif
}
static inline lbm_uint lbm_dec_U(lbm_value x) {
return lbm_car(x);
static inline double lbm_dec_double(lbm_value x) {
#ifndef LBM64
double d;
uint32_t *data = (uint32_t*)lbm_car(x);
memcpy(&d, data, sizeof(double));
return d;
#else
double f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(double));
return f_tmp;
#endif
}
static inline lbm_int lbm_dec_I(lbm_value x) {
return (lbm_int)lbm_car(x);
static inline uint32_t lbm_dec_u32(lbm_value x) {
#ifndef LBM64
return (uint32_t)lbm_car(x);
#else
return (uint32_t)(x >> LBM_VAL_SHIFT);
#endif
}
static inline uint64_t lbm_dec_u64(lbm_value x) {
#ifndef LBM64
uint64_t u;
uint32_t *data = (uint32_t*)lbm_car(x);
memcpy(&u, data, 8);
return u;
#else
return (uint64_t)lbm_car(x);
#endif
}
static inline int32_t lbm_dec_i32(lbm_value x) {
#ifndef LBM64
return (int32_t)lbm_car(x);
#else
return (int32_t)(x >> LBM_VAL_SHIFT);
#endif
}
static inline int64_t lbm_dec_i64(lbm_value x) {
#ifndef LBM64
int64_t i;
uint32_t *data = (uint32_t*)lbm_car(x);
memcpy(&i, data, 8);
return i;
#else
return (int64_t)lbm_car(x);
#endif
}
static inline lbm_value lbm_set_gc_mark(lbm_value x) {
return x | LBM_GC_MARKED;
}
@ -574,54 +773,57 @@ static inline bool lbm_get_gc_mark(lbm_value x) {
static inline bool lbm_is_number(lbm_value x) {
lbm_uint t = lbm_type_of(x);
return ((t == LBM_VAL_TYPE_I) ||
(t == LBM_VAL_TYPE_U) ||
(t == LBM_VAL_TYPE_CHAR) ||
(t == LBM_PTR_TYPE_BOXED_I) ||
(t == LBM_PTR_TYPE_BOXED_U) ||
(t == LBM_PTR_TYPE_BOXED_F));
return ((t == LBM_TYPE_I) ||
(t == LBM_TYPE_U) ||
(t == LBM_TYPE_CHAR) ||
(t == LBM_TYPE_I32) ||
(t == LBM_TYPE_U32) ||
(t == LBM_TYPE_I64) ||
(t == LBM_TYPE_U64) ||
(t == LBM_TYPE_FLOAT) ||
(t == LBM_TYPE_DOUBLE));
}
static inline bool lbm_is_char(lbm_value x) {
lbm_uint t = lbm_type_of(x);
return (t == LBM_VAL_TYPE_CHAR);
return (t == LBM_TYPE_CHAR);
}
static inline bool lbm_is_special(lbm_value symrep) {
return ((lbm_type_of(symrep) == LBM_VAL_TYPE_SYMBOL) &&
return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL) &&
(lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END));
}
static inline bool lbm_is_fundamental(lbm_value symrep) {
return ((lbm_type_of(symrep) == LBM_VAL_TYPE_SYMBOL) &&
return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL) &&
(lbm_dec_sym(symrep) >= FUNDAMENTALS_START) &&
(lbm_dec_sym(symrep) <= FUNDAMENTALS_END));
}
static inline bool lbm_is_closure(lbm_value exp) {
return ((lbm_type_of(exp) == LBM_PTR_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_VAL_TYPE_SYMBOL) &&
return ((lbm_type_of(exp) == LBM_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL) &&
(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) &&
return ((lbm_type_of(exp) == LBM_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_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) &&
return ((lbm_type_of(exp) == LBM_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_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) &&
return ((lbm_type_of(exp) == LBM_TYPE_CONS) &&
(lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL) &&
((lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_ANY) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I28) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U28) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I32) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U32) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_FLOAT) ||
@ -629,7 +831,7 @@ static inline bool lbm_is_match_binder(lbm_value exp) {
}
static inline bool lbm_is_symbol(lbm_value exp) {
return (lbm_type_of(exp) == LBM_VAL_TYPE_SYMBOL);
return (lbm_type_of(exp) == LBM_TYPE_SYMBOL);
}
static inline bool lbm_is_symbol_nil(lbm_value exp) {
@ -645,10 +847,16 @@ static inline bool lbm_is_symbol_merror(lbm_value exp) {
}
#ifndef LBM64
#define ERROR_SYMBOL_MASK 0xFFFFFF20
#else
#define ERROR_SYMBOL_MASK 0xFFFFFFFFFFFFFF20
#endif
/* all error signaling symbols are in the range 0x20 - 0x2F */
static inline bool lbm_is_error(lbm_value v){
if (lbm_type_of(v) == LBM_VAL_TYPE_SYMBOL &&
((lbm_dec_sym(v) & 0xFFFFFF20) == 0x20)) {
if (lbm_type_of(v) == LBM_TYPE_SYMBOL &&
((lbm_dec_sym(v) & ERROR_SYMBOL_MASK) == 0x20)) {
return true;
}
return false;

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

@ -103,7 +103,7 @@ extern int lbm_undefine(char *symbol);
* \param type What type are the elements of the array.
* \param num_elt Number of elements in the array.
*/
extern int lbm_share_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, lbm_uint 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.
@ -113,7 +113,7 @@ extern int lbm_share_array(lbm_value *value, char *data, lbm_type type, uint32_t
* \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);
extern int lbm_create_array(lbm_value *value, lbm_type type, lbm_uint num_elt);
#endif

23
lispBM/lispBM/include/lbm_memory.h
View File

@ -77,11 +77,12 @@
#include "lbm_types.h"
#include <stdint.h>
//#define MEMORY_SIZE_64BYTES_TIMES_X(X) (64*(X))
//#define MEMORY_BITMAP_SIZE(X) (4*(X))
#define LBM_MEMORY_SIZE_64BYTES_TIMES_X(X) (16*(X))
#ifndef LBM64
#define LBM_MEMORY_BITMAP_SIZE(X) (X)
#else
#define LBM_MEMORY_BITMAP_SIZE(X) ((X)/2)
#endif
#define LBM_MEMORY_SIZE_512 LBM_MEMORY_SIZE_64BYTES_TIMES_X(8)
#define LBM_MEMORY_SIZE_1K LBM_MEMORY_SIZE_64BYTES_TIMES_X(16)
@ -109,39 +110,39 @@
* \param bitmap_size The size of the meta-data in number of uint32_t elements.
* \return
*/
extern int lbm_memory_init(uint32_t *data, uint32_t data_size,
uint32_t *bitmap, uint32_t bitmap_size);
extern int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
lbm_uint *bitmap, lbm_uint bitmap_size);
/** Size of of the symbols and arrays memory in uint32_t chunks.
*
* \return Numberof uint32_t words.
*/
extern uint32_t lbm_memory_num_words(void);
extern lbm_uint lbm_memory_num_words(void);
/**
*
* \return The number of free words in the symbols and arrays memory.
*/
extern uint32_t lbm_memory_num_free(void);
extern lbm_uint lbm_memory_num_free(void);
/** Allocate a number of words from the symbols and arrays memory.
*
* \param num_words Number of words to allocate.
* \return pointer to allocated array or NULL.
*/
extern uint32_t *lbm_memory_allocate(uint32_t num_words);
extern lbm_uint *lbm_memory_allocate(lbm_uint num_words);
/** Free an allocated array int the symbols and arrays memory.
*
* \param ptr Pointer to array to free.
* \return 1 on success and 0 on failure.
*/
extern int lbm_memory_free(uint32_t *ptr);
extern int lbm_memory_free(lbm_uint *ptr);
/** Check if a pointer points into the lbm_memory
*
* \param ptr
* \return 1 for yes and 0 for no.
*/
extern int lbm_memory_ptr_inside(uint32_t *ptr);
extern int lbm_memory_ptr_inside(lbm_uint *ptr);
extern lbm_int lbm_memory_address_to_ix(uint32_t *ptr);
extern lbm_int lbm_memory_address_to_ix(lbm_uint *ptr);
#endif

37
lispBM/lispBM/include/lbm_types.h
View File

@ -1,6 +1,6 @@
/** \file lbm_types.h */
/*
Copyright 2019 Joel Svensson svenssonjoel@yahoo.se
Copyright 2019, 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
@ -23,6 +23,15 @@
#include <stdbool.h>
#include <inttypes.h>
/* Addresses that are put into lbm_values or into
* lbm_memory must have this alignment. */
#ifndef LBM64
#define LBM_STORABLE_ADDRESS_ALIGNMENT 4
#else
#define LBM_STORABLE_ADDRESS_ALIGNMENT 8
#endif
#ifndef LBM64
/** A lispBM value.
* Can represent a character, 28 bit signed or unsigned integer.
* A value can also represent a pointer to a heap cell or to boxed 32 bit values such as a float.
@ -39,12 +48,36 @@ typedef float lbm_float;
#define PRI_TYPE PRIu32
#define PRI_UINT PRIu32
#define PRI_INT PRId32
#define PRI_HEX PRIx32
#define PRI_FLOAT "f"
typedef int32_t lbm_cid;
#else
/** A lispBM value.
*
*/
typedef uint64_t lbm_value;
/** A lispBM type. */
typedef uint64_t lbm_type;
typedef uint64_t lbm_uint;
typedef int64_t lbm_int;
typedef double lbm_float;
#define PRI_VALUE PRIu64
#define PRI_TYPE PRIu64
#define PRI_UINT PRIu64
#define PRI_INT PRId64
#define PRI_HEX PRIx64
#define PRI_FLOAT "lf"
typedef int64_t lbm_cid;
#endif
/**
* Represents a lisp process "context"-id
*/
typedef int32_t lbm_cid;
/* tokenizer */

38
lispBM/lispBM/include/lbm_utils.h Normal file
View File

@ -0,0 +1,38 @@
/*
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/>.
*/
#ifndef LBM_UTILS_H_
#define LBM_UTILS_H_
#ifndef M_PI
#define M_PI 3.14159265358979323846
#endif
#define DEG2RAD_f(deg) ((deg) * (float)(M_PI / 180.0))
#define RAD2DEG_f(rad) ((rad) * (float)(180.0 / M_PI))
#ifndef MIN
#define MIN(a,b) (((a)<(b))?(a):(b))
#endif
#ifndef MAX
#define MAX(a,b) (((a)>(b))?(a):(b))
#endif
#define CMP(a,b) (((a) > (b)) - ((a) < (b)));
#endif

18
lispBM/lispBM/include/lispbm.h
View File

@ -45,21 +45,21 @@
*
* \param heap_storage Pointer to array of lbm_cons_t to use as heap. This array must be aligned 4 at least.
* \param heap_size Size of heap storage array in number of lm_cons_t.
* \param memory Pointer to uint32_t array to use for the arrays and symbols memory. This array must be aligned 4 at least.
* \param memory Pointer to lbm_uint array to use for the arrays and symbols memory. This array must be aligned 4 at least.
* \param memory_size Size of the memory array.
* \param memory_bitmap Pointer to uint32_t array to use for the memory subsystem meta-data.
* \param memory_bitmap Pointer to lbm_uint array to use for the memory subsystem meta-data.
* \param bitmap_size Size of the memory meta-data array.
* \param print_stack_storage Pointer to uint32_t array to use as print_value stack.
* \param print_stack_size Size in number of uint32_t values of the print stack.
* \param print_stack_storage Pointer to lbm_uint array to use as print_value stack.
* \param print_stack_size Size in number of lbm_uint values of the print stack.
* \param extension_storage Pointer to array of extension_fptr.
* \param extension_storage_size Size of extension array.
* \return 1 on success and 0 on failure.
*/
extern int lbm_init(lbm_cons_t *heap_storage, uint32_t heap_size,
uint32_t *gc_stack_storage, uint32_t gc_stack_size,
uint32_t *memory, uint32_t memory_size,
uint32_t *memory_bitmap, uint32_t bitmap_size,
uint32_t *print_stack_storage, uint32_t print_stack_size,
extern int lbm_init(lbm_cons_t *heap_storage, lbm_uint heap_size,
lbm_uint *gc_stack_storage, lbm_uint gc_stack_size,
lbm_uint *memory, lbm_uint memory_size,
lbm_uint *memory_bitmap, lbm_uint bitmap_size,
lbm_uint *print_stack_storage, lbm_uint print_stack_size,
extension_fptr *extension_storage, int extension_storage_size );
#endif

2
lispBM/lispBM/include/print.h
View File

@ -30,7 +30,7 @@
* \param print_stack_size The number of uint32_t elements in the array.
* \return 1 for success and 0 for failure.
*/
extern int lbm_print_init(uint32_t *print_stack_storage, uint32_t print_stack_size);
extern int lbm_print_init(lbm_uint *print_stack_storage, lbm_uint print_stack_size);
/** Print an lbm_value into a buffer provided by the user.
* If printing fails, the buffer may contain an error message.

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

@ -28,9 +28,9 @@
typedef struct {
lbm_uint* data;
unsigned int sp;
unsigned int size;
unsigned int max_sp;
lbm_uint sp;
lbm_uint size;
lbm_uint max_sp;
} lbm_stack_t;
/** Allocate a stack on the symbols and arrays memory.
@ -39,7 +39,7 @@ typedef struct {
* \param stack_size Size in 32 bit words of stack to allocate.
* \return 1 on success and 0 on failure.
*/
extern int lbm_stack_allocate(lbm_stack_t *s, unsigned int stack_size);
extern int lbm_stack_allocate(lbm_stack_t *s, lbm_uint stack_size);
/** Create a stack in a statically allocated array.
*
* \param s Pointer to an lbm_stack_t to initialize.
@ -47,7 +47,7 @@ extern int lbm_stack_allocate(lbm_stack_t *s, unsigned int stack_size);
* \param size Size in number of 32 bit words.
* \return 1
*/
extern int lbm_stack_create(lbm_stack_t *s, lbm_uint* data, unsigned int size);
extern int lbm_stack_create(lbm_stack_t *s, lbm_uint* data, lbm_uint size);
/** Free a stack allocated on the lispbm_memory.
*
* \param s Pointer to lbm_stack_t to free.
@ -65,14 +65,14 @@ extern int lbm_stack_clear(lbm_stack_t *s);
* \param n Index.
* \return Pointer into the stack or NULL.
*/
extern lbm_uint *lbm_get_stack_ptr(lbm_stack_t *s, unsigned int n);
extern lbm_uint *lbm_get_stack_ptr(lbm_stack_t *s, lbm_uint n);
/** Drop n elements (from the top) of a stack.
*
* \param s Stack to drop elements from.
* \param n Number of elements to drop.
* \return 1 on Success and 0 on failure.
*/
extern int lbm_stack_drop(lbm_stack_t *s, unsigned int n);
extern int lbm_stack_drop(lbm_stack_t *s, lbm_uint n);
/** Push an element onto a stack.
*
* \param s Stack to push a value onto.

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

@ -67,36 +67,44 @@
#define SYM_RECOVERED 0x28
#define TYPE_CLASSIFIER_STARTS 0x30
#define SYM_ARRAY_TYPE 0x30
#define SYM_BOXED_I_TYPE 0x31
#define SYM_BOXED_U_TYPE 0x32
#define SYM_BOXED_F_TYPE 0x33
#define SYM_STREAM_TYPE 0x34
#define SYM_BYTECODE_TYPE 0x37
#define SYM_NONSENSE 0x38
#define SYM_RAW_I_TYPE 0x31
#define SYM_RAW_U_TYPE 0x32
#define SYM_RAW_F_TYPE 0x33
#define SYM_IND_I_TYPE 0x34
#define SYM_IND_U_TYPE 0x35
#define SYM_IND_F_TYPE 0x36
#define SYM_STREAM_TYPE 0x37
#define SYM_BYTECODE_TYPE 0x38
#define TYPE_CLASSIFIER_ENDS 0x38
#define SYM_NONSENSE 0x39
#define SYM_NO_MATCH 0x39
#define SYM_MATCH_ANY 0x3A
#define SYM_MATCH_I28 0x3B
#define SYM_MATCH_U28 0x3C
#define SYM_MATCH_U32 0x3D
#define SYM_MATCH_I32 0x3E
#define SYM_MATCH_FLOAT 0x3F
#define SYM_MATCH_CONS 0x40
#define SYM_NO_MATCH 0x3A
#define SYM_MATCH_ANY 0x3B
#define SYM_MATCH_I 0x3C
#define SYM_MATCH_U 0x3D
#define SYM_MATCH_U32 0x3E
#define SYM_MATCH_I32 0x3F
#define SYM_MATCH_FLOAT 0x40
#define SYM_MATCH_CONS 0x41
// Type identifying symbols
#define SYM_TYPE_LIST 0x50
#define SYM_TYPE_I28 0x51
#define SYM_TYPE_U28 0x52
#define SYM_TYPE_I 0x51
#define SYM_TYPE_U 0x52
#define SYM_TYPE_FLOAT 0x53
#define SYM_TYPE_I32 0x54
#define SYM_TYPE_U32 0x55
#define SYM_TYPE_ARRAY 0x56
#define SYM_TYPE_SYMBOL 0x57
#define SYM_TYPE_CHAR 0x58
#define SYM_TYPE_BYTE 0x59
#define SYM_TYPE_REF 0x5A
#define SYM_TYPE_STREAM 0x5B
#define SYM_TYPE_DOUBLE 0x56
#define SYM_TYPE_I64 0x57
#define SYM_TYPE_U64 0x58
#define SYM_TYPE_ARRAY 0x59
#define SYM_TYPE_SYMBOL 0x5A
#define SYM_TYPE_CHAR 0x5B
#define SYM_TYPE_BYTE 0x5C
#define SYM_TYPE_REF 0x5D
#define SYM_TYPE_STREAM 0x5E
//Relevant for the tokenizer
#define SYM_OPENPAR 0x70
@ -246,6 +254,6 @@ extern int lbm_get_num_variables(void);
*
* \return The amount of space occupied by the symbol table in bytes.
*/
extern unsigned int lbm_get_symbol_table_size(void);
extern lbm_uint lbm_get_symbol_table_size(void);
#endif

4
lispBM/lispBM/lispbm.mk
View File

@ -17,7 +17,9 @@ LISPBM_SRC = $(LISPBM)/src/env.c \
$(LISPBM)/src/streams.c \
$(LISPBM)/src/lbm_c_interop.c \
$(LISPBM)/src/lbm_variables.c \
$(LISPBM)/src/extensions/array_extensions.c
$(LISPBM)/src/extensions/array_extensions.c \
$(LISPBM)/src/extensions/string_extensions.c \
$(LISPBM)/src/extensions/math_extensions.c
LISPBM_INC = -I$(LISPBM)/include \

8
lispBM/lispBM/old/repl-ec/repl.c
View File

@ -47,10 +47,10 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
for (int i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && ptr_type(t) == LBM_PTR_TYPE_ARRAY) {
if (lbm_is_ptr(t) && ptr_type(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_VAL_TYPE_CHAR: {
case LBM_TYPE_CHAR: {
char *data = (char *)array + 8;
printf("%s", data);
break;
@ -59,7 +59,7 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
return lbm_enc_sym(symrepr_nil);
break;
}
} else if (val_type(t) == LBM_VAL_TYPE_CHAR) {
} else if (val_type(t) == LBM_TYPE_CHAR) {
printf("%c", lbm_dec_char(t));
} else {
int print_ret = lbm_print_value(output, 1024, error, 1024, t);
@ -198,7 +198,7 @@ int main(int argc, char **argv) {
}
int env_len = 0;
lbm_value curr = *lbm_get_env_ptr();
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
env_len ++;
curr = lbm_cdr(curr);
}

7
lispBM/lispBM/repl-cps/Makefile
View File

@ -6,7 +6,7 @@ include $(LISPBM)/lispbm.mk
PLATFORM_INCLUDE = -I$(LISPBM)/platform/linux/include
PLATFORM_SRC = $(LISPBM)/platform/linux/src/platform_mutex.c
CCFLAGS = -g -m32 -Wall -Wconversion -pedantic -std=c11
CCFLAGS = -g -Wall -Wconversion -pedantic -std=c11
PICCFLAGS = -O2 -Wall -Wconversion -pedantic -std=c11
@ -16,8 +16,13 @@ ifdef HEAP_VIS
CCFLAGS += -DVISUALIZE_HEAP
endif
all: CCFLAGS += -m32
all: repl $(LISPBM_DEPS)
all64: CCFLAGS += -DLBM64
all64: repl $(LISPBM_DEPS)
debug: CCFLAGS += -g
debug: repl

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

@ -27,6 +27,8 @@
#include "lispbm.h"
#include "extensions/array_extensions.h"
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
#define EVAL_CPS_STACK_SIZE 256
#define GC_STACK_SIZE 256
@ -36,8 +38,8 @@
#define WAIT_TIMEOUT 2500
uint32_t gc_stack_storage[GC_STACK_SIZE];
uint32_t print_stack_storage[PRINT_STACK_SIZE];
lbm_uint gc_stack_storage[GC_STACK_SIZE];
lbm_uint print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
@ -140,13 +142,13 @@ void done_callback(eval_context_t *ctx) {
int print_ret = lbm_print_value(output, 1024, t);
if (print_ret >= 0) {
printf("<< Context %d finished with value %s >>\n", cid, output);
printf("<< Context %"PRI_INT" finished with value %s >>\n", cid, output);
} else {
printf("<< Context %d finished with value %s >>\n", cid, output);
printf("<< Context %"PRI_INT" finished with value %s >>\n", cid, output);
}
printf("stack max: %d\n", ctx->K.max_sp);
printf("stack size: %u\n", ctx->K.size);
printf("stack sp: %d\n", ctx->K.sp);
printf("stack max: %"PRI_UINT"\n", ctx->K.max_sp);
printf("stack size: %"PRI_UINT"\n", ctx->K.size);
printf("stack sp: %"PRI_INT"\n", ctx->K.sp);
// if (!eval_cps_remove_done_ctx(cid, &t)) {
// printf("Error: done context (%d) not in list\n", cid);
@ -204,10 +206,10 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
for (int i = 0; i < argn; i ++) {
lbm_value t = args[i];
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_PTR_TYPE_ARRAY) {
if (lbm_is_ptr(t) && lbm_type_of(t) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(t);
switch (array->elt_type){
case LBM_VAL_TYPE_CHAR: {
case LBM_TYPE_CHAR: {
char *data = (char*)array->data;
printf("%s", data);
break;
@ -216,7 +218,7 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
return lbm_enc_sym(SYM_NIL);
break;
}
} else if (lbm_type_of(t) == LBM_VAL_TYPE_CHAR) {
} else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
printf("%c", lbm_dec_char(t));
} else {
lbm_print_value(output, 1024, t);
@ -229,7 +231,7 @@ lbm_value ext_print(lbm_value *args, lbm_uint argn) {
char output[128];
static lbm_value ext_range(lbm_value *args, lbm_uint argn) {
if (argn != 2 || lbm_type_of(args[0]) != LBM_VAL_TYPE_I || lbm_type_of(args[1]) != LBM_VAL_TYPE_I) {
if (argn != 2 || lbm_type_of(args[0]) != LBM_TYPE_I || lbm_type_of(args[1]) != LBM_TYPE_I) {
return lbm_enc_sym(SYM_EERROR);
}
@ -316,9 +318,9 @@ void print_ctx_info(eval_context_t *ctx, void *arg1, void *arg2) {
int print_ret = lbm_print_value(output, 1024, ctx->r);
printf("--------------------------------\n");
printf("ContextID: %u\n", ctx->id);
printf("Stack SP: %u\n", ctx->K.sp);
printf("Stack SP max: %u\n", ctx->K.max_sp);
printf("ContextID: %"PRI_UINT"\n", ctx->id);
printf("Stack SP: %"PRI_UINT"\n", ctx->K.sp);
printf("Stack SP max: %"PRI_UINT"\n", ctx->K.max_sp);
if (print_ret) {
printf("Value: %s\n", output);
} else {
@ -341,11 +343,11 @@ void sym_it(const char *str) {
printf("%s\n", str);
}
static uint32_t memory[LBM_MEMORY_SIZE_8K];
static uint32_t bitmap[LBM_MEMORY_BITMAP_SIZE_8K];
static lbm_uint memory[LBM_MEMORY_SIZE_8K];
static lbm_uint bitmap[LBM_MEMORY_BITMAP_SIZE_8K];
char char_array[1024];
uint32_t word_array[1024];
lbm_uint word_array[1024];
int main(int argc, char **argv) {
@ -361,7 +363,7 @@ int main(int argc, char **argv) {
for (int i = 0; i < 1024; i ++) {
char_array[i] = (char)i;
word_array[i] = (uint32_t)i;
word_array[i] = (lbm_uint)i;
}
//setup_terminal();
@ -371,12 +373,15 @@ int main(int argc, char **argv) {
return 0;
}
lbm_init(heap_storage, heap_size,
if (!lbm_init(heap_storage, heap_size,
gc_stack_storage, GC_STACK_SIZE,
memory, LBM_MEMORY_SIZE_8K,
bitmap, LBM_MEMORY_BITMAP_SIZE_8K,
print_stack_storage, PRINT_STACK_SIZE,
extension_storage, EXTENSION_STORAGE_SIZE);
extension_storage, EXTENSION_STORAGE_SIZE)) {
printf("Failed to initialize LispBM\n");
return 0;
}
lbm_set_ctx_done_callback(done_callback);
lbm_set_timestamp_us_callback(timestamp_callback);
@ -386,10 +391,25 @@ int main(int argc, char **argv) {
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
if (!lbm_array_extensions_init()) {
printf("error adding array extensions");
if (lbm_array_extensions_init()) {
printf("Array extensions loaded\n");
} else {
printf("Loading array extensions failed\n");
}
if (lbm_string_extensions_init()) {
printf("String extensions loaded\n");
} else {
printf("Loading string extensions failed\n");
}
if (lbm_math_extensions_init()) {
printf("Math extensions loaded\n");
} else {
printf("Loading math extensions failed\n");
}
res = lbm_add_extension("print", ext_print);
if (res)
printf("Extension added.\n");
@ -435,21 +455,21 @@ int main(int argc, char **argv) {
printf("--(LISP HEAP)-----------------------------------------------\n");
lbm_get_heap_state(&heap_state);
printf("Heap size: %u Bytes\n", heap_size * 8);
printf("Used cons cells: %d\n", heap_size - lbm_heap_num_free());
printf("Free cons cells: %d\n", lbm_heap_num_free());
printf("GC counter: %d\n", heap_state.gc_num);
printf("Recovered: %d\n", heap_state.gc_recovered);
printf("Recovered arrays: %u\n", heap_state.gc_recovered_arrays);
printf("Marked: %d\n", heap_state.gc_marked);
printf("Used cons cells: %"PRI_INT"\n", heap_size - lbm_heap_num_free());
printf("Free cons cells: %"PRI_INT"\n", lbm_heap_num_free());
printf("GC counter: %"PRI_INT"\n", heap_state.gc_num);
printf("Recovered: %"PRI_INT"\n", heap_state.gc_recovered);
printf("Recovered arrays: %"PRI_UINT"\n", heap_state.gc_recovered_arrays);
printf("Marked: %"PRI_INT"\n", heap_state.gc_marked);
printf("--(Symbol and Array memory)---------------------------------\n");
printf("Memory size: %u Words\n", lbm_memory_num_words());
printf("Memory free: %u Words\n", lbm_memory_num_free());
printf("Allocated arrays: %u\n", heap_state.num_alloc_arrays);
printf("Symbol table size: %u Bytes\n", lbm_get_symbol_table_size());
printf("Memory size: %"PRI_UINT" Words\n", lbm_memory_num_words());
printf("Memory free: %"PRI_UINT" Words\n", lbm_memory_num_free());
printf("Allocated arrays: %"PRI_UINT"\n", heap_state.num_alloc_arrays);
printf("Symbol table size: %"PRI_UINT" Bytes\n", lbm_get_symbol_table_size());
} else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
printf("Environment:\r\n");
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_print_value(output,1024, lbm_car(curr));
curr = lbm_cdr(curr);
printf(" %s\r\n",output);
@ -480,7 +500,7 @@ int main(int argc, char **argv) {
lbm_continue_eval();
printf("started ctx: %u\n", cid);
printf("started ctx: %"PRI_UINT"\n", cid);
}
} else if (n >= 4 && strncmp(str, ":pon", 4) == 0) {
allow_print = true;
@ -523,7 +543,24 @@ int main(int argc, char **argv) {
lbm_variables_init(variable_storage, VARIABLE_STORAGE_SIZE);
lbm_array_extensions_init();
if (lbm_array_extensions_init()) {
printf("Array extensions loaded\n");
} else {
printf("Loading array extensions failed\n");
}
if (lbm_string_extensions_init()) {
printf("String extensions loaded\n");
} else {
printf("Loading string extensions failed\n");
}
if (lbm_math_extensions_init()) {
printf("Math extensions loaded\n");
} else {
printf("Loading math extensions failed\n");
}
lbm_add_extension("print", ext_print);
} else if (strncmp(str, ":prelude", 8) == 0) {
@ -595,10 +632,10 @@ int main(int argc, char **argv) {
printf("Evaluator paused\n");
lbm_value arr_val;
lbm_share_array(&arr_val, char_array, LBM_VAL_TYPE_CHAR,1024);
lbm_share_array(&arr_val, char_array, LBM_TYPE_CHAR,1024);
lbm_define("c-arr", arr_val);
lbm_share_array(&arr_val, (char *)word_array, LBM_PTR_TYPE_BOXED_I,1024);
lbm_share_array(&arr_val, (char *)word_array, LBM_TYPE_I32,1024);
lbm_define("i-arr", arr_val);
lbm_continue_eval();
@ -617,7 +654,7 @@ int main(int argc, char **argv) {
lbm_continue_eval();
printf("started ctx: %u\n", cid);
printf("started ctx: %"PRI_UINT"\n", cid);
/* Something better is needed.
this sleep ís to ensure the string is alive until parsing
is done */

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

@ -193,10 +193,10 @@ int match_longest_key(char *string) {
int longest_match_ix = -1;
unsigned int longest_match_length = 0;
unsigned int n = strlen(string);
unsigned int n = (unsigned int)strlen(string);
for (int i = 0; i < NUM_CODES; i ++) {
unsigned int s_len = strlen(codes[i][KEY]);
unsigned int s_len = (unsigned int)strlen(codes[i][KEY]);
if (s_len <= n) {
if (strncasecmp(codes[i][KEY], string, s_len) == 0) {
if (s_len > longest_match_length) {
@ -216,7 +216,7 @@ int match_longest_code(char *string, uint32_t start_bit, uint32_t total_bits) {
unsigned int longest_match_length = 0;
for (int i = 0; i < NUM_CODES; i++) {
unsigned int s_len = strlen(codes[i][CODE]);
unsigned int s_len = (unsigned int)strlen(codes[i][CODE]);
if ((uint32_t)s_len <= bits_left) {
bool match = true;
for (uint32_t b = 0; b < (uint32_t)s_len; b ++) {
@ -242,7 +242,7 @@ int match_longest_code(char *string, uint32_t start_bit, uint32_t total_bits) {
int compressed_length(char *string) {
uint32_t i = 0;
uint32_t n = strlen(string);
uint32_t n = (uint32_t)strlen(string);
int comp_len = 0; // in bits
bool string_mode = false;
@ -292,9 +292,9 @@ int compressed_length(char *string) {
}
if (ix == -1)return -1;
unsigned int code_len = strlen(codes[ix][1]);
unsigned int code_len = (unsigned int)strlen(codes[ix][1]);
comp_len += (int)code_len;
i += strlen(codes[ix][0]);
i += (unsigned int)strlen(codes[ix][0]);
}
}
return comp_len;
@ -324,7 +324,7 @@ void emit_string_char_code(char *compressed, char c, int *bit_pos) {
}
void emit_code(char *compressed, char *code, int *bit_pos) {
unsigned int n = strlen(code);
unsigned int n = (unsigned int)strlen(code);
for (unsigned int i = 0; i < n; i ++) {
int byte_ix = (*bit_pos) / 8;
@ -388,7 +388,7 @@ char *lbm_compress(char *string, uint32_t *res_size) {
bool string_mode = false;
bool gobbling_whitespace = false;
uint32_t n = strlen(string);
uint32_t n = (uint32_t) strlen(string);
uint32_t i = 0;
while (i < n) {
@ -442,7 +442,7 @@ char *lbm_compress(char *string, uint32_t *res_size) {
emit_code(compressed, codes[ix][CODE], &bit_pos);
i += strlen(codes[ix][0]);
i += (unsigned int)strlen(codes[ix][0]);
}
}
@ -488,7 +488,7 @@ int lbm_decompress_incremental(decomp_state *s, char *dest_buff, uint32_t dest_n
s->last_string_char = 0;
}
unsigned int n_bits_decoded = strlen(codes[ix][CODE]);
unsigned int n_bits_decoded = (unsigned int)strlen(codes[ix][CODE]);
emit_key(dest_buff, codes[ix][KEY], (int)strlen(codes[ix][KEY]), &char_pos);
s->i+=n_bits_decoded;
return (int)char_pos;

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

@ -44,13 +44,13 @@ lbm_value lbm_env_copy_shallow(lbm_value env) {
lbm_value res = lbm_enc_sym(SYM_NIL);
lbm_value curr = env;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value key = lbm_car(lbm_car(curr));
if (lbm_dec_sym(key) != SYM_NIL) {
res = lbm_cons(lbm_car(curr), res);
// Check for "out of memory"
if (lbm_type_of(res) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(res) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(res) == SYM_MERROR) {
return res;
}
@ -67,7 +67,7 @@ lbm_value lbm_env_lookup(lbm_value sym, lbm_value env) {
return sym;
}
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
if (lbm_car(lbm_car(curr)) == sym) {
return lbm_cdr(lbm_car(curr));
}
@ -82,7 +82,7 @@ lbm_value lbm_env_set(lbm_value env, lbm_value key, lbm_value val) {
lbm_value new_env;
lbm_value keyval;
while(lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while(lbm_type_of(curr) == LBM_TYPE_CONS) {
if (lbm_car(lbm_car(curr)) == key) {
lbm_set_cdr(lbm_car(curr),val);
return env;
@ -91,12 +91,12 @@ lbm_value lbm_env_set(lbm_value env, lbm_value key, lbm_value val) {
}
keyval = lbm_cons(key,val);
if (lbm_type_of(keyval) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(keyval) == LBM_TYPE_SYMBOL) {
return keyval;
}
new_env = lbm_cons(keyval, env);
if (lbm_type_of(new_env) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(new_env) == LBM_TYPE_SYMBOL) {
return keyval;
}
@ -107,7 +107,7 @@ lbm_value lbm_env_modify_binding(lbm_value env, lbm_value key, lbm_value val) {
lbm_value curr = env;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
if (lbm_car(lbm_car(curr)) == key) {
lbm_set_cdr(lbm_car(curr), val);
return env;
@ -131,16 +131,16 @@ lbm_value lbm_env_build_params_args(lbm_value params,
}
lbm_value env = env0;
while (lbm_type_of(curr_param) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr_param) == LBM_TYPE_CONS) {
lbm_value entry = lbm_cons(lbm_car(curr_param), lbm_car(curr_arg));
if (lbm_type_of(entry) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(entry) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(entry) == SYM_MERROR)
return lbm_enc_sym(SYM_MERROR);
env = lbm_cons(entry,env);
if (lbm_type_of(env) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(env) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(env) == SYM_MERROR)
return lbm_enc_sym(SYM_MERROR);

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

@ -250,7 +250,7 @@ void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char **)) {
void print_error_explanation(lbm_value error, char *buf, unsigned int size) {
if (lbm_type_of(error) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(error) == LBM_TYPE_SYMBOL) {
switch(lbm_dec_sym(error)){
case SYM_RERROR:
printf_callback("\tRead errors are most likely caused by syntactically\n"
@ -318,7 +318,7 @@ void print_environments(char *buf, unsigned int size) {
lbm_value curr_l = ctx_running->curr_env;
printf_callback("\tCurrent local environment:\n");
while (lbm_type_of(curr_l) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr_l) == LBM_TYPE_CONS) {
lbm_print_value(buf, (size/2) - 1,lbm_car(lbm_car(curr_l)));
lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
@ -328,7 +328,7 @@ void print_environments(char *buf, unsigned int size) {
printf_callback("\n\n");
printf_callback("\tCurrent global environment:\n");
while (lbm_type_of(curr_g) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr_g) == LBM_TYPE_CONS) {
lbm_print_value(buf, (size/2) - 1,lbm_car(lbm_car(curr_g)));
lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
@ -342,7 +342,7 @@ void print_error_message(lbm_value error) {
if (!printf_callback) return;
/* try to allocate a lbm_print_value buffer on the lbm_memory */
uint32_t* buf32 = lbm_memory_allocate(ERROR_MESSAGE_BUFFER_SIZE_BYTES / 4);
lbm_uint* buf32 = lbm_memory_allocate(ERROR_MESSAGE_BUFFER_SIZE_BYTES / (sizeof(lbm_uint)));
if (!buf32) {
printf_callback("Error: Not enough free memory to create a human readable error message\n");
return;
@ -410,8 +410,7 @@ static lbm_value token_stream_put(lbm_stream_t *str, lbm_value v){
lbm_value lbm_create_token_stream(lbm_tokenizer_char_stream_t *str) {
lbm_stream_t *stream;
stream = (lbm_stream_t*)lbm_memory_allocate(sizeof(lbm_stream_t) / 4);
stream = (lbm_stream_t*)lbm_memory_allocate(sizeof(lbm_stream_t) / (sizeof(lbm_uint)));
if (stream == NULL) {
return lbm_enc_sym(SYM_MERROR);
@ -437,21 +436,21 @@ lbm_value token_stream_from_string_value(lbm_value s) {
lbm_tokenizer_string_state_t *tok_stream_state = NULL;
lbm_tokenizer_char_stream_t *tok_stream = NULL;
stream = (lbm_stream_t*)lbm_memory_allocate(sizeof(lbm_stream_t) / 4);
stream = (lbm_stream_t*)lbm_memory_allocate(sizeof(lbm_stream_t) / (sizeof(lbm_uint)));
if (stream == NULL) {
return lbm_enc_sym(SYM_MERROR);
}
tok_stream_state = (lbm_tokenizer_string_state_t*)lbm_memory_allocate(1 + (sizeof(lbm_tokenizer_string_state_t) / 4));
tok_stream_state = (lbm_tokenizer_string_state_t*)lbm_memory_allocate(1 + (sizeof(lbm_tokenizer_string_state_t) / (sizeof(lbm_uint))));
if (tok_stream_state == NULL) {
lbm_memory_free((uint32_t*)stream);
lbm_memory_free((lbm_uint*)stream);
return lbm_enc_sym(SYM_MERROR);
}
tok_stream = (lbm_tokenizer_char_stream_t*)lbm_memory_allocate(sizeof(lbm_tokenizer_char_stream_t) / 4);
tok_stream = (lbm_tokenizer_char_stream_t*)lbm_memory_allocate(sizeof(lbm_tokenizer_char_stream_t) / (sizeof(lbm_uint)));
if (tok_stream == NULL) {
lbm_memory_free((uint32_t*)stream);
lbm_memory_free((uint32_t*)tok_stream_state);
lbm_memory_free((lbm_uint*)stream);
lbm_memory_free((lbm_uint*)tok_stream_state);
return lbm_enc_sym(SYM_MERROR);
}
@ -591,7 +590,7 @@ static void finish_ctx(void) {
lbm_memory_free((lbm_uint*)ctx_running->error_reason);
}
lbm_memory_free((uint32_t*)ctx_running);
lbm_memory_free((lbm_uint*)ctx_running);
ctx_running = NULL;
}
@ -601,7 +600,7 @@ static void context_exists(eval_context_t *ctx, void *cid, void *b) {
}
}
bool lbm_wait_ctx(lbm_cid cid, uint32_t timeout_ms) {
bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
bool exists;
uint32_t i = 0;
@ -644,8 +643,8 @@ static void error_ctx(lbm_value err_val) {
}
static eval_context_t *dequeue_ctx(uint32_t *us) {
uint32_t min_us = DEFAULT_SLEEP_US;
uint32_t t_now;
lbm_uint min_us = DEFAULT_SLEEP_US;
lbm_uint t_now;
mutex_lock(&qmutex);
@ -658,10 +657,14 @@ static eval_context_t *dequeue_ctx(uint32_t *us) {
eval_context_t *curr = queue.first; //ctx_queue;
while (curr != NULL) {
uint32_t t_diff;
lbm_uint t_diff;
if ( curr->timestamp > t_now) {
/* There was an overflow on the counter */
#ifndef LBM64
t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
#else
t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
#endif
} else {
t_diff = t_now - curr->timestamp;
}
@ -700,7 +703,7 @@ static eval_context_t *dequeue_ctx(uint32_t *us) {
return NULL;
}
static void yield_ctx(uint32_t sleep_us) {
static void yield_ctx(lbm_uint sleep_us) {
if (timestamp_us_callback) {
ctx_running->timestamp = timestamp_us_callback();
ctx_running->sleep_us = sleep_us;
@ -714,27 +717,27 @@ static void yield_ctx(uint32_t sleep_us) {
ctx_running = NULL;
}
lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, uint32_t stack_size) {
lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size) {
if (lbm_type_of(program) != LBM_PTR_TYPE_CONS) return -1;
if (lbm_type_of(program) != LBM_TYPE_CONS) return -1;
eval_context_t *ctx = NULL;
ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / 4);
ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / (sizeof(lbm_uint)));
if (ctx == NULL) {
gc(program,env);
ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / 4);
ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / (sizeof(lbm_uint)));
}
if (ctx == NULL) return -1;
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
gc(program,env);
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
lbm_memory_free((uint32_t*)ctx);
lbm_memory_free((lbm_uint*)ctx);
return -1;
}
}
lbm_int cid = lbm_memory_address_to_ix((uint32_t*)ctx);
lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
ctx->program = lbm_cdr(program);
ctx->curr_exp = lbm_car(program);
@ -753,7 +756,7 @@ lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, uint32_t stack_size) {
if (!lbm_push_u32(&ctx->K, lbm_enc_u(DONE))) {
lbm_stack_free(&ctx->K);
lbm_memory_free((uint32_t*)ctx);
lbm_memory_free((lbm_uint*)ctx);
return -1;
}
@ -765,7 +768,7 @@ lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, uint32_t stack_size) {
/* Advance execution to the next expression in the program */
static void advance_ctx(void) {
if (lbm_type_of(ctx_running->program) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(ctx_running->program) == LBM_TYPE_CONS) {
lbm_push_u32(&ctx_running->K, lbm_enc_u(DONE));
ctx_running->curr_exp = lbm_car(ctx_running->program);
ctx_running->curr_env = lbm_enc_sym(SYM_NIL);
@ -791,7 +794,7 @@ lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
if (found) {
lbm_value new_mailbox = lbm_cons(msg, found->mailbox);
if (lbm_type_of(new_mailbox) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(new_mailbox) == LBM_TYPE_SYMBOL) {
return new_mailbox; /* An error symbol */
}
@ -808,7 +811,7 @@ lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
if (ctx_running && ctx_running->id == cid) {
lbm_value new_mailbox = lbm_cons(msg, ctx_running->mailbox);
if (lbm_type_of(new_mailbox) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(new_mailbox) == LBM_TYPE_SYMBOL) {
return new_mailbox; /* An error symbol */
}
ctx_running->mailbox = new_mailbox;
@ -825,13 +828,13 @@ static lbm_value remove_from_list(int n, lbm_value list) {
lbm_value tmp = lbm_enc_sym(SYM_NIL);
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
if (n == c) {
curr = lbm_cdr(curr);
break;
}
tmp = lbm_cons(lbm_car(curr), tmp);
if (lbm_type_of(tmp) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(tmp) == LBM_TYPE_SYMBOL) {
res = tmp;
return res;
}
@ -842,9 +845,9 @@ static lbm_value remove_from_list(int n, lbm_value list) {
res = curr; /*res is the tail */
curr = tmp;
if ( c != 0) {
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
res = lbm_cons(lbm_car(curr),res);
if (lbm_type_of(res) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(res) == LBM_TYPE_SYMBOL) {
return res;
}
curr = lbm_cdr(curr);
@ -874,8 +877,8 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
break;
}
return false;
case SYM_MATCH_I28:
if (lbm_type_of(e) == LBM_VAL_TYPE_I) {
case SYM_MATCH_I:
if (lbm_type_of(e) == LBM_TYPE_I) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -883,8 +886,8 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
}
}
return false;
case SYM_MATCH_U28:
if (lbm_type_of(e) == LBM_VAL_TYPE_U) {
case SYM_MATCH_U:
if (lbm_type_of(e) == LBM_TYPE_U) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -893,7 +896,7 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
}
return false;
case SYM_MATCH_I32:
if (lbm_type_of(e) == LBM_PTR_TYPE_BOXED_I) {
if (lbm_type_of(e) == LBM_TYPE_I32) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -902,7 +905,7 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
}
return false;
case SYM_MATCH_U32:
if (lbm_type_of(e) == LBM_PTR_TYPE_BOXED_U) {
if (lbm_type_of(e) == LBM_TYPE_U32) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -912,7 +915,7 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
return false;
case SYM_MATCH_FLOAT:
if (lbm_type_of(e) == LBM_PTR_TYPE_BOXED_F) {
if (lbm_type_of(e) == LBM_TYPE_FLOAT) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -921,7 +924,7 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
}
return false;
case SYM_MATCH_CONS:
if (lbm_type_of(e) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(e) == LBM_TYPE_CONS) {
if (lbm_dec_sym(var) == SYM_DONTCARE) {
return true;
} else {
@ -934,8 +937,8 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
}
binding = lbm_cons(var, e);
*env = lbm_cons(binding, *env);
if (lbm_type_of(binding) == LBM_VAL_TYPE_SYMBOL ||
lbm_type_of(*env) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(binding) == LBM_TYPE_SYMBOL ||
lbm_type_of(*env) == LBM_TYPE_SYMBOL) {
*gc = true;
return false;
}
@ -947,8 +950,8 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
return (p == e);
}
if (lbm_type_of(p) == LBM_PTR_TYPE_CONS &&
lbm_type_of(e) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(p) == LBM_TYPE_CONS &&
lbm_type_of(e) == LBM_TYPE_CONS) {
lbm_value headp = lbm_car(p);
lbm_value heade = lbm_car(e);
@ -956,17 +959,17 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
return false;
}
return match (lbm_cdr(p), lbm_cdr(e), env, gc);
} else if (lbm_type_of(p) == LBM_PTR_TYPE_BOXED_F &&
lbm_type_of(e) == LBM_PTR_TYPE_BOXED_F &&
lbm_dec_F(p) == lbm_dec_F(e)) {
} else if (lbm_type_of(p) == LBM_TYPE_FLOAT &&
lbm_type_of(e) == LBM_TYPE_FLOAT &&
lbm_dec_float(p) == lbm_dec_float(e)) {
return true;
} else if (lbm_type_of(p) == LBM_PTR_TYPE_BOXED_U &&
lbm_type_of(e) == LBM_PTR_TYPE_BOXED_U &&
lbm_dec_U(p) == lbm_dec_U(e)) {
} else if (lbm_type_of(p) == LBM_TYPE_U32 &&
lbm_type_of(e) == LBM_TYPE_U32 &&
lbm_dec_u32(p) == lbm_dec_u32(e)) {
return true;
} else if (lbm_type_of(p) == LBM_PTR_TYPE_BOXED_I &&
lbm_type_of(e) == LBM_PTR_TYPE_BOXED_I &&
lbm_dec_I(p) == lbm_dec_I(e)) {
} else if (lbm_type_of(p) == LBM_TYPE_I32 &&
lbm_type_of(e) == LBM_TYPE_I32 &&
lbm_dec_i32(p) == lbm_dec_i32(e)) {
return true;
} else if (p == e) {
return true;
@ -979,8 +982,8 @@ static int find_match(lbm_value plist, lbm_value elist, lbm_value *e, lbm_value
lbm_value curr_p = plist;
lbm_value curr_e = elist;
int n = 0;
while (lbm_type_of(curr_e) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr_p) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr_e) == LBM_TYPE_CONS) {
while (lbm_type_of(curr_p) == LBM_TYPE_CONS) {
if (match(lbm_car(lbm_car(curr_p)), lbm_car(curr_e), env, gc)) {
if (*gc) return -1;
*e = lbm_car(lbm_cdr(lbm_car(curr_p)));
@ -1000,8 +1003,8 @@ static int find_match(lbm_value plist, lbm_value elist, lbm_value *e, lbm_value
/* Garbage collection */
static int gc(lbm_value remember1, lbm_value remember2) {
uint32_t tstart = 0;
uint32_t tend = 0;
lbm_uint tstart = 0;
lbm_uint tend = 0;
if (timestamp_us_callback) {
tstart = timestamp_us_callback();
@ -1062,15 +1065,14 @@ static int gc(lbm_value remember1, lbm_value remember2) {
tend = timestamp_us_callback();
}
uint32_t dur = 0;
lbm_uint dur = 0;
if (tend >= tstart) {
dur = tend - tstart;
}
lbm_heap_new_gc_time(dur);
uint32_t num_free = lbm_heap_num_free();
lbm_heap_new_freelist_length(num_free);
lbm_heap_new_freelist_length();
return r;
}
@ -1096,7 +1098,7 @@ static inline void eval_symbol(eval_context_t *ctx) {
} else {
// If not special, check if there is a binding in the environments
value = lbm_env_lookup(ctx->curr_exp, ctx->curr_env);
if (lbm_type_of(value) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(value) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(value) == SYM_NOT_FOUND) {
value = lbm_env_lookup(ctx->curr_exp, *lbm_get_env_ptr());
@ -1104,7 +1106,7 @@ static inline void eval_symbol(eval_context_t *ctx) {
}
if (dynamic_load_callback &&
lbm_type_of(value) == LBM_VAL_TYPE_SYMBOL &&
lbm_type_of(value) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(value) == SYM_NOT_FOUND ) {
const char *sym_str = lbm_get_name_by_symbol(lbm_dec_sym(ctx->curr_exp));
const char *code_str = NULL;
@ -1114,31 +1116,31 @@ static inline void eval_symbol(eval_context_t *ctx) {
} else {
CHECK_STACK(lbm_push_u32_2(&ctx->K, ctx->curr_exp, lbm_enc_u(RESUME)));
lbm_value cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (lbm_type_of(cell) == LBM_VAL_TYPE_SYMBOL)
if (lbm_type_of(cell) == LBM_TYPE_SYMBOL)
gc(NIL,NIL);
cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
if (lbm_type_of(cell) == LBM_VAL_TYPE_SYMBOL) {
cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) {
error_ctx(cell);
return;
}
lbm_array_header_t *array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / 4);
lbm_array_header_t *array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / (sizeof(lbm_uint)));
if (array == NULL) {
error_ctx(lbm_enc_sym(SYM_MERROR));
return;
}
array->data = (uint32_t*)code_str;
array->elt_type = LBM_VAL_TYPE_CHAR;
array->data = (lbm_uint*)code_str;
array->elt_type = LBM_TYPE_CHAR;
array->size = strlen(code_str);
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_PTR_TYPE_ARRAY;
cell = cell | LBM_TYPE_ARRAY;
lbm_value stream = token_stream_from_string_value(cell);
@ -1235,7 +1237,7 @@ static inline void eval_progn(eval_context_t *ctx) {
lbm_value exps = lbm_cdr(ctx->curr_exp);
lbm_value env = ctx->curr_env;
if (lbm_type_of(exps) == LBM_VAL_TYPE_SYMBOL && exps == NIL) {
if (lbm_type_of(exps) == LBM_TYPE_SYMBOL && exps == NIL) {
ctx->r = NIL;
ctx->app_cont = true;
return;
@ -1297,14 +1299,14 @@ static inline void eval_let(eval_context_t *ctx) {
lbm_value curr = binds;
lbm_value new_env = orig_env;
if (lbm_type_of(binds) != LBM_PTR_TYPE_CONS) {
if (lbm_type_of(binds) != LBM_TYPE_CONS) {
// binds better be nil or there is a programmer error.
ctx->curr_exp = exp;
return;
}
// Implements letrec by "preallocating" the key parts
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value key = lbm_car(lbm_car(curr));
lbm_value val = NIL;
lbm_value binding;
@ -1326,7 +1328,7 @@ static inline void eval_let(eval_context_t *ctx) {
static inline void eval_and(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
ctx->app_cont = true;
ctx->r = lbm_enc_sym(SYM_TRUE);
@ -1338,7 +1340,7 @@ static inline void eval_and(eval_context_t *ctx) {
static inline void eval_or(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
ctx->app_cont = true;
ctx->r = lbm_enc_sym(SYM_NIL);
@ -1357,7 +1359,7 @@ static inline void eval_or(eval_context_t *ctx) {
static inline void eval_match(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
/* Someone wrote the program (match) */
ctx->app_cont = true;
@ -1371,7 +1373,7 @@ static inline void eval_match(eval_context_t *ctx) {
static inline void eval_receive(eval_context_t *ctx) {
if (lbm_type_of(ctx->mailbox) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(ctx->mailbox) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(ctx->mailbox) == SYM_NIL) {
/*nothing in the mailbox: block the context*/
ctx->timestamp = timestamp_us_callback();
@ -1382,7 +1384,7 @@ static inline void eval_receive(eval_context_t *ctx) {
lbm_value pats = ctx->curr_exp;
lbm_value msgs = ctx->mailbox;
if (lbm_type_of(pats) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(pats) == LBM_TYPE_SYMBOL &&
pats == NIL) {
/* A receive statement without any patterns */
ctx->app_cont = true;
@ -1470,8 +1472,8 @@ static inline void cont_expand_macro(eval_context_t *ctx) {
lbm_value curr_param = lbm_car(lbm_cdr(m));
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) {
while (lbm_type_of(curr_param) == LBM_TYPE_CONS &&
lbm_type_of(curr_arg) == LBM_TYPE_CONS) {
lbm_value entry;
WITH_GC(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), expand_env,NIL);
@ -1495,7 +1497,7 @@ static inline void cont_progn_rest(eval_context_t *ctx) {
lbm_value rest;
lbm_value env;
lbm_pop_u32_2(&ctx->K, &rest, &env);
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL && rest == NIL) {
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL && rest == NIL) {
ctx->app_cont = true;
return;
}
@ -1505,7 +1507,7 @@ static inline void cont_progn_rest(eval_context_t *ctx) {
return;
}
// allow for tail recursion
if (lbm_type_of(lbm_cdr(rest)) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(lbm_cdr(rest)) == LBM_TYPE_SYMBOL &&
lbm_cdr(rest) == NIL) {
ctx->curr_exp = lbm_car(rest);
ctx->curr_env = env;
@ -1566,7 +1568,7 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_value curr_param = params;
lbm_uint i = 1;
while (lbm_type_of(curr_param) == LBM_PTR_TYPE_CONS &&
while (lbm_type_of(curr_param) == LBM_TYPE_CONS &&
i <= lbm_dec_u(count)) {
lbm_value entry;
@ -1589,14 +1591,14 @@ static inline void cont_application(eval_context_t *ctx) {
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) {
while (lbm_type_of(c) == LBM_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_TYPE_SYMBOL) {
/* eval_cps specific operations */
lbm_uint dfun = lbm_dec_sym(fun);
@ -1614,11 +1616,11 @@ static inline void cont_application(eval_context_t *ctx) {
ctx->r = lbm_set_var(s, fun_args[2]);
} else {
lbm_value new_env = lbm_env_modify_binding(ctx->curr_env, fun_args[1], fun_args[2]);
if (lbm_type_of(new_env) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(new_env) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(new_env) == SYM_NOT_FOUND) {
new_env = lbm_env_modify_binding(lbm_get_env(), fun_args[1], fun_args[2]);
}
if (lbm_type_of(new_env) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(new_env) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(new_env) == SYM_NOT_FOUND) {
new_env = lbm_env_set(lbm_get_env(), fun_args[1], fun_args[2]);
if (lbm_is_error(new_env)) {
@ -1646,12 +1648,12 @@ static inline void cont_application(eval_context_t *ctx) {
case SYM_READ_PROGRAM:
if (lbm_dec_u(count) == 1) {
lbm_value stream = NIL;
if (lbm_type_of(fun_args[1]) == LBM_PTR_TYPE_ARRAY) {
if (lbm_type_of(fun_args[1]) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(fun_args[1]);
if(array->elt_type == LBM_VAL_TYPE_CHAR) {
if(array->elt_type == LBM_TYPE_CHAR) {
stream = token_stream_from_string_value(fun_args[1]);
}
} else if (lbm_type_of(fun_args[1]) == LBM_PTR_TYPE_STREAM) {
} else if (lbm_type_of(fun_args[1]) == LBM_TYPE_STREAM) {
stream = fun_args[1];
} else {
error_ctx(lbm_enc_sym(SYM_EERROR));
@ -1670,7 +1672,7 @@ static inline void cont_application(eval_context_t *ctx) {
if (lbm_dec_u(count) >= 2 &&
lbm_is_number(fun_args[1]) &&
lbm_is_closure(fun_args[2])) {
stack_size = lbm_dec_as_u(fun_args[1]);
stack_size = lbm_dec_as_u32(fun_args[1]);
closure_pos = 2;
}
@ -1689,7 +1691,7 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_value curr_param = params;
lbm_uint i = closure_pos + 1;
while (lbm_type_of(curr_param) == LBM_PTR_TYPE_CONS &&
while (lbm_type_of(curr_param) == LBM_TYPE_CONS &&
i <= lbm_dec_u(count)) {
lbm_value entry;
@ -1716,7 +1718,7 @@ static inline void cont_application(eval_context_t *ctx) {
} break;
case SYM_YIELD:
if (lbm_dec_u(count) == 1 && lbm_is_number(fun_args[1])) {
lbm_uint ts = lbm_dec_as_u(fun_args[1]);
lbm_uint ts = lbm_dec_as_u32(fun_args[1]);
lbm_stack_drop(&ctx->K, lbm_dec_u(count)+1);
yield_ctx(ts);
} else {
@ -1724,7 +1726,7 @@ static inline void cont_application(eval_context_t *ctx) {
}
break;
case SYM_WAIT:
if (lbm_type_of(fun_args[1]) == LBM_VAL_TYPE_I) {
if (lbm_type_of(fun_args[1]) == LBM_TYPE_I) {
lbm_cid cid = (lbm_cid)lbm_dec_i(fun_args[1]);
lbm_stack_drop(&ctx->K, lbm_dec_u(count)+1);
CHECK_STACK(lbm_push_u32_2(&ctx->K, lbm_enc_i(cid), lbm_enc_u(WAIT)));
@ -1745,7 +1747,7 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_stack_drop(&ctx->K, lbm_dec_u(count)+1);
if (lbm_type_of(prg) != LBM_PTR_TYPE_CONS) {
if (lbm_type_of(prg) != LBM_TYPE_CONS) {
error_ctx(lbm_enc_sym(SYM_EERROR));
return;
}
@ -1757,7 +1759,7 @@ static inline void cont_application(eval_context_t *ctx) {
lbm_value status = lbm_enc_sym(SYM_EERROR);
if (lbm_dec_u(count) == 2) {
if (lbm_type_of(fun_args[1]) == LBM_VAL_TYPE_I) { /* CID is of U type */
if (lbm_type_of(fun_args[1]) == LBM_TYPE_I) { /* CID is of U type */
lbm_cid cid = (lbm_cid)lbm_dec_i(fun_args[1]);
lbm_value msg = fun_args[2];
@ -1818,12 +1820,12 @@ static inline void cont_application_args(eval_context_t *ctx) {
CHECK_STACK(lbm_push_u32(&ctx->K, arg));
/* Deal with general fundamentals */
if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
// no arguments
CHECK_STACK(lbm_push_u32(&ctx->K, count));
cont_application(ctx);
} else if (lbm_type_of(rest) == LBM_PTR_TYPE_CONS) {
} else if (lbm_type_of(rest) == LBM_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);
ctx->curr_env = env;
@ -1839,11 +1841,11 @@ static inline void cont_and(eval_context_t *ctx) {
lbm_value rest;
lbm_value arg = ctx->r;
lbm_pop_u32(&ctx->K, &rest);
if (lbm_type_of(arg) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(arg) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(arg) == SYM_NIL) {
ctx->app_cont = true;
ctx->r = lbm_enc_sym(SYM_NIL);
} else if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
} else if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
ctx->app_cont = true;
} else {
@ -1856,10 +1858,10 @@ static inline void cont_or(eval_context_t *ctx) {
lbm_value rest;
lbm_value arg = ctx->r;
lbm_pop_u32(&ctx->K, &rest);
if (lbm_type_of(arg) != LBM_VAL_TYPE_SYMBOL ||
if (lbm_type_of(arg) != LBM_TYPE_SYMBOL ||
lbm_dec_sym(arg) != SYM_NIL) {
ctx->app_cont = true;
} else if (lbm_type_of(rest) == LBM_VAL_TYPE_SYMBOL &&
} else if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
rest == NIL) {
ctx->app_cont = true;
ctx->r = lbm_enc_sym(SYM_NIL);
@ -1878,7 +1880,7 @@ static inline void cont_bind_to_key_rest(eval_context_t *ctx) {
lbm_env_modify_binding(env, key, arg);
if ( lbm_type_of(rest) == LBM_PTR_TYPE_CONS ){
if ( lbm_type_of(rest) == LBM_TYPE_CONS ){
lbm_value keyn = lbm_car(lbm_car(rest));
lbm_value valn_exp = lbm_car(lbm_cdr(lbm_car(rest)));
@ -1904,7 +1906,7 @@ static inline void cont_if(eval_context_t *ctx) {
lbm_pop_u32_3(&ctx->K, &env, &then_branch, &else_branch);
if (lbm_type_of(arg) == LBM_VAL_TYPE_SYMBOL && lbm_dec_sym(arg) == SYM_TRUE) {
if (lbm_type_of(arg) == LBM_TYPE_SYMBOL && lbm_dec_sym(arg) == SYM_TRUE) {
ctx->curr_env = env;
ctx->curr_exp = then_branch;
} else {
@ -1923,10 +1925,10 @@ static inline void cont_match_many(eval_context_t *ctx) {
lbm_pop_u32_3(&ctx->K, &rest_msgs, &pats, &exp);
if (lbm_type_of(r) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(r) == LBM_TYPE_SYMBOL &&
(lbm_dec_sym(r) == SYM_NO_MATCH)) {
if (lbm_type_of(rest_msgs) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(rest_msgs) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(rest_msgs) == SYM_NIL) {
ctx->curr_exp = exp;
@ -1953,11 +1955,11 @@ static inline void cont_match(eval_context_t *ctx) {
lbm_pop_u32(&ctx->K, &patterns);
if (lbm_type_of(patterns) == LBM_VAL_TYPE_SYMBOL && lbm_dec_sym(patterns) == SYM_NIL) {
if (lbm_type_of(patterns) == LBM_TYPE_SYMBOL && lbm_dec_sym(patterns) == SYM_NIL) {
/* no more patterns */
ctx->r = lbm_enc_sym(SYM_NO_MATCH);
ctx->app_cont = true;
} else if (lbm_type_of(patterns) == LBM_PTR_TYPE_CONS) {
} else if (lbm_type_of(patterns) == LBM_TYPE_CONS) {
lbm_value pattern = lbm_car(lbm_car(patterns));
lbm_value body = lbm_car(lbm_cdr(lbm_car(patterns)));
@ -2005,9 +2007,9 @@ static inline void cont_read(eval_context_t *ctx) {
bool app_cont = false;
bool program = false;
unsigned int sp_start = ctx->K.sp;
lbm_uint sp_start = ctx->K.sp;
if (lbm_type_of(prg_val) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(prg_val) == LBM_TYPE_SYMBOL) {
if (lbm_dec_sym(prg_val) == SYM_READ) program = false;
else if (lbm_dec_sym(prg_val) == SYM_READ_PROGRAM) program = true;
} else {
@ -2035,9 +2037,9 @@ static inline void cont_read(eval_context_t *ctx) {
lbm_value last_cell = NIL;
lbm_pop_u32_2(&ctx->K, &last_cell, &first_cell);
if (lbm_type_of(ctx->r) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(ctx->r) == SYM_CLOSEPAR) {
if (lbm_type_of(last_cell) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
lbm_set_cdr(last_cell, NIL); // terminate the list
ctx->r = first_cell;
} else {
@ -2045,7 +2047,7 @@ static inline void cont_read(eval_context_t *ctx) {
ctx->r = NIL;
}
app_cont = true;
} else if (lbm_type_of(ctx->r) == LBM_VAL_TYPE_SYMBOL &&
} else if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(ctx->r) == SYM_DOT) {
CHECK_STACK(lbm_push_u32_3(&ctx->K,
first_cell, last_cell,
@ -2053,7 +2055,7 @@ static inline void cont_read(eval_context_t *ctx) {
} else {
lbm_value new_cell;
CONS_WITH_GC(new_cell, ctx->r, NIL, stream);
if (lbm_type_of(last_cell) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
lbm_set_cdr(last_cell, new_cell);
last_cell = new_cell;
} else {
@ -2065,7 +2067,7 @@ static inline void cont_read(eval_context_t *ctx) {
}
} break;
case EXPECT_CLOSEPAR: {
if (lbm_type_of(ctx->r) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(ctx->r) == SYM_CLOSEPAR) {
lbm_value res = NIL;
lbm_pop_u32(&ctx->K, &res);
@ -2081,13 +2083,13 @@ static inline void cont_read(eval_context_t *ctx) {
lbm_value last_cell = NIL;
lbm_pop_u32_2(&ctx->K, &last_cell, &first_cell);
if (lbm_type_of(ctx->r) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
(lbm_dec_sym(ctx->r) == SYM_CLOSEPAR ||
lbm_dec_sym(ctx->r) == SYM_DOT)) {
error_ctx(lbm_enc_sym(SYM_RERROR));
return;
} else {
if (lbm_type_of(last_cell) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
lbm_set_cdr(last_cell, ctx->r);
ctx->r = first_cell;
CHECK_STACK(lbm_push_u32_2(&ctx->K,
@ -2140,10 +2142,9 @@ static inline void cont_read(eval_context_t *ctx) {
} break;
}
} else {
app_cont = false;
tok = token_stream_get(str);
if (lbm_type_of(tok) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(tok) == LBM_TYPE_SYMBOL) {
switch (lbm_dec_sym(tok)) {
case SYM_RERROR:
error_ctx(lbm_enc_sym(SYM_RERROR));
@ -2229,20 +2230,38 @@ static inline void cont_read(eval_context_t *ctx) {
}
}
#define OTHER_APPLY 0
#define MACRO_APPLY 1
#define MACRO_EXPAND 2
#define CLOSURE_APPLY 3
static inline int application_kind(lbm_value v) {
if (lbm_type_of(v) == LBM_TYPE_CONS) {
lbm_value fun_kind_identifier = lbm_car(v);
if (lbm_type_of(fun_kind_identifier) == LBM_TYPE_SYMBOL) {
if (lbm_dec_sym(fun_kind_identifier) == SYM_CLOSURE) return CLOSURE_APPLY;
if (lbm_dec_sym(fun_kind_identifier) == SYM_MACRO) return MACRO_APPLY;
if (lbm_dec_sym(fun_kind_identifier) == SYM_MACRO_EXPAND) return MACRO_EXPAND;
}
}
return OTHER_APPLY;
}
static inline void cont_application_start(eval_context_t *ctx) {
lbm_value args;
lbm_pop_u32(&ctx->K, &args);
if (lbm_is_symbol(ctx->r) &&
lbm_dec_sym(ctx->r) == SYM_MACRO_EXPAND) {
switch (application_kind(ctx->r)) {
case MACRO_EXPAND:
/* (macro-expand (args + (list 1 2 3))) */
CHECK_STACK(lbm_push_u32_2(&ctx->K,
lbm_cdr(lbm_car(args)),
lbm_enc_u(EXPAND_MACRO)));
ctx->curr_exp = lbm_car(lbm_car(args));
} else if (lbm_is_macro(ctx->r)) {
break;
case MACRO_APPLY:{
/*
* Perform macro expansion.
* Macro expansion is really just evaluation in an
@ -2255,8 +2274,8 @@ static inline void cont_application_start(eval_context_t *ctx) {
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) {
while (lbm_type_of(curr_param) == LBM_TYPE_CONS &&
lbm_type_of(curr_arg) == LBM_TYPE_CONS) {
lbm_value entry;
WITH_GC(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), expand_env,NIL);
@ -2280,11 +2299,19 @@ static inline void cont_application_start(eval_context_t *ctx) {
ctx->curr_exp = exp;
ctx->curr_env = expand_env;
ctx->app_cont = false;
} else {
} break;
case CLOSURE_APPLY:
/* CHECK_STACK(lbm_push_u32(&ctx->K, */
/* NIL, */
/* args)); */
/* cont_closure_application_args(ctx); */
/* break; */
default:
CHECK_STACK(lbm_push_u32_2(&ctx->K,
lbm_enc_u(0),
args));
cont_application_args(ctx);
break;
}
}
@ -2341,21 +2368,24 @@ static void evaluation_step(void){
switch (lbm_type_of(ctx->curr_exp)) {
case LBM_VAL_TYPE_SYMBOL: eval_symbol(ctx); return;
case LBM_PTR_TYPE_BOXED_F: /* fall through */
case LBM_PTR_TYPE_BOXED_U:
case LBM_PTR_TYPE_BOXED_I:
case LBM_VAL_TYPE_I:
case LBM_VAL_TYPE_U:
case LBM_VAL_TYPE_CHAR:
case LBM_PTR_TYPE_ARRAY:
case LBM_PTR_TYPE_REF:
case LBM_PTR_TYPE_STREAM: eval_selfevaluating(ctx); return;
case LBM_TYPE_SYMBOL: eval_symbol(ctx); return;
case LBM_TYPE_FLOAT: /* fall through */
case LBM_TYPE_DOUBLE:
case LBM_TYPE_U32:
case LBM_TYPE_U64:
case LBM_TYPE_I32:
case LBM_TYPE_I64:
case LBM_TYPE_I:
case LBM_TYPE_U:
case LBM_TYPE_CHAR:
case LBM_TYPE_ARRAY:
case LBM_TYPE_REF:
case LBM_TYPE_STREAM: eval_selfevaluating(ctx); return;
case LBM_PTR_TYPE_CONS:
case LBM_TYPE_CONS:
head = lbm_car(ctx->curr_exp);
if (lbm_type_of(head) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(head) == LBM_TYPE_SYMBOL) {
lbm_uint sym_id = lbm_dec_sym(head);

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

@ -28,8 +28,6 @@ static int ext_offset = EXTENSION_SYMBOLS_START;
static int ext_max = -1;
static extension_fptr *extension_table = NULL;
uint32_t* extensions = NULL;
int lbm_extensions_init(extension_fptr *extension_storage, int extension_storage_size) {
if (extension_storage == NULL || extension_storage_size <= 0) return 0;

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

@ -84,19 +84,19 @@ lbm_value array_extension_unsafe_free_array(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
if (argn != 1 ||
lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY) {
lbm_type_of(args[0]) != LBM_TYPE_ARRAY) {
return res;
}
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
if (lbm_memory_ptr_inside(array->data)) {
lbm_memory_free((uint32_t *)array->data);
lbm_memory_free((lbm_uint *)array->data);
lbm_uint ptr = lbm_dec_ptr(args[0]);
lbm_value cons_ptr = lbm_enc_cons_ptr(ptr);
lbm_set_car(cons_ptr,lbm_enc_sym(SYM_NIL));
lbm_set_cdr(cons_ptr,lbm_enc_sym(SYM_NIL));
res = lbm_enc_sym(SYM_TRUE);
}
lbm_memory_free((uint32_t *)array);
lbm_memory_free((lbm_uint *)array);
return res;
}
@ -105,17 +105,17 @@ 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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_int value = lbm_dec_as_i(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
if (index >= array->size) {
return res;
@ -136,23 +136,23 @@ lbm_value array_extension_buffer_append_i16(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[3]) == LBM_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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_int value = lbm_dec_as_i(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
if (index+1 >= array->size) {
return res;
@ -183,23 +183,23 @@ lbm_value array_extension_buffer_append_i32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[3]) == LBM_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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_int value = lbm_dec_as_i(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_int value = lbm_dec_as_i32(args[2]);
if (index+3 >= array->size) {
return res;
@ -233,17 +233,17 @@ lbm_value array_extension_buffer_append_u8(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if(lbm_type_of(args[0]) != LBM_PTR_TYPE_ARRAY ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = lbm_dec_as_u(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
if (index >= array->size) {
return res;
@ -267,23 +267,23 @@ lbm_value array_extension_buffer_append_u16(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[3]) == LBM_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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = lbm_dec_as_u(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
if (index+1 >= array->size) {
return res;
@ -314,23 +314,23 @@ lbm_value array_extension_buffer_append_u32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[3]) == LBM_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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = lbm_dec_as_u(args[2]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = lbm_dec_as_u32(args[2]);
if (index+3 >= array->size) {
return res;
@ -357,7 +357,7 @@ lbm_value array_extension_buffer_append_u32(lbm_value *args, lbm_uint argn) {
return res;
}
static lbm_uint float32_to_u32(float number) {
static lbm_uint float_to_u(float number) {
// Set subnormal numbers to 0 as they are not handled properly
// using this method.
if (fabsf(number) < 1.5e-38) {
@ -382,7 +382,7 @@ static lbm_uint float32_to_u32(float number) {
return res;
}
static float u32_to_float32(uint32_t v) {
static lbm_float u_to_float(uint32_t v) {
int e = (v >> 23) & 0xFF;
uint32_t sig_i = v & 0x7FFFFF;
@ -401,7 +401,6 @@ static float u32_to_float32(uint32_t v) {
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);
@ -410,24 +409,24 @@ lbm_value array_extension_buffer_append_f32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 4:
if (lbm_type_of(args[3]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[3]) == LBM_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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
float f_value = lbm_dec_as_f(args[2]);
lbm_value value = float32_to_u32(f_value);
lbm_uint index = lbm_dec_as_u(args[1]);
float f_value = (float)lbm_dec_as_float(args[2]);
lbm_value value = float_to_u(f_value);
lbm_uint index = lbm_dec_as_u32(args[1]);
if (index+3 >= array->size) {
return res;
@ -461,16 +460,16 @@ 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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
if (index >= array->size) {
@ -492,22 +491,22 @@ lbm_value array_extension_buffer_get_i16(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[2]) == LBM_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 ||
if (lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
if (index+1 >= array->size) {
@ -540,23 +539,23 @@ lbm_value array_extension_buffer_get_i32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[2]) == LBM_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 ||
if (lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
lbm_uint index = lbm_dec_as_u32(args[1]);
uint32_t value = 0;
if (index+3 >= array->size) {
return res;
@ -565,19 +564,19 @@ lbm_value array_extension_buffer_get_i32(lbm_value *args, lbm_uint argn) {
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;
(uint32_t) data[index+3] |
(uint32_t) data[index+2] << 8 |
(uint32_t) data[index+1] << 16 |
(uint32_t) 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;
(uint32_t) data[index] |
(uint32_t) data[index+1] << 8 |
(uint32_t) data[index+2] << 16 |
(uint32_t) data[index+3] << 24;
}
res = lbm_enc_I((lbm_int)value);
res = lbm_enc_i32((int32_t)value);
break;
default:
break;
@ -590,16 +589,16 @@ 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 ||
if(lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
if (index >= array->size) {
@ -621,22 +620,22 @@ lbm_value array_extension_buffer_get_u16(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[2]) == LBM_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 ||
if (lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint index = lbm_dec_as_u32(args[1]);
lbm_uint value = 0;
if (index+1 >= array->size) {
@ -669,23 +668,23 @@ lbm_value array_extension_buffer_get_u32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[2]) == LBM_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 ||
if (lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
lbm_uint index = lbm_dec_as_u32(args[1]);
uint32_t value = 0;
if (index+3 >= array->size) {
return res;
@ -694,19 +693,19 @@ lbm_value array_extension_buffer_get_u32(lbm_value *args, lbm_uint argn) {
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;
(uint32_t) data[index+3] |
(uint32_t) data[index+2] << 8 |
(uint32_t) data[index+1] << 16 |
(uint32_t) 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;
(uint32_t) data[index] |
(uint32_t) data[index+1] << 8 |
(uint32_t) data[index+2] << 16 |
(uint32_t) data[index+3] << 24;
}
res = lbm_enc_U(value);
res = lbm_enc_u32(value);
break;
default:
break;
@ -721,23 +720,23 @@ lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn) {
switch(argn) {
case 3:
if (lbm_type_of(args[2]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[2]) == LBM_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 ||
if (lbm_type_of(args[0]) != LBM_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) {
if (array->elt_type != LBM_TYPE_BYTE) {
return res;
}
lbm_uint index = lbm_dec_as_u(args[1]);
lbm_uint value = 0;
uint32_t index = (uint32_t)lbm_dec_as_u32(args[1]);
uint32_t value = 0;
if (index+3 >= array->size) {
return res;
@ -746,19 +745,19 @@ lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn) {
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;
(uint32_t) data[index+3] |
(uint32_t) data[index+2] << 8 |
(uint32_t) data[index+1] << 16 |
(uint32_t) 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;
(uint32_t) data[index] |
(uint32_t) data[index+1] << 8 |
(uint32_t) data[index+2] << 16 |
(uint32_t) data[index+3] << 24;
}
res = lbm_enc_F(u32_to_float32(value));
res = lbm_enc_float((float)u_to_float(value));
break;
default:
break;
@ -769,18 +768,18 @@ lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn) {
lbm_value array_extension_buffer_length(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_EERROR);
if (argn == 1 &&
lbm_type_of(args[0]) == LBM_PTR_TYPE_ARRAY) {
lbm_type_of(args[0]) == LBM_TYPE_ARRAY) {
printf("trying\n");
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
switch(array->elt_type) {
case LBM_VAL_TYPE_CHAR: /* Same as byte */
case LBM_TYPE_CHAR: /* Same as byte */
res = lbm_enc_i((lbm_int)array->size);
break;
case LBM_VAL_TYPE_I: /* fall through */
case LBM_VAL_TYPE_U:
case LBM_PTR_TYPE_BOXED_I:
case LBM_PTR_TYPE_BOXED_U:
case LBM_PTR_TYPE_BOXED_F:
case LBM_TYPE_I: /* fall through */
case LBM_TYPE_U:
case LBM_TYPE_I32:
case LBM_TYPE_U32:
case LBM_TYPE_FLOAT:
res = lbm_enc_i((lbm_int)array->size * 4);
break;
}

211
lispBM/lispBM/src/extensions/math_extensions.c Normal file
View File

@ -0,0 +1,211 @@
/*
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.h"
#include "lbm_utils.h"
#include <math.h>
// Helpers
static bool is_number_all(lbm_value *args, lbm_uint argn) {
for (lbm_uint i = 0;i < argn;i++) {
if (!lbm_is_number(args[i])) {
return false;
}
}
return true;
}
#define CHECK_NUMBER_ALL() if (!is_number_all(args, argn)) {return lbm_enc_sym(SYM_EERROR);}
#define CHECK_ARGN(n) if (argn != n) {return lbm_enc_sym(SYM_EERROR);}
#define CHECK_ARGN_NUMBER(n) if (argn != n || !is_number_all(args, argn)) {return lbm_enc_sym(SYM_EERROR);}
void rotate_vector3(float *input, float *rotation, float *output, bool reverse) {
float s1, c1, s2, c2, s3, c3;
if (rotation[2] != 0.0) {
s1 = sinf(rotation[2]);
c1 = cosf(rotation[2]);
} else {
s1 = 0.0;
c1 = 1.0;
}
if (rotation[1] != 0.0) {
s2 = sinf(rotation[1]);
c2 = cosf(rotation[1]);
} else {
s2 = 0.0;
c2 = 1.0;
}
if (rotation[0] != 0.0) {
s3 = sinf(rotation[0]);
c3 = cosf(rotation[0]);
} else {
s3 = 0.0;
c3 = 1.0;
}
float m11 = c1 * c2; float m12 = c1 * s2 * s3 - c3 * s1; float m13 = s1 * s3 + c1 * c3 * s2;
float m21 = c2 * s1; float m22 = c1 * c3 + s1 * s2 * s3; float m23 = c3 * s1 * s2 - c1 * s3;
float m31 = -s2; float m32 = c2 * s3; float m33 = c2 * c3;
if (reverse) {
output[0] = input[0] * m11 + input[1] * m21 + input[2] * m31;
output[1] = input[0] * m12 + input[1] * m22 + input[2] * m32;
output[2] = input[0] * m13 + input[1] * m23 + input[2] * m33;
} else {
output[0] = input[0] * m11 + input[1] * m12 + input[2] * m13;
output[1] = input[0] * m21 + input[1] * m22 + input[2] * m23;
output[2] = input[0] * m31 + input[1] * m32 + input[2] * m33;
}
}
// Math
static lbm_value ext_sinf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(sinf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_cosf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(cosf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_tanf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(tanf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_asinf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(asinf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_acosf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(acosf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_atanf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(atanf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_atan2f(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(2)
return lbm_enc_float(atan2f(lbm_dec_as_float(args[0]), lbm_dec_as_float(args[1])));
}
static lbm_value ext_powf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(2)
return lbm_enc_float(powf(lbm_dec_as_float(args[0]), lbm_dec_as_float(args[1])));
}
static lbm_value ext_sqrtf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(sqrtf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_logf(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(logf(lbm_dec_as_float(args[0])));
}
static lbm_value ext_log10f(lbm_value *args, lbm_uint argn) {
CHECK_ARGN_NUMBER(1)
return lbm_enc_float(log10f(lbm_dec_as_float(args[0])));
}
static lbm_value ext_deg2radf(lbm_value *args, lbm_uint argn) {
CHECK_NUMBER_ALL();
if (argn == 1) {
return lbm_enc_float(DEG2RAD_f(lbm_dec_as_float(args[0])));
} else {
lbm_value out_list = lbm_enc_sym(SYM_NIL);
for (int i = (int)(argn - 1);i >= 0;i--) {
out_list = lbm_cons(lbm_enc_float(DEG2RAD_f(lbm_dec_as_float(args[i]))), out_list);
}
return out_list;
}
}
static lbm_value ext_rad2degf(lbm_value *args, lbm_uint argn) {
CHECK_NUMBER_ALL();
if (argn == 1) {
return lbm_enc_float(RAD2DEG_f(lbm_dec_as_float(args[0])));
} else {
lbm_value out_list = lbm_enc_sym(SYM_NIL);
for (int i = (int)(argn - 1);i >= 0;i--) {
out_list = lbm_cons(lbm_enc_float(RAD2DEG_f(lbm_dec_as_float(args[i]))), out_list);
}
return out_list;
}
}
static lbm_value ext_vec3_rotf(lbm_value *args, lbm_uint argn) {
CHECK_NUMBER_ALL();
if (argn != 6 && argn != 7) {
return lbm_enc_sym(SYM_EERROR);
}
float input[] = {lbm_dec_as_float(args[0]), lbm_dec_as_float(args[1]), lbm_dec_as_float(args[2])};
float rotation[] = {lbm_dec_as_float(args[3]), lbm_dec_as_float(args[4]), lbm_dec_as_float(args[5])};
float output[3];
bool reverse = false;
if (argn == 7) {
reverse = lbm_dec_as_i32(args[6]);
}
rotate_vector3(input, rotation, output, reverse);
lbm_value out_list = lbm_enc_sym(SYM_NIL);
out_list = lbm_cons(lbm_enc_float(output[2]), out_list);
out_list = lbm_cons(lbm_enc_float(output[1]), out_list);
out_list = lbm_cons(lbm_enc_float(output[0]), out_list);
return out_list;
}
bool lbm_math_extensions_init(void) {
bool res = true;
res = res && lbm_add_extension("sinf", ext_sinf);
res = res && lbm_add_extension("cosf", ext_cosf);
res = res && lbm_add_extension("tanf", ext_tanf);
res = res && lbm_add_extension("asinf", ext_asinf);
res = res && lbm_add_extension("acosf", ext_acosf);
res = res && lbm_add_extension("atanf", ext_atanf);
res = res && lbm_add_extension("atan2f", ext_atan2f);
res = res && lbm_add_extension("powf", ext_powf);
res = res && lbm_add_extension("sqrtf", ext_sqrtf);
res = res && lbm_add_extension("logf", ext_logf);
res = res && lbm_add_extension("log10f", ext_log10f);
res = res && lbm_add_extension("deg2radf", ext_deg2radf);
res = res && lbm_add_extension("rad2degf", ext_rad2degf);
res = res && lbm_add_extension("vec3-rotf", ext_vec3_rotf);
return res;
}

401
lispBM/lispBM/src/extensions/string_extensions.c Normal file
View File

@ -0,0 +1,401 @@
/*
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.h"
#include "lbm_memory.h"
#include "heap.h"
#include "fundamental.h"
#include "lbm_c_interop.h"
#include <ctype.h>
#ifndef MIN
#define MIN(a,b) (((a)<(b))?(a):(b))
#endif
#ifndef MAX
#define MAX(a,b) (((a)>(b))?(a):(b))
#endif
static lbm_value ext_str_from_n(lbm_value *args, lbm_uint argn) {
if ((argn != 1 && argn != 2) || !lbm_is_number(args[0])) {
return lbm_enc_sym(SYM_EERROR);
}
if (argn == 2 && lbm_type_of(args[1]) != LBM_TYPE_ARRAY) {
return lbm_enc_sym(SYM_EERROR);
}
char *format = 0;
if (argn == 2) {
format = lbm_dec_str(args[1]);
}
char buffer[100];
size_t len = 0;
switch (lbm_type_of(args[0])) {
case LBM_TYPE_FLOAT:
if (!format) {
format = "%f";
}
len = (size_t)snprintf(buffer, sizeof(buffer), format, (double)lbm_dec_as_float(args[0]));
break;
default:
if (!format) {
format = "%d";
}
len = (size_t)snprintf(buffer, sizeof(buffer), format, lbm_dec_as_i32(args[0]));
break;
}
if (len > sizeof(buffer)) {
len = sizeof(buffer);
}
lbm_value res;
if (lbm_create_array(&res, LBM_TYPE_CHAR, len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
memcpy(arr->data, buffer, len);
((char*)(arr->data))[len] = '\0';
return res;
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
static lbm_value ext_str_merge(lbm_value *args, lbm_uint argn) {
int len_tot = 0;
for (unsigned int i = 0;i < argn;i++) {
char *str = lbm_dec_str(args[i]);
if (str) {
len_tot += (int)strlen(str);
} else {
return lbm_enc_sym(SYM_EERROR);
}
}
lbm_value res;
if (lbm_create_array(&res, LBM_TYPE_CHAR, (lbm_uint)len_tot + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
unsigned int offset = 0;
for (unsigned int i = 0;i < argn;i++) {
offset += (unsigned int)sprintf((char*)arr->data + offset, "%s", lbm_dec_str(args[i]));
}
((char*)(arr->data))[len_tot] = '\0';
return res;
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
static lbm_value ext_str_to_i(lbm_value *args, lbm_uint argn) {
if (argn != 1 && argn != 2) {
return lbm_enc_sym(SYM_EERROR);
}
char *str = lbm_dec_str(args[0]);
if (!str) {
return lbm_enc_sym(SYM_EERROR);
}
int base = 0;
if (argn == 2) {
if (!lbm_is_number(args[1])) {
return lbm_enc_sym(SYM_EERROR);
}
base = lbm_dec_as_i32(args[1]);
}
return lbm_enc_i(strtol(str, NULL, base));
}
static lbm_value ext_str_to_f(lbm_value *args, lbm_uint argn) {
if (argn != 1) {
return lbm_enc_sym(SYM_EERROR);
}
char *str = lbm_dec_str(args[0]);
if (!str) {
return lbm_enc_sym(SYM_EERROR);
}
return lbm_enc_float(strtof(str, NULL));
}
static lbm_value ext_str_part(lbm_value *args, lbm_uint argn) {
if ((argn != 2 && argn != 3) || !lbm_is_number(args[1])) {
return lbm_enc_sym(SYM_EERROR);
}
char *str = lbm_dec_str(args[0]);
if (!str) {
return lbm_enc_sym(SYM_EERROR);
}
size_t len = strlen(str);
uint32_t start = lbm_dec_as_u32(args[1]);
if (start >= len) {
return lbm_enc_sym(SYM_EERROR);
}
uint32_t n = (uint32_t)len - start;
if (argn == 3) {
if (!lbm_is_number(args[2])) {
return lbm_enc_sym(SYM_EERROR);
}
n = MIN(lbm_dec_as_u32(args[2]), n);
}
lbm_value res;
if (lbm_create_array(&res, LBM_TYPE_CHAR, n + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
memcpy(arr->data, str + start, n);
((char*)(arr->data))[n] = '\0';
return res;
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
if (argn != 2) {
return lbm_enc_sym(SYM_EERROR);
}
char *str = lbm_dec_str(args[0]);
if (!str) {
return lbm_enc_sym(SYM_EERROR);
}
char *split = lbm_dec_str(args[1]);
int step = 0;
if (!split) {
if (lbm_is_number(args[1])) {
step = MAX(lbm_dec_as_i32(args[1]), 1);
} else {
return lbm_enc_sym(SYM_EERROR);
}
}
if (step > 0) {
lbm_value res = lbm_enc_sym(SYM_NIL);
int len = (int)strlen(str);
for (int i = len / step;i >= 0;i--) {
int ind_now = i * step;
if (ind_now >= len) {
continue;
}
int step_now = step;
while ((ind_now + step_now) > len) {
step_now--;
}
lbm_value tok;
if (lbm_create_array(&tok, LBM_TYPE_CHAR, (lbm_uint)step_now + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(tok);
memcpy(arr->data, str + ind_now, (size_t)step_now);
((char*)(arr->data))[step_now] = '\0';
res = lbm_cons(tok, res);
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
return res;
} else {
lbm_value res = lbm_enc_sym(SYM_NIL);
const char *s = str;
while (*(s += strspn(s, split)) != '\0') {
size_t len = strcspn(s, split);
lbm_value tok;
if (lbm_create_array(&tok, LBM_TYPE_CHAR, len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(tok);
memcpy(arr->data, s, len);
((char*)(arr->data))[len] = '\0';
res = lbm_cons(tok, res);
} else {
return lbm_enc_sym(SYM_MERROR);
}
s += len;
}
return lbm_list_destructive_reverse(res);
}
}
static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
if (argn != 2 && argn != 3) {
return lbm_enc_sym(SYM_EERROR);
}
char *orig = lbm_dec_str(args[0]);
if (!orig) {
return lbm_enc_sym(SYM_TERROR);
}
char *rep = lbm_dec_str(args[1]);
if (!rep) {
return lbm_enc_sym(SYM_TERROR);
}
char *with = "";
if (argn == 3) {
with = lbm_dec_str(args[2]);
if (!with) {
return lbm_enc_sym(SYM_TERROR);
}
}
// See https://stackoverflow.com/questions/779875/what-function-is-to-replace-a-substring-from-a-string-in-c
char *result; // the return string
char *ins; // the next insert point
char *tmp; // varies
int len_rep; // length of rep (the string to remove)
int len_with; // length of with (the string to replace rep with)
int len_front; // distance between rep and end of last rep
int count; // number of replacements
len_rep = (int)strlen(rep);
if (len_rep == 0) {
return args[0]; // empty rep causes infinite loop during count
}
len_with = (int)strlen(with);
// count the number of replacements needed
ins = orig;
for (count = 0; (tmp = strstr(ins, rep)); ++count) {
ins = tmp + len_rep;
}
size_t len_res = strlen(orig) + (size_t)((len_with - len_rep) * count + 1);
lbm_value lbm_res;
if (lbm_create_array(&lbm_res, LBM_TYPE_CHAR, len_res)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
tmp = result = (char*)arr->data;
} else {
return lbm_enc_sym(SYM_MERROR);
}
// first time through the loop, all the variable are set correctly
// from here on,
// tmp points to the end of the result string
// ins points to the next occurrence of rep in orig
// orig points to the remainder of orig after "end of rep"
while (count--) {
ins = strstr(orig, rep);
len_front = (int)((lbm_uint)ins - (lbm_uint)orig);
tmp = strncpy(tmp, orig, (size_t)len_front) + len_front;
tmp = strcpy(tmp, with) + len_with;
orig += len_front + len_rep; // move to next "end of rep"
}
strcpy(tmp, orig);
return lbm_res;
}
static lbm_value ext_str_to_lower(lbm_value *args, lbm_uint argn) {
if (argn != 1) {
return lbm_enc_sym(SYM_EERROR);
}
char *orig = lbm_dec_str(args[0]);
if (!orig) {
return lbm_enc_sym(SYM_TERROR);
}
int len = (int)strlen(orig);
lbm_value lbm_res;
if (lbm_create_array(&lbm_res, LBM_TYPE_CHAR, (lbm_uint)len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
for (int i = 0;i < len;i++) {
((char*)(arr->data))[i] = (char)tolower(orig[i]);
}
((char*)(arr->data))[len] = '\0';
return lbm_res;
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
static lbm_value ext_str_to_upper(lbm_value *args, lbm_uint argn) {
if (argn != 1) {
return lbm_enc_sym(SYM_EERROR);
}
char *orig = lbm_dec_str(args[0]);
if (!orig) {
return lbm_enc_sym(SYM_TERROR);
}
int len = (int)strlen(orig);
lbm_value lbm_res;
if (lbm_create_array(&lbm_res, LBM_TYPE_CHAR, (lbm_uint)len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
for (int i = 0;i < len;i++) {
((char*)(arr->data))[i] = (char)toupper(orig[i]);
}
((char*)(arr->data))[len] = '\0';
return lbm_res;
} else {
return lbm_enc_sym(SYM_MERROR);
}
}
static lbm_value ext_str_cmp(lbm_value *args, lbm_uint argn) {
if (argn != 2) {
return lbm_enc_sym(SYM_EERROR);
}
char *str1 = lbm_dec_str(args[0]);
if (!str1) {
return lbm_enc_sym(SYM_EERROR);
}
char *str2 = lbm_dec_str(args[1]);
if (!str2) {
return lbm_enc_sym(SYM_EERROR);
}
return lbm_enc_i(strcmp(str1, str2));
}
bool lbm_string_extensions_init(void) {
bool res = true;
res = res && lbm_add_extension("str-from-n", ext_str_from_n);
res = res && lbm_add_extension("str-merge", ext_str_merge);
res = res && lbm_add_extension("str-to-i", ext_str_to_i);
res = res && lbm_add_extension("str-to-f", ext_str_to_f);
res = res && lbm_add_extension("str-part", ext_str_part);
res = res && lbm_add_extension("str-split", ext_str_split);
res = res && lbm_add_extension("str-replace", ext_str_replace);
res = res && lbm_add_extension("str-to-lower", ext_str_to_lower);
res = res && lbm_add_extension("str-to-upper", ext_str_to_upper);
res = res && lbm_add_extension("str-cmp", ext_str_cmp);
return res;
}

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

@ -24,6 +24,7 @@
#include "print.h"
#include "lbm_variables.h"
#include "env.h"
#include "lbm_utils.h"
#include <stdio.h>
#include <math.h>
@ -37,10 +38,12 @@ static lbm_uint shl(lbm_uint a, lbm_uint b) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) << lbm_dec_as_u(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) << lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_U(a) << lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_I(a) << lbm_dec_as_u(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) << lbm_dec_as_u32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) << lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_u32(a) << lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_i32(a) << lbm_dec_as_u32(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_i64(a) << lbm_dec_as_u32(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_u64(a) << lbm_dec_as_u32(b)); break;
}
return retval;
}
@ -54,10 +57,12 @@ static lbm_uint shr(lbm_uint a, lbm_uint b) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) >> lbm_dec_as_u(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) >> lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_U(a) >> lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_I(a) >> lbm_dec_as_u(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) >> lbm_dec_as_u32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) >> lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_u32(a) >> lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_i32(a) >> lbm_dec_as_u32(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_i64(a) >> lbm_dec_as_u32(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_u64(a) >> lbm_dec_as_u32(b)); break;
}
return retval;
}
@ -71,10 +76,12 @@ static lbm_uint bitwise_and(lbm_uint a, lbm_uint b) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) & lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) & lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_U(a) & lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_I(a) & lbm_dec_as_i(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) & lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) & lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_u32(a) & lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_i32(a) & lbm_dec_as_i32(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_i64(a) & lbm_dec_as_i64(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_u64(a) & lbm_dec_as_u64(b)); break;
}
return retval;
}
@ -88,10 +95,12 @@ static lbm_uint bitwise_or(lbm_uint a, lbm_uint b) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) | lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) | lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_U(a) | lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_I(a) | lbm_dec_as_i(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) | lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) | lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_u32(a) | lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_i32(a) | lbm_dec_as_i32(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_i64(a) | lbm_dec_as_i64(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_u64(a) | lbm_dec_as_u64(b)); break;
}
return retval;
}
@ -105,10 +114,12 @@ static lbm_uint bitwise_xor(lbm_uint a, lbm_uint b) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) ^ lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) ^ lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_U(a) ^ lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_I(a) ^ lbm_dec_as_i(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_i(a) ^ lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_u(a) ^ lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_u32(a) ^ lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_i32(a) ^ lbm_dec_as_i32(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_i64(a) ^ lbm_dec_as_i64(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_u64(a) ^ lbm_dec_as_u64(b)); break;
}
return retval;
}
@ -122,10 +133,12 @@ static lbm_uint bitwise_not(lbm_uint a) {
}
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(~lbm_dec_i(a)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(~lbm_dec_u(a)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(~lbm_dec_U(a)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(~lbm_dec_I(a)); break;
case LBM_TYPE_I: retval = lbm_enc_i(~lbm_dec_i(a)); break;
case LBM_TYPE_U: retval = lbm_enc_u(~lbm_dec_u(a)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(~lbm_dec_u32(a)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(~lbm_dec_i32(a)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(~lbm_dec_i64(a)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(~lbm_dec_u64(a)); break;
}
return retval;
}
@ -141,11 +154,14 @@ static lbm_uint add2(lbm_uint a, lbm_uint b) {
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i(a) + lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u(a) + lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_as_u(a) + lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_as_i(a) + lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: retval = lbm_enc_F(lbm_dec_as_f(a) + lbm_dec_as_f(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i32(a) + lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u32(a) + lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_as_u32(a) + lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_as_i32(a) + lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: retval = lbm_enc_float(lbm_dec_as_float(a) + lbm_dec_as_float(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_as_u64(a) + lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_as_i64(a) + lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: retval = lbm_enc_double(lbm_dec_as_double(a) + lbm_dec_as_double(b)); break;
}
return retval;
}
@ -160,11 +176,14 @@ static lbm_uint mul2(lbm_uint a, lbm_uint b) {
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i(a) * lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u(a) * lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_as_u(a) * lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_as_i(a) * lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: retval = lbm_enc_F(lbm_dec_as_f(a) * lbm_dec_as_f(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i32(a) * lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u32(a) * lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_as_u32(a) * lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_as_i32(a) * lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: retval = lbm_enc_float(lbm_dec_as_float(a) * lbm_dec_as_float(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_as_u64(a) * lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_as_i64(a) * lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: retval = lbm_enc_double(lbm_dec_as_double(a) * lbm_dec_as_double(b)); break;
}
return retval;
}
@ -179,11 +198,14 @@ static lbm_uint div2(lbm_uint a, lbm_uint b) {
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: if (lbm_dec_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i(lbm_dec_as_i(a) / lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: if (lbm_dec_as_u(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u(lbm_dec_as_u(a) / lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: if (lbm_dec_as_u(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_U(lbm_dec_as_u(a) / lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: if (lbm_dec_as_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_I(lbm_dec_as_i(a) / lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: if (lbm_dec_as_f(b) == 0.0 || lbm_dec_as_f(b) == -0.0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_F(lbm_dec_as_f(a) / lbm_dec_as_f(b)); break;
case LBM_TYPE_I: if (lbm_dec_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i(lbm_dec_as_i32(a) / lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: if (lbm_dec_as_u32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u(lbm_dec_as_u32(a) / lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: if (lbm_dec_as_u32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u32(lbm_dec_as_u32(a) / lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: if (lbm_dec_as_i32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i32(lbm_dec_as_i32(a) / lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: if (lbm_dec_as_float(b) == 0.0f || lbm_dec_as_float(b) == -0.0f) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_float(lbm_dec_as_float(a) / lbm_dec_as_float(b)); break;
case LBM_TYPE_U64: if (lbm_dec_as_u64(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u64(lbm_dec_as_u32(a) / lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: if (lbm_dec_as_i64(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i64(lbm_dec_as_i32(a) / lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: if (lbm_dec_as_double(b) == (double)0.0 || lbm_dec_as_double(b) == (double)-0.0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_double(lbm_dec_as_double(a) / lbm_dec_as_double(b)); break;
}
return retval;
}
@ -198,11 +220,14 @@ static lbm_uint mod2(lbm_uint a, lbm_uint b) {
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: if (lbm_dec_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i(lbm_dec_as_i(a) % lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: if (lbm_dec_as_u(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u(lbm_dec_as_u(a) % lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: if (lbm_dec_as_u(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_U(lbm_dec_as_u(a) % lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: if (lbm_dec_as_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_I(lbm_dec_as_i(a) % lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: if (lbm_dec_as_f(b) == 0.0 || lbm_dec_as_f(b) == -0.0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_F(fmodf(lbm_dec_as_f(a), lbm_dec_as_f(b))); break;
case LBM_TYPE_I: if (lbm_dec_i(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i(lbm_dec_as_i32(a) % lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: if (lbm_dec_as_u32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u(lbm_dec_as_u32(a) % lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: if (lbm_dec_as_u32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u32(lbm_dec_as_u32(a) % lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: if (lbm_dec_as_i32(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i32(lbm_dec_as_i32(a) % lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: if (lbm_dec_as_float(b) == 0.0f || lbm_dec_as_float(b) == -0.0f) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_float(fmodf(lbm_dec_as_float(a), lbm_dec_as_float(b))); break;
case LBM_TYPE_U64: if (lbm_dec_as_u64(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_u64(lbm_dec_as_u64(a) % lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: if (lbm_dec_as_i64(b) == 0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_i64(lbm_dec_as_i64(a) % lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: if (lbm_dec_as_double(b) == (double)0.0 || lbm_dec_as_double(b) == (double)-0.0) {return lbm_enc_sym(SYM_DIVZERO);} retval = lbm_enc_double(fmod(lbm_dec_as_double(a), lbm_dec_as_double(b))); break;
}
return retval;
}
@ -210,34 +235,17 @@ static lbm_uint mod2(lbm_uint a, lbm_uint b) {
static lbm_uint negate(lbm_uint a) {
lbm_uint retval = lbm_enc_sym(SYM_TERROR);
lbm_int i0;
lbm_uint u0;
lbm_float f0;
if (lbm_type_of(a) > LBM_VAL_TYPE_CHAR) {
if (lbm_type_of(a) > LBM_TYPE_CHAR) {
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_I:
i0 = lbm_dec_i(a);
retval = lbm_enc_i(-i0);
break;
case LBM_VAL_TYPE_U:
u0 = lbm_dec_u(a);
retval = lbm_enc_u(-u0);
break;
case LBM_PTR_TYPE_BOXED_U:
u0 = lbm_dec_U(a);
retval = lbm_enc_U(-u0); //cons(-u0, enc_sym(SYM_BOXED_U_TYPE));
break;
case LBM_PTR_TYPE_BOXED_I:
i0 = lbm_dec_I(a);
retval = lbm_enc_I(-i0); //cons(-i0, enc_sym(SYM_BOXED_I_TYPE));
break;
case LBM_PTR_TYPE_BOXED_F:
f0 = lbm_dec_F(a);
f0 = -f0;
//memcpy(&retval, &f0, sizeof(FLOAT));
retval = lbm_enc_F(f0); //cons(retval, enc_sym(SYM_BOXED_F_TYPE));
break;
case LBM_TYPE_I: retval = lbm_enc_i(- lbm_dec_i(a)); break;
case LBM_TYPE_U: retval = lbm_enc_u(- lbm_dec_u(a)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(- lbm_dec_u32(a)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(- lbm_dec_i32(a)); break;
case LBM_TYPE_FLOAT: retval = lbm_enc_float(- lbm_dec_float(a)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(- lbm_dec_u64(a)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(- lbm_dec_i64(a)); break;
case LBM_TYPE_DOUBLE: retval = lbm_enc_double(- lbm_dec_double(a)); break;
}
}
return retval;
@ -253,17 +261,20 @@ static lbm_uint sub2(lbm_uint a, lbm_uint b) {
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i(a) - lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u(a) - lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = lbm_enc_U(lbm_dec_as_u(a) - lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = lbm_enc_I(lbm_dec_as_i(a) - lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: retval = lbm_enc_F(lbm_dec_as_f(a) - lbm_dec_as_f(b)); break;
case LBM_TYPE_I: retval = lbm_enc_i(lbm_dec_as_i32(a) - lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = lbm_enc_u(lbm_dec_as_u32(a) - lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = lbm_enc_u32(lbm_dec_as_u32(a) - lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = lbm_enc_i32(lbm_dec_as_i32(a) - lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: retval = lbm_enc_float(lbm_dec_as_float(a) - lbm_dec_as_float(b)); break;
case LBM_TYPE_U64: retval = lbm_enc_u64(lbm_dec_as_u64(a) - lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: retval = lbm_enc_i64(lbm_dec_as_i64(a) - lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: retval = lbm_enc_double(lbm_dec_as_double(a) - lbm_dec_as_double(b)); break;
}
return retval;
}
static bool array_equality(lbm_value a, lbm_value b) {
if (lbm_type_of(a) == LBM_PTR_TYPE_ARRAY &&
if (lbm_type_of(a) == LBM_TYPE_ARRAY &&
lbm_type_of(a) == lbm_type_of(b)) {
lbm_array_header_t *a_ = (lbm_array_header_t*)lbm_car(a);
lbm_array_header_t *b_ = (lbm_array_header_t*)lbm_car(b);
@ -271,20 +282,16 @@ static bool array_equality(lbm_value a, lbm_value b) {
if (a_->elt_type == b_->elt_type &&
a_->size == b_->size) {
switch(a_->elt_type) {
case LBM_VAL_TYPE_U:
case LBM_PTR_TYPE_BOXED_U:
if (memcmp((char*)a_->data, (char*)b_->data, a_->size * sizeof(lbm_uint)) == 0) return true;
break;
case LBM_VAL_TYPE_I:
case LBM_PTR_TYPE_BOXED_I:
case LBM_TYPE_U:
case LBM_TYPE_U32:
case LBM_TYPE_I:
case LBM_TYPE_I32:
case LBM_TYPE_FLOAT:
if (memcmp((char*)a_->data, (char*)b_->data, a_->size * sizeof(lbm_int)) == 0) return true;
break;
case LBM_VAL_TYPE_CHAR:
case LBM_TYPE_CHAR:
if (memcmp((char*)a_->data, (char*)b_->data, a_->size) == 0) return true;
break;
case LBM_PTR_TYPE_BOXED_F:
if (memcmp((char*)a_->data, (char*)b_->data, a_->size * sizeof(lbm_float)) == 0) return true;
break;
default:
break;
}
@ -295,80 +302,59 @@ static bool array_equality(lbm_value a, lbm_value b) {
static bool struct_eq(lbm_value a, lbm_value b) {
if (!lbm_is_ptr(a) && !lbm_is_ptr(b)) {
if (lbm_type_of(a) == lbm_type_of(b)){
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_SYMBOL:
return (lbm_dec_sym(a) == lbm_dec_sym(b));
case LBM_VAL_TYPE_I:
return (lbm_dec_i(a) == lbm_dec_i(b));
case LBM_VAL_TYPE_U:
return (lbm_dec_u(a) == lbm_dec_u(b));
case LBM_VAL_TYPE_CHAR:
return (lbm_dec_char(a) == lbm_dec_char(b));
default:
return false;
break;
}
} else {
return false;
}
}
bool res = false;
if (lbm_is_ptr(a) && lbm_is_ptr(b)) {
if (lbm_type_of(a) == lbm_type_of(b)) {
switch (lbm_type_of(a)) {
case LBM_PTR_TYPE_CONS:
switch(lbm_type_of(a)){
case LBM_TYPE_SYMBOL:
return (lbm_dec_sym(a) == lbm_dec_sym(b));
case LBM_TYPE_I:
return (lbm_dec_i(a) == lbm_dec_i(b));
case LBM_TYPE_U:
return (lbm_dec_u(a) == lbm_dec_u(b));
case LBM_TYPE_CHAR:
return (lbm_dec_char(a) == lbm_dec_char(b));
case LBM_TYPE_CONS:
return ( struct_eq(lbm_car(a),lbm_car(b)) &&
struct_eq(lbm_cdr(a),lbm_cdr(b)) );
case LBM_PTR_TYPE_BOXED_I:
return ((lbm_int)lbm_car(a) == (lbm_int)lbm_car(b));
case LBM_PTR_TYPE_BOXED_U:
return (lbm_car(a) == lbm_car(b));
case LBM_PTR_TYPE_BOXED_F:
return ((lbm_float)lbm_car(a) == (lbm_float)lbm_car(b));
case LBM_PTR_TYPE_ARRAY:
case LBM_TYPE_I32:
return (lbm_dec_i32(a) == lbm_dec_i32(b));
case LBM_TYPE_U32:
return (lbm_dec_u32(a) == lbm_dec_u32(b));
case LBM_TYPE_FLOAT:
return (lbm_dec_float(a) == lbm_dec_float(b));
case LBM_TYPE_I64:
return (lbm_dec_i64(a) == lbm_dec_i64(b));
case LBM_TYPE_U64:
return (lbm_dec_u64(a) == lbm_dec_u64(b));
case LBM_TYPE_DOUBLE:
return (lbm_dec_double(a) == lbm_dec_double(b));
case LBM_TYPE_ARRAY:
return array_equality(a, b);
default:
return false;
}
}
}
return false;
}
static int cmpi(lbm_int a, lbm_int b) {
int res = (a > b) - (a < b);
return res;
}
static int cmpu(lbm_uint a, lbm_uint b) {
int res = (a > b) - (a < b);
return res;
}
static int cmpf(lbm_float a, lbm_float b) {
int res = (a > b) - (a < b);
return res;
}
/* returns -1 if a < b; 0 if a = b; 1 if a > b */
static int compare(lbm_uint a, lbm_uint b) {
int retval = 0;
if (!(lbm_is_number(a) && lbm_is_number(b))) {
return retval;
return retval; // result is nonsense if arguments are not numbers.
}
lbm_uint t = (lbm_type_of(a) < lbm_type_of(b)) ? lbm_type_of(b) : lbm_type_of(a);
switch (t) {
case LBM_VAL_TYPE_I: retval = cmpi(lbm_dec_as_i(a), lbm_dec_as_i(b)); break;
case LBM_VAL_TYPE_U: retval = cmpu(lbm_dec_as_u(a), lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_U: retval = cmpu(lbm_dec_as_u(a), lbm_dec_as_u(b)); break;
case LBM_PTR_TYPE_BOXED_I: retval = cmpi(lbm_dec_as_i(a), lbm_dec_as_i(b)); break;
case LBM_PTR_TYPE_BOXED_F: retval = cmpf(lbm_dec_as_f(a), lbm_dec_as_f(b)); break;
case LBM_TYPE_I: retval = CMP(lbm_dec_as_i32(a), lbm_dec_as_i32(b)); break;
case LBM_TYPE_U: retval = CMP(lbm_dec_as_u32(a), lbm_dec_as_u32(b)); break;
case LBM_TYPE_U32: retval = CMP(lbm_dec_as_u32(a), lbm_dec_as_u32(b)); break;
case LBM_TYPE_I32: retval = CMP(lbm_dec_as_i32(a), lbm_dec_as_i32(b)); break;
case LBM_TYPE_FLOAT: retval = CMP(lbm_dec_as_float(a), lbm_dec_as_float(b)); break;
case LBM_TYPE_U64: retval = CMP(lbm_dec_as_u64(a), lbm_dec_as_u64(b)); break;
case LBM_TYPE_I64: retval = CMP(lbm_dec_as_i64(a), lbm_dec_as_i64(b)); break;
case LBM_TYPE_DOUBLE: retval = CMP(lbm_dec_as_double(a), lbm_dec_as_double(b)); break;
}
return retval;
}
@ -395,8 +381,8 @@ void array_read(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
lbm_uint ix_end;
if (lbm_is_number(index) && lbm_is_number(index_end)) {
ix = lbm_dec_as_u(index);
ix_end = lbm_dec_as_u(index_end);
ix = lbm_dec_as_u32(index);
ix_end = lbm_dec_as_u32(index_end);
} else {
return;
}
@ -407,9 +393,9 @@ void array_read(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
ix_end = tmp;
}
if (lbm_type_of(arr) == LBM_PTR_TYPE_ARRAY) {
if (lbm_type_of(arr) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t*)lbm_car(arr);
uint32_t* data = array->data;
lbm_uint* data = array->data;
for (lbm_int i = (lbm_int)ix_end; i >= (lbm_int)ix; i--) {
if ((lbm_uint)i >= array->size){
@ -418,30 +404,57 @@ void array_read(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
}
switch(array->elt_type) {
case LBM_VAL_TYPE_CHAR:
curr = lbm_enc_char((lbm_uint) ((char*)data)[i]);
case LBM_TYPE_CHAR:
curr = lbm_enc_char((char)data[i]);
break;
case LBM_VAL_TYPE_U:
curr = lbm_enc_u(((lbm_uint*)data)[i]);
case LBM_TYPE_U:
curr = lbm_enc_u((uint32_t)data[i]);
break;
case LBM_VAL_TYPE_I:
curr = lbm_enc_i(((lbm_int*)data)[i]);
case LBM_TYPE_I:
curr = lbm_enc_i((int32_t)data[i]);
break;
case LBM_PTR_TYPE_BOXED_U:
curr = lbm_cons(((lbm_uint*)data)[i], lbm_enc_sym(SYM_BOXED_U_TYPE));
if (lbm_type_of(curr) == LBM_VAL_TYPE_SYMBOL) return;
curr = lbm_set_ptr_type(curr, LBM_PTR_TYPE_BOXED_U);
case LBM_TYPE_U32:
curr = lbm_enc_u32((uint32_t)data[i]);
break;
case LBM_PTR_TYPE_BOXED_I:
curr = lbm_cons(((lbm_uint*)data)[i], lbm_enc_sym(SYM_BOXED_I_TYPE));
if (lbm_type_of(curr) == LBM_VAL_TYPE_SYMBOL) return;
curr = lbm_set_ptr_type(curr, LBM_PTR_TYPE_BOXED_I);
case LBM_TYPE_I32:
curr = lbm_enc_i32((int32_t)data[i]);
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(curr) == LBM_VAL_TYPE_SYMBOL) return;
curr = lbm_set_ptr_type(curr, LBM_PTR_TYPE_BOXED_F);
case LBM_TYPE_FLOAT: {
float v;
memcpy(&v, &data[i], sizeof(float));
curr = lbm_enc_float(v);
} break;
#ifndef LBM64
case LBM_TYPE_U64: {
uint64_t v = 0;
v |= (uint64_t)data[i*2];
v |= ((uint64_t)data[i*2+1]) << 32;
curr = lbm_enc_u64(v);
} break;
case LBM_TYPE_I64: {
uint64_t v = 0;
v |= (uint64_t)data[i*2];
v |= ((uint64_t)data[i*2+1]) << 32;
curr = lbm_enc_i64((int64_t)v);
} break;
case LBM_TYPE_DOUBLE: {
double v;
memcpy(&v, &data[i*2], sizeof(double));
curr = lbm_enc_double(v);
} break;
#else
case LBM_TYPE_U64:
curr = lbm_enc_u64(data[i]);
break;
case LBM_TYPE_I64:
curr = lbm_enc_i64((int64_t)data[i]);
break;
case LBM_TYPE_DOUBLE: {
double v;
memcpy(&v, &data[i], sizeof(double));
curr = lbm_enc_double(v);
} break;
#endif
default:
curr = lbm_enc_sym(SYM_EERROR);
break;
@ -468,54 +481,88 @@ void array_write(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
*result = lbm_enc_sym(SYM_EERROR);
if (lbm_is_number(index)) {
ix = lbm_dec_as_u(index);
ix = lbm_dec_as_u32(index);
} else {
return;
}
if (lbm_type_of(arr) == LBM_PTR_TYPE_ARRAY) {
if (lbm_type_of(arr) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t*)lbm_car(arr);
if (lbm_type_of(val) != array->elt_type ||
ix >= array->size) {
if (ix >= array->size) {
*result = lbm_enc_sym(SYM_NIL);
return;
}
switch(array->elt_type) {
case LBM_VAL_TYPE_CHAR: {
case LBM_TYPE_CHAR: {
char * data = (char *)array->data;
data[ix] = lbm_dec_char(val);
data[ix] = lbm_dec_as_char(val);
break;
}
case LBM_VAL_TYPE_U: {
lbm_uint* data = (lbm_uint*)array->data;
data[ix] = lbm_dec_u(val);
break;
}
case LBM_VAL_TYPE_I: {
lbm_int *data = (lbm_int*)array->data;
data[ix] = lbm_dec_i(val);
break;
}
case LBM_PTR_TYPE_BOXED_U: {
case LBM_TYPE_U:
/* fall through */
case LBM_TYPE_U32: {
lbm_uint *data = (lbm_uint*)array->data;
data[ix] = lbm_dec_U(val);
data[ix] = lbm_dec_as_u32(val);
break;
}
case LBM_PTR_TYPE_BOXED_I: {
case LBM_TYPE_I:
/* fall through */
case LBM_TYPE_I32: {
lbm_int *data = (lbm_int*)array->data;
data[ix] = lbm_dec_I(val);
data[ix] = lbm_dec_as_i32(val);
break;
}
case LBM_PTR_TYPE_BOXED_F: {
//uv = car(val);
//memcpy(&v, &uv, sizeof(FLOAT));
case LBM_TYPE_FLOAT: {
lbm_uint *data = (lbm_uint*)array->data;
data[ix] = lbm_car(val);
float v = lbm_dec_as_float(val);
uint32_t t;
memcpy(&t,&v,sizeof(uint32_t));
data[ix] = t;
break;
}
#ifndef LBM64
case LBM_TYPE_U64: {
uint64_t v = lbm_dec_as_u64(val);
lbm_uint *data = (lbm_uint*)array->data;
data[ix*2] = (uint32_t)v;
data[ix*2+1] = (uint32_t)(v >> 32);
break;
}
case LBM_TYPE_I64: {
int64_t v = lbm_dec_as_i64(val);
lbm_uint *data = (lbm_uint*)array->data;
data[ix*2] = (uint32_t)v;
data[ix*2+1] = (uint32_t)(v >> 32);
break;
}
case LBM_TYPE_DOUBLE: {
double v = lbm_dec_as_double(val);
uint64_t v2;
memcpy(&v2,&v,sizeof(uint64_t));
lbm_uint *data = (lbm_uint*)array->data;
data[ix*2] = (uint32_t)v2;
data[ix*2+1] = (uint32_t)(v2 >> 32);
break;
}
#else
case LBM_TYPE_U64: {
lbm_uint *data = (lbm_uint*)array->data;
data[ix] = lbm_dec_as_u64(val);
break;
}
case LBM_TYPE_I64: {
lbm_int *data = (lbm_int*)array->data;
data[ix] = lbm_dec_as_i64(val);
break;
}
case LBM_TYPE_DOUBLE: {
lbm_float *data = (lbm_float*)array->data;
data[ix] = lbm_dec_as_double(val);
break;
}
#endif
default:
// Maybe result should be something else than arr here.
break;
@ -530,23 +577,32 @@ void array_write(lbm_value *args, lbm_uint nargs, lbm_uint *result) {
void array_create(lbm_value *args, lbm_uint nargs, lbm_value *result) {
*result = lbm_enc_sym(SYM_EERROR);
if (nargs == 1 && lbm_is_number(args[0])) {
lbm_heap_allocate_array(result, lbm_dec_as_u(args[0]), LBM_VAL_TYPE_BYTE);
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[0]), LBM_TYPE_BYTE);
} else if (nargs == 2) {
if (lbm_type_of(args[0]) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(args[0]) == LBM_TYPE_SYMBOL &&
lbm_is_number(args[1])) {
switch(lbm_dec_sym(args[0])) {
case SYM_TYPE_CHAR: /* fall through */
case SYM_TYPE_BYTE:
lbm_heap_allocate_array(result, lbm_dec_as_u(args[1]), LBM_VAL_TYPE_BYTE);
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_BYTE);
break;
case SYM_TYPE_I32:
lbm_heap_allocate_array(result, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_I);
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_I32);
break;
case SYM_TYPE_U32:
lbm_heap_allocate_array(result, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_U);
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_U32);
break;
case SYM_TYPE_FLOAT:
lbm_heap_allocate_array(result, lbm_dec_as_u(args[1]), LBM_PTR_TYPE_BOXED_F);
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_FLOAT);
break;
case SYM_TYPE_I64:
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_I64);
break;
case SYM_TYPE_U64:
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_U64);
break;
case SYM_TYPE_DOUBLE:
lbm_heap_allocate_array(result, lbm_dec_as_u32(args[1]), LBM_TYPE_DOUBLE);
break;
default:
break;
@ -558,12 +614,12 @@ void array_create(lbm_value *args, lbm_uint nargs, lbm_value *result) {
lbm_value index_list(lbm_value l, unsigned int n) {
lbm_value curr = l;
while ( lbm_type_of(curr) == LBM_PTR_TYPE_CONS &&
while ( lbm_type_of(curr) == LBM_TYPE_CONS &&
n > 0) {
curr = lbm_cdr(curr);
n --;
}
if (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(curr) == LBM_TYPE_CONS) {
return lbm_car(curr);
} else {
return lbm_enc_sym(SYM_NIL);
@ -582,36 +638,36 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
break;
case SYM_IX:
if (nargs == 2 && lbm_is_number(args[1])) {
result = index_list(args[0], lbm_dec_as_u(args[1]));
result = index_list(args[0], lbm_dec_as_u32(args[1]));
} break;
case SYM_DECODE:
if (nargs == 1 && (lbm_is_number(args[0]) ||
lbm_is_char(args[0]))) {
switch (lbm_type_of(args[0])) {
case LBM_VAL_TYPE_CHAR:
case LBM_TYPE_CHAR:
/*fall through*/
case LBM_VAL_TYPE_I:
case LBM_TYPE_I:
/* fall through */
case LBM_VAL_TYPE_U: {
lbm_uint v = lbm_dec_as_u(args[0]);
case LBM_TYPE_U: {
lbm_uint v = lbm_dec_as_u32(args[0]);
result = lbm_cons(lbm_enc_u(v & 0xFF), lbm_enc_sym(SYM_NIL));
result = lbm_cons(lbm_enc_u(v >> 8 & 0xFF), result);
result = lbm_cons(lbm_enc_u(v >> 16 & 0xFF), result);
result = lbm_cons(lbm_enc_u(v >> 24 & 0xF), result);
} break;
case LBM_PTR_TYPE_BOXED_F: {
lbm_float tmp = lbm_dec_F(args[0]);
lbm_uint v;
memcpy(&v, &tmp, sizeof(lbm_uint));
case LBM_TYPE_FLOAT: {
float tmp = (float)lbm_dec_float(args[0]);
uint32_t v;
memcpy(&v, &tmp, sizeof(uint32_t));
result = lbm_cons(lbm_enc_u(v & 0xFF), lbm_enc_sym(SYM_NIL));
result = lbm_cons(lbm_enc_u(v >> 8 & 0xFF), result);
result = lbm_cons(lbm_enc_u(v >> 16 & 0xFF), result);
result = lbm_cons(lbm_enc_u(v >> 24 & 0xFF), result);
} break;
case LBM_PTR_TYPE_BOXED_I:
case LBM_TYPE_I32:
/* fall through */
case LBM_PTR_TYPE_BOXED_U: {
lbm_uint v = lbm_dec_as_u(args[0]);
case LBM_TYPE_U32: {
lbm_uint v = lbm_dec_as_u32(args[0]);
result = lbm_cons(lbm_enc_u(v & 0xFF), lbm_enc_sym(SYM_NIL));
result = lbm_cons(lbm_enc_u(v >> 8 & 0xFF), result);
result = lbm_cons(lbm_enc_u(v >> 16 & 0xFF), result);
@ -621,69 +677,69 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
}break;
/// Encode a list of up to 4 bytes as an i32
case SYM_ENCODE_I32:
if (nargs == 1 && lbm_type_of(args[0]) == LBM_PTR_TYPE_CONS) {
if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_CONS) {
lbm_value curr = args[0];
lbm_uint r = 0;
uint32_t r = 0;
int n = 4;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS && n > 0) {
while (lbm_type_of(curr) == LBM_TYPE_CONS && n > 0) {
if (n < 4) r = r << 8;
if (lbm_is_number(lbm_car(curr))) {
uint32_t v = lbm_dec_as_u(lbm_car(curr));
r |= v;
uint32_t v = lbm_dec_as_u32(lbm_car(curr));
r |= (0xFF & v);
n --;
curr = lbm_cdr(curr);
} else {
break;
}
}
result = lbm_enc_I((lbm_int)r);
result = lbm_enc_i32((int32_t)r);
}
break;
/// Encode a list of up to 4 bytes as an U32
case SYM_ENCODE_U32:
if (nargs == 1 && lbm_type_of(args[0]) == LBM_PTR_TYPE_CONS) {
if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_CONS) {
lbm_value curr = args[0];
lbm_uint r = 0;
uint32_t r = 0;
int n = 4;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS && n > 0) {
while (lbm_type_of(curr) == LBM_TYPE_CONS && n > 0) {
if (n < 4) r = r << 8;
if (lbm_is_number(lbm_car(curr))) {
uint32_t v = lbm_dec_as_u(lbm_car(curr));
r |= v;
uint32_t v = lbm_dec_as_u32(lbm_car(curr));
r |= (0xFF & v);
n --;
curr = lbm_cdr(curr);
} else {
break;
}
}
result = lbm_enc_U(r);
result = lbm_enc_u32(r);
}
break;
/// Encode a list of up to 4 bytes as an U32
/// Encode a list of up to 4 bytes as a float
case SYM_ENCODE_FLOAT:
if (nargs == 1 && lbm_type_of(args[0]) == LBM_PTR_TYPE_CONS) {
if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_CONS) {
lbm_value curr = args[0];
lbm_uint r = 0;
lbm_float f;
uint32_t r = 0;
float f;
int n = 4;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS && n > 0) {
while (lbm_type_of(curr) == LBM_TYPE_CONS && n > 0) {
if (n < 4) r = r << 8;
if (lbm_is_number(lbm_car(curr))) {
uint32_t v = lbm_dec_as_u(lbm_car(curr));
r |= v;
uint32_t v = (uint32_t)lbm_dec_as_u32(lbm_car(curr));
r |= (0xFF & v);
n --;
curr = lbm_cdr(curr);
} else {
break;
}
}
memcpy(&f,&r, sizeof(lbm_uint));
result = lbm_enc_F(f);
memcpy(&f,&r, sizeof(float)); // float result
result = lbm_enc_float(f);
}
break;
case SYM_IS_FUNDAMENTAL:
if (nargs < 1 ||
lbm_type_of(args[0]) != LBM_VAL_TYPE_SYMBOL)
lbm_type_of(args[0]) != LBM_TYPE_SYMBOL)
result = lbm_enc_sym(SYM_NIL);
else if (lbm_is_fundamental(args[0]))
result = lbm_enc_sym(SYM_TRUE);
@ -693,7 +749,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
case SYM_SYMBOL_TO_STRING: {
if (nargs < 1 ||
lbm_type_of(args[0]) != LBM_VAL_TYPE_SYMBOL)
lbm_type_of(args[0]) != LBM_TYPE_SYMBOL)
return lbm_enc_sym(SYM_NIL);
lbm_value sym = args[0];
const char *sym_str = lbm_get_name_by_symbol(lbm_dec_sym(sym));
@ -701,7 +757,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
size_t len = strlen(sym_str);
lbm_value v;
if (lbm_heap_allocate_array(&v, len+1, LBM_VAL_TYPE_CHAR)) {
if (lbm_heap_allocate_array(&v, len+1, LBM_TYPE_CHAR)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(v);
if (!arr) return lbm_enc_sym(SYM_MERROR);
memset(arr->data,0,len+1);
@ -715,10 +771,10 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
case SYM_STRING_TO_SYMBOL: {
result = lbm_enc_sym(SYM_EERROR);
if (nargs < 1 ||
lbm_type_of(args[0] != LBM_PTR_TYPE_ARRAY))
lbm_type_of(args[0] != LBM_TYPE_ARRAY))
break;
lbm_array_header_t *arr = (lbm_array_header_t *)lbm_car(args[0]);
if (arr->elt_type != LBM_VAL_TYPE_CHAR)
if (arr->elt_type != LBM_TYPE_CHAR)
break;
char *str = (char *)arr->data;
lbm_uint sym;
@ -731,7 +787,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
}
case SYM_SYMBOL_TO_UINT: {
lbm_value s = args[0];
if (lbm_type_of(s) == LBM_VAL_TYPE_SYMBOL)
if (lbm_type_of(s) == LBM_TYPE_SYMBOL)
result = lbm_enc_u(lbm_dec_sym(s));
else
result = lbm_enc_sym(SYM_EERROR);
@ -739,7 +795,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
}
case SYM_UINT_TO_SYMBOL: {
lbm_value s = args[0];
if (lbm_type_of(s) == LBM_VAL_TYPE_U)
if (lbm_type_of(s) == LBM_TYPE_U)
result = lbm_enc_sym(lbm_dec_u(s));
else
result = lbm_enc_sym(SYM_EERROR);
@ -781,7 +837,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
result = lbm_enc_sym(SYM_NIL);
for (lbm_uint i = 1; i <= nargs; i ++) {
result = lbm_cons(args[nargs-i], result);
if (lbm_type_of(result) == LBM_VAL_TYPE_SYMBOL)
if (lbm_type_of(result) == LBM_TYPE_SYMBOL)
break;
}
break;
@ -795,14 +851,14 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
result = b;
lbm_value curr = a;
int n = 0;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
n++;
curr = lbm_cdr(curr);
}
for (int i = n-1; i >= 0; i --) {
result = lbm_cons(index_list(a,(unsigned int)i), result);
if (lbm_type_of(result) == LBM_VAL_TYPE_SYMBOL)
if (lbm_type_of(result) == LBM_TYPE_SYMBOL)
break;
}
break;
@ -811,7 +867,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
lbm_uint sum = lbm_enc_u(0);
for (lbm_uint i = 0; i < nargs; i ++) {
sum = add2(sum, args[i]);
if (lbm_type_of(sum) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(sum) == LBM_TYPE_SYMBOL) {
break;
}
}
@ -826,7 +882,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
} else {
for (lbm_uint i = 1; i < nargs; i ++) {
res = sub2(res, args[i]);
if (lbm_type_of(res) == LBM_VAL_TYPE_SYMBOL)
if (lbm_type_of(res) == LBM_TYPE_SYMBOL)
break;
}
}
@ -837,7 +893,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
lbm_uint prod = lbm_enc_u(1);
for (lbm_uint i = 0; i < nargs; i ++) {
prod = mul2(prod, args[i]);
if (lbm_type_of(prod) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(prod) == LBM_TYPE_SYMBOL) {
break;
}
}
@ -849,7 +905,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
lbm_uint res = args[0];
for (lbm_uint i = 1; i < nargs; i ++) {
res = div2(res, args[i]);
if (lbm_type_of(res) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(res) == LBM_TYPE_SYMBOL) {
break;
}
}
@ -863,7 +919,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
lbm_uint res = args[0];
for (lbm_uint i = 1; i < nargs; i ++) {
res = mod2(res, args[i]);
if (lbm_type_of(res) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(res) == LBM_TYPE_SYMBOL) {
break;
}
}
@ -985,7 +1041,7 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
break;
}
lbm_uint a = args[0];
if (lbm_type_of(a) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(a) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(a) == SYM_NIL) {
result = lbm_enc_sym(SYM_TRUE);
break;
@ -1006,26 +1062,19 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) {
if (nargs != 1) return lbm_enc_sym(SYM_NIL);
lbm_value val = args[0];
switch(lbm_type_of(val)) {
case LBM_PTR_TYPE_CONS:
return lbm_enc_sym(SYM_TYPE_LIST);
case LBM_PTR_TYPE_ARRAY:
return lbm_enc_sym(SYM_TYPE_ARRAY);
case LBM_PTR_TYPE_BOXED_I:
return lbm_enc_sym(SYM_TYPE_I32);
case LBM_PTR_TYPE_BOXED_U:
return lbm_enc_sym(SYM_TYPE_U32);
case LBM_PTR_TYPE_BOXED_F:
return lbm_enc_sym(SYM_TYPE_FLOAT);
case LBM_VAL_TYPE_I:
return lbm_enc_sym(SYM_TYPE_I28);
case LBM_VAL_TYPE_U:
return lbm_enc_sym(SYM_TYPE_U28);
case LBM_VAL_TYPE_CHAR:
return lbm_enc_sym(SYM_TYPE_CHAR);
case LBM_VAL_TYPE_SYMBOL:
return lbm_enc_sym(SYM_TYPE_SYMBOL);
default:
return lbm_enc_sym(SYM_TERROR);
case LBM_TYPE_CONS: return lbm_enc_sym(SYM_TYPE_LIST);
case LBM_TYPE_ARRAY: return lbm_enc_sym(SYM_TYPE_ARRAY);
case LBM_TYPE_I32: return lbm_enc_sym(SYM_TYPE_I32);
case LBM_TYPE_U32: return lbm_enc_sym(SYM_TYPE_U32);
case LBM_TYPE_FLOAT: return lbm_enc_sym(SYM_TYPE_FLOAT);
case LBM_TYPE_I64: return lbm_enc_sym(SYM_TYPE_I64);
case LBM_TYPE_U64: return lbm_enc_sym(SYM_TYPE_U64);
case LBM_TYPE_DOUBLE: return lbm_enc_sym(SYM_TYPE_DOUBLE);
case LBM_TYPE_I: return lbm_enc_sym(SYM_TYPE_I);
case LBM_TYPE_U: return lbm_enc_sym(SYM_TYPE_U);
case LBM_TYPE_CHAR: return lbm_enc_sym(SYM_TYPE_CHAR);
case LBM_TYPE_SYMBOL: return lbm_enc_sym(SYM_TYPE_SYMBOL);
default: return lbm_enc_sym(SYM_TERROR);
}
break;
case SYM_SHL:

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

@ -37,10 +37,10 @@ static lbm_value RECOVERED;
char *lbm_dec_str(lbm_value val) {
char *res = 0;
if (lbm_type_of(val) == LBM_PTR_TYPE_ARRAY) {
if (lbm_type_of(val) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val);
if (array->elt_type == LBM_VAL_TYPE_CHAR) {
if (array->elt_type == LBM_TYPE_CHAR) {
res = (char *)array->data;
}
}
@ -50,93 +50,167 @@ char *lbm_dec_str(lbm_value val) {
lbm_stream_t *lbm_dec_stream(lbm_value val) {
lbm_stream_t *res = 0;
if (lbm_type_of(val) == LBM_PTR_TYPE_STREAM) {
if (lbm_type_of(val) == LBM_TYPE_STREAM) {
res = (lbm_stream_t *)lbm_car(val);
}
return res;
}
lbm_uint lbm_dec_as_u(lbm_value a) {
lbm_uint tmp;
lbm_float f_tmp;
char lbm_dec_as_char(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_CHAR:
return (lbm_uint) lbm_dec_char(a);
case LBM_VAL_TYPE_I:
return (lbm_uint) lbm_dec_i(a);
case LBM_VAL_TYPE_U:
case LBM_TYPE_CHAR:
return (char) lbm_dec_char(a);
case LBM_TYPE_I:
return (char) lbm_dec_i(a);
case LBM_TYPE_U:
return (char) lbm_dec_u(a);
case LBM_TYPE_I32:
return (char) lbm_dec_i32(a);
case LBM_TYPE_U32:
return (char) lbm_dec_u32(a);
case LBM_TYPE_FLOAT:
return (char)lbm_dec_float(a);
}
return 0;
}
uint32_t lbm_dec_as_u32(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_TYPE_CHAR:
return (uint32_t) lbm_dec_char(a);
case LBM_TYPE_I:
return (uint32_t) lbm_dec_i(a);
case LBM_TYPE_U:
return (uint32_t) lbm_dec_u(a);
case LBM_TYPE_I32: /* fall through */
case LBM_TYPE_U32:
return (uint32_t) lbm_dec_u32(a);
case LBM_TYPE_FLOAT:
return (uint32_t)lbm_dec_float(a);
}
return 0;
}
uint64_t lbm_dec_as_u64(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_TYPE_CHAR:
return (uint64_t) lbm_dec_char(a);
case LBM_TYPE_I:
return (uint64_t) lbm_dec_i(a);
case LBM_TYPE_U:
return lbm_dec_u(a);
case LBM_PTR_TYPE_BOXED_I: /* fall through */
case LBM_PTR_TYPE_BOXED_U:
return (lbm_uint)lbm_car(a);
case LBM_PTR_TYPE_BOXED_F:
tmp = lbm_car(a);
memcpy(&f_tmp, &tmp, sizeof(lbm_float));
return (lbm_uint)f_tmp;
case LBM_TYPE_I32: /* fall through */
case LBM_TYPE_U32:
return (uint64_t) lbm_dec_u32(a);
case LBM_TYPE_FLOAT:
return (uint64_t)lbm_dec_float(a);
case LBM_TYPE_I64:
case LBM_TYPE_U64:
return (uint64_t) lbm_dec_u64(a);
case LBM_TYPE_DOUBLE:
return (uint64_t) lbm_dec_double(a);
}
return 0;
}
lbm_int lbm_dec_as_i(lbm_value a) {
lbm_uint tmp;
lbm_float f_tmp;
int32_t lbm_dec_as_i32(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_CHAR:
return (lbm_int) lbm_dec_char(a);
case LBM_VAL_TYPE_I:
case LBM_TYPE_CHAR:
return (int32_t) lbm_dec_char(a);
case LBM_TYPE_I:
return (int32_t) lbm_dec_i(a);
case LBM_TYPE_U:
return (int32_t) lbm_dec_u(a);
case LBM_TYPE_I32:
case LBM_TYPE_U32:
return (int32_t) lbm_dec_i32(a);
case LBM_TYPE_FLOAT:
return (int32_t) lbm_dec_float(a);
}
return 0;
}
int64_t lbm_dec_as_i64(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_TYPE_CHAR:
return (int64_t) lbm_dec_char(a);
case LBM_TYPE_I:
return lbm_dec_i(a);
case LBM_VAL_TYPE_U:
return (lbm_int) lbm_dec_u(a);
case LBM_PTR_TYPE_BOXED_I:
case LBM_PTR_TYPE_BOXED_U:
return (lbm_int)lbm_car(a);
case LBM_PTR_TYPE_BOXED_F:
tmp = lbm_car(a);
memcpy(&f_tmp, &tmp, sizeof(lbm_float));
return (lbm_int)f_tmp;
case LBM_TYPE_U:
return (int64_t) lbm_dec_u(a);
case LBM_TYPE_I32:
case LBM_TYPE_U32:
return (int64_t) lbm_dec_i32(a);
case LBM_TYPE_FLOAT:
return (int64_t) lbm_dec_float(a);
case LBM_TYPE_I64:
case LBM_TYPE_U64:
return (int64_t) lbm_dec_i64(a);
case LBM_TYPE_DOUBLE:
return (int64_t) lbm_dec_double(a);
}
return 0;
}
lbm_float lbm_dec_as_f(lbm_value a) {
lbm_uint tmp;
lbm_float f_tmp;
float lbm_dec_as_float(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_VAL_TYPE_CHAR:
return (lbm_float) lbm_dec_char(a);
case LBM_VAL_TYPE_I:
return (lbm_float) lbm_dec_i(a);
case LBM_VAL_TYPE_U:
return (lbm_float)lbm_dec_u(a);
case LBM_PTR_TYPE_BOXED_I:
case LBM_PTR_TYPE_BOXED_U:
return (lbm_float)lbm_car(a);
case LBM_PTR_TYPE_BOXED_F:
tmp = lbm_car(a);
memcpy(&f_tmp, &tmp, sizeof(lbm_float));
return f_tmp;
case LBM_TYPE_CHAR:
return (float) lbm_dec_char(a);
case LBM_TYPE_I:
return (float) lbm_dec_i(a);
case LBM_TYPE_U:
return (float) lbm_dec_u(a);
case LBM_TYPE_I32:
return (float) lbm_dec_i32(a);
case LBM_TYPE_U32:
return (float) lbm_dec_u32(a);
case LBM_TYPE_FLOAT:
return (float) lbm_dec_float(a);
}
return 0;
}
double lbm_dec_as_double(lbm_value a) {
switch (lbm_type_of(a)) {
case LBM_TYPE_CHAR:
return (double) lbm_dec_char(a);
case LBM_TYPE_I:
return (double) lbm_dec_i(a);
case LBM_TYPE_U:
return (double) lbm_dec_u(a);
case LBM_TYPE_I32:
return (double) lbm_dec_i32(a);
case LBM_TYPE_U32:
return (double) lbm_dec_u32(a);
case LBM_TYPE_FLOAT:
return (double) lbm_dec_float(a);
case LBM_TYPE_I64:
return (double) lbm_dec_i64(a);
case LBM_TYPE_U64:
return (double) lbm_dec_u64(a);
case LBM_TYPE_DOUBLE:
return (double) lbm_dec_double(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 */
case LBM_TYPE_CHAR: /* fall through */
case LBM_TYPE_I: /* fall through */
case LBM_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 */
case LBM_TYPE_I32: /* fall through */
case LBM_TYPE_U32: /* fall through */
case LBM_TYPE_FLOAT: /* fall through */
res = lbm_car(v);
break;
default:
@ -223,15 +297,14 @@ static int generate_freelist(size_t num_cells) {
return 1;
}
static void heap_init_state(lbm_cons_t *addr, unsigned int num_cells,
uint32_t *gc_stack_storage, unsigned int gc_stack_size) {
static void heap_init_state(lbm_cons_t *addr, lbm_uint num_cells,
lbm_uint *gc_stack_storage, lbm_uint gc_stack_size) {
heap_state.heap = addr;
heap_state.heap_bytes = (unsigned int)(num_cells * sizeof(lbm_cons_t));
heap_state.heap_size = num_cells;
lbm_stack_create(&heap_state.gc_stack, gc_stack_storage, gc_stack_size);
heap_state.num_alloc = 0;
heap_state.num_alloc_arrays = 0;
heap_state.gc_num = 0;
@ -239,13 +312,14 @@ static void heap_init_state(lbm_cons_t *addr, unsigned int num_cells,
heap_state.gc_recovered = 0;
heap_state.gc_recovered_arrays = 0;
heap_state.gc_least_free = num_cells;
heap_state.gc_last_free = num_cells;
heap_state.gc_time_acc = 0;
heap_state.gc_max_duration = 0;
heap_state.gc_min_duration = UINT32_MAX;
}
void lbm_heap_new_gc_time(uint32_t dur) {
void lbm_heap_new_gc_time(lbm_uint dur) {
heap_state.gc_time_acc += dur;
if (dur > heap_state.gc_max_duration)
heap_state.gc_max_duration = dur;
@ -253,13 +327,15 @@ void lbm_heap_new_gc_time(uint32_t dur) {
heap_state.gc_min_duration = dur;
}
void lbm_heap_new_freelist_length(uint32_t l) {
void lbm_heap_new_freelist_length(void) {
lbm_uint l = heap_state.heap_size - heap_state.num_alloc;
heap_state.gc_last_free = l;
if (l < heap_state.gc_least_free)
heap_state.gc_least_free = l;
}
int lbm_heap_init(lbm_cons_t *addr, uint32_t num_cells,
uint32_t *gc_stack_storage, uint32_t gc_stack_size) {
int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells,
lbm_uint *gc_stack_storage, lbm_uint gc_stack_size) {
NIL = lbm_enc_sym(SYM_NIL);
RECOVERED = lbm_enc_sym(SYM_RECOVERED);
@ -274,31 +350,17 @@ int lbm_heap_init(lbm_cons_t *addr, uint32_t num_cells,
return generate_freelist(num_cells);
}
unsigned int lbm_heap_num_free(void) {
unsigned int count = 0;
lbm_value curr = heap_state.freelist;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
curr = read_cdr(ref_cell(curr));
count++;
}
// Prudence.
if (!(lbm_type_of(curr) == LBM_VAL_TYPE_SYMBOL) &&
curr == NIL){
return 0;
}
return count;
lbm_uint lbm_heap_num_free(void) {
return heap_state.heap_size - heap_state.num_alloc;
}
lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
lbm_value res;
if (!lbm_is_ptr(heap_state.freelist)) {
// Free list not a ptr (should be Symbol NIL)
if ((lbm_type_of(heap_state.freelist) == LBM_VAL_TYPE_SYMBOL) &&
if ((lbm_type_of(heap_state.freelist) == LBM_TYPE_SYMBOL) &&
(lbm_dec_sym(heap_state.freelist) == SYM_NIL)) {
// all is as it should be (but no free cells)
return lbm_enc_sym(SYM_MERROR);
@ -311,7 +373,7 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
// it is a ptr replace freelist with cdr of freelist;
res = heap_state.freelist;
if (lbm_type_of(res) != LBM_PTR_TYPE_CONS) {
if (lbm_type_of(res) != LBM_TYPE_CONS) {
return lbm_enc_sym(SYM_FATAL_ERROR);
}
@ -330,32 +392,19 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
return res;
}
unsigned int lbm_heap_num_allocated(void) {
lbm_uint lbm_heap_num_allocated(void) {
return heap_state.num_alloc;
}
unsigned int lbm_heap_size(void) {
lbm_uint lbm_heap_size(void) {
return heap_state.heap_size;
}
unsigned int lbm_heap_size_bytes(void) {
lbm_uint lbm_heap_size_bytes(void) {
return heap_state.heap_bytes;
}
void lbm_get_heap_state(lbm_heap_state_t *res) {
res->heap = heap_state.heap;
res->freelist = heap_state.freelist;
res->heap_size = heap_state.heap_size;
res->heap_bytes = heap_state.heap_bytes;
res->num_alloc = heap_state.num_alloc;
res->num_alloc_arrays = heap_state.num_alloc_arrays;
res->gc_num = heap_state.gc_num;
res->gc_marked = heap_state.gc_marked;
res->gc_recovered = heap_state.gc_recovered;
res->gc_recovered_arrays = heap_state.gc_recovered_arrays;
res->gc_least_free = heap_state.gc_least_free;
res->gc_time_acc = heap_state.gc_time_acc;
res->gc_max_duration = heap_state.gc_max_duration;
res->gc_min_duration = heap_state.gc_min_duration;
*res = heap_state;
}
int lbm_gc_mark_phase(lbm_value env) {
@ -367,10 +416,10 @@ int lbm_gc_mark_phase(lbm_value env) {
}
lbm_push_u32(s, env);
int res = 1;
while (!lbm_stack_is_empty(s)) {
lbm_value curr;
int res = 1;
lbm_pop_u32(s, &curr);
if (!lbm_is_ptr(curr)) {
@ -389,20 +438,16 @@ int lbm_gc_mark_phase(lbm_value env) {
lbm_value t_ptr = lbm_type_of(curr);
if (t_ptr == LBM_PTR_TYPE_BOXED_I ||
t_ptr == LBM_PTR_TYPE_BOXED_U ||
t_ptr == LBM_PTR_TYPE_BOXED_F ||
t_ptr == LBM_PTR_TYPE_ARRAY ||
t_ptr == LBM_PTR_TYPE_STREAM) {
continue;
}
if (t_ptr >= LBM_NON_CONS_POINTER_TYPE_FIRST &&
t_ptr <= LBM_NON_CONS_POINTER_TYPE_LAST) continue;
res &= lbm_push_u32(s, lbm_cdr(curr));
res &= lbm_push_u32(s, lbm_car(curr));
if (!res) return 0;
if (!res) break;
}
return 1;
return res;
}
// The free list should be a "proper list"
@ -414,7 +459,7 @@ int lbm_gc_mark_freelist() {
lbm_value fl = heap_state.freelist;
if (!lbm_is_ptr(fl)) {
if (lbm_type_of(fl) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(fl) == LBM_TYPE_SYMBOL &&
fl == NIL){
return 1; // Nothing to mark here
} else {
@ -434,28 +479,21 @@ int lbm_gc_mark_freelist() {
return 1;
}
int lbm_gc_mark_aux(lbm_uint *aux_data, unsigned int aux_size) {
int lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
for (unsigned int i = 0; i < aux_size; i ++) {
for (lbm_uint i = 0; i < aux_size; i ++) {
if (lbm_is_ptr(aux_data[i])) {
lbm_type pt_t = lbm_type_of(aux_data[i]);
lbm_uint pt_v = lbm_dec_ptr(aux_data[i]);
if ( (pt_t == LBM_PTR_TYPE_CONS ||
pt_t == LBM_PTR_TYPE_BOXED_I ||
pt_t == LBM_PTR_TYPE_BOXED_U ||
pt_t == LBM_PTR_TYPE_BOXED_F ||
pt_t == LBM_PTR_TYPE_ARRAY ||
pt_t == LBM_PTR_TYPE_REF ||
pt_t == LBM_PTR_TYPE_STREAM) &&
if( pt_t >= LBM_POINTER_TYPE_FIRST &&
pt_t <= LBM_POINTER_TYPE_LAST &&
pt_v < heap_state.heap_size) {
lbm_gc_mark_phase(aux_data[i]);
}
}
}
return 1;
}
@ -471,21 +509,27 @@ int lbm_gc_sweep_phase(void) {
// Check if this cell is a pointer to an array
// and free it.
if (lbm_type_of(heap[i].cdr) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(heap[i].cdr) == LBM_TYPE_SYMBOL) {
switch(lbm_dec_sym(heap[i].cdr)) {
case SYM_IND_I_TYPE: /* fall through */
case SYM_IND_U_TYPE:
case SYM_IND_F_TYPE:
lbm_memory_free((lbm_uint*)heap[i].car);
break;
case SYM_ARRAY_TYPE:{
lbm_array_header_t *arr = (lbm_array_header_t*)heap[i].car;
if (lbm_memory_ptr_inside((uint32_t*)arr->data)) {
lbm_memory_free((uint32_t *)arr->data);
if (lbm_memory_ptr_inside((lbm_uint*)arr->data)) {
lbm_memory_free((lbm_uint *)arr->data);
heap_state.gc_recovered_arrays++;
}
lbm_memory_free((uint32_t *)arr);
lbm_memory_free((lbm_uint *)arr);
} break;
case SYM_STREAM_TYPE:{
lbm_stream_t *stream = (lbm_stream_t*)heap[i].car;
if (lbm_memory_ptr_inside((uint32_t*)stream)) {
lbm_memory_free((uint32_t*)stream);
if (lbm_memory_ptr_inside((lbm_uint*)stream)) {
lbm_memory_free((lbm_uint*)stream);
}
} break;
default:
@ -500,7 +544,6 @@ int lbm_gc_sweep_phase(void) {
heap[i].car = RECOVERED;
heap[i].cdr = heap_state.freelist;
heap_state.freelist = addr;
heap_state.num_alloc --;
heap_state.gc_recovered ++;
}
@ -517,7 +560,7 @@ void lbm_gc_state_inc(void) {
// construct, alter and break apart
lbm_value lbm_cons(lbm_value car, lbm_value cdr) {
lbm_value addr = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
lbm_value addr = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if ( lbm_is_ptr(addr)) {
set_car_(ref_cell(addr), car);
set_cdr_(ref_cell(addr), cdr);
@ -529,7 +572,7 @@ lbm_value lbm_cons(lbm_value car, lbm_value cdr) {
lbm_value lbm_car(lbm_value c){
if (lbm_type_of(c) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(c) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(c) == SYM_NIL) {
return lbm_enc_sym(SYM_NIL); // if nil, return nil.
}
@ -543,7 +586,7 @@ lbm_value lbm_car(lbm_value c){
lbm_value lbm_cdr(lbm_value c){
if (lbm_type_of(c) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(c) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(c) == SYM_NIL) {
return lbm_enc_sym(SYM_NIL); // if nil, return nil.
}
@ -557,7 +600,7 @@ lbm_value lbm_cdr(lbm_value c){
int lbm_set_car(lbm_value c, lbm_value v) {
int r = 0;
if (lbm_type_of(c) == LBM_PTR_TYPE_CONS) {
if (lbm_type_of(c) == LBM_TYPE_CONS) {
lbm_cons_t *cell = ref_cell(c);
set_car_(cell,v);
r = 1;
@ -567,7 +610,7 @@ int lbm_set_car(lbm_value c, lbm_value v) {
int lbm_set_cdr(lbm_value c, lbm_value v) {
int r = 0;
if (lbm_type_of(c) == LBM_PTR_TYPE_CONS){
if (lbm_type_of(c) == LBM_TYPE_CONS){
lbm_cons_t *cell = ref_cell(c);
set_cdr_(cell,v);
r = 1;
@ -579,7 +622,7 @@ int lbm_set_cdr(lbm_value c, lbm_value v) {
unsigned int lbm_list_length(lbm_value c) {
unsigned int len = 0;
while (lbm_type_of(c) == LBM_PTR_TYPE_CONS){
while (lbm_type_of(c) == LBM_TYPE_CONS){
len ++;
c = lbm_cdr(c);
}
@ -588,17 +631,17 @@ unsigned int lbm_list_length(lbm_value c) {
/* reverse a proper list */
lbm_value lbm_list_reverse(lbm_value list) {
if (lbm_type_of(list) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(list) == LBM_TYPE_SYMBOL) {
return list;
}
lbm_value curr = list;
lbm_value new_list = NIL;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
new_list = lbm_cons(lbm_car(curr), new_list);
if (lbm_type_of(new_list) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(new_list) == LBM_TYPE_SYMBOL) {
return lbm_enc_sym(SYM_MERROR);
}
curr = lbm_cdr(curr);
@ -607,13 +650,13 @@ lbm_value lbm_list_reverse(lbm_value list) {
}
lbm_value lbm_list_destructive_reverse(lbm_value list) {
if (lbm_type_of(list) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(list) == LBM_TYPE_SYMBOL) {
return list;
}
lbm_value curr = list;
lbm_value last_cell = lbm_enc_sym(SYM_NIL);
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value next = lbm_cdr(curr);
lbm_set_cdr(curr, last_cell);
last_cell = curr;
@ -629,9 +672,9 @@ lbm_value lbm_list_copy(lbm_value list) {
lbm_value curr = list;
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
lbm_value c = lbm_cons (lbm_car(curr), res);
if (lbm_type_of(c) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(c) == LBM_TYPE_SYMBOL) {
return lbm_enc_sym(SYM_MERROR);
}
res = c;
@ -645,15 +688,15 @@ lbm_value lbm_list_copy(lbm_value list) {
// Destructive update of list1.
lbm_value lbm_list_append(lbm_value list1, lbm_value list2) {
if (lbm_type_of(list1) != LBM_PTR_TYPE_CONS) {
if (lbm_type_of(list1) != LBM_TYPE_CONS) {
return list2;
}
if (lbm_type_of(list1) != LBM_PTR_TYPE_CONS) {
if (lbm_type_of(list1) != LBM_TYPE_CONS) {
return list1;
}
lbm_value curr = list1;
while(lbm_type_of(lbm_cdr(curr)) == LBM_PTR_TYPE_CONS) {
while(lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_CONS) {
curr = lbm_cdr(curr);
}
lbm_set_cdr(curr, list2);
@ -663,39 +706,55 @@ lbm_value lbm_list_append(lbm_value list1, lbm_value list2) {
// Arrays are part of the heap module because their lifespan is managed
// by the garbage collector. The data in the array is not stored
// in the "heap of cons cells".
int lbm_heap_allocate_array(lbm_value *res, unsigned int size, lbm_type type){
int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type){
lbm_array_header_t *array = NULL;
// allocating a cell that will, to start with, be a cons cell.
lbm_value cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (lbm_type_of(cell) == LBM_VAL_TYPE_SYMBOL) { // Out of heap memory
if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) { // Out of heap memory
*res = cell;
return 0;
}
unsigned int allocate_size = 0;
if (type == LBM_VAL_TYPE_CHAR) {
if ( size % 4 == 0) {
lbm_uint allocate_size = 0;
if (type == LBM_TYPE_CHAR) {
if ( size % sizeof(lbm_uint) == 0) {
#ifndef LBM64
allocate_size = size >> 2;
#else
allocate_size = size >> 3;
#endif
} else {
#ifndef LBM64
allocate_size = (size >> 2) + 1;
#else
allocate_size = (size >> 3) + 1;
#endif
}
} else {
}
#ifndef LBM64
else if (type == LBM_TYPE_I64 ||
type == LBM_TYPE_U64 ||
type == LBM_TYPE_DOUBLE) {
allocate_size = 2*size;
}
#endif
else {
allocate_size = size;
}
array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / 4);
array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / sizeof(lbm_uint));
if (array == NULL) {
*res = lbm_enc_sym(SYM_MERROR);
return 0;
}
array->data = (uint32_t*)lbm_memory_allocate(allocate_size);
array->data = (lbm_uint*)lbm_memory_allocate(allocate_size);
if (array->data == NULL) {
lbm_memory_free((uint32_t *)array);
lbm_memory_free(array->data);
*res = lbm_enc_sym(SYM_MERROR);
return 0;
}
@ -706,7 +765,7 @@ int lbm_heap_allocate_array(lbm_value *res, unsigned int size, lbm_type type){
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_PTR_TYPE_ARRAY;
cell = cell | LBM_TYPE_ARRAY;
*res = cell;

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

@ -26,7 +26,7 @@ lbm_cid eval_cps_load_and_eval(lbm_tokenizer_char_stream_t *tokenizer, bool prog
lbm_value stream = lbm_create_token_stream(tokenizer);
if (lbm_type_of(stream) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(stream) == LBM_TYPE_SYMBOL) {
// TODO: Check what should be done.
return 0;
}
@ -41,10 +41,10 @@ lbm_cid eval_cps_load_and_eval(lbm_tokenizer_char_stream_t *tokenizer, bool prog
/* LISP ZONE ENDS */
if (lbm_type_of(launcher) != LBM_PTR_TYPE_CONS ||
lbm_type_of(evaluator) != LBM_PTR_TYPE_CONS ||
lbm_type_of(start_prg) != LBM_PTR_TYPE_CONS ) {
lbm_memory_free((uint32_t*)stream);
if (lbm_type_of(launcher) != LBM_TYPE_CONS ||
lbm_type_of(evaluator) != LBM_TYPE_CONS ||
lbm_type_of(start_prg) != LBM_TYPE_CONS ) {
lbm_memory_free((lbm_uint*)stream);
return 0;
}
return lbm_create_ctx(start_prg, lbm_enc_sym(SYM_NIL), 256);
@ -54,7 +54,7 @@ lbm_cid eval_cps_load_and_define(lbm_tokenizer_char_stream_t *tokenizer, char *s
lbm_value stream = lbm_create_token_stream(tokenizer);
if (lbm_type_of(stream) == LBM_VAL_TYPE_SYMBOL) {
if (lbm_type_of(stream) == LBM_TYPE_SYMBOL) {
return 0;
}
@ -62,7 +62,7 @@ lbm_cid eval_cps_load_and_define(lbm_tokenizer_char_stream_t *tokenizer, char *s
if (!lbm_get_symbol_by_name(symbol, &sym_id)) {
if (!lbm_add_symbol(symbol, &sym_id)) {
lbm_memory_free((uint32_t*)stream);
lbm_memory_free((lbm_uint*)stream);
return 0;
}
}
@ -77,10 +77,10 @@ lbm_cid eval_cps_load_and_define(lbm_tokenizer_char_stream_t *tokenizer, char *s
definer = lbm_cons(definer, lbm_enc_sym(SYM_NIL));
/* LISP ZONE ENDS */
if (lbm_type_of(launcher) != LBM_PTR_TYPE_CONS ||
lbm_type_of(binding) != LBM_PTR_TYPE_CONS ||
lbm_type_of(definer) != LBM_PTR_TYPE_CONS ) {
lbm_memory_free((uint32_t*)stream);
if (lbm_type_of(launcher) != LBM_TYPE_CONS ||
lbm_type_of(binding) != LBM_TYPE_CONS ||
lbm_type_of(definer) != LBM_TYPE_CONS ) {
lbm_memory_free((lbm_uint*)stream);
return 0;
}
return lbm_create_ctx(definer, lbm_enc_sym(SYM_NIL), 256);
@ -97,7 +97,7 @@ lbm_cid lbm_eval_defined(char *symbol, bool program) {
lbm_value binding = lbm_env_lookup(lbm_enc_sym(sym_id), *lbm_get_env_ptr());
if (lbm_type_of(binding) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(binding) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(binding) == SYM_NOT_FOUND) {
return 0;
}
@ -111,9 +111,9 @@ lbm_cid lbm_eval_defined(char *symbol, bool program) {
/* LISP ZONE ENDS */
if (lbm_type_of(launcher) != LBM_PTR_TYPE_CONS ||
lbm_type_of(evaluator) != LBM_PTR_TYPE_CONS ||
lbm_type_of(start_prg) != LBM_PTR_TYPE_CONS ) {
if (lbm_type_of(launcher) != LBM_TYPE_CONS ||
lbm_type_of(evaluator) != LBM_TYPE_CONS ||
lbm_type_of(start_prg) != LBM_TYPE_CONS ) {
return 0;
}
return lbm_create_ctx(start_prg, lbm_enc_sym(SYM_NIL), 256);
@ -152,7 +152,7 @@ int lbm_send_message(lbm_cid cid, lbm_value msg) {
lbm_value v = lbm_find_receiver_and_send(cid, msg);
if (lbm_type_of(v) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(v) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(v) == SYM_TRUE) {
res = 1;
}
@ -195,7 +195,7 @@ int lbm_undefine(char *symbol) {
curr = lbm_cdr(prev);
while (lbm_type_of(curr) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
if (lbm_dec_sym(lbm_car(lbm_car(curr))) == sym_id) {
/* drop the curr mapping from the env */
@ -209,12 +209,12 @@ int lbm_undefine(char *symbol) {
}
int lbm_share_array(lbm_value *value, char *data, lbm_type type, uint32_t num_elt) {
int lbm_share_array(lbm_value *value, char *data, lbm_type type, lbm_uint num_elt) {
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_TYPE_CONS);
if (lbm_type_of(cell) == LBM_VAL_TYPE_SYMBOL) { // Out of heap memory
if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) { // Out of heap memory
*value = cell;
return 0;
}
@ -223,18 +223,18 @@ int lbm_share_array(lbm_value *value, char *data, lbm_type type, uint32_t num_el
if (array == NULL) return 0;
array->data = (uint32_t*)data;
array->data = (lbm_uint*)data;
array->elt_type = type;
array->size = num_elt;
lbm_set_car(cell, (lbm_uint)array);
lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE));
cell = cell | LBM_PTR_TYPE_ARRAY;
cell = cell | LBM_TYPE_ARRAY;
*value = cell;
return 1;
}
int lbm_create_array(lbm_value *value, lbm_type type, uint32_t num_elt) {
int lbm_create_array(lbm_value *value, lbm_type type, lbm_uint num_elt) {
return lbm_heap_allocate_array(value, num_elt, type);
}

113
lispBM/lispBM/src/lbm_memory.c
View File

@ -34,20 +34,24 @@
#define ALLOC_DONE 0xF00DF00D
#define ALLOC_FAILED 0xDEADBEAF
static uint32_t *bitmap = NULL;
static uint32_t *memory = NULL;
static uint32_t memory_size; // in 4 byte words
static uint32_t bitmap_size; // in 4 byte words
static unsigned int memory_base_address = 0;
static lbm_uint *bitmap = NULL;
static lbm_uint *memory = NULL;
static lbm_uint memory_size; // in 4 or 8 byte words depending on 32 or 64 bit platform
static lbm_uint bitmap_size; // in 4 or 8 byte words
static lbm_uint memory_base_address = 0;
int lbm_memory_init(uint32_t *data, uint32_t data_size,
uint32_t *bits, uint32_t bits_size) {
int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
lbm_uint *bits, lbm_uint bits_size) {
if (data == NULL || bits == NULL) return 0;
if (((unsigned int)data % 4 != 0) || data_size != 16 * bits_size || data_size % 4 != 0 ||
((unsigned int)bits % 4 != 0) || bits_size < 1 || bits_size % 4 != 0) {
// data is not 4 byte aligned
if (((lbm_uint)data % sizeof(lbm_uint) != 0) ||
(data_size * 2) != (bits_size * sizeof(lbm_uint) * 8) ||
data_size % 4 != 0 ||
((lbm_uint)bits % sizeof(lbm_uint) != 0) ||
bits_size < 1 ||
bits_size % 4 != 0) {
// data is not aligned to sizeof lbm_uint
// size is too small
// or size is not a multiple of 4
return 0;
@ -56,66 +60,84 @@ int lbm_memory_init(uint32_t *data, uint32_t data_size,
bitmap = bits;
bitmap_size = bits_size;
for (uint32_t i = 0; i < bitmap_size; i ++) {
for (lbm_uint i = 0; i < bitmap_size; i ++) {
bitmap[i] = 0;
}
memory = data;
memory_base_address = (unsigned int)data;
memory_base_address = (lbm_uint)data;
memory_size = data_size;
return 1;
}
static inline unsigned int address_to_bitmap_ix(uint32_t *ptr) {
return ((unsigned int)ptr - memory_base_address) >> 2;
static inline lbm_uint address_to_bitmap_ix(lbm_uint *ptr) {
#ifndef LBM64
return ((lbm_uint)ptr - memory_base_address) >> 2;
#else
return ((lbm_uint)ptr - memory_base_address) >> 3;
#endif
}
lbm_int lbm_memory_address_to_ix(uint32_t *ptr) {
lbm_int lbm_memory_address_to_ix(lbm_uint *ptr) {
/* TODO: assuming that that index
will have more then enough room in the
positive halv of a 28bit integer */
return (int32_t)address_to_bitmap_ix(ptr);
return (lbm_int)address_to_bitmap_ix(ptr);
}
static inline uint32_t *bitmap_ix_to_address(unsigned int ix) {
return (uint32_t*)(memory_base_address + (ix << 2));
static inline lbm_uint *bitmap_ix_to_address(lbm_uint ix) {
return &((lbm_uint*)(memory_base_address))[ix];// + (ix << 2));
}
static inline unsigned int status(unsigned int i) {
#ifndef LBM64
#define WORD_IX_SHIFT 5
#define WORD_MOD_MASK 0x1F
#define BITMAP_SIZE_SHIFT 4 // 16 statuses per bitmap word
#else
#define WORD_IX_SHIFT 6 // divide by 64
#define WORD_MOD_MASK 0x3F // mod 64
#define BITMAP_SIZE_SHIFT 5 // times 32, 32 statuses per bitmap word
#endif
unsigned int ix = i << 1; // * 2
unsigned int word_ix = ix >> 5; // / 32
unsigned int bit_ix = ix & 0x1F; // % 32
static inline lbm_uint status(lbm_uint i) {
uint32_t mask = ((uint32_t)3) << bit_ix; // 000110..0
lbm_uint ix = i << 1; // * 2
lbm_uint word_ix = ix >> WORD_IX_SHIFT; // / 32
lbm_uint bit_ix = ix & WORD_MOD_MASK; // % 32
lbm_uint mask = ((lbm_uint)3) << bit_ix; // 000110..0
if (word_ix > bitmap_size) {
return (lbm_uint)NULL;
}
return (bitmap[word_ix] & mask) >> bit_ix;
}
static inline void set_status(unsigned int i, uint32_t status) {
unsigned int ix = i << 1; // * 2
unsigned int word_ix = ix >> 5; // / 32
unsigned int bit_ix = ix & 0x1F; // % 32
static inline void set_status(lbm_uint i, lbm_uint status) {
lbm_uint ix = i << 1; // * 2
lbm_uint word_ix = ix >> WORD_IX_SHIFT; // / 32
lbm_uint bit_ix = ix & WORD_MOD_MASK; // % 32
lbm_uint clr_mask = ~(((lbm_uint)3) << bit_ix);
lbm_uint mask = status << bit_ix;
uint32_t clr_mask = ~(((uint32_t)3) << bit_ix);
uint32_t mask = status << bit_ix;
bitmap[word_ix] &= clr_mask;
bitmap[word_ix] |= mask;
}
uint32_t lbm_memory_num_words(void) {
lbm_uint lbm_memory_num_words(void) {
return memory_size;
}
uint32_t lbm_memory_num_free(void) {
lbm_uint lbm_memory_num_free(void) {
if (memory == NULL || bitmap == NULL) {
return 0;
}
unsigned int state = INIT;
uint32_t sum_length = 0;
lbm_uint sum_length = 0;
for (unsigned int i = 0; i < (bitmap_size << 4); i ++) {
for (unsigned int i = 0; i < (bitmap_size << BITMAP_SIZE_SHIFT); i ++) {
switch(status(i)) {
case FREE_OR_USED:
@ -149,18 +171,18 @@ uint32_t lbm_memory_num_free(void) {
return sum_length;
}
uint32_t *lbm_memory_allocate(uint32_t num_words) {
lbm_uint *lbm_memory_allocate(lbm_uint num_words) {
if (memory == NULL || bitmap == NULL) {
return NULL;
}
uint32_t start_ix = 0;
uint32_t end_ix = 0;
uint32_t free_length = 0;
lbm_uint start_ix = 0;
lbm_uint end_ix = 0;
lbm_uint free_length = 0;
unsigned int state = INIT;
for (unsigned int i = 0; i < (bitmap_size << 4); i ++) {
for (unsigned int i = 0; i < (bitmap_size << BITMAP_SIZE_SHIFT); i ++) {
if (state == ALLOC_DONE) break;
switch(status(i)) {
@ -211,17 +233,20 @@ uint32_t *lbm_memory_allocate(uint32_t num_words) {
set_status(start_ix, START);
set_status(end_ix, END);
}
return bitmap_ix_to_address(start_ix);
}
return NULL;
}
int lbm_memory_free(uint32_t *ptr) {
unsigned int ix = address_to_bitmap_ix(ptr);
int lbm_memory_free(lbm_uint *ptr) {
lbm_uint ix = address_to_bitmap_ix(ptr);
switch(status(ix)) {
case START:
set_status(ix, FREE_OR_USED);
for (unsigned int i = ix; i < (bitmap_size << 4); i ++) {
for (lbm_uint i = ix; i < (bitmap_size << BITMAP_SIZE_SHIFT); i ++) {
if (status(i) == END) {
set_status(i, FREE_OR_USED);
return 1;
@ -236,11 +261,11 @@ int lbm_memory_free(uint32_t *ptr) {
return 0;
}
int lbm_memory_ptr_inside(uint32_t *ptr) {
int lbm_memory_ptr_inside(lbm_uint *ptr) {
int r = 0;
if ((uint32_t)ptr >= (uint32_t)memory &&
(uint32_t)ptr < (uint32_t)memory + (memory_size * 4))
if ((lbm_uint)ptr >= (lbm_uint)memory &&
(lbm_uint)ptr < (lbm_uint)memory + (memory_size * sizeof(lbm_uint)))
r = 1;
return r;
}

10
lispBM/lispBM/src/lispbm.c
View File

@ -17,11 +17,11 @@
#include "lispbm.h"
int lbm_init(lbm_cons_t *heap_storage, uint32_t heap_size,
uint32_t *gc_stack_storage, uint32_t gc_stack_size,
uint32_t *memory, uint32_t memory_size,
uint32_t *memory_bitmap, uint32_t bitmap_size,
uint32_t *print_stack_storage, uint32_t print_stack_size,
int lbm_init(lbm_cons_t *heap_storage, lbm_uint heap_size,
lbm_uint *gc_stack_storage, lbm_uint gc_stack_size,
lbm_uint *memory, lbm_uint memory_size,
lbm_uint *memory_bitmap, lbm_uint bitmap_size,
lbm_uint *print_stack_storage, lbm_uint print_stack_size,
extension_fptr *extension_storage, int extension_storage_size ) {
if (lbm_print_init(print_stack_storage, print_stack_size) == 0)

12
lispBM/lispBM/src/qq_expand.c
View File

@ -67,14 +67,14 @@ lbm_value qq_expand_list(lbm_value l) {
lbm_value cdr_val;
switch (lbm_type_of(l)) {
case LBM_PTR_TYPE_CONS:
case LBM_TYPE_CONS:
car_val = lbm_car(l);
cdr_val = lbm_cdr(l);
if (lbm_type_of(car_val) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(car_val) == SYM_COMMA) {
res = lbm_cons(lbm_enc_sym(SYM_LIST),
lbm_cons(lbm_car(cdr_val), res));
} else if (lbm_type_of(car_val) == LBM_VAL_TYPE_SYMBOL &&
} else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(car_val) == SYM_COMMAAT) {
res = lbm_car(cdr_val);
} else {
@ -116,13 +116,13 @@ lbm_value lbm_qq_expand(lbm_value qquoted) {
lbm_value cdr_val;
switch (lbm_type_of(qquoted)) {
case LBM_PTR_TYPE_CONS:
case LBM_TYPE_CONS:
car_val = lbm_car(qquoted);
cdr_val = lbm_cdr(qquoted);
if (lbm_type_of(car_val) == LBM_VAL_TYPE_SYMBOL &&
if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(car_val) == SYM_COMMA) {
res = lbm_car(cdr_val);
} else if (lbm_type_of(car_val) == LBM_VAL_TYPE_SYMBOL &&
} else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
lbm_dec_sym(car_val) == SYM_COMMAAT) {
res = lbm_enc_sym(SYM_RERROR); // should have a more specific error here.
} else {

10
lispBM/lispBM/src/stack.c
View File

@ -22,7 +22,7 @@
#include "stack.h"
#include "print.h"
int lbm_stack_allocate(lbm_stack_t *s, unsigned int stack_size) {
int lbm_stack_allocate(lbm_stack_t *s, lbm_uint stack_size) {
s->data = lbm_memory_allocate(stack_size);
s->sp = 0;
s->size = stack_size;
@ -32,7 +32,7 @@ int lbm_stack_allocate(lbm_stack_t *s, unsigned int stack_size) {
return 0;
}
int lbm_stack_create(lbm_stack_t *s, lbm_uint* data, unsigned int size) {
int lbm_stack_create(lbm_stack_t *s, lbm_uint* data, lbm_uint size) {
s->data = data;
s->sp = 0;
s->size = size;
@ -51,13 +51,13 @@ int lbm_stack_clear(lbm_stack_t *s) {
return 1;
}
lbm_uint *lbm_get_stack_ptr(lbm_stack_t *s, unsigned int n) {
lbm_uint *lbm_get_stack_ptr(lbm_stack_t *s, lbm_uint n) {
if (n > s->sp) return NULL;
unsigned int index = s->sp - n;
lbm_uint index = s->sp - n;
return &s->data[index];
}
int lbm_stack_drop(lbm_stack_t *s, unsigned int n) {
int lbm_stack_drop(lbm_stack_t *s, lbm_uint n) {
if (n > s->sp) return 0;

4
lispBM/lispBM/src/streams.c
View File

@ -40,8 +40,8 @@ lbm_value lbm_stream_put(lbm_stream_t *str, lbm_value v) {
lbm_value lbm_stream_create(lbm_stream_t *str) {
lbm_value s = lbm_cons((lbm_value)str, lbm_enc_sym(SYM_STREAM_TYPE));
if (lbm_type_of(s) == LBM_PTR_TYPE_CONS) {
s = s | LBM_PTR_TYPE_STREAM;
if (lbm_type_of(s) == LBM_TYPE_CONS) {
s = s | LBM_TYPE_STREAM;
}
return s;
}

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

@ -24,7 +24,7 @@
#include "symrepr.h"
#define NUM_SPECIAL_SYMBOLS 111
#define NUM_SPECIAL_SYMBOLS 117
#define NAME 0
#define ID 1
#define NEXT 2
@ -62,8 +62,8 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
// pattern matching
{"?" , SYM_MATCH_ANY},
{"?i28" , SYM_MATCH_I28},
{"?u28" , SYM_MATCH_U28},
{"?i" , SYM_MATCH_I},
{"?u" , SYM_MATCH_U},
{"?u32" , SYM_MATCH_U32},
{"?i32" , SYM_MATCH_I32},
{"?float" , SYM_MATCH_FLOAT},
@ -79,9 +79,12 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"out_of_stack" , SYM_STACK_ERROR},
{"division_by_zero" , SYM_DIVZERO},
{"sym_array" , SYM_ARRAY_TYPE},
{"sym_boxed_i" , SYM_BOXED_I_TYPE},
{"sym_boxed_u" , SYM_BOXED_U_TYPE},
{"sym_boxed_f" , SYM_BOXED_F_TYPE},
{"sym_raw_i" , SYM_RAW_I_TYPE},
{"sym_raw_u" , SYM_RAW_U_TYPE},
{"sym_raw_f" , SYM_RAW_F_TYPE},
{"sym_ind_i" , SYM_IND_I_TYPE},
{"sym_ind_u" , SYM_IND_U_TYPE},
{"sym_ind_f" , SYM_IND_F_TYPE},
{"sym_stream" , SYM_STREAM_TYPE},
{"sym_recovered" , SYM_RECOVERED},
{"sym_bytecode" , SYM_BYTECODE_TYPE},
@ -100,11 +103,14 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
// special symbols with parseable names
{"type-list" , SYM_TYPE_LIST},
{"type-i28" , SYM_TYPE_I28},
{"type-u28" , SYM_TYPE_U28},
{"type-i" , SYM_TYPE_I},
{"type-u" , SYM_TYPE_U},
{"type-float" , SYM_TYPE_FLOAT},
{"type-i32" , SYM_TYPE_I32},
{"type-u32" , SYM_TYPE_U32},
{"type-double" , SYM_TYPE_DOUBLE},
{"type-i64" , SYM_TYPE_I64},
{"type-u64" , SYM_TYPE_U64},
{"type-array" , SYM_TYPE_ARRAY},
{"type-symbol" , SYM_TYPE_SYMBOL},
{"type-char" , SYM_TYPE_CHAR},
@ -173,7 +179,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = {
{"is-fundamental" , SYM_IS_FUNDAMENTAL}
};
static uint32_t *symlist = NULL;
static lbm_uint *symlist = NULL;
static lbm_uint next_symbol_id = RUNTIME_SYMBOLS_START;
static lbm_uint next_extension_symbol_id = EXTENSION_SYMBOLS_START;
static lbm_uint next_variable_symbol_id = VARIABLE_SYMBOLS_START;
@ -188,21 +194,21 @@ int lbm_symrepr_init(void) {
void lbm_symrepr_name_iterator(symrepr_name_iterator_fun f) {
uint32_t *curr = symlist;
lbm_uint *curr = symlist;
while (curr) {
f((const char *)curr[NAME]);
curr = (uint32_t *)curr[NEXT];
curr = (lbm_uint *)curr[NEXT];
}
}
const char *lookup_symrepr_name_memory(lbm_uint id) {
uint32_t *curr = symlist;
lbm_uint *curr = symlist;
while (curr) {
if (id == curr[ID]) {
return (const char *)curr[NAME];
}
curr = (uint32_t*)curr[NEXT];
curr = (lbm_uint*)curr[NEXT];
}
return NULL;
}
@ -230,14 +236,14 @@ int lbm_get_symbol_by_name(char *name, lbm_uint* id) {
}
}
uint32_t *curr = symlist;
lbm_uint *curr = symlist;
while (curr) {
char *str = (char*)curr[NAME];
if (strcmp(name, str) == 0) {
*id = curr[ID];
return 1;
}
curr = (uint32_t*)curr[NEXT];
curr = (lbm_uint*)curr[NEXT];
}
return 0;
}
@ -248,17 +254,17 @@ int lbm_add_symbol(char *name, lbm_uint* id) {
n = strlen(name) + 1;
if (n == 1) return 0; // failure if empty symbol
uint32_t *m = lbm_memory_allocate(3);
lbm_uint *m = lbm_memory_allocate(3);
if (m == NULL) {
return 0;
}
char *symbol_name_storage = NULL;;
if (n % 4 == 0) {
symbol_name_storage = (char *)lbm_memory_allocate(n/4);
if (n % sizeof(lbm_uint) == 0) {
symbol_name_storage = (char *)lbm_memory_allocate(n/sizeof(lbm_uint));
} else {
symbol_name_storage = (char *)lbm_memory_allocate((n/4) + 1);
symbol_name_storage = (char *)lbm_memory_allocate((n/sizeof(lbm_uint)) + 1);
}
if (symbol_name_storage == NULL) {
@ -268,13 +274,13 @@ int lbm_add_symbol(char *name, lbm_uint* id) {
strcpy(symbol_name_storage, name);
m[NAME] = (uint32_t)symbol_name_storage;
m[NAME] = (lbm_uint)symbol_name_storage;
if (symlist == NULL) {
m[NEXT] = (uint32_t) NULL;
m[NEXT] = (lbm_uint) NULL;
symlist = m;
} else {
m[NEXT] = (uint32_t) symlist;
m[NEXT] = (lbm_uint) symlist;
symlist = m;
}
m[ID] = next_symbol_id++;
@ -290,17 +296,17 @@ int lbm_add_variable_symbol(char *name, lbm_uint* id) {
n = strlen(name) + 1;
if (n == 1) return 0; // failure if empty symbol
uint32_t *m = lbm_memory_allocate(3);
lbm_uint *m = lbm_memory_allocate(3);
if (m == NULL) {
return 0;
}
char *symbol_name_storage = NULL;;
if (n % 4 == 0) {
symbol_name_storage = (char *)lbm_memory_allocate(n/4);
if (n % sizeof(lbm_uint) == 0) {
symbol_name_storage = (char *)lbm_memory_allocate(n/sizeof(lbm_uint));
} else {
symbol_name_storage = (char *)lbm_memory_allocate((n/4) + 1);
symbol_name_storage = (char *)lbm_memory_allocate((n/sizeof(lbm_uint)) + 1);
}
if (symbol_name_storage == NULL) {
@ -310,13 +316,13 @@ int lbm_add_variable_symbol(char *name, lbm_uint* id) {
strcpy(symbol_name_storage, name);
m[NAME] = (uint32_t)symbol_name_storage;
m[NAME] = (lbm_uint)symbol_name_storage;
if (symlist == NULL) {
m[NEXT] = (uint32_t) NULL;
m[NEXT] = (lbm_uint) NULL;
symlist = m;
} else {
m[NEXT] = (uint32_t) symlist;
m[NEXT] = (lbm_uint) symlist;
symlist = m;
}
m[ID] = next_variable_symbol_id++;
@ -328,19 +334,19 @@ int lbm_add_variable_symbol(char *name, lbm_uint* id) {
int lbm_add_symbol_const(char *name, lbm_uint* id) {
if (strlen(name) == 0) return 0; // failure if empty symbol
uint32_t *m = lbm_memory_allocate(3);
lbm_uint *m = lbm_memory_allocate(3);
if (m == NULL) {
return 0;
}
m[NAME] = (uint32_t)name;
m[NAME] = (lbm_uint)name;
if (symlist == NULL) {
m[NEXT] = (uint32_t) NULL;
m[NEXT] = (lbm_uint) NULL;
symlist = m;
} else {
m[NEXT] = (uint32_t) symlist;
m[NEXT] = (lbm_uint) symlist;
symlist = m;
}
m[ID] = next_symbol_id++;
@ -352,19 +358,19 @@ int lbm_add_extension_symbol_const(char *name, lbm_uint* id) {
if (strlen(name) == 0) return 0; // failure if empty symbol
if (next_extension_symbol_id >= EXTENSION_SYMBOLS_END) return 0;
uint32_t *m = lbm_memory_allocate(3);
lbm_uint *m = lbm_memory_allocate(3);
if (m == NULL) {
return 0;
}
m[NAME] = (uint32_t)name;
m[NAME] = (lbm_uint)name;
if (symlist == NULL) {
m[NEXT] = (uint32_t) NULL;
m[NEXT] = (lbm_uint) NULL;
symlist = m;
} else {
m[NEXT] = (uint32_t) symlist;
m[NEXT] = (lbm_uint) symlist;
symlist = m;
}
m[ID] = next_extension_symbol_id++;
@ -373,18 +379,18 @@ int lbm_add_extension_symbol_const(char *name, lbm_uint* id) {
}
unsigned int lbm_get_symbol_table_size(void) {
lbm_uint lbm_get_symbol_table_size(void) {
unsigned int n = 0;
uint32_t *curr = symlist;
lbm_uint n = 0;
lbm_uint *curr = symlist;
while (curr) {
// up to 3 extra bytes are used for string storage if length is not multiple of 4
size_t s = strlen((char *)curr[NAME]);
s ++;
n += s % 4;
n += s % sizeof(lbm_uint);
n += 12; // sizeof the node in the linked list
curr = (uint32_t *)curr[NEXT];
curr = (lbm_uint *)curr[NEXT];
}
return n;
}

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

@ -68,20 +68,6 @@ static void clear_sym_str(void) {
memset(sym_str,0,TOKENIZER_MAX_SYMBOL_AND_STRING_LENGTH);
}
typedef struct {
unsigned int type;
unsigned int text_len;
union {
char c;
char *text;
lbm_int i;
lbm_uint u;
lbm_float f;
}data;
} token;
typedef struct {
const char *str;
uint32_t token;
@ -98,8 +84,8 @@ const matcher match_table[NUM_FIXED_SIZE_TOKENS] = {
{"`", TOKBACKQUOTE, 1},
{",@", TOKCOMMAAT, 2},
{",", TOKCOMMA, 1},
{"?i28", TOKMATCHI28, 4},
{"?u28", TOKMATCHU28, 4},
{"?i", TOKMATCHI28, 4},
{"?u", TOKMATCHU28, 4},
{"?u32", TOKMATCHU32, 4},
{"?i32", TOKMATCHI32, 4},
{"?float", TOKMATCHFLOAT, 6},
@ -306,10 +292,8 @@ int tok_i(lbm_tokenizer_char_stream_t *str, lbm_int *res) {
peek(str,n) == 'I') return 0;
unsigned int ndrop = n;
if (peek(str,n) == 'i' &&
peek(str,n+1) == '2' &&
peek(str,n+2) == '8' ) {
ndrop += 3;
if (peek(str,n) == 'i' ) {
ndrop += 1;
}
if (valid_num) {
drop(str,ndrop);
@ -319,8 +303,8 @@ int tok_i(lbm_tokenizer_char_stream_t *str, lbm_int *res) {
return 0;
}
int tok_I(lbm_tokenizer_char_stream_t *str, lbm_int *res) {
lbm_int acc = 0;
int tok_i32(lbm_tokenizer_char_stream_t *str, int32_t *res) {
int32_t acc = 0;
unsigned int n = 0;
bool negative = false;
bool valid_num = false;
@ -348,6 +332,36 @@ int tok_I(lbm_tokenizer_char_stream_t *str, lbm_int *res) {
return 0;
}
int tok_i64(lbm_tokenizer_char_stream_t *str, int64_t *res) {
int64_t acc = 0;
unsigned int n = 0;
bool negative = false;
bool valid_num = false;
if (peek(str, 0) == '-') {
n = 1;
negative = true;
}
while ( peek(str,n) >= '0' && peek(str,n) <= '9' ){
acc = (acc*10) + (peek(str,n) - '0');
n++;
}
if ((negative && n > 1) ||
(!negative && n > 0)) valid_num = true;
if (peek(str,n) == 'i' &&
peek(str,n+1) == '6' &&
peek(str,n+2) == '4' &&
valid_num) {
*res = negative ? -acc : acc;
drop(str,n+3);
return (int)(n+3);
}
return 0;
}
int tok_u(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
lbm_uint acc = 0;
unsigned int n = 0;
@ -366,19 +380,16 @@ int tok_u(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
if ((negative && n > 1) ||
(!negative && n > 0)) valid_num = true;
if (peek(str,n) == 'u' &&
peek(str,n+1) == '2' &&
peek(str,n+2) == '8' &&
valid_num) {
if (peek(str,n) == 'u' && valid_num) {
*res = negative ? -acc : acc;
drop(str,n+3);
drop(str,n+1);
return (int)(n+3);
}
return 0;
}
int tok_U(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
lbm_uint acc = 0;
int tok_u32(lbm_tokenizer_char_stream_t *str, uint32_t *res) {
uint32_t acc = 0;
unsigned int n = 0;
bool negative = false;
bool valid_num = false;
@ -395,13 +406,13 @@ int tok_U(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
while ( (peek(str,n) >= '0' && peek(str,n) <= '9') ||
(peek(str,n) >= 'a' && peek(str,n) <= 'f') ||
(peek(str,n) >= 'A' && peek(str,n) <= 'F')){
lbm_uint val;
uint32_t val;
if (peek(str,n) >= 'a' && peek(str,n) <= 'f') {
val = 10 + (lbm_uint)(peek(str,n) - 'a');
val = 10 + (uint32_t)(peek(str,n) - 'a');
} else if (peek(str,n) >= 'A' && peek(str,n) <= 'F') {
val = 10 + (lbm_uint)(peek(str,n) - 'A');
val = 10 + (uint32_t)(peek(str,n) - 'A');
} else {
val = (lbm_uint)peek(str,n) - '0';
val = (uint32_t)peek(str,n) - '0';
}
acc = (acc * 0x10) + val;
n++;
@ -418,7 +429,7 @@ int tok_U(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
// check if nonhex
while ( peek(str,n) >= '0' && peek(str,n) <= '9' ){
acc = (acc*10) + (lbm_uint)(peek(str,n) - '0');
acc = (acc*10) + (uint32_t)(peek(str,n) - '0');
n++;
}
if ((negative && n > 1) ||
@ -435,7 +446,69 @@ int tok_U(lbm_tokenizer_char_stream_t *str, lbm_uint *res) {
return 0;
}
int tok_F(lbm_tokenizer_char_stream_t *str, lbm_float *res) {
int tok_u64(lbm_tokenizer_char_stream_t *str, uint64_t *res) {
uint64_t acc = 0;
unsigned int n = 0;
bool negative = false;
bool valid_num = false;
if (peek(str, 0) == '-') {
n = 1;
negative = true;
}
// Check if hex notation is used
if (peek(str,0) == '0' &&
(peek(str,1) == 'x' || peek(str,1) == 'X')) {
n+= 2;
while ( (peek(str,n) >= '0' && peek(str,n) <= '9') ||
(peek(str,n) >= 'a' && peek(str,n) <= 'f') ||
(peek(str,n) >= 'A' && peek(str,n) <= 'F')){
uint32_t val;
if (peek(str,n) >= 'a' && peek(str,n) <= 'f') {
val = 10 + (uint32_t)(peek(str,n) - 'a');
} else if (peek(str,n) >= 'A' && peek(str,n) <= 'F') {
val = 10 + (uint32_t)(peek(str,n) - 'A');
} else {
val = (uint32_t)peek(str,n) - '0';
}
acc = (acc * 0x10) + val;
n++;
}
if ((negative && n > 1) ||
(!negative && n > 0)) valid_num = true;
if (peek(str,n) == 'u' &&
peek(str,n+1) == '6' &&
peek(str,n+2) == '4' &&
valid_num) {
drop(str,n+3);
*res = negative ? -acc : acc;
return (int)n; /*check that isnt so high that it becomes a negative number when casted */
}
}
// check if nonhex
while ( peek(str,n) >= '0' && peek(str,n) <= '9' ){
acc = (acc*10) + (uint32_t)(peek(str,n) - '0');
n++;
}
if ((negative && n > 1) ||
(!negative && n > 0)) valid_num = true;
if (peek(str,n) == 'u' &&
peek(str,n+1) == '6' &&
peek(str,n+2) == '4' &&
valid_num) {
*res = negative ? -acc : acc;
drop(str,n+3);
return (int)(n+3);
}
return 0;
}
int tok_F(lbm_tokenizer_char_stream_t *str, float *res) {
unsigned int n = 0;
unsigned int m = 0;
@ -474,13 +547,63 @@ int tok_F(lbm_tokenizer_char_stream_t *str, lbm_float *res) {
return 0;
}
int tok_D(lbm_tokenizer_char_stream_t *str, double *res) {
unsigned int n = 0;
unsigned int m = 0;
char fbuf[128];
bool negative = false;
bool valid_num = false;
if (peek(str, 0) == '-') {
n = 1;
negative = true;
}
while ( peek(str,n) >= '0' && peek(str,n) <= '9') n++;
if ( peek(str,n) == '.') n++;
else return 0;
if ( !(peek(str,n) >= '0' && peek(str,n) <= '9')) return 0;
while ( peek(str,n) >= '0' && peek(str,n) <= '9') n++;
if (!(peek(str,n) == 'f' &&
peek(str,n+1) == '6' &&
peek(str,n+2) == '4')) {
return 0;
}
if ((negative && n > 1) ||
(!negative && n > 0)) valid_num = true;
if (n > 127) return 0;
else m = n;
if(valid_num) {
unsigned int i;
for (i = 0; i < m; i ++) {
fbuf[i] = get(str);
}
drop(str,3);
fbuf[i] = 0;
*res = (double)strtod(fbuf, NULL);
return (int)n;
}
return 0;
}
lbm_value lbm_get_next_token(lbm_tokenizer_char_stream_t *str) {
lbm_int i_val;
lbm_uint u_val;
uint32_t u32_val;
int32_t i32_val;
uint64_t u64_val;
int64_t i64_val;
double d_val;
char c_val;
lbm_float f_val;
float f_val;
int n = 0;
if (!more(str)) {
@ -536,10 +659,10 @@ lbm_value lbm_get_next_token(lbm_tokenizer_char_stream_t *str) {
res = lbm_enc_sym(SYM_COMMA);
break;
case TOKMATCHI28:
res = lbm_enc_sym(SYM_MATCH_I28);
res = lbm_enc_sym(SYM_MATCH_I);
break;
case TOKMATCHU28:
res = lbm_enc_sym(SYM_MATCH_U28);
res = lbm_enc_sym(SYM_MATCH_U);
break;
case TOKMATCHI32:
res = lbm_enc_sym(SYM_MATCH_I32);
@ -566,7 +689,7 @@ lbm_value lbm_get_next_token(lbm_tokenizer_char_stream_t *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_heap_allocate_array(&res, (unsigned int)(n-2)+1, LBM_TYPE_CHAR);
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
char *data = (char *)arr->data;
memset(data, 0, (unsigned int)((n-2)+1) * sizeof(char));
@ -577,22 +700,34 @@ lbm_value lbm_get_next_token(lbm_tokenizer_char_stream_t *str) {
return res;
}
if (tok_F(str, &f_val)) {
// Will be SYM_MERROR in case of full heap
return lbm_enc_F(f_val);
if (tok_D(str, &d_val)) {
return lbm_enc_double(d_val);
}
if (tok_U(str, &u_val)) {
if (tok_F(str, &f_val)) {
// Will be SYM_MERROR in case of full heap
return lbm_enc_U(u_val);
return lbm_enc_float(f_val);
}
if (tok_u64(str,&u64_val)) {
return lbm_enc_u64(u64_val);
}
if (tok_u32(str, &u32_val)) {
// Will be SYM_MERROR in case of full heap
return lbm_enc_u32(u32_val);
}
if (tok_u(str, &u_val)) {
return lbm_enc_u(u_val);
}
if (tok_I(str, &i_val)) {
return lbm_enc_I(i_val);
if (tok_i64(str, &i64_val)) {
return lbm_enc_i64(i64_val);
}
if (tok_i32(str, &i32_val)) {
return lbm_enc_i32(i32_val);
}
// Shortest form of integer match. Move to last in chain of numerical tokens.

2
lispBM/lispBM/src/visual/heap_vis.c
View File

@ -67,7 +67,7 @@ void heap_vis_gen_image(void) {
uint32_t fl = hs.freelist;
while (lbm_type_of(fl) == LBM_PTR_TYPE_CONS) {
while (lbm_type_of(fl) == LBM_TYPE_CONS) {
uint32_t index = lbm_dec_ptr(fl);
pix_data[index] = free_color;
fl = lbm_cdr(fl);

10
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 -Wextra -Wshadow -Wconversion -pedantic -std=c99
CCFLAGS = -g -O2 -Wall -Wextra -Wshadow -Wconversion -pedantic -std=c99
CC=gcc
SRC = src
@ -16,10 +16,18 @@ OBJ = obj
SOURCES = $(wildcard *.c)
EXECS = $(patsubst %.c, %.exe, $(SOURCES))
all: CCFLAGS += -m32
all: $(EXECS)
mv test_lisp_code_cps.exe test_lisp_code_cps
# mv test_lisp_code_cps_nc.exe test_lisp_code_cps_nc
all64: CCFLAGS += -DLBM64
all64: $(EXECS)
mv test_lisp_code_cps.exe test_lisp_code_cps
# mv test_lisp_code_cps_nc.exe test_lisp_code_cps_nc
%.exe: %.c $(LISPBM_DEPS)
$(CC) $(CCFLAGS) $(LISPBM_SRC) $(PLATFORM_SRC) $(LISPBM_FLAGS) $< -o $@ -I$(LISPBM)include $(PLATFORM_INCLUDE) -lpthread

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

@ -25,6 +25,8 @@ expected_fails=("test_lisp_code_cps -h 512 test_qq_4.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"
"test_lisp_code_cps -h 512 test_array_extensions_4.lisp"
"test_lisp_code_cps -c -h 512 test_array_extensions_4.lisp"
)

130
lispBM/lispBM/tests/run_tests64.sh Executable file
View File

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

2
lispBM/lispBM/tests/test_arith_0.lisp
View File

@ -1,3 +1,3 @@
(= (+ 5u28 60u28) 65u28)
(= (+ 5u 60u) 65u)

2
lispBM/lispBM/tests/test_arith_2.lisp
View File

@ -1,2 +1,2 @@
(= (+ 1 0xf) 16u28)
(= (+ 1 0xf) 16u)

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

@ -0,0 +1 @@
(= 3i (+ 1u 2i))

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

@ -0,0 +1 @@
(= 3i64 (+ 1i64 2i64))

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

@ -0,0 +1 @@
(= 3u64 (+ 1u64 2u64))

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

@ -0,0 +1 @@
(= -3i64 (- 3i64))

2
lispBM/lispBM/tests/test_array_0.lisp
View File

@ -1,2 +1,2 @@
(= (array-read "hello" 3u28) \#l)
(= (array-read "hello" 3u) \#l)

2
lispBM/lispBM/tests/test_array_1.lisp
View File

@ -1,4 +1,4 @@
(define a "hello")
(= (array-read a 3u28) \#l)
(= (array-read a 3u) \#l)

2
lispBM/lispBM/tests/test_array_2.lisp
View File

@ -1,3 +1,3 @@
(let ((a "hello"))
(= (array-read a 3u28) \#l))
(= (array-read a 3u) \#l))

5
lispBM/lispBM/tests/test_array_3.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-u32 10))
(array-write arr 5 77)
(= (array-read arr 5) 77)

5
lispBM/lispBM/tests/test_array_4.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-i32 10))
(array-write arr 5 77)
(= (array-read arr 5) 77)

5
lispBM/lispBM/tests/test_array_5.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-u64 10))
(array-write arr 5 77)
(= (array-read arr 5) 77)

5
lispBM/lispBM/tests/test_array_6.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-i64 10))
(array-write arr 5 77)
(= (array-read arr 5) 77)

5
lispBM/lispBM/tests/test_array_7.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-float 10))
(array-write arr 5 3.14)
(= (array-read arr 5) 3.14)

5
lispBM/lispBM/tests/test_array_8.lisp Normal file
View File

@ -0,0 +1,5 @@
(define arr (array-create type-double 10))
(array-write arr 5 3.14f64)
(= (array-read arr 5) 3.14f64)

16
lispBM/lispBM/tests/test_array_extensions_4.lisp
View File

@ -1,3 +1,11 @@
(define close-enough
(lambda (x y)
(if (> x y)
(< (- x y) 0.0001)
(< (- y x) 0.0001)
)))
(define arr (array-create type-byte 16))
(bufset-f32 arr 0 3.14)
@ -5,7 +13,7 @@
(bufset-f32 arr 8 100)
(bufset-f32 arr 12 42)
(and (= (bufget-f32 arr 0) 3.14)
(= (bufget-f32 arr 4) 666.666)
(= (bufget-f32 arr 8) 100)
(= (bufget-f32 arr 12) 42))
(and (close-enough (bufget-f32 arr 0) 3.14)
(close-enough (bufget-f32 arr 4) 666.666)
(close-enough (bufget-f32 arr 8) 100)
(close-enough (bufget-f32 arr 12) 42))

2
lispBM/lispBM/tests/test_decode_0.lisp
View File

@ -1,2 +1,2 @@
(eq '(0u28 0u28 255u28 255u28) (decode (- 65536 1)))
(eq '(0u 0u 255u 255u) (take 4 (decode (- 65536 1))))

12
lispBM/lispBM/tests/test_encode_1.lisp
View File

@ -1 +1,11 @@
(= 3.14 (encode-float (decode 3.14)))
(define close-enough
(lambda (x y)
(if (> x y)
(< (- x y) 0.0001)
(< (- y x) 0.0001)
)))
(close-enough 3.14 (encode-float (decode 3.14)))

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

@ -0,0 +1 @@
(eq 1.2 1.2)

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

@ -0,0 +1 @@
(eq 1u32 1u32)

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

@ -0,0 +1 @@
(eq 1i32 1i32)

6
lispBM/lispBM/tests/test_heap_alloc.c
View File

@ -41,7 +41,7 @@ int main(int argc, char **argv) {
printf("Initialized heap: OK\n");
for (unsigned int i = 0; i < heap_size; i ++) {
cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (!lbm_is_ptr(cell)) {
printf("Error allocating cell %d\n", i);
return 0;
@ -50,11 +50,11 @@ int main(int argc, char **argv) {
printf("Allocated %d heap cells: OK\n", heap_size);
for (int i = 0; i < 34; i ++) {
cell = lbm_heap_allocate_cell(LBM_PTR_TYPE_CONS);
cell = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if (lbm_is_ptr(cell)) {
printf("Error allocation succeeded on empty heap\n");
return 0;
} else if (lbm_type_of(cell) != LBM_VAL_TYPE_SYMBOL ||
} else if (lbm_type_of(cell) != LBM_TYPE_SYMBOL ||
lbm_dec_sym(cell) != SYM_MERROR) {
printf("Error Incorrect return value at cell allocation on full heap\n");
return 0;

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

@ -36,8 +36,8 @@
#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];
lbm_uint gc_stack_storage[GC_STACK_SIZE];
lbm_uint print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
@ -84,7 +84,7 @@ void context_done_callback(eval_context_t *ctx) {
printf("%s\n", output);
}
if (res && lbm_type_of(t) == LBM_VAL_TYPE_SYMBOL && lbm_dec_sym(t) == SYM_TRUE){ // structural_equality(car(rest),car(cdr(rest)))) {
if (res && lbm_type_of(t) == LBM_TYPE_SYMBOL && lbm_dec_sym(t) == SYM_TRUE){ // structural_equality(car(rest),car(cdr(rest)))) {
experiment_success = true;
printf("Test: OK!\n");
} else {
@ -94,14 +94,14 @@ void context_done_callback(eval_context_t *ctx) {
experiment_done = true;
}
lbm_value ext_even(lbm_value *args, lbm_uint argn) {
//lbm_value ext_even(lbm_value *args, lbm_uint argn) {
LBM_EXTENSION(ext_even, args, argn){
if (argn < 1) return lbm_enc_sym(SYM_NIL);
lbm_value v = args[0];
if (lbm_type_of(v) == LBM_VAL_TYPE_I ||
lbm_type_of(v) == LBM_VAL_TYPE_U) {
if (lbm_type_of(v) == LBM_TYPE_I ||
lbm_type_of(v) == LBM_TYPE_U) {
if (lbm_dec_i(v) % 2 == 0)
return lbm_enc_sym(SYM_TRUE);
}
@ -109,14 +109,15 @@ lbm_value ext_even(lbm_value *args, lbm_uint argn) {
return lbm_enc_sym(SYM_NIL);
}
lbm_value ext_odd(lbm_value *args, lbm_uint argn) {
LBM_EXTENSION(ext_odd, args, argn){
//lbm_value ext_odd(lbm_value *args, lbm_uint argn) {
if (argn < 1) return lbm_enc_sym(SYM_NIL);
lbm_value v = args[0];
if (lbm_type_of(v) == LBM_VAL_TYPE_I ||
lbm_type_of(v) == LBM_VAL_TYPE_U) {
if (lbm_type_of(v) == LBM_TYPE_I ||
lbm_type_of(v) == LBM_TYPE_U) {
if (lbm_dec_i(v) % 2 == 1)
return lbm_enc_sym(SYM_TRUE);
}
@ -187,9 +188,9 @@ int main(int argc, char **argv) {
return 0;
}
uint32_t *memory = malloc(4 * LBM_MEMORY_SIZE_16K);
lbm_uint *memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_32K);
if (memory == NULL) return 0;
uint32_t *bitmap = malloc(4 * LBM_MEMORY_BITMAP_SIZE_16K);
lbm_uint *bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_32K);
if (bitmap == NULL) return 0;
@ -225,7 +226,7 @@ int main(int argc, char **argv) {
res = lbm_heap_init(heap_storage, heap_size, gc_stack_storage, GC_STACK_SIZE);
if (res)
printf("Heap initialized. Heap size: %f MiB. Free cons cells: %d\n", lbm_heap_size_bytes() / 1024.0 / 1024.0, lbm_heap_num_free());
printf("Heap initialized. Heap size: %"PRI_FLOAT" MiB. Free cons cells: %"PRI_INT"\n", (double)lbm_heap_size_bytes() / 1024.0 / 1024.0, lbm_heap_num_free());
else {
printf("Error initializing heap!\n");
return 0;

2
lispBM/lispBM/tests/test_sumtree_0.lisp
View File

@ -1,6 +1,6 @@
(define sumtree
(lambda (x)
(if (eq (type-of x) type-i28)
(if (eq (type-of x) type-i)
x
(if (eq x 'nil)
0

6
lispBM/lispBM/tests/test_sumtree_1.lisp
View File

@ -1,8 +1,8 @@
(define is-number
(lambda (x)
(if (eq (type-of x) type-i28)
(if (eq (type-of x) type-i)
't
(if (eq (type-of x) type-u28)
(if (eq (type-of x) type-u)
't
(if (eq (type-of x) type-float)
't
@ -25,4 +25,4 @@
)))))
(= (sumtree (list (list 1u32 1i32 1u28 1 1 1 1 1 1 1) (list 1 2.0) (list 3 4.0))) 20.0)
(= (sumtree (list (list 1u32 1i32 1u 1 1 1 1 1 1 1) (list 1 2.0) (list 3 4.0))) 20.0)

6
lispBM/lispBM/tests/test_sumtree_2.lisp
View File

@ -1,7 +1,7 @@
(define is-number
(lambda (x)
(or (eq (type-of x) type-i28)
(eq (type-of x) type-u28)
(or (eq (type-of x) type-i)
(eq (type-of x) type-u)
(eq (type-of x) type-float)
(eq (type-of x) type-i32)
(eq (type-of x) type-u32))
@ -20,4 +20,4 @@
)))))
(= (sumtree (list (list 1u32 1i32 1u28 1 1 1 1 1 1 1) (list 1 2.0) (list 3 4.0))) 20.0)
(= (sumtree (list (list 1u32 1i32 1u 1 1 1 1 1 1 1) (list 1 2.0) (list 3 4.0))) 20.0)