1/* 2 * ALSA lisp implementation 3 * Copyright (c) 2003 by Jaroslav Kysela <perex@perex.cz> 4 * 5 * Based on work of Sandro Sigala (slisp-1.2) 6 * 7 * 8 * This library is free software; you can redistribute it and/or modify 9 * it under the terms of the GNU Lesser General Public License as 10 * published by the Free Software Foundation; either version 2.1 of 11 * the License, or (at your option) any later version. 12 * 13 * This program is distributed in the hope that it will be useful, 14 * but WITHOUT ANY WARRANTY; without even the implied warranty of 15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 * GNU Lesser General Public License for more details. 17 * 18 * You should have received a copy of the GNU Lesser General Public 19 * License along with this library; if not, write to the Free Software 20 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 21 * 22 */ 23 24#define alisp_seq_iterator alisp_object 25 26#include "local.h" 27#include "alisp.h" 28#include "alisp_local.h" 29 30#include <assert.h> 31 32#include <limits.h> 33#include <stdio.h> 34#include <stdlib.h> 35#include <string.h> 36#include <ctype.h> 37#include <math.h> 38#include <err.h> 39 40 41struct alisp_object alsa_lisp_nil; 42struct alisp_object alsa_lisp_t; 43 44/* parser prototypes */ 45static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken); 46static void princ_cons(snd_output_t *out, struct alisp_object * p); 47static void princ_object(snd_output_t *out, struct alisp_object * p); 48static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p); 49 50/* functions */ 51static struct alisp_object *F_eval(struct alisp_instance *instance, struct alisp_object *); 52static struct alisp_object *F_progn(struct alisp_instance *instance, struct alisp_object *); 53static struct alisp_object *F_funcall(struct alisp_instance *instance, struct alisp_object *); 54 55/* others */ 56static int alisp_include_file(struct alisp_instance *instance, const char *filename); 57 58/* 59 * object handling 60 */ 61 62static int get_string_hash(const char *s) 63{ 64 int val = 0; 65 if (s == NULL) 66 return val; 67 while (*s) 68 val += *s++; 69 return val & ALISP_OBJ_PAIR_HASH_MASK; 70} 71 72static void nomem(void) 73{ 74 SNDERR("alisp: no enough memory"); 75} 76 77static void lisp_verbose(struct alisp_instance *instance, const char *fmt, ...) 78{ 79 va_list ap; 80 81 if (!instance->verbose) 82 return; 83 va_start(ap, fmt); 84 snd_output_printf(instance->vout, "alisp: "); 85 snd_output_vprintf(instance->vout, fmt, ap); 86 snd_output_putc(instance->vout, '\n'); 87 va_end(ap); 88} 89 90static void lisp_error(struct alisp_instance *instance, const char *fmt, ...) 91{ 92 va_list ap; 93 94 if (!instance->warning) 95 return; 96 va_start(ap, fmt); 97 snd_output_printf(instance->eout, "alisp error: "); 98 snd_output_vprintf(instance->eout, fmt, ap); 99 snd_output_putc(instance->eout, '\n'); 100 va_end(ap); 101} 102 103static void lisp_warn(struct alisp_instance *instance, const char *fmt, ...) 104{ 105 va_list ap; 106 107 if (!instance->warning) 108 return; 109 va_start(ap, fmt); 110 snd_output_printf(instance->wout, "alisp warning: "); 111 snd_output_vprintf(instance->wout, fmt, ap); 112 snd_output_putc(instance->wout, '\n'); 113 va_end(ap); 114} 115 116static void lisp_debug(struct alisp_instance *instance, const char *fmt, ...) 117{ 118 va_list ap; 119 120 if (!instance->debug) 121 return; 122 va_start(ap, fmt); 123 snd_output_printf(instance->dout, "alisp debug: "); 124 snd_output_vprintf(instance->dout, fmt, ap); 125 snd_output_putc(instance->dout, '\n'); 126 va_end(ap); 127} 128 129static struct alisp_object * new_object(struct alisp_instance *instance, int type) 130{ 131 struct alisp_object * p; 132 133 if (list_empty(&instance->free_objs_list)) { 134 p = (struct alisp_object *)malloc(sizeof(struct alisp_object)); 135 if (p == NULL) { 136 nomem(); 137 return NULL; 138 } 139 lisp_debug(instance, "allocating cons %p", p); 140 } else { 141 p = (struct alisp_object *)instance->free_objs_list.next; 142 list_del(&p->list); 143 instance->free_objs--; 144 lisp_debug(instance, "recycling cons %p", p); 145 } 146 147 instance->used_objs++; 148 149 alisp_set_type(p, type); 150 alisp_set_refs(p, 1); 151 if (type == ALISP_OBJ_CONS) { 152 p->value.c.car = &alsa_lisp_nil; 153 p->value.c.cdr = &alsa_lisp_nil; 154 list_add(&p->list, &instance->used_objs_list[0][ALISP_OBJ_CONS]); 155 } 156 157 if (instance->used_objs + instance->free_objs > instance->max_objs) 158 instance->max_objs = instance->used_objs + instance->free_objs; 159 160 return p; 161} 162 163static void free_object(struct alisp_object * p) 164{ 165 switch (alisp_get_type(p)) { 166 case ALISP_OBJ_STRING: 167 case ALISP_OBJ_IDENTIFIER: 168 free(p->value.s); 169 alisp_set_type(p, ALISP_OBJ_INTEGER); 170 break; 171 default: 172 break; 173 } 174} 175 176static void delete_object(struct alisp_instance *instance, struct alisp_object * p) 177{ 178 if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t) 179 return; 180 if (alisp_compare_type(p, ALISP_OBJ_NIL) || 181 alisp_compare_type(p, ALISP_OBJ_T)) 182 return; 183 assert(alisp_get_refs(p) > 0); 184 lisp_debug(instance, "delete cons %p (type = %i, refs = %i) (s = '%s')", p, alisp_get_type(p), alisp_get_refs(p), 185 alisp_compare_type(p, ALISP_OBJ_STRING) || 186 alisp_compare_type(p, ALISP_OBJ_IDENTIFIER) ? p->value.s : "???"); 187 if (alisp_dec_refs(p)) 188 return; 189 list_del(&p->list); 190 instance->used_objs--; 191 free_object(p); 192 if (instance->free_objs >= ALISP_FREE_OBJ_POOL) { 193 lisp_debug(instance, "freed cons %p", p); 194 free(p); 195 return; 196 } 197 lisp_debug(instance, "moved cons %p to free list", p); 198 list_add(&p->list, &instance->free_objs_list); 199 instance->free_objs++; 200} 201 202static void delete_tree(struct alisp_instance *instance, struct alisp_object * p) 203{ 204 if (p == NULL) 205 return; 206 if (alisp_compare_type(p, ALISP_OBJ_CONS)) { 207 delete_tree(instance, p->value.c.car); 208 delete_tree(instance, p->value.c.cdr); 209 } 210 delete_object(instance, p); 211} 212 213static struct alisp_object * incref_object(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * p) 214{ 215 if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t) 216 return p; 217 if (alisp_get_refs(p) == ALISP_MAX_REFS) { 218 assert(0); 219 fprintf(stderr, "OOPS: alsa lisp: incref fatal error\n"); 220 exit(EXIT_FAILURE); 221 } 222 alisp_inc_refs(p); 223 return p; 224} 225 226static struct alisp_object * incref_tree(struct alisp_instance *instance, struct alisp_object * p) 227{ 228 if (p == NULL) 229 return NULL; 230 if (alisp_compare_type(p, ALISP_OBJ_CONS)) { 231 incref_tree(instance, p->value.c.car); 232 incref_tree(instance, p->value.c.cdr); 233 } 234 return incref_object(instance, p); 235} 236 237/* Function not used yet. Leave it commented out until we actually use it to 238 * avoid compiler complaints */ 239#if 0 240static struct alisp_object * incref_tree_explicit(struct alisp_instance *instance, struct alisp_object * p, struct alisp_object * e) 241{ 242 if (p == NULL) 243 return NULL; 244 if (alisp_compare_type(p, ALISP_OBJ_CONS)) { 245 if (e == p) { 246 incref_tree(instance, p->value.c.car); 247 incref_tree(instance, p->value.c.cdr); 248 } else { 249 incref_tree_explicit(instance, p->value.c.car, e); 250 incref_tree_explicit(instance, p->value.c.cdr, e); 251 } 252 } 253 if (e == p) 254 return incref_object(instance, p); 255 return p; 256} 257#endif 258 259static void free_objects(struct alisp_instance *instance) 260{ 261 struct list_head *pos, *pos1; 262 struct alisp_object * p; 263 struct alisp_object_pair * pair; 264 int i, j; 265 266 for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { 267 list_for_each_safe(pos, pos1, &instance->setobjs_list[i]) { 268 pair = list_entry(pos, struct alisp_object_pair, list); 269 lisp_debug(instance, "freeing pair: '%s' -> %p", pair->name, pair->value); 270 delete_tree(instance, pair->value); 271 free((void *)pair->name); 272 free(pair); 273 } 274 } 275 for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) 276 for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) { 277 list_for_each_safe(pos, pos1, &instance->used_objs_list[i][j]) { 278 p = list_entry(pos, struct alisp_object, list); 279 lisp_warn(instance, "object %p is still referenced %i times!", p, alisp_get_refs(p)); 280#if 0 281 snd_output_printf(instance->wout, ">>>> "); 282 princ_object(instance->wout, p); 283 snd_output_printf(instance->wout, " <<<<\n"); 284#endif 285 if (alisp_get_refs(p) > 0) 286 alisp_set_refs(p, 1); 287 delete_object(instance, p); 288 } 289 } 290 list_for_each_safe(pos, pos1, &instance->free_objs_list) { 291 p = list_entry(pos, struct alisp_object, list); 292 list_del(&p->list); 293 free(p); 294 lisp_debug(instance, "freed (all) cons %p", p); 295 } 296} 297 298static struct alisp_object * search_object_identifier(struct alisp_instance *instance, const char *s) 299{ 300 struct list_head * pos; 301 struct alisp_object * p; 302 303 list_for_each(pos, &instance->used_objs_list[get_string_hash(s)][ALISP_OBJ_IDENTIFIER]) { 304 p = list_entry(pos, struct alisp_object, list); 305 if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) 306 continue; 307 if (!strcmp(p->value.s, s)) 308 return incref_object(instance, p); 309 } 310 311 return NULL; 312} 313 314static struct alisp_object * search_object_string(struct alisp_instance *instance, const char *s) 315{ 316 struct list_head * pos; 317 struct alisp_object * p; 318 319 list_for_each(pos, &instance->used_objs_list[get_string_hash(s)][ALISP_OBJ_STRING]) { 320 p = list_entry(pos, struct alisp_object, list); 321 if (!strcmp(p->value.s, s)) { 322 if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) 323 continue; 324 return incref_object(instance, p); 325 } 326 } 327 328 return NULL; 329} 330 331static struct alisp_object * search_object_integer(struct alisp_instance *instance, long in) 332{ 333 struct list_head * pos; 334 struct alisp_object * p; 335 336 list_for_each(pos, &instance->used_objs_list[in & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_INTEGER]) { 337 p = list_entry(pos, struct alisp_object, list); 338 if (p->value.i == in) { 339 if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) 340 continue; 341 return incref_object(instance, p); 342 } 343 } 344 345 return NULL; 346} 347 348static struct alisp_object * search_object_float(struct alisp_instance *instance, double in) 349{ 350 struct list_head * pos; 351 struct alisp_object * p; 352 353 list_for_each(pos, &instance->used_objs_list[(long)in & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_FLOAT]) { 354 p = list_entry(pos, struct alisp_object, list); 355 if (p->value.i == in) { 356 if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) 357 continue; 358 return incref_object(instance, p); 359 } 360 } 361 362 return NULL; 363} 364 365static struct alisp_object * search_object_pointer(struct alisp_instance *instance, const void *ptr) 366{ 367 struct list_head * pos; 368 struct alisp_object * p; 369 370 list_for_each(pos, &instance->used_objs_list[(long)ptr & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_POINTER]) { 371 p = list_entry(pos, struct alisp_object, list); 372 if (p->value.ptr == ptr) { 373 if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) 374 continue; 375 return incref_object(instance, p); 376 } 377 } 378 379 return NULL; 380} 381 382static struct alisp_object * new_integer(struct alisp_instance *instance, long value) 383{ 384 struct alisp_object * obj; 385 386 obj = search_object_integer(instance, value); 387 if (obj != NULL) 388 return obj; 389 obj = new_object(instance, ALISP_OBJ_INTEGER); 390 if (obj) { 391 list_add(&obj->list, &instance->used_objs_list[value & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_INTEGER]); 392 obj->value.i = value; 393 } 394 return obj; 395} 396 397static struct alisp_object * new_float(struct alisp_instance *instance, double value) 398{ 399 struct alisp_object * obj; 400 401 obj = search_object_float(instance, value); 402 if (obj != NULL) 403 return obj; 404 obj = new_object(instance, ALISP_OBJ_FLOAT); 405 if (obj) { 406 list_add(&obj->list, &instance->used_objs_list[(long)value & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_FLOAT]); 407 obj->value.f = value; 408 } 409 return obj; 410} 411 412static struct alisp_object * new_string(struct alisp_instance *instance, const char *str) 413{ 414 struct alisp_object * obj; 415 416 obj = search_object_string(instance, str); 417 if (obj != NULL) 418 return obj; 419 obj = new_object(instance, ALISP_OBJ_STRING); 420 if (obj) 421 list_add(&obj->list, &instance->used_objs_list[get_string_hash(str)][ALISP_OBJ_STRING]); 422 if (obj && (obj->value.s = strdup(str)) == NULL) { 423 delete_object(instance, obj); 424 nomem(); 425 return NULL; 426 } 427 return obj; 428} 429 430static struct alisp_object * new_identifier(struct alisp_instance *instance, const char *id) 431{ 432 struct alisp_object * obj; 433 434 obj = search_object_identifier(instance, id); 435 if (obj != NULL) 436 return obj; 437 obj = new_object(instance, ALISP_OBJ_IDENTIFIER); 438 if (obj) 439 list_add(&obj->list, &instance->used_objs_list[get_string_hash(id)][ALISP_OBJ_IDENTIFIER]); 440 if (obj && (obj->value.s = strdup(id)) == NULL) { 441 delete_object(instance, obj); 442 nomem(); 443 return NULL; 444 } 445 return obj; 446} 447 448static struct alisp_object * new_pointer(struct alisp_instance *instance, const void *ptr) 449{ 450 struct alisp_object * obj; 451 452 obj = search_object_pointer(instance, ptr); 453 if (obj != NULL) 454 return obj; 455 obj = new_object(instance, ALISP_OBJ_POINTER); 456 if (obj) { 457 list_add(&obj->list, &instance->used_objs_list[(long)ptr & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_POINTER]); 458 obj->value.ptr = ptr; 459 } 460 return obj; 461} 462 463static struct alisp_object * new_cons_pointer(struct alisp_instance * instance, const char *ptr_id, void *ptr) 464{ 465 struct alisp_object * lexpr; 466 467 if (ptr == NULL) 468 return &alsa_lisp_nil; 469 lexpr = new_object(instance, ALISP_OBJ_CONS); 470 if (lexpr == NULL) 471 return NULL; 472 lexpr->value.c.car = new_string(instance, ptr_id); 473 if (lexpr->value.c.car == NULL) 474 goto __end; 475 lexpr->value.c.cdr = new_pointer(instance, ptr); 476 if (lexpr->value.c.cdr == NULL) { 477 delete_object(instance, lexpr->value.c.car); 478 __end: 479 delete_object(instance, lexpr); 480 return NULL; 481 } 482 return lexpr; 483} 484 485void alsa_lisp_init_objects(void) __attribute__ ((constructor)); 486 487void alsa_lisp_init_objects(void) 488{ 489 memset(&alsa_lisp_nil, 0, sizeof(alsa_lisp_nil)); 490 alisp_set_type(&alsa_lisp_nil, ALISP_OBJ_NIL); 491 INIT_LIST_HEAD(&alsa_lisp_nil.list); 492 memset(&alsa_lisp_t, 0, sizeof(alsa_lisp_t)); 493 alisp_set_type(&alsa_lisp_t, ALISP_OBJ_T); 494 INIT_LIST_HEAD(&alsa_lisp_t.list); 495} 496 497/* 498 * lexer 499 */ 500 501static int xgetc(struct alisp_instance *instance) 502{ 503 instance->charno++; 504 if (instance->lex_bufp > instance->lex_buf) 505 return *--(instance->lex_bufp); 506 return snd_input_getc(instance->in); 507} 508 509static inline void xungetc(struct alisp_instance *instance, int c) 510{ 511 *(instance->lex_bufp)++ = c; 512 instance->charno--; 513} 514 515static int init_lex(struct alisp_instance *instance) 516{ 517 instance->charno = instance->lineno = 1; 518 instance->token_buffer_max = 10; 519 if ((instance->token_buffer = (char *)malloc(instance->token_buffer_max)) == NULL) { 520 nomem(); 521 return -ENOMEM; 522 } 523 instance->lex_bufp = instance->lex_buf; 524 return 0; 525} 526 527static void done_lex(struct alisp_instance *instance) 528{ 529 free(instance->token_buffer); 530} 531 532static char * extend_buf(struct alisp_instance *instance, char *p) 533{ 534 int off = p - instance->token_buffer; 535 536 instance->token_buffer_max += 10; 537 instance->token_buffer = (char *)realloc(instance->token_buffer, instance->token_buffer_max); 538 if (instance->token_buffer == NULL) { 539 nomem(); 540 return NULL; 541 } 542 543 return instance->token_buffer + off; 544} 545 546static int gettoken(struct alisp_instance *instance) 547{ 548 char *p; 549 int c; 550 551 for (;;) { 552 c = xgetc(instance); 553 switch (c) { 554 case '\n': 555 ++instance->lineno; 556 break; 557 558 case ' ': case '\f': case '\t': case '\v': case '\r': 559 break; 560 561 case ';': 562 /* Comment: ";".*"\n" */ 563 while ((c = xgetc(instance)) != '\n' && c != EOF) 564 ; 565 if (c != EOF) 566 ++instance->lineno; 567 break; 568 569 case '?': 570 /* Character: "?". */ 571 c = xgetc(instance); 572 sprintf(instance->token_buffer, "%d", c); 573 return instance->thistoken = ALISP_INTEGER; 574 575 case '-': 576 /* Minus sign: "-". */ 577 c = xgetc(instance); 578 if (!isdigit(c)) { 579 xungetc(instance, c); 580 c = '-'; 581 goto got_id; 582 } 583 xungetc(instance, c); 584 c = '-'; 585 /* FALLTRHU */ 586 587 case '0': 588 case '1': case '2': case '3': 589 case '4': case '5': case '6': 590 case '7': case '8': case '9': 591 /* Integer: [0-9]+ */ 592 p = instance->token_buffer; 593 instance->thistoken = ALISP_INTEGER; 594 do { 595 __ok: 596 if (p - instance->token_buffer >= instance->token_buffer_max - 1) { 597 p = extend_buf(instance, p); 598 if (p == NULL) 599 return instance->thistoken = EOF; 600 } 601 *p++ = c; 602 c = xgetc(instance); 603 if (c == '.' && instance->thistoken == ALISP_INTEGER) { 604 c = xgetc(instance); 605 xungetc(instance, c); 606 if (isdigit(c)) { 607 instance->thistoken = ALISP_FLOAT; 608 c = '.'; 609 goto __ok; 610 } else { 611 c = '.'; 612 } 613 } else if (c == 'e' && instance->thistoken == ALISP_FLOAT) { 614 c = xgetc(instance); 615 if (isdigit(c)) { 616 instance->thistoken = ALISP_FLOATE; 617 goto __ok; 618 } 619 } 620 } while (isdigit(c)); 621 xungetc(instance, c); 622 *p = '\0'; 623 return instance->thistoken; 624 625 got_id: 626 case '!': case '_': case '+': case '*': case '/': case '%': 627 case '<': case '>': case '=': case '&': 628 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': 629 case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': 630 case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': 631 case 's': case 't': case 'u': case 'v': case 'w': case 'x': 632 case 'y': case 'z': 633 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 634 case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': 635 case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': 636 case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': 637 case 'Y': case 'Z': 638 /* Identifier: [!-/+*%<>=&a-zA-Z_][-/+*%<>=&a-zA-Z_0-9]* */ 639 p = instance->token_buffer; 640 do { 641 if (p - instance->token_buffer >= instance->token_buffer_max - 1) { 642 p = extend_buf(instance, p); 643 if (p == NULL) 644 return instance->thistoken = EOF; 645 } 646 *p++ = c; 647 c = xgetc(instance); 648 } while (isalnum(c) || strchr("!_-+*/%<>=&", c) != NULL); 649 xungetc(instance, c); 650 *p = '\0'; 651 return instance->thistoken = ALISP_IDENTIFIER; 652 653 case '"': 654 /* String: "\""([^"]|"\\".)*"\"" */ 655 p = instance->token_buffer; 656 while ((c = xgetc(instance)) != '"' && c != EOF) { 657 if (p - instance->token_buffer >= instance->token_buffer_max - 1) { 658 p = extend_buf(instance, p); 659 if (p == NULL) 660 return instance->thistoken = EOF; 661 } 662 if (c == '\\') { 663 c = xgetc(instance); 664 switch (c) { 665 case '\n': ++instance->lineno; break; 666 case 'a': *p++ = '\a'; break; 667 case 'b': *p++ = '\b'; break; 668 case 'f': *p++ = '\f'; break; 669 case 'n': *p++ = '\n'; break; 670 case 'r': *p++ = '\r'; break; 671 case 't': *p++ = '\t'; break; 672 case 'v': *p++ = '\v'; break; 673 default: *p++ = c; 674 } 675 } else { 676 if (c == '\n') 677 ++instance->lineno; 678 *p++ = c; 679 } 680 } 681 *p = '\0'; 682 return instance->thistoken = ALISP_STRING; 683 684 default: 685 return instance->thistoken = c; 686 } 687 } 688} 689 690/* 691 * parser 692 */ 693 694static struct alisp_object * parse_form(struct alisp_instance *instance) 695{ 696 int thistoken; 697 struct alisp_object * p, * first = NULL, * prev = NULL; 698 699 while ((thistoken = gettoken(instance)) != ')' && thistoken != EOF) { 700 /* 701 * Parse a dotted pair notation. 702 */ 703 if (thistoken == '.') { 704 gettoken(instance); 705 if (prev == NULL) { 706 lisp_error(instance, "unexpected '.'"); 707 __err: 708 delete_tree(instance, first); 709 return NULL; 710 } 711 prev->value.c.cdr = parse_object(instance, 1); 712 if (prev->value.c.cdr == NULL) 713 goto __err; 714 if ((thistoken = gettoken(instance)) != ')') { 715 lisp_error(instance, "expected ')'"); 716 goto __err; 717 } 718 break; 719 } 720 721 p = new_object(instance, ALISP_OBJ_CONS); 722 if (p == NULL) 723 goto __err; 724 725 if (first == NULL) 726 first = p; 727 if (prev != NULL) 728 prev->value.c.cdr = p; 729 730 p->value.c.car = parse_object(instance, 1); 731 if (p->value.c.car == NULL) 732 goto __err; 733 734 prev = p; 735 } 736 737 if (first == NULL) 738 return &alsa_lisp_nil; 739 else 740 return first; 741} 742 743static struct alisp_object * quote_object(struct alisp_instance *instance, struct alisp_object * obj) 744{ 745 struct alisp_object * p; 746 747 if (obj == NULL) 748 goto __end1; 749 750 p = new_object(instance, ALISP_OBJ_CONS); 751 if (p == NULL) 752 goto __end1; 753 754 p->value.c.car = new_identifier(instance, "quote"); 755 if (p->value.c.car == NULL) 756 goto __end; 757 p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); 758 if (p->value.c.cdr == NULL) { 759 delete_object(instance, p->value.c.car); 760 __end: 761 delete_object(instance, p); 762 __end1: 763 delete_tree(instance, obj); 764 return NULL; 765 } 766 767 p->value.c.cdr->value.c.car = obj; 768 return p; 769} 770 771static inline struct alisp_object * parse_quote(struct alisp_instance *instance) 772{ 773 return quote_object(instance, parse_object(instance, 0)); 774} 775 776static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken) 777{ 778 int thistoken; 779 struct alisp_object * p = NULL; 780 781 if (!havetoken) 782 thistoken = gettoken(instance); 783 else 784 thistoken = instance->thistoken; 785 786 switch (thistoken) { 787 case EOF: 788 break; 789 case '(': 790 p = parse_form(instance); 791 break; 792 case '\'': 793 p = parse_quote(instance); 794 break; 795 case ALISP_IDENTIFIER: 796 if (!strcmp(instance->token_buffer, "t")) 797 p = &alsa_lisp_t; 798 else if (!strcmp(instance->token_buffer, "nil")) 799 p = &alsa_lisp_nil; 800 else { 801 p = new_identifier(instance, instance->token_buffer); 802 } 803 break; 804 case ALISP_INTEGER: { 805 p = new_integer(instance, atol(instance->token_buffer)); 806 break; 807 } 808 case ALISP_FLOAT: 809 case ALISP_FLOATE: { 810 p = new_float(instance, atof(instance->token_buffer)); 811 break; 812 } 813 case ALISP_STRING: 814 p = new_string(instance, instance->token_buffer); 815 break; 816 default: 817 lisp_warn(instance, "%d:%d: unexpected character `%c'", instance->lineno, instance->charno, thistoken); 818 break; 819 } 820 821 return p; 822} 823 824/* 825 * object manipulation 826 */ 827 828static struct alisp_object_pair * set_object_direct(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * value) 829{ 830 struct alisp_object_pair *p; 831 const char *id; 832 833 id = name->value.s; 834 p = (struct alisp_object_pair *)malloc(sizeof(struct alisp_object_pair)); 835 if (p == NULL) { 836 nomem(); 837 return NULL; 838 } 839 p->name = strdup(id); 840 if (p->name == NULL) { 841 delete_tree(instance, value); 842 free(p); 843 return NULL; 844 } 845 list_add(&p->list, &instance->setobjs_list[get_string_hash(id)]); 846 p->value = value; 847 return p; 848} 849 850static int check_set_object(struct alisp_instance * instance, struct alisp_object * name) 851{ 852 if (name == &alsa_lisp_nil) { 853 lisp_warn(instance, "setting the value of a nil object"); 854 return 0; 855 } 856 if (name == &alsa_lisp_t) { 857 lisp_warn(instance, "setting the value of a t object"); 858 return 0; 859 } 860 if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && 861 !alisp_compare_type(name, ALISP_OBJ_STRING)) { 862 lisp_warn(instance, "setting the value of an object with non-indentifier"); 863 return 0; 864 } 865 return 1; 866} 867 868static struct alisp_object_pair * set_object(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * value) 869{ 870 struct list_head *pos; 871 struct alisp_object_pair *p; 872 const char *id; 873 874 if (name == NULL || value == NULL) 875 return NULL; 876 877 id = name->value.s; 878 879 list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { 880 p = list_entry(pos, struct alisp_object_pair, list); 881 if (!strcmp(p->name, id)) { 882 delete_tree(instance, p->value); 883 p->value = value; 884 return p; 885 } 886 } 887 888 p = (struct alisp_object_pair *)malloc(sizeof(struct alisp_object_pair)); 889 if (p == NULL) { 890 nomem(); 891 return NULL; 892 } 893 p->name = strdup(id); 894 if (p->name == NULL) { 895 delete_tree(instance, value); 896 free(p); 897 return NULL; 898 } 899 list_add(&p->list, &instance->setobjs_list[get_string_hash(id)]); 900 p->value = value; 901 return p; 902} 903 904static struct alisp_object * unset_object(struct alisp_instance *instance, struct alisp_object * name) 905{ 906 struct list_head *pos; 907 struct alisp_object *res; 908 struct alisp_object_pair *p; 909 const char *id; 910 911 if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && 912 !alisp_compare_type(name, ALISP_OBJ_STRING)) { 913 lisp_warn(instance, "unset object with a non-indentifier"); 914 return &alsa_lisp_nil; 915 } 916 id = name->value.s; 917 918 list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { 919 p = list_entry(pos, struct alisp_object_pair, list); 920 if (!strcmp(p->name, id)) { 921 list_del(&p->list); 922 res = p->value; 923 free((void *)p->name); 924 free(p); 925 return res; 926 } 927 } 928 929 return &alsa_lisp_nil; 930} 931 932static struct alisp_object * get_object1(struct alisp_instance *instance, const char *id) 933{ 934 struct alisp_object_pair *p; 935 struct list_head *pos; 936 937 list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { 938 p = list_entry(pos, struct alisp_object_pair, list); 939 if (!strcmp(p->name, id)) 940 return p->value; 941 } 942 943 return &alsa_lisp_nil; 944} 945 946static struct alisp_object * get_object(struct alisp_instance *instance, struct alisp_object * name) 947{ 948 if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && 949 !alisp_compare_type(name, ALISP_OBJ_STRING)) { 950 delete_tree(instance, name); 951 return &alsa_lisp_nil; 952 } 953 return get_object1(instance, name->value.s); 954} 955 956static struct alisp_object * replace_object(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * onew) 957{ 958 struct alisp_object_pair *p; 959 struct alisp_object *r; 960 struct list_head *pos; 961 const char *id; 962 963 if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && 964 !alisp_compare_type(name, ALISP_OBJ_STRING)) { 965 delete_tree(instance, name); 966 return &alsa_lisp_nil; 967 } 968 id = name->value.s; 969 list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { 970 p = list_entry(pos, struct alisp_object_pair, list); 971 if (!strcmp(p->name, id)) { 972 r = p->value; 973 p->value = onew; 974 return r; 975 } 976 } 977 978 return NULL; 979} 980 981static void dump_objects(struct alisp_instance *instance, const char *fname) 982{ 983 struct alisp_object_pair *p; 984 snd_output_t *out; 985 struct list_head *pos; 986 int i, err; 987 988 if (!strcmp(fname, "-")) 989 err = snd_output_stdio_attach(&out, stdout, 0); 990 else 991 err = snd_output_stdio_open(&out, fname, "w+"); 992 if (err < 0) { 993 SNDERR("alisp: cannot open file '%s' for writing (%s)", fname, snd_strerror(errno)); 994 return; 995 } 996 997 for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { 998 list_for_each(pos, &instance->setobjs_list[i]) { 999 p = list_entry(pos, struct alisp_object_pair, list); 1000 if (alisp_compare_type(p->value, ALISP_OBJ_CONS) && 1001 alisp_compare_type(p->value->value.c.car, ALISP_OBJ_IDENTIFIER) && 1002 !strcmp(p->value->value.c.car->value.s, "lambda")) { 1003 snd_output_printf(out, "(defun %s ", p->name); 1004 princ_cons(out, p->value->value.c.cdr); 1005 snd_output_printf(out, ")\n"); 1006 continue; 1007 } 1008 snd_output_printf(out, "(setq %s '", p->name); 1009 princ_object(out, p->value); 1010 snd_output_printf(out, ")\n"); 1011 } 1012 } 1013 snd_output_close(out); 1014} 1015 1016static const char *obj_type_str(struct alisp_object * p) 1017{ 1018 switch (alisp_get_type(p)) { 1019 case ALISP_OBJ_NIL: return "nil"; 1020 case ALISP_OBJ_T: return "t"; 1021 case ALISP_OBJ_INTEGER: return "integer"; 1022 case ALISP_OBJ_FLOAT: return "float"; 1023 case ALISP_OBJ_IDENTIFIER: return "identifier"; 1024 case ALISP_OBJ_STRING: return "string"; 1025 case ALISP_OBJ_POINTER: return "pointer"; 1026 case ALISP_OBJ_CONS: return "cons"; 1027 default: assert(0); 1028 } 1029} 1030 1031static void print_obj_lists(struct alisp_instance *instance, snd_output_t *out) 1032{ 1033 struct list_head *pos; 1034 struct alisp_object * p; 1035 int i, j; 1036 1037 snd_output_printf(out, "** used objects\n"); 1038 for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) 1039 for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) 1040 list_for_each(pos, &instance->used_objs_list[i][j]) { 1041 p = list_entry(pos, struct alisp_object, list); 1042 snd_output_printf(out, "** %p (%s) (", p, obj_type_str(p)); 1043 if (!alisp_compare_type(p, ALISP_OBJ_CONS)) 1044 princ_object(out, p); 1045 else 1046 snd_output_printf(out, "cons"); 1047 snd_output_printf(out, ") refs=%i\n", alisp_get_refs(p)); 1048 } 1049 snd_output_printf(out, "** free objects\n"); 1050 list_for_each(pos, &instance->free_objs_list) { 1051 p = list_entry(pos, struct alisp_object, list); 1052 snd_output_printf(out, "** %p\n", p); 1053 } 1054} 1055 1056static void dump_obj_lists(struct alisp_instance *instance, const char *fname) 1057{ 1058 snd_output_t *out; 1059 int err; 1060 1061 if (!strcmp(fname, "-")) 1062 err = snd_output_stdio_attach(&out, stdout, 0); 1063 else 1064 err = snd_output_stdio_open(&out, fname, "w+"); 1065 if (err < 0) { 1066 SNDERR("alisp: cannot open file '%s' for writing (%s)", fname, snd_strerror(errno)); 1067 return; 1068 } 1069 1070 print_obj_lists(instance, out); 1071 1072 snd_output_close(out); 1073} 1074 1075/* 1076 * functions 1077 */ 1078 1079static int count_list(struct alisp_object * p) 1080{ 1081 int i = 0; 1082 1083 while (p != &alsa_lisp_nil && alisp_compare_type(p, ALISP_OBJ_CONS)) { 1084 p = p->value.c.cdr; 1085 ++i; 1086 } 1087 1088 return i; 1089} 1090 1091static inline struct alisp_object * car(struct alisp_object * p) 1092{ 1093 if (alisp_compare_type(p, ALISP_OBJ_CONS)) 1094 return p->value.c.car; 1095 1096 return &alsa_lisp_nil; 1097} 1098 1099static inline struct alisp_object * cdr(struct alisp_object * p) 1100{ 1101 if (alisp_compare_type(p, ALISP_OBJ_CONS)) 1102 return p->value.c.cdr; 1103 1104 return &alsa_lisp_nil; 1105} 1106 1107/* 1108 * Syntax: (car expr) 1109 */ 1110static struct alisp_object * F_car(struct alisp_instance *instance, struct alisp_object * args) 1111{ 1112 struct alisp_object *p1 = car(args), *p2; 1113 delete_tree(instance, cdr(args)); 1114 delete_object(instance, args); 1115 p1 = eval(instance, p1); 1116 delete_tree(instance, cdr(p1)); 1117 p2 = car(p1); 1118 delete_object(instance, p1); 1119 return p2; 1120} 1121 1122/* 1123 * Syntax: (cdr expr) 1124 */ 1125static struct alisp_object * F_cdr(struct alisp_instance *instance, struct alisp_object * args) 1126{ 1127 struct alisp_object *p1 = car(args), *p2; 1128 delete_tree(instance, cdr(args)); 1129 delete_object(instance, args); 1130 p1 = eval(instance, p1); 1131 delete_tree(instance, car(p1)); 1132 p2 = cdr(p1); 1133 delete_object(instance, p1); 1134 return p2; 1135} 1136 1137/* 1138 * Syntax: (+ expr...) 1139 */ 1140static struct alisp_object * F_add(struct alisp_instance *instance, struct alisp_object * args) 1141{ 1142 struct alisp_object * p = args, * p1, * n; 1143 long v = 0; 1144 double f = 0; 1145 int type = ALISP_OBJ_INTEGER; 1146 1147 p1 = eval(instance, car(p)); 1148 for (;;) { 1149 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { 1150 if (type == ALISP_OBJ_FLOAT) 1151 f += p1->value.i; 1152 else 1153 v += p1->value.i; 1154 } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { 1155 f += p1->value.f + v; 1156 v = 0; 1157 type = ALISP_OBJ_FLOAT; 1158 } else { 1159 lisp_warn(instance, "sum with a non integer or float operand"); 1160 } 1161 delete_tree(instance, p1); 1162 p = cdr(n = p); 1163 delete_object(instance, n); 1164 if (p == &alsa_lisp_nil) 1165 break; 1166 p1 = eval(instance, car(p)); 1167 } 1168 if (type == ALISP_OBJ_INTEGER) { 1169 return new_integer(instance, v); 1170 } else { 1171 return new_float(instance, f); 1172 } 1173} 1174 1175/* 1176 * Syntax: (concat expr...) 1177 */ 1178static struct alisp_object * F_concat(struct alisp_instance *instance, struct alisp_object * args) 1179{ 1180 struct alisp_object * p = args, * p1, * n; 1181 char *str = NULL, *str1; 1182 1183 p1 = eval(instance, car(p)); 1184 for (;;) { 1185 if (alisp_compare_type(p1, ALISP_OBJ_STRING)) { 1186 str1 = realloc(str, (str ? strlen(str) : 0) + strlen(p1->value.s) + 1); 1187 if (str1 == NULL) { 1188 nomem(); 1189 free(str); 1190 return NULL; 1191 } 1192 if (str == NULL) 1193 strcpy(str1, p1->value.s); 1194 else 1195 strcat(str1, p1->value.s); 1196 str = str1; 1197 } else { 1198 lisp_warn(instance, "concat with a non string or identifier operand"); 1199 } 1200 delete_tree(instance, p1); 1201 p = cdr(n = p); 1202 delete_object(instance, n); 1203 if (p == &alsa_lisp_nil) 1204 break; 1205 p1 = eval(instance, car(p)); 1206 } 1207 if (str) { 1208 p = new_string(instance, str); 1209 free(str); 1210 } else { 1211 p = &alsa_lisp_nil; 1212 } 1213 return p; 1214} 1215 1216/* 1217 * Syntax: (- expr...) 1218 */ 1219static struct alisp_object * F_sub(struct alisp_instance *instance, struct alisp_object * args) 1220{ 1221 struct alisp_object * p = args, * p1, * n; 1222 long v = 0; 1223 double f = 0; 1224 int type = ALISP_OBJ_INTEGER; 1225 1226 do { 1227 p1 = eval(instance, car(p)); 1228 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { 1229 if (p == args && cdr(p) != &alsa_lisp_nil) { 1230 v = p1->value.i; 1231 } else { 1232 if (type == ALISP_OBJ_FLOAT) 1233 f -= p1->value.i; 1234 else 1235 v -= p1->value.i; 1236 } 1237 } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { 1238 if (type == ALISP_OBJ_INTEGER) { 1239 f = v; 1240 type = ALISP_OBJ_FLOAT; 1241 } 1242 if (p == args && cdr(p) != &alsa_lisp_nil) 1243 f = p1->value.f; 1244 else { 1245 f -= p1->value.f; 1246 } 1247 } else 1248 lisp_warn(instance, "difference with a non integer or float operand"); 1249 delete_tree(instance, p1); 1250 n = cdr(p); 1251 delete_object(instance, p); 1252 p = n; 1253 } while (p != &alsa_lisp_nil); 1254 1255 if (type == ALISP_OBJ_INTEGER) { 1256 return new_integer(instance, v); 1257 } else { 1258 return new_float(instance, f); 1259 } 1260} 1261 1262/* 1263 * Syntax: (* expr...) 1264 */ 1265static struct alisp_object * F_mul(struct alisp_instance *instance, struct alisp_object * args) 1266{ 1267 struct alisp_object * p = args, * p1, * n; 1268 long v = 1; 1269 double f = 1; 1270 int type = ALISP_OBJ_INTEGER; 1271 1272 do { 1273 p1 = eval(instance, car(p)); 1274 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { 1275 if (type == ALISP_OBJ_FLOAT) 1276 f *= p1->value.i; 1277 else 1278 v *= p1->value.i; 1279 } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { 1280 f *= p1->value.f * v; v = 1; 1281 type = ALISP_OBJ_FLOAT; 1282 } else { 1283 lisp_warn(instance, "product with a non integer or float operand"); 1284 } 1285 delete_tree(instance, p1); 1286 n = cdr(p); 1287 delete_object(instance, p); 1288 p = n; 1289 } while (p != &alsa_lisp_nil); 1290 1291 if (type == ALISP_OBJ_INTEGER) { 1292 return new_integer(instance, v); 1293 } else { 1294 return new_float(instance, f); 1295 } 1296} 1297 1298/* 1299 * Syntax: (/ expr...) 1300 */ 1301static struct alisp_object * F_div(struct alisp_instance *instance, struct alisp_object * args) 1302{ 1303 struct alisp_object * p = args, * p1, * n; 1304 long v = 0; 1305 double f = 0; 1306 int type = ALISP_OBJ_INTEGER; 1307 1308 do { 1309 p1 = eval(instance, car(p)); 1310 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { 1311 if (p == args && cdr(p) != &alsa_lisp_nil) { 1312 v = p1->value.i; 1313 } else { 1314 if (p1->value.i == 0) { 1315 lisp_warn(instance, "division by zero"); 1316 v = 0; 1317 f = 0; 1318 break; 1319 } else { 1320 if (type == ALISP_OBJ_FLOAT) 1321 f /= p1->value.i; 1322 else 1323 v /= p1->value.i; 1324 } 1325 } 1326 } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { 1327 if (type == ALISP_OBJ_INTEGER) { 1328 f = v; 1329 type = ALISP_OBJ_FLOAT; 1330 } 1331 if (p == args && cdr(p) != &alsa_lisp_nil) { 1332 f = p1->value.f; 1333 } else { 1334 if (p1->value.f == 0) { 1335 lisp_warn(instance, "division by zero"); 1336 f = 0; 1337 break; 1338 } else { 1339 f /= p1->value.i; 1340 } 1341 } 1342 } else 1343 lisp_warn(instance, "quotient with a non integer or float operand"); 1344 delete_tree(instance, p1); 1345 n = cdr(p); 1346 delete_object(instance, p); 1347 p = n; 1348 } while (p != &alsa_lisp_nil); 1349 1350 if (type == ALISP_OBJ_INTEGER) { 1351 return new_integer(instance, v); 1352 } else { 1353 return new_float(instance, f); 1354 } 1355} 1356 1357/* 1358 * Syntax: (% expr1 expr2) 1359 */ 1360static struct alisp_object * F_mod(struct alisp_instance *instance, struct alisp_object * args) 1361{ 1362 struct alisp_object * p1, * p2, * p3; 1363 1364 p1 = eval(instance, car(args)); 1365 p2 = eval(instance, car(cdr(args))); 1366 delete_tree(instance, cdr(cdr(args))); 1367 delete_object(instance, cdr(args)); 1368 delete_object(instance, args); 1369 1370 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1371 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1372 if (p2->value.i == 0) { 1373 lisp_warn(instance, "module by zero"); 1374 p3 = new_integer(instance, 0); 1375 } else { 1376 p3 = new_integer(instance, p1->value.i % p2->value.i); 1377 } 1378 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1379 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1380 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1381 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1382 double f1, f2; 1383 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1384 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1385 f1 = fmod(f1, f2); 1386 if (f1 == EDOM) { 1387 lisp_warn(instance, "module by zero"); 1388 p3 = new_float(instance, 0); 1389 } else { 1390 p3 = new_float(instance, f1); 1391 } 1392 } else { 1393 lisp_warn(instance, "module with a non integer or float operand"); 1394 delete_tree(instance, p1); 1395 delete_tree(instance, p2); 1396 return &alsa_lisp_nil; 1397 } 1398 1399 delete_tree(instance, p1); 1400 delete_tree(instance, p2); 1401 return p3; 1402} 1403 1404/* 1405 * Syntax: (< expr1 expr2) 1406 */ 1407static struct alisp_object * F_lt(struct alisp_instance *instance, struct alisp_object * args) 1408{ 1409 struct alisp_object * p1, * p2; 1410 1411 p1 = eval(instance, car(args)); 1412 p2 = eval(instance, car(cdr(args))); 1413 delete_tree(instance, cdr(cdr(args))); 1414 delete_object(instance, cdr(args)); 1415 delete_object(instance, args); 1416 1417 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1418 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1419 if (p1->value.i < p2->value.i) { 1420 __true: 1421 delete_tree(instance, p1); 1422 delete_tree(instance, p2); 1423 return &alsa_lisp_t; 1424 } 1425 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1426 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1427 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1428 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1429 double f1, f2; 1430 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1431 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1432 if (f1 < f2) 1433 goto __true; 1434 } else { 1435 lisp_warn(instance, "comparison with a non integer or float operand"); 1436 } 1437 1438 delete_tree(instance, p1); 1439 delete_tree(instance, p2); 1440 return &alsa_lisp_nil; 1441} 1442 1443/* 1444 * Syntax: (> expr1 expr2) 1445 */ 1446static struct alisp_object * F_gt(struct alisp_instance *instance, struct alisp_object * args) 1447{ 1448 struct alisp_object * p1, * p2; 1449 1450 p1 = eval(instance, car(args)); 1451 p2 = eval(instance, car(cdr(args))); 1452 delete_tree(instance, cdr(cdr(args))); 1453 delete_object(instance, cdr(args)); 1454 delete_object(instance, args); 1455 1456 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1457 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1458 if (p1->value.i > p2->value.i) { 1459 __true: 1460 delete_tree(instance, p1); 1461 delete_tree(instance, p2); 1462 return &alsa_lisp_t; 1463 } 1464 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1465 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1466 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1467 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1468 double f1, f2; 1469 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1470 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1471 if (f1 > f2) 1472 goto __true; 1473 } else { 1474 lisp_warn(instance, "comparison with a non integer or float operand"); 1475 } 1476 1477 delete_tree(instance, p1); 1478 delete_tree(instance, p2); 1479 return &alsa_lisp_nil; 1480} 1481 1482/* 1483 * Syntax: (<= expr1 expr2) 1484 */ 1485static struct alisp_object * F_le(struct alisp_instance *instance, struct alisp_object * args) 1486{ 1487 struct alisp_object * p1, * p2; 1488 1489 p1 = eval(instance, car(args)); 1490 p2 = eval(instance, car(cdr(args))); 1491 delete_tree(instance, cdr(cdr(args))); 1492 delete_object(instance, cdr(args)); 1493 delete_object(instance, args); 1494 1495 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1496 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1497 if (p1->value.i <= p2->value.i) { 1498 __true: 1499 delete_tree(instance, p1); 1500 delete_tree(instance, p2); 1501 return &alsa_lisp_t; 1502 } 1503 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1504 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1505 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1506 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1507 double f1, f2; 1508 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1509 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1510 if (f1 <= f2) 1511 goto __true; 1512 } else { 1513 lisp_warn(instance, "comparison with a non integer or float operand"); 1514 } 1515 1516 delete_tree(instance, p1); 1517 delete_tree(instance, p2); 1518 return &alsa_lisp_nil; 1519} 1520 1521/* 1522 * Syntax: (>= expr1 expr2) 1523 */ 1524static struct alisp_object * F_ge(struct alisp_instance *instance, struct alisp_object * args) 1525{ 1526 struct alisp_object * p1, * p2; 1527 1528 p1 = eval(instance, car(args)); 1529 p2 = eval(instance, car(cdr(args))); 1530 delete_tree(instance, cdr(cdr(args))); 1531 delete_object(instance, cdr(args)); 1532 delete_object(instance, args); 1533 1534 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1535 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1536 if (p1->value.i >= p2->value.i) { 1537 __true: 1538 delete_tree(instance, p1); 1539 delete_tree(instance, p2); 1540 return &alsa_lisp_t; 1541 } 1542 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1543 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1544 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1545 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1546 double f1, f2; 1547 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1548 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1549 if (f1 >= f2) 1550 goto __true; 1551 } else { 1552 lisp_warn(instance, "comparison with a non integer or float operand"); 1553 } 1554 1555 delete_tree(instance, p1); 1556 delete_tree(instance, p2); 1557 return &alsa_lisp_nil; 1558} 1559 1560/* 1561 * Syntax: (= expr1 expr2) 1562 */ 1563static struct alisp_object * F_numeq(struct alisp_instance *instance, struct alisp_object * args) 1564{ 1565 struct alisp_object * p1, * p2; 1566 1567 p1 = eval(instance, car(args)); 1568 p2 = eval(instance, car(cdr(args))); 1569 delete_tree(instance, cdr(cdr(args))); 1570 delete_object(instance, cdr(args)); 1571 delete_object(instance, args); 1572 1573 if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && 1574 alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { 1575 if (p1->value.i == p2->value.i) { 1576 __true: 1577 delete_tree(instance, p1); 1578 delete_tree(instance, p2); 1579 return &alsa_lisp_t; 1580 } 1581 } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || 1582 alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && 1583 (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || 1584 alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { 1585 double f1, f2; 1586 f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; 1587 f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; 1588 if (f1 == f2) 1589 goto __true; 1590 } else { 1591 lisp_warn(instance, "comparison with a non integer or float operand"); 1592 } 1593 1594 delete_tree(instance, p1); 1595 delete_tree(instance, p2); 1596 return &alsa_lisp_nil; 1597} 1598 1599/* 1600 * Syntax: (!= expr1 expr2) 1601 */ 1602static struct alisp_object * F_numneq(struct alisp_instance *instance, struct alisp_object * args) 1603{ 1604 struct alisp_object * p; 1605 1606 p = F_numeq(instance, args); 1607 if (p == &alsa_lisp_nil) 1608 return &alsa_lisp_t; 1609 return &alsa_lisp_nil; 1610} 1611 1612/* 1613 * Syntax: (exfun name) 1614 * Test, if a function exists 1615 */ 1616static struct alisp_object * F_exfun(struct alisp_instance *instance, struct alisp_object * args) 1617{ 1618 struct alisp_object * p1, * p2; 1619 1620 p1 = eval(instance, car(args)); 1621 delete_tree(instance, cdr(args)); 1622 delete_object(instance, args); 1623 p2 = get_object(instance, p1); 1624 if (p2 == &alsa_lisp_nil) { 1625 delete_tree(instance, p1); 1626 return &alsa_lisp_nil; 1627 } 1628 p2 = car(p2); 1629 if (alisp_compare_type(p2, ALISP_OBJ_IDENTIFIER) && 1630 !strcmp(p2->value.s, "lambda")) { 1631 delete_tree(instance, p1); 1632 return &alsa_lisp_t; 1633 } 1634 delete_tree(instance, p1); 1635 return &alsa_lisp_nil; 1636} 1637 1638static void princ_string(snd_output_t *out, char *s) 1639{ 1640 char *p; 1641 1642 snd_output_putc(out, '"'); 1643 for (p = s; *p != '\0'; ++p) 1644 switch (*p) { 1645 case '\a': snd_output_putc(out, '\\'); snd_output_putc(out, 'a'); break; 1646 case '\b': snd_output_putc(out, '\\'); snd_output_putc(out, 'b'); break; 1647 case '\f': snd_output_putc(out, '\\'); snd_output_putc(out, 'f'); break; 1648 case '\n': snd_output_putc(out, '\\'); snd_output_putc(out, 'n'); break; 1649 case '\r': snd_output_putc(out, '\\'); snd_output_putc(out, 'r'); break; 1650 case '\t': snd_output_putc(out, '\\'); snd_output_putc(out, 't'); break; 1651 case '\v': snd_output_putc(out, '\\'); snd_output_putc(out, 'v'); break; 1652 case '"': snd_output_putc(out, '\\'); snd_output_putc(out, '"'); break; 1653 default: snd_output_putc(out, *p); 1654 } 1655 snd_output_putc(out, '"'); 1656} 1657 1658static void princ_cons(snd_output_t *out, struct alisp_object * p) 1659{ 1660 do { 1661 princ_object(out, p->value.c.car); 1662 p = p->value.c.cdr; 1663 if (p != &alsa_lisp_nil) { 1664 snd_output_putc(out, ' '); 1665 if (!alisp_compare_type(p, ALISP_OBJ_CONS)) { 1666 snd_output_printf(out, ". "); 1667 princ_object(out, p); 1668 } 1669 } 1670 } while (p != &alsa_lisp_nil && alisp_compare_type(p, ALISP_OBJ_CONS)); 1671} 1672 1673static void princ_object(snd_output_t *out, struct alisp_object * p) 1674{ 1675 switch (alisp_get_type(p)) { 1676 case ALISP_OBJ_NIL: 1677 snd_output_printf(out, "nil"); 1678 break; 1679 case ALISP_OBJ_T: 1680 snd_output_putc(out, 't'); 1681 break; 1682 case ALISP_OBJ_IDENTIFIER: 1683 snd_output_printf(out, "%s", p->value.s); 1684 break; 1685 case ALISP_OBJ_STRING: 1686 princ_string(out, p->value.s); 1687 break; 1688 case ALISP_OBJ_INTEGER: 1689 snd_output_printf(out, "%ld", p->value.i); 1690 break; 1691 case ALISP_OBJ_FLOAT: 1692 snd_output_printf(out, "%f", p->value.f); 1693 break; 1694 case ALISP_OBJ_POINTER: 1695 snd_output_printf(out, "<%p>", p->value.ptr); 1696 break; 1697 case ALISP_OBJ_CONS: 1698 snd_output_putc(out, '('); 1699 princ_cons(out, p); 1700 snd_output_putc(out, ')'); 1701 } 1702} 1703 1704/* 1705 * Syntax: (princ expr...) 1706 */ 1707static struct alisp_object * F_princ(struct alisp_instance *instance, struct alisp_object * args) 1708{ 1709 struct alisp_object * p = args, * p1 = NULL, * n; 1710 1711 do { 1712 if (p1) 1713 delete_tree(instance, p1); 1714 p1 = eval(instance, car(p)); 1715 if (alisp_compare_type(p1, ALISP_OBJ_STRING)) 1716 snd_output_printf(instance->out, "%s", p1->value.s); 1717 else 1718 princ_object(instance->out, p1); 1719 n = cdr(p); 1720 delete_object(instance, p); 1721 p = n; 1722 } while (p != &alsa_lisp_nil); 1723 1724 return p1; 1725} 1726 1727/* 1728 * Syntax: (atom expr) 1729 */ 1730static struct alisp_object * F_atom(struct alisp_instance *instance, struct alisp_object * args) 1731{ 1732 struct alisp_object * p; 1733 1734 p = eval(instance, car(args)); 1735 delete_tree(instance, cdr(args)); 1736 delete_object(instance, args); 1737 if (p == NULL) 1738 return NULL; 1739 1740 switch (alisp_get_type(p)) { 1741 case ALISP_OBJ_T: 1742 case ALISP_OBJ_NIL: 1743 case ALISP_OBJ_INTEGER: 1744 case ALISP_OBJ_FLOAT: 1745 case ALISP_OBJ_STRING: 1746 case ALISP_OBJ_IDENTIFIER: 1747 case ALISP_OBJ_POINTER: 1748 delete_tree(instance, p); 1749 return &alsa_lisp_t; 1750 default: 1751 break; 1752 } 1753 1754 delete_tree(instance, p); 1755 return &alsa_lisp_nil; 1756} 1757 1758/* 1759 * Syntax: (cons expr1 expr2) 1760 */ 1761static struct alisp_object * F_cons(struct alisp_instance *instance, struct alisp_object * args) 1762{ 1763 struct alisp_object * p; 1764 1765 p = new_object(instance, ALISP_OBJ_CONS); 1766 if (p) { 1767 p->value.c.car = eval(instance, car(args)); 1768 p->value.c.cdr = eval(instance, car(cdr(args))); 1769 delete_tree(instance, cdr(cdr(args))); 1770 delete_object(instance, cdr(args)); 1771 delete_object(instance, args); 1772 } else { 1773 delete_tree(instance, args); 1774 } 1775 1776 return p; 1777} 1778 1779/* 1780 * Syntax: (list expr1...) 1781 */ 1782static struct alisp_object * F_list(struct alisp_instance *instance, struct alisp_object * args) 1783{ 1784 struct alisp_object * p = args, * first = NULL, * prev = NULL, * p1; 1785 1786 if (p == &alsa_lisp_nil) 1787 return &alsa_lisp_nil; 1788 1789 do { 1790 p1 = new_object(instance, ALISP_OBJ_CONS); 1791 if (p1 == NULL) { 1792 delete_tree(instance, p); 1793 delete_tree(instance, first); 1794 return NULL; 1795 } 1796 p1->value.c.car = eval(instance, car(p)); 1797 if (p1->value.c.car == NULL) { 1798 delete_tree(instance, first); 1799 delete_tree(instance, cdr(p)); 1800 delete_object(instance, p); 1801 return NULL; 1802 } 1803 if (first == NULL) 1804 first = p1; 1805 if (prev != NULL) 1806 prev->value.c.cdr = p1; 1807 prev = p1; 1808 p = cdr(p1 = p); 1809 delete_object(instance, p1); 1810 } while (p != &alsa_lisp_nil); 1811 1812 return first; 1813} 1814 1815static inline int eq(struct alisp_object * p1, struct alisp_object * p2) 1816{ 1817 return p1 == p2; 1818} 1819 1820static int equal(struct alisp_object * p1, struct alisp_object * p2) 1821{ 1822 int type1, type2; 1823 1824 if (eq(p1, p2)) 1825 return 1; 1826 1827 type1 = alisp_get_type(p1); 1828 type2 = alisp_get_type(p2); 1829 1830 if (type1 == ALISP_OBJ_CONS || type2 == ALISP_OBJ_CONS) 1831 return 0; 1832 1833 if (type1 == type2) { 1834 switch (type1) { 1835 case ALISP_OBJ_STRING: 1836 return !strcmp(p1->value.s, p2->value.s); 1837 case ALISP_OBJ_INTEGER: 1838 return p1->value.i == p2->value.i; 1839 case ALISP_OBJ_FLOAT: 1840 return p1->value.i == p2->value.i; 1841 } 1842 } 1843 1844 return 0; 1845} 1846 1847/* 1848 * Syntax: (eq expr1 expr2) 1849 */ 1850static struct alisp_object * F_eq(struct alisp_instance *instance, struct alisp_object * args) 1851{ 1852 struct alisp_object * p1, * p2; 1853 1854 p1 = eval(instance, car(args)); 1855 p2 = eval(instance, car(cdr(args))); 1856 delete_tree(instance, cdr(cdr(args))); 1857 delete_object(instance, cdr(args)); 1858 delete_object(instance, args); 1859 1860 if (eq(p1, p2)) { 1861 delete_tree(instance, p1); 1862 delete_tree(instance, p2); 1863 return &alsa_lisp_t; 1864 } 1865 delete_tree(instance, p1); 1866 delete_tree(instance, p2); 1867 return &alsa_lisp_nil; 1868} 1869 1870/* 1871 * Syntax: (equal expr1 expr2) 1872 */ 1873static struct alisp_object * F_equal(struct alisp_instance *instance, struct alisp_object * args) 1874{ 1875 struct alisp_object * p1, * p2; 1876 1877 p1 = eval(instance, car(args)); 1878 p2 = eval(instance, car(cdr(args))); 1879 delete_tree(instance, cdr(cdr(args))); 1880 delete_object(instance, cdr(args)); 1881 delete_object(instance, args); 1882 1883 if (equal(p1, p2)) { 1884 delete_tree(instance, p1); 1885 delete_tree(instance, p2); 1886 return &alsa_lisp_t; 1887 } 1888 delete_tree(instance, p1); 1889 delete_tree(instance, p2); 1890 return &alsa_lisp_nil; 1891} 1892 1893/* 1894 * Syntax: (quote expr) 1895 */ 1896static struct alisp_object * F_quote(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * args) 1897{ 1898 struct alisp_object *p = car(args); 1899 1900 delete_tree(instance, cdr(args)); 1901 delete_object(instance, args); 1902 return p; 1903} 1904 1905/* 1906 * Syntax: (and expr...) 1907 */ 1908static struct alisp_object * F_and(struct alisp_instance *instance, struct alisp_object * args) 1909{ 1910 struct alisp_object * p = args, * p1 = NULL, * n; 1911 1912 do { 1913 if (p1) 1914 delete_tree(instance, p1); 1915 p1 = eval(instance, car(p)); 1916 if (p1 == &alsa_lisp_nil) { 1917 delete_tree(instance, p1); 1918 delete_tree(instance, cdr(p)); 1919 delete_object(instance, p); 1920 return &alsa_lisp_nil; 1921 } 1922 p = cdr(n = p); 1923 delete_object(instance, n); 1924 } while (p != &alsa_lisp_nil); 1925 1926 return p1; 1927} 1928 1929/* 1930 * Syntax: (or expr...) 1931 */ 1932static struct alisp_object * F_or(struct alisp_instance *instance, struct alisp_object * args) 1933{ 1934 struct alisp_object * p = args, * p1 = NULL, * n; 1935 1936 do { 1937 if (p1) 1938 delete_tree(instance, p1); 1939 p1 = eval(instance, car(p)); 1940 if (p1 != &alsa_lisp_nil) { 1941 delete_tree(instance, cdr(p)); 1942 delete_object(instance, p); 1943 return p1; 1944 } 1945 p = cdr(n = p); 1946 delete_object(instance, n); 1947 } while (p != &alsa_lisp_nil); 1948 1949 return &alsa_lisp_nil; 1950} 1951 1952/* 1953 * Syntax: (not expr) 1954 * Syntax: (null expr) 1955 */ 1956static struct alisp_object * F_not(struct alisp_instance *instance, struct alisp_object * args) 1957{ 1958 struct alisp_object * p = eval(instance, car(args)); 1959 1960 delete_tree(instance, cdr(args)); 1961 delete_object(instance, args); 1962 if (p != &alsa_lisp_nil) { 1963 delete_tree(instance, p); 1964 return &alsa_lisp_nil; 1965 } 1966 1967 delete_tree(instance, p); 1968 return &alsa_lisp_t; 1969} 1970 1971/* 1972 * Syntax: (cond (expr1 [expr2])...) 1973 */ 1974static struct alisp_object * F_cond(struct alisp_instance *instance, struct alisp_object * args) 1975{ 1976 struct alisp_object * p = args, * p1, * p2, * p3; 1977 1978 do { 1979 p1 = car(p); 1980 if ((p2 = eval(instance, car(p1))) != &alsa_lisp_nil) { 1981 p3 = cdr(p1); 1982 delete_object(instance, p1); 1983 delete_tree(instance, cdr(p)); 1984 delete_object(instance, p); 1985 if (p3 != &alsa_lisp_nil) { 1986 delete_tree(instance, p2); 1987 return F_progn(instance, p3); 1988 } else { 1989 delete_tree(instance, p3); 1990 return p2; 1991 } 1992 } else { 1993 delete_tree(instance, p2); 1994 delete_tree(instance, cdr(p1)); 1995 delete_object(instance, p1); 1996 } 1997 p = cdr(p2 = p); 1998 delete_object(instance, p2); 1999 } while (p != &alsa_lisp_nil); 2000 2001 return &alsa_lisp_nil; 2002} 2003 2004/* 2005 * Syntax: (if expr then-expr else-expr...) 2006 */ 2007static struct alisp_object * F_if(struct alisp_instance *instance, struct alisp_object * args) 2008{ 2009 struct alisp_object * p1, * p2, * p3; 2010 2011 p1 = car(args); 2012 p2 = car(cdr(args)); 2013 p3 = cdr(cdr(args)); 2014 delete_object(instance, cdr(args)); 2015 delete_object(instance, args); 2016 2017 p1 = eval(instance, p1); 2018 if (p1 != &alsa_lisp_nil) { 2019 delete_tree(instance, p1); 2020 delete_tree(instance, p3); 2021 return eval(instance, p2); 2022 } 2023 2024 delete_tree(instance, p1); 2025 delete_tree(instance, p2); 2026 return F_progn(instance, p3); 2027} 2028 2029/* 2030 * Syntax: (when expr then-expr...) 2031 */ 2032static struct alisp_object * F_when(struct alisp_instance *instance, struct alisp_object * args) 2033{ 2034 struct alisp_object * p1, * p2; 2035 2036 p1 = car(args); 2037 p2 = cdr(args); 2038 delete_object(instance, args); 2039 if ((p1 = eval(instance, p1)) != &alsa_lisp_nil) { 2040 delete_tree(instance, p1); 2041 return F_progn(instance, p2); 2042 } else { 2043 delete_tree(instance, p1); 2044 delete_tree(instance, p2); 2045 } 2046 2047 return &alsa_lisp_nil; 2048} 2049 2050/* 2051 * Syntax: (unless expr else-expr...) 2052 */ 2053static struct alisp_object * F_unless(struct alisp_instance *instance, struct alisp_object * args) 2054{ 2055 struct alisp_object * p1, * p2; 2056 2057 p1 = car(args); 2058 p2 = cdr(args); 2059 delete_object(instance, args); 2060 if ((p1 = eval(instance, p1)) == &alsa_lisp_nil) { 2061 return F_progn(instance, p2); 2062 } else { 2063 delete_tree(instance, p1); 2064 delete_tree(instance, p2); 2065 } 2066 2067 return &alsa_lisp_nil; 2068} 2069 2070/* 2071 * Syntax: (while expr exprs...) 2072 */ 2073static struct alisp_object * F_while(struct alisp_instance *instance, struct alisp_object * args) 2074{ 2075 struct alisp_object * p1, * p2, * p3; 2076 2077 p1 = car(args); 2078 p2 = cdr(args); 2079 2080 delete_object(instance, args); 2081 while (1) { 2082 incref_tree(instance, p1); 2083 if ((p3 = eval(instance, p1)) == &alsa_lisp_nil) 2084 break; 2085 delete_tree(instance, p3); 2086 incref_tree(instance, p2); 2087 delete_tree(instance, F_progn(instance, p2)); 2088 } 2089 2090 delete_tree(instance, p1); 2091 delete_tree(instance, p2); 2092 return &alsa_lisp_nil; 2093} 2094 2095/* 2096 * Syntax: (progn expr...) 2097 */ 2098static struct alisp_object * F_progn(struct alisp_instance *instance, struct alisp_object * args) 2099{ 2100 struct alisp_object * p = args, * p1 = NULL, * n; 2101 2102 do { 2103 if (p1) 2104 delete_tree(instance, p1); 2105 p1 = eval(instance, car(p)); 2106 n = cdr(p); 2107 delete_object(instance, p); 2108 p = n; 2109 } while (p != &alsa_lisp_nil); 2110 2111 return p1; 2112} 2113 2114/* 2115 * Syntax: (prog1 expr...) 2116 */ 2117static struct alisp_object * F_prog1(struct alisp_instance *instance, struct alisp_object * args) 2118{ 2119 struct alisp_object * p = args, * first = NULL, * p1; 2120 2121 do { 2122 p1 = eval(instance, car(p)); 2123 if (first == NULL) 2124 first = p1; 2125 else 2126 delete_tree(instance, p1); 2127 p1 = cdr(p); 2128 delete_object(instance, p); 2129 p = p1; 2130 } while (p != &alsa_lisp_nil); 2131 2132 if (first == NULL) 2133 first = &alsa_lisp_nil; 2134 2135 return first; 2136} 2137 2138/* 2139 * Syntax: (prog2 expr...) 2140 */ 2141static struct alisp_object * F_prog2(struct alisp_instance *instance, struct alisp_object * args) 2142{ 2143 struct alisp_object * p = args, * second = NULL, * p1; 2144 int i = 0; 2145 2146 do { 2147 ++i; 2148 p1 = eval(instance, car(p)); 2149 if (i == 2) 2150 second = p1; 2151 else 2152 delete_tree(instance, p1); 2153 p1 = cdr(p); 2154 delete_object(instance, p); 2155 p = p1; 2156 } while (p != &alsa_lisp_nil); 2157 2158 if (second == NULL) 2159 second = &alsa_lisp_nil; 2160 2161 return second; 2162} 2163 2164/* 2165 * Syntax: (set name value) 2166 */ 2167static struct alisp_object * F_set(struct alisp_instance *instance, struct alisp_object * args) 2168{ 2169 struct alisp_object * p1 = eval(instance, car(args)), 2170 * p2 = eval(instance, car(cdr(args))); 2171 2172 delete_tree(instance, cdr(cdr(args))); 2173 delete_object(instance, cdr(args)); 2174 delete_object(instance, args); 2175 if (!check_set_object(instance, p1)) { 2176 delete_tree(instance, p2); 2177 p2 = &alsa_lisp_nil; 2178 } else { 2179 if (set_object(instance, p1, p2) == NULL) { 2180 delete_tree(instance, p1); 2181 delete_tree(instance, p2); 2182 return NULL; 2183 } 2184 } 2185 delete_tree(instance, p1); 2186 return incref_tree(instance, p2); 2187} 2188 2189/* 2190 * Syntax: (unset name) 2191 */ 2192static struct alisp_object * F_unset(struct alisp_instance *instance, struct alisp_object * args) 2193{ 2194 struct alisp_object * p1 = eval(instance, car(args)); 2195 2196 delete_tree(instance, unset_object(instance, p1)); 2197 delete_tree(instance, cdr(args)); 2198 delete_object(instance, args); 2199 return p1; 2200} 2201 2202/* 2203 * Syntax: (setq name value...) 2204 * Syntax: (setf name value...) 2205 * `name' is not evalled 2206 */ 2207static struct alisp_object * F_setq(struct alisp_instance *instance, struct alisp_object * args) 2208{ 2209 struct alisp_object * p = args, * p1, * p2 = NULL, *n; 2210 2211 do { 2212 p1 = car(p); 2213 p2 = eval(instance, car(cdr(p))); 2214 n = cdr(cdr(p)); 2215 delete_object(instance, cdr(p)); 2216 delete_object(instance, p); 2217 if (!check_set_object(instance, p1)) { 2218 delete_tree(instance, p2); 2219 p2 = &alsa_lisp_nil; 2220 } else { 2221 if (set_object(instance, p1, p2) == NULL) { 2222 delete_tree(instance, p1); 2223 delete_tree(instance, p2); 2224 return NULL; 2225 } 2226 } 2227 delete_tree(instance, p1); 2228 p = n; 2229 } while (p != &alsa_lisp_nil); 2230 2231 return incref_tree(instance, p2); 2232} 2233 2234/* 2235 * Syntax: (unsetq name...) 2236 * Syntax: (unsetf name...) 2237 * `name' is not evalled 2238 */ 2239static struct alisp_object * F_unsetq(struct alisp_instance *instance, struct alisp_object * args) 2240{ 2241 struct alisp_object * p = args, * p1 = NULL, * n; 2242 2243 do { 2244 if (p1) 2245 delete_tree(instance, p1); 2246 p1 = unset_object(instance, car(p)); 2247 delete_tree(instance, car(p)); 2248 p = cdr(n = p); 2249 delete_object(instance, n); 2250 } while (p != &alsa_lisp_nil); 2251 2252 return p1; 2253} 2254 2255/* 2256 * Syntax: (defun name arglist expr...) 2257 * `name' is not evalled 2258 * `arglist' is not evalled 2259 */ 2260static struct alisp_object * F_defun(struct alisp_instance *instance, struct alisp_object * args) 2261{ 2262 struct alisp_object * p1 = car(args), 2263 * p2 = car(cdr(args)), 2264 * p3 = cdr(cdr(args)); 2265 struct alisp_object * lexpr; 2266 2267 lexpr = new_object(instance, ALISP_OBJ_CONS); 2268 if (lexpr) { 2269 lexpr->value.c.car = new_identifier(instance, "lambda"); 2270 if (lexpr->value.c.car == NULL) { 2271 delete_object(instance, lexpr); 2272 delete_tree(instance, args); 2273 return NULL; 2274 } 2275 if ((lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS)) == NULL) { 2276 delete_object(instance, lexpr->value.c.car); 2277 delete_object(instance, lexpr); 2278 delete_tree(instance, args); 2279 return NULL; 2280 } 2281 lexpr->value.c.cdr->value.c.car = p2; 2282 lexpr->value.c.cdr->value.c.cdr = p3; 2283 delete_object(instance, cdr(args)); 2284 delete_object(instance, args); 2285 if (set_object(instance, p1, lexpr) == NULL) { 2286 delete_tree(instance, p1); 2287 delete_tree(instance, lexpr); 2288 return NULL; 2289 } 2290 delete_tree(instance, p1); 2291 } else { 2292 delete_tree(instance, args); 2293 } 2294 return &alsa_lisp_nil; 2295} 2296 2297static struct alisp_object * eval_func(struct alisp_instance *instance, struct alisp_object * p, struct alisp_object * args) 2298{ 2299 struct alisp_object * p1, * p2, * p3, * p4; 2300 struct alisp_object ** eval_objs, ** save_objs; 2301 int i; 2302 2303 p1 = car(p); 2304 if (alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER) && 2305 !strcmp(p1->value.s, "lambda")) { 2306 p2 = car(cdr(p)); 2307 p3 = args; 2308 2309 if ((i = count_list(p2)) != count_list(p3)) { 2310 lisp_warn(instance, "wrong number of parameters"); 2311 goto _delete; 2312 } 2313 2314 eval_objs = malloc(2 * i * sizeof(struct alisp_object *)); 2315 if (eval_objs == NULL) { 2316 nomem(); 2317 goto _delete; 2318 } 2319 save_objs = eval_objs + i; 2320 2321 /* 2322 * Save the new variable values. 2323 */ 2324 i = 0; 2325 while (p3 != &alsa_lisp_nil) { 2326 eval_objs[i++] = eval(instance, car(p3)); 2327 p3 = cdr(p4 = p3); 2328 delete_object(instance, p4); 2329 } 2330 2331 /* 2332 * Save the old variable values and set the new ones. 2333 */ 2334 i = 0; 2335 while (p2 != &alsa_lisp_nil) { 2336 p3 = car(p2); 2337 save_objs[i] = replace_object(instance, p3, eval_objs[i]); 2338 if (save_objs[i] == NULL && 2339 set_object_direct(instance, p3, eval_objs[i]) == NULL) { 2340 p4 = NULL; 2341 goto _end; 2342 } 2343 p2 = cdr(p2); 2344 ++i; 2345 } 2346 2347 p4 = F_progn(instance, cdr(incref_tree(instance, p3 = cdr(p)))); 2348 2349 /* 2350 * Restore the old variable values. 2351 */ 2352 p2 = car(p3); 2353 delete_object(instance, p3); 2354 i = 0; 2355 while (p2 != &alsa_lisp_nil) { 2356 p3 = car(p2); 2357 if (save_objs[i] == NULL) { 2358 p3 = unset_object(instance, p3); 2359 } else { 2360 p3 = replace_object(instance, p3, save_objs[i]); 2361 } 2362 i++; 2363 delete_tree(instance, p3); 2364 delete_tree(instance, car(p2)); 2365 p2 = cdr(p3 = p2); 2366 delete_object(instance, p3); 2367 } 2368 2369 _end: 2370 free(eval_objs); 2371 2372 return p4; 2373 } else { 2374 _delete: 2375 delete_tree(instance, args); 2376 } 2377 return &alsa_lisp_nil; 2378} 2379 2380struct alisp_object * F_gc(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * args ATTRIBUTE_UNUSED) 2381{ 2382 /* improved: no more traditional gc */ 2383 return &alsa_lisp_t; 2384} 2385 2386/* 2387 * Syntax: (path what) 2388 * what is string ('data') 2389 */ 2390struct alisp_object * F_path(struct alisp_instance *instance, struct alisp_object * args) 2391{ 2392 struct alisp_object * p1; 2393 2394 p1 = eval(instance, car(args)); 2395 delete_tree(instance, cdr(args)); 2396 delete_object(instance, args); 2397 if (!alisp_compare_type(p1, ALISP_OBJ_STRING)) { 2398 delete_tree(instance, p1); 2399 return &alsa_lisp_nil; 2400 } 2401 if (!strcmp(p1->value.s, "data")) { 2402 delete_tree(instance, p1); 2403 return new_string(instance, snd_config_topdir()); 2404 } 2405 delete_tree(instance, p1); 2406 return &alsa_lisp_nil; 2407} 2408 2409/* 2410 * Syntax: (include filename...) 2411 */ 2412struct alisp_object * F_include(struct alisp_instance *instance, struct alisp_object * args) 2413{ 2414 struct alisp_object * p = args, * p1; 2415 int res = -ENOENT; 2416 2417 do { 2418 p1 = eval(instance, car(p)); 2419 if (alisp_compare_type(p1, ALISP_OBJ_STRING)) 2420 res = alisp_include_file(instance, p1->value.s); 2421 delete_tree(instance, p1); 2422 p = cdr(p1 = p); 2423 delete_object(instance, p1); 2424 } while (p != &alsa_lisp_nil); 2425 2426 return new_integer(instance, res); 2427} 2428 2429/* 2430 * Syntax: (string-to-integer value) 2431 * 'value' can be integer or float type 2432 */ 2433struct alisp_object * F_string_to_integer(struct alisp_instance *instance, struct alisp_object * args) 2434{ 2435 struct alisp_object * p = eval(instance, car(args)), * p1; 2436 2437 delete_tree(instance, cdr(args)); 2438 delete_object(instance, args); 2439 if (alisp_compare_type(p, ALISP_OBJ_INTEGER)) 2440 return p; 2441 if (alisp_compare_type(p, ALISP_OBJ_FLOAT)) { 2442 p1 = new_integer(instance, floor(p->value.f)); 2443 } else { 2444 lisp_warn(instance, "expected an integer or float for integer conversion"); 2445 p1 = &alsa_lisp_nil; 2446 } 2447 delete_tree(instance, p); 2448 return p1; 2449} 2450 2451/* 2452 * Syntax: (string-to-float value) 2453 * 'value' can be integer or float type 2454 */ 2455struct alisp_object * F_string_to_float(struct alisp_instance *instance, struct alisp_object * args) 2456{ 2457 struct alisp_object * p = eval(instance, car(args)), * p1; 2458 2459 delete_tree(instance, cdr(args)); 2460 delete_object(instance, args); 2461 if (alisp_compare_type(p, ALISP_OBJ_FLOAT)) 2462 return p; 2463 if (alisp_compare_type(p, ALISP_OBJ_INTEGER)) { 2464 p1 = new_float(instance, p->value.i); 2465 } else { 2466 lisp_warn(instance, "expected an integer or float for integer conversion"); 2467 p1 = &alsa_lisp_nil; 2468 } 2469 delete_tree(instance, p); 2470 return p1; 2471} 2472 2473static int append_to_string(char **s, int *len, char *from, int size) 2474{ 2475 if (*len == 0) { 2476 *s = malloc(*len = size + 1); 2477 if (*s == NULL) { 2478 nomem(); 2479 return -ENOMEM; 2480 } 2481 memcpy(*s, from, size); 2482 } else { 2483 *len += size; 2484 *s = realloc(*s, *len); 2485 if (*s == NULL) { 2486 nomem(); 2487 return -ENOMEM; 2488 } 2489 memcpy(*s + strlen(*s), from, size); 2490 } 2491 (*s)[*len - 1] = '\0'; 2492 return 0; 2493} 2494 2495static int format_parse_char(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) 2496{ 2497 char b; 2498 2499 if (!alisp_compare_type(p, ALISP_OBJ_INTEGER)) { 2500 lisp_warn(instance, "format: expected integer\n"); 2501 return 0; 2502 } 2503 b = p->value.i; 2504 return append_to_string(s, len, &b, 1); 2505} 2506 2507static int format_parse_integer(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) 2508{ 2509 int res; 2510 char *s1; 2511 2512 if (!alisp_compare_type(p, ALISP_OBJ_INTEGER) && 2513 !alisp_compare_type(p, ALISP_OBJ_FLOAT)) { 2514 lisp_warn(instance, "format: expected integer or float\n"); 2515 return 0; 2516 } 2517 s1 = malloc(64); 2518 if (s1 == NULL) { 2519 nomem(); 2520 return -ENOMEM; 2521 } 2522 sprintf(s1, "%li", alisp_compare_type(p, ALISP_OBJ_FLOAT) ? (long)floor(p->value.f) : p->value.i); 2523 res = append_to_string(s, len, s1, strlen(s1)); 2524 free(s1); 2525 return res; 2526} 2527 2528static int format_parse_float(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) 2529{ 2530 int res; 2531 char *s1; 2532 2533 if (!alisp_compare_type(p, ALISP_OBJ_INTEGER) && 2534 !alisp_compare_type(p, ALISP_OBJ_FLOAT)) { 2535 lisp_warn(instance, "format: expected integer or float\n"); 2536 return 0; 2537 } 2538 s1 = malloc(64); 2539 if (s1 == NULL) { 2540 nomem(); 2541 return -ENOMEM; 2542 } 2543 sprintf(s1, "%f", alisp_compare_type(p, ALISP_OBJ_FLOAT) ? p->value.f : (double)p->value.i); 2544 res = append_to_string(s, len, s1, strlen(s1)); 2545 free(s1); 2546 return res; 2547} 2548 2549static int format_parse_string(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) 2550{ 2551 if (!alisp_compare_type(p, ALISP_OBJ_STRING)) { 2552 lisp_warn(instance, "format: expected string\n"); 2553 return 0; 2554 } 2555 return append_to_string(s, len, p->value.s, strlen(p->value.s)); 2556} 2557 2558/* 2559 * Syntax: (format format value...) 2560 * 'format' is C-like format string 2561 */ 2562struct alisp_object * F_format(struct alisp_instance *instance, struct alisp_object * args) 2563{ 2564 struct alisp_object * p = eval(instance, car(args)), * p1 = cdr(args), * n; 2565 char *s, *s1, *s2; 2566 int len; 2567 2568 delete_object(instance, args); 2569 if (!alisp_compare_type(p, ALISP_OBJ_STRING)) { 2570 delete_tree(instance, p1); 2571 delete_tree(instance, p); 2572 lisp_warn(instance, "format: expected an format string"); 2573 return &alsa_lisp_nil; 2574 } 2575 s = p->value.s; 2576 s1 = NULL; 2577 len = 0; 2578 n = eval(instance, car(p1)); 2579 do { 2580 while (1) { 2581 s2 = s; 2582 while (*s2 && *s2 != '%') 2583 s2++; 2584 if (s2 != s) { 2585 if (append_to_string(&s1, &len, s, s2 - s) < 0) { 2586 __error: 2587 delete_tree(instance, n); 2588 delete_tree(instance, cdr(p1)); 2589 delete_object(instance, p1); 2590 delete_tree(instance, p); 2591 return NULL; 2592 } 2593 } 2594 if (*s2 == '%') 2595 s2++; 2596 switch (*s2) { 2597 case '%': 2598 if (append_to_string(&s1, &len, s2, 1) < 0) 2599 goto __error; 2600 s = s2 + 1; 2601 break; 2602 case 'c': 2603 if (format_parse_char(instance, &s1, &len, n) < 0) 2604 goto __error; 2605 s = s2 + 1; 2606 goto __next; 2607 case 'd': 2608 case 'i': 2609 if (format_parse_integer(instance, &s1, &len, n) < 0) 2610 goto __error; 2611 s = s2 + 1; 2612 goto __next; 2613 case 'f': 2614 if (format_parse_float(instance, &s1, &len, n) < 0) 2615 goto __error; 2616 s = s2 + 1; 2617 goto __next; 2618 case 's': 2619 if (format_parse_string(instance, &s1, &len, n) < 0) 2620 goto __error; 2621 s = s2 + 1; 2622 goto __next; 2623 case '\0': 2624 goto __end; 2625 default: 2626 lisp_warn(instance, "unknown format char '%c'", *s2); 2627 s = s2 + 1; 2628 goto __next; 2629 } 2630 } 2631 __next: 2632 delete_tree(instance, n); 2633 p1 = cdr(n = p1); 2634 delete_object(instance, n); 2635 n = eval(instance, car(p1)); 2636 } while (*s); 2637 __end: 2638 delete_tree(instance, n); 2639 delete_tree(instance, cdr(p1)); 2640 delete_object(instance, p1); 2641 delete_tree(instance, p); 2642 if (len > 0) { 2643 p1 = new_string(instance, s1); 2644 free(s1); 2645 } else { 2646 p1 = &alsa_lisp_nil; 2647 } 2648 return p1; 2649} 2650 2651/* 2652 * Syntax: (compare-strings str1 start1 end1 str2 start2 end2 /opt-case-insensitive) 2653 * 'str1' is first compared string 2654 * 'start1' is first char (0..) 2655 * 'end1' is last char (0..) 2656 * 'str2' is second compared string 2657 * 'start2' is first char (0..) 2658 * 'end2' is last char (0..) 2659 * /opt-case-insensitive true - case insensitive match 2660 */ 2661struct alisp_object * F_compare_strings(struct alisp_instance *instance, struct alisp_object * args) 2662{ 2663 struct alisp_object * p1 = args, * n, * p[7]; 2664 char *s1, *s2; 2665 int start1, end1, start2, end2; 2666 2667 for (start1 = 0; start1 < 7; start1++) { 2668 p[start1] = eval(instance, car(p1)); 2669 p1 = cdr(n = p1); 2670 delete_object(instance, n); 2671 } 2672 delete_tree(instance, p1); 2673 if (alisp_compare_type(p[0], ALISP_OBJ_STRING)) { 2674 lisp_warn(instance, "compare-strings: first argument must be string\n"); 2675 p1 = &alsa_lisp_nil; 2676 goto __err; 2677 } 2678 if (alisp_compare_type(p[1], ALISP_OBJ_INTEGER)) { 2679 lisp_warn(instance, "compare-strings: second argument must be integer\n"); 2680 p1 = &alsa_lisp_nil; 2681 goto __err; 2682 } 2683 if (alisp_compare_type(p[2], ALISP_OBJ_INTEGER)) { 2684 lisp_warn(instance, "compare-strings: third argument must be integer\n"); 2685 p1 = &alsa_lisp_nil; 2686 goto __err; 2687 } 2688 if (alisp_compare_type(p[3], ALISP_OBJ_STRING)) { 2689 lisp_warn(instance, "compare-strings: fifth argument must be string\n"); 2690 p1 = &alsa_lisp_nil; 2691 goto __err; 2692 } 2693 if (!alisp_compare_type(p[4], ALISP_OBJ_NIL) && 2694 !alisp_compare_type(p[4], ALISP_OBJ_INTEGER)) { 2695 lisp_warn(instance, "compare-strings: fourth argument must be integer\n"); 2696 p1 = &alsa_lisp_nil; 2697 goto __err; 2698 } 2699 if (!alisp_compare_type(p[5], ALISP_OBJ_NIL) && 2700 !alisp_compare_type(p[5], ALISP_OBJ_INTEGER)) { 2701 lisp_warn(instance, "compare-strings: sixth argument must be integer\n"); 2702 p1 = &alsa_lisp_nil; 2703 goto __err; 2704 } 2705 s1 = p[0]->value.s; 2706 start1 = p[1]->value.i; 2707 end1 = p[2]->value.i; 2708 s2 = p[3]->value.s; 2709 start2 = alisp_compare_type(p[4], ALISP_OBJ_NIL) ? 0 : p[4]->value.i; 2710 end2 = alisp_compare_type(p[5], ALISP_OBJ_NIL) ? start2 + (end1 - start1) : p[5]->value.i; 2711 if (start1 < 0 || start2 < 0 || end1 < 0 || end2 < 0 || 2712 start1 >= (int)strlen(s1) || start2 >= (int)strlen(s2) || 2713 (end1 - start1) != (end2 - start2)) { 2714 p1 = &alsa_lisp_nil; 2715 goto __err; 2716 } 2717 if (p[6] != &alsa_lisp_nil) { 2718 while (start1 < end1) { 2719 if (s1[start1] == '\0' || 2720 s2[start2] == '\0' || 2721 tolower(s1[start1]) != tolower(s2[start2])) { 2722 p1 = &alsa_lisp_nil; 2723 goto __err; 2724 } 2725 start1++; 2726 start2++; 2727 } 2728 } else { 2729 while (start1 < end1) { 2730 if (s1[start1] == '\0' || 2731 s2[start2] == '\0' || 2732 s1[start1] != s2[start2]) { 2733 p1 = &alsa_lisp_nil; 2734 goto __err; 2735 } 2736 start1++; 2737 start2++; 2738 } 2739 } 2740 p1 = &alsa_lisp_t; 2741 2742 __err: 2743 for (start1 = 0; start1 < 7; start1++) 2744 delete_tree(instance, p[start1]); 2745 return p1; 2746} 2747 2748/* 2749 * Syntax: (assoc key alist) 2750 */ 2751struct alisp_object * F_assoc(struct alisp_instance *instance, struct alisp_object * args) 2752{ 2753 struct alisp_object * p1, * p2, * n; 2754 2755 p1 = eval(instance, car(args)); 2756 p2 = eval(instance, car(cdr(args))); 2757 delete_tree(instance, cdr(cdr(args))); 2758 delete_object(instance, cdr(args)); 2759 delete_object(instance, args); 2760 2761 do { 2762 if (eq(p1, car(car(p2)))) { 2763 n = car(p2); 2764 delete_tree(instance, p1); 2765 delete_tree(instance, cdr(p2)); 2766 delete_object(instance, p2); 2767 return n; 2768 } 2769 delete_tree(instance, car(p2)); 2770 p2 = cdr(n = p2); 2771 delete_object(instance, n); 2772 } while (p2 != &alsa_lisp_nil); 2773 2774 delete_tree(instance, p1); 2775 return &alsa_lisp_nil; 2776} 2777 2778/* 2779 * Syntax: (rassoc value alist) 2780 */ 2781struct alisp_object * F_rassoc(struct alisp_instance *instance, struct alisp_object * args) 2782{ 2783 struct alisp_object * p1, *p2, * n; 2784 2785 p1 = eval(instance, car(args)); 2786 p2 = eval(instance, car(cdr(args))); 2787 delete_tree(instance, cdr(cdr(args))); 2788 delete_object(instance, cdr(args)); 2789 delete_object(instance, args); 2790 2791 do { 2792 if (eq(p1, cdr(car(p2)))) { 2793 n = car(p2); 2794 delete_tree(instance, p1); 2795 delete_tree(instance, cdr(p2)); 2796 delete_object(instance, p2); 2797 return n; 2798 } 2799 delete_tree(instance, car(p2)); 2800 p2 = cdr(n = p2); 2801 delete_object(instance, n); 2802 } while (p2 != &alsa_lisp_nil); 2803 2804 delete_tree(instance, p1); 2805 return &alsa_lisp_nil; 2806} 2807 2808/* 2809 * Syntax: (assq key alist) 2810 */ 2811struct alisp_object * F_assq(struct alisp_instance *instance, struct alisp_object * args) 2812{ 2813 struct alisp_object * p1, * p2, * n; 2814 2815 p1 = eval(instance, car(args)); 2816 p2 = eval(instance, car(cdr(args))); 2817 delete_tree(instance, cdr(cdr(args))); 2818 delete_object(instance, cdr(args)); 2819 delete_object(instance, args); 2820 2821 do { 2822 if (equal(p1, car(car(p2)))) { 2823 n = car(p2); 2824 delete_tree(instance, p1); 2825 delete_tree(instance, cdr(p2)); 2826 delete_object(instance, p2); 2827 return n; 2828 } 2829 delete_tree(instance, car(p2)); 2830 p2 = cdr(n = p2); 2831 delete_object(instance, n); 2832 } while (p2 != &alsa_lisp_nil); 2833 2834 delete_tree(instance, p1); 2835 return &alsa_lisp_nil; 2836} 2837 2838/* 2839 * Syntax: (nth index alist) 2840 */ 2841struct alisp_object * F_nth(struct alisp_instance *instance, struct alisp_object * args) 2842{ 2843 struct alisp_object * p1, * p2, * n; 2844 long idx; 2845 2846 p1 = eval(instance, car(args)); 2847 p2 = eval(instance, car(cdr(args))); 2848 delete_tree(instance, cdr(cdr(args))); 2849 delete_object(instance, cdr(args)); 2850 delete_object(instance, args); 2851 2852 if (!alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { 2853 delete_tree(instance, p1); 2854 delete_tree(instance, p2); 2855 return &alsa_lisp_nil; 2856 } 2857 if (!alisp_compare_type(p2, ALISP_OBJ_CONS)) { 2858 delete_object(instance, p1); 2859 delete_tree(instance, p2); 2860 return &alsa_lisp_nil; 2861 } 2862 idx = p1->value.i; 2863 delete_object(instance, p1); 2864 while (idx-- > 0) { 2865 delete_tree(instance, car(p2)); 2866 p2 = cdr(n = p2); 2867 delete_object(instance, n); 2868 } 2869 n = car(p2); 2870 delete_tree(instance, cdr(p2)); 2871 delete_object(instance, p2); 2872 return n; 2873} 2874 2875/* 2876 * Syntax: (rassq value alist) 2877 */ 2878struct alisp_object * F_rassq(struct alisp_instance *instance, struct alisp_object * args) 2879{ 2880 struct alisp_object * p1, * p2, * n; 2881 2882 p1 = eval(instance, car(args)); 2883 p2 = eval(instance, car(cdr(args))); 2884 delete_tree(instance, cdr(cdr(args))); 2885 delete_object(instance, cdr(args)); 2886 delete_object(instance, args); 2887 2888 do { 2889 if (equal(p1, cdr(car(p2)))) { 2890 n = car(p2); 2891 delete_tree(instance, p1); 2892 delete_tree(instance, cdr(p2)); 2893 delete_object(instance, p2); 2894 return n; 2895 } 2896 delete_tree(instance, car(p2)); 2897 p2 = cdr(n = p2); 2898 delete_object(instance, n); 2899 } while (p2 != &alsa_lisp_nil); 2900 2901 delete_tree(instance, p1); 2902 return &alsa_lisp_nil; 2903} 2904 2905static struct alisp_object * F_dump_memory(struct alisp_instance *instance, struct alisp_object * args) 2906{ 2907 struct alisp_object * p = car(args); 2908 2909 if (p != &alsa_lisp_nil && cdr(args) == &alsa_lisp_nil && 2910 alisp_compare_type(p, ALISP_OBJ_STRING)) { 2911 if (strlen(p->value.s) > 0) { 2912 dump_objects(instance, p->value.s); 2913 delete_tree(instance, args); 2914 return &alsa_lisp_t; 2915 } else 2916 lisp_warn(instance, "expected filename"); 2917 } else 2918 lisp_warn(instance, "wrong number of parameters (expected string)"); 2919 2920 delete_tree(instance, args); 2921 return &alsa_lisp_nil; 2922} 2923 2924static struct alisp_object * F_stat_memory(struct alisp_instance *instance, struct alisp_object * args) 2925{ 2926 snd_output_printf(instance->out, "*** Memory stats\n"); 2927 snd_output_printf(instance->out, " used_objs = %li, free_objs = %li, max_objs = %li, obj_size = %i (total bytes = %li, max bytes = %li)\n", 2928 instance->used_objs, 2929 instance->free_objs, 2930 instance->max_objs, 2931 (int)sizeof(struct alisp_object), 2932 (long)((instance->used_objs + instance->free_objs) * sizeof(struct alisp_object)), 2933 (long)(instance->max_objs * sizeof(struct alisp_object))); 2934 delete_tree(instance, args); 2935 return &alsa_lisp_nil; 2936} 2937 2938static struct alisp_object * F_check_memory(struct alisp_instance *instance, struct alisp_object * args) 2939{ 2940 delete_tree(instance, args); 2941 if (instance->used_objs > 0) { 2942 fprintf(stderr, "!!!alsa lisp - check memory failed!!!\n"); 2943 F_stat_memory(instance, &alsa_lisp_nil); 2944 exit(EXIT_FAILURE); 2945 } 2946 return &alsa_lisp_t; 2947} 2948 2949static struct alisp_object * F_dump_objects(struct alisp_instance *instance, struct alisp_object * args) 2950{ 2951 struct alisp_object * p = car(args); 2952 2953 if (p != &alsa_lisp_nil && cdr(args) == &alsa_lisp_nil && 2954 alisp_compare_type(p, ALISP_OBJ_STRING)) { 2955 if (strlen(p->value.s) > 0) { 2956 dump_obj_lists(instance, p->value.s); 2957 delete_tree(instance, args); 2958 return &alsa_lisp_t; 2959 } else 2960 lisp_warn(instance, "expected filename"); 2961 } else 2962 lisp_warn(instance, "wrong number of parameters (expected string)"); 2963 2964 delete_tree(instance, args); 2965 return &alsa_lisp_nil; 2966} 2967 2968struct intrinsic { 2969 const char *name; 2970 struct alisp_object * (*func)(struct alisp_instance *instance, struct alisp_object * args); 2971}; 2972 2973static const struct intrinsic intrinsics[] = { 2974 { "!=", F_numneq }, 2975 { "%", F_mod }, 2976 { "&check-memory", F_check_memory }, 2977 { "&dump-memory", F_dump_memory }, 2978 { "&dump-objects", F_dump_objects }, 2979 { "&stat-memory", F_stat_memory }, 2980 { "*", F_mul }, 2981 { "+", F_add }, 2982 { "-", F_sub }, 2983 { "/", F_div }, 2984 { "<", F_lt }, 2985 { "<=", F_le }, 2986 { "=", F_numeq }, 2987 { ">", F_gt }, 2988 { ">=", F_ge }, 2989 { "and", F_and }, 2990 { "assoc", F_assoc }, 2991 { "assq", F_assq }, 2992 { "atom", F_atom }, 2993 { "car", F_car }, 2994 { "cdr", F_cdr }, 2995 { "compare-strings", F_compare_strings }, 2996 { "concat", F_concat }, 2997 { "cond", F_cond }, 2998 { "cons", F_cons }, 2999 { "defun", F_defun }, 3000 { "eq", F_eq }, 3001 { "equal", F_equal }, 3002 { "eval", F_eval }, 3003 { "exfun", F_exfun }, 3004 { "format", F_format }, 3005 { "funcall", F_funcall }, 3006 { "garbage-collect", F_gc }, 3007 { "gc", F_gc }, 3008 { "if", F_if }, 3009 { "include", F_include }, 3010 { "list", F_list }, 3011 { "not", F_not }, 3012 { "nth", F_nth }, 3013 { "null", F_not }, 3014 { "or", F_or }, 3015 { "path", F_path }, 3016 { "princ", F_princ }, 3017 { "prog1", F_prog1 }, 3018 { "prog2", F_prog2 }, 3019 { "progn", F_progn }, 3020 { "quote", F_quote }, 3021 { "rassoc", F_rassoc }, 3022 { "rassq", F_rassq }, 3023 { "set", F_set }, 3024 { "setf", F_setq }, 3025 { "setq", F_setq }, 3026 { "string-equal", F_equal }, 3027 { "string-to-float", F_string_to_float }, 3028 { "string-to-integer", F_string_to_integer }, 3029 { "string-to-number", F_string_to_float }, 3030 { "string=", F_equal }, 3031 { "unless", F_unless }, 3032 { "unset", F_unset }, 3033 { "unsetf", F_unsetq }, 3034 { "unsetq", F_unsetq }, 3035 { "when", F_when }, 3036 { "while", F_while }, 3037}; 3038 3039#include "alisp_snd.c" 3040 3041static int compar(const void *p1, const void *p2) 3042{ 3043 return strcmp(((struct intrinsic *)p1)->name, 3044 ((struct intrinsic *)p2)->name); 3045} 3046 3047static inline struct alisp_object * eval_cons1(struct alisp_instance *instance, struct alisp_object * p1, struct alisp_object * p2) 3048{ 3049 struct alisp_object * p3; 3050 struct intrinsic key, *item; 3051 3052 key.name = p1->value.s; 3053 3054 if ((item = bsearch(&key, intrinsics, 3055 sizeof intrinsics / sizeof intrinsics[0], 3056 sizeof intrinsics[0], compar)) != NULL) { 3057 delete_object(instance, p1); 3058 return item->func(instance, p2); 3059 } 3060 3061 if ((item = bsearch(&key, snd_intrinsics, 3062 sizeof snd_intrinsics / sizeof snd_intrinsics[0], 3063 sizeof snd_intrinsics[0], compar)) != NULL) { 3064 delete_object(instance, p1); 3065 return item->func(instance, p2); 3066 } 3067 3068 if ((p3 = get_object(instance, p1)) != &alsa_lisp_nil) { 3069 delete_object(instance, p1); 3070 return eval_func(instance, p3, p2); 3071 } else { 3072 lisp_warn(instance, "function `%s' is undefined", p1->value.s); 3073 delete_object(instance, p1); 3074 delete_tree(instance, p2); 3075 } 3076 3077 return &alsa_lisp_nil; 3078} 3079 3080/* 3081 * Syntax: (funcall function args...) 3082 */ 3083static struct alisp_object * F_funcall(struct alisp_instance *instance, struct alisp_object * args) 3084{ 3085 struct alisp_object * p = eval(instance, car(args)), * p1; 3086 3087 if (!alisp_compare_type(p, ALISP_OBJ_IDENTIFIER) && 3088 !alisp_compare_type(p, ALISP_OBJ_STRING)) { 3089 lisp_warn(instance, "expected an function name"); 3090 delete_tree(instance, p); 3091 delete_tree(instance, cdr(args)); 3092 delete_object(instance, args); 3093 return &alsa_lisp_nil; 3094 } 3095 p1 = cdr(args); 3096 delete_object(instance, args); 3097 return eval_cons1(instance, p, p1); 3098} 3099 3100static inline struct alisp_object * eval_cons(struct alisp_instance *instance, struct alisp_object * p) 3101{ 3102 struct alisp_object * p1 = car(p), * p2; 3103 3104 if (p1 != &alsa_lisp_nil && alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER)) { 3105 if (!strcmp(p1->value.s, "lambda")) 3106 return p; 3107 3108 p2 = cdr(p); 3109 delete_object(instance, p); 3110 return eval_cons1(instance, p1, p2); 3111 } else { 3112 delete_tree(instance, p); 3113 } 3114 3115 return &alsa_lisp_nil; 3116} 3117 3118static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p) 3119{ 3120 switch (alisp_get_type(p)) { 3121 case ALISP_OBJ_IDENTIFIER: { 3122 struct alisp_object *r = incref_tree(instance, get_object(instance, p)); 3123 delete_object(instance, p); 3124 return r; 3125 } 3126 case ALISP_OBJ_INTEGER: 3127 case ALISP_OBJ_FLOAT: 3128 case ALISP_OBJ_STRING: 3129 case ALISP_OBJ_POINTER: 3130 return p; 3131 case ALISP_OBJ_CONS: 3132 return eval_cons(instance, p); 3133 default: 3134 break; 3135 } 3136 3137 return p; 3138} 3139 3140static struct alisp_object * F_eval(struct alisp_instance *instance, struct alisp_object * args) 3141{ 3142 return eval(instance, eval(instance, car(args))); 3143} 3144 3145/* 3146 * main routine 3147 */ 3148 3149static int alisp_include_file(struct alisp_instance *instance, const char *filename) 3150{ 3151 snd_input_t *old_in; 3152 struct alisp_object *p, *p1; 3153 char *name; 3154 int retval = 0, err; 3155 3156 err = snd_user_file(filename, &name); 3157 if (err < 0) 3158 return err; 3159 old_in = instance->in; 3160 err = snd_input_stdio_open(&instance->in, name, "r"); 3161 if (err < 0) { 3162 retval = err; 3163 goto _err; 3164 } 3165 if (instance->verbose) 3166 lisp_verbose(instance, "** include filename '%s'", name); 3167 3168 for (;;) { 3169 if ((p = parse_object(instance, 0)) == NULL) 3170 break; 3171 if (instance->verbose) { 3172 lisp_verbose(instance, "** code"); 3173 princ_object(instance->vout, p); 3174 snd_output_putc(instance->vout, '\n'); 3175 } 3176 p1 = eval(instance, p); 3177 if (p1 == NULL) { 3178 retval = -ENOMEM; 3179 break; 3180 } 3181 if (instance->verbose) { 3182 lisp_verbose(instance, "** result"); 3183 princ_object(instance->vout, p1); 3184 snd_output_putc(instance->vout, '\n'); 3185 } 3186 delete_tree(instance, p1); 3187 if (instance->debug) { 3188 lisp_debug(instance, "** objects after operation"); 3189 print_obj_lists(instance, instance->dout); 3190 } 3191 } 3192 3193 snd_input_close(instance->in); 3194 _err: 3195 free(name); 3196 instance->in = old_in; 3197 return retval; 3198} 3199 3200int alsa_lisp(struct alisp_cfg *cfg, struct alisp_instance **_instance) 3201{ 3202 struct alisp_instance *instance; 3203 struct alisp_object *p, *p1; 3204 int i, j, retval = 0; 3205 3206 instance = (struct alisp_instance *)calloc(1, sizeof(struct alisp_instance)); 3207 if (instance == NULL) { 3208 nomem(); 3209 return -ENOMEM; 3210 } 3211 instance->verbose = cfg->verbose && cfg->vout; 3212 instance->warning = cfg->warning && cfg->wout; 3213 instance->debug = cfg->debug && cfg->dout; 3214 instance->in = cfg->in; 3215 instance->out = cfg->out; 3216 instance->vout = cfg->vout; 3217 instance->eout = cfg->eout; 3218 instance->wout = cfg->wout; 3219 instance->dout = cfg->dout; 3220 INIT_LIST_HEAD(&instance->free_objs_list); 3221 for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { 3222 for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) 3223 INIT_LIST_HEAD(&instance->used_objs_list[i][j]); 3224 INIT_LIST_HEAD(&instance->setobjs_list[i]); 3225 } 3226 3227 init_lex(instance); 3228 3229 for (;;) { 3230 if ((p = parse_object(instance, 0)) == NULL) 3231 break; 3232 if (instance->verbose) { 3233 lisp_verbose(instance, "** code"); 3234 princ_object(instance->vout, p); 3235 snd_output_putc(instance->vout, '\n'); 3236 } 3237 p1 = eval(instance, p); 3238 if (p1 == NULL) { 3239 retval = -ENOMEM; 3240 break; 3241 } 3242 if (instance->verbose) { 3243 lisp_verbose(instance, "** result"); 3244 princ_object(instance->vout, p1); 3245 snd_output_putc(instance->vout, '\n'); 3246 } 3247 delete_tree(instance, p1); 3248 if (instance->debug) { 3249 lisp_debug(instance, "** objects after operation"); 3250 print_obj_lists(instance, instance->dout); 3251 } 3252 } 3253 3254 if (_instance) 3255 *_instance = instance; 3256 else 3257 alsa_lisp_free(instance); 3258 3259 return retval; 3260} 3261 3262void alsa_lisp_free(struct alisp_instance *instance) 3263{ 3264 if (instance == NULL) 3265 return; 3266 done_lex(instance); 3267 free_objects(instance); 3268 free(instance); 3269} 3270 3271struct alisp_cfg *alsa_lisp_default_cfg(snd_input_t *input) 3272{ 3273 snd_output_t *output, *eoutput; 3274 struct alisp_cfg *cfg; 3275 int err; 3276 3277 err = snd_output_stdio_attach(&output, stdout, 0); 3278 if (err < 0) 3279 return NULL; 3280 err = snd_output_stdio_attach(&eoutput, stderr, 0); 3281 if (err < 0) { 3282 snd_output_close(output); 3283 return NULL; 3284 } 3285 cfg = calloc(1, sizeof(struct alisp_cfg)); 3286 if (cfg == NULL) { 3287 snd_output_close(eoutput); 3288 snd_output_close(output); 3289 return NULL; 3290 } 3291 cfg->out = output; 3292 cfg->wout = eoutput; 3293 cfg->eout = eoutput; 3294 cfg->dout = eoutput; 3295 cfg->in = input; 3296 return cfg; 3297} 3298 3299void alsa_lisp_default_cfg_free(struct alisp_cfg *cfg) 3300{ 3301 snd_input_close(cfg->in); 3302 snd_output_close(cfg->out); 3303 snd_output_close(cfg->dout); 3304 free(cfg); 3305} 3306 3307int alsa_lisp_function(struct alisp_instance *instance, struct alisp_seq_iterator **result, 3308 const char *id, const char *args, ...) 3309{ 3310 int err = 0; 3311 struct alisp_object *aargs = NULL, *obj, *res; 3312 3313 if (args && *args != 'n') { 3314 va_list ap; 3315 struct alisp_object *p; 3316 p = NULL; 3317 va_start(ap, args); 3318 while (*args) { 3319 if (*args++ != '%') { 3320 err = -EINVAL; 3321 break; 3322 } 3323 if (*args == '\0') { 3324 err = -EINVAL; 3325 break; 3326 } 3327 obj = NULL; 3328 err = 0; 3329 switch (*args++) { 3330 case 's': 3331 obj = new_string(instance, va_arg(ap, char *)); 3332 break; 3333 case 'i': 3334 obj = new_integer(instance, va_arg(ap, int)); 3335 break; 3336 case 'l': 3337 obj = new_integer(instance, va_arg(ap, long)); 3338 break; 3339 case 'f': 3340 case 'd': 3341 obj = new_integer(instance, va_arg(ap, double)); 3342 break; 3343 case 'p': { 3344 char _ptrid[24]; 3345 char *ptrid = _ptrid; 3346 while (*args && *args != '%') 3347 *ptrid++ = *args++; 3348 *ptrid = 0; 3349 if (ptrid == _ptrid) { 3350 err = -EINVAL; 3351 break; 3352 } 3353 obj = new_cons_pointer(instance, _ptrid, va_arg(ap, void *)); 3354 obj = quote_object(instance, obj); 3355 break; 3356 } 3357 default: 3358 err = -EINVAL; 3359 break; 3360 } 3361 if (err < 0) 3362 goto __args_end; 3363 if (obj == NULL) { 3364 err = -ENOMEM; 3365 goto __args_end; 3366 } 3367 if (p == NULL) { 3368 p = aargs = new_object(instance, ALISP_OBJ_CONS); 3369 } else { 3370 p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); 3371 p = p->value.c.cdr; 3372 } 3373 if (p == NULL) { 3374 err = -ENOMEM; 3375 goto __args_end; 3376 } 3377 p->value.c.car = obj; 3378 } 3379 __args_end: 3380 va_end(ap); 3381 if (err < 0) 3382 return err; 3383#if 0 3384 snd_output_printf(instance->wout, ">>>"); 3385 princ_object(instance->wout, aargs); 3386 snd_output_printf(instance->wout, "<<<\n"); 3387#endif 3388 } 3389 3390 err = -ENOENT; 3391 if (aargs == NULL) 3392 aargs = &alsa_lisp_nil; 3393 if ((obj = get_object1(instance, id)) != &alsa_lisp_nil) { 3394 res = eval_func(instance, obj, aargs); 3395 err = 0; 3396 } else { 3397 struct intrinsic key, *item; 3398 key.name = id; 3399 if ((item = bsearch(&key, intrinsics, 3400 sizeof intrinsics / sizeof intrinsics[0], 3401 sizeof intrinsics[0], compar)) != NULL) { 3402 res = item->func(instance, aargs); 3403 err = 0; 3404 } else if ((item = bsearch(&key, snd_intrinsics, 3405 sizeof snd_intrinsics / sizeof snd_intrinsics[0], 3406 sizeof snd_intrinsics[0], compar)) != NULL) { 3407 res = item->func(instance, aargs); 3408 err = 0; 3409 } else { 3410 res = &alsa_lisp_nil; 3411 } 3412 } 3413 if (res == NULL) 3414 err = -ENOMEM; 3415 if (err == 0 && result) { 3416 *result = res; 3417 } else { 3418 delete_tree(instance, res); 3419 } 3420 3421 return 0; 3422} 3423 3424void alsa_lisp_result_free(struct alisp_instance *instance, 3425 struct alisp_seq_iterator *result) 3426{ 3427 delete_tree(instance, result); 3428} 3429 3430int alsa_lisp_seq_first(struct alisp_instance *instance, const char *id, 3431 struct alisp_seq_iterator **seq) 3432{ 3433 struct alisp_object * p1; 3434 3435 p1 = get_object1(instance, id); 3436 if (p1 == NULL) 3437 return -ENOMEM; 3438 *seq = p1; 3439 return 0; 3440} 3441 3442int alsa_lisp_seq_next(struct alisp_seq_iterator **seq) 3443{ 3444 struct alisp_object * p1 = *seq; 3445 3446 p1 = cdr(p1); 3447 if (p1 == &alsa_lisp_nil) 3448 return -ENOENT; 3449 *seq = p1; 3450 return 0; 3451} 3452 3453int alsa_lisp_seq_count(struct alisp_seq_iterator *seq) 3454{ 3455 int count = 0; 3456 3457 while (seq != &alsa_lisp_nil) { 3458 count++; 3459 seq = cdr(seq); 3460 } 3461 return count; 3462} 3463 3464int alsa_lisp_seq_integer(struct alisp_seq_iterator *seq, long *val) 3465{ 3466 if (alisp_compare_type(seq, ALISP_OBJ_CONS)) 3467 seq = seq->value.c.cdr; 3468 if (alisp_compare_type(seq, ALISP_OBJ_INTEGER)) 3469 *val = seq->value.i; 3470 else 3471 return -EINVAL; 3472 return 0; 3473} 3474 3475int alsa_lisp_seq_pointer(struct alisp_seq_iterator *seq, const char *ptr_id, void **ptr) 3476{ 3477 struct alisp_object * p2; 3478 3479 if (alisp_compare_type(seq, ALISP_OBJ_CONS) && 3480 alisp_compare_type(seq->value.c.car, ALISP_OBJ_CONS)) 3481 seq = seq->value.c.car; 3482 if (alisp_compare_type(seq, ALISP_OBJ_CONS)) { 3483 p2 = seq->value.c.car; 3484 if (!alisp_compare_type(p2, ALISP_OBJ_STRING)) 3485 return -EINVAL; 3486 if (strcmp(p2->value.s, ptr_id)) 3487 return -EINVAL; 3488 p2 = seq->value.c.cdr; 3489 if (!alisp_compare_type(p2, ALISP_OBJ_POINTER)) 3490 return -EINVAL; 3491 *ptr = (void *)seq->value.ptr; 3492 } else 3493 return -EINVAL; 3494 return 0; 3495} 3496