[SS]: An interesting object oriented programming language, basic ideas comes from [SmallTalk] but SELF is
more flexible and powerful, and probably even more ''pure''.

SELF was used as test-bed for new ideas about compilation and virtual machines of
very high level programming languages. More info at [http://research.sun.com/self/language.html]
and [http://www.objs.com/x3h7/self.htm].

It should be possible to build an object-system for TCL that uses ideas from SELF, maybe
it was already implemented. Please if you know more, or have some code to show, write it here.

[RS] wrote [On things], which might interest you.

[SS] - great! it is pretty similar to SELF, I like the design [RS] used to add it to TCL.

[Artur Trzewik] - Some of SELF ideas are also included in [XOTcl], that are mixins.
Also in XOTcl the object has relative more importance than class. 
Classes are also objects and the relationship between objects and classes is
dynamic.
Self is prototype-based OO language but some of programing technigues one can good
simulated with XOTcl mixins and filters.
The manier how to program with SELF, is also implemented in [XOTclIDE].
That is interatively extent or change runing, "living" system. The same way
Smalltalker are programming.

[SS]: I see a fundamental difference between [SELF] and [XOTcl] btw: [SELF] is simple, there is
even no difference between a method and instance variable, everything is a slot, and there are
many other semplifications like no classes at all. On the exact contrary [XOTcl] has a lot
of concepts, so I think the essence is very different, while of course with every kind of
OO-related feature you can fake the coding way of prototype based systems, class based systems
and so on.
----
[MJ] -- Basic implementation of a self like OO system in plain Tcl. Supports '''super''', '''self''' and '''slot''' in slot bodies. Furthermore it allows object aggregates with '''addChild''' so that the children will be cleaned up when the object containing the children is destroyed. If a slot cannot be found, the unknown slot is called on the object receiving the message.

 # parents* for method dispatch
 # children* for aggregated objects

 proc Object {args} {
    set self [lindex [info level 0] 0]  
    set slot [lindex $args 0]
    set obj $self
    
    if {[info exists ::${self}($slot)]} {
	return [apply [set ::${self}($slot)] {expand}[lrange $args 1 end]]
    }
    set ancestors [$self parents*]
    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}[::$obj parents*]]
 	if {[info exists ::${obj}($slot)]} {
 	    return [apply [set ::${obj}($slot)] {expand}[lrange $args 1 end]]
 	}
    }
    $self unknown {expand}$args
 }

 set _nr 0

 proc self {args} {
    set self [uplevel 2 {set self}]
    if {[llength $args]==0} {
	return $self
    } else {
	return [uplevel 1 [list $self {expand}$args]]
    }
 }

 proc slot {} {
    uplevel 2 {set slot}
 }

 proc super {args} {
    set currObj [uplevel 2 {set obj}]
    set slot [uplevel 2 {set slot}]
    
    set tmp [Object clone]
    $tmp valueSlot parents* [$currObj parents*]
     set err [catch {$tmp $slot {expand}$args} res]
    $tmp destroy
     if {$err} {
	 error $res
     } else {
	 return $res
     }
 }

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

 Object slot valueSlot {name value} {
    [self] slot $name {args} [list if {[llength $args] == 0} [list return $value] else {[self] valueSlot [slot] [lindex $args 0]}]
    return $value
 }

 Object valueSlot parents* {}
 Object valueSlot children* {}
  
 Object slot clone {{new {}}} {
    if {$new eq {}} {
	set new _o[incr ::_nr]
    }
    # we need the parent slot before we can do any method dispatch
    set ::[set new](parents*) [list {} [list return [self]]]
    set ::[set new](children*) [list {} {return}]
    proc $new args [info body [self]]
    return $new
 }

 Object slot destroy {} {
    foreach child [self children*] {$child destroy}
    unset ::[self]
    rename ::[self] {}
 }
 
 Object slot slots {} {
    return [lsort [array names ::[self]]]
 }

 Object slot addParent {parent} {
    set parents [list $parent {expand}[self parents*]]
    self valueSlot parents* $parents
 }

 Object slot print {} {
    puts "Object: [self]\n parents: [self parents*]\n slots: [self slots]\n children [self children*]"
 }

 Object slot addChild {slot child} {
    self valueSlot $slot $child
    set children [self children*]
    lappend children $child
    self valueSlot children* $children
 }

 Object slot unknown {args} {
    error "slot \"[lindex $args 0]\" not defined for [self]"
 } 

 package provide self 0.1
'''examples'''

 source ./self.tcl

 Object clone Point

 Point slot create {x y} {
    set obj [self clone]
    $obj valueSlot x $x 
    $obj valueSlot y $y
    return $obj
 }

 Object clone Line

 Line slot create {p1 p2} {
    set obj [self clone]
    $obj addChild p1 $p1 
    $obj addChild p2 $p2
    return $obj
 }

 Line slot length {} {
    set dx [expr {[[self p1] x] - [[self p2] x]}] 
    set dy [expr {[[self p1] y] - [[self p2] y]}]
    return [expr {sqrt($dx*$dx + $dy*$dy)}]
 }

 set l [Line create [Point create 0 0] [Point create 1 1]]

 $l print

 puts "Length: [$l length]"
 parray $l

 $l destroy


----
[[[Category Language]|[Category Object Orientation]]]