New Language: Ada

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

1 files changed, 266 insertions, 0 deletions

diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb
new file mode 100644
index 00000000000..086f1de7970
--- /dev/null
+++ b/gcc/ada/g-table.adb
@@ -0,0 +1,266 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUNTIME COMPONENTS                          --
+--                                                                          --
+--                            G N A T .  T A B L E                          --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--            Copyright (C) 1998-2001 Ada Core Technologies, 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.                                      --
+--                                                                          --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with System; use System;
+
+package body GNAT.Table is
+
+   Min : constant Integer := Integer (Table_Low_Bound);
+   --  Subscript of the minimum entry in the currently allocated table
+
+   Max : Integer;
+   --  Subscript of the maximum entry in the currently allocated table
+
+   Length : Integer := 0;
+   --  Number of entries in currently allocated table. The value of zero
+   --  ensures that we initially allocate the table.
+
+   Last_Val : Integer;
+   --  Current value of Last.
+
+   type size_t is new Integer;
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Reallocate;
+   --  Reallocate the existing table according to the current value stored
+   --  in Max. Works correctly to do an initial allocation if the table
+   --  is currently null.
+
+   --------------
+   -- Allocate --
+   --------------
+
+   function Allocate (Num : Integer := 1) return Table_Index_Type is
+      Old_Last : constant Integer := Last_Val;
+
+   begin
+      Last_Val := Last_Val + Num;
+
+      if Last_Val > Max then
+         Reallocate;
+      end if;
+
+      return Table_Index_Type (Old_Last + 1);
+   end Allocate;
+
+   ------------
+   -- Append --
+   ------------
+
+   procedure Append (New_Val : Table_Component_Type) is
+   begin
+      Increment_Last;
+      Table (Table_Index_Type (Last_Val)) := New_Val;
+   end Append;
+
+   --------------------
+   -- Decrement_Last --
+   --------------------
+
+   procedure Decrement_Last is
+   begin
+      Last_Val := Last_Val - 1;
+   end Decrement_Last;
+
+   ----------
+   -- Free --
+   ----------
+
+   procedure Free is
+      procedure free (T : Table_Ptr);
+      pragma Import (C, free);
+
+   begin
+      free (Table);
+      Table := null;
+      Length := 0;
+   end Free;
+
+   --------------------
+   -- Increment_Last --
+   --------------------
+
+   procedure Increment_Last is
+   begin
+      Last_Val := Last_Val + 1;
+
+      if Last_Val > Max then
+         Reallocate;
+      end if;
+   end Increment_Last;
+
+   ----------
+   -- Init --
+   ----------
+
+   procedure Init is
+      Old_Length : Integer := Length;
+
+   begin
+      Last_Val := Min - 1;
+      Max      := Min + Table_Initial - 1;
+      Length   := Max - Min + 1;
+
+      --  If table is same size as before (happens when table is never
+      --  expanded which is a common case), then simply reuse it. Note
+      --  that this also means that an explicit Init call right after
+      --  the implicit one in the package body is harmless.
+
+      if Old_Length = Length then
+         return;
+
+      --  Otherwise we can use Reallocate to get a table of the right size.
+      --  Note that Reallocate works fine to allocate a table of the right
+      --  initial size when it is first allocated.
+
+      else
+         Reallocate;
+      end if;
+   end Init;
+
+   ----------
+   -- Last --
+   ----------
+
+   function Last return Table_Index_Type is
+   begin
+      return Table_Index_Type (Last_Val);
+   end Last;
+
+   ----------------
+   -- Reallocate --
+   ----------------
+
+   procedure Reallocate is
+
+      function realloc
+        (memblock : Table_Ptr;
+         size     : size_t)
+         return     Table_Ptr;
+      pragma Import (C, realloc);
+
+      function malloc
+        (size     : size_t)
+         return     Table_Ptr;
+      pragma Import (C, malloc);
+
+      New_Size : size_t;
+
+   begin
+      if Max < Last_Val then
+         pragma Assert (not Locked);
+
+         while Max < Last_Val loop
+
+            --  Increase length using the table increment factor, but make
+            --  sure that we add at least ten elements (this avoids a loop
+            --  for silly small increment values)
+
+            Length := Integer'Max
+                        (Length * (100 + Table_Increment) / 100,
+                         Length + 10);
+            Max := Min + Length - 1;
+         end loop;
+      end if;
+
+      New_Size :=
+        size_t ((Max - Min + 1) *
+                (Table_Type'Component_Size / Storage_Unit));
+
+      if Table = null then
+         Table := malloc (New_Size);
+
+      elsif New_Size > 0 then
+         Table :=
+           realloc
+             (memblock => Table,
+              size     => New_Size);
+      end if;
+
+      if Length /= 0 and then Table = null then
+         raise Storage_Error;
+      end if;
+
+   end Reallocate;
+
+   -------------
+   -- Release --
+   -------------
+
+   procedure Release is
+   begin
+      Length := Last_Val - Integer (Table_Low_Bound) + 1;
+      Max    := Last_Val;
+      Reallocate;
+   end Release;
+
+   --------------
+   -- Set_Item --
+   --------------
+
+   procedure Set_Item
+     (Index : Table_Index_Type;
+      Item  : Table_Component_Type)
+   is
+   begin
+      if Integer (Index) > Max then
+         Set_Last (Index);
+      end if;
+
+      Table (Index) := Item;
+   end Set_Item;
+
+   --------------
+   -- Set_Last --
+   --------------
+
+   procedure Set_Last (New_Val : Table_Index_Type) is
+   begin
+      if Integer (New_Val) < Last_Val then
+         Last_Val := Integer (New_Val);
+      else
+         Last_Val := Integer (New_Val);
+
+         if Last_Val > Max then
+            Reallocate;
+         end if;
+      end if;
+   end Set_Last;
+
+begin
+   Init;
+end GNAT.Table;