+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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.1.16.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff