[SS]: An interesting object-oriented programming language; basic ideas come 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 programing technigues one can be
well-simulated with XOTcl mixins and filters.
The manner of how to program with SELF is also implemented in [XOTclIDE].
That is interatively extent or change running, "living" system. The same way
Smalltalkers program.

[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 simplifications 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.

[KBK] 2006-10-12: One of the earliest OO systems for TCL, [BOS], was consciously modelled after [Self].
Developed by Sean Levy, then of CMU, it had several other interesting ideas.  A description can be
found at http://www.ndim.edrc.cmu.edu/papers/bos.pdf ; the paper also discusses Sean's reasons
for abandoning Tcl in the implementation.  The original Tcl implementation is at 
ftp://ftp.procplace.com/pub/tcl/sorted/packages-7.6/devel/bos-1.31.tar.gz .
----
[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.

[MJ] -- The Tcl implementation below has problems when calls to next or self are chained. The C extension at [SELF extension] doesn't have these problems. 

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

----
[MJ] - Version above has bugs when handling self and super. Next version should handle self correctly.

 # parents* for method dispatch

 namespace eval self {
    set Object(parents*) {data {}}
    set Object(slot) {method 
	{
	    {name args} {
		# value slot
		if {[llength $args]==1} {
		    set value [lindex $args 0]
		    set ::self::[self]($name) [list data $value]
		    return $name
		} elseif {[llength $args]==2} {
		    # method slot
		    set arguments [lindex $args 0]
		    set body [lindex $args 1]
		    set ::self::[self]($name) [list method [list $arguments $body]]
		    return $name
		} else {
		    error "wrong number of args: use slot name value/args ?body?"
		}
	    }
	}    
    }
 }

 proc ::self::selfcmd {self args} {
    if {$args eq ""} {
	return $self
    }
    $self {*}$args
 }

 proc Object {args} {
    set self [lindex [info level 0] 0]  
    set slot [lindex $args 0]
    set old_self [interp alias {} self]
    interp alias {} self {} ::self::selfcmd $self

    set slot_value {}
    if {[llength $args]==0} {return $self}
    
    if {[info exists ::self::${self}($slot)]} {
	set slot_value [set ::self::${self}($slot)]
    } else {
	set ancestors [$self parents*]
	set visited {}
	
	while {true} {
	    set obj [lindex $ancestors 0]
	    if {[llength $obj]==0} {
		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
	 
	    catch {set ancestors [list {*}[lrange $ancestors 1 end] {*}[$obj parents*]]}
	   
	    if {[info exists ::self::${obj}($slot)]} {
		set slot_value [set ::self::${obj}($slot)]
	    }
	}
    }
    if {$slot_value ne  {}} {
	switch [lindex $slot_value 0] {
	    method { 
		set res [apply [lindex $slot_value 1] {*}[lrange $args 1 end]]

	    }
	    data {
		if {[llength $args]==1} {
		    set res [lindex $slot_value end]
		} else {
		    self slot [list data [lindex $args 2]]
		    set res [self]
		}
		
	    }
	}
	interp alias {} self {} {*}$old_self
	return $res
    } else {
	interp alias {} self {} {*}$old_self
	error "object '$self' can't handle slot '$slot'"
    }
 }

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

 set ::self::Object(slot) [list method [list {name args} {
    if {[llength $args]==2} { 
	set ::self::[self]($name) [list method $args]
    } else {
	set ::self::[self]($name) [list data [lindex $args 0]]
    }
    return [self]
 }]]

 Object slot destroy {} {
    unset ::self::[self]
    rename [self] {}
 }
 
 Object slot slots {} {
    return [lsort [array names ::self::[self]]]
 }

 package provide self 0.2

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