See  http://people.fishpool.fi/~setok/proj/Selfish/ for preliminary implementation.

[MJ] -- Really nice work after playing with it a bit, it really shows the power and ease of prototype based OO. However a [[super]] call is missing. I had a look at implementing it with my similar code below, but the tricky part is that super should be called in the context of the object that has the slot. I haven't found a way to do this yet.

----
[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]:

 # TODO: add $super, tricky

 set Object(parent*) {{self} {return}}

 set Object(slot) {
    {self name args body} {
	set ::${self}($name) [list [list self {expand}$args] $body]
	return $name
    }
 }

 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"
 }


 Object slot clone new { 
    set ::${new}(parent*) [list {self} "return $self"]
    proc $new args [info body $self]
 }

 Object slot valueSlot {name value} {
    $self slot $name {} [list return $value]
 }

 Object slot destroy {} {
    unset ::$self
    rename ::$self {}
 }

 Object slot slots {} {
    return [array names ::$self]
 }

'''example'''

 Object clone Point

 # class like behaviour
 Point slot create {name x y} {
   $self clone $name
   $name valueSlot x $x
   $name valueSlot y $y
   return $name
 }

 Object clone Line
 Line slot xlength {} {
   expr {[[$self p2] x] - [[$self p1] x]}  
 }

 Line clone l
 Point create p1 0 0
 Point create p2 1 1

 l valueSlot p1 p1
 l valueSlot p2 p2
 
 puts [l xlength]

----
[[
[Category Object Orientation] |
[Category Package]
]]