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 test
----
[MJ] -- 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 handled false
    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)]} {
	    set res [apply [set ::${obj}($slot)] $self {expand}[lrange $args 1 end]]
	    set handled true;
	    break
	}
    }
    if {$handled} {
	return $res
    } else {
	error "slot \"$slot\" not defined for $self"
    }
 }
----
[[
[Category Object Orientation] |
[Category Package]
]]