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