# 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.

# Initialize global variables
catch {unset _o_next}
set _o_next 0

# effects - Create class
proc class {name arglist body} {
    proc $name $arglist [format {
	global _o_next
	incr _o_next
	set self _o_$_o_next
	upvar #0 $self slot
	catch {unset slot}
	set slot(junk) x
	catch {unset slot(junk)}
	_o_class_create %s
	%s
	return $self
    } $name $body]

    # Default cleanup routine for objects of this class does nothing
    proc $name::cleanup {self} {
    }
}

# 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
    $object cleanup

    # Reclaim storage
    rename $object {}
    global $object
    catch {unset $object}
}

# effects - Create method
proc method {class selector arglist body} {
    proc $class::$selector [linsert $arglist 0 self] [format {
	upvar #0 $self slot
	%s
    } $body]
}

# effects - Used internally for object creation.  Takes class name.
proc _o_class_create {C} {
    upvar 1 self self

    proc $self {selector args} [format {
	return [eval %s::$selector %s $args]
    } $C $self]
}
