Bonjour,
Dans une application faisant un usage normal, voire intensif de la messagerie Hilscher, on peut éviter d’allouer puis libérer continuellement des paquets en utilisant un réservoir (Pool) de paquets.
Ce réservoir de paquets est implémenté dans le paquetage générique « A4A.Protocols.HilscherX.Message_Pool ».
On met en œuvre un type protégé qui autorise une utilisation par plusieurs tâches du Pool.
Ainsi, on instancie ce paquetage générique avec la taille souhaitée, on l’initialise avec la procédure idoine puis on peut obtenir un accès sur un paquet avec la procédure « Get_Packet », on s’en sert et enfin on le retourne au Pool avec la procédure « Return_Packet ». Si tous les paquets sont en cours d’utilisation on attend son tour.
Il est également souhaitable d’utiliser des queues pour gérer les flux de messages en émission comme en réception.
Le paquetage générique « A4A.Protocols.HilscherX.Message_Queue » constitue une implémentation possible d’une FIFO, aussi sous la forme d’un type protégé.
On pourra utiliser ces queues entre les objets initiateurs des requêtes et la tâche gérant l’émission ou entre la tâche de réception et les objets destinataires des réponses ou indications.
Après instanciation de ce paquetage, il est possible d’insérer dans la queue un paquet, ou plutôt une référence à ce paquet, avec la procédure « Put » (qui indique si cela a pu être réalisé ou pas – la queue est pleine).
On peut interroger la queue avec la procédure « Get », qui indique si la queue est vide le cas échéant, ou avec l’entrée « Get » qui permet une mise en attente de la tâche appelante si la queue est vide. La procédure est normalement utilisée par les objets en attente de réponse car elle est non bloquante.
Un exemple d’une telle infrastructure est fourni par le paquetage « A4A.Protocols.HilscherX.Messaging » dont la spécification est :
-----------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
-- <summary>
-- This package provides the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - messaging infrastructure.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>
with A4A.Protocols.HilscherX.cifX_Errors;
use A4A.Protocols.HilscherX.cifX_Errors;
with A4A.Protocols.HilscherX.cifX_User;
use A4A.Protocols.HilscherX.cifX_User;
with A4A.Protocols.HilscherX.Message_Queue;
with A4A.Protocols.HilscherX.Message_Pool;
package A4A.Protocols.HilscherX.Messaging is
procedure Quit;
procedure Initialise (Channel_Handle : in Channel_Handle_Type);
package Pool_Package is new
A4A.Protocols.HilscherX.Message_Pool (Pool_Size => 20);
Message_Pool : Pool_Package.Message_Pool_Type;
package Queue_Package is new
A4A.Protocols.HilscherX.Message_Queue (Queue_Size => 10);
Send_Queue : Queue_Package.Message_Queue_Type;
Receive_Queue : Queue_Package.Message_Queue_Type;
task Send_Msg;
task Receive_Msg;
private
Quit_Flag : Boolean := False;
Init_Flag : Boolean := False;
The_Channel_Handle : Channel_Handle_Type;
end A4A.Protocols.HilscherX.Messaging;
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
-- <summary>
-- This package provides the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - messaging infrastructure.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>
with A4A.Protocols.HilscherX.cifX_Errors;
use A4A.Protocols.HilscherX.cifX_Errors;
with A4A.Protocols.HilscherX.cifX_User;
use A4A.Protocols.HilscherX.cifX_User;
with A4A.Protocols.HilscherX.Message_Queue;
with A4A.Protocols.HilscherX.Message_Pool;
package A4A.Protocols.HilscherX.Messaging is
procedure Quit;
procedure Initialise (Channel_Handle : in Channel_Handle_Type);
package Pool_Package is new
A4A.Protocols.HilscherX.Message_Pool (Pool_Size => 20);
Message_Pool : Pool_Package.Message_Pool_Type;
package Queue_Package is new
A4A.Protocols.HilscherX.Message_Queue (Queue_Size => 10);
Send_Queue : Queue_Package.Message_Queue_Type;
Receive_Queue : Queue_Package.Message_Queue_Type;
task Send_Msg;
task Receive_Msg;
private
Quit_Flag : Boolean := False;
Init_Flag : Boolean := False;
The_Channel_Handle : Channel_Handle_Type;
end A4A.Protocols.HilscherX.Messaging;
On y trouve :
- L’instanciation du paquetage « réservoir de paquets » et la déclaration du pool
- L’instanciation du paquetage « queue de paquets » et la déclaration des queues d’émission et réception
- La déclaration des deux tâches d’émission et réception
Le code de l’application de test est montré ci-dessous qui réalise la même opération que dans l’article précédent mais en utilisant bien sûr cette infrastructure :
-----------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
with Ada.Text_IO;
with Interfaces.C;
with Ada.Exceptions; use Ada.Exceptions;
with A4A; use A4A;
with A4A.Protocols.HilscherX.cifX_Errors;
use A4A.Protocols.HilscherX.cifX_Errors;
with A4A.Protocols.HilscherX.cifX_User;
with A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify;
use A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify;
with A4A.Protocols.HilscherX.Messaging;
use A4A.Protocols.HilscherX;
procedure Test_Messaging is
package cifX renames A4A.Protocols.HilscherX.cifX_User;
Driver_Handle : aliased cifX.Driver_Handle_Type;
Channel_Handle : aliased cifX.Channel_Handle_Type;
Result : DInt;
Request : cifX.cifX_Packet_Access;
Confirmation : cifX.cifX_Packet_Access;
cifX_Driver_Init_Done : Boolean := False;
cifX_Driver_Open_Done : Boolean := False;
cifX_Channel_Open_Done : Boolean := False;
Fw_Ident_Req : RCX_FIRMWARE_IDENTIFY_REQ_T_Access;
Fw_Ident_Cnf : RCX_FIRMWARE_IDENTIFY_CNF_T_Access;
Packet_Got : Boolean := False;
Packet_Put : Boolean := False;
procedure cifX_Show_Firmware_Identification is
What : String := CRLF
& "***********************************************" & CRLF
& " Firmware Identification" & CRLF & CRLF
& "Firmware Version :" & CRLF
& "Major : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Major'Img & CRLF
& "Minor : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Minor'Img & CRLF
& "Build : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Build'Img & CRLF
& "Revision : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Revision'Img & CRLF
& CRLF
& "Firmware Name : "
& Interfaces.C.To_Ada
(Fw_Ident_Cnf.Data.Fw_Identification.Fw_Name.Name) & CRLF
& CRLF
& "Firmware Date :" & CRLF
& "Year : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Year'Img & CRLF
& "Month : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Month'Img & CRLF
& "Day : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Day'Img & CRLF
& "***********************************************" & CRLF;
begin
Ada.Text_IO.Put_Line (What);
end cifX_Show_Firmware_Identification;
procedure Close is
begin
Messaging.Quit;
delay 5.0;
if cifX_Channel_Open_Done then
Ada.Text_IO.Put_Line (Item => "Closing Channel");
Result := cifX.Channel_Close (Channel_Handle);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
end if;
cifX_Channel_Open_Done := False;
end if;
if cifX_Driver_Open_Done then
Ada.Text_IO.Put_Line (Item => "Closing Driver");
Result := cifX.Driver_Close (Driver_Handle);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
end if;
cifX_Driver_Open_Done := False;
end if;
if cifX_Driver_Init_Done then
Ada.Text_IO.Put_Line (Item => "Deinitializing cifX Driver");
cifX.Driver_Deinit;
cifX_Driver_Init_Done := False;
end if;
end Close;
begin
Ada.Text_IO.Put_Line (Item => "Test_Messaging...");
Ada.Text_IO.Put_Line (Item => "Initializing cifX Driver");
Result := cifX.Driver_Init;
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Driver_Init_Done := True;
end if;
if cifX_Driver_Init_Done then
Ada.Text_IO.Put_Line (Item => "Opening Driver");
Result := cifX.Driver_Open (Driver_Handle'Access);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Driver_Open_Done := True;
end if;
end if;
if cifX_Driver_Open_Done then
Ada.Text_IO.Put_Line (Item => "Opening Channel");
Result := cifX.Channel_Open
(Driver_Handle => Driver_Handle,
Board_Name => "cifX0",
Channel_Number => 0,
Channel_Handle_Access => Channel_Handle'Access);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Channel_Open_Done := True;
end if;
end if;
if cifX_Channel_Open_Done then
Messaging.Initialise (Channel_Handle => Channel_Handle);
Ada.Text_IO.Put_Line (Item => "Sending Request");
Messaging.Message_Pool.Get_Packet
(Item => Request,
Result => Packet_Got);
if not Packet_Got then
Ada.Text_IO.Put_Line
("Could not get Request packet from pool...");
else
Fw_Ident_Req := From_cifX_Packet (Request);
Fw_Ident_Req.Head.Dest := 16#20#;
Fw_Ident_Req.Head.Src := 0;
Fw_Ident_Req.Head.Dest_Id := 0;
Fw_Ident_Req.Head.Src_Id := 0;
Fw_Ident_Req.Head.Len := 4;
Fw_Ident_Req.Head.Id := 1;
Fw_Ident_Req.Head.State := 0;
Fw_Ident_Req.Head.Cmd := RCX_FIRMWARE_IDENTIFY_REQ;
Fw_Ident_Req.Head.Ext := 0;
Fw_Ident_Req.Head.Rout := 0;
Fw_Ident_Req.Data.Channel_Id := 0;
Messaging.Send_Queue.Put
(Item => Request,
Result => Packet_Put);
if not Packet_Put then
Ada.Text_IO.Put_Line
("Could not put Request packet in queue...");
Messaging.Message_Pool.Return_Packet (Item => Request);
else
Messaging.Receive_Queue.Get (Item => Confirmation);
Fw_Ident_Cnf := From_cifX_Packet (Confirmation);
cifX_Show_Firmware_Identification;
Messaging.Message_Pool.Return_Packet (Item => Confirmation);
end if;
end if;
end if;
Close;
exception
when Error: others =>
Ada.Text_IO.Put_Line (Exception_Information(Error));
Close;
end Test_Messaging;
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
with Ada.Text_IO;
with Interfaces.C;
with Ada.Exceptions; use Ada.Exceptions;
with A4A; use A4A;
with A4A.Protocols.HilscherX.cifX_Errors;
use A4A.Protocols.HilscherX.cifX_Errors;
with A4A.Protocols.HilscherX.cifX_User;
with A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify;
use A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify;
with A4A.Protocols.HilscherX.Messaging;
use A4A.Protocols.HilscherX;
procedure Test_Messaging is
package cifX renames A4A.Protocols.HilscherX.cifX_User;
Driver_Handle : aliased cifX.Driver_Handle_Type;
Channel_Handle : aliased cifX.Channel_Handle_Type;
Result : DInt;
Request : cifX.cifX_Packet_Access;
Confirmation : cifX.cifX_Packet_Access;
cifX_Driver_Init_Done : Boolean := False;
cifX_Driver_Open_Done : Boolean := False;
cifX_Channel_Open_Done : Boolean := False;
Fw_Ident_Req : RCX_FIRMWARE_IDENTIFY_REQ_T_Access;
Fw_Ident_Cnf : RCX_FIRMWARE_IDENTIFY_CNF_T_Access;
Packet_Got : Boolean := False;
Packet_Put : Boolean := False;
procedure cifX_Show_Firmware_Identification is
What : String := CRLF
& "***********************************************" & CRLF
& " Firmware Identification" & CRLF & CRLF
& "Firmware Version :" & CRLF
& "Major : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Major'Img & CRLF
& "Minor : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Minor'Img & CRLF
& "Build : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Build'Img & CRLF
& "Revision : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Version.Revision'Img & CRLF
& CRLF
& "Firmware Name : "
& Interfaces.C.To_Ada
(Fw_Ident_Cnf.Data.Fw_Identification.Fw_Name.Name) & CRLF
& CRLF
& "Firmware Date :" & CRLF
& "Year : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Year'Img & CRLF
& "Month : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Month'Img & CRLF
& "Day : "
& Fw_Ident_Cnf.Data.Fw_Identification.Fw_Date.Day'Img & CRLF
& "***********************************************" & CRLF;
begin
Ada.Text_IO.Put_Line (What);
end cifX_Show_Firmware_Identification;
procedure Close is
begin
Messaging.Quit;
delay 5.0;
if cifX_Channel_Open_Done then
Ada.Text_IO.Put_Line (Item => "Closing Channel");
Result := cifX.Channel_Close (Channel_Handle);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
end if;
cifX_Channel_Open_Done := False;
end if;
if cifX_Driver_Open_Done then
Ada.Text_IO.Put_Line (Item => "Closing Driver");
Result := cifX.Driver_Close (Driver_Handle);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
end if;
cifX_Driver_Open_Done := False;
end if;
if cifX_Driver_Init_Done then
Ada.Text_IO.Put_Line (Item => "Deinitializing cifX Driver");
cifX.Driver_Deinit;
cifX_Driver_Init_Done := False;
end if;
end Close;
begin
Ada.Text_IO.Put_Line (Item => "Test_Messaging...");
Ada.Text_IO.Put_Line (Item => "Initializing cifX Driver");
Result := cifX.Driver_Init;
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Driver_Init_Done := True;
end if;
if cifX_Driver_Init_Done then
Ada.Text_IO.Put_Line (Item => "Opening Driver");
Result := cifX.Driver_Open (Driver_Handle'Access);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Driver_Open_Done := True;
end if;
end if;
if cifX_Driver_Open_Done then
Ada.Text_IO.Put_Line (Item => "Opening Channel");
Result := cifX.Channel_Open
(Driver_Handle => Driver_Handle,
Board_Name => "cifX0",
Channel_Number => 0,
Channel_Handle_Access => Channel_Handle'Access);
if Result /= CIFX_NO_ERROR then
cifX.Show_Error(Result);
else
cifX_Channel_Open_Done := True;
end if;
end if;
if cifX_Channel_Open_Done then
Messaging.Initialise (Channel_Handle => Channel_Handle);
Ada.Text_IO.Put_Line (Item => "Sending Request");
Messaging.Message_Pool.Get_Packet
(Item => Request,
Result => Packet_Got);
if not Packet_Got then
Ada.Text_IO.Put_Line
("Could not get Request packet from pool...");
else
Fw_Ident_Req := From_cifX_Packet (Request);
Fw_Ident_Req.Head.Dest := 16#20#;
Fw_Ident_Req.Head.Src := 0;
Fw_Ident_Req.Head.Dest_Id := 0;
Fw_Ident_Req.Head.Src_Id := 0;
Fw_Ident_Req.Head.Len := 4;
Fw_Ident_Req.Head.Id := 1;
Fw_Ident_Req.Head.State := 0;
Fw_Ident_Req.Head.Cmd := RCX_FIRMWARE_IDENTIFY_REQ;
Fw_Ident_Req.Head.Ext := 0;
Fw_Ident_Req.Head.Rout := 0;
Fw_Ident_Req.Data.Channel_Id := 0;
Messaging.Send_Queue.Put
(Item => Request,
Result => Packet_Put);
if not Packet_Put then
Ada.Text_IO.Put_Line
("Could not put Request packet in queue...");
Messaging.Message_Pool.Return_Packet (Item => Request);
else
Messaging.Receive_Queue.Get (Item => Confirmation);
Fw_Ident_Cnf := From_cifX_Packet (Confirmation);
cifX_Show_Firmware_Identification;
Messaging.Message_Pool.Return_Packet (Item => Confirmation);
end if;
end if;
end if;
Close;
exception
when Error: others =>
Ada.Text_IO.Put_Line (Exception_Information(Error));
Close;
end Test_Messaging;
Avec un peu de chance ça tombe en marche et la trace est présentée ci-bas :
C:\GNAT\Projects\A4A\hilscherx\exe\test_messaging
Test_Messaging...
Initializing cifX Driver
Opening Driver
Opening Channel
Sending Request
***********************************************
Firmware Identification
Firmware Version :
Major : 2
Minor : 6
Build : 7
Revision : 1
Firmware Name : EtherNet/IP Scanner
Firmware Date :
Year : 2013
Month : 12
Day : 3
***********************************************
Closing Channel
Closing Driver
Deinitializing cifX Driver
[2014-06-11 11:19:03] process terminated successfully, elapsed time: 06.53s
Test_Messaging...
Initializing cifX Driver
Opening Driver
Opening Channel
Sending Request
***********************************************
Firmware Identification
Firmware Version :
Major : 2
Minor : 6
Build : 7
Revision : 1
Firmware Name : EtherNet/IP Scanner
Firmware Date :
Year : 2013
Month : 12
Day : 3
***********************************************
Closing Channel
Closing Driver
Deinitializing cifX Driver
[2014-06-11 11:19:03] process terminated successfully, elapsed time: 06.53s
De leur côté, les tâches d’émission et de réception s’exécutent parallèlement au fil du programme principal.
La tâche d’émission bloque sur l’attente d’un message dans la queue d’émission et retourne le paquet émis au pool.
La tâche de réception obtient un paquet du pool puis boucle en attente de réception d’un paquet et poste le paquet reçu dans la queue de réception.
Voilà le corps du paquetage « A4A.Protocols.HilscherX.Messaging » :
-----------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
-- <summary>
-- This package provides the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - messaging infrastructure.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>
with Ada.Text_IO;
package body A4A.Protocols.HilscherX.Messaging is
procedure Quit is
begin
Quit_Flag := True;
end Quit;
procedure Initialise
(Channel_Handle : in Channel_Handle_Type) is
begin
The_Channel_Handle := Channel_Handle;
Message_Pool.Initialise;
Init_Flag := True;
end Initialise;
task body Send_Msg is
Packet : cifX_Packet_Access;
Result : DInt;
begin
loop
delay 1.0;
exit when Init_Flag or Quit_Flag;
end loop;
loop
exit when Quit_Flag;
select
Send_Queue.Get (Item => Packet);
Result := Channel_Put_Packet
(Channel_Handle => The_Channel_Handle,
Send_Packet => Packet.all,
Time_Out => 10);
if Result /= CIFX_NO_ERROR then
Show_Error (Result);
end if;
Message_Pool.Return_Packet (Item => Packet);
or
delay 1.0;
end select;
end loop;
end Send_Msg;
task body Receive_Msg is
Packet : cifX_Packet_Access;
Result : DInt;
Packet_Got : Boolean := False;
Packet_Put : Boolean := False;
begin
loop
delay 1.0;
exit when Init_Flag or Quit_Flag;
end loop;
loop
exit when Quit_Flag;
if not Packet_Got then
Message_Pool.Get_Packet
(Item => Packet,
Result => Packet_Got);
end if;
if not Packet_Got then
Ada.Text_IO.Put_Line
("Receive_Msg : Could not get packet from pool...");
else
Result := Channel_Get_Packet
(Channel_Handle => The_Channel_Handle,
Size => cifX_Packet_Type'Size / 8,
Recv_Packet => Packet.all,
Time_Out => 1000);
if Result = CIFX_NO_ERROR then
Receive_Queue.Put
(Item => Packet,
Result => Packet_Put);
Packet_Got := False;
elsif Result = CIFX_DEV_GET_TIMEOUT
or Result = CIFX_DEV_GET_NO_PACKET then
Ada.Text_IO.Put_Line
("Zut !");
else
Show_Error (Result);
end if;
end if;
end loop;
end Receive_Msg;
end A4A.Protocols.HilscherX.Messaging;
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2014, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT 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 Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this 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. --
-----------------------------------------------------------------------
-- <summary>
-- This package provides the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - messaging infrastructure.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>
with Ada.Text_IO;
package body A4A.Protocols.HilscherX.Messaging is
procedure Quit is
begin
Quit_Flag := True;
end Quit;
procedure Initialise
(Channel_Handle : in Channel_Handle_Type) is
begin
The_Channel_Handle := Channel_Handle;
Message_Pool.Initialise;
Init_Flag := True;
end Initialise;
task body Send_Msg is
Packet : cifX_Packet_Access;
Result : DInt;
begin
loop
delay 1.0;
exit when Init_Flag or Quit_Flag;
end loop;
loop
exit when Quit_Flag;
select
Send_Queue.Get (Item => Packet);
Result := Channel_Put_Packet
(Channel_Handle => The_Channel_Handle,
Send_Packet => Packet.all,
Time_Out => 10);
if Result /= CIFX_NO_ERROR then
Show_Error (Result);
end if;
Message_Pool.Return_Packet (Item => Packet);
or
delay 1.0;
end select;
end loop;
end Send_Msg;
task body Receive_Msg is
Packet : cifX_Packet_Access;
Result : DInt;
Packet_Got : Boolean := False;
Packet_Put : Boolean := False;
begin
loop
delay 1.0;
exit when Init_Flag or Quit_Flag;
end loop;
loop
exit when Quit_Flag;
if not Packet_Got then
Message_Pool.Get_Packet
(Item => Packet,
Result => Packet_Got);
end if;
if not Packet_Got then
Ada.Text_IO.Put_Line
("Receive_Msg : Could not get packet from pool...");
else
Result := Channel_Get_Packet
(Channel_Handle => The_Channel_Handle,
Size => cifX_Packet_Type'Size / 8,
Recv_Packet => Packet.all,
Time_Out => 1000);
if Result = CIFX_NO_ERROR then
Receive_Queue.Put
(Item => Packet,
Result => Packet_Put);
Packet_Got := False;
elsif Result = CIFX_DEV_GET_TIMEOUT
or Result = CIFX_DEV_GET_NO_PACKET then
Ada.Text_IO.Put_Line
("Zut !");
else
Show_Error (Result);
end if;
end if;
end loop;
end Receive_Msg;
end A4A.Protocols.HilscherX.Messaging;
Cordialement,
Stéphane