diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | alsalisp/Makefile.am | 8 | ||||
| -rw-r--r-- | alsalisp/alsalisp.c | 120 | ||||
| -rw-r--r-- | configure.in | 4 | ||||
| -rw-r--r-- | include/Makefile.am | 3 | ||||
| -rw-r--r-- | include/alisp.h | 38 | ||||
| -rw-r--r-- | include/asoundlib.h | 1 | ||||
| -rw-r--r-- | include/local.h | 1 | ||||
| -rw-r--r-- | include/output.h | 1 | ||||
| -rw-r--r-- | src/Makefile.am | 7 | ||||
| -rw-r--r-- | src/Versions | 6 | ||||
| -rw-r--r-- | src/alisp/Makefile.am | 9 | ||||
| -rw-r--r-- | src/alisp/alisp.c | 1628 | ||||
| -rw-r--r-- | src/alisp/alisp_local.h | 92 | ||||
| -rw-r--r-- | src/output.c | 12 |
15 files changed, 1926 insertions, 6 deletions
diff --git a/Makefile.am b/Makefile.am index 61d82e0e..ba193959 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,4 +1,4 @@ -SUBDIRS=doc include src aserver test utils +SUBDIRS=doc include src aserver alsalisp test utils EXTRA_DIST=ChangeLog INSTALL TODO configure cvscompile libtool depcomp version INCLUDES=-I$(top_srcdir)/include diff --git a/alsalisp/Makefile.am b/alsalisp/Makefile.am new file mode 100644 index 00000000..398261ca --- /dev/null +++ b/alsalisp/Makefile.am @@ -0,0 +1,8 @@ +bin_PROGRAMS = alsalisp + +alsalisp_SOURCES = alsalisp.c +alsalisp_LDADD = ../src/libasound.la + +all: alsalisp + +INCLUDES=-I$(top_srcdir)/include -I$(top_srcdir)/src/alisp diff --git a/alsalisp/alsalisp.c b/alsalisp/alsalisp.c new file mode 100644 index 00000000..0dad484a --- /dev/null +++ b/alsalisp/alsalisp.c @@ -0,0 +1,120 @@ +/* + * ALSA lisp implementation + * Copyright (c) 2003 by Jaroslav Kysela <perex@suse.cz> + * + * + * This library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation; either version 2.1 of + * the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + */ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <unistd.h> +#include <err.h> + +#include "asoundlib.h" +#include "alisp.h" + +static int verbose = 0; +static int warning = 0; +static int debug = 0; + +static void interpret_filename(const char *file) +{ + struct alisp_cfg cfg; + snd_input_t *in; + snd_output_t *out; + snd_config_t *root; + int err; + + memset(&cfg, 0, sizeof(cfg)); + if (file != NULL && strcmp(file, "-") != 0) { + if ((err = snd_input_stdio_open(&in, file, "r")) < 0) { + fprintf(stderr, "unable to open filename '%s' (%s)\n", file, snd_strerror(err)); + return; + } + } else { + if ((err = snd_input_stdio_attach(&in, stdin, 0)) < 0) { + fprintf(stderr, "unable to attach stdin '%s' (%s)\n", file, snd_strerror(err)); + return; + } + } + if (snd_output_stdio_attach(&out, stdout, 0) < 0) { + snd_input_close(in); + fprintf(stderr, "unable to attach stdout (%s)\n", strerror(errno)); + return; + } + err = snd_config_top(&root); + if (err < 0) + fprintf(stderr, "unable to allocate config root\n"); + else { + cfg.verbose = verbose; + cfg.warning = warning; + cfg.debug = debug; + cfg.in = in; + cfg.out = cfg.vout = cfg.wout = cfg.dout = out; + cfg.root = root; + cfg.node = root; + err = alsa_lisp(&cfg); + } + if (err < 0) + fprintf(stderr, "alsa lisp returned error %i (%s)\n", err, strerror(err)); + else if (verbose) + printf("file %s passed ok via alsa lisp interpreter", file); + snd_config_save(root, out); + snd_output_close(out); + snd_input_close(in); + snd_config_delete(root); +} + +static void usage(void) +{ + fprintf(stderr, "usage: alsalisp [-vdw] [file...]\n"); + exit(1); +} + +int main(int argc, char **argv) +{ + int c; + + while ((c = getopt(argc, argv, "vdw")) != -1) { + switch (c) { + case 'v': + verbose = 1; + break; + case 'd': + debug = 1; + break; + case 'w': + warning = 1; + break; + case '?': + default: + usage(); + /* NOTREACHED */ + } + } + argc -= optind; + argv += optind; + + if (argc < 1) + interpret_filename(NULL); + else + while (*argv) + interpret_filename(*argv++); + + return 0; +} diff --git a/configure.in b/configure.in index b229b95e..67715323 100644 --- a/configure.in +++ b/configure.in @@ -165,7 +165,7 @@ AC_OUTPUT(Makefile doc/Makefile doc/pictures/Makefile include/Makefile src/pcm/Makefile src/pcm/ext/Makefile src/pcm/scopes/Makefile src/ordinary_pcm/Makefile \ src/rawmidi/Makefile src/timer/Makefile \ src/hwdep/Makefile src/seq/Makefile src/instr/Makefile \ - src/compat/Makefile src/conf/Makefile \ + src/compat/Makefile src/alisp/Makefile src/conf/Makefile \ src/conf/cards/Makefile src/conf/pcm/Makefile \ - aserver/Makefile test/Makefile utils/Makefile \ + alsalisp/Makefile aserver/Makefile test/Makefile utils/Makefile \ utils/alsa-lib.spec utils/alsa.pc) diff --git a/include/Makefile.am b/include/Makefile.am index e078eca4..948b71be 100644 --- a/include/Makefile.am +++ b/include/Makefile.am @@ -9,7 +9,8 @@ alsainclude_HEADERS = asoundlib.h asoundef.h \ hwdep.h control.h mixer.h \ seq_event.h seq.h seqmid.h seq_midi_event.h \ conv.h instr.h iatomic.h \ - pcm_ordinary.h mixer_ordinary.h + pcm_ordinary.h mixer_ordinary.h \ + alisp.h noinst_HEADERS = sys.h search.h list.h aserver.h local.h alsa-symbols.h diff --git a/include/alisp.h b/include/alisp.h new file mode 100644 index 00000000..e81e2d05 --- /dev/null +++ b/include/alisp.h @@ -0,0 +1,38 @@ +/* + * ALSA lisp implementation + * Copyright (c) 2003 by Jaroslav Kysela <perex@suse.cz> + * + * + * This library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation; either version 2.1 of + * the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + */ + +struct alisp_cfg { + int verbose: 1, + warning: 1, + debug: 1; + snd_input_t *in; /* program code */ + snd_output_t *out; /* program output */ + snd_output_t *vout; /* verbose output */ + snd_output_t *wout; /* warning output */ + snd_output_t *dout; /* debug output */ + snd_config_t *root; + snd_config_t *node; +}; + +int alsa_lisp(struct alisp_cfg *cfg); + +extern struct alisp_object alsa_lisp_nil; +extern struct alisp_object alsa_lisp_t; diff --git a/include/asoundlib.h b/include/asoundlib.h index a96507bf..c8560f69 100644 --- a/include/asoundlib.h +++ b/include/asoundlib.h @@ -35,6 +35,7 @@ #include <fcntl.h> #include <assert.h> #include <endian.h> +#include <stdarg.h> #include <sys/poll.h> #include <errno.h> diff --git a/include/local.h b/include/local.h index e04c8c15..f57cc182 100644 --- a/include/local.h +++ b/include/local.h @@ -29,6 +29,7 @@ #include <fcntl.h> #include <assert.h> #include <endian.h> +#include <stdarg.h> #include <sys/poll.h> #include <errno.h> diff --git a/include/output.h b/include/output.h index 492d712c..6c7fdca8 100644 --- a/include/output.h +++ b/include/output.h @@ -71,6 +71,7 @@ int snd_output_printf(snd_output_t *output, const char *format, ...) __attribute__ ((format (printf, 2, 3))) #endif ; +int snd_output_vprintf(snd_output_t *output, const char *format, va_list args); int snd_output_puts(snd_output_t *output, const char *str); int snd_output_putc(snd_output_t *output, int c); int snd_output_flush(snd_output_t *output); diff --git a/src/Makefile.am b/src/Makefile.am index d8b5e00f..2851d222 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -1,4 +1,4 @@ -SUBDIRS=control mixer ordinary_mixer pcm ordinary_pcm rawmidi timer hwdep seq instr compat conf +SUBDIRS=control mixer ordinary_mixer pcm ordinary_pcm rawmidi timer hwdep seq instr compat conf alisp EXTRA_DIST=Versions COMPATNUM=@LIBTOOL_VERSION_INFO@ @@ -15,7 +15,7 @@ libasound_la_LIBADD = control/libcontrol.la \ pcm/libpcm.la ordinary_pcm/libordinarypcm.la \ rawmidi/librawmidi.la timer/libtimer.la \ hwdep/libhwdep.la seq/libseq.la instr/libinstr.la \ - compat/libcompat.la -lm -ldl -lpthread + compat/libcompat.la alisp/libalisp.la -lm -ldl -lpthread libasound_la_LDFLAGS = -version-info $(COMPATNUM) LDFLAGS = $(VSYMS) @@ -53,4 +53,7 @@ instr/libinstr.la: compat/libcompat.la: $(MAKE) -C compat libcompat.la +alisp/libalisp.la: + $(MAKE) -C alisp libalisp.la + INCLUDES=-I$(top_srcdir)/include diff --git a/src/Versions b/src/Versions index 0ca00aa2..d3906ffb 100644 --- a/src/Versions +++ b/src/Versions @@ -108,3 +108,9 @@ ALSA_0.9.3 { snd_ctl_elem_info_get_dimensions; snd_ctl_elem_info_get_dimension; } ALSA_0.9.0; + +ALSA_0.9.5 { + global: + + alsa_lisp; +} ALSA_0.9.3; diff --git a/src/alisp/Makefile.am b/src/alisp/Makefile.am new file mode 100644 index 00000000..eaca125f --- /dev/null +++ b/src/alisp/Makefile.am @@ -0,0 +1,9 @@ +EXTRA_LTLIBRARIES = libalisp.la + +libalisp_la_SOURCES = alisp.c + +noinst_HEADERS = alisp_local.h + +all: libalisp.la + +INCLUDES=-I$(top_srcdir)/include diff --git a/src/alisp/alisp.c b/src/alisp/alisp.c new file mode 100644 index 00000000..1c723141 --- /dev/null +++ b/src/alisp/alisp.c @@ -0,0 +1,1628 @@ +/* + * ALSA lisp implementation + * Copyright (c) 2003 by Jaroslav Kysela <perex@suse.cz> + * + * Based on work of Sandro Sigala (slisp-1.2) + * + * + * This library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation; either version 2.1 of + * the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + */ + +#include <assert.h> + +#include <limits.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <ctype.h> +#include <err.h> + +#include "local.h" +#include "alisp.h" +#include "alisp_local.h" + +struct alisp_object alsa_lisp_nil; +struct alisp_object alsa_lisp_t; + +/* parser prototypes */ +static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken); +static void princ_object(snd_output_t *out, struct alisp_object * p); +static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p); + +/* functions */ +static struct alisp_object *F_eval(struct alisp_instance *instance, struct alisp_object *); +static struct alisp_object *F_progn(struct alisp_instance *instance, struct alisp_object *); + +/* + * object handling + */ + +static void nomem(void) +{ + SNDERR("alisp: no enough memory"); +} + +static void lisp_verbose(struct alisp_instance *instance, const char *fmt, ...) +{ + va_list ap; + + if (!instance->verbose) + return; + va_start(ap, fmt); + snd_output_printf(instance->vout, "alisp: "); + snd_output_vprintf(instance->vout, fmt, ap); + va_end(ap); +} + +static void lisp_warn(struct alisp_instance *instance, const char *fmt, ...) +{ + va_list ap; + + if (!instance->warning) + return; + va_start(ap, fmt); + snd_output_printf(instance->wout, "alisp warning: "); + snd_output_vprintf(instance->wout, fmt, ap); + va_end(ap); +} + +static void lisp_debug(struct alisp_instance *instance, const char *fmt, ...) +{ + va_list ap; + + if (!instance->debug) + return; + va_start(ap, fmt); + snd_output_printf(instance->dout, "alisp debug: "); + snd_output_vprintf(instance->dout, fmt, ap); + va_end(ap); +} + +static struct alisp_object * new_object(struct alisp_instance *instance, int type) +{ + struct alisp_object * p; + + if (instance->free_objs_list == NULL) { + p = (struct alisp_object *)malloc(sizeof(struct alisp_object)); + if (p == NULL) { + nomem(); + return NULL; + } + lisp_debug(instance, "allocating cons %p", p); + } else { + p = instance->free_objs_list; + instance->free_objs_list = instance->free_objs_list->next; + --instance->free_objs; + lisp_debug(instance, "recycling cons %p", p); + } + + p->next = instance->used_objs_list; + instance->used_objs_list = p; + + p->type = type; + if (type == ALISP_OBJ_CONS) { + p->value.c.car = &alsa_lisp_nil; + p->value.c.cdr = &alsa_lisp_nil; + } + p->gc = 0; + + ++instance->used_objs; + + return p; +} + +static struct alisp_object * search_object_identifier(struct alisp_instance *instance, const char *s) +{ + struct alisp_object * p; + + for (p = instance->used_objs_list; p != NULL; p = p->next) + if (p->type == ALISP_OBJ_IDENTIFIER && !strcmp(p->value.id, s)) + return p; + + return NULL; +} + +static struct alisp_object * search_object_string(struct alisp_instance *instance, const char *s) +{ + struct alisp_object * p; + + for (p = instance->used_objs_list; p != NULL; p = p->next) + if (p->type == ALISP_OBJ_STRING && !strcmp(p->value.s, s)) + return p; + + return NULL; +} + +static struct alisp_object * search_object_integer(struct alisp_instance *instance, int in) +{ + struct alisp_object * p; + + for (p = instance->used_objs_list; p != NULL; p = p->next) + if (p->type == ALISP_OBJ_INTEGER && p->value.i == in) + return p; + + return NULL; +} + +void alsa_lisp_init_objects(void) __attribute__ ((constructor)); + +void alsa_lisp_init_objects(void) +{ + memset(&alsa_lisp_nil, 0, sizeof(alsa_lisp_nil)); + alsa_lisp_nil.type = ALISP_OBJ_NIL; + memset(&alsa_lisp_t, 0, sizeof(alsa_lisp_t)); + alsa_lisp_t.type = ALISP_OBJ_T; +} + +/* + * lexer + */ + +static int xgetc(struct alisp_instance *instance) +{ + if (instance->lex_bufp > instance->lex_buf) + *--(instance->lex_bufp); + instance->charno++; + return snd_input_getc(instance->in); +} + +static inline void xungetc(struct alisp_instance *instance, int c) +{ + *(instance->lex_bufp)++ = c; + instance->charno--; +} + +static int init_lex(struct alisp_instance *instance) +{ + instance->charno = instance->lineno = 1; + instance->token_buffer_max = 10; + if ((instance->token_buffer = (char *)malloc(instance->token_buffer_max)) == NULL) { + nomem(); + return -ENOMEM; + } + instance->lex_bufp = instance->lex_buf; + return 0; +} + +static void done_lex(struct alisp_instance *instance) +{ + if (instance->token_buffer) + free(instance->token_buffer); +} + +static char * extend_buf(struct alisp_instance *instance, char *p) +{ + int off = p - instance->token_buffer; + + instance->token_buffer_max += 10; + instance->token_buffer = (char *)realloc(instance->token_buffer, instance->token_buffer_max); + if (instance->token_buffer == NULL) { + nomem(); + return NULL; + } + + return instance->token_buffer + off; +} + +static int gettoken(struct alisp_instance *instance) +{ + char *p; + int c; + + for (;;) { + c = xgetc(instance); + switch (c) { + case '\n': + ++instance->lineno; + break; + + case ' ': case '\f': case '\t': case '\v': case '\r': + break; + + case ';': + /* Comment: ";".*"\n" */ + while ((c = xgetc(instance)) != '\n' && c != EOF) + ; + if (c != EOF) + ++instance->lineno; + break; + + case '?': + /* Character: "?". */ + c = xgetc(instance); + sprintf(instance->token_buffer, "%d", c); + return instance->thistoken = ALISP_INTEGER; + + case '-': + /* Minus sign: "-". */ + c = xgetc(instance); + if (!isdigit(c)) { + xungetc(instance, c); + c = '-'; + goto got_id; + } + xungetc(instance, c); + c = '-'; + /* FALLTRHU */ + + case '0': + case '1': case '2': case '3': + case '4': case '5': case '6': + case '7': case '8': case '9': + /* Integer: [0-9]+ */ + p = instance->token_buffer; + do { + if (p - instance->token_buffer >= instance->token_buffer_max) { + p = extend_buf(instance, p); + if (p == NULL) + return instance->thistoken = EOF; + } + *p++ = c; + c = xgetc(instance); + } while (isdigit(c)); + xungetc(instance, c); + *p = '\0'; + return instance->thistoken = ALISP_INTEGER; + + got_id: + case '_': case '+': case '*': case '/': case '%': + case '<': case '>': case '=': case '&': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + /* Identifier: [-/+*%<>=&a-zA-Z_][-/+*%<>=&a-zA-Z_0-9]* */ + p = instance->token_buffer; + do { + if (p - instance->token_buffer >= instance->token_buffer_max) { + p = extend_buf(instance, p); + if (p == NULL) + return instance->thistoken = EOF; + } + *p++ = c; + c = xgetc(instance); + } while (isalnum(c) || strchr("_-+*/%<>=&", c) != NULL); + xungetc(instance, c); + *p = '\0'; + return instance->thistoken = ALISP_IDENTIFIER; + + case '"': + /* String: "\""([^"]|"\\".)*"\"" */ + p = instance->token_buffer; + while ((c = xgetc(instance)) != '"' && c != EOF) { + if (p - instance->token_buffer >= instance->token_buffer_max) { + p = extend_buf(instance, p); + if (p == NULL) + return instance->thistoken = EOF; + } + if (c == '\\') { + c = xgetc(instance); + switch (c) { + case '\n': ++instance->lineno; break; + case 'a': *p++ = '\a'; break; + case 'b': *p++ = '\b'; break; + case 'f': *p++ = '\f'; break; + case 'n': *p++ = '\n'; break; + case 'r': *p++ = '\r'; break; + case 't': *p++ = '\t'; break; + case 'v': *p++ = '\v'; break; + default: *p++ = c; + } + } else { + if (c == '\n') + ++instance->lineno; + *p++ = c; + } + } + *p = '\0'; + return instance->thistoken = ALISP_STRING; + + default: + return instance->thistoken = c; + } + } +} + +/* + * parser + */ + +static struct alisp_object * parse_form(struct alisp_instance *instance) +{ + int thistoken; + struct alisp_object * p, * first = NULL, * prev = NULL; + + while ((thistoken = gettoken(instance)) != ')' && thistoken != EOF) { + /* + * Parse a dotted pair notation. + */ + if (thistoken == '.') { + thistoken = gettoken(instance); + if (prev == NULL) + errx(1, "unexpected `.'"); + prev->value.c.cdr = parse_object(instance, 1); + if (prev->value.c.cdr == NULL) + return NULL; + if ((thistoken = gettoken(instance)) != ')') + errx(1, "expected `)'"); + break; + } + + p = new_object(instance, ALISP_OBJ_CONS); + if (p == NULL) + return NULL; + + if (first == NULL) + first = p; + if (prev != NULL) + prev->value.c.cdr = p; + + p->value.c.car = parse_object(instance, 1); + if (p->value.c.car == NULL) + return NULL; + prev = p; + }; + + if (first == NULL) + return &alsa_lisp_nil; + else + return first; +} + +static struct alisp_object * parse_quote(struct alisp_instance *instance) +{ + struct alisp_object * p; + + p = new_object(instance, ALISP_OBJ_CONS); + if (p == NULL) + return NULL; + + p->value.c.car = new_object(instance, ALISP_OBJ_IDENTIFIER); + if (p->value.c.car == NULL) + return NULL; + if ((p->value.c.car->value.id = strdup("quote")) == NULL) { + nomem(); + return NULL; + } + p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); + if (p->value.c.cdr == NULL) + return NULL; + p->value.c.cdr->value.c.car = parse_object(instance, 0); + if (p->value.c.cdr->value.c.car == NULL) + return NULL; + + return p; +} + +static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken) +{ + int thistoken; + struct alisp_object * p = NULL; + int i; + + if (!havetoken) + thistoken = gettoken(instance); + else + thistoken = instance->thistoken; + + switch (thistoken) { + case EOF: + break; + case '(': + p = parse_form(instance); + break; + case '\'': + p = parse_quote(instance); + break; + case ALISP_IDENTIFIER: + if (!strcmp(instance->token_buffer, "t")) + p = &alsa_lisp_t; + else if (!strcmp(instance->token_buffer, "nil")) + p = &alsa_lisp_nil; + else { + if ((p = search_object_identifier(instance, instance->token_buffer)) == NULL) { + p = new_object(instance, ALISP_OBJ_IDENTIFIER); + if (p) { + if ((p->value.id = strdup(instance->token_buffer)) == NULL) { + nomem(); + return NULL; + } + } + } + } + break; + case ALISP_INTEGER: + i = atoi(instance->token_buffer); + if ((p = search_object_integer(instance, i)) == NULL) { + p = new_object(instance, ALISP_OBJ_INTEGER); + if (p) + p->value.i = i; + } + break; + case ALISP_STRING: + if ((p = search_object_string(instance, instance->token_buffer)) == NULL) { + p = new_object(instance, ALISP_OBJ_STRING); + if (p) { + if ((p->value.s = strdup(instance->token_buffer)) == NULL) { + nomem(); + return NULL; + } + } + } + break; + default: + lisp_warn(instance, "%d:%d: unexpected character `%c'", instance->lineno, instance->charno, thistoken); + break; + } + + return p; +} + +/* + * object manipulation + */ + +static int set_object(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * value) +{ + struct alisp_object_pair *p; + + if (name->value.id == NULL) + return 0; + + for (p = instance->setobjs_list; p != NULL; p = p->next) + if (p->name->value.id != NULL && + !strcmp(name->value.id, p->name->value.id)) { + p->value = value; + return 0; + } + + p = (struct alisp_object_pair *)malloc(sizeof(struct alisp_object_pair)); + if (p == NULL) { + nomem(); + return -ENOMEM; + } + p->next = instance->setobjs_list; + instance->setobjs_list = p; + p->name = name; + p->value = value; + return 0; +} + +static struct alisp_object * get_object(struct alisp_instance *instance, struct alisp_object * name) +{ + struct alisp_object_pair *p; + + for (p = instance->setobjs_list; p != NULL; p = p->next) + if (p->name->value.id != NULL && + !strcmp(name->value.id, p->name->value.id)) + return p->value; + + return &alsa_lisp_nil; +} + +static void dump_objects(struct alisp_instance *instance, const char *fname) +{ + struct alisp_object_pair *p; + snd_output_t *out; + int err; + + if (!strcmp(fname, "-")) + err = snd_output_stdio_attach(&out, stdout, 0); + else + err = snd_output_stdio_open(&out, fname, "w+"); + if (err < 0) { + SNDERR("alisp: cannot open file '%s' for writting (%s)", fname, snd_strerror(errno)); + return; + } + + for (p = instance->setobjs_list; p != NULL; p = p->next) { + snd_output_printf(out, "(setq %s '", p->name->value.id); + princ_object(out, p->value); + snd_output_printf(out, ")\n"); + } + + snd_output_close(out); +} + +static const char *obj_type_str(struct alisp_object * p) +{ + switch (p->type) { + case ALISP_OBJ_NIL: return "nil"; + case ALISP_OBJ_T: return "t"; + case ALISP_OBJ_INTEGER: return "integer"; + case ALISP_OBJ_IDENTIFIER: return "identifier"; + case ALISP_OBJ_STRING: return "string"; + case ALISP_OBJ_CONS: return "cons"; + default: assert(0); + } +} + +static void print_obj_lists(struct alisp_instance *instance, snd_output_t *out) +{ + struct alisp_object * p; + + snd_output_printf(out, "** used objects"); + for (p = instance->used_objs_list; p != NULL; p = p->next) + snd_output_printf(out, "** %p (%s)", p, obj_type_str(p)); + snd_output_printf(out, "** free objects"); + for (p = instance->free_objs_list; p != NULL; p = p->next) + snd_output_printf(out, "** %p (%s)", p, obj_type_str(p)); +} + +static void dump_obj_lists(struct alisp_instance *instance, const char *fname) +{ + snd_output_t *out; + int err; + + if (!strcmp(fname, "-")) + err = snd_output_stdio_attach(&out, stdout, 0); + else + err = snd_output_stdio_open(&out, fname, "w+"); + if (err < 0) { + SNDERR("alisp: cannot open file '%s' for writting (%s)", fname, snd_strerror(errno)); + return; + } + + print_obj_lists(instance, out); + + snd_output_close(out); +} + +/* + * garbage collection + */ + +static void tag_tree(struct alisp_instance *instance, struct alisp_object * p) +{ + if (p->gc == instance->gc_id) + return; + + p->gc = instance->gc_id; + + if (p->type == ALISP_OBJ_CONS) { + tag_tree(instance, p->value.c.car); + tag_tree(instance, p->value.c.cdr); + } +} + +static void tag_whole_tree(struct alisp_instance *instance) +{ + struct alisp_object_pair *p; + + for (p = instance->setobjs_list; p != NULL; p = p->next) { + tag_tree(instance, p->name); + tag_tree(instance, p->value); + } +} + +static void do_garbage_collect(struct alisp_instance *instance) +{ + struct alisp_object * p, * new_used_objs_list = NULL, * next; + + tag_whole_tree(instance); + + /* + * Search in the object vector. + */ + for (p = instance->used_objs_list; p != NULL; p = next) { + next = p->next; + if (p->gc != instance->gc_id) { + /* Remove unreferenced object. */ + lisp_debug(instance, "** collecting cons %p", p); + switch (p->type) { + case ALISP_OBJ_STRING: + free(p->value.s); + break; + case ALISP_OBJ_IDENTIFIER: + free(p->value.id); + break; + } + + p->next = instance->free_objs_list; + instance->free_objs_list = p; + + ++instance->free_objs; + --instance->used_objs; + } else { + /* The object is referenced somewhere. */ + p->next = new_used_objs_list; + new_used_objs_list = p; + } + } + + instance->used_objs_list = new_used_objs_list; +} + +static void garbage_collect(struct alisp_instance *instance) +{ + if (++instance->gc_id == INT_MAX) + instance->gc_id = 1; + do_garbage_collect(instance); +} + +/* + * functions + */ + +static int count_list(struct alisp_object * p) +{ + int i = 0; + + while (p != &alsa_lisp_nil && p->type == ALISP_OBJ_CONS) + p = p->value.c.cdr, ++i; + + return i; +} + +static inline struct alisp_object * car(struct alisp_object * p) +{ + if (p->type == ALISP_OBJ_CONS) + return p->value.c.car; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (car expr) + */ +static struct alisp_object * F_car(struct alisp_instance *instance, struct alisp_object * args) +{ + return car(eval(instance, car(args))); +} + +static inline struct alisp_object * cdr(struct alisp_object * p) +{ + if (p->type == ALISP_OBJ_CONS) + return p->value.c.cdr; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (cdr expr) + */ +static struct alisp_object * F_cdr(struct alisp_instance *instance, struct alisp_object * args) +{ + return cdr(eval(instance, car(args))); +} + +/* + * Syntax: (+ expr...) + */ +static struct alisp_object * F_add(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + int v = 0; + + do { + p1 = eval(instance, car(p)); + if (p1->type == ALISP_OBJ_INTEGER) + v += p1->value.i; + else + lisp_warn(instance, "sum with a non integer operand"); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + p1 = new_object(instance, ALISP_OBJ_INTEGER); + if (p1) + p1->value.i = v; + + return p1; +} + +/* + * Syntax: (- expr...) + */ +static struct alisp_object * F_sub(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + int v = 0; + + do { + p1 = eval(instance, car(p)); + if (p1->type == ALISP_OBJ_INTEGER) { + if (p == args && cdr(p) != &alsa_lisp_nil) + v = p1->value.i; + else + v -= p1->value.i; + } else + lisp_warn(instance, "difference with a non integer operand"); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + p1 = new_object(instance, ALISP_OBJ_INTEGER); + if (p1) + p1->value.i = v; + + return p1; +} + +/* + * Syntax: (* expr...) + */ +static struct alisp_object * F_mul(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + int v = 1; + + do { + p1 = eval(instance, car(p)); + if (p1->type == ALISP_OBJ_INTEGER) + v *= p1->value.i; + else + lisp_warn(instance, "product with a non integer operand"); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + p1 = new_object(instance, ALISP_OBJ_INTEGER); + if (p1) + p1->value.i = v; + + return p1; +} + +/* + * Syntax: (/ expr...) + */ +static struct alisp_object * F_div(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + int v = 0; + + do { + p1 = eval(instance, car(p)); + if (p1->type == ALISP_OBJ_INTEGER) { + if (p == args && cdr(p) != &alsa_lisp_nil) + v = p1->value.i; + else { + if (p1->value.i == 0) { + lisp_warn(instance, "division by zero"); + v = 0; + break; + } else + v /= p1->value.i; + } + } else + lisp_warn(instance, "quotient with a non integer operand"); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + p1 = new_object(instance, ALISP_OBJ_INTEGER); + if (p1) + p1->value.i = v; + + return p1; +} + +/* + * Syntax: (% expr1 expr2) + */ +static struct alisp_object * F_mod(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2, * p3; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "module with a non integer operand"); + return &alsa_lisp_nil; + } + + p3 = new_object(instance, ALISP_OBJ_INTEGER); + if (p2->value.i == 0) { + lisp_warn(instance, "module by zero"); + if (p3) + p3->value.i = 0; + } else + if (p3) + p3->value.i = p1->value.i % p2->value.i; + + return p3; +} + +/* + * Syntax: (< expr1 expr2) + */ +static struct alisp_object * F_lt(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "comparison with a non integer operand"); + return &alsa_lisp_nil; + } + + if (p1->value.i < p2->value.i) + return &alsa_lisp_t; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (> expr1 expr2) + */ +static struct alisp_object * F_gt(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "comparison with a non integer operand"); + return &alsa_lisp_nil; + } + + if (p1->value.i > p2->value.i) + return &alsa_lisp_t; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (<= expr1 expr2) + */ +static struct alisp_object * F_le(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "comparison with a non integer operand"); + return &alsa_lisp_nil; + } + + if (p1->value.i <= p2->value.i) + return &alsa_lisp_t; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (>= expr1 expr2) + */ +static struct alisp_object * F_ge(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "comparison with a non integer operand"); + return &alsa_lisp_nil; + } + + if (p1->value.i >= p2->value.i) + return &alsa_lisp_t; + + return &alsa_lisp_nil; +} + +/* + * Syntax: (= expr1 expr2) + */ +static struct alisp_object * F_numeq(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1->type != ALISP_OBJ_INTEGER || p2->type != ALISP_OBJ_INTEGER) { + lisp_warn(instance, "comparison with a non integer operand"); + return &alsa_lisp_nil; + } + + if (p1->value.i == p2->value.i) + return &alsa_lisp_t; + + return &alsa_lisp_nil; +} + +static void princ_string(snd_output_t *out, char *s) +{ + char *p; + + snd_output_putc(out, '"'); + for (p = s; *p != '\0'; ++p) + switch (*p) { + case '\a': snd_output_putc(out, '\\'); snd_output_putc(out, 'a'); break; + case '\b': snd_output_putc(out, '\\'); snd_output_putc(out, 'b'); break; + case '\f': snd_output_putc(out, '\\'); snd_output_putc(out, 'f'); break; + case '\n': snd_output_putc(out, '\\'); snd_output_putc(out, 'n'); break; + case '\r': snd_output_putc(out, '\\'); snd_output_putc(out, 'r'); break; + case '\t': snd_output_putc(out, '\\'); snd_output_putc(out, 't'); break; + case '\v': snd_output_putc(out, '\\'); snd_output_putc(out, 'v'); break; + default: snd_output_putc(out, *p); + } + snd_output_putc(out, '"'); +} + +static void princ_object(snd_output_t *out, struct alisp_object * p) +{ + struct alisp_object * p1; + + switch (p->type) { + case ALISP_OBJ_NIL: + snd_output_printf(out, "nil"); + break; + case ALISP_OBJ_T: + snd_output_putc(out, 't'); + break; + case ALISP_OBJ_IDENTIFIER: + snd_output_printf(out, "%s", p->value.id); + break; + case ALISP_OBJ_STRING: + princ_string(out, p->value.s); + break; + case ALISP_OBJ_INTEGER: + snd_output_printf(out, "%d", p->value.i); + break; + case ALISP_OBJ_CONS: + snd_output_putc(out, '('); + p1 = p; + do { + princ_object(out, p1->value.c.car); + p1 = p1->value.c.cdr; + if (p1 != &alsa_lisp_nil) { + snd_output_putc(out, ' '); + if (p1->type != ALISP_OBJ_CONS) { + snd_output_printf(out, ". "); + princ_object(out, p1); + } + } + } while (p1 != &alsa_lisp_nil && p1->type == ALISP_OBJ_CONS); + snd_output_putc(out, ')'); + } +} + +/* + * Syntax: (princ expr...) + */ +static struct alisp_object * F_princ(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + + do { + p1 = eval(instance, car(p)); + if (p1->type == ALISP_OBJ_STRING) + snd_output_printf(instance->out, "%s", p1->value.s); + else + princ_object(instance->out, p1); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return p1; +} + +/* + * Syntax: (atom expr) + */ +static struct alisp_object * F_atom(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p; + + p = eval(instance, car(args)); + + switch (p->type) { + case ALISP_OBJ_T: + case ALISP_OBJ_NIL: + case ALISP_OBJ_INTEGER: + case ALISP_OBJ_STRING: + case ALISP_OBJ_IDENTIFIER: + return &alsa_lisp_t; + } + + return &alsa_lisp_nil; +} + +/* + * Syntax: (cons expr1 expr2) + */ +static struct alisp_object * F_cons(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p; + + p = new_object(instance, ALISP_OBJ_CONS); + if (p) { + p->value.c.car = eval(instance, car(args)); + p->value.c.cdr = eval(instance, car(cdr(args))); + } + + return p; +} + +/* + * Syntax: (list expr1...) + */ +static struct alisp_object * F_list(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * first = NULL, * prev = NULL, * p1; + + if (p == &alsa_lisp_nil) + return &alsa_lisp_nil; + + do { + p1 = new_object(instance, ALISP_OBJ_CONS); + if (p1 == NULL) + return NULL; + p1->value.c.car = eval(instance, car(p)); + if (first == NULL) + first = p1; + if (prev != NULL) + prev->value.c.cdr = p1; + prev = p1; + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return first; +} + +/* + * Syntax: (eq expr1 expr2) + */ +static struct alisp_object * F_eq(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = eval(instance, car(args)); + p2 = eval(instance, car(cdr(args))); + + if (p1 == p2) + return &alsa_lisp_t; + + if (p1->type == ALISP_OBJ_CONS || p2->type == ALISP_OBJ_CONS) + return &alsa_lisp_nil; + + if (p1->type == p2->type) + switch (p1->type) { + case ALISP_IDENTIFIER: + if (!strcmp(p1->value.id, p2->value.id)) + return &alsa_lisp_t; + return &alsa_lisp_nil; + case ALISP_OBJ_STRING: + if (!strcmp(p1->value.s, p2->value.s)) + return &alsa_lisp_t; + return &alsa_lisp_nil; + case ALISP_OBJ_INTEGER: + if (p1->value.i == p2->value.i) + return &alsa_lisp_t; + return &alsa_lisp_nil; + } + + return &alsa_lisp_nil; +} + +/* + * Syntax: (quote expr) + */ +static struct alisp_object * F_quote(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * args) +{ + return car(args); +} + +/* + * Syntax: (and expr...) + */ +static struct alisp_object * F_and(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + + do { + p1 = eval(instance, car(p)); + if (p1 == &alsa_lisp_nil) + return &alsa_lisp_nil; + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return p1; +} + +/* + * Syntax: (or expr...) + */ +static struct alisp_object * F_or(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + + do { + p1 = eval(instance, car(p)); + if (p1 != &alsa_lisp_nil) + return p1; + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return &alsa_lisp_nil; +} + +/* + * Syntax: (not expr) + * Syntax: (null expr) + */ +static struct alisp_object * F_not(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = eval(instance, car(args)); + + if (p != &alsa_lisp_nil) + return &alsa_lisp_nil; + + return &alsa_lisp_t; +} + +/* + * Syntax: (cond (expr1 [expr2])...) + */ +static struct alisp_object * F_cond(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1, * p2, * p3; + + do { + p1 = car(p); + if ((p2 = eval(instance, car(p1))) != &alsa_lisp_nil) { + if ((p3 = cdr(p1)) != &alsa_lisp_nil) + return F_progn(instance, p3); + return p2; + } + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return &alsa_lisp_nil; +} + +/* + * Syntax: (if expr then-expr else-expr...) + */ +static struct alisp_object * F_if(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2, * p3; + + p1 = car(args); + p2 = car(cdr(args)); + p3 = cdr(cdr(args)); + + if (eval(instance, p1) != &alsa_lisp_nil) + return eval(instance, p2); + + return F_progn(instance, p3); +} + +/* + * Syntax: (when expr then-expr...) + */ +static struct alisp_object * F_when(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = car(args); + p2 = cdr(args); + if (eval(instance, p1) != &alsa_lisp_nil) + return F_progn(instance, p2); + + return &alsa_lisp_nil; +} + +/* + * Syntax: (unless expr else-expr...) + */ +static struct alisp_object * F_unless(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = car(args); + p2 = cdr(args); + if (eval(instance, p1) == &alsa_lisp_nil) + return F_progn(instance, p2); + + return &alsa_lisp_nil; +} + +/* + * Syntax: (while expr exprs...) + */ +static struct alisp_object * F_while(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1, * p2; + + p1 = car(args); + p2 = cdr(args); + + while (eval(instance, p1) != &alsa_lisp_nil) + F_progn(instance, p2); + + return &alsa_lisp_nil; +} + +/* + * Syntax: (progn expr...) + */ +static struct alisp_object * F_progn(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1; + + do { + p1 = eval(instance, car(p)); + p = cdr(p); + } while (p != &alsa_lisp_nil); + + return p1; +} + +/* + * Syntax: (prog1 expr...) + */ +static struct alisp_object * F_prog1(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * first = NULL, * p1; + + do { + p1 = eval(instance, car(p)); + if (first == NULL) + first = p1; + p = cdr(p); + } while (p != &alsa_lisp_nil); + + if (first == NULL) + first = &alsa_lisp_nil; + + return first; +} + +/* + * Syntax: (prog2 expr...) + */ +static struct alisp_object * F_prog2(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * second = NULL, * p1; + int i = 0; + + do { + ++i; + p1 = eval(instance, car(p)); + if (i == 2) + second = p1; + p = cdr(p); + } while (p != &alsa_lisp_nil); + + if (second == NULL) + second = &alsa_lisp_nil; + + return second; +} + +/* + * Syntax: (set name value) + */ +static struct alisp_object * F_set(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1 = eval(instance, car(args)), * p2 = eval(instance, car(cdr(args))); + + if (p1 == &alsa_lisp_nil) { + lisp_warn(instance, "setting the value of a nil object"); + } else + if (set_object(instance, p1, p2)) + return NULL; + + return p2; +} + +/* + * Syntax: (setq name value...) + * Syntax: (setf name value...) + * `name' is not evalled + */ +static struct alisp_object * F_setq(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = args, * p1, * p2; + + do { + p1 = car(p); + p2 = eval(instance, car(cdr(p))); + if (set_object(instance, p1, p2)) + return NULL; + p = cdr(cdr(p)); + } while (p != &alsa_lisp_nil); + + return p2; +} + +/* + * Syntax: (defun name arglist expr...) + * `name' is not evalled + * `arglist' is not evalled + */ +static struct alisp_object * F_defun(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p1 = car(args), * p2 = car(cdr(args)), * p3 = cdr(cdr(args)); + struct alisp_object * lexpr; + + lexpr = new_object(instance, ALISP_OBJ_CONS); + if (lexpr) { + lexpr->value.c.car = new_object(instance, ALISP_IDENTIFIER); + if (lexpr->value.c.car == NULL) + return NULL; + if ((lexpr->value.c.car->value.id = strdup("lambda")) == NULL) { + nomem(); + return NULL; + } + if ((lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS)) == NULL) + return NULL; + lexpr->value.c.cdr->value.c.car = p2; + lexpr->value.c.cdr->value.c.cdr = p3; + + if (set_object(instance, p1, lexpr)) + return NULL; + } + + return lexpr; +} + +static struct alisp_object * eval_func(struct alisp_instance *instance, struct alisp_object * p, struct alisp_object * args) +{ + struct alisp_object * p1, * p2, * p3, * p4, * p5; + struct alisp_object * eval_objs[64], * save_objs[64]; + int i; + + p1 = car(p); + if (p1->type == ALISP_IDENTIFIER && !strcmp(p1->value.id, "lambda")) { + p2 = car(cdr(p)); + p3 = args; + + if (count_list(p2) != count_list(p3)) { + lisp_warn(instance, "wrong number of parameters"); + return &alsa_lisp_nil; + } + + /* + * Save the new variable values. + */ + i = 0; + do { + p5 = eval(instance, car(p3)); + eval_objs[i++] = p5; + p3 = cdr(p3); + } while (p3 != &alsa_lisp_nil); + + /* + * Save the old variable values and set the new ones. + */ + i = 0; + do { + p4 = car(p2); + save_objs[i] = get_object(instance, p4); + if (set_object(instance, p4, eval_objs[i])) + return NULL; + p2 = cdr(p2); + ++i; + } while (p2 != &alsa_lisp_nil); + + p5 = F_progn(instance, cdr(cdr(p))); + + /* + * Restore the old variable values. + */ + p2 = car(cdr(p)); + i = 0; + do { + p4 = car(p2); + if (set_object(instance, p4, save_objs[i++])) + return NULL; + p2 = cdr(p2); + } while (p2 != &alsa_lisp_nil); + + return p5; + } + + return &alsa_lisp_nil; +} + +struct alisp_object * F_gc(struct alisp_instance *instance, struct alisp_object * args ATTRIBUTE_UNUSED) +{ + garbage_collect(instance); + + return &alsa_lisp_t; +} + +static struct alisp_object * F_dump_memory(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = car(args); + + if (p != &alsa_lisp_nil && cdr(args) == &alsa_lisp_nil && p->type == ALISP_OBJ_STRING) { + if (strlen(p->value.s) > 0) { + dump_objects(instance, p->value.s); + return &alsa_lisp_t; + } else + lisp_warn(instance, "expected filename"); + } else + lisp_warn(instance, "wrong number of parameters (expected string)"); + + return &alsa_lisp_nil; +} + +static struct alisp_object * F_dump_objects(struct alisp_instance *instance, struct alisp_object * args) +{ + struct alisp_object * p = car(args); + + if (p != &alsa_lisp_nil && cdr(args) == &alsa_lisp_nil && p->type == ALISP_OBJ_STRING) { + if (strlen(p->value.s) > 0) { + dump_obj_lists(instance, p->value.s); + return &alsa_lisp_t; + } else + lisp_warn(instance, "expected filename"); + } else + lisp_warn(instance, "wrong number of parameters (expected string)"); + + return &alsa_lisp_nil; +} + +struct intrinsic { + const char *name; + struct alisp_object * (*func)(struct alisp_instance *instance, struct alisp_object * args); +}; + +static struct intrinsic intrinsics[] = { + { "%", F_mod }, + { "&dump-memory", F_dump_memory }, + { "&dump-objects", F_dump_objects }, + { "*", F_mul }, + { "+", F_add }, + { "-", F_sub }, + { "/", F_div }, + { "<", F_lt }, + { "<=", F_le }, + { "=", F_numeq }, + { ">", F_gt }, + { ">=", F_ge }, + { "and", F_and }, + { "atom", F_atom }, + { "car", F_car }, + { "cdr", F_cdr }, + { "cond", F_cond }, + { "cons", F_cons }, + { "defun", F_defun }, + { "eq", F_eq }, + { "eval", F_eval }, + { "garbage-collect", F_gc }, + { "gc", F_gc }, + { "if", F_if }, + { "list", F_list }, + { "not", F_not }, + { "null", F_not }, + { "or", F_or }, + { "princ", F_princ }, + { "prog1", F_prog1 }, + { "prog2", F_prog2 }, + { "progn", F_progn }, + { "quote", F_quote }, + { "set", F_set }, + { "setf", F_setq }, + { "setq", F_setq }, + { "unless", F_unless }, + { "when", F_when }, + { "while", F_while }, +}; + +static int compar(const void *p1, const void *p2) +{ + return strcmp(((struct intrinsic *)p1)->name, + ((struct intrinsic *)p2)->name); +} + +static struct alisp_object * eval_cons(struct alisp_instance *instance, struct alisp_object * p) +{ + struct alisp_object * p1 = car(p), * p2 = cdr(p), * p3; + + if (p1 != &alsa_lisp_nil && p1->type == ALISP_IDENTIFIER) { + struct intrinsic key, *item; + + if (!strcmp(p1->value.id, "lambda")) + return p; + key.name = p1->value.id; + if ((item = bsearch(&key, intrinsics, + sizeof intrinsics / sizeof intrinsics[0], + sizeof intrinsics[0], compar)) != NULL) + return item->func(instance, p2); + + if ((p3 = get_object(instance, p1)) != &alsa_lisp_nil) + return eval_func(instance, p3, p2); + else + lisp_warn(instance, "function `%s' is undefined", p1->value.id); + } + + return &alsa_lisp_nil; +} + +static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p) +{ + switch (p->type) { + case ALISP_OBJ_IDENTIFIER: + return get_object(instance, p); + case ALISP_OBJ_INTEGER: + case ALISP_OBJ_STRING: + return p; + case ALISP_OBJ_CONS: + return eval_cons(instance, p); + } + + return p; +} + +static struct alisp_object * F_eval(struct alisp_instance *instance, struct alisp_object * args) +{ + return eval(instance, eval(instance, car(args))); +} + +/* + * main routine + */ + +int alsa_lisp(struct alisp_cfg *cfg) +{ + struct alisp_instance *instance; + struct alisp_object *p, *p1; + + instance = (struct alisp_instance *)malloc(sizeof(struct alisp_instance)); + if (instance == NULL) { + nomem(); + return -ENOMEM; + } + instance->verbose = cfg->verbose && cfg->vout; + instance->warning = cfg->warning && cfg->wout; + instance->debug = cfg->debug && cfg->dout; + instance->in = cfg->in; + instance->out = cfg->out; + instance->vout = cfg->vout; + instance->wout = cfg->wout; + instance->dout = cfg->dout; + + init_lex(instance); + + for (;;) { + if ((p = parse_object(instance, 0)) == NULL) + break; + if (instance->verbose) + princ_object(instance->vout, p); + p1 = eval(instance, p); + if (instance->verbose) + princ_object(instance->vout, p1); + if (instance->debug) { + lisp_debug(instance, "** objects before collection"); + print_obj_lists(instance, instance->dout); + } + garbage_collect(instance); + if (instance->debug) { + lisp_debug(instance, "** objects after collection"); + print_obj_lists(instance, instance->dout); + } + } + + done_lex(instance); + free(instance); + + return 0; +} diff --git a/src/alisp/alisp_local.h b/src/alisp/alisp_local.h new file mode 100644 index 00000000..d5361e9c --- /dev/null +++ b/src/alisp/alisp_local.h @@ -0,0 +1,92 @@ +/* + * ALSA lisp implementation + * Copyright (c) 2003 by Jaroslav Kysela <perex@suse.cz> + * + * Based on work of Sandro Sigala (slisp-1.2) + * + * + * This library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation; either version 2.1 of + * the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + */ + +enum alisp_tokens { + ALISP_IDENTIFIER, + ALISP_INTEGER, + ALISP_STRING +}; + +enum alisp_objects { + ALISP_OBJ_NIL, + ALISP_OBJ_T, + ALISP_OBJ_INTEGER, + ALISP_OBJ_IDENTIFIER, + ALISP_OBJ_STRING, + ALISP_OBJ_CONS +}; + +struct alisp_object { + int type; + int gc; + union { + char *id; + char *s; + int i; + struct { + struct alisp_object *car; + struct alisp_object *cdr; + } c; + } value; + struct alisp_object *next; +}; + +struct alisp_object_pair { + struct alisp_object *name; + struct alisp_object *value; + struct alisp_object_pair *next; +}; + +#define ALISP_LEX_BUF_MAX 16 + +struct alisp_instance { + int verbose: 1, + warning: 1, + debug: 1; + /* i/o */ + snd_input_t *in; + snd_output_t *out; + snd_output_t *vout; /* verbose output */ + snd_output_t *wout; /* warning output */ + snd_output_t *dout; /* debug output */ + /* lexer */ + int charno; + int lineno; + int lex_buf[ALISP_LEX_BUF_MAX]; + int *lex_bufp; + char *token_buffer; + int token_buffer_max; + int thistoken; + /* object allocator */ + int free_objs; + int used_objs; + struct alisp_object *free_objs_list; + struct alisp_object *used_objs_list; + /* set object */ + struct alisp_object_pair *setobjs_list; + /* garbage collect */ + int gc_id; + /* alsa configuration */ + snd_config_t *root; /* configuration root */ + snd_config_t *node; /* result */ +}; diff --git a/src/output.c b/src/output.c index 2804b20f..3bf112f3 100644 --- a/src/output.c +++ b/src/output.c @@ -79,6 +79,18 @@ int snd_output_printf(snd_output_t *output, const char *format, ...) } /** + * \brief Writes formatted output (like \c fprintf(3)) to an output handle. + * \param output The output handle. + * \param format Format string in \c fprintf format. + * \param args Other \c fprintf arguments. + * \return The number of characters written, or a negative error code. + */ +int snd_output_vprintf(snd_output_t *output, const char *format, va_list args) +{ + return output->ops->print(output, format, args); +} + +/** * \brief Writes a string to an output handle (like \c fputs(3)). * \param output The output handle. * \param str Pointer to the string. |