File : i-c.adb
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
5 -- I N T E R F A C E S . C --
-- --
-- B o d y --
-- --
-- $Revision: 1.15 $
10 -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
30 -- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
35
package body Interfaces.C is
-----------------------
-- Is_Nul_Terminated --
40 -----------------------
-- Case of char_array
function Is_Nul_Terminated (Item : char_array) return Boolean is
45 begin
for J in Item'Range loop
if Item (J) = nul then
return True;
end if;
50 end loop;
return False;
end Is_Nul_Terminated;
55 -- Case of wchar_array
function Is_Nul_Terminated (Item : wchar_array) return Boolean is
begin
for J in Item'Range loop
60 if Item (J) = wide_nul then
return True;
end if;
end loop;
65 return False;
end Is_Nul_Terminated;
------------
-- To_Ada --
70 ------------
-- Convert char to Character
function To_Ada (Item : char) return Character is
75 begin
return Character'Val (char'Pos (Item));
end To_Ada;
-- Convert char_array to String (function form)
80
function To_Ada
(Item : char_array;
Trim_Nul : Boolean := True)
return String
85 is
Count : Natural;
From : size_t;
begin
90 if Trim_Nul then
From := Item'First;
loop
if From > Item'Last then
95 raise Terminator_Error;
elsif Item (From) = nul then
exit;
else
From := From + 1;
100 end if;
end loop;
Count := Natural (From - Item'First);
105 else
Count := Item'Length;
end if;
declare
110 R : String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
115 end loop;
return R;
end;
end To_Ada;
120
-- Convert char_array to String (procedure form)
procedure To_Ada
(Item : char_array;
125 Target : out String;
Count : out Natural;
Trim_Nul : Boolean := True)
is
From : size_t;
130 To : Positive;
begin
if Trim_Nul then
From := Item'First;
135 loop
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = nul then
exit;
140 else
From := From + 1;
end if;
end loop;
145 Count := Natural (From - Item'First);
else
Count := Item'Length;
end if;
150
if Count > Target'Length then
raise Constraint_Error;
else
155 From := Item'First;
To := Target'First;
for J in 1 .. Count loop
Target (To) := Character (Item (From));
160 From := From + 1;
To := To + 1;
end loop;
end if;
165 end To_Ada;
-- Convert wchar_t to Wide_Character
function To_Ada (Item : wchar_t) return Wide_Character is
170 begin
return Wide_Character (Item);
end To_Ada;
-- Convert wchar_array to Wide_String (function form)
175
function To_Ada
(Item : wchar_array;
Trim_Nul : Boolean := True)
return Wide_String
180 is
Count : Natural;
From : size_t;
begin
185 if Trim_Nul then
From := Item'First;
loop
if From > Item'Last then
190 raise Terminator_Error;
elsif Item (From) = wide_nul then
exit;
else
From := From + 1;
195 end if;
end loop;
Count := Natural (From - Item'First);
200 else
Count := Item'Length;
end if;
declare
205 R : Wide_String (1 .. Count);
begin
for J in R'Range loop
R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
210 end loop;
return R;
end;
end To_Ada;
215
-- Convert wchar_array to Wide_String (procedure form)
procedure To_Ada
(Item : wchar_array;
220 Target : out Wide_String;
Count : out Natural;
Trim_Nul : Boolean := True)
is
From : size_t;
225 To : Positive;
begin
if Trim_Nul then
From := Item'First;
230 loop
if From > Item'Last then
raise Terminator_Error;
elsif Item (From) = wide_nul then
exit;
235 else
From := From + 1;
end if;
end loop;
240 Count := Natural (From - Item'First);
else
Count := Item'Length;
end if;
245
if Count > Target'Length then
raise Constraint_Error;
else
250 From := Item'First;
To := Target'First;
for J in 1 .. Count loop
Target (To) := To_Ada (Item (From));
255 From := From + 1;
To := To + 1;
end loop;
end if;
260 end To_Ada;
----------
-- To_C --
----------
265
-- Convert Character to char
function To_C (Item : Character) return char is
begin
270 return char'Val (Character'Pos (Item));
end To_C;
-- Convert String to char_array (function form)
275 function To_C
(Item : String;
Append_Nul : Boolean := True)
return char_array
is
280 begin
if Append_Nul then
declare
R : char_array (0 .. Item'Length);
285 begin
for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
end loop;
290 R (R'Last) := nul;
return R;
end;
else -- Append_Nul is False
295
-- A nasty case, if the string is null, we must return
-- a null char_array. The lower bound of this array is
-- required to be zero (RM B.3(50)) but that is of course
-- impossible given that size_t is unsigned. This needs
300 -- ARG resolution, but for now GNAT returns bounds 1 .. 0
if Item'Length = 0 then
declare
R : char_array (1 .. 0);
305
begin
return R;
end;
310 else
declare
R : char_array (0 .. Item'Length - 1);
begin
315 for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
end loop;
return R;
320 end;
end if;
end if;
end To_C;
325 -- Convert String to char_array (procedure form)
procedure To_C
(Item : String;
Target : out char_array;
330 Count : out size_t;
Append_Nul : Boolean := True)
is
To : size_t;
335 begin
if Target'Length < Item'Length then
raise Constraint_Error;
else
340 To := Target'First;
for From in Item'Range loop
Target (To) := char (Item (From));
To := To + 1;
end loop;
345
if Append_Nul then
if To > Target'Last then
raise Constraint_Error;
else
350 Target (To) := nul;
Count := Item'Length + 1;
end if;
else
355 Count := Item'Length;
end if;
end if;
end To_C;
360 -- Convert Wide_Character to wchar_t
function To_C (Item : Wide_Character) return wchar_t is
begin
return wchar_t (Item);
365 end To_C;
-- Convert Wide_String to wchar_array (function form)
function To_C
370 (Item : Wide_String;
Append_Nul : Boolean := True)
return wchar_array
is
begin
375 if Append_Nul then
declare
R : wchar_array (0 .. Item'Length);
begin
380 for J in Item'Range loop
R (size_t (J - Item'First)) := To_C (Item (J));
end loop;
R (R'Last) := wide_nul;
385 return R;
end;
else
-- A nasty case, if the string is null, we must return
390 -- a null char_array. The lower bound of this array is
-- required to be zero (RM B.3(50)) but that is of course
-- impossible given that size_t is unsigned. This needs
-- ARG resolution, but for now GNAT returns bounds 1 .. 0
395 if Item'Length = 0 then
declare
R : wchar_array (1 .. 0);
begin
400 return R;
end;
else
declare
405 R : wchar_array (0 .. Item'Length - 1);
begin
for J in size_t range 0 .. Item'Length - 1 loop
R (J) := To_C (Item (Integer (J) + Item'First));
410 end loop;
return R;
end;
end if;
415 end if;
end To_C;
-- Convert Wide_String to wchar_array (procedure form)
420 procedure To_C
(Item : Wide_String;
Target : out wchar_array;
Count : out size_t;
Append_Nul : Boolean := True)
425 is
To : size_t;
begin
if Target'Length < Item'Length then
430 raise Constraint_Error;
else
To := Target'First;
for From in Item'Range loop
435 Target (To) := To_C (Item (From));
To := To + 1;
end loop;
if Append_Nul then
440 if To > Target'Last then
raise Constraint_Error;
else
Target (To) := wide_nul;
Count := Item'Length + 1;
445 end if;
else
Count := Item'Length;
end if;
450 end if;
end To_C;
end Interfaces.C;