'''eos''': ensemble object system ([neo] is a much better name, [RS] was faster ...) This system is closely related to [neo], and inspired by [NEM]'s '[Using namespace ensemble without a namespace]'. This here is a second version: twice as fast in the methcall benchmark, backed by a namespace array. The original is at [eos original]. ---- '''eos''' is a slot based system. It provides ''cloning'', ''parts'' (or sub-objects) and ''delegation'' to any command. Delegation to own parts is correclty managed by ''cloning'', whether they are eos objects or objects from another system: all a part needs to have is * a [[$part $cloneCmd]] interface to produce an auto-named clone (or new object of the same class) * a [[$part $destroyCmd]] interface to destroy itself The subcommand names $cloneCmd and $destroyCmd are arbitrary (see example below). '''Cloning of parts still buggy ...''' ''To be continued ...'' namespace eval eos { variable nobjs 0 namespace export * # ::eos:: Create a new object: it is a command in this namespace, defined # as an ensemble on this namespace. proc {} args { if {[set len [llength $args]] > 1} { set cmd [lindex [info level 1] 0] return -code error "wrong # args: should be \"$cmd ?objname?\"" } variable nobjs set rname ::eos::OBJ[incr nobjs] set var ::eos::OVAR$nobjs array set $var [list *var $var *parts {}] set initmap [list \ *var [list ::set ${var}(*var)]\ *parts [list ::set ${var}(*parts)]\ ] namespace ensemble create \ -command $rname \ -map $initmap \ -unknown ::eos::unknown\ -prefixes 0 trace add command $rname delete "::unset $var;\#" if {$len == 1} { # a name was given - we'll build an alias set name [lindex $args 0] if {[string range $name 0 1] ne "::"} { set ns [uplevel 1 [list namespace current]] if {![llength $ns]} {set ns ::} set name $ns$name } interp alias {} $name {} $rname trace add command $rname delete "rename $name {};\#" trace add command $name delete "rename $rname {};\#" } return $rname } # The proc unknown defines the default slots, ie, the "class" of the # object. It processes all not-found instances, as it is the -unknown # option in the ensemble as set above. # A new "class" just requires defining a new unknown processor, and setting # it as the -unknown processor in the ensemble. proc unknown {obj cmd args} {list ::eos::*$cmd $obj} # # Define the default functions for the "class": by convention, the names # start with '*'. These are found by the utility function "unknown" above # interp alias {} ::eos::*config {} namespace ensemble configure proc *slot {self slot args} { set map [namespace ensemble configure $self -map] if {[llength $args]} { dict set map $slot $args } else { set map [dict remove $map $slot] } namespace ensemble configure $self -map $map } proc *method {self name params body {ns ::}} { set params [linsert $params 0 self] *slot $self $name ::apply [list $params $body $ns] $self } proc *value {self slot args} { if {[llength $args]} { *slot $self $slot ::set [$self *var]($slot) return [$self $slot [lindex $args 0]] } *slot $self $slot unset -nocomplain [$self *var]($slot) } proc *delete {self} { uplevel 1 [rename $self {}] } proc *destroyPart {self name} { set curr [$self *parts] if {[dict exists $curr $name]} { # destroy the old object lassign [dict get $curr $name] part cloneCmd destroyCmd trace remove command $self delete "$part $destroyCmd;\#" $part $destroyOld *slot $self $name } } proc *part {self name part cloneCmd destroyCmd {cloning 0}} { set curr [$self *parts] if {(!$cloning) && [dict exists $curr $name]} { *destroyPart $self $name $cloning } dict set [$self *var](*parts) $name [list $part $cloneCmd $destroyCmd] $self value $name $part trace add command $self delete "$part $destroyCmd;\#" } proc *delegate {source method target args} { set target [uplevel 1 [list namespace which -command $target]] *slot $source $method $target {expand}$args } proc *clone {self args} { # Assumes that $self only appears at the end (as in methods) if {[llength $args] > 1} { return -code error "wrong # args: should be \"$self clone ?cloneName?\"" } set new [uplevel 1 [list ::eos:: {expand}$args]] set selfvar [$self *var] set newvar [$new *var] array set $newvar [array get $selfvar] set conf [*config $self] dict unset conf -namespace set pat ${selfvar}\(* set selfend [expr {[string length $selfvar] -1}] set map [dict get $conf -map] dict for {slot meth} $map { set last [lindex $meth end] if {$last eq $self} { # update methods dict set map $slot [lreplace $meth end end $new] } elseif {$last eq $selfvar} { dict set map $slot [lreplace $meth end end $newvar] } elseif {[string match $pat $last]} { # update elements set mod [string replace $last 0 $selfend $newvar] dict set map $slot [lreplace $meth end end $mod] } } dict for {name partSpec} [$new *parts] { # update parts and delegations to them lassign $partSpec part cloneCmd destroyCmd set newPart [$part $cloneCmd] *part $new $name $newPart $cloneCmd $destroyCmd 1 dict for {slot meth} $map { set cmd [lindex $meth 0] if {$cmd eq $part} { dict set map $slot [lreplace $meth 0 0 $newPart] } } } dict set conf -map $map *config $new {expand}$conf $new *var $newvar return $new } } ---- This thing is ''very fast'': running the methcall benchmarks (see [Comparing Performance of Tcl OO extensions]) I get xotcl: 2.47user 0.01system 0:02.63elapsed 94%CPU stooop: 4.81user 0.01system 0:04.93elapsed 97%CPU eos0: 4.44user 0.00system 0:04.54elapsed 97%CPU eos: 2.06user 0.00system 0:02.16elapsed 95%CPU Note that is slughtly unfair: both [XOTcl] and [stooop] are dispatching via inheritance, '''eos''' is cloning. The code running in eos is source eos.tcl ::eos:: Toggle Toggle method activate {} {$self state [expr {![$self state]}]; return $self} Toggle value state 1 Toggle clone NthToggle NthToggle value max 3 NthToggle value counter 0 NthToggle method activate {} { $self counter [expr {[$self counter]+1}] if {[$self counter]>=[$self max]} { $self state [expr {![$self state]}] } return $self } proc main {n} { set val 1 set toggle [Toggle clone] for {set i 0} {$i<$n} {incr i} { set val [[$toggle activate] state] } if {$val} {puts true} else {puts false} $toggle delete set val 1 set ntoggle [NthToggle clone] for {set i 0} {$i<$n} {incr i} { set val [[$ntoggle activate] state] } if {$val} {puts true} else {puts false} $ntoggle delete } main [expr {$argc==1?[lindex $argv 0]:1}] ---- [Category Object Orientation]