fixed binbuf support

svn path=/trunk/externals/loaders/tclpd/; revision=15751

7 files changed, 131 insertions, 81 deletions

diff --git a/ChangeLog.txt b/ChangeLog.txt
index 917e22b..ee576cc 100644
--- a/ChangeLog.txt
+++ b/ChangeLog.txt
@@ -1,5 +1,6 @@
 Version 0.3.0:
 	- Big rewrite, fixing typemaps
+	- Support for most binbuf atoms (COMMA, SEMI, DOLLAR, DOLLSYM, ...)
 
 Version 0.2.3:
 	- Big rewrite, using tcl namespaces (more tidy, more efficient)
diff --git a/TODO.txt b/TODO.txt
index c5371b3..04aa87e 100644
--- a/TODO.txt
+++ b/TODO.txt
@@ -1,7 +1,5 @@
 TODO-list for tclpd (most important things first)
 =================================================
-- binbuf support broken
-- unable to patch classes with dir prefixes (e.g. [dir/class]) (crashes pd)
 - bitmap's help make pd crash only when opened via context menu Help -> investigate
 - slider2.tcl is broken
 - add (or check) GOP
diff --git a/tcl_class.c b/tcl_class.c
index fc4136d..46aec27 100644
--- a/tcl_class.c
+++ b/tcl_class.c
@@ -324,6 +324,12 @@ t_atom * tclpd_binbuf_get_atom(t_binbuf *b, int n) {
 }
 */
 
+/* helper function for accessing binbuf's atoms
+   cause, accessing C arrays and doing typemaps is not that easy */
+t_atom * binbuf_getatom(t_binbuf *x, int index) {
+    return binbuf_getvec(x) + index;
+}
+
 t_object * CAST_t_object(t_object *o) {
     return o;
 }
diff --git a/tcl_typemap.c b/tcl_typemap.c
index 0f4b5d0..e1d770f 100644
--- a/tcl_typemap.c
+++ b/tcl_typemap.c
@@ -1,12 +1,41 @@
 #include "tclpd.h"
 #include <string.h>
 
+static const char *atomtype_map[] = {
+  /* A_NULL */     "null",
+  /* A_FLOAT */    "float",
+  /* A_SYMBOL */   "symbol",
+  /* A_POINTER */  "pointer",
+  /* A_SEMI */     "semi",
+  /* A_COMMA */    "comma",
+  /* A_DEFFLOAT */ "deffloat",
+  /* A_DEFSYM */   "defsym",
+  /* A_DOLLAR */   "dollar",
+  /* A_DOLLSYM */  "dollsym",
+  /* A_GIMME */    "gimme",
+  /* A_CANT */     "cant",
+  /* A_BLOB */     "blob"
+};
+
+#define atomtype_map_size (sizeof(atomtype_map)/sizeof(atomtype_map[0]))
+
+static const char * fwd_atomtype_map(t_atomtype t) {
+    if(t >= atomtype_map_size) return atomtype_map[A_NULL];
+    return atomtype_map[t];
+}
+
+static t_atomtype rev_atomtype_map(const char *s) {
+    for(t_atomtype i = 0; i < atomtype_map_size; i++) {
+        if(strcmp(s, atomtype_map[i]) == 0) return i;
+    }
+    return A_NULL;
+}
+
 int tcl_to_pdatom(Tcl_Obj *input, t_atom *output) {
     int llength;
     if(Tcl_ListObjLength(tclpd_interp, 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;
@@ -14,17 +43,62 @@ int tcl_to_pdatom(Tcl_Obj *input, t_atom *output) {
     for(i = 0; i < 2; i++) Tcl_ListObjIndex(tclpd_interp, input, i, &obj[i]);
     char *argv0 = Tcl_GetStringFromObj(obj[0], 0);
 
-    if(strcmp(argv0, "float") == 0) {
-        double dbl;
-        if(Tcl_GetDoubleFromObj(tclpd_interp, obj[1], &dbl) == TCL_ERROR)
+    t_atomtype a_type = rev_atomtype_map(argv0);
+
+    switch(a_type) {
+        case A_FLOAT:
+        case A_DEFFLOAT:
+        {
+            double dbl;
+            if(Tcl_GetDoubleFromObj(tclpd_interp, obj[1], &dbl) == TCL_ERROR)
+                return TCL_ERROR;
+            SETFLOAT(output, dbl);
+            break;
+        }
+        case A_SYMBOL:
+        case A_DEFSYM:
+        {
+            SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0)));
+            break;
+        }
+        case A_POINTER:
+        {
+            SETPOINTER(output, NULL);
+            break;
+        }
+        case A_SEMI:
+        {
+            SETSEMI(output);
+            break;
+        }
+        case A_COMMA:
+        {
+            SETCOMMA(output);
+            break;
+        }
+        case A_DOLLAR:
+        {
+            int ii;
+            if(Tcl_GetIntFromObj(tclpd_interp, obj[1], &ii) == TCL_ERROR)
+                return TCL_ERROR;
+            SETDOLLAR(output, ii);
+            break;
+        }
+        case A_DOLLSYM:
+        {
+            SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0)));
+            break;
+        }
+        case A_GIMME:
+        case A_CANT:
+        case A_BLOB:
+        case A_NULL:
+        {
+            // TODO: set error result
             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;
 }
 
@@ -34,62 +108,42 @@ int tcl_to_pdsymbol(Tcl_Obj *input, t_symbol **output) {
     return TCL_OK;
 }
 
-const char * pdatom_type_string(t_atom *a) {
-    switch(a->a_type) {
-    case A_FLOAT:
-    case A_DEFFLOAT:
-        return "float";
-    case A_SYMBOL:
-    case A_DEFSYM:
-    case A_DOLLAR:
-    case A_DOLLSYM:
-    case A_SEMI:
-    case A_COMMA:
-        return "symbol";
-    case A_POINTER:
-        return "pointer";
-    default:
-        error("atom_type_string: unsupported/unknown selector: %d", a->a_type);
-        return "???";
-    }
-}
-
-const char * pdatom_symbol_value(t_atom *a) {
-    if(a->a_type == A_DOLLAR) {
-        char buf[6];
-        snprintf(buf, 6, "$%d", a->a_w.w_index);
-        t_symbol *s = gensym(buf);
-        return s->s_name;
-    }
-    return a->a_w.w_symbol->s_name;
-}
-
-float pdatom_float_value(t_atom *a) {
-    return a->a_w.w_float;
-}
-
 int pdatom_to_tcl(t_atom *input, Tcl_Obj **output) {
     Tcl_Obj *tcl_t_atom[2];
+    tcl_t_atom[0] = Tcl_NewStringObj(fwd_atomtype_map(input->a_type), -1);
     switch (input->a_type) {
-        case A_FLOAT: {
-            tcl_t_atom[0] = Tcl_NewStringObj("float", -1);
+        case A_FLOAT:
+        case A_DEFFLOAT:
+        {
             tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float);
             break;
         }
-        case A_SYMBOL: {
-            tcl_t_atom[0] = Tcl_NewStringObj("symbol", -1);
+        case A_SYMBOL:
+        case A_DEFSYM:
+        case A_DOLLSYM:
+        {
             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);
+        case A_POINTER:
+        {
             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);
+        case A_DOLLAR:
+        {
+            tcl_t_atom[1] = Tcl_NewIntObj((int)input->a_w.w_index);
+            break;
+        }
+        case A_SEMI:
+        case A_COMMA:
+        case A_GIMME:
+        case A_CANT:
+        case A_BLOB:
+        case A_NULL:
+        default:
+        {
+            tcl_t_atom[1] = Tcl_NewStringObj("--", 2);
             break;
         }
     }
diff --git a/tclpd.h b/tclpd.h
index 20afc83..ff25106 100644
--- a/tclpd.h
+++ b/tclpd.h
@@ -51,9 +51,6 @@ extern int Tclpd_SafeInit(Tcl_Interp *interp);
 /* tcl_typemap.c */
 int tcl_to_pdatom(Tcl_Obj *input, t_atom *output);
 int tcl_to_pdsymbol(Tcl_Obj *input, t_symbol **output);
-const char * pdatom_type_string(t_atom *a);
-const char * pdatom_symbol_value(t_atom *a);
-float pdatom_float_value(t_atom *a);
 int pdatom_to_tcl(t_atom *input, Tcl_Obj **output);
 int pdsymbol_to_tcl(t_symbol *input, Tcl_Obj **output);
 
@@ -88,6 +85,7 @@ t_binbuf * tclpd_get_object_binbuf(const char *objectSequentialId);
 t_glist * tclpd_get_glist(const char *objectSequentialId);
 t_atom * tclpd_binbuf_get_atom(t_binbuf *b, int n);
 */
+t_atom * binbuf_getatom(t_binbuf *x, int index);
 t_object * CAST_t_object(t_object *o);
 t_pd * CAST_t_pd(t_pd *o);
 t_text * CAST_t_text(t_text *o);
diff --git a/tclpd.i b/tclpd.i
index 8e15d55..442787f 100644
--- a/tclpd.i
+++ b/tclpd.i
@@ -11,11 +11,11 @@
 %include carrays.i
 %include typemaps.i
 
-%pointer_functions(t_atom, atom)
-%pointer_functions(t_symbol, symbol)
+%pointer_functions(t_atom, atom);
+%pointer_functions(t_symbol, symbol);
 
-%array_functions(t_atom, atom_array)
 /*
+%array_functions(t_atom_array, atom_array);
 Creates four functions.
 
 type *new_name(int nelements)
@@ -81,26 +81,29 @@ void name_setitem(type *ary, int index, type value)
 %typemap(in) t_tcl * {
     const char *str = Tcl_GetStringFromObj($input, NULL);
     $1 = object_table_get(str);
-    SWIG_contract_assert($1, "not a t_tcl * instance");
+    SWIG_contract_assert($1, "not a t_tcl * instance") {};
 }
 
 %typemap(in) t_pd * {
     const char *str = Tcl_GetStringFromObj($input, NULL);
     $1 = object_table_get(str);
-    SWIG_contract_assert($1, "not a t_pd * instance");
+    SWIG_contract_assert($1, "not a t_pd * instance") {};
 }
 
 %typemap(in) t_text * {
-    const char *str = Tcl_GetStringFromObj($input, NULL);
-    t_tcl *x = object_table_get(str);
-    SWIG_contract_assert(x, "not a t_text * instance");
-    $1 = &x->o;
+    int res = SWIG_ConvertPtr($input, &$1, SWIGTYPE_p__text, 0 |  0 );
+    if(!SWIG_IsOK(res)) {
+        const char *str = Tcl_GetStringFromObj($input, NULL);
+        t_tcl *x = object_table_get(str);
+        SWIG_contract_assert(x, "not a t_text * instance") {};
+        $1 = &x->o;
+    }
 }
 
 %typemap(in) t_object * {
     const char *str = Tcl_GetStringFromObj($input, NULL);
     t_tcl *x = object_table_get(str);
-    SWIG_contract_assert(x, "not a t_object * instance");
+    SWIG_contract_assert(x, "not a t_object * instance") {};
     $1 = &x->o;
 }
 
diff --git a/tclpd.tcl b/tclpd.tcl
index fe358ac..a93fc84 100644
--- a/tclpd.tcl
+++ b/tclpd.tcl
@@ -261,24 +261,14 @@ namespace eval ::pd {
 
     proc get_binbuf {self} {
         set ob [CAST_t_object $self]
-        post "get_binbuf: ob = $ob"
-        if 0 {
         set binbuf [$ob cget -te_binbuf]
         set len [binbuf_getnatom $binbuf]
         set result {}
         for {set i 0} {$i < $len} {incr i} {
-            set atom [tclpd_binbuf_get_atom $binbuf $i]
-            set selector [atom_type_string $atom]
-            set value {?}
-            if {$selector eq "float"} {
-                set value [atom_float_value $atom]
-            } elseif {$selector eq "symbol"} {
-                set value [atom_symbol_value $atom]
-            }
-            lappend result [list $selector $value]
+            set atom [binbuf_getatom $binbuf $i]
+            lappend result $atom
         }
         return $result
-        } else {return {}}
     }
 }