--  Copyright 2001-2002 Simon Wright <simon@pushface.org>

--  This package is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2, or
--  (at your option) any later version. This package 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 GNU General Public License for more
--  details. You should have received a copy of the GNU General Public
--  License distributed with this package; see file COPYING.  If not,
--  write to the Free Software Foundation, 59 Temple Place - Suite
--  330, Boston, MA 02111-1307, USA.

--  As a special exception, if other files instantiate generics from
--  this unit, or you link this unit with other files to produce an
--  executable, this unit does not by itself cause the resulting
--  executable to be covered by the GNU General Public License.  This
--  exception does not however invalidate any other reasons why the
--  executable file might be covered by the GNU Public License.

--  $RCSfile: bc-support-bounded_hash_tables.adb,v $
--  $Revision: 1.8.2.6 $
--  $Date: 2002/12/26 14:48:06 $
--  $Author: simon $

with Ada.Exceptions;
with BC.Support.Exceptions;
with System;
with System.Address_To_Access_Conversions;

package body BC.Support.Bounded_Hash_Tables is


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


   package body Tables is


      pragma Warnings (Off);
      --  for GNAT: style checks require a specification, but the
      --  operation can't be dispatching.
      function Location
        (T : Table; Start : Index; I : Items.Item) return Index;
      pragma Warnings (On);

      function Location
        (T : Table; Start : Index; I : Items.Item) return Index is
         Result : Index := Start;
      begin
         while Result /= 0 loop
            if Items.Eq (T.Contents (Result).Item, I) then
               return Result;
            end if;
            Result := T.Contents (Result).Next;
         end loop;
         return 0;
      end Location;


      procedure Initialize (T : in out Table) is
      begin
         Clear (T);
      end Initialize;


      function "=" (L, R : Table) return Boolean is
      begin
         if System."=" (L'Address, R'Address) then
            return True;
         end if;
         if L.Size = R.Size then
            for B in L.Buckets'Range loop
               declare
                  I : Index := L.Buckets (B);
               begin
                  while I > 0 loop
                     declare
                        C : constant Cell := L.Contents (I);
                     begin
                        if not Is_Bound (R, C.Item)
                          or else not Values.Eq (C.Value, Value_Of (R, C.Item))
                        then
                           return False;
                        end if;
                        I := C.Next;
                     end;
                  end loop;
               end;
            end loop;
            return True;
         else
            return False;
         end if;
      end "=";


      procedure Clear (T : in out Table) is
      begin
         T.Buckets := (others => 0);
         for C in T.Contents'First .. T.Contents'Last - 1 loop
            T.Contents (C).Next := C + 1;
         end loop;
         T.Contents (T.Contents'Last).Next := 0;
         T.Free := T.Contents'First;
         T.Size := 0;
      end Clear;


      procedure Bind (T : in out Table; I : Items.Item; V : Values.Value) is
         Bucket : constant Positive
           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
         B : Index renames T.Buckets (Bucket);
      begin
         Assert (Location (T, B, I) = 0,
                 BC.Duplicate'Identity,
                 "Bind",
                 BSE.Duplicate);
         Assert (T.Size < T.Maximum_Size,
                 BC.Overflow'Identity,
                 "Bind",
                 BSE.Full);
         declare
            C : Cell renames T.Contents (T.Free);
            Next : constant Index := C.Next;
         begin
            C := (Item => I,
                  Value => V,
                  Next => B);
            B := T.Free;
            T.Free := Next;
         end;
         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 T.Number_Of_Buckets) + 1;
         C : constant Index := Location (T, T.Buckets (Bucket), I);
      begin
         Assert (C /= 0,
                 BC.Not_Found'Identity,
                 "Rebind",
                 BSE.Missing);
         T.Contents (C).Value := V;
      end Rebind;


      procedure Unbind (T : in out Table; I : Items.Item) is
         Bucket : constant Positive
           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
         Current : Index := T.Buckets (Bucket);
         Previous : Index := 0;
      begin
         loop
            exit when Current = 0;
            exit when Items.Eq (T.Contents (Current).Item, I);
            Previous := Current;
            Current := T.Contents (Current).Next;
         end loop;
         Assert (Current /= 0,
                 BC.Not_Found'Identity,
                 "Unbind",
                 BSE.Missing);
         if Previous = 0 then
            T.Buckets (Bucket) := T.Contents (Current).Next;
         else
            T.Contents (Previous).Next := T.Contents (Current).Next;
         end if;
         T.Contents (Current).Next := T.Free;
         T.Free := Current;
         T.Size := T.Size - 1;
      end Unbind;


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


      function Bucket_Extent
        (T : Table; Bucket : Bucket_Index) return Natural is
         Current : Index := T.Buckets (Bucket);
         Result : Natural := 0;
      begin
         while Current /= 0 loop
            Result := Result + 1;
            Current := T.Contents (Current).Next;
         end loop;
         return Result;
      end Bucket_Extent;


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


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


      --  We can't take 'Access of non-aliased components. But if we
      --  alias discriminated objects they become constrained - even
      --  if the discriminant has a default.
      package Allow_Item_Access
      is new System.Address_To_Access_Conversions (Items.Item);

      function Access_Item_At (T : Table; Position : Cell_Index)
                              return Items.Item_Ptr is
      begin
         return Items.Item_Ptr
           (Allow_Item_Access.To_Pointer
              (T.Contents (Position).Item'Address));
      end Access_Item_At;


      --  We can't take 'Access of non-aliased components. But if we
      --  alias discriminated objects they become constrained - even
      --  if the discriminant has a default.
      package Allow_Value_Access
      is new System.Address_To_Access_Conversions (Values.Value);

      function Access_Value_At (T : Table; Position : Cell_Index)
                               return Values.Value_Ptr is
      begin
         return Values.Value_Ptr
           (Allow_Value_Access.To_Pointer
              (T.Contents (Position).Value'Address));
      end Access_Value_At;


      procedure Reset (T : Table;
                       Bucket : out Positive;
                       Index : out Positive) is
      begin
         if T.Size = 0 then
            Bucket := T.Number_Of_Buckets + 1;
            Index := Positive'Last;         --  we have to ensure it's > 0
         else
            Bucket := 1;
            loop
               exit when Bucket > T.Number_Of_Buckets;
               if T.Buckets (Bucket) > 0 then
                  Index := T.Buckets (Bucket);
                  return;
               end if;
               Bucket := Bucket + 1;
            end loop;
            Ada.Exceptions.Raise_Exception
              (Program_Error'Identity,
               "BC.Support.Bounded_Hash_Tables.Reset: no items found");
         end if;
      end Reset;


      function Is_Done (T : Table;
                        Bucket : Positive;
                        Index : Positive) return Boolean is
         pragma Warnings (Off, Index);
      begin
         return Bucket > T.Number_Of_Buckets;
      end Is_Done;


      function Current_Item_Ptr (T : Table;
                                 Bucket : Positive;
                                 Index : Positive) return Items.Item_Ptr is
      begin
         Assert (Bucket <= T.Number_Of_Buckets,
                 BC.Not_Found'Identity,
                 "Current_Item_Ptr",
                 BSE.Missing);
         return Items.Item_Ptr
           (Allow_Item_Access.To_Pointer
            (T.Contents (Index).Item'Address));
      end Current_Item_Ptr;


      function Current_Value_Ptr (T : Table;
                                  Bucket : Positive;
                                  Index : Positive) return Values.Value_Ptr is
      begin
         Assert (Bucket <= T.Number_Of_Buckets,
                 BC.Not_Found'Identity,
                 "Current_Value_Ptr",
                 BSE.Missing);
         return Values.Value_Ptr
           (Allow_Value_Access.To_Pointer
            (T.Contents (Index).Value'Address));
      end Current_Value_Ptr;


      procedure Delete_Item_At (T : in out Table;
                                Bucket : in out Positive;
                                Index : in out  Positive) is
         Next : Tables.Index;
         Previous : Tables.Index;
      begin
         Assert (Bucket <= T.Number_Of_Buckets,
                 BC.Not_Found'Identity,
                 "Delete_Item_At",
                 BSE.Missing);
         Next := T.Contents (Index).Next;
         Previous := T.Buckets (Bucket);
         if Previous = Index then
            --  This is the first cell
            T.Buckets (Bucket) := Next;
         else
            --  We have to find the previous Contents cell
            while T.Contents (Previous).Next /= Index loop
               Previous := T.Contents (Previous).Next;
            end loop;
            T.Contents (Previous).Next := Next;
         end if;
         --  Put the released cell on the free list
         T.Contents (Index).Next := T.Free;
         T.Free := Index;
         T.Size := T.Size - 1;
         --  Adjust Index
         if Next = 0 then
            --  That was the last cell in this bucket, on to the next
            loop
               Bucket := Bucket + 1;
               exit when Bucket > T.Number_Of_Buckets;  --  we've done
               if T.Buckets (Bucket) > 0 then
                  Index := T.Buckets (Bucket);
                  exit;
               end if;
            end loop;
         else
            Index := Next;
         end if;
      end Delete_Item_At;


      procedure Next (T : Table;
                      Bucket : in out Positive;
                      Index : in out  Positive) is
      begin
         Assert (Bucket <= T.Number_Of_Buckets,
                 BC.Not_Found'Identity,
                 "Next",
                 BSE.Missing);
         if T.Contents (Index).Next > 0 then
            Index := T.Contents (Index).Next;
         else
            loop
               Bucket := Bucket + 1;
               exit when Bucket > T.Number_Of_Buckets;
               if T.Buckets (Bucket) > 0 then
                  Index := T.Buckets (Bucket);
                  exit;
               end if;
            end loop;
         end if;
      end Next;


   end Tables;


end BC.Support.Bounded_Hash_Tables;