On 02.04.13 15:42, Ludovic Brenta wrote:
> La r�ponse est, bien entendu, oui. Mais attention � bien convertir les
> pointeurs (ou valeurs acc�s en Ada) et non pas les objets point�s.
> Ensuite, si Unchecked_Conversion conduit � des recopies, ce n'est pas
> grave puisque l'on ne recopie jamais que des pointeurs.
Une possibilit�e suppl�mentaire : si en C, c'est �l�mentaire, en Ada,
il fault seulement le dire.
package View_Cmd1 is new
System.Address_To_Access_Conversions (Cmd1_Msg);
package View_Generic is new
System.Address_To_Access_Conversions (Generic_Msg);
En plus de ces conversions, B.3 garantit que on ne recopie pas des objects
correspondants aux structs en C. (Je pense que une variante de Streams.Read
aide aussi, si ce variante ne consomme pas.)
http://www.adapower.com/index.php?Command=Class&ClassID=Advanced&CID=213
with Interfaces.C;
package Ada_Side is
pragma Elaborate_Body (Ada_Side);
subtype Byte_Type is Interfaces.C.unsigned_char;
-- cf. System.Storage_Element, System.Storage_Unit
type Header_Num is range 0..1;
type Header_Type is array (Header_Num) of Byte_Type;
type Byte_Array is array (Natural range <>) of aliased Byte_Type;
Max : constant := 7;
-- 1.
type Generic_Msg is
record
Header : Header_Type;
Data : Byte_Array (0..Max);
end record;
pragma Convention (C, Generic_Msg);
procedure Pass_Generic_Msg (X : Generic_Msg);
pragma Export (C, Pass_Generic_Msg, "ada_side__pass_generic_msg");
-- 2.
type Cmd1_Type is record
Upper : String (1..Max/2+1);
Lower : String (Max/2+1+1..Max+1);
end record;
type Cmd1_Msg is
record
Header : Header_Type;
Cmd1_Data : Cmd1_Type;
end record;
procedure Pass_Cmd1_Msg (X : Cmd1_Msg);
pragma Export (C, Pass_Cmd1_Msg, "ada_side__pass_cmd1_msg");
-- 3.
function Call_Me return
Interfaces.C.int;
pragma Import (C, Call_Me, "c_side__call_me");
procedure Receive_Generic_Msg (X : out Generic_Msg);
pragma Export (C, Receive_Generic_Msg, "ada_side__receive_generic_msg");
procedure Receive_Cmd1_Msg (X : out Cmd1_Msg);
pragma Export (C, Receive_Cmd1_Msg, "ada_side__receive_cmd1_msg");
-- 4.
procedure Process_Generic (X : in out Generic_Msg);
procedure If_Header_Says (X : in out Cmd1_Msg);
type Msg_Pointer is access all Generic_Msg;
function As_Generic_Msg (X : Cmd1_Msg) return Msg_Pointer;
end Ada_Side;
-- 8< --
#define MAX 8
typedef unsigned char byte;
enum hdr { zero, un, deux, trois };
struct generic_msg {
byte header[2];
byte bytes[MAX];
};
/* Ici, il n'y a pas une d�finition de struct cmd1_msg ! */
extern void ada_side__pass_generic_msg(void*);
extern void ada_side__pass_cmd1_msg(void*);
extern void ada_side__receive_generic_msg(struct generic_msg*);
extern void ada_side__receive_cmd1_msg(void*);
int c_side__call_me(void)
{
struct generic_msg msg;
int k;
msg.header[0] = (byte)un, msg.header[1] = (byte)deux;
for (k=0; k<MAX; ++k)
msg.bytes[k] = 'A'+k;
ada_side__pass_generic_msg(&msg);
ada_side__receive_generic_msg(&msg);
ada_side__pass_cmd1_msg(&msg);
ada_side__receive_cmd1_msg(&msg);
ada_side__pass_cmd1_msg(&msg);
ada_side__receive_generic_msg(&msg);
ada_side__pass_generic_msg(&msg);
ada_side__receive_cmd1_msg(&msg);
return 0;
}
-- >8 --
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Characters.Handling;
with System.Address_To_Access_Conversions;
package body Ada_Side is
package Byte_IO is new Modular_IO (Byte_Type);
package View_Cmd1 is new
System.Address_To_Access_Conversions (Cmd1_Msg);
package View_Generic is new
System.Address_To_Access_Conversions (Generic_Msg);
The_Pointer : View_Generic.Object_Pointer;
procedure Show_Header (H : Header_Type);
function As_Generic_Msg (X : Cmd1_Msg) return Msg_Pointer is
Result : View_Generic.Object_Pointer;
begin
Result := View_Generic.To_Pointer (X'Address);
return Msg_Pointer (Result);
end As_Generic_Msg;
procedure If_Header_Says (X : in out Cmd1_Msg) is
begin
Put_Line ("processing a CMD 1");
end If_Header_Says;
procedure Pass_Cmd1_Msg (X : Cmd1_Msg) is
Data : Cmd1_Type renames X.Cmd1_Data;
use Interfaces.C;
begin
-- save:
The_Pointer := View_Generic.To_Pointer (X'Address);
Show_Header (X.Header);
Put_Line ("* CMD1:");
Put ("part U:");
Put (Data.Upper);
New_Line;
Put ("part L:");
Put (Data.Lower);
New_Line;
end Pass_Cmd1_Msg;
procedure Pass_Generic_Msg (X : Generic_Msg) is
begin
-- save:
The_Pointer := View_Generic.To_Pointer (X'Address);
Show_Header (X.Header);
-- dump:
Put_Line ("@ MSG:");
for K in X.Data'Range loop
Byte_IO.Put (X.Data (K));
end loop;
New_Line;
end Pass_Generic_Msg;
procedure Process_Generic (X : in out Generic_Msg) is
-- si on ne veut pas le Unchecked_Conversion et pas
-- les d�finitions comme for X'Address use ...
It : View_Cmd1.Object_Pointer := View_Cmd1.To_Pointer (X'Address);
begin
case X.Header (X.Header'First) is
when 1 =>
If_Header_Says (It.all);
when others =>
null;
end case;
end Process_Generic;
procedure Receive_Cmd1_Msg (X : out Cmd1_Msg) is
-- LRM B.3 (69/2)
use Ada.Characters.Handling, Interfaces.C;
procedure Toggle_Case (Pfx : in out Character) is
begin
if Pfx in 'A' .. 'Z' then
Pfx := To_Lower (Pfx);
else
Pfx := To_Upper (Pfx);
end if;
end Toggle_Case;
Data : Cmd1_Type renames X.Cmd1_Data;
begin
X := View_Cmd1.To_Pointer (The_Pointer.all'Address).all;
Toggle_Case (Data.Upper (Data.Upper'First));
Toggle_Case (Data.Lower (Data.Lower'First));
end Receive_Cmd1_Msg;
procedure Receive_Generic_Msg (X : out Generic_Msg) is
-- LRM B.3 (69/2)
begin
X := The_Pointer.all;
end Receive_Generic_Msg;
procedure Show_Header (H : Header_Type) is
package HNum_IO is new Integer_IO (Header_Num);
begin
HNum_IO.Default_Width := 1;
Put_Line (">");
for K in H'Range loop
Put ('H'); HNum_IO.Put (K); Put (':');
Byte_IO.Put (H (K)); New_Line;
end loop;
end Show_Header;
begin
Byte_IO.Default_Base := 16;
Byte_IO.Default_Width := 8;
end Ada_Side;
with Ada_Side; use Ada_Side;
with Interfaces.C;
procedure Test_Ada_Side is
Result :
Interfaces.C.int;
Stuff : Cmd1_Msg;
begin
Result := Call_Me; -- calling C, which in turn calls Ada
Stuff.Header (0) := 0;
Process_Generic (As_Generic_Msg (Stuff).all);
Stuff.Header (0) := 1;
Process_Generic (As_Generic_Msg (Stuff).all);
end Test_Ada_Side;
$ ./test_ada_side
>
H0: 16#1#
H1: 16#2#
@ MSG:
16#41# 16#42# 16#43# 16#44# 16#45# 16#46# 16#47# 16#48#
>
H0: 16#1#
H1: 16#2#
* CMD1:
part U:ABCD
part L:EFGH
>
H0: 16#1#
H1: 16#2#
* CMD1:
part U:aBCD
part L:eFGH
>
H0: 16#1#
H1: 16#2#
@ MSG:
16#61# 16#42# 16#43# 16#44# 16#65# 16#46# 16#47# 16#48#
processing a CMD 1