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

Text File | 1988-05-03 | 17.1 KB | 499 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : generic package LINKED_LIST
-- Version      : 1.0
-- Author       : Richard Conn
--              : Texas Instruments
--              : PO Box 801, Mail Stop 8007
--              : McKinney, TX  75069
-- DDN Address  : RCONN@SIMTEL20
-- Copyright    : (c) 1984 Richard Conn
-- Date created :  OCTOBER 2, 1984
-- Release date :  NOVEMBER 29, 1984
-- Last update  :  CONN NOVEMBER 29, 1984
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  DOUBLY-LINKED LIST
----------------:  LIST MANIPULATION
--
-- Abstract     :  This package provides a number of routines
----------------:  which can be used to manipulate a doubly-
----------------:  linked list.  See the visible section for
----------------:  a rather complete set of documentation on
----------------:  the routines.
----------------:
----------------:  Each element of the list is of the following
----------------:  structure:
----------------:     RECORD
----------------:      contents: element_object;  -- data
----------------:      next:     element_pointer; -- ptr
----------------:    previous: element_pointer; -- ptr
----------------:     END RECORD;
----------------:
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 11/29/84       1.0    Richard Conn        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 Package to Handle Doubly-Linked Lists
--    by Richard Conn, TI Ada Technology Branch
--
-- The purpose of this package is to provide a software component
-- which can be generically instantiated to handle any type of
-- doubly-linked list.  The set of routines provided in this package
-- are general-purpose in nature and manipulate the elements of a
-- doubly-linked list without regard to their contents.  Each element
-- of the list is of the following structure:
--
--    record
--      content  : element_object;  -- the data in the list element
--      next     : element_pointer; -- pointer to the next element
--      previous : element_pointer; -- pointer to the previous element
--    end record;
--

generic
    type element_object is private;


package generic_list is

--
-- The following type declarations are used throughout is package
-- and are needed by the programs which WITH this package.
--

    type list_element;
    type element_pointer is access list_element;
    type list_element is
        record
            content  : element_object; -- the generic object
            next     : element_pointer;
            previous : element_pointer;
        end record;


--
-- The following procedures and functions initialize the list and
-- return pointers to the three list elements which are continuously
-- tracked by the routines in this package.  These list elements
-- are:
--
--    first_element       the first element in the list
--    last_element        the last element in the list
--    current_element     the current element in the list
--

    procedure initialize_list;
    function  return_first_element   return element_pointer;
    function  return_last_element    return element_pointer;
    function  return_current_element return element_pointer;
    function  return_first_element   return element_object;
    function  return_last_element    return element_object;
    function  return_current_element return element_object;

--
-- The following procedures and functions manipulate the current
-- element pointer.  The following table outlines their functions:
--
--    set_first           the first element becomes the current element
--    set_last            the last element becomes the current element
--    current_index       return the number of the current element
--                          (ordinal); 0 returned if list is empty
--    current_next        set current element to next element in the
--                          list; return TRUE if done or FALSE if
--                          already at end of list
--    current_previous    set current element to previous element in the
--                          list; return TRUE if done or FALSE if
--                          already at front of list
--    set_current_index   set the Nth element as the current element;
--                          return TRUE if done or FALSE if end of list
--                          encountered, in which case the last element
--                          becomes the current element
--

    procedure set_first;
    procedure set_last;
    function  current_index     return natural;
    function  current_next      return boolean;
    function  current_previous  return boolean;
    function  set_current_index (index : natural) return boolean;

--
-- The following functions return the index of the last element in
-- the list and indicate if the list is empty or not.
--
--    last_index          return the number of the last element
--                          (ordinal); 0 returned if list is empty
--    list_empty          return TRUE if the list is empty; FALSE if
--                          the list is not empty
--    at_end_of_list      return TRUE if the current_element is also
--                          the last_element; return FALSE if not
--    at_front_of_list    return TRUE if the current_element is also
--                          the first_element; return FALSE if not
--

    function last_index       return natural;
    function list_empty       return boolean;
    function at_end_of_list   return boolean;
    function at_front_of_list return boolean;

--
-- The following procedures and functions are used to manipulate
-- the elements in the list.
--
--    append_element       append the indicated element after the
--                           current_element in the list; the
--                           current_element is set to the new
--                           element
--    insert_element       insert the indicated element before the
--                           current_element in the list; the
--                           current_element is unchanged
--    delete_element       delete the current_element from the list;
--                           the next element is the new current_element
--                           unless there is no next element, in which
--                           case the previous element is the new
--                           current_element
--

    procedure append_element (element : element_pointer);
    procedure append_element (element : element_object);
    procedure insert_element (element : element_pointer);
    procedure insert_element (element : element_object);
    procedure delete_element;

--
-- The following function and procedure are used to dynamically
-- create new elements and to free the space occupied by unneeded
-- elements.
--
--    new_element        returns a pointer to a new list_element
--    free_element       frees the indicated list_element
--

    function  new_element  return element_pointer;
    procedure free_element (element : element_pointer);

end generic_list;


--
-- BODY of generic_list
--
package body generic_list is

--
-- Definition of the three element pointers
--
    first_element, last_element, current_element : element_pointer;

--
-- Procedure to initialize the list
--    All element pointers are initialized to null
--
    procedure initialize_list is
    begin
        first_element := null;
        last_element := null;
        current_element := null;
    end initialize_list;

--
-- Functions to return element pointers
--
    function return_first_element return element_pointer is
    begin
        return first_element;
    end return_first_element;

    function return_first_element return element_object is
    begin
        return first_element.content;
    end return_first_element;

    function return_last_element return element_pointer is
    begin
        return last_element;
    end return_last_element;

    function return_last_element return element_object is
    begin
        return last_element.content;
    end return_last_element;

    function return_current_element return element_pointer is
    begin
        return current_element;
    end return_current_element;

    function return_current_element return element_object is
    begin
        return current_element.content;
    end return_current_element;

--
-- Current element pointer manipulation
--
    procedure set_first is
    begin
        current_element := first_element;
    end set_first;

    procedure set_last is
    begin
        current_element := last_element;
    end set_last;

    function current_index return natural is
        local_element : element_pointer;
        index         : natural;
    begin
        index := 0; -- initialize counter and set empty list return
        if current_element /= null then
            local_element := first_element; -- point to first element
            index := 1;
            while local_element /= current_element loop
                exit when local_element = null; -- error trap
                local_element := local_element.next;
                index := index + 1;
            end loop;
        end if;
        return index;
    end current_index;

    function current_next return boolean is
    begin
        if current_element = last_element then
            return FALSE;
        else
            current_element := current_element.next;
            return TRUE;
        end if;
    end current_next;

    function current_previous return boolean is
    begin
        if current_element = first_element then
            return FALSE;
        else
            current_element := current_element.previous;
            return TRUE;
        end if;
    end current_previous;

    function set_current_index (index : natural) return boolean is
        counter : natural;
    begin
        current_element := first_element; -- start at first element
        if index <= 1 then
            return TRUE;
        else
            for counter in 1 .. index - 1 loop
                if current_element = last_element then
                    return FALSE;
                    exit;      -- this exit may not be necessary
                else
                    current_element := current_element.next;
                end if;
            end loop;
            return TRUE;
        end if;
    end set_current_index;

--
-- Return the index of the last element in the list
--
    function last_index return natural is
        current_save : element_pointer;
        index        : natural;
    begin
        current_save := current_element;
        current_element := last_element;
        index := current_index;
        current_element := current_save;
        return index;
    end last_index;

--
-- Determine if the list is empty; return TRUE if so, FALSE if not
--
    function list_empty return boolean is
    begin
        if first_element = null then
            return TRUE; -- list is empty
        else
            return FALSE; -- list is not empty
        end if;
    end list_empty;

--
-- Determine if at first element in list; return TRUE if so
--
    function at_front_of_list return boolean is
    begin
        if current_element = first_element then
            return TRUE;
        else
            return FALSE;
        end if;
    end at_front_of_list;

--
-- Determine if at last element in list; return TRUE if so
--
    function at_end_of_list return boolean is
    begin
        if current_element = last_element then
            return TRUE;
        else
            return FALSE;
        end if;
    end at_end_of_list;

--
-- Procedures to manipulate elements in list
--  These procedures insert elements into the list and
--  delete elements from the list
--
    procedure append_element (element : element_pointer) is
    begin
        if list_empty then
            first_element := element;
            last_element := element;
            current_element := element;
            element.next := null;
            element.previous := null;
        else
            element.next := current_element.next;
            current_element.next := element;
            element.previous := current_element;
            if element.next /= null then
                element.next.previous := element;
            else
                last_element := element;
            end if;
        end if;
        current_element := element;
    end append_element;

    procedure append_element (element : element_object) is
        loc_element : element_pointer;
    begin
        loc_element := new_element;
        loc_element.content := element;
        append_element (loc_element);
    end append_element;

    procedure insert_element (element : element_pointer) is
    begin
        if list_empty then
            first_element := element;
            last_element := element;
            current_element := element;
            element.next := null;
            element.previous := null;
        else
            element.previous := current_element.previous;
            current_element.previous := element;
            element.next := current_element;
            if element.previous /= null then
                element.previous.next := element;
            else
                first_element := element;
            end if;
        end if;
    end insert_element;

    procedure insert_element (element : element_object) is
        loc_element : element_pointer;
    begin
        loc_element := new_element;
        loc_element.content := element;
        insert_element (loc_element);
    end insert_element;

    procedure delete_element is
        temp_element : element_pointer;
    begin
        if not list_empty then

            if current_element = first_element then
                first_element := current_element.next;
            else
                current_element.previous.next := current_element.next;
            end if;

            if current_element = last_element then
                last_element := current_element.previous;
                temp_element := last_element;
            else
                current_element.next.previous := current_element.previous;
                temp_element := current_element.next;
            end if;

            free_element (current_element);
            current_element := temp_element;
        end if;
    end delete_element;

--
-- Memory management routines
--   Obtain a new list element and free old, unneeded list elements
--
    function new_element return element_pointer is
    begin
        return (new list_element);
    end new_element;

    procedure free_element (element : element_pointer) is
--
-- This procedure is a dummy for now; the following generic
-- instantiation is what it should be, but there is a bug in my
-- Ada compiler which prevents this instatiation from working
--
-- procedure free_element is new unchecked_deallocation
--    (list_element, element_pointer);
--
    begin
        null;
    end free_element;

end generic_list;