| 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 (name num-fields initials) { " | ||
| 63 | "(var arr (mkarray (+ 1 num-fields))) " | ||
| 64 | "(setix arr 0 name) " | ||
| 65 | "(var num_inits (length initials))" | ||
| 66 | "(if initials (loopfor i 0 (and (< i num-fields) (< i num_inits)) (+ i 1) (setix arr (+ i 1) (ix initials i))))" | ||
| 67 | "arr " | ||
| 68 | "})", | ||
| 69 | |||
| 70 | "(defun is-struct (struct name) " | ||
| 71 | "(and (eq (type-of struct) type-lisparray) " | ||
| 72 | "(eq (ix struct 0) name)))", | ||
| 73 | |||
| 74 | "(defun accessor-sym (name field) " | ||
| 75 | "(str2sym (str-merge name \"-\" (sym2str field))))", | ||
| 76 | |||
| 77 | "(defun access-set (i) " | ||
| 78 | "(lambda (struct) " | ||
| 79 | "(if (rest-args) " | ||
| 80 | "(setix struct i (rest-args 0)) " | ||
| 81 | "(ix struct i)))) ", | ||
| 82 | #endif | ||
| 83 | #endif //LBM_DYN_FUNS | ||
| 84 | #ifdef LBM_USE_DYN_ARRAYS | ||
| 85 | "(defun list-to-array (ls)" | ||
| 86 | "(let ((n (length ls)) (arr (mkarray n)) (i 0)) {" | ||
| 87 | "(loopforeach e ls { (setix arr i e) (setq i (+ i 1)) }) arr }))", | ||
| 88 | |||
| 89 | "(defun array-to-list (arr)" | ||
| 90 | "(let ((n (length arr)) (ls nil)) {" | ||
| 91 | "(loopfor i (- n 1) (>= i 0) (- i 1) { (setq ls (cons (ix arr i) ls)) }) ls }))", | ||
| 92 | |||
| 93 | "(defun array? (a) (eq (type-of a) type-lisparray))", | ||
| 94 | #endif | ||
| 95 | }; | ||
| 96 | #endif // defined(LBM_USE_DYN_FUNS) || defined(LBM_USE_DYN_ARRAYS) | ||
| 97 | |||
| 98 | |||
| 99 | #ifdef LBM_USE_DYN_MACROS | ||
| 100 | static const char* lbm_dyn_macros[] = { | ||
| 101 | "(define defun (macro (name args body) (me-defun name args body)))", | ||
| 102 | "(define defunret (macro (name args body) (me-defunret name args body)))", | ||
| 103 | "(define defmacro (macro (name args body) `(define ,name (macro ,args ,body))))", | ||
| 104 | #ifdef LBM_USE_DYN_LOOPS | ||
| 105 | "(define loopfor (macro (it start cnd update body) (me-loopfor it start cnd update body)))", | ||
| 106 | "(define loopwhile (macro (cnd body) (me-loopwhile cnd body)))", | ||
| 107 | "(define looprange (macro (it start end body) (me-looprange it start end body)))", | ||
| 108 | "(define loopforeach (macro (it lst body) (me-loopforeach it lst body)))", | ||
| 109 | "(define loopwhile-thd (macro (stk cnd body) `(spawn ,@(if (list? stk) stk (list stk)) (fn () (loopwhile ,cnd ,body)))))", | ||
| 110 | #endif | ||
| 111 | #ifdef LBM_USE_DYN_DEFSTRUCT | ||
| 112 | "(define defstruct (macro (name list-of-fields)" | ||
| 113 | "{" | ||
| 114 | "(var num-fields (length list-of-fields))" | ||
| 115 | "(var name-as-string (sym2str name))" | ||
| 116 | "(var new-create-sym (str2sym (str-merge \"make-\" name-as-string)))" | ||
| 117 | "(var new-pred-sym (str2sym (str-merge name-as-string \"?\")))" | ||
| 118 | "(var field-ix (zip list-of-fields (range 1 (+ num-fields 1))))" | ||
| 119 | "`(progn" | ||
| 120 | "(define ,new-create-sym (lambda () (create-struct ',name ,num-fields (rest-args))))" | ||
| 121 | "(define ,new-pred-sym (lambda (struct) (is-struct struct ',name)))" | ||
| 122 | ",@(map (lambda (x) (list define (accessor-sym name-as-string (car x))" | ||
| 123 | "(access-set (cdr x)))) field-ix)" | ||
| 124 | "'t" | ||
| 125 | ")" | ||
| 126 | "}))", | ||
| 127 | #endif | ||
| 128 | }; | ||
| 129 | |||
| 130 | static lbm_uint sym_return; | ||
| 131 | |||
| 132 | 255 | static lbm_value ext_me_defun(lbm_value *argsi, lbm_uint argn) { | |
| 133 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 254 times.
|
255 | if (argn != 3) { |
| 134 | 1 | return ENC_SYM_EERROR; | |
| 135 | } | ||
| 136 | |||
| 137 | 254 | lbm_value name = argsi[0]; | |
| 138 | 254 | lbm_value args = argsi[1]; | |
| 139 | 254 | lbm_value body = argsi[2]; | |
| 140 | |||
| 141 | // (define name (lambda args body)) | ||
| 142 | |||
| 143 | 254 | return make_list(3, | |
| 144 | ENC_SYM_DEFINE, | ||
| 145 | name, | ||
| 146 | mk_lam(args, body)); | ||
| 147 | } | ||
| 148 | |||
| 149 | 2 | static lbm_value ext_me_defunret(lbm_value *argsi, lbm_uint argn) { | |
| 150 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 1 times.
|
2 | if (argn != 3) { |
| 151 | 1 | return ENC_SYM_EERROR; | |
| 152 | } | ||
| 153 | |||
| 154 | 1 | lbm_value name = argsi[0]; | |
| 155 | 1 | lbm_value args = argsi[1]; | |
| 156 | 1 | lbm_value body = argsi[2]; | |
| 157 | |||
| 158 | // (def name (lambda args (call-cc (lambda (return) body)))) | ||
| 159 | |||
| 160 | 1 | return make_list(3, | |
| 161 | ENC_SYM_DEFINE, | ||
| 162 | name, | ||
| 163 | mk_lam(args, | ||
| 164 | mk_call_cc(mk_lam(make_list(1, lbm_enc_sym(sym_return)), | ||
| 165 | body)))); | ||
| 166 | } | ||
| 167 | |||
| 168 | #endif | ||
| 169 | |||
| 170 | // DYN LOOPS //////////////////////////////////////////////////////////// | ||
| 171 | #ifdef LBM_USE_DYN_LOOPS | ||
| 172 | |||
| 173 | static lbm_uint sym_res; | ||
| 174 | static lbm_uint sym_loop; | ||
| 175 | static lbm_uint sym_break; | ||
| 176 | static lbm_uint sym_brk; | ||
| 177 | static lbm_uint sym_rst; | ||
| 178 | static lbm_uint sym_return; | ||
| 179 | |||
| 180 | 495 | static lbm_value ext_me_loopfor(lbm_value *args, lbm_uint argn) { | |
| 181 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 494 times.
|
495 | if (argn != 5) { |
| 182 | 1 | return ENC_SYM_EERROR; | |
| 183 | } | ||
| 184 | |||
| 185 | 494 | lbm_value it = args[0]; | |
| 186 | 494 | lbm_value start = args[1]; | |
| 187 | 494 | lbm_value cond = args[2]; | |
| 188 | 494 | lbm_value update = args[3]; | |
| 189 | 494 | lbm_value body = args[4]; | |
| 190 | |||
| 191 | // (call-cc-unsafe | ||
| 192 | // (lambda (break) | ||
| 193 | // (let ((loop (lambda (it res) | ||
| 194 | // (if cond (loop update body) res)))) | ||
| 195 | // (loop start nil)))) | ||
| 196 | |||
| 197 | 494 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 198 | 494 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 199 | 494 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 200 | |||
| 201 | 494 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 202 | mk_let(make_list(1, | ||
| 203 | make_list(2, | ||
| 204 | enc_sym_loop, | ||
| 205 | mk_lam(make_list(2, it, enc_sym_res), | ||
| 206 | mk_if(cond, | ||
| 207 | make_list(3, enc_sym_loop, update, body), | ||
| 208 | enc_sym_res)))), | ||
| 209 | make_list(3, enc_sym_loop, start, ENC_SYM_NIL)))); | ||
| 210 | } | ||
| 211 | |||
| 212 | 181 | static lbm_value ext_me_loopwhile(lbm_value *args, lbm_uint argn) { | |
| 213 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 180 times.
|
181 | if (argn != 2) { |
| 214 | 1 | return ENC_SYM_EERROR; | |
| 215 | } | ||
| 216 | |||
| 217 | 180 | lbm_value cond = args[0]; | |
| 218 | 180 | lbm_value body = args[1]; | |
| 219 | |||
| 220 | //(call-cc-unsafe | ||
| 221 | // (lambda (break) | ||
| 222 | // (let ((loop (lambda (res) | ||
| 223 | // (if cond (loop body) res)))) | ||
| 224 | // (loop nil)))) | ||
| 225 | |||
| 226 | 180 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 227 | 180 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 228 | 180 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 229 | |||
| 230 | 180 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 231 | mk_let(make_list(1, | ||
| 232 | make_list(2, | ||
| 233 | enc_sym_loop, | ||
| 234 | mk_lam(make_list(1, enc_sym_res), | ||
| 235 | mk_if(cond, | ||
| 236 | make_list(2,enc_sym_loop, body), | ||
| 237 | enc_sym_res)))), | ||
| 238 | (make_list(2, enc_sym_loop, ENC_SYM_NIL))))); | ||
| 239 | } | ||
| 240 | |||
| 241 | 186 | static lbm_value ext_me_looprange(lbm_value *args, lbm_uint argn) { | |
| 242 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 185 times.
|
186 | if (argn != 4) { |
| 243 | 1 | return ENC_SYM_EERROR; | |
| 244 | } | ||
| 245 | |||
| 246 | 185 | lbm_value it = args[0]; | |
| 247 | 185 | lbm_value start = args[1]; | |
| 248 | 185 | lbm_value end = args[2]; | |
| 249 | 185 | lbm_value body = args[3]; | |
| 250 | |||
| 251 | // (call-cc-unsafe | ||
| 252 | // (lambda (break) | ||
| 253 | // (let ((loop (lambda (it res) | ||
| 254 | // (if (< it end) | ||
| 255 | // (loop (+ it 1) body) | ||
| 256 | // res)))) | ||
| 257 | // (loop start nil)))) | ||
| 258 | |||
| 259 | 185 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 260 | 185 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 261 | 185 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 262 | |||
| 263 | 185 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 264 | mk_let(make_list(1, | ||
| 265 | make_list(2, | ||
| 266 | enc_sym_loop, | ||
| 267 | mk_lam(make_list(2, it, enc_sym_res), | ||
| 268 | mk_if(mk_lt(it, end), | ||
| 269 | make_list(3, | ||
| 270 | enc_sym_loop, | ||
| 271 | mk_inc(it), | ||
| 272 | body), | ||
| 273 | enc_sym_res)))), | ||
| 274 | make_list(3, enc_sym_loop, start, ENC_SYM_NIL)))); | ||
| 275 | } | ||
| 276 | |||
| 277 | // TODO: Something that does not work as expected with this | ||
| 278 | // definition of loopforeach is (loopforeach e (list nil nil nil) ...). | ||
| 279 | |||
| 280 | 1345 | static lbm_value ext_me_loopforeach(lbm_value *args, lbm_uint argn) { | |
| 281 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 1344 times.
|
1345 | if (argn != 3) { |
| 282 | 1 | return ENC_SYM_EERROR; | |
| 283 | } | ||
| 284 | |||
| 285 | 1344 | lbm_value it = args[0]; | |
| 286 | 1344 | lbm_value lst = args[1]; | |
| 287 | 1344 | lbm_value body = args[2]; | |
| 288 | |||
| 289 | //(call-cc-unsafe | ||
| 290 | // (lambda (break) | ||
| 291 | // (let ((loop (lambda (rst it res) | ||
| 292 | // (if (eq it nil) | ||
| 293 | // res | ||
| 294 | // (loop (car rst) (cdr rst) body))))) | ||
| 295 | // (loop (car lst) (cdr lst) nil)))) | ||
| 296 | |||
| 297 | 1344 | lbm_value enc_sym_loop = lbm_enc_sym(sym_loop); // maybe do one time at init? | |
| 298 | 1344 | lbm_value enc_sym_break = lbm_enc_sym(sym_break); | |
| 299 | 1344 | lbm_value enc_sym_res = lbm_enc_sym(sym_res); | |
| 300 | 1344 | lbm_value enc_sym_rst = lbm_enc_sym(sym_rst); | |
| 301 | |||
| 302 | 1344 | return mk_call_cc(mk_lam(make_list(1, enc_sym_break), | |
| 303 | mk_let(make_list(1, | ||
| 304 | make_list(2, | ||
| 305 | enc_sym_loop, | ||
| 306 | mk_lam(make_list(3, | ||
| 307 | it, | ||
| 308 | enc_sym_rst, | ||
| 309 | enc_sym_res), | ||
| 310 | mk_if(mk_eq(it, ENC_SYM_NIL), | ||
| 311 | enc_sym_res, | ||
| 312 | (make_list(4, | ||
| 313 | enc_sym_loop, | ||
| 314 | mk_car(enc_sym_rst), | ||
| 315 | mk_cdr(enc_sym_rst), | ||
| 316 | body)))))), | ||
| 317 | (make_list(4, | ||
| 318 | enc_sym_loop, | ||
| 319 | mk_car(lst), | ||
| 320 | mk_cdr(lst), | ||
| 321 | ENC_SYM_NIL))))); | ||
| 322 | } | ||
| 323 | #endif | ||
| 324 | |||
| 325 | |||
| 326 | // DYN_LIB_INIT //////////////////////////////////////////////////////////// | ||
| 327 | 66493 | void lbm_dyn_lib_init(void) { | |
| 328 | #ifdef LBM_USE_DYN_MACROS | ||
| 329 | 66493 | lbm_add_symbol_const("return", &sym_return); | |
| 330 | |||
| 331 | 66493 | lbm_add_extension("me-defun", ext_me_defun); | |
| 332 | 66493 | lbm_add_extension("me-defunret", ext_me_defunret); | |
| 333 | #ifdef LBM_USE_DYN_LOOPS | ||
| 334 | 66493 | lbm_add_symbol_const("a01", &sym_res); | |
| 335 | 66493 | lbm_add_symbol_const("a02", &sym_loop); | |
| 336 | 66493 | lbm_add_symbol_const("break", &sym_break); | |
| 337 | 66493 | lbm_add_symbol_const("a03", &sym_brk); | |
| 338 | 66493 | lbm_add_symbol_const("a04", &sym_rst); | |
| 339 | 66493 | lbm_add_symbol_const("return", &sym_return); | |
| 340 | |||
| 341 | 66493 | lbm_add_extension("me-loopfor", ext_me_loopfor); | |
| 342 | 66493 | lbm_add_extension("me-loopwhile", ext_me_loopwhile); | |
| 343 | 66493 | lbm_add_extension("me-looprange", ext_me_looprange); | |
| 344 | 66493 | lbm_add_extension("me-loopforeach", ext_me_loopforeach); | |
| 345 | #endif | ||
| 346 | #endif | ||
| 347 | 66493 | } | |
| 348 | |||
| 349 | 3405 | bool lbm_dyn_lib_find(const char *str, const char **code) { | |
| 350 | #ifndef LBM_USE_DYN_MACROS | ||
| 351 | #ifndef LBM_USE_DYN_FUNS | ||
| 352 | (void)str; | ||
| 353 | (void)code; | ||
| 354 | #endif | ||
| 355 | #endif | ||
| 356 | |||
| 357 | #ifdef LBM_USE_DYN_MACROS | ||
| 358 |
2/2✓ Branch 0 taken 21888 times.
✓ Branch 1 taken 1303 times.
|
23191 | for (unsigned int i = 0; i < (sizeof(lbm_dyn_macros) / sizeof(lbm_dyn_macros[0]));i++) { |
| 359 |
2/2✓ Branch 0 taken 2102 times.
✓ Branch 1 taken 19786 times.
|
21888 | if (strmatch(str, lbm_dyn_macros[i] + 8)) { // define is 6 char |
| 360 | 2102 | *code = lbm_dyn_macros[i]; | |
| 361 | 2102 | return true; | |
| 362 | } | ||
| 363 | } | ||
| 364 | #endif | ||
| 365 | |||
| 366 | #if defined(LBM_USE_DYN_FUNS) || defined(LBM_USE_DYN_ARRAYS) | ||
| 367 |
2/2✓ Branch 0 taken 17607 times.
✓ Branch 1 taken 276 times.
|
17883 | for (unsigned int i = 0; i < (sizeof(lbm_dyn_fun) / sizeof(lbm_dyn_fun[0]));i++) { |
| 368 |
2/2✓ Branch 0 taken 1027 times.
✓ Branch 1 taken 16580 times.
|
17607 | if (strmatch(str, lbm_dyn_fun[i] + 7)) { // defun is 5 |
| 369 | 1027 | *code = lbm_dyn_fun[i]; | |
| 370 | 1027 | return true; | |
| 371 | } | ||
| 372 | } | ||
| 373 | #endif | ||
| 374 | 276 | return false; | |
| 375 | } | ||
| 376 |