------------------------------------------------------------------------------ -- -- -- 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 -- -- -- -- Copyright (C) 1992-2005 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 : 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 : 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 : 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 : 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 : 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 : Wide_Character; Set : 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 : Wide_Character_Set; Set : 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 : Wide_Character_Mapping) return Wide_Character_Sequence is begin return Map.Map.Domain; end To_Domain; ---------------- -- To_Mapping -- ---------------- function To_Mapping (From, To : 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); <> 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 : 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 : 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 : 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); <> 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 : 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 : 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 : 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 : Wide_Character_Mapping; Element : 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;