diff --git a/.gitignore b/.gitignore index 3c0791f5..80d3f8b7 100644 --- a/.gitignore +++ b/.gitignore @@ -35,7 +35,6 @@ include/version.h include/alsa include/asoundlib.h utils/alsa-lib.spec -alsalisp/alsalisp aserver/aserver m4/libtool.m4 m4/ltoptions.m4 diff --git a/Makefile.am b/Makefile.am index ff4c963a..5bcef999 100644 --- a/Makefile.am +++ b/Makefile.am @@ -10,11 +10,6 @@ endif if BUILD_PCM_PLUGIN_SHM SUBDIRS += aserver endif -if BUILD_MIXER -if BUILD_ALISP -SUBDIRS += alsalisp -endif -endif SUBDIRS += test utils EXTRA_DIST=README.md ChangeLog INSTALL TODO NOTES configure gitcompile libtool \ depcomp version MEMORY-LEAK m4/attributes.m4 diff --git a/alsalisp/Makefile.am b/alsalisp/Makefile.am deleted file mode 100644 index 8e3e0159..00000000 --- a/alsalisp/Makefile.am +++ /dev/null @@ -1,8 +0,0 @@ -noinst_PROGRAMS = alsalisp - -alsalisp_SOURCES = alsalisp.c -alsalisp_LDADD = ../src/libasound.la - -all: alsalisp - -AM_CPPFLAGS=-I$(top_srcdir)/include -I$(top_srcdir)/src/alisp diff --git a/alsalisp/alsalisp.c b/alsalisp/alsalisp.c deleted file mode 100644 index d1e1bce2..00000000 --- a/alsalisp/alsalisp.c +++ /dev/null @@ -1,110 +0,0 @@ -/* - * ALSA lisp implementation - * Copyright (c) 2003 by Jaroslav Kysela - * - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - */ - -#include -#include -#include -#include -#include - -#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; - 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; - } - cfg.verbose = verbose; - cfg.warning = warning; - cfg.debug = debug; - cfg.in = in; - cfg.out = cfg.eout = cfg.vout = cfg.wout = cfg.dout = out; - err = alsa_lisp(&cfg, NULL); - 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\n", file); - snd_output_close(out); - snd_input_close(in); -} - -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/alsalisp/hctl.lisp b/alsalisp/hctl.lisp deleted file mode 100644 index 504050f6..00000000 --- a/alsalisp/hctl.lisp +++ /dev/null @@ -1,91 +0,0 @@ -(setq card (Acall 'card_next -1)) -(setq card (Aresult card)) -(while (>= card 0) - (progn - (princ "found card: " card "\n") - (princ " name : " (Aresult (Acall 'card_get_name card)) "\n") - (princ " longname: " (Aresult (Acall 'card_get_longname card)) "\n") - (setq card (Acall 'card_next card)) - (setq card (Aresult card)) - ) -) -(unsetq card) - -(princ "card_get_index test (SI7018): " (Acall 'card_get_index "SI7018") "\n") -(princ "card_get_index test (ABCD): " (Acall 'card_get_index "ABCD") "\n") - -(setq hctl (Acall 'hctl_open 'default nil)) -(if (= (Aerror hctl) 0) - (progn - (princ "open success: " hctl "\n") - (setq hctl (Ahandle hctl)) - (princ "open hctl: " hctl "\n") - (setq hctl (Acall 'hctl_close hctl)) - (if (= hctl 0) - (princ "close success\n") - (princ "close failed: " hctl "\n") - ) - ) - (progn - (princ "open failed: " hctl "\n") - ) -) -(unsetq hctl) - -(setq ctl (Acall 'ctl_open 'default nil)) -(if (= (Aerror ctl) 0) - (progn - (princ "ctl open success: " ctl "\n") - (setq ctl (Ahandle ctl)) - (setq info (Aresult (Acall 'ctl_card_info ctl))) - (princ "ctl card info: " info "\n") - (princ "ctl card info (mixername): " (cdr (assq "mixername" info)) "\n") - (unsetq info) - (setq hctl (Acall 'hctl_open_ctl ctl)) - (if (= (Aerror hctl) 0) - (progn - (princ "hctl open success: " hctl "\n") - (setq hctl (Ahandle hctl)) - (princ "open hctl: " hctl "\n") - (princ "load hctl: " (Acall 'hctl_load hctl) "\n") - (princ "first : " (Acall 'hctl_first_elem hctl) "\n") - (princ "last : " (Acall 'hctl_last_elem hctl) "\n") - (princ "next (first): " (Acall 'hctl_elem_next (Acall 'hctl_first_elem hctl)) "\n") - (princ "prev (last) : " (Acall 'hctl_elem_prev (Acall 'hctl_last_elem hctl)) "\n") - (setq elem (Acall 'hctl_first_elem hctl)) - (while elem - (progn - (setq info (Acall 'hctl_elem_info elem)) - (princ info "\n") - (setq value (Acall 'hctl_elem_read elem)) - (princ value "\n") - (when (equal (cdr (assq "name" (car (cdr (assq "id" (Aresult info)))))) "Master Playback Volume") - (princ "write Master: " (Acall 'hctl_elem_write elem (20 20)) "\n") - ) - (unsetq info value) - (gc) - (setq elem (Acall 'hctl_elem_next elem)) - ) - ) - (unsetq elem) - (setq hctl (Acall 'hctl_close hctl)) - (if (= hctl 0) - (princ "hctl close success\n") - (princ "hctl close failed: " hctl "\n") - ) - ) - (progn - (princ "hctl open failed: " hctl "\n") - (Acall 'ctl_close ctl) - ) - ) - (unsetq hctl) - ) - (progn - (princ "ctl open failed: " ctl "\n") - ) -) -(unsetq ctl) - -(&stat-memory) -(&dump-memory "memory.dump") diff --git a/alsalisp/hello.lisp b/alsalisp/hello.lisp deleted file mode 100644 index f04fc381..00000000 --- a/alsalisp/hello.lisp +++ /dev/null @@ -1,26 +0,0 @@ -(princ "Hello ALSA world\n") -(princ "One " 1 "\n") -(princ "Two " (+ 1 1) "\n") - -(defun myprinc (o) (progn (princ o))) -(myprinc "Printed via myprinc function!\n") -(unsetq myprinc) - -(defun printnum (from to) (while (<= from to) (princ " " from) (setq from (+ from 1)))) -(princ "Numbers 1-10: ") (printnum 1 10) (princ "\n") -(unsetq printnum) - -(defun factorial (n) (if (> n 1) (* n (factorial (- n 1))) 1)) -(princ "Factorial of 10: " (factorial 10) "\n") -(princ "Float test 1.1 + 1.35 = " (+ 1.1 1.35) "\n") -(princ "Factorial of 10.0: " (factorial 10.0) "\n") -(princ "Factorial of 20.0: " (factorial 20.0) "\n") -(unsetq factorial) - -(setq alist '((one . first) (two . second) (three . third))) -(princ "alist = " alist "\n") -(princ "alist assoc one = " (assoc 'one alist) "\n") -(princ "alist rassoc third = " (rassoc 'third alist) "\n") -(unsetq alist) - -(&stat-memory) diff --git a/alsalisp/itest.lisp b/alsalisp/itest.lisp deleted file mode 100644 index decd9ae7..00000000 --- a/alsalisp/itest.lisp +++ /dev/null @@ -1 +0,0 @@ -(princ "itest.lisp file included!\n") diff --git a/alsalisp/test.lisp b/alsalisp/test.lisp deleted file mode 100644 index 5e3820f4..00000000 --- a/alsalisp/test.lisp +++ /dev/null @@ -1,382 +0,0 @@ -; -; Test code for all basic alsa lisp commands. -; The test is indended to find memory leaks. -; -; Copyright (c) 2003 Jaroslav Kysela -; License: GPL v2 (http://www.gnu.org/licenses/gpl.html) -; - -; -; Basic commands -; - -(!=) (&check-memory) -(!= 0) (&check-memory) -(!= 0 1) (&check-memory) -(!= 1 1) (&check-memory) -(!= 0 1 2) (&check-memory) -(!= 'aaaa 'bbbb) (&check-memory) - -(%) (&check-memory) -(% 11) (&check-memory) -(% 11 5) (&check-memory) -(% 11.5 5.1) (&check-memory) -(% 11.5 5.1 2.2) (&check-memory) -(% 'aaaa 'bbbb) (&check-memory) - -(&check-memory) (&check-memory) -(&check-memory "abcd") (&check-memory) -(&dump-memory "-") (&check-memory) -(&dump-memory) (&check-memory) -(&dump-objects "-") (&check-memory) -(&dump-objects) (&check-memory) -(&stat-memory) (&check-memory) -(&stat-memory "abcd") (&check-memory) - -(*) (&check-memory) -(* 1) (&check-memory) -(* 1 2) (&check-memory) -(* 1.1 2.2) (&check-memory) -(* 1.1 2.2 3.3) (&check-memory) -(* 'aaaa) (&check-memory) - -(+) (&check-memory) -(+ 1) (&check-memory) -(+ 1 2) (&check-memory) -(+ 1.1 2.2) (&check-memory) -(+ 1.1 2.2 3.3) (&check-memory) -(+ 'aaaa) (&check-memory) -(+ 'aaaa 'bbbb) (&check-memory) -(+ "aaaa") (&check-memory) -(+ "aaaa" "bbbb") (&check-memory) -(+ "aaaa" "bbbb" "cccc") (&check-memory) - -(-) (&check-memory) -(- 1) (&check-memory) -(- 1 2) (&check-memory) -(- 1.1 2.2) (&check-memory) -(- 1.1 2.2 3.3) (&check-memory) -(- 'aaaa) (&check-memory) -(- 'aaaa 'bbbb) (&check-memory) - -(/) (&check-memory) -(/ 1) (&check-memory) -(/ 1 2) (&check-memory) -(/ 1.1 2.2) (&check-memory) -(/ 1.1 2.2 3.3) (&check-memory) -(/ 'aaaa) (&check-memory) -(/ 'aaaa 'bbbb) (&check-memory) - -(<) (&check-memory) -(< 0) (&check-memory) -(< 0 1) (&check-memory) -(< 1 0) (&check-memory) -(< 0 1 2) (&check-memory) - -(<=) (&check-memory) -(<= 0) (&check-memory) -(<= 0 1) (&check-memory) -(<= 1 0) (&check-memory) -(<= 0 1 2) (&check-memory) - -(=) (&check-memory) -(= 0) (&check-memory) -(= 0 1) (&check-memory) -(= 1 1) (&check-memory) -(= 0 1 2) (&check-memory) - -(>) (&check-memory) -(> 0) (&check-memory) -(> 0 1) (&check-memory) -(> 1 0) (&check-memory) -(> 0 1 2) (&check-memory) - -(>= 0) (&check-memory) -(>= 0 1) (&check-memory) -(>= 1 0) (&check-memory) -(>= 0 1 2) (&check-memory) - -(and) (&check-memory) -(and 0) (&check-memory) -(and 1) (&check-memory) -(and 0 0 0) (&check-memory) - -(quote a) (&check-memory) - -(assoc) (&check-memory) -(assoc 'one) (&check-memory) -(assoc 'one '((one . first))) (&check-memory) -(assoc 'one '((two . second))) (&check-memory) -(assoc 'one '((one . first) (two . second))) (&check-memory) - -(assq) (&check-memory) -(assq 'one) (&check-memory) -(assq "one" '(("one" . "first"))) (&check-memory) -(assq "one" '(("two" . "second"))) (&check-memory) -(assq "one" '(("one" . "first") ("two" . "second"))) (&check-memory) - -(atom) (&check-memory) -(atom 'one) (&check-memory) -(atom "one") (&check-memory) -(atom "one" 'two) (&check-memory) - -(funcall) (&check-memory) - -(car) (&check-memory) -(car '(one . two)) (&check-memory) - -(cdr) (&check-memory) -(cdr '(one . two)) (&check-memory) - -(concat) (&check-memory) -(concat 'aaaa) (&check-memory) -(concat 'aaaa 'bbbb) (&check-memory) -(concat "aaaa") (&check-memory) -(concat "aaaa" "bbbb") (&check-memory) -(concat "aaaa" "bbbb" "cccc") (&check-memory) - -(cond) (&check-memory) -(cond 0) (&check-memory) -(cond 0 1) (&check-memory) -(cond 0 1 2) (&check-memory) -(cond 0 1 2 3) (&check-memory) -(cond (0 'a) (1 'b) (0 'd)) (&check-memory) -(cond 1) (&check-memory) -(cond 1 1) (&check-memory) -(cond 1 1 2) (&check-memory) -(cond 1 1 2 3) (&check-memory) - -(cons) (&check-memory) -(cons "a") (&check-memory) -(cons "a" "b") (&check-memory) -(cons "a" "b" "c") (&check-memory) - -(eq) (&check-memory) -(eq 1) (&check-memory) -(eq 0 0) (&check-memory) -(eq "a" "b") (&check-memory) -(eq "a" "b" "c") (&check-memory) - -(equal) (&check-memory) -(equal 1) (&check-memory) -(equal 0 0) (&check-memory) -(equal "a" "b") (&check-memory) -(equal "a" "b" "c") (&check-memory) - -(exfun) (&check-memory) -(exfun 'abcd) (&check-memory) -(exfun 'abcd 'ijkl) (&check-memory) - -(format) (&check-memory) -(format 1) (&check-memory) -(format 'a) (&check-memory) -(format "a" "b" "c") (&check-memory) -(format "1.2") (&check-memory) -(format "%c" 43) (&check-memory) -(format "%d" 12) (&check-memory) -(format "%i" 12) (&check-memory) -(format "%f" 12.1) (&check-memory) -(format "%s" "abcd") (&check-memory) -(format "%s %i %i" "abcd" 1 2) (&check-memory) - -(garbage-collect) (&check-memory) -(gc) (&check-memory) - -(if) (&check-memory) -(if t) (&check-memory) -(if t 'a) (&check-memory) -(if t 'a 'b) (&check-memory) -(if nil) (&check-memory) -(if nil 'a) (&check-memory) -(if nil 'a 'b) (&check-memory) - -(include "itest.lisp") (&check-memory) - -(list) (&check-memory) -(list "a") (&check-memory) -(list "a" "b") (&check-memory) -(list "a" "b" "c") (&check-memory) - -(not) (&check-memory) -(not 0) (&check-memory) -(not nil) (&check-memory) -(not t) (&check-memory) -(not 'a) (&check-memory) -(not 'a 'b 'c 'd) (&check-memory) - -(nth) (&check-memory) -(nth 2) (&check-memory) -(nth 2 nil) (&check-memory) -(nth 2 '(('one 'two 'three))) (&check-memory) - -(null) (&check-memory) -(null 0) (&check-memory) -(null nil) (&check-memory) -(null t) (&check-memory) -(null 'a) (&check-memory) -(null 'a 'b 'c 'd) (&check-memory) - -(or) (&check-memory) -(or 0) (&check-memory) -(or 1) (&check-memory) -(or 0 0 0) (&check-memory) - -(path) (&check-memory) -(path 0) (&check-memory) -(path 1) (&check-memory) -(path 0 0 0) (&check-memory) -(path "data") (&check-memory) - -(princ) (&check-memory) -(princ "\nabcd\n") (&check-memory) -(princ "a" "b" "c\n") (&check-memory) - -(prog1) (&check-memory) -(prog1 1) (&check-memory) -(prog1 1 2 3 4) (&check-memory) - -(prog2) (&check-memory) -(prog2 1) (&check-memory) -(prog2 1 2 3 4) (&check-memory) - -(progn) (&check-memory) -(progn 1) (&check-memory) -(progn 1 2 3 4) (&check-memory) - -(quote) (&check-memory) -(quote a) (&check-memory) - -(rassoc) (&check-memory) -(rassoc 'first) (&check-memory) -(rassoc 'first '((one . first))) (&check-memory) -(rassoc 'first '((two . second))) (&check-memory) -(rassoc 'first '((one . first) (two . second))) (&check-memory) - -(rassq) (&check-memory) -(rassq "first") (&check-memory) -(rassq "first" '(("one" . "first"))) (&check-memory) -(rassq "first" '(("two" . "second"))) (&check-memory) -(rassq "first" '(("one" . "first") ("two" . "second"))) (&check-memory) - -(set) (&check-memory) -(set "a") (unset "a") (&check-memory) -(set "a" 1) (unset "a") (&check-memory) -(set a 1) (unset a) (&check-memory) -(set "a" 1 2) (unset "a") (&check-memory) - -(setf) (&check-memory) -(setf a) (unsetf a) (&check-memory) -(setf a 1) (unsetf a) (&check-memory) -(setf a 1 2) (unsetf a) (&check-memory) - -(setq) (&check-memory) -(setq a) (unsetq a) (&check-memory) -(setq a 1) (unsetq a) (&check-memory) -(setq a 1 2) (unsetq a) (&check-memory) - -(string-equal) (&check-memory) -(string-equal 1) (&check-memory) -(string-equal "a") (&check-memory) -(string-equal "a" "a") (&check-memory) -(string-equal "a" "b") (&check-memory) -(string-equal "a" "b" "c") (&check-memory) - -(string-to-integer) (&check-memory) -(string-to-integer 1) (&check-memory) -(string-to-integer 1.5) (&check-memory) -(string-to-integer "a") (&check-memory) -(string-to-integer "a" "a") (&check-memory) -(string-to-integer "a" "b") (&check-memory) -(string-to-integer "a" "b" "c") (&check-memory) - -(string-to-float) (&check-memory) -(string-to-float 1) (&check-memory) -(string-to-float 1.5) (&check-memory) -(string-to-float "a") (&check-memory) -(string-to-float "a" "a") (&check-memory) -(string-to-float "a" "b") (&check-memory) -(string-to-float "a" "b" "c") (&check-memory) - -(string=) (&check-memory) -(string= 1) (&check-memory) -(string= "a") (&check-memory) -(string= "a" "a") (&check-memory) -(string= "a" "b") (&check-memory) -(string= "a" "b" "c") (&check-memory) - -(unless) (&check-memory) -(unless 1) (&check-memory) -(unless 0 1 2) (&check-memory) -(unless t 2 3 4) (&check-memory) -(unless nil 2 3 4) (&check-memory) - -(unset) (&check-memory) -(unset "a") (&check-memory) - -(unsetf) (&check-memory) -(unsetf a) (&check-memory) -(unsetf a b) (&check-memory) - -(unsetq) (&check-memory) -(unsetq a) (&check-memory) -(unsetq a b) (&check-memory) - -(when) (&check-memory) -(when 0) (&check-memory) -(when 0 1) (&check-memory) -(when t 1) (&check-memory) -(when nil 1) (&check-memory) - -(while) (&check-memory) -(while nil) (&check-memory) -(while nil 1) (&check-memory) -(while nil 1 2 3 4) (&check-memory) - -; -; more complex command sequences -; - -(setq abcd "abcd") -(unsetq abcd) -(&check-memory) - -(setq abcd (("abcd" . "efgh") ("1234" . "5678"))) -(unsetq abcd) -(&check-memory) - -(defun myfun () (princ "a\n")) -(exfun 'myfun) -(unsetq myfun) -(&check-memory) - -(defun myfun () (princ "a\n")) -(funcall 'myfun) -(funcall 'myfun 'aaaaa) -(unsetq myfun) -(&check-memory) - -(defun myfun (o) (princ o "a\n")) -(funcall 'myfun) -(funcall 'myfun 'aaaaa) -(unsetq myfun) -(&check-memory) - -(defun myfun (o p) (princ o p "\n")) -(funcall 'myfun) -(funcall 'myfun 'aaaaa) -(funcall 'myfun 'aaaaa 'bbbbb) -(unsetq myfun) -(&check-memory) - -(defun printnum (from to) (while (<= from to) (princ " " from) (setq from (+ from 1)))) -(princ "Numbers 1-10:") (printnum 1 10) (princ "\n") -(unsetq printnum) - -; -; game over -; - -(princ "*********************\n") -(princ "OK, all tests passed!\n") -(princ "*********************\n") -(&stat-memory) diff --git a/configure.ac b/configure.ac index 75c65530..094bd11b 100644 --- a/configure.ac +++ b/configure.ac @@ -419,10 +419,6 @@ AC_ARG_ENABLE(ucm, AC_ARG_ENABLE(topology, AS_HELP_STRING([--disable-topology], [disable the DSP topology component]), [build_topology="$enableval"], [build_topology="yes"]) -AC_ARG_ENABLE(alisp, - AS_HELP_STRING([--enable-alisp], [enable the alisp component]), - [build_alisp="$enableval"], [build_alisp="no"]) -test "$softfloat" = "yes" && build_alisp="no" AC_ARG_ENABLE(old-symbols, AS_HELP_STRING([--disable-old-symbols], [disable old obsoleted symbols]), [keep_old_symbols="$enableval"], [keep_old_symbols="yes"]) @@ -496,7 +492,6 @@ AM_CONDITIONAL([BUILD_HWDEP], [test x$build_hwdep = xyes]) AM_CONDITIONAL([BUILD_SEQ], [test x$build_seq = xyes]) AM_CONDITIONAL([BUILD_UCM], [test x$build_ucm = xyes]) AM_CONDITIONAL([BUILD_TOPOLOGY], [test x$build_topology = xyes]) -AM_CONDITIONAL([BUILD_ALISP], [test x$build_alisp = xyes]) AM_CONDITIONAL([BUILD_MIXER_MODULES], [test x$build_mixer_modules = xyes]) AM_CONDITIONAL([BUILD_MIXER_PYMODULES], [test x$build_mixer_pymodules = xyes]) @@ -773,13 +768,13 @@ AC_CONFIG_FILES(Makefile doc/Makefile doc/pictures/Makefile doc/doxygen.cfg \ src/pcm/Makefile src/pcm/scopes/Makefile \ src/rawmidi/Makefile src/timer/Makefile \ src/hwdep/Makefile src/seq/Makefile src/ucm/Makefile \ - src/alisp/Makefile src/topology/Makefile \ + src/topology/Makefile \ src/conf/Makefile \ src/conf/cards/Makefile \ src/conf/ctl/Makefile \ src/conf/pcm/Makefile \ modules/Makefile modules/mixer/Makefile modules/mixer/simple/Makefile \ - alsalisp/Makefile aserver/Makefile \ + aserver/Makefile \ test/Makefile test/lsb/Makefile \ utils/Makefile utils/alsa-lib.spec utils/alsa.pc utils/alsa-topology.pc) diff --git a/gitcompile b/gitcompile index c70448f7..783d0fd3 100755 --- a/gitcompile +++ b/gitcompile @@ -5,7 +5,6 @@ set -e bits32= cbits32= modules= -alisp= lto= if [ $# -ne 0 ]; then endloop= @@ -20,10 +19,6 @@ if [ $# -ne 0 ]; then modules=yes echo "Forced mixer modules build..." shift ;; - alisp) - alisp=yes - echo "Forced alisp code build..." - shift ;; python2) python2=yes echo "Forced python2 interpreter build..." @@ -71,10 +66,6 @@ if [ "$modules" = "yes" ]; then args="$args --enable-mixer-pymods" fi -if [ "$alisp" = "yes" ]; then - args="$args --enable-alisp" -fi - if [ "$python2" = "yes" ]; then args="$args --enable-python2" fi diff --git a/include/Makefile.am b/include/Makefile.am index c1885e1d..bd8a4b97 100644 --- a/include/Makefile.am +++ b/include/Makefile.am @@ -58,10 +58,6 @@ if BUILD_TOPOLOGY alsainclude_HEADERS += topology.h endif -if BUILD_ALISP -alsainclude_HEADERS += alisp.h -endif - noinst_HEADERS = alsa sys.h search.h list.h aserver.h local.h alsa-symbols.h \ asoundlib-head.h asoundlib-tail.h bswap.h type_compat.h diff --git a/include/alisp.h b/include/alisp.h deleted file mode 100644 index 11d7adf4..00000000 --- a/include/alisp.h +++ /dev/null @@ -1,55 +0,0 @@ -/* - * ALSA lisp implementation - * Copyright (c) 2003 by Jaroslav Kysela - * - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 *eout; /* error output */ - snd_output_t *vout; /* verbose output */ - snd_output_t *wout; /* warning output */ - snd_output_t *dout; /* debug output */ -}; - -struct alisp_instance; -struct alisp_object; -struct alisp_seq_iterator; - -struct alisp_cfg *alsa_lisp_default_cfg(snd_input_t *input); -void alsa_lisp_default_cfg_free(struct alisp_cfg *cfg); -int alsa_lisp(struct alisp_cfg *cfg, struct alisp_instance **instance); -void alsa_lisp_free(struct alisp_instance *instance); -int alsa_lisp_function(struct alisp_instance *instance, struct alisp_seq_iterator **result, - const char *id, const char *args, ...) -#ifndef DOC_HIDDEN - __attribute__ ((format (printf, 4, 5))) -#endif - ; -void alsa_lisp_result_free(struct alisp_instance *instance, - struct alisp_seq_iterator *result); -int alsa_lisp_seq_first(struct alisp_instance *instance, const char *id, - struct alisp_seq_iterator **seq); -int alsa_lisp_seq_next(struct alisp_seq_iterator **seq); -int alsa_lisp_seq_count(struct alisp_seq_iterator *seq); -int alsa_lisp_seq_integer(struct alisp_seq_iterator *seq, long *val); -int alsa_lisp_seq_pointer(struct alisp_seq_iterator *seq, const char *ptr_id, void **ptr); diff --git a/include/error.h b/include/error.h index 8a2a9abc..13f59d55 100644 --- a/include/error.h +++ b/include/error.h @@ -46,7 +46,6 @@ extern "C" { #define SND_ERROR_BEGIN 500000 /**< Lower boundary of sound error codes. */ #define SND_ERROR_INCOMPATIBLE_VERSION (SND_ERROR_BEGIN+0) /**< Kernel/library protocols are not compatible. */ -#define SND_ERROR_ALISP_NIL (SND_ERROR_BEGIN+1) /**< Lisp encountered an error during acall. */ const char *snd_strerror(int errnum); diff --git a/src/Makefile.am b/src/Makefile.am index f8905343..679c626c 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -51,13 +51,6 @@ if BUILD_UCM SUBDIRS += ucm libasound_la_LIBADD += ucm/libucm.la endif -if BUILD_ALISP -if VERSIONED_SYMBOLS -VERSION_CPPFLAGS += -DHAVE_ALISP_SYMS -endif -SUBDIRS += alisp -libasound_la_LIBADD += alisp/libalisp.la -endif SUBDIRS += conf libasound_la_LIBADD += @ALSA_DEPLIBS@ @@ -102,7 +95,4 @@ topology/libtopology.la: instr/libinstr.la: $(MAKE) -C instr libinstr.la -alisp/libalisp.la: - $(MAKE) -C alisp libalisp.la - AM_CPPFLAGS=-I$(top_srcdir)/include diff --git a/src/Versions.in.in b/src/Versions.in.in index 7ad6a633..4aa2e13b 100644 --- a/src/Versions.in.in +++ b/src/Versions.in.in @@ -129,19 +129,9 @@ ALSA_0.9.3 { } ALSA_0.9.0; ALSA_0.9.5 { -#ifdef HAVE_ALISP_SYMS - global: - - @SYMBOL_PREFIX@alsa_lisp; -#endif } ALSA_0.9.3; ALSA_0.9.7 { -#ifdef HAVE_ALISP_SYMS - global: - - @SYMBOL_PREFIX@alsa_lisp_*; -#endif } ALSA_0.9.5; ALSA_1.1.6 { diff --git a/src/alisp/Makefile.am b/src/alisp/Makefile.am deleted file mode 100644 index 1234e111..00000000 --- a/src/alisp/Makefile.am +++ /dev/null @@ -1,11 +0,0 @@ -EXTRA_LTLIBRARIES = libalisp.la - -EXTRA_DIST = alisp_snd.c - -libalisp_la_SOURCES = alisp.c - -noinst_HEADERS = alisp_local.h - -all: libalisp.la - -AM_CPPFLAGS=-I$(top_srcdir)/include diff --git a/src/alisp/alisp.c b/src/alisp/alisp.c deleted file mode 100644 index bb841119..00000000 --- a/src/alisp/alisp.c +++ /dev/null @@ -1,3495 +0,0 @@ -/* - * ALSA lisp implementation - * Copyright (c) 2003 by Jaroslav Kysela - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - */ - -#define alisp_seq_iterator alisp_object - -#include "local.h" -#include "alisp.h" -#include "alisp_local.h" - -#include - -#include -#include -#include -#include -#include -#include -#include - - -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_cons(snd_output_t *out, struct alisp_object * p); -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 *); -static struct alisp_object *F_funcall(struct alisp_instance *instance, struct alisp_object *); - -/* others */ -static int alisp_include_file(struct alisp_instance *instance, const char *filename); - -/* - * object handling - */ - -static int get_string_hash(const char *s) -{ - int val = 0; - if (s == NULL) - return val; - while (*s) - val += *s++; - return val & ALISP_OBJ_PAIR_HASH_MASK; -} - -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); - snd_output_putc(instance->vout, '\n'); - va_end(ap); -} - -static void lisp_error(struct alisp_instance *instance, const char *fmt, ...) -{ - va_list ap; - - if (!instance->warning) - return; - va_start(ap, fmt); - snd_output_printf(instance->eout, "alisp error: "); - snd_output_vprintf(instance->eout, fmt, ap); - snd_output_putc(instance->eout, '\n'); - 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); - snd_output_putc(instance->wout, '\n'); - 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); - snd_output_putc(instance->dout, '\n'); - va_end(ap); -} - -static struct alisp_object * new_object(struct alisp_instance *instance, int type) -{ - struct alisp_object * p; - - if (list_empty(&instance->free_objs_list)) { - p = (struct alisp_object *)malloc(sizeof(struct alisp_object)); - if (p == NULL) { - nomem(); - return NULL; - } - lisp_debug(instance, "allocating cons %p", p); - } else { - p = (struct alisp_object *)instance->free_objs_list.next; - list_del(&p->list); - instance->free_objs--; - lisp_debug(instance, "recycling cons %p", p); - } - - instance->used_objs++; - - alisp_set_type(p, type); - alisp_set_refs(p, 1); - if (type == ALISP_OBJ_CONS) { - p->value.c.car = &alsa_lisp_nil; - p->value.c.cdr = &alsa_lisp_nil; - list_add(&p->list, &instance->used_objs_list[0][ALISP_OBJ_CONS]); - } - - if (instance->used_objs + instance->free_objs > instance->max_objs) - instance->max_objs = instance->used_objs + instance->free_objs; - - return p; -} - -static void free_object(struct alisp_object * p) -{ - switch (alisp_get_type(p)) { - case ALISP_OBJ_STRING: - case ALISP_OBJ_IDENTIFIER: - free(p->value.s); - alisp_set_type(p, ALISP_OBJ_INTEGER); - break; - default: - break; - } -} - -static void delete_object(struct alisp_instance *instance, struct alisp_object * p) -{ - if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t) - return; - if (alisp_compare_type(p, ALISP_OBJ_NIL) || - alisp_compare_type(p, ALISP_OBJ_T)) - return; - assert(alisp_get_refs(p) > 0); - lisp_debug(instance, "delete cons %p (type = %i, refs = %i) (s = '%s')", p, alisp_get_type(p), alisp_get_refs(p), - alisp_compare_type(p, ALISP_OBJ_STRING) || - alisp_compare_type(p, ALISP_OBJ_IDENTIFIER) ? p->value.s : "???"); - if (alisp_dec_refs(p)) - return; - list_del(&p->list); - instance->used_objs--; - free_object(p); - if (instance->free_objs >= ALISP_FREE_OBJ_POOL) { - lisp_debug(instance, "freed cons %p", p); - free(p); - return; - } - lisp_debug(instance, "moved cons %p to free list", p); - list_add(&p->list, &instance->free_objs_list); - instance->free_objs++; -} - -static void delete_tree(struct alisp_instance *instance, struct alisp_object * p) -{ - if (p == NULL) - return; - if (alisp_compare_type(p, ALISP_OBJ_CONS)) { - delete_tree(instance, p->value.c.car); - delete_tree(instance, p->value.c.cdr); - } - delete_object(instance, p); -} - -static struct alisp_object * incref_object(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * p) -{ - if (p == NULL || p == &alsa_lisp_nil || p == &alsa_lisp_t) - return p; - if (alisp_get_refs(p) == ALISP_MAX_REFS) { - assert(0); - fprintf(stderr, "OOPS: alsa lisp: incref fatal error\n"); - exit(EXIT_FAILURE); - } - alisp_inc_refs(p); - return p; -} - -static struct alisp_object * incref_tree(struct alisp_instance *instance, struct alisp_object * p) -{ - if (p == NULL) - return NULL; - if (alisp_compare_type(p, ALISP_OBJ_CONS)) { - incref_tree(instance, p->value.c.car); - incref_tree(instance, p->value.c.cdr); - } - return incref_object(instance, p); -} - -/* Function not used yet. Leave it commented out until we actually use it to - * avoid compiler complaints */ -#if 0 -static struct alisp_object * incref_tree_explicit(struct alisp_instance *instance, struct alisp_object * p, struct alisp_object * e) -{ - if (p == NULL) - return NULL; - if (alisp_compare_type(p, ALISP_OBJ_CONS)) { - if (e == p) { - incref_tree(instance, p->value.c.car); - incref_tree(instance, p->value.c.cdr); - } else { - incref_tree_explicit(instance, p->value.c.car, e); - incref_tree_explicit(instance, p->value.c.cdr, e); - } - } - if (e == p) - return incref_object(instance, p); - return p; -} -#endif - -static void free_objects(struct alisp_instance *instance) -{ - struct list_head *pos, *pos1; - struct alisp_object * p; - struct alisp_object_pair * pair; - int i, j; - - for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { - list_for_each_safe(pos, pos1, &instance->setobjs_list[i]) { - pair = list_entry(pos, struct alisp_object_pair, list); - lisp_debug(instance, "freeing pair: '%s' -> %p", pair->name, pair->value); - delete_tree(instance, pair->value); - free((void *)pair->name); - free(pair); - } - } - for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) - for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) { - list_for_each_safe(pos, pos1, &instance->used_objs_list[i][j]) { - p = list_entry(pos, struct alisp_object, list); - lisp_warn(instance, "object %p is still referenced %i times!", p, alisp_get_refs(p)); -#if 0 - snd_output_printf(instance->wout, ">>>> "); - princ_object(instance->wout, p); - snd_output_printf(instance->wout, " <<<<\n"); -#endif - if (alisp_get_refs(p) > 0) - alisp_set_refs(p, 1); - delete_object(instance, p); - } - } - list_for_each_safe(pos, pos1, &instance->free_objs_list) { - p = list_entry(pos, struct alisp_object, list); - list_del(&p->list); - free(p); - lisp_debug(instance, "freed (all) cons %p", p); - } -} - -static struct alisp_object * search_object_identifier(struct alisp_instance *instance, const char *s) -{ - struct list_head * pos; - struct alisp_object * p; - - list_for_each(pos, &instance->used_objs_list[get_string_hash(s)][ALISP_OBJ_IDENTIFIER]) { - p = list_entry(pos, struct alisp_object, list); - if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) - continue; - if (!strcmp(p->value.s, s)) - return incref_object(instance, p); - } - - return NULL; -} - -static struct alisp_object * search_object_string(struct alisp_instance *instance, const char *s) -{ - struct list_head * pos; - struct alisp_object * p; - - list_for_each(pos, &instance->used_objs_list[get_string_hash(s)][ALISP_OBJ_STRING]) { - p = list_entry(pos, struct alisp_object, list); - if (!strcmp(p->value.s, s)) { - if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) - continue; - return incref_object(instance, p); - } - } - - return NULL; -} - -static struct alisp_object * search_object_integer(struct alisp_instance *instance, long in) -{ - struct list_head * pos; - struct alisp_object * p; - - list_for_each(pos, &instance->used_objs_list[in & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_INTEGER]) { - p = list_entry(pos, struct alisp_object, list); - if (p->value.i == in) { - if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) - continue; - return incref_object(instance, p); - } - } - - return NULL; -} - -static struct alisp_object * search_object_float(struct alisp_instance *instance, double in) -{ - struct list_head * pos; - struct alisp_object * p; - - list_for_each(pos, &instance->used_objs_list[(long)in & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_FLOAT]) { - p = list_entry(pos, struct alisp_object, list); - if (p->value.i == in) { - if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) - continue; - return incref_object(instance, p); - } - } - - return NULL; -} - -static struct alisp_object * search_object_pointer(struct alisp_instance *instance, const void *ptr) -{ - struct list_head * pos; - struct alisp_object * p; - - list_for_each(pos, &instance->used_objs_list[(long)ptr & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_POINTER]) { - p = list_entry(pos, struct alisp_object, list); - if (p->value.ptr == ptr) { - if (alisp_get_refs(p) > ALISP_MAX_REFS_LIMIT) - continue; - return incref_object(instance, p); - } - } - - return NULL; -} - -static struct alisp_object * new_integer(struct alisp_instance *instance, long value) -{ - struct alisp_object * obj; - - obj = search_object_integer(instance, value); - if (obj != NULL) - return obj; - obj = new_object(instance, ALISP_OBJ_INTEGER); - if (obj) { - list_add(&obj->list, &instance->used_objs_list[value & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_INTEGER]); - obj->value.i = value; - } - return obj; -} - -static struct alisp_object * new_float(struct alisp_instance *instance, double value) -{ - struct alisp_object * obj; - - obj = search_object_float(instance, value); - if (obj != NULL) - return obj; - obj = new_object(instance, ALISP_OBJ_FLOAT); - if (obj) { - list_add(&obj->list, &instance->used_objs_list[(long)value & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_FLOAT]); - obj->value.f = value; - } - return obj; -} - -static struct alisp_object * new_string(struct alisp_instance *instance, const char *str) -{ - struct alisp_object * obj; - - obj = search_object_string(instance, str); - if (obj != NULL) - return obj; - obj = new_object(instance, ALISP_OBJ_STRING); - if (obj) - list_add(&obj->list, &instance->used_objs_list[get_string_hash(str)][ALISP_OBJ_STRING]); - if (obj && (obj->value.s = strdup(str)) == NULL) { - delete_object(instance, obj); - nomem(); - return NULL; - } - return obj; -} - -static struct alisp_object * new_identifier(struct alisp_instance *instance, const char *id) -{ - struct alisp_object * obj; - - obj = search_object_identifier(instance, id); - if (obj != NULL) - return obj; - obj = new_object(instance, ALISP_OBJ_IDENTIFIER); - if (obj) - list_add(&obj->list, &instance->used_objs_list[get_string_hash(id)][ALISP_OBJ_IDENTIFIER]); - if (obj && (obj->value.s = strdup(id)) == NULL) { - delete_object(instance, obj); - nomem(); - return NULL; - } - return obj; -} - -static struct alisp_object * new_pointer(struct alisp_instance *instance, const void *ptr) -{ - struct alisp_object * obj; - - obj = search_object_pointer(instance, ptr); - if (obj != NULL) - return obj; - obj = new_object(instance, ALISP_OBJ_POINTER); - if (obj) { - list_add(&obj->list, &instance->used_objs_list[(long)ptr & ALISP_OBJ_PAIR_HASH_MASK][ALISP_OBJ_POINTER]); - obj->value.ptr = ptr; - } - return obj; -} - -static struct alisp_object * new_cons_pointer(struct alisp_instance * instance, const char *ptr_id, void *ptr) -{ - struct alisp_object * lexpr; - - if (ptr == NULL) - return &alsa_lisp_nil; - lexpr = new_object(instance, ALISP_OBJ_CONS); - if (lexpr == NULL) - return NULL; - lexpr->value.c.car = new_string(instance, ptr_id); - if (lexpr->value.c.car == NULL) - goto __end; - lexpr->value.c.cdr = new_pointer(instance, ptr); - if (lexpr->value.c.cdr == NULL) { - delete_object(instance, lexpr->value.c.car); - __end: - delete_object(instance, lexpr); - return NULL; - } - return lexpr; -} - -void alsa_lisp_init_objects(void) __attribute__ ((constructor)); - -void alsa_lisp_init_objects(void) -{ - memset(&alsa_lisp_nil, 0, sizeof(alsa_lisp_nil)); - alisp_set_type(&alsa_lisp_nil, ALISP_OBJ_NIL); - INIT_LIST_HEAD(&alsa_lisp_nil.list); - memset(&alsa_lisp_t, 0, sizeof(alsa_lisp_t)); - alisp_set_type(&alsa_lisp_t, ALISP_OBJ_T); - INIT_LIST_HEAD(&alsa_lisp_t.list); -} - -/* - * lexer - */ - -static int xgetc(struct alisp_instance *instance) -{ - instance->charno++; - if (instance->lex_bufp > instance->lex_buf) - return *--(instance->lex_bufp); - 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) -{ - 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; - instance->thistoken = ALISP_INTEGER; - do { - __ok: - if (p - instance->token_buffer >= instance->token_buffer_max - 1) { - p = extend_buf(instance, p); - if (p == NULL) - return instance->thistoken = EOF; - } - *p++ = c; - c = xgetc(instance); - if (c == '.' && instance->thistoken == ALISP_INTEGER) { - c = xgetc(instance); - xungetc(instance, c); - if (isdigit(c)) { - instance->thistoken = ALISP_FLOAT; - c = '.'; - goto __ok; - } else { - c = '.'; - } - } else if (c == 'e' && instance->thistoken == ALISP_FLOAT) { - c = xgetc(instance); - if (isdigit(c)) { - instance->thistoken = ALISP_FLOATE; - goto __ok; - } - } - } while (isdigit(c)); - xungetc(instance, c); - *p = '\0'; - return instance->thistoken; - - got_id: - case '!': 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 - 1) { - 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 - 1) { - 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 == '.') { - gettoken(instance); - if (prev == NULL) { - lisp_error(instance, "unexpected '.'"); - __err: - delete_tree(instance, first); - return NULL; - } - prev->value.c.cdr = parse_object(instance, 1); - if (prev->value.c.cdr == NULL) - goto __err; - if ((thistoken = gettoken(instance)) != ')') { - lisp_error(instance, "expected ')'"); - goto __err; - } - break; - } - - p = new_object(instance, ALISP_OBJ_CONS); - if (p == NULL) - goto __err; - - 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) - goto __err; - - prev = p; - } - - if (first == NULL) - return &alsa_lisp_nil; - else - return first; -} - -static struct alisp_object * quote_object(struct alisp_instance *instance, struct alisp_object * obj) -{ - struct alisp_object * p; - - if (obj == NULL) - goto __end1; - - p = new_object(instance, ALISP_OBJ_CONS); - if (p == NULL) - goto __end1; - - p->value.c.car = new_identifier(instance, "quote"); - if (p->value.c.car == NULL) - goto __end; - p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); - if (p->value.c.cdr == NULL) { - delete_object(instance, p->value.c.car); - __end: - delete_object(instance, p); - __end1: - delete_tree(instance, obj); - return NULL; - } - - p->value.c.cdr->value.c.car = obj; - return p; -} - -static inline struct alisp_object * parse_quote(struct alisp_instance *instance) -{ - return quote_object(instance, parse_object(instance, 0)); -} - -static struct alisp_object * parse_object(struct alisp_instance *instance, int havetoken) -{ - int thistoken; - struct alisp_object * p = NULL; - - 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 { - p = new_identifier(instance, instance->token_buffer); - } - break; - case ALISP_INTEGER: { - p = new_integer(instance, atol(instance->token_buffer)); - break; - } - case ALISP_FLOAT: - case ALISP_FLOATE: { - p = new_float(instance, atof(instance->token_buffer)); - break; - } - case ALISP_STRING: - p = new_string(instance, instance->token_buffer); - break; - default: - lisp_warn(instance, "%d:%d: unexpected character `%c'", instance->lineno, instance->charno, thistoken); - break; - } - - return p; -} - -/* - * object manipulation - */ - -static struct alisp_object_pair * set_object_direct(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * value) -{ - struct alisp_object_pair *p; - const char *id; - - id = name->value.s; - p = (struct alisp_object_pair *)malloc(sizeof(struct alisp_object_pair)); - if (p == NULL) { - nomem(); - return NULL; - } - p->name = strdup(id); - if (p->name == NULL) { - delete_tree(instance, value); - free(p); - return NULL; - } - list_add(&p->list, &instance->setobjs_list[get_string_hash(id)]); - p->value = value; - return p; -} - -static int check_set_object(struct alisp_instance * instance, struct alisp_object * name) -{ - if (name == &alsa_lisp_nil) { - lisp_warn(instance, "setting the value of a nil object"); - return 0; - } - if (name == &alsa_lisp_t) { - lisp_warn(instance, "setting the value of a t object"); - return 0; - } - if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(name, ALISP_OBJ_STRING)) { - lisp_warn(instance, "setting the value of an object with non-indentifier"); - return 0; - } - return 1; -} - -static struct alisp_object_pair * set_object(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * value) -{ - struct list_head *pos; - struct alisp_object_pair *p; - const char *id; - - if (name == NULL || value == NULL) - return NULL; - - id = name->value.s; - - list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { - p = list_entry(pos, struct alisp_object_pair, list); - if (!strcmp(p->name, id)) { - delete_tree(instance, p->value); - p->value = value; - return p; - } - } - - p = (struct alisp_object_pair *)malloc(sizeof(struct alisp_object_pair)); - if (p == NULL) { - nomem(); - return NULL; - } - p->name = strdup(id); - if (p->name == NULL) { - delete_tree(instance, value); - free(p); - return NULL; - } - list_add(&p->list, &instance->setobjs_list[get_string_hash(id)]); - p->value = value; - return p; -} - -static struct alisp_object * unset_object(struct alisp_instance *instance, struct alisp_object * name) -{ - struct list_head *pos; - struct alisp_object *res; - struct alisp_object_pair *p; - const char *id; - - if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(name, ALISP_OBJ_STRING)) { - lisp_warn(instance, "unset object with a non-indentifier"); - return &alsa_lisp_nil; - } - id = name->value.s; - - list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { - p = list_entry(pos, struct alisp_object_pair, list); - if (!strcmp(p->name, id)) { - list_del(&p->list); - res = p->value; - free((void *)p->name); - free(p); - return res; - } - } - - return &alsa_lisp_nil; -} - -static struct alisp_object * get_object1(struct alisp_instance *instance, const char *id) -{ - struct alisp_object_pair *p; - struct list_head *pos; - - list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { - p = list_entry(pos, struct alisp_object_pair, list); - if (!strcmp(p->name, id)) - return p->value; - } - - return &alsa_lisp_nil; -} - -static struct alisp_object * get_object(struct alisp_instance *instance, struct alisp_object * name) -{ - if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(name, ALISP_OBJ_STRING)) { - delete_tree(instance, name); - return &alsa_lisp_nil; - } - return get_object1(instance, name->value.s); -} - -static struct alisp_object * replace_object(struct alisp_instance *instance, struct alisp_object * name, struct alisp_object * onew) -{ - struct alisp_object_pair *p; - struct alisp_object *r; - struct list_head *pos; - const char *id; - - if (!alisp_compare_type(name, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(name, ALISP_OBJ_STRING)) { - delete_tree(instance, name); - return &alsa_lisp_nil; - } - id = name->value.s; - list_for_each(pos, &instance->setobjs_list[get_string_hash(id)]) { - p = list_entry(pos, struct alisp_object_pair, list); - if (!strcmp(p->name, id)) { - r = p->value; - p->value = onew; - return r; - } - } - - return NULL; -} - -static void dump_objects(struct alisp_instance *instance, const char *fname) -{ - struct alisp_object_pair *p; - snd_output_t *out; - struct list_head *pos; - int i, 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 writing (%s)", fname, snd_strerror(errno)); - return; - } - - for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { - list_for_each(pos, &instance->setobjs_list[i]) { - p = list_entry(pos, struct alisp_object_pair, list); - if (alisp_compare_type(p->value, ALISP_OBJ_CONS) && - alisp_compare_type(p->value->value.c.car, ALISP_OBJ_IDENTIFIER) && - !strcmp(p->value->value.c.car->value.s, "lambda")) { - snd_output_printf(out, "(defun %s ", p->name); - princ_cons(out, p->value->value.c.cdr); - snd_output_printf(out, ")\n"); - continue; - } - snd_output_printf(out, "(setq %s '", p->name); - 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 (alisp_get_type(p)) { - case ALISP_OBJ_NIL: return "nil"; - case ALISP_OBJ_T: return "t"; - case ALISP_OBJ_INTEGER: return "integer"; - case ALISP_OBJ_FLOAT: return "float"; - case ALISP_OBJ_IDENTIFIER: return "identifier"; - case ALISP_OBJ_STRING: return "string"; - case ALISP_OBJ_POINTER: return "pointer"; - case ALISP_OBJ_CONS: return "cons"; - default: assert(0); - } -} - -static void print_obj_lists(struct alisp_instance *instance, snd_output_t *out) -{ - struct list_head *pos; - struct alisp_object * p; - int i, j; - - snd_output_printf(out, "** used objects\n"); - for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) - for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) - list_for_each(pos, &instance->used_objs_list[i][j]) { - p = list_entry(pos, struct alisp_object, list); - snd_output_printf(out, "** %p (%s) (", p, obj_type_str(p)); - if (!alisp_compare_type(p, ALISP_OBJ_CONS)) - princ_object(out, p); - else - snd_output_printf(out, "cons"); - snd_output_printf(out, ") refs=%i\n", alisp_get_refs(p)); - } - snd_output_printf(out, "** free objects\n"); - list_for_each(pos, &instance->free_objs_list) { - p = list_entry(pos, struct alisp_object, list); - snd_output_printf(out, "** %p\n", 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 writing (%s)", fname, snd_strerror(errno)); - return; - } - - print_obj_lists(instance, out); - - snd_output_close(out); -} - -/* - * functions - */ - -static int count_list(struct alisp_object * p) -{ - int i = 0; - - while (p != &alsa_lisp_nil && alisp_compare_type(p, ALISP_OBJ_CONS)) { - p = p->value.c.cdr; - ++i; - } - - return i; -} - -static inline struct alisp_object * car(struct alisp_object * p) -{ - if (alisp_compare_type(p, ALISP_OBJ_CONS)) - return p->value.c.car; - - return &alsa_lisp_nil; -} - -static inline struct alisp_object * cdr(struct alisp_object * p) -{ - if (alisp_compare_type(p, ALISP_OBJ_CONS)) - return p->value.c.cdr; - - return &alsa_lisp_nil; -} - -/* - * Syntax: (car expr) - */ -static struct alisp_object * F_car(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object *p1 = car(args), *p2; - delete_tree(instance, cdr(args)); - delete_object(instance, args); - p1 = eval(instance, p1); - delete_tree(instance, cdr(p1)); - p2 = car(p1); - delete_object(instance, p1); - return p2; -} - -/* - * Syntax: (cdr expr) - */ -static struct alisp_object * F_cdr(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object *p1 = car(args), *p2; - delete_tree(instance, cdr(args)); - delete_object(instance, args); - p1 = eval(instance, p1); - delete_tree(instance, car(p1)); - p2 = cdr(p1); - delete_object(instance, p1); - return p2; -} - -/* - * Syntax: (+ expr...) - */ -static struct alisp_object * F_add(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1, * n; - long v = 0; - double f = 0; - int type = ALISP_OBJ_INTEGER; - - p1 = eval(instance, car(p)); - for (;;) { - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - if (type == ALISP_OBJ_FLOAT) - f += p1->value.i; - else - v += p1->value.i; - } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { - f += p1->value.f + v; - v = 0; - type = ALISP_OBJ_FLOAT; - } else { - lisp_warn(instance, "sum with a non integer or float operand"); - } - delete_tree(instance, p1); - p = cdr(n = p); - delete_object(instance, n); - if (p == &alsa_lisp_nil) - break; - p1 = eval(instance, car(p)); - } - if (type == ALISP_OBJ_INTEGER) { - return new_integer(instance, v); - } else { - return new_float(instance, f); - } -} - -/* - * Syntax: (concat expr...) - */ -static struct alisp_object * F_concat(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1, * n; - char *str = NULL, *str1; - - p1 = eval(instance, car(p)); - for (;;) { - if (alisp_compare_type(p1, ALISP_OBJ_STRING)) { - str1 = realloc(str, (str ? strlen(str) : 0) + strlen(p1->value.s) + 1); - if (str1 == NULL) { - nomem(); - free(str); - return NULL; - } - if (str == NULL) - strcpy(str1, p1->value.s); - else - strcat(str1, p1->value.s); - str = str1; - } else { - lisp_warn(instance, "concat with a non string or identifier operand"); - } - delete_tree(instance, p1); - p = cdr(n = p); - delete_object(instance, n); - if (p == &alsa_lisp_nil) - break; - p1 = eval(instance, car(p)); - } - if (str) { - p = new_string(instance, str); - free(str); - } else { - p = &alsa_lisp_nil; - } - return p; -} - -/* - * Syntax: (- expr...) - */ -static struct alisp_object * F_sub(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1, * n; - long v = 0; - double f = 0; - int type = ALISP_OBJ_INTEGER; - - do { - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - if (p == args && cdr(p) != &alsa_lisp_nil) { - v = p1->value.i; - } else { - if (type == ALISP_OBJ_FLOAT) - f -= p1->value.i; - else - v -= p1->value.i; - } - } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { - if (type == ALISP_OBJ_INTEGER) { - f = v; - type = ALISP_OBJ_FLOAT; - } - if (p == args && cdr(p) != &alsa_lisp_nil) - f = p1->value.f; - else { - f -= p1->value.f; - } - } else - lisp_warn(instance, "difference with a non integer or float operand"); - delete_tree(instance, p1); - n = cdr(p); - delete_object(instance, p); - p = n; - } while (p != &alsa_lisp_nil); - - if (type == ALISP_OBJ_INTEGER) { - return new_integer(instance, v); - } else { - return new_float(instance, f); - } -} - -/* - * Syntax: (* expr...) - */ -static struct alisp_object * F_mul(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1, * n; - long v = 1; - double f = 1; - int type = ALISP_OBJ_INTEGER; - - do { - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - if (type == ALISP_OBJ_FLOAT) - f *= p1->value.i; - else - v *= p1->value.i; - } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { - f *= p1->value.f * v; v = 1; - type = ALISP_OBJ_FLOAT; - } else { - lisp_warn(instance, "product with a non integer or float operand"); - } - delete_tree(instance, p1); - n = cdr(p); - delete_object(instance, p); - p = n; - } while (p != &alsa_lisp_nil); - - if (type == ALISP_OBJ_INTEGER) { - return new_integer(instance, v); - } else { - return new_float(instance, f); - } -} - -/* - * Syntax: (/ expr...) - */ -static struct alisp_object * F_div(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1, * n; - long v = 0; - double f = 0; - int type = ALISP_OBJ_INTEGER; - - do { - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, 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; - f = 0; - break; - } else { - if (type == ALISP_OBJ_FLOAT) - f /= p1->value.i; - else - v /= p1->value.i; - } - } - } else if (alisp_compare_type(p1, ALISP_OBJ_FLOAT)) { - if (type == ALISP_OBJ_INTEGER) { - f = v; - type = ALISP_OBJ_FLOAT; - } - if (p == args && cdr(p) != &alsa_lisp_nil) { - f = p1->value.f; - } else { - if (p1->value.f == 0) { - lisp_warn(instance, "division by zero"); - f = 0; - break; - } else { - f /= p1->value.i; - } - } - } else - lisp_warn(instance, "quotient with a non integer or float operand"); - delete_tree(instance, p1); - n = cdr(p); - delete_object(instance, p); - p = n; - } while (p != &alsa_lisp_nil); - - if (type == ALISP_OBJ_INTEGER) { - return new_integer(instance, v); - } else { - return new_float(instance, f); - } -} - -/* - * 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p2->value.i == 0) { - lisp_warn(instance, "module by zero"); - p3 = new_integer(instance, 0); - } else { - p3 = new_integer(instance, p1->value.i % p2->value.i); - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - f1 = fmod(f1, f2); - if (f1 == EDOM) { - lisp_warn(instance, "module by zero"); - p3 = new_float(instance, 0); - } else { - p3 = new_float(instance, f1); - } - } else { - lisp_warn(instance, "module with a non integer or float operand"); - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p1->value.i < p2->value.i) { - __true: - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - if (f1 < f2) - goto __true; - } else { - lisp_warn(instance, "comparison with a non integer or float operand"); - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p1->value.i > p2->value.i) { - __true: - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - if (f1 > f2) - goto __true; - } else { - lisp_warn(instance, "comparison with a non integer or float operand"); - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p1->value.i <= p2->value.i) { - __true: - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - if (f1 <= f2) - goto __true; - } else { - lisp_warn(instance, "comparison with a non integer or float operand"); - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p1->value.i >= p2->value.i) { - __true: - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - if (f1 >= f2) - goto __true; - } else { - lisp_warn(instance, "comparison with a non integer or float operand"); - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (alisp_compare_type(p1, ALISP_OBJ_INTEGER) && - alisp_compare_type(p2, ALISP_OBJ_INTEGER)) { - if (p1->value.i == p2->value.i) { - __true: - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - } else if ((alisp_compare_type(p1, ALISP_OBJ_INTEGER) || - alisp_compare_type(p1, ALISP_OBJ_FLOAT)) && - (alisp_compare_type(p2, ALISP_OBJ_INTEGER) || - alisp_compare_type(p2, ALISP_OBJ_FLOAT))) { - double f1, f2; - f1 = alisp_compare_type(p1, ALISP_OBJ_INTEGER) ? p1->value.i : p1->value.f; - f2 = alisp_compare_type(p2, ALISP_OBJ_INTEGER) ? p2->value.i : p2->value.f; - if (f1 == f2) - goto __true; - } else { - lisp_warn(instance, "comparison with a non integer or float operand"); - } - - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; -} - -/* - * Syntax: (!= expr1 expr2) - */ -static struct alisp_object * F_numneq(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p; - - p = F_numeq(instance, args); - if (p == &alsa_lisp_nil) - return &alsa_lisp_t; - return &alsa_lisp_nil; -} - -/* - * Syntax: (exfun name) - * Test, if a function exists - */ -static struct alisp_object * F_exfun(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - p2 = get_object(instance, p1); - if (p2 == &alsa_lisp_nil) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - p2 = car(p2); - if (alisp_compare_type(p2, ALISP_OBJ_IDENTIFIER) && - !strcmp(p2->value.s, "lambda")) { - delete_tree(instance, p1); - return &alsa_lisp_t; - } - delete_tree(instance, p1); - 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; - case '"': snd_output_putc(out, '\\'); snd_output_putc(out, '"'); break; - default: snd_output_putc(out, *p); - } - snd_output_putc(out, '"'); -} - -static void princ_cons(snd_output_t *out, struct alisp_object * p) -{ - do { - princ_object(out, p->value.c.car); - p = p->value.c.cdr; - if (p != &alsa_lisp_nil) { - snd_output_putc(out, ' '); - if (!alisp_compare_type(p, ALISP_OBJ_CONS)) { - snd_output_printf(out, ". "); - princ_object(out, p); - } - } - } while (p != &alsa_lisp_nil && alisp_compare_type(p, ALISP_OBJ_CONS)); -} - -static void princ_object(snd_output_t *out, struct alisp_object * p) -{ - switch (alisp_get_type(p)) { - 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.s); - break; - case ALISP_OBJ_STRING: - princ_string(out, p->value.s); - break; - case ALISP_OBJ_INTEGER: - snd_output_printf(out, "%ld", p->value.i); - break; - case ALISP_OBJ_FLOAT: - snd_output_printf(out, "%f", p->value.f); - break; - case ALISP_OBJ_POINTER: - snd_output_printf(out, "<%p>", p->value.ptr); - break; - case ALISP_OBJ_CONS: - snd_output_putc(out, '('); - princ_cons(out, p); - 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 = NULL, * n; - - do { - if (p1) - delete_tree(instance, p1); - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, ALISP_OBJ_STRING)) - snd_output_printf(instance->out, "%s", p1->value.s); - else - princ_object(instance->out, p1); - n = cdr(p); - delete_object(instance, p); - p = n; - } 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)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (p == NULL) - return NULL; - - switch (alisp_get_type(p)) { - case ALISP_OBJ_T: - case ALISP_OBJ_NIL: - case ALISP_OBJ_INTEGER: - case ALISP_OBJ_FLOAT: - case ALISP_OBJ_STRING: - case ALISP_OBJ_IDENTIFIER: - case ALISP_OBJ_POINTER: - delete_tree(instance, p); - return &alsa_lisp_t; - default: - break; - } - - delete_tree(instance, p); - 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - } else { - delete_tree(instance, 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) { - delete_tree(instance, p); - delete_tree(instance, first); - return NULL; - } - p1->value.c.car = eval(instance, car(p)); - if (p1->value.c.car == NULL) { - delete_tree(instance, first); - delete_tree(instance, cdr(p)); - delete_object(instance, p); - return NULL; - } - if (first == NULL) - first = p1; - if (prev != NULL) - prev->value.c.cdr = p1; - prev = p1; - p = cdr(p1 = p); - delete_object(instance, p1); - } while (p != &alsa_lisp_nil); - - return first; -} - -static inline int eq(struct alisp_object * p1, struct alisp_object * p2) -{ - return p1 == p2; -} - -static int equal(struct alisp_object * p1, struct alisp_object * p2) -{ - int type1, type2; - - if (eq(p1, p2)) - return 1; - - type1 = alisp_get_type(p1); - type2 = alisp_get_type(p2); - - if (type1 == ALISP_OBJ_CONS || type2 == ALISP_OBJ_CONS) - return 0; - - if (type1 == type2) { - switch (type1) { - case ALISP_OBJ_STRING: - return !strcmp(p1->value.s, p2->value.s); - case ALISP_OBJ_INTEGER: - return p1->value.i == p2->value.i; - case ALISP_OBJ_FLOAT: - return p1->value.i == p2->value.i; - } - } - - return 0; -} - -/* - * 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))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (eq(p1, p2)) { - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; -} - -/* - * Syntax: (equal expr1 expr2) - */ -static struct alisp_object * F_equal(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (equal(p1, p2)) { - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_t; - } - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; -} - -/* - * Syntax: (quote expr) - */ -static struct alisp_object * F_quote(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * args) -{ - struct alisp_object *p = car(args); - - delete_tree(instance, cdr(args)); - delete_object(instance, args); - return p; -} - -/* - * Syntax: (and expr...) - */ -static struct alisp_object * F_and(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1 = NULL, * n; - - do { - if (p1) - delete_tree(instance, p1); - p1 = eval(instance, car(p)); - if (p1 == &alsa_lisp_nil) { - delete_tree(instance, p1); - delete_tree(instance, cdr(p)); - delete_object(instance, p); - return &alsa_lisp_nil; - } - p = cdr(n = p); - delete_object(instance, n); - } 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 = NULL, * n; - - do { - if (p1) - delete_tree(instance, p1); - p1 = eval(instance, car(p)); - if (p1 != &alsa_lisp_nil) { - delete_tree(instance, cdr(p)); - delete_object(instance, p); - return p1; - } - p = cdr(n = p); - delete_object(instance, n); - } 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)); - - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (p != &alsa_lisp_nil) { - delete_tree(instance, p); - return &alsa_lisp_nil; - } - - delete_tree(instance, p); - 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) { - p3 = cdr(p1); - delete_object(instance, p1); - delete_tree(instance, cdr(p)); - delete_object(instance, p); - if (p3 != &alsa_lisp_nil) { - delete_tree(instance, p2); - return F_progn(instance, p3); - } else { - delete_tree(instance, p3); - return p2; - } - } else { - delete_tree(instance, p2); - delete_tree(instance, cdr(p1)); - delete_object(instance, p1); - } - p = cdr(p2 = p); - delete_object(instance, p2); - } 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)); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - p1 = eval(instance, p1); - if (p1 != &alsa_lisp_nil) { - delete_tree(instance, p1); - delete_tree(instance, p3); - return eval(instance, p2); - } - - delete_tree(instance, p1); - delete_tree(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); - delete_object(instance, args); - if ((p1 = eval(instance, p1)) != &alsa_lisp_nil) { - delete_tree(instance, p1); - return F_progn(instance, p2); - } else { - delete_tree(instance, p1); - delete_tree(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); - delete_object(instance, args); - if ((p1 = eval(instance, p1)) == &alsa_lisp_nil) { - return F_progn(instance, p2); - } else { - delete_tree(instance, p1); - delete_tree(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, * p3; - - p1 = car(args); - p2 = cdr(args); - - delete_object(instance, args); - while (1) { - incref_tree(instance, p1); - if ((p3 = eval(instance, p1)) == &alsa_lisp_nil) - break; - delete_tree(instance, p3); - incref_tree(instance, p2); - delete_tree(instance, F_progn(instance, p2)); - } - - delete_tree(instance, p1); - delete_tree(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 = NULL, * n; - - do { - if (p1) - delete_tree(instance, p1); - p1 = eval(instance, car(p)); - n = cdr(p); - delete_object(instance, p); - p = n; - } 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; - else - delete_tree(instance, p1); - p1 = cdr(p); - delete_object(instance, p); - p = p1; - } 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; - else - delete_tree(instance, p1); - p1 = cdr(p); - delete_object(instance, p); - p = p1; - } 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))); - - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - if (!check_set_object(instance, p1)) { - delete_tree(instance, p2); - p2 = &alsa_lisp_nil; - } else { - if (set_object(instance, p1, p2) == NULL) { - delete_tree(instance, p1); - delete_tree(instance, p2); - return NULL; - } - } - delete_tree(instance, p1); - return incref_tree(instance, p2); -} - -/* - * Syntax: (unset name) - */ -static struct alisp_object * F_unset(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1 = eval(instance, car(args)); - - delete_tree(instance, unset_object(instance, p1)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - return p1; -} - -/* - * 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 = NULL, *n; - - do { - p1 = car(p); - p2 = eval(instance, car(cdr(p))); - n = cdr(cdr(p)); - delete_object(instance, cdr(p)); - delete_object(instance, p); - if (!check_set_object(instance, p1)) { - delete_tree(instance, p2); - p2 = &alsa_lisp_nil; - } else { - if (set_object(instance, p1, p2) == NULL) { - delete_tree(instance, p1); - delete_tree(instance, p2); - return NULL; - } - } - delete_tree(instance, p1); - p = n; - } while (p != &alsa_lisp_nil); - - return incref_tree(instance, p2); -} - -/* - * Syntax: (unsetq name...) - * Syntax: (unsetf name...) - * `name' is not evalled - */ -static struct alisp_object * F_unsetq(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1 = NULL, * n; - - do { - if (p1) - delete_tree(instance, p1); - p1 = unset_object(instance, car(p)); - delete_tree(instance, car(p)); - p = cdr(n = p); - delete_object(instance, n); - } while (p != &alsa_lisp_nil); - - return p1; -} - -/* - * 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_identifier(instance, "lambda"); - if (lexpr->value.c.car == NULL) { - delete_object(instance, lexpr); - delete_tree(instance, args); - return NULL; - } - if ((lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS)) == NULL) { - delete_object(instance, lexpr->value.c.car); - delete_object(instance, lexpr); - delete_tree(instance, args); - return NULL; - } - lexpr->value.c.cdr->value.c.car = p2; - lexpr->value.c.cdr->value.c.cdr = p3; - delete_object(instance, cdr(args)); - delete_object(instance, args); - if (set_object(instance, p1, lexpr) == NULL) { - delete_tree(instance, p1); - delete_tree(instance, lexpr); - return NULL; - } - delete_tree(instance, p1); - } else { - delete_tree(instance, args); - } - return &alsa_lisp_nil; -} - -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; - struct alisp_object ** eval_objs, ** save_objs; - int i; - - p1 = car(p); - if (alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER) && - !strcmp(p1->value.s, "lambda")) { - p2 = car(cdr(p)); - p3 = args; - - if ((i = count_list(p2)) != count_list(p3)) { - lisp_warn(instance, "wrong number of parameters"); - goto _delete; - } - - eval_objs = malloc(2 * i * sizeof(struct alisp_object *)); - if (eval_objs == NULL) { - nomem(); - goto _delete; - } - save_objs = eval_objs + i; - - /* - * Save the new variable values. - */ - i = 0; - while (p3 != &alsa_lisp_nil) { - eval_objs[i++] = eval(instance, car(p3)); - p3 = cdr(p4 = p3); - delete_object(instance, p4); - } - - /* - * Save the old variable values and set the new ones. - */ - i = 0; - while (p2 != &alsa_lisp_nil) { - p3 = car(p2); - save_objs[i] = replace_object(instance, p3, eval_objs[i]); - if (save_objs[i] == NULL && - set_object_direct(instance, p3, eval_objs[i]) == NULL) { - p4 = NULL; - goto _end; - } - p2 = cdr(p2); - ++i; - } - - p4 = F_progn(instance, cdr(incref_tree(instance, p3 = cdr(p)))); - - /* - * Restore the old variable values. - */ - p2 = car(p3); - delete_object(instance, p3); - i = 0; - while (p2 != &alsa_lisp_nil) { - p3 = car(p2); - if (save_objs[i] == NULL) { - p3 = unset_object(instance, p3); - } else { - p3 = replace_object(instance, p3, save_objs[i]); - } - i++; - delete_tree(instance, p3); - delete_tree(instance, car(p2)); - p2 = cdr(p3 = p2); - delete_object(instance, p3); - } - - _end: - free(eval_objs); - - return p4; - } else { - _delete: - delete_tree(instance, args); - } - return &alsa_lisp_nil; -} - -struct alisp_object * F_gc(struct alisp_instance *instance ATTRIBUTE_UNUSED, struct alisp_object * args ATTRIBUTE_UNUSED) -{ - /* improved: no more traditional gc */ - return &alsa_lisp_t; -} - -/* - * Syntax: (path what) - * what is string ('data') - */ -struct alisp_object * F_path(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (!alisp_compare_type(p1, ALISP_OBJ_STRING)) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - if (!strcmp(p1->value.s, "data")) { - delete_tree(instance, p1); - return new_string(instance, snd_config_topdir()); - } - delete_tree(instance, p1); - return &alsa_lisp_nil; -} - -/* - * Syntax: (include filename...) - */ -struct alisp_object * F_include(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1; - int res = -ENOENT; - - do { - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, ALISP_OBJ_STRING)) - res = alisp_include_file(instance, p1->value.s); - delete_tree(instance, p1); - p = cdr(p1 = p); - delete_object(instance, p1); - } while (p != &alsa_lisp_nil); - - return new_integer(instance, res); -} - -/* - * Syntax: (string-to-integer value) - * 'value' can be integer or float type - */ -struct alisp_object * F_string_to_integer(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = eval(instance, car(args)), * p1; - - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (alisp_compare_type(p, ALISP_OBJ_INTEGER)) - return p; - if (alisp_compare_type(p, ALISP_OBJ_FLOAT)) { - p1 = new_integer(instance, floor(p->value.f)); - } else { - lisp_warn(instance, "expected an integer or float for integer conversion"); - p1 = &alsa_lisp_nil; - } - delete_tree(instance, p); - return p1; -} - -/* - * Syntax: (string-to-float value) - * 'value' can be integer or float type - */ -struct alisp_object * F_string_to_float(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = eval(instance, car(args)), * p1; - - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (alisp_compare_type(p, ALISP_OBJ_FLOAT)) - return p; - if (alisp_compare_type(p, ALISP_OBJ_INTEGER)) { - p1 = new_float(instance, p->value.i); - } else { - lisp_warn(instance, "expected an integer or float for integer conversion"); - p1 = &alsa_lisp_nil; - } - delete_tree(instance, p); - return p1; -} - -static int append_to_string(char **s, int *len, char *from, int size) -{ - if (*len == 0) { - *s = malloc(*len = size + 1); - if (*s == NULL) { - nomem(); - return -ENOMEM; - } - memcpy(*s, from, size); - } else { - *len += size; - *s = realloc(*s, *len); - if (*s == NULL) { - nomem(); - return -ENOMEM; - } - memcpy(*s + strlen(*s), from, size); - } - (*s)[*len - 1] = '\0'; - return 0; -} - -static int format_parse_char(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) -{ - char b; - - if (!alisp_compare_type(p, ALISP_OBJ_INTEGER)) { - lisp_warn(instance, "format: expected integer\n"); - return 0; - } - b = p->value.i; - return append_to_string(s, len, &b, 1); -} - -static int format_parse_integer(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) -{ - int res; - char *s1; - - if (!alisp_compare_type(p, ALISP_OBJ_INTEGER) && - !alisp_compare_type(p, ALISP_OBJ_FLOAT)) { - lisp_warn(instance, "format: expected integer or float\n"); - return 0; - } - s1 = malloc(64); - if (s1 == NULL) { - nomem(); - return -ENOMEM; - } - sprintf(s1, "%li", alisp_compare_type(p, ALISP_OBJ_FLOAT) ? (long)floor(p->value.f) : p->value.i); - res = append_to_string(s, len, s1, strlen(s1)); - free(s1); - return res; -} - -static int format_parse_float(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) -{ - int res; - char *s1; - - if (!alisp_compare_type(p, ALISP_OBJ_INTEGER) && - !alisp_compare_type(p, ALISP_OBJ_FLOAT)) { - lisp_warn(instance, "format: expected integer or float\n"); - return 0; - } - s1 = malloc(64); - if (s1 == NULL) { - nomem(); - return -ENOMEM; - } - sprintf(s1, "%f", alisp_compare_type(p, ALISP_OBJ_FLOAT) ? p->value.f : (double)p->value.i); - res = append_to_string(s, len, s1, strlen(s1)); - free(s1); - return res; -} - -static int format_parse_string(struct alisp_instance *instance, char **s, int *len, struct alisp_object *p) -{ - if (!alisp_compare_type(p, ALISP_OBJ_STRING)) { - lisp_warn(instance, "format: expected string\n"); - return 0; - } - return append_to_string(s, len, p->value.s, strlen(p->value.s)); -} - -/* - * Syntax: (format format value...) - * 'format' is C-like format string - */ -struct alisp_object * F_format(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = eval(instance, car(args)), * p1 = cdr(args), * n; - char *s, *s1, *s2; - int len; - - delete_object(instance, args); - if (!alisp_compare_type(p, ALISP_OBJ_STRING)) { - delete_tree(instance, p1); - delete_tree(instance, p); - lisp_warn(instance, "format: expected an format string"); - return &alsa_lisp_nil; - } - s = p->value.s; - s1 = NULL; - len = 0; - n = eval(instance, car(p1)); - do { - while (1) { - s2 = s; - while (*s2 && *s2 != '%') - s2++; - if (s2 != s) { - if (append_to_string(&s1, &len, s, s2 - s) < 0) { - __error: - delete_tree(instance, n); - delete_tree(instance, cdr(p1)); - delete_object(instance, p1); - delete_tree(instance, p); - return NULL; - } - } - if (*s2 == '%') - s2++; - switch (*s2) { - case '%': - if (append_to_string(&s1, &len, s2, 1) < 0) - goto __error; - s = s2 + 1; - break; - case 'c': - if (format_parse_char(instance, &s1, &len, n) < 0) - goto __error; - s = s2 + 1; - goto __next; - case 'd': - case 'i': - if (format_parse_integer(instance, &s1, &len, n) < 0) - goto __error; - s = s2 + 1; - goto __next; - case 'f': - if (format_parse_float(instance, &s1, &len, n) < 0) - goto __error; - s = s2 + 1; - goto __next; - case 's': - if (format_parse_string(instance, &s1, &len, n) < 0) - goto __error; - s = s2 + 1; - goto __next; - case '\0': - goto __end; - default: - lisp_warn(instance, "unknown format char '%c'", *s2); - s = s2 + 1; - goto __next; - } - } - __next: - delete_tree(instance, n); - p1 = cdr(n = p1); - delete_object(instance, n); - n = eval(instance, car(p1)); - } while (*s); - __end: - delete_tree(instance, n); - delete_tree(instance, cdr(p1)); - delete_object(instance, p1); - delete_tree(instance, p); - if (len > 0) { - p1 = new_string(instance, s1); - free(s1); - } else { - p1 = &alsa_lisp_nil; - } - return p1; -} - -/* - * Syntax: (compare-strings str1 start1 end1 str2 start2 end2 /opt-case-insensitive) - * 'str1' is first compared string - * 'start1' is first char (0..) - * 'end1' is last char (0..) - * 'str2' is second compared string - * 'start2' is first char (0..) - * 'end2' is last char (0..) - * /opt-case-insensitive true - case insensitive match - */ -struct alisp_object * F_compare_strings(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1 = args, * n, * p[7]; - char *s1, *s2; - int start1, end1, start2, end2; - - for (start1 = 0; start1 < 7; start1++) { - p[start1] = eval(instance, car(p1)); - p1 = cdr(n = p1); - delete_object(instance, n); - } - delete_tree(instance, p1); - if (alisp_compare_type(p[0], ALISP_OBJ_STRING)) { - lisp_warn(instance, "compare-strings: first argument must be string\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - if (alisp_compare_type(p[1], ALISP_OBJ_INTEGER)) { - lisp_warn(instance, "compare-strings: second argument must be integer\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - if (alisp_compare_type(p[2], ALISP_OBJ_INTEGER)) { - lisp_warn(instance, "compare-strings: third argument must be integer\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - if (alisp_compare_type(p[3], ALISP_OBJ_STRING)) { - lisp_warn(instance, "compare-strings: fifth argument must be string\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - if (!alisp_compare_type(p[4], ALISP_OBJ_NIL) && - !alisp_compare_type(p[4], ALISP_OBJ_INTEGER)) { - lisp_warn(instance, "compare-strings: fourth argument must be integer\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - if (!alisp_compare_type(p[5], ALISP_OBJ_NIL) && - !alisp_compare_type(p[5], ALISP_OBJ_INTEGER)) { - lisp_warn(instance, "compare-strings: sixth argument must be integer\n"); - p1 = &alsa_lisp_nil; - goto __err; - } - s1 = p[0]->value.s; - start1 = p[1]->value.i; - end1 = p[2]->value.i; - s2 = p[3]->value.s; - start2 = alisp_compare_type(p[4], ALISP_OBJ_NIL) ? 0 : p[4]->value.i; - end2 = alisp_compare_type(p[5], ALISP_OBJ_NIL) ? start2 + (end1 - start1) : p[5]->value.i; - if (start1 < 0 || start2 < 0 || end1 < 0 || end2 < 0 || - start1 >= (int)strlen(s1) || start2 >= (int)strlen(s2) || - (end1 - start1) != (end2 - start2)) { - p1 = &alsa_lisp_nil; - goto __err; - } - if (p[6] != &alsa_lisp_nil) { - while (start1 < end1) { - if (s1[start1] == '\0' || - s2[start2] == '\0' || - tolower(s1[start1]) != tolower(s2[start2])) { - p1 = &alsa_lisp_nil; - goto __err; - } - start1++; - start2++; - } - } else { - while (start1 < end1) { - if (s1[start1] == '\0' || - s2[start2] == '\0' || - s1[start1] != s2[start2]) { - p1 = &alsa_lisp_nil; - goto __err; - } - start1++; - start2++; - } - } - p1 = &alsa_lisp_t; - - __err: - for (start1 = 0; start1 < 7; start1++) - delete_tree(instance, p[start1]); - return p1; -} - -/* - * Syntax: (assoc key alist) - */ -struct alisp_object * F_assoc(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2, * n; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - do { - if (eq(p1, car(car(p2)))) { - n = car(p2); - delete_tree(instance, p1); - delete_tree(instance, cdr(p2)); - delete_object(instance, p2); - return n; - } - delete_tree(instance, car(p2)); - p2 = cdr(n = p2); - delete_object(instance, n); - } while (p2 != &alsa_lisp_nil); - - delete_tree(instance, p1); - return &alsa_lisp_nil; -} - -/* - * Syntax: (rassoc value alist) - */ -struct alisp_object * F_rassoc(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, *p2, * n; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - do { - if (eq(p1, cdr(car(p2)))) { - n = car(p2); - delete_tree(instance, p1); - delete_tree(instance, cdr(p2)); - delete_object(instance, p2); - return n; - } - delete_tree(instance, car(p2)); - p2 = cdr(n = p2); - delete_object(instance, n); - } while (p2 != &alsa_lisp_nil); - - delete_tree(instance, p1); - return &alsa_lisp_nil; -} - -/* - * Syntax: (assq key alist) - */ -struct alisp_object * F_assq(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2, * n; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - do { - if (equal(p1, car(car(p2)))) { - n = car(p2); - delete_tree(instance, p1); - delete_tree(instance, cdr(p2)); - delete_object(instance, p2); - return n; - } - delete_tree(instance, car(p2)); - p2 = cdr(n = p2); - delete_object(instance, n); - } while (p2 != &alsa_lisp_nil); - - delete_tree(instance, p1); - return &alsa_lisp_nil; -} - -/* - * Syntax: (nth index alist) - */ -struct alisp_object * F_nth(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2, * n; - long idx; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - if (!alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - delete_tree(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; - } - if (!alisp_compare_type(p2, ALISP_OBJ_CONS)) { - delete_object(instance, p1); - delete_tree(instance, p2); - return &alsa_lisp_nil; - } - idx = p1->value.i; - delete_object(instance, p1); - while (idx-- > 0) { - delete_tree(instance, car(p2)); - p2 = cdr(n = p2); - delete_object(instance, n); - } - n = car(p2); - delete_tree(instance, cdr(p2)); - delete_object(instance, p2); - return n; -} - -/* - * Syntax: (rassq value alist) - */ -struct alisp_object * F_rassq(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, * p2, * n; - - p1 = eval(instance, car(args)); - p2 = eval(instance, car(cdr(args))); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - - do { - if (equal(p1, cdr(car(p2)))) { - n = car(p2); - delete_tree(instance, p1); - delete_tree(instance, cdr(p2)); - delete_object(instance, p2); - return n; - } - delete_tree(instance, car(p2)); - p2 = cdr(n = p2); - delete_object(instance, n); - } while (p2 != &alsa_lisp_nil); - - delete_tree(instance, p1); - return &alsa_lisp_nil; -} - -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 && - alisp_compare_type(p, ALISP_OBJ_STRING)) { - if (strlen(p->value.s) > 0) { - dump_objects(instance, p->value.s); - delete_tree(instance, args); - return &alsa_lisp_t; - } else - lisp_warn(instance, "expected filename"); - } else - lisp_warn(instance, "wrong number of parameters (expected string)"); - - delete_tree(instance, args); - return &alsa_lisp_nil; -} - -static struct alisp_object * F_stat_memory(struct alisp_instance *instance, struct alisp_object * args) -{ - snd_output_printf(instance->out, "*** Memory stats\n"); - snd_output_printf(instance->out, " used_objs = %li, free_objs = %li, max_objs = %li, obj_size = %i (total bytes = %li, max bytes = %li)\n", - instance->used_objs, - instance->free_objs, - instance->max_objs, - (int)sizeof(struct alisp_object), - (long)((instance->used_objs + instance->free_objs) * sizeof(struct alisp_object)), - (long)(instance->max_objs * sizeof(struct alisp_object))); - delete_tree(instance, args); - return &alsa_lisp_nil; -} - -static struct alisp_object * F_check_memory(struct alisp_instance *instance, struct alisp_object * args) -{ - delete_tree(instance, args); - if (instance->used_objs > 0) { - fprintf(stderr, "!!!alsa lisp - check memory failed!!!\n"); - F_stat_memory(instance, &alsa_lisp_nil); - exit(EXIT_FAILURE); - } - return &alsa_lisp_t; -} - -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 && - alisp_compare_type(p, ALISP_OBJ_STRING)) { - if (strlen(p->value.s) > 0) { - dump_obj_lists(instance, p->value.s); - delete_tree(instance, args); - return &alsa_lisp_t; - } else - lisp_warn(instance, "expected filename"); - } else - lisp_warn(instance, "wrong number of parameters (expected string)"); - - delete_tree(instance, args); - return &alsa_lisp_nil; -} - -struct intrinsic { - const char *name; - struct alisp_object * (*func)(struct alisp_instance *instance, struct alisp_object * args); -}; - -static const struct intrinsic intrinsics[] = { - { "!=", F_numneq }, - { "%", F_mod }, - { "&check-memory", F_check_memory }, - { "&dump-memory", F_dump_memory }, - { "&dump-objects", F_dump_objects }, - { "&stat-memory", F_stat_memory }, - { "*", F_mul }, - { "+", F_add }, - { "-", F_sub }, - { "/", F_div }, - { "<", F_lt }, - { "<=", F_le }, - { "=", F_numeq }, - { ">", F_gt }, - { ">=", F_ge }, - { "and", F_and }, - { "assoc", F_assoc }, - { "assq", F_assq }, - { "atom", F_atom }, - { "car", F_car }, - { "cdr", F_cdr }, - { "compare-strings", F_compare_strings }, - { "concat", F_concat }, - { "cond", F_cond }, - { "cons", F_cons }, - { "defun", F_defun }, - { "eq", F_eq }, - { "equal", F_equal }, - { "eval", F_eval }, - { "exfun", F_exfun }, - { "format", F_format }, - { "funcall", F_funcall }, - { "garbage-collect", F_gc }, - { "gc", F_gc }, - { "if", F_if }, - { "include", F_include }, - { "list", F_list }, - { "not", F_not }, - { "nth", F_nth }, - { "null", F_not }, - { "or", F_or }, - { "path", F_path }, - { "princ", F_princ }, - { "prog1", F_prog1 }, - { "prog2", F_prog2 }, - { "progn", F_progn }, - { "quote", F_quote }, - { "rassoc", F_rassoc }, - { "rassq", F_rassq }, - { "set", F_set }, - { "setf", F_setq }, - { "setq", F_setq }, - { "string-equal", F_equal }, - { "string-to-float", F_string_to_float }, - { "string-to-integer", F_string_to_integer }, - { "string-to-number", F_string_to_float }, - { "string=", F_equal }, - { "unless", F_unless }, - { "unset", F_unset }, - { "unsetf", F_unsetq }, - { "unsetq", F_unsetq }, - { "when", F_when }, - { "while", F_while }, -}; - -#include "alisp_snd.c" - -static int compar(const void *p1, const void *p2) -{ - return strcmp(((struct intrinsic *)p1)->name, - ((struct intrinsic *)p2)->name); -} - -static inline struct alisp_object * eval_cons1(struct alisp_instance *instance, struct alisp_object * p1, struct alisp_object * p2) -{ - struct alisp_object * p3; - struct intrinsic key, *item; - - key.name = p1->value.s; - - if ((item = bsearch(&key, intrinsics, - sizeof intrinsics / sizeof intrinsics[0], - sizeof intrinsics[0], compar)) != NULL) { - delete_object(instance, p1); - return item->func(instance, p2); - } - - if ((item = bsearch(&key, snd_intrinsics, - sizeof snd_intrinsics / sizeof snd_intrinsics[0], - sizeof snd_intrinsics[0], compar)) != NULL) { - delete_object(instance, p1); - return item->func(instance, p2); - } - - if ((p3 = get_object(instance, p1)) != &alsa_lisp_nil) { - delete_object(instance, p1); - return eval_func(instance, p3, p2); - } else { - lisp_warn(instance, "function `%s' is undefined", p1->value.s); - delete_object(instance, p1); - delete_tree(instance, p2); - } - - return &alsa_lisp_nil; -} - -/* - * Syntax: (funcall function args...) - */ -static struct alisp_object * F_funcall(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = eval(instance, car(args)), * p1; - - if (!alisp_compare_type(p, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(p, ALISP_OBJ_STRING)) { - lisp_warn(instance, "expected an function name"); - delete_tree(instance, p); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - return &alsa_lisp_nil; - } - p1 = cdr(args); - delete_object(instance, args); - return eval_cons1(instance, p, p1); -} - -static inline struct alisp_object * eval_cons(struct alisp_instance *instance, struct alisp_object * p) -{ - struct alisp_object * p1 = car(p), * p2; - - if (p1 != &alsa_lisp_nil && alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER)) { - if (!strcmp(p1->value.s, "lambda")) - return p; - - p2 = cdr(p); - delete_object(instance, p); - return eval_cons1(instance, p1, p2); - } else { - delete_tree(instance, p); - } - - return &alsa_lisp_nil; -} - -static struct alisp_object * eval(struct alisp_instance *instance, struct alisp_object * p) -{ - switch (alisp_get_type(p)) { - case ALISP_OBJ_IDENTIFIER: { - struct alisp_object *r = incref_tree(instance, get_object(instance, p)); - delete_object(instance, p); - return r; - } - case ALISP_OBJ_INTEGER: - case ALISP_OBJ_FLOAT: - case ALISP_OBJ_STRING: - case ALISP_OBJ_POINTER: - return p; - case ALISP_OBJ_CONS: - return eval_cons(instance, p); - default: - break; - } - - 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 - */ - -static int alisp_include_file(struct alisp_instance *instance, const char *filename) -{ - snd_input_t *old_in; - struct alisp_object *p, *p1; - char *name; - int retval = 0, err; - - err = snd_user_file(filename, &name); - if (err < 0) - return err; - old_in = instance->in; - err = snd_input_stdio_open(&instance->in, name, "r"); - if (err < 0) { - retval = err; - goto _err; - } - if (instance->verbose) - lisp_verbose(instance, "** include filename '%s'", name); - - for (;;) { - if ((p = parse_object(instance, 0)) == NULL) - break; - if (instance->verbose) { - lisp_verbose(instance, "** code"); - princ_object(instance->vout, p); - snd_output_putc(instance->vout, '\n'); - } - p1 = eval(instance, p); - if (p1 == NULL) { - retval = -ENOMEM; - break; - } - if (instance->verbose) { - lisp_verbose(instance, "** result"); - princ_object(instance->vout, p1); - snd_output_putc(instance->vout, '\n'); - } - delete_tree(instance, p1); - if (instance->debug) { - lisp_debug(instance, "** objects after operation"); - print_obj_lists(instance, instance->dout); - } - } - - snd_input_close(instance->in); - _err: - free(name); - instance->in = old_in; - return retval; -} - -int alsa_lisp(struct alisp_cfg *cfg, struct alisp_instance **_instance) -{ - struct alisp_instance *instance; - struct alisp_object *p, *p1; - int i, j, retval = 0; - - instance = (struct alisp_instance *)calloc(1, 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->eout = cfg->eout; - instance->wout = cfg->wout; - instance->dout = cfg->dout; - INIT_LIST_HEAD(&instance->free_objs_list); - for (i = 0; i < ALISP_OBJ_PAIR_HASH_SIZE; i++) { - for (j = 0; j <= ALISP_OBJ_LAST_SEARCH; j++) - INIT_LIST_HEAD(&instance->used_objs_list[i][j]); - INIT_LIST_HEAD(&instance->setobjs_list[i]); - } - - init_lex(instance); - - for (;;) { - if ((p = parse_object(instance, 0)) == NULL) - break; - if (instance->verbose) { - lisp_verbose(instance, "** code"); - princ_object(instance->vout, p); - snd_output_putc(instance->vout, '\n'); - } - p1 = eval(instance, p); - if (p1 == NULL) { - retval = -ENOMEM; - break; - } - if (instance->verbose) { - lisp_verbose(instance, "** result"); - princ_object(instance->vout, p1); - snd_output_putc(instance->vout, '\n'); - } - delete_tree(instance, p1); - if (instance->debug) { - lisp_debug(instance, "** objects after operation"); - print_obj_lists(instance, instance->dout); - } - } - - if (_instance) - *_instance = instance; - else - alsa_lisp_free(instance); - - return retval; -} - -void alsa_lisp_free(struct alisp_instance *instance) -{ - if (instance == NULL) - return; - done_lex(instance); - free_objects(instance); - free(instance); -} - -struct alisp_cfg *alsa_lisp_default_cfg(snd_input_t *input) -{ - snd_output_t *output, *eoutput; - struct alisp_cfg *cfg; - int err; - - err = snd_output_stdio_attach(&output, stdout, 0); - if (err < 0) - return NULL; - err = snd_output_stdio_attach(&eoutput, stderr, 0); - if (err < 0) { - snd_output_close(output); - return NULL; - } - cfg = calloc(1, sizeof(struct alisp_cfg)); - if (cfg == NULL) { - snd_output_close(eoutput); - snd_output_close(output); - return NULL; - } - cfg->out = output; - cfg->wout = eoutput; - cfg->eout = eoutput; - cfg->dout = eoutput; - cfg->in = input; - return cfg; -} - -void alsa_lisp_default_cfg_free(struct alisp_cfg *cfg) -{ - snd_input_close(cfg->in); - snd_output_close(cfg->out); - snd_output_close(cfg->dout); - free(cfg); -} - -int alsa_lisp_function(struct alisp_instance *instance, struct alisp_seq_iterator **result, - const char *id, const char *args, ...) -{ - int err = 0; - struct alisp_object *aargs = NULL, *obj, *res; - - if (args && *args != 'n') { - va_list ap; - struct alisp_object *p; - p = NULL; - va_start(ap, args); - while (*args) { - if (*args++ != '%') { - err = -EINVAL; - break; - } - if (*args == '\0') { - err = -EINVAL; - break; - } - obj = NULL; - err = 0; - switch (*args++) { - case 's': - obj = new_string(instance, va_arg(ap, char *)); - break; - case 'i': - obj = new_integer(instance, va_arg(ap, int)); - break; - case 'l': - obj = new_integer(instance, va_arg(ap, long)); - break; - case 'f': - case 'd': - obj = new_integer(instance, va_arg(ap, double)); - break; - case 'p': { - char _ptrid[24]; - char *ptrid = _ptrid; - while (*args && *args != '%') - *ptrid++ = *args++; - *ptrid = 0; - if (ptrid == _ptrid) { - err = -EINVAL; - break; - } - obj = new_cons_pointer(instance, _ptrid, va_arg(ap, void *)); - obj = quote_object(instance, obj); - break; - } - default: - err = -EINVAL; - break; - } - if (err < 0) - goto __args_end; - if (obj == NULL) { - err = -ENOMEM; - goto __args_end; - } - if (p == NULL) { - p = aargs = new_object(instance, ALISP_OBJ_CONS); - } else { - p->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); - p = p->value.c.cdr; - } - if (p == NULL) { - err = -ENOMEM; - goto __args_end; - } - p->value.c.car = obj; - } - __args_end: - va_end(ap); - if (err < 0) - return err; -#if 0 - snd_output_printf(instance->wout, ">>>"); - princ_object(instance->wout, aargs); - snd_output_printf(instance->wout, "<<<\n"); -#endif - } - - err = -ENOENT; - if (aargs == NULL) - aargs = &alsa_lisp_nil; - if ((obj = get_object1(instance, id)) != &alsa_lisp_nil) { - res = eval_func(instance, obj, aargs); - err = 0; - } else { - struct intrinsic key, *item; - key.name = id; - if ((item = bsearch(&key, intrinsics, - sizeof intrinsics / sizeof intrinsics[0], - sizeof intrinsics[0], compar)) != NULL) { - res = item->func(instance, aargs); - err = 0; - } else if ((item = bsearch(&key, snd_intrinsics, - sizeof snd_intrinsics / sizeof snd_intrinsics[0], - sizeof snd_intrinsics[0], compar)) != NULL) { - res = item->func(instance, aargs); - err = 0; - } else { - res = &alsa_lisp_nil; - } - } - if (res == NULL) - err = -ENOMEM; - if (err == 0 && result) { - *result = res; - } else { - delete_tree(instance, res); - } - - return 0; -} - -void alsa_lisp_result_free(struct alisp_instance *instance, - struct alisp_seq_iterator *result) -{ - delete_tree(instance, result); -} - -int alsa_lisp_seq_first(struct alisp_instance *instance, const char *id, - struct alisp_seq_iterator **seq) -{ - struct alisp_object * p1; - - p1 = get_object1(instance, id); - if (p1 == NULL) - return -ENOMEM; - *seq = p1; - return 0; -} - -int alsa_lisp_seq_next(struct alisp_seq_iterator **seq) -{ - struct alisp_object * p1 = *seq; - - p1 = cdr(p1); - if (p1 == &alsa_lisp_nil) - return -ENOENT; - *seq = p1; - return 0; -} - -int alsa_lisp_seq_count(struct alisp_seq_iterator *seq) -{ - int count = 0; - - while (seq != &alsa_lisp_nil) { - count++; - seq = cdr(seq); - } - return count; -} - -int alsa_lisp_seq_integer(struct alisp_seq_iterator *seq, long *val) -{ - if (alisp_compare_type(seq, ALISP_OBJ_CONS)) - seq = seq->value.c.cdr; - if (alisp_compare_type(seq, ALISP_OBJ_INTEGER)) - *val = seq->value.i; - else - return -EINVAL; - return 0; -} - -int alsa_lisp_seq_pointer(struct alisp_seq_iterator *seq, const char *ptr_id, void **ptr) -{ - struct alisp_object * p2; - - if (alisp_compare_type(seq, ALISP_OBJ_CONS) && - alisp_compare_type(seq->value.c.car, ALISP_OBJ_CONS)) - seq = seq->value.c.car; - if (alisp_compare_type(seq, ALISP_OBJ_CONS)) { - p2 = seq->value.c.car; - if (!alisp_compare_type(p2, ALISP_OBJ_STRING)) - return -EINVAL; - if (strcmp(p2->value.s, ptr_id)) - return -EINVAL; - p2 = seq->value.c.cdr; - if (!alisp_compare_type(p2, ALISP_OBJ_POINTER)) - return -EINVAL; - *ptr = (void *)seq->value.ptr; - } else - return -EINVAL; - return 0; -} diff --git a/src/alisp/alisp_local.h b/src/alisp/alisp_local.h deleted file mode 100644 index af638843..00000000 --- a/src/alisp/alisp_local.h +++ /dev/null @@ -1,151 +0,0 @@ -/* - * ALSA lisp implementation - * Copyright (c) 2003 by Jaroslav Kysela - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - */ - -#include "list.h" - -enum alisp_tokens { - ALISP_IDENTIFIER, - ALISP_INTEGER, - ALISP_FLOAT, - ALISP_FLOATE, - ALISP_STRING -}; - -enum alisp_objects { - ALISP_OBJ_INTEGER, - ALISP_OBJ_FLOAT, - ALISP_OBJ_IDENTIFIER, - ALISP_OBJ_STRING, - ALISP_OBJ_POINTER, - ALISP_OBJ_CONS, - ALISP_OBJ_LAST_SEARCH = ALISP_OBJ_CONS, - ALISP_OBJ_NIL, - ALISP_OBJ_T, -}; - -struct alisp_object; - -#define ALISP_TYPE_MASK 0xf0000000 -#define ALISP_TYPE_SHIFT 28 -#define ALISP_REFS_MASK 0x0fffffff -#define ALISP_REFS_SHIFT 0 -#define ALISP_MAX_REFS (ALISP_REFS_MASK>>ALISP_REFS_SHIFT) -#define ALISP_MAX_REFS_LIMIT ((ALISP_MAX_REFS + 1) / 2) - -struct alisp_object { - struct list_head list; - unsigned int type_refs; /* type and count of references */ - union { - char *s; - long i; - double f; - const void *ptr; - struct { - struct alisp_object *car; - struct alisp_object *cdr; - } c; - } value; -}; - -static inline enum alisp_objects alisp_get_type(struct alisp_object *p) -{ - return (p->type_refs >> ALISP_TYPE_SHIFT); -} - -static inline void alisp_set_type(struct alisp_object *p, enum alisp_objects type) -{ - p->type_refs &= ~ALISP_TYPE_MASK; - p->type_refs |= (unsigned int)type << ALISP_TYPE_SHIFT; -} - -static inline int alisp_compare_type(struct alisp_object *p, enum alisp_objects type) -{ - return ((unsigned int)type << ALISP_TYPE_SHIFT) == - (p->type_refs & ALISP_TYPE_MASK); -} - -static inline void alisp_set_refs(struct alisp_object *p, unsigned int refs) -{ - p->type_refs &= ~ALISP_REFS_MASK; - p->type_refs |= refs & ALISP_REFS_MASK; -} - -static inline unsigned int alisp_get_refs(struct alisp_object *p) -{ - return p->type_refs & ALISP_REFS_MASK; -} - -static inline unsigned int alisp_inc_refs(struct alisp_object *p) -{ - unsigned r = alisp_get_refs(p) + 1; - alisp_set_refs(p, r); - return r; -} - -static inline unsigned int alisp_dec_refs(struct alisp_object *p) -{ - unsigned r = alisp_get_refs(p) - 1; - alisp_set_refs(p, r); - return r; -} - -struct alisp_object_pair { - struct list_head list; - const char *name; - struct alisp_object *value; -}; - -#define ALISP_LEX_BUF_MAX 16 -#define ALISP_OBJ_PAIR_HASH_SHIFT 4 -#define ALISP_OBJ_PAIR_HASH_SIZE (1< - * - * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - */ - -#include "../control/control_local.h" - -struct acall_table { - const char *name; - struct alisp_object * (*func) (struct alisp_instance *instance, struct acall_table * item, struct alisp_object * args); - void * xfunc; - const char *prefix; -}; - -/* - * helper functions - */ - -static inline int get_integer(struct alisp_object * obj) -{ - if (alisp_compare_type(obj, ALISP_OBJ_INTEGER)) - return obj->value.i; - return 0; -} - -static inline const void *get_pointer(struct alisp_object * obj) -{ - if (alisp_compare_type(obj, ALISP_OBJ_POINTER)) - return obj->value.ptr; - return NULL; -} - -static const char *get_string(struct alisp_object * obj, const char * deflt) -{ - if (obj == &alsa_lisp_t) - return "true"; - if (alisp_compare_type(obj, ALISP_OBJ_STRING) || - alisp_compare_type(obj, ALISP_OBJ_IDENTIFIER)) - return obj->value.s; - return deflt; -} - -struct flags { - const char *key; - unsigned int mask; -}; - -static unsigned int get_flags(struct alisp_instance * instance, - struct alisp_object * obj, - const struct flags * flags, - unsigned int deflt) -{ - const char *key; - int invert; - unsigned int result; - const struct flags *ptr; - struct alisp_object *n; - - if (obj == &alsa_lisp_nil) - return deflt; - result = deflt; - do { - key = get_string(obj, NULL); - if (key) { - invert = key[0] == '!'; - key += invert; - ptr = flags; - while (ptr->key) { - if (!strcmp(ptr->key, key)) { - if (invert) - result &= ~ptr->mask; - else - result |= ptr->mask; - break; - } - ptr++; - } - } - delete_tree(instance, car(obj)); - obj = cdr(n = obj); - delete_object(instance, n); - } while (obj != &alsa_lisp_nil); - return result; -} - -static const void *get_ptr(struct alisp_instance * instance, - struct alisp_object * obj, - const char *_ptr_id) -{ - const char *ptr_id; - const void *ptr; - - ptr_id = get_string(car(obj), NULL); - if (ptr_id == NULL) { - delete_tree(instance, obj); - return NULL; - } - if (strcmp(ptr_id, _ptr_id)) { - delete_tree(instance, obj); - return NULL; - } - ptr = get_pointer(cdr(obj)); - delete_tree(instance, obj); - return ptr; -} - -static struct alisp_object * new_lexpr(struct alisp_instance * instance, int err) -{ - struct alisp_object * lexpr; - - lexpr = new_object(instance, ALISP_OBJ_CONS); - if (lexpr == NULL) - return NULL; - lexpr->value.c.car = new_integer(instance, err); - if (lexpr->value.c.car == NULL) { - delete_object(instance, lexpr); - return NULL; - } - lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); - if (lexpr->value.c.cdr == NULL) { - delete_object(instance, lexpr->value.c.car); - delete_object(instance, lexpr); - return NULL; - } - return lexpr; -} - -static struct alisp_object * add_cons(struct alisp_instance * instance, - struct alisp_object *lexpr, - int cdr, const char *id, - struct alisp_object *obj) -{ - struct alisp_object * p1, * p2; - - if (lexpr == NULL || obj == NULL) { - delete_tree(instance, obj); - return NULL; - } - if (cdr) { - p1 = lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); - } else { - p1 = lexpr->value.c.car = new_object(instance, ALISP_OBJ_CONS); - } - lexpr = p1; - if (p1 == NULL) { - delete_tree(instance, obj); - return NULL; - } - p1->value.c.car = new_object(instance, ALISP_OBJ_CONS); - if ((p2 = p1->value.c.car) == NULL) - goto __err; - p2->value.c.car = new_string(instance, id); - if (p2->value.c.car == NULL) { - __err: - if (cdr) - lexpr->value.c.cdr = NULL; - else - lexpr->value.c.car = NULL; - delete_tree(instance, p1); - delete_tree(instance, obj); - return NULL; - } - p2->value.c.cdr = obj; - return lexpr; -} - -static struct alisp_object * add_cons2(struct alisp_instance * instance, - struct alisp_object *lexpr, - int cdr, struct alisp_object *obj) -{ - struct alisp_object * p1; - - if (lexpr == NULL || obj == NULL) { - delete_tree(instance, obj); - return NULL; - } - if (cdr) { - p1 = lexpr->value.c.cdr = new_object(instance, ALISP_OBJ_CONS); - } else { - p1 = lexpr->value.c.car = new_object(instance, ALISP_OBJ_CONS); - } - lexpr = p1; - if (p1 == NULL) { - delete_tree(instance, obj); - return NULL; - } - p1->value.c.car = obj; - return lexpr; -} - -static struct alisp_object * new_result1(struct alisp_instance * instance, - int err, const char *ptr_id, void *ptr) -{ - struct alisp_object * lexpr, * p1; - - if (err < 0) - ptr = NULL; - lexpr = new_object(instance, ALISP_OBJ_CONS); - if (lexpr == NULL) - return NULL; - lexpr->value.c.car = new_integer(instance, err); - if (lexpr->value.c.car == NULL) { - delete_object(instance, lexpr); - return NULL; - } - p1 = add_cons(instance, lexpr, 1, ptr_id, new_pointer(instance, ptr)); - if (p1 == NULL) { - delete_object(instance, lexpr); - return NULL; - } - return lexpr; -} - -static struct alisp_object * new_result2(struct alisp_instance * instance, - int err, int val) -{ - struct alisp_object * lexpr, * p1; - - if (err < 0) - val = 0; - lexpr = new_lexpr(instance, err); - if (lexpr == NULL) - return NULL; - p1 = lexpr->value.c.cdr; - p1->value.c.car = new_integer(instance, val); - if (p1->value.c.car == NULL) { - delete_object(instance, lexpr); - return NULL; - } - return lexpr; -} - -static struct alisp_object * new_result3(struct alisp_instance * instance, - int err, const char *str) -{ - struct alisp_object * lexpr, * p1; - - if (err < 0) - str = ""; - lexpr = new_lexpr(instance, err); - if (lexpr == NULL) - return NULL; - p1 = lexpr->value.c.cdr; - p1->value.c.car = new_string(instance, str); - if (p1->value.c.car == NULL) { - delete_object(instance, lexpr); - return NULL; - } - return lexpr; -} - -/* - * macros - */ - -/* - * HCTL functions - */ - -typedef int (*snd_int_pp_strp_int_t)(void **rctl, const char *name, int mode); -typedef int (*snd_int_pp_p_t)(void **rctl, void *handle); -typedef int (*snd_int_p_t)(void *rctl); -typedef char * (*snd_str_p_t)(void *rctl); -typedef int (*snd_int_intp_t)(int *val); -typedef int (*snd_int_str_t)(const char *str); -typedef int (*snd_int_int_strp_t)(int val, char **str); -typedef void *(*snd_p_p_t)(void *handle); - -static struct alisp_object * FA_int_pp_strp_int(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - const char *name; - int err, mode; - void *handle; - struct alisp_object *p1, *p2; - static const struct flags flags[] = { - { "nonblock", SND_CTL_NONBLOCK }, - { "async", SND_CTL_ASYNC }, - { "readonly", SND_CTL_READONLY }, - { NULL, 0 } - }; - - name = get_string(p1 = eval(instance, car(args)), NULL); - if (name == NULL) - return &alsa_lisp_nil; - mode = get_flags(instance, p2 = eval(instance, car(cdr(args))), flags, 0); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - delete_tree(instance, p2); - err = ((snd_int_pp_strp_int_t)item->xfunc)(&handle, name, mode); - delete_tree(instance, p1); - return new_result1(instance, err, item->prefix, handle); -} - -static struct alisp_object * FA_int_pp_p(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - int err; - void *handle; - const char *prefix1; - struct alisp_object *p1; - - if (item->xfunc == &snd_hctl_open_ctl) - prefix1 = "ctl"; - else { - delete_tree(instance, args); - return &alsa_lisp_nil; - } - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (void *)get_ptr(instance, p1, prefix1); - if (handle == NULL) - return &alsa_lisp_nil; - err = ((snd_int_pp_p_t)item->xfunc)(&handle, handle); - return new_result1(instance, err, item->prefix, handle); -} - -static struct alisp_object * FA_p_p(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - void *handle; - const char *prefix1; - struct alisp_object * p1; - - if (item->xfunc == &snd_hctl_first_elem || - item->xfunc == &snd_hctl_last_elem || - item->xfunc == &snd_hctl_elem_next || - item->xfunc == &snd_hctl_elem_prev) - prefix1 = "hctl_elem"; - else if (item->xfunc == &snd_hctl_ctl) - prefix1 = "ctl"; - else { - delete_tree(instance, args); - return &alsa_lisp_nil; - } - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (void *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - handle = ((snd_p_p_t)item->xfunc)(handle); - return new_cons_pointer(instance, prefix1, handle); -} - -static struct alisp_object * FA_int_p(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - void *handle; - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (void *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - return new_integer(instance, ((snd_int_p_t)item->xfunc)(handle)); -} - -static struct alisp_object * FA_str_p(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - void *handle; - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (void *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - return new_string(instance, ((snd_str_p_t)item->xfunc)(handle)); -} - -static struct alisp_object * FA_int_intp(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - int val, err; - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (!alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - val = p1->value.i; - delete_tree(instance, p1); - err = ((snd_int_intp_t)item->xfunc)(&val); - return new_result2(instance, err, val); -} - -static struct alisp_object * FA_int_str(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - int err; - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (!alisp_compare_type(p1, ALISP_OBJ_STRING) && - !alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER)) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - err = ((snd_int_str_t)item->xfunc)(p1->value.s); - delete_tree(instance, p1); - return new_integer(instance, err); -} - -static struct alisp_object * FA_int_int_strp(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - int err; - char *str; - long val; - struct alisp_object * p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - if (!alisp_compare_type(p1, ALISP_OBJ_INTEGER)) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - val = p1->value.i; - delete_tree(instance, p1); - err = ((snd_int_int_strp_t)item->xfunc)(val, &str); - return new_result3(instance, err, str); -} - -static struct alisp_object * FA_card_info(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_ctl_t *handle; - struct alisp_object * lexpr, * p1; - snd_ctl_card_info_t info = {0}; - int err; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (snd_ctl_t *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - err = snd_ctl_card_info(handle, &info); - lexpr = new_lexpr(instance, err); - if (err < 0) - return lexpr; - p1 = add_cons(instance, lexpr->value.c.cdr, 0, "id", new_string(instance, snd_ctl_card_info_get_id(&info))); - p1 = add_cons(instance, p1, 1, "driver", new_string(instance, snd_ctl_card_info_get_driver(&info))); - p1 = add_cons(instance, p1, 1, "name", new_string(instance, snd_ctl_card_info_get_name(&info))); - p1 = add_cons(instance, p1, 1, "longname", new_string(instance, snd_ctl_card_info_get_longname(&info))); - p1 = add_cons(instance, p1, 1, "mixername", new_string(instance, snd_ctl_card_info_get_mixername(&info))); - p1 = add_cons(instance, p1, 1, "components", new_string(instance, snd_ctl_card_info_get_components(&info))); - if (p1 == NULL) { - delete_tree(instance, lexpr); - return NULL; - } - return lexpr; -} - -static struct alisp_object * create_ctl_elem_id(struct alisp_instance * instance, snd_ctl_elem_id_t * id, struct alisp_object * cons) -{ - cons = add_cons(instance, cons, 0, "numid", new_integer(instance, snd_ctl_elem_id_get_numid(id))); - cons = add_cons(instance, cons, 1, "iface", new_string(instance, snd_ctl_elem_iface_name(snd_ctl_elem_id_get_interface(id)))); - cons = add_cons(instance, cons, 1, "dev", new_integer(instance, snd_ctl_elem_id_get_device(id))); - cons = add_cons(instance, cons, 1, "subdev", new_integer(instance, snd_ctl_elem_id_get_subdevice(id))); - cons = add_cons(instance, cons, 1, "name", new_string(instance, snd_ctl_elem_id_get_name(id))); - cons = add_cons(instance, cons, 1, "index", new_integer(instance, snd_ctl_elem_id_get_index(id))); - return cons; -} - -static int parse_ctl_elem_id(struct alisp_instance * instance, - struct alisp_object * cons, - snd_ctl_elem_id_t * id) -{ - struct alisp_object *p1; - const char *xid; - - if (cons == NULL) - return -ENOMEM; - snd_ctl_elem_id_clear(id); - id->numid = 0; - do { - p1 = car(cons); - if (alisp_compare_type(p1, ALISP_OBJ_CONS)) { - xid = get_string(p1->value.c.car, NULL); - if (xid == NULL) { - /* noop */ - } else if (!strcmp(xid, "numid")) { - snd_ctl_elem_id_set_numid(id, get_integer(p1->value.c.cdr)); - } else if (!strcmp(xid, "iface")) { - snd_ctl_elem_id_set_interface(id, snd_config_get_ctl_iface_ascii(get_string(p1->value.c.cdr, "0"))); - } else if (!strcmp(xid, "dev")) { - snd_ctl_elem_id_set_device(id, get_integer(p1->value.c.cdr)); - } else if (!strcmp(xid, "subdev")) { - snd_ctl_elem_id_set_subdevice(id, get_integer(p1->value.c.cdr)); - } else if (!strcmp(xid, "name")) { - snd_ctl_elem_id_set_name(id, get_string(p1->value.c.cdr, "?")); - } else if (!strcmp(xid, "index")) { - snd_ctl_elem_id_set_index(id, get_integer(p1->value.c.cdr)); - } - } - delete_tree(instance, p1); - cons = cdr(p1 = cons); - delete_object(instance, p1); - } while (cons != &alsa_lisp_nil); - return 0; -} - -static struct alisp_object * FA_hctl_find_elem(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_hctl_t *handle; - snd_ctl_elem_id_t id = {0}; - struct alisp_object *p1; - - handle = (snd_hctl_t *)get_ptr(instance, car(args), item->prefix); - if (handle == NULL) { - delete_tree(instance, cdr(args)); - delete_object(instance, args); - return &alsa_lisp_nil; - } - p1 = car(cdr(args)); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - if (parse_ctl_elem_id(instance, eval(instance, p1), &id) < 0) - return &alsa_lisp_nil; - return new_cons_pointer(instance, "hctl_elem", snd_hctl_find_elem(handle, &id)); -} - -static struct alisp_object * FA_hctl_elem_info(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_hctl_elem_t *handle; - struct alisp_object * lexpr, * p1, * p2; - snd_ctl_elem_info_t info = {0}; - snd_ctl_elem_id_t id = {0}; - snd_ctl_elem_type_t type; - int err; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (snd_hctl_elem_t *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - err = snd_hctl_elem_info(handle, &info); - lexpr = new_lexpr(instance, err); - if (err < 0) - return lexpr; - type = snd_ctl_elem_info_get_type(&info); - p1 = add_cons(instance, lexpr->value.c.cdr, 0, "id", p2 = new_object(instance, ALISP_OBJ_CONS)); - snd_ctl_elem_info_get_id(&info, &id); - if (create_ctl_elem_id(instance, &id, p2) == NULL) { - delete_tree(instance, lexpr); - return NULL; - } - p1 = add_cons(instance, p1, 1, "type", new_string(instance, snd_ctl_elem_type_name(type))); - p1 = add_cons(instance, p1, 1, "readable", new_integer(instance, snd_ctl_elem_info_is_readable(&info))); - p1 = add_cons(instance, p1, 1, "writable", new_integer(instance, snd_ctl_elem_info_is_writable(&info))); - p1 = add_cons(instance, p1, 1, "volatile", new_integer(instance, snd_ctl_elem_info_is_volatile(&info))); - p1 = add_cons(instance, p1, 1, "inactive", new_integer(instance, snd_ctl_elem_info_is_inactive(&info))); - p1 = add_cons(instance, p1, 1, "locked", new_integer(instance, snd_ctl_elem_info_is_locked(&info))); - p1 = add_cons(instance, p1, 1, "isowner", new_integer(instance, snd_ctl_elem_info_is_owner(&info))); - p1 = add_cons(instance, p1, 1, "owner", new_integer(instance, snd_ctl_elem_info_get_owner(&info))); - p1 = add_cons(instance, p1, 1, "count", new_integer(instance, snd_ctl_elem_info_get_count(&info))); - err = INTERNAL(snd_ctl_elem_info_get_dimensions)(&info); - if (err > 0) { - int idx; - p1 = add_cons(instance, p1, 1, "dimensions", p2 = new_object(instance, ALISP_OBJ_CONS)); - for (idx = 0; idx < err; idx++) - p2 = add_cons2(instance, p2, idx > 0, new_integer(instance, INTERNAL(snd_ctl_elem_info_get_dimension)(&info, idx))); - } - switch (type) { - case SND_CTL_ELEM_TYPE_ENUMERATED: { - unsigned int items, item; - items = snd_ctl_elem_info_get_items(&info); - p1 = add_cons(instance, p1, 1, "items", p2 = new_object(instance, ALISP_OBJ_CONS)); - for (item = 0; item < items; item++) { - snd_ctl_elem_info_set_item(&info, item); - err = snd_hctl_elem_info(handle, &info); - if (err < 0) { - p2 = add_cons2(instance, p2, item, &alsa_lisp_nil); - } else { - p2 = add_cons2(instance, p2, item, new_string(instance, snd_ctl_elem_info_get_item_name(&info))); - } - } - break; - } - case SND_CTL_ELEM_TYPE_INTEGER: - p1 = add_cons(instance, p1, 1, "min", new_integer(instance, snd_ctl_elem_info_get_min(&info))); - p1 = add_cons(instance, p1, 1, "max", new_integer(instance, snd_ctl_elem_info_get_max(&info))); - p1 = add_cons(instance, p1, 1, "step", new_integer(instance, snd_ctl_elem_info_get_step(&info))); - break; - case SND_CTL_ELEM_TYPE_INTEGER64: - p1 = add_cons(instance, p1, 1, "min64", new_float(instance, snd_ctl_elem_info_get_min64(&info))); - p1 = add_cons(instance, p1, 1, "max64", new_float(instance, snd_ctl_elem_info_get_max64(&info))); - p1 = add_cons(instance, p1, 1, "step64", new_float(instance, snd_ctl_elem_info_get_step64(&info))); - break; - default: - break; - } - if (p1 == NULL) { - delete_tree(instance, lexpr); - return NULL; - } - return lexpr; -} - -static struct alisp_object * FA_hctl_elem_read(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_hctl_elem_t *handle; - struct alisp_object * lexpr, * p1 = NULL, * obj; - snd_ctl_elem_info_t info = {0}; - snd_ctl_elem_value_t value = {0}; - snd_ctl_elem_type_t type; - unsigned int idx, count; - int err; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (snd_hctl_elem_t *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - err = snd_hctl_elem_info(handle, &info); - if (err >= 0) - err = snd_hctl_elem_read(handle, &value); - lexpr = new_lexpr(instance, err); - if (err < 0) - return lexpr; - type = snd_ctl_elem_info_get_type(&info); - count = snd_ctl_elem_info_get_count(&info); - if (type == SND_CTL_ELEM_TYPE_IEC958) { - count = sizeof(snd_aes_iec958_t); - type = SND_CTL_ELEM_TYPE_BYTES; - } - for (idx = 0; idx < count; idx++) { - switch (type) { - case SND_CTL_ELEM_TYPE_BOOLEAN: - obj = new_integer(instance, snd_ctl_elem_value_get_boolean(&value, idx)); - break; - case SND_CTL_ELEM_TYPE_INTEGER: - obj = new_integer(instance, snd_ctl_elem_value_get_integer(&value, idx)); - break; - case SND_CTL_ELEM_TYPE_INTEGER64: - obj = new_integer(instance, snd_ctl_elem_value_get_integer64(&value, idx)); - break; - case SND_CTL_ELEM_TYPE_ENUMERATED: - obj = new_integer(instance, snd_ctl_elem_value_get_enumerated(&value, idx)); - break; - case SND_CTL_ELEM_TYPE_BYTES: - obj = new_integer(instance, snd_ctl_elem_value_get_byte(&value, idx)); - break; - default: - obj = NULL; - break; - } - if (idx == 0) { - p1 = add_cons2(instance, lexpr->value.c.cdr, 0, obj); - } else { - p1 = add_cons2(instance, p1, 1, obj); - } - } - if (p1 == NULL) { - delete_tree(instance, lexpr); - return &alsa_lisp_nil; - } - return lexpr; -} - -static struct alisp_object * FA_hctl_elem_write(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_hctl_elem_t *handle; - struct alisp_object * p1 = NULL, * obj; - snd_ctl_elem_info_t info = {0}; - snd_ctl_elem_value_t value = {0}; - snd_ctl_elem_type_t type; - unsigned int idx, count; - int err; - - p1 = car(cdr(args)); - obj = eval(instance, car(args)); - delete_tree(instance, cdr(cdr(args))); - delete_object(instance, cdr(args)); - delete_object(instance, args); - handle = (snd_hctl_elem_t *)get_ptr(instance, obj, item->prefix); - if (handle == NULL) { - delete_tree(instance, p1); - return &alsa_lisp_nil; - } - err = snd_hctl_elem_info(handle, &info); - if (err < 0) { - delete_tree(instance, p1); - return new_integer(instance, err); - } - type = snd_ctl_elem_info_get_type(&info); - count = snd_ctl_elem_info_get_count(&info); - if (type == SND_CTL_ELEM_TYPE_IEC958) { - count = sizeof(snd_aes_iec958_t); - type = SND_CTL_ELEM_TYPE_BYTES; - } - idx = -1; - do { - if (++idx >= count) { - delete_tree(instance, p1); - break; - } - obj = car(p1); - switch (type) { - case SND_CTL_ELEM_TYPE_BOOLEAN: - snd_ctl_elem_value_set_boolean(&value, idx, get_integer(obj)); - break; - case SND_CTL_ELEM_TYPE_INTEGER: - snd_ctl_elem_value_set_integer(&value, idx, get_integer(obj)); - break; - case SND_CTL_ELEM_TYPE_INTEGER64: - snd_ctl_elem_value_set_integer64(&value, idx, get_integer(obj)); - break; - case SND_CTL_ELEM_TYPE_ENUMERATED: - snd_ctl_elem_value_set_enumerated(&value, idx, get_integer(obj)); - break; - case SND_CTL_ELEM_TYPE_BYTES: - snd_ctl_elem_value_set_byte(&value, idx, get_integer(obj)); - break; - default: - break; - } - delete_tree(instance, obj); - p1 = cdr(obj = p1); - delete_object(instance, obj); - } while (p1 != &alsa_lisp_nil); - err = snd_hctl_elem_write(handle, &value); - return new_integer(instance, err); -} - -static struct alisp_object * FA_pcm_info(struct alisp_instance * instance, struct acall_table * item, struct alisp_object * args) -{ - snd_pcm_t *handle; - struct alisp_object * lexpr, * p1; - snd_pcm_info_t info = {0}; - int err; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - handle = (snd_pcm_t *)get_ptr(instance, p1, item->prefix); - if (handle == NULL) - return &alsa_lisp_nil; - err = snd_pcm_info(handle, &info); - lexpr = new_lexpr(instance, err); - if (err < 0) - return lexpr; - p1 = add_cons(instance, lexpr->value.c.cdr, 0, "card", new_integer(instance, snd_pcm_info_get_card(&info))); - p1 = add_cons(instance, p1, 1, "device", new_integer(instance, snd_pcm_info_get_device(&info))); - p1 = add_cons(instance, p1, 1, "subdevice", new_integer(instance, snd_pcm_info_get_subdevice(&info))); - p1 = add_cons(instance, p1, 1, "id", new_string(instance, snd_pcm_info_get_id(&info))); - p1 = add_cons(instance, p1, 1, "name", new_string(instance, snd_pcm_info_get_name(&info))); - p1 = add_cons(instance, p1, 1, "subdevice_name", new_string(instance, snd_pcm_info_get_subdevice_name(&info))); - p1 = add_cons(instance, p1, 1, "class", new_integer(instance, snd_pcm_info_get_class(&info))); - p1 = add_cons(instance, p1, 1, "subclass", new_integer(instance, snd_pcm_info_get_subclass(&info))); - p1 = add_cons(instance, p1, 1, "subdevices_count", new_integer(instance, snd_pcm_info_get_subdevices_count(&info))); - p1 = add_cons(instance, p1, 1, "subdevices_avail", new_integer(instance, snd_pcm_info_get_subdevices_avail(&info))); - //p1 = add_cons(instance, p1, 1, "sync", new_string(instance, snd_pcm_info_get_sync(&info))); - return lexpr; -} - -/* - * main code - */ - -static const struct acall_table acall_table[] = { - { "card_get_index", &FA_int_str, (void *)snd_card_get_index, NULL }, - { "card_get_longname", &FA_int_int_strp, (void *)snd_card_get_longname, NULL }, - { "card_get_name", &FA_int_int_strp, (void *)snd_card_get_name, NULL }, - { "card_next", &FA_int_intp, (void *)&snd_card_next, NULL }, - { "ctl_card_info", &FA_card_info, NULL, "ctl" }, - { "ctl_close", &FA_int_p, (void *)&snd_ctl_close, "ctl" }, - { "ctl_open", &FA_int_pp_strp_int, (void *)&snd_ctl_open, "ctl" }, - { "hctl_close", &FA_int_p, (void *)&snd_hctl_close, "hctl" }, - { "hctl_ctl", &FA_p_p, (void *)&snd_hctl_ctl, "hctl" }, - { "hctl_elem_info", &FA_hctl_elem_info, (void *)&snd_hctl_elem_info, "hctl_elem" }, - { "hctl_elem_next", &FA_p_p, (void *)&snd_hctl_elem_next, "hctl_elem" }, - { "hctl_elem_prev", &FA_p_p, (void *)&snd_hctl_elem_prev, "hctl_elem" }, - { "hctl_elem_read", &FA_hctl_elem_read, (void *)&snd_hctl_elem_read, "hctl_elem" }, - { "hctl_elem_write", &FA_hctl_elem_write, (void *)&snd_hctl_elem_write, "hctl_elem" }, - { "hctl_find_elem", &FA_hctl_find_elem, (void *)&snd_hctl_find_elem, "hctl" }, - { "hctl_first_elem", &FA_p_p, (void *)&snd_hctl_first_elem, "hctl" }, - { "hctl_free", &FA_int_p, (void *)&snd_hctl_free, "hctl" }, - { "hctl_last_elem", &FA_p_p, (void *)&snd_hctl_last_elem, "hctl" }, - { "hctl_load", &FA_int_p, (void *)&snd_hctl_load, "hctl" }, - { "hctl_open", &FA_int_pp_strp_int, (void *)&snd_hctl_open, "hctl" }, - { "hctl_open_ctl", &FA_int_pp_p, (void *)&snd_hctl_open_ctl, "hctl" }, - { "pcm_info", &FA_pcm_info, NULL, "pcm" }, - { "pcm_name", &FA_str_p, (void *)&snd_pcm_name, "pcm" }, -}; - -static int acall_compar(const void *p1, const void *p2) -{ - return strcmp(((struct acall_table *)p1)->name, - ((struct acall_table *)p2)->name); -} - -static struct alisp_object * F_acall(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p1, *p2; - struct acall_table key, *item; - - p1 = eval(instance, car(args)); - p2 = cdr(args); - delete_object(instance, args); - if (!alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER) && - !alisp_compare_type(p1, ALISP_OBJ_STRING)) { - delete_tree(instance, p2); - return &alsa_lisp_nil; - } - key.name = p1->value.s; - if ((item = bsearch(&key, acall_table, - sizeof acall_table / sizeof acall_table[0], - sizeof acall_table[0], acall_compar)) != NULL) { - delete_tree(instance, p1); - return item->func(instance, item, p2); - } - delete_tree(instance, p1); - delete_tree(instance, p2); - lisp_warn(instance, "acall function %s' is undefined", p1->value.s); - return &alsa_lisp_nil; -} - -static struct alisp_object * F_ahandle(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object *p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - args = car(cdr(p1)); - delete_tree(instance, cdr(cdr(p1))); - delete_object(instance, cdr(p1)); - delete_tree(instance, car(p1)); - delete_object(instance, p1); - return args; -} - -static struct alisp_object * F_aerror(struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object *p1; - - p1 = eval(instance, car(args)); - delete_tree(instance, cdr(args)); - delete_object(instance, args); - args = car(p1); - if (args == &alsa_lisp_nil) { - delete_tree(instance, p1); - return new_integer(instance, SND_ERROR_ALISP_NIL); - } else { - delete_tree(instance, cdr(p1)); - delete_object(instance, p1); - } - return args; -} - -static int common_error(snd_output_t **rout, struct alisp_instance *instance, struct alisp_object * args) -{ - struct alisp_object * p = args, * p1; - snd_output_t *out; - int err; - - err = snd_output_buffer_open(&out); - if (err < 0) { - delete_tree(instance, args); - return err; - } - - do { - p1 = eval(instance, car(p)); - if (alisp_compare_type(p1, ALISP_OBJ_STRING)) - snd_output_printf(out, "%s", p1->value.s); - else - princ_object(out, p1); - delete_tree(instance, p1); - p = cdr(p1 = p); - delete_object(instance, p1); - } while (p != &alsa_lisp_nil); - - *rout = out; - return 0; -} - -static struct alisp_object * F_snderr(struct alisp_instance *instance, struct alisp_object * args) -{ - snd_output_t *out; - char *str; - - if (common_error(&out, instance, args) < 0) - return &alsa_lisp_nil; - snd_output_buffer_string(out, &str); - SNDERR(str); - snd_output_close(out); - return &alsa_lisp_t; -} - -static struct alisp_object * F_syserr(struct alisp_instance *instance, struct alisp_object * args) -{ - snd_output_t *out; - char *str; - - if (common_error(&out, instance, args) < 0) - return &alsa_lisp_nil; - snd_output_buffer_string(out, &str); - SYSERR(str); - snd_output_close(out); - return &alsa_lisp_t; -} - -static const struct intrinsic snd_intrinsics[] = { - { "Acall", F_acall }, - { "Aerror", F_aerror }, - { "Ahandle", F_ahandle }, - { "Aresult", F_ahandle }, - { "Asnderr", F_snderr }, - { "Asyserr", F_syserr } -}; diff --git a/src/conf/Makefile.am b/src/conf/Makefile.am index e7bcbbe0..dc59d7d1 100644 --- a/src/conf/Makefile.am +++ b/src/conf/Makefile.am @@ -1,9 +1,6 @@ SUBDIRS=cards ctl pcm cfg_files = alsa.conf -if BUILD_ALISP -cfg_files += sndo-mixer.alisp -endif if BUILD_MODULES if BUILD_MIXER_MODULES cfg_files += smixer.conf diff --git a/src/conf/cards/Makefile.am b/src/conf/cards/Makefile.am index 00999f01..f387cf41 100644 --- a/src/conf/cards/Makefile.am +++ b/src/conf/cards/Makefile.am @@ -60,22 +60,6 @@ cfg_files = aliases.conf \ VXPocket.conf \ VXPocket440.conf -if BUILD_ALISP -cfg_files += aliases.alisp -endif - alsa_DATA = $(cfg_files) -if BUILD_ALISP -SI7018dir = $(alsaconfigdir)/cards/SI7018 -SI7018_files = \ - SI7018/sndoc-mixer.alisp \ - SI7018/sndop-mixer.alisp -SI7018_DATA = $(SI7018_files) -else -SI7018_files= -endif - -EXTRA_DIST = \ - $(cfg_files) \ - $(SI7018_files) +EXTRA_DIST = $(cfg_files) diff --git a/src/conf/cards/SI7018/sndoc-mixer.alisp b/src/conf/cards/SI7018/sndoc-mixer.alisp deleted file mode 100644 index ade1ea3f..00000000 --- a/src/conf/cards/SI7018/sndoc-mixer.alisp +++ /dev/null @@ -1,11 +0,0 @@ -; -; SiS SI7018 mixer abstract layer -; -; Copyright (c) 2003 Jaroslav Kysela -; License: GPL v2 (http://www.gnu.org/licenses/gpl.html) -; - -(defun sndoc_mixer_open (hctl pcm) - (princ "sndoc_mixer_open: hctl=" hctl " pcm=" pcm "\n") - 0 -) diff --git a/src/conf/cards/SI7018/sndop-mixer.alisp b/src/conf/cards/SI7018/sndop-mixer.alisp deleted file mode 100644 index 285e2898..00000000 --- a/src/conf/cards/SI7018/sndop-mixer.alisp +++ /dev/null @@ -1,11 +0,0 @@ -; -; SiS SI7018 mixer abstract layer -; -; Copyright (c) 2003 Jaroslav Kysela -; License: GPL v2 (http://www.gnu.org/licenses/gpl.html) -; - -(defun sndop_mixer_open (hctl pcm) - (princ "sndop_mixer_open: hctl=" hctl " pcm=" pcm "\n") - 0 -) diff --git a/src/conf/cards/aliases.alisp b/src/conf/cards/aliases.alisp deleted file mode 100644 index 1661caa3..00000000 --- a/src/conf/cards/aliases.alisp +++ /dev/null @@ -1,29 +0,0 @@ -(setq snd_card_aliases_array - ( - ("YMF724" . "YMF744") - ("YMF724F" . "YMF744") - ("YMF740" . "YMF744") - ("YMF740C" . "YMF744") - ("YMF754" . "YMF744") - ("CMIPCI" . "CMI8338") - ("CMI8738" . "CMI8338") - ("CMI8738-MC4" . "CMI8738-MC6") - ("E-mu APS" . "EMU10K1") - ("GUS Max" . "GUS") - ("GUS ACE" . "GUS") - ("GUS Extreme" . "GUS") - ("AMD InterWave" . "GUS") - ("Dynasonic 3-D" . "GUS") - ("InterWave STB" . "GUS") - ) -) - -(defun snd_card_alias (cardname) - (setq r (assq cardname snd_card_aliases_array)) - (setq r (if (null r) cardname r)) - (unsetq r) -) - -(defun snd_card_alias_unset () - (unsetq snd_card_aliases_array snd_card_alias) -) diff --git a/src/conf/sndo-mixer.alisp b/src/conf/sndo-mixer.alisp deleted file mode 100644 index c8b03f06..00000000 --- a/src/conf/sndo-mixer.alisp +++ /dev/null @@ -1,115 +0,0 @@ -; -; Toplevel configuration for the ALSA Ordinary Mixer Interface -; -; Copyright (c) 2003 Jaroslav Kysela -; License: GPL v2 (http://www.gnu.org/licenses/gpl.html) -; - -(defun sndo_include (hctl stream) - (setq info (Acall "ctl_card_info" (Acall "hctl_ctl" hctl))) - (if (= (Aerror info) 0) - (progn - (setq info (Aresult info)) - (setq driver (cdr (assq "driver" (unsetq info)))) - (setq file (concat (path "data") "/alsa/cards/" (snd_card_alias driver) "/sndo" stream "-mixer.alisp")) - (setq r (include file)) - (when (= r -2) (Asyserr "unable to find file " file)) - ) - (setq r (Aerror info)) - ) - (unsetq info driver file r) -) - -(defun sndo_mixer_open_fcn (hctl stream pcm) - (setq fcn (concat "sndo" stream "_mixer_open")) - (setq r (if (exfun fcn) (funcall fcn hctl pcm) 0)) - (when (= r 0) - (setq hctls (if hctls (cons hctls (cons hctl)) hctl)) - ) - (unsetq fcn r) -) - -(defun sndo_mixer_open_hctl (name stream pcm) - (setq hctl (Acall "hctl_open" name nil)) - (setq r (Aerror hctl)) - (when (= r 0) - (setq hctl (Aresult hctl)) - (setq r (sndo_include hctl stream)) - (if (= r 0) - (setq r (sndo_mixer_open_fcn hctl stream pcm)) - (Acall "hctl_close" hctl) - ) - ) - (unsetq hctl r) -) - -(defun sndo_mixer_open_virtual (name stream pcm) - (setq file (concat (path "data") "/alsa/virtual/" name "/sndo" stream "-mixer.alisp")) - (setq r (include file)) - (when (= r -2) (Asyserr "unable to find file " file)) - (when (= r 0) (setq r (sndo_mixer_open_fcn nil stream pcm))) - (unsetq file r) -) - -(defun sndo_mixer_open1 (name stream) - (if (compare-strings name 0 2 "hw:" 0 2) - (sndo_mixer_open_hctl name stream nil) - (sndo_mixer_open_virtual name stream nil) - ) -) - -(defun sndo_mixer_open (pname cname) - (setq r (sndo_mixer_open1 pname "p")) - (when (= r 0) (setq r (sndo_mixer_open1 cname "c"))) - (when (!= r 0) (sndo_mixer_close)) - (unsetq sndo_mixer_open - sndo_mixer_open_pcm sndo_mixer_open_pcm1 - sndo_mixer_open_virtual sndo_mixer_open_fcn - sndo_include r) -) - -(defun sndo_mixer_open_pcm1 (pcm stream) - (setq info (Acall "pcm_info" pcm)) - (setq r (Aerror info)) - (when (= r 0) - (setq info (Aresult info)) - (setq card (cdr (assq "card" info))) - (setq r - (if (< card 0) - (sndo_mixer_open_virtual (Acall "pcm_name" pcm) stream pcm) - (sndo_mixer_open_hctl (format "hw:%i" card) stream pcm) - ) - ) - ) - (unsetq info card r) -) - -(defun sndo_mixer_open_pcm (ppcm cpcm) - (setq r (sndo_mixer_open_pcm1 ppcm "p")) - (when (= r 0) (setq r (sndo_mixer_open_pcm1 cpcm "c"))) - (when (!= r 0) (sndo_mixer_close)) - (unsetq sndo_mixer_open - sndo_mixer_open_pcm sndo_mixer_open_pcm1 - sndo_mixer_open_virtual sndo_mixer_open_fcn - sndo_include r) -) - -(defun sndo_mixer_close1 (hctl stream) - (when hctl - (progn - (setq fcn (concat "sndo" stream "_mixer_close")) - (when (exfun fcn) (funcall fcn hctl)) - (unsetq fcn) - (Acall "hctl_close" hctl) - ) - ) -) - -(defun sndo_mixer_close nil - (sndo_mixer_close1 (nth 1 hctls) "c") - (sndo_mixer_close1 (nth 0 hctls) "p") - (snd_card_alias_unset) - (unsetq hctls) -) - -(include (concat (path "data") "/alsa/cards/aliases.alisp"))