743 lines
20 KiB
Ada
743 lines
20 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT RUN-TIME 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-2015, 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_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 : 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 Ada.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 Ada.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);
|
||
|
|
|
||
|
|
<<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 : Wide_Character_Mapping) return Wide_Character_Sequence
|
||
|
|
is
|
||
|
|
begin
|
||
|
|
return Map.Map.Rangev;
|
||
|
|
end To_Range;
|
||
|
|
|
||
|
|
---------------
|
||
|
|
-- To_Ranges --
|
||
|
|
---------------
|
||
|
|
|
||
|
|
function To_Ranges
|
||
|
|
(Set : 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;
|
||
|
|
N : Natural := 0;
|
||
|
|
Count : Natural := 0;
|
||
|
|
|
||
|
|
begin
|
||
|
|
for J in SS'Range loop
|
||
|
|
Count :=
|
||
|
|
Count + (Wide_Character'Pos (SS (J).High) -
|
||
|
|
Wide_Character'Pos (SS (J).Low) + 1);
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
return Result : Wide_String (1 .. Count) do
|
||
|
|
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;
|
||
|
|
end return;
|
||
|
|
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);
|
||
|
|
|
||
|
|
<<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 N > 0 and then 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;
|