Dynamically allocated objects take their memory from a heap.

The memory for an object is provided by an allocator which maintains the storage pool used for the heap.

Often a call to allocator is denoted as

P := new T
where   T   is the type of an allocated object,   and   P   is a reference to the object.

The storage pool chosen by the allocator can be determined by either:

 the object type   T
 the type of pointer   P


In the former case objects can be allocated only in one storage pool.

In the latter case objects of the type can be allocated in any storage pool or on the stack.



Task

The task is to show how allocators and user-defined storage pools are supported by the language.

In particular:

 define an arena storage pool.   An arena is a pool in which objects are allocated individually, but freed by groups.
 allocate some objects (e.g., integers) in the pool.


Explain what controls the storage pool choice in the language.




package require Tcl 8.6
oo::class create Pool {
    superclass oo::class
    variable capacity pool busy
    unexport create
    constructor args {
	next {*}$args
	set capacity 100
	set pool [set busy {}]
    }
    method new {args} {
	if {[llength $pool]} {
	    set pool [lassign $pool obj]
	} else {
	    if {[llength $busy] >= $capacity} {
		throw {POOL CAPACITY} "exceeded capacity: $capacity"
	    }
	    set obj [next]
	    set newobj [namespace current]::[namespace tail $obj]
	    rename $obj $newobj
	    set obj $newobj
	}
	try {
	    [info object namespace $obj]::my Init {*}$args
	} on error {msg opt} {
	    lappend pool $obj
	    return -options $opt $msg
	}
	lappend busy $obj
	return $obj
    }
    method ReturnToPool obj {
	try {
	    if {"Finalize" in [info object methods $obj -all -private]} {
		[info object namespace $obj]::my Finalize
	    }
	} on error {msg opt} {
	    after 0 [list return -options $opt $msg]
	    return false
	}
	set idx [lsearch -exact $busy $obj]
	set busy [lreplace $busy $idx $idx]
	if {[llength $pool] + [llength $busy] + 1 <= $capacity} {
	    lappend pool $obj
	    return true
	} else {
	    return false
	}
    }
    method capacity {{value {}}} {
	if {[llength [info level 0]] == 3} {
	    if {$value < $capacity} {
		while {[llength $pool] > 0 && [llength $pool] + [llength $busy] > $value} {
		    set pool [lassign $pool obj]
		    rename $obj {}
		}
	    }
	    set capacity [expr {$value >> 0}]
	} else {
	    return $capacity
	}
    }
    method clearPool {} {
	foreach obj $busy {
	    $obj destroy
	}
    }
    method destroy {} {
	my clearPool
	next
    }
    self method create {class {definition {}}} {
	set cls [next $class $definition]
	oo::define $cls method destroy {} {
	    if {![[info object namespace [self class]]::my ReturnToPool [self]]} {
		next
	    }
	}
	return $cls
    }
}