english
version "1.0"
identify "%Z%%M% %I% %E%"

#: Copyright (c) 1995, 2002 by Wayne C. Gramlich.
#, All rights reserved.
#,
#, Permission to use, copy, modify, distribute, and sell this software
#, for any purpose is hereby granted without fee provided that the above
#, copyright notice and this permission are retained.  The author makes
#, no representations about the suitability of this software for any purpose.
#, It is provided "as is" without express or implied warranty.

module manage

#: This module implements the {manage} storage management type.

import
    address
    errors
    format
    in_stream
    logical
    out_stream
    string
    unsigned
    vector

define manage[object]			#: Storage manager for {object}'s
    record
	allocated vector[object]	#: Outstanding objects
	count unsigned			#: Total number of objects out
	debug logical			#: {true}=>check deallocs. carefully
	errors errors			#: Place to print errors
	name string			#: Name of object being managed
	objects vector[object]		#: Free list
    generate allocate, erase, identical, print

#: {manage} procedures:

procedure xallocate@manage[object]
    takes
	manage manage[object]
    returns object
    needs
	procedure allocate@object
	    takes_nothing
	    returns object

    #: This procedure will allocate an object from {manage}.

    assert manage !== ??
    objects :@= manage.objects
    object:: object := ??
    if objects.size = 0
	object := allocate@object()
    else
	object := pop@(objects)
    if manage.debug
	append@(manage.allocated, object)
    manage.count :+= 1
    return object


procedure free_append@manage[object]
    takes
	manage manage[object]
	object object
    returns_nothing
    needs
	procedure identical@object
	    takes object, object
	    returns logical

    #: This procedure will append {object} to {manage}'s free list.

    assert manage !== ??
    assert object !== ??
    objects :@= manage.objects

    # First verify that the object is not accidently being duplicated:
    size :@= objects.size
    index :@= 0
    loop
	while index < size
	assert objects[index] !== object
	index :+= 1

    append@(objects, object)


procedure create@manage[object]
    takes
	name string
	debug logical
	errors errors
    returns manage[object]

    #: This procedure will create and return a storage manager object.

    initialize manage:: manage[object] := allocate@manage[object]()
	manage.allocated := allocate@vector[object]()
	manage.count := 0
	manage.debug := debug
	manage.errors := errors
	manage.name := name
	manage.objects := allocate@vector[object]()
    return manage


procedure deallocate@manage[object]
    takes
	manage manage[object]
	object object
    returns_nothing
    needs
	procedure identical@object
	    takes object, object
	    returns logical
	procedure address_get@object
	    takes object
	    returns address

    #: This procedure will return {object} to {manage} for subsequent
    #, reallocation.

    assert manage !== ??
    objects :@= manage.objects
    if manage.debug
	size :@= objects.size
	index :@= 0
	loop
	    while index < size
	    if objects[index] == object
		format@errors2[string, address](manage.errors,
		  '%ds% at %X% object being deallocated twice!\n\',
		  manage.name, object.address)
		assert false
	    index :+= 1
    append@(objects, object)
    if manage.debug
	allocated :@= manage.allocated
	size :@= allocated.size
	index :@= 0
	loop
	    while index < size
	    if allocated[index] == object
		# Found it!
		allocated[index] := allocated[size - 1]
		truncate@(allocated, size - 1)
		break
	    index :+= 1

    manage.count :-= 1


procedure leaks_check@manage[object]
    takes
	manage manage[object]
    returns logical
    needs
	procedure address_get@object
	    takes object
	    returns address

    #: This procedure will verify that the number of out-standing objects
    #, of type {object} is zero; if not, an error message is output to
    #, {error_stream} and {true} is returned.

    assert manage !== ??
    errors :@= manage.errors
    count :@= manage.count
    if count != 0
	name :@= manage.name
	objects :@= manage.objects
	size :@= objects.size
	format@errors3[string, unsigned, string](errors,
	  '%ds% has %d% deallocated objects!%s%', name, size,
	  (size = 0) ? '(empty free list)\n\' : '(free list: ')
	index :@= 0
	loop
	    while index < size
	    object :@= objects[index]
	    format@errors2[address, string](errors, "%X%%s%",
	      object.address, (index + 1 = size) ? ")\n\" : ", ")
	    index :+= 1

	allocated :@= manage.allocated
	size := allocated.size
	format@errors3[string, unsigned, unsigned](errors,
	  '%ds% has %d% out-standing objects! (count = %d%)',
	  name, size, count)
	if size = 0
	    format@errors1[string](errors, "%s%", "\n\")
	else
	    format@errors1[string](errors, "%s%", " (")
	    index := 0
	    loop
		while index < size
		object :@= allocated[index]
		format@errors2[address, string](errors, "%X%%s%",
		  object.address, (index + 1 = size) ? ")\n\" : ", ")
		index :+= 1
	return true
    return false


procedure free_count_get@manage[object]
    takes
	manage manage[object]
    returns unsigned

    #: This procedure will return the number of available free objects
    #, in {manage}.

    return manage.objects.size