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:
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 one or more other objects. When you invoke a method on an object, the object 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 all object data dynamically, so you can just set another target or add new targets.
The whole system boots itself from only Object and Meta and their methods.
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" 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*]"Here is the code:
(NOT YET)