diff options
| -rw-r--r-- | Makefile | 48 | ||||
| -rw-r--r-- | config.h | 4 | ||||
| -rw-r--r-- | pdlib.tcl | 43 | ||||
| -rw-r--r-- | tcl.i | 170 | ||||
| -rw-r--r-- | tcl_class.cxx | 93 | ||||
| -rw-r--r-- | tcl_extras.cxx | 86 | ||||
| -rw-r--r-- | tcl_extras.h | 38 | ||||
| -rw-r--r-- | tcl_loader.cxx | 6 | ||||
| -rw-r--r-- | tcl_setup.cxx | 53 | ||||
| -rw-r--r-- | tcl_typemap.cxx | 68 |
10 files changed, 340 insertions, 269 deletions
@@ -1,24 +1,11 @@ #!/usr/bin/make DEBUG=1 -TCL_VERSION := $(shell echo 'puts $$tcl_version' | tclsh) -INCLUDES = -I../../pd/src -I/usr/include -I/usr/include/tcl$(TCL_VERSION) -CFLAGS += $(INCLUDES) -xc++ -funroll-loops -fno-operator-names -fno-omit-frame-pointer -falign-functions=16 -O2 -Wall -fPIC +OS = linux + ifeq ($(DEBUG),1) CFLAGS += -O0 -g -ggdb -DDEBUG endif -LDSOFLAGS += -lm -ltcl$(TCL_VERSION) -CXX = g++ -OS = linux -LDSHARED = $(CXX) $(PDBUNDLEFLAGS) - -all:: tcl - -clean:: - rm -f tcl.pd_linux tcl_wrap.cxx *.o *~ - -.SUFFIXES: - ifeq ($(OS),darwin) PDSUF = .pd_darwin PDBUNDLEFLAGS = -bundle -flat_namespace -undefined dynamic_lookup @@ -32,11 +19,32 @@ else endif endif -tcl:: tcl.pd_linux +LIBNAME = tcl +TCL_VERSION := $(shell echo 'puts $$tcl_version' | tclsh) +INCLUDES = -I../../pd/src -I/usr/include -I/usr/include/tcl$(TCL_VERSION) +CFLAGS += -funroll-loops -fno-operator-names -fno-omit-frame-pointer -falign-functions=16 -O2 -Wall -fPIC +CFLAGS += -DPDSUF=\"$(PDSUF)\" +LDSOFLAGS += -lm -ltcl$(TCL_VERSION) +LDSHARED = $(CXX) $(PDBUNDLEFLAGS) + +all:: $(LIBNAME)$(PDSUF) + @echo '-----------------------------------------------------------------------------' + @echo ' $(LIBNAME)$(PDSUF) ('`test $(DEBUG) -eq 1 && echo debug || echo release`' build) '\ + '[size: '`ls -gGh $(LIBNAME)$(PDSUF) | cut -d " " -f 3`']' -tcl.pd_linux: tcl_wrap.cxx tcl_extras.cxx tcl_loader.cxx tcl_extras.h Makefile - $(LDSHARED) $(CFLAGS) -DPDSUF=\"$(PDSUF)\" -o tcl$(PDSUF) \ - tcl_wrap.cxx tcl_extras.cxx tcl_loader.cxx $(LDSOFLAGS) +clean:: + rm -f tcl.pd_linux tcl_wrap.cxx *.o *~ + +.SUFFIXES: .cxx .o -tcl_wrap.cxx: tcl.i tcl_extras.h +SRCS = tcl_wrap.cxx tcl_typemap.cxx tcl_class.cxx tcl_setup.cxx tcl_loader.cxx +OBJS = ${SRCS:.cxx=.o} + +tcl_wrap.cxx:: tcl.i tcl_extras.h Makefile swig -v -c++ -tcl -o tcl_wrap.cxx $(INCLUDES) tcl.i + +.cxx.o:: tcl_extras.h Makefile + $(CXX) $(CFLAGS) $(INCLUDES) -xc++ -c $< + +$(LIBNAME)$(PDSUF):: tcl_extras.h Makefile $(OBJS) + $(LDSHARED) $(CFLAGS) -o $(LIBNAME)$(PDSUF) $(OBJS) $(LDSOFLAGS) diff --git a/config.h b/config.h deleted file mode 100644 index c3bc2d3..0000000 --- a/config.h +++ /dev/null @@ -1,4 +0,0 @@ -#ifndef __CONFIG_H -#define __CONFIG_H -#include <tcl.h> -#endif /* __CONFIG_H */ @@ -12,6 +12,7 @@ namespace eval ::pd { return "pdlib: [uplevel {lindex [info level 0] 0}]: error: $m" } + # create additional inlets with this proc add_inlet {self sel} { if $::verbose {post [info level 0]} variable _ @@ -19,20 +20,36 @@ namespace eval ::pd { float { set ptr [new_t_float] lappend _($self:p_inlet) $ptr - lappend _($self:x_inlet) [floatinlet_new [tclpd_get_object $self] $ptr] + lappend _($self:t_inlet) "float" + #lappend _($self:x_inlet) [floatinlet_new [tclpd_get_object $self] $ptr] } symbol { set ptr [new_t_symbol] lappend _($self:p_inlet) $ptr - lappend _($self:x_inlet) [symbolinlet_new [tclpd_get_object $self] $ptr] + lappend _($self:t_inlet) "symbol" + #lappend _($self:x_inlet) [symbolinlet_new [tclpd_get_object $self] $ptr] + } + list { + set ptr [new_t_alist] + alist_init $ptr + alist_list $ptr 0 3 {some test args} + lappend _($self:p_inlet) $ptr + lappend _($self:t_inlet) "list" + } + DISABLED__pointer { + ## need to think more about this + # set ptr [new_t_pointer] + # lappend _($self:p_inlet) $ptr + ## lappend _($self:x_inlet) [pointerinlet_new [tclpd_get_object $self] $ptr] } default { return -code error [error_msg "unsupported selector: $sel"] } } - return [lindex $_($self:x_inlet) end] + #return [lindex $_($self:x_inlet) end] } + # get the value of a given inlet (inlets numbered starting from 1) proc inlet {self n} { if {$::verbose} {post [info level 0]} if {$n <= 0} {return {}} @@ -41,9 +58,15 @@ namespace eval ::pd { return -code error [error_msg "no such inlet: $n"] } variable _ - return [[lindex $_($self:p_inlet) [expr $n-1]] value] + set p_inlet [lindex $_($self:p_inlet) [expr $n-1]] + if {$_($self:t_inlet) == {list}} { + return [$p_inlet value] + } else { + return [$p_inlet value] + } } + # used in object constructor for adding inlets proc add_outlet {self sel} { if $::verbose {post [info level 0]} variable _ @@ -67,6 +90,7 @@ namespace eval ::pd { return [lindex $_($self:x_outlet) end] } + # used inside class for outputting some value proc outlet {self n sel args} { if $::verbose {post [info level 0]} variable _ @@ -99,12 +123,14 @@ namespace eval ::pd { } } + # used in object constructor to create inlets (internal method) proc create_iolets {cn self} { if $::verbose {post [info level 0]} variable class_db variable _ set _($self:p_inlet) {} - set _($self:x_inlet) {} + #set _($self:x_inlet) {} + set _($self:t_inlet) {} set _($self:x_outlet) {} for {set i 0} {$i < [llength $class_db($cn:d_inlet)]} {incr i} { add_inlet $self [lindex $class_db($cn:d_inlet) $i] @@ -114,6 +140,7 @@ namespace eval ::pd { } } + # add a class method (that is: a proc named <class>_<sel>) proc call_classmethod {classname self sel args} { if $::verbose {post [info level 0]} set m "${classname}_${sel}" @@ -122,12 +149,14 @@ namespace eval ::pd { } } + # this handles the pd::class definition proc class {classname def} { if $::verbose {post [lrange [info level 0] 0 end-1]} variable class_db array set class_db {} set class_db($classname:d_inlet) {} set class_db($classname:d_outlet) {} + # strip comments: set def2 [regsub -all -line {#.*$} $def {}] set patchable_flag 1 set noinlet_flag 0 @@ -157,10 +186,12 @@ namespace eval ::pd { } } + # class level dispatcher (sort of class constructor) proc ::$classname {self args} " if \$::verbose {::pd::post \[info level 0\]} ::pd::create_iolets $classname \$self ::pd::call_classmethod $classname \$self constructor {*}\$args + # object dispatcher proc ::\$self {selector args} \" if \\\$::verbose {::pd::post \\\[info level 0\\\]} ::pd::call_classmethod $classname \$self \\\$selector {*}\\\$args @@ -174,9 +205,11 @@ namespace eval ::pd { 3 * ($patchable_flag != 0) }] + # this wraps the call to class_new() tclpd_class_new $classname $flag } + # wrapper to post() withouth vargs proc post {args} { poststring2 [concat {*}$args] } @@ -44,9 +44,13 @@ %include "tcl_extras.h" %{ -#include "m_pd.h" + #include "m_pd.h" + #include "tcl_extras.h" -typedef t_atom t_atom_array; + typedef t_atom t_atom_array; + + /* extern "C" SWIGEXPORT int Tclpd_SafeInit(Tcl_Interp *interp); */ + /* extern "C" { void tcl_setup() {tclpd_setup(void);} } */ %} %name(outlet_list) EXTERN void outlet_list(t_outlet *x, t_symbol *s, int argc, t_atom_array *argv); @@ -54,155 +58,41 @@ typedef t_atom t_atom_array; %pointer_class(t_float, t_float) %pointer_class(t_symbol, t_symbol) -%{ -#include "tcl_extras.h" - -#include <unistd.h> -#include "config.h" - -Tcl_Interp *tcl_for_pd = 0; - -extern "C" SWIGEXPORT int Tclpd_SafeInit(Tcl_Interp *interp); - -extern "C" void tcl_setup (void) { - /* Pd initialization */ - - if (tcl_for_pd) { - post("Tcl: already loaded"); - return; - } - post("Tcl external v0.1-alpha - 09.2007"); - post("by Federico Ferri <mescalinum@gmail.com>, Mathieu Bouchard <matju@artengine.ca>"); - tcl_for_pd = Tcl_CreateInterp(); - Tcl_Init(tcl_for_pd); - Tclpd_SafeInit(tcl_for_pd); - - char *dirname = new char[242]; - char *dirresult = new char[242]; - /* nameresult is only a pointer in dirresult space so don't delete[] it. */ - char *nameresult; - if (getcwd(dirname,242)<0) {post("AAAARRRRGGGGHHHH!"); exit(69);} - int fd=open_via_path(dirname,"gridflow/tcl",PDSUF,dirresult,&nameresult,242,1); - if (fd<0) fd=open_via_path(dirname, "tcl",PDSUF,dirresult,&nameresult,242,1); - if (fd>=0) { - close(fd); - } else { - post("%s was not found via the -path!","tcl"PDSUF); - } - Tcl_SetVar(tcl_for_pd,"DIR",dirresult,0); - Tcl_Eval(tcl_for_pd,"set auto_path [concat [list $DIR/.. $DIR $DIR/optional/rblti] $auto_path]"); - - if (Tcl_Eval(tcl_for_pd,"source $DIR/tcl.tcl") == TCL_OK) - post("Tcl: loaded %s/tcl.tcl", dirresult); - - if (Tcl_Eval(tcl_for_pd,"source $env(HOME)/.pd.tcl") == TCL_OK) - post("Tcl: loaded ~/.pd.tcl"); - - delete[] dirresult; - delete[] dirname; - - post("Tcl: registering tcl loader"); - sys_register_loader(tclpd_do_load_lib); -} - -int tcl_to_pd(Tcl_Obj *input, t_atom *output) { - int llength; - if(Tcl_ListObjLength(tcl_for_pd, input, &llength) == TCL_ERROR) - return TCL_ERROR; - if(llength != 2) - /*SWIG_exception(SWIG_ValueError, "Bad t_atom: expeting a 2-elements list.");*/ - return TCL_ERROR; - - int i; - Tcl_Obj* obj[2]; - for(i = 0; i < 2; i++) Tcl_ListObjIndex(tcl_for_pd, input, i, &obj[i]); - char* argv0 = Tcl_GetStringFromObj(obj[0], 0); - - if(strcmp(argv0, "float") == 0) { - double dbl; - if(Tcl_GetDoubleFromObj(tcl_for_pd, obj[1], &dbl) == TCL_ERROR) - return TCL_ERROR; - SETFLOAT(output, dbl); - } else if(strcmp(argv0, "symbol") == 0) { - SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); - } else if(strcmp(argv0, "pointer") == 0) { - // TODO: - } - return TCL_OK; -} - -int pd_to_tcl(t_atom *input, Tcl_Obj **output) { - Tcl_Obj* tcl_t_atom[2]; -#ifdef DEBUG - post("pd_to_tcl: atom type = %d (%s)", - input->a_type, input->a_type == A_FLOAT ? "A_FLOAT" : - input->a_type == A_SYMBOL ? "A_SYMBOL" : - input->a_type == A_POINTER ? "A_POINTER" : "?"); -#endif - switch (input->a_type) { - case A_FLOAT: { - tcl_t_atom[0] = Tcl_NewStringObj("float", -1); - tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float); - break; - } - case A_SYMBOL: { - tcl_t_atom[0] = Tcl_NewStringObj("symbol", -1); - tcl_t_atom[1] = Tcl_NewStringObj(input->a_w.w_symbol->s_name, strlen(input->a_w.w_symbol->s_name)); - break; - } - case A_POINTER: { - tcl_t_atom[0] = Tcl_NewStringObj("pointer", -1); - tcl_t_atom[1] = Tcl_NewDoubleObj((long)input->a_w.w_gpointer); - break; - } - default: { - tcl_t_atom[0] = Tcl_NewStringObj("?", -1); - tcl_t_atom[1] = Tcl_NewStringObj("", 0); - break; - } - } -#ifdef DEBUG - post("pd_to_tcl: atom value = \"%s\"", Tcl_GetStringFromObj(tcl_t_atom[1], 0)); -#endif - *output = Tcl_NewListObj(2, &tcl_t_atom[0]); - Tcl_IncrRefCount(*output); - return TCL_OK; -} - -%} - %typemap(in) t_atom * { - t_atom *a = (t_atom*)getbytes(sizeof(t_atom)); - if(tcl_to_pd($input, a) == TCL_ERROR) - return TCL_ERROR; - $1 = a; + t_atom *a = (t_atom*)getbytes(sizeof(t_atom)); + if(tcl_to_pd($input, a) == TCL_ERROR) + return TCL_ERROR; + $1 = a; } %typemap(freearg) t_atom * { - freebytes($1, sizeof(t_atom)); + freebytes($1, sizeof(t_atom)); } %typemap(out) t_atom* { - Tcl_Obj* res_obj; - if(pd_to_tcl($1, &res_obj) == TCL_ERROR) - return TCL_ERROR; - Tcl_SetObjResult(tcl_for_pd, res_obj); + Tcl_Obj* res_obj; + if(pd_to_tcl($1, &res_obj) == TCL_ERROR) + return TCL_ERROR; + Tcl_SetObjResult(tcl_for_pd, res_obj); } /* helper functions for t_atom arrays */ %inline %{ -t_atom_array *new_atom_array(int size) { - return (t_atom_array*)getbytes(size*sizeof(t_atom)); -} -void delete_atom_array(t_atom_array *a, int size) { - freebytes(a, size*sizeof(t_atom)); -} -t_atom* get_atom_array(t_atom_array *a, int index) { - return &a[index]; -} -void set_atom_array(t_atom_array *a, int index, t_atom *n) { - memcpy(&a[index], n, sizeof(t_atom)); -} + t_atom_array *new_atom_array(int size) { + return (t_atom_array*)getbytes(size*sizeof(t_atom)); + } + + void delete_atom_array(t_atom_array *a, int size) { + freebytes(a, size*sizeof(t_atom)); + } + + t_atom* get_atom_array(t_atom_array *a, int index) { + return &a[index]; + } + + void set_atom_array(t_atom_array *a, int index, t_atom *n) { + memcpy(&a[index], n, sizeof(t_atom)); + } %} diff --git a/tcl_class.cxx b/tcl_class.cxx new file mode 100644 index 0000000..a95bf5c --- /dev/null +++ b/tcl_class.cxx @@ -0,0 +1,93 @@ +#include "tcl_extras.h" +#include <map> +#include <string> +#include <string.h> + +using namespace std; + +static long objectSequentialId = 0; +map<string,t_class*> class_table; +map<string,t_pd*> object_table; + +/* set up the class that handles loading of tcl classes */ +t_class* tclpd_class_new(char *name, int flags) { + t_class *c = class_new(gensym(name), (t_newmethod)tclpd_new, + (t_method)tclpd_free, sizeof(t_tcl), flags, A_GIMME, A_NULL); + class_table[string(name)] = c; + class_addanything(c, tclpd_anything); + return c; +} + +t_tcl* tclpd_new(t_symbol *classsym, int ac, t_atom *at) { + const char* name = classsym->s_name; + t_class* qlass = class_table[string(name)]; + t_tcl* self = (t_tcl*)pd_new(qlass); + char s[32]; + sprintf(s, "pd%06lx", objectSequentialId++); + self->self = Tcl_NewStringObj(s, -1); + Tcl_IncrRefCount(self->self); + object_table[string(s)] = (t_pd*)self; + Tcl_Obj *av[ac+2]; + av[0] = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(av[0]); + av[1] = self->self; + for(int i=0; i<ac; i++) { + if(pd_to_tcl(&at[i], &av[2+i]) == TCL_ERROR) { + post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); + pd_free((t_pd *)self); + return 0; + } + } + if (Tcl_EvalObjv(tcl_for_pd,ac+2,av,0) != TCL_OK) { + post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); + pd_free((t_pd *)self); + return 0; + } + return self; +} + +void tclpd_free (t_tcl *self) { +#ifdef DEBUG + post("tclpd_free called"); +#endif +} + +void tclpd_anything(t_tcl *self, t_symbol *s, int ac, t_atom *at) { +/* proxy method */ + Tcl_Obj *av[ac+2]; + av[0] = self->self; + av[1] = Tcl_NewIntObj(0); // TODO: 0 -> outlet_number + Tcl_AppendToObj(av[1],"_",1); + Tcl_AppendToObj(av[1],s->s_name,strlen(s->s_name)); // selector + Tcl_IncrRefCount(av[1]); + for(int i=0; i<ac; i++) { + if(pd_to_tcl(&at[i], &av[2+i]) == TCL_ERROR) { + post("Tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); + return; + } + } + int result = Tcl_EvalObjv(tcl_for_pd,ac+2,av,0); + Tcl_DecrRefCount(av[1]); + if (result != TCL_OK) + post("Tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); +} + +/* Tcl glue: */ + +t_pd* tclpd_get_instance(const char* objectSequentialId) { + return object_table[objectSequentialId]; +} + +t_object* tclpd_get_object(const char* objectSequentialId) { + t_tcl* x = (t_tcl*)tclpd_get_instance(objectSequentialId); + return &x->o; +} + +t_pd* tclpd_get_object_pd(const char* objectSequentialId) { + t_object* o = tclpd_get_object(objectSequentialId); + return &o->ob_pd; +} + +void poststring2 (const char *s) { + post("%s", s); +} diff --git a/tcl_extras.cxx b/tcl_extras.cxx deleted file mode 100644 index e277e60..0000000 --- a/tcl_extras.cxx +++ /dev/null @@ -1,86 +0,0 @@ -#include "tcl_extras.h" -#include <map> -#include <string> -#include <string.h> - -using namespace std; - -static long cereal=0; -map<string,t_class*> class_table; -map<string,t_pd*> object_table; - -void poststring2 (const char *s) {post("%s",s);} - -static void *tclpd_init (t_symbol *classsym, int ac, t_atom *at) { - const char *name = classsym->s_name; - t_class *qlass = class_table[string(name)]; - t_tcl *self = (t_tcl *)pd_new(qlass); - char s[32]; - sprintf(s,"pd%06lx",cereal++); - self->self = Tcl_NewStringObj(s, -1); - Tcl_IncrRefCount(self->self); - object_table[string(s)] = (t_pd*)self; - Tcl_Obj *av[ac+2]; - av[0] = Tcl_NewStringObj(name, -1); - Tcl_IncrRefCount(av[0]); - av[1] = self->self; - for(int i=0; i<ac; i++) { - if(pd_to_tcl(&at[i], &av[2+i]) == TCL_ERROR) { - post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); - pd_free((t_pd *)self); - return 0; - } - } - if (Tcl_EvalObjv(tcl_for_pd,ac+2,av,0) != TCL_OK) { - post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); - pd_free((t_pd *)self); - return 0; - } - return self; -} - -t_pd* tclpd_get_instance(const char* cereal) { - return object_table[cereal]; -} - -t_object* tclpd_get_object(const char* cereal) { - t_tcl* x = (t_tcl*)tclpd_get_instance(cereal); - return &x->o; -} - -t_pd* tclpd_get_object_pd(const char* cereal) { - t_object* o = tclpd_get_object(cereal); - return &o->ob_pd; -} - -static void tclpd_anything (t_tcl *self, t_symbol *s, int ac, t_atom *at) { - /* proxy method */ - Tcl_Obj *av[ac+2]; - av[0] = self->self; - av[1] = Tcl_NewIntObj(0); // TODO: 0 -> outlet_number - Tcl_AppendToObj(av[1],"_",1); - Tcl_AppendToObj(av[1],s->s_name,strlen(s->s_name)); // selector - Tcl_IncrRefCount(av[1]); - for(int i=0; i<ac; i++) { - if(pd_to_tcl(&at[i], &av[2+i]) == TCL_ERROR) { - post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); - return; - } - } - int result = Tcl_EvalObjv(tcl_for_pd,ac+2,av,0); - Tcl_DecrRefCount(av[1]); - if (result != TCL_OK) - post("tcl error: %s\n", Tcl_GetStringResult(tcl_for_pd)); -} - -static void tclpd_free (t_tcl *self) { - post("tclpd_free called"); -} - -t_class *tclpd_class_new (char *name, int flags) { - t_class *qlass = class_new(gensym(name), (t_newmethod) tclpd_init, - (t_method) tclpd_free, sizeof(t_tcl), flags, A_GIMME, A_NULL); - class_table[string(name)] = qlass; - class_addanything(qlass,tclpd_anything); - return qlass; -} diff --git a/tcl_extras.h b/tcl_extras.h index 16cc31c..e3546c6 100644 --- a/tcl_extras.h +++ b/tcl_extras.h @@ -1,28 +1,42 @@ #include "m_pd.h" #include <tcl.h> -typedef struct t_tcl { - t_object o; - Tcl_Obj *self; -} t_tcl; +/* PATH_MAX is not defined in limits.h on some platforms */ +#ifndef PATH_MAX +#define PATH_MAX 4096 +#endif -void poststring2 (const char* s); +typedef struct _t_tcl { + t_object o; + Tcl_Obj *self; +} t_tcl; -t_class* tclpd_class_new (char* name, int flags); -t_pd* tclpd_get_instance (const char* cereal); -t_object* tclpd_get_object (const char* cereal); -t_pd* tclpd_get_object_pd (const char* cereal); +/* tcl_wrap.cxx */ +extern "C" int Tclpd_SafeInit(Tcl_Interp *interp); +/* tcl_typemap.cxx */ int pd_to_tcl (t_atom* input, Tcl_Obj** output); int tcl_to_pd (Tcl_Obj* input, t_atom* output); +/* tcl_setup.cxx */ extern Tcl_Interp *tcl_for_pd; +extern "C" void tclpd_setup(void); -/* tcl loader */ +/* tcl_class.cxx */ +t_class* tclpd_class_new(char *name, int flags); +t_tcl* tclpd_new(t_symbol *classsym, int ac, t_atom *at); +void tclpd_free (t_tcl *self); +void tclpd_anything(t_tcl *self, t_symbol *s, int ac, t_atom *at); +t_pd* tclpd_get_instance(const char* objectSequentialId); +t_object* tclpd_get_object(const char* objectSequentialId); +t_pd* tclpd_get_object_pd(const char* objectSequentialId); +void poststring2 (const char *s); + +/* tcl_loader.cxx */ +extern "C" int tclpd_do_load_lib (t_canvas *canvas, char *objectname); +/* pd loader private stuff: */ typedef int (*loader_t)(t_canvas *canvas, char *classname); extern "C" void sys_register_loader(loader_t loader); extern "C" int sys_onloadlist(char *classname); extern "C" void sys_putonloadlist(char *classname); extern "C" void class_set_extern_dir(t_symbol *s); -extern "C" int tclpd_do_load_lib (t_canvas *canvas, char *objectname); - diff --git a/tcl_loader.cxx b/tcl_loader.cxx index fececed..e7f22ff 100644 --- a/tcl_loader.cxx +++ b/tcl_loader.cxx @@ -2,8 +2,10 @@ #include <string.h> #include <unistd.h> -extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname) -{ +extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname) { +#ifdef DEBUG + post("Tcl loader: registering tcl class loader mechanism"); +#endif char filename[MAXPDSTRING], dirbuf[MAXPDSTRING], *classname, *nameptr; int fd; diff --git a/tcl_setup.cxx b/tcl_setup.cxx new file mode 100644 index 0000000..28d6778 --- /dev/null +++ b/tcl_setup.cxx @@ -0,0 +1,53 @@ +#include "tcl_extras.h" +#include <unistd.h> +#include <limits.h> + +Tcl_Interp *tcl_for_pd = NULL; + +extern "C" void tcl_setup(void) { + tclpd_setup(); +} + +void tclpd_setup(void) { + if(tcl_for_pd) { + return; + } + + post("Tcl loader v0.1.1 - 08.2009"); + + tcl_for_pd = Tcl_CreateInterp(); + Tcl_Init(tcl_for_pd); + Tclpd_SafeInit(tcl_for_pd); + + char *dirname = new char[PATH_MAX]; + char *dirresult = new char[PATH_MAX]; + /* nameresult is only a pointer in dirresult space so don't delete[] it. */ + char *nameresult; + if(getcwd(dirname, PATH_MAX) < 0) { + post("Tcl loader: FATAL: cannot get current dir"); + /* exit(69); */ return; + } + + int fd = open_via_path(dirname, "tcl", PDSUF, dirresult, &nameresult, PATH_MAX, 1); + if(fd >= 0) { + close(fd); + } else { + post("Tcl loader: %s was not found via the -path!", "tcl" PDSUF); + } + + Tcl_SetVar(tcl_for_pd, "DIR", dirresult, 0); + Tcl_Eval(tcl_for_pd, "set auto_path [linsert $auto_path $DIR]"); + + if(Tcl_Eval(tcl_for_pd, "source $DIR/tcl.tcl") == TCL_OK) { + post("Tcl loader: loaded %s/tcl.tcl", dirresult); + } + + if(Tcl_Eval(tcl_for_pd,"source $env(HOME)/.pd.tcl") == TCL_OK) { + post("Tcl loader: loaded ~/.pd.tcl"); + } + + delete[] dirresult; + delete[] dirname; + + sys_register_loader(tclpd_do_load_lib); +} diff --git a/tcl_typemap.cxx b/tcl_typemap.cxx new file mode 100644 index 0000000..4044afb --- /dev/null +++ b/tcl_typemap.cxx @@ -0,0 +1,68 @@ +#include "tcl_extras.h" +#include <string.h> + +int tcl_to_pd(Tcl_Obj *input, t_atom *output) { + int llength; + if(Tcl_ListObjLength(tcl_for_pd, input, &llength) == TCL_ERROR) + return TCL_ERROR; + if(llength != 2) + /*SWIG_exception(SWIG_ValueError, "Bad t_atom: expeting a 2-elements list.");*/ + return TCL_ERROR; + + int i; + Tcl_Obj* obj[2]; + for(i = 0; i < 2; i++) Tcl_ListObjIndex(tcl_for_pd, input, i, &obj[i]); + char* argv0 = Tcl_GetStringFromObj(obj[0], 0); + + if(strcmp(argv0, "float") == 0) { + double dbl; + if(Tcl_GetDoubleFromObj(tcl_for_pd, obj[1], &dbl) == TCL_ERROR) + return TCL_ERROR; + SETFLOAT(output, dbl); + } else if(strcmp(argv0, "symbol") == 0) { + SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); + } else if(strcmp(argv0, "pointer") == 0) { + // TODO: + return TCL_ERROR; + } + return TCL_OK; +} + +int pd_to_tcl(t_atom *input, Tcl_Obj **output) { + Tcl_Obj* tcl_t_atom[2]; +#ifdef DEBUG + post("pd_to_tcl: atom type = %d (%s)", + input->a_type, input->a_type == A_FLOAT ? "A_FLOAT" : + input->a_type == A_SYMBOL ? "A_SYMBOL" : + input->a_type == A_POINTER ? "A_POINTER" : "?"); +#endif + switch (input->a_type) { + case A_FLOAT: { + tcl_t_atom[0] = Tcl_NewStringObj("float", -1); + tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float); + break; + } + case A_SYMBOL: { + tcl_t_atom[0] = Tcl_NewStringObj("symbol", -1); + tcl_t_atom[1] = Tcl_NewStringObj(input->a_w.w_symbol->s_name, strlen(input->a_w.w_symbol->s_name)); + break; + } + case A_POINTER: { + return TCL_ERROR; + tcl_t_atom[0] = Tcl_NewStringObj("pointer", -1); + tcl_t_atom[1] = Tcl_NewDoubleObj((long)input->a_w.w_gpointer); + break; + } + default: { + tcl_t_atom[0] = Tcl_NewStringObj("?", -1); + tcl_t_atom[1] = Tcl_NewStringObj("", 0); + break; + } + } +#ifdef DEBUG + post("pd_to_tcl: atom value = \"%s\"", Tcl_GetStringFromObj(tcl_t_atom[1], 0)); +#endif + *output = Tcl_NewListObj(2, &tcl_t_atom[0]); + Tcl_IncrRefCount(*output); + return TCL_OK; +} |