[Richard Suchenwirth] - Things look good. In [On things], I have shown a minimal OO API for Tcl, inspired by Self. Here's the initial implementation. See [Doing things in namespaces] for an advanced version.

Similar to [Gadgets], a ''thing'' (which can be used like an object, or class... its untypedness fits Tcl pretty well) consists of an array in the caller's scope (may, but need not be global) and a proc, both of same name. The trivial one-liner proc is only needed so the thing can be called by name - it only redirects
 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 legs
No sugaring for the trace mode letter yet... which is activated by replacing the trace line in proc thing by
    uplevel trace var $name rwu thing:trace

----
[Arts and crafts of Tcl-Tk programming]