polyorb_hi-messages.adb 6.7 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
--    Copyright (C) 2006-2009 Telecom ParisTech, 2010-2014 ESA & ISAE.      --
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
--                                                                          --
-- PolyORB HI is free software; you  can  redistribute  it and/or modify it --
-- under terms of the GNU General Public License as published by the Free   --
-- Software Foundation; either version 2, or (at your option) any later.    --
-- 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. See the GNU General --
-- Public License for more details. You should have received  a copy of the --
-- GNU General Public  License  distributed with PolyORB HI; see file       --
-- COPYING. If not, write  to the Free  Software Foundation, 51 Franklin    --
-- Street, Fifth Floor, Boston, MA 02111-1301, 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.                                      --
--                                                                          --
jhugues's avatar
jhugues committed
29 30
--              PolyORB-HI/Ada is maintained by the TASTE project           --
--                      (taste-users@lists.tuxfamily.org)                   --
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 62 63
--                                                                          --
------------------------------------------------------------------------------

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;

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

69 70 71 72 73 74 75 76 77 78
   -----------------
   -- Encapsulate --
   -----------------

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

      P : constant Stream_Element_Array (1 .. Length (Message))
        := Payload (Message);
84 85 86 87
   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));
88 89
      R (Header_Size +  1 .. Header_Size + Length (Message)) := P;
      --  XXX GNATProve GPL 2014 limitation ?
90 91 92 93 94 95 96 97 98
      return R;
   end Encapsulate;

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

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

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

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

116 117 118 119 120 121 122 123
      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;
124 125
      end if;

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

129 130 131 132 133
      if Stream.First + Read_Elts < Stream.Content'Last then
         Stream.First := Stream.First + Read_Elts;
      else
         Stream.First := 0;
      end if;
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
   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
156
         Reallocate (Stream);
157
         -- The message is invalid, we reset it
158
         -- XXX Do we need to do that ???
159 160
      end if;

yoogx's avatar
yoogx committed
161 162 163
      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;
164
      end if;
165 166 167 168 169 170 171 172 173 174
   end Write;

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

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

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

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

end PolyORB_HI.Messages;