UFO (yet another pure tcl OOS)

MS

   ? Unidentified Flying Objects 
   ? Undocummented Flexible Objects 
   ? Unlikely to Fly Objects
   ? Uniquely Freaky Objects
   ? Ultra-Fast Objects
   ? Unterernährter Französichen Oberkellner
   ? Ungulates Frying Ova (thanks to dkf)
   ! Unexpectedly Familiar Objects

Who cares anyway?

DKF - Our department has a language called this already, where it stands for Unified Functions and Objects. It is designed to be easy to automatically parallelize...

MS - Sorry about the name collision! I'll fix it up.


 #!/usr/local/bin/tclsh
 #######################################################################
 # This is an (unfriendly but) "powerful" prototype-based object system. 
 # (Actually, the basis for such a system: more introspection capabilities
 #  are certainly required, a few traces here and there would improve it
 #  a lot, some error control wouldn't be bad ...
 #
 #   . fits in about 20 LOC
 #   . single command 'ufo' defined
 #   . provides for multiple inheritance (methods are imported, vars are copied)
 #   . an ufo is a standard tcl namespace; its procs and cmds and vars 
 #     are standard tcl too. They can be handled as usual.
 #   . children can override ANYTHING (methods, variables, ...)
 #   . ancestor variables are default values for newborn children
 #   . somewhat dynamic:
 #      - allows dynamic redefinition of "class methods" (i.e., changing 
 #        the proc in an ancestor changes it for all those in the lineage
 #        that have not redefined the method)
 #      - DOES NOT ALLOW dynamic addition of methods or variables to a class 
 #        (it does, but previously created children will not know about it)
 #      - there is NO dynamic linking of variables (as opposed to procs ...)
 #   . fastest possible proc dispatching in tcl 
 #            (I think, see http://www.purl.org/mini/tcl/1190.html) [Speed of different method dispatching methods]
 #   . rather slow on object creation; ufos are heavyweight.
 #
 #######################################################################
 #
 # USAGE NOTES: (see examples)
 #   * "ufo name {parent2 parent1} {var1 val1 var2 val2} {
 #          proc1 {@ args1} {body1}
 #          proc2 {@ args2} {body2}
 #          @INIT {@} {body_init}; # @INIT is a reserved name!
 #      }"
 #     defines a new ufo that 
 #      . inherits procs and vars from parent1 and parent2 (only those that 
 #           are not defined by parent 1!)
 #      . initializes var1 to val1 (maybe overriding some inherited defaults)
 #      . gets methods proc1 and proc2 (ditto)
 #      . executes @INIT right after all this, on creation only
 #
 #   * I use '@' for references to the currently executing object; C++/java/itcl
 #     use 'this', self/things/... use 'self': regsub to your favourite variant!
 #
 #   * The unfriendly parts (but see "sugar" at the bottom!):
 #       - ufo procs get as first argument THE FULLY QUALIFIED NAME OF THE UFO
 #       - in an ufo proc, you connect to the ufo's procs and variables through 
 #          their fully qualified names (prepend ${@}::!); if you are using 
 #          a variable more than once, you can connect through a global command
 #
 ###########################################################################
 #
 # THE SYSTEM
 #
 proc ufo {name parents vars procs} {
     set ns ${name}::
     set oldvars ""
     foreach parent $parents {
         set tmp ${parent}::*
         append toEval "namespace import -force $tmp\n"
         foreach var [info vars $tmp] {
             append oldvars "[namespace tail $var] [set $var] "
         }
     }
     foreach {procName argLst body} $procs {
         append toEval "proc $procName \{$argLst\} \{$body\}\n"
     }
     append toEval "eval variable $oldvars $vars; namespace export *; @INIT $name"
     namespace eval $name $toEval
 }
 ## That is it!
 ########################################################################
 #
 # EXAMPLES
 # 1. Create an ufo that switches state (0/1) every time it is activated; it 
 #    has a method to get its value
 ufo ::Toggle {} {state 0} {
     activate {@} {
         global ${@}::state
         set state [expr {! $state}]
     }
     value {@} {
         set ${@}::state
     }
     @INIT {@} {}
 } 

 # 2. Create an ufo that switches state (0/1) every Nth time it is activated; it 
 #    inherits from Toggle, overrides thje method 'activate'
 ufo ::NthToggle {::Toggle} {state 0 maxCounter 10} {
     activate {@} {
         global ${@}::counter
         if {![incr counter -1]} {
             global  ${@}::state
             set counter [set ${@}::maxCounter]
             return [set state [expr {! $state}]]
         } else {
            return [set ${@}::state]
        }
     }
     @INIT {@} {set ${@}::counter [expr {[set ${@}::maxCounter]+1}]}
 } 

 # The previous ufos can be used as objects ...
 puts [Toggle::activate ::Toggle]
 puts [NthToggle::activate ::NthToggle]

 # ... or as classe for new objects
 ufo 3Toggle ::NthToggle {state 1 maxCounter 3} {}
 puts [3Toggle::activate ::3Toggle]
 puts [namespace origin 3Toggle::value]

 ########################################################################
 #
 # SUGAR
 #
 # It *is* kind of boring to repeat the name at each call! If you do get 
 # bored, standard tcl has an answer ready for you:
 #
 proc 3Toggle {{method {-}} args} {
     if {$method == "-"} {
        set cmds [info command ::3Toggle::*]
        regsub -all {(^|\s)(::3Toggle::)(\S)} $cmds {\1\3} cmds
         error "3Toggle: which method?? Choose from: $cmds"
     }
     ::3Toggle::$method ::3Toggle
 }

 puts [3Toggle activate]
 puts [3Toggle]


 # Use of sugar will make you overweight - read, this is a much slower
 # method dispatch! Do not use it for very small methods that are called 
 # often; for most other purposes it is fine. This can be done very easily 
 # in @INIT for a given class, or even done automatically within 'ufo'
 # 
 #
 # NOTE: the use (or not) of sugar may break methods that use 'uplevel'
 #     or 'upvar', or otherwise get info from the call stack ...
 ########################################################################

GPS - Miguel, this seems rather complex, but I like it. :)


A differently sugared version can also receive multiple messages:

 proc 3Toggle msg {        
     namespace eval ::3Toggle [string map {@ ::3Toggle} $msg]
 }

3Toggle can now receive multiple messages, separated by either newline or ;

 3Toggle {activate @; activate @; activate @}

Tcl8.5 allows sugar that is not as expensive:

 proc ufo {name parents vars procs} {
     uplevel 1 [list proc $name {} {}]
     set name [uplevel 1 [list namespace which -command $name]]
     set ns ::ufo::[string trimleft $name :]
     namespace eval $ns [list namespace export *]
     set oldvars {}
     foreach parent $parents {
         set pref ::ufo::[string trimleft $parent :]::*
         namespace eval $ns [list namespace import -force $pref]
         foreach var [info vars $pref] {
             lappend oldvars [namespace tail $var] [set $var]
         }
    }
     foreach {procName argLst body} $procs { 
         namespace eval $ns [list proc $procName $argLst $body]
     }
     namespace eval $ns [list variable {*}$oldvars {*}$vars self $name]
     interp alias {} $name {} ::apply [list {selfns cmd args} {$cmd $selfns {*}$args} $ns] $ns
     trace add command $name delete "namespace delete $ns;\#"
     $name @INIT
 }

 ## That is it!
 ########################################################################
 #
 # EXAMPLES
 # 1. Create an ufo that switches state (0/1) every time it is activated; it
 #    has a method to get its value
  ufo ::Toggle {} {state 1} {
      activate {selfns} {
          namespace upvar $selfns self self state state
          set state [expr {! $state}]
          return $self
      }
      value {selfns} {
          namespace upvar $selfns state state
          return $state
      }
      @INIT {selfns} {}
  }

 ufo ::NthToggle {::Toggle} {state 1 maxCounter 3} {
     activate {selfns} {
         namespace upvar $selfns self self counter counter
         if {[incr counter -1]} {
             return $self
         }
         namespace upvar $selfns state state maxCounter maxCounter
         set counter $maxCounter
         set state [expr {! $state}]
         return $self
     }
     @INIT {selfns} {
         namespace upvar $selfns self self counter counter maxCounter maxCounter
         set counter [expr {$maxCounter+1}]
     }
 }

 # Example usage
 [Toggle activate] value

The dispatch speed is worse, but still good:

 xotcl:   1.11user 0.00system 0:01.23elapsed 91%CPU 
 stooop:  2.95user 0.01system 0:03.08elapsed 96%CPU 
 eos0:    2.67user 0.00system 0:02.78elapsed 96%CPU 
 eos:     1.13user 0.00system 0:01.23elapsed 91%CPU 
 ufo:     0.63user 0.00system 0:00.74elapsed 85%CPU 
 ufo2:    1.03user 0.00system 0:01.13elapsed 90%CPU