1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . S T R I N G S . W I D E _ M A P S --
9 -- Copyright (C) 1992-2007, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Ada.Unchecked_Deallocation;
36 package body Ada.Strings.Wide_Maps is
43 (Left, Right : Wide_Character_Set) return Wide_Character_Set
45 LS : constant Wide_Character_Ranges_Access := Left.Set;
46 RS : constant Wide_Character_Ranges_Access := Right.Set;
48 Result : 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_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
73 -- of 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_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_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_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_Character_Ranges'(Result (1 .. N)));
149 -- The sorted, discontiguous form is canonical, so equality can be used
151 function "=" (Left, Right : Wide_Character_Set) return Boolean is
153 return Left.Set.all = Right.Set.all;
161 (Left, Right : Wide_Character_Set) return Wide_Character_Set
163 LS : constant Wide_Character_Ranges_Access := Left.Set;
164 RS : constant Wide_Character_Ranges_Access := Right.Set;
166 Result : 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
187 Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low);
189 Wide_Character'Min (LS (L).High, RS (R).High);
191 if RS (R).High = LS (L).High then
194 elsif RS (R).High < LS (L).High then
202 return (AF.Controlled with
203 Set => new Wide_Character_Ranges'(Result (1 .. N)));
211 (Right : Wide_Character_Set) return Wide_Character_Set
213 RS : constant Wide_Character_Ranges_Access := Right.Set;
215 Result : Wide_Character_Ranges (1 .. RS'Last + 1);
221 Result (1) := (Low => Wide_Character'First,
222 High => Wide_Character'Last);
225 if RS (1).Low /= Wide_Character'First then
227 Result (N).Low := Wide_Character'First;
228 Result (N).High := Wide_Character'Pred (RS (1).Low);
231 for K in 1 .. RS'Last - 1 loop
233 Result (N).Low := Wide_Character'Succ (RS (K).High);
234 Result (N).High := Wide_Character'Pred (RS (K + 1).Low);
237 if RS (RS'Last).High /= Wide_Character'Last then
239 Result (N).Low := Wide_Character'Succ (RS (RS'Last).High);
240 Result (N).High := Wide_Character'Last;
244 return (AF.Controlled with
245 Set => new Wide_Character_Ranges'(Result (1 .. N)));
253 (Left, Right : Wide_Character_Set) return Wide_Character_Set
255 LS : constant Wide_Character_Ranges_Access := Left.Set;
256 RS : constant Wide_Character_Ranges_Access := Right.Set;
258 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
267 -- Loop through ranges in output file
270 -- If no left ranges left, copy next right range
273 exit when R > RS'Last;
275 Result (N) := RS (R);
278 -- If no right ranges left, copy next left range
280 elsif R > RS'Last then
282 Result (N) := LS (L);
286 -- We have two ranges, choose lower one
290 if LS (L).Low <= RS (R).Low then
291 Result (N) := LS (L);
294 Result (N) := RS (R);
298 -- Loop to collapse ranges into last range
301 -- Collapse next length range into current result range
305 and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
308 Wide_Character'Max (Result (N).High, LS (L).High);
311 -- Collapse next right range into current result range
315 and then RS (R).Low <=
316 Wide_Character'Succ (Result (N).High)
319 Wide_Character'Max (Result (N).High, RS (R).High);
322 -- If neither range collapses, then done with this range
331 return (AF.Controlled with
332 Set => new Wide_Character_Ranges'(Result (1 .. N)));
340 (Left, Right : Wide_Character_Set) return Wide_Character_Set
343 return (Left or Right) - (Left and Right);
350 procedure Adjust (Object : in out Wide_Character_Mapping) is
352 Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all);
355 procedure Adjust (Object : in out Wide_Character_Set) is
357 Object.Set := new Wide_Character_Ranges'(Object.Set.all);
364 procedure Finalize (Object : in out Wide_Character_Mapping) is
366 procedure Free is new Ada.Unchecked_Deallocation
367 (Wide_Character_Mapping_Values,
368 Wide_Character_Mapping_Values_Access);
371 if Object.Map /= Null_Map'Unrestricted_Access then
376 procedure Finalize (Object : in out Wide_Character_Set) is
378 procedure Free is new Ada.Unchecked_Deallocation
379 (Wide_Character_Ranges,
380 Wide_Character_Ranges_Access);
383 if Object.Set /= Null_Range'Unrestricted_Access then
392 procedure Initialize (Object : in out Wide_Character_Mapping) is
397 procedure Initialize (Object : in out Wide_Character_Set) is
407 (Element : Wide_Character;
408 Set : Wide_Character_Set) return Boolean
411 SS : constant Wide_Character_Ranges_Access := Set.Set;
417 -- Binary search loop. The invariant is that if Element is in any of
418 -- of the constituent ranges it is in one between Set (L) and Set (R).
427 if Element > SS (M).High then
429 elsif Element < SS (M).Low then
443 (Elements : Wide_Character_Set;
444 Set : Wide_Character_Set) return Boolean
446 ES : constant Wide_Character_Ranges_Access := Elements.Set;
447 SS : constant Wide_Character_Ranges_Access := Set.Set;
454 -- If no more element ranges, done, and result is true
459 -- If more element ranges, but no more set ranges, result is false
461 elsif S > SS'Last then
464 -- Remove irrelevant set range
466 elsif SS (S).High < ES (E).Low then
469 -- Get rid of element range that is properly covered by set
471 elsif SS (S).Low <= ES (E).Low
472 and then ES (E).High <= SS (S).High
476 -- Otherwise we have a non-covered element range, result is false
489 (Map : Wide_Character_Mapping) return Wide_Character_Sequence
492 return Map.Map.Domain;
500 (From, To : Wide_Character_Sequence) return Wide_Character_Mapping
502 Domain : Wide_Character_Sequence (1 .. From'Length);
503 Rangev : Wide_Character_Sequence (1 .. To'Length);
507 if From'Length /= To'Length then
508 raise Translation_Error;
511 pragma Warnings (Off); -- apparent uninit use of Domain
513 for J in From'Range loop
515 if From (J) = Domain (M) then
516 raise Translation_Error;
517 elsif From (J) < Domain (M) then
518 Domain (M + 1 .. N + 1) := Domain (M .. N);
519 Rangev (M + 1 .. N + 1) := Rangev (M .. N);
520 Domain (M) := From (J);
521 Rangev (M) := To (J);
526 Domain (N + 1) := From (J);
527 Rangev (N + 1) := To (J);
533 pragma Warnings (On);
535 return (AF.Controlled with
536 Map => new Wide_Character_Mapping_Values'(
538 Domain => Domain (1 .. N),
539 Rangev => Rangev (1 .. N)));
548 (Map : Wide_Character_Mapping) return Wide_Character_Sequence
551 return Map.Map.Rangev;
559 (Set : Wide_Character_Set) return Wide_Character_Ranges
570 (Set : Wide_Character_Set) return Wide_Character_Sequence
572 SS : constant Wide_Character_Ranges_Access := Set.Set;
574 Result : Wide_String (Positive range 1 .. 2 ** 16);
578 for J in SS'Range loop
579 for K in SS (J).Low .. SS (J).High loop
585 return Result (1 .. N);
592 -- Case of multiple range input
595 (Ranges : Wide_Character_Ranges) return Wide_Character_Set
597 Result : Wide_Character_Ranges (Ranges'Range);
602 -- The output of To_Set is required to be sorted by increasing Low
603 -- values, and discontiguous, so first we sort them as we enter them,
604 -- using a simple insertion sort.
606 pragma Warnings (Off);
607 -- Kill bogus warning on Result being uninitialized
609 for J in Ranges'Range loop
611 if Ranges (J).Low < Result (K).Low then
612 Result (K + 1 .. N + 1) := Result (K .. N);
613 Result (K) := Ranges (J);
618 Result (N + 1) := Ranges (J);
624 pragma Warnings (On);
626 -- Now collapse any contiguous or overlapping ranges
630 if Result (J).High < Result (J).Low then
632 Result (J .. N) := Result (J + 1 .. N + 1);
634 elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then
636 Wide_Character'Max (Result (J).High, Result (J + 1).High);
639 Result (J + 1 .. N) := Result (J + 2 .. N + 1);
646 if N > 0 and then Result (N).High < Result (N).Low then
650 return (AF.Controlled with
651 Set => new Wide_Character_Ranges'(Result (1 .. N)));
654 -- Case of single range input
657 (Span : Wide_Character_Range) return Wide_Character_Set
660 if Span.Low > Span.High then
662 -- This is safe, because there is no procedure with parameter
663 -- Wide_Character_Set of mode "out" or "in out".
666 return (AF.Controlled with
667 Set => new Wide_Character_Ranges'(1 => Span));
671 -- Case of wide string input
674 (Sequence : Wide_Character_Sequence) return Wide_Character_Set
676 R : Wide_Character_Ranges (1 .. Sequence'Length);
679 for J in R'Range loop
680 R (J) := (Sequence (J), Sequence (J));
686 -- Case of single wide character input
689 (Singleton : Wide_Character) return Wide_Character_Set
694 Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton)));
702 (Map : Wide_Character_Mapping;
703 Element : Wide_Character) return Wide_Character
707 MV : constant Wide_Character_Mapping_Values_Access := Map.Map;
713 -- Binary search loop
716 -- If not found, identity
721 -- Otherwise do binary divide
726 if Element < MV.Domain (M) then
729 elsif Element > MV.Domain (M) then
732 else -- Element = MV.Domain (M) then
733 return MV.Rangev (M);
739 end Ada.Strings.Wide_Maps;