| Line | Branch | Exec | Source |
|---|---|---|---|
| 1 | /* | ||
| 2 | Copyright 2023, 2025 Joel Svensson svenssonjoel@yahoo.se | ||
| 3 | 2022 Benjamin Vedder benjamin@vedder.se | ||
| 4 | 2025 Rasmus Söderhielm rasmus.soderhielm@gmail.com | ||
| 5 | |||
| 6 | This program is free software: you can redistribute it and/or modify | ||
| 7 | it under the terms of the GNU General Public License as published by | ||
| 8 | the Free Software Foundation, either version 3 of the License, or | ||
| 9 | (at your option) any later version. | ||
| 10 | |||
| 11 | This program is distributed in the hope that it will be useful, | ||
| 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | GNU General Public License for more details. | ||
| 15 | |||
| 16 | You should have received a copy of the GNU General Public License | ||
| 17 | along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | */ | ||
| 19 | |||
| 20 | #include <extensions.h> | ||
| 21 | |||
| 22 | #if defined(LBM_USE_DYN_FUNS) || defined(LBM_USE_DYN_ARRAYS) | ||
| 23 | static const char* lbm_dyn_fun[] = { | ||
| 24 | #ifdef LBM_USE_DYN_FUNS | ||
| 25 | "(defun str-merge () (str-join (rest-args)))", | ||
| 26 | "(defun iota (n) (range n))", | ||
| 27 | |||
| 28 | "(defun foldl (f init lst)" | ||
| 29 | "(if (eq lst nil) init (foldl f (f init (car lst)) (cdr lst))))", | ||
| 30 | |||
| 31 | "(defun foldr (f init lst)" | ||
| 32 | "(if (eq lst nil) init (f (car lst) (foldr f init (cdr lst)))))", | ||
| 33 | |||
| 34 | "(defun zipwith (f xs ys) " | ||
| 35 | "(let (( zip-acc (lambda (acc xs ys) " | ||
| 36 | "(if (and xs ys) " | ||
| 37 | "(zip-acc (cons (f (car xs) (car ys)) acc) (cdr xs) (cdr ys)) " | ||
| 38 | "acc)))) " | ||
| 39 | "(reverse (zip-acc nil xs ys))))", | ||
| 40 | |||
| 41 | "(defun zip (xs ys) " | ||
| 42 | "(zipwith cons xs ys))", | ||
| 43 | |||
| 44 | "(defun filter (f lst)" | ||
| 45 | "(let ((filter-rec (lambda (f lst ys)" | ||
| 46 | "(if (eq lst nil)" | ||
| 47 | "(reverse ys)" | ||
| 48 | "(if (f (car lst))" | ||
| 49 | "(filter-rec f (cdr lst) (cons (car lst) ys))" | ||
| 50 | "(filter-rec f (cdr lst) ys))))))" | ||
| 51 | "(filter-rec f lst nil)" | ||
| 52 | "))", | ||
| 53 | |||
| 54 | "(defun str-cmp-asc (a b) (< (str-cmp a b) 0))", | ||
| 55 | "(defun str-cmp-dsc (a b) (> (str-cmp a b) 0))", | ||
| 56 | |||
| 57 | "(defun second (x) (car (cdr x)))", | ||
| 58 | "(defun third (x) (car (cdr (cdr x))))", | ||
| 59 | |||
| 60 | "(defun abs (x) (if (< x 0) (- x) x))", | ||
| 61 | #ifdef LBM_USE_DYN_DEFSTRUCT | ||
| 62 | "(defun create-struct (dm name num-fields) { " | ||
| 63 | "(var arr (if dm (mkarray dm (+ 1 num-fields)) (mkarray (+ 1 num-fields)))) " | ||
| 64 | "(setix arr 0 name) " | ||
| 65 | "arr " | ||
| 66 | "})", | ||
| 67 | |||
| 68 | "(defun is-struct (struct name) " | ||
| 69 | "(and (eq (type-of struct) type-lisparray) " | ||
| 70 | "(eq (ix struct 0) name)))", | ||
| 71 | |||
| 72 | "(defun accessor-sym (name field) " | ||
| 73 | "(str2sym (str-merge name \"-\" (sym2str field))))", | ||
| 74 | |||
| 75 | "(defun access-set (i) " | ||
| 76 | "(lambda (struct) " | ||
| 77 | "(if (rest-args) " | ||
| 78 | "(setix struct i (rest-args 0)) " | ||
| 79 | "(ix struct i)))) ", | ||
| 80 | #endif | ||
| 81 | #endif //LBM_DYN_FUNS | ||
| 82 | #ifdef LBM_USE_DYN_ARRAYS | ||
| 83 | "(defun list-to-array (ls)" | ||
| 84 | "(let ((n (length ls)) (arr (mkarray n)) (i 0)) {" | ||
| 85 | "(loopforeach e ls { (setix arr i e) (setq i (+ i 1)) }) arr }))", | ||
| 86 | |||
| 87 | "(defun array-to-list (arr)" | ||
| 88 | "(let ((n (length arr)) (ls nil)) {" | ||
| 89 | "(loopfor i (- n 1) (>= i 0) (- i 1) { (setq ls (cons (ix arr i) ls)) }) ls }))", | ||
| 90 | |||
| 91 | "(defun array? (a) (eq (type-of a) type-lisparray))", | ||
| 92 | #endif | ||
| 93 | }; | ||
| 94 | #endif // defined(LBM_USE_DYN_FUNS) || defined(LBM_USE_DYN_ARRAYS) | ||
| 95 | |||
| 96 | |||
| 97 | #ifdef LBM_USE_DYN_MACROS | ||
| 98 | static const char* lbm_dyn_macros[] = { | ||
| 99 | "(define defun (macro (name args body) (me-defun name args body)))", | ||
| 100 | "(define defunret (macro (name args body) (me-defunret name args body)))", | ||
| 101 | "(define defmacro (macro (name args body) `(define ,name (macro ,args ,body))))", | ||
| 102 | #ifdef LBM_USE_DYN_LOOPS | ||
| 103 | "(define loopfor (macro (it start cnd update body) (me-loopfor it start cnd update body)))", | ||
| 104 | "(define loopwhile (macro (cnd body) (me-loopwhile cnd body)))", | ||
| 105 | "(define looprange (macro (it start end body) (me-looprange it start end body)))", | ||
| 106 | "(define loopforeach (macro (it lst body) (me-loopforeach it lst body)))", | ||
| 107 | "(define loopwhile-thd (macro (stk cnd body) `(spawn ,@(if (list? stk) stk (list stk)) (fn () (loopwhile ,cnd ,body)))))", | ||
| 108 | #endif | ||
| 109 | #ifdef LBM_USE_DYN_DEFSTRUCT | ||
| 110 | "(define defstruct (macro (name list-of-fields)" | ||
| 111 | "{" | ||
| 112 | "(var num-fields (length list-of-fields))" | ||
| 113 | "(var name-as-string (sym2str name))" | ||
| 114 | "(var new-create-sym (str2sym (str-merge \"make-\" name-as-string)))" | ||
| 115 | "(var new-pred-sym (str2sym (str-merge name-as-string \"?\")))" | ||
| 116 | "(var field-ix (zip list-of-fields (range 1 (+ num-fields 1))))" | ||
| 117 | "`(progn" | ||
| 118 | "(define ,new-create-sym (lambda () (create-struct (rest-args 0) ',name ,num-fields)))" | ||
| 119 | "(define ,new-pred-sym (lambda (struct) (is-struct struct ',name)))" | ||
| 120 | ",@(map (lambda (x) (list define (accessor-sym name-as-string (car x))" | ||
| 121 | "(access-set (cdr x)))) field-ix)" | ||
| 122 | "'t" | ||
| 123 | ")" | ||
| 124 | "}))", | ||
| 125 | #endif | ||
| 126 | }; | ||
| 127 | |||
| 128 | static lbm_uint sym_return; | ||
| 129 | |||
| 130 | 145 | static lbm_value ext_me_defun(lbm_value *argsi, lbm_uint argn) { | |
| 131 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 144 times.
|
145 | if (argn != 3) { |
| 132 | 1 | return ENC_SYM_EERROR; | |
| 133 | } | ||
| 134 | |||
| 135 | 144 | lbm_value name = argsi[0]; | |
| 136 | 144 | lbm_value args = argsi[1]; | |
| 137 | 144 | lbm_value body = argsi[2]; | |
| 138 | |||
| 139 | // (define name (lambda args body)) | ||
| 140 | |||
| 141 | 144 | return make_list(3, | |
| 142 | ENC_SYM_DEFINE, | ||
| 143 | name, | ||
| 144 | mk_lam(args, body)); | ||
| 145 | } | ||
| 146 | |||
| 147 | 2 | static lbm_value ext_me_defunret(lbm_value *argsi, lbm_uint argn) { | |
| 148 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 1 times.
|
2 | if (argn != 3) { |
| 149 | 1 | return ENC_SYM_EERROR; | |
| 150 | } | ||
| 151 | |||
| 152 | 1 | lbm_value name = argsi[0]; | |
| 153 | 1 | lbm_value args = argsi[1]; | |
| 154 | 1 | lbm_value body = argsi[2]; | |
| 155 | |||
| 156 | // (def name (lambda args (call-cc (lambda (return) body)))) | ||
| 157 | |||
| 158 | 1 | return make_list(3, | |
| 159 | ENC_SYM_DEFINE, | ||
| 160 | name, | ||
| 161 | mk_lam(args, | ||
| 162 | mk_call_cc(mk_lam(make_list(1, lbm_enc_sym(sym_return)), | ||
| 163 | body)))); | ||
| 164 | } | ||
| 165 | |||
| 166 | #endif | ||
| 167 | |||
| 168 | // DYN LOOPS //////////////////////////////////////////////////////////// | ||
| 169 | #ifdef LBM_USE_DYN_LOOPS | ||
| 170 | |||
| 171 | static lbm_uint sym_res; | ||
| 172 | static lbm_uint sym_loop; | ||
| 173 | static lbm_uint sym_break; | ||
| 174 | static lbm_uint sym_brk; | ||
| 175 | static lbm_uint sym_rst; | ||
| 176 | static lbm_uint sym_return; | ||
| 177 | |||
| 178 | 329 | static lbm_value ext_me_loopfor(lbm_value *args, lbm_uint argn) { | |
| 179 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 328 times.
|
329 | if (argn != 5) { |
| 180 | 1 | return ENC_SYM_EERROR; | |
| 181 | } | ||
| 182 | |||
| 183 | 328 | lbm_value it = args[0]; | |
| 184 | 328 | lbm_value start = args[1]; | |
| 185 | 328 | lbm_value cond = args[2]; | |
| 186 | 328 | lbm_value update = args[3]; | |
| 187 | 328 | lbm_value body = args[4]; | |
| 188 | |||
| 189 | // (call-cc-unsafe | ||
| 190 | // (lambda (break) | ||
| 191 | // (let ((loop (lambda (it res) | ||
| 192 | // (if cond (loop update body) res)))) | ||
| 193 | // (loop start nil)))) | ||
| 194 | |||
| 195 | 328 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 196 | 328 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 197 | 328 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 198 | |||
| 199 | 328 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 200 | mk_let(make_list(1, | ||
| 201 | make_list(2, | ||
| 202 | enc_sym_loop, | ||
| 203 | mk_lam(make_list(2, it, enc_sym_res), | ||
| 204 | mk_if(cond, | ||
| 205 | make_list(3, enc_sym_loop, update, body), | ||
| 206 | enc_sym_res)))), | ||
| 207 | make_list(3, enc_sym_loop, start, ENC_SYM_NIL)))); | ||
| 208 | } | ||
| 209 | |||
| 210 | 119 | static lbm_value ext_me_loopwhile(lbm_value *args, lbm_uint argn) { | |
| 211 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 118 times.
|
119 | if (argn != 2) { |
| 212 | 1 | return ENC_SYM_EERROR; | |
| 213 | } | ||
| 214 | |||
| 215 | 118 | lbm_value cond = args[0]; | |
| 216 | 118 | lbm_value body = args[1]; | |
| 217 | |||
| 218 | //(call-cc-unsafe | ||
| 219 | // (lambda (break) | ||
| 220 | // (let ((loop (lambda (res) | ||
| 221 | // (if cond (loop body) res)))) | ||
| 222 | // (loop nil)))) | ||
| 223 | |||
| 224 | 118 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 225 | 118 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 226 | 118 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 227 | |||
| 228 | 118 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 229 | mk_let(make_list(1, | ||
| 230 | make_list(2, | ||
| 231 | enc_sym_loop, | ||
| 232 | mk_lam(make_list(1, enc_sym_res), | ||
| 233 | mk_if(cond, | ||
| 234 | make_list(2,enc_sym_loop, body), | ||
| 235 | enc_sym_res)))), | ||
| 236 | (make_list(2, enc_sym_loop, ENC_SYM_NIL))))); | ||
| 237 | } | ||
| 238 | |||
| 239 | 116 | static lbm_value ext_me_looprange(lbm_value *args, lbm_uint argn) { | |
| 240 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 115 times.
|
116 | if (argn != 4) { |
| 241 | 1 | return ENC_SYM_EERROR; | |
| 242 | } | ||
| 243 | |||
| 244 | 115 | lbm_value it = args[0]; | |
| 245 | 115 | lbm_value start = args[1]; | |
| 246 | 115 | lbm_value end = args[2]; | |
| 247 | 115 | lbm_value body = args[3]; | |
| 248 | |||
| 249 | // (call-cc-unsafe | ||
| 250 | // (lambda (break) | ||
| 251 | // (let ((loop (lambda (it res) | ||
| 252 | // (if (< it end) | ||
| 253 | // (loop (+ it 1) body) | ||
| 254 | // res)))) | ||
| 255 | // (loop start nil)))) | ||
| 256 | |||
| 257 | 115 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 258 | 115 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 259 | 115 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 260 | |||
| 261 | 115 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 262 | mk_let(make_list(1, | ||
| 263 | make_list(2, | ||
| 264 | enc_sym_loop, | ||
| 265 | mk_lam(make_list(2, it, enc_sym_res), | ||
| 266 | mk_if(mk_lt(it, end), | ||
| 267 | make_list(3, | ||
| 268 | enc_sym_loop, | ||
| 269 | mk_inc(it), | ||
| 270 | body), | ||
| 271 | enc_sym_res)))), | ||
| 272 | make_list(3, enc_sym_loop, start, ENC_SYM_NIL)))); | ||
| 273 | } | ||
| 274 | |||
| 275 | // TODO: Something that does not work as expected with this | ||
| 276 | // definition of loopforeach is (loopforeach e (list nil nil nil) ...). | ||
| 277 | |||
| 278 | 897 | static lbm_value ext_me_loopforeach(lbm_value *args, lbm_uint argn) { | |
| 279 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 896 times.
|
897 | if (argn != 3) { |
| 280 | 1 | return ENC_SYM_EERROR; | |
| 281 | } | ||
| 282 | |||
| 283 | 896 | lbm_value it = args[0]; | |
| 284 | 896 | lbm_value lst = args[1]; | |
| 285 | 896 | lbm_value body = args[2]; | |
| 286 | |||
| 287 | //(call-cc-unsafe | ||
| 288 | // (lambda (break) | ||
| 289 | // (let ((loop (lambda (rst it res) | ||
| 290 | // (if (eq it nil) | ||
| 291 | // res | ||
| 292 | // (loop (car rst) (cdr rst) body))))) | ||
| 293 | // (loop (car lst) (cdr lst) nil)))) | ||
| 294 | |||
| 295 | 896 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 296 | 896 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 297 | 896 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 298 | 896 | lbm_value enc_sym_rst = lbm_enc_sym(sym_rst); | |
| 299 | |||
| 300 | 896 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 301 | mk_let(make_list(1, | ||
| 302 | make_list(2, | ||
| 303 | enc_sym_loop, | ||
| 304 | mk_lam(make_list(3, | ||
| 305 | it, | ||
| 306 | enc_sym_rst, | ||
| 307 | enc_sym_res), | ||
| 308 | mk_if(mk_eq(it, ENC_SYM_NIL), | ||
| 309 | enc_sym_res, | ||
| 310 | (make_list(4, | ||
| 311 | enc_sym_loop, | ||
| 312 | mk_car(enc_sym_rst), | ||
| 313 | mk_cdr(enc_sym_rst), | ||
| 314 | body)))))), | ||
| 315 | (make_list(4, | ||
| 316 | enc_sym_loop, | ||
| 317 | mk_car(lst), | ||
| 318 | mk_cdr(lst), | ||
| 319 | ENC_SYM_NIL))))); | ||
| 320 | } | ||
| 321 | #endif | ||
| 322 | |||
| 323 | |||
| 324 | // DYN_LIB_INIT //////////////////////////////////////////////////////////// | ||
| 325 | 44335 | void lbm_dyn_lib_init(void) { | |
| 326 | #ifdef LBM_USE_DYN_MACROS | ||
| 327 | 44335 | lbm_add_symbol_const("return", &sym_return); | |
| 328 | |||
| 329 | 44335 | lbm_add_extension("me-defun", ext_me_defun); | |
| 330 | 44335 | lbm_add_extension("me-defunret", ext_me_defunret); | |
| 331 | #ifdef LBM_USE_DYN_LOOPS | ||
| 332 | 44335 | lbm_add_symbol_const("a01", &sym_res); | |
| 333 | 44335 | lbm_add_symbol_const("a02", &sym_loop); | |
| 334 | 44335 | lbm_add_symbol_const("break", &sym_break); | |
| 335 | 44335 | lbm_add_symbol_const("a03", &sym_brk); | |
| 336 | 44335 | lbm_add_symbol_const("a04", &sym_rst); | |
| 337 | 44335 | lbm_add_symbol_const("return", &sym_return); | |
| 338 | |||
| 339 | 44335 | lbm_add_extension("me-loopfor", ext_me_loopfor); | |
| 340 | 44335 | lbm_add_extension("me-loopwhile", ext_me_loopwhile); | |
| 341 | 44335 | lbm_add_extension("me-looprange", ext_me_looprange); | |
| 342 | 44335 | lbm_add_extension("me-loopforeach", ext_me_loopforeach); | |
| 343 | #endif | ||
| 344 | #endif | ||
| 345 | 44335 | } | |
| 346 | |||
| 347 | 2249 | bool lbm_dyn_lib_find(const char *str, const char **code) { | |
| 348 | #ifndef LBM_USE_DYN_MACROS | ||
| 349 | #ifndef LBM_USE_DYN_FUNS | ||
| 350 | (void)str; | ||
| 351 | (void)code; | ||
| 352 | #endif | ||
| 353 | #endif | ||
| 354 | |||
| 355 | #ifdef LBM_USE_DYN_MACROS | ||
| 356 |
2/2✓ Branch 0 taken 14394 times.
✓ Branch 1 taken 851 times.
|
15245 | for (unsigned int i = 0; i < (sizeof(lbm_dyn_macros) / sizeof(lbm_dyn_macros[0]));i++) { |
| 357 |
2/2✓ Branch 0 taken 1398 times.
✓ Branch 1 taken 12996 times.
|
14394 | if (strmatch(str, lbm_dyn_macros[i] + 8)) { // define is 6 char |
| 358 | 1398 | *code = lbm_dyn_macros[i]; | |
| 359 | 1398 | return true; | |
| 360 | } | ||
| 361 | } | ||
| 362 | #endif | ||
| 363 | |||
| 364 | #if defined(LBM_USE_DYN_FUNS) || defined(LBM_USE_DYN_ARRAYS) | ||
| 365 |
2/2✓ Branch 0 taken 11494 times.
✓ Branch 1 taken 177 times.
|
11671 | for (unsigned int i = 0; i < (sizeof(lbm_dyn_fun) / sizeof(lbm_dyn_fun[0]));i++) { |
| 366 |
2/2✓ Branch 0 taken 674 times.
✓ Branch 1 taken 10820 times.
|
11494 | if (strmatch(str, lbm_dyn_fun[i] + 7)) { // defun is 5 |
| 367 | 674 | *code = lbm_dyn_fun[i]; | |
| 368 | 674 | return true; | |
| 369 | } | ||
| 370 | } | ||
| 371 | #endif | ||
| 372 | 177 | return false; | |
| 373 | } | ||
| 374 |