* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,

	a-crbtgk.adb, a-crbltr.ads, a-coprnu.ads, a-coprnu.adb,
	a-coorse.ads, a-coorse.adb, a-convec.ads, a-convec.adb,
	a-contai.ads, a-coinve.ads, a-coinve.adb, a-cohata.ads,
	a-cohama.ads, a-cohama.adb, a-ciorse.ads, a-ciorse.adb,
	a-cihama.ads, a-cihama.adb, a-cidlli.ads, a-cidlli.adb,
	a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, a-cgcaso.adb,
	a-cgarso.ads, a-cgarso.adb, a-cdlili.ads, a-cdlili.adb,
	a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb,
	a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads,
	a-coorma.ads, a-swunha.ads, a-stunha.ads, a-ciormu.ads,
	a-coormu.ads, a-rbtgso.ads, a-swunha.adb, a-stunha.adb,
	a-cgaaso.ads, a-ciorma.adb, a-coorma.adb, a-secain.adb,
	a-secain.ads, a-slcain.ads, a-slcain.adb, a-shcain.ads,
	a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads,
	a-stwiha.adb, a-strhas.ads, a-strhas.adb, a-chzla1.ads,
	a-chzla9.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads,
	a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads,
	a-stzbou.adb, a-stzbou.ads, a-stzfix.adb, a-stzfix.ads,
	a-stzhas.adb, a-stzhas.ads, a-stzmap.adb, a-stzmap.ads,
	a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads,
	a-stzunb.adb, a-stzunb.ads, a-swunau.adb, a-swunau.ads,
	a-szmzco.ads, a-szunau.adb, a-szunau.ads, a-szunha.adb,
	a-szunha.ads, a-szuzti.adb, a-szuzti.ads, a-tiunio.ads,
	a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb,
	a-ztcoio.ads, a-ztcstr.adb, a-ztcstr.ads, a-ztdeau.adb,
	a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb,
	a-ztedit.ads, a-ztenau.adb, a-ztenau.ads, a-ztenio.adb,
	a-ztenio.ads, a-ztexio.adb, a-ztexio.ads, a-ztfiio.adb,
	a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, a-ztflio.adb,
	a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb,
	a-ztinau.ads, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb,
	a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, a-zttest.adb,
	a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005
	library.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94764 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 701 insertions, 0 deletions

diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb
new file mode 100644
index 00000000000..aa27f427c2e
--- /dev/null
+++ b/gcc/ada/a-chtgop.adb
@@ -0,0 +1,701 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--              ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2004 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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 GNAT;  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.                                      --
+--                                                                          --
+-- This unit was originally developed by Matthew J Heaney.                  --
+------------------------------------------------------------------------------
+
+--  This body needs commenting ???
+
+with Ada.Containers.Prime_Numbers;
+with Ada.Unchecked_Deallocation;
+
+with System;  use type System.Address;
+
+package body Ada.Containers.Hash_Tables.Generic_Operations is
+
+   procedure Free is
+     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Rehash
+     (HT   : in out Hash_Table_Type;
+      Size : Hash_Type);
+
+   ------------
+   -- Adjust --
+   ------------
+
+   procedure Adjust (HT : in out Hash_Table_Type) is
+      Src_Buckets : constant Buckets_Access := HT.Buckets;
+      N           : constant Count_Type := HT.Length;
+      Src_Node    : Node_Access;
+      Dst_Prev    : Node_Access;
+
+   begin
+      HT.Buckets := null;
+      HT.Length := 0;
+
+      if N = 0 then
+         return;
+      end if;
+
+      HT.Buckets := new Buckets_Type (Src_Buckets'Range);
+
+      --  Probably we have to duplicate the Size (Src), too, in order
+      --  to guarantee that
+
+      --    Dst := Src;
+      --    Dst = Src is true
+
+      --  The only quirk is that we depend on the hash value of a dst key
+      --  to be the same as the src key from which it was copied.
+      --  If we relax the requirement that the hash value must be the
+      --  same, then of course we can't guarantee that following
+      --  assignment that Dst = Src is true ???
+
+      for Src_Index in Src_Buckets'Range loop
+         Src_Node := Src_Buckets (Src_Index);
+
+         if Src_Node /= Null_Node then
+            declare
+               Dst_Node : constant Node_Access := Copy_Node (Src_Node);
+
+               --   See note above
+
+               pragma Assert (Index (HT, Dst_Node) = Src_Index);
+
+            begin
+               HT.Buckets (Src_Index) := Dst_Node;
+               HT.Length := HT.Length + 1;
+
+               Dst_Prev := Dst_Node;
+            end;
+
+            Src_Node := Next (Src_Node);
+            while Src_Node /= Null_Node loop
+               declare
+                  Dst_Node : constant Node_Access := Copy_Node (Src_Node);
+
+                  --  See note above
+
+                  pragma Assert (Index (HT, Dst_Node) = Src_Index);
+
+               begin
+                  Set_Next (Node => Dst_Prev, Next => Dst_Node);
+                  HT.Length := HT.Length + 1;
+
+                  Dst_Prev := Dst_Node;
+               end;
+
+               Src_Node := Next (Src_Node);
+            end loop;
+         end if;
+      end loop;
+
+      pragma Assert (HT.Length = N);
+   end Adjust;
+
+   --------------
+   -- Capacity --
+   --------------
+
+   function Capacity (HT : Hash_Table_Type) return Count_Type is
+   begin
+      if HT.Buckets = null then
+         return 0;
+      end if;
+
+      return HT.Buckets'Length;
+   end Capacity;
+
+   -----------
+   -- Clear --
+   -----------
+
+   procedure Clear (HT : in out Hash_Table_Type) is
+      Index : Hash_Type := 0;
+      Node  : Node_Access;
+
+   begin
+      while HT.Length > 0 loop
+         while HT.Buckets (Index) = Null_Node loop
+            Index := Index + 1;
+         end loop;
+
+         declare
+            Bucket : Node_Access renames HT.Buckets (Index);
+         begin
+            loop
+               Node := Bucket;
+               Bucket := Next (Bucket);
+               HT.Length := HT.Length - 1;
+               Free (Node);
+               exit when Bucket = Null_Node;
+            end loop;
+         end;
+      end loop;
+   end Clear;
+
+   ---------------------------
+   -- Delete_Node_Sans_Free --
+   ---------------------------
+
+   procedure Delete_Node_Sans_Free
+     (HT : in out Hash_Table_Type;
+      X  : Node_Access)
+   is
+      pragma Assert (X /= Null_Node);
+
+      Indx : Hash_Type;
+      Prev : Node_Access;
+      Curr : Node_Access;
+
+   begin
+      if HT.Length = 0 then
+         raise Program_Error;
+      end if;
+
+      Indx := Index (HT, X);
+      Prev := HT.Buckets (Indx);
+
+      if Prev = Null_Node then
+         raise Program_Error;
+      end if;
+
+      if Prev = X then
+         HT.Buckets (Indx) := Next (Prev);
+         HT.Length := HT.Length - 1;
+         return;
+      end if;
+
+      if HT.Length = 1 then
+         raise Program_Error;
+      end if;
+
+      loop
+         Curr := Next (Prev);
+
+         if Curr = Null_Node then
+            raise Program_Error;
+         end if;
+
+         if Curr = X then
+            Set_Next (Node => Prev, Next => Next (Curr));
+            HT.Length := HT.Length - 1;
+            return;
+         end if;
+
+         Prev := Curr;
+      end loop;
+   end Delete_Node_Sans_Free;
+
+   ---------------------
+   -- Ensure_Capacity --
+   ---------------------
+
+   procedure Ensure_Capacity
+     (HT : in out Hash_Table_Type;
+      N  : Count_Type)
+   is
+      NN : Hash_Type;
+
+   begin
+      if N = 0 then
+         if HT.Length = 0 then
+            Free (HT.Buckets);
+
+         elsif HT.Length < HT.Buckets'Length then
+            NN := Prime_Numbers.To_Prime (HT.Length);
+
+            --  ASSERT: NN >= HT.Length
+
+            if NN < HT.Buckets'Length then
+               Rehash (HT, Size => NN);
+            end if;
+         end if;
+
+         return;
+      end if;
+
+      if HT.Buckets = null then
+         NN := Prime_Numbers.To_Prime (N);
+
+         --  ASSERT: NN >= N
+
+         Rehash (HT, Size => NN);
+         return;
+      end if;
+
+      if N <= HT.Length then
+         if HT.Length >= HT.Buckets'Length then
+            return;
+         end if;
+
+         NN := Prime_Numbers.To_Prime (HT.Length);
+
+         --  ASSERT: NN >= HT.Length
+
+         if NN < HT.Buckets'Length then
+            Rehash (HT, Size => NN);
+         end if;
+
+         return;
+      end if;
+
+      --  ASSERT: N > HT.Length
+
+      if N = HT.Buckets'Length then
+         return;
+      end if;
+
+      NN := Prime_Numbers.To_Prime (N);
+
+      --  ASSERT: NN >= N
+      --  ASSERT: NN > HT.Length
+
+      if NN /= HT.Buckets'Length then
+         Rehash (HT, Size => NN);
+      end if;
+   end Ensure_Capacity;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   procedure Finalize (HT : in out Hash_Table_Type) is
+   begin
+      Clear (HT);
+      Free (HT.Buckets);
+   end Finalize;
+
+   -----------
+   -- First --
+   -----------
+
+   function First (HT : Hash_Table_Type) return Node_Access is
+      Indx : Hash_Type;
+
+   begin
+      if HT.Length = 0 then
+         return Null_Node;
+      end if;
+
+      Indx := HT.Buckets'First;
+      loop
+         if HT.Buckets (Indx) /= Null_Node then
+            return HT.Buckets (Indx);
+         end if;
+
+         Indx := Indx + 1;
+      end loop;
+   end First;
+
+   ---------------------
+   -- Free_Hash_Table --
+   ---------------------
+
+   procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
+      Node : Node_Access;
+
+   begin
+      if Buckets = null then
+         return;
+      end if;
+
+      for J in Buckets'Range loop
+         while Buckets (J) /= Null_Node loop
+            Node := Buckets (J);
+            Buckets (J) := Next (Node);
+            Free (Node);
+         end loop;
+      end loop;
+
+      Free (Buckets);
+   end Free_Hash_Table;
+
+   -------------------
+   -- Generic_Equal --
+   -------------------
+
+   function Generic_Equal
+     (L, R : Hash_Table_Type) return Boolean is
+
+      L_Index : Hash_Type;
+      L_Node  : Node_Access;
+
+      N : Count_Type;
+
+   begin
+      if L'Address = R'Address then
+         return True;
+      end if;
+
+      if L.Length /= R.Length then
+         return False;
+      end if;
+
+      if L.Length = 0 then
+         return True;
+      end if;
+
+      L_Index := 0;
+
+      loop
+         L_Node := L.Buckets (L_Index);
+         exit when L_Node /= Null_Node;
+         L_Index := L_Index + 1;
+      end loop;
+
+      N := L.Length;
+
+      loop
+         if not Find (HT => R, Key => L_Node) then
+            return False;
+         end if;
+
+         N := N - 1;
+
+         L_Node := Next (L_Node);
+
+         if L_Node = Null_Node then
+            if N = 0 then
+               return True;
+            end if;
+
+            loop
+               L_Index := L_Index + 1;
+               L_Node := L.Buckets (L_Index);
+               exit when L_Node /= Null_Node;
+            end loop;
+         end if;
+      end loop;
+   end Generic_Equal;
+
+   -----------------------
+   -- Generic_Iteration --
+   -----------------------
+
+   procedure Generic_Iteration (HT : Hash_Table_Type) is
+      Node : Node_Access;
+
+   begin
+      if HT.Buckets = null
+        or else HT.Length = 0
+      then
+         return;
+      end if;
+
+      for Indx in HT.Buckets'Range loop
+         Node := HT.Buckets (Indx);
+         while Node /= Null_Node loop
+            Process (Node);
+            Node := Next (Node);
+         end loop;
+      end loop;
+   end Generic_Iteration;
+
+   ------------------
+   -- Generic_Read --
+   ------------------
+
+   procedure Generic_Read
+     (Stream : access Root_Stream_Type'Class;
+      HT     : out Hash_Table_Type)
+   is
+      X, Y : Node_Access;
+
+      Last, I : Hash_Type;
+      N, M    : Count_Type'Base;
+
+   begin
+      --  As with the sorted set, it's not clear whether read is allowed to
+      --  have side effect if it fails. For now, we assume side effects are
+      --  allowed since it simplifies the algorithm ???
+      --
+      Clear (HT);
+
+      declare
+         B : Buckets_Access := HT.Buckets;
+      begin
+         HT.Buckets := null;
+         HT.Length := 0;
+         Free (B); -- can this fail???
+      end;
+
+      Hash_Type'Read (Stream, Last);
+
+      if Last /= 0 then
+         HT.Buckets := new Buckets_Type (0 .. Last);
+      end if;
+
+      Count_Type'Base'Read (Stream, N);
+      pragma Assert (N >= 0);
+      while N > 0 loop
+         Hash_Type'Read (Stream, I);
+         pragma Assert (I in HT.Buckets'Range);
+         pragma Assert (HT.Buckets (I) = Null_Node);
+
+         Count_Type'Base'Read (Stream, M);
+         pragma Assert (M >= 1);
+         pragma Assert (M <= N);
+
+         HT.Buckets (I) := New_Node (Stream);
+         pragma Assert (HT.Buckets (I) /= Null_Node);
+         pragma Assert (Next (HT.Buckets (I)) = Null_Node);
+
+         Y := HT.Buckets (I);
+
+         HT.Length := HT.Length + 1;
+
+         for J in Count_Type range 2 .. M loop
+            X := New_Node (Stream);
+            pragma Assert (X /= Null_Node);
+            pragma Assert (Next (X) = Null_Node);
+
+            Set_Next (Node => Y, Next => X);
+            Y := X;
+
+            HT.Length := HT.Length + 1;
+         end loop;
+
+         N := N - M;
+      end loop;
+   end Generic_Read;
+
+   -------------------
+   -- Generic_Write --
+   -------------------
+
+   procedure Generic_Write
+     (Stream : access Root_Stream_Type'Class;
+      HT     : Hash_Table_Type)
+   is
+      M : Count_Type'Base;
+      X : Node_Access;
+
+   begin
+      if HT.Buckets = null then
+         Hash_Type'Write (Stream, 0);
+      else
+         Hash_Type'Write (Stream, HT.Buckets'Last);
+      end if;
+
+      Count_Type'Base'Write (Stream, HT.Length);
+
+      if HT.Length = 0 then
+         return;
+      end if;
+
+      for Indx in HT.Buckets'Range loop
+         X := HT.Buckets (Indx);
+
+         if X /= Null_Node then
+            M := 1;
+            loop
+               X := Next (X);
+               exit when X = Null_Node;
+               M := M + 1;
+            end loop;
+
+            Hash_Type'Write (Stream, Indx);
+            Count_Type'Base'Write (Stream, M);
+
+            X := HT.Buckets (Indx);
+            for J in Count_Type range 1 .. M loop
+               Write (Stream, X);
+               X := Next (X);
+            end loop;
+
+            pragma Assert (X = Null_Node);
+         end if;
+      end loop;
+   end Generic_Write;
+
+   -----------
+   -- Index --
+   -----------
+
+   function Index
+     (Buckets : Buckets_Type;
+      Node    : Node_Access) return Hash_Type is
+   begin
+      return Hash_Node (Node) mod Buckets'Length;
+   end Index;
+
+   function Index
+     (Hash_Table : Hash_Table_Type;
+      Node       : Node_Access) return Hash_Type is
+   begin
+      return Index (Hash_Table.Buckets.all, Node);
+   end Index;
+
+   ----------
+   -- Move --
+   ----------
+
+   procedure Move (Target, Source : in out Hash_Table_Type) is
+   begin
+      if Target'Address = Source'Address then
+         return;
+      end if;
+
+      if Target.Length > 0 then
+         raise Constraint_Error;
+      end if;
+
+      Free (Target.Buckets);
+
+      Target.Buckets := Source.Buckets;
+      Source.Buckets := null;
+
+      Target.Length := Source.Length;
+      Source.Length := 0;
+   end Move;
+
+   ----------
+   -- Next --
+   ----------
+
+   function Next
+     (HT   : Hash_Table_Type;
+      Node : Node_Access) return Node_Access
+   is
+      Result : Node_Access := Next (Node);
+
+   begin
+      if Result /= Null_Node then
+         return Result;
+      end if;
+
+      for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
+         Result := HT.Buckets (Indx);
+
+         if Result /= Null_Node then
+            return Result;
+         end if;
+      end loop;
+
+      return Null_Node;
+   end Next;
+
+   ------------
+   -- Rehash --
+   ------------
+
+   procedure Rehash
+     (HT   : in out Hash_Table_Type;
+      Size : Hash_Type)
+   is
+      subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
+
+      Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
+      Src_Buckets : Buckets_Access := HT.Buckets;
+
+      L  : Count_Type renames HT.Length;
+      LL : constant Count_Type := L;
+
+   begin
+      if Src_Buckets = null then
+         pragma Assert (L = 0);
+         HT.Buckets := Dst_Buckets;
+         return;
+      end if;
+
+      if L = 0 then
+         HT.Buckets := Dst_Buckets;
+         Free (Src_Buckets);
+         return;
+      end if;
+
+      --  We might want to change this to iter from 1 .. L instead ???
+
+      for Src_Index in Src_Buckets'Range loop
+
+         declare
+            Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
+         begin
+            while Src_Bucket /= Null_Node loop
+               declare
+                  Src_Node   : constant Node_Access := Src_Bucket;
+                  Dst_Index  : constant Hash_Type :=
+                                 Index (Dst_Buckets.all, Src_Node);
+                  Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
+               begin
+                  Src_Bucket := Next (Src_Node);
+                  Set_Next (Src_Node, Dst_Bucket);
+                  Dst_Bucket := Src_Node;
+               end;
+
+               pragma Assert (L > 0);
+               L := L - 1;
+
+            end loop;
+
+         exception
+            when others =>
+
+               --  Not clear that we can deallocate the nodes,
+               --  because they may be designated by outstanding
+               --  iterators.  Which means they're now lost... ???
+
+               --                 for J in NB'Range loop
+               --                    declare
+               --                       Dst : Node_Access renames NB (J);
+               --                       X   : Node_Access;
+               --                    begin
+               --                       while Dst /= Null_Node loop
+               --                          X := Dst;
+               --                          Dst := Succ (Dst);
+               --                          Free (X);
+               --                       end loop;
+               --                    end;
+               --                 end loop;
+
+
+               Free (Dst_Buckets);
+               raise;
+         end;
+
+         --  exit when L = 0;
+         --  need to bother???
+
+      end loop;
+
+      pragma Assert (L = 0);
+
+      HT.Buckets := Dst_Buckets;
+      HT.Length := LL;
+
+      Free (Src_Buckets);
+   end Rehash;
+
+end Ada.Containers.Hash_Tables.Generic_Operations;
+