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

Text File | 1988-05-03 | 7.2 KB | 226 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : generic package LIMITED_PRIORITIZED_QUEUE
-- Version      : 1.0
-- Author       : John A. Anderson
--              : TEXAS INSTRUMENTS MS 8006
--              : P.O. BOX 801
--              : MCKINNEY, TEXAS   75069
-- DDN Address  : ANDERSON%TI-EG@CSNET-RELAY
-- Copyright    : (c) 1984 John A. Anderson
-- Date created :  OCTOBER  2, 1984
-- Release date :  NOVEMBER 27, 1984
-- Last update  :  ANDERSON Wed Nov 27, 1984
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  QUEUE
----------------:  PRIORITIZED QUEUE
--
-- Abstract     :  This generic package creates a Prioritized
----------------:  Queue of a User-defined Limited number of
----------------:  objects.  The Queue is First-In, First-Out
----------------:  except where overridden by the priority.
----------------:  The priority may be any discrete type.
----------------:  It is assumed that the priorities are from
----------------:  lowest to highest.  The type of data structure
----------------:  to be instantiated for the queue may be any
----------------:  type having assignment and equality.  Other
----------------:  types may be enqueued by using access types.
----------------:  (i.e. Access variable pointing to a task.)
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 11/27/84      1.0    Anderson        Initial Release
--                                                           -*
------------------ 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
    SIZE : INTEGER;

    type ELEMENT_TYPE is private;

    type PRIORITY_TYPE is (<>);

package LIMITED_PRIORITIZED_QUEUE is

    procedure ADD (ELEMENT  : ELEMENT_TYPE;
                   PRIORITY : PRIORITY_TYPE := PRIORITY_TYPE'FIRST);

    procedure REMOVE (ELEMENT : out ELEMENT_TYPE);

    function IS_EMPTY return BOOLEAN;

    function IS_FULL return BOOLEAN;

    UNDERFLOW : exception;

    OVERFLOW  : exception;

end LIMITED_PRIORITIZED_QUEUE;

package body LIMITED_PRIORITIZED_QUEUE is

    type NODE;

    type LINK is access NODE;

    type NODE is
        record
            VALUE : ELEMENT_TYPE;
            NEXT  : LINK;
        end record;

    type PRIORITY_ARRAY_TYPE is array (PRIORITY_TYPE
                                         range PRIORITY_TYPE'FIRST ..
                                               PRIORITY_TYPE'LAST) of LINK;

    LIST_HEADS   : PRIORITY_ARRAY_TYPE;

    LIST_TAILS   : PRIORITY_ARRAY_TYPE;

    POOL_HEAD    : LINK;

    POOL_ELEMENT : LINK;

    function IS_EMPTY return BOOLEAN is
        EMPTY_HEADS : PRIORITY_ARRAY_TYPE;
    begin

-- EMPTY_HEADS was initialized to all null
        return (LIST_HEADS = EMPTY_HEADS);

    end IS_EMPTY;


    function IS_FULL return BOOLEAN is
    begin

-- if the POOL_HEAD is null all
--  available resources are in queue
        return POOL_HEAD = null;

    end IS_FULL;

    procedure ADD (ELEMENT  : ELEMENT_TYPE;
                   PRIORITY : PRIORITY_TYPE := PRIORITY_TYPE'FIRST) is

        POINTER : LINK;

    begin
        if IS_FULL then
            raise OVERFLOW;
        end if;

---------
-- obtain record from pool
---------
        POINTER := POOL_HEAD;
        -- set POINTER to next available cell
        POOL_HEAD := POINTER.NEXT;
        -- reset POOL_HEAD to next available cell

---------
-- assign values to record
---------
        POINTER.VALUE := ELEMENT;
        POINTER.NEXT := null;

---------
-- link to proper priority list of queue
---------
        if LIST_TAILS (PRIORITY) /= null then
            LIST_TAILS (PRIORITY).NEXT := POINTER;
            -- link onto tail of queue
        else
            -- this priority has nothing in it, so
            LIST_HEADS (PRIORITY) := POINTER;
            --   link it to the front
        end if;
        LIST_TAILS (PRIORITY) := POINTER;
        -- set this item to be last in queue
    end ADD;

    procedure REMOVE (ELEMENT : out ELEMENT_TYPE) is
        POINTER      : LINK;
        TEMP_ELEMENT : ELEMENT_TYPE;
        PRIORITY     : PRIORITY_TYPE;
    begin

        if IS_EMPTY then
            raise UNDERFLOW;
        end if;

---------
-- find highest priority with element to be removed
---------
        PRIORITY := PRIORITY_TYPE'LAST;
        while LIST_HEADS (PRIORITY) = null loop
            PRIORITY := PRIORITY_TYPE'PRED (PRIORITY);
        end loop;

---------
-- load ELEMENT with value
---------
        ELEMENT := LIST_HEADS (PRIORITY).VALUE;

---------
-- remove ELEMENT from queue
---------
        POINTER := LIST_HEADS (PRIORITY);
        -- set POINTER to cell to be released
        LIST_HEADS (PRIORITY) := LIST_HEADS (PRIORITY).NEXT;
        -- reset queue
        if LIST_HEADS (PRIORITY) = null then
            LIST_TAILS (PRIORITY) := null;
        end if;
---------
-- return cell to resource pool
---------
        POINTER.NEXT := POOL_HEAD; -- link POINTER to Pool
        POOL_HEAD := POINTER; -- reset POOL_HEAD

    end REMOVE;

begin
    for COUNT in 1 .. SIZE loop
        POOL_ELEMENT := new NODE;      -- allocate memory
        POOL_ELEMENT.NEXT := POOL_HEAD; -- link to old head
        POOL_HEAD := POOL_ELEMENT;     -- make this new
                                       -- header
    end loop;
end LIMITED_PRIORITIZED_QUEUE;