New Language: Ada

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

1 files changed, 758 insertions, 0 deletions

diff --git a/gcc/ada/a-stwima.adb b/gcc/ada/a-stwima.adb
new file mode 100644
index 00000000000..f552f1d72da
--- /dev/null
+++ b/gcc/ada/a-stwima.adb
@@ -0,0 +1,758 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUNTIME COMPONENTS                          --
+--                                                                          --
+--                A D A . S T R I N G S . W I D E _ M A P S                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.18 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Maps is
+
+   ---------
+   -- "-" --
+   ---------
+
+   function "-"
+     (Left, Right : in Wide_Character_Set)
+      return        Wide_Character_Set
+   is
+      LS : constant Wide_Character_Ranges_Access := Left.Set;
+      RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+      Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+      --  Each range on the right can generate at least one more range in
+      --  the result, by splitting one of the left operand ranges.
+
+      N  : Natural := 0;
+      R  : Natural := 1;
+      L  : Natural := 1;
+
+      Left_Low : Wide_Character;
+      --  Left_Low is lowest character of the L'th range not yet dealt with
+
+   begin
+      if LS'Last = 0 or else RS'Last = 0 then
+         return Left;
+      end if;
+
+      Left_Low := LS (L).Low;
+      while R <= RS'Last loop
+
+         --  If next right range is below current left range, skip it
+
+         if RS (R).High < Left_Low then
+            R := R + 1;
+
+         --  If next right range above current left range, copy remainder
+         --  of the left range to the result
+
+         elsif RS (R).Low > LS (L).High then
+            N := N + 1;
+            Result (N).Low  := Left_Low;
+            Result (N).High := LS (L).High;
+            L := L + 1;
+            exit when L > LS'Last;
+            Left_Low := LS (L).Low;
+
+         else
+            --  Next right range overlaps bottom of left range
+
+            if RS (R).Low <= Left_Low then
+
+               --  Case of right range complete overlaps left range
+
+               if RS (R).High >= LS (L).High then
+                  L := L + 1;
+                  exit when L > LS'Last;
+                  Left_Low := LS (L).Low;
+
+               --  Case of right range eats lower part of left range
+
+               else
+                  Left_Low := Wide_Character'Succ (RS (R).High);
+                  R := R + 1;
+               end if;
+
+            --  Next right range overlaps some of left range, but not bottom
+
+            else
+               N := N + 1;
+               Result (N).Low  := Left_Low;
+               Result (N).High := Wide_Character'Pred (RS (R).Low);
+
+               --  Case of right range splits left range
+
+               if RS (R).High < LS (L).High then
+                  Left_Low := Wide_Character'Succ (RS (R).High);
+                  R := R + 1;
+
+               --  Case of right range overlaps top of left range
+
+               else
+                  L := L + 1;
+                  exit when L > LS'Last;
+                  Left_Low := LS (L).Low;
+               end if;
+            end if;
+         end if;
+      end loop;
+
+      --  Copy remainder of left ranges to result
+
+      if L <= LS'Last then
+         N := N + 1;
+         Result (N).Low  := Left_Low;
+         Result (N).High := LS (L).High;
+
+         loop
+            L := L + 1;
+            exit when L > LS'Last;
+            N := N + 1;
+            Result (N) := LS (L);
+         end loop;
+      end if;
+
+      return (AF.Controlled with
+              Set => new Wide_Character_Ranges'(Result (1 .. N)));
+   end "-";
+
+   ---------
+   -- "=" --
+   ---------
+
+   --  The sorted, discontiguous form is canonical, so equality can be used
+
+   function "=" (Left, Right : in Wide_Character_Set) return Boolean is
+   begin
+      return Left.Set.all = Right.Set.all;
+   end "=";
+
+   -----------
+   -- "and" --
+   -----------
+
+   function "and"
+     (Left, Right : in Wide_Character_Set)
+      return        Wide_Character_Set
+   is
+      LS : constant Wide_Character_Ranges_Access := Left.Set;
+      RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+      Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+      N      : Natural := 0;
+      L, R   : Natural := 1;
+
+   begin
+      --  Loop to search for overlapping character ranges
+
+      while L <= LS'Last and then R <= RS'Last loop
+
+         if LS (L).High < RS (R).Low then
+            L := L + 1;
+
+         elsif RS (R).High < LS (L).Low then
+            R := R + 1;
+
+         --  Here we have LS (L).High >= RS (R).Low
+         --           and RS (R).High >= LS (L).Low
+         --  so we have an overlapping range
+
+         else
+            N := N + 1;
+            Result (N).Low := Wide_Character'Max (LS (L).Low,  RS (R).Low);
+            Result (N).High :=
+              Wide_Character'Min (LS (L).High, RS (R).High);
+
+            if RS (R).High = LS (L).High then
+               L := L + 1;
+               R := R + 1;
+            elsif RS (R).High < LS (L).High then
+               R := R + 1;
+            else
+               L := L + 1;
+            end if;
+         end if;
+      end loop;
+
+      return (AF.Controlled with
+              Set       => new Wide_Character_Ranges'(Result (1 .. N)));
+   end "and";
+
+   -----------
+   -- "not" --
+   -----------
+
+   function "not"
+     (Right  : in Wide_Character_Set)
+      return Wide_Character_Set
+   is
+      RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+      Result : Wide_Character_Ranges (1 .. RS'Last + 1);
+      N      : Natural := 0;
+
+   begin
+      if RS'Last = 0 then
+         N := 1;
+         Result (1) := (Low  => Wide_Character'First,
+                        High => Wide_Character'Last);
+
+      else
+         if RS (1).Low /= Wide_Character'First then
+            N := N + 1;
+            Result (N).Low  := Wide_Character'First;
+            Result (N).High := Wide_Character'Pred (RS (1).Low);
+         end if;
+
+         for K in 1 .. RS'Last - 1 loop
+            N := N + 1;
+            Result (N).Low  := Wide_Character'Succ (RS (K).High);
+            Result (N).High := Wide_Character'Pred (RS (K + 1).Low);
+         end loop;
+
+         if RS (RS'Last).High /= Wide_Character'Last then
+            N := N + 1;
+            Result (N).Low  := Wide_Character'Succ (RS (RS'Last).High);
+            Result (N).High := Wide_Character'Last;
+         end if;
+      end if;
+
+      return (AF.Controlled with
+              Set => new Wide_Character_Ranges'(Result (1 .. N)));
+   end "not";
+
+   ----------
+   -- "or" --
+   ----------
+
+   function "or"
+     (Left, Right : in Wide_Character_Set)
+      return        Wide_Character_Set
+   is
+      LS : constant Wide_Character_Ranges_Access := Left.Set;
+      RS : constant Wide_Character_Ranges_Access := Right.Set;
+
+      Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
+      N      : Natural;
+      L, R   : Natural;
+
+   begin
+      N := 0;
+      L := 1;
+      R := 1;
+
+      --  Loop through ranges in output file
+
+      loop
+         --  If no left ranges left, copy next right range
+
+         if L > LS'Last then
+            exit when R > RS'Last;
+            N := N + 1;
+            Result (N) := RS (R);
+            R := R + 1;
+
+         --  If no right ranges left, copy next left range
+
+         elsif R > RS'Last then
+            N := N + 1;
+            Result (N) := LS (L);
+            L := L + 1;
+
+         else
+            --  We have two ranges, choose lower one
+
+            N := N + 1;
+
+            if LS (L).Low <= RS (R).Low then
+               Result (N) := LS (L);
+               L := L + 1;
+            else
+               Result (N) := RS (R);
+               R := R + 1;
+            end if;
+
+            --  Loop to collapse ranges into last range
+
+            loop
+               --  Collapse next length range into current result range
+               --  if possible.
+
+               if L <= LS'Last
+                 and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
+               then
+                  Result (N).High :=
+                    Wide_Character'Max (Result (N).High, LS (L).High);
+                  L := L + 1;
+
+               --  Collapse next right range into current result range
+               --  if possible
+
+               elsif R <= RS'Last
+                 and then RS (R).Low <=
+                            Wide_Character'Succ (Result (N).High)
+               then
+                  Result (N).High :=
+                    Wide_Character'Max (Result (N).High, RS (R).High);
+                  R := R + 1;
+
+               --  If neither range collapses, then done with this range
+
+               else
+                  exit;
+               end if;
+            end loop;
+         end if;
+      end loop;
+
+      return (AF.Controlled with
+              Set => new Wide_Character_Ranges'(Result (1 .. N)));
+   end "or";
+
+   -----------
+   -- "xor" --
+   -----------
+
+   function "xor"
+     (Left, Right : in Wide_Character_Set)
+      return        Wide_Character_Set
+   is
+   begin
+      return (Left or Right) - (Left and Right);
+   end "xor";
+
+   ------------
+   -- Adjust --
+   ------------
+
+   procedure Adjust (Object : in out Wide_Character_Mapping) is
+   begin
+      Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all);
+   end Adjust;
+
+   procedure Adjust (Object : in out Wide_Character_Set) is
+   begin
+      Object.Set := new Wide_Character_Ranges'(Object.Set.all);
+   end Adjust;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   procedure Finalize (Object : in out Wide_Character_Mapping) is
+
+      procedure Free is new Unchecked_Deallocation
+        (Wide_Character_Mapping_Values,
+         Wide_Character_Mapping_Values_Access);
+
+   begin
+      if Object.Map /=  Null_Map'Unrestricted_Access then
+         Free (Object.Map);
+      end if;
+   end Finalize;
+
+   procedure Finalize (Object : in out Wide_Character_Set) is
+
+      procedure Free is new Unchecked_Deallocation
+        (Wide_Character_Ranges,
+         Wide_Character_Ranges_Access);
+
+   begin
+      if Object.Set /= Null_Range'Unrestricted_Access then
+         Free (Object.Set);
+      end if;
+   end Finalize;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize (Object : in out Wide_Character_Mapping) is
+   begin
+      Object := Identity;
+   end Initialize;
+
+   procedure Initialize (Object : in out Wide_Character_Set) is
+   begin
+      Object := Null_Set;
+   end Initialize;
+
+   -----------
+   -- Is_In --
+   -----------
+
+   function Is_In
+     (Element : in Wide_Character;
+      Set     : in Wide_Character_Set)
+      return    Boolean
+   is
+      L, R, M : Natural;
+      SS      : constant Wide_Character_Ranges_Access := Set.Set;
+
+   begin
+      L := 1;
+      R := SS'Last;
+
+      --  Binary search loop. The invariant is that if Element is in any of
+      --  of the constituent ranges it is in one between Set (L) and Set (R).
+
+      loop
+         if L > R then
+            return False;
+
+         else
+            M := (L + R) / 2;
+
+            if Element > SS (M).High then
+               L := M + 1;
+            elsif Element < SS (M).Low then
+               R := M - 1;
+            else
+               return True;
+            end if;
+         end if;
+      end loop;
+   end Is_In;
+
+   ---------------
+   -- Is_Subset --
+   ---------------
+
+   function Is_Subset
+     (Elements : in Wide_Character_Set;
+      Set      : in Wide_Character_Set)
+      return     Boolean
+   is
+      ES : constant Wide_Character_Ranges_Access := Elements.Set;
+      SS : constant Wide_Character_Ranges_Access := Set.Set;
+
+      S  : Positive := 1;
+      E  : Positive := 1;
+
+   begin
+      loop
+         --  If no more element ranges, done, and result is true
+
+         if E > ES'Last then
+            return True;
+
+         --  If more element ranges, but no more set ranges, result is false
+
+         elsif S > SS'Last then
+            return False;
+
+         --  Remove irrelevant set range
+
+         elsif SS (S).High < ES (E).Low then
+            S := S + 1;
+
+         --  Get rid of element range that is properly covered by set
+
+         elsif SS (S).Low <= ES (E).Low
+            and then ES (E).High <= SS (S).High
+         then
+            E := E + 1;
+
+         --  Otherwise we have a non-covered element range, result is false
+
+         else
+            return False;
+         end if;
+      end loop;
+   end Is_Subset;
+
+   ---------------
+   -- To_Domain --
+   ---------------
+
+   function To_Domain
+     (Map  : in Wide_Character_Mapping)
+      return Wide_Character_Sequence
+   is
+   begin
+      return Map.Map.Domain;
+   end To_Domain;
+
+   ----------------
+   -- To_Mapping --
+   ----------------
+
+   function To_Mapping
+     (From, To : in Wide_Character_Sequence)
+      return     Wide_Character_Mapping
+   is
+      Domain : Wide_Character_Sequence (1 .. From'Length);
+      Rangev : Wide_Character_Sequence (1 .. To'Length);
+      N      : Natural := 0;
+
+   begin
+      if From'Length /= To'Length then
+         raise Translation_Error;
+
+      else
+         pragma Warnings (Off); -- apparent uninit use of Domain
+
+         for J in From'Range loop
+            for M in 1 .. N loop
+               if From (J) = Domain (M) then
+                  raise Translation_Error;
+               elsif From (J) < Domain (M) then
+                  Domain (M + 1 .. N + 1) := Domain (M .. N);
+                  Rangev (M + 1 .. N + 1) := Rangev (M .. N);
+                  Domain (M) := From (J);
+                  Rangev (M) := To   (J);
+                  goto Continue;
+               end if;
+            end loop;
+
+            Domain (N + 1) := From (J);
+            Rangev (N + 1) := To   (J);
+
+            <<Continue>>
+               N := N + 1;
+         end loop;
+
+         pragma Warnings (On);
+
+         return (AF.Controlled with
+                 Map => new Wide_Character_Mapping_Values'(
+                          Length => N,
+                          Domain => Domain (1 .. N),
+                          Rangev => Rangev (1 .. N)));
+      end if;
+   end To_Mapping;
+
+   --------------
+   -- To_Range --
+   --------------
+
+   function To_Range
+     (Map  : in Wide_Character_Mapping)
+      return Wide_Character_Sequence
+   is
+   begin
+      return Map.Map.Rangev;
+   end To_Range;
+
+   ---------------
+   -- To_Ranges --
+   ---------------
+
+   function To_Ranges
+     (Set :  in Wide_Character_Set)
+      return Wide_Character_Ranges
+   is
+   begin
+      return Set.Set.all;
+   end To_Ranges;
+
+   -----------------
+   -- To_Sequence --
+   -----------------
+
+   function To_Sequence
+     (Set  : in Wide_Character_Set)
+      return Wide_Character_Sequence
+   is
+      SS : constant Wide_Character_Ranges_Access := Set.Set;
+
+      Result : Wide_String (Positive range 1 .. 2 ** 16);
+      N      : Natural := 0;
+
+   begin
+      for J in SS'Range loop
+         for K in SS (J).Low .. SS (J).High loop
+            N := N + 1;
+            Result (N) := K;
+         end loop;
+      end loop;
+
+      return Result (1 .. N);
+   end To_Sequence;
+
+   ------------
+   -- To_Set --
+   ------------
+
+   --  Case of multiple range input
+
+   function To_Set
+     (Ranges : in Wide_Character_Ranges)
+      return   Wide_Character_Set
+   is
+      Result : Wide_Character_Ranges (Ranges'Range);
+      N      : Natural := 0;
+      J      : Natural;
+
+   begin
+      --  The output of To_Set is required to be sorted by increasing Low
+      --  values, and discontiguous, so first we sort them as we enter them,
+      --  using a simple insertion sort.
+
+      pragma Warnings (Off);
+      --  Kill bogus warning on Result being uninitialized
+
+      for J in Ranges'Range loop
+         for K in 1 .. N loop
+            if Ranges (J).Low < Result (K).Low then
+               Result (K + 1 .. N + 1) := Result (K .. N);
+               Result (K) := Ranges (J);
+               goto Continue;
+            end if;
+         end loop;
+
+         Result (N + 1) := Ranges (J);
+
+         <<Continue>>
+            N := N + 1;
+      end loop;
+
+      pragma Warnings (On);
+
+      --  Now collapse any contiguous or overlapping ranges
+
+      J := 1;
+      while J < N loop
+         if Result (J).High < Result (J).Low then
+            N := N - 1;
+            Result (J .. N) := Result (J + 1 .. N + 1);
+
+         elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then
+            Result (J).High :=
+              Wide_Character'Max (Result (J).High, Result (J + 1).High);
+
+            N := N - 1;
+            Result (J + 1 .. N) := Result (J + 2 .. N + 1);
+
+         else
+            J := J + 1;
+         end if;
+      end loop;
+
+      if Result (N).High < Result (N).Low then
+         N := N - 1;
+      end if;
+
+      return (AF.Controlled with
+              Set => new Wide_Character_Ranges'(Result (1 .. N)));
+   end To_Set;
+
+   --  Case of single range input
+
+   function To_Set
+     (Span : in Wide_Character_Range)
+      return Wide_Character_Set
+   is
+   begin
+      if Span.Low > Span.High then
+         return Null_Set;
+         --  This is safe, because there is no procedure with parameter
+         --  Wide_Character_Set of mode "out" or "in out".
+
+      else
+         return (AF.Controlled with
+                 Set => new Wide_Character_Ranges'(1 => Span));
+      end if;
+   end To_Set;
+
+   --  Case of wide string input
+
+   function To_Set
+     (Sequence : in Wide_Character_Sequence)
+      return     Wide_Character_Set
+   is
+      R : Wide_Character_Ranges (1 .. Sequence'Length);
+
+   begin
+      for J in R'Range loop
+         R (J) := (Sequence (J), Sequence (J));
+      end loop;
+
+      return To_Set (R);
+   end To_Set;
+
+   --  Case of single wide character input
+
+   function To_Set
+     (Singleton : in Wide_Character)
+      return      Wide_Character_Set
+   is
+   begin
+      return
+        (AF.Controlled with
+         Set => new Wide_Character_Ranges' (1 => (Singleton, Singleton)));
+   end To_Set;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value
+     (Map     : in Wide_Character_Mapping;
+      Element : in Wide_Character)
+      return    Wide_Character
+   is
+      L, R, M : Natural;
+
+      MV : constant Wide_Character_Mapping_Values_Access := Map.Map;
+
+   begin
+      L := 1;
+      R := MV.Domain'Last;
+
+      --  Binary search loop
+
+      loop
+         --  If not found, identity
+
+         if L > R then
+            return Element;
+
+         --  Otherwise do binary divide
+
+         else
+            M := (L + R) / 2;
+
+            if Element < MV.Domain (M) then
+               R := M - 1;
+
+            elsif Element > MV.Domain (M) then
+               L := M + 1;
+
+            else --  Element = MV.Domain (M) then
+               return MV.Rangev (M);
+            end if;
+         end if;
+      end loop;
+   end Value;
+
+end Ada.Strings.Wide_Maps;