[RS] 2005-03-08 - Here is, as a snapshot from the [ical]-2.3.1 tarball, their OO system (dating back to 1993): ---- # Copyright (c) 1993 by Sanjay Ghemawat ############################################################################# # Class system for Tcl. # # Implementation # * Each object has a name of the form _o_ for some integer . # * _o_next is a global integer variable used for allocating object handles. # * _o_ is a global array that stores the slots for _o_. # * _o_ is a procedure that dispatches to the appropriate methods. # * _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] } #### Making sure a proc is defined #### 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 ;) ---- [Category Object Orientation]