DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦641a0f558⟧ TextFile

    Length: 14114 (0x3722)
    Types: TextFile
    Names: »B«

Derivation

└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
    └─ ⟦0c20f784e⟧ »DATA« 
        └─⟦1abbe589f⟧ 
            └─⟦591c5b094⟧ 
                └─⟦this⟧ 

TextFile

with Unchecked_Deallocation;

with Arithmetic;
use Arithmetic;
with Vstring_Case;
with Vstring_Type;
use Vstring_Type;

package body String_Heap is
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
--                  All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------

    type S_Natural_Array is array (S_Natural range <>) of S_Natural;

----Elements are simply pairs of string Keys and Range_Type values.

    type Elem_Rec is
        record
            Hash : S_Natural        := 0;
            Key  : E_String_Pointer := null;
            Next : Element          := null;
        end record;

----Maps are simply a table of Element linked lists.

    type Element_Array is array (S_Natural range 0 .. Hash_Size - 1) of Element;

    type Map_Rec is
        record
            Count : S_Natural     := 0;
            Table : Element_Array := (0 .. Hash_Size - 1 => null);
        end record;

--\f

    procedure Free_String_Ptr is new Unchecked_Deallocation (E_String,  
                                                             E_String_Pointer);

    procedure Free_Element is new Unchecked_Deallocation (Elem_Rec,  
                                                          Element);

    procedure Free_Map_Internal is new Unchecked_Deallocation (Map_Rec,  
                                                               Map);

--\f

    function Hash (Key : E_String) return S_Natural is
------------------------------------------------------------------------------
--  Key - Specfies the string to hash
--
-- Returns a hash value for the indicated string.
------------------------------------------------------------------------------
        Xl : S_Natural_Array (Key'Range);
        use Vstring_Case;
    begin

        if Exact_Case_Match then
            for I in Key'Range loop
                Xl (I) := Character'Pos (Key (I));
            end loop;
        else
            for I in Key'Range loop
                Xl (I) := Character'Pos (Vstring_Case.Uc_Char (Key (I)));
            end loop;
        end if;

        case Key'Length is
            when 0 =>
                return 0;
            when 1 =>
                return Xl (Xl'First);
            when 2 =>
                return Xl (Xl'First) * 128  
                           + Xl (Xl'Last);
            when 3 =>
                return Xl (Xl'First) * 64  
                           + Xl (Xl'First + 1) * 128  
                           + Xl (Xl'Last);
            when 4 =>
                return Xl (Xl'First) * 32  
                           + Xl (Xl'First + 1) * 64  
                           + Xl (Xl'First + 2) * 128  
                           + Xl (Xl'Last);
            when others =>
                declare
                    I : S_Natural := Xl'First;
                    H : S_Natural := 0;
                begin
                    while I + 3 <= Xl'Last loop
                        if S_Natural'Last / 3 < H then
                            ----Prevent overflow on long strings.
                            H := H / 3;
                        end if;
                        H := H + Xl (I) * 32  
                                 + Xl (I + 1) * 64  
                                 + Xl (I + 2) * 128  
                                 + Xl (I + 3);
                        I := I + 4;
                    end loop;
                    for J in I .. Xl'Last loop
                        H := H + Xl (J);
                    end loop;
                    return H;
                end;
        end case;

    end Hash;

--\f

    function Equal (A : E_String; B : E_String) return Boolean is
------------------------------------------------------------------------------
--  A   - Specifies the first string
--  B   - Specifies the second string
--
-- Returns TRUE if A = B when both are upper case.
------------------------------------------------------------------------------
        Ai : S_Natural := A'First;
        Bi : S_Natural := B'First;
    begin

----The lengths must be the same.

        if A'Length /= B'Length then
            return False;
        end if;

----Check for any differences.

        for I in S_Natural range 0 .. A'Length - 1 loop
            if Vstring_Case.Uc_Char (A (Ai + I)) /=
               Vstring_Case.Uc_Char (B (Bi + I)) then
                return False;
            end if;
        end loop;

----They are the same.

        return True;

    end Equal;

--\f

    procedure Lookup (H    :        S_Natural;  
                      Key  :        E_String;  
                      Prev : out    Element;  
                      Elem : in out Element) is
------------------------------------------------------------------------------
--  H       - Specifies the hash value for the Key
--  Key     - Specifies the key we are looking for
--  Prev    - Receives the last element in the initial Elem list or else the
--              Element whose .Next is Elem.
--  Elem    - Receives NULL or else the Element that matches the Key/H values;
--              initially is the M.Table(H) value
------------------------------------------------------------------------------
        El : Element := Elem;
    begin

----Initially there is no Prev vaue.

        Prev := null;

----Loop over all of the chained elements looking for matching H/Key values.

        while El /= null loop
            if El.Hash = H then
                if Exact_Case_Match then
                    if El.Key.all = Key then
                        Elem := El;
                        return;
                    end if;
                else
                    if Equal (Key, El.Key.all) then
                        Elem := El;
                        return;
                    end if;
                end if;
            end if;  
            Prev := El;
            El   := El.Next;
        end loop;

----Nothing was found.  Return null.

        Elem := null;

    end Lookup;

--\f

    procedure New_Map (M : out Map) is
------------------------------------------------------------------------------
--  M   - Receives a new Map.
--
-- Called to create and initialize a new Map.  The Map Is_Empty.
------------------------------------------------------------------------------
    begin

        M := new Map_Rec;

    end New_Map;

--\f

    procedure Free_Map (M : in out Map) is
------------------------------------------------------------------------------
--  M   - Specifies the existing Map to deallocate.
--
-- Called to destroy an existing Map.  Map may have a None_Map value.  All map
-- entries are destroyed.  The Range_Type values contained in the map are
-- merely dropped and are not deallocated or manipulated in any way.
------------------------------------------------------------------------------
        Elem1 : Element;
        Elem2 : Element;
    begin

----Free any existing table entries.

        if M.Count > 0 then
            for I in M.Table'Range loop
                Elem1 := M.Table (I);

----Free elements on this chain; including the Key strings.

                while Elem1 /= null loop
                    Elem2 := Elem1.Next;
                    Free_String_Ptr (Elem1.Key);
                    Free_Element (Elem1);
                    Elem1 := Elem2;
                end loop;

            end loop;
        end if;

----Free the map itself.

        Free_Map_Internal (M);

    end Free_Map;

--\f

    function Is_Empty (M : in Map) return Boolean is
------------------------------------------------------------------------------
--  M   - Specifies the map
--
-- Returns TRUE if the map is completely empty.
------------------------------------------------------------------------------
    begin

        return M.Count = 0;

    end Is_Empty;

--\f

    function Cardinality (M : in Map) return S_Natural is
------------------------------------------------------------------------------
--  M   - Specifies the map
--
-- Returns the number of entries in the map.
------------------------------------------------------------------------------
    begin

        return M.Count;

    end Cardinality;

--\f

    function Share (M   : in Map;  
                    Key : in E_String) return E_String_Pointer is
------------------------------------------------------------------------------
--  M       - Specifies the map to use
--  Key     - Specifies the string value to use for the lookup
--
-- Returns a shared string containing the same characters as are found in Key.
------------------------------------------------------------------------------
        H    : S_Natural := Hash (Key);
        Prev : Element;
        Elem : Element   := M.Table (H rem Hash_Size);
    begin

----Lookup the entry in the table with this hash value.  Replace any existing
--  entry if that is ok.

        Lookup (H, Key, Prev, Elem);
        if Elem /= null then
            return Elem.Key;
        end if;

----Create a new map element and put it into the map.

        Elem        := new Elem_Rec'(Hash => H,  
                                     Key  => new E_String'(Key),  
                                     Next => null);
        H           := H rem Hash_Size;
        Elem.Next   := M.Table (H);
        M.Table (H) := Elem;
        M.Count     := M.Count + 1;
        return Elem.Key;

    end Share;

--\f

    procedure Initialize (M : in     Map;  
                          I : in out Iter) is

------------------------------------------------------------------------------
--  M   - Specifies the map
--  I   - Receives the new iteration value
--
-- Called to initialize an iterator for a particular map.  Iterators are
-- used in this fashion:
--      declare
--          I  : Iter;
--          M  : Map;
--          Vl : E_String_Pointer;
--      begin
--          Initilize (M, I);
--          while not Done (I) loop
--              Vl := Key (I);
--              .... Code using the Vl value ....
--              Next (I);
--          end loop;
--      end;
-- Iterators are affected by changes to the map.  Deletions can cause
-- dereferencing of null pointers.  Insertions are benign and new map entries
-- may or may not appear as Values in the iteration depending upon the
-- state of the Iter when the Insert is performed and also depending upon the
-- value of the Key string.
--
-- The iterator will advance through all entries within the map and the
-- processing order of the entries is determined by the hash value of the
-- Key strings and may or may not have any externally sensible ordering.
------------------------------------------------------------------------------
    begin

----Search for any element whatsoever.

        I.M := M;
        for Ind in 0 .. Hash_Size - 1 loop
            if M.Table (Ind) /= null then
                I.Elem  := M.Table (Ind);
                I.Index := Ind;
                return;
            end if;
        end loop;

----Map is empty.  Finish the initialization.

        I.Elem  := null;
        I.Index := Hash_Size;

    end Initialize;

--\f

    function Done (I : in Iter) return Boolean is
------------------------------------------------------------------------------
--  I   - Specifies the iterator to check
--
-- Returns TRUE when there are no more map entries to iterate through.
------------------------------------------------------------------------------
    begin

----If we have an element waiting then we are not done.

        if I.Elem /= null then
            return False;
        end if;

----We must be done.

        return True;

    end Done;

--\f

    function Key (I : in Iter) return E_String_Pointer is
------------------------------------------------------------------------------
--  I   - Specifies the iterator to check
--
-- Returns the key string value associated with the current value of the
-- map iterator.  Raises Missing_Entry if Done(I) = TRUE.
------------------------------------------------------------------------------
    begin

        if I.Elem = null then
            raise Missing_Entry;
        end if;
        return I.Elem.Key;

    end Key;

--\f

    procedure Next (I : in out Iter) is
------------------------------------------------------------------------------
--  I   - Specifies the iterator
--
-- Advances the map iterator by one entry.  Raises Missing_Entry if
-- Done(I) = TRUE already.  Done(I) = TRUE will be true when this routine
-- returns if there are no more entries to be processed.
------------------------------------------------------------------------------
        Elem : Element;
    begin

----Locate the next element.

        if I.Elem = null then
            raise Missing_Entry;
        end if;
        if I.Elem.Next /= null then
            I.Elem := I.Elem.Next;
            return;
        end if;
        for Ind in I.Index + 1 .. Hash_Size - 1 loop
            if I.M.Table (Ind) /= null then
                I.Elem  := I.M.Table (Ind);
                I.Index := Ind;
                return;
            end if;
        end loop;

----Nothing Next; we are Done.

        I.Elem := null;

    end Next;

--\f

end String_Heap;