improve errors printouts, and cleanup

svn path=/trunk/externals/tclpd/; revision=12132

3 files changed, 74 insertions, 40 deletions

diff --git a/list_change.tcl b/list_change.tcl
index 34ffe9a..562d036 100644
--- a/list_change.tcl
+++ b/list_change.tcl
@@ -1,32 +1,27 @@
 source pdlib.tcl
 
 pd::class list_change {
-#    inlet float
+    # first 'hot' inlet is created by default
+
+    # add 'cold' inlet:
+    inlet list
+
     outlet list
-#    outlet float
 
     constructor {
-        if [pd::args] {
-            set n [pd::arg_int 0]
-            for {set i 0} {$i < $n} {incr i} {
-                pd::add_inlet $self float
-            }
-        }
+        #pd::add_inlet $self float
+
         set @curlist {}
     }
 
     0_list {
-        set newlist $args
-        if {$newlist != $@curlist} {
-            pd::outlet $self 0 list $newlist
+        if {$args != $@curlist} {
+            set @curlist $args
+            0_bang
         }
-        set @curlist $newlist
-
-        pd::outlet $self 1 float [pd::inlet $self 1]
     }
 
     0_bang {
-        pd::post "right value is: [pd::inlet $self 1]"
+        pd::outlet $self 0 list $@curlist
     }
 }
-
diff --git a/pdlib.tcl b/pdlib.tcl
index 3ac00cd..83ba027 100644
--- a/pdlib.tcl
+++ b/pdlib.tcl
@@ -5,9 +5,12 @@ package provide pdlib 0.1
 
 package require Tcl 8.5
 
-set verbose 0
+set verbose 1
 
 namespace eval ::pd {
+    proc error_msg {m} {
+        return "pdlib: [uplevel {lindex [info level 0] 0}]: error: $m"
+    }
 
     proc add_inlet {self sel} {
         if $::verbose {post [info level 0]}
@@ -24,8 +27,7 @@ namespace eval ::pd {
                 lappend _($self:x_inlet) [symbolinlet_new [tclpd_get_object $self] $ptr]
             }
             default {
-                post "inlet creation error: unsupported selector: $sel"
-                return {}
+                return -code error [error_msg "unsupported selector: $sel"]
             }
         }
         return [lindex $_($self:x_inlet) end]
@@ -36,7 +38,7 @@ namespace eval ::pd {
         if {$n <= 0} {return {}}
         if {![info exists _($self:p_inlet)] ||
             $n >= [llength $_($self:p_inlet)]} {
-            return -code error "pdlib: error: no such inlet: $n"
+            return -code error [error_msg "no such inlet: $n"]
         }
         variable _
         return [[lindex $_($self:p_inlet) [expr $n-1]] value]
@@ -59,8 +61,7 @@ namespace eval ::pd {
                     [outlet_new [tclpd_get_object $self] [gensym "list"]]
             }
             default {
-                return -code error \
-                "pdlib: outlet creation error: unsupported selector: $sel"
+                return -code error [error_msg "unsupported selector: $sel"]
             }
         }
         return [lindex $_($self:x_outlet) end]
@@ -93,7 +94,7 @@ namespace eval ::pd {
                 outlet_bang $outlet
             }
             default {
-                return -code error "pdlib: outlet: unknown selector: $sel"
+                return -code error [error_msg "unknown selector: $sel"]
             }
         }
     }
@@ -122,11 +123,14 @@ namespace eval ::pd {
     }
 
     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) {}
         set def2 [regsub -all -line {#.*$} $def {}]
+        set patchable_flag 1
+        set noinlet_flag 0
         foreach {id arg} $def2 {
             switch -- $id {
                 inlet {
@@ -135,28 +139,42 @@ namespace eval ::pd {
                 outlet {
                     lappend class_db($classname:d_outlet) $arg
                 }
+                patchable {
+                    if {$arg != 0 && $arg != 1} {
+                        return -code error [error_msg "patchable must be 0/1"]
+                    }
+                    set patchable_flag $arg
+                }
+                noinlet {
+                    if {$arg != 0 && $arg != 1} {
+                        return -code error [error_msg "noinlet must be 0/1"]
+                    }
+                    set noinlet_flag $arg
+                }
                 default {
-                    proc ::${classname}_${id} {self args} \
-                        "global _; [expand_macros $arg]"
+                    proc ::${classname}_${id} {self args} [concat "global _;" [regsub -all @(\\\$?\[\\w\\?\]+) $arg _(\$self:\\1)]]
                 }
             }
         }
 
         proc ::$classname {self args} "
+            if \$::verbose {::pd::post \[info level 0\]}
             ::pd::create_iolets $classname \$self
             ::pd::call_classmethod $classname \$self constructor {*}\$args
             proc ::\$self {selector args} \"
+             if \\\$::verbose {::pd::post \\\[info level 0\\\]}
              ::pd::call_classmethod $classname \$self \\\$selector {*}\\\$args
             \"
             return \$self
         "
 
-        tclpd_class_new $classname 3
-    }
+        # TODO: c->c_gobj = (typeflag >= CLASS_GOBJ)
+        set flag [expr {
+            8 * ($noinlet_flag != 0) +
+            3 * ($patchable_flag != 0)
+        }]
 
-    proc expand_macros {body} {
-        # from poe.tcl by Mathieu Bouchard
-        return [regsub -all @(\\\$?\[\\w\\?\]+) $body _(\$self:\\1)]
+        tclpd_class_new $classname $flag
     }
 
     proc post {args} {
diff --git a/tcl_loader.cxx b/tcl_loader.cxx
index d4b45d1..fececed 100644
--- a/tcl_loader.cxx
+++ b/tcl_loader.cxx
@@ -7,18 +7,22 @@ extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname)
     char filename[MAXPDSTRING], dirbuf[MAXPDSTRING],
         *classname, *nameptr;
     int fd;
-    if (classname = strrchr(objectname, '/'))
+
+    if ((classname = strrchr(objectname, '/')) != NULL)
         classname++;
-    else classname = objectname;
-    if (sys_onloadlist(objectname))
-    {
+    else
+        classname = objectname;
+
+    if(sys_onloadlist(objectname)) {
         post("%s: already loaded", objectname);
         return (1);
     }
+
         /* try looking in the path for (objectname).(tcl) ... */
     if ((fd = canvas_open(canvas, objectname, ".tcl",
         dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0)
             goto gotone;
+
         /* next try (objectname)/(classname).(tcl) ... */
     strncpy(filename, objectname, MAXPDSTRING);
     filename[MAXPDSTRING-2] = 0;
@@ -28,7 +32,9 @@ extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname)
     if ((fd = canvas_open(canvas, filename, ".tcl",
         dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0)
             goto gotone;
-    return (0);
+
+    return 0;
+
 gotone:
     close(fd);
     class_set_extern_dir(gensym(dirbuf));
@@ -42,13 +48,28 @@ gotone:
     // load tcl:
     char b[MAXPDSTRING+10];
     snprintf(&b[0], MAXPDSTRING+10, "source %s", filename);
-    if (Tcl_Eval(tcl_for_pd,b) == TCL_OK)
-        post("Tcl_loader: loaded %s", b);
-    else
-        post("Tcl_loader: error trying to load %s", b);
+    int result = Tcl_Eval(tcl_for_pd, b);
+    if(result == TCL_OK) {
+        post("Tcl_loader: loaded %s", filename);
+    } else {
+        post("Tcl_loader: error trying to load %s", filename);
+        post("Error: %s", Tcl_GetStringResult(tcl_for_pd));
+        post("(see stderr for details)");
+
+        fprintf(stderr, "------------------- Tcl error: -------------------\n");
+        Tcl_Obj* dict = Tcl_GetReturnOptions(tcl_for_pd, result);
+        Tcl_Obj* errorInfo = NULL;
+        Tcl_Obj* errorInfoK = Tcl_NewStringObj("-errorinfo", -1);
+        Tcl_IncrRefCount(errorInfoK);
+        Tcl_DictObjGet(tcl_for_pd, dict, errorInfoK, &errorInfo);
+        Tcl_DecrRefCount(errorInfoK);
+        fprintf(stderr, "%s\n", Tcl_GetStringFromObj(errorInfo, 0));
+        fprintf(stderr, "--------------------------------------------------\n");
+        return 0;
+    }
 
     class_set_extern_dir(&s_);
     sys_putonloadlist(objectname);
-    return (1);
+    return 1;
 }