Version 4 of Self on a class-based OO system

Updated 2007-06-06 12:34:44 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)

 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]
       class create ::self::cl::$name [list superclass $parent]
       oo::define ::self::cl::$name destructor {
         [self class] destroy
       }
       namespace eval :: [list ::self::cl::$name create $name]
     }
   }
 }

 class create ::self::cl::Object {
   method clone name {
     ::self::_::create_prototype $name [oo::InfoObject class [self]]    t]
   }

   method slot {name arg {body {}}} {
     if {$body eq {}} {
       ::oo::define [oo::InfoObject class [self]] method $name {} [list return $arg]
       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 $arg $body
     }
   }

   method slots {} {
     oo::InfoClass methods [oo::InfoObject class [self]]
   }

   method parents* {{new {}}} {
     oo::InfoClass mixins [oo::InfoObject class [self]]
   }
 }


 ::self::cl::Object create ::self::Object

 package provide self 0.6

 puts "#### Examples ####"
 namespace import ::self::Object

 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 cannot be called for now.
 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
 }

 # clone a Point
 Point clone p1

 # to_s will fail because the x and y slots in Point are called
 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]

 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]"

See also tclOO, Self


Category Example Category Object Orientation