Merge commit '65a3ed7ca429d343051fb687a7929c4a1201c9b5'

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.

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 <http://www.gnu.org/licenses/>.
+*/
+
+#ifndef MATVEC_EXTENSIONS_H_
+#define MATVEC_EXTENSIONS_H_
+
+#include <stdbool.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_matvec_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif

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 <http://www.gnu.org/licenses/>.
+*/
+
+#ifndef RANDOM_EXTENSIONS_H_
+#define RANDOM_EXTENSIONS_H_
+
+#include <stdbool.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_random_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif

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 <http://www.gnu.org/licenses/>.
+*/
+
+#ifndef RUNTIME_EXTENSIONS_H_
+#define RUNTIME_EXTENSIONS_H_
+
+#include <stdbool.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+bool lbm_runtime_extensions_init(void);
+
+#ifdef __cplusplus
+}
+#endif
+#endif

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.

lispBM/lispBM/include/lbm_custom_type.h

@@ -20,7 +20,10 @@
 #define LBM_CUSTOM_TYPE_H_
 
 #include <stdbool.h>
+#include <stddef.h>
 #include <lbm_types.h>
+#include <lbm_defines.h>
+#include <heap.h>
 
 #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

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

lispBM/lispBM/include/lbm_memory.h

@@ -76,6 +76,7 @@
 
 #include "lbm_types.h"
 #include <stdint.h>
+#include <stddef.h>
 
 #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

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 \

lispBM/lispBM/repl/repl.c

@@ -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) {
@@ -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)) {

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))

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);

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");

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))

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;
+}

lispBM/lispBM/src/extensions/array_extensions.c

@@ -1,6 +1,6 @@
 /*
-    Copyright 2022 Joel Svensson        svenssonjoel@yahoo.se
+    Copyright 2022, 2023 Joel Svensson        svenssonjoel@yahoo.se
-    Copyright 2022 Benjamin Vedder
+    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;
+}

lispBM/lispBM/src/extensions/math_extensions.c

@@ -1,6 +1,6 @@
 /*
-    Copyright 2022 Joel Svensson        svenssonjoel@yahoo.se
+    Copyright 2022, 2023 Joel Svensson        svenssonjoel@yahoo.se
-    Copyright 2022 Benjamin Vedder
+    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;
 
@@ -81,63 +67,79 @@ 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)
+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) {
+static lbm_value ext_cos(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_tan(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_asin(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_acos(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_atan(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_atan2(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(2)
+        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) {
+static lbm_value ext_pow(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(2)
+        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) {
+static lbm_value ext_sqrt(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_log(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_log10(lbm_value *args, lbm_uint argn) {
-  CHECK_ARGN_NUMBER(1)
+        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) {
+static lbm_value ext_floor(lbm_value *args, lbm_uint argn) {
-  CHECK_NUMBER_ALL();
+        LBM_CHECK_ARGN_NUMBER(1)
+        return lbm_enc_float(floorf(lbm_dec_as_float(args[0])));
+}
+
+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_round(lbm_value *args, lbm_uint argn) {
+        LBM_CHECK_ARGN_NUMBER(1)
+        return lbm_enc_float(roundf(lbm_dec_as_float(args[0])));
+}
+
+static lbm_value ext_deg2rad(lbm_value *args, lbm_uint argn) {
+        LBM_CHECK_NUMBER_ALL();
 
         if (argn == 1) {
                 return lbm_enc_float(DEG2RAD_f(lbm_dec_as_float(args[0])));
@@ -150,8 +152,8 @@ static lbm_value ext_deg2radf(lbm_value *args, lbm_uint argn) {
         }
 }
 
-static lbm_value ext_rad2degf(lbm_value *args, lbm_uint argn) {
+static lbm_value ext_rad2deg(lbm_value *args, lbm_uint argn) {
-  CHECK_NUMBER_ALL();
+        LBM_CHECK_NUMBER_ALL();
 
         if (argn == 1) {
                 return lbm_enc_float(RAD2DEG_f(lbm_dec_as_float(args[0])));
@@ -164,8 +166,8 @@ static lbm_value ext_rad2degf(lbm_value *args, lbm_uint argn) {
         }
 }
 
-static lbm_value ext_vec3_rotf(lbm_value *args, lbm_uint argn) {
+static lbm_value ext_vec3_rot(lbm_value *args, lbm_uint argn) {
-  CHECK_NUMBER_ALL();
+        LBM_CHECK_NUMBER_ALL();
         if (argn != 6 && argn != 7) {
                 return ENC_SYM_EERROR;
         }
@@ -192,20 +194,22 @@ static lbm_value ext_vec3_rotf(lbm_value *args, lbm_uint argn) {
 bool lbm_math_extensions_init(void) {
 
   bool res = true;
-  res = res && lbm_add_extension("sin", ext_sinf);
+  res = res && lbm_add_extension("sin", ext_sin);
-  res = res && lbm_add_extension("cos", ext_cosf);
+  res = res && lbm_add_extension("cos", ext_cos);
-  res = res && lbm_add_extension("tan", ext_tanf);
+  res = res && lbm_add_extension("tan", ext_tan);
-  res = res && lbm_add_extension("asin", ext_asinf);
+  res = res && lbm_add_extension("asin", ext_asin);
-  res = res && lbm_add_extension("acos", ext_acosf);
+  res = res && lbm_add_extension("acos", ext_acos);
-  res = res && lbm_add_extension("atan", ext_atanf);
+  res = res && lbm_add_extension("atan", ext_atan);
-  res = res && lbm_add_extension("atan2", ext_atan2f);
+  res = res && lbm_add_extension("atan2", ext_atan2);
-  res = res && lbm_add_extension("pow", ext_powf);
+  res = res && lbm_add_extension("pow", ext_pow);
-  res = res && lbm_add_extension("sqrt", ext_sqrtf);
+  res = res && lbm_add_extension("sqrt", ext_sqrt);
-  res = res && lbm_add_extension("log", ext_logf);
+  res = res && lbm_add_extension("log", ext_log);
-  res = res && lbm_add_extension("log10", ext_log10f);
+  res = res && lbm_add_extension("log10", ext_log10);
-  res = res && lbm_add_extension("deg2rad", ext_deg2radf);
+  res = res && lbm_add_extension("floor", ext_floor);
-  res = res && lbm_add_extension("rad2deg", ext_rad2degf);
+  res = res && lbm_add_extension("ceil", ext_ceil);
-  res = res && lbm_add_extension("vec3-rot", ext_vec3_rotf);
+  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;
 }

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 <http://www.gnu.org/licenses/>.
+*/
+
+#include "extensions.h"
+#include "lbm_utils.h"
+#include "lbm_custom_type.h"
+
+#include <math.h>
+
+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;
+}
+

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 <http://www.gnu.org/licenses/>.
+*/
+
+#include <extensions.h>
+#include <lbm_utils.h>
+
+#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;
+}

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 <http://www.gnu.org/licenses/>.
+*/
+
+#include <lbm_memory.h>
+#include <heap.h>
+#include <eval_cps.h>
+#include <extensions.h>
+#include <lbm_utils.h>
+
+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;
+}

lispBM/lispBM/src/extensions/string_extensions.c

@@ -1,6 +1,6 @@
 /*
-    Copyright 2022 Joel Svensson        svenssonjoel@yahoo.se
+    Copyright 2022, 2023 Joel Svensson        svenssonjoel@yahoo.se
-    Copyright 2022 Benjamin Vedder
+    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 <ctype.h>
 
@@ -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)
+  size_t len_rep;  // length of rep (the string to remove)
-  int len_with; // length of with (the string to replace rep with)
+  size_t 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_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 = result = (char*)arr->data;
-    tmp = (char*)arr->data; // result is never accessed so should not be needed.
   } 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);
+    len_front = (size_t)ins - (unsigned int)orig;
-    tmp = strncpy(tmp, orig, (size_t)len_front) + len_front;
+    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;
   }
 
+  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) {
+// TODO: This is very similar to ext-print. Maybe they can share code.
-  if (argn != 3) {
+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]);
+  char *delim = lbm_dec_str(args[0]);
-  if (!str1) {
+  if (!delim) {
     return ENC_SYM_EERROR;
   }
 
-  char *str2 = lbm_dec_str(args[1]);
+  return to_str(delim, args + 1, argn - 1);
-  if (!str2) {
+}
+
+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])) {
+  lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(args[0]);
-    int n = lbm_dec_as_i32(args[2]);
 
-    return lbm_enc_i(strncmp(str1, str2, n));
+  return lbm_enc_i((int)strlen_max(str, array->size));
-  }
-  return ENC_SYM_TERROR;
 }
 
 
@@ -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;
 }

lispBM/lispBM/src/fundamental.c

@@ -1,5 +1,5 @@
 /*
-    Copyright 2019, 2021, 2022 Joel Svensson   svenssonjoel@yahoo.se
+    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
@@ -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
   };

lispBM/lispBM/src/heap.c

@@ -188,13 +188,12 @@ 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) {
+    if (array) {
-      return NULL;
-    }
       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.
 

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) {
-
+  return lbm_lift_array(value, data, type, 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;
 }
 
 int lbm_create_array(lbm_value *value, lbm_type type, lbm_uint num_elt) {

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,8 +62,7 @@ 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;
@@ -69,9 +74,10 @@ int lbm_memory_init(lbm_uint *data, lbm_uint data_size,
     memory = data;
     memory_base_address = (lbm_uint)data;
     memory_size = data_size;
-
+    res = 1;
-  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);

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},
 

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));

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)

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)))

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"))))

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

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))))
+     
+

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,
+  res = lbm_memory_init(memory, LBM_MEMORY_SIZE_14K,
-                        bitmap, LBM_MEMORY_BITMAP_SIZE_12K);
+                        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);

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)

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)

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)

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)

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

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)

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

lispBM/lispBM/tests/test_random_1.lisp

@@ -0,0 +1,3 @@
+(define r (random))
+
+(eq (type-of r) type-u)

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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))

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)

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))

lispBM/lispBM/tests/test_word_size.lisp

@@ -0,0 +1,3 @@
+
+(or (= (word-size 4))
+    (= (word-size 8)))