File : bc-support-hash_tables.adb


-- Copyright (C) 1994-2000 Grady Booch and Simon Wright.
-- All Rights Reserved.
--
--      This program is free software; you can redistribute it
--      and/or modify it under the terms of the Ada Community
--      License which comes with this Library.
--
--      This program is distributed in the hope that it will be
--      useful, but WITHOUT ANY WARRANTY; without even the implied
--      warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--      PURPOSE. See the Ada Community License for more details.
--      You should have received a copy of the Ada Community
--      License with this library, in the file named "Ada Community
--      License" or "ACL". If not, contact the author of this library
--      for a copy.
--

-- $Id: bc-support-hash_tables.adb,v 1.2.2.1 2000/02/12 14:43:51 simon Exp $

with BC.Support.Exceptions;

package body BC.Support.Hash_Tables is


  package BSE renames BC.Support.Exceptions;
  procedure Assert
  is new BSE.Assert ("BC.Support.Tables");


  package body Tables is

    
    function "=" (L, R : Table) return Boolean is
    begin
      -- optimisation if L, R are the same Table?
      if L.Size = R.Size then
        for B in 1 .. Buckets loop
          for Index in 1 .. Items.Length (L.Items (B).all) loop
            declare
              This_Item : Items.Item 
                 renames Items.Item_At (L.Items (B).all, Index);
              use type Values.Value;
            begin
              if not Is_Bound (R, This_Item)
                 or else not (Values.Item_At (L.Values (B).all, Index)
                              = Values.Value'(Value_Of (R, This_Item))) then
                return False;
              end if;
            end;
          end loop;
        end loop;
        return True;
      else
        return False;
      end if;
    end "=";


    procedure Clear (T : in out Table) is
    begin
      for B in 1 .. Buckets loop
        Items.Clear (T.Items (B).all);
        Values.Clear (T.Values (B).all);
        T.Size := 0;
      end loop;
    end Clear;


    procedure Bind (T : in out Table; I : Items.Item; V : Values.Value) is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
    begin
      Assert (Items.Location (T.Items (Bucket).all, I, 1) = 0,
              BC.Duplicate'Identity,
              "Bind",
              BSE.Duplicate);
      Items.Insert (T.Items (Bucket).all, I);
      Values.Insert (T.Values (Bucket).all, V);
      T.Size := T.Size + 1;
    end Bind;


    procedure Rebind (T : in out Table; I : Items.Item; V : Values.Value) is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
      Index : constant Natural := Items.Location (T.Items (Bucket).all, I, 1);
    begin
      Assert (Index /= 0,
              BC.Not_Found'Identity,
              "Rebind",
              BSE.Missing);
      Values.Replace (T.Values (Bucket).all, Index, V);
    end Rebind;


    procedure Unbind (T : in out Table; I : Items.Item) is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
      Index : constant Natural := Items.Location (T.Items (Bucket).all, I, 1);
    begin
      Assert (Index /= 0,
              BC.Not_Found'Identity,
              "Unbind",
              BSE.Missing);
      Items.Remove (T.Items (Bucket).all, Index);
      Values.Remove (T.Values (Bucket).all, Index);
      T.Size := T.Size - 1;
    end Unbind;

    function Extent (T : Table) return Natural is
    begin
      return T.Size;
    end Extent;


    function Is_Bound (T : Table; I : Items.Item) return Boolean is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
    begin
      return Items.Location (T.Items (Bucket).all, I, 1) /= 0;
    end Is_Bound;


    function Value_Of (T : Table; I : Items.Item) return Values.Value is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
      Index : constant Natural := Items.Location (T.Items (Bucket).all, I, 1);
    begin
      Assert (Index /= 0,
              BC.Not_Found'Identity,
              "Value_Of",
              BSE.Missing);
      return Values.Item_At (T.Values (Bucket).all, Index);
    end Value_Of;


    function Value_Of (T : Table; I : Items.Item) return Values.Value_Ptr is
      Bucket : constant Positive := (Items.Hash (I) mod Buckets) + 1;
      Index : constant Natural := Items.Location (T.Items (Bucket).all, I, 1);
    begin
      Assert (Index /= 0,
              BC.Not_Found'Identity,
              "Value_Of",
              BSE.Missing);
      return Values.Item_At (T.Values (Bucket).all, Index);
    end Value_Of;


    function Item_Bucket
       (T : Table; Bucket : Positive) return Items.Item_Container_Ptr is
    begin
      Assert (Bucket <= Buckets,
              BC.Container_Error'Identity,
              "Item_Bucket");
      return T.Items (Bucket);
    end Item_Bucket;


    function Value_Bucket
       (T : Table; Bucket : Positive) return Values.Value_Container_Ptr is
    begin
      Assert (Bucket <= Buckets,
              BC.Container_Error'Identity,
              "Value_Bucket");
      return T.Values (Bucket);
    end Value_Bucket;


    procedure Initialize (T : in out Table) is
    begin
      for B in 1 .. Buckets loop
        T.Items (B) := new Items.Item_Container;
        T.Values (B) := new Values.Value_Container;
      end loop;
    end Initialize;


    procedure Adjust (T : in out Table) is
    begin
      for B in 1 .. Buckets loop
        T.Items (B) := Items.Create (T.Items (B).all);
        T.Values (B) := Values.Create (T.Values (B).all);
      end loop;
    end Adjust;


    procedure Finalize (T : in out Table) is
    begin
      for B in 1 .. Buckets loop
        Items.Free (T.Items (B));
        Values.Free (T.Values (B));
      end loop;
    end Finalize;


  end Tables;
  

end BC.Support.Hash_Tables;