Itcl in XOTcl

GN This is an example how to implement a ITcl like language in XOTcl. Note that this is not a full implementation of itcl, but it is sufficient to run the tests from Tcl OO Bench. The only change necessary in the tests was to replace #auto by a counter based version. Note from the OO Bench results that the emulation of the ITcl like language is faster than ITcl.

 ###########################################################
 ## Small example to emulate a itcl-like language in XOTcl
 ##  -gustaf neumann            Jan. 2004
 ###########################################################
 namespace eval itcl {
   Class create class -superclass Class
   class instproc instvars {} {
     set vars [list]; set c [self]
     for {} {[string compare ::xotcl::Object $c]} {set c [$c info superclass]} {
       eval lappend vars [$c set __autovars]
     }
     return "\n\tmy instvar [lsort -unique $vars]"
   }
   class proc constructor {args} {
     if {[llength $args]==2} {
       foreach {arglist body} $args break
     } else { 
       foreach {arglist construct body} $args break
       set body $construct\n$body
     }
     my parameter [list {this [self]}]
     my proc constructor args {uplevel next $args}
     my instproc init $arglist [my instvars]\n$body
   }
   class proc method {name arglist body} {
     my proc $name args {uplevel next $args}
     my instproc $name $arglist [my instvars]\n$body
   }
   class proc inherit {class} {
     my superclass $class
   }
   class proc variable {arglist} {
     foreach v $arglist {my lappend __autovars $v}
   }
   class instproc init {classdef} {
     my set __autovars this
     namespace eval [self class] $classdef
     my class Class
   }
   proc delete {what name} {$name destroy}
 }

Below is the Object Instantiation Test, which is codewise a superset of the OO Method Calls. The code for the method invocation test is available at [L1 ].

 ###########################################################
 # Two Demo classes from oo-bench
 ###########################################################
 itcl::class Toggle {
   variable state
   constructor {start_state} {
     set state $start_state
   }
   method value {} {
     return $state
   }
   method activate {} {
     set state [expr {!$state}]
     return $this
   }
 }
 itcl::class NthToggle {
   inherit Toggle
   variable count_max
   variable counter
   constructor {start_state max_counter} {
     Toggle::constructor $start_state
   } {
     set count_max $max_counter
     set counter 0
   }
   method activate {} {
     if {[incr counter] >= $count_max} {
       Toggle::activate
       set counter 0
     }
     return $this
   }
 }
 proc main {n} {
   set toggle1 [Toggle \#auto 1]
   for {set i 0} {$i<5} {incr i} {
     $toggle1 activate
     if {[$toggle1 value]} {
       puts true
     } else {  puts false
     }
   }
   itcl::delete object $toggle1
   for {set i 0} {$i<$n} {incr i} {
     set toggle [Toggle toggle$i 1]
     itcl::delete object $toggle
   }
   puts {}
   set ntoggle1 [NthToggle \#auto 1 3]
   for {set i 0} {$i<8} {incr i} {
     $ntoggle1 activate
     if {[$ntoggle1 value]} {
       puts true
     } else {  
       puts false
     }
   }
   itcl::delete object $ntoggle1
   for {set i 0} {$i<$n} {incr i} {
     set ntoggle [NthToggle toggle$i 1 3]
     itcl::delete object $ntoggle
   }
 }
 main [expr {$argc==1?[lindex $argv 0]:1}]

Category XOTcl Code