From baecc2dc2449d04b44917a5114bf71262d65da30 Mon Sep 17 00:00:00 2001 From: "Kjetil S. Matheussen" Date: Thu, 8 Jan 2004 14:55:24 +0000 Subject: First commit of k_vst~, k_guile and k_cext svn path=/trunk/externals/k_guile/; revision=1253 --- Makefile | 114 +++++++++++ README | 98 ++++++++++ add.scm | 15 ++ gen_c_scheme.py | 19 ++ global.scm | 173 ++++++++++++++++ help-k_guile.pd | 64 ++++++ inout.scm | 24 +++ k_guile.c | 586 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ local.scm | 167 ++++++++++++++++ mozilla.scm | 8 + send_receive.scm | 24 +++ 11 files changed, 1292 insertions(+) create mode 100644 Makefile create mode 100644 README create mode 100644 add.scm create mode 100755 gen_c_scheme.py create mode 100644 global.scm create mode 100644 help-k_guile.pd create mode 100644 inout.scm create mode 100644 k_guile.c create mode 100644 local.scm create mode 100644 mozilla.scm create mode 100644 send_receive.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5defaaa --- /dev/null +++ b/Makefile @@ -0,0 +1,114 @@ +NAME=k_guile +CSYM=k_guile + +DIR=k_guile + +current: pd_linux + +# ----------------------- NT ----------------------- + +pd_nt: $(NAME).dll + +.SUFFIXES: .dll + +PDNTCFLAGS = /W3 /WX /DNT /DPD /nologo /DINCLUDEPATH=\"c:\\pd\" +VC="C:\Programme\Microsoft Visual Studio\Vc98" + +PDNTINCLUDE = /I. /I\tcl\include /Ic:\pd\src /I$(VC)\include + +PDNTLDIR = $(VC)\lib +PDNTLIB = $(PDNTLDIR)\libc.lib \ + $(PDNTLDIR)\oldnames.lib \ + $(PDNTLDIR)\kernel32.lib \ + c:\pd\bin\pd.lib + +.c.dll: + cl $(PDNTCFLAGS) $(PDNTINCLUDE) /c k_guile_win.c + cl $(PDNTCFLAGS) $(PDNTINCLUDE) /c $*.c + link /dll /export:$(CSYM)_setup $*.obj k_guile_win.obj $(PDNTLIB) + +# ----------------------- IRIX 5.x ----------------------- + +pd_irix5: $(NAME).pd_irix5 + +.SUFFIXES: .pd_irix5 + +SGICFLAGS5 = -o32 -DPD -DUNIX -DIRIX -O2 + +SGIINCLUDE = -I../../src + +.c.pd_irix5: + cc $(SGICFLAGS5) $(SGIINCLUDE) -o $*.o -c $*.c + ld -elf -shared -rdata_shared -o $*.pd_irix5 $*.o + rm $*.o + +# ----------------------- IRIX 6.x ----------------------- + +pd_irix6: $(NAME).pd_irix6 + +.SUFFIXES: .pd_irix6 + +SGICFLAGS6 = -n32 -DPD -DUNIX -DIRIX -DN32 -woff 1080,1064,1185 \ + -OPT:roundoff=3 -OPT:IEEE_arithmetic=3 -OPT:cray_ivdep=true \ + -Ofast=ip32 + +.c.pd_irix6: + cc $(SGICFLAGS6) $(SGIINCLUDE) -o $*.o -c $*.c + ld -n32 -IPA -shared -rdata_shared -o $*.pd_irix6 $*.o + rm $*.o + +# ----------------------- LINUX i386 ----------------------- + +pd_linux: $(NAME).pd_linux + +.SUFFIXES: .pd_linux + +LINUXCFLAGS = -DPD -DUNIX -DICECAST -O2 -funroll-loops -fomit-frame-pointer \ + -Wall -W -Wno-shadow -Wstrict-prototypes \ + -Wno-unused -Wno-parentheses -Wno-switch #-Werror + +LINUXINCLUDEPATH=../../src +LINUXINCLUDE = -I$(LINUXINCLUDEPATH) + +$(NAME).pd_linux: $(NAME).o + ld -export_dynamic -shared -o $(NAME).pd_linux k_guile.o -lc -lm -lguile + strip --strip-unneeded $*.pd_linux + rm -f $*.o ../$*.pd_linux + ln -s $(DIR)/$*.pd_linux .. + +$(NAME).o: $(NAME).c global_scm.txt local_scm.txt + cc $(LINUXCFLAGS) $(LINUXINCLUDE) -o $(NAME).o -c $(NAME).c + + +# ----------------------- Mac OSX ----------------------- + +pd_darwin: $(NAME).pd_darwin k_guile.c + +.SUFFIXES: .pd_darwin + +DARWINCFLAGS = -DPD -O2 -Wall -W -Wshadow -Wstrict-prototypes \ + -Wno-unused -Wno-parentheses -Wno-switch + +.c.pd_darwin: global_scm.txt local_scm.txt + cc $(DARWINCFLAGS) $(LINUXINCLUDE) -DINCLUDEPATH=\""`pwd`"\" -DLINUXINCLUDE=\""$(LINUXINCLUDEPATH)"\ -o $*.o -c k_guile.c + cc -bundle -undefined suppress -flat_namespace -o $*.pd_darwin $*.o + rm -f $*.o ../$*.pd_darwin + ln -s $*/$*.pd_darwin .. + +# ---------------------------------------------------------- + + +global_scm.txt: global.scm gen_c_scheme.py + ./gen_c_scheme.py global.scm >global_scm.txt + +local_scm.txt: local.scm gen_c_scheme.py + ./gen_c_scheme.py local.scm >local_scm.txt + + +install: + cp help-*.pd ../../doc/5.reference + +clean: + rm -f *.o *.pd_* so_locations *~ core global_scm.txt local_scm.txt + + diff --git a/README b/README new file mode 100644 index 0000000..7259ebb --- /dev/null +++ b/README @@ -0,0 +1,98 @@ + + +k_guile PD external +-------------------------------------------- +V0.0.1 + +-This external makes you able to use guile as an extension language for + PD. Guile is a scheme interpreter. The API is inspired by + the python pyext external made by Thomas Grill, and a small part of + the code is made by looking at the flext source. + +-To be able to use it, you should first know the lisp programming language, + then check out the help-k_guile.pd example patch and read the small + example-scripts that the patch loads. + + +API +------------------------------------------- +k_guile provides the following functions: + +* (pd-inlets num-inlets) + - Sets number of inlets for the object. + - add.scm, inout.scm + - Local function. + +* (pd-outlets num-outlets) + - Sets number of outlets for the object. + - add.scm, inout.scm + - Local function. + +* (pd-inlet inlet-num type func) + - "func" is a function that is called when the object + receives a message to the inlet "inlet-num" of type + "type". Normal values for "type" are 'float, 'list, + 'bang, etc. + - add.scm, inout.scm + - Local function. + +* (pd-outlet outlet-num arg0 arg1 ...) + - Sends value(s) to outlet "outlet-num". + The argument(s) can be of any kind. + - add.scm, inout.scm + - Local function. + +* (pd-bind symbol func) + - Pd messages sent to "symbol" arrives at the "func" function. + - send_receive.scm + - Both local and global + +* (pd-unbind symbol) + - Stop receiving messages sent to "symbol". + - Both local and global. For the local version, all bindings + are automatically unbinded when the object is destroyed or + reloaded. + +* (pd-send symbol arg0 arg1 ...) + - Sends value(s) to receivers for "symbol". "Symbol" can either + be a scheme or a pd symbol. + - send_receive.scm + - Global function. + +* (pd-get-symbol symbol) + - Returns the pd symbol for the scheme symbol "symbol". + pd-send works faster when a pd symbol is used instead of a scheme symbol. + - send_receive.scm + - Global function. + +* (pd-set-destroy-func thunk) + - "thunk" is called before the object is destroyed or reloaded. + - Local function. + + + +Scheme programming with the k_guile object. +-------------------------------------------------- +-The code executed lives in its own local namespace + spesific for the pd object. If you need or want to + break out of the local namespace, simply just use + (load ) to let another script run in the global + namespace. +-If you need to call pd-inlets or pd-outlets, they + should/must be the first functions to call in the + script. The default number of inlets is 1, + and the default number of outlets is 0. +-Some global debugging options are set at the top + of the global.scm file. You might want to edit + those values _before compiling_ the k_guile external. +-None of the functions have been made with + thread-safety in mind. +-Backtracing doesn't work properly. Don't know why. + + + +-------------------------------------------------- +Kjetil S. Matheussen, k.s.matheussen@notam02.no +last updated 4.1.2004 + + diff --git a/add.scm b/add.scm new file mode 100644 index 0000000..b4bfd76 --- /dev/null +++ b/add.scm @@ -0,0 +1,15 @@ + +(pd-inlets 2) +(pd-outlets 1) + +(let ((inlet1 0)) + (pd-inlet 1 'float + (lambda (x) + (set! inlet1 x))) + (pd-inlet 0 'float + (lambda (x) + (pd-outlet 0 (+ inlet1 x))))) + + + + diff --git a/gen_c_scheme.py b/gen_c_scheme.py new file mode 100755 index 0000000..58c2dcc --- /dev/null +++ b/gen_c_scheme.py @@ -0,0 +1,19 @@ +#!/usr/bin/env python + +import sys,string + +file=open(sys.argv[1],"r") + +while 1: + line="" + while line=="" or line=="\n" or line[0:1]==";": + line=file.readline() + if line=="": + file.close() + sys.exit(0) + line=string.replace(line[:-1],'\\','\\\\') + sys.stdout.write('"'+string.replace(line,'"','\\"')+'\\n"\n') + + + + diff --git a/global.scm b/global.scm new file mode 100644 index 0000000..121852e --- /dev/null +++ b/global.scm @@ -0,0 +1,173 @@ + + +;; These functions are global functions available for all guile scripts loaded into PD. +;; Kjetil S. Matheussen, 2004. + +;;/* This program is free software; you can redistribute it and/or */ +;;/* modify it under the terms of the GNU General Public License */ +;;/* as published by the Free Software Foundation; either version 2 */ +;;/* 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 General Public License for more details. */ +;;/* */ +;;/* You should have received a copy of the GNU General Public License */ +;;/* along with this program; if not, write to the Free Software */ +;;/* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ +;;/* */ + + + +(debug-enable 'debug) +(debug-enable 'trace) +(debug-enable 'backtrace) + +(use-modules (ice-9 stack-catch)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Misc. functions +;; +;; +(define (pd-display . args) + (if (not (null? args)) + (begin + (display (car args)) + (apply pd-display (cdr args))) + (newline))) + +(define (pd-filter proc list) + (if (null? list) + '() + (if (proc (car list)) + (cons (car list) (pd-filter proc (cdr list))) + (pd-filter proc (cdr list))))) + +(define (pd-for init pred least add proc) + (if (pred init least) + (begin + (proc init) + (pd-for (+ add init) pred least add proc)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Argument checking +;; +;; +(define (pd-check-number number message) + (if (number? number) + #t + (begin + (pd-display message ": " number " is not a number") + #f))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bindings +;; +;; +(define pd-global-bindings '()) + +(define (pd-bind-do symbol func bindings) + (if (or (not (symbol? symbol)) + (not (procedure? func))) + (begin + (pd-display "Wrong arguments for pd-bind") + bindings) + (cons (list symbol + func + (pd-c-bind symbol func)) + bindings))) + +(define (pd-unbind-do symbol bindings) + (if (not (symbol? symbol)) + (begin + (pd-display "Wrong arguments for pd-unbind") + bindings) + (let ((binding (assq symbol bindings))) + (pd-c-unbind (caddr binding) symbol) + (pd-filter (lambda (x) (not (eq? symbol (car x)))) + bindings)))) + +(define (pd-bind symbol func) + (set! pd-global-bindings (pd-bind-do symbol func pd-global-bindings))) + +(define (pd-unbind symbol) + (set! pd-global-bindings (pd-unbind-do symbol pd-global-bindings))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Sending +;; +;; +(define (pd-send symbol firstarg . args) + (if (or (symbol? symbol) + (number? symbol)) + (cond ((> (length args) 0) (pd-c-send-list symbol (cons firstarg args))) + ((list? firstarg) (pd-c-send-list symbol firstarg)) + ((number? firstarg) (pd-c-send-number symbol firstarg)) + ((string? firstarg) (pd-c-send-string symbol firstarg)) + ((eq? 'bang firstarg) (pd-c-send-bang symbol)) + ((symbol? firstarg) (pd-c-send-symbol symbol firstarg)) + (else + (pd-display "Unknown argument to pd-outlet-or-send:" firstarg))))) + +(define (pd-get-symbol sym) + (if (not (symbol? sym)) + (pd-display sym " is not a scheme symbol") + (pd-c-get-symbol sym))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Backtrace (does not work properly) +;; +;; +(define (pd-display-errorfunc key . args) + (let ((dasstack (make-stack #t))) + (display-backtrace dasstack (current-output-port) #f #f) + ;(display (stack-ref (make-stack #t) 1)) + ;(display (stack-length (make-stack #t))) + (display key)(newline) + (display args) + (newline)) + 0) + +(define (pd-backtrace-run thunk) + (stack-catch #t + thunk + pd-display-errorfunc)) + +(define (pd-backtrace-run1 func arg1) + (stack-catch #t + (lambda () + (func arg1)) + pd-display-errorfunc)) + +(define (pd-backtrace-run2 func arg1 arg2) + (stack-catch #t + (lambda () + (func arg1 arg2)) + pd-display-errorfunc)) + +(define (pd-backtrace-run3 func arg1 arg2 arg3) + (stack-catch #t + (lambda () + (func arg1 arg2 arg3)) + pd-display-errorfunc)) + +(define (pd-backtrace-run4 func arg1 arg2 arg3 arg4) + (stack-catch #t + (lambda () + (func arg1 arg2 arg3 arg4)) + pd-display-errorfunc)) + + diff --git a/help-k_guile.pd b/help-k_guile.pd new file mode 100644 index 0000000..b0458ff --- /dev/null +++ b/help-k_guile.pd @@ -0,0 +1,64 @@ +#N canvas 372 11 707 547 10; +#X obj 101 135 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 93 256; +#X obj 101 162 k_guile add.scm; +#X obj 101 195 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 220 256; +#X obj 201 137 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 127 256; +#X msg 38 134 reload; +#X obj 341 157 k_guile send_receive.scm; +#X msg 341 127 reload; +#X obj 483 130 s in; +#X obj 512 97 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 6 256; +#X obj 475 186 r out; +#X msg 468 95 gakk; +#X obj 475 215 print; +#X obj 580 95 bng 15 250 50 0 empty empty empty 0 -6 0 8 -262144 -1 +-1; +#X msg 608 96 list 2 3 4; +#X text 27 19 k_guile - guile external for PD.; +#X text 26 36 Kjetil S. Matheussen \, 2004; +#X obj 130 301 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 62 256; +#X obj 255 300 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 82 256; +#X obj 71 301 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 22 256; +#X obj 71 388 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 95 256; +#X obj 146 389 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 267 256; +#X obj 213 390 nbx 5 14 -1e+37 1e+37 0 0 empty empty empty 0 -6 0 10 +-262144 -1 -1 428 256; +#X msg 17 300 reload; +#X obj 75 341 k_guile inout.scm; +#X obj 436 346 k_guile mozilla.scm; +#X msg 436 301 start; +#X text 300 496 Note \; you can not change the number of inlets and +outlets by sending "reload".; +#X msg 316 299 testing; +#X msg 190 299 testing; +#X msg 409 95 we 3 2; +#X connect 0 0 1 0; +#X connect 1 0 2 0; +#X connect 3 0 1 1; +#X connect 4 0 1 0; +#X connect 6 0 5 0; +#X connect 8 0 7 0; +#X connect 9 0 11 0; +#X connect 10 0 7 0; +#X connect 12 0 7 0; +#X connect 13 0 7 0; +#X connect 16 0 23 152; +#X connect 17 0 23 323; +#X connect 18 0 23 9; +#X connect 22 0 23 0; +#X connect 23 13 19 0; +#X connect 23 185 20 0; +#X connect 23 346 21 0; +#X connect 25 0 24 0; +#X connect 27 0 23 396; +#X connect 28 0 23 284; +#X connect 29 0 7 0; diff --git a/inout.scm b/inout.scm new file mode 100644 index 0000000..a2d829c --- /dev/null +++ b/inout.scm @@ -0,0 +1,24 @@ + +(define num-inouts 400) + +(pd-inlets num-inouts) +(pd-outlets num-inouts) + + +(pd-for 0 < num-inouts 1 + (lambda (i) + (pd-inlet i 'float + (lambda (x) + (pd-display "Got " x " to inlet " i) + (pd-for 0 < num-inouts 1 + (lambda (i2) + (pd-outlet i2 (+ i2 x)))))))) + + +(pd-inlet 284 'testing + (lambda () + (pd-display "This is a function for handling 'testing sent to inlet 284."))) + + + + diff --git a/k_guile.c b/k_guile.c new file mode 100644 index 0000000..62e86af --- /dev/null +++ b/k_guile.c @@ -0,0 +1,586 @@ +/* --------------------------- k_guile ----------------------------------- */ +/* ;; Kjetil S. Matheussen, 2004. */ +/* */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License */ +/* as published by the Free Software Foundation; either version 2 */ +/* 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 General Public License for more details. */ +/* */ +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ +/* */ +/* ---------------------------------------------------------------------------- */ + + + +#include "libguile.h" + +/* Need some more macros. */ + +#define POINTER_P(x) (((int) (x) & 3) == 0) +#define INTEGER_P(x) (! POINTER_P (x)) + +#define GET_INTEGER SCM_INUM +#define MAKE_INTEGER SCM_MAKINUM + +#define MAKE_STRING(a) scm_mem2string(a,strlen(a)) +#define EVAL(a) scm_eval_string(MAKE_STRING(a)) +#define EVALINT(a) do{char tempstring[500];sprintf(tempstring,"%d",a);EVAL(tempstring);}while(0) + +#define MAKE_SYM(a) gensym(SCM_SYMBOL_CHARS(a)) + +#define MAKE_POINTER(a) scm_ulong2num((unsigned long)a) +#define GET_POINTER(a) (void *)scm_num2ulong(a,0,"GET_POINTER()") + +#define GET_X(a) ((t_k_guile *)GET_POINTER(a)) + +#define RU_ return SCM_UNSPECIFIED + + + +#include "m_pd.h" + +#include +#include +#include +#include +#include +#include + + +struct k_guile_workaround; + +typedef struct k_guile +{ + t_object x_ob; + + int num_ins; + int num_outs; + + struct k_guile_workaround **inlets; + t_outlet **outlets; + + SCM inlet_func; + SCM cleanup_func; + + char *filename; + + bool isinited; +} t_k_guile; + +typedef struct k_guile_workaround{ + t_object x_ob; + t_k_guile *x; + t_inlet *inlet; + int index; + SCM func; +} t_k_guile_workaround; + + + + +#define KG_MAX(a,b) (((a)>(b))?(a):(b)) +#define KG_MIN(a,b) (((a)<(b))?(a):(b)) + + + +static char *version = +"k_guile v0.0.1, written by Kjetil S. Matheussen, k.s.matheussen@notam02.no"; + +static t_class *k_guile_class, *k_guile_workaroundclass; + +static SCM pd_backtrace_run; +static SCM pd_backtrace_run1; +static SCM pd_backtrace_run2; +static SCM pd_backtrace_run3; +static SCM pd_backtrace_run4; + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Functions to evaluate large amount of scheme code from C. + ***************************************************************************************************** + *****************************************************************************************************/ + +static char *evalstring=NULL; +static void eval2(char *string){ + char *new; + if(evalstring==NULL){ + new=malloc(strlen(string)+1); + sprintf(new,"%s",string); + }else{ + new=malloc(strlen(evalstring)+strlen(string)+1); + sprintf(new,"%s%s",evalstring,string); + free(evalstring); + } + evalstring=new; +} +static void eval_file(FILE *file){ + char line[50000]; + for(;;){ + int c=fgetc(file); + if(c==EOF) break; + ungetc(c,file); + fgets(line,49999,file); + eval2(line); + } +} +static SCM eval_do(void){ + //post(evalstring); + SCM ret=EVAL(evalstring); + free(evalstring); + evalstring=NULL; + return ret; +} + + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Sending data to the guile side. Called either via bind or an inlet. + ***************************************************************************************************** + *****************************************************************************************************/ + +static void k_guile_anything_do(t_k_guile *x,int index,SCM func,t_symbol *s, t_int argc, t_atom* argv){ + int lokke; + SCM applyarg=SCM_EOL; + + for(lokke=argc-1;lokke>=0;lokke--){ + SCM to=SCM_BOOL_F; + switch(argv[lokke].a_type){ + case A_NULL: + to=SCM_EOL; + break; + case A_FLOAT: + to=scm_make_real(atom_getfloatarg(lokke,argc,argv)); + break; + case A_SYMBOL: + to=scm_string_to_symbol(MAKE_STRING(atom_getsymbolarg(lokke,argc,argv)->s_name)); + break; + default: + post("Strange"); + break; + } + applyarg=scm_cons(to,applyarg); + } + + if(index>=0){ + // Inlet + scm_call_4(pd_backtrace_run3,x->inlet_func,MAKE_INTEGER(index),scm_string_to_symbol(MAKE_STRING(s->s_name)),applyarg); + }else{ + // Binding + if(s!=&s_float && s!=&s_list && s!=&s_symbol){ + applyarg=scm_cons(scm_string_to_symbol(MAKE_STRING(s->s_name)),applyarg); + } + if(s!=&s_list && GET_INTEGER(scm_length(applyarg))==1) + applyarg=SCM_CAR(applyarg); + scm_call_2(pd_backtrace_run1,func,applyarg); + } +} + +// Handles inlet>0 and bindings +static void k_guile_anything(t_k_guile_workaround *x2,t_symbol *s, t_int argc, t_atom* argv){ + if(x2->index>=0){ + // Inlet + k_guile_anything_do(x2->x,x2->index,0,s,argc,argv); + }else{ + // Binding + k_guile_anything_do(NULL,x2->index,x2->func,s,argc,argv); + } +} + +// Handles first inlet +static void k_guile_anything_first(t_k_guile *x,t_symbol *s, t_int argc, t_atom* argv){ + k_guile_anything_do(x,0,0,s,argc,argv); +} + + + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Initialization, called from the guile side. + ***************************************************************************************************** + *****************************************************************************************************/ + +static SCM gpd_set_inlet_func(SCM instance,SCM func){ + t_k_guile *x=GET_X(instance); + x->inlet_func=func; + scm_gc_protect_object(x->inlet_func); + RU_; +} +static SCM gpd_set_cleanup_func(SCM instance,SCM func){ + t_k_guile *x=GET_X(instance); + x->cleanup_func=func; + scm_gc_protect_object(x->cleanup_func); + RU_; +} +static SCM gpd_inlets(SCM instance,SCM num_ins){ + int lokke; + t_k_guile *x=GET_X(instance); + + if(x->isinited==true) goto exit; + + x->num_ins=GET_INTEGER(num_ins); + x->inlets=calloc(sizeof(t_k_guile_workaround*),x->num_ins); + + for(lokke=1;lokkenum_ins;lokke++){ + t_k_guile_workaround *x2; + x2=(t_k_guile_workaround*)pd_new(k_guile_workaroundclass); + x->inlets[lokke]=x2; + x2->x=x; + x2->index=lokke; + x2->inlet=inlet_new(&x->x_ob,(t_pd*)x2,0,0); + } + + exit: + RU_; +} +static SCM gpd_outlets(SCM instance,SCM num_outs){ + int lokke; + t_k_guile *x=GET_X(instance); + + if(x->isinited==true) goto exit; + + x->num_outs=GET_INTEGER(num_outs); + x->outlets=calloc(sizeof(t_outlet*),x->num_outs); + + for(lokke=0;lokkenum_outs;lokke++){ + x->outlets[lokke] = outlet_new(&x->x_ob, gensym("anything")); + } + + exit: + RU_; +} + +static SCM gpd_inited_p(SCM instance){ + t_k_guile *x=GET_X(instance); + if(x->isinited==true) return SCM_BOOL_T; + return SCM_BOOL_F; +} +static SCM gpd_get_num_inlets(SCM instance){ + t_k_guile *x=GET_X(instance); + return MAKE_INTEGER(x->num_ins); +} +static SCM gpd_get_num_outlets(SCM instance){ + t_k_guile *x=GET_X(instance); + return MAKE_INTEGER(x->num_outs); +} + + +/***************************************************************************************************** + ***************************************************************************************************** + * Binding and unbinding. Called from the guile side. + ***************************************************************************************************** + *****************************************************************************************************/ + +static SCM gpd_bind(SCM symname,SCM func){ + t_k_guile_workaround *x2; + x2=(t_k_guile_workaround*)pd_new(k_guile_workaroundclass); + x2->index=-1; + x2->func=func; + scm_protect_object(x2->func); + pd_bind((t_pd *)x2, MAKE_SYM(symname)); + return MAKE_POINTER(x2); +} +static SCM gpd_unbind(SCM scm_x2,SCM symname){ + t_k_guile_workaround *x2=GET_POINTER(scm_x2); + pd_unbind((t_pd *)x2,MAKE_SYM(symname)); + scm_unprotect_object(x2->func); + pd_free((t_pd*)x2); + RU_; +} + + + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Got data from the guile side. Distributing to outlets or receivers. + * The guile side is responsible for checking that the arguments are correct. + ***************************************************************************************************** + *****************************************************************************************************/ + +#define GET_CLASS() (INTEGER_P(symbol)?(t_symbol*)GET_POINTER(symbol):MAKE_SYM(symbol))->s_thing +#define CLASS_INIT t_class **s=GET_CLASS();if(s==NULL) post("no receiver"); else +#define GET_OUTLET() GET_X(instance)->outlets[GET_INTEGER(outlet)] + + +/* Number -> float */ +static SCM gpd_outlet_number(SCM instance,SCM outlet,SCM val){ + outlet_float(GET_OUTLET(),scm_num2dbl(val,"gpd_outlet")); + RU_; +} + + +static SCM gpd_send_number(SCM symbol,SCM val){ + CLASS_INIT + pd_float(s,scm_num2dbl(val,"gpd_send_number")); + RU_; +} + + +/* List -> list */ +static t_atom *make_list(t_atom *atom,SCM val){ + int lokke; + int length=GET_INTEGER(scm_length(val)); + + for(lokke=0;lokke symbol */ +static SCM gpd_outlet_symbol(SCM instance,SCM outlet,SCM val){ + outlet_symbol(GET_OUTLET(),MAKE_SYM(val)); + RU_; +} +static SCM gpd_send_symbol(SCM symbol,SCM val){ + CLASS_INIT + pd_symbol(s,MAKE_SYM(val)); + RU_; +} + +/* String -> symbol */ +static SCM gpd_outlet_string(SCM instance,SCM outlet,SCM val){ + outlet_symbol(GET_OUTLET(),gensym(SCM_STRING_CHARS(val))); + RU_; +} +static SCM gpd_send_string(SCM symbol,SCM val){ + CLASS_INIT + pd_symbol(s,gensym(SCM_STRING_CHARS(val))); + RU_; +} + +/* Bang -> bang */ +static SCM gpd_outlet_bang(SCM instance,SCM outlet){ + outlet_bang(GET_OUTLET()); + RU_; +} +static SCM gpd_send_bang(SCM symbol){ + CLASS_INIT + pd_bang(s); + RU_; +} + +/* <- symbol */ +static SCM gpd_get_symbol(SCM symname){ + return MAKE_POINTER(MAKE_SYM(symname)); +} + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Setting up global guile functions. + ***************************************************************************************************** + *****************************************************************************************************/ + +static void k_guile_init(void){ + char *command= +#include "global_scm.txt" + ; + + scm_init_guile(); + scm_c_define_gsubr("pd-c-outlets",2,0,0,gpd_outlets); + scm_c_define_gsubr("pd-c-inlets",2,0,0,gpd_inlets); + scm_c_define_gsubr("pd-c-inited?",1,0,0,gpd_inited_p); + scm_c_define_gsubr("pd-c-get-num-inlets",1,0,0,gpd_get_num_inlets); + scm_c_define_gsubr("pd-c-get-num-outlets",1,0,0,gpd_get_num_outlets); + scm_c_define_gsubr("pd-c-set-inlet-func",2,0,0,gpd_set_inlet_func); + scm_c_define_gsubr("pd-c-set-cleanup-func",2,0,0,gpd_set_cleanup_func); + scm_c_define_gsubr("pd-c-bind",2,0,0,gpd_bind); + scm_c_define_gsubr("pd-c-unbind",2,0,0,gpd_unbind); + scm_c_define_gsubr("pd-c-outlet-number",3,0,0,gpd_outlet_number); + scm_c_define_gsubr("pd-c-outlet-list",3,0,0,gpd_outlet_list); + scm_c_define_gsubr("pd-c-outlet-symbol",3,0,0,gpd_outlet_symbol); + scm_c_define_gsubr("pd-c-outlet-string",3,0,0,gpd_outlet_string); + scm_c_define_gsubr("pd-c-outlet-bang",2,0,0,gpd_outlet_bang); + scm_c_define_gsubr("pd-c-send-number",2,0,0,gpd_send_number); + scm_c_define_gsubr("pd-c-send-list",2,0,0,gpd_send_list); + scm_c_define_gsubr("pd-c-send-symbol",2,0,0,gpd_send_symbol); + scm_c_define_gsubr("pd-c-send-string",2,0,0,gpd_send_string); + scm_c_define_gsubr("pd-c-send-bang",1,0,0,gpd_send_bang); + scm_c_define_gsubr("pd-c-get-symbol",1,0,0,gpd_get_symbol); + + EVAL(command); + + pd_backtrace_run=EVAL("pd-backtrace-run"); + scm_permanent_object(pd_backtrace_run); + + pd_backtrace_run1=EVAL("pd-backtrace-run1"); + scm_permanent_object(pd_backtrace_run1); + + pd_backtrace_run2=EVAL("pd-backtrace-run2"); + scm_permanent_object(pd_backtrace_run2); + + pd_backtrace_run3=EVAL("pd-backtrace-run3"); + scm_permanent_object(pd_backtrace_run3); + + pd_backtrace_run4=EVAL("pd-backtrace-run4"); + scm_permanent_object(pd_backtrace_run4); +} + + + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Starting and stopping new guile script + ***************************************************************************************************** + *****************************************************************************************************/ + +static bool k_guile_load(t_k_guile *x,char *filename){ + bool ret=true; + + FILE *file=fopen(filename,"r"); + if(file==NULL){ + post("file \"%s\" not found.\n",filename); + return false; + } + + + // Let the file live in its own name-space, or something like that. + eval2("(define (pd-instance-func pd-instance)"); + eval2( +#include "local_scm.txt" +); + eval_file(file); + eval2(" (pd-set-inlet-func)(pd-set-cleanup-func))"); + eval2("1"); + + if( + 1!=GET_INTEGER(eval_do()) + || 1!=GET_INTEGER(scm_call_2(pd_backtrace_run1,EVAL("pd-instance-func"),MAKE_POINTER(x))) + ) + { + post("Failed."); + ret=false; + } + + fclose(file); + + return ret; +} + +static void *k_guile_new(t_symbol *s){ + int lokke; + t_k_guile *x = (t_k_guile *)pd_new(k_guile_class); + x->filename=s->s_name; + x->isinited=false; + + if(k_guile_load(x,x->filename)==true){ + x->isinited=true; + return x; + } + + return NULL; +} + +static void k_guile_free(t_k_guile *x){ + int lokke; + scm_call_1(pd_backtrace_run,x->cleanup_func); + for(lokke=1;lokkenum_ins;lokke++){ + inlet_free(x->inlets[lokke]->inlet); + pd_free((t_pd*)x->inlets[lokke]); + } + for(lokke=0;lokkenum_outs;lokke++){ + outlet_free(x->outlets[lokke]); + } + scm_gc_unprotect_object(x->inlet_func); + scm_gc_unprotect_object(x->cleanup_func); + + free(x->inlets); + free(x->outlets); +} + + +static void k_guile_reload(t_k_guile *x){ + scm_call_1(pd_backtrace_run,x->cleanup_func); + scm_gc_unprotect_object(x->inlet_func); + scm_gc_unprotect_object(x->cleanup_func); + k_guile_load(x,x->filename); +} + + + +/***************************************************************************************************** + ***************************************************************************************************** + * Das setup + ***************************************************************************************************** + *****************************************************************************************************/ +void k_guile_setup(void){ + + k_guile_init(); + + k_guile_class = class_new(gensym("k_guile"), (t_newmethod)k_guile_new, + (t_method)k_guile_free, sizeof(t_k_guile), 0, A_DEFSYM, 0); + + class_addanything(k_guile_class, (t_method)k_guile_anything_first); + class_addmethod(k_guile_class, (t_method)k_guile_reload, gensym("reload"), 0); + class_sethelpsymbol(k_guile_class, gensym("help-k_guile.pd")); + + + /* This trick(?) is taken from the flext source. (I don't understand what happens...) */ + k_guile_workaroundclass=class_new(gensym("indexworkaround"),NULL,NULL,sizeof(t_k_guile_workaround),CLASS_PD|CLASS_NOINLET, A_NULL); + class_addanything(k_guile_workaroundclass,k_guile_anything); + + + post(version); +} + diff --git a/local.scm b/local.scm new file mode 100644 index 0000000..500f78b --- /dev/null +++ b/local.scm @@ -0,0 +1,167 @@ + + +;; This file is evaluated (not (load)-ed) right before the file defined in the k_guile object in pd is evaluated or the +;; reload message has been sent. (see k_guile.c/k_guile_new) +;; Kjetil S. Matheussen, 2004. +;; +;;/* This program is free software; you can redistribute it and/or */ +;;/* modify it under the terms of the GNU General Public License */ +;;/* as published by the Free Software Foundation; either version 2 */ +;;/* 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 General Public License for more details. */ +;;/* */ +;;/* You should have received a copy of the GNU General Public License */ +;;/* along with this program; if not, write to the Free Software */ +;;/* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ +;;/* */ + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Instance data +;; +;; +(define pd-num-inlets 1) +(define pd-num-outlets 0) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Argument checking +;; +;; +(define (pd-legaloutlet outlet-num) + (if (and (< outlet-num pd-num-outlets) (>= outlet-num 0)) + #t + (begin + (pd-display "outlet-num out of range") + #f))) + +(define (pd-legalinlet inlet-num) + (if (and (< inlet-num pd-num-inlets) (>= inlet-num 0)) + #t + (begin + (pd-display "inlet-num out of range") + #f))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Inlets +;; +;; +(define pd-inlet-vector (make-vector 1 '())) + +(define (pd-set-inlet-func) + (pd-c-set-inlet-func pd-instance + ;; This function is called from the C side when the object receives something on an inlet. + (lambda (inlet-num symbol args) + (let ((inlet-func (assq symbol + (vector-ref pd-inlet-vector + inlet-num)))) + (if inlet-func + (apply (cadr inlet-func) args) + (pd-display "No function defined for handling \'" symbol " to inlet " inlet-num)))))) + +(define (pd-inlet inlet-num symbol func) + (if (not (procedure? func)) + (pd-display "Wrong argument to pd-inlet: " func " is not a procedure") + (if (and (pd-check-number inlet-num "pd-inlet") + (pd-legalinlet inlet-num)) + (let ((inlet-funcs (vector-ref pd-inlet-vector inlet-num))) + (vector-set! pd-inlet-vector + inlet-num + (cons (list symbol func) + inlet-funcs)))))) + +(define (pd-inlets new-num-inlets) + (let ((num-inlets (if (pd-c-inited? pd-instance) + (pd-c-get-num-inlets pd-instance) + new-num-inlets))) + (if (pd-check-number num-inlets "pd-inlets") + (if (<= num-inlets 0) + (pd-display "num-inlets must be greater than 0, not " num-inlets) + (begin + (set! pd-num-inlets num-inlets) + (set! pd-inlet-vector (make-vector num-inlets '())) + (pd-c-inlets pd-instance num-inlets)))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Outlets +;; +;; +(define (pd-outlets new-num-outlets) + (let ((num-outlets (if (pd-c-inited? pd-instance) + (pd-c-get-num-outlets pd-instance) + new-num-outlets))) + (if (pd-check-number num-outlets "pd-outlets") + (if (<= num-outlets 0) + (pd-display "num-outlets must be greater than 0, not " num-outlets) + (begin + (set! pd-num-outlets num-outlets) + (pd-c-outlets pd-instance num-outlets)))))) + +(define (pd-outlet outlet-num firstarg . args) + (if (pd-legaloutlet outlet-num) + (cond ((> (length args) 0) (pd-c-outlet-list pd-instance outlet-num issymbol (cons firstarg args))) + ((list? firstarg) (pd-c-outlet-list pd-instance outlet-num firstarg)) + ((number? firstarg) (pd-c-outlet-number pd-instance outlet-num firstarg)) + ((string? firstarg) (pd-c-outlet-string pd-instance outlet-num firstarg)) + ((eq? 'bang firstarg) (pd-c-outlet-bang pd-instance outlet-num)) + ((symbol? firstarg) (pd-c-outlet-symbol pd-instance outlet-num firstarg)) + (else + (pd-display "Unknown argument to pd-outlet-or-send:" firstarg))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bindings +;; +;; +;; We must have our own local bind/unbind functions to be able to clean up automaticly. +(define pd-local-bindings '()) + +(define (pd-bind symbol func) + (set! pd-local-bindings (pd-bind-do symbol func pd-local-bindings))) + +(define (pd-unbind symbol) + (set! pd-local-bindings (pd-unbind-do symbol pd-local-bindings))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Cleanup +;; +;; +(define pd-destroy-func #f) +(define (pd-set-destroy-func thunk) + (if (not (procedure? thunk)) + (pd-display "Wrong argument to pd-set-destroy-func: " thunk " is not a procedure.") + (set! pd-destroy-func thunk))) + +(define (pd-cleanup) + (if pd-destroy-func + (begin + (pd-destroy-func) + (set! pd-destroy-func #f))) + (if (not (null? pd-local-bindings)) + (begin + (pd-unbind (car (car pd-local-bindings))) + (pd-cleanup)))) + +;; This one also returns the return-value for the pd-instance-func function, which is 1 for success. +(define (pd-set-cleanup-func) + (pd-c-set-cleanup-func pd-instance + pd-cleanup) + 1) + diff --git a/mozilla.scm b/mozilla.scm new file mode 100644 index 0000000..e0e17b2 --- /dev/null +++ b/mozilla.scm @@ -0,0 +1,8 @@ + + +(pd-inlet 0 'start + (lambda x + (system "mozilla&"))) + + + diff --git a/send_receive.scm b/send_receive.scm new file mode 100644 index 0000000..bae7668 --- /dev/null +++ b/send_receive.scm @@ -0,0 +1,24 @@ + + + +;; Send out what comes in. +(pd-bind 'in + (lambda (arg) + (pd-send 'out arg))) + + +#! +;; This one does the same and is faster, but requires some more typing: +(let ((s-out (pd-get-symbol 'out))) + (pd-bind 'in + (lambda (arg) + (pd-send s-out arg)))) +!# + + +#! +;; And the following example will (most probably) lead to a segmentation fault: +;; This is also the only way I can think of right now that will make pd segfault using the pd- interface. +(pd-send 5 arg) +!# + -- cgit v1.2.1