├── LICENSE ├── README.md ├── aria.c ├── aria.h ├── build.sh ├── lib.lsp └── script ├── fib.lsp ├── hello.lsp ├── life.lsp ├── mandelbrot.lsp └── titleize.lsp /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Copyright (c) 2018 rxi 3 | 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # aria 2 | A *tiny*, easily embeddable lisp-shaped language implemented in C89. 3 | 4 | ```lisp 5 | (do 6 | 7 | (= fib (fn (n) 8 | (if (>= n 2) 9 | (+ (fib (- n 1)) (fib (- n 2))) 10 | n))) 11 | 12 | (print (fib 20))) ; prints 6765 13 | ``` 14 | 15 | 16 | ## Overview 17 | * Supports numbers (floats), symbols, strings, pairs, lambdas, macros 18 | * Stack tracebacks with filename and line numbers on error 19 | * Exception-like error handling 20 | * Simple implementation and garbage collector 21 | * Easy-to-use C API 22 | 23 | 24 | ## License 25 | This library is free software; you can redistribute it and/or modify it under 26 | the terms of the MIT license. See [LICENSE](LICENSE) for details. 27 | -------------------------------------------------------------------------------- /aria.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2018 rxi 3 | * 4 | * This library is free software; you can redistribute it and/or modify it 5 | * under the terms of the MIT license. See LICENSE for details. 6 | */ 7 | 8 | #include "aria.h" 9 | 10 | #define MAX_STACK 1024 11 | #define CHUNK_LEN 1024 12 | 13 | #define UNUSED(x) ((void) x) 14 | 15 | 16 | struct ar_Chunk { 17 | ar_Value values[CHUNK_LEN]; 18 | struct ar_Chunk *next; 19 | }; 20 | 21 | 22 | static void *zrealloc(ar_State *S, void *ptr, size_t n) { 23 | void *p = S->alloc(S->udata, ptr, n); 24 | if (!p) ar_error(S, S->oom_error); 25 | return p; 26 | } 27 | 28 | static void zfree(ar_State *S, void *ptr) { 29 | S->alloc(S, ptr, 0); 30 | } 31 | 32 | 33 | /*=========================================================================== 34 | * Value 35 | *===========================================================================*/ 36 | 37 | static void push_value_to_stack(ar_State *S, ar_Value *v) { 38 | /* Expand stack's capacity? */ 39 | if (S->gc_stack_idx == S->gc_stack_cap) { 40 | int n = (S->gc_stack_cap << 1) | !S->gc_stack_cap; 41 | S->gc_stack = zrealloc(S, S->gc_stack, n * sizeof(*S->gc_stack)); 42 | S->gc_stack_cap = n; 43 | } 44 | /* Push value */ 45 | S->gc_stack[S->gc_stack_idx++] = v; 46 | } 47 | 48 | 49 | static ar_Value *new_value(ar_State *S, int type) { 50 | ar_Value *v; 51 | /* Run garbage collector? */ 52 | S->gc_count--; 53 | if (!S->gc_pool && S->gc_count < 0) { 54 | ar_gc(S); 55 | } 56 | /* No values in pool? Create and init new chunk */ 57 | if (!S->gc_pool) { 58 | int i; 59 | ar_Chunk *c = zrealloc(S, NULL, sizeof(*c)); 60 | c->next = S->gc_chunks; 61 | S->gc_chunks = c; 62 | /* Init all chunk's values and link them together, set the currently-empty 63 | * pool to point to this new list */ 64 | for (i = 0; i < CHUNK_LEN; i++) { 65 | c->values[i].type = AR_TNIL; 66 | c->values[i].u.pair.cdr = (c->values + i + 1); 67 | } 68 | c->values[CHUNK_LEN - 1].u.pair.cdr = NULL; 69 | S->gc_pool = c->values; 70 | } 71 | /* Get value from pool */ 72 | v = S->gc_pool; 73 | S->gc_pool = v->u.pair.cdr; 74 | /* Init */ 75 | v->type = type; 76 | v->mark = 0; 77 | push_value_to_stack(S, v); 78 | return v; 79 | } 80 | 81 | 82 | ar_Value *ar_new_env(ar_State *S, ar_Value *parent) { 83 | ar_Value *res = new_value(S, AR_TENV); 84 | res->u.env.parent = parent; 85 | res->u.env.map = NULL; 86 | return res; 87 | } 88 | 89 | 90 | ar_Value *ar_new_pair(ar_State *S, ar_Value *car, ar_Value *cdr) { 91 | ar_Value *res = new_value(S, AR_TPAIR); 92 | res->u.pair.car = car; 93 | res->u.pair.cdr = cdr; 94 | res->u.pair.dbg = NULL; 95 | return res; 96 | } 97 | 98 | 99 | ar_Value *ar_new_list(ar_State *S, size_t n, ...) { 100 | va_list args; 101 | ar_Value *res = NULL, **last = &res; 102 | va_start(args, n); 103 | while (n--) { 104 | last = ar_append_tail(S, last, va_arg(args, ar_Value*)); 105 | } 106 | va_end(args); 107 | return res; 108 | } 109 | 110 | 111 | ar_Value *ar_new_number(ar_State *S, double n) { 112 | ar_Value *res = new_value(S, AR_TNUMBER); 113 | res->u.num.n = n; 114 | return res; 115 | } 116 | 117 | 118 | ar_Value *ar_new_udata(ar_State *S, void *ptr, ar_CFunc gc, ar_CFunc mark) { 119 | ar_Value *res = new_value(S, AR_TUDATA); 120 | res->u.udata.ptr = ptr; 121 | res->u.udata.gc = gc; 122 | res->u.udata.mark = mark; 123 | return res; 124 | } 125 | 126 | 127 | ar_Value *ar_new_stringl(ar_State *S, const char *str, size_t len) { 128 | ar_Value *v = new_value(S, AR_TSTRING); 129 | v->u.str.s = NULL; 130 | v->u.str.s = zrealloc(S, NULL, len + 1); 131 | v->u.str.s[len] = '\0'; 132 | if (str) { 133 | memcpy(v->u.str.s, str, len); 134 | } 135 | v->u.str.len = len; 136 | return v; 137 | } 138 | 139 | 140 | ar_Value *ar_new_string(ar_State *S, const char *str) { 141 | if (str == NULL) return NULL; 142 | return ar_new_stringl(S, str, strlen(str)); 143 | } 144 | 145 | 146 | ar_Value *ar_new_symbol(ar_State *S, const char *name) { 147 | ar_Value *v; 148 | /* Build hash of string */ 149 | unsigned hash = 5381; 150 | const char *p = name; 151 | while (*p) hash = ((hash << 5) + hash) ^ *p++; 152 | /* Create and init symbol */ 153 | v = ar_new_string(S, name); 154 | v->type = AR_TSYMBOL; 155 | v->u.str.hash = hash; 156 | return v; 157 | } 158 | 159 | 160 | ar_Value *ar_new_cfunc(ar_State *S, ar_CFunc fn) { 161 | ar_Value *v = new_value(S, AR_TCFUNC); 162 | v->u.cfunc.fn = fn; 163 | return v; 164 | } 165 | 166 | 167 | ar_Value *ar_new_prim(ar_State *S, ar_Prim fn) { 168 | ar_Value *v = new_value(S, AR_TPRIM); 169 | v->u.prim.fn = fn; 170 | return v; 171 | } 172 | 173 | 174 | int ar_type(ar_Value *v) { 175 | return v ? v->type : AR_TNIL; 176 | } 177 | 178 | 179 | const char *ar_type_str(int type) { 180 | switch (type) { 181 | case AR_TNIL : return "nil"; 182 | case AR_TPAIR : return "pair"; 183 | case AR_TNUMBER : return "number"; 184 | case AR_TSTRING : return "string"; 185 | case AR_TSYMBOL : return "symbol"; 186 | case AR_TFUNC : return "function"; 187 | case AR_TMACRO : return "macro"; 188 | case AR_TPRIM : return "primitive"; 189 | case AR_TCFUNC : return "cfunction"; 190 | case AR_TENV : return "env"; 191 | case AR_TUDATA : return "udata"; 192 | } 193 | return "?"; 194 | } 195 | 196 | 197 | ar_Value *ar_check(ar_State *S, ar_Value *v, int type) { 198 | if (ar_type(v) != type) { 199 | ar_error_str(S, "expected %s, got %s", 200 | ar_type_str(type), ar_type_str(ar_type(v))); 201 | } 202 | return v; 203 | } 204 | 205 | 206 | ar_Value *ar_car(ar_Value *v) { 207 | return (ar_type(v) == AR_TPAIR) ? v->u.pair.car : v; 208 | } 209 | 210 | 211 | ar_Value *ar_cdr(ar_Value *v) { 212 | return (ar_type(v) == AR_TPAIR) ? v->u.pair.cdr : NULL; 213 | } 214 | 215 | 216 | ar_Value *ar_nth(ar_Value *v, int idx) { 217 | while (v) { 218 | if (idx-- == 0) return ar_car(v); 219 | v = ar_cdr(v); 220 | } 221 | return NULL; 222 | } 223 | 224 | 225 | ar_Value **ar_append_tail(ar_State *S, ar_Value **last, ar_Value *v) { 226 | *last = ar_new_pair(S, v, NULL); 227 | return &(*last)->u.pair.cdr; 228 | } 229 | 230 | 231 | static ar_Value *join_list_of_strings(ar_State *S, ar_Value *list) { 232 | ar_Value *res; 233 | /* Get combined length of strings */ 234 | ar_Value *v = list; 235 | size_t len = 0; 236 | while (v) { 237 | len += v->u.pair.car->u.str.len; 238 | v = v->u.pair.cdr; 239 | } 240 | /* Join list of strings */ 241 | res = ar_new_stringl(S, NULL, len); 242 | v = list; 243 | len = 0; 244 | while (v) { 245 | ar_Value *x = v->u.pair.car; 246 | memcpy(res->u.str.s + len, x->u.str.s, x->u.str.len); 247 | len += x->u.str.len; 248 | v = v->u.pair.cdr; 249 | } 250 | return res; 251 | } 252 | 253 | 254 | static int escape_char(int chr) { 255 | switch (chr) { 256 | case '\t' : return 't'; 257 | case '\n' : return 'n'; 258 | case '\r' : return 'r'; 259 | case '\\' : 260 | case '"' : return chr; 261 | } 262 | return 0; 263 | } 264 | 265 | 266 | ar_Value *ar_to_string_value(ar_State *S, ar_Value *v, int quotestr) { 267 | ar_Value *res, **last; 268 | char buf[128]; 269 | char *p, *q; 270 | size_t len, sz; 271 | switch (ar_type(v)) { 272 | case AR_TNIL: 273 | return ar_new_string(S, "nil"); 274 | 275 | case AR_TSYMBOL: 276 | return ar_new_string(S, v->u.str.s); 277 | 278 | case AR_TPAIR: 279 | /* Handle empty pair */ 280 | if (!ar_car(v) && !ar_cdr(v)) { 281 | return ar_new_string(S, "()"); 282 | } 283 | /* Build list of strings */ 284 | res = NULL; 285 | last = ar_append_tail(S, &res, ar_new_string(S, "(")); 286 | while (v) { 287 | if (v->type == AR_TPAIR) { 288 | last = ar_append_tail(S, last, ar_to_string_value(S, ar_car(v), 1)); 289 | if (ar_cdr(v)) { 290 | last = ar_append_tail(S, last, ar_new_string(S, " ")); 291 | } 292 | } else { 293 | last = ar_append_tail(S, last, ar_new_string(S, ". ")); 294 | last = ar_append_tail(S, last, ar_to_string_value(S, v, 1)); 295 | } 296 | v = ar_cdr(v); 297 | } 298 | last = ar_append_tail(S, last, ar_new_string(S, ")")); 299 | return join_list_of_strings(S, res); 300 | 301 | case AR_TNUMBER: 302 | sprintf(buf, "%.14g", v->u.num.n); 303 | return ar_new_string(S, buf); 304 | 305 | case AR_TSTRING: 306 | if (quotestr) { 307 | /* Get string length + escapes and quotes */ 308 | len = 2; 309 | p = v->u.str.s; 310 | sz = v->u.str.len; 311 | while (sz--) { 312 | len += escape_char(*p++) ? 2 : 1; 313 | } 314 | /* Build quoted string */ 315 | res = ar_new_stringl(S, NULL, len); 316 | p = v->u.str.s; 317 | sz = v->u.str.len; 318 | q = res->u.str.s; 319 | *q++ = '"'; 320 | while (sz--) { 321 | if (escape_char(*p)) { 322 | *q++ = '\\'; 323 | *q++ = escape_char(*p); 324 | } else { 325 | *q++ = *p; 326 | } 327 | p++; 328 | } 329 | *q = '"'; 330 | return res; 331 | } 332 | return v; 333 | 334 | default: 335 | sprintf(buf, "[%s %p]", ar_type_str(ar_type(v)), (void*) v); 336 | return ar_new_string(S, buf); 337 | } 338 | } 339 | 340 | 341 | const char *ar_to_stringl(ar_State *S, ar_Value *v, size_t *len) { 342 | v = ar_to_string_value(S, v, 0); 343 | if (len) *len = v->u.str.len; 344 | return v->u.str.s; 345 | } 346 | 347 | 348 | const char *ar_to_string(ar_State *S, ar_Value *v) { 349 | return ar_to_stringl(S, v, NULL); 350 | } 351 | 352 | 353 | void *ar_to_udata(ar_State *S, ar_Value *v) { 354 | UNUSED(S); 355 | return (ar_type(v) == AR_TUDATA) ? v->u.udata.ptr : NULL; 356 | } 357 | 358 | 359 | double ar_to_number(ar_State *S, ar_Value *v) { 360 | UNUSED(S); 361 | switch (ar_type(v)) { 362 | case AR_TNUMBER : return v->u.num.n; 363 | case AR_TSTRING : return strtod(v->u.str.s, NULL); 364 | } 365 | return 0; 366 | } 367 | 368 | 369 | #define OPT_FUNC(NAME, CTYPE, TYPE, FIELD) \ 370 | CTYPE NAME(ar_State *S, ar_Value *v, CTYPE def) { \ 371 | if (!v) return def; \ 372 | return ar_check(S, v, TYPE)->FIELD; \ 373 | } 374 | 375 | OPT_FUNC( ar_opt_string, const char*, AR_TSTRING, u.str.s ) 376 | OPT_FUNC( ar_opt_udata, void*, AR_TUDATA, u.udata.ptr ) 377 | OPT_FUNC( ar_opt_number, double, AR_TNUMBER, u.num.n ) 378 | 379 | 380 | static int is_equal(ar_Value *v1, ar_Value *v2) { 381 | int v1type, v2type; 382 | if (v1 == v2) return 1; 383 | v1type = ar_type(v1); 384 | v2type = ar_type(v2); 385 | if (v1type != v2type) return 0; 386 | switch (v1type) { 387 | case AR_TNUMBER : return v1->u.num.n == v2->u.num.n; 388 | case AR_TSYMBOL : 389 | case AR_TSTRING : return (v1->u.str.len == v2->u.str.len) && 390 | !memcmp(v1->u.str.s, v2->u.str.s, v1->u.str.len); 391 | } 392 | return 0; 393 | } 394 | 395 | 396 | static ar_Value *debug_location(ar_State *S, ar_Value *v) { 397 | if (ar_type(v) != AR_TPAIR || !v->u.pair.dbg) { 398 | return ar_new_string(S, "?"); 399 | } 400 | return join_list_of_strings(S, ar_new_list(S, 3, 401 | v->u.pair.dbg->u.dbg.name, 402 | ar_new_string(S, ":"), 403 | ar_to_string_value(S, ar_new_number(S, v->u.pair.dbg->u.dbg.line), 0))); 404 | } 405 | 406 | 407 | /*=========================================================================== 408 | * Garbage collector 409 | *===========================================================================*/ 410 | 411 | static void gc_free(ar_State *S, ar_Value *v) { 412 | /* Deinit value */ 413 | switch (v->type) { 414 | case AR_TSYMBOL: 415 | case AR_TSTRING: 416 | zfree(S, v->u.str.s); 417 | break; 418 | case AR_TUDATA: 419 | if (v->u.udata.gc) v->u.udata.gc(S, v); 420 | break; 421 | } 422 | /* Set type to nil (ignored by GC) and add to dead values pool */ 423 | v->type = AR_TNIL; 424 | v->u.pair.cdr = S->gc_pool; 425 | S->gc_pool = v; 426 | } 427 | 428 | 429 | static void gc_deinit(ar_State *S) { 430 | int i; 431 | ar_Chunk *c, *next; 432 | /* Free all values in all chunks and free the chunks themselves */ 433 | c = S->gc_chunks; 434 | while (c) { 435 | next = c->next; 436 | for (i = 0; i < CHUNK_LEN; i++) { 437 | gc_free(S, c->values + i); 438 | } 439 | zfree(S, c); 440 | c = next; 441 | } 442 | /* Free stack */ 443 | zfree(S, S->gc_stack); 444 | } 445 | 446 | 447 | void ar_mark(ar_State *S, ar_Value *v) { 448 | begin: 449 | if ( !v || v->mark ) return; 450 | v->mark = 1; 451 | switch (v->type) { 452 | case AR_TDBGINFO: 453 | v = v->u.dbg.name; 454 | goto begin; 455 | case AR_TMAPNODE: 456 | ar_mark(S, v->u.map.pair); 457 | ar_mark(S, v->u.map.left); 458 | v = v->u.map.right; 459 | goto begin; 460 | case AR_TPAIR: 461 | ar_mark(S, v->u.pair.dbg); 462 | ar_mark(S, v->u.pair.car); 463 | v = v->u.pair.cdr; 464 | goto begin; 465 | case AR_TMACRO: 466 | case AR_TFUNC: 467 | ar_mark(S, v->u.func.params); 468 | ar_mark(S, v->u.func.body); 469 | v = v->u.func.env; 470 | goto begin; 471 | case AR_TENV: 472 | ar_mark(S, v->u.env.map); 473 | v = v->u.env.parent; 474 | goto begin; 475 | case AR_TUDATA: 476 | if (v->u.udata.mark) v->u.udata.mark(S, v); 477 | break; 478 | } 479 | } 480 | 481 | 482 | void ar_gc(ar_State *S) { 483 | int i, count; 484 | ar_Chunk *c; 485 | /* Mark roots */ 486 | for (i = 0; i < S->gc_stack_idx; i++) ar_mark(S, S->gc_stack[i]); 487 | ar_mark(S, S->global); 488 | ar_mark(S, S->oom_error); 489 | ar_mark(S, S->oom_args); 490 | ar_mark(S, S->t); 491 | /* Sweep: free still-unmarked values, unmark and count remaining values */ 492 | count = 0; 493 | c = S->gc_chunks; 494 | while (c) { 495 | for (i = 0; i < CHUNK_LEN; i++) { 496 | if (c->values[i].type != AR_TNIL) { 497 | if (!c->values[i].mark) { 498 | gc_free(S, c->values + i); 499 | } else { 500 | c->values[i].mark = 0; 501 | count++; 502 | } 503 | } 504 | } 505 | c = c->next; 506 | } 507 | /* Reset gc counter */ 508 | S->gc_count = count; 509 | } 510 | 511 | 512 | /*=========================================================================== 513 | * Environment 514 | *===========================================================================*/ 515 | 516 | static ar_Value *new_mapnode(ar_State *S, ar_Value *k, ar_Value *v) { 517 | /* The pair for the node is created *first* as this may trigger garbage 518 | * collection which expects all values to be in an intialised state */ 519 | ar_Value *p = ar_new_pair(S, k, v); 520 | ar_Value *x = new_value(S, AR_TMAPNODE); 521 | x->u.map.left = x->u.map.right = NULL; 522 | x->u.map.pair = p; 523 | return x; 524 | } 525 | 526 | 527 | static ar_Value **get_map_ref(ar_Value **m, ar_Value *k) { 528 | unsigned h = k->u.str.hash; 529 | while (*m) { 530 | ar_Value *k2 = (*m)->u.map.pair->u.pair.car; 531 | if (k2->u.str.hash == h && is_equal(k, k2)) { 532 | return m; 533 | } else if (k2->u.str.hash < h) { 534 | m = &(*m)->u.map.left; 535 | } else { 536 | m = &(*m)->u.map.right; 537 | } 538 | } 539 | return m; 540 | } 541 | 542 | 543 | static ar_Value *get_bound_value(ar_Value *sym, ar_Value *env) { 544 | do { 545 | ar_Value *x = *get_map_ref(&env->u.env.map, sym); 546 | if (x) return x->u.map.pair->u.pair.cdr; 547 | env = env->u.env.parent; 548 | } while (env); 549 | return NULL; 550 | } 551 | 552 | 553 | ar_Value *ar_bind(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env) { 554 | ar_Value **x = get_map_ref(&env->u.env.map, sym); 555 | if (*x) { 556 | (*x)->u.map.pair->u.pair.cdr = v; 557 | } else { 558 | *x = new_mapnode(S, sym, v); 559 | } 560 | return v; 561 | } 562 | 563 | 564 | ar_Value *ar_set(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env) { 565 | for (;;) { 566 | ar_Value *x = *get_map_ref(&env->u.env.map, sym); 567 | if (x) return x->u.map.pair->u.pair.cdr = v; 568 | if (!env->u.env.parent) return ar_bind(S, sym, v, env); 569 | env = env->u.env.parent; 570 | } 571 | } 572 | 573 | 574 | /*=========================================================================== 575 | * Parser 576 | *===========================================================================*/ 577 | 578 | #define WHITESPACE " \n\t\r" 579 | #define DELIMITER (WHITESPACE "();") 580 | 581 | static ar_Value parse_end; 582 | 583 | static ar_Value *parse(ar_State *S, const char **str) { 584 | ar_Value *res, **last, *v; 585 | char buf[512]; 586 | size_t i; 587 | char *q; 588 | const char *p = *str; 589 | 590 | /* Skip whitespace */ 591 | while (*p && strchr(WHITESPACE, *p)) { 592 | if (*p++ == '\n') S->parse_line++; 593 | } 594 | 595 | switch (*p) { 596 | case '\0': 597 | return &parse_end; 598 | 599 | case '(': 600 | res = NULL; 601 | last = &res; 602 | *str = p + 1; 603 | while ((v = parse(S, str)) != &parse_end) { 604 | if (ar_type(v) == AR_TSYMBOL && !strcmp(v->u.str.s, ".")) { 605 | /* Handle dotted pair */ 606 | *last = parse(S, str); 607 | } else { 608 | /* Handle proper pair */ 609 | int first = !res; 610 | *last = ar_new_pair(S, v, NULL); 611 | if (first) { 612 | /* This is the first pair in the list, attach debug info */ 613 | ar_Value *dbg = new_value(S, AR_TDBGINFO); 614 | dbg->u.dbg.name = S->parse_name; 615 | dbg->u.dbg.line = S->parse_line; 616 | (*last)->u.pair.dbg = dbg; 617 | } 618 | last = &(*last)->u.pair.cdr; 619 | } 620 | } 621 | return res; 622 | 623 | case '\'': 624 | *str = p + 1; 625 | return ar_new_list(S, 2, ar_new_symbol(S, "quote"), parse(S, str)); 626 | 627 | case ')': 628 | *str = p + 1; 629 | return &parse_end; 630 | 631 | case ';': 632 | *str = p + strcspn(p, "\n"); 633 | return parse(S, str); 634 | 635 | case '.': case '-': 636 | case '1': case '2': case '3': case '4': case '5': 637 | case '6': case '7': case '8': case '9': case '0': 638 | res = ar_new_number(S, strtod(p, &q)); 639 | /* Not a valid number? treat as symbol */ 640 | if ( *q && !strchr(DELIMITER, *q) ) { 641 | goto parse_symbol; 642 | } 643 | break; 644 | 645 | case '"': 646 | /* Get string length */ 647 | p++; 648 | *str = p; 649 | i = 0; 650 | while (*p && *p != '"') { 651 | if (*p == '\\') p++; 652 | i++, p++; 653 | } 654 | /* Copy string */ 655 | res = ar_new_stringl(S, NULL, i); 656 | p = *str; 657 | q = res->u.str.s; 658 | while (*p && *p != '"') { 659 | if (*p == '\\') { 660 | switch (*(++p)) { 661 | case 'r' : { *q++ = '\r'; p++; continue; } 662 | case 'n' : { *q++ = '\n'; p++; continue; } 663 | case 't' : { *q++ = '\t'; p++; continue; } 664 | } 665 | } 666 | if (*p == '\n') S->parse_line++; 667 | *q++ = *p++; 668 | } 669 | *str = p; 670 | break; 671 | 672 | default: 673 | parse_symbol: 674 | *str = p + strcspn(p, DELIMITER); 675 | i = *str - p; 676 | if (i >= sizeof(buf)) i = sizeof(buf) - 1; 677 | memcpy(buf, p, i); 678 | buf[i] = '\0'; 679 | if (!strcmp(buf, "nil")) return NULL; 680 | return ar_new_symbol(S, buf); 681 | } 682 | 683 | *str = p + strcspn(p, DELIMITER); 684 | return res; 685 | } 686 | 687 | 688 | ar_Value *ar_parse(ar_State *S, const char *str, const char *name) { 689 | ar_Value *res; 690 | S->parse_name = ar_new_string(S, name ? name : "?"); 691 | S->parse_line = 1; 692 | res = parse(S, &str); 693 | return (res == &parse_end) ? NULL : res; 694 | } 695 | 696 | 697 | /*=========================================================================== 698 | * Eval 699 | *===========================================================================*/ 700 | 701 | static ar_Value *eval_list(ar_State *S, ar_Value *list, ar_Value *env) { 702 | ar_Value *res = NULL, **last = &res; 703 | while (list) { 704 | last = ar_append_tail(S, last, ar_eval(S, ar_car(list), env)); 705 | list = ar_cdr(list); 706 | } 707 | return res; 708 | } 709 | 710 | 711 | static ar_Value *args_to_env( 712 | ar_State *S, ar_Value *params, ar_Value *args, ar_Value *env 713 | ) { 714 | ar_Value *e = ar_new_env(S, env); 715 | /* No params? */ 716 | if (ar_car(params) == AR_TNIL) { 717 | return e; 718 | } 719 | /* Handle arg list */ 720 | while (params) { 721 | /* Symbol instead of pair? Bind remaining args to symbol */ 722 | if (ar_type(params) == AR_TSYMBOL) { 723 | ar_bind(S, params, args, e); 724 | return e; 725 | } 726 | /* Handle normal param */ 727 | ar_bind(S, ar_car(params), ar_car(args), e); 728 | params = ar_cdr(params); 729 | args = ar_cdr(args); 730 | } 731 | return e; 732 | } 733 | 734 | 735 | static void push_frame(ar_State *S, ar_Frame *f, ar_Value *caller) { 736 | if (S->frame_idx == MAX_STACK) { 737 | ar_error_str(S, "stack overflow"); 738 | } 739 | S->frame_idx++; 740 | f->parent = S->frame; 741 | f->caller = caller; 742 | f->stack_idx = S->gc_stack_idx; 743 | f->err_env = NULL; 744 | S->frame = f; 745 | } 746 | 747 | 748 | static void pop_frame(ar_State *S, ar_Value *rtn) { 749 | S->gc_stack_idx = S->frame->stack_idx; 750 | S->frame = S->frame->parent; 751 | S->frame_idx--; 752 | /* Reached the base frame? Clear protected-value-stack of all values */ 753 | if (S->frame == &S->base_frame) S->gc_stack_idx = 0; 754 | if (rtn) push_value_to_stack(S, rtn); 755 | } 756 | 757 | 758 | static ar_Value *raw_call( 759 | ar_State *S, ar_Value *caller, ar_Value *fn, ar_Value *args, ar_Value *env 760 | ) { 761 | ar_Value *e, *res; 762 | ar_Frame frame; 763 | push_frame(S, &frame, caller); 764 | 765 | switch (ar_type(fn)) { 766 | case AR_TCFUNC: 767 | res = fn->u.cfunc.fn(S, args); 768 | break; 769 | 770 | case AR_TPRIM: 771 | res = fn->u.prim.fn(S, args, env); 772 | break; 773 | 774 | case AR_TFUNC: 775 | e = args_to_env(S, fn->u.func.params, args, fn->u.func.env); 776 | res = ar_do_list(S, fn->u.func.body, e); 777 | break; 778 | 779 | case AR_TMACRO: 780 | e = args_to_env(S, fn->u.func.params, args, fn->u.func.env); 781 | res = ar_eval(S, ar_do_list(S, fn->u.func.body, e), env); 782 | break; 783 | 784 | default: 785 | ar_error_str(S, "expected primitive, function or macro; got %s", 786 | ar_type_str(ar_type(fn))); 787 | res = NULL; 788 | } 789 | pop_frame(S, res); 790 | return res; 791 | } 792 | 793 | 794 | ar_Value *ar_eval(ar_State *S, ar_Value *v, ar_Value *env) { 795 | ar_Value *fn, *args; 796 | 797 | switch (ar_type(v)) { 798 | case AR_TPAIR : break; 799 | case AR_TSYMBOL : return get_bound_value(v, env); 800 | default : return v; 801 | } 802 | 803 | fn = ar_eval(S, v->u.pair.car, env); 804 | switch (ar_type(fn)) { 805 | case AR_TCFUNC : 806 | case AR_TFUNC : args = eval_list(S, v->u.pair.cdr, env); break; 807 | default : args = v->u.pair.cdr; break; 808 | } 809 | return raw_call(S, v, fn, args, env); 810 | } 811 | 812 | 813 | ar_Value *ar_call(ar_State *S, ar_Value *fn, ar_Value *args) { 814 | int t = ar_type(fn); 815 | if (t != AR_TFUNC && t != AR_TCFUNC) { 816 | ar_error_str(S, "expected function, got %s", ar_type_str(t)); 817 | } 818 | return raw_call(S, ar_new_pair(S, fn, args), fn, args, NULL); 819 | } 820 | 821 | 822 | ar_Value *ar_do_list(ar_State *S, ar_Value *body, ar_Value *env) { 823 | ar_Value *res = NULL; 824 | while (body) { 825 | res = ar_eval(S, ar_car(body), env); 826 | body = ar_cdr(body); 827 | } 828 | return res; 829 | } 830 | 831 | 832 | ar_Value *ar_do_string(ar_State *S, const char *str) { 833 | return ar_eval(S, ar_parse(S, str, "(string)"), S->global); 834 | } 835 | 836 | 837 | ar_Value *ar_do_file(ar_State *S, const char *filename) { 838 | ar_Value *args = ar_new_list(S, 1, ar_new_string(S, filename)); 839 | ar_Value *str = ar_call_global(S, "loads", args); 840 | return ar_eval(S, ar_parse(S, str->u.str.s, filename), S->global); 841 | } 842 | 843 | 844 | /*=========================================================================== 845 | * Built-in primitives and funcs 846 | *===========================================================================*/ 847 | 848 | static ar_Value *p_do(ar_State *S, ar_Value *args, ar_Value *env) { 849 | return ar_do_list(S, args, env); 850 | } 851 | 852 | 853 | static ar_Value *p_set(ar_State *S, ar_Value *args, ar_Value *env) { 854 | ar_Value *sym, *v; 855 | do { 856 | sym = ar_check(S, ar_car(args), AR_TSYMBOL); 857 | v = ar_eval(S, ar_car(args = ar_cdr(args)), env); 858 | ar_set(S, sym, v, env); 859 | } while ( (args = ar_cdr(args)) ); 860 | return v; 861 | } 862 | 863 | 864 | static ar_Value *p_quote(ar_State *S, ar_Value *args, ar_Value *env) { 865 | UNUSED(S); 866 | UNUSED(env); 867 | return ar_car(args); 868 | } 869 | 870 | 871 | static ar_Value *p_eval(ar_State *S, ar_Value *args, ar_Value *env) { 872 | ar_Value *e = ar_eval(S, ar_nth(args, 1), env); 873 | e = e ? ar_check(S, e, AR_TENV) : env; 874 | return ar_eval(S, ar_eval(S, ar_car(args), env), e); 875 | } 876 | 877 | 878 | static ar_Value *p_fn(ar_State *S, ar_Value *args, ar_Value *env) { 879 | ar_Value *v = ar_car(args); 880 | int t = ar_type(v); 881 | /* Type check */ 882 | if (t && t != AR_TPAIR && t != AR_TSYMBOL) { 883 | ar_error_str(S, "expected pair or symbol, got %s", ar_type_str(t)); 884 | } 885 | if (t == AR_TPAIR) { 886 | while (v) { 887 | ar_check(S, ar_car(v), AR_TSYMBOL); 888 | v = ar_cdr(v); 889 | } 890 | } 891 | /* Init function */ 892 | v = new_value(S, AR_TFUNC); 893 | v->u.func.params = ar_car(args); 894 | v->u.func.body = ar_cdr(args); 895 | v->u.func.env = env; 896 | return v; 897 | } 898 | 899 | 900 | static ar_Value *p_macro(ar_State *S, ar_Value *args, ar_Value *env) { 901 | ar_Value *v = p_fn(S, args, env); 902 | v->type = AR_TMACRO; 903 | return v; 904 | } 905 | 906 | 907 | static ar_Value *p_apply(ar_State *S, ar_Value *args, ar_Value *env) { 908 | ar_Value *fn = ar_eval(S, ar_car(args), env); 909 | return ar_call(S, fn, ar_eval(S, ar_nth(args, 1), env)); 910 | } 911 | 912 | 913 | static ar_Value *p_if(ar_State *S, ar_Value *args, ar_Value *env) { 914 | ar_Value *cond, *next, *v = args; 915 | while (v) { 916 | cond = ar_eval(S, ar_car(v), env); 917 | next = ar_cdr(v); 918 | if (cond) { 919 | return next ? ar_eval(S, ar_car(next), env) : cond; 920 | } 921 | v = ar_cdr(next); 922 | } 923 | return NULL; 924 | } 925 | 926 | 927 | static ar_Value *p_and(ar_State *S, ar_Value *args, ar_Value *env) { 928 | ar_Value *res = NULL; 929 | while (args) { 930 | if ( !(res = ar_eval(S, ar_car(args), env)) ) return NULL; 931 | args = ar_cdr(args); 932 | } 933 | return res; 934 | } 935 | 936 | 937 | static ar_Value *p_or(ar_State *S, ar_Value *args, ar_Value *env) { 938 | ar_Value *res; 939 | while (args) { 940 | if ( (res = ar_eval(S, ar_car(args), env)) ) return res; 941 | args = ar_cdr(args); 942 | } 943 | return NULL; 944 | } 945 | 946 | 947 | static ar_Value *p_let(ar_State *S, ar_Value *args, ar_Value *env) { 948 | ar_Value *vars = ar_check(S, ar_car(args), AR_TPAIR); 949 | env = ar_new_env(S, env); 950 | while (vars) { 951 | ar_Value *sym = ar_check(S, ar_car(vars), AR_TSYMBOL); 952 | vars = ar_cdr(vars); 953 | ar_bind(S, sym, ar_eval(S, ar_car(vars), env), env); 954 | vars = ar_cdr(vars); 955 | } 956 | return ar_do_list(S, ar_cdr(args), env); 957 | } 958 | 959 | 960 | static ar_Value *p_while(ar_State *S, ar_Value *args, ar_Value *env) { 961 | ar_Value *cond = ar_car(args); 962 | ar_Value *body = ar_cdr(args); 963 | int orig_stack_idx = S->gc_stack_idx; 964 | while ( ar_eval(S, cond, env) ) { 965 | ar_do_list(S, body, env); 966 | /* Truncate stack so we don't accumulate protected values */ 967 | S->gc_stack_idx = orig_stack_idx; 968 | } 969 | return NULL; 970 | } 971 | 972 | 973 | static ar_Value *p_pcall(ar_State *S, ar_Value *args, ar_Value *env) { 974 | ar_Value *res; 975 | ar_try(S, err, { 976 | res = ar_call(S, ar_eval(S, ar_car(args), env), NULL); 977 | }, { 978 | res = ar_call(S, ar_eval(S, ar_nth(args, 1), env), err); 979 | }); 980 | return res; 981 | } 982 | 983 | 984 | static ar_Value *f_list(ar_State *S, ar_Value *args) { 985 | UNUSED(S); 986 | return args; 987 | } 988 | 989 | 990 | static ar_Value *f_type(ar_State *S, ar_Value *args) { 991 | return ar_new_symbol(S, ar_type_str(ar_type(ar_car(args)))); 992 | } 993 | 994 | 995 | static ar_Value *f_print(ar_State *S, ar_Value *args) { 996 | while (args) { 997 | size_t len; 998 | const char *str = ar_to_stringl(S, ar_car(args), &len); 999 | fwrite(str, len, 1, stdout); 1000 | if (!ar_cdr(args)) break; 1001 | printf(" "); 1002 | args = ar_cdr(args); 1003 | } 1004 | printf("\n"); 1005 | return ar_car(args); 1006 | } 1007 | 1008 | 1009 | static ar_Value *f_parse(ar_State *S, ar_Value *args) { 1010 | return ar_parse(S, ar_check_string(S, ar_car(args)), 1011 | ar_opt_string(S, ar_nth(args, 1), "(string)")); 1012 | } 1013 | 1014 | 1015 | static ar_Value *f_error(ar_State *S, ar_Value *args) { 1016 | ar_error(S, ar_car(args)); 1017 | return NULL; 1018 | } 1019 | 1020 | 1021 | static ar_Value *f_dbgloc(ar_State *S, ar_Value *args) { 1022 | return debug_location(S, ar_car(args)); 1023 | } 1024 | 1025 | 1026 | static ar_Value *f_cons(ar_State *S, ar_Value *args) { 1027 | return ar_new_pair(S, ar_car(args), ar_nth(args, 1)); 1028 | } 1029 | 1030 | 1031 | static ar_Value *f_car(ar_State *S, ar_Value *args) { 1032 | ar_Value *v = ar_car(args); 1033 | if (!v) return NULL; 1034 | return ar_check(S, v, AR_TPAIR)->u.pair.car; 1035 | } 1036 | 1037 | 1038 | static ar_Value *f_cdr(ar_State *S, ar_Value *args) { 1039 | ar_Value *v = ar_car(args); 1040 | if (!v) return NULL; 1041 | return ar_check(S, v, AR_TPAIR)->u.pair.cdr; 1042 | } 1043 | 1044 | 1045 | static ar_Value *f_setcar(ar_State *S, ar_Value *args) { 1046 | return ar_check(S, ar_car(args), AR_TPAIR)->u.pair.car = ar_nth(args, 1); 1047 | } 1048 | 1049 | 1050 | static ar_Value *f_setcdr(ar_State *S, ar_Value *args) { 1051 | return ar_check(S, ar_car(args), AR_TPAIR)->u.pair.cdr = ar_nth(args, 1); 1052 | } 1053 | 1054 | 1055 | static ar_Value *f_string(ar_State *S, ar_Value *args) { 1056 | ar_Value *res = NULL, **last = &res; 1057 | ar_Value *v = args; 1058 | while (v) { 1059 | last = ar_append_tail(S, last, ar_to_string_value(S, ar_car(v), 0)); 1060 | v = ar_cdr(v); 1061 | } 1062 | return join_list_of_strings(S, res); 1063 | } 1064 | 1065 | 1066 | static ar_Value *f_substr(ar_State *S, ar_Value *args) { 1067 | ar_Value *str = ar_check(S, ar_car(args), AR_TSTRING); 1068 | int slen = str->u.str.len; 1069 | int start = ar_opt_number(S, ar_nth(args, 1), 0); 1070 | int len = ar_opt_number(S, ar_nth(args, 2), str->u.str.len); 1071 | if (start < 0) start = slen + start; 1072 | if (start < 0) len += start, start = 0; 1073 | if (start + len > slen) len = slen - start; 1074 | if (len < 0) len = 0; 1075 | return ar_new_stringl(S, &str->u.str.s[start], len); 1076 | } 1077 | 1078 | 1079 | static ar_Value *f_strlen(ar_State *S, ar_Value *args) { 1080 | return ar_new_number(S, ar_check(S, ar_car(args), AR_TSTRING)->u.str.len); 1081 | } 1082 | 1083 | 1084 | static ar_Value *f_strpos(ar_State *S, ar_Value *args) { 1085 | ar_Value *haystack = ar_check(S, ar_car(args), AR_TSTRING); 1086 | ar_Value *needle = ar_check(S, ar_nth(args, 1), AR_TSTRING); 1087 | unsigned offset = ar_opt_number(S, ar_nth(args, 2), 0); 1088 | const char *p; 1089 | if (offset >= haystack->u.str.len) return NULL; 1090 | p = strstr(haystack->u.str.s + offset, needle->u.str.s); 1091 | return p ? ar_new_number(S, p - haystack->u.str.s) : NULL; 1092 | } 1093 | 1094 | 1095 | static ar_Value *f_chr(ar_State *S, ar_Value *args) { 1096 | char c = ar_check_number(S, ar_car(args)); 1097 | return ar_new_stringl(S, &c, 1); 1098 | } 1099 | 1100 | 1101 | static ar_Value *f_ord(ar_State *S, ar_Value *args) { 1102 | return ar_new_number(S, *ar_check_string(S, ar_car(args))); 1103 | } 1104 | 1105 | 1106 | #define STRING_MAP_FUNC(NAME, FUNC) \ 1107 | static ar_Value *NAME(ar_State *S, ar_Value *args) { \ 1108 | ar_Value *str = ar_check(S, ar_car(args), AR_TSTRING); \ 1109 | ar_Value *res = ar_new_stringl(S, NULL, str->u.str.len); \ 1110 | size_t i; \ 1111 | for (i = 0; i < res->u.str.len; i++) { \ 1112 | res->u.str.s[i] = FUNC(str->u.str.s[i]); \ 1113 | } \ 1114 | return res; \ 1115 | } 1116 | 1117 | STRING_MAP_FUNC( f_lower, tolower ) 1118 | STRING_MAP_FUNC( f_upper, toupper ) 1119 | 1120 | 1121 | static ar_Value *f_loads(ar_State *S, ar_Value *args) { 1122 | ar_Value *res; 1123 | int r, size; 1124 | FILE *fp = fopen(ar_check_string(S, ar_car(args)), "rb"); 1125 | if (!fp) ar_error_str(S, "could not open file"); 1126 | /* Get size */ 1127 | fseek(fp, 0, SEEK_END); 1128 | size = ftell(fp); 1129 | fseek(fp, 0, SEEK_SET); 1130 | /* Load file into string value */ 1131 | res = ar_new_stringl(S, NULL, size); 1132 | r = fread(res->u.str.s, 1, size, fp); 1133 | fclose(fp); 1134 | if (r != size) ar_error_str(S, "could not read file"); 1135 | return res; 1136 | } 1137 | 1138 | 1139 | static ar_Value *f_dumps(ar_State *S, ar_Value *args) { 1140 | const char *name, *data; 1141 | int r; 1142 | size_t len; 1143 | FILE *fp; 1144 | name = ar_to_string( S, ar_check(S, ar_nth(args, 0), AR_TSTRING)); 1145 | data = ar_to_stringl(S, ar_check(S, ar_nth(args, 1), AR_TSTRING), &len); 1146 | fp = fopen(name, ar_nth(args, 2) ? "ab" : "wb"); 1147 | if (!fp) ar_error_str(S, "could not open file"); 1148 | r = fwrite(data, len, 1, fp); 1149 | fclose(fp); 1150 | if (r != 1) ar_error_str(S, "could not write file"); 1151 | return NULL; 1152 | } 1153 | 1154 | 1155 | static ar_Value *f_is(ar_State *S, ar_Value *args) { 1156 | return is_equal(ar_car(args), ar_nth(args, 1)) ? S->t : NULL; 1157 | } 1158 | 1159 | 1160 | #define NUM_COMPARE_FUNC(NAME, OP) \ 1161 | static ar_Value *NAME(ar_State *S, ar_Value *args) { \ 1162 | return ( ar_check_number(S, ar_car(args)) OP \ 1163 | ar_check_number(S, ar_nth(args, 1)) ) ? S->t : NULL; \ 1164 | } 1165 | 1166 | NUM_COMPARE_FUNC( f_lt, < ) 1167 | NUM_COMPARE_FUNC( f_gt, > ) 1168 | NUM_COMPARE_FUNC( f_lte, <= ) 1169 | NUM_COMPARE_FUNC( f_gte, >= ) 1170 | 1171 | 1172 | #define NUM_ARITH_FUNC(NAME, OP) \ 1173 | static ar_Value *NAME(ar_State *S, ar_Value *args) { \ 1174 | double res = ar_check_number(S, ar_car(args)); \ 1175 | while ( (args = ar_cdr(args)) ) { \ 1176 | res = res OP ar_check_number(S, ar_car(args)); \ 1177 | } \ 1178 | return ar_new_number(S, res); \ 1179 | } 1180 | 1181 | NUM_ARITH_FUNC( f_add, + ) 1182 | NUM_ARITH_FUNC( f_sub, - ) 1183 | NUM_ARITH_FUNC( f_mul, * ) 1184 | NUM_ARITH_FUNC( f_div, / ) 1185 | 1186 | static ar_Value *f_mod(ar_State *S, ar_Value *args) { 1187 | double a = ar_check_number(S, ar_car(args)); 1188 | double b = ar_check_number(S, ar_nth(args, 1)); 1189 | if (b == 0.) ar_error_str(S, "expected a non-zero divisor"); 1190 | return ar_new_number(S, a - b * (long) (a / b)); 1191 | } 1192 | 1193 | 1194 | static ar_Value *f_exit(ar_State *S, ar_Value *args) { 1195 | exit(ar_opt_number(S, ar_car(args), EXIT_SUCCESS)); 1196 | return NULL; 1197 | } 1198 | 1199 | 1200 | static void register_builtin(ar_State *S) { 1201 | int i; 1202 | /* Primitives */ 1203 | struct { const char *name; ar_Prim fn; } prims[] = { 1204 | { "=", p_set }, 1205 | { "do", p_do }, 1206 | { "quote", p_quote }, 1207 | { "eval", p_eval }, 1208 | { "fn", p_fn }, 1209 | { "macro", p_macro }, 1210 | { "apply", p_apply }, 1211 | { "if", p_if }, 1212 | { "and", p_and }, 1213 | { "or", p_or }, 1214 | { "let", p_let }, 1215 | { "while", p_while }, 1216 | { "pcall", p_pcall }, 1217 | { NULL, NULL } 1218 | }; 1219 | /* Functions */ 1220 | struct { const char *name; ar_CFunc fn; } funcs[] = { 1221 | { "list", f_list }, 1222 | { "type", f_type }, 1223 | { "print", f_print }, 1224 | { "parse", f_parse }, 1225 | { "error", f_error }, 1226 | { "dbgloc", f_dbgloc }, 1227 | { "cons", f_cons }, 1228 | { "car", f_car }, 1229 | { "cdr", f_cdr }, 1230 | { "setcar", f_setcar }, 1231 | { "setcdr", f_setcdr }, 1232 | { "string", f_string }, 1233 | { "substr", f_substr }, 1234 | { "strlen", f_strlen }, 1235 | { "strpos", f_strpos }, 1236 | { "chr", f_chr }, 1237 | { "ord", f_ord }, 1238 | { "lower", f_lower }, 1239 | { "upper", f_upper }, 1240 | { "loads", f_loads }, 1241 | { "dumps", f_dumps }, 1242 | { "is", f_is }, 1243 | { "<", f_lt }, 1244 | { ">", f_gt }, 1245 | { "<=", f_lte }, 1246 | { ">=", f_gte }, 1247 | { "+", f_add }, 1248 | { "-", f_sub }, 1249 | { "*", f_mul }, 1250 | { "/", f_div }, 1251 | { "mod", f_mod }, 1252 | { "exit", f_exit }, 1253 | { NULL, NULL } 1254 | }; 1255 | /* Register */ 1256 | for (i = 0; prims[i].name; i++) { 1257 | ar_bind_global(S, prims[i].name, ar_new_prim(S, prims[i].fn)); 1258 | } 1259 | for (i = 0; funcs[i].name; i++) { 1260 | ar_bind_global(S, funcs[i].name, ar_new_cfunc(S, funcs[i].fn)); 1261 | } 1262 | } 1263 | 1264 | 1265 | /*=========================================================================== 1266 | * State 1267 | *===========================================================================*/ 1268 | 1269 | static void *alloc_(void *udata, void *ptr, size_t size) { 1270 | UNUSED(udata); 1271 | if (ptr && size == 0) { 1272 | free(ptr); 1273 | return NULL; 1274 | } 1275 | return realloc(ptr, size); 1276 | } 1277 | 1278 | 1279 | ar_State *ar_new_state(ar_Alloc alloc, void *udata) { 1280 | ar_State *volatile S; 1281 | if (!alloc) { 1282 | alloc = alloc_; 1283 | } 1284 | S = alloc(udata, NULL, sizeof(*S)); 1285 | if (!S) return NULL; 1286 | memset(S, 0, sizeof(*S)); 1287 | S->alloc = alloc; 1288 | S->udata = udata; 1289 | S->frame = &S->base_frame; 1290 | /* We use the ar_try macro in case an out-of-memory error occurs -- you 1291 | * shouldn't usually return from inside the ar_try macro */ 1292 | ar_try(S, err, { 1293 | /* Init global env; add constants, primitives and funcs */ 1294 | S->global = ar_new_env(S, NULL); 1295 | S->oom_error = ar_new_string(S, "out of memory"); 1296 | S->oom_args = ar_new_pair(S, S->oom_error, NULL); 1297 | S->t = ar_new_symbol(S, "t"); 1298 | ar_bind(S, S->t, S->t, S->global); 1299 | ar_bind_global(S, "global", S->global); 1300 | register_builtin(S); 1301 | }, { 1302 | UNUSED(err); 1303 | ar_close_state(S); 1304 | return NULL; 1305 | }); 1306 | return S; 1307 | } 1308 | 1309 | 1310 | void ar_close_state(ar_State *S) { 1311 | gc_deinit(S); 1312 | zfree(S, S); 1313 | } 1314 | 1315 | 1316 | ar_CFunc ar_at_panic(ar_State *S, ar_CFunc fn) { 1317 | ar_CFunc old = S->panic; 1318 | S->panic = fn; 1319 | return old; 1320 | } 1321 | 1322 | 1323 | static ar_Value *traceback(ar_State *S, ar_Frame *until) { 1324 | ar_Value *res = NULL, **last = &res; 1325 | ar_Frame *f = S->frame; 1326 | while (f != until) { 1327 | last = ar_append_tail(S, last, f->caller); 1328 | f = f->parent; 1329 | } 1330 | return res; 1331 | } 1332 | 1333 | 1334 | void ar_error(ar_State *S, ar_Value *err) { 1335 | ar_Frame *f; 1336 | ar_Value *args; 1337 | /* Create arguments to pass to error handler */ 1338 | if (err == S->oom_error) { 1339 | args = S->oom_args; 1340 | } else { 1341 | /* String error? Add debug location string to start */ 1342 | if (ar_type(err) == AR_TSTRING) { 1343 | err = join_list_of_strings(S, ar_new_list(S, 3, 1344 | debug_location(S, S->frame->caller), 1345 | ar_new_string(S, ": "), 1346 | err)); 1347 | } 1348 | args = ar_new_list(S, 2, err, NULL); 1349 | } 1350 | /* Unwind stack, create traceback list and jump to error env if it exists */ 1351 | f = S->frame; 1352 | while (f) { 1353 | if (f->err_env) { 1354 | if (err != S->oom_error) { 1355 | ar_cdr(args)->u.pair.car = traceback(S, f); 1356 | } 1357 | S->err_args = args; 1358 | while (S->frame != f) pop_frame(S, args); 1359 | if (err == S->oom_error) ar_gc(S); 1360 | longjmp(*f->err_env, -1); 1361 | } 1362 | f = f->parent; 1363 | } 1364 | /* No error env found -- if we have a panic callback we unwind the stack and 1365 | * call it else the error and traceback is printed */ 1366 | if (S->panic) { 1367 | while (S->frame != &S->base_frame) pop_frame(S, args); 1368 | S->panic(S, args); 1369 | } else { 1370 | printf("error: %s\n", ar_to_string(S, err)); 1371 | if (err != S->oom_error) { 1372 | ar_Value *v = traceback(S, &S->base_frame); 1373 | printf("traceback:\n"); 1374 | while (v) { 1375 | printf(" [%s] %.50s\n", ar_to_string(S, debug_location(S, ar_car(v))), 1376 | ar_to_string(S, ar_car(v))); 1377 | v = ar_cdr(v); 1378 | } 1379 | } 1380 | } 1381 | exit(EXIT_FAILURE); 1382 | } 1383 | 1384 | 1385 | void ar_error_str(ar_State *S, const char *fmt, ...) { 1386 | char buf[512]; 1387 | va_list args; 1388 | va_start(args, fmt); 1389 | vsprintf(buf, fmt, args); 1390 | va_end(args); 1391 | ar_error(S, ar_new_string(S, buf)); 1392 | } 1393 | 1394 | 1395 | /*=========================================================================== 1396 | * Standalone 1397 | *===========================================================================*/ 1398 | 1399 | #ifdef AR_STANDALONE 1400 | 1401 | static ar_Value *f_readline(ar_State *S, ar_Value *args) { 1402 | char buf[512]; 1403 | UNUSED(args); 1404 | printf("> "); 1405 | return ar_new_string(S, fgets(buf, sizeof(buf) - 1, stdin)); 1406 | } 1407 | 1408 | 1409 | int main(int argc, char **argv) { 1410 | ar_State *S = ar_new_state(NULL, NULL); 1411 | if (!S) { 1412 | printf("out of memory\n"); 1413 | return EXIT_FAILURE; 1414 | } 1415 | ar_bind_global(S, "readline", ar_new_cfunc(S, f_readline)); 1416 | 1417 | if (argc < 2) { 1418 | /* Init REPL */ 1419 | printf("aria " AR_VERSION "\n"); 1420 | ar_do_string(S, "(while t (pcall " 1421 | " (fn () (print (eval (parse (readline)) global))) " 1422 | " (fn (err tr) " 1423 | " (print \"error:\" err) " 1424 | " (print \"traceback:\") " 1425 | " (while tr " 1426 | " (print (string \" [\" (dbgloc (car tr)) \"] \" " 1427 | " (substr (string (car tr)) 0 50))) " 1428 | " (= tr (cdr tr))))))" ); 1429 | 1430 | 1431 | } else { 1432 | /* Store arguments at global list `argv` */ 1433 | int i; 1434 | ar_Value *v = NULL, **last = &v; 1435 | for (i = 1; i < argc; i++) { 1436 | last = ar_append_tail(S, last, ar_new_string(S, argv[i])); 1437 | } 1438 | ar_bind_global(S, "argv", v); 1439 | /* Load and do file from argv[1] */ 1440 | ar_do_file(S, argv[1]); 1441 | } 1442 | ar_close_state(S); 1443 | return EXIT_SUCCESS; 1444 | } 1445 | 1446 | #endif 1447 | -------------------------------------------------------------------------------- /aria.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2018 rxi 3 | * 4 | * This library is free software; you can redistribute it and/or modify it 5 | * under the terms of the MIT license. See LICENSE for details. 6 | */ 7 | 8 | #ifndef ARIA_H 9 | #define ARIA_H 10 | 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | #define AR_VERSION "0.1.1" 19 | 20 | typedef struct ar_Value ar_Value; 21 | typedef struct ar_State ar_State; 22 | typedef struct ar_Chunk ar_Chunk; 23 | typedef struct ar_Frame ar_Frame; 24 | 25 | typedef void *(*ar_Alloc)(void *udata, void *ptr, size_t size); 26 | typedef ar_Value* (*ar_CFunc)(ar_State *S, ar_Value* args); 27 | typedef ar_Value* (*ar_Prim)(ar_State *S, ar_Value* args, ar_Value *env); 28 | 29 | 30 | struct ar_Value { 31 | unsigned char type, mark; 32 | union { 33 | struct { ar_Value *name; int line; } dbg; 34 | struct { ar_Value *pair, *left, *right; } map; 35 | struct { ar_Value *car, *cdr, *dbg; } pair; 36 | struct { double n; } num; 37 | struct { ar_Value *params, *body, *env; } func; 38 | struct { void *ptr; ar_CFunc gc, mark; } udata; 39 | struct { ar_Value *parent, *map; } env; 40 | struct { ar_CFunc fn; } cfunc; 41 | struct { ar_Prim fn; } prim; 42 | struct { char *s; size_t len; unsigned hash; } str; 43 | } u; 44 | }; 45 | 46 | 47 | struct ar_Frame { 48 | struct ar_Frame *parent; /* Parent stack frame */ 49 | ar_Value *caller; /* Calling function pair */ 50 | jmp_buf *err_env; /* Jumped to on error, if it exists */ 51 | int stack_idx; /* Index on stack where frame's values start */ 52 | }; 53 | 54 | 55 | struct ar_State { 56 | ar_Alloc alloc; /* Allocator function */ 57 | void *udata; /* Pointer passed as allocator's udata */ 58 | ar_Value *global; /* Global environment */ 59 | ar_Frame base_frame; /* Base stack frame */ 60 | ar_Frame *frame; /* Current stack frame */ 61 | int frame_idx; /* Current stack frame index */ 62 | ar_Value *t; /* Symbol `t` */ 63 | ar_CFunc panic; /* Called if an unprotected error occurs */ 64 | ar_Value *err_args; /* Error args passed to error handler */ 65 | ar_Value *oom_error; /* Value thrown on an out of memory error */ 66 | ar_Value *oom_args; /* Args passed to err handler on out of mem */ 67 | ar_Value *parse_name; /* Parser's current chunk name */ 68 | int parse_line; /* Parser's current line */ 69 | ar_Value **gc_stack; /* Stack of values (protected from GC) */ 70 | int gc_stack_idx; /* Current index for the top of the gc_stack */ 71 | int gc_stack_cap; /* Max capacity of protected values stack */ 72 | ar_Chunk *gc_chunks; /* List of all chunks */ 73 | ar_Value *gc_pool; /* Dead (usable) Values */ 74 | int gc_count; /* Counts down number of new values until GC */ 75 | }; 76 | 77 | 78 | enum { 79 | AR_TNIL, 80 | AR_TDBGINFO, 81 | AR_TMAPNODE, 82 | AR_TPAIR, 83 | AR_TNUMBER, 84 | AR_TSTRING, 85 | AR_TSYMBOL, 86 | AR_TFUNC, 87 | AR_TMACRO, 88 | AR_TPRIM, 89 | AR_TCFUNC, 90 | AR_TENV, 91 | AR_TUDATA 92 | }; 93 | 94 | #define ar_get_global(S,x) ar_eval(S, ar_new_symbol(S, x), (S)->global) 95 | #define ar_bind_global(S,x,v) ar_bind(S, ar_new_symbol(S, x), v, (S)->global) 96 | #define ar_call_global(S,f,a) ar_call(S, ar_get_global(S, f), a) 97 | 98 | #define ar_check_string(S,v) ar_to_string(S, ar_check(S, v, AR_TSTRING)) 99 | #define ar_check_udata(S,v) ar_to_udata(S, ar_check(S, v, AR_TUDATA)) 100 | #define ar_check_number(S,v) ar_to_number(S, ar_check(S, v, AR_TNUMBER)) 101 | 102 | #define ar_try(S, err_val, blk, err_blk) \ 103 | do { \ 104 | jmp_buf err_env__, *old_env__ = (S)->frame->err_env; \ 105 | S->frame->err_env = &err_env__; \ 106 | if (setjmp(err_env__)) { \ 107 | ar_Value *err_val = (S)->err_args; \ 108 | (S)->frame->err_env = old_env__; \ 109 | err_blk; \ 110 | } else { \ 111 | blk; \ 112 | (S)->frame->err_env = old_env__; \ 113 | } \ 114 | } while (0) 115 | 116 | ar_State *ar_new_state(ar_Alloc alloc, void *udata); 117 | void ar_close_state(ar_State *S); 118 | ar_CFunc ar_at_panic(ar_State *S, ar_CFunc fn); 119 | void ar_error(ar_State *S, ar_Value *err); 120 | void ar_error_str(ar_State *S, const char *fmt, ...); 121 | 122 | ar_Value *ar_new_env(ar_State *S, ar_Value *parent); 123 | ar_Value *ar_new_pair(ar_State *S, ar_Value *car, ar_Value *cdr); 124 | ar_Value *ar_new_list(ar_State *S, size_t n, ...); 125 | ar_Value *ar_new_number(ar_State *S, double n); 126 | ar_Value *ar_new_udata(ar_State *S, void *ptr, ar_CFunc gc, ar_CFunc mark); 127 | ar_Value *ar_new_stringl(ar_State *S, const char *str, size_t len); 128 | ar_Value *ar_new_string(ar_State *S, const char *str); 129 | ar_Value *ar_new_symbol(ar_State *S, const char *name); 130 | ar_Value *ar_new_cfunc(ar_State *S, ar_CFunc fn); 131 | ar_Value *ar_new_prim(ar_State *S, ar_Prim fn); 132 | 133 | int ar_type(ar_Value *v); 134 | const char *ar_type_str(int type); 135 | ar_Value *ar_check(ar_State *S, ar_Value *v, int type); 136 | ar_Value *ar_car(ar_Value *v); 137 | ar_Value *ar_cdr(ar_Value *v); 138 | ar_Value *ar_nth(ar_Value *v, int idx); 139 | ar_Value **ar_append_tail(ar_State *S, ar_Value **last, ar_Value *v); 140 | ar_Value *ar_to_string_value(ar_State *S, ar_Value *v, int quotestr); 141 | 142 | const char *ar_to_stringl(ar_State *S, ar_Value *v, size_t *len); 143 | const char *ar_to_string(ar_State *S, ar_Value *v); 144 | void *ar_to_udata(ar_State *S, ar_Value *v); 145 | double ar_to_number(ar_State *S, ar_Value *v); 146 | const char *ar_opt_string(ar_State *S, ar_Value *v, const char *def); 147 | void *ar_opt_udata(ar_State *S, ar_Value *v, void *def); 148 | double ar_opt_number(ar_State *S, ar_Value *v, double def); 149 | 150 | ar_Value *ar_bind(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env); 151 | ar_Value *ar_set(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env); 152 | 153 | void ar_mark(ar_State *S, ar_Value *v); 154 | void ar_gc(ar_State *S); 155 | 156 | ar_Value *ar_parse(ar_State *S, const char *str, const char *name); 157 | ar_Value *ar_eval(ar_State *S, ar_Value *v, ar_Value *env); 158 | ar_Value *ar_call(ar_State *S, ar_Value *fn, ar_Value *args); 159 | ar_Value *ar_do_list(ar_State *S, ar_Value *body, ar_Value *env); 160 | ar_Value *ar_do_string(ar_State *S, const char *str); 161 | ar_Value *ar_do_file(ar_State *S, const char *filename); 162 | 163 | #endif 164 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | gcc aria.c -o aria -DAR_STANDALONE -Wall -Wextra -std=c89 -pedantic -O3 3 | strip aria 4 | -------------------------------------------------------------------------------- /lib.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | ; core 4 | 5 | (= caar (fn (x) (car (car x)))) 6 | (= cadr (fn (x) (car (cdr x)))) 7 | (= cddr (fn (x) (cdr (cdr x)))) 8 | (= cdar (fn (x) (cdr (car x)))) 9 | 10 | (= dostring (fn (str name) 11 | (default name "(string)") 12 | (eval (parse str name) global))) 13 | 14 | (= dofile (fn (filename) 15 | (dostring (loads filename) filename))) 16 | 17 | (= not (fn (x) 18 | (is x nil))) 19 | 20 | (= isnt (fn (a b) 21 | (not (is a b)))) 22 | 23 | (= isa (fn (x y) 24 | (is (type x) y))) 25 | 26 | (= when (macro (x . body) 27 | (list if x (cons do body)))) 28 | 29 | (= unless (macro (x . body) 30 | (list if (list not x) (cons do body)))) 31 | 32 | (= whenlet (macro (x . body) 33 | (list let x 34 | (list if (car x) (cons do body))))) 35 | 36 | (= ++ (macro (x n) 37 | (list = x (list + x (list or n 1))))) 38 | 39 | (= -- (macro (x n) 40 | (list = x (list - x (list or n 1))))) 41 | 42 | (= default (macro (x val) 43 | (list = x (list or x val)))) 44 | 45 | (= assert (fn (val msg) 46 | (if (not val) 47 | (error (or msg "assertion failed"))) 48 | val)) 49 | 50 | (= gensym (let (x 0) 51 | (fn () 52 | (parse (string "G#" (++ x)))))) 53 | 54 | 55 | ; math 56 | 57 | (= rand (let (seed 0) 58 | (fn (n) 59 | (= seed (mod (+ (* seed 196561) 1374) 2147483647)) 60 | (if n (mod seed n) (/ seed 2147483647))))) 61 | 62 | (= abs (fn (n) 63 | (if (< n 0) (- 0 n) n))) 64 | 65 | (= floor (fn (n) 66 | (- n (mod n 1)))) 67 | 68 | (= min (fn args 69 | (reduce (fn (a b) (if (< a b) a b)) args))) 70 | 71 | (= max (fn args 72 | (reduce (fn (a b) (if (> a b) a b)) args))) 73 | 74 | 75 | ; loop 76 | 77 | (= until (macro (x . body) 78 | (cons while (cons (list not x) body)))) 79 | 80 | (= times (fn (n f) 81 | (let (i 0) 82 | (while (< i n) 83 | (f i) 84 | (++ i))))) 85 | 86 | 87 | ; list 88 | 89 | (= nth* (fn (n lst) 90 | (if (>= n 0) (do 91 | (while (> n 0) 92 | (= lst (cdr lst) 93 | n (- n 1))) 94 | lst)))) 95 | 96 | (= nth (fn (n lst) 97 | (car (nth* n lst)))) 98 | 99 | (= len (fn (lst) 100 | (let (res 0) 101 | (while lst 102 | (= res (+ res 1) 103 | lst (cdr lst))) 104 | res))) 105 | 106 | (= take (fn (n lst) 107 | (collect (fn (p) 108 | (while (and lst (> n 0)) 109 | (p (car lst)) 110 | (= lst (cdr lst)) 111 | (-- n)))))) 112 | 113 | (= reverse (fn (lst) 114 | (let (res nil) 115 | (each (fn (c) (= res (cons c res))) lst) 116 | res))) 117 | 118 | (= choice (fn (lst) 119 | (nth (rand (len lst)) lst))) 120 | 121 | (= each (fn (f lst) 122 | (while lst 123 | (f (car lst)) 124 | (= lst (cdr lst))))) 125 | 126 | (= concat (fn args 127 | (collect (fn (p) 128 | (each (fn (c) 129 | (each p c)) args))))) 130 | 131 | (= map (fn (f lst) 132 | (collect (fn (p) 133 | (each (fn (c) 134 | (p (f c))) lst))))) 135 | 136 | (= filter (fn (f lst) 137 | (collect (fn (p) 138 | (each (fn (c) 139 | (if (f c) (p c))) lst))))) 140 | 141 | (= reject (fn (f lst) 142 | (collect (fn (p) 143 | (each (fn (c) 144 | (if (not (f c)) (p c))) lst))))) 145 | 146 | (= count (fn (f lst) 147 | (let (n 0) 148 | (each (fn (x) 149 | (if (f x) (= n (+ n 1)))) lst) 150 | n))) 151 | 152 | (= any (fn (f lst) 153 | (if (find* f lst) t))) 154 | 155 | (= all (fn (f lst) 156 | (let (res t) 157 | (while lst 158 | (if (not (f (car lst))) 159 | (= res nil 160 | lst nil) 161 | (= lst (cdr lst)))) 162 | res))) 163 | 164 | (= find* (fn (f lst) 165 | (let (res nil) 166 | (while lst 167 | (if (f (car lst)) 168 | (= res lst 169 | lst nil) 170 | (= lst (cdr lst)))) 171 | res))) 172 | 173 | (= find (fn (f lst) 174 | (car (find* f lst)))) 175 | 176 | (= pos (fn (val lst) 177 | (let (i 0 found nil) 178 | (while lst 179 | (if (is (car lst) val) 180 | (= found t 181 | lst nil) 182 | (do (= lst (cdr lst)) 183 | (++ i)))) 184 | (if found i)))) 185 | 186 | (= has (fn (val lst) 187 | (let (res nil) 188 | (while lst 189 | (if (is (car lst) val) 190 | (= lst nil 191 | res t) 192 | (= lst (cdr lst)))) 193 | res))) 194 | 195 | (= reduce (fn (f lst) 196 | (let (res (car lst)) 197 | (= lst (cdr lst)) 198 | (while lst 199 | (= res (f res (car lst)) 200 | lst (cdr lst))) 201 | res))) 202 | 203 | (= collect (fn (f) 204 | (let (res (cons) x res) 205 | (f (fn (val) 206 | (setcdr x (cons val)) 207 | (= x (cdr x)))) 208 | (cdr res)))) 209 | 210 | (= range (fn (lo hi) 211 | (unless hi (= hi lo 212 | lo 0)) 213 | (let (res nil) 214 | (while (>= (-- hi) lo) 215 | (= res (cons hi res))) 216 | res))) 217 | 218 | (= push (macro (val sym) 219 | (list = sym (list cons val sym)))) 220 | 221 | (= pop (macro (sym) 222 | (let (x (gensym)) 223 | (list let (list x (list car sym)) 224 | (list = sym (list cdr sym)) 225 | x)))) 226 | 227 | 228 | ; association list 229 | 230 | (= alist (fn x 231 | (let (res nil) 232 | (while (car x) 233 | (= res (alcons (car x) (cadr x) res) 234 | x (cddr x))) 235 | res))) 236 | 237 | (= alget (fn (key lst) 238 | (while (and lst (isnt (caar lst) key)) 239 | (= lst (cdr lst))) 240 | (car lst))) 241 | 242 | (= alref (fn (key lst) 243 | (cdr (alget key lst)))) 244 | 245 | (= alset (fn (key val lst) 246 | (let (x (alget key lst)) 247 | (if x (do (setcdr x val) lst) 248 | (alcons key val lst))))) 249 | 250 | (= aldel (fn (key lst) 251 | (if (is (caar lst) key) 252 | (cdr lst) 253 | (let (x lst) 254 | (while x 255 | (if (is (caar (cdr x)) key) 256 | (do (setcdr x (cddr x)) 257 | (= x nil)) 258 | (= x (cdr x)))) 259 | lst)))) 260 | 261 | (= alcons (fn (key val lst) 262 | (cons (cons key val) lst))) 263 | 264 | 265 | ; string 266 | 267 | (= join (fn (lst sep) 268 | (default sep "") 269 | (apply string 270 | (let (x lst) 271 | (collect (fn (p) 272 | (while x 273 | (if (isnt x lst) (p sep)) 274 | (p (car x)) 275 | (= x (cdr x))))))))) 276 | 277 | (= split (fn (str delim) 278 | (default delim " ") 279 | (collect (fn (p) 280 | (let (offset 0 x nil) 281 | (while str 282 | (= x (strpos str delim offset)) 283 | (if x (do 284 | (p (substr str offset (- x offset))) 285 | (= offset (+ x (strlen delim)))) 286 | (do 287 | (p (substr str offset)) 288 | (= str nil))))))))) 289 | 290 | (= replace (fn (str old new) 291 | (join (split str old) new))) 292 | 293 | (= ltrim (fn (str chr) 294 | (default chr " ") 295 | (let (i 0) 296 | (while (is (substr str i 1) chr) 297 | (++ i)) 298 | (substr str i)))) 299 | 300 | (= rtrim (fn (str chr) 301 | (default chr " ") 302 | (let (i (- (strlen str) 1)) 303 | (while (is (substr str i 1) chr) 304 | (-- i)) 305 | (substr str 0 (+ i 1))))) 306 | 307 | (= trim (fn (str chr) 308 | (ltrim (rtrim str chr) chr))) 309 | 310 | nil) 311 | -------------------------------------------------------------------------------- /script/fib.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | (= fib (fn (n) 4 | (if (>= n 2) 5 | (+ (fib (- n 1)) (fib (- n 2))) 6 | n))) 7 | 8 | (print (fib 20))) ; prints 6765 9 | -------------------------------------------------------------------------------- /script/hello.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | (print "hello world")) 4 | -------------------------------------------------------------------------------- /script/life.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | ; load lib 4 | (eval (parse (loads "lib.lsp") "lib.lsp") global) 5 | 6 | 7 | (= eachi (fn (f lst) 8 | (let (i 0) 9 | (while lst 10 | (f (car lst) i) 11 | (++ i) 12 | (= lst (cdr lst)))))) 13 | 14 | 15 | (= print-grid (fn (grid) 16 | (each (fn (row) 17 | (print 18 | (map (fn (x) (if (is x 0) '- '#)) 19 | row))) 20 | grid))) 21 | 22 | 23 | (= get-cell (fn (grid x y) 24 | (or (nth x (nth y grid)) 0))) 25 | 26 | 27 | (= next-cell (fn (grid cell x y) 28 | (let (n (+ (get-cell grid (- x 1) (- y 1)) 29 | (get-cell grid (- x 1) y) 30 | (get-cell grid (- x 1) (+ y 1)) 31 | (get-cell grid x (- y 1)) 32 | (get-cell grid x (+ y 1)) 33 | (get-cell grid (+ x 1) (- y 1)) 34 | (get-cell grid (+ x 1) y) 35 | (get-cell grid (+ x 1) (+ y 1)))) 36 | (if (and (is cell 1) (or (is n 2) (is n 3))) 1 37 | (and (is cell 0) (is n 3)) 1 38 | 0)))) 39 | 40 | 41 | (= next-grid (fn (grid) 42 | (collect (fn (add-row) 43 | (eachi (fn (row y) 44 | (add-row (collect (fn (add-cell) 45 | (eachi (fn (cell x) 46 | (add-cell (next-cell grid cell x y))) 47 | row))))) 48 | grid))))) 49 | 50 | 51 | (= life (fn (grid n) 52 | (times n (fn (i) 53 | (print "--- iteration" (+ i 1)) 54 | (print-grid grid) 55 | (print) 56 | (= grid (next-grid grid)))))) 57 | 58 | 59 | ; blinker in a 3x3 universe 60 | (life '((0 1 0) 61 | (0 1 0) 62 | (0 1 0)) 63 | 5) 64 | 65 | ; glider in an 8x8 universe 66 | (life '((0 0 1 0 0 0 0 0) 67 | (0 0 0 1 0 0 0 0) 68 | (0 1 1 1 0 0 0 0) 69 | (0 0 0 0 0 0 0 0) 70 | (0 0 0 0 0 0 0 0) 71 | (0 0 0 0 0 0 0 0) 72 | (0 0 0 0 0 0 0 0) 73 | (0 0 0 0 0 0 0 0)) 74 | 24)) 75 | -------------------------------------------------------------------------------- /script/mandelbrot.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | ; load lib 4 | (eval (parse (loads "lib.lsp") "lib.lsp") global) 5 | 6 | 7 | (= width 79) 8 | (= height 24) 9 | (= chars " .,;/oO%8@#") 10 | 11 | (times height (fn (y) 12 | (print (join (collect (fn (p) 13 | (times width (fn (x) 14 | (let (x0 (+ -2.2 (* (/ 3 width) x)) 15 | y0 (+ -1.5 (* (/ 3 height) y)) 16 | x 0 17 | y 0 18 | n 16 19 | i 1 20 | z nil) 21 | (while (and (< (+ (* x x) (* y y)) 4) (< i n)) 22 | (= z (+ (- (* x x) (* y y)) x0) 23 | y (+ (* 2 x y) y0) 24 | x z 25 | i (+ i 1))) 26 | (= z (* (/ i n) (- (strlen chars) 1))) 27 | (p (substr chars z 1)))))))))))) 28 | -------------------------------------------------------------------------------- /script/titleize.lsp: -------------------------------------------------------------------------------- 1 | (do 2 | 3 | ; load lib 4 | (eval (parse (loads "lib.lsp") "lib.lsp") global) 5 | 6 | 7 | (= capitalize (fn (s) 8 | (string (upper (substr s 0 1)) (substr s 1)))) 9 | 10 | (= titleize (fn (s) 11 | (join (map capitalize (split s " ")) " "))) 12 | 13 | 14 | (print (titleize "hello world"))) ; prints "Hello World" 15 | --------------------------------------------------------------------------------