# Copyright (c) 1993 by Sanjay Ghemawat
#############################################################################
# Class system for Tcl.
#
# Implementation
# * Each object has a name of the form _o_<n> for some integer <n>.
# * _o_next is a global integer variable used for allocating object handles.
# * _o_<n> is a global array that stores the slots for _o_<n>.
# * _o_<n> is a procedure that dispatches to the appropriate methods.
# * <c>_ops is an array of class names indexed by method names.
# * superclass(c) is the name of the superclass for c.
# Initialize global variables
catch {unset _o_next}
set _o_next 0
catch {unset superclass}
# effects - Create class
proc class {name arglist body} {
proc $name {args} [format {
global _o_next
incr _o_next
set self _o_$_o_next
_o_class_create %s $self
eval [list %s.constructor %s $self] $args
return $self
} $name $name $name]
proc $name-with-name {self args} [format {
_o_class_create %s $self
eval [list %s.constructor %s $self] $args
return $self
} $name $name $name]
# Initialization routine
method $name constructor $arglist $body
# Default destructor routine for objects of this class does nothing
method $name destructor {} {}
# Return class name
method $name class {} [format {return %s} $name]
}
# effects - Create subclass. Superclass constructor and destructor are NOT called by default. The subclass constructor and destructor should call them explicitly if necessary
proc subclass {name super arglist body} {
# Make sure the super class is defined
require $super
# Inherit the superclass methods
upvar #0 [set name]_ops sub_ops
upvar #0 [set super]_ops super_ops
# Record super-class name
global superclass
set superclass($name) $super
foreach m [array names super_ops] {
set sub_ops($m) $super_ops($m)
}
# Create subclass
class $name $arglist $body
}
# effects - Delete object
#
# This cannot be a method because Tcl does not like active procs being
# deleted.
proc class_kill {object} {
# Do object-specific cleanup
global superclass
set c [$object class]
while 1 {
$c.destructor $c $object
if ![info exists superclass($c)] break
set c $superclass($c)
}
# Reclaim storage
rename $object {}
global $object
catch {unset $object}
}
# effects - Create method
proc method {class selector arglist body} {
upvar #0 [set class]_ops ops
set ops($selector) $class
proc $class.$selector [linsert $arglist 0 selfclass self] [format {
upvar #0 $self slot
%s
} $body]
}
# effects - Rename method from "old" to "new"
proc rename_method {class old new} {
upvar #0 [set class]_ops ops
set ops($new) $ops($old)
unset ops($old)
rename $class.$old $class.$new
}
# effects - Invoke selected method in superclass context
proc super {selector args} {
global superclass
upvar self self selfclass selfclass
set sup $superclass($selfclass)
upvar #0 ${sup}_ops ops
return [uplevel [list $ops($selector).$selector $sup $self] $args]
}
# effects - Used internally for object creation. Takes class name.
proc _o_class_create {C self} {
upvar #0 $self slot
catch {unset slot}
set slot(junk) {}
unset slot(junk)
proc $self {sel args} [format {
global %s_ops
return [uplevel [list $%s_ops($sel).$sel $%s_ops($sel) %s] $args]
} $C $C $C $self]
}
proc require {procname} {
if ![string compare [info commands $procname] $procname] return
auto_load $procname
}SS Nice! this runs with a minor change (using concat instead of linsert that's still not implemeted) with Jim! so it's the first OOP extension available for it ;)
