home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
adav313.zip
/
gnat-3_13p-os2-bin-20010916.zip
/
emx
/
gnatlib
/
a-stwima.adb
< prev
next >
Wrap
Text File
|
2000-07-19
|
21KB
|
759 lines
------------------------------------------------------------------------------
-- --
-- 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.17 $ --
-- --
-- Copyright (C) 1992-1998 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. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Unchecked_Deallocation;
package body Ada.Strings.Wide_Maps is
---------
-- "=" --
---------
-- 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 "=";
---------
-- "-" --
---------
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 "-";
-----------
-- "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;
