The twist with this object system is that objects are implemented as key-value lists (dictionaries in modern terminology), and that everything goes through variable names. If taken to an extreme, there would be no need for Tcl commands at all. For now, "!" must precede all invocations.
Objects can contain values (properties) and member functions (methods). Values consist of a single item, while methods consist of a lambda-like parameter + a body tuple. Here's an object with three properties:
obj1 {color red size 10 type apple}To retrieve the color, one would do:
! obj1 color
And here's an object with a property and a method:
obj2 {factor 10 times {x {expr {$x * [! me factor]}}}}The above example also illustrates how to get at "instance variables". Let's give the factor property a new value:
! obj2 factor 2
Now, let's use it to double a numeric argument:
puts [! obj2 times 123]
Things still missing from this design are inheritance, basic construction/destruction, clean-up, plus some syntactic sugar to make it more readable. What it offers is a pure data-centric design which would be trivial to make fully persistent, with optional efficient hashed name lookup coded in C.
Why lists? Well, first of all, just as a proof of concept: to show that they are sufficient to build a little OO system. The second reason is that lists are first-order objects in Tcl and can thus be passed around, unlike arrays. The third reason is that a prototype-based OO design like this one might turn out to be quite efficient — sharing maximally when objects are copied.
The original implementation works at least as far back as Tcl 7.6 with a shim for lassign and lset.
Download with wiki-reaper: wiki-reaper 3271 0 > yao.tcl
jcw 2002-04-20:
# optional: fast C-coded version of ihash, built with CriTcl
# package require ihash
# Tcl version, get or set items in a "key value key value ..." list
proc ihash {vref cmd args} {
upvar $vref v
lassign $args a b
switch $cmd {
get {
foreach {x y} $v {
if {$x == $a} {
return $y
}
}
}
set {
set i 1
foreach {x y} $v {
if {$x == $a} {
if {$b ne {}} {
lset v $i $b
} else {
set v [lreplace $v [expr {$i-1}] $i]
}
return $b
}
incr i 2
}
if {$b ne {}} {
lappend v $a $b
}
return $b
}
default { error "$cmd: not implemented" }
}
}
# all objects must be accessed as "! varname method args"
proc ! {self method args} {
upvar $self me
lassign [ihash me get $method] params body
if {$body ne {}} {
if {[llength $args] == 0} {
return $params
}
set a [lindex $args 0]
ihash me set $method $a
return $a
}
foreach 1 $params 2 $args {
if {$1 eq {args}} {
set args [lrange $args [expr {[llength $params]-1}] end]
break
}
set $1 $2
}
eval $body
}2018-03-17 dbohdan: This modification replaces ihash with dict. It has been tested against Tcl 8.5-8.6 and Jim Tcl 0.76.
Download with wiki-reaper: wiki-reaper 3271 1 > yao.tcl
proc ! {self method args} {
upvar $self me
lassign [dict get $me $method] params body
if {$body eq {}} {
# Get value.
if {[llength $args] == 0} {
return $params
}
# Set value.
lassign $args a
dict set me $method $a
return $a
}
# Evaluate method.
foreach 1 $params 2 $args {
if {$1 eq {args}} {
set args [lrange $args [expr {[llength $params]-1}] end]
break
}
set $1 $2
}
eval $body
}The following code replaces eval with apply. It allows you to set the default values for the method arguments and improves the performance of some methods. However, it is not fully compatible with the original:
This means that you must replace, e.g., puts ! counter incr with puts ! counter incr 1 in the examples below when using this version.
Download with wiki-reaper: wiki-reaper 3271 2 > yao.tcl
proc ! {self method args} {
upvar $self me
lassign [dict get $me $method] params body
if {$body eq ""} {
# Get value.
if {[llength $args] == 0} {
return $params
} elseif {[llength $args] >= 2} {
error {too many arguments}
}
# Set value.
lassign $args a
dict set me $method $a
return $a
}
# Evaluate method.
set preamble [list upvar $self me]
uplevel 1 [list apply [list $params $preamble\n$body] {*}$args]
}set obj1 {color red size 10 type apple}
puts [! obj1 color]set obj2 {factor 10 times {{x} { expr {$x * [! me factor]} }}}
! obj2 factor 2
puts [! obj2 times 123]# a more readable example: raw definition of an "object" called "two"
set two {
value 2
times {{x} {
return [expr {$x*2}]
}}
combine {{k args} {
set v {}
foreach x $args {
lappend v [list $k $x]
}
return $v
}}
}
# property access
puts [! two value]
# property setting
puts [! two value 3]
# member call
puts [! two times 5]
# member call with variable args
puts [! two combine 1 a b c]
# dump the full "object" again
puts $twoset counter {
i 0
incr {n {
if {$n eq {}} { set n 1 }
! me i [expr {[! me i] + $n}]
}}
}
puts [! counter incr] ;# 1
puts [! counter incr] ;# 2
set copy $counter
puts [! counter incr 98] ;# 100
puts [! copy incr] ;# 3set obj {
hello Hello!
greet {{} {
puts [! me hello]
}}
}
! obj greet ;# Hello!
set obj {
hello {Hello, World!}
greet {{} {
puts [! me hello]
}}
}
catch { ! obj greet } err
puts $err ;# invalid command name "World!"
# correct
set obj {
hello {{Hello, World!}}
greet {{} {
puts [! me hello]
}}
}
! obj greet ;# Hello, World!source yao.tcl
proc benchmark-counter-field {counterStart max} {
set counter $counterStart
for {set i 0} {$i < $max} {incr i} {
! counter i [expr {[! counter i] + 1}]
}
}
proc benchmark-counter-method {counterStart max} {
set counter $counterStart
for {set i 0} {$i < $max} {incr i} {
! counter incr
}
}
proc run {{max 10000} {times 5}} {
set counterStart {
i 0
incr {{{n 1}} {
! me i [expr { [! me i] + $n }]
}}
}
puts "Counting up to $max $times times."
puts -nonewline { counter field: }
puts [time {benchmark-counter-field $counterStart $max} $times]
puts -nonewline {counter method: }
puts [time {benchmark-counter-method $counterStart $max} $times]
}
run {*}$argvCounting up to 10000 5 times. counter field: 48657.8 microseconds per iteration counter method: 293073.6 microseconds per iteration
Actually, the "!" could be dropped by extending the package unknown mechanism... hm, yes, that would allow for much cleaner uses...
RS: Package unknown? Shall every object be treated as a separate package? I think this refers rather to the normal unknown from init.tcl. But this should be a last resort - maybe it's cleaner and faster to use an interp alias, e.g. in this simple "constructor":
proc yao {name value} {
if [llength [info commands $name]] {
error "cannot override command $name"
}
uplevel 1 [set $name $value] ;# creating "yet another object"
interp alias {} $name {} ! $name ;# shorthand for calling it
uplevel 1 [list trace add variable $name unset "interp alias {} $name {} ;#"]
}where the unset trace cleans up the alias (so you can omit the !), when the variable disappears ("destructor" - a "yao" is destroyed with unset or implicitly when leaving scope). Non-existence of the command has to be checked, as interp alias silently clobbers any command...
JCW: Ah, yes, of course, silly me - too much "package" work lately, it pollutes my brain now. Thanks for the correction - I'll edit out this mistake in a few days.
Richard, as always you add more magic to things. I like your alias and its self-cleanup style. And the "yao" name (I started with "yaos", but your choice is closer to "tao" - and indeed, it's all about Zen).
Note that one hideous little plan of mine is to see if one can throw out all commands, namespaces (even files and packages, but that's another story...). So the alias is great in the current world, but maybe one day all one needs is variables and arrays (or nested variables, possibly). So that the notation "name arg1 arg2 ..." means: find name as object, and either apply arg1 as method or fall back to a default if not found. No more commands at all, at the core level, just a re-implementation on top of variables and something like the above yao data model? Just a thought...
French-speaking users should take a look at this French Tcler's Wiki page [L1 ]. There is an object system without inheritance that clones namespaces. You may define a class (une classe) as a single namespace eval-like command, then instanciate individual namespaces, each with its own variables. Instances behave exactly as namespaces, without any need to reference a this or self pointer.