Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / gcc-lib / m68k-amigaos / 2.7.2.1 / adainclude / a-stwima.adb < prev next >

Wrap

Text File | 1995-10-17 | 16.0 KB | 610 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.7 $ -- -- -- -- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved -- -- -- -- The GNAT library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU Library General Public License as published by -- -- the Free Software Foundation; either version 2, or (at your option) any -- -- later version. The GNAT library is distributed in the hope that it will -- -- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- Library General Public License for more details. You should have -- -- received a copy of the GNU Library General Public License along with -- -- the GNAT library; see the file COPYING.LIB. If not, write to the Free -- -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ 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.all = Right.all; end "="; --------- -- "-" -- --------- function "-" (Left, Right : in Wide_Character_Set) return Wide_Character_Set is Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length); -- 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; W : Wide_Character; begin -- Basic loop is through ranges of left set for L in Left'Range loop -- W is lowest element of current left range not dealt with yet W := Left (L).Low; -- Skip by ranges of right set that have no impact on us while R <= Right'Length and then Right (R).High < W loop R := R + 1; end loop; -- Deal with ranges on right that create holes in the left range while R <= Right'Length and then Right (R).High < Left (L).High loop N := N + 1; Result (N).Low := W; Result (N).High := Right (R).High; R := R + 1; end loop; -- Now we have to output the final piece of the left range if any if R <= Right'Length and then Right (R).Low <= Left (L).High then -- Current right range consumes all of the rest of left range if Right (R).Low < W then null; -- Current right range consumes part of the rest of left range else N := N + 1; Result (N).Low := W; Result (N).High := Wide_Character'Pred (Right (R).Low); end if; -- Rest of left range to be retained complete else N := N + 1; Result (N).Low := W; Result (N).High := Left (L).High; end if; end loop; return new Wide_Character_Ranges'(Result (1 .. N)); end "-"; ----------- -- "and" -- ----------- function "and" (Left, Right : in Wide_Character_Set) return Wide_Character_Set is Result : Wide_Character_Ranges (1 .. Left.all'Length + Right.all'Length); N : Natural := 0; L, R : Natural := 1; begin -- Loop to search for overlapping character ranges loop exit when L > Left.all'Last; exit when R > Right.all'Last; if Left (L).High < Right (R).Low then L := L + 1; elsif Right (R).High < Left (L).Low then R := R + 1; -- Here we have Left.High >= Right.Low -- and Right.High >= Left.Low -- so we have an overlapping range else N := N + 1; Result (N).Low := Wide_Character'Max (Left (L).Low, Right (R).Low); Result (N).High := Wide_Character'Min (Left (L).High, Right (R).High); if Right (R).High = Left (L).High then L := L + 1; R := R + 1; elsif Right (R).High < Left (L).High then R := R + 1; else L := L + 1; end if; end if; end loop; return new Wide_Character_Ranges'(Result (1 .. N)); end "and"; ----------- -- "not" -- ----------- function "not" (Right : in Wide_Character_Set) return Wide_Character_Set is Result : Wide_Character_Ranges (1 .. Right.all'Length + 1); N : Natural := 0; begin if Right = Null_Set then N := 1; Result (1) := (Low => Wide_Character'First, High => Wide_Character'Last); else if Right (1).Low /= Wide_Character'First then N := N + 1; Result (N).Low := Wide_Character'First; Result (N).High := Wide_Character'Pred (Right (1).Low); end if; for K in 1 .. Right.all'Last - 1 loop N := N + 1; Result (N).Low := Wide_Character'Succ (Right (K).High); Result (N).High := Wide_Character'Pred (Right (K + 1).Low); end loop; if Right (Right.all'Last).High /= Wide_Character'Last then N := N + 1; Result (N).Low := Wide_Character'Succ (Right (Right'Last).High); Result (N).High := Wide_Character'Pred (Right (1).Low); end if; end if; return new Wide_Character_Ranges'(Result (1 .. N)); end "not"; ---------- -- "or" -- ---------- function "or" (Left, Right : in Wide_Character_Set) return Wide_Character_Set is Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length); N : Natural; L, R : Natural; begin if Left'Length = 0 then return Right; elsif Right'Length = 0 then return Left; else N := 1; Result (1) := Left (1); L := 2; R := 1; loop -- Collapse next left range into current result range if possible if L <= Left'Length and then Wide_Character'Pos (Left (L).Low) <= Wide_Character'Pos (Result (N).High) + 1 then Result (N).High := Wide_Character'Max (Result (N).High, Left (L).High); L := L + 1; -- Collapse next right range into current result range if possible elsif R <= Right'Length and then Wide_Character'Pos (Right (R).Low) <= Wide_Character'Pos (Result (N).High) + 1 then Result (N).High := Wide_Character'Max (Result (N).High, Right (R).High); R := R + 1; -- Otherwise establish new result range else if L <= Left'Length then N := N + 1; Result (N) := Left (L); L := L + 1; elsif R <= Right'Length then N := N + 1; Result (N) := Right (R); R := R + 1; else exit; end if; end if; end loop; end if; return new Wide_Character_Ranges'(Result (1 .. N)); end "or"; ----------- -- "xor" -- ----------- function "xor" (Left, Right : in Wide_Character_Set) return Wide_Character_Set is Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length); N : Natural := 0; L, R : Natural := 1; begin return (Left or Right) - (Left and Right); end "xor"; ----------- -- Is_In -- ----------- function Is_In (Element : in Wide_Character; Set : in Wide_Character_Set) return Boolean is L, R, M : Natural; begin L := Set'First; R := Set'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 > Set (M).High then L := M + 1; elsif Element < Set (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 S : Positive := 1; E : Positive := 1; begin loop -- If no more element ranges, done, and result is true if E > Elements'Length then return True; -- If more element ranges, but no more set ranges, result is false elsif S > Set'Length then return False; -- Remove irrelevant set range elsif Set (S).High < Elements (E).Low then S := S + 1; -- Get rid of element range that is properly covered by set elsif Set (S).Low <= Elements (E).Low and then Elements (E).High <= Set (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.Domain.all; 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; K : Natural := 0; begin if From'Length /= To'Length then raise Translation_Error; else 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); 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; return (Domain => new Wide_Character_Sequence'(Domain (1 .. N)), Rangev => new Wide_Character_Sequence'(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.Rangev.all; end To_Range; --------------- -- To_Ranges -- --------------- function To_Ranges (Set : in Wide_Character_Set) return Wide_Character_Ranges is begin return Set.all; end To_Ranges; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Set : in Wide_Character_Set) return Wide_Character_Sequence is Result : Wide_String (Positive range 1 .. 2 ** 16); N : Natural := 0; begin for J in Set'Range loop for K in Set (J).Low .. Set (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. 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; -- 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'Pos (Result (J).High) + 1 >= Wide_Character'Pos (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 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 on mode "out" or "in out". else return 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 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; begin L := 1; R := Map.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 < Map.Domain (M) then R := M - 1; elsif Element > Map.Domain (M) then L := M + 1; else -- Element = Map.Domain (M) then return Map.Rangev (M); end if; end if; end loop; end Value; end Ada.Strings.Wide_Maps;