Update of /cvsroot/pure-data/pd/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22516
Modified Files: Tag: devel_0_39 desire.tk pkgIndex.tcl Added Files: Tag: devel_0_39 poe.tcl Removed Files: Tag: devel_0_39 objective.tcl Log Message: renaming objective.tcl to poe.tcl
--- NEW FILE: poe.tcl --- # $Id: poe.tcl,v 1.1.2.1 2006/11/16 23:30:25 matju Exp $ #----------------------------------------------------------------# # OBJECTIVE TCL # # Copyright (c) 2005 by Mathieu Bouchard # This software has no license yet # And is not covered by the license on the rest of PureData. # All Rights Reserved (for now)
#-----------------------------------------------------------------------------------# # OBJECT ORIENTED PROGRAMMING IN TCL (by Mathieu Bouchard) # (please distinguish between what this is and what dataflow is) # note, the toplevel class is called "thing".
package provide poe 0.1
if {$tcl_version < 8.5} {package require pre8.5} set nextid 0 set _(Class:_class) Class set _(Class:_super) {Thing}
proc proc* {name args body} { set argl {} foreach arg $args {set arg [lindex $arg 0]; lappend argl "$arg=$$arg"} proc $name $args "puts "[VTgreen]CALL TO PROC $name [join $argl " "][VTgrey]"; $body" }
#proc Class_def {self selector args body} { # global _; if {![info exists _($self:_class)]} {error "unknown class '$self'"} # proc ${self}_$selector "self $args" "global _; [regsub -all @([\w\?]+) $body _($self:\1)]" #} #proc def {class selector args body} {$class def $selector $args $body}
proc expand_macros {body} { return [regsub -all @(\$?[\w\?]+) $body _($self:\1)] }
proc def {self selector args body} { global _ __trace if {![info exists _($self:_class)]} {error "unknown class '$self'"} if {[info exists __trace($self:$selector)]} { proc* ${self}_$selector "self $args" "global _; [expand_macros $body]" } { proc ${self}_$selector "self $args" "global _; [expand_macros $body]" } #trace add execution ${self}_$selector enter dedebug }
proc class_new {self {super {Thing}}} { global _ set _($self:_class) Class set _($self:_super) $super set _($self:subclasses) {} foreach sup $super {lappend _($sup:subclasses) $self} proc ${self}_new {args} " global nextid _ set self [format o%07x $nextid] incr nextid set _($self:_class) $self eval [concat [list $self init] $args] return $self " proc ${self}_new_as {self args} " global _ if {[info exists _($self:_class)]} {error "object '\$self' already exists" } set _($self:_class) $self eval [concat [list $self init] $args] return $self " }
proc lookup_method {class selector methodsv ancestorsv} { global _ upvar $methodsv methods upvar $ancestorsv ancestors set name ${class}_$selector if {[llength [info procs $name]]} {lappend methods $name} lappend ancestors $class foreach super $_($class:_super) {lookup_method $super $selector methods ancestors} }
rename unknown unknown2 # TODO: remove duplicates in lookup # TODO: cache lookup for greater speed proc unknown {args} { global _ __ set self [lindex $args 0] if {[llength [array names _ $self:_class]] == 0} { return [uplevel 1 [linsert $args 0 unknown2]] } set methods {} set ancestors {} set selector [lindex $args 1] set class $_($self:_class) if {[info exists __($class:$selector)]} { set methods $__($class:$selector) } { lookup_method $_($self:_class) $selector methods ancestors set __($class:$selector) $methods } set i 0 if {![llength $methods]} { set ancestors [Class_ancestors $class] error "no such method '$selector' for object '$self'\nwith ancestors {$ancestors}" } eval [concat [list [lindex $methods $i] $self] [lrange $args 2 end]] }
proc super {args} { upvar 2 methods methods self self i oi set i [expr 1+$oi] if {[llength $methods] < $i} {error "no more supermethods"} eval [concat [list [lindex $methods $i] $self] $args] }
class_new Thing {} #set _(Thing:_super) {} def Thing init {} {} def Thing == {other} {return [expr ![string compare $self $other]]}
# virtual destructor def Thing delete {} {}
def Thing vars {} { set n [string length $self:] set ks [list] foreach k [array names _] { if {0==[string compare -length $n $self: $k]} {lappend ks [string range $k $n end]} } return $ks }
def Thing inspect {} { set t [list "#<$self: "] foreach k [lsort [$self vars]] {lappend t "$k=[list $@$k] "} lappend t ">" return [join $t ""] }
def Thing class {} {return $@_class}
class_new Class
# those return only the direct neighbours in the hierarchy def Class superclasses {} {return $@_super} def Class subclasses {} {return $@subclasses}
# those look recursively. def Class ancestors {} { #if {[info exists @ancestors]} {} set r [list $self] foreach super $@_super {eval [concat [list lappend r] [$super ancestors]]} return $r } def Class <= {class} {return [expr [lsearch [$self ancestors] $class]>=0]}
# those are static methods, and objective.tcl doesn't distinguish them yet. def Class new { args} {eval [concat [list ${self}_new ] $args]} def Class new_as {id args} {eval [concat [list ${self}_new_as $id] $args]}
#-----------------------------------------------------------------------------------#
proc VTgreen {} {return "\x1b[0;1;32m"} proc VTred {} {return "\x1b[0;1;31m"} proc VTyellow {} {return "\x1b[0;1;33m"} proc VTgrey {} {return "\x1b[0m"}
proc error_text {} { global errorInfo set e $errorInfo regsub -all " invoked from within\n" $e "" e regsub -all "\n \(" $e " (" e regsub -all {\n[^\n]*procedure "(::unknown|super)"[^\n]*\n} $e "\n" e regsub -all {\s*while executing\s*\n} $e "\n" e #regsub {\n$} $e "" e return $e } proc error_dump {} { global errorCode puts "[VTred]Exception:[VTgrey] errorCode=$errorCode; errorInfo=[error_text]" }
proc tracedef {class method {when enter}} { global __trace set __trace($class:$method) $when }
proc yell {var key args} { global _ $key puts "[VTyellow]HEY! at [info level -1] set $key [list $_($key)][VTgrey]" }
Index: desire.tk =================================================================== RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v retrieving revision 1.1.2.550 retrieving revision 1.1.2.551 diff -C2 -d -r1.1.2.550 -r1.1.2.551 *** desire.tk 16 Nov 2006 18:37:30 -0000 1.1.2.550 --- desire.tk 16 Nov 2006 23:30:24 -0000 1.1.2.551 *************** *** 38,42 **** $auto_path]
! package require objective package require bgerror #package require profiler --- 38,42 ---- $auto_path]
! package require poe package require bgerror #package require profiler
Index: pkgIndex.tcl =================================================================== RCS file: /cvsroot/pure-data/pd/src/Attic/pkgIndex.tcl,v retrieving revision 1.1.2.2 retrieving revision 1.1.2.3 diff -C2 -d -r1.1.2.2 -r1.1.2.3 *** pkgIndex.tcl 16 Sep 2006 01:20:26 -0000 1.1.2.2 --- pkgIndex.tcl 16 Nov 2006 23:30:25 -0000 1.1.2.3 *************** *** 9,13 **** # full path name of this file's directory.
! package ifneeded objective 0.0 [list source [file join $dir objective.tcl]] ! package ifneeded pre8.5 8.4 [list source [file join $dir pre8.5.tcl]] ! package ifneeded bgerror 8.4 [list source [file join $dir bgerror.tcl]] --- 9,13 ---- # full path name of this file's directory.
! package ifneeded poe 0.1 [list source [file join $dir poe.tcl]] ! package ifneeded pre8.5 8.4 [list source [file join $dir pre8.5.tcl]] ! package ifneeded bgerror 8.4 [list source [file join $dir bgerror.tcl]]
--- objective.tcl DELETED ---