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