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