From f3e255ddca6468b6adea0f10f30540c37cdde9ad Mon Sep 17 00:00:00 2001
From: "N.N." <federico__@users.sourceforge.net>
Date: Tue, 18 Sep 2007 17:19:03 +0000
Subject: first commit for tclpd external

svn path=/trunk/externals/tclpd/; revision=8736
---
 pdlib.tcl | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 200 insertions(+)
 create mode 100644 pdlib.tcl

(limited to 'pdlib.tcl')

diff --git a/pdlib.tcl b/pdlib.tcl
new file mode 100644
index 0000000..3ac00cd
--- /dev/null
+++ b/pdlib.tcl
@@ -0,0 +1,200 @@
+# TCL objectized library for PD api
+# by Federico Ferri <mescalinum@gmail.com> - 2007
+
+package provide pdlib 0.1
+
+package require Tcl 8.5
+
+set verbose 0
+
+namespace eval ::pd {
+
+    proc add_inlet {self sel} {
+        if $::verbose {post [info level 0]}
+        variable _
+        switch -- $sel {
+            float {
+                set ptr [new_t_float]
+                lappend _($self:p_inlet) $ptr
+                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]
+            }
+            default {
+                post "inlet creation error: unsupported selector: $sel"
+                return {}
+            }
+        }
+        return [lindex $_($self:x_inlet) end]
+    }
+
+    proc inlet {self n} {
+        if {$::verbose} {post [info level 0]}
+        if {$n <= 0} {return {}}
+        if {![info exists _($self:p_inlet)] ||
+            $n >= [llength $_($self:p_inlet)]} {
+            return -code error "pdlib: error: no such inlet: $n"
+        }
+        variable _
+        return [[lindex $_($self:p_inlet) [expr $n-1]] value]
+    }
+
+    proc add_outlet {self sel} {
+        if $::verbose {post [info level 0]}
+        variable _
+        switch -- $sel {
+            float {
+                lappend _($self:x_outlet) \
+                    [outlet_new [tclpd_get_object $self] [gensym "float"]]
+            }
+            symbol {
+                lappend _($self:x_outlet) \
+                    [outlet_new [tclpd_get_object $self] [gensym "symbol"]]
+            }
+            list {
+                lappend _($self:x_outlet) \
+                    [outlet_new [tclpd_get_object $self] [gensym "list"]]
+            }
+            default {
+                return -code error \
+                "pdlib: outlet creation error: unsupported selector: $sel"
+            }
+        }
+        return [lindex $_($self:x_outlet) end]
+    }
+
+    proc outlet {self n sel args} {
+        if $::verbose {post [info level 0]}
+        variable _
+        set outlet [lindex $_($self:x_outlet) $n]
+        switch -- $sel {
+            float {
+                set v [lindex $args 0]
+                outlet_float $outlet $v
+            }
+            symbol {
+                set v [lindex $args 0]
+                outlet_symbol $outlet $v
+            }
+            list {
+                set v [lindex $args 0]
+                set sz [llength $v]
+                set aa [new_atom_array $sz]
+                for {set i 0} {$i < $sz} {incr i} {
+                    set_atom_array $aa $i [lindex $v $i]
+                }
+                outlet_list $outlet [gensym "list"] $sz $aa
+                delete_atom_array $aa $sz
+            }
+            bang {
+                outlet_bang $outlet
+            }
+            default {
+                return -code error "pdlib: outlet: unknown selector: $sel"
+            }
+        }
+    }
+
+    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_outlet) {}
+        for {set i 0} {$i < [llength $class_db($cn:d_inlet)]} {incr i} {
+            add_inlet $self [lindex $class_db($cn:d_inlet) $i]
+        }
+        for {set i 0} {$i < [llength $class_db($cn:d_outlet)]} {incr i} {
+            add_outlet $self [lindex $class_db($cn:d_outlet) $i]
+        }
+    }
+
+    proc call_classmethod {classname self sel args} {
+        if $::verbose {post [info level 0]}
+        set m "${classname}_${sel}"
+        if {[llength [info commands "::$m"]] > 0} {
+            return [$m $self {*}$args]
+        }
+    }
+
+    proc class {classname def} {
+        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 {}]
+        foreach {id arg} $def2 {
+            switch -- $id {
+                inlet {
+                    lappend class_db($classname:d_inlet) $arg
+                }
+                outlet {
+                    lappend class_db($classname:d_outlet) $arg
+                }
+                default {
+                    proc ::${classname}_${id} {self args} \
+                        "global _; [expand_macros $arg]"
+                }
+            }
+        }
+
+        proc ::$classname {self args} "
+            ::pd::create_iolets $classname \$self
+            ::pd::call_classmethod $classname \$self constructor {*}\$args
+            proc ::\$self {selector args} \"
+             ::pd::call_classmethod $classname \$self \\\$selector {*}\\\$args
+            \"
+            return \$self
+        "
+
+        tclpd_class_new $classname 3
+    }
+
+    proc expand_macros {body} {
+        # from poe.tcl by Mathieu Bouchard
+        return [regsub -all @(\\\$?\[\\w\\?\]+) $body _(\$self:\\1)]
+    }
+
+    proc post {args} {
+        poststring2 [concat {*}$args]
+    }
+
+    proc assert= {a b} {
+        if {$a != $b} {
+            post "ASSERTION FAILED: \"$a\" == \"$b\""
+            return 0
+        }
+        return 1
+    }
+
+    proc args {} {
+        return [uplevel 1 "llength \$args"]
+    }
+
+    proc arg_float {n} {
+        set v [uplevel 1 "lindex \$args $n"]
+        foreach {selector value} $v {break}
+        assert= $selector "float"
+        return $value
+    }
+
+    proc arg_int {n} {
+        set v [uplevel 1 "lindex \$args $n"]
+        foreach {selector value} $v {break}
+        assert= $selector "float"
+        return [expr {int($value)}]
+    }
+
+    proc arg_symbol {n} {
+        set v [uplevel 1 "lindex \$args $n"]
+        foreach {selector value} $v {break}
+        assert= $selector "symbol"
+        return $value
+    }
+
+}
+
-- 
cgit v1.2.1