# Very simple OO support for Jim Tcl, with inheritance
# Create a new class $classname, with the given
# dictionary as instance variables. These are the initial
# variables which all newly created objects of this class are
# initialised with.
# If $baseclass is given, methods and instance variables are inherited
proc class {classname {baseclass {}} instvars} {
if {$baseclass ne ""} {
# Start by mapping all methods to the parent class
foreach method [$baseclass.methods] { alias $classname.$method $baseclass.$method }
# Now import the base class initial variables
set instvars [$baseclass.instvars $instvars]
}
# pre-create some class methods
proc $classname.vars {} instvars { dict keys $instvars }
proc $classname.instvars {{dict {}}} instvars { array set instvars $dict; return $instvars }
proc $classname.classname {} classname { return $classname }
proc $classname.methods {} classname { lmap p [info procs $classname.*] { lindex [split $p .] 1 } }
# and instance methods
method $classname destroy {} { rename $self "" }
# This is the constructor for class $classname
# Any variable values in $args override class defaults
proc $classname {args} {classname instvars} {
# Initialise vars
array set instvars $args
# This is the object dispatcher for $classname.
# Don't use lambda here so that we can use a more meaningful ref tag
proc [ref {} $classname lambda.finalizer] {method args} {classname instvars} {
$classname.$method {*}$args
}
}
}
# Create method $method on class $classname
proc method {classname method arglist body} {
proc $classname.$method $arglist {classname body} {
lassign [info level -1] self
foreach i [$self vars] {upvar 1 instvars($i) $i}
eval $body
}
}Test code:
package require oo
# Create a class, the usual bank account, with two instance variables:
class Account {
balance 0
name "Unknown"
}
# We have some class methods predefined
puts "---- class Account ----"
puts vars=[Account.vars]
puts methods=[Account.methods]
puts ""
# Now flesh out the class with some methods
method Account deposit {amount} {
set balance [+ $balance $amount]
}
method Account see {} {
set balance
}
method Account withdraw {amount} {
if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"}
set balance [- $balance $amount]
}
method Account describe {} {
puts "I am object $self of class [$self classname]"
puts "My variables are:"
foreach i [$self vars] {
puts " $i=[set $i]"
}
}
puts methods=[Account.methods]
# Now an instance, initialisition some fields
set a [Account name "Bob Smith"]
puts "---- object Account ----"
# We can use class methods on the instance too
puts a.vars=[$a vars]
puts a.classname=[$a classname]
# Now object methods
$a deposit 100
puts "deposit 100 -> [$a see]"
$a withdraw 40
puts "withdraw 40 -> [$a see]"
catch {$a withdraw 1000} res
puts "withdraw 1000 -> $res\n"
# Tell me something about the object
$a describe
puts ""
# Now create a new superclass
class CreditAccount Account {
limit -1000
}
# Allow overdrawing
method CreditAccount withdraw {amount} {
if {$balance - $amount < $limit} {error "Sorry $name, that would exceed your credit limit of [expr -$limit]"}
set balance [- $balance $amount]
}
puts "---- class CreditAccount ----"
puts vars=[CreditAccount.vars]
puts methods=[CreditAccount.methods]
puts ""
puts "---- object CreditAccount ----"
set b [CreditAccount name "John White"]
puts b.vars=[$b vars]
puts b.classname=[$b classname]
$b deposit 100
puts "deposit 100 -> [$b see]"
$b withdraw 40
puts "withdraw 40 -> [$b see]"
$b withdraw 1000
puts "withdraw 1000 -> [$b see]"
puts ""
# Tell me something about the object
$b describe
# And goodbye
$a destroy
$b destroyAnd the output:
---- class Account ---- vars=name balance methods=classname destroy methods instvars vars methods=deposit destroy describe instvars vars classname see methods withdraw ---- object Account ---- a.vars=name balance a.classname=Account deposit 100 -> 100 withdraw 40 -> 60 withdraw 1000 -> Sorry Bob Smith, can only withdraw 60 I am object <reference.<Account>.00000000000000000000> of class Account My variables are: name=Bob Smith balance=60 ---- class CreditAccount ---- vars=name balance limit methods=deposit describe destroy instvars vars withdraw methods see classname ---- object CreditAccount ---- b.vars=name balance limit b.classname=CreditAccount deposit 100 -> 100 withdraw 40 -> 60 withdraw 1000 -> -940 I am object <reference.<CreditA>.00000000000000000001> of class CreditAccount My variables are: name=John White balance=-940 limit=-1000
Richard's Original CodeHere's a "constructor" the hard (bare-bones) way:}
proc Account args {
lambda {method args} {{balance 0}} {eval Account'$method $args}
}if 0 {Alternatively, if you want to use more than one class, here's factoring out the generic part. It also adds an introspection method for the names of instance vars. Other methods that all classes shall have, can be placed here too:} proc class {name instvars} {
proc $name args \
[list lambda {method args} $instvars "eval $name'\$method \$args"]
proc $name'vars {} [list return [lmap i $instvars {lindex $i 0}]]
}#-- Let's re-create a first class, the usual bank account, with one instance variable: class Account {
{balance 0}
}#-- Bare-bone methods are procs with class'method names. They need to upvar the instance vars they use:
proc Account'deposit amount {
upvar 1 balance balance
set balance [+ $balance $amount]
}#-- Here's a wrapper to implicitly do those upvars in methods: proc method {class name argl body} {
proc $class'$name $argl "foreach i \[\[self] vars] {upvar 1 \$i \$i} \n$body"
}#-- Methods can be written much slicker now: method Account see {} {set balance}
method Account withdraw amount {
if {($balance-$amount) < 0} {error "can only withdraw $balance"}
set balance [- $balance $amount]
}if 0 {"Who am I?" is a deep philosophical question. Inside methods, it's easily answered - the name of the caller's caller, i.e. the object lambda:} proc self {} {lindex [info level -2] 0}if 0 {Now testing: set a [Account]
puts a:$a
$a deposit 100
puts "deposit 100 -> [$a see]"
$a withdraw 40
catch {$a withdraw 1000} res
puts $resshows on stdouta:<reference.<functio>.00000000000000000000> deposit 100 -> 100 can only withdraw 60Conclusion: For years, I wondered what exactly closures are. After seeing their simplicity and power in this example (9 LOC for class-based OO without inheritance - for the convenience wrappers class, method, and self; if you use only "bare-bones" constructors and methods as shown above, you need zero LOC of framework :-), I strongly advocate that Tcl adopts them too, for procs. And we can have it today, with Jimulation :)
SS Very nice! It seems to me a very natural hack to try to implement objects via closures. Also your way to do the dispatch is impressive ;)
MiR: Question: Is there any way to do inheritance with closures?
Arts and crafts of Tcl-Tk programming | Category Object Orientation | Category Jim }
