diff --git a/lispBM/lispBM/include/eval_cps.h b/lispBM/lispBM/include/eval_cps.h
index d9ab46dc..9055884d 100644
--- a/lispBM/lispBM/include/eval_cps.h
+++ b/lispBM/lispBM/include/eval_cps.h
@@ -62,6 +62,23 @@ typedef struct eval_context_s{
struct eval_context_s *next;
} eval_context_t;
+typedef enum {
+ LBM_EVENT_SYM = 0,
+ LBM_EVENT_SYM_INT,
+ LBM_EVENT_SYM_INT_INT,
+ LBM_EVENT_SYM_ARRAY,
+ LBM_EVENT_SYM_INT_ARRAY,
+} lbm_event_type_t;
+
+typedef struct {
+ lbm_event_type_t type;
+ lbm_uint sym;
+ int32_t i;
+ int32_t i2;
+ char *array;
+ int32_t array_len;
+} lbm_event_t;
+
/** Fundamental operation type */
typedef lbm_value (*fundamental_fun)(lbm_value *, lbm_uint, eval_context_t*);
@@ -93,7 +110,26 @@ int lbm_eval_init(void);
* \param quota The new quota.
*/
void lbm_set_eval_step_quota(uint32_t quota);
-
+/** Initialize events
+ * \param num_events The maximum number of unprocessed events.
+ * \return true on success, false otherwise.
+ */
+bool lbm_eval_init_events(unsigned int num_events);
+/** Get the process ID for the current event handler.
+ * \return process ID on success and -1 if no event handler is registered.
+ */
+lbm_cid lbm_get_event_handler_pid(void);
+/** Set the event handler process ID.
+ * \param pid The ID of the process to which events should be sent
+ */
+void lbm_set_event_handler_pid(lbm_cid pid);
+/** Send an event to the registered event handler process.
+ * \param event The event to send to the registered handler.
+ * \param opt_array An optional array to pass to the event handler.
+ * \param opt_array_len Length of array mandatory if array is passed in.
+ * \return true if the event was successfully enqueued to be sent, false otherwise.
+ */
+bool lbm_event(lbm_event_t event, uint8_t* opt_array, int opt_array_len);
/** Remove a context that has finished executing and free up its associated memory.
*
* \param cid Context id of context to free.
@@ -204,7 +240,7 @@ void lbm_blocked_iterator(ctx_fun f, void*, void*);
* \param arg1 Pointer argument that can be used to convey information back to user.
* \param arg2 Same as above
*/
-void lbm_sleeping_iterator(ctx_fun f, void *, void *);
+void lbm_sleeping_iterator(ctx_fun f, void *, void *);
/** toggle verbosity level of error messages
*/
void lbm_toggle_verbose(void);
diff --git a/lispBM/lispBM/include/extensions/matvec_extensions.h b/lispBM/lispBM/include/extensions/matvec_extensions.h
new file mode 100644
index 00000000..fcb21805
--- /dev/null
+++ b/lispBM/lispBM/include/extensions/matvec_extensions.h
@@ -0,0 +1,32 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#ifndef MATVEC_EXTENSIONS_H_
+#define MATVEC_EXTENSIONS_H_
+
+#include
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_matvec_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif
diff --git a/lispBM/lispBM/include/extensions/random_extensions.h b/lispBM/lispBM/include/extensions/random_extensions.h
new file mode 100644
index 00000000..be1d16eb
--- /dev/null
+++ b/lispBM/lispBM/include/extensions/random_extensions.h
@@ -0,0 +1,32 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#ifndef RANDOM_EXTENSIONS_H_
+#define RANDOM_EXTENSIONS_H_
+
+#include
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_random_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif
diff --git a/lispBM/lispBM/include/extensions/runtime_extensions.h b/lispBM/lispBM/include/extensions/runtime_extensions.h
new file mode 100644
index 00000000..c40d901b
--- /dev/null
+++ b/lispBM/lispBM/include/extensions/runtime_extensions.h
@@ -0,0 +1,32 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#ifndef RUNTIME_EXTENSIONS_H_
+#define RUNTIME_EXTENSIONS_H_
+
+#include
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_runtime_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif
diff --git a/lispBM/lispBM/include/heap.h b/lispBM/lispBM/include/heap.h
index c595ff27..8bb6179e 100644
--- a/lispBM/lispBM/include/heap.h
+++ b/lispBM/lispBM/include/heap.h
@@ -446,6 +446,16 @@ int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val);
* \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate.
*/
unsigned int lbm_list_length(lbm_value c);
+
+/** Calculate the length of a proper list and evaluate a predicate for each element.
+ * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
+ * may lead to the function not terminating.
+ *
+ * \param c A list
+ * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true.
+ * \param pred Predicate to evaluate for each element of the list.
+ */
+unsigned int lbm_list_length_pred(lbm_value c, bool *pres, bool (*pred)(lbm_value));
/** Reverse a proper list
* \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap
* may lead to the function not terminating.
@@ -533,6 +543,15 @@ int lbm_gc_sweep_phase(void);
* \return 1 for success of 0 for failure.
*/
int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type);
+/** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY
+ * the lifetime of the array will be managed by GC.
+ * \param res lbm_value result pointer for storage of the result array.
+ * \param data C array.
+ * \param type The type tag to assign to the resulting LBM array.
+ * \param num_elt Number of elements in the array.
+ * \return 1 for success and 0 for failure.
+ */
+int lbm_lift_array(lbm_value *value, char *data, lbm_type type, lbm_uint num_elt);
/** Explicitly free an array.
* This function needs to be used with care and knowledge.
* \param arr Array value.
diff --git a/lispBM/lispBM/include/lbm_custom_type.h b/lispBM/lispBM/include/lbm_custom_type.h
index 710a53aa..c8c84b4c 100644
--- a/lispBM/lispBM/include/lbm_custom_type.h
+++ b/lispBM/lispBM/include/lbm_custom_type.h
@@ -20,7 +20,10 @@
#define LBM_CUSTOM_TYPE_H_
#include
+#include
#include
+#include
+#include
#ifdef __cplusplus
extern "C" {
@@ -60,6 +63,19 @@ bool lbm_custom_type_create(lbm_uint value, custom_type_destructor fptr, const c
*/
bool lbm_custom_type_destroy(lbm_uint *lbm_mem_ptr);
+static inline const char *lbm_get_custom_descriptor(lbm_value value) {
+ if (lbm_type_of(value) == LBM_TYPE_CUSTOM) {
+ lbm_uint *m = (lbm_uint*)lbm_dec_custom(value);
+ return (const char*)m[CUSTOM_TYPE_DESCRIPTOR];
+ }
+ return NULL;
+}
+
+static inline lbm_uint lbm_get_custom_value(lbm_value value) {
+ lbm_uint *m = (lbm_uint*)lbm_dec_custom(value);
+ return m[CUSTOM_TYPE_VALUE];
+}
+
#ifdef __cplusplus
}
#endif
diff --git a/lispBM/lispBM/include/lbm_defines.h b/lispBM/lispBM/include/lbm_defines.h
index dc1216fd..f39895e2 100644
--- a/lispBM/lispBM/include/lbm_defines.h
+++ b/lispBM/lispBM/include/lbm_defines.h
@@ -270,7 +270,8 @@
#define SYM_RANGE 0x238
#define SYM_NUM_NOT_EQ 0x239
#define SYM_NOT_EQ 0x23A
-#define FUNDAMENTALS_END 0x23A
+#define SYM_REG_EVENT_HANDLER 0x23B
+#define FUNDAMENTALS_END 0x23B
#define SPECIAL_SYMBOLS_START 0
#define SPECIAL_SYMBOLS_END 0xFFFF
diff --git a/lispBM/lispBM/include/lbm_memory.h b/lispBM/lispBM/include/lbm_memory.h
index ebd7cb23..88c50fea 100644
--- a/lispBM/lispBM/include/lbm_memory.h
+++ b/lispBM/lispBM/include/lbm_memory.h
@@ -76,6 +76,7 @@
#include "lbm_types.h"
#include
+#include
#ifdef __cplusplus
extern "C" {
@@ -148,7 +149,15 @@ lbm_uint *lbm_memory_allocate(lbm_uint num_words);
* \return 1 on success and 0 on failure.
*/
int lbm_memory_free(lbm_uint *ptr);
-
+/** Malloc like interface to lbm_memory
+ * \param size Size in bytes of memory to allocate.
+ * \return Pointer to array or NULL.
+ */
+void* lbm_malloc(size_t size);
+/** Free memory allocated with lbm_malloc
+ * \param Pointer to array to free
+ */
+void lbm_free(void *ptr);
/** Shrink an allocated array.
* \param ptr Pointer to array to shrink
* \param n New smaller size of array
diff --git a/lispBM/lispBM/lispbm.mk b/lispBM/lispBM/lispbm.mk
index 5f08428e..e2d8b63f 100644
--- a/lispBM/lispBM/lispbm.mk
+++ b/lispBM/lispBM/lispbm.mk
@@ -18,7 +18,10 @@ LISPBM_SRC = $(LISPBM)/src/env.c \
$(LISPBM)/src/lbm_channel.c \
$(LISPBM)/src/extensions/array_extensions.c \
$(LISPBM)/src/extensions/string_extensions.c \
- $(LISPBM)/src/extensions/math_extensions.c
+ $(LISPBM)/src/extensions/math_extensions.c \
+ $(LISPBM)/src/extensions/runtime_extensions.c \
+ $(LISPBM)/src/extensions/matvec_extensions.c \
+ $(LISPBM)/src/extensions/random_extensions.c
LISPBM_INC = -I$(LISPBM)/include \
diff --git a/lispBM/lispBM/repl/repl.c b/lispBM/lispBM/repl/repl.c
index f873939b..c3ecef2a 100644
--- a/lispBM/lispBM/repl/repl.c
+++ b/lispBM/lispBM/repl/repl.c
@@ -268,40 +268,40 @@ bool dyn_load(const char *str, const char **code) {
res = true;
} else if (strlen(str) == 6 && strncmp(str, "length", 6) == 0) {
*code = "(define length (lambda (xs)"
- "(let ((len (lambda (l xs)"
- "(if (eq xs nil) l"
- "(len (+ l 1) (cdr xs))))))"
+ "(let ((len (lambda (l xs)"
+ "(if (eq xs nil) l"
+ "(len (+ l 1) (cdr xs))))))"
"(len 0 xs))))";
res = true;
} else if (strlen(str) == 4 && strncmp(str, "take", 4) == 0) {
*code = "(define take (lambda (n xs)"
- "(let ((take-tail (lambda (acc n xs)"
- "(if (= n 0) acc"
- "(take-tail (cons (car xs) acc) (- n 1) (cdr xs))))))"
+ "(let ((take-tail (lambda (acc n xs)"
+ "(if (= n 0) acc"
+ "(take-tail (cons (car xs) acc) (- n 1) (cdr xs))))))"
"(reverse (take-tail nil n xs)))))";
res = true;
} else if (strlen(str) == 4 && strncmp(str, "drop", 4) == 0) {
*code = "(define drop (lambda (n xs)"
- "(if (= n 0) xs"
- "(if (eq xs nil) nil"
+ "(if (= n 0) xs"
+ "(if (eq xs nil) nil"
"(drop (- n 1) (cdr xs))))))";
res = true;
} else if (strlen(str) == 3 && strncmp(str, "zip", 3) == 0) {
*code = "(define zip (lambda (xs ys)"
- "(if (eq xs nil) nil"
- "(if (eq ys nil) nil"
+ "(if (eq xs nil) nil"
+ "(if (eq ys nil) nil"
"(cons (cons (car xs) (car ys)) (zip (cdr xs) (cdr ys)))))))";
res = true;
} else if (strlen(str) == 6 && strncmp(str, "lookup", 6) == 0) {
*code = "(define lookup (lambda (x xs)"
- "(if (eq xs nil) nil"
- "(if (eq (car (car xs)) x)"
- "(car (cdr (car xs)))"
+ "(if (eq xs nil) nil"
+ "(if (eq (car (car xs)) x)"
+ "(car (cdr (car xs)))"
"(lookup x (cdr xs))))))";
res = true;
} else if (strlen(str) == 5 && strncmp(str, "foldr", 5) == 0) {
*code = "(define foldr (lambda (f i xs)"
- "(if (eq xs nil) i"
+ "(if (eq xs nil) i"
"(f (car xs) (foldr f i (cdr xs))))))";
res = true;
} else if (strlen(str) == 5 && strncmp(str, "foldl", 5) == 0) {
@@ -393,6 +393,17 @@ static lbm_value ext_custom(lbm_value *args, lbm_uint argn) {
return res;
}
+static lbm_value ext_event(lbm_value *args, lbm_uint argn) {
+
+ if (argn != 1 || !lbm_is_symbol(args[0])) return ENC_SYM_EERROR;
+ lbm_event_t e;
+ e.type = LBM_EVENT_SYM;
+ e.sym = lbm_dec_sym(args[0]);
+ if (lbm_event(e, NULL, 0)) {
+ return ENC_SYM_TRUE;
+ }
+ return ENC_SYM_NIL;
+}
/* load a file, caller is responsible for freeing the returned string */
char * load_file(char *filename) {
@@ -474,7 +485,7 @@ void lookup_local(eval_context_t *ctx, void *arg1, void *arg2) {
} else {
printf("not found\n");
}
-
+
}
@@ -522,6 +533,11 @@ int main(int argc, char **argv) {
return 0;
}
+ if (!lbm_eval_init_events(20)) {
+ printf("Failed to initialize events\n");
+ return 0;
+ }
+
lbm_set_ctx_done_callback(done_callback);
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
@@ -573,6 +589,12 @@ int main(int argc, char **argv) {
else
printf("Error adding extension.\n");
+ res = lbm_add_extension("event", ext_event);
+ if (res)
+ printf("Extension added.\n");
+ else
+ printf("Error adding extension.\n");
+
/* Start evaluator thread */
if (pthread_create(&lispbm_thd, NULL, eval_thd_wrapper, NULL)) {
@@ -809,15 +831,15 @@ int main(int argc, char **argv) {
int i = 8;
if (strlen(str) >= 8) {
- while (str[i] == ' ') i++;
+ while (str[i] == ' ') i++;
}
char *sym = str + i;
lbm_uint sym_id = 0;
if (lbm_get_symbol_by_name(sym, &sym_id)) {
- lbm_running_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
- lbm_blocked_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
+ lbm_running_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
+ lbm_blocked_iterator(lookup_local, (void*)lbm_enc_sym(sym_id), (void*)sym);
} else {
- printf("symbol does not exist\n");
+ printf("symbol does not exist\n");
}
} else if (strncmp(str, ":undef", 6) == 0) {
lbm_pause_eval_with_gc(50);
diff --git a/lispBM/lispBM/sdlrepl/flake.lisp b/lispBM/lispBM/sdlrepl/flake.lisp
new file mode 100644
index 00000000..70babe90
--- /dev/null
+++ b/lispBM/lispBM/sdlrepl/flake.lisp
@@ -0,0 +1,105 @@
+
+
+(sdl-init)
+
+(define w 500)
+(define h 500)
+
+(defun degtorad (d)
+ (/ (* d 3.141) 180.0))
+
+(defun rotate (p angle)
+ `(,(- (* (car p) (cos (degtorad angle)))
+ (* (cdr p) (sin (degtorad angle))))
+ .
+ ,(+ (* (car p) (sin (degtorad angle)))
+ (* (cdr p) (cos (degtorad angle))))))
+
+
+(defun trans (p v)
+ `(,(+ (car p) (car v)) . ,(+ (cdr p) (cdr v))))
+
+(defun move (p ang s)
+ (let ((v (rotate `( 0 . ,(- s)) ang)))
+ (trans p v)))
+
+(defun event-loop (w)
+ (let ((event (sdl-poll-event)))
+ (if (eq event 'sdl-quit-event)
+ (custom-destruct w)
+ (progn
+ (yield 5000)
+ (event-loop w)))))
+
+(defun line (rend p1 p2)
+ (sdl-draw-line rend (car p1) (cdr p1) (car p2) (cdr p2)))
+
+
+;; (defun draw-figure (rend p ang s)
+;; (if (<= s 1)
+;; ()
+;; (let ((p1 (move p ang s)))
+;; (progn
+;; (line rend p p1)
+;; (draw-figure rend p1 (+ ang 2) (- s 1))
+;; (draw-figure rend p1 (- ang 27) (/ s 2))
+;; (draw-figure rend p1 (+ ang 27) (/ s 2))))))
+
+
+
+(defun draw-figure (rend p ang s)
+ (if (<= s 1)
+ ()
+ (let ((p1 (move p ang s))
+ (p2 (move p (+ ang 60) s))
+ (p3 (move p (+ ang 120) s))
+ (p4 (move p (+ ang 180) s))
+ (p5 (move p (+ ang 240) s))
+ (p6 (move p (+ ang 300) s)))
+ (progn
+ (yield 100)
+ (line rend p p1)
+ (line rend p p2)
+ (line rend p p3)
+ (line rend p p4)
+ (line rend p p5)
+ (line rend p p6)
+ (sdl-present rend)
+ (draw-figure rend p1 (+ ang 10) (/ s 2))
+ (draw-figure rend p2 (+ ang 70) (/ s 2))
+ (draw-figure rend p3 (+ ang 130) (/ s 2))
+ (draw-figure rend p4 (+ ang 190) (/ s 2))
+ (draw-figure rend p5 (+ ang 250) (/ s 2))
+ (draw-figure rend p6 (+ ang 310) (/ s 2))))))
+
+
+(defun start-figure (rend p ang s)
+ (progn
+ (spawn draw-figure rend p (+ ang ) s)
+ (spawn draw-figure rend p (+ ang 60) s)
+ (spawn draw-figure rend p (+ ang 120) s)
+ (spawn draw-figure rend p (+ ang 180) s)
+ (spawn draw-figure rend p (+ ang 240) s)
+ (spawn draw-figure rend p (+ ang 300) s)))
+
+
+
+(defun main ()
+ (let ((win (sdl-create-window "LISP-GFX" 500 500))
+ (rend (sdl-create-soft-renderer win)))
+ (progn
+ (spawn 100 event-loop win)
+ (sdl-renderer-set-color rend 0 0 0)
+ (sdl-clear rend)
+ (sdl-renderer-set-color rend 255 255 255)
+
+ (start-figure rend '(250 . 250) 0 100)
+
+ (sdl-present rend)
+
+ ;;(custom-destruct rend)
+ 'done
+ )))
+
+(defun clean ()
+ (gc))
diff --git a/lispBM/lispBM/sdlrepl/lbm_sdl.c b/lispBM/lispBM/sdlrepl/lbm_sdl.c
index 78b74bbf..eb57eb9d 100644
--- a/lispBM/lispBM/sdlrepl/lbm_sdl.c
+++ b/lispBM/lispBM/sdlrepl/lbm_sdl.c
@@ -162,6 +162,25 @@ static lbm_value ext_sdl_draw_line(lbm_value *args, lbm_uint argn) {
return res;
}
+static lbm_value ext_sdl_draw_point(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_EERROR;
+
+ if (argn == 3 && lbm_type_of(args[0]) == LBM_TYPE_CUSTOM) {
+ lbm_uint *m = (lbm_uint *)lbm_dec_custom(args[0]);
+ SDL_Renderer *rend = (SDL_Renderer*)m[CUSTOM_TYPE_VALUE];
+
+ int32_t x1 = lbm_dec_as_i32(args[1]);
+ int32_t y1 = lbm_dec_as_i32(args[2]);
+ res = ENC_SYM_TRUE;
+ if (SDL_RenderDrawPoint(rend, x1, y1)) {
+ res = ENC_SYM_NIL;
+ }
+ }
+ return res;
+}
+
+
static lbm_value ext_sdl_clear(lbm_value *args, lbm_uint argn) {
lbm_value res = lbm_enc_sym(SYM_TRUE);
@@ -270,6 +289,7 @@ bool lbm_sdl_init(void) {
res = res && lbm_add_extension("sdl-create-window",ext_sdl_create_window);
res = res && lbm_add_extension("sdl-create-soft-renderer", ext_sdl_create_soft_renderer);
res = res && lbm_add_extension("sdl-renderer-set-color", ext_sdl_renderer_set_color);
+ res = res && lbm_add_extension("sdl-draw-point", ext_sdl_draw_point);
res = res && lbm_add_extension("sdl-draw-line", ext_sdl_draw_line);
res = res && lbm_add_extension("sdl-clear", ext_sdl_clear);
res = res && lbm_add_extension("sdl-present", ext_sdl_present);
diff --git a/lispBM/lispBM/sdlrepl/repl.c b/lispBM/lispBM/sdlrepl/repl.c
index 8efb29f7..ac494e4b 100644
--- a/lispBM/lispBM/sdlrepl/repl.c
+++ b/lispBM/lispBM/sdlrepl/repl.c
@@ -30,6 +30,7 @@
#include "extensions/array_extensions.h"
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
+#include "extensions/random_extensions.h"
#include "lbm_custom_type.h"
#include "lbm_sdl.h"
@@ -547,6 +548,12 @@ int main(int argc, char **argv) {
printf("Loading math extensions failed\n");
}
+ if (lbm_random_extensions_init()) {
+ printf("Random extensions loaded\n");
+ } else {
+ printf("Loading random extensions failed\n");
+ }
+
res = lbm_add_extension("block", ext_block);
if (res)
printf("Extension added.\n");
diff --git a/lispBM/lispBM/sdlrepl/sierpinski.lisp b/lispBM/lispBM/sdlrepl/sierpinski.lisp
new file mode 100644
index 00000000..5bd11296
--- /dev/null
+++ b/lispBM/lispBM/sdlrepl/sierpinski.lisp
@@ -0,0 +1,107 @@
+(sdl-init)
+
+(define w 500)
+(define h 500)
+
+(define corners '((10 . 490) (490 . 490) (250 . 10)))
+
+
+(defun degtorad (d)
+ (/ (* d 3.141) 180.0))
+
+(defun rotate (p angle)
+ `(,(- (* (car p) (cos (degtorad angle)))
+ (* (cdr p) (sin (degtorad angle))))
+ .
+ ,(+ (* (car p) (sin (degtorad angle)))
+ (* (cdr p) (cos (degtorad angle))))))
+
+
+(defun trans (p v)
+ `(,(+ (car p) (car v)) . ,(+ (cdr p) (cdr v))))
+
+(defun move (p ang s)
+ (let ((v (rotate `( 0 . ,(- s)) ang)))
+ (trans p v)))
+
+(defun event-loop (w)
+ (let ((event (sdl-poll-event)))
+ (if (eq event 'sdl-quit-event)
+ (custom-destruct w)
+ (progn
+ (yield 5000)
+ (event-loop w)))))
+
+(defun line (rend p1 p2)
+ (sdl-draw-line rend (car p1) (cdr p1) (car p2) (cdr p2)))
+
+(defun point (rend p)
+ (sdl-draw-point rend (car p) (cdr p)))
+
+;; (defun draw-figure (rend p ang s)
+;; (if (<= s 1)
+;; ()
+;; (let ((p1 (move p ang s)))
+;; (progn
+;; (line rend p p1)
+;; (draw-figure rend p1 (+ ang 2) (- s 1))
+;; (draw-figure rend p1 (- ang 27) (/ s 2))
+;; (draw-figure rend p1 (+ ang 27) (/ s 2))))))
+
+
+(defun mid-point (p1 p2)
+ (progn
+ ;(print "p1: " p1)
+ ;(print "p2: " p2)
+ (let ((x (/ (+ (car p1) (car p2)) 2))
+ (y (/ (+ (cdr p1) (cdr p2)) 2)))
+ (cons x y))))
+
+(defun sierpinsky (n rend corners p)
+ (if (= n 0) ()
+ (let ((i (mod (random) 3))
+ (target (ix corners i))
+ (mid (mid-point p target)))
+ (progn
+ ;(print "p " p)
+ ;(print "target " target)
+ ;(print "mid "mid)
+ ;(print "i " i)
+ (point rend mid)
+ (sdl-present rend)
+ (sierpinsky (- n 1) rend corners mid))
+ )))
+
+
+
+
+(defun draw-figure (rend)
+ (progn
+ (seed 3)
+ (map (point rend) corners)
+ (sierpinsky 25000 rend corners (car corners))))
+
+
+
+
+
+
+(defun main ()
+ (let ((win (sdl-create-window "LISP-GFX" 500 500))
+ (rend (sdl-create-soft-renderer win)))
+ (progn
+ (spawn 100 event-loop win)
+ (sdl-renderer-set-color rend 0 0 0)
+ (sdl-clear rend)
+ (sdl-renderer-set-color rend 255 255 255)
+
+ (draw-figure rend)
+
+ (sdl-present rend)
+
+ ;;(custom-destruct rend)
+ 'done
+ )))
+
+(defun clean ()
+ (gc))
diff --git a/lispBM/lispBM/src/eval_cps.c b/lispBM/lispBM/src/eval_cps.c
index e09f2e21..1086d46c 100644
--- a/lispBM/lispBM/src/eval_cps.c
+++ b/lispBM/lispBM/src/eval_cps.c
@@ -1,5 +1,5 @@
/*
- Copyright 2018, 2020, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se
+ Copyright 2018, 2020, 2021, 2022, 2023 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
@@ -164,6 +164,67 @@ static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_RUNNING;
static volatile uint32_t eval_cps_next_state_arg = 0;
static volatile bool eval_cps_state_changed = false;
+static volatile lbm_event_t *lbm_events = NULL;
+static unsigned int lbm_events_head = 0;
+static unsigned int lbm_events_tail = 0;
+static unsigned int lbm_events_max = 0;
+static bool lbm_events_full = false;
+static mutex_t lbm_events_mutex;
+static bool lbm_events_mutex_initialized = false;
+static volatile lbm_cid lbm_event_handler_pid = -1;
+
+lbm_cid lbm_get_event_handler_pid(void) {
+ return lbm_event_handler_pid;
+}
+
+void lbm_set_event_handler_pid(lbm_cid pid) {
+ lbm_event_handler_pid = pid;
+}
+
+bool lbm_event(lbm_event_t event, uint8_t* opt_array, int opt_array_len) {
+
+ if (lbm_event_handler_pid == -1 || !lbm_events) {
+ return false;
+ }
+ mutex_lock(&lbm_events_mutex);
+ if (lbm_events_full) return false;
+ if (opt_array != NULL) {
+ event.array = lbm_malloc((size_t)opt_array_len);
+ event.array_len = opt_array_len;
+ if (event.array == NULL) return false;
+ memcpy(event.array, opt_array, (size_t)opt_array_len);
+ }
+ lbm_events[lbm_events_head] = event;
+
+ lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
+ mutex_unlock(&lbm_events_mutex);
+ return true;
+}
+
+static bool lbm_event_pop(lbm_event_t *event) {
+ mutex_lock(&lbm_events_mutex);
+ if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
+ mutex_unlock(&lbm_events_mutex);
+ return false;
+ }
+ *event = lbm_events[lbm_events_tail];
+ lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
+ lbm_events_full = false;
+ mutex_unlock(&lbm_events_mutex);
+ return true;
+}
+
+static unsigned int lbm_event_num(void) {
+ mutex_lock(&lbm_events_mutex);
+ unsigned int res = lbm_events_max;
+ if (!lbm_events_full) {
+ if (lbm_events_head >= lbm_events_tail) res = lbm_events_head - lbm_events_tail;
+ else res = lbm_events_max - lbm_events_tail + lbm_events_head;
+ }
+ mutex_unlock(&lbm_events_mutex);
+ return res;
+}
+
/*
On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
resolution of the timer used for sleep operations. If this is set
@@ -194,6 +255,7 @@ static eval_context_queue_t queue = {NULL, NULL};
/* one mutex for all queue operations */
mutex_t qmutex;
+bool qmutex_initialized = false;
static void usleep_nonsense(uint32_t us) {
(void) us;
@@ -386,8 +448,6 @@ bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
}
-
-
/****************************************************/
/* Queue functions */
@@ -3126,6 +3186,103 @@ uint32_t lbm_get_eval_state(void) {
return eval_cps_run_state;
}
+static void process_events(void) {
+
+ if (!lbm_events) return;
+
+ if (lbm_event_handler_pid < 0) {
+ lbm_events_head = 0;
+ lbm_events_tail = 0;
+ lbm_events_full = false;
+ return;
+ }
+
+ unsigned int event_cnt = lbm_event_num();
+
+ lbm_event_t e;
+
+ if (event_cnt > 0) {
+ while (lbm_event_pop(&e) && lbm_event_handler_pid >= 0) {
+ if (e.type == LBM_EVENT_SYM) {
+ lbm_find_receiver_and_send(lbm_event_handler_pid, lbm_enc_sym(e.sym));
+ } else if (e.type == LBM_EVENT_SYM_INT) {
+ lbm_value msg = lbm_cons(lbm_enc_sym(e.sym), lbm_enc_i(e.i));
+ if (lbm_is_symbol_merror(msg)) {
+ gc();
+ msg = lbm_cons(lbm_enc_sym(e.sym), lbm_enc_i(e.i));
+ }
+ if (lbm_is_ptr(msg)) {
+ lbm_find_receiver_and_send(lbm_event_handler_pid, msg);
+ }
+ } else if (e.type == LBM_EVENT_SYM_INT_INT) {
+ lbm_value ints = lbm_cons(lbm_enc_i(e.i), lbm_enc_i(e.i2));
+ if (lbm_is_symbol_merror(ints)) {
+ gc();
+ ints = lbm_cons(lbm_enc_i(e.i), lbm_enc_i(e.i2));
+ }
+ lbm_value msg = lbm_cons(lbm_enc_sym(e.sym), ints);
+ if (lbm_is_symbol_merror(msg)) {
+ lbm_gc_mark_phase(1,ints);
+ gc();
+ msg = lbm_cons(lbm_enc_sym(e.sym), ints);
+ }
+ if (lbm_is_ptr(ints) && lbm_is_ptr(msg)) {
+ lbm_find_receiver_and_send(lbm_event_handler_pid, msg);
+ }
+ } else if (e.type == LBM_EVENT_SYM_ARRAY) {
+ lbm_value val;
+ if (!lbm_lift_array(&val, e.array, LBM_TYPE_BYTE, (size_t)e.array_len)) {
+ gc();
+ lbm_lift_array(&val, e.array, LBM_TYPE_BYTE, (size_t)e.array_len);
+ }
+ if (lbm_is_array(val)) {
+ lbm_value msg;
+ msg = lbm_cons(lbm_enc_sym(e.sym), val);
+ if (lbm_is_symbol_merror(msg)) {
+ lbm_gc_mark_phase(1, val);
+ gc();
+ msg = lbm_cons(lbm_enc_sym(e.sym), val);
+ }
+ if (!lbm_is_symbol_merror(msg)) {
+ lbm_find_receiver_and_send(lbm_event_handler_pid, msg);
+ } else {
+ lbm_heap_explicit_free_array(val);
+ }
+ }
+ } else if (e.type == LBM_EVENT_SYM_INT_ARRAY) {
+ lbm_value val;
+ if (!lbm_lift_array(&val, e.array, LBM_TYPE_BYTE, (size_t)e.array_len)) {
+ gc();
+ lbm_lift_array(&val, e.array, LBM_TYPE_BYTE, (size_t)e.array_len);
+ }
+ if (lbm_is_array(val)) {
+ lbm_value msg_data;
+ msg_data = lbm_cons(lbm_enc_i32(e.i),val);
+ if (lbm_is_symbol_merror(msg_data)) {
+ lbm_gc_mark_phase(1,val);
+ gc();
+ msg_data = lbm_cons(lbm_enc_i32(e.i), val);
+ }
+ if (!lbm_is_symbol_merror(msg_data)) {
+ lbm_value msg;
+ msg = lbm_cons(lbm_enc_sym(e.sym), msg_data);
+ if (lbm_is_symbol_merror(msg)) {
+ lbm_gc_mark_phase(1, msg_data);
+ gc();
+ msg = lbm_cons(lbm_enc_sym(e.sym), msg_data);
+ }
+ if (!lbm_is_symbol_merror(msg)) {
+ lbm_find_receiver_and_send(lbm_event_handler_pid, msg);
+ } else {
+ lbm_heap_explicit_free_array(val);
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
/* eval_cps_run can be paused
I think it would be better use a mailbox for
communication between other threads and the run_eval
@@ -3173,6 +3330,7 @@ void lbm_run_eval(void){
// report an error in.
}
} else {
+ process_events();
next_to_run = dequeue_ctx(&sleeping, &us);
}
@@ -3205,6 +3363,16 @@ lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
int lbm_eval_init() {
int res = 1;
+ if (!qmutex_initialized) {
+ mutex_init(&qmutex);
+ }
+ if (!lbm_events_mutex_initialized) {
+ mutex_init(&lbm_events_mutex);
+ }
+
+ mutex_lock(&qmutex);
+ mutex_lock(&lbm_events_mutex);
+
blocked.first = NULL;
blocked.last = NULL;
sleeping.first = NULL;
@@ -3215,7 +3383,8 @@ int lbm_eval_init() {
eval_cps_run_state = EVAL_CPS_STATE_RUNNING;
- mutex_init(&qmutex);
+ mutex_unlock(&qmutex);
+ mutex_unlock(&lbm_events_mutex);
*lbm_get_env_ptr() = ENC_SYM_NIL;
eval_running = true;
@@ -3223,3 +3392,17 @@ int lbm_eval_init() {
return res;
}
+bool lbm_eval_init_events(unsigned int num_events) {
+
+ mutex_lock(&lbm_events_mutex);
+ lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
+
+ if (!lbm_events) return false;
+ lbm_events_max = num_events;
+ lbm_events_head = 0;
+ lbm_events_tail = 0;
+ lbm_events_full = false;
+ lbm_event_handler_pid = -1;
+ mutex_unlock(&lbm_events_mutex);
+ return true;
+}
diff --git a/lispBM/lispBM/src/extensions/array_extensions.c b/lispBM/lispBM/src/extensions/array_extensions.c
index a89fd040..9b0d1bd6 100644
--- a/lispBM/lispBM/src/extensions/array_extensions.c
+++ b/lispBM/lispBM/src/extensions/array_extensions.c
@@ -1,6 +1,6 @@
/*
- Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
- Copyright 2022 Benjamin Vedder
+ Copyright 2022, 2023 Joel Svensson svenssonjoel@yahoo.se
+ Copyright 2022, 2023 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
@@ -49,6 +49,10 @@ static lbm_value array_extension_buffer_get_f32(lbm_value *args, lbm_uint argn);
static lbm_value array_extension_buffer_length(lbm_value *args, lbm_uint argn);
+static lbm_value array_extensions_bufclear(lbm_value *args, lbm_uint argn);
+static lbm_value array_extensions_bufcpy(lbm_value *args, lbm_uint argn);
+static lbm_value array_extensions_bufset_bit(lbm_value *args, lbm_uint argn);
+
bool lbm_array_extensions_init(void) {
if (!lbm_get_symbol_by_name("little-endian", &little_endian)) {
@@ -83,6 +87,10 @@ bool lbm_array_extensions_init(void) {
res = res && lbm_add_extension("bufget-f32", array_extension_buffer_get_f32);
res = res && lbm_add_extension("buflen", array_extension_buffer_length);
+ res = res && lbm_add_extension("bufclear", array_extensions_bufclear);
+ res = res && lbm_add_extension("bufcpy", array_extensions_bufcpy);
+ res = res && lbm_add_extension("bufset-bit", array_extensions_bufset_bit);
+
return res;
}
@@ -960,3 +968,122 @@ lbm_value array_extension_buffer_length(lbm_value *args, lbm_uint argn) {
}
return res;
}
+
+
+static lbm_value array_extensions_bufclear(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_EERROR;
+
+ if ((argn != 1 && argn != 2 && argn != 3 && argn != 4) || !lbm_is_array(args[0])) {
+ return res;
+ }
+
+ lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
+ if (array->elt_type != LBM_TYPE_BYTE) {
+ return res;
+ }
+
+ uint8_t clear_byte = 0;
+ if (argn >= 2) {
+ if (!lbm_is_number(args[1])) {
+ return res;
+ }
+ clear_byte = (uint8_t)lbm_dec_as_u32(args[1]);
+ }
+
+ unsigned int start = 0;
+ if (argn >= 3) {
+ if (!lbm_is_number(args[2])) {
+ return res;
+ }
+ unsigned int start_new = lbm_dec_as_u32(args[2]);
+ if (start_new < array->size) {
+ start = start_new;
+ } else {
+ return res;
+ }
+ }
+
+ unsigned int len = array->size - start;
+ if (argn >= 4) {
+ if (!lbm_is_number(args[3])) {
+ return res;
+ }
+ unsigned int len_new = lbm_dec_as_u32(args[3]);
+ if (len_new <= len) {
+ len = len_new;
+ }
+ }
+
+ memset((char*)array->data + start, clear_byte, len);
+ res = ENC_SYM_TRUE;
+
+ return res;
+}
+
+static lbm_value array_extensions_bufcpy(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_EERROR;
+
+ if (argn != 5 || !lbm_is_array(args[0]) || !lbm_is_number(args[1])
+ || !lbm_is_array(args[2]) || !lbm_is_number(args[3]) || !lbm_is_number(args[4])) {
+ return res;
+ }
+
+ lbm_array_header_t *array1 = (lbm_array_header_t *)lbm_car(args[0]);
+ if (array1->elt_type != LBM_TYPE_BYTE) {
+ return res;
+ }
+
+ unsigned int start1 = lbm_dec_as_u32(args[1]);
+
+ lbm_array_header_t *array2 = (lbm_array_header_t *)lbm_car(args[2]);
+ if (array2->elt_type != LBM_TYPE_BYTE) {
+ return res;
+ }
+
+ unsigned int start2 = lbm_dec_as_u32(args[3]);
+ unsigned int len = lbm_dec_as_u32(args[4]);
+
+ if (start1 < array1->size && start2 < array2->size) {
+ if (len > (array1->size - start1)) {
+ len = (array1->size - start1);
+ }
+ if (len > (array2->size - start2)) {
+ len = (array2->size - start2);
+ }
+
+ memcpy((char*)array1->data + start1, (char*)array2->data + start2, len);
+ }
+
+ res = ENC_SYM_TRUE;
+
+ return res;
+}
+
+static lbm_value array_extensions_bufset_bit(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_EERROR;
+
+ if (argn != 3 || !lbm_is_array(args[0]) ||
+ !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_TYPE_BYTE) {
+ return res;
+ }
+
+ unsigned int pos = lbm_dec_as_u32(args[1]);
+ unsigned int bit = lbm_dec_as_u32(args[2]) ? 1 : 0;
+
+ unsigned int bytepos = pos / 8;
+ unsigned int bitpos = pos % 8;
+
+ if (bytepos < array->size) {
+ ((uint8_t*)array->data)[bytepos] &= (uint8_t)~(1 << bitpos);
+ ((uint8_t*)array->data)[bytepos] |= (uint8_t)(bit << bitpos);
+ }
+
+ res = ENC_SYM_TRUE;
+
+ return res;
+}
diff --git a/lispBM/lispBM/src/extensions/math_extensions.c b/lispBM/lispBM/src/extensions/math_extensions.c
index c125b6e1..033676f8 100644
--- a/lispBM/lispBM/src/extensions/math_extensions.c
+++ b/lispBM/lispBM/src/extensions/math_extensions.c
@@ -1,6 +1,6 @@
/*
- Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
- Copyright 2022 Benjamin Vedder
+ Copyright 2022, 2023 Joel Svensson svenssonjoel@yahoo.se
+ Copyright 2022, 2023 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
@@ -23,20 +23,6 @@
// 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 ENC_SYM_EERROR;}
-#define CHECK_ARGN(n) if (argn != n) {return ENC_SYM_EERROR;}
-#define CHECK_ARGN_NUMBER(n) if (argn != n || !is_number_all(args, argn)) {return ENC_SYM_EERROR;}
-
-
void rotate_vector3(float *input, float *rotation, float *output, bool reverse) {
float s1, c1, s2, c2, s3, c3;
@@ -64,9 +50,9 @@ void rotate_vector3(float *input, float *rotation, float *output, bool reverse)
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;
+ 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;
@@ -81,131 +67,149 @@ void rotate_vector3(float *input, float *rotation, float *output, bool reverse)
// 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_sin(lbm_value *args, lbm_uint argn) {
+ LBM_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_cos(lbm_value *args, lbm_uint argn) {
+ LBM_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_tan(lbm_value *args, lbm_uint argn) {
+ LBM_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_asin(lbm_value *args, lbm_uint argn) {
+ LBM_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_acos(lbm_value *args, lbm_uint argn) {
+ LBM_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_atan(lbm_value *args, lbm_uint argn) {
+ LBM_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_atan2(lbm_value *args, lbm_uint argn) {
+ LBM_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_pow(lbm_value *args, lbm_uint argn) {
+ LBM_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_sqrt(lbm_value *args, lbm_uint argn) {
+ LBM_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_log(lbm_value *args, lbm_uint argn) {
+ LBM_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_log10(lbm_value *args, lbm_uint argn) {
+ LBM_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 = ENC_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_floor(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_ARGN_NUMBER(1)
+ return lbm_enc_float(floorf(lbm_dec_as_float(args[0])));
}
-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 = ENC_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_ceil(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_ARGN_NUMBER(1)
+ return lbm_enc_float(ceilf(lbm_dec_as_float(args[0])));
}
-static lbm_value ext_vec3_rotf(lbm_value *args, lbm_uint argn) {
- CHECK_NUMBER_ALL();
- if (argn != 6 && argn != 7) {
- return ENC_SYM_EERROR;
- }
+static lbm_value ext_round(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_ARGN_NUMBER(1)
+ return lbm_enc_float(roundf(lbm_dec_as_float(args[0])));
+}
- 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];
+static lbm_value ext_deg2rad(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_NUMBER_ALL();
- bool reverse = false;
- if (argn == 7) {
- reverse = lbm_dec_as_i32(args[6]);
- }
+ if (argn == 1) {
+ return lbm_enc_float(DEG2RAD_f(lbm_dec_as_float(args[0])));
+ } else {
+ lbm_value out_list = ENC_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;
+ }
+}
- rotate_vector3(input, rotation, output, reverse);
+static lbm_value ext_rad2deg(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_NUMBER_ALL();
- lbm_value out_list = ENC_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);
+ if (argn == 1) {
+ return lbm_enc_float(RAD2DEG_f(lbm_dec_as_float(args[0])));
+ } else {
+ lbm_value out_list = ENC_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;
+ }
+}
- return out_list;
+static lbm_value ext_vec3_rot(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_NUMBER_ALL();
+ if (argn != 6 && argn != 7) {
+ return ENC_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 = ENC_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("sin", ext_sinf);
- res = res && lbm_add_extension("cos", ext_cosf);
- res = res && lbm_add_extension("tan", ext_tanf);
- res = res && lbm_add_extension("asin", ext_asinf);
- res = res && lbm_add_extension("acos", ext_acosf);
- res = res && lbm_add_extension("atan", ext_atanf);
- res = res && lbm_add_extension("atan2", ext_atan2f);
- res = res && lbm_add_extension("pow", ext_powf);
- res = res && lbm_add_extension("sqrt", ext_sqrtf);
- res = res && lbm_add_extension("log", ext_logf);
- res = res && lbm_add_extension("log10", ext_log10f);
- res = res && lbm_add_extension("deg2rad", ext_deg2radf);
- res = res && lbm_add_extension("rad2deg", ext_rad2degf);
- res = res && lbm_add_extension("vec3-rot", ext_vec3_rotf);
-
+ res = res && lbm_add_extension("sin", ext_sin);
+ res = res && lbm_add_extension("cos", ext_cos);
+ res = res && lbm_add_extension("tan", ext_tan);
+ res = res && lbm_add_extension("asin", ext_asin);
+ res = res && lbm_add_extension("acos", ext_acos);
+ res = res && lbm_add_extension("atan", ext_atan);
+ res = res && lbm_add_extension("atan2", ext_atan2);
+ res = res && lbm_add_extension("pow", ext_pow);
+ res = res && lbm_add_extension("sqrt", ext_sqrt);
+ res = res && lbm_add_extension("log", ext_log);
+ res = res && lbm_add_extension("log10", ext_log10);
+ res = res && lbm_add_extension("floor", ext_floor);
+ res = res && lbm_add_extension("ceil", ext_ceil);
+ res = res && lbm_add_extension("round", ext_round);
+ res = res && lbm_add_extension("deg2rad", ext_deg2rad);
+ res = res && lbm_add_extension("rad2deg", ext_rad2deg);
+ res = res && lbm_add_extension("vec3-rot", ext_vec3_rot);
return res;
}
diff --git a/lispBM/lispBM/src/extensions/matvec_extensions.c b/lispBM/lispBM/src/extensions/matvec_extensions.c
new file mode 100644
index 00000000..faaad49c
--- /dev/null
+++ b/lispBM/lispBM/src/extensions/matvec_extensions.c
@@ -0,0 +1,354 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#include "extensions.h"
+#include "lbm_utils.h"
+#include "lbm_custom_type.h"
+
+#include
+
+static const char *vector_float_desc = "Vector-Float";
+static const char *matrix_float_desc = "Matrix-Float";
+
+typedef struct {
+ unsigned int size;
+ float data[1];
+} vector_float_t;
+
+static bool common_destructor(lbm_uint value) {
+ lbm_free((void*)value);
+ return true;
+}
+
+static lbm_value vector_float_allocate(lbm_uint size) {
+ vector_float_t *mem = lbm_malloc( 1 * sizeof(lbm_uint) +
+ size * sizeof(float));
+ if (!mem) return ENC_SYM_MERROR;
+ mem->size = size;
+ lbm_value res;
+ lbm_custom_type_create((lbm_uint)mem,
+ common_destructor,
+ vector_float_desc,
+ &res);
+ return res;
+}
+
+static bool is_vector_float(lbm_value v) {
+ return ((lbm_uint)lbm_get_custom_descriptor(v) == (lbm_uint)vector_float_desc);
+}
+
+/* **************************************************
+ * Matrices stored in row-major form
+ */
+
+typedef struct {
+ lbm_uint rows;
+ lbm_uint cols;
+ float data[1];
+} matrix_float_t;
+
+static lbm_value matrix_float_allocate(unsigned int rows, unsigned int cols) {
+ matrix_float_t *mem = lbm_malloc(1 * sizeof(lbm_uint) +
+ 1 * sizeof(lbm_uint) +
+ rows * cols * sizeof(float));
+ if (!mem) return ENC_SYM_MERROR;
+ mem->rows = rows;
+ mem->cols = cols;
+ lbm_value res;
+ lbm_custom_type_create((lbm_uint)mem,
+ common_destructor,
+ matrix_float_desc,
+ &res);
+ return res;
+}
+
+static bool is_matrix_float(lbm_value m) {
+ return ((lbm_uint)lbm_get_custom_descriptor(m) == (lbm_uint)matrix_float_desc);
+}
+
+/* **************************************************
+ * Extension implementations
+ */
+
+static lbm_value ext_vector(lbm_value *args, lbm_uint argn) {
+
+ LBM_CHECK_NUMBER_ALL();
+
+ if (argn < 1) return ENC_SYM_TERROR;
+
+ lbm_value vec = vector_float_allocate(argn);
+ if (lbm_is_error(vec)) return vec;
+
+ vector_float_t *lvec = (vector_float_t*)lbm_get_custom_value(vec);
+
+ for (lbm_uint i = 0; i < argn; i ++) {
+ lvec->data[i] = lbm_dec_as_float(args[i]);
+ }
+ return vec;
+}
+
+static lbm_value ext_list_to_vector(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_TERROR;
+
+ if (argn == 1 &&
+ lbm_is_list(args[0])) {
+
+ bool nums = true;
+ unsigned int len = lbm_list_length_pred(args[0], &nums, lbm_is_number);
+
+ if (len > 0 && nums) {
+ lbm_value vec = vector_float_allocate(len);
+ if (lbm_is_error(vec)) return vec;
+ vector_float_t *lvec = (vector_float_t*)lbm_get_custom_value(vec);
+
+ lbm_value curr = args[0];
+ unsigned int i = 0;
+ while (lbm_is_cons(curr)) {
+ lvec->data[i] = lbm_dec_as_float(lbm_car(curr));
+ i ++;
+ curr = lbm_cdr(curr);
+ }
+ res = vec;
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_vector_to_list(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_TERROR;
+ if (argn == 1 && is_vector_float(args[0])) {
+ vector_float_t *lvec = (vector_float_t*)lbm_get_custom_value(args[0]);
+
+ lbm_value result = lbm_heap_allocate_list(lvec->size);
+ if (lbm_is_cons(result)) {
+ lbm_value curr = result;
+ for (lbm_uint i = 0; i < lvec->size; i ++) {
+ lbm_value f_val = lbm_enc_float(lvec->data[i]);
+ if (lbm_is_error(f_val)) {
+ result = f_val;
+ break;
+ }
+ lbm_set_car(curr, f_val);
+ curr = lbm_cdr(curr);
+ }
+ res = result;
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_vproj(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_TERROR;
+ if (argn == 2 &&
+ is_vector_float(args[0]) &&
+ lbm_is_number(args[1])) {
+ vector_float_t *vec = (vector_float_t*)lbm_get_custom_value(args[0]);
+ uint32_t i = lbm_dec_as_u32(args[1]);
+ if (i < vec->size) {
+ res = lbm_enc_float(vec->data[i]);
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_axpy(lbm_value *args, lbm_uint argn ) {
+
+ lbm_value res = ENC_SYM_TERROR;
+
+ if (argn != 3) return res;
+ lbm_value a = args[0];
+ lbm_value x = args[1];
+ lbm_value y = args[2];
+
+ if (is_vector_float(x) && is_vector_float(y) && lbm_is_number(a)) {
+
+ float alpha = lbm_dec_as_float(a);
+ vector_float_t *X = (vector_float_t*)lbm_get_custom_value(x);
+ vector_float_t *Y = (vector_float_t*)lbm_get_custom_value(y);
+
+ if (X->size == Y->size) {
+
+ unsigned int res_size = X->size;
+
+ res = vector_float_allocate(res_size);
+ if (!lbm_is_symbol_merror(res)) {
+
+ vector_float_t *R = (vector_float_t*)lbm_get_custom_value(res);
+
+ for (unsigned i = 0; i < res_size; i ++) {
+ R->data[i] = alpha * X->data[i] + Y->data[i];
+ }
+ }
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_dot(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_TERROR;
+
+ if (argn != 2) return res;
+ lbm_value x = args[0];
+ lbm_value y = args[1];
+
+ if (is_vector_float(x) && is_vector_float(y)) {
+
+ vector_float_t *X = (vector_float_t*)lbm_get_custom_value(x);
+ vector_float_t *Y = (vector_float_t*)lbm_get_custom_value(y);
+
+ if (X->size == Y->size) {
+ unsigned int res_size = X->size;
+
+ float f_res = 0;
+ for (unsigned i = 0; i < res_size; i ++) {
+ f_res += X->data[i] * Y->data[i];
+ }
+ res = lbm_enc_float(f_res);
+ }
+ }
+ return res;
+}
+
+static float vector_float_mag(vector_float_t *v) {
+ float mag = 0.0;
+ for (unsigned int i = 0; i < v->size; i ++) {
+ mag += (v->data[i] * v->data[i]);
+ }
+ mag = sqrtf(mag);
+ return mag;
+}
+
+static lbm_value ext_mag(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_TERROR;
+
+ if (argn == 1 &&
+ is_vector_float(args[0])) {
+ vector_float_t *v = (vector_float_t *)lbm_get_custom_value(args[0]);
+ float mag = vector_float_mag(v);
+ res = lbm_enc_float(mag);
+ }
+ return res;
+}
+
+static lbm_value ext_vmult(lbm_value *args, lbm_uint argn) {
+ lbm_value res = ENC_SYM_TERROR;
+ if (argn == 2 &&
+ lbm_is_number(args[0]) &&
+ is_vector_float(args[1])) {
+
+ float alpha = lbm_dec_as_float(args[0]);
+ vector_float_t *x = (vector_float_t *)lbm_get_custom_value(args[1]);
+ lbm_value y = vector_float_allocate(x->size);
+ res = y;
+ if (!lbm_is_error(y)) {
+ vector_float_t *y_vec = (vector_float_t *)lbm_get_custom_value(y);
+ for (unsigned int i = 0; i < x->size; i ++) {
+ y_vec->data[i] = alpha * x->data[i];
+ }
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_list_to_matrix(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_TERROR;
+
+ if (argn == 2 &&
+ lbm_is_number(args[0]) &&
+ lbm_is_list(args[1])) {
+
+ bool nums = true;
+ unsigned int len = lbm_list_length_pred(args[1], &nums, lbm_is_number);
+
+ if (len > 0 && nums) {
+ uint32_t cols = lbm_dec_as_u32(args[0]);
+ uint32_t rows = len / cols;
+
+ if (len % cols == 0) {
+ lbm_value mat = matrix_float_allocate(rows, cols);
+ if (lbm_is_error(mat)) return mat;
+ matrix_float_t *lmat = (matrix_float_t*)lbm_get_custom_value(mat);
+
+ lbm_value curr = args[1];
+ unsigned int i = 0;
+ while (lbm_is_cons(curr)) {
+ float f = lbm_dec_as_float(lbm_car(curr));
+ lmat->data[i] = lbm_dec_as_float(lbm_car(curr));
+ i ++;
+ curr = lbm_cdr(curr);
+ }
+ res = mat;
+ }
+ }
+ }
+ return res;
+}
+
+static lbm_value ext_matrix_to_list(lbm_value *args, lbm_uint argn) {
+
+ lbm_value res = ENC_SYM_TERROR;
+ if (argn == 1 && is_matrix_float(args[0])) {
+ matrix_float_t *lmat = (matrix_float_t*)lbm_get_custom_value(args[0]);
+ unsigned int size = lmat->rows * lmat->cols;
+
+ res = lbm_heap_allocate_list(size);
+ if (lbm_is_cons(res)) {
+ lbm_value curr = res;
+ for (unsigned int i = 0; i < size; i ++) {
+ lbm_value f_val = lbm_enc_float(lmat->data[i]);
+ if (lbm_is_error(f_val)) {
+ res = f_val;
+ break;
+ }
+ lbm_set_car(curr, f_val);
+ curr = lbm_cdr(curr);
+ }
+ }
+ }
+ return res;
+}
+
+
+
+/* **************************************************
+ * Initialization
+ */
+
+bool lbm_matvec_extensions_init(void) {
+ bool res = true;
+
+ // Vectors
+ res = res && lbm_add_extension("vector", ext_vector);
+ res = res && lbm_add_extension("list-to-vector", ext_list_to_vector);
+ res = res && lbm_add_extension("vector-to-list", ext_vector_to_list);
+ res = res && lbm_add_extension("vproj", ext_vproj);
+ res = res && lbm_add_extension("axpy", ext_axpy);
+ res = res && lbm_add_extension("dot", ext_dot);
+ res = res && lbm_add_extension("mag", ext_mag);
+ res = res && lbm_add_extension("vmult", ext_vmult);
+
+ // Matrices
+ res = res && lbm_add_extension("list-to-matrix", ext_list_to_matrix);
+ res = res && lbm_add_extension("matrix-to-list", ext_matrix_to_list);
+
+ return res;
+}
+
diff --git a/lispBM/lispBM/src/extensions/random_extensions.c b/lispBM/lispBM/src/extensions/random_extensions.c
new file mode 100644
index 00000000..64b7d8cf
--- /dev/null
+++ b/lispBM/lispBM/src/extensions/random_extensions.c
@@ -0,0 +1,49 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#include
+#include
+
+#define M 268435183 //(1 << 28)
+#define A 268435043
+#define C 268434949
+
+
+static lbm_uint random_seed = 177739;
+
+static lbm_value ext_seed(lbm_value *args, lbm_uint argn) {
+
+ LBM_CHECK_ARGN_NUMBER(1);
+
+ random_seed = lbm_dec_as_u32(args[0]);
+ return ENC_SYM_TRUE;
+}
+
+static lbm_value ext_random(lbm_value *args, lbm_uint argn) {
+ (void)args;
+ (void)argn;
+ random_seed = (A * random_seed + C) % M;
+ return lbm_enc_u(random_seed);
+}
+
+bool lbm_random_extensions_init(void) {
+
+ bool res = true;
+ res = res && lbm_add_extension("seed", ext_seed);
+ res = res && lbm_add_extension("random", ext_random);
+ return res;
+}
diff --git a/lispBM/lispBM/src/extensions/runtime_extensions.c b/lispBM/lispBM/src/extensions/runtime_extensions.c
new file mode 100644
index 00000000..c9c39682
--- /dev/null
+++ b/lispBM/lispBM/src/extensions/runtime_extensions.c
@@ -0,0 +1,67 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#include
+#include
+#include
+#include
+#include
+
+lbm_value ext_eval_set_quota(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_ARGN_NUMBER(1);
+ uint32_t q = lbm_dec_as_u32(args[0]);
+ lbm_set_eval_step_quota(q);
+ return ENC_SYM_TRUE;
+}
+
+lbm_value ext_memory_num_free(lbm_value *args, lbm_uint argn) {
+ (void)args;
+ (void)argn;
+ lbm_uint n = lbm_memory_num_free();
+ return lbm_enc_i((lbm_int)n);
+}
+
+lbm_value ext_memory_longest_free(lbm_value *args, lbm_uint argn) {
+ (void)args;
+ (void)argn;
+ lbm_uint n = lbm_memory_longest_free();
+ return lbm_enc_i((lbm_int)n);
+}
+
+lbm_value ext_memory_size(lbm_value *args, lbm_uint argn) {
+ (void)args;
+ (void)argn;
+ lbm_uint n = lbm_memory_num_words();
+ return lbm_enc_i((lbm_int)n);
+}
+
+lbm_value ext_memory_word_size(lbm_value *args, lbm_uint argn) {
+ (void)args;
+ (void)argn;
+ return lbm_enc_i((lbm_int)sizeof(lbm_uint));
+}
+
+bool lbm_runtime_extensions_init(void) {
+
+ bool res = true;
+ res = res && lbm_add_extension("set-eval-quota", ext_eval_set_quota);
+ res = res && lbm_add_extension("mem-num-free", ext_memory_num_free);
+ res = res && lbm_add_extension("mem-longest-free", ext_memory_longest_free);
+ res = res && lbm_add_extension("mem-size", ext_memory_size);
+ res = res && lbm_add_extension("word-size", ext_memory_word_size);
+ return res;
+}
diff --git a/lispBM/lispBM/src/extensions/string_extensions.c b/lispBM/lispBM/src/extensions/string_extensions.c
index 45f11cb3..c0e0fdc0 100644
--- a/lispBM/lispBM/src/extensions/string_extensions.c
+++ b/lispBM/lispBM/src/extensions/string_extensions.c
@@ -1,6 +1,6 @@
/*
- Copyright 2022 Joel Svensson svenssonjoel@yahoo.se
- Copyright 2022 Benjamin Vedder
+ Copyright 2022, 2023 Joel Svensson svenssonjoel@yahoo.se
+ Copyright 2022, 2023 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
@@ -21,6 +21,7 @@
#include "heap.h"
#include "fundamental.h"
#include "lbm_c_interop.h"
+#include "print.h"
#include
@@ -31,6 +32,15 @@
#define MAX(a,b) (((a)>(b))?(a):(b))
#endif
+static char print_val_buffer[256];
+
+static size_t strlen_max(const char *s, size_t maxlen) {
+ size_t i;
+ for (i = 0; i < maxlen; i ++) {
+ if (s[i] == 0) break;
+ }
+ return i;
+}
static lbm_value ext_str_from_n(lbm_value *args, lbm_uint argn) {
if ((argn != 1 && argn != 2) || !lbm_is_number(args[0])) {
@@ -52,7 +62,7 @@ static lbm_value ext_str_from_n(lbm_value *args, lbm_uint argn) {
switch (lbm_type_of(args[0])) {
case LBM_TYPE_FLOAT:
if (!format) {
- format = "%f";
+ format = "%g";
}
len = (size_t)snprintf(buffer, sizeof(buffer), format, (double)lbm_dec_as_float(args[0]));
break;
@@ -81,18 +91,18 @@ static lbm_value ext_str_from_n(lbm_value *args, lbm_uint argn) {
}
static lbm_value ext_str_merge(lbm_value *args, lbm_uint argn) {
- int len_tot = 0;
+ size_t 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);
+ len_tot += strlen(str);
} else {
return ENC_SYM_EERROR;
}
}
lbm_value res;
- if (lbm_create_array(&res, LBM_TYPE_CHAR, (lbm_uint)len_tot + 1)) {
+ if (lbm_create_array(&res, LBM_TYPE_CHAR, 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++) {
@@ -121,10 +131,10 @@ static lbm_value ext_str_to_i(lbm_value *args, lbm_uint argn) {
return ENC_SYM_EERROR;
}
- base = lbm_dec_as_i32(args[1]);
+ base = (int)lbm_dec_as_u32(args[1]);
}
- return lbm_enc_i(strtol(str, NULL, base));
+ return lbm_enc_i32(strtol(str, NULL, base));
}
static lbm_value ext_str_to_f(lbm_value *args, lbm_uint argn) {
@@ -152,13 +162,13 @@ static lbm_value ext_str_part(lbm_value *args, lbm_uint argn) {
size_t len = strlen(str);
- uint32_t start = lbm_dec_as_u32(args[1]);
+ unsigned int start = lbm_dec_as_u32(args[1]);
if (start >= len) {
return ENC_SYM_EERROR;
}
- uint32_t n = (uint32_t)len - start;
+ unsigned int n = len - start;
if (argn == 3) {
if (!lbm_is_number(args[2])) {
return ENC_SYM_EERROR;
@@ -215,7 +225,7 @@ static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
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);
+ memcpy(arr->data, str + ind_now, (unsigned int)step_now);
((char*)(arr->data))[step_now] = '\0';
res = lbm_cons(tok, res);
} else {
@@ -224,13 +234,6 @@ static lbm_value ext_str_split(lbm_value *args, lbm_uint argn) {
}
return res;
- } else if (!split) {
- // This case is here to make static analysis happy.
- // The SA tools does not seem to understand that there
- // is a relationship between the split and step variables
- // such that if split is null step will be greater than zero and if
- // step is zero, split will be non-nil.
- return ENC_SYM_MERROR;
} else {
lbm_value res = ENC_SYM_NIL;
const char *s = str;
@@ -278,20 +281,20 @@ static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
}
// See https://stackoverflow.com/questions/779875/what-function-is-to-replace-a-substring-from-a-string-in-c
- //char *result; // the return string
+ char *result; // the return string
char *ins; // the next insert point
char *tmp; // varies
- 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
+ size_t len_rep; // length of rep (the string to remove)
+ size_t len_with; // length of with (the string to replace rep with)
+ size_t len_front; // distance between rep and end of last rep
int count; // number of replacements
- len_rep = (int)strlen(rep);
+ len_rep = strlen(rep);
if (len_rep == 0) {
return args[0]; // empty rep causes infinite loop during count
}
- len_with = (int)strlen(with);
+ len_with = strlen(with);
// count the number of replacements needed
ins = orig;
@@ -299,12 +302,11 @@ static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
ins = tmp + len_rep;
}
- size_t len_res = strlen(orig) + (size_t)((len_with - len_rep) * count + 1);
+ size_t len_res = strlen(orig) + (len_with - len_rep) * (unsigned int)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;
- tmp = (char*)arr->data; // result is never accessed so should not be needed.
+ tmp = result = (char*)arr->data;
} else {
return ENC_SYM_MERROR;
}
@@ -316,8 +318,8 @@ static lbm_value ext_str_replace(lbm_value *args, lbm_uint argn) {
// 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;
+ len_front = (size_t)ins - (unsigned int)orig;
+ tmp = strncpy(tmp, orig, len_front) + len_front;
tmp = strcpy(tmp, with) + len_with;
orig += len_front + len_rep; // move to next "end of rep"
}
@@ -336,11 +338,11 @@ static lbm_value ext_str_to_lower(lbm_value *args, lbm_uint argn) {
return ENC_SYM_TERROR;
}
- int len = (int)strlen(orig);
+ size_t len = strlen(orig);
lbm_value lbm_res;
- if (lbm_create_array(&lbm_res, LBM_TYPE_CHAR, (lbm_uint)len + 1)) {
+ if (lbm_create_array(&lbm_res, LBM_TYPE_CHAR, len + 1)) {
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(lbm_res);
- for (int i = 0;i < len;i++) {
+ for (unsigned int i = 0;i < len;i++) {
((char*)(arr->data))[i] = (char)tolower(orig[i]);
}
((char*)(arr->data))[len] = '\0';
@@ -375,7 +377,8 @@ static lbm_value ext_str_to_upper(lbm_value *args, lbm_uint argn) {
}
static lbm_value ext_str_cmp(lbm_value *args, lbm_uint argn) {
- if (argn != 2) {
+ if (argn != 2 && argn != 3) {
+ lbm_set_error_reason((char*)lbm_error_str_num_args);
return ENC_SYM_EERROR;
}
@@ -389,30 +392,125 @@ static lbm_value ext_str_cmp(lbm_value *args, lbm_uint argn) {
return ENC_SYM_EERROR;
}
- return lbm_enc_i(strcmp(str1, str2));
+ int n = -1;
+ if (argn == 3) {
+ if (!lbm_is_number(args[2])) {
+ return ENC_SYM_EERROR;
+ }
+
+ n = lbm_dec_as_i32(args[2]);
+ }
+
+ if (n > 0) {
+ return lbm_enc_i(strncmp(str1, str2, (unsigned int)n));
+ } else {
+ return lbm_enc_i(strcmp(str1, str2));
+ }
}
-static lbm_value ext_str_n_cmp(lbm_value *args, lbm_uint argn) {
- if (argn != 3) {
+// TODO: This is very similar to ext-print. Maybe they can share code.
+static lbm_value to_str(char *delimiter, lbm_value *args, lbm_uint argn) {
+ const int str_len = 300;
+ char *str = lbm_malloc(str_len);
+ if (!str) {
+ return ENC_SYM_MERROR;
+ }
+
+ int str_ofs = 0;
+
+ for (lbm_uint i = 0; i < argn; i ++) {
+ lbm_value t = args[i];
+ int max = str_len - str_ofs - 1;
+
+ 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_TYPE_CHAR: {
+ int chars = 0;
+ if (str_ofs == 0) {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%s", (char*)array->data);
+ } else {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%s%s", delimiter, (char*)array->data);
+ }
+ if (chars >= max) {
+ str_ofs += max;
+ } else {
+ str_ofs += chars;
+ }
+ } break;
+ default:
+ return ENC_SYM_NIL;
+ break;
+ }
+ } else if (lbm_type_of(t) == LBM_TYPE_CHAR) {
+ int chars = 0;
+ if (str_ofs == 0) {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%c", lbm_dec_char(t));
+ } else {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%s%c", delimiter, lbm_dec_char(t));
+ }
+ if (chars >= max) {
+ str_ofs += max;
+ } else {
+ str_ofs += chars;
+ }
+ } else {
+ lbm_print_value(print_val_buffer, 256, t);
+
+ int chars = 0;
+ if (str_ofs == 0) {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%s", print_val_buffer);
+ } else {
+ chars = snprintf(str + str_ofs, (unsigned int)max, "%s%s", delimiter, print_val_buffer);
+ }
+ if (chars >= max) {
+ str_ofs += max;
+ } else {
+ str_ofs += chars;
+ }
+ }
+ }
+
+ lbm_value res;
+ if (lbm_create_array(&res, LBM_TYPE_CHAR, (lbm_uint)str_ofs + 1)) {
+ lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
+ strncpy((char*)arr->data, str, (unsigned int)str_ofs + 1);
+ lbm_free(str);
+ return res;
+ } else {
+ lbm_free(str);
+ return ENC_SYM_MERROR;
+ }
+}
+
+static lbm_value ext_to_str(lbm_value *args, lbm_uint argn) {
+ return to_str(" ", args, argn);
+}
+
+static lbm_value ext_to_str_delim(lbm_value *args, lbm_uint argn) {
+ if (argn < 1) {
return ENC_SYM_EERROR;
}
- char *str1 = lbm_dec_str(args[0]);
- if (!str1) {
+ char *delim = lbm_dec_str(args[0]);
+ if (!delim) {
return ENC_SYM_EERROR;
}
- char *str2 = lbm_dec_str(args[1]);
- if (!str2) {
+ return to_str(delim, args + 1, argn - 1);
+}
+
+static lbm_value ext_str_len(lbm_value *args, lbm_uint argn) {
+ LBM_CHECK_ARGN(1);
+
+ char *str = lbm_dec_str(args[0]);
+ if (!str) {
return ENC_SYM_EERROR;
}
- if (lbm_is_number(args[2])) {
- int n = lbm_dec_as_i32(args[2]);
+ lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
- return lbm_enc_i(strncmp(str1, str2, n));
- }
- return ENC_SYM_TERROR;
+ return lbm_enc_i((int)strlen_max(str, array->size));
}
@@ -430,6 +528,9 @@ bool lbm_string_extensions_init(void) {
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);
- res = res && lbm_add_extension("str-n-cmp", ext_str_n_cmp);
+ res = res && lbm_add_extension("to-str", ext_to_str);
+ res = res && lbm_add_extension("to-str-delim", ext_to_str_delim);
+ res = res && lbm_add_extension("str-len", ext_str_len);
+
return res;
}
diff --git a/lispBM/lispBM/src/fundamental.c b/lispBM/lispBM/src/fundamental.c
index 32a06f8f..bf359396 100644
--- a/lispBM/lispBM/src/fundamental.c
+++ b/lispBM/lispBM/src/fundamental.c
@@ -1,6 +1,6 @@
/*
- Copyright 2019, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se
- 2022 Benjamin Vedder
+ Copyright 2019, 2021, 2022, 2023 Joel Svensson svenssonjoel@yahoo.se
+ 2022 Benjamin Vedder
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -1518,6 +1518,16 @@ static lbm_value fundamental_range(lbm_value *args, lbm_uint nargs, eval_context
return r_list;
}
+static lbm_value fundamental_reg_event_handler(lbm_value *args, lbm_uint argn, eval_context_t *ctx) {
+ (void)ctx;
+ if (argn != 1 || !lbm_is_number(args[0])) {
+ return ENC_SYM_EERROR;
+ }
+
+ lbm_set_event_handler_pid((lbm_cid)lbm_dec_i(args[0]));
+ return ENC_SYM_TRUE;
+}
+
const fundamental_fun fundamental_table[] =
{ fundamental_add,
fundamental_sub,
@@ -1577,5 +1587,6 @@ const fundamental_fun fundamental_table[] =
fundamental_list_length,
fundamental_range,
fundamental_num_not_eq,
- fundamental_not_eq
+ fundamental_not_eq,
+ fundamental_reg_event_handler
};
diff --git a/lispBM/lispBM/src/heap.c b/lispBM/lispBM/src/heap.c
index 2866130e..f20939be 100644
--- a/lispBM/lispBM/src/heap.c
+++ b/lispBM/lispBM/src/heap.c
@@ -188,11 +188,10 @@ char *lbm_dec_str(lbm_value val) {
char *res = 0;
if (lbm_type_of(val) == LBM_TYPE_ARRAY) {
lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val);
- if (array == NULL) {
- return NULL;
- }
- if (array->elt_type == LBM_TYPE_CHAR) {
- res = (char *)array->data;
+ if (array) {
+ if (array->elt_type == LBM_TYPE_CHAR) {
+ res = (char *)array->data;
+ }
}
}
return res;
@@ -885,6 +884,21 @@ unsigned int lbm_list_length(lbm_value c) {
return len;
}
+/* calculate the length of a list and check that each element
+ fullfills the predicate pred */
+unsigned int lbm_list_length_pred(lbm_value c, bool *pres, bool (*pred)(lbm_value)) {
+ bool res = true;
+ unsigned int len = 0;
+
+ while (lbm_type_of(c) == LBM_TYPE_CONS){
+ len ++;
+ res = res && pred(lbm_car(c));
+ c = lbm_cdr(c);
+ }
+ *pres = res;
+ return len;
+}
+
/* reverse a proper list */
lbm_value lbm_list_reverse(lbm_value list) {
if (lbm_type_of(list) == LBM_TYPE_SYMBOL) {
@@ -1031,6 +1045,33 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type){
return 1;
}
+// Convert a C array into an lbm_array.
+// if the array is in LBM_MEMORY, the lifetime will be managed by the GC.
+int lbm_lift_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_TYPE_CONS);
+
+ if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) { // Out of heap memory
+ *value = cell;
+ return 0;
+ }
+
+ array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / 4);
+
+ if (array == NULL) return 0;
+
+ 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 = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
+ *value = cell;
+ return 1;
+}
/* Explicitly freeing an array.
diff --git a/lispBM/lispBM/src/lbm_c_interop.c b/lispBM/lispBM/src/lbm_c_interop.c
index fa3db942..f603d413 100644
--- a/lispBM/lispBM/src/lbm_c_interop.c
+++ b/lispBM/lispBM/src/lbm_c_interop.c
@@ -226,29 +226,7 @@ int lbm_undefine(char *symbol) {
}
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_TYPE_CONS);
-
- if (lbm_type_of(cell) == LBM_TYPE_SYMBOL) { // Out of heap memory
- *value = cell;
- return 0;
- }
-
- array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / 4);
-
- if (array == NULL) return 0;
-
- 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 = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY);
- *value = cell;
- return 1;
+ return lbm_lift_array(value, data, type, num_elt);
}
int lbm_create_array(lbm_value *value, lbm_type type, lbm_uint num_elt) {
diff --git a/lispBM/lispBM/src/lbm_memory.c b/lispBM/lispBM/src/lbm_memory.c
index 4540f944..1fbdbb8a 100644
--- a/lispBM/lispBM/src/lbm_memory.c
+++ b/lispBM/lispBM/src/lbm_memory.c
@@ -41,10 +41,16 @@ static lbm_uint memory_size; // in 4 or 8 byte words depending on 32 or 64 bit
static lbm_uint bitmap_size; // in 4 or 8 byte words
static lbm_uint memory_base_address = 0;
static mutex_t lbm_mem_mutex;
+static bool lbm_mem_mutex_initialized;
int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
lbm_uint *bits, lbm_uint bits_size) {
+ if (!lbm_mem_mutex_initialized) {
+ mutex_init(&lbm_mem_mutex);
+ }
+ mutex_lock(&lbm_mem_mutex);
+ int res = 0;
if (data == NULL || bits == NULL) return 0;
if (((lbm_uint)data % sizeof(lbm_uint) != 0) ||
@@ -56,22 +62,22 @@ int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
// data is not aligned to sizeof lbm_uint
// size is too small
// or size is not a multiple of 4
- return 0;
+ } else {
+
+ bitmap = bits;
+ bitmap_size = bits_size;
+
+ for (lbm_uint i = 0; i < bitmap_size; i ++) {
+ bitmap[i] = 0;
+ }
+
+ memory = data;
+ memory_base_address = (lbm_uint)data;
+ memory_size = data_size;
+ res = 1;
}
-
- bitmap = bits;
- bitmap_size = bits_size;
-
- for (lbm_uint i = 0; i < bitmap_size; i ++) {
- bitmap[i] = 0;
- }
-
- memory = data;
- memory_base_address = (lbm_uint)data;
- memory_size = data_size;
-
- mutex_init(&lbm_mem_mutex);
- return 1;
+ mutex_unlock(&lbm_mem_mutex);
+ return res;
}
static inline lbm_uint address_to_bitmap_ix(lbm_uint *ptr) {
@@ -325,6 +331,21 @@ int lbm_memory_free(lbm_uint *ptr) {
}
return r;
}
+//Malloc/free like interface
+void* lbm_malloc(size_t size) {
+ lbm_uint alloc_size;
+ if (size % sizeof(lbm_uint) == 0) {
+ alloc_size = size / (sizeof(lbm_uint));
+ } else {
+ alloc_size = (size / (sizeof(lbm_uint))) + 1;
+ }
+
+ return lbm_memory_allocate(alloc_size);
+}
+
+void lbm_free(void *ptr) {
+ lbm_memory_free(ptr);
+}
int lbm_memory_shrink(lbm_uint *ptr, lbm_uint n) {
lbm_uint ix = address_to_bitmap_ix(ptr);
diff --git a/lispBM/lispBM/src/symrepr.c b/lispBM/lispBM/src/symrepr.c
index 80eb06d3..dd89d1c0 100644
--- a/lispBM/lispBM/src/symrepr.c
+++ b/lispBM/lispBM/src/symrepr.c
@@ -196,6 +196,8 @@ special_sym const special_symbols[] = {
{"to-double" , SYM_TO_DOUBLE},
{"to-byte" , SYM_TO_BYTE},
+ {"event-register-handler", SYM_REG_EVENT_HANDLER},
+
// fast access in list
{"ix" , SYM_IX},
diff --git a/lispBM/lispBM/src/tokpar.c b/lispBM/lispBM/src/tokpar.c
index 4b862a77..2829507b 100644
--- a/lispBM/lispBM/src/tokpar.c
+++ b/lispBM/lispBM/src/tokpar.c
@@ -611,7 +611,12 @@ lbm_value lbm_get_next_token(lbm_char_channel_t *chan, bool peek) {
if (!peek) lbm_channel_drop(chan, (unsigned int)n);
// TODO: Proper error checking here!
// TODO: Check if anything has to be allocated for the empty string
- lbm_heap_allocate_array(&res, (unsigned int)(string_len+1), LBM_TYPE_CHAR);
+ if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1), LBM_TYPE_CHAR)) {
+ // Should really be a tokenizer memory error.
+ // GC should run and tokenizer be retried.
+ // Needs some thinking on how to do that.
+ return lbm_enc_sym(TOKENIZER_ERROR);
+ }
lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(res);
char *data = (char *)arr->data;
memset(data, 0, (string_len+1) * sizeof(char));
diff --git a/lispBM/lispBM/tests/test_dot_1.lisp b/lispBM/lispBM/tests/test_dot_1.lisp
new file mode 100644
index 00000000..44211564
--- /dev/null
+++ b/lispBM/lispBM/tests/test_dot_1.lisp
@@ -0,0 +1,7 @@
+
+(define x (vector 1 2 3))
+(define y (vector 1 5 7))
+
+(define r (dot x y))
+
+(= r 32.0)
diff --git a/lispBM/lispBM/tests/test_event_1.lisp b/lispBM/lispBM/tests/test_event_1.lisp
new file mode 100644
index 00000000..dc0f8b1a
--- /dev/null
+++ b/lispBM/lispBM/tests/test_event_1.lisp
@@ -0,0 +1,12 @@
+
+
+
+(event-register-handler (self))
+
+
+(spawn (fn ()
+ (event-sym 'apa)))
+
+
+
+(recv ((? x) (eq x 'apa)))
diff --git a/lispBM/lispBM/tests/test_event_2.lisp b/lispBM/lispBM/tests/test_event_2.lisp
new file mode 100644
index 00000000..70b25410
--- /dev/null
+++ b/lispBM/lispBM/tests/test_event_2.lisp
@@ -0,0 +1,10 @@
+
+(event-register-handler (self))
+
+
+(spawn (fn ()
+ (event-array 'apa)))
+
+
+
+(recv (((? x) . (? arr)) (and (eq x 'apa) (eq arr "Hello world"))))
diff --git a/lispBM/lispBM/tests/test_event_3.lisp b/lispBM/lispBM/tests/test_event_3.lisp
new file mode 100644
index 00000000..dbb25789
--- /dev/null
+++ b/lispBM/lispBM/tests/test_event_3.lisp
@@ -0,0 +1,18 @@
+(event-register-handler (self))
+
+
+(spawn (fn ()
+ (progn
+ (event-sym 'apa)
+ (event-sym 'bepa)
+ (event-array 'cepa))))
+
+
+
+(recv ( apa 1))
+(recv ( bepa 2))
+(recv (( cepa . (? arr)) 3))
+
+
+
+'t
diff --git a/lispBM/lispBM/tests/test_event_4.lisp b/lispBM/lispBM/tests/test_event_4.lisp
new file mode 100644
index 00000000..090e3fdb
--- /dev/null
+++ b/lispBM/lispBM/tests/test_event_4.lisp
@@ -0,0 +1,28 @@
+
+
+
+(event-register-handler (self))
+
+(defun event-sender (n)
+ (if (= 0 n) ()
+ (progn
+ (event-sym 'apa)
+ (event-sender (- n 1)))))
+
+(spawn event-sender 100)
+
+
+
+(and (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa)))
+ (recv ((? x) (eq x 'apa))))
+
+
diff --git a/lispBM/lispBM/tests/test_lisp_code_cps.c b/lispBM/lispBM/tests/test_lisp_code_cps.c
index 9335979d..f18f29c7 100644
--- a/lispBM/lispBM/tests/test_lisp_code_cps.c
+++ b/lispBM/lispBM/tests/test_lisp_code_cps.c
@@ -1,5 +1,5 @@
/*
- Copyright 2018,2020 Joel Svensson svenssonjoel@yahoo.se
+ Copyright 2018, 2020, 2023 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
@@ -27,6 +27,11 @@
#include "lispbm.h"
#include "extensions/array_extensions.h"
+#include "extensions/math_extensions.h"
+#include "extensions/string_extensions.h"
+#include "extensions/runtime_extensions.h"
+#include "extensions/matvec_extensions.h"
+#include "extensions/random_extensions.h"
#include "lbm_channel.h"
#define WAIT_TIMEOUT 2500
@@ -194,6 +199,30 @@ LBM_EXTENSION(ext_numbers, args, argn) {
}
+LBM_EXTENSION(ext_event_sym, args, argn) {
+ lbm_value res = ENC_SYM_EERROR;
+ if (argn == 1 && lbm_is_symbol(args[0])) {
+ lbm_event_t e;
+ e.type = LBM_EVENT_SYM;
+ e.sym = lbm_dec_sym(args[0]);
+ lbm_event(e, NULL, 0);
+ res = ENC_SYM_TRUE;
+ }
+ return res;
+}
+
+LBM_EXTENSION(ext_event_array, args, argn) {
+ lbm_value res = ENC_SYM_EERROR;
+ if (argn == 1 && lbm_is_symbol(args[0])) {
+ lbm_event_t e;
+ e.type = LBM_EVENT_SYM_ARRAY;
+ e.sym = lbm_dec_sym(args[0]);
+ lbm_event(e, "Hello world", 12);
+ res = ENC_SYM_TRUE;
+ }
+ return res;
+}
+
int main(int argc, char **argv) {
@@ -263,14 +292,14 @@ int main(int argc, char **argv) {
return 0;
}
- lbm_uint *memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_12K);
+ lbm_uint *memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_14K);
if (memory == NULL) return 0;
- lbm_uint *bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_12K);
+ lbm_uint *bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_14K);
if (bitmap == NULL) return 0;
- res = lbm_memory_init(memory, LBM_MEMORY_SIZE_12K,
- bitmap, LBM_MEMORY_BITMAP_SIZE_12K);
+ res = lbm_memory_init(memory, LBM_MEMORY_SIZE_14K,
+ bitmap, LBM_MEMORY_BITMAP_SIZE_14K);
if (res)
printf("Memory initialized.\n");
else {
@@ -323,6 +352,14 @@ int main(int argc, char **argv) {
return 0;
}
+ res = lbm_eval_init_events(20);
+ if (res)
+ printf("Events initialized.\n");
+ else {
+ printf("Error initializing events.\n");
+ return 0;
+ }
+
res = lbm_extensions_init(extension_storage, EXTENSION_STORAGE_SIZE);
if (res)
printf("Extensions initialized.\n");
@@ -331,7 +368,47 @@ int main(int argc, char **argv) {
return 0;
}
- lbm_array_extensions_init();
+ if (lbm_array_extensions_init()) {
+ printf("Array extensions initialized.\n");
+ } else {
+ printf("Array extensions failed.\n");
+ return 0;
+ }
+
+ if (lbm_math_extensions_init()) {
+ printf("Math extensions initialized.\n");
+ } else {
+ printf("Math extensions failed.\n");
+ return 0;
+ }
+
+ if (lbm_string_extensions_init()) {
+ printf("String extensions initialized.\n");
+ } else {
+ printf("String extensions failed.\n");
+ return 0;
+ }
+
+ if (lbm_runtime_extensions_init()) {
+ printf("Runtime extensions initialized.\n");
+ } else {
+ printf("Runtime extensions failed.\n");
+ return 0;
+ }
+
+ if (lbm_matvec_extensions_init()) {
+ printf("Matvec extensions initialized.\n");
+ } else {
+ printf("Matvec extensions failed.\n");
+ return 0;
+ }
+
+ if (lbm_random_extensions_init()) {
+ printf("Random extensions initialized.\n");
+ } else {
+ printf("Random extensions failed.\n");
+ return 0;
+ }
res = lbm_add_extension("ext-even", ext_even);
if (res)
@@ -357,6 +434,22 @@ int main(int argc, char **argv) {
return 0;
}
+ res = lbm_add_extension("event-sym", ext_event_sym);
+ if (res)
+ printf("Extension added.\n");
+ else {
+ printf("Error adding extension.\n");
+ return 0;
+ }
+
+ res = lbm_add_extension("event-array", ext_event_array);
+ if (res)
+ printf("Extension added.\n");
+ else {
+ printf("Error adding extension.\n");
+ return 0;
+ }
+
lbm_set_dynamic_load_callback(dyn_load);
lbm_set_timestamp_us_callback(timestamp_callback);
lbm_set_usleep_callback(sleep_callback);
diff --git a/lispBM/lispBM/tests/test_match_13.lisp b/lispBM/lispBM/tests/test_match_13.lisp
new file mode 100644
index 00000000..bd275fa0
--- /dev/null
+++ b/lispBM/lispBM/tests/test_match_13.lisp
@@ -0,0 +1,6 @@
+
+(defun f (x y)
+ (match (cons x y)
+ ((1 . 2) 'a-symbol)))
+
+(eq (f 1 2) 'a-symbol)
diff --git a/lispBM/lispBM/tests/test_match_14.lisp b/lispBM/lispBM/tests/test_match_14.lisp
new file mode 100644
index 00000000..b9ccd048
--- /dev/null
+++ b/lispBM/lispBM/tests/test_match_14.lisp
@@ -0,0 +1,6 @@
+
+(defun f (x y)
+ (match `(,x . ,y)
+ ((1 . 2) 'a-symbol)))
+
+(eq (f 1 2) 'a-symbol)
diff --git a/lispBM/lispBM/tests/test_match_15.lisp b/lispBM/lispBM/tests/test_match_15.lisp
new file mode 100644
index 00000000..29b21b37
--- /dev/null
+++ b/lispBM/lispBM/tests/test_match_15.lisp
@@ -0,0 +1,7 @@
+
+(defun f (x y)
+ (match (cons x y)
+ ((1 . 2) 'a-symbol)
+ ( _ 'whatever)))
+
+(eq (f 1 4) 'whatever)
diff --git a/lispBM/lispBM/tests/test_matrix_1.lisp b/lispBM/lispBM/tests/test_matrix_1.lisp
new file mode 100644
index 00000000..055e68d6
--- /dev/null
+++ b/lispBM/lispBM/tests/test_matrix_1.lisp
@@ -0,0 +1,12 @@
+
+
+(def d '(1.0 0.0 0.0
+ 0.0 1.0 0.0
+ 0.0 0.0 1.0))
+
+(def m (list-to-matrix 3 d))
+
+
+(def d-new (matrix-to-list m))
+
+(eq d-new d)
diff --git a/lispBM/lispBM/tests/test_memory_1.lisp b/lispBM/lispBM/tests/test_memory_1.lisp
new file mode 100644
index 00000000..14534733
--- /dev/null
+++ b/lispBM/lispBM/tests/test_memory_1.lisp
@@ -0,0 +1,14 @@
+
+
+(defun repeat (n c)
+ (if (= n 0) nil
+ (progn
+ (c)
+ (repeat (- n 1) c)
+ )))
+
+
+(def n (* 4 (mem-longest-free)))
+(repeat 100 (fn () (array-create (- n 1))))
+
+t
diff --git a/lispBM/lispBM/tests/test_memory_2.lisp b/lispBM/lispBM/tests/test_memory_2.lisp
new file mode 100644
index 00000000..cfe7204f
--- /dev/null
+++ b/lispBM/lispBM/tests/test_memory_2.lisp
@@ -0,0 +1,21 @@
+
+
+(defun repeat (n c)
+ (if (= n 0) 'repeat-done
+ (progn
+ (c)
+ (repeat (- n 1) c)
+ )))
+
+
+(def n (* 4 (mem-longest-free)))
+(defun f () (repeat 100 (fn () (array-create (- n 1500)))))
+
+
+
+(spawn-trap f)
+
+
+(eq (recv ((exit-error (? tid) (? e)) 'error)
+ ((exit-ok (? tid) (? r)) r))
+ 'repeat-done)
diff --git a/lispBM/lispBM/tests/test_memory_3.lisp b/lispBM/lispBM/tests/test_memory_3.lisp
new file mode 100644
index 00000000..26b1429f
--- /dev/null
+++ b/lispBM/lispBM/tests/test_memory_3.lisp
@@ -0,0 +1,17 @@
+
+
+(def n (* 4 (mem-longest-free)))
+
+(def a (array-create (- n 1500)))
+
+(defun f () (array-create 1500)) ;; Should not succeed
+
+
+(spawn-trap f)
+
+
+(def err (recv ((exit-error (? tid) (? e)) e)
+ ((exit-ok (? tid) (? r)) r)))
+
+(and (eq err out_of_memory) ;; error caught
+ (= (+ 1 2) 3)) ;; eval is alive
diff --git a/lispBM/lispBM/tests/test_random_1.lisp b/lispBM/lispBM/tests/test_random_1.lisp
new file mode 100644
index 00000000..91a82bee
--- /dev/null
+++ b/lispBM/lispBM/tests/test_random_1.lisp
@@ -0,0 +1,3 @@
+(define r (random))
+
+(eq (type-of r) type-u)
diff --git a/lispBM/lispBM/tests/test_range_9.lisp b/lispBM/lispBM/tests/test_range_9.lisp
new file mode 100644
index 00000000..0aa94dee
--- /dev/null
+++ b/lispBM/lispBM/tests/test_range_9.lisp
@@ -0,0 +1,8 @@
+
+(defun f (n) (if (= n 0)
+ 0
+ (progn (range 5) (f (- n 1)))))
+
+;; Trigger gc lots of times.
+(f 100000)
+(eq (range 10) '(0 1 2 3 4 5 6 7 8 9))
diff --git a/lispBM/lispBM/tests/test_saxpy_1.lisp b/lispBM/lispBM/tests/test_saxpy_1.lisp
new file mode 100644
index 00000000..90bb5208
--- /dev/null
+++ b/lispBM/lispBM/tests/test_saxpy_1.lisp
@@ -0,0 +1,9 @@
+
+
+(define x (vector 1.0 2.0 3.0))
+(define y (vector 0.1 0.2 0.3))
+(define alpha 2)
+
+(define r (axpy alpha x y))
+
+(eq (vector-to-list r) (list 2.1 4.2 6.3))
diff --git a/lispBM/lispBM/tests/test_saxpy_2.lisp b/lispBM/lispBM/tests/test_saxpy_2.lisp
new file mode 100644
index 00000000..f4720fe3
--- /dev/null
+++ b/lispBM/lispBM/tests/test_saxpy_2.lisp
@@ -0,0 +1,9 @@
+
+
+(define x (vector 1.0 2.0 3.0 4.0 5.0))
+(define y (vector 0.1 0.2 0.3 0.4 0.5))
+(define alpha 2)
+
+(define r (axpy alpha x y))
+
+(eq (vector-to-list r) (list 2.1 4.2 6.3 8.4 10.5))
diff --git a/lispBM/lispBM/tests/test_str_cmp_1.lisp b/lispBM/lispBM/tests/test_str_cmp_1.lisp
new file mode 100644
index 00000000..70a6ff5b
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_cmp_1.lisp
@@ -0,0 +1,21 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "a string that is quite unique")
+(define bepa "a string tat is quite oonique")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-cmp apa bepa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_from_n_1.lisp b/lispBM/lispBM/tests/test_str_from_n_1.lisp
new file mode 100644
index 00000000..785eb31c
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_from_n_1.lisp
@@ -0,0 +1,10 @@
+
+(gc)
+
+(define n (mem-num-free))
+
+(str-from-n 132)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_from_n_2.lisp b/lispBM/lispBM/tests/test_str_from_n_2.lisp
new file mode 100644
index 00000000..c4884f35
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_from_n_2.lisp
@@ -0,0 +1,18 @@
+
+(defun repeat (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ (f n)
+ (repeat f (- n 1)))))
+
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeat (lambda (n) (str-from-n n)) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_len_1.lisp b/lispBM/lispBM/tests/test_str_len_1.lisp
new file mode 100644
index 00000000..e7b1806a
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_len_1.lisp
@@ -0,0 +1,19 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+(define my-string "anjovis")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-len my-string) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_merge_1.lisp b/lispBM/lispBM/tests/test_str_merge_1.lisp
new file mode 100644
index 00000000..be200d67
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_merge_1.lisp
@@ -0,0 +1,21 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "apa")
+(define bepa "bepa")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-merge apa bepa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_part_1.lisp b/lispBM/lispBM/tests/test_str_part_1.lisp
new file mode 100644
index 00000000..ee1de829
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_part_1.lisp
@@ -0,0 +1,20 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "Hello world")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-part apa 4) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_replace_1.lisp b/lispBM/lispBM/tests/test_str_replace_1.lisp
new file mode 100644
index 00000000..c51ad423
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_replace_1.lisp
@@ -0,0 +1,22 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "a couple of words in a row")
+(define r "words")
+(define w "penguins")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-replace apa r w) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_split_1.lisp b/lispBM/lispBM/tests/test_str_split_1.lisp
new file mode 100644
index 00000000..0f2d25b0
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_split_1.lisp
@@ -0,0 +1,21 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "a couple of words in a row")
+(define delim " ")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-split apa delim) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_to_f_1.lisp b/lispBM/lispBM/tests/test_str_to_f_1.lisp
new file mode 100644
index 00000000..1f235916
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_to_f_1.lisp
@@ -0,0 +1,20 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "124.321")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-to-f apa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_to_i_1.lisp b/lispBM/lispBM/tests/test_str_to_i_1.lisp
new file mode 100644
index 00000000..49e341e8
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_to_i_1.lisp
@@ -0,0 +1,20 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "124")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-to-i apa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_to_lower_1.lisp b/lispBM/lispBM/tests/test_str_to_lower_1.lisp
new file mode 100644
index 00000000..2c97dcfa
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_to_lower_1.lisp
@@ -0,0 +1,20 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "A VERY LOUD STRING")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-to-lower apa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_str_to_upper_1.lisp b/lispBM/lispBM/tests/test_str_to_upper_1.lisp
new file mode 100644
index 00000000..5653468f
--- /dev/null
+++ b/lispBM/lispBM/tests/test_str_to_upper_1.lisp
@@ -0,0 +1,20 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+
+(define apa "a very gentle string")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(str-to-upper apa) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_to_str_1.lisp b/lispBM/lispBM/tests/test_to_str_1.lisp
new file mode 100644
index 00000000..0edb0ef7
--- /dev/null
+++ b/lispBM/lispBM/tests/test_to_str_1.lisp
@@ -0,0 +1,17 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(to-str 1 2 3 4 5 6 7 8 9) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_to_str_delim_1.lisp b/lispBM/lispBM/tests/test_to_str_delim_1.lisp
new file mode 100644
index 00000000..02a9e061
--- /dev/null
+++ b/lispBM/lispBM/tests/test_to_str_delim_1.lisp
@@ -0,0 +1,19 @@
+
+(defun repeatq (f n)
+ (if ( = n 0)
+ ()
+ (progn
+ f
+ (repeatq f (- n 1)))))
+
+(define delim "anjovis")
+
+(gc)
+
+(define n (mem-num-free))
+
+(repeatq '(to-str-delim delim 1 2 3 4 5 6 7 8 9) 1000)
+
+(gc)
+
+(= n (mem-num-free))
diff --git a/lispBM/lispBM/tests/test_vector_1.lisp b/lispBM/lispBM/tests/test_vector_1.lisp
new file mode 100644
index 00000000..676459aa
--- /dev/null
+++ b/lispBM/lispBM/tests/test_vector_1.lisp
@@ -0,0 +1,7 @@
+
+
+(def vec (list-to-vector '(1 2 3)))
+(def lis (vector-to-list vec))
+
+
+(eq lis '(1.0 2.0 3.0))
diff --git a/lispBM/lispBM/tests/test_vector_2.lisp b/lispBM/lispBM/tests/test_vector_2.lisp
new file mode 100644
index 00000000..6578de64
--- /dev/null
+++ b/lispBM/lispBM/tests/test_vector_2.lisp
@@ -0,0 +1,20 @@
+
+(def v (vector 1.0 2.0 3.0))
+
+(def v2 (vmult 2.0 v))
+
+(defun zipwith (f x y)
+ (match (cons x y)
+ ((_ . nil) nil)
+ ((nil . _) nil)
+ (((? a). (? b)) (cons (f (car a) (car b)) (zipwith f (cdr a) (cdr b))))))
+
+(defun fold (f i x)
+ (match x
+ (nil i)
+ (((? x) . (? xs)) (f x (fold f i xs)))))
+
+(def diff (zipwith (fn (x y) (- x y)) (vector-to-list v2) '(2.0 4.0 6.0)))
+(def sum (fold (fn (x y) (+ x y)) 0.0 diff))
+
+(< sum 0.001)
diff --git a/lispBM/lispBM/tests/test_vector_3.lisp b/lispBM/lispBM/tests/test_vector_3.lisp
new file mode 100644
index 00000000..91ef790e
--- /dev/null
+++ b/lispBM/lispBM/tests/test_vector_3.lisp
@@ -0,0 +1,7 @@
+
+(def v (list-to-vector '(1.0 2.0 3.0 4.0)))
+
+(and (= (vproj v 0) 1.0)
+ (= (vproj v 1) 2.0)
+ (= (vproj v 2) 3.0)
+ (= (vproj v 3) 4.0))
diff --git a/lispBM/lispBM/tests/test_word_size.lisp b/lispBM/lispBM/tests/test_word_size.lisp
new file mode 100644
index 00000000..b525b9f6
--- /dev/null
+++ b/lispBM/lispBM/tests/test_word_size.lisp
@@ -0,0 +1,3 @@
+
+(or (= (word-size 4))
+ (= (word-size 8)))