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