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