|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- I N T E R F A C E S . C . S T R I N G S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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 with System; use System;
|
|
|
33 with System.Storage_Elements; use System.Storage_Elements;
|
|
|
34
|
|
|
35 with Ada.Unchecked_Conversion;
|
|
|
36
|
|
|
37 package body Interfaces.C.Strings is
|
|
|
38
|
|
|
39 -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the
|
|
|
40 -- spec, to prevent any assumptions about aliasing for values of this type,
|
|
|
41 -- since arbitrary addresses can be converted, and it is quite likely that
|
|
|
42 -- this type will in fact be used for aliasing values of other types.
|
|
|
43
|
|
|
44 function To_chars_ptr is
|
|
|
45 new Ada.Unchecked_Conversion (System.Parameters.C_Address, chars_ptr);
|
|
|
46
|
|
|
47 function To_Address is
|
|
|
48 new Ada.Unchecked_Conversion (chars_ptr, System.Parameters.C_Address);
|
|
|
49
|
|
|
50 -----------------------
|
|
|
51 -- Local Subprograms --
|
|
|
52 -----------------------
|
|
|
53
|
|
|
54 function Peek (From : chars_ptr) return char;
|
|
|
55 pragma Inline (Peek);
|
|
|
56 -- Given a chars_ptr value, obtain referenced character
|
|
|
57
|
|
|
58 procedure Poke (Value : char; Into : chars_ptr);
|
|
|
59 pragma Inline (Poke);
|
|
|
60 -- Given a chars_ptr, modify referenced Character value
|
|
|
61
|
|
|
62 function "+" (Left : chars_ptr; Right : size_t) return chars_ptr;
|
|
|
63 pragma Inline ("+");
|
|
|
64 -- Address arithmetic on chars_ptr value
|
|
|
65
|
|
|
66 function Position_Of_Nul (Into : char_array) return size_t;
|
|
|
67 -- Returns position of the first Nul in Into or Into'Last + 1 if none
|
|
|
68
|
|
|
69 -- We can't use directly System.Memory because the categorization is not
|
|
|
70 -- compatible, so we directly import here the malloc and free routines.
|
|
|
71
|
|
|
72 function Memory_Alloc (Size : size_t) return chars_ptr;
|
|
|
73 pragma Import (C, Memory_Alloc, System.Parameters.C_Malloc_Linkname);
|
|
|
74
|
|
|
75 procedure Memory_Free (Address : chars_ptr);
|
|
|
76 pragma Import (C, Memory_Free, "__gnat_free");
|
|
|
77
|
|
|
78 ---------
|
|
|
79 -- "+" --
|
|
|
80 ---------
|
|
|
81
|
|
|
82 function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
|
|
|
83 begin
|
|
|
84 return To_chars_ptr (To_Address (Left) + Storage_Offset (Right));
|
|
|
85 end "+";
|
|
|
86
|
|
|
87 ----------
|
|
|
88 -- Free --
|
|
|
89 ----------
|
|
|
90
|
|
|
91 procedure Free (Item : in out chars_ptr) is
|
|
|
92 begin
|
|
|
93 if Item = Null_Ptr then
|
|
|
94 return;
|
|
|
95 end if;
|
|
|
96
|
|
|
97 Memory_Free (Item);
|
|
|
98 Item := Null_Ptr;
|
|
|
99 end Free;
|
|
|
100
|
|
|
101 --------------------
|
|
|
102 -- New_Char_Array --
|
|
|
103 --------------------
|
|
|
104
|
|
|
105 function New_Char_Array (Chars : char_array) return chars_ptr is
|
|
|
106 Index : size_t;
|
|
|
107 Pointer : chars_ptr;
|
|
|
108
|
|
|
109 begin
|
|
|
110 -- Get index of position of null. If Index > Chars'Last,
|
|
|
111 -- nul is absent and must be added explicitly.
|
|
|
112
|
|
|
113 Index := Position_Of_Nul (Into => Chars);
|
|
|
114 Pointer := Memory_Alloc ((Index - Chars'First + 1));
|
|
|
115
|
|
|
116 -- If nul is present, transfer string up to and including nul
|
|
|
117
|
|
|
118 if Index <= Chars'Last then
|
|
|
119 Update (Item => Pointer,
|
|
|
120 Offset => 0,
|
|
|
121 Chars => Chars (Chars'First .. Index),
|
|
|
122 Check => False);
|
|
|
123 else
|
|
|
124 -- If original string has no nul, transfer whole string and add
|
|
|
125 -- terminator explicitly.
|
|
|
126
|
|
|
127 Update (Item => Pointer,
|
|
|
128 Offset => 0,
|
|
|
129 Chars => Chars,
|
|
|
130 Check => False);
|
|
|
131 Poke (nul, Into => Pointer + size_t'(Chars'Length));
|
|
|
132 end if;
|
|
|
133
|
|
|
134 return Pointer;
|
|
|
135 end New_Char_Array;
|
|
|
136
|
|
|
137 ----------------
|
|
|
138 -- New_String --
|
|
|
139 ----------------
|
|
|
140
|
|
|
141 function New_String (Str : String) return chars_ptr is
|
|
|
142
|
|
|
143 -- It's important that this subprogram uses the heap directly to compute
|
|
|
144 -- the result, and doesn't copy the string on the stack, otherwise its
|
|
|
145 -- use is limited when used from tasks on large strings.
|
|
|
146
|
|
|
147 Result : constant chars_ptr := Memory_Alloc (Str'Length + 1);
|
|
|
148
|
|
|
149 Result_Array : char_array (1 .. Str'Length + 1);
|
|
|
150 for Result_Array'Address use To_Address (Result);
|
|
|
151 pragma Import (Ada, Result_Array);
|
|
|
152
|
|
|
153 Count : size_t;
|
|
|
154
|
|
|
155 begin
|
|
|
156 To_C
|
|
|
157 (Item => Str,
|
|
|
158 Target => Result_Array,
|
|
|
159 Count => Count,
|
|
|
160 Append_Nul => True);
|
|
|
161 return Result;
|
|
|
162 end New_String;
|
|
|
163
|
|
|
164 ----------
|
|
|
165 -- Peek --
|
|
|
166 ----------
|
|
|
167
|
|
|
168 function Peek (From : chars_ptr) return char is
|
|
|
169 begin
|
|
|
170 return char (From.all);
|
|
|
171 end Peek;
|
|
|
172
|
|
|
173 ----------
|
|
|
174 -- Poke --
|
|
|
175 ----------
|
|
|
176
|
|
|
177 procedure Poke (Value : char; Into : chars_ptr) is
|
|
|
178 begin
|
|
|
179 Into.all := Character (Value);
|
|
|
180 end Poke;
|
|
|
181
|
|
|
182 ---------------------
|
|
|
183 -- Position_Of_Nul --
|
|
|
184 ---------------------
|
|
|
185
|
|
|
186 function Position_Of_Nul (Into : char_array) return size_t is
|
|
|
187 begin
|
|
|
188 for J in Into'Range loop
|
|
|
189 if Into (J) = nul then
|
|
|
190 return J;
|
|
|
191 end if;
|
|
|
192 end loop;
|
|
|
193
|
|
|
194 return Into'Last + 1;
|
|
|
195 end Position_Of_Nul;
|
|
|
196
|
|
|
197 ------------
|
|
|
198 -- Strlen --
|
|
|
199 ------------
|
|
|
200
|
|
|
201 function Strlen (Item : chars_ptr) return size_t is
|
|
|
202 Item_Index : size_t := 0;
|
|
|
203
|
|
|
204 begin
|
|
|
205 if Item = Null_Ptr then
|
|
|
206 raise Dereference_Error;
|
|
|
207 end if;
|
|
|
208
|
|
|
209 loop
|
|
|
210 if Peek (Item + Item_Index) = nul then
|
|
|
211 return Item_Index;
|
|
|
212 end if;
|
|
|
213
|
|
|
214 Item_Index := Item_Index + 1;
|
|
|
215 end loop;
|
|
|
216 end Strlen;
|
|
|
217
|
|
|
218 ------------------
|
|
|
219 -- To_Chars_Ptr --
|
|
|
220 ------------------
|
|
|
221
|
|
|
222 function To_Chars_Ptr
|
|
|
223 (Item : char_array_access;
|
|
|
224 Nul_Check : Boolean := False) return chars_ptr
|
|
|
225 is
|
|
|
226 begin
|
|
|
227 if Item = null then
|
|
|
228 return Null_Ptr;
|
|
|
229 elsif Nul_Check
|
|
|
230 and then Position_Of_Nul (Into => Item.all) > Item'Last
|
|
|
231 then
|
|
|
232 raise Terminator_Error;
|
|
|
233 else
|
|
|
234 return To_chars_ptr (Item (Item'First)'Address);
|
|
|
235 end if;
|
|
|
236 end To_Chars_Ptr;
|
|
|
237
|
|
|
238 ------------
|
|
|
239 -- Update --
|
|
|
240 ------------
|
|
|
241
|
|
|
242 procedure Update
|
|
|
243 (Item : chars_ptr;
|
|
|
244 Offset : size_t;
|
|
|
245 Chars : char_array;
|
|
|
246 Check : Boolean := True)
|
|
|
247 is
|
|
|
248 Index : chars_ptr := Item + Offset;
|
|
|
249
|
|
|
250 begin
|
|
|
251 if Check and then Offset + Chars'Length > Strlen (Item) then
|
|
|
252 raise Update_Error;
|
|
|
253 end if;
|
|
|
254
|
|
|
255 for J in Chars'Range loop
|
|
|
256 Poke (Chars (J), Into => Index);
|
|
|
257 Index := Index + size_t'(1);
|
|
|
258 end loop;
|
|
|
259 end Update;
|
|
|
260
|
|
|
261 procedure Update
|
|
|
262 (Item : chars_ptr;
|
|
|
263 Offset : size_t;
|
|
|
264 Str : String;
|
|
|
265 Check : Boolean := True)
|
|
|
266 is
|
|
|
267 begin
|
|
|
268 -- Note: in RM 95, the Append_Nul => False parameter is omitted. But
|
|
|
269 -- this has the unintended consequence of truncating the string after
|
|
|
270 -- an update. As discussed in Ada 2005 AI-242, this was unintended,
|
|
|
271 -- and should be corrected. Since this is a clear error, it seems
|
|
|
272 -- appropriate to apply the correction in Ada 95 mode as well.
|
|
|
273
|
|
|
274 Update (Item, Offset, To_C (Str, Append_Nul => False), Check);
|
|
|
275 end Update;
|
|
|
276
|
|
|
277 -----------
|
|
|
278 -- Value --
|
|
|
279 -----------
|
|
|
280
|
|
|
281 function Value (Item : chars_ptr) return char_array is
|
|
|
282 Result : char_array (0 .. Strlen (Item));
|
|
|
283
|
|
|
284 begin
|
|
|
285 if Item = Null_Ptr then
|
|
|
286 raise Dereference_Error;
|
|
|
287 end if;
|
|
|
288
|
|
|
289 -- Note that the following loop will also copy the terminating Nul
|
|
|
290
|
|
|
291 for J in Result'Range loop
|
|
|
292 Result (J) := Peek (Item + J);
|
|
|
293 end loop;
|
|
|
294
|
|
|
295 return Result;
|
|
|
296 end Value;
|
|
|
297
|
|
|
298 function Value
|
|
|
299 (Item : chars_ptr;
|
|
|
300 Length : size_t) return char_array
|
|
|
301 is
|
|
|
302 begin
|
|
|
303 if Item = Null_Ptr then
|
|
|
304 raise Dereference_Error;
|
|
|
305 end if;
|
|
|
306
|
|
|
307 -- ACATS cxb3010 checks that Constraint_Error gets raised when Length
|
|
|
308 -- is 0. Seems better to check that Length is not null before declaring
|
|
|
309 -- an array with size_t bounds of 0 .. Length - 1 anyway.
|
|
|
310
|
|
|
311 if Length = 0 then
|
|
|
312 raise Constraint_Error;
|
|
|
313 end if;
|
|
|
314
|
|
|
315 declare
|
|
|
316 Result : char_array (0 .. Length - 1);
|
|
|
317
|
|
|
318 begin
|
|
|
319 for J in Result'Range loop
|
|
|
320 Result (J) := Peek (Item + J);
|
|
|
321
|
|
|
322 if Result (J) = nul then
|
|
|
323 return Result (0 .. J);
|
|
|
324 end if;
|
|
|
325 end loop;
|
|
|
326
|
|
|
327 return Result;
|
|
|
328 end;
|
|
|
329 end Value;
|
|
|
330
|
|
|
331 function Value (Item : chars_ptr) return String is
|
|
|
332 begin
|
|
|
333 return To_Ada (Value (Item));
|
|
|
334 end Value;
|
|
|
335
|
|
|
336 function Value (Item : chars_ptr; Length : size_t) return String is
|
|
|
337 Result : char_array (0 .. Length);
|
|
|
338
|
|
|
339 begin
|
|
|
340 -- As per AI-00177, this is equivalent to:
|
|
|
341
|
|
|
342 -- To_Ada (Value (Item, Length) & nul);
|
|
|
343
|
|
|
344 if Item = Null_Ptr then
|
|
|
345 raise Dereference_Error;
|
|
|
346 end if;
|
|
|
347
|
|
|
348 for J in 0 .. Length - 1 loop
|
|
|
349 Result (J) := Peek (Item + J);
|
|
|
350
|
|
|
351 if Result (J) = nul then
|
|
|
352 return To_Ada (Result (0 .. J));
|
|
|
353 end if;
|
|
|
354 end loop;
|
|
|
355
|
|
|
356 Result (Length) := nul;
|
|
|
357 return To_Ada (Result);
|
|
|
358 end Value;
|
|
|
359
|
|
|
360 end Interfaces.C.Strings;
|
