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

Merge commit '65a3ed7ca429d343051fb687a7929c4a1201c9b5'

This commit is contained in:
Benjamin Vedder 2023-01-24 09:19:05 +01:00
parent 3ae1b06d92 65a3ed7ca4
commit 1bc0baf2da
62 changed files with 2207 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

32
lispBM/lispBM/include/extensions/matvec_extensions.h Normal file
View File

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

32
lispBM/lispBM/include/extensions/random_extensions.h Normal file
View File

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

32
lispBM/lispBM/include/extensions/runtime_extensions.h Normal file
View File

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

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

@ -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.

16
lispBM/lispBM/include/lbm_custom_type.h
View File

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

3
lispBM/lispBM/include/lbm_defines.h
View File

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

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

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

5
lispBM/lispBM/lispbm.mk
View File

@ -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 \

60
lispBM/lispBM/repl/repl.c
View File

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

105
lispBM/lispBM/sdlrepl/flake.lisp Normal file
View File

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

20
lispBM/lispBM/sdlrepl/lbm_sdl.c
View File

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

7
lispBM/lispBM/sdlrepl/repl.c
View File

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

107
lispBM/lispBM/sdlrepl/sierpinski.lisp Normal file
View File

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

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

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

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

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

222
lispBM/lispBM/src/extensions/math_extensions.c
View File

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

354
lispBM/lispBM/src/extensions/matvec_extensions.c Normal file
View File

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

49
lispBM/lispBM/src/extensions/random_extensions.c Normal file
View File

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

67
lispBM/lispBM/src/extensions/runtime_extensions.c Normal file
View File

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

193
lispBM/lispBM/src/extensions/string_extensions.c
View File

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

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

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

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

@ -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.

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

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

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

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

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

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

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

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

7
lispBM/lispBM/tests/test_dot_1.lisp Normal file
View File

@ -0,0 +1,7 @@
(define x (vector 1 2 3))
(define y (vector 1 5 7))
(define r (dot x y))
(= r 32.0)

12
lispBM/lispBM/tests/test_event_1.lisp Normal file
View File

@ -0,0 +1,12 @@
(event-register-handler (self))
(spawn (fn ()
(event-sym 'apa)))
(recv ((? x) (eq x 'apa)))

10
lispBM/lispBM/tests/test_event_2.lisp Normal file
View File

@ -0,0 +1,10 @@
(event-register-handler (self))
(spawn (fn ()
(event-array 'apa)))
(recv (((? x) . (? arr)) (and (eq x 'apa) (eq arr "Hello world"))))

18
lispBM/lispBM/tests/test_event_3.lisp Normal file
View File

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

28
lispBM/lispBM/tests/test_event_4.lisp Normal file
View File

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

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

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

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

@ -0,0 +1,6 @@
(defun f (x y)
(match (cons x y)
((1 . 2) 'a-symbol)))
(eq (f 1 2) 'a-symbol)

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

@ -0,0 +1,6 @@
(defun f (x y)
(match `(,x . ,y)
((1 . 2) 'a-symbol)))
(eq (f 1 2) 'a-symbol)

7
lispBM/lispBM/tests/test_match_15.lisp Normal file
View File

@ -0,0 +1,7 @@
(defun f (x y)
(match (cons x y)
((1 . 2) 'a-symbol)
( _ 'whatever)))
(eq (f 1 4) 'whatever)

12
lispBM/lispBM/tests/test_matrix_1.lisp Normal file
View File

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

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

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

21
lispBM/lispBM/tests/test_memory_2.lisp Normal file
View File

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

17
lispBM/lispBM/tests/test_memory_3.lisp Normal file
View File

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

3
lispBM/lispBM/tests/test_random_1.lisp Normal file
View File

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

8
lispBM/lispBM/tests/test_range_9.lisp Normal file
View File

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

9
lispBM/lispBM/tests/test_saxpy_1.lisp Normal file
View File

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

9
lispBM/lispBM/tests/test_saxpy_2.lisp Normal file
View File

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

21
lispBM/lispBM/tests/test_str_cmp_1.lisp Normal file
View File

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

10
lispBM/lispBM/tests/test_str_from_n_1.lisp Normal file
View File

@ -0,0 +1,10 @@
(gc)
(define n (mem-num-free))
(str-from-n 132)
(gc)
(= n (mem-num-free))

18
lispBM/lispBM/tests/test_str_from_n_2.lisp Normal file
View File

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

19
lispBM/lispBM/tests/test_str_len_1.lisp Normal file
View File

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

21
lispBM/lispBM/tests/test_str_merge_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_str_part_1.lisp Normal file
View File

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

22
lispBM/lispBM/tests/test_str_replace_1.lisp Normal file
View File

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

21
lispBM/lispBM/tests/test_str_split_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_str_to_f_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_str_to_i_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_str_to_lower_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_str_to_upper_1.lisp Normal file
View File

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

17
lispBM/lispBM/tests/test_to_str_1.lisp Normal file
View File

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

19
lispBM/lispBM/tests/test_to_str_delim_1.lisp Normal file
View File

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

7
lispBM/lispBM/tests/test_vector_1.lisp Normal file
View File

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

20
lispBM/lispBM/tests/test_vector_2.lisp Normal file
View File

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

7
lispBM/lispBM/tests/test_vector_3.lisp Normal file
View File

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

3
lispBM/lispBM/tests/test_word_size.lisp Normal file
View File

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