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