1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- A D A . S T R I N G S . W I D E _ W I D E _ M A P S --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Unchecked_Deallocation;
36 package body Ada.Strings.Wide_Wide_Maps is
43 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
45 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
46 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
48 Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
49 -- Each range on the right can generate at least one more range in
50 -- the result, by splitting one of the left operand ranges.
56 Left_Low : Wide_Wide_Character;
57 -- Left_Low is lowest character of the L'th range not yet dealt with
60 if LS'Last = 0 or else RS'Last = 0 then
64 Left_Low := LS (L).Low;
65 while R <= RS'Last loop
67 -- If next right range is below current left range, skip it
69 if RS (R).High < Left_Low then
72 -- If next right range above current left range, copy remainder of
73 -- the left range to the result
75 elsif RS (R).Low > LS (L).High then
77 Result (N).Low := Left_Low;
78 Result (N).High := LS (L).High;
80 exit when L > LS'Last;
81 Left_Low := LS (L).Low;
84 -- Next right range overlaps bottom of left range
86 if RS (R).Low <= Left_Low then
88 -- Case of right range complete overlaps left range
90 if RS (R).High >= LS (L).High then
92 exit when L > LS'Last;
93 Left_Low := LS (L).Low;
95 -- Case of right range eats lower part of left range
98 Left_Low := Wide_Wide_Character'Succ (RS (R).High);
102 -- Next right range overlaps some of left range, but not bottom
106 Result (N).Low := Left_Low;
107 Result (N).High := Wide_Wide_Character'Pred (RS (R).Low);
109 -- Case of right range splits left range
111 if RS (R).High < LS (L).High then
112 Left_Low := Wide_Wide_Character'Succ (RS (R).High);
115 -- Case of right range overlaps top of left range
119 exit when L > LS'Last;
120 Left_Low := LS (L).Low;
126 -- Copy remainder of left ranges to result
130 Result (N).Low := Left_Low;
131 Result (N).High := LS (L).High;
135 exit when L > LS'Last;
137 Result (N) := LS (L);
141 return (AF.Controlled with
142 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
149 -- The sorted, discontiguous form is canonical, so equality can be used
151 function "=" (Left, Right : in Wide_Wide_Character_Set) return Boolean is
153 return Left.Set.all = Right.Set.all;
161 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
163 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
164 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
166 Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
171 -- Loop to search for overlapping character ranges
173 while L <= LS'Last and then R <= RS'Last loop
175 if LS (L).High < RS (R).Low then
178 elsif RS (R).High < LS (L).Low then
181 -- Here we have LS (L).High >= RS (R).Low
182 -- and RS (R).High >= LS (L).Low
183 -- so we have an overlapping range
188 Wide_Wide_Character'Max (LS (L).Low, RS (R).Low);
190 Wide_Wide_Character'Min (LS (L).High, RS (R).High);
192 if RS (R).High = LS (L).High then
195 elsif RS (R).High < LS (L).High then
203 return (AF.Controlled with
204 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
212 (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
214 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
216 Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
222 Result (1) := (Low => Wide_Wide_Character'First,
223 High => Wide_Wide_Character'Last);
226 if RS (1).Low /= Wide_Wide_Character'First then
228 Result (N).Low := Wide_Wide_Character'First;
229 Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
232 for K in 1 .. RS'Last - 1 loop
234 Result (N).Low := Wide_Wide_Character'Succ (RS (K).High);
235 Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
238 if RS (RS'Last).High /= Wide_Wide_Character'Last then
240 Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High);
241 Result (N).High := Wide_Wide_Character'Last;
245 return (AF.Controlled with
246 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
254 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
256 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
257 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
259 Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
268 -- Loop through ranges in output file
271 -- If no left ranges left, copy next right range
274 exit when R > RS'Last;
276 Result (N) := RS (R);
279 -- If no right ranges left, copy next left range
281 elsif R > RS'Last then
283 Result (N) := LS (L);
287 -- We have two ranges, choose lower one
291 if LS (L).Low <= RS (R).Low then
292 Result (N) := LS (L);
295 Result (N) := RS (R);
299 -- Loop to collapse ranges into last range
302 -- Collapse next length range into current result range
306 and then LS (L).Low <=
307 Wide_Wide_Character'Succ (Result (N).High)
310 Wide_Wide_Character'Max (Result (N).High, LS (L).High);
313 -- Collapse next right range into current result range
317 and then RS (R).Low <=
318 Wide_Wide_Character'Succ (Result (N).High)
321 Wide_Wide_Character'Max (Result (N).High, RS (R).High);
324 -- If neither range collapses, then done with this range
333 return (AF.Controlled with
334 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
342 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
345 return (Left or Right) - (Left and Right);
352 procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
354 Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
357 procedure Adjust (Object : in out Wide_Wide_Character_Set) is
359 Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
366 procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is
368 procedure Free is new Unchecked_Deallocation
369 (Wide_Wide_Character_Mapping_Values,
370 Wide_Wide_Character_Mapping_Values_Access);
373 if Object.Map /= Null_Map'Unrestricted_Access then
378 procedure Finalize (Object : in out Wide_Wide_Character_Set) is
380 procedure Free is new Unchecked_Deallocation
381 (Wide_Wide_Character_Ranges,
382 Wide_Wide_Character_Ranges_Access);
385 if Object.Set /= Null_Range'Unrestricted_Access then
394 procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is
399 procedure Initialize (Object : in out Wide_Wide_Character_Set) is
409 (Element : Wide_Wide_Character;
410 Set : Wide_Wide_Character_Set) return Boolean
413 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
419 -- Binary search loop. The invariant is that if Element is in any of
420 -- of the constituent ranges it is in one between Set (L) and Set (R).
429 if Element > SS (M).High then
431 elsif Element < SS (M).Low then
445 (Elements : Wide_Wide_Character_Set;
446 Set : Wide_Wide_Character_Set) return Boolean
448 ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
449 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
456 -- If no more element ranges, done, and result is true
461 -- If more element ranges, but no more set ranges, result is false
463 elsif S > SS'Last then
466 -- Remove irrelevant set range
468 elsif SS (S).High < ES (E).Low then
471 -- Get rid of element range that is properly covered by set
473 elsif SS (S).Low <= ES (E).Low
474 and then ES (E).High <= SS (S).High
478 -- Otherwise we have a non-covered element range, result is false
491 (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
494 return Map.Map.Domain;
502 (From, To : Wide_Wide_Character_Sequence)
503 return Wide_Wide_Character_Mapping
505 Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
506 Rangev : Wide_Wide_Character_Sequence (1 .. To'Length);
510 if From'Length /= To'Length then
511 raise Translation_Error;
514 pragma Warnings (Off); -- apparent uninit use of Domain
516 for J in From'Range loop
518 if From (J) = Domain (M) then
519 raise Translation_Error;
520 elsif From (J) < Domain (M) then
521 Domain (M + 1 .. N + 1) := Domain (M .. N);
522 Rangev (M + 1 .. N + 1) := Rangev (M .. N);
523 Domain (M) := From (J);
524 Rangev (M) := To (J);
529 Domain (N + 1) := From (J);
530 Rangev (N + 1) := To (J);
536 pragma Warnings (On);
538 return (AF.Controlled with
539 Map => new Wide_Wide_Character_Mapping_Values'(
541 Domain => Domain (1 .. N),
542 Rangev => Rangev (1 .. N)));
551 (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
554 return Map.Map.Rangev;
562 (Set : in Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
573 (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
575 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
577 Result : Wide_Wide_String (Positive range 1 .. 2 ** 16);
581 for J in SS'Range loop
582 for K in SS (J).Low .. SS (J).High loop
588 return Result (1 .. N);
595 -- Case of multiple range input
598 (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
600 Result : Wide_Wide_Character_Ranges (Ranges'Range);
605 -- The output of To_Set is required to be sorted by increasing Low
606 -- values, and discontiguous, so first we sort them as we enter them,
607 -- using a simple insertion sort.
609 pragma Warnings (Off);
610 -- Kill bogus warning on Result being uninitialized
612 for J in Ranges'Range loop
614 if Ranges (J).Low < Result (K).Low then
615 Result (K + 1 .. N + 1) := Result (K .. N);
616 Result (K) := Ranges (J);
621 Result (N + 1) := Ranges (J);
627 pragma Warnings (On);
629 -- Now collapse any contiguous or overlapping ranges
633 if Result (J).High < Result (J).Low then
635 Result (J .. N) := Result (J + 1 .. N + 1);
637 elsif Wide_Wide_Character'Succ (Result (J).High) >=
641 Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High);
644 Result (J + 1 .. N) := Result (J + 2 .. N + 1);
651 if Result (N).High < Result (N).Low then
655 return (AF.Controlled with
656 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
659 -- Case of single range input
662 (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set
665 if Span.Low > Span.High then
667 -- This is safe, because there is no procedure with parameter
668 -- Wide_Wide_Character_Set of mode "out" or "in out".
671 return (AF.Controlled with
672 Set => new Wide_Wide_Character_Ranges'(1 => Span));
676 -- Case of wide string input
679 (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set
681 R : Wide_Wide_Character_Ranges (1 .. Sequence'Length);
684 for J in R'Range loop
685 R (J) := (Sequence (J), Sequence (J));
691 -- Case of single wide character input
694 (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set
699 Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
707 (Map : Wide_Wide_Character_Mapping;
708 Element : Wide_Wide_Character) return Wide_Wide_Character
712 MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map;
718 -- Binary search loop
721 -- If not found, identity
726 -- Otherwise do binary divide
731 if Element < MV.Domain (M) then
734 elsif Element > MV.Domain (M) then
737 else -- Element = MV.Domain (M) then
738 return MV.Rangev (M);
744 end Ada.Strings.Wide_Wide_Maps;