'''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 {expand}$oldvars {expand}$vars self $name] interp alias {} $name {} ::apply [list {selfns cmd args} {$cmd $selfns {expand}$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 ---- [Category Object Orientation]