Self on a class-based OO system

MJ - Will add some documentation here. One disadvantage of dragging around a class for every object, is that it is more expensive to clone objects (a class also will be created). Also a provision to send a message to receiver but start method lookup on its parents is missing (super in self).

package require TclOO
namespace import ::oo::*
 
namespace eval self {
   namespace export Object
   namespace eval _ {
     proc create_prototype {name parent} {
       # doesn't work: 
       # class create ::self::cl::$name [list mixin $parent]
       # I really want to use mixins here. Now a destroy of a parent destroys all its children
       class create ::self::cl::$name [list superclass $parent]
       ::oo::define ::self::cl::$name destructor {
         [self class] destroy
       }
       set res [namespace eval :: [list ::self::cl::$name create $name]]
       $res parents*: [string map [list ::self::cl {}] $parent]
       ::oo::define ::self::cl::$name method parents* {} {
         set res {}
         foreach class  [oo::InfoClass superclasses [oo::InfoObject class [self]] ] {
           if {$class eq "::oo::object"} {return {}}
           lappend res [string map [list ::self::cl {}] $class]
         }
         return [lsort $res] 
       }
 
       ::oo::define ::self::cl::$name method parents*: {args} {
         set classnames {}
         foreach parent $args {
           lappend classnames ::self::cl::$parent 
         }
         ::oo::define  [oo::InfoObject class [self]] superclass {*}$classnames 
       }
 
       return $res
     }
   }
}
 
class create ::self::cl::Object {
   method clone name {
     ::self::_::create_prototype $name [oo::InfoObject class [self]]        
   }
 
   method destroy {} {
     foreach subclass [::oo::InfoClass subclasses [::oo::InfoObject class [self]]] {
       set current [oo::InfoClass superclasses $subclass]
       set new [lsearch -inline -all -not $current [::oo::InfoObject class [self]]]
       # prevent orphans
       if {$new eq {}} {
         set new ::self::cl::Object
       }
       ::oo::define $subclass superclass $new
     }
     next
   }
 
   method slot {name args} {
     if {[llength $args]==1} {
       ::oo::define [oo::InfoObject class [self]] method $name {} [list return [lindex $args 0]]
       set body  "\[self\] slot [list $name] \$val"
       ::oo::define [oo::InfoObject class [self]] method $name: {val} $body
     } else {
       ::oo::define [oo::InfoObject class [self]] method $name [lindex $args 0] [lindex $args 1]
     }
   }
 
   method parents* {} {
     set res {}
     foreach class  [oo::InfoClass superclasses [oo::InfoObject class [self]] ] {
       if {$class eq "::oo::object"} {return {}}
       lappend res [string map [list ::self::cl {}] $class]
     }
     return [lsort $res] 
   }
 
   method parents*: {args} {
     set classnames {}
     foreach parent $args {
       lappend classnames ::self::cl::$parent 
     }
     ::oo::define  [oo::InfoObject class [self]] superclass {*}$classnames 
   }
 
   method slots {} {
     oo::InfoClass methods [oo::InfoObject class [self]]
   }
 
}
 
 
::self::cl::Object create ::self::Object
namespace import ::self::Object
 
package provide self 0.6
 
if {$argv0 eq [info script]} {
 
 puts "#### Examples ####"
 
 Object clone test
 
 test slot test {} {puts "test slot in [self]"}
 test slot nop {} {#}
 
 test test
 puts "test slots: [test slots]"
 
 test destroy
 
 puts "#### Point demo ####"
 
 
 Object clone Point
 
 # add a to_s slot to display information of the object
 Object slot to_s {} {
   return "[self]"
 }
 
 
 # add x and y slots for the point, notice that these slots give an error when called.
 Point slot x {args} {error "abstract slot, override in clone"}
 Point slot y {args} {error "abstract slot, override in clone"}
 
 # extend default behavior from parent (Object)
 Point slot to_s {} {
   return "id: [next] ([my x],[my y])"
   # Here next will search for a slot named to_s in the parents of the implementor of the current method (Point)
   # finding the Object slot to_s and the execute it in the context of the receiver (which will be a clone of Point)
 }
 
 # define a point factory
 Point slot create {name x y} {
   my clone $name
   $name slot x $x
   $name slot y $y
   return $name
 }
 
 # clone a Point
 Point clone p1
 
 # to_s will fail because the x and y slots in Point are called which were defined as abstract
 catch {p1 to_s} err
 puts $err
 
 p1 destroy
 
 # use the Point factory which will define x and y slots
 Point create p1 0 0
 
 # to_s will now work
 puts [p1 to_s]
 
 p1 x: 12
 puts [p1 to_s]
 
 # some debugging aids
 Point clone DPoint
 DPoint slot to_s {} {
   puts "calling to_s"
   next
 }
 
 # make p1 use the debugging version of Point
 p1 parents* DPoint
 puts [p1 to_s]
 
 puts "parents* of p1: [p1 parents*]"
 puts "parents* of Point: [Point parents*]"
 puts "parents* of Object: [Object parents*]"
 
 puts "##### Benchmarks #####"
 puts "clone/destroy: [time {Object clone a ; a destroy} 1000]"
 Object clone test0
 test0 slot nop {} {#}
 
 for {set i 0} {$i < 999} {} {
   test$i clone test[incr i]
 }
 
 puts "nested slot dispatch 999 deep: [time {test999 nop} 1000]"
}

MJ - It seems that with clever use of mixins the same can be achieved with much less effort (first demonstrated by dkf on the Tcl chat)

package require TclOO

namespace eval self {
  namespace export Object
  oo::class create Object {
    superclass ::oo::class
    self mixin ::self::Object
    method clone {name} {
        set o [my new [list superclass [self]]]
        ::oo::objdefine $o mixin $o
        uplevel 1 [list rename $o $name]\;[list namespace which $name]
    }
    method slot {name arguments body} {
        oo::define [self] method $name $arguments $body
    }
    method parents {} {
        return [info class superclasses [self]]
    }

    method parents! {parents} {
        ::oo::define [self] superclass {*}$parents 
    }
    unexport create new
    self unexport create new
  }
}

DKF: It's based on an example in the TclOO test suite, and that in turn is based on something I saw someone do with XOTcl.