Version 9 of Self on a class-based OO system

Updated 2008-01-21 16:03:26 by MJ

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 it's 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

 oo::class create Object {
    superclass ::oo::class
    self.mixin Object
    method clone {name} {
        set o [my new [list superclass [self]]]
        ::oo::define $o self.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 [::oo::InfoClass [self] superclasses]
    }

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


See also tclOO, Self


Category Example Category Object Orientation