1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- I N T E R F A C E S . C --
9 -- Copyright (C) 1992-2004 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 package body Interfaces
.C
is
36 -----------------------
37 -- Is_Nul_Terminated --
38 -----------------------
42 function Is_Nul_Terminated
(Item
: char_array
) return Boolean is
44 for J
in Item
'Range loop
45 if Item
(J
) = nul
then
51 end Is_Nul_Terminated
;
53 -- Case of wchar_array
55 function Is_Nul_Terminated
(Item
: wchar_array
) return Boolean is
57 for J
in Item
'Range loop
58 if Item
(J
) = wide_nul
then
64 end Is_Nul_Terminated
;
70 -- Convert char to Character
72 function To_Ada
(Item
: char
) return Character is
74 return Character'Val (char
'Pos (Item
));
77 -- Convert char_array to String (function form)
81 Trim_Nul
: Boolean := True)
92 if From
> Item
'Last then
93 raise Terminator_Error
;
94 elsif Item
(From
) = nul
then
101 Count
:= Natural (From
- Item
'First);
104 Count
:= Item
'Length;
108 R
: String (1 .. Count
);
111 for J
in R
'Range loop
112 R
(J
) := To_Ada
(Item
(size_t
(J
) + (Item
'First - 1)));
119 -- Convert char_array to String (procedure form)
125 Trim_Nul
: Boolean := True)
134 if From
> Item
'Last then
135 raise Terminator_Error
;
136 elsif Item
(From
) = nul
then
143 Count
:= Natural (From
- Item
'First);
146 Count
:= Item
'Length;
149 if Count
> Target
'Length then
150 raise Constraint_Error
;
156 for J
in 1 .. Count
loop
157 Target
(To
) := Character (Item
(From
));
165 -- Convert wchar_t to Wide_Character
167 function To_Ada
(Item
: wchar_t
) return Wide_Character is
169 return Wide_Character (Item
);
172 -- Convert wchar_array to Wide_String (function form)
176 Trim_Nul
: Boolean := True)
187 if From
> Item
'Last then
188 raise Terminator_Error
;
189 elsif Item
(From
) = wide_nul
then
196 Count
:= Natural (From
- Item
'First);
199 Count
:= Item
'Length;
203 R
: Wide_String (1 .. Count
);
206 for J
in R
'Range loop
207 R
(J
) := To_Ada
(Item
(size_t
(J
) + (Item
'First - 1)));
214 -- Convert wchar_array to Wide_String (procedure form)
218 Target
: out Wide_String;
220 Trim_Nul
: Boolean := True)
229 if From
> Item
'Last then
230 raise Terminator_Error
;
231 elsif Item
(From
) = wide_nul
then
238 Count
:= Natural (From
- Item
'First);
241 Count
:= Item
'Length;
244 if Count
> Target
'Length then
245 raise Constraint_Error
;
251 for J
in 1 .. Count
loop
252 Target
(To
) := To_Ada
(Item
(From
));
264 -- Convert Character to char
266 function To_C
(Item
: Character) return char
is
268 return char
'Val (Character'Pos (Item
));
271 -- Convert String to char_array (function form)
275 Append_Nul
: Boolean := True)
281 R
: char_array
(0 .. Item
'Length);
284 for J
in Item
'Range loop
285 R
(size_t
(J
- Item
'First)) := To_C
(Item
(J
));
296 -- A nasty case, if the string is null, we must return
297 -- a null char_array. The lower bound of this array is
298 -- required to be zero (RM B.3(50)) but that is of course
299 -- impossible given that size_t is unsigned. According to
300 -- Ada 2005 AI-258, the result is to raise Constraint_Error.
302 if Item
'Length = 0 then
303 raise Constraint_Error
;
309 R
: char_array
(0 .. Item
'Length - 1);
312 for J
in Item
'Range loop
313 R
(size_t
(J
- Item
'First)) := To_C
(Item
(J
));
322 -- Convert String to char_array (procedure form)
326 Target
: out char_array
;
328 Append_Nul
: Boolean := True)
333 if Target
'Length < Item
'Length then
334 raise Constraint_Error
;
338 for From
in Item
'Range loop
339 Target
(To
) := char
(Item
(From
));
344 if To
> Target
'Last then
345 raise Constraint_Error
;
348 Count
:= Item
'Length + 1;
352 Count
:= Item
'Length;
357 -- Convert Wide_Character to wchar_t
359 function To_C
(Item
: Wide_Character) return wchar_t
is
361 return wchar_t
(Item
);
364 -- Convert Wide_String to wchar_array (function form)
368 Append_Nul
: Boolean := True)
374 R
: wchar_array
(0 .. Item
'Length);
377 for J
in Item
'Range loop
378 R
(size_t
(J
- Item
'First)) := To_C
(Item
(J
));
381 R
(R
'Last) := wide_nul
;
386 -- A nasty case, if the string is null, we must return
387 -- a null char_array. The lower bound of this array is
388 -- required to be zero (RM B.3(50)) but that is of course
389 -- impossible given that size_t is unsigned. This needs
390 -- ARG resolution, but for now GNAT returns bounds 1 .. 0
392 if Item
'Length = 0 then
394 R
: wchar_array
(1 .. 0);
402 R
: wchar_array
(0 .. Item
'Length - 1);
405 for J
in size_t
range 0 .. Item
'Length - 1 loop
406 R
(J
) := To_C
(Item
(Integer (J
) + Item
'First));
415 -- Convert Wide_String to wchar_array (procedure form)
419 Target
: out wchar_array
;
421 Append_Nul
: Boolean := True)
426 if Target
'Length < Item
'Length then
427 raise Constraint_Error
;
431 for From
in Item
'Range loop
432 Target
(To
) := To_C
(Item
(From
));
437 if To
> Target
'Last then
438 raise Constraint_Error
;
440 Target
(To
) := wide_nul
;
441 Count
:= Item
'Length + 1;
445 Count
:= Item
'Length;