Koen Van Damme -- This is an experiment in object-orientation. I wanted to find out the minimal number of classes required to pull an object system out of the ground. It turns out that you need only 2:
The whole system boots itself from only Object and Meta and their methods.
As usual in Tcl, we store an object's data in a global array. A class is a special object with special entries in this array. All the array contents can be changed dynamically, so any normal object can be turned into a class and vice versa.
Above I said that Meta inherits from Object. It would be better to say that Meta chains to Object. There is no inheritance; instead, objects chain to each other. When you invoke a method, the receiver first tries to find the method locally, and then simply passes it on to its chains one by one. When a class creates a new object, it makes itself the single chain target for the new object. But again, you can change this dynamically, so you can just set another chain target or even add multiple new targets.
Note that this is only an experiment, not a fully functional object system. E.g. it does not support constructors, destructors, object persistence etc. You could easily add those features if you wanted to.
Here is an example of how to use it:
class Animal {
# Use the normal 'set' and 'proc' to define class members.
set num_legs 4
proc walk {} {
puts "$this walking on all [$this get num_legs]s..."
}
}
class Cat : Animal {
set tail_size 5
proc sound {num_times {sound "Meow"}} {
for { set i 0 } { $i < $num_times } { incr i } {
puts "$sound!"
}
}
# Class-static variable: just prepend 'static'.
static set typical_names {felix fluffy lucky}
# Class-static method: just prepend 'static'.
static proc info {} {
puts "INFO: Cats are animals with 4 legs, a tail, and lots of hair."
}
}
### Use static members by calling the 'Cat' object, which happens to be a class.
### Note that 'Cat get' will be resolved to 'Object:get'. In other words,
### objects inherit their 'get' method from the top of the hierarchy by default.
Cat info
puts "Some typical names for cats are: [Cat get typical_names]."
### Printing a class: this shows the internals for the 'Animal' and 'Cat' class.
### The output should give you an idea of how the SPOT object model works.
Meta:print Animal
Meta:print Cat
### Create cat 'felix'.
Cat new felix
Meta:print felix
felix sound 3
felix walk
### Inject a new class into the chain,
### to change the "inheritance" of the 'walk' method dynamically.
class Silly_walker {
proc walk {} {
puts "$this doing a silly walk"
}
}
felix set class "Silly_walker"
puts "Felix now chains to: [felix get class]"
felix walk ; # This now produces a silly walk rather than the one from the Cat class.
### Inject a new class which re-implements the 'get' method, to block access to member variables.
class Blocked_getter {
proc get {var_name} {
return "$this has no access to $var_name"
}
}
puts "Getting 'num_legs': [felix get num_legs]"
Silly_walker set chain "Blocked_getter"
puts "Blocking 'num_legs': [felix get num_legs]"
### Clean up by deleting all arrays.
puts "Spot arrays: [info vars spot*]"
Meta:del felix
Meta del Cat
Meta del Animal
Meta del Silly_walker
Meta del Blocked_getter
Meta del Object
Meta del Meta ;# Yes, we can delete 'Meta' itself.
;# Note that the 'Meta:xxx' procs are
;# automatically removed too:
#Meta:message "This is impossible" ;# -> TCL ERROR
puts "Spot arrays at end: (should be empty) [info vars spot*]"Before we look at the code, I should explain the internal structure of the objects (i.e. the data members stored in their global arrays).
Every object has a 'class' member, containing a list of class objects that contain the object's methods. When making a call to the object, it first tries to find an object-specific method of that name, and otherwise it chains to its classes one by one. Each class will try to find the requested method locally, then pass it on to its chain targets recursively. If nobody knows the method, we call 'Meta:unknown' as a last resort. You can implement it to catch special cases just like the regular Tcl 'unknown' command.
Since classes are also objects, they also have a 'class' member. It is set to Meta, which in turn has its 'class' member set to empty.
It is crucial to understand that a chain target resolves method calls for the original receiver, not for itself! The original reciever is passed as the 'this' argument in the code below.
Every class object additionally has the following members:
OK, so here is the code:
#######
# First boot 'Meta', the class of classes.
# It delegates its methods to global procedures called 'Meta:xxx'.
# - It chains to Object (every class is an Object).
# - It sets the class of its instances to "Meta"
# (all classes have Meta as their class).
# - Its instances are classes, which in turn have instances
# which we call the "final instances".
# On the last line of the array body below, we assign a default value (the empty string)
# to proto_vars:proto_vars:class, which will be copied into
# the final instances. This gets replaced with the specific class name
# by the class itself. You'll see ;-)
array set spot_v_Meta {
class {}
procs:new {
{ class_name instance_name args }
{ eval Meta:new $class_name $instance_name $args }
}
procs:del {
{ instance_name }
{ Meta:del $instance_name }
}
procs:exec {
{ instance_name command args }
{ return [eval Meta:exec $instance_name $command $args] }
}
procs:print {
{ instance_name }
{ Meta:print $instance_name }
}
chain "Object"
proto_vars:class "Meta"
proto_vars:procs:new {
{ instance_name args }
{ eval Meta:new $this $instance_name $args }
}
proto_vars:chain ""
proto_vars:proto_vars:class ""
}
proc Meta:new {class_name instance_name args} {
# Just set 'class_name' to 'Meta' to obtain a new class!
# Otherwise, this creates a normal instance.
if { [info commands $instance_name] != "" } {
Meta:error "Creating '$instance_name' redefines an existing command."
}
# Create new array and copy proto_vars into it.
upvar #0 spot_v_$class_name class_arr
upvar #0 spot_v_$instance_name instance_arr
foreach var [array names class_arr "proto_vars:*"] {
regsub {^proto_vars:} $var "" var_name
set instance_arr($var_name) $class_arr($var)
}
# Copy args into array.
# We support leading dashes only pro forma.
foreach {var_name var_value} $args {
regsub {^-} $var_name "" var_name
set instance_arr($var_name) $var_value
}
# Create instance command.
set template {
proc @instance_name@ {command args} {
eval Meta:exec @instance_name@ $command $args
}
}
regsub -all "@instance_name@" $template $instance_name template
eval $template
}
proc Meta:del {instance_name} {
# Delete array.
upvar #0 spot_v_$instance_name arr
unset arr
# Delete instance command.
rename $instance_name ""
# Also remove all its global procs.
foreach proc_name [info procs "$instance_name:*"] {
rename $proc_name ""
}
}
proc Meta:exec {this spot_command args} {
foreach {spot_found spot_args spot_body} [Meta:find $this $spot_command] {}
# If not found, resort to 'Meta:unknown'.
if { $spot_found == 0 } {
return [eval Meta:unknown $this $spot_command $args]
}
# Some temporary local variables need not be available for the called body.
unset spot_found
set spot_actuals $args
unset args
# Assign default argument values.
set spot_tmp_arg ""
foreach spot_tmp_arg $spot_args {
if { [llength $spot_tmp_arg] == 1 } {
set $spot_tmp_arg "" ; # Note the extra dollar
} else {
set [lindex $spot_tmp_arg 0] [lindex $spot_tmp_arg 1]
}
}
# Assign actual values.
set spot_tmp_i 0
set spot_tmp_len [llength $spot_args]
set spot_tmp_val ""
foreach spot_tmp_val $spot_actuals {
if { $spot_tmp_i >= $spot_tmp_len } {
break ; # Ignore any trailing values
}
set spot_tmp_arg [lindex $spot_args $spot_tmp_i]
# Simulate the final 'args' argument.
if { $spot_tmp_arg == "args" && ($spot_tmp_i == [expr $spot_tmp_len - 1]) } {
set args [lrange $spot_actuals $spot_tmp_i end]
break
}
if { [llength $spot_tmp_arg] == 1 } {
set $spot_tmp_arg $spot_tmp_val
} else {
set [lindex $spot_tmp_arg 0] $spot_tmp_val
}
incr spot_tmp_i
}
# Some temporary local variables need not be available for the called body.
unset spot_tmp_arg
unset spot_tmp_val
unset spot_tmp_i
unset spot_tmp_len
# The following special variables DO remain available, for debugging:
# - this = the name of the instance being invoked
# = name of the instance command being executed
# - spot_command = command currently being executed
# - spot_args = list of formal args and their default values
# - spot_actuals = list of actual arg values supplied by caller
# - spot_body = body currently being executed
# And finally do it!
return [eval $spot_body]
}
proc Meta:find {instance_name command} {
set the_args ""
set the_body ""
set found 0
# Find 'command' in the instance methods.
set method "procs:$command"
upvar #0 spot_v_$instance_name instance_arr
if { [info exists instance_arr($method)] } {
foreach {m_args m_body} $instance_arr($method) {}
return [list 1 $m_args $m_body]
}
# If not an instance method, chain to its classes one by one, in given order.
# Use an agenda mechanism to avoid recursion.
# The agenda contains the classes we still need to visit.
set method "chain_procs:$command"
set agenda $instance_arr(class)
while { [llength $agenda] > 0 } {
set cls [lindex $agenda 0]
set agenda [lreplace $agenda 0 0]
upvar #0 spot_v_$cls class_arr
if { [info exists class_arr($method)] } {
foreach {m_args m_body} $class_arr($method) {}
return [list 1 $m_args $m_body]
}
# Update agenda with "base classes".
# We cannot precompute & cache these, because chains can be altered dynamically.
for { set i [expr [llength $class_arr(chain)] - 1] } { $i >= 0 } { incr i -1 } {
set agenda [linsert $agenda 0 [lindex $class_arr(chain) $i]]
}
}
return {0 "" ""}
}
# Prints the contents of an object for debugging purposes.
proc Meta:print {instance_name} {
upvar #0 spot_v_$instance_name arr
if { ! [info exists arr] } {
Meta:error "Trying to print non-existing object '$instance_name'"
}
foreach nam [lsort [array names arr]] {
puts "${instance_name}($nam)= $arr($nam)"
}
}
# You can override this similarly to the Tcl 'unknown' command.
proc Meta:unknown {instance_name command args} {
Meta:error "Did not find proc '$command' in instance '$instance_name'"
}
# Just print an error message and quit.
proc Meta:error {msg} {
Meta:message "SPOT ERROR: $msg"
exit
}
# Just print a message.
proc Meta:message {msg} {
puts "$msg"
}
# Instance command for the 'Meta' object.
proc Meta {command args} {
eval Meta:exec Meta $command $args
}
#######
# Now boot 'Object', the class of objects.
# It is the top of the "inheritance hierarchy", so it has an empty 'chain' attribute.
# But you can change this dynamically!
array set spot_v_Object {
class ""
chain ""
chain_procs:get {
{ var_name }
{ return [Object:get $this $var_name] }
}
chain_procs:set {
{ var_name var_value }
{ return [Object:set $this $var_name $var_value] }
}
chain_procs:unset {
{ var_name }
{ return [Object:unset $this $var_name] }
}
chain_procs:proc {
{ proc_name proc_args proc_body }
{ Object:proc $this $proc_name $proc_args $proc_body }
}
chain_procs:unproc {
{ proc_name }
{ Object:unproc $this $proc_name }
}
}
proc Object:get {instance_name var_name} {
upvar #0 spot_v_$instance_name arr
return $arr($var_name)
}
proc Object:set {instance_name var_name var_value} {
upvar #0 spot_v_$instance_name arr
set arr($var_name) $var_value
return $var_value
}
proc Object:unset {instance_name var_name} {
upvar #0 spot_v_$instance_name arr
set var_value $arr($var_name)
unset arr($var_name)
return $var_value
}
proc Object:proc {instance_name proc_name proc_args proc_body} {
upvar #0 spot_v_$instance_name arr
set arr(procs:$proc_name) [list $proc_args $proc_body]
}
proc Object:unproc {instance_name proc_name} {
upvar #0 spot_v_$instance_name arr
unset arr(procs:$proc_name)
}
# Instance command for the 'Object' object.
proc Object {command args} {
Meta:exec Object $command $args
}
#######
# Syntactic sugar: command to create new classes.
proc class {cls_nam args} {
# Create a new class by instantiating Meta, the class of classes.
Meta:new Meta $cls_nam
upvar #0 spot_v_$cls_nam arr
# Chain of superclasses
if { [lindex $args 0] == ":" } {
foreach elt [lrange $args 1 [expr [llength $args] - 2]] {
lappend arr(chain) $elt
# Copy the proto_vars from the base class to the derived class.
# Note that this implies that base classes must be declared before derived ones.
upvar #0 spot_v_$elt base_arr
foreach base_var [array names base_arr "proto_vars:*"] {
set arr($base_var) $base_arr($base_var)
}
}
}
# Every object, even a class, chains to Object by default.
lappend arr(chain) "Object"
# Members and methods
set arr(proto_vars:class) $cls_nam
# Allow 'set' and 'proc' to declare members inside the class body.
rename proc spot_tmp_proc
rename set spot_tmp_set
spot_tmp_proc set {var_nam val} {
upvar arr arr
spot_tmp_set arr(proto_vars:$var_nam) $val
}
spot_tmp_proc proc {proc_nam arglist body} {
upvar arr arr
spot_tmp_set arr(chain_procs:$proc_nam) [list $arglist $body]
}
# Can even define static members.
spot_tmp_proc static {thingy args} {
if { $thingy == "proc" } {
upvar arr arr
spot_tmp_set proc_nam [lindex $args 0]
spot_tmp_set arr(procs:$proc_nam) [list [lindex $args 1] [lindex $args 2]]
} elseif { $thingy == "set" } {
upvar arr arr
spot_tmp_set var_nam [lindex $args 0]
spot_tmp_set arr($var_nam) [lindex $args 1]
} else {
Meta:error "Should be static set or static proc, not static $thingy."
}
}
# Evaluate the class body, which typically contains calls to
# the 'proc' and 'set' we defined above.
eval [lindex $args end]
rename proc ""
rename set ""
rename static ""
rename spot_tmp_proc proc
rename spot_tmp_set set
}