Archives de catégorie : comX

Les modules comX font partie de la dernière génération d’interfaces de communication construite autour des systèmes sur puce netX développés par Hilscher.

A4A : Messagerie Hilscher – PROFIBUS DP V1 Class 2

Bonjour,

Les articles précédents avaient pour objectif de présenter l’infrastructure mise en œuvre dans « Ada for Automation » pour la gestion de la messagerie Hilscher.

Cette messagerie permet comme on l’a vu d’accéder à toute la fonctionnalité acyclique offerte par le système et les piles de protocoles pour la configuration, le paramétrage et le diagnostic.

L’exemple d’utilisation du jour reprend la manipulation déjà décrite dans l’article :
cifX : Mise en œuvre : API – Messages – PROFIBUS DP V1 Class 2

Après avoir initialisé le pilote, ouvert celui-ci ainsi que le canal de communication, le programme ci-dessous :

  • initie une connexion DP V1 Class 2
  • lit une donnée, en l’occurrence la version du firmware,
  • termine la connexion,
  • attend l’indication de la fermeture de la connexion et y répond,
  • puis termine proprement.

Les blocs fonctions DPV1C2 Initiate, Read, et Abort sont du même tonneau que décrit ici :
A4A : Infrastructure Messagerie Hilscher cifX – Layer 3

Tandis que pour la gestion de l’indication de fermeture c’est décrit là hier :
A4A : Infrastructure Messagerie Hilscher cifX – Layer 3 – Indications

Voici donc le code du jour qui utilise 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 Interfaces.C;

with Ada.Exceptions; use Ada.Exceptions;

with A4A; use A4A;

with A4A.Log;

with A4A.Protocols.HilscherX.cifX_Errors;
use A4A.Protocols.HilscherX.cifX_Errors;

with A4A.Protocols.HilscherX.cifX_User;

with A4A.Protocols.HilscherX.Channel_Messaging;
use A4A.Protocols.HilscherX.Channel_Messaging;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Initiate.FB;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Abort_Req.FB;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Read.FB;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB;

use A4A.Protocols.HilscherX.Profibus_DPM;

procedure Test_DPM_DPV1 is

   My_Ident : String := "Test_Profibus_DPM_DPV1";

   package cifX renames A4A.Protocols.HilscherX.cifX_User;

   My_Board : String := "DPM";
--     My_Board : String := "cifX1";

   Driver_Handle  : aliased cifX.Driver_Handle_Type;
   Channel_Handle : aliased cifX.Channel_Handle_Type;

   Result : DInt;

   cifX_Driver_Init_Done  : Boolean := False;
   cifX_Driver_Open_Done  : Boolean := False;
   cifX_Channel_Open_Done : Boolean := False;

   My_Channel_Messaging : aliased
     A4A.Protocols.HilscherX.Channel_Messaging.Instance;

   DPV1_FB : DPV1.Instance;

   Initiate_FB : DPV1C2.Initiate.FB.Instance;

   Remote_Address : DWord := 2;

   Do_Initiate    : Boolean := False;
   Initiate_Done  : Boolean := False;
   Initiate_Error : Boolean := False;

   Initiate_Cnf_Pos_Data  : DPV1C2.Initiate.PROFIBUS_FSPMM2_INITIATE_CNF_POS_T;

   Abort_FB : DPV1C2.Abort_Req.FB.Instance;

   Do_Abort    : Boolean := False;
   Abort_Done  : Boolean := False;
   Abort_Error : Boolean := False;

   Abort_Cnf_Data  : DPV1C2.Abort_Req.PROFIBUS_FSPMM2_ABORT_CNF_T;

   Read_FB : DPV1C2.Read.FB.Instance;

   -- Software revision from E+H Level Meter
   Slot   : DWord :=  1;
   Index  : DWord := 73;
   Length : DWord := 16;

   Do_Read    : Boolean := False;
   Read_Done  : Boolean := False;
   Read_Error : Boolean := False;

   Read_Cnf_Pos_Data  : DPV1C2.Read.PROFIBUS_FSPMM2_READ_CNF_POS_T;

   Software_Revision : String (1 .. 16);

   DPV1C2_Closed_FB : aliased DPV1C2.Closed.FB.Instance;

   Closed_Indication_Got : Boolean := False;

   Closed_Indication_Data : DPV1C2.Closed.PROFIBUS_FSPMM2_CLOSED_IND_T;

   type Block_Status is
     (X00,
      -- Initial

      X01,
      -- Initiate DPV1C2 connection

      X02,
      -- Read data from slave

      X03,
      -- Abort connection

      X04,
      -- Wait for Closed Indication

      X05
      -- Terminate
     );

   Status : Block_Status := X00;

   procedure cifX_Show_Error (Error : DInt) is
   begin
      A4A.Log.Logger.Put
        (Who  => My_Ident,
         What => cifX.Driver_Get_Error_Description(Error));
   end cifX_Show_Error;

   procedure Close is
   begin

      DPV1_FB.Quit;

      --Wait for completion
      loop

         exit when DPV1_FB.Is_Terminated;
         delay 1.0;

      end loop;

      My_Channel_Messaging.Quit;

      --Wait for completion
      loop

         exit when My_Channel_Messaging.Is_Terminated;
         delay 1.0;

      end loop;

      if cifX_Channel_Open_Done then
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "Deinitializing cifX Driver");
         cifX.Driver_Deinit;
         cifX_Driver_Init_Done := False;
      end if;

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Finished !");
      A4A.Log.Quit;

   end Close;

begin

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "Test_Messaging...");

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Opening Channel");
      Result := cifX.Channel_Open
        (Driver_Handle          => Driver_Handle,
         Board_Name             => My_Board,
         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

      My_Channel_Messaging.Initialise (Channel_Handle => Channel_Handle);

      Initiate_FB.Initialise
        (Channel_Access => My_Channel_Messaging'Unrestricted_Access);

      Abort_FB.Initialise
        (Channel_Access => My_Channel_Messaging'Unrestricted_Access);

      Read_FB.Initialise
        (Channel_Access => My_Channel_Messaging'Unrestricted_Access);

      DPV1_FB.Initialise
        (Channel_Access => My_Channel_Messaging'Unrestricted_Access,
         DPV1C2_Closed_Access => DPV1C2_Closed_FB'Unrestricted_Access);

      loop

         case Status is

            when X00 => -- Initial state

               if DPV1_FB.Is_Ready then

                  Status := X01;

               end if;

            when X01 => -- Initiating DPV1C2 connection

               if Initiate_Done then

                  if Initiate_Error  then

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Connection failed");

                     Status := X05;

                  else

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Connected");

                     Initiate_Cnf_Pos_Data := Initiate_FB.Get_Data_Pos;

                     Status := X02;

                  end if;
               end if;

            when X02 => -- Reading data from slave

               if Read_Done then

                  if Read_Error  then

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Read failed");

                  else

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Data Read");

                     Read_Cnf_Pos_Data := Read_FB.Get_Data_Pos;

                     for I in Software_Revision'Range loop
                        exit when Read_Cnf_Pos_Data.Data (I) = 0;
                        Software_Revision (I) :=
                          Character'Val (Read_Cnf_Pos_Data.Data (I));
                     end loop;

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Software Revision : " & Software_Revision);

                  end if;

                  Status := X03;

               end if;

            when X03 => -- Aborting connection

               if Abort_Done then

                  if Abort_Error  then

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Connection Abortion failed");

                     Status := X05;

                  else

                     A4A.Log.Logger.Put
                       (Who  => My_Ident,
                        What => "Connection Aborted");

                     Abort_Cnf_Data := Abort_FB.Get_Data;

                     Status := X04;

                  end if;

               end if;

            when X04 => -- Waiting for Closed Indication

               if Closed_Indication_Got then

                  Closed_Indication_Data := DPV1C2_Closed_FB.Get_Data;

                  if Closed_Indication_Data.CRef =
                    Initiate_Cnf_Pos_Data.Com_Ref then

                     DPV1C2_Closed_FB.Answer;
                     Status := X05;

                  end if;

               end if;

            when X05 => -- Terminating

               null;

         end case;

         Do_Initiate := (Status = X01);

         Initiate_FB.Cyclic
           (Do_Command     => Do_Initiate,
            Remote_Address => Remote_Address,
            Done           => Initiate_Done,
            Error          => Initiate_Error);

         Do_Read := (Status = X02);

         Read_FB.Cyclic
           (Do_Command     => Do_Read,
            Com_Ref        => Initiate_Cnf_Pos_Data.Com_Ref,
            Slot           => Slot,
            Index          => Index,
            Length         => Length,
            Done           => Read_Done,
            Error          => Read_Error);

         Do_Abort := (Status = X03);

         Abort_FB.Cyclic
           (Do_Command     => Do_Abort,
            Com_Ref        => Initiate_Cnf_Pos_Data.Com_Ref,
            Done           => Abort_Done,
            Error          => Abort_Error);

         DPV1C2_Closed_FB.Cyclic
           (Got_Indication => Closed_Indication_Got);

         exit when
           ((Status = X05) and DPV1C2_Closed_FB.Is_Ready)
           or DPV1_FB.Is_Faulty;

      end loop;

      -- Let's see if other indications get caught
      delay 5.0;

   end if;

   Close;

exception

   when Error: others =>
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => Exception_Information(Error));

      Close;

end Test_DPM_DPV1;

Et la trace vraiment bavarde mais c’est didactique :

C:\GNAT\Projects\A4A\hilscherx\exe\test_dpm_dpv1
2014-06-16 09:57:26.68 => Test_Profibus_DPM_DPV1 : Test_Messaging...
2014-06-16 09:57:26.68 => Test_Profibus_DPM_DPV1 : Initializing cifX Driver
2014-06-16 09:57:26.68 => Test_Profibus_DPM_DPV1 : Opening Driver
2014-06-16 09:57:26.68 => Test_Profibus_DPM_DPV1 : Opening Channel
2014-06-16 09:57:26.68 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : Initialised !
2014-06-16 09:57:26.68 => A4A.Protocols.HilscherX.rcX_Public.rcX_Register_App.FB.Cyclic : Request Sent
2014-06-16 09:57:27.85 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#1#
Dest_Id :                16#0#
Src_Id  :           16#28F97C#
Cmd     :             16#2F11#
2014-06-16 09:57:27.86 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : Got a message :             16#2F11#
2014-06-16 09:57:27.86 => A4A.Protocols.HilscherX.rcX_Public.rcX_Register_App.FB.Cyclic : Confirmation received fine
2014-06-16 09:57:27.86 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : App Registered !
2014-06-16 09:57:27.99 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#0#
Dest_Id :                16#0#
Src_Id  :           16#28FA48#
Cmd     :             16#4405#
2014-06-16 09:57:27.99 => Test_Profibus_DPM_DPV1 : Connected
2014-06-16 09:57:28.16 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#0#
Dest_Id :                16#0#
Src_Id  :           16#28FC8C#
Cmd     :             16#4407#
2014-06-16 09:57:28.16 => Test_Profibus_DPM_DPV1 : Data Read
2014-06-16 09:57:28.16 => Test_Profibus_DPM_DPV1 : Software Revision : 01.05.00        
2014-06-16 09:57:28.25 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#0#
Dest_Id :                16#0#
Src_Id  :           16#28FBE8#
Cmd     :             16#440D#
2014-06-16 09:57:28.25 => Test_Profibus_DPM_DPV1 : Connection Aborted
2014-06-16 09:57:28.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :                16#1#
Src     :         16#8017E710#
Dest_Id :           16#28F97C#
Src_Id  :                16#0#
Cmd     :             16#4428#
2014-06-16 09:57:28.35 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : Got a message :             16#4428#
2014-06-16 09:57:28.35 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB.Handle_Indication : Indication received
2014-06-16 09:57:28.35 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB.Cyclic : Answer Got
2014-06-16 09:57:28.35 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB.Cyclic : Response Sent
2014-06-16 09:57:29.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:30.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:31.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:32.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:33.35 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.rcX_Public.rcX_Unregister_App.FB.Cyclic : Request Sent
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#1#
Dest_Id :                16#0#
Src_Id  :           16#28F97C#
Cmd     :             16#2F13#
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : Got a message :             16#2F13#
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.rcX_Public.rcX_Unregister_App.FB.Cyclic : Confirmation received fine
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : App Unregistered !
2014-06-16 09:57:33.46 => A4A.Protocols.HilscherX.Profibus_DPM.DPV1.DPV1_Task : Terminated !
2014-06-16 09:57:34.46 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:35.46 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-16 09:57:35.49 => Test_Profibus_DPM_DPV1 : Closing Channel
2014-06-16 09:57:35.49 => Test_Profibus_DPM_DPV1 : Closing Driver
2014-06-16 09:57:35.49 => Test_Profibus_DPM_DPV1 : Deinitializing cifX Driver
2014-06-16 09:57:35.49 => Test_Profibus_DPM_DPV1 : Finished !
Logging_Task terminated...

[2014-06-16 11:57:35] process terminated successfully, elapsed time: 09.57s

Et la révision du firmware de mon radar Endress + Hauser est donc :

Software Revision : 01.05.00

Edifiant non ? 😉

Cordialement,
Stéphane

A4A : Infrastructure Messagerie Hilscher cifX – Layer 3 – Indications

Bonjour,

Pour que l’application puisse recevoir les indications il est nécessaire de s’enregistrer auprès de la pile de protocole afin qu’elle sache que l’application va les gérer d’une part et d’autre part lui indiquer la queue de destination.

On trouve dans le document netX Dual Port Memory Interface les requêtes RCX_REGISTER_APP_REQ et RCX_UNREGISTER_APP_REQ.

En remplissant les requêtes RCX_REGISTER_APP_REQ et RCX_UNREGISTER_APP_REQ, on indique la référence de la queue de réception des indications dans les champs Src et Src_Id.

Pour chacune de ces requêtes un bloc fonction est disponible qui ne possède pas de queue de réception propre mais reçoit la référence de la queue à utiliser à l’initialisation.

Après s’être enregistré auprès de la pile de protocole, il faut bien évidemment gérer les indications et y répondre.

On va donc avoir un bloc fonction pour chaque indication qui fournit à l’application le moyen de savoir qu’une indication a été reçue, une méthode pour récupérer les données de l’indication, et une méthode qui permet de déclencher la réponse.

Comme toutes les indications parviennent à la même queue de réception il est nécessaire de prévoir un mécanisme de distribution des paquets vers les blocs fonction gérant les indications, ces blocs ne possédant pas de queue de réception propre.

Pour gérer ce mécanisme de distribution on a recours à un bloc fonction qui dispose de sa propre tâche pour :

  • gérer sa machine d’état,
  • s’enregistrer auprès de la pile de protocole en fournissant sa propre queue de réception en paramètre,
  • lorsqu’une indication est reçue, la distribuer au bloc en charge de sa gestion si celui-ci est disponible pour le faire,
  • se dés-enregistrer auprès de la pile de protocole lorsque l’application se termine.

On initialise ce bloc en lui fournissant d’une part une référence du canal de communication et d’autre part les références de chaque bloc fonction gérant une indication.

Le code source pour la gestion des requêtes RCX_REGISTER_APP_REQ et RCX_UNREGISTER_APP_REQ se trouve dans le dossier « A4A/hilscherx/src/rcx_public ». Je ne pense pas qu’il soit nécessaire d’en donner davantage d’explications car cela ressemble fort à ce qui a été présenté précédemment.

Voici ci-dessous la spécification du bloc fonction gérant les indications pour PROFIBUS DP V1. Il est notablement incomplet car il ne gère que l’indication de connexion fermée pour la classe 2, ce qui est suffisant pour mon exemple.

Au cas où vous souhaiteriez un bloc fonction plus complet, n’hésitez pas à vous manifester.
Surveillez les logs, une indication non gérée devrait être signalée.

On pourrait tout à fait instancier plusieurs fois cet objet comme par exemple pour gérer ce type de communication sur les deux canaux d’une carte Hilscher cifX 50-2DP.

On peut également décliner ce concept pour tous les bus de terrain supportés par ces cartes. Cela sera fait en fonction des demandes exprimées, ou contributions… 😉

Ça se passe dans le dossier « A4A/hilscherx/src/profibus_dpm ».

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - PROFIBUS DP Master data types,
-- - cifX C functions binding.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


with A4A.Log;

with A4A.Protocols.HilscherX.Channel_Messaging;
use A4A.Protocols.HilscherX;

with A4A.Protocols.HilscherX.rcX_Public.rcX_Register_App.FB;
with A4A.Protocols.HilscherX.rcX_Public.rcX_Unregister_App.FB;
use A4A.Protocols.HilscherX.rcX_Public;

with A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB;
use A4A.Protocols.HilscherX.Profibus_DPM;

package A4A.Protocols.HilscherX.Profibus_DPM.DPV1 is

   type Instance is tagged limited private;
   type Instance_Access is access all Instance;

   procedure Initialise
     (Self           : in out Instance;
      Channel_Access : in Channel_Messaging.Instance_Access;
      DPV1C2_Closed_Access : in DPV1C2.Closed.FB.Instance_Access);
   
   procedure Quit
     (Self : in out Instance);

   function Is_Ready
     (Self : in Instance) return Boolean;
   
   function Is_Faulty
     (Self : in Instance) return Boolean;
   
   function Is_Terminated
     (Self : in Instance) return Boolean;
   
private

   Package_Ident : String := "A4A.Protocols.HilscherX.Profibus_DPM.DPV1";
   
   task type DPV1_Task_Type
     (Self : access Instance);
   
   type Block_Status is
     (X00,
      -- Initial
     
      X01,
      -- Initialized
     
      X02,
      -- Registered / Ready
     
      X03,
      -- Unregistering
     
      X04,
      -- Unregistered
     
      X05,
      -- Faulty
     
      X06
      -- Terminated
     );

   type Instance is tagged limited
      record
         
         Quit_Flag : Boolean := False;
         Init_Flag : Boolean := False;
         
         My_Channel   : Channel_Messaging.Instance_Access;
         
         Status       : Block_Status := X00;
         
         Register_App_FB : rcX_Register_App.FB.Instance;

         Do_Register_App    : Boolean := False;
         Register_App_Done  : Boolean := False;
         Register_App_Error : Boolean := False;
         
         Unregister_App_FB : rcX_Unregister_App.FB.Instance;

         Do_Unregister_App    : Boolean := False;
         Unregister_App_Done  : Boolean := False;
         Unregister_App_Error : Boolean := False;
         
         DPV1C2_Closed_FB : DPV1C2.Closed.FB.Instance_Access;
         
         Received_Packet : cifX_Packet_Access;
         
         Packet_Got   : Boolean := False;
         
         My_Receive_Queue : aliased
           Channel_Messaging.Queue_Package_Multiple.Message_Queue_Type;
         
         Error_Flag : Boolean;
         Last_Error : DWord;

         DPV1_Task    : DPV1_Task_Type (Instance'Access);
         
      end record;
   
end A4A.Protocols.HilscherX.Profibus_DPM.DPV1;

Le corps est présenté ci-dessous :

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - PROFIBUS DP Master data types,
-- - cifX C functions binding.
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


package body A4A.Protocols.HilscherX.Profibus_DPM.DPV1 is

   procedure Initialise
     (Self           : in out Instance;
      Channel_Access :Channel_Messaging.Instance_Access;
      DPV1C2_Closed_Access : in DPV1C2.Closed.FB.Instance_Access) is
   begin

      Self.My_Channel := Channel_Access;
      Self.DPV1C2_Closed_FB := DPV1C2_Closed_Access;

      Self.Register_App_FB.Initialise
        (Channel_Access => Channel_Access,
         Receive_Queue  => Self.My_Receive_Queue'Unrestricted_Access);

      Self.Unregister_App_FB.Initialise
        (Channel_Access => Channel_Access,
         Receive_Queue  => Self.My_Receive_Queue'Unrestricted_Access);

      Self.DPV1C2_Closed_FB.Initialise
        (Channel_Access => Channel_Access);

      Self.Status := X00;
      Self.Error_Flag := False;

      Self.Init_Flag := True;

   end Initialise;

   procedure Quit
     (Self : in out Instance) is
   begin
      Self.Quit_Flag := True;
   end Quit;

   function Is_Ready
     (Self : in Instance) return Boolean is
   begin

      return Self.Status = X02;

   end Is_Ready;

   function Is_Faulty
     (Self : in Instance) return Boolean is
   begin

      return Self.Status = X05;

   end Is_Faulty;

   function Is_Terminated
     (Self : in Instance) return Boolean is
   begin

      return Self.Status = X06;

   end Is_Terminated;

   task body DPV1_Task_Type is

      My_Ident : String := Package_Ident & ".DPV1_Task";

      Error_String : String (1.. 20);
      Cmd_String   : String (1.. 20);

   begin

      loop

         case Self.Status is

         when X00 =>

            if Self.Init_Flag then

               A4A.Log.Logger.Put
                 (Who  => My_Ident,
                  What => "Initialised !");

               Self.Status  := X01;

            end if;

         when X01 =>

            if Self.Register_App_Done then

               if Self.Register_App_Error then

                  DWord_Text_IO.Put
                    (To   => Error_String,
                     Item => Self.Register_App_FB.Get_Last_Error,
                     Base => 16);

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "Got an error : " & Error_String);

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "App Not Registered !");

                  Self.Status  := X05;

               else

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "App Registered !");

                  Self.Status  := X02;

               end if;

            end if;

         when X02 =>

            if Self.Quit_Flag then

               Self.Status  := X03;

            end if;

         when X03 =>

            if Self.Unregister_App_Done then

               if Self.Unregister_App_Error then

                  DWord_Text_IO.Put
                    (To   => Error_String,
                     Item => Self.Unregister_App_FB.Get_Last_Error,
                     Base => 16);

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "Got an error : " & Error_String);

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "App Not Unregistered !");

                  Self.Status  := X05;

               else

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "App Unregistered !");

                  Self.Status  := X04;

               end if;

            end if;

         when X04 =>

            null;

         when X05 =>

            null;

         when X06 =>

            null;

         end case;

         -- Register the Application
         Self.Do_Register_App := (Self.Status = X01);

         Self.Register_App_FB.Cyclic
           (Do_Command => Self.Do_Register_App,
            Done       => Self.Register_App_Done,
            Error      => Self.Register_App_Error);

         -- Unregister the Application
         Self.Do_Unregister_App := (Self.Status = X03);

         Self.Unregister_App_FB.Cyclic
           (Do_Command => Self.Do_Unregister_App,
            Done       => Self.Unregister_App_Done,
            Error      => Self.Unregister_App_Error);

         if not Self.Packet_Got then
            Self.My_Receive_Queue.Get
              (Item   => Self.Received_Packet,
               Result => Self.Packet_Got);
         end if;

         if Self.Packet_Got then

            DWord_Text_IO.Put
              (To   => Cmd_String,
               Item => Self.Received_Packet.Header.Cmd,
               Base => 16);

            A4A.Log.Logger.Put
              (Who  => My_Ident,
               What => "Got a message : " & Cmd_String);

            case Self.Received_Packet.Header.Cmd is

               when rcX_Register_App.RCX_REGISTER_APP_CNF =>

                  Self.Register_App_FB.Handle_Answer (Self.Received_Packet);
                  Self.Packet_Got := False;

               when rcX_Unregister_App.RCX_UNREGISTER_APP_CNF =>

                  Self.Unregister_App_FB.Handle_Answer (Self.Received_Packet);
                  Self.Packet_Got := False;

               when DPV1C2.Closed.PROFIBUS_FSPMM2_CMD_CLOSED_IND =>

                  if Self.DPV1C2_Closed_FB.Is_Ready then
                     Self.DPV1C2_Closed_FB.Handle_Indication
                       (Self.Received_Packet);
                     Self.Packet_Got := False;
                  end if;

               when others =>

                  A4A.Log.Logger.Put
                    (Who  => My_Ident,
                     What => "Received unmanaged message !!!");
                     Self.Packet_Got := False;

            end case;

         end if;

         exit when
           ((Self.Status = X00) or (Self.Status = X04) or (Self.Status = X05))
           and Self.Quit_Flag;

      end loop;

      A4A.Log.Logger.Put
        (Who  => My_Ident,
         What => "Terminated !");

      Self.Status  := X06;

   end DPV1_Task_Type;

end A4A.Protocols.HilscherX.Profibus_DPM.DPV1;

La spécification du bloc fonction gérant l’indication connexion fermée :

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - PROFIBUS DP V1 Master Class 2 data types,
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


with A4A.Log;

with A4A.Protocols.HilscherX.Channel_Messaging;
use A4A.Protocols.HilscherX;

package A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB is

   type Instance is tagged limited private;
   type Instance_Access is access all Instance;

   procedure Initialise
     (Function_Block : in out Instance;
      Channel_Access : in Channel_Messaging.Instance_Access);

   procedure Cyclic
     (Function_Block : in out Instance;
      Got_Indication : out Boolean);
   
   procedure Handle_Indication
     (Function_Block : in out Instance;
      Indication     : in cifX_Packet_Access);
   
   procedure Answer
     (Function_Block : in out Instance);
   
   function Is_Ready
     (Function_Block : in Instance) return Boolean;
   
   function Get_Data
     (Function_Block : in Instance)
      return PROFIBUS_FSPMM2_CLOSED_IND_T;
   
private

   My_Ident : String :=
     "A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB";
   
   type Block_Status is
     (X00,
      -- Initial
     
      X01,
      -- Indication Got
     
      X02
      -- Send packet
     );

   type Instance is tagged limited
      record
         
         My_Channel   : Channel_Messaging.Instance_Access;
         
         Status       : Block_Status := X00;
         
         Indication   : cifX_Packet_Access;
         Response     : cifX_Packet_Access;

         Closed_Ind   : PROFIBUS_FSPMM2_PACKET_CLOSED_IND_T_Access;
         Closed_Res   : PROFIBUS_FSPMM2_PACKET_CLOSED_RES_T_Access;
         
         Closed_Ind_Data : PROFIBUS_FSPMM2_CLOSED_IND_T;
         
         Indication_Got : Boolean := False;
         Answer_Got     : Boolean := False;
         Packet_Sent    : Boolean := False;
         
      end record;
   
end A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB;

Et son corps :

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - PROFIBUS DP V1 Master Class 2 data types,
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


package body A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB is

   procedure Initialise
     (Function_Block : in out Instance;
      Channel_Access :Channel_Messaging.Instance_Access) is
   begin

      Function_Block.My_Channel := Channel_Access;

      Function_Block.Status := X00;

   end Initialise;

   procedure Cyclic
     (Function_Block : in out Instance;
      Got_Indication : out Boolean) is
   begin

      case Function_Block.Status is

         when X00 =>

            if Function_Block.Indication_Got then

               Function_Block.Status := X01;
               Function_Block.Indication_Got := False;

            end if;

         when X01 =>

            if Function_Block.Answer_Got then

               A4A.Log.Logger.Put
                 (Who  => My_Ident & ".Cyclic",
                  What => "Answer Got");

               Function_Block.Status := X02;
               Function_Block.Answer_Got := False;

            end if;

         when X02 =>

            Function_Block.My_Channel.Send
              (Item   => Function_Block.Response,
               Result => Function_Block.Packet_Sent);

            if Function_Block.Packet_Sent then

               A4A.Log.Logger.Put
                 (Who  => My_Ident & ".Cyclic",
                  What => "Response Sent");

               Function_Block.Status := X00;

            end if;

      end case;

      Got_Indication := Function_Block.Status = X01;

   end Cyclic;

   procedure Handle_Indication
     (Function_Block : in out Instance;
      Indication     : in cifX_Packet_Access) is
   begin

      Function_Block.Indication := Indication;
      Function_Block.Closed_Ind :=
        From_cifX_Packet (Function_Block.Indication);

      Function_Block.Closed_Ind_Data := Function_Block.Closed_Ind.Data;

      -- We use the same packet for the response
      -- So we don't need to return it to the pool nor get a new one

      Function_Block.Response   := Indication;
      Function_Block.Closed_Res :=
        From_cifX_Packet (Function_Block.Response);

      -- We change only relevant fields
      Function_Block.Closed_Res.Head.Dest := 16#20#;
      Function_Block.Closed_Res.Head.Cmd  := PROFIBUS_FSPMM2_CMD_CLOSED_RES;

      -- The response is ready to be sent back

      A4A.Log.Logger.Put
        (Who  => My_Ident & ".Handle_Indication",
         What => "Indication received");

      Function_Block.Indication_Got := True;

   end Handle_Indication;

   procedure Answer
     (Function_Block : in out Instance) is
   begin

      Function_Block.Answer_Got := True;

   end Answer;

   function Is_Ready
     (Function_Block : in Instance) return Boolean is
   begin

      return Function_Block.Status = X00;

   end Is_Ready;

   function Get_Data
     (Function_Block : in Instance)
      return PROFIBUS_FSPMM2_CLOSED_IND_T is
   begin

      return Function_Block.Closed_Ind_Data;

   end Get_Data;

end A4A.Protocols.HilscherX.Profibus_DPM.DPV1C2.Closed.FB;

On notera que l’on se sert ici du même paquet reçu pour la réponse en changeant juste les champs comme nécessaire.

Cordialement,
Stéphane

A4A : Infrastructure Messagerie Hilscher cifX – Layer 3

Bonjour,

Cet étage est celui des objets qui constituent l’interface applicative.

L’automaticien est habitué aux fonctions et blocs fonctions.

Un bloc fonction, ce n’est jamais qu’un objet qui ne propose qu’une seule méthode.
On instancie ce bloc fonction ou l’on crée un bloc de données d’instance et on appelle le bloc en accolant cet appel à l’instance.

Comme il ne propose qu’une seule méthode, l’interface du bloc fonction doit présenter tous les paramètres, commandes et résultats (IN, OUT, IN_OUT), ce qui alourdit très rapidement celle-ci d’autant plus si la représentation est graphique.

Ada dispose de la notion d’objet depuis 1995. On a toujours des données d’instance mais il est possible pour un objet de posséder diverses méthodes comme nous allons le voir.

En fait, on l’a déjà vu avec l’objet « A4A.Protocols.HilscherX.Channel_Messaging » mais celui-ci n’a pas vocation à être utilisé au niveau application.

Dans tous les exemples précédents, nous avons mis en œuvre la requête permettant de lire les informations concernant le firmware de la carte Hilscher cifX.

Pour gérer cette requête il faut un certain nombre de variables, remplir la requête, l’envoyer, attendre la réponse, recevoir et analyser celle-ci.

Encapsulons tout cela dans un objet et nous augmenterons l’abstraction.

C’est ce que réalise le « Function Block » dont la spécification suit « A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB ».

Comme le paquetage contenant notre objet est fils de « A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify » il hérite de ce qui y est défini et peut donc y utiliser à sa guise.

On trouve dans cette spécification la définition de l’interface de notre objet, constituée des quatre procédures et fonctions, ainsi que celle des données d’instance.

La procédure « Initialise » permet d’associer le bloc au canal de communication.

La procédure « Cyclic » doit bien sûr être appelée cycliquement, tout au moins durant l’exécution de la commande, pour actualiser la machine d’état du bloc.

Les fonctions « Get_Last_Error » et « Get_Data » fournissent les données résultat.

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - rcX_Public data types
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


with A4A.Log;

with A4A.Protocols.HilscherX.Channel_Messaging;
use A4A.Protocols.HilscherX;

package A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB is

   type Instance is tagged limited private;
   type Instance_Access is access all Instance;

   procedure Initialise
     (Function_Block : in out Instance;
      Channel_Access : in Channel_Messaging.Instance_Access);

   procedure Cyclic
     (Function_Block : in out Instance;
      Do_Command     : in Boolean;
      Done           : out Boolean;
      Error          : out Boolean);
   
   function Get_Last_Error
     (Function_Block : in Instance) return DWord;
   
   function Get_Data
     (Function_Block : in Instance) return RCX_FW_IDENTIFICATION_T;
   
private

   My_Ident : String :=
     "A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB";
   
   type Block_Status is
     (X00,
      -- Initial
     
      X01,
      -- Get packet from pool
     
      X02,
      -- Fill packet
     
      X03,
      -- Send packet
     
      X04,
      -- Get answer
     
      X05
      -- Done
     );

   type Instance is tagged limited
      record
         
         My_Channel   : Channel_Messaging.Instance_Access;
         
         Status       : Block_Status := X00;
         
         Request      : cifX_Packet_Access;
         Confirmation : cifX_Packet_Access;

         Fw_Ident_Req : RCX_FIRMWARE_IDENTIFY_REQ_T_Access;
         Fw_Ident_Cnf : RCX_FIRMWARE_IDENTIFY_CNF_T_Access;
         
         Message_Id   : DWord := 0;

         Packet_Got   : Boolean := False;
         Packet_Sent  : Boolean := False;
         Answer_Got   : Boolean := False;
         
         My_Receive_Queue : aliased
           Channel_Messaging.Queue_Package_Single.Message_Queue_Type;
         
         Fw_Identification  : RCX_FW_IDENTIFICATION_T;
         
         Error_Flag : Boolean;
         Last_Error : DWord;

      end record;
   
end A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB;

Le corps de notre objet dans lequel les méthodes sont implémentées est disponible ci-dessous.

On y trouve dans la fonction cyclique le traitement de la machine d’état.

-----------------------------------------------------------------------
--                       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 is part of the binding to Hilscher cifX Device Driver,
-- a library allowing access to the cifX boards with numerous protocols.
-- </summary>
-- <description>
-- It provides :
-- - rcX_Public data types
-- </description>
-- <group>Protocols</group>
-- <c_version>3.0.1</c_version>


package body A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB is

   procedure Initialise
     (Function_Block : in out Instance;
      Channel_Access :Channel_Messaging.Instance_Access) is
   begin

      Function_Block.My_Channel := Channel_Access;

      Function_Block.Status := X00;
      Function_Block.Error_Flag := False;

   end Initialise;

   procedure Cyclic
     (Function_Block : in out Instance;
      Do_Command     : in Boolean;
      Done           : out Boolean;
      Error          : out Boolean) is
   begin

      case Function_Block.Status is

         when X00 =>

            if Do_Command then
               Function_Block.Error_Flag := False;
               Function_Block.Status := X01;
               Function_Block.Message_Id := Function_Block.Message_Id + 1;
            end if;

         when X01 =>

            Function_Block.My_Channel.Get_Packet
              (Item   => Function_Block.Request,
               Result => Function_Block.Packet_Got);

            if Function_Block.Packet_Got then
               Function_Block.Status := X02;
            end if;

         when X02 =>

            Function_Block.Fw_Ident_Req :=
              From_cifX_Packet (Function_Block.Request);

            Function_Block.Fw_Ident_Req.Head.Dest    := 16#20#;

            Function_Block.Fw_Ident_Req.Head.Src     :=
              Channel_Messaging.Queue_Package_Type_Single;

            Function_Block.Fw_Ident_Req.Head.Dest_Id := 0;

            Function_Block.Fw_Ident_Req.Head.Src_Id  :=
              Channel_Messaging.Queue_Package_Single.From_Message_Queue
                (Function_Block.My_Receive_Queue'Unrestricted_Access);

            Function_Block.Fw_Ident_Req.Head.Len     := 4;

            Function_Block.Fw_Ident_Req.Head.Id      :=
              Function_Block.Message_Id;

            Function_Block.Fw_Ident_Req.Head.State   := 0;

            Function_Block.Fw_Ident_Req.Head.Cmd     :=
              RCX_FIRMWARE_IDENTIFY_REQ;

            Function_Block.Fw_Ident_Req.Head.Ext     := 0;
            Function_Block.Fw_Ident_Req.Head.Rout    := 0;

            Function_Block.Fw_Ident_Req.Data.Channel_Id := 0;

            Function_Block.Status := X03;

         when X03 =>

            Function_Block.My_Channel.Send
              (Item   => Function_Block.Request,
               Result => Function_Block.Packet_Sent);

            if Function_Block.Packet_Sent then
               Function_Block.Status := X04;
            end if;

         when X04 =>

            Function_Block.My_Receive_Queue.Get
              (Item   => Function_Block.Confirmation,
               Result => Function_Block.Answer_Got);

            if Function_Block.Answer_Got then

               Function_Block.Fw_Ident_Cnf :=
                 From_cifX_Packet (Function_Block.Confirmation);

               if Function_Block.Fw_Ident_Cnf.Head.Cmd /=
                 RCX_FIRMWARE_IDENTIFY_CNF then

                  Function_Block.Error_Flag := True;

                  A4A.Log.Logger.Put
                    (Who  => My_Ident & ".Cyclic",
                     What => "Wrong Command received");

               elsif Function_Block.Fw_Ident_Cnf.Head.Id /=
                 Function_Block.Message_Id then

                  Function_Block.Error_Flag := True;

                  A4A.Log.Logger.Put
                    (Who  => My_Ident & ".Cyclic",
                     What => "Wrong Message Id received");

               elsif Function_Block.Fw_Ident_Cnf.Head.State /= 0 then

                  Function_Block.Error_Flag := True;

                  Function_Block.Last_Error :=
                    Function_Block.Fw_Ident_Cnf.Head.State;

               else

                  Function_Block.Fw_Identification :=
                    Function_Block.Fw_Ident_Cnf.Data.Fw_Identification;

               end if;

               Function_Block.My_Channel.Return_Packet
                 (Item => Function_Block.Confirmation);

               Function_Block.Status := X05;
            end if;

         when X05 =>

            if not Do_Command then
               Function_Block.Status := X00;
            end if;

      end case;

      Done := (Function_Block.Status = X05);

      Error := Function_Block.Error_Flag;

   end Cyclic;

   function Get_Last_Error
     (Function_Block : in Instance) return DWord is
   begin

      return Function_Block.Last_Error;

   end Get_Last_Error;

   function Get_Data
     (Function_Block : in Instance) return RCX_FW_IDENTIFICATION_T is
   begin

      return Function_Block.Fw_Identification;

   end Get_Data;

end A4A.Protocols.HilscherX.rcX_Public.rcX_Firmware_Identify.FB;

Le programme exemple « Test_rcX_Firmware_Identify » met à profit notre nouvel objet.

Après les habituelles initialisations, on entre dans une boucle qui simule le traitement cyclique de votre application d’automatisme.

On en sort lorsqu’un résultat ou une erreur sont obtenus et on les affiche puis on termine proprement.

-----------------------------------------------------------------------
--                       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 Interfaces.C;

with Ada.Exceptions; use Ada.Exceptions;

with A4A; use A4A;

with A4A.Log;

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.FB;
use A4A.Protocols.HilscherX.rcX_Public;

with A4A.Protocols.HilscherX.Channel_Messaging;
use A4A.Protocols.HilscherX.Channel_Messaging;

procedure Test_rcX_Firmware_Identify is

   My_Ident : String := "Test_rcX_Firmware_Identify";

   package cifX renames A4A.Protocols.HilscherX.cifX_User;

   Driver_Handle  : aliased cifX.Driver_Handle_Type;
   Channel_Handle : aliased cifX.Channel_Handle_Type;

   Result : DInt;

   cifX_Driver_Init_Done  : Boolean := False;
   cifX_Driver_Open_Done  : Boolean := False;
   cifX_Channel_Open_Done : Boolean := False;

   Do_Command    : Boolean := False;
   Command_Done  : Boolean := False;
   Command_Error : Boolean := False;

   My_Channel_Messaging : aliased
     A4A.Protocols.HilscherX.Channel_Messaging.Instance;

   rcX_Firmware_Identify_FB : rcX_Firmware_Identify.FB.Instance;

   Fw_Identification  : rcX_Firmware_Identify.RCX_FW_IDENTIFICATION_T;

   Error_String : String (1.. 20);

   procedure cifX_Show_Error (Error : DInt) is
   begin
      A4A.Log.Logger.Put
        (Who  => My_Ident,
         What => cifX.Driver_Get_Error_Description(Error));
   end cifX_Show_Error;

   procedure cifX_Show_Firmware_Identification is
      What : String := CRLF
        & "***********************************************" & CRLF
        & "          Firmware Identification" & CRLF & CRLF
        & "Firmware Version :" & CRLF
        & "Major    : "
        & Fw_Identification.Fw_Version.Major'Img & CRLF
        & "Minor    : "
        & Fw_Identification.Fw_Version.Minor'Img & CRLF
        & "Build    : "
        & Fw_Identification.Fw_Version.Build'Img & CRLF
        & "Revision : "
        & Fw_Identification.Fw_Version.Revision'Img & CRLF
        & CRLF
        & "Firmware Name : "
        & Interfaces.C.To_Ada
        (Fw_Identification.Fw_Name.Name) & CRLF
        & CRLF
        & "Firmware Date :" & CRLF
        & "Year  : "
        & Fw_Identification.Fw_Date.Year'Img & CRLF
        & "Month : "
        & Fw_Identification.Fw_Date.Month'Img & CRLF
        & "Day   : "
        & Fw_Identification.Fw_Date.Day'Img & CRLF
        & "***********************************************" & CRLF;
   begin
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => What);
   end cifX_Show_Firmware_Identification;

   procedure Close is
   begin

      My_Channel_Messaging.Quit;

      --Wait for completion
      loop

         exit when My_Channel_Messaging.Is_Terminated;
         delay 1.0;

      end loop;

      if cifX_Channel_Open_Done then
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "Deinitializing cifX Driver");
         cifX.Driver_Deinit;
         cifX_Driver_Init_Done := False;
      end if;

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "finished !");
      A4A.Log.Quit;

   end Close;

begin

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "Test_Messaging...");

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "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

      My_Channel_Messaging.Initialise (Channel_Handle => Channel_Handle);

      rcX_Firmware_Identify_FB.Initialise
        (Channel_Access => My_Channel_Messaging'Unrestricted_Access);

      loop

         Do_Command := not Command_Done;

         rcX_Firmware_Identify_FB.Cyclic
           (Do_Command => Do_Command,
            Done       => Command_Done,
            Error      => Command_Error);

         exit when not Do_Command;

         delay 0.1;

      end loop;

      if not Command_Error then

         Fw_Identification := rcX_Firmware_Identify_FB.Get_Data;

         cifX_Show_Firmware_Identification;

      else

         DWord_Text_IO.Put
           (To   => Error_String,
            Item => rcX_Firmware_Identify_FB.Get_Last_Error,
            Base => 16);

         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "Got an error : " & Error_String);

      end if;

   end if;

   Close;

exception

   when Error: others =>
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => Exception_Information(Error));

      Close;

end Test_rcX_Firmware_Identify;

La trace suivante montre notre code à l’œuvre, et ça fonctionne !

C:\GNAT\Projects\A4A\hilscherx\exe\test_rcx_firmware_identify
2014-06-13 07:31:35.09 => Test_rcX_Firmware_Identify : Test_Messaging...
2014-06-13 07:31:35.09 => Test_rcX_Firmware_Identify : Initializing cifX Driver
2014-06-13 07:31:35.09 => Test_rcX_Firmware_Identify : Opening Driver
2014-06-13 07:31:35.09 => Test_rcX_Firmware_Identify : Opening Channel
2014-06-13 07:31:36.12 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#0#
Dest_Id :                16#1#
Src_Id  :           16#28FD48#
Cmd     :             16#1EB7#
2014-06-13 07:31:36.30 => Test_rcX_Firmware_Identify :
***********************************************
          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
***********************************************

2014-06-13 07:31:37.12 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-13 07:31:37.31 => Test_rcX_Firmware_Identify : Closing Channel
2014-06-13 07:31:37.31 => Test_rcX_Firmware_Identify : Closing Driver
2014-06-13 07:31:37.31 => Test_rcX_Firmware_Identify : Deinitializing cifX Driver
2014-06-13 07:31:37.31 => Test_rcX_Firmware_Identify : finished !
Logging_Task terminated...

[2014-06-13 09:31:38] process terminated successfully, elapsed time: 03.73s

Quelques blocs fonctions de ce type sont aujourd’hui disponibles dans « Ada for Automation ».

L’API Hilscher est riche, les protocoles supportés nombreux, et il faudra un peu de temps et beaucoup de contributions 😉 pour disposer de toute la fonctionnalité au niveau utilisateur.

N’hésitez pas à nous solliciter si vous souhaitez mettre en œuvre une solution « Ada for Automation » et qu’il vous manque des blocs. Ça doit pouvoir s’arranger…

Merci d’avance pour vos retours constructifs.

Cordialement,
Stéphane

A4A : Infrastructure Messagerie Hilscher cifX – Layer 2 – Objet

Bonjour,

L’infrastructure présentée dans l’article précédent permet d’utiliser un canal de communication.

Cependant, certaines cartes Hilscher cifX offrent deux canaux de communication et l’API en prévoit jusqu’à quatre.

Et il est possible de gérer un nombre illimité de cartes Hilscher cifX sur la même machine.

Aussi, il est nécessaire de rendre le code réutilisable le plus simplement possible et c’est ce que réalise le paquetage « A4A.Protocols.HilscherX.Channel_Messaging » sous forme d’objet.

La spécification du paquetage ci-dessous montre :

  • l’instanciation du paquetage « Pool » avec une taille par défaut,
  • l’instanciation du paquetage « Queue » avec une taille de 1, nous y reviendrons,
  • l’instanciation du paquetage « Queue » avec une taille par défaut,
  • et un objet défini par son interface et ses données d’instance.

Dans les données d’instance on trouve le réservoir de paquets, la queue en émission, la queue par défaut en réception et les deux tâches d’émission et réception qui exercent leur activité sur les données d’instance.

J’adore cette construction ! A chaque instanciation de cet objet, les tâches sont automatiquement créées.
Un objet très actif donc.

En fonction du besoin, l’utilisateur de cet objet peut, soit déclarer sa propre queue en réception, soit utiliser celle par défaut. Pour les fonctions en mode Client / Serveur, on peut utiliser la queue de taille 1 car on n’attend que la réponse à la requête.

-----------------------------------------------------------------------
--                       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.Channel_Messaging is

   Default_Pool_Size  : constant := 20;
   Default_Queue_Size : constant := 10;

   package Pool_Package is new
     A4A.Protocols.HilscherX.Message_Pool (Pool_Size => Default_Pool_Size);

   package Queue_Package_Single is new
     A4A.Protocols.HilscherX.Message_Queue (Queue_Size => 1);

   package Queue_Package_Multiple is new
     A4A.Protocols.HilscherX.Message_Queue (Queue_Size => Default_Queue_Size);

   Queue_Package_Type_Single   : constant := 0;
   Queue_Package_Type_Multiple : constant := 1;

   type Instance is tagged limited private;
   type Instance_Access is access all Instance;

   procedure Initialise
     (Channel        : in out Instance;
      Channel_Handle : in Channel_Handle_Type);

   procedure Quit
     (Channel : in out Instance);

   function Is_Terminated
     (Channel : in Instance) return Boolean;

   procedure Get_Packet
     (Channel : in out Instance;
      Item    : out cifX_Packet_Access;
      Result  : out Boolean);
   -- Get a packet from the Packet Pool
   -- Returns False if the Pool is empty

   procedure Return_Packet
     (Channel : in out Instance;
      Item    : in cifX_Packet_Access);
   -- Return a packet to the Packet Pool

   procedure Send
     (Channel : in out Instance;
      Item    : in cifX_Packet_Access;
      Result  : out Boolean);
   -- Send a packet via the Packet Queue
   -- Returns False if the Queue is full

   procedure Receive
     (Channel : in out Instance;
      Item    : out cifX_Packet_Access;
      Result  : out Boolean);
   -- Receive a packet from the default receive queue
   -- Returns False if no packet was available

private

   Package_Ident : String := "A4A.Protocols.HilscherX.Channel_Messaging";

   task type Send_Msg_Task_Type
     (Channel : access Instance);

   task type Receive_Msg_Task_Type
     (Channel : access Instance);

   type Instance is tagged limited
      record

         Quit_Flag : Boolean := False;
         Init_Flag : Boolean := False;

         Send_Task_Terminated    : Boolean := False;
         Receive_Task_Terminated : Boolean := False;

         The_Channel_Handle  : Channel_Handle_Type;

         Message_Pool  : Pool_Package.Message_Pool_Type;

         Send_Queue    : Queue_Package_Multiple.Message_Queue_Type;
         Receive_Queue : Queue_Package_Multiple.Message_Queue_Type;

         Send_Msg_Task    : Send_Msg_Task_Type (Instance'Access);
         Receive_Msg_Task : Receive_Msg_Task_Type (Instance'Access);

      end record;

end A4A.Protocols.HilscherX.Channel_Messaging;

Le corps de ce paquetage reprend le principe déjà présenté dans l’article précédent, hormis le fait qu’il travaille maintenant sur les données d’instance de l’objet.

On notera cependant que le routage des paquets vers les queues de destination est implémenté.

Selon que le paquet est une réponse ou une indication, le champ Cmd dans l’en-tête du paquet est pair ou impair, l’utilisation des informations de routage est différente puisque dans un cas il faut retourner la réponse à la source de la requête et dans l’autre il faut transmettre l’indication au destinataire de celles-ci, qui n’est autre que celui qui s’est enregistré, nous verrons cela ultérieurement.

Les champs Src et Dest indiquent le type de queue, single ou multiple, ce qui est une utilisation un peu détournée de l’utilisation prévue et explicitée dans le document netX Dual Port Memory Interface.

Les champs Src_Id et Dest_Id transportent la référence à la queue de l’émetteur ou du destinataire et, comme Ada est un langage fortement typé, il est nécessaire de recourir à des conversions de type « Access / DWord ».

-----------------------------------------------------------------------
--                       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.Log;

package body A4A.Protocols.HilscherX.Channel_Messaging is

   procedure Initialise
     (Channel        : in out Instance;
      Channel_Handle : in Channel_Handle_Type) is
   begin

      Channel.The_Channel_Handle := Channel_Handle;

      Channel.Message_Pool.Initialise;

      Channel.Init_Flag := True;

   end Initialise;

   procedure Quit
     (Channel : in out Instance) is
   begin
      Channel.Quit_Flag := True;
   end Quit;

   function Is_Terminated
     (Channel : in Instance) return Boolean is
   begin

      return Channel.Send_Task_Terminated and Channel.Receive_Task_Terminated;

   end Is_Terminated;

   procedure Get_Packet
     (Channel : in out Instance;
      Item    : out cifX_Packet_Access;
      Result  : out Boolean) is
   begin

      Channel.Message_Pool.Get_Packet (Item, Result);

   end Get_Packet;

   procedure Return_Packet
     (Channel : in out Instance;
      Item    : in cifX_Packet_Access) is
   begin

      Channel.Message_Pool.Return_Packet (Item);

   end Return_Packet;

   procedure Send
     (Channel : in out Instance;
      Item    : in cifX_Packet_Access;
      Result  : out Boolean) is
   begin

      Channel.Send_Queue.Put (Item, Result);

   end Send;

   procedure Receive
     (Channel : in out Instance;
      Item    : out cifX_Packet_Access;
      Result  : out Boolean) is
   begin

      Channel.Receive_Queue.Get (Item, Result);

   end Receive;

   task body Send_Msg_Task_Type is

      Packet    : cifX_Packet_Access;

      Result    : DInt;

   begin

      loop

         delay 1.0;
         exit when Channel.Init_Flag or Channel.Quit_Flag;

      end loop;

      loop

         exit when Channel.Quit_Flag;

         select

            Channel.Send_Queue.Get (Item => Packet);

            Result := Channel_Put_Packet
              (Channel_Handle => Channel.The_Channel_Handle,
               Send_Packet    => Packet.all,
               Time_Out       => 10);
            if Result /= CIFX_NO_ERROR then
               Show_Error (Result);
            end if;

            Channel.Message_Pool.Return_Packet (Item => Packet);

         or

            delay 1.0;

         end select;

      end loop;

      Channel.Send_Task_Terminated := True;

   end Send_Msg_Task_Type;

   task body Receive_Msg_Task_Type is

      My_Ident : String := Package_Ident & ".Receive_Msg_Task_Type";

      Packet     : cifX_Packet_Access;

      Result     : DInt;

      Queue_Type : DWord;
      Queue_Id   : DWord;

      Packet_Got : Boolean := False;
      Packet_Put : Boolean := False;

      Message_Queue_Single_Access : Queue_Package_Single.Message_Queue_Access;
      Message_Queue_Multiple_Access :
      Queue_Package_Multiple.Message_Queue_Access;

      procedure Dump_Packet is

         Dest_String    : String (1.. 20);
         Src_String     : String (1.. 20);
         Dest_Id_String : String (1.. 20);
         Src_Id_String  : String (1.. 20);
         Cmd_String     : String (1.. 20);

      begin

         DWord_Text_IO.Put
           (To   => Dest_String,
            Item => Packet.Header.Dest,
            Base => 16);

         DWord_Text_IO.Put
           (To   => Src_String,
            Item => Packet.Header.Src,
            Base => 16);

         DWord_Text_IO.Put
           (To   => Dest_Id_String,
            Item => Packet.Header.Dest_Id,
            Base => 16);

         DWord_Text_IO.Put
           (To   => Src_Id_String,
            Item => Packet.Header.Src_Id,
            Base => 16);

         DWord_Text_IO.Put
           (To   => Cmd_String,
            Item => Packet.Header.Cmd,
            Base => 16);

         A4A.Log.Logger.Put
           (Who  => My_Ident,
            What => "Got a message : " & CRLF
            & "Dest    : " & Dest_String & CRLF
            & "Src     : " & Src_String & CRLF
            & "Dest_Id : " & Dest_Id_String & CRLF
            & "Src_Id  : " & Src_Id_String & CRLF
            & "Cmd     : " & Cmd_String
           );

      end Dump_Packet;

   begin

      loop

         delay 1.0;
         exit when Channel.Init_Flag or Channel.Quit_Flag;

      end loop;

      loop

         exit when Channel.Quit_Flag;

         if not Packet_Got then

            Channel.Message_Pool.Get_Packet
              (Item   => Packet,
               Result => Packet_Got);

         end if;

         if not Packet_Got then

            A4A.Log.Logger.Put (Who  => My_Ident,
                                What => "Could not get packet from pool...");

         else

            Result := Channel_Get_Packet
              (Channel_Handle => Channel.The_Channel_Handle,
               Size           => cifX_Packet_Type'Size / 8,
               Recv_Packet    => Packet.all,
               Time_Out       => 1000);
            if Result = CIFX_NO_ERROR then

               Dump_Packet;

               if (Packet.Header.Cmd and 1) = 0 then

                  -- It's an indication
                  Queue_Type := Packet.Header.Dest;
                  Queue_Id := Packet.Header.Dest_Id;

               else

                  -- It's a response
                  Queue_Type := Packet.Header.Src;
                  Queue_Id := Packet.Header.Src_Id;

               end if;

               if Queue_Id /= 0 then

                  if Queue_Type = Queue_Package_Type_Single then

                     Message_Queue_Single_Access :=
                       Queue_Package_Single.To_Message_Queue (Queue_Id);

                     Message_Queue_Single_Access.Put
                       (Item   => Packet,
                        Result => Packet_Put);

                  else

                     Message_Queue_Multiple_Access :=
                       Queue_Package_Multiple.To_Message_Queue (Queue_Id);

                     Message_Queue_Multiple_Access.Put
                       (Item   => Packet,
                        Result => Packet_Put);

                  end if;

               else

                  Channel.Receive_Queue.Put
                    (Item   => Packet,
                     Result => Packet_Put);

               end if;

               Packet_Got := False;

            elsif Result = CIFX_DEV_GET_TIMEOUT
              or Result = CIFX_DEV_GET_NO_PACKET then

               A4A.Log.Logger.Put (Who  => My_Ident,
                                   What => "No packet pending.");

            else

               Show_Error (Result);

            end if;

         end if;

      end loop;

      Channel.Receive_Task_Terminated := True;

   end Receive_Msg_Task_Type;

end A4A.Protocols.HilscherX.Channel_Messaging;

Le programme de tests « Test_Channel_Messaging » ci-dessous reprend les grandes lignes de celui d’hier.

Il se déroule en deux temps, l’un en utilisant la queue de réception par défaut, l’autre en utilisant une queue de réception en propre.

Cette queue de réception en propre peut être du type « single » ou « multiple ». On utiliserait « multiple » afin de récupérer un flot d’indications par exemple.

-----------------------------------------------------------------------
--                       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 Interfaces.C;

with Ada.Exceptions; use Ada.Exceptions;

with A4A; use A4A;

with A4A.Log;

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.Channel_Messaging;
use A4A.Protocols.HilscherX.Channel_Messaging;

procedure Test_Channel_Messaging is

   My_Ident : String := "Test_Channel_Messaging";

   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_Sent : Boolean := False;
   Answer_Got  : Boolean := False;

   My_Channel_Messaging : A4A.Protocols.HilscherX.Channel_Messaging.Instance;

   -- My_Receive_Queue : aliased Queue_Package_Single.Message_Queue_Type;
   -- My_Receive_Queue_Type : constant := Queue_Package_Type_Single;
   My_Receive_Queue : aliased Queue_Package_Multiple.Message_Queue_Type;
   My_Receive_Queue_Type : constant := Queue_Package_Type_Multiple;

   procedure cifX_Show_Error (Error : DInt) is
   begin
      A4A.Log.Logger.Put
        (Who  => My_Ident,
         What => cifX.Driver_Get_Error_Description(Error));
   end cifX_Show_Error;

   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
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => What);
   end cifX_Show_Firmware_Identification;

   procedure Close is
   begin

      My_Channel_Messaging.Quit;

      --Wait for completion
      loop

         exit when My_Channel_Messaging.Is_Terminated;
         delay 1.0;

      end loop;

      if cifX_Channel_Open_Done then
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "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
         A4A.Log.Logger.Put (Who  => My_Ident,
                             What => "Deinitializing cifX Driver");
         cifX.Driver_Deinit;
         cifX_Driver_Init_Done := False;
      end if;

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "finished !");
      A4A.Log.Quit;

   end Close;

begin

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "Test_Messaging...");

   A4A.Log.Logger.Put (Who  => My_Ident,
                       What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "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

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "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

      My_Channel_Messaging.Initialise (Channel_Handle => Channel_Handle);

   end if;

   if cifX_Channel_Open_Done then

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Test with default receive queue+++");
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Sending Request");

      My_Channel_Messaging.Get_Packet
        (Item   => Request,
         Result => Packet_Got);

      if not Packet_Got then

         A4A.Log.Logger.Put (Who  => My_Ident,
                             What =>
                               "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;

         My_Channel_Messaging.Send
           (Item   => Request,
            Result => Packet_Sent);

         if not Packet_Sent then

            A4A.Log.Logger.Put (Who  => My_Ident,
                                What =>
                                  "Could not put Request packet in queue...");

            My_Channel_Messaging.Return_Packet (Item => Request);

         else

            delay 3.0;

            My_Channel_Messaging.Receive
              (Item   => Confirmation,
               Result => Answer_Got);

            if Answer_Got then

               Fw_Ident_Cnf := From_cifX_Packet (Confirmation);

               cifX_Show_Firmware_Identification;

               My_Channel_Messaging.Return_Packet (Item => Confirmation);

            else

               A4A.Log.Logger.Put (Who  => My_Ident,
                                   What => "Got no answer...");

            end if;

         end if;

      end if;

   end if;

   Packet_Got  := False;
   Packet_Sent := False;
   Answer_Got  := False;

   if cifX_Channel_Open_Done then

      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Test with own receive queue+++");
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => "Sending Request");

      My_Channel_Messaging.Get_Packet
        (Item   => Request,
         Result => Packet_Got);

      if not Packet_Got then

         A4A.Log.Logger.Put (Who  => My_Ident,
                             What =>
                               "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     := My_Receive_Queue_Type;
         Fw_Ident_Req.Head.Dest_Id := 0;

         Fw_Ident_Req.Head.Src_Id  :=
           -- Queue_Package_Single.From_Message_Queue
           Queue_Package_Multiple.From_Message_Queue
             (My_Receive_Queue'Unrestricted_Access);

         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;

         My_Channel_Messaging.Send
           (Item   => Request,
            Result => Packet_Sent);

         if not Packet_Sent then

            A4A.Log.Logger.Put (Who  => My_Ident,
                                What =>
                                  "Could not put Request packet in queue...");

            My_Channel_Messaging.Return_Packet (Item => Request);

         else

            delay 3.0;

            My_Receive_Queue.Get
              (Item   => Confirmation,
               Result => Answer_Got);

            if Answer_Got then

               Fw_Ident_Cnf := From_cifX_Packet (Confirmation);

               cifX_Show_Firmware_Identification;

               My_Channel_Messaging.Return_Packet (Item => Confirmation);

            else

               A4A.Log.Logger.Put (Who  => My_Ident,
                                   What => "Got no answer...");

            end if;

         end if;

      end if;

   end if;

   Close;

exception

   when Error: others =>
      A4A.Log.Logger.Put (Who  => My_Ident,
                          What => Exception_Information(Error));

      Close;

end Test_Channel_Messaging;

Et pour terminer, la trace qui s’est un peu étoffée… 😉

On remarquera l’utilisation des champs Src et Src_Id, Dest et Dest_Id pour le routage des messages.

C:\GNAT\Projects\A4A\hilscherx\exe\test_channel_messaging
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Test_Messaging...
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Initializing cifX Driver
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Opening Driver
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Opening Channel
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Test with default receive queue+++
2014-06-12 07:36:52.72 => Test_Channel_Messaging : Sending Request
2014-06-12 07:36:53.75 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#0#
Dest_Id :                16#1#
Src_Id  :                16#0#
Cmd     :             16#1EB7#
2014-06-12 07:36:54.75 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-12 07:36:55.73 => Test_Channel_Messaging :
***********************************************
          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
***********************************************

2014-06-12 07:36:55.73 => Test_Channel_Messaging : Test with own receive queue+++
2014-06-12 07:36:55.73 => Test_Channel_Messaging : Sending Request
2014-06-12 07:36:55.73 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : Got a message :
Dest    :               16#20#
Src     :                16#1#
Dest_Id :                16#1#
Src_Id  :           16#28FDC0#
Cmd     :             16#1EB7#
2014-06-12 07:36:56.73 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-12 07:36:57.73 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-12 07:36:58.73 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-12 07:36:58.74 => Test_Channel_Messaging :
***********************************************
          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
***********************************************

2014-06-12 07:36:59.73 => A4A.Protocols.HilscherX.Channel_Messaging.Receive_Msg_Task_Type : No packet pending.
2014-06-12 07:36:59.75 => Test_Channel_Messaging : Closing Channel
2014-06-12 07:36:59.75 => Test_Channel_Messaging : Closing Driver
2014-06-12 07:36:59.75 => Test_Channel_Messaging : Deinitializing cifX Driver
2014-06-12 07:36:59.75 => Test_Channel_Messaging : finished !
Logging_Task terminated...

[2014-06-12 09:36:59] process terminated successfully, elapsed time: 07.59s

Cordialement,
Stéphane

A4A : Infrastructure Messagerie Hilscher cifX – Layer 2

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;

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;

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

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;

Cordialement,
Stéphane