Update of /cvsroot/alsa/alsa-lib/src/alisp
In directory sc8-pr-cvs1:/tmp/cvs-serv25356/src/alisp
Added Files:
.cvsignore Makefile.am alisp.c alisp_local.h
Log Message:
Initial code for lisp interpreter
--- NEW FILE: .cvsignore ---
.deps
.libs
Makefile
Makefile.in
*.la
*.lo
--- NEW FILE: Makefile.am ---
EXTRA_LTLIBRARIES = libalisp.la
libalisp_la_SOURCES = alisp.c
noinst_HEADERS = alisp_local.h
all: libalisp.la
INCLUDES=-I$(top_srcdir)/include
--- NEW FILE: alisp.c ---
/*
* ALSA lisp implementation
* Copyright (c) 2003 by Jaroslav Kysela <[EMAIL PROTECTED]>
*
* 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;
}
--- NEW FILE: alisp_local.h ---
/*
* ALSA lisp implementation
* Copyright (c) 2003 by Jaroslav Kysela <[EMAIL PROTECTED]>
*
* 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 */
};
-------------------------------------------------------
This SF.Net email is sponsored by: INetU
Attention Web Developers & Consultants: Become An INetU Hosting Partner.
Refer Dedicated Servers. We Manage Them. You Get 10% Monthly Commission!
INetU Dedicated Managed Hosting http://www.inetu.net/partner/index.php
_______________________________________________
Alsa-cvslog mailing list
[EMAIL PROTECTED]
https://lists.sourceforge.net/lists/listinfo/alsa-cvslog
