? 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 ObjectsWho 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] valueThe 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
