[thirdparty/gcc.git] / gcc / ada / a-stzmap.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--           A D A . S T R I N G S . W I D E _ W I D E _ M A P S            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, 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 3,  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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

package body Ada.Strings.Wide_Wide_Maps is

   ---------
   -- "-" --
   ---------

   function "-"
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
   is
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;

      Result : Wide_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_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_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_Wide_Character'Pred (RS (R).Low);

               --  Case of right range splits left range

               if RS (R).High < LS (L).High then
                  Left_Low := Wide_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_Wide_Character_Ranges'(Result (1 .. N)));
   end "-";

   ---------
   -- "=" --
   ---------

   --  The sorted, discontiguous form is canonical, so equality can be used

   function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is
   begin
      return Left.Set.all = Right.Set.all;
   end "=";

   -----------
   -- "and" --
   -----------

   function "and"
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
   is
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;

      Result : Wide_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_Wide_Character'Max (LS (L).Low,  RS (R).Low);
            Result (N).High :=
              Wide_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_Wide_Character_Ranges'(Result (1 .. N)));
   end "and";

   -----------
   -- "not" --
   -----------

   function "not"
     (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
   is
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;

      Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
      N      : Natural := 0;

   begin
      if RS'Last = 0 then
         N := 1;
         Result (1) := (Low  => Wide_Wide_Character'First,
                        High => Wide_Wide_Character'Last);

      else
         if RS (1).Low /= Wide_Wide_Character'First then
            N := N + 1;
            Result (N).Low  := Wide_Wide_Character'First;
            Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
         end if;

         for K in 1 .. RS'Last - 1 loop
            N := N + 1;
            Result (N).Low  := Wide_Wide_Character'Succ (RS (K).High);
            Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
         end loop;

         if RS (RS'Last).High /= Wide_Wide_Character'Last then
            N := N + 1;
            Result (N).Low  := Wide_Wide_Character'Succ (RS (RS'Last).High);
            Result (N).High := Wide_Wide_Character'Last;
         end if;
      end if;

      return (AF.Controlled with
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
   end "not";

   ----------
   -- "or" --
   ----------

   function "or"
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
   is
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;

      Result : Wide_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_Wide_Character'Succ (Result (N).High)
               then
                  Result (N).High :=
                    Wide_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_Wide_Character'Succ (Result (N).High)
               then
                  Result (N).High :=
                    Wide_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_Wide_Character_Ranges'(Result (1 .. N)));
   end "or";

   -----------
   -- "xor" --
   -----------

   function "xor"
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
   is
   begin
      return (Left or Right) - (Left and Right);
   end "xor";

   ------------
   -- Adjust --
   ------------

   procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
   begin
      Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
   end Adjust;

   procedure Adjust (Object : in out Wide_Wide_Character_Set) is
   begin
      Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
   end Adjust;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is

      procedure Free is new Ada.Unchecked_Deallocation
        (Wide_Wide_Character_Mapping_Values,
         Wide_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_Wide_Character_Set) is

      procedure Free is new Ada.Unchecked_Deallocation
        (Wide_Wide_Character_Ranges,
         Wide_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_Wide_Character_Mapping) is
   begin
      Object := Identity;
   end Initialize;

   procedure Initialize (Object : in out Wide_Wide_Character_Set) is
   begin
      Object := Null_Set;
   end Initialize;

   -----------
   -- Is_In --
   -----------

   function Is_In
     (Element : Wide_Wide_Character;
      Set     : Wide_Wide_Character_Set) return Boolean
   is
      L, R, M : Natural;
      SS      : constant Wide_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 : Wide_Wide_Character_Set;
      Set      : Wide_Wide_Character_Set) return Boolean
   is
      ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
      SS : constant Wide_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 : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
   is
   begin
      return Map.Map.Domain;
   end To_Domain;

   ----------------
   -- To_Mapping --
   ----------------

   function To_Mapping
     (From, To : Wide_Wide_Character_Sequence)
     return Wide_Wide_Character_Mapping
   is
      Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
      Rangev : Wide_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_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 : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
   is
   begin
      return Map.Map.Rangev;
   end To_Range;

   ---------------
   -- To_Ranges --
   ---------------

   function To_Ranges
     (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
   is
   begin
      return Set.Set.all;
   end To_Ranges;

   -----------------
   -- To_Sequence --
   -----------------

   function To_Sequence
     (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
   is
      SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;

      Result : Wide_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 : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
   is
      Result : Wide_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_Wide_Character'Succ (Result (J).High) >=
           Result (J + 1).Low
         then
            Result (J).High :=
              Wide_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_Wide_Character_Ranges'(Result (1 .. N)));
   end To_Set;

   --  Case of single range input

   function To_Set
     (Span : Wide_Wide_Character_Range) return Wide_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_Wide_Character_Set of mode "out" or "in out".

      else
         return (AF.Controlled with
                 Set => new Wide_Wide_Character_Ranges'(1 => Span));
      end if;
   end To_Set;

   --  Case of wide string input

   function To_Set
     (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set
   is
      R : Wide_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 : Wide_Wide_Character) return Wide_Wide_Character_Set
   is
   begin
      return
        (AF.Controlled with
         Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
   end To_Set;

   -----------
   -- Value --
   -----------

   function Value
     (Map     : Wide_Wide_Character_Mapping;
      Element : Wide_Wide_Character) return Wide_Wide_Character
   is
      L, R, M : Natural;

      MV : constant Wide_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_Wide_Maps;
Commit	Line	Data
4c2d6a70 AC	1	------------------------------------------------------------------------------
4c2d6a70 AC	2	-- --
3084fecd	3	-- GNAT RUN-TIME COMPONENTS --
4c2d6a70 AC	4	-- --
	5	-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S --
	6	-- --
	7	-- B o d y --
	8	-- --
748086b7	9	-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
4c2d6a70 AC	10	-- --
	11	-- GNAT is free software; you can redistribute it and/or modify it under --
	12	-- terms of the GNU General Public License as published by the Free Soft- --
748086b7	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
4c2d6a70 AC	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
4c2d6a70 AC	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
748086b7 JJ	16	-- or FITNESS FOR A PARTICULAR PURPOSE. --
	17	-- --
	18	-- As a special exception under Section 7 of GPL version 3, you are granted --
	19	-- additional permissions described in the GCC Runtime Library Exception, --
	20	-- version 3.1, as published by the Free Software Foundation. --
	21	-- --
	22	-- You should have received a copy of the GNU General Public License and --
	23	-- a copy of the GCC Runtime Library Exception along with this program; --
	24	-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
	25	-- <http://www.gnu.org/licenses/>. --
4c2d6a70 AC	26	-- --
	27	-- GNAT was originally developed by the GNAT team at New York University. --
	28	-- Extensive contributions were provided by Ada Core Technologies Inc. --
	29	-- --
	30	------------------------------------------------------------------------------
	31
cecaf88a	32	with Ada.Unchecked_Deallocation;
4c2d6a70 AC	33
	34	package body Ada.Strings.Wide_Wide_Maps is
	35
	36	---------
	37	-- "-" --
	38	---------
	39
	40	function "-"
	41	(Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
	42	is
	43	LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
	44	RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
	45
	46	Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
	47	-- Each range on the right can generate at least one more range in
	48	-- the result, by splitting one of the left operand ranges.
	49
	50	N : Natural := 0;
	51	R : Natural := 1;
	52	L : Natural := 1;
	53
	54	Left_Low : Wide_Wide_Character;
	55	-- Left_Low is lowest character of the L'th range not yet dealt with
	56
	57	begin
	58	if LS'Last = 0 or else RS'Last = 0 then
	59	return Left;
	60	end if;
	61
	62	Left_Low := LS (L).Low;
	63	while R <= RS'Last loop
	64
	65	-- If next right range is below current left range, skip it
	66
	67	if RS (R).High < Left_Low then
	68	R := R + 1;
	69
	70	-- If next right range above current left range, copy remainder of
	71	-- the left range to the result
	72
	73	elsif RS (R).Low > LS (L).High then
	74	N := N + 1;
	75	Result (N).Low := Left_Low;
	76	Result (N).High := LS (L).High;
	77	L := L + 1;
	78	exit when L > LS'Last;
	79	Left_Low := LS (L).Low;
	80
	81	else
	82	-- Next right range overlaps bottom of left range
	83
	84	if RS (R).Low <= Left_Low then
	85
	86	-- Case of right range complete overlaps left range
	87
	88	if RS (R).High >= LS (L).High then
	89	L := L + 1;
	90	exit when L > LS'Last;
	91	Left_Low := LS (L).Low;
	92
	93	-- Case of right range eats lower part of left range
	94
	95	else
	96	Left_Low := Wide_Wide_Character'Succ (RS (R).High);
97	R := R + 1;
98	end if;
99
100	-- Next right range overlaps some of left range, but not bottom
101
102	else
103	N := N + 1;
104	Result (N).Low := Left_Low;
105	Result (N).High := Wide_Wide_Character'Pred (RS (R).Low);
106
107	-- Case of right range splits left range
108
109	if RS (R).High < LS (L).High then
110	Left_Low := Wide_Wide_Character'Succ (RS (R).High);
111	R := R + 1;
112
113	-- Case of right range overlaps top of left range
114
115	else
116	L := L + 1;
117	exit when L > LS'Last;
118	Left_Low := LS (L).Low;
119	end if;
120	end if;
121	end if;
122	end loop;
123
124	-- Copy remainder of left ranges to result
125
126	if L <= LS'Last then
127	N := N + 1;
128	Result (N).Low := Left_Low;
129	Result (N).High := LS (L).High;
130
131	loop
132	L := L + 1;
133	exit when L > LS'Last;
134	N := N + 1;
135	Result (N) := LS (L);
136	end loop;
137	end if;
138
139	return (AF.Controlled with
140	Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
141	end "-";
142
143	---------
144	-- "=" --
145	---------
146
147	-- The sorted, discontiguous form is canonical, so equality can be used
148
0ae9f22f	149	function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is
4c2d6a70 AC	150	begin
	151	return Left.Set.all = Right.Set.all;
	152	end "=";
	153
	154	-----------
	155	-- "and" --
	156	-----------
	157
	158	function "and"
	159	(Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
	160	is
	161	LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
	162	RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
	163
	164	Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
	165	N : Natural := 0;
	166	L, R : Natural := 1;
	167
	168	begin
	169	-- Loop to search for overlapping character ranges
	170
	171	while L <= LS'Last and then R <= RS'Last loop
	172
	173	if LS (L).High < RS (R).Low then
	174	L := L + 1;
	175
	176	elsif RS (R).High < LS (L).Low then
	177	R := R + 1;
	178
	179	-- Here we have LS (L).High >= RS (R).Low
	180	-- and RS (R).High >= LS (L).Low
	181	-- so we have an overlapping range
	182
	183	else
	184	N := N + 1;
	185	Result (N).Low :=
	186	Wide_Wide_Character'Max (LS (L).Low, RS (R).Low);
	187	Result (N).High :=
	188	Wide_Wide_Character'Min (LS (L).High, RS (R).High);
	189
	190	if RS (R).High = LS (L).High then
	191	L := L + 1;
	192	R := R + 1;
	193	elsif RS (R).High < LS (L).High then
	194	R := R + 1;
	195	else
	196	L := L + 1;
	197	end if;
	198	end if;
	199	end loop;
	200
	201	return (AF.Controlled with
	202	Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
	203	end "and";
	204
	205	-----------
	206	-- "not" --
	207	-----------
	208
	209	function "not"
	210	(Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
	211	is
	212	RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
	213
214	Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
215	N : Natural := 0;
216
217	begin
218	if RS'Last = 0 then
219	N := 1;
220	Result (1) := (Low => Wide_Wide_Character'First,
221	High => Wide_Wide_Character'Last);
222
223	else
224	if RS (1).Low /= Wide_Wide_Character'First then
225	N := N + 1;
226	Result (N).Low := Wide_Wide_Character'First;
227	Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
228	end if;
229
230	for K in 1 .. RS'Last - 1 loop
231	N := N + 1;
232	Result (N).Low := Wide_Wide_Character'Succ (RS (K).High);
233	Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
234	end loop;
235
236	if RS (RS'Last).High /= Wide_Wide_Character'Last then
237	N := N + 1;
238	Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High);
239	Result (N).High := Wide_Wide_Character'Last;
240	end if;
241	end if;
242
243	return (AF.Controlled with
244	Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
245	end "not";
246
247	----------
248	-- "or" --
249	----------
250
251	function "or"
252	(Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
253	is
254	LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
255	RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
256
257	Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
258	N : Natural;
259	L, R : Natural;
260
261	begin
262	N := 0;
263	L := 1;
264	R := 1;
265
266	-- Loop through ranges in output file
267
268	loop
269	-- If no left ranges left, copy next right range
270
271	if L > LS'Last then
272	exit when R > RS'Last;
273	N := N + 1;
274	Result (N) := RS (R);
275	R := R + 1;
276
277	-- If no right ranges left, copy next left range
278
279	elsif R > RS'Last then
280	N := N + 1;
281	Result (N) := LS (L);
282	L := L + 1;
283
284	else
285	-- We have two ranges, choose lower one
286
287	N := N + 1;
288
289	if LS (L).Low <= RS (R).Low then
290	Result (N) := LS (L);
291	L := L + 1;
292	else
293	Result (N) := RS (R);
294	R := R + 1;
295	end if;
296
297	-- Loop to collapse ranges into last range
298
299	loop
300	-- Collapse next length range into current result range
301	-- if possible.
302
303	if L <= LS'Last
304	and then LS (L).Low <=
305	Wide_Wide_Character'Succ (Result (N).High)
306	then
307	Result (N).High :=
308	Wide_Wide_Character'Max (Result (N).High, LS (L).High);
309	L := L + 1;
310
311	-- Collapse next right range into current result range
312	-- if possible
313
314	elsif R <= RS'Last
315	and then RS (R).Low <=
316	Wide_Wide_Character'Succ (Result (N).High)
317	then
318	Result (N).High :=
319	Wide_Wide_Character'Max (Result (N).High, RS (R).High);
320	R := R + 1;
321
322	-- If neither range collapses, then done with this range
323
324	else
325	exit;
326	end if;
327	end loop;
328	end if;
329	end loop;
330
331	return (AF.Controlled with
332	Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
333	end "or";
334
335	-----------
336	-- "xor" --
337	-----------
338
339	function "xor"
340	(Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
341	is
342	begin
343	return (Left or Right) - (Left and Right);
344	end "xor";
345
346	------------
347	-- Adjust --
348	------------
349
350	procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
351	begin
352	Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
353	end Adjust;
354
355	procedure Adjust (Object : in out Wide_Wide_Character_Set) is
356	begin
357	Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
358	end Adjust;
359
360	--------------
361	-- Finalize --
362	--------------
363
364	procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is
365
cecaf88a	366	procedure Free is new Ada.Unchecked_Deallocation
4c2d6a70 AC	367	(Wide_Wide_Character_Mapping_Values,
	368	Wide_Wide_Character_Mapping_Values_Access);
	369
	370	begin
	371	if Object.Map /= Null_Map'Unrestricted_Access then
	372	Free (Object.Map);
	373	end if;
	374	end Finalize;
	375
	376	procedure Finalize (Object : in out Wide_Wide_Character_Set) is
	377
cecaf88a	378	procedure Free is new Ada.Unchecked_Deallocation
4c2d6a70 AC	379	(Wide_Wide_Character_Ranges,
	380	Wide_Wide_Character_Ranges_Access);
	381
	382	begin
	383	if Object.Set /= Null_Range'Unrestricted_Access then
	384	Free (Object.Set);
	385	end if;
	386	end Finalize;
	387
	388	----------------
	389	-- Initialize --
	390	----------------
	391
	392	procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is
	393	begin
	394	Object := Identity;
	395	end Initialize;
	396
	397	procedure Initialize (Object : in out Wide_Wide_Character_Set) is
	398	begin
	399	Object := Null_Set;
	400	end Initialize;
	401
	402	-----------
	403	-- Is_In --
	404	-----------
	405
	406	function Is_In
	407	(Element : Wide_Wide_Character;
	408	Set : Wide_Wide_Character_Set) return Boolean
	409	is
	410	L, R, M : Natural;
	411	SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
	412
	413	begin
	414	L := 1;
	415	R := SS'Last;
	416
	417	-- Binary search loop. The invariant is that if Element is in any of
	418	-- of the constituent ranges it is in one between Set (L) and Set (R).
	419
	420	loop
	421	if L > R then
	422	return False;
	423
	424	else
	425	M := (L + R) / 2;
	426
	427	if Element > SS (M).High then
	428	L := M + 1;
	429	elsif Element < SS (M).Low then
	430	R := M - 1;
	431	else
	432	return True;
	433	end if;
	434	end if;
	435	end loop;
	436	end Is_In;
	437
	438	---------------
	439	-- Is_Subset --
	440	---------------
	441
	442	function Is_Subset
443	(Elements : Wide_Wide_Character_Set;
444	Set : Wide_Wide_Character_Set) return Boolean
445	is
446	ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
447	SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
448
449	S : Positive := 1;
450	E : Positive := 1;
451
452	begin
453	loop
454	-- If no more element ranges, done, and result is true
455
456	if E > ES'Last then
457	return True;
458
459	-- If more element ranges, but no more set ranges, result is false
460
461	elsif S > SS'Last then
462	return False;
463
464	-- Remove irrelevant set range
465
466	elsif SS (S).High < ES (E).Low then
467	S := S + 1;
468
469	-- Get rid of element range that is properly covered by set
470
471	elsif SS (S).Low <= ES (E).Low
472	and then ES (E).High <= SS (S).High
473	then
474	E := E + 1;
475
476	-- Otherwise we have a non-covered element range, result is false
477
478	else
479	return False;
480	end if;
481	end loop;
482	end Is_Subset;
483
484	---------------
485	-- To_Domain --
486	---------------
487
488	function To_Domain
489	(Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
490	is
491	begin
492	return Map.Map.Domain;
493	end To_Domain;
494
495	----------------
496	-- To_Mapping --
497	----------------
498
499	function To_Mapping
500	(From, To : Wide_Wide_Character_Sequence)
501	return Wide_Wide_Character_Mapping
502	is
503	Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
504	Rangev : Wide_Wide_Character_Sequence (1 .. To'Length);
505	N : Natural := 0;
506
507	begin
508	if From'Length /= To'Length then
509	raise Translation_Error;
510
511	else
512	pragma Warnings (Off); -- apparent uninit use of Domain
513
514	for J in From'Range loop
515	for M in 1 .. N loop
516	if From (J) = Domain (M) then
517	raise Translation_Error;
518	elsif From (J) < Domain (M) then
519	Domain (M + 1 .. N + 1) := Domain (M .. N);
520	Rangev (M + 1 .. N + 1) := Rangev (M .. N);
521	Domain (M) := From (J);
522	Rangev (M) := To (J);
523	goto Continue;
524	end if;
525	end loop;
526
527	Domain (N + 1) := From (J);
528	Rangev (N + 1) := To (J);
529
530	<<Continue>>
531	N := N + 1;
532	end loop;
533
534	pragma Warnings (On);
535
536	return (AF.Controlled with
537	Map => new Wide_Wide_Character_Mapping_Values'(
538	Length => N,
539	Domain => Domain (1 .. N),
540	Rangev => Rangev (1 .. N)));
541	end if;
542	end To_Mapping;
543
544	--------------
545	-- To_Range --
546	--------------
547
548	function To_Range
549	(Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
550	is
551	begin
552	return Map.Map.Rangev;
553	end To_Range;
554
555	---------------
556	-- To_Ranges --
557	---------------
558
559	function To_Ranges
0ae9f22f	560	(Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
4c2d6a70 AC	561	is
	562	begin
	563	return Set.Set.all;
	564	end To_Ranges;
	565
	566	-----------------
	567	-- To_Sequence --
	568	-----------------
	569
	570	function To_Sequence
	571	(Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
	572	is
	573	SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
	574
	575	Result : Wide_Wide_String (Positive range 1 .. 2 ** 16);
	576	N : Natural := 0;
	577
	578	begin
	579	for J in SS'Range loop
	580	for K in SS (J).Low .. SS (J).High loop
	581	N := N + 1;
	582	Result (N) := K;
	583	end loop;
	584	end loop;
	585
	586	return Result (1 .. N);
	587	end To_Sequence;
	588
	589	------------
	590	-- To_Set --
	591	------------
	592
	593	-- Case of multiple range input
	594
	595	function To_Set
	596	(Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
	597	is
	598	Result : Wide_Wide_Character_Ranges (Ranges'Range);
	599	N : Natural := 0;
	600	J : Natural;
	601
	602	begin
	603	-- The output of To_Set is required to be sorted by increasing Low
	604	-- values, and discontiguous, so first we sort them as we enter them,
	605	-- using a simple insertion sort.
	606
	607	pragma Warnings (Off);
	608	-- Kill bogus warning on Result being uninitialized
	609
	610	for J in Ranges'Range loop
	611	for K in 1 .. N loop
	612	if Ranges (J).Low < Result (K).Low then
	613	Result (K + 1 .. N + 1) := Result (K .. N);
	614	Result (K) := Ranges (J);
	615	goto Continue;
	616	end if;
	617	end loop;
	618
	619	Result (N + 1) := Ranges (J);
	620
	621	<<Continue>>
	622	N := N + 1;
	623	end loop;
	624
625	pragma Warnings (On);
626
627	-- Now collapse any contiguous or overlapping ranges
628
629	J := 1;
630	while J < N loop
631	if Result (J).High < Result (J).Low then
632	N := N - 1;
633	Result (J .. N) := Result (J + 1 .. N + 1);
634
635	elsif Wide_Wide_Character'Succ (Result (J).High) >=
636	Result (J + 1).Low
637	then
638	Result (J).High :=
639	Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High);
640
641	N := N - 1;
642	Result (J + 1 .. N) := Result (J + 2 .. N + 1);
643
644	else
645	J := J + 1;
646	end if;
647	end loop;
648
649	if Result (N).High < Result (N).Low then
650	N := N - 1;
651	end if;
652
653	return (AF.Controlled with
654	Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
655	end To_Set;
656
657	-- Case of single range input
658
659	function To_Set
660	(Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set
661	is
662	begin
663	if Span.Low > Span.High then
664	return Null_Set;
665	-- This is safe, because there is no procedure with parameter
666	-- Wide_Wide_Character_Set of mode "out" or "in out".
667
668	else
669	return (AF.Controlled with
670	Set => new Wide_Wide_Character_Ranges'(1 => Span));
671	end if;
672	end To_Set;
673
674	-- Case of wide string input
675
676	function To_Set
677	(Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set
678	is
679	R : Wide_Wide_Character_Ranges (1 .. Sequence'Length);
680
681	begin
682	for J in R'Range loop
683	R (J) := (Sequence (J), Sequence (J));
684	end loop;
685
686	return To_Set (R);
687	end To_Set;
688
689	-- Case of single wide character input
690
691	function To_Set
692	(Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set
693	is
694	begin
695	return
696	(AF.Controlled with
697	Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
698	end To_Set;
699
700	-----------
701	-- Value --
702	-----------
703
704	function Value
705	(Map : Wide_Wide_Character_Mapping;
706	Element : Wide_Wide_Character) return Wide_Wide_Character
707	is
708	L, R, M : Natural;
709
710	MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map;
711
712	begin
713	L := 1;
714	R := MV.Domain'Last;
715
716	-- Binary search loop
717
718	loop
719	-- If not found, identity
720
721	if L > R then
722	return Element;
723
724	-- Otherwise do binary divide
725
726	else
727	M := (L + R) / 2;
728
729	if Element < MV.Domain (M) then
730	R := M - 1;
731
732	elsif Element > MV.Domain (M) then
733	L := M + 1;
734
735	else -- Element = MV.Domain (M) then
736	return MV.Rangev (M);
737	end if;
738	end if;
739	end loop;
740	end Value;
741
742	end Ada.Strings.Wide_Wide_Maps;