~ubuntu-branches/ubuntu/natty/alsa-lib/natty
» Revision
70
: .pc/Fix-str-lit-no-format.patch/src/alisp/alisp.c
« back to all changes in this revision
Viewing changes to .pc/Fix-str-lit-no-format.patch/src/alisp/alisp.c
- browse files at revision 70
- compare with another revision
- download diff
- download tarball
- view history from revision 70
- Committer: Bazaar Package Importer
- Author(s): Luke Yelavich
- Date: 2010-05-19 11:04:50 UTC
- mfrom: (1.1.14 upstream) (2.2.6 sid)
- Revision ID: james.westby@ubuntu.com-20100519110450-79ixzqrupz0ylqjb
Tags: 1.0.23-0ubuntu1
* New upstream release
- debian/patches/:
+ Dont_leak_timer_fd_on_pcm_slave_close.patch
+ Fix-S24_3LE-softvol-distortion.patc
+ Fix-modem-on-hook.patch
+ Fix-stream-state-updates.patch
+ Fix-pcm-timer-open-subdevice-pcm_hw.patch
+ b9dbee6-Fix-threading-drain.patch
- Dropped
+ Fix-str-lit-no-format.patch
+ lp433573-Support-Echo3G.patch
- retained, need to be sent upstream
* Merge from debian unstable, remaining changes:
- debian/rules:
+ Don't bail when removing include/alsa
- debian/control: Add Vcs-Bzr URI
- Add configuration files for bluetooth/bluez-alsa and pulseaudio
- debian/libasound2.install: Ship smixer plugins for native and bi-arch
packages
- drop libcxxtools-dev build dependency, its in universe
- add --with-plugindir=\$${prefix}/lib/alsa-lib to configure-stamp
- Demote libc6-i386 pre-depends to depends for lib32asound2
- debian/patches/:
+ Dont_leak_timer_fd_on_pcm_slave_close.patch
+ Fix-S24_3LE-softvol-distortion.patc
+ Fix-modem-on-hook.patch
+ Fix-stream-state-updates.patch
+ Fix-pcm-timer-open-subdevice-pcm_hw.patch
+ b9dbee6-Fix-threading-drain.patch
- Dropped
+ Fix-str-lit-no-format.patch
+ lp433573-Support-Echo3G.patch
- retained, need to be sent upstream
* Merge from debian unstable, remaining changes:
- debian/rules:
+ Don't bail when removing include/alsa
- debian/control: Add Vcs-Bzr URI
- Add configuration files for bluetooth/bluez-alsa and pulseaudio
- debian/libasound2.install: Ship smixer plugins for native and bi-arch
packages
- drop libcxxtools-dev build dependency, its in universe
- add --with-plugindir=\$${prefix}/lib/alsa-lib to configure-stamp
- Demote libc6-i386 pre-depends to depends for lib32asound2
- files added:
- .pc
- .pc/Fix-str-lit-no-format.patch
- .pc/Fix-str-lit-no-format.patch/src
- .pc/Fix-str-lit-no-format.patch/src/alisp
- .pc/add-maintainer-mode.patch
- .pc/bluetooth_configuration.patch
- .pc/bluetooth_configuration.patch/src
- .pc/bluetooth_configuration.patch/src/conf
- .pc/configure_cross_compile.patch
- .pc/lp433573-Support-Echo3G.patch
- .pc/lp433573-Support-Echo3G.patch/src
- .pc/lp433573-Support-Echo3G.patch/src/conf
- .pc/lp433573-Support-Echo3G.patch/src/conf/cards
- .pc/pulseaudio_configuration.patch
- .pc/pulseaudio_configuration.patch/src
- .pc/pulseaudio_configuration.patch/src/conf
- .pc/relibtoolise.patch
- .pc/relibtoolise.patch/alsalisp
- .pc/relibtoolise.patch/aserver
- .pc/relibtoolise.patch/doc
- .pc/relibtoolise.patch/doc/pictures
- .pc/relibtoolise.patch/include
- .pc/relibtoolise.patch/include/sound
- .pc/relibtoolise.patch/m4
- .pc/relibtoolise.patch/modules
- .pc/relibtoolise.patch/modules/mixer
- .pc/relibtoolise.patch/modules/mixer/simple
- .pc/relibtoolise.patch/src
- .pc/relibtoolise.patch/src/alisp
- .pc/relibtoolise.patch/src/compat
- .pc/relibtoolise.patch/src/conf
- .pc/relibtoolise.patch/src/conf/cards
- .pc/relibtoolise.patch/src/conf/pcm
- .pc/relibtoolise.patch/src/control
- .pc/relibtoolise.patch/src/hwdep
- .pc/relibtoolise.patch/src/mixer
- .pc/relibtoolise.patch/src/pcm
- .pc/relibtoolise.patch/src/pcm/scopes
- .pc/relibtoolise.patch/src/rawmidi
- .pc/relibtoolise.patch/src/seq
- .pc/relibtoolise.patch/src/timer
- .pc/relibtoolise.patch/test
- .pc/relibtoolise.patch/test/lsb
- .pc/relibtoolise.patch/utils
- debian/source
- files removed:
- debian/patches/Dont_leak_timer_fd_on_pcm_slave_close.patch
- files modified:
- Makefile.in
added
removed
.pc/Fix-str-lit-no-format.patch/src/alisp/alisp.c
1
/*
2
* ALSA lisp implementation
3
* Copyright (c) 2003 by Jaroslav Kysela <perex@perex.cz>
4
*
5
* Based on work of Sandro Sigala (slisp-1.2)
6
*
7
*
8
* This library is free software; you can redistribute it and/or modify
9
* it under the terms of the GNU Lesser General Public License as
10
* published by the Free Software Foundation; either version 2.1 of
11
* the License, or (at your option) any later version.
12
*
13
* This program is distributed in the hope that it will be useful,
14
* but WITHOUT ANY WARRANTY; without even the implied warranty of
15
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
* GNU Lesser General Public License for more details.
17
*
18
* You should have received a copy of the GNU Lesser General Public
19
* License along with this library; if not, write to the Free Software
20
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21
*
22
*/
23
24
#include <assert.h>
25
26
#include <limits.h>
27
#include <stdio.h>
28
#include <stdlib.h>
29
#include <string.h>
30
#include <ctype.h>
31
#include <math.h>
32
#include <err.h>
33
34
#define alisp_seq_iterator alisp_object
35
36
#include "local.h"
37
#include "alisp.h"
38
#include "alisp_local.h"
39
40
struct alisp_object alsa_lisp_nil;
41
struct alisp_object alsa_lisp_t;
42
43
/* parser prototypes */
44
static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken);
45
static void princ_cons(snd_output_t *out, struct alisp_object * p);
46
static void princ_object(snd_output_t *out, struct alisp_object * p);
47
static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p);
48
49
/* functions */
50
static struct alisp_object *F_eval(struct alisp_instance *instance, struct alisp_object *);
51
static struct alisp_object *F_progn(struct alisp_instance *instance, struct alisp_object *);
52
static struct alisp_object *F_funcall(struct alisp_instance *instance, struct alisp_object *);
53
54
/* others */
55
static int alisp_include_file(struct alisp_instance *instance, const char *filename);
56
57
/*
58
* object handling
59
*/
60
61
static int get_string_hash(const char *s)
62
{
63
int val = 0;
64
if (s == NULL)
65
return val;
66
while (*s)
67
val += *s++;
68
return val & ALISP_OBJ_PAIR_HASH_MASK;
69
}
70
71
static void nomem(void)
72
{
73
SNDERR("alisp: no enough memory");
74
}
75
76
static void lisp_verbose(struct alisp_instance *instance, const char *fmt, ...)
77
{
78
va_list ap;
79
80
if (!instance->verbose)
81
return;
82
va_start(ap, fmt);
83
snd_output_printf(instance->vout, "alisp: ");
84
snd_output_vprintf(instance->vout, fmt, ap);
85
snd_output_putc(instance->vout, '\n');
86
va_end(ap);
87
}
88
89
static void lisp_error(struct alisp_instance *instance, const char *fmt, ...)
90
{
91
va_list ap;
92
93
if (!instance->warning)
94
return;
95
va_start(ap, fmt);
96
snd_output_printf(instance->eout, "alisp error: ");
97
snd_output_vprintf(instance->eout, fmt, ap);
98
snd_output_putc(instance->eout, '\n');
99
va_end(ap);
100
}
101
102
static void lisp_warn(struct alisp_instance *instance, const char *fmt, ...)
103
{
104
va_list ap;
105
106
if (!instance->warning)
107
return;
108
va_start(ap, fmt);
109
snd_output_printf(instance->wout, "alisp warning: ");
110
snd_output_vprintf(instance->wout, fmt, ap);
111
snd_output_putc(instance->wout, '\n');
112
va_end(ap);
113
}
114
115
static void lisp_debug(struct alisp_instance *instance, const char *fmt, ...)
116
{
117
va_list ap;
118
119
if (!instance->debug)
120
return;
121
va_start(ap, fmt);
122
snd_output_printf(instance->dout, "alisp debug: ");
123
snd_output_vprintf(instance->dout, fmt, ap);
124
snd_output_putc(instance->dout, '\n');
125
va_end(ap);
126
}
127
128
static struct alisp_object * new_object(struct alisp_instance *instance, int type)
129
{
130
struct alisp_object * p;
131
132
if (list_empty(&instance->free_objs_list)) {
133
p = (struct alisp_object *)malloc(sizeof(struct alisp_object));
134
if (p == NULL) {
135
nomem();
136
return NULL;
137
}
138
lisp_debug(instance, "allocating cons %p", p);
139
} else {
140
p = (struct alisp_object *)instance->free_objs_list.next;
141
list_del(&p->list);
142
instance->free_objs--;
143
lisp_debug(instance, "recycling cons %p", p);
144
}
145
146
instance->used_objs++;
147
148
alisp_set_type(p, type);
149
alisp_set_refs(p, 1);
150
if (type == ALISP_OBJ_CONS) {
151
p->value.c.car = &alsa_lisp_nil;
152
p->value.c.cdr = &alsa_lisp_nil;
153
list_add(&p->list, &instance->used_objs_list[0][ALISP_OBJ_CONS]);
154
}
155
156
if (instance->used_objs + instance->free_objs > instance->max_objs)
157
instance->max_objs = instance->used_objs + instance->free_objs;
158
159
return p;
160
}
161
162
static void free_object(struct alisp_object * p)
163
{
164
switch (alisp_get_type(p)) {
165
case ALISP_OBJ_STRING:
166
case ALISP_OBJ_IDENTIFIER:
167
free(p->value.s);
168
alisp_set_type(p, ALISP_OBJ_INTEGER);
169
break;
170
default:
171
break;
172
}
173
}
174
175
static void delete_object(struct alisp_instance *instance, struct alisp_object * p)
176
{
177
if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t)
178
return;
179
if (alisp_compare_type(p, ALISP_OBJ_NIL) ||
180
alisp_compare_type(p, ALISP_OBJ_T))
181
return;
182
assert(alisp_get_refs(p) > 0);
183
lisp_debug(instance, "delete cons %p (type = %i, refs = %i) (s = '%s')", p, alisp_get_type(p), alisp_get_refs(p),
184
alisp_compare_type(p, ALISP_OBJ_STRING) ||
185
alisp_compare_type(p, ALISP_OBJ_IDENTIFIER) ? p->value.s : "???");
186
if (alisp_dec_refs(p))
187
return;
188
list_del(&p->list);
189
instance->used_objs--;
190
free_object(p);
191
if (instance->free_objs >= ALISP_FREE_OBJ_POOL) {
192
lisp_debug(instance, "freed cons %p", p);
193
free(p);
194
return;
195
}
196
lisp_debug(instance, "moved cons %p to free list", p);
197
list_add(&p->list, &instance->free_objs_list);
198
instance->free_objs++;
199
}
200
201
static void delete_tree(struct alisp_instance *instance, struct alisp_object * p)
202
{
203
if (p == NULL)
204
return;
205
if (alisp_compare_type(p, ALISP_OBJ_CONS)) {
206
delete_tree(instance, p->value.c.car);
207
delete_tree(instance, p->value.c.cdr);
208
}
209
delete_object(instance, p);
210
}
211
212
static struct alisp_object * incref_object(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * p)
213
{
214
if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t)
215
return p;
216
if (alisp_get_refs(p) == ALISP_MAX_REFS) {
217
assert(0);
218
fprintf(stderr, "OOPS: alsa lisp: incref fatal error\n");
219
exit(EXIT_FAILURE);
220
}
221
alisp_inc_refs(p);
222
return p;
223
}
224
225
static struct alisp_object * incref_tree(struct alisp_instance *instance, struct alisp_object * p)
226
{
227
if (p == NULL)
228
return NULL;
229
if (alisp_compare_type(p, ALISP_OBJ_CONS)) {
230
incref_tree(instance, p->value.c.car);
231
incref_tree(instance, p->value.c.cdr);
232
}
233
return incref_object(instance, p);
234
}
235
236
/* 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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
508
static inline void xungetc(struct alisp_instance *instance, int c)
509
{
510
*(instance->lex_bufp)++ = c;
511
instance->charno--;
512
}
513
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
526
static void done_lex(struct alisp_instance *instance)
527
{
528
free(instance->token_buffer);
529
}
530
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
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
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
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
770
static inline struct alisp_object * parse_quote(struct alisp_instance *instance)
771
{
772
return quote_object(instance, parse_object(instance, 0));
773
}
774
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
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
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
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
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
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
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
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
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 writting (%s)", fname, snd_strerror(errno));
993
return;
994
}
995
996
for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) {
997
list_for_each(pos, &instance->setobjs_list[i]) {
998
p = list_entry(pos, struct alisp_object_pair, list);
999
if (alisp_compare_type(p->value, ALISP_OBJ_CONS) &&
1000
alisp_compare_type(p->value->value.c.car, ALISP_OBJ_IDENTIFIER) &&
1001
!strcmp(p->value->value.c.car->value.s, "lambda")) {
1002
snd_output_printf(out, "(defun %s ", p->name);
1003
princ_cons(out, p->value->value.c.cdr);
1004
snd_output_printf(out, ")\n");
1005
continue;
1006
}
1007
snd_output_printf(out, "(setq %s '", p->name);
1008
princ_object(out, p->value);
1009
snd_output_printf(out, ")\n");
1010
}
1011
}
1012
snd_output_close(out);
1013
}
1014
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
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
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 writting (%s)", fname, snd_strerror(errno));
1066
return;
1067
}
1068
1069
print_obj_lists(instance, out);
1070
1071
snd_output_close(out);
1072
}
1073
1074
/*
1075
* functions
1076
*/
1077
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
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
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
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
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
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
*/
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, 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
*/
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
*/
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
*/
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
1814
static inline int eq(struct alisp_object * p1, struct alisp_object * p2)
1815
{
1816
return p1 == p2;
1817
}
1818
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
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
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
*/
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, ALSA_CONFIG_DIR);
2403
}
2404
delete_tree(instance, p1);
2405
return &alsa_lisp_nil;
2406
}
2407
2408
/*
2409
* Syntax: (include filename...)
2410
*/
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
*/
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
*/
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
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
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
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
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
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
*/
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
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
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
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
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
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
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
*/
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
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
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
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
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
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 *)malloc(sizeof(struct alisp_instance));
3206
if (instance == NULL) {
3207
nomem();
3208
return -ENOMEM;
3209
}
3210
memset(instance, 0, sizeof(struct alisp_instance));
3211
instance->verbose = cfg->verbose && cfg->vout;
3212
instance->warning = cfg->warning && cfg->wout;
3213
instance->debug = cfg->debug && cfg->dout;
3214
instance->in = cfg->in;
3215
instance->out = cfg->out;
3216
instance->vout = cfg->vout;
3217
instance->eout = cfg->eout;
3218
instance->wout = cfg->wout;
3219
instance->dout = cfg->dout;
3220
INIT_LIST_HEAD(&instance->free_objs_list);
3221
for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) {
3222
for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++)
3223
INIT_LIST_HEAD(&instance->used_objs_list[i][j]);
3224
INIT_LIST_HEAD(&instance->setobjs_list[i]);
3225
}
3226
3227
init_lex(instance);
3228
3229
for (;;) {
3230
if ((p = parse_object(instance, 0)) == NULL)
3231
break;
3232
if (instance->verbose) {
3233
lisp_verbose(instance, "** code");
3234
princ_object(instance->vout, p);
3235
snd_output_putc(instance->vout, '\n');
3236
}
3237
p1 = eval(instance, p);
3238
if (p1 == NULL) {
3239
retval = -ENOMEM;
3240
break;
3241
}
3242
if (instance->verbose) {
3243
lisp_verbose(instance, "** result");
3244
princ_object(instance->vout, p1);
3245
snd_output_putc(instance->vout, '\n');
3246
}
3247
delete_tree(instance, p1);
3248
if (instance->debug) {
3249
lisp_debug(instance, "** objects after operation");
3250
print_obj_lists(instance, instance->dout);
3251
}
3252
}
3253
3254
if (_instance)
3255
*_instance = instance;
3256
else
3257
alsa_lisp_free(instance);
3258
3259
return 0;
3260
}
3261
3262
void alsa_lisp_free(struct alisp_instance *instance)
3263
{
3264
if (instance == NULL)
3265
return;
3266
done_lex(instance);
3267
free_objects(instance);
3268
free(instance);
3269
}
3270
3271
struct alisp_cfg *alsa_lisp_default_cfg(snd_input_t *input)
3272
{
3273
snd_output_t *output, *eoutput;
3274
struct alisp_cfg *cfg;
3275
int err;
3276
3277
err = snd_output_stdio_attach(&output, stdout, 0);
3278
if (err < 0)
3279
return NULL;
3280
err = snd_output_stdio_attach(&eoutput, stderr, 0);
3281
if (err < 0) {
3282
snd_output_close(output);
3283
return NULL;
3284
}
3285
cfg = calloc(1, sizeof(struct alisp_cfg));
3286
if (cfg == NULL) {
3287
snd_output_close(eoutput);
3288
snd_output_close(output);
3289
return NULL;
3290
}
3291
cfg->out = output;
3292
cfg->wout = eoutput;
3293
cfg->eout = eoutput;
3294
cfg->dout = eoutput;
3295
cfg->in = input;
3296
return cfg;
3297
}
3298
3299
void alsa_lisp_default_cfg_free(struct alisp_cfg *cfg)
3300
{
3301
snd_input_close(cfg->in);
3302
snd_output_close(cfg->out);
3303
snd_output_close(cfg->dout);
3304
free(cfg);
3305
}
3306
3307
int alsa_lisp_function(struct alisp_instance *instance, struct alisp_seq_iterator **result,
3308
const char *id, const char *args, ...)
3309
{
3310
int err = 0;
3311
struct alisp_object *aargs = NULL, *obj, *res;
3312
3313
if (args && *args != 'n') {
3314
va_list ap;
3315
struct alisp_object *p;
3316
p = NULL;
3317
va_start(ap, args);
3318
while (*args) {
3319
if (*args++ != '%') {
3320
err = -EINVAL;
3321
break;
3322
}
3323
if (*args == '\0') {
3324
err = -EINVAL;
3325
break;
3326
}
3327
obj = NULL;
3328
err = 0;
3329
switch (*args++) {
3330
case 's':
3331
obj = new_string(instance, va_arg(ap, char *));
3332
break;
3333
case 'i':
3334
obj = new_integer(instance, va_arg(ap, int));
3335
break;
3336
case 'l':
3337
obj = new_integer(instance, va_arg(ap, long));
3338
break;
3339
case 'f':
3340
case 'd':
3341
obj = new_integer(instance, va_arg(ap, double));
3342
break;
3343
case 'p': {
3344
char _ptrid[24];
3345
char *ptrid = _ptrid;
3346
while (*args && *args != '%')
3347
*ptrid++ = *args++;
3348
*ptrid = 0;
3349
if (ptrid == _ptrid) {
3350
err = -EINVAL;
3351
break;
3352
}
3353
obj = new_cons_pointer(instance, _ptrid, va_arg(ap, void *));
3354
obj = quote_object(instance, obj);
3355
break;
3356
}
3357
default:
3358
err = -EINVAL;
3359
break;
3360
}
3361
if (err < 0)
3362
goto __args_end;
3363
if (obj == NULL) {
3364
err = -ENOMEM;
3365
goto __args_end;
3366
}
3367
if (p == NULL) {
3368
p = aargs = new_object(instance, ALISP_OBJ_CONS);
3369
} else {
3370
p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS);
3371
p = p->value.c.cdr;
3372
}
3373
if (p == NULL) {
3374
err = -ENOMEM;
3375
goto __args_end;
3376
}
3377
p->value.c.car = obj;
3378
}
3379
__args_end:
3380
va_end(ap);
3381
if (err < 0)
3382
return err;
3383
#if 0
3384
snd_output_printf(instance->wout, ">>>");
3385
princ_object(instance->wout, aargs);
3386
snd_output_printf(instance->wout, "<<<\n");
3387
#endif
3388
}
3389
3390
err = -ENOENT;
3391
if (aargs == NULL)
3392
aargs = &alsa_lisp_nil;
3393
if ((obj = get_object1(instance, id)) != &alsa_lisp_nil) {
3394
res = eval_func(instance, obj, aargs);
3395
err = 0;
3396
} else {
3397
struct intrinsic key, *item;
3398
key.name = id;
3399
if ((item = bsearch(&key, intrinsics,
3400
sizeof intrinsics / sizeof intrinsics[0],
3401
sizeof intrinsics[0], compar)) != NULL) {
3402
res = item->func(instance, aargs);
3403
err = 0;
3404
} else if ((item = bsearch(&key, snd_intrinsics,
3405
sizeof snd_intrinsics / sizeof snd_intrinsics[0],
3406
sizeof snd_intrinsics[0], compar)) != NULL) {
3407
res = item->func(instance, aargs);
3408
err = 0;
3409
} else {
3410
res = &alsa_lisp_nil;
3411
}
3412
}
3413
if (res == NULL)
3414
err = -ENOMEM;
3415
if (err == 0 && result) {
3416
*result = res;
3417
} else {
3418
delete_tree(instance, res);
3419
}
3420
3421
return 0;
3422
}
3423
3424
void alsa_lisp_result_free(struct alisp_instance *instance,
3425
struct alisp_seq_iterator *result)
3426
{
3427
delete_tree(instance, result);
3428
}
3429
3430
int alsa_lisp_seq_first(struct alisp_instance *instance, const char *id,
3431
struct alisp_seq_iterator **seq)
3432
{
3433
struct alisp_object * p1;
3434
3435
p1 = get_object1(instance, id);
3436
if (p1 == NULL)
3437
return -ENOMEM;
3438
*seq = p1;
3439
return 0;
3440
}
3441
3442
int alsa_lisp_seq_next(struct alisp_seq_iterator **seq)
3443
{
3444
struct alisp_object * p1 = *seq;
3445
3446
p1 = cdr(p1);
3447
if (p1 == &alsa_lisp_nil)
3448
return -ENOENT;
3449
*seq = p1;
3450
return 0;
3451
}
3452
3453
int alsa_lisp_seq_count(struct alisp_seq_iterator *seq)
3454
{
3455
int count = 0;
3456
3457
while (seq != &alsa_lisp_nil) {
3458
count++;
3459
seq = cdr(seq);
3460
}
3461
return count;
3462
}
3463
3464
int alsa_lisp_seq_integer(struct alisp_seq_iterator *seq, long *val)
3465
{
3466
if (alisp_compare_type(seq, ALISP_OBJ_CONS))
3467
seq = seq->value.c.cdr;
3468
if (alisp_compare_type(seq, ALISP_OBJ_INTEGER))
3469
*val = seq->value.i;
3470
else
3471
return -EINVAL;
3472
return 0;
3473
}
3474
3475
int alsa_lisp_seq_pointer(struct alisp_seq_iterator *seq, const char *ptr_id, void **ptr)
3476
{
3477
struct alisp_object * p2;
3478
3479
if (alisp_compare_type(seq, ALISP_OBJ_CONS) &&
3480
alisp_compare_type(seq->value.c.car, ALISP_OBJ_CONS))
3481
seq = seq->value.c.car;
3482
if (alisp_compare_type(seq, ALISP_OBJ_CONS)) {
3483
p2 = seq->value.c.car;
3484
if (!alisp_compare_type(p2, ALISP_OBJ_STRING))
3485
return -EINVAL;
3486
if (strcmp(p2->value.s, ptr_id))
3487
return -EINVAL;
3488
p2 = seq->value.c.cdr;
3489
if (!alisp_compare_type(p2, ALISP_OBJ_POINTER))
3490
return -EINVAL;
3491
*ptr = (void *)seq->value.ptr;
3492
} else
3493
return -EINVAL;
3494
return 0;
3495
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1