1 # OO support for Jim Tcl, with multiple inheritance
3 # Create a new class $classname, with the given
4 # dictionary as class variables. These are the initial
5 # variables which all newly created objects of this class are
8 # If a list of baseclasses is given,
9 # methods and instance variables are inherited.
10 # The *last* baseclass can be accessed directly with [super]
11 # Later baseclasses take precedence if the same method exists in more than one
12 proc class
{classname
{baseclasses
{}} classvars
} {
14 foreach baseclass
$baseclasses {
15 # Start by mapping all methods to the parent class
16 foreach method
[$baseclass methods
] { alias
"$classname $method" "$baseclass $method" }
17 # Now import the base class classvars
18 set baseclassvars
[dict merge
$baseclassvars [$baseclass classvars
]]
19 # The last baseclass will win here
20 proc "$classname baseclass" {} baseclass
{ return $baseclass }
23 # Merge in the baseclass vars with lower precedence
24 set classvars
[dict merge
$baseclassvars $classvars]
25 set vars
[lsort [dict keys
$classvars]]
27 # This is the class dispatcher for $classname
28 # It simply dispatches 'classname cmd' to a procedure named {classname cmd}
29 # with a nice message if the class procedure doesn't exist
30 proc $classname {{cmd new
} args
} classname
{
31 if {![exists
-command "$classname $cmd"]} {
32 return -code error "$classname, unknown command \"$cmd\": should be [join [$classname methods] ", "]"
34 tailcall
"$classname $cmd" {*}$args
38 proc "$classname new" {{instvars
{}}} {classname classvars
} {
39 set instvars
[dict merge
$classvars $instvars]
41 # This is the object dispatcher for $classname.
42 # Store the classname in both the ref value and tag, for debugging
43 # ref tag (for debugging)
44 set obj
[ref
$classname $classname "$classname finalize"]
45 proc $obj {method args
} {classname instvars
} {
46 if {![exists
-command "$classname $method"]} {
47 if {![exists
-command "$classname unknown"]} {
48 return -code error "$classname, unknown method \"$method\": should be [join [$classname methods] ", "]"
50 return ["$classname unknown" $method {*}$args]
52 "$classname $method" {*}$args
54 if {[exists
-command "$classname constructor"]} {
59 # Finalizer to invoke destructor during garbage collection
60 proc "$classname finalize" {ref classname
} { $ref destroy }
62 proc "$classname method" {method arglist __body
} classname
{
63 proc "$classname $method" $arglist {__body
} {
64 # Make sure this isn't incorrectly called without an object
65 if {![uplevel exists instvars
]} {
66 return -code error -level 2 "\"[lindex [info level 0] 0]\" method called with no object"
68 set self
[lindex [info level
-1] 0]
69 # Note that we can't use 'dict with' here because
70 # the dict isn't updated until the body completes.
71 foreach __
[$self vars
] {upvar 1 instvars
($__) $__}
76 # Other simple class procs
77 proc "$classname vars" {} vars
{ return $vars }
78 proc "$classname classvars" {} classvars
{ return $classvars }
79 proc "$classname classname" {} classname
{ return $classname }
80 proc "$classname methods" {} classname
{
81 lsort [lmap p
[info commands
"$classname *"] {
82 lindex [split $p " "] 1
85 # Pre-defined some instance methods
86 $classname method
destroy {} { rename $self "" }
87 $classname method get
{var
} { set $var }
88 $classname method
eval {{locals
{}} __code
} {
89 foreach var
$locals { upvar 2 $var $var }
95 # From within a method, invokes the given method on the base class.
96 # Note that this will only call the last baseclass given
97 proc super
{method args
} {
99 uplevel 2 [$self baseclass
] $method {*}$args