polyorb_hi-messages.adb 6.55 KB
Newer Older
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                          PolyORB HI COMPONENTS                           --
--                                                                          --
--                  P O L Y O R B _ H I . M E S S A G E S                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
--    Copyright (C) 2006-2009 Telecom ParisTech, 2010-2015 ESA & ISAE.      --
--                                                                          --
-- PolyORB-HI is free software; you can redistribute it and/or modify under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion. PolyORB-HI 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.                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
jhugues's avatar
jhugues committed
27 28
--              PolyORB-HI/Ada is maintained by the TASTE project           --
--                      (taste-users@lists.tuxfamily.org)                   --
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
--                                                                          --
------------------------------------------------------------------------------

with Interfaces;
with PolyORB_HI.Utils;
with Ada.Unchecked_Conversion;

package body PolyORB_HI.Messages is

   use PolyORB_HI.Utils;
   use Interfaces;

   --  Message format:
   --  - the first byte is set to the message length,
   --  - the second one is the destination entity (Thread),
   --  - the third one is the sender entity (Thread),
   --  - other bytes are the message payload.

   type Wrapper is new Stream_Element_Count range
     0 .. 2 ** (8 * Message_Length_Size) - 1;
   for Wrapper'Size use Message_Length_Size * 8;

   function Internal_To_Length is new Ada.Unchecked_Conversion
     (Message_Size_Buffer, Wrapper);
   function Internal_To_Buffer is new Ada.Unchecked_Conversion
     (Wrapper, Message_Size_Buffer);

   --  The message header offsets. Must be synchronized with the
   --  header size.

   Receiver_Offset : constant Stream_Element_Offset := Message_Length_Size + 1;
   Sender_Offset   : constant Stream_Element_Offset := Message_Length_Size + 2;

62 63 64
   function Length (M : Message_Type) return PDU_Index is
      (M.Last - M.First + 1)
        with Pre => (Valid (M));
65 66
   --  Return length of message M

67 68 69 70 71 72 73 74 75 76
   -----------------
   -- Encapsulate --
   -----------------

   function Encapsulate
     (Message : Message_Type;
      From    : Entity_Type;
      Entity  : Entity_Type)
     return Stream_Element_Array
   is
77
      L : constant Stream_Element_Count := Message.Last + Header_Size;
78 79 80 81
      R : Stream_Element_Array (1 .. L) := (others => 0);

      P : constant Stream_Element_Array (1 .. Length (Message))
        := Payload (Message);
82 83 84 85
   begin
      R (1 .. Message_Length_Size) := To_Buffer (L - 1);
      R (Receiver_Offset) := Stream_Element (Internal_Code (Entity));
      R (Sender_Offset)   := Stream_Element (Internal_Code (From));
86 87
      R (Header_Size +  1 .. Header_Size + Length (Message)) := P;
      --  XXX GNATProve GPL 2014 limitation ?
88 89 90 91 92 93 94 95 96
      return R;
   end Encapsulate;

   ------------
   -- Sender --
   ------------

   function Sender (M : Stream_Element_Array) return Entity_Type is
   begin
97
      return Corresponding_Entity (Unsigned_8 (M (Sender_Offset)));
98 99 100 101 102 103 104 105 106 107 108
   end Sender;

   ----------
   -- Read --
   ----------

   procedure Read
     (Stream : in out Message_Type;
      Item   :    out Stream_Element_Array;
      Last   :    out Stream_Element_Offset)
   is
109 110
      Read_Elts : constant Stream_Element_Count
        := Stream_Element_Count'Min (Item'Length, Length (Stream));
111
   begin
112 113
      Item := (others => 0);

114 115 116 117 118 119 120 121
      if Read_Elts < 1 then
         --  We have nothing to read, exit
         Last := 0;
         return;
      elsif Read_Elts = Item'Length then
         Last := Item'Last;
      else
         Last := Item'First + Read_Elts - 1;
122 123
      end if;

124 125
      Item (Item'First .. Last)
        := Stream.Content (Stream.First .. Stream.First + Read_Elts - 1);
126

127 128 129 130 131
      if Stream.First + Read_Elts < Stream.Content'Last then
         Stream.First := Stream.First + Read_Elts;
      else
         Stream.First := 0;
      end if;
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
   end Read;

   ----------------
   -- Reallocate --
   ----------------

   procedure Reallocate (M : in out Message_Type) is
   begin
      M.First := 1;
      M.Last  := 0;
   end Reallocate;

   -----------
   -- Write --
   -----------

   procedure Write
     (Stream : in out Message_Type;
      Item   :        Stream_Element_Array)
   is
   begin
      if Stream.First > Stream.Last then
154
         Reallocate (Stream);
155
         -- The message is invalid, we reset it
156
         -- XXX Do we need to do that ???
157 158
      end if;

yoogx's avatar
yoogx committed
159 160 161
      if Item'Length <= Stream.Content'Last - Stream.Last then
         Stream.Content (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
         Stream.Last := Stream.Last + Item'Length;
162
      end if;
163 164 165 166 167 168 169 170 171 172
   end Write;

   ---------------
   -- To_Length --
   ---------------

   function To_Length (B : Message_Size_Buffer) return Stream_Element_Count is
   begin
      return Stream_Element_Count
        (Swap_Bytes
173
           (Interfaces.Unsigned_16 (Internal_To_Length (B))));
174 175 176 177 178 179 180 181 182
   end To_Length;

   ---------------
   -- To_Buffer --
   ---------------

   function To_Buffer (L : Stream_Element_Count) return Message_Size_Buffer is
   begin
      return Internal_To_Buffer
183
        (Wrapper (Swap_Bytes (Interfaces.Unsigned_16 (L))));
184 185 186
   end To_Buffer;

end PolyORB_HI.Messages;