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
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 {*}$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:: {*}$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 {*}$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: 1.30user 0.01system 0:01.41elapsed 93%CPU snit: 1.14user 0.00system 0:01.25elapsed 92%CPU stooop: 3.58user 0.01system 0:03.69elapsed 97%CPU eos: 1.30user 0.00system 0:01.40elapsed 93%CPU eos1: 0.94user 0.00system 0:01.04elapsed 90%CPU ufo: 0.74user 0.00system 0:00.84elapsed 88%CPU(The previous version of this table was understating xotcl's speed: for some reason, the first test seems to run slower)Note that is slightly unfair: both XOTcl and stooop are dispatching via inheritance, eos is cloning.The code running in eos is (see below for eos1)
::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]}]
$self counter 0
}
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}]The dispatch is very fast, the access to the variables less so: the way it is programmed there, each access implies a proc call and an access to a FQ variable. It is possible to accelerate this, as illustrated by the following eos1 code in which a local array named {} is linked to the global array:
::eos:: Toggle
Toggle method activate {} {
upvar 0 [$self *var] {}
set (state) [expr {!$(state)}]
return $self
}
Toggle value state 1
Toggle clone NthToggle
NthToggle value max 3
NthToggle value counter 0
NthToggle method activate {} {
upvar 0 [$self *var] {} ;#(counter) counter
incr (counter)
if {$(counter)>=$(max)} {
set (state) [expr {!$(state)}]
set (counter) 0
}
return $self
}