Updated 2013-01-01 00:19:30 by RLE

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 {*}$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