URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-stzmap.adb] - Blame information for rev 728

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-stzmap.adb] - Blame information for rev 728

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT RUN-TIME COMPONENTS --`
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			`-- --`
9			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
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- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
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/>. --`
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
32			`with Ada.Unchecked_Deallocation;`
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
149			`function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is`
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
366			`procedure Free is new Ada.Unchecked_Deallocation`
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
378			`procedure Free is new Ada.Unchecked_Deallocation`
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`
560			`(Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges`
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;`