Update of /cvsroot/pure-data/externals/k_guile In directory sc8-pr-cvs1:/tmp/cvs-serv12055/k_guile
Added Files: Makefile README add.scm gen_c_scheme.py global.scm help-k_guile.pd inout.scm k_guile.c local.scm mozilla.scm send_receive.scm Log Message: First commit of k_vst~, k_guile and k_cext
--- NEW FILE: Makefile --- 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
--- NEW FILE: README ---
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
--- NEW FILE: add.scm ---
(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)))))
--- NEW FILE: gen_c_scheme.py --- #!/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')
--- NEW FILE: global.scm ---
;; 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))
--- NEW FILE: help-k_guile.pd --- #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;
--- NEW FILE: inout.scm ---
(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.")))
--- NEW FILE: k_guile.c --- /* --------------------------- 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 <stdio.h> #include <stdlib.h> #include <string.h> #include <math.h> #include <stdbool.h> #include <stdarg.h>
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;lokke<x->num_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;lokke<x->num_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<length;lokke++){ SCM el=scm_list_ref(val,MAKE_INTEGER(lokke)); t_atom *to=&atom[lokke]; if(SCM_INUMP(el)){ SETFLOAT(to,(float)GET_INTEGER(el)); }else{ if(SCM_UNBNDP(el)){ SETSYMBOL(to,gensym("undefined")); }else{ if(SCM_STRINGP(el)){ SETSYMBOL(to,gensym(SCM_STRING_CHARS(el))); }else{ if(SCM_SYMBOLP(el)){ SETSYMBOL(to,MAKE_SYM(el)); }else{ if(scm_number_p(el)){ if(scm_real_p(el)){ SETFLOAT(to,(float)scm_num2dbl(el,"gpd_outlet_or_send_list")); }else{ post("Illegal argument to gdp_outlet_or_send_list. Setting atom to 0."); SETFLOAT(to,0.0f); } } } } } } } return atom; } static SCM gpd_outlet_list(SCM instance,SCM outlet,SCM val){ int length=GET_INTEGER(scm_length(val)); t_atom atom[length]; outlet_list(GET_OUTLET(), &s_list,length,make_list(atom,val)); RU_; } static SCM gpd_send_list(SCM symbol,SCM val){ int length=GET_INTEGER(scm_length(val)); t_atom atom[length]; CLASS_INIT pd_list(s, &s_list,length,make_list(atom,val)); RU_; }
/* Symbol -> 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;lokke<x->num_ins;lokke++){ inlet_free(x->inlets[lokke]->inlet); pd_free((t_pd*)x->inlets[lokke]); } for(lokke=0;lokke<x->num_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); }
--- NEW FILE: local.scm ---
;; 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)
--- NEW FILE: mozilla.scm ---
(pd-inlet 0 'start (lambda x (system "mozilla&")))
--- NEW FILE: send_receive.scm ---
;; 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) !#