# 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]
}

#### Making sure a proc is defined ####

proc require {procname} {
    if ![string compare [info commands $procname] $procname] return
    auto_load $procname
}