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-2023, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Unchecked_Deallocation
;
34 package body Ada
.Strings
.Wide_Maps
is
41 (Left
, Right
: Wide_Character_Set
) return Wide_Character_Set
43 LS
: constant Wide_Character_Ranges_Access
:= Left
.Set
;
44 RS
: constant Wide_Character_Ranges_Access
:= Right
.Set
;
46 Result
: Wide_Character_Ranges
(1 .. LS
'Last + RS
'Last);
47 -- Each range on the right can generate at least one more range in
48 -- the result, by splitting one of the left operand ranges.
54 Left_Low
: Wide_Character;
55 -- Left_Low is lowest character of the L'th range not yet dealt with
58 if LS
'Last = 0 or else RS
'Last = 0 then
62 Left_Low
:= LS
(L
).Low
;
63 while R
<= RS
'Last loop
65 -- If next right range is below current left range, skip it
67 if RS
(R
).High
< Left_Low
then
70 -- If next right range above current left range, copy remainder
71 -- of the left range to the result
73 elsif RS
(R
).Low
> LS
(L
).High
then
75 Result
(N
).Low
:= Left_Low
;
76 Result
(N
).High
:= LS
(L
).High
;
78 exit when L
> LS
'Last;
79 Left_Low
:= LS
(L
).Low
;
82 -- Next right range overlaps bottom of left range
84 if RS
(R
).Low
<= Left_Low
then
86 -- Case of right range complete overlaps left range
88 if RS
(R
).High
>= LS
(L
).High
then
90 exit when L
> LS
'Last;
91 Left_Low
:= LS
(L
).Low
;
93 -- Case of right range eats lower part of left range
96 Left_Low
:= Wide_Character'Succ (RS
(R
).High
);
100 -- Next right range overlaps some of left range, but not bottom
104 Result
(N
).Low
:= Left_Low
;
105 Result
(N
).High
:= Wide_Character'Pred (RS
(R
).Low
);
107 -- Case of right range splits left range
109 if RS
(R
).High
< LS
(L
).High
then
110 Left_Low
:= Wide_Character'Succ (RS
(R
).High
);
113 -- Case of right range overlaps top of left range
117 exit when L
> LS
'Last;
118 Left_Low
:= LS
(L
).Low
;
124 -- Copy remainder of left ranges to result
128 Result
(N
).Low
:= Left_Low
;
129 Result
(N
).High
:= LS
(L
).High
;
133 exit when L
> LS
'Last;
135 Result
(N
) := LS
(L
);
139 return (AF
.Controlled
with
140 Set
=> new Wide_Character_Ranges
'(Result (1 .. N)));
147 -- The sorted, discontiguous form is canonical, so equality can be used
149 function "=" (Left, Right : Wide_Character_Set) return Boolean is
151 return Left.Set.all = Right.Set.all;
159 (Left, Right : Wide_Character_Set) return Wide_Character_Set
161 LS : constant Wide_Character_Ranges_Access := Left.Set;
162 RS : constant Wide_Character_Ranges_Access := Right.Set;
164 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
169 -- Loop to search for overlapping character ranges
171 while L <= LS'Last and then R <= RS'Last loop
173 if LS (L).High < RS (R).Low then
176 elsif RS (R).High < LS (L).Low then
179 -- Here we have LS (L).High >= RS (R).Low
180 -- and RS (R).High >= LS (L).Low
181 -- so we have an overlapping range
185 Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low);
187 Wide_Character'Min (LS (L).High, RS (R).High);
189 if RS (R).High = LS (L).High then
192 elsif RS (R).High < LS (L).High then
200 return (AF.Controlled with
201 Set => new Wide_Character_Ranges'(Result
(1 .. N
)));
209 (Right
: Wide_Character_Set
) return Wide_Character_Set
211 RS
: constant Wide_Character_Ranges_Access
:= Right
.Set
;
213 Result
: Wide_Character_Ranges
(1 .. RS
'Last + 1);
219 Result
(1) := (Low
=> Wide_Character'First,
220 High
=> Wide_Character'Last);
223 if RS
(1).Low
/= Wide_Character'First then
225 Result
(N
).Low
:= Wide_Character'First;
226 Result
(N
).High
:= Wide_Character'Pred (RS
(1).Low
);
229 for K
in 1 .. RS
'Last - 1 loop
231 Result
(N
).Low
:= Wide_Character'Succ (RS
(K
).High
);
232 Result
(N
).High
:= Wide_Character'Pred (RS
(K
+ 1).Low
);
235 if RS
(RS
'Last).High
/= Wide_Character'Last then
237 Result
(N
).Low
:= Wide_Character'Succ (RS
(RS
'Last).High
);
238 Result
(N
).High
:= Wide_Character'Last;
242 return (AF
.Controlled
with
243 Set
=> new Wide_Character_Ranges
'(Result (1 .. N)));
251 (Left, Right : Wide_Character_Set) return Wide_Character_Set
253 LS : constant Wide_Character_Ranges_Access := Left.Set;
254 RS : constant Wide_Character_Ranges_Access := Right.Set;
256 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
265 -- Loop through ranges in output file
268 -- If no left ranges left, copy next right range
271 exit when R > RS'Last;
273 Result (N) := RS (R);
276 -- If no right ranges left, copy next left range
278 elsif R > RS'Last then
280 Result (N) := LS (L);
284 -- We have two ranges, choose lower one
288 if LS (L).Low <= RS (R).Low then
289 Result (N) := LS (L);
292 Result (N) := RS (R);
296 -- Loop to collapse ranges into last range
299 -- Collapse next length range into current result range
303 and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
306 Wide_Character'Max (Result (N).High, LS (L).High);
309 -- Collapse next right range into current result range
313 and then RS (R).Low <=
314 Wide_Character'Succ (Result (N).High)
317 Wide_Character'Max (Result (N).High, RS (R).High);
320 -- If neither range collapses, then done with this range
329 return (AF.Controlled with
330 Set => new Wide_Character_Ranges'(Result
(1 .. N
)));
338 (Left
, Right
: Wide_Character_Set
) return Wide_Character_Set
341 return (Left
or Right
) - (Left
and Right
);
348 procedure Adjust
(Object
: in out Wide_Character_Mapping
) is
350 Object
.Map
:= new Wide_Character_Mapping_Values
'(Object.Map.all);
353 procedure Adjust (Object : in out Wide_Character_Set) is
355 Object.Set := new Wide_Character_Ranges'(Object
.Set
.all);
362 procedure Finalize
(Object
: in out Wide_Character_Mapping
) is
364 procedure Free
is new Ada
.Unchecked_Deallocation
365 (Wide_Character_Mapping_Values
,
366 Wide_Character_Mapping_Values_Access
);
369 if Object
.Map
/= Null_Map
'Unrestricted_Access then
374 procedure Finalize
(Object
: in out Wide_Character_Set
) is
376 procedure Free
is new Ada
.Unchecked_Deallocation
377 (Wide_Character_Ranges
,
378 Wide_Character_Ranges_Access
);
381 if Object
.Set
/= Null_Range
'Unrestricted_Access then
390 procedure Initialize
(Object
: in out Wide_Character_Mapping
) is
395 procedure Initialize
(Object
: in out Wide_Character_Set
) is
405 (Element
: Wide_Character;
406 Set
: Wide_Character_Set
) return Boolean
409 SS
: constant Wide_Character_Ranges_Access
:= Set
.Set
;
415 -- Binary search loop. The invariant is that if Element is in any of
416 -- of the constituent ranges it is in one between Set (L) and Set (R).
425 if Element
> SS
(M
).High
then
427 elsif Element
< SS
(M
).Low
then
441 (Elements
: Wide_Character_Set
;
442 Set
: Wide_Character_Set
) return Boolean
444 ES
: constant Wide_Character_Ranges_Access
:= Elements
.Set
;
445 SS
: constant Wide_Character_Ranges_Access
:= Set
.Set
;
452 -- If no more element ranges, done, and result is true
457 -- If more element ranges, but no more set ranges, result is false
459 elsif S
> SS
'Last then
462 -- Remove irrelevant set range
464 elsif SS
(S
).High
< ES
(E
).Low
then
467 -- Get rid of element range that is properly covered by set
469 elsif SS
(S
).Low
<= ES
(E
).Low
470 and then ES
(E
).High
<= SS
(S
).High
474 -- Otherwise we have a non-covered element range, result is false
487 (Map
: Wide_Character_Mapping
) return Wide_Character_Sequence
490 return Map
.Map
.Domain
;
498 (From
, To
: Wide_Character_Sequence
) return Wide_Character_Mapping
500 Domain
: Wide_Character_Sequence
(1 .. From
'Length);
501 Rangev
: Wide_Character_Sequence
(1 .. To
'Length);
505 if From
'Length /= To
'Length then
506 raise Translation_Error
;
509 pragma Warnings
(Off
); -- apparent uninit use of Domain
511 for J
in From
'Range loop
513 if From
(J
) = Domain
(M
) then
514 raise Translation_Error
;
515 elsif From
(J
) < Domain
(M
) then
516 Domain
(M
+ 1 .. N
+ 1) := Domain
(M
.. N
);
517 Rangev
(M
+ 1 .. N
+ 1) := Rangev
(M
.. N
);
518 Domain
(M
) := From
(J
);
519 Rangev
(M
) := To
(J
);
524 Domain
(N
+ 1) := From
(J
);
525 Rangev
(N
+ 1) := To
(J
);
531 pragma Warnings
(On
);
533 return (AF
.Controlled
with
534 Map
=> new Wide_Character_Mapping_Values
'(
536 Domain => Domain (1 .. N),
537 Rangev => Rangev (1 .. N)));
546 (Map : Wide_Character_Mapping) return Wide_Character_Sequence
549 return Map.Map.Rangev;
557 (Set : Wide_Character_Set) return Wide_Character_Ranges
568 (Set : Wide_Character_Set) return Wide_Character_Sequence
570 SS : constant Wide_Character_Ranges_Access := Set.Set;
572 Count : Natural := 0;
575 for J in SS'Range loop
577 Count + (Wide_Character'Pos (SS (J).High) -
578 Wide_Character'Pos (SS (J).Low) + 1);
581 return Result : Wide_String (1 .. Count) do
582 for J in SS'Range loop
583 for K in SS (J).Low .. SS (J).High loop
595 -- Case of multiple range input
598 (Ranges : Wide_Character_Ranges) return Wide_Character_Set
600 Result : 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_Character'Succ (Result (J).High) >= Result (J + 1).Low then
639 Wide_Character'Max (Result (J).High, Result (J + 1).High);
642 Result (J + 1 .. N) := Result (J + 2 .. N + 1);
649 if N > 0 and then Result (N).High < Result (N).Low then
653 return (AF.Controlled with
654 Set => new Wide_Character_Ranges'(Result
(1 .. N
)));
657 -- Case of single range input
660 (Span
: Wide_Character_Range
) return Wide_Character_Set
663 if Span
.Low
> Span
.High
then
665 -- This is safe, because there is no procedure with parameter
666 -- Wide_Character_Set of mode "out" or "in out".
669 return (AF
.Controlled
with
670 Set
=> new Wide_Character_Ranges
'(1 => Span));
674 -- Case of wide string input
677 (Sequence : Wide_Character_Sequence) return Wide_Character_Set
679 R : Wide_Character_Ranges (1 .. Sequence'Length);
682 for J in R'Range loop
683 R (J) := (Sequence (J), Sequence (J));
689 -- Case of single wide character input
692 (Singleton : Wide_Character) return Wide_Character_Set
697 Set => new Wide_Character_Ranges'(1 => (Singleton
, Singleton
)));
705 (Map
: Wide_Character_Mapping
;
706 Element
: Wide_Character) return Wide_Character
710 MV
: constant Wide_Character_Mapping_Values_Access
:= Map
.Map
;
716 -- Binary search loop
719 -- If not found, identity
724 -- Otherwise do binary divide
729 if Element
< MV
.Domain
(M
) then
732 elsif Element
> MV
.Domain
(M
) then
735 else -- Element = MV.Domain (M) then
736 return MV
.Rangev
(M
);
742 end Ada
.Strings
.Wide_Maps
;