1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                     A D A . S T R I N G S . M A P S                      --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, Free Software Foundation, Inc.         --
10--                                                                          --
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.                                     --
17--                                                                          --
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.               --
21--                                                                          --
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/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  Note: parts of this code are derived from the ADAR.CSH public domain
33--  Ada 83 versions of the Appendix C string handling packages. The main
34--  differences are that we avoid the use of the minimize function which
35--  is bit-by-bit or character-by-character and therefore rather slow.
36--  Generally for character sets we favor the full 32-byte representation.
37
38package body Ada.Strings.Maps is
39
40   ---------
41   -- "-" --
42   ---------
43
44   function "-" (Left, Right : Character_Set) return Character_Set is
45   begin
46      return Left and not Right;
47   end "-";
48
49   ---------
50   -- "=" --
51   ---------
52
53   function "=" (Left, Right : Character_Set) return Boolean is
54   begin
55      return Character_Set_Internal (Left) = Character_Set_Internal (Right);
56   end "=";
57
58   -----------
59   -- "and" --
60   -----------
61
62   function "and" (Left, Right : Character_Set) return Character_Set is
63   begin
64      return Character_Set
65        (Character_Set_Internal (Left) and Character_Set_Internal (Right));
66   end "and";
67
68   -----------
69   -- "not" --
70   -----------
71
72   function "not" (Right : Character_Set) return Character_Set is
73   begin
74      return Character_Set (not Character_Set_Internal (Right));
75   end "not";
76
77   ----------
78   -- "or" --
79   ----------
80
81   function "or" (Left, Right : Character_Set) return Character_Set is
82   begin
83      return Character_Set
84        (Character_Set_Internal (Left) or Character_Set_Internal (Right));
85   end "or";
86
87   -----------
88   -- "xor" --
89   -----------
90
91   function "xor" (Left, Right : Character_Set) return Character_Set is
92   begin
93      return Character_Set
94        (Character_Set_Internal (Left) xor Character_Set_Internal (Right));
95   end "xor";
96
97   -----------
98   -- Is_In --
99   -----------
100
101   function Is_In
102     (Element : Character;
103      Set     : Character_Set) return Boolean
104   is
105   begin
106      return Set (Element);
107   end Is_In;
108
109   ---------------
110   -- Is_Subset --
111   ---------------
112
113   function Is_Subset
114     (Elements : Character_Set;
115      Set      : Character_Set) return Boolean
116   is
117   begin
118      return (Elements and Set) = Elements;
119   end Is_Subset;
120
121   ---------------
122   -- To_Domain --
123   ---------------
124
125   function To_Domain (Map : Character_Mapping) return Character_Sequence
126   is
127      Result : String (1 .. Map'Length);
128      J      : Natural;
129
130   begin
131      J := 0;
132      for C in Map'Range loop
133         if Map (C) /= C then
134            J := J + 1;
135            Result (J) := C;
136         end if;
137      end loop;
138
139      return Result (1 .. J);
140   end To_Domain;
141
142   ----------------
143   -- To_Mapping --
144   ----------------
145
146   function To_Mapping
147     (From, To : Character_Sequence) return Character_Mapping
148   is
149      Result   : Character_Mapping;
150      Inserted : Character_Set := Null_Set;
151      From_Len : constant Natural := From'Length;
152      To_Len   : constant Natural := To'Length;
153
154   begin
155      if From_Len /= To_Len then
156         raise Strings.Translation_Error;
157      end if;
158
159      for Char in Character loop
160         Result (Char) := Char;
161      end loop;
162
163      for J in From'Range loop
164         if Inserted (From (J)) then
165            raise Strings.Translation_Error;
166         end if;
167
168         Result   (From (J)) := To (J - From'First + To'First);
169         Inserted (From (J)) := True;
170      end loop;
171
172      return Result;
173   end To_Mapping;
174
175   --------------
176   -- To_Range --
177   --------------
178
179   function To_Range (Map : Character_Mapping) return Character_Sequence
180   is
181      Result : String (1 .. Map'Length);
182      J      : Natural;
183   begin
184      J := 0;
185      for C in Map'Range loop
186         if Map (C) /= C then
187            J := J + 1;
188            Result (J) := Map (C);
189         end if;
190      end loop;
191
192      return Result (1 .. J);
193   end To_Range;
194
195   ---------------
196   -- To_Ranges --
197   ---------------
198
199   function To_Ranges (Set : Character_Set) return Character_Ranges is
200      Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
201      Range_Num  : Natural;
202      C          : Character;
203
204   begin
205      C := Character'First;
206      Range_Num := 0;
207
208      loop
209         --  Skip gap between subsets
210
211         while not Set (C) loop
212            exit when C = Character'Last;
213            C := Character'Succ (C);
214         end loop;
215
216         exit when not Set (C);
217
218         Range_Num := Range_Num + 1;
219         Max_Ranges (Range_Num).Low := C;
220
221         --  Span a subset
222
223         loop
224            exit when not Set (C) or else C = Character'Last;
225            C := Character'Succ (C);
226         end loop;
227
228         if Set (C) then
229            Max_Ranges (Range_Num). High := C;
230            exit;
231         else
232            Max_Ranges (Range_Num). High := Character'Pred (C);
233         end if;
234      end loop;
235
236      return Max_Ranges (1 .. Range_Num);
237   end To_Ranges;
238
239   -----------------
240   -- To_Sequence --
241   -----------------
242
243   function To_Sequence (Set : Character_Set) return Character_Sequence is
244      Result : String (1 .. Character'Pos (Character'Last) + 1);
245      Count  : Natural := 0;
246   begin
247      for Char in Set'Range loop
248         if Set (Char) then
249            Count := Count + 1;
250            Result (Count) := Char;
251         end if;
252      end loop;
253
254      return Result (1 .. Count);
255   end To_Sequence;
256
257   ------------
258   -- To_Set --
259   ------------
260
261   function To_Set (Ranges : Character_Ranges) return Character_Set is
262      Result : Character_Set;
263   begin
264      for C in Result'Range loop
265         Result (C) := False;
266      end loop;
267
268      for R in Ranges'Range loop
269         for C in Ranges (R).Low .. Ranges (R).High loop
270            Result (C) := True;
271         end loop;
272      end loop;
273
274      return Result;
275   end To_Set;
276
277   function To_Set (Span : Character_Range) return Character_Set is
278      Result : Character_Set;
279   begin
280      for C in Result'Range loop
281         Result (C) := False;
282      end loop;
283
284      for C in Span.Low .. Span.High loop
285         Result (C) := True;
286      end loop;
287
288      return Result;
289   end To_Set;
290
291   function To_Set (Sequence : Character_Sequence) return Character_Set is
292      Result : Character_Set := Null_Set;
293   begin
294      for J in Sequence'Range loop
295         Result (Sequence (J)) := True;
296      end loop;
297
298      return Result;
299   end To_Set;
300
301   function To_Set (Singleton : Character) return Character_Set is
302      Result : Character_Set := Null_Set;
303   begin
304      Result (Singleton) := True;
305      return Result;
306   end To_Set;
307
308   -----------
309   -- Value --
310   -----------
311
312   function Value
313     (Map     : Character_Mapping;
314      Element : Character) return Character
315   is
316   begin
317      return Map (Element);
318   end Value;
319
320end Ada.Strings.Maps;
321