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 testMJ -- Similar functionality using arrays {expand} and apply:
# TODO: add $super, tricky
# NOTE: if you clone Object and add the parents of an object to parent*
# you essentially have $super of the object
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]