proc foo {args} {uplevel thing:dispatch foo $args}The array holds the properties and the ways (methods) of the thing - all that is to know about the thing. The most important property is the is-a list that every thing has. This lists its superthings and is searched when retrieving a property or way.The lookup is not transitive, i.e. superthings of superthings are not searched. This is for safety: as hierarchies are not predefined, cycles can easily occur. With a one-pass is-a list, the lookup is guaranteed to terminate. You can have multi-level inheritance if you specify all super*things in the is-a list (OK, not exactly elegant).Setting properties or ways is always done in the specified thing itself (in contrast to Tcl's namespace resolution, see Dangers of creative writing).Ways are also in the same array. They are something like procs: they have a name, an arglist (args feature not yet supported) and a body. But using China Blue's procless lambda trick (see Lambda in Tcl), they act like pure lambdas: A list of arglist and body is the value of the (ticked) name and can be assigned to another. To distinguish ways from properties, their name gets a tick prefixed which is stripped off again when listed, so foo wayto bar {x {expr !$x}} == foo set 'bar {x {expr !$x}}Now here's the thing: proc thing {name args} {
if {$name=="-names"} {return [thing:names]}
if {[info commands $name]!=""} {error "can't make thing $name: exists"}
upvar 1 $name self
set self(is-a) {}
array set self $args
regsub @name {uplevel thing:dispatch @name $args} $name body
proc $name args $body
uplevel trace var $name u thing:unset
proc thing:names {} [concat [info body thing:names] $name]
set name
}Thing procs are removed when the whole thing (not just an array element) is unset: proc thing:unset {name el -} {
if {$el==""} {
rename $name ""
set names [info body thing:names]
set where [lsearch $names $name]
if {$where>0} {
proc thing:names {} [lreplace $names $where $where]
}
}
}The list of things is maintained in a proc body that is extended when a new thing is created, or purged when a thing is deleted: proc thing:names {} {list}All thing invocations (the built-ins set, get, unset, is-a, wayto and the ways - I added get as synonym for set, just for sugar) go through this dispatcher: proc thing:dispatch {name way args} {
upvar 1 $name self
switch -- $way {
get - set {
switch -- [llength $args] {
0 {
set res [array names self]
foreach i $self(is-a) {
ladd res [uplevel array names $i]
}
return $res
}
1 {
foreach i [concat $name $self(is-a)] {
if [llength [uplevel array names $i $args]] {
return [uplevel set [set i]($args)]
}
}
}
default {
array set self $args
return [lindex $args end]
}
}
}
unset {foreach i $args {unset self($i)}}
is-a {
if [llength $args] {lappend self(is-a) $args}
return $self(is-a)
}
wayto {
switch -- [llength $args] {
0 {
set res [list]
foreach i [concat $name $self(is-a)] {
foreach j [uplevel array names $i '*] {
regexp {^'(.+)} $j -> i2
ladd res $i2
}
}
return $res
}
1 {set self('$args)}
2 {
foreach {wayname waylambda} $args break
set self('$wayname) $waylambda
}
}
}
default {
foreach i [concat $name $self(is-a)] {
if [llength [uplevel array names $i '$way]] {
upvar 1 $i super
foreach {argl body} $super('$way) break
if [llength $argl] {
foreach $argl $args break ;# binding to locals
}
return [eval $body]
}
}
error "$way? Use one of: set, unset, is-a, [uplevel $name wayto]"
}
}
}Little helper for lappending if the list doesn't have it yet: proc ladd {_L list} {
upvar 1 $_L L
foreach i $list {
if {[lsearch $L $i]<0} {lappend L $i}
}
}That's it. Finally, my little test suite: ###################### Test code
set tests {
thing human legs 2
thing Socrates is-a {human philosopher}
human set mortal 1
Socrates is-a
Socrates set hair white
Socrates set hair
Socrates unset hair
Socrates set mortal
Socrates set
human wayto sing {text {subst $text,$text,lala}}
Socrates wayto sing {{text} {subst "$text, haha."}}
Socrates wayto sing
Socrates wayto
Socrates sing Lali
[thing Joe is-a human] sing hey
thing Plato
Plato wayto sing [Socrates wayto sing]
Plato sing kalimera
catch {Socrates help} res
set res
thing -names
}
foreach i [split $tests \n] {
puts "$i => [eval $i]"
}General trace handler: I am experimenting with the following handler that will be called on all accesses to a thing:
proc thing:trace {name el mode} {
if {$el=="" && $mode=="u"} {
rename $name ""
set names [info body thing:names]
set where [lsearch $names $name]
if {$where>0} {
proc thing:names {} [lreplace $names $where $where]
}
} else {
upvar 1 $name self
if [info exists self('$mode'$el)] {
foreach {argl body} $self('$mode'$el) break
if [llength $argl] {
foreach $argl $args break ;# binding to locals
}
return [uplevel $body]
}
}
}It includes the original unset trace for the whole array, but in addition checks whether a way for the operation and element exists, so the test suite can be extended to Socrates wayto w'legs {{} {puts "hey, I $name have $self(legs) legs"}}
Socrates wayto u'legs {{} {puts "hey, I $name need legs"}}
Socrates set legs 3
Socrates unset legsNo sugaring for the trace mode letter yet... which is activated by replacing the trace line in proc thing byuplevel trace var $name rwu thing:trace
