Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/garbage.src

Text File | 1988-05-03 | 6.4 KB | 209 lines

::::::::::
garb_coll_v.ada
::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : generic package Garbage_Collection
-- Version      : 1.0
-- Author       : Doug Bryan
--              : Computer Systems Lab
--              : Stanford University
--              : Stanford, CA 94305
-- DDN Address  : bryan@su-sierra
-- Copyright    : (c) -none-
-- Date created : 10 Aug 1985
-- Release date : 16 Aug 1985
-- Machine/System Compiled/Run on :
--   Data General MV/10000 running the Ada Development Environment 2.2
---------------------------------------------------------------
--                                                           -*
-- Keywords     : MEMORY, GARBAGE, COLLECTION
----------------:
--
-- Abstract     : This is a generic garbage collector.  It simply
----------------: maintains an internal linked list of items which
--              : have been freed then reuses these items when more
--              : are needed.
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------
generic
    type Item is limited private;
    type Link is access Item;
package Garbage_Collection is

    procedure Free (Item : in out Link);
    --| out (item = null);
    -- if item = null, then do nothing.
    -- may raise storage_error;

    procedure Get (New_Item : in out Link);
    --| out (new_item /= null);
    -- if new_item /= null then do nothing.
    -- may raise storage_error;

end Garbage_Collection;

::::::::::
garb_coll_b.ada
::::::::::
package body Garbage_Collection is

-- type item is limited private;
-- type link is access item;

    type Node_Type;
    type List_Type is access Node_Type;
    type Node_Type is
    record
        L    : Link;
        Next : List_Type;
    end record;

    Free_Nodes_With_No_Items,
    Free_Nodes_With_Free_Items : List_Type;
    Free_Items : List_Type renames Free_Nodes_With_Free_Items;
    Free_Nodes : List_Type renames Free_Nodes_With_No_Items;

----------------------------------------------------------
-- A logical improvement on this package would be to have the
-- procedures call Unchecked_Deallocation if Storage_Error is
-- ever raised.  They could deallocate all the items and nodes
-- in the local list.  The reasons this is simply not done instead
-- of maintaining the list are:
--   1- an implementation need not implement Unchecked_Deallocation
--   2- it is felt that maintaining a list will be faster than
--      maintaining an entire heap (???)
----------------------------------------------------------

    procedure Free (Item : in out Link) is
    Temp : List_Type;
    begin
    if Item /= null then
        if Free_Nodes = null then
        Temp := new Node_Type;
        else
        Temp := Free_Nodes;
        Free_Nodes := Free_Nodes.all.Next;
        end if;
        Temp.all := (L => Item, Next => Free_Items);
        Free_Items := Temp;
        Item := null;
    end if;
    end Free;

----------------------------------------------------------
    procedure Get (New_Item : in out Link) is
    Temp : List_Type;
    begin
    if New_Item = null then
        if Free_Items = null then
        New_Item := new Item;
        else
        Temp := Free_Items;
        Free_Items := Free_Items.all.Next;
        New_Item := Temp.all.L;
        Temp.all := (L => null, Next => Free_Nodes);
        Free_Nodes := Temp;
        end if;
    end if;
    end Get;

----------------------------------------------------------
end Garbage_Collection;

::::::::::
garb_coll_test.ada
::::::::::
with Text_Io,
     Garbage_Collection;
use Text_Io;

procedure Garb_Coll_Test is
    type Block   is array (1 .. 1000) of Integer;
    type A_Block is access Block;
    package Garbage is new Garbage_Collection
           (Item => Block, Link => A_Block);
    A : array (1 .. 5) of A_Block;
    Bug : exception;
begin
    for I in 1 .. 10_000 loop
    for J in A'Range loop
        Garbage.Get (A (J));
        a(j).all := (others => 44);
    end loop;
    for J in A'Range loop
        Garbage.Free (A (J));
        if A (J) /= null then
        raise Bug;
        end if;
    end loop;
    Put ('.');
    end loop;
exception
    when Storage_Error =>
    New_Line;
    Put_Line ("Storage Error !!!!!");
    when others =>
    New_Line;
    Put_Line ("Fatal Exception. ");
end Garb_Coll_Test;

pragma Main;
::::::::::
garb_coll_test_2.ada
::::::::::
with Text_Io;
use Text_Io;

procedure Garb_Coll_Test_2 is
    type Block   is array (1 .. 1000) of Integer;
    type A_Block is access Block;
    a : a_block;
    count : natural := 0;
    -- the goal of this test is simply to see how may blocks
    -- we can allocate before we get a storage error.
begin
    loop
    a := new block;
    count := natural'succ (count);
    end loop;
exception
    when others =>
    New_Line;
    Put_Line ("Fatal Exception.");
    put_line ("Count was "& natural'image (count));
end Garb_Coll_Test_2;

pragma Main;