See http://people.fishpool.fi/~setok/proj/Selfish/ for preliminary implementation.
MJ -- Is this a bug in slot lookup?
% set a [selfish::baseObject clone]
::selfish::0
% ::selfish::slot ::selfish::baseObject test {} {puts test}
foo
% $a test
SelfishError exception thrown: Could not find slot testMJ -- Similar functionality using arrays {expand} and apply:
set Object(parent*) {{self} {return}}
set Object(clone) {
{self new} {
set ::${new}(parent*) [list {self} "return $self"]
proc $new args [info body $self]
return;
}
}
set Object(slots) {
{self} {
return [array names ::$self]
}
}
set Object(slot) {
{self name args body} {
set ::${self}($name) [list [list self {expand}$args] $body]
return
}
}
set Object(valueSlot) {
{self name value} {
$self slot $name {} [list return $value]
return $value
}
}
proc Object {args} {
set self [lindex [info level 0] 0]
set slot [lindex $args 0]
# every object has the parent* slot
set parents [apply [set ::${self}(parent*)] $self]
if {$slot=="parent*" } {
return $parents
}
set ancestors $self
set visited {}
while {true} {
set obj [lindex $ancestors 0]
if {$obj eq ""} {break}
# keep a visited objects list to prevent circular lookups
if {[lsearch -exact $visited $obj]>-1} {
set ancestors [lrange $ancestors 1 end]
continue
}
lappend visited $obj
set ancestors [list {expand}[lrange $ancestors 1 end] {expand}[apply [set ::${obj}(parent*)] $self]]
if {[info exists ::${obj}($slot)]} {
return [apply [set ::${obj}($slot)] $self {expand}[lrange $args 1 end]]
}
}
error "slot \"$slot\" not defined for $self"
}