OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--                  OCARINA.BACKENDS.PO_HI_ADA.TRANSPORT                    --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2008-2009 Telecom ParisTech,                 --
10
--                 2010-2019 ESA & ISAE, 2019-2020 OpenAADL                 --
11
--                                                                          --
12
-- Ocarina  is free software; you can redistribute it and/or modify under   --
13
-- terms of the  GNU General Public License as published  by the Free Soft- --
14
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
15
-- sion. Ocarina is distributed in the hope that it will be useful, but     --
16
-- WITHOUT ANY WARRANTY; without even the implied warranty of               --
17
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     --
18
--                                                                          --
19
-- As a special exception under Section 7 of GPL version 3, you are granted --
20
-- additional permissions described in the GCC Runtime Library Exception,   --
21
-- version 3.1, as published by the Free Software Foundation.               --
22
--                                                                          --
23
-- You should have received a copy of the GNU General Public License and    --
24
-- a copy of the GCC Runtime Library Exception along with this program;     --
25
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26
-- <http://www.gnu.org/licenses/>.                                          --
27
--                                                                          --
28
--                    Ocarina is maintained by OpenAADL team                --
29
--                              (info@openaadl.org)                         --
30
--                                                                          --
31
------------------------------------------------------------------------------
32

33
with Ocarina.Namet;
34

35
with Ocarina.ME_AADL;
36
with Ocarina.ME_AADL.AADL_Instances.Nodes;
37
with Ocarina.ME_AADL.AADL_Instances.Nutils;
38
with Ocarina.ME_AADL.AADL_Instances.Entities;
39
with Ocarina.Backends.Ada_Values;
40

41
with Ocarina.Backends.Utils;
42
with Ocarina.Backends.Properties;
43
with Ocarina.Backends.Ada_Tree.Nutils;
44
with Ocarina.Backends.Ada_Tree.Nodes;
45
with Ocarina.Backends.PO_HI_Ada.Mapping;
46
with Ocarina.Backends.PO_HI_Ada.Runtime;
47

48
package body Ocarina.Backends.PO_HI_Ada.Transport is
49

50
   use Ocarina.Namet;
51
   use Ocarina.ME_AADL;
52
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
53
   use Ocarina.ME_AADL.AADL_Instances.Entities;
54
   use Ocarina.Backends.Utils;
55
   use Ocarina.Backends.Properties;
56
   use Ocarina.Backends.Ada_Tree.Nutils;
57
   use Ocarina.Backends.PO_HI_Ada.Mapping;
58
   use Ocarina.Backends.PO_HI_Ada.Runtime;
59
   use Ocarina.Backends.Ada_Values;
60

61
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
62
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
63

64
   function Deliver_Spec (E : Node_Id; With_Aspect : Boolean) return Node_Id;
65
   --  Create a subprogram specification corresponding to the
66
   --  message delivery routine.
67

68
   function Send_Spec (E : Node_Id; With_Aspect : Boolean) return Node_Id;
69
   --  Create the subprogram specification corresponding to the
70
   --  transport layer Send routine.
71

72
   ------------------
73
   -- Deliver_Spec --
74
   ------------------
75

76 1
   function Deliver_Spec (E : Node_Id; With_Aspect : Boolean) return Node_Id is
77
      pragma Unreferenced (E);
78

79 1
      Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
80 1
      N       : Node_Id;
81 1
      Aspect : Node_Id := No_Node;
82
   begin
83
      --  Entity
84

85
      N :=
86 1
        Make_Parameter_Specification
87 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_Entity)),
88 1
           Subtype_Mark        => RE (RE_Entity_Type),
89
           Parameter_Mode      => Mode_In);
90 1
      Append_Node_To_List (N, Profile);
91

92
      --  Message
93

94
      N :=
95 1
        Make_Parameter_Specification
96 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_Message)),
97 1
           Subtype_Mark        => RE (RE_Stream_Element_Array),
98
           Parameter_Mode      => Mode_In);
99 1
      Append_Node_To_List (N, Profile);
100

101
      --  Pre-condition
102

103 1
      if Add_SPARK2014_Annotations and then With_Aspect then
104 0
         Aspect := Make_Aspect_Specification
105 0
           (Make_List_Id
106 0
              (Make_Aspect (ASN (A_Pre),
107 0
                            Make_Pre
108 0
                              (Make_Subprogram_Call
109 0
                                 (RE (RE_Valid),
110 0
                                  Make_List_Id (Make_Defining_Identifier
111
                                                  (PN (P_Message))))))));
112
      end if;
113

114
      N :=
115 1
        Make_Subprogram_Specification
116 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Deliver)),
117
           Parameter_Profile   => Profile,
118
           Return_Type         => No_Node,
119
           Aspect_Specification => Aspect);
120

121 1
      return N;
122
   end Deliver_Spec;
123

124
   ---------------
125
   -- Send_Spec --
126
   ---------------
127

128 1
   function Send_Spec (E : Node_Id; With_Aspect : Boolean) return Node_Id is
129
      pragma Unreferenced (E);
130

131 1
      Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
132 1
      Aspect  : Node_Id := No_Node;
133 1
      N       : Node_Id;
134
   begin
135
      --  From
136

137
      N :=
138 1
        Make_Parameter_Specification
139 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_From)),
140 1
           Subtype_Mark        => RE (RE_Entity_Type),
141
           Parameter_Mode      => Mode_In);
142 1
      Append_Node_To_List (N, Profile);
143

144
      --  Entity
145

146
      N :=
147 1
        Make_Parameter_Specification
148 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_Entity)),
149 1
           Subtype_Mark        => RE (RE_Entity_Type),
150
           Parameter_Mode      => Mode_In);
151 1
      Append_Node_To_List (N, Profile);
152

153
      --  Message
154

155
      N :=
156 1
        Make_Parameter_Specification
157 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_Message)),
158 1
           Subtype_Mark        => RE (RE_Message_Type),
159
           Parameter_Mode      => Mode_In);
160 1
      Append_Node_To_List (N, Profile);
161

162
      N :=
163 1
        Make_Parameter_Specification
164 1
          (Defining_Identifier => Make_Defining_Identifier (PN (P_Error)),
165 1
           Subtype_Mark        => RE (RE_Error_Kind),
166
           Parameter_Mode      => Mode_Out);
167 1
      Append_Node_To_List (N, Profile);
168

169
      --  Pre-condition
170 1
      if Add_SPARK2014_Annotations and then With_Aspect then
171 0
         Aspect := Make_Aspect_Specification
172 0
           (Make_List_Id
173 0
              (Make_Aspect
174
                 (ASN (A_Pre),
175 0
                  Make_Pre
176 0
                    (Make_Subprogram_Call
177 0
                       (RE (Re_Not_Empty),
178 0
                        Make_List_Id (Make_Defining_Identifier
179
                                     (PN (P_Message))))))));
180
      end if;
181

182
      N :=
183 1
        Make_Subprogram_Specification
184 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Send)),
185
           Parameter_Profile   => Profile,
186
           Return_Type         => No_Node,
187
           Aspect_Specification => Aspect);
188

189 1
      return N;
190
   end Send_Spec;
191

192
   ------------------
193
   -- Package_Spec --
194
   ------------------
195

196
   package body Package_Spec is
197

198
      procedure Visit_Architecture_Instance (E : Node_Id);
199
      procedure Visit_Component_Instance (E : Node_Id);
200
      procedure Visit_System_Instance (E : Node_Id);
201
      procedure Visit_Process_Instance (E : Node_Id);
202
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
203

204
      -----------
205
      -- Visit --
206
      -----------
207

208 1
      procedure Visit (E : Node_Id) is
209
      begin
210 1
         case Kind (E) is
211 1
            when K_Architecture_Instance =>
212 1
               Visit_Architecture_Instance (E);
213

214 1
            when K_Component_Instance =>
215 1
               Visit_Component_Instance (E);
216

217 0
            when others =>
218 0
               null;
219 1
         end case;
220 1
      end Visit;
221

222
      ---------------------------------
223
      -- Visit_Architecture_Instance --
224
      ---------------------------------
225

226 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
227
      begin
228 1
         Visit (Root_System (E));
229 1
      end Visit_Architecture_Instance;
230

231
      ------------------------------
232
      -- Visit_Component_Instance --
233
      ------------------------------
234

235 1
      procedure Visit_Component_Instance (E : Node_Id) is
236
         Category : constant Component_Category :=
237 1
           Get_Category_Of_Component (E);
238
      begin
239 1
         case Category is
240 1
            when CC_System =>
241 1
               Visit_System_Instance (E);
242

243 1
            when CC_Process =>
244 1
               Visit_Process_Instance (E);
245

246 1
            when others =>
247 1
               null;
248 1
         end case;
249 1
      end Visit_Component_Instance;
250

251
      ----------------------------
252
      -- Visit_Process_Instance --
253
      ----------------------------
254

255 1
      procedure Visit_Process_Instance (E : Node_Id) is
256
         U : constant Node_Id :=
257 1
           ADN.Distributed_Application_Unit
258 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
259 1
         P : constant Node_Id := ADN.Entity (U);
260 1
         N : Node_Id;
261
      begin
262 1
         Push_Entity (P);
263 1
         Push_Entity (U);
264 1
         Set_Transport_Spec;
265

266
         --  Generate a delivery spec
267

268 1
         N := Deliver_Spec (E, With_Aspect => True);
269 1
         Bind_AADL_To_Deliver (Identifier (E), N);
270 1
         Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
271

272
         --  Generate the message sending spec if necessary
273

274 1
         N := Send_Spec (E, With_Aspect => True);
275 1
         Bind_AADL_To_Send (Identifier (E), N);
276 1
         Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
277

278 1
         Pop_Entity; -- U
279 1
         Pop_Entity; -- P
280 1
      end Visit_Process_Instance;
281

282
      ---------------------------
283
      -- Visit_System_Instance --
284
      ---------------------------
285

286 1
      procedure Visit_System_Instance (E : Node_Id) is
287
      begin
288 1
         Push_Entity (Ada_Root);
289

290
         --  Visit all the subcomponents of the system
291

292 1
         Visit_Subcomponents_Of (E);
293

294 1
         Pop_Entity; --  Ada_Root
295 1
      end Visit_System_Instance;
296

297
   end Package_Spec;
298

299
   ------------------
300
   -- Package_Body --
301
   ------------------
302

303
   package body Package_Body is
304

305
      procedure Visit_Architecture_Instance (E : Node_Id);
306
      procedure Visit_Component_Instance (E : Node_Id);
307
      procedure Visit_System_Instance (E : Node_Id);
308
      procedure Visit_Process_Instance (E : Node_Id);
309
      procedure Visit_Thread_Instance (E : Node_Id);
310
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
311

312
      function Internal_Deliver_Spec (E : Node_Id) return Node_Id;
313
      function Internal_Deliver_Body (E : Node_Id) return Node_Id;
314
      --  Create the internal delivery routine corresponding to the
315
      --  thread E.
316

317
      function Internal_Send_Spec (E : Node_Id) return Node_Id;
318
      function Internal_Send_Body (E : Node_Id) return Node_Id;
319
      --  Create the internal sending routine corresponding to the
320
      --  thread E.
321

322
      function Deliver_Body (E : Node_Id) return Node_Id;
323
      --  Create a subprogram implementation corresponding to the
324
      --  message delivery routine.
325

326
      function Send_Body (E : Node_Id) return Node_Id;
327
      --  Create a subprogram implementation corresponding to the
328
      --  message sending routine.
329

330
      ------------------
331
      -- Deliver_Body --
332
      ------------------
333

334 1
      function Deliver_Body (E : Node_Id) return Node_Id is
335 1
         Spec : constant Node_Id := Deliver_Spec (E, With_Aspect => False);
336

337 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
338 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
339 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
340 1
         N            : Node_Id;
341 1
         T            : Node_Id;
342
      begin
343 1
         pragma Assert (AAU.Is_Process (E));
344

345 1
         if not Need_Deliver (E) then
346
            --  Generate a dummy Deliver
347

348
            N :=
349 1
              Make_Pragma_Statement
350
                (Pragma_Unreferenced,
351 1
                 Make_List_Id
352 1
                   (Make_Defining_Identifier (PN (P_Entity)),
353 1
                    Make_Defining_Identifier (PN (P_Message))));
354 1
            Append_Node_To_List (N, Declarations);
355

356 1
            N := Make_Null_Statement;
357 1
            Append_Node_To_List (N, Statements);
358
         else
359
            --  Declarative part
360

361 1
            N := Make_Used_Package (RU (RU_PolyORB_HI_Generated_Deployment));
362 1
            Append_Node_To_List (N, Declarations);
363

364
            N :=
365 1
              Make_Object_Declaration
366 1
                (Defining_Identifier => Make_Defining_Identifier (PN (P_Msg)),
367 1
                 Object_Definition   => RE (RE_Message_Type));
368 1
            Append_Node_To_List (N, Declarations);
369

370
            N :=
371 1
              Make_Object_Declaration
372
                (Defining_Identifier =>
373 1
                   Make_Defining_Identifier (PN (P_Value)),
374 1
                 Object_Definition => RE (RE_Unsigned_16));
375 1
            Append_Node_To_List (N, Declarations);
376

377
            N :=
378 1
              Make_Object_Declaration
379 1
                (Defining_Identifier => Make_Defining_Identifier (PN (P_Port)),
380 1
                 Object_Definition   => RE (RE_Port_Type_1));
381 1
            Append_Node_To_List (N, Declarations);
382

383
            --  Add a use clause for the
384
            --  Ada.Streams.Stream_Element_Offset type to have
385
            --  visibility on its operators.
386

387 1
            N := Make_Used_Type (RE (RE_Stream_Element_Offset));
388 1
            Append_Node_To_List (N, Declarations);
389

390
            --  Statements
391

392
            --  Get the message payload
393

394
            N :=
395 1
              Make_Expression
396 1
                (Make_Attribute_Designator
397 1
                   (Make_Designator (PN (P_Message)),
398
                    A_First),
399
                 Op_Plus,
400 1
                 RE (RE_Header_Size));
401

402
            N :=
403 1
              Make_Range_Constraint
404
                (N,
405 1
                 Make_Attribute_Designator
406 1
                   (Make_Designator (PN (P_Message)),
407
                    A_Last));
408

409
            N :=
410 1
              Make_Subprogram_Call
411 1
                (Make_Designator (PN (P_Message)),
412 1
                 Make_List_Id (N));
413

414
            N :=
415 1
              Make_Subprogram_Call
416 1
                (RE (RE_Write),
417 1
                 Make_List_Id (Make_Defining_Identifier (PN (P_Msg)), N));
418 1
            Append_Node_To_List (N, Statements);
419

420
            --  Unmarshall the destination port
421

422
            N :=
423 1
              Make_Subprogram_Call
424 1
                (RE (RE_Unmarshall_1),
425 1
                 Make_List_Id
426 1
                   (Make_Defining_Identifier (PN (P_Value)),
427 1
                    Make_Defining_Identifier (PN (P_Msg))));
428 1
            Append_Node_To_List (N, Statements);
429

430
            N :=
431 1
              Make_Subprogram_Call
432 1
                (RE (RE_Corresponding_Port),
433 1
                 Make_List_Id (Make_Defining_Identifier (PN (P_Value))));
434
            N :=
435 1
              Make_Assignment_Statement
436 1
                (Variable_Identifier => Make_Defining_Identifier (PN (P_Port)),
437
                 Expression          => N);
438

439 1
            Append_Node_To_List (N, Statements);
440

441
            --  The case statement: for each thread of the current
442
            --  process, we generate a case statement alternative to
443
            --  call its specific delivery routine.
444

445 1
            T := First_Node (Subcomponents (E));
446

447 1
            while Present (T) loop
448 1
               if AAU.Is_Thread (Corresponding_Instance (T))
449 1
                 and then Has_In_Ports (Corresponding_Instance (T))
450
               then
451
                  --  Generate the spec of the internal delivery
452
                  --  routine of thread T. It is important to do this
453
                  --  before adding the global delivery body to the
454
                  --  package statemnets because it uses the internal
455
                  --  delivery routines.
456

457 1
                  N := Internal_Deliver_Spec (Corresponding_Instance (T));
458 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
459

460
                  --  Call the internal delivery routine of the thread
461

462
                  N :=
463 1
                    Make_Subprogram_Call
464 1
                      (Make_Defining_Identifier
465 1
                         (Map_Deliver_Name (Corresponding_Instance (T))),
466 1
                       Make_List_Id
467 1
                         (Make_Defining_Identifier (PN (P_Port)),
468 1
                          Make_Subprogram_Call
469 1
                            (RE (RE_Sender),
470 1
                             Make_List_Id (Make_Designator (PN (P_Message)))),
471 1
                          Make_Defining_Identifier (PN (P_Msg))));
472

473
                  --  The case statement alternative
474

475
                  N :=
476 1
                    Make_Elsif_Statement
477 1
                      (Make_Expression
478 1
                         (Make_Defining_Identifier (PN (P_Entity)),
479
                          Op_Equal,
480 1
                          Extract_Enumerator (Corresponding_Instance (T))),
481 1
                       Make_List_Id (N));
482 1
                  Append_Node_To_List (N, Alternatives);
483
               end if;
484

485 1
               T := Next_Node (T);
486 1
            end loop;
487

488
            declare
489 1
               Elsif_Statements : constant List_Id := New_List (ADN.K_List_Id);
490

491
            begin
492 1
               ADN.Set_First_Node
493
                 (Elsif_Statements,
494 1
                  ADN.Next_Node (ADN.First_Node (Alternatives)));
495

496
               N :=
497 1
                 Make_If_Statement
498 1
                   (Condition => ADN.Condition (ADN.First_Node (Alternatives)),
499
                    Then_Statements =>
500 1
                      ADN.Then_Statements (ADN.First_Node (Alternatives)),
501
                    Elsif_Statements => Elsif_Statements);
502

503 1
               Append_Node_To_List (N, Statements);
504
            end;
505
         end if;
506

507 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
508 1
         return N;
509
      end Deliver_Body;
510

511
      ---------------
512
      -- Send_Body --
513
      ---------------
514

515 1
      function Send_Body (E : Node_Id) return Node_Id is
516 1
         Spec : constant Node_Id := Send_Spec (E, With_Aspect => False);
517

518 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
519 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
520 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
521 1
         N            : Node_Id;
522 1
         T            : Node_Id;
523 1
         Msg_T : Node_Id;
524

525
      begin
526 1
         pragma Assert (AAU.Is_Process (E));
527

528 1
         if not Need_Send (E) then
529
            --  Generate a dummy Send
530

531
            N :=
532 1
              Make_Pragma_Statement
533
                (Pragma_Unreferenced,
534 1
                 Make_List_Id
535 1
                   (Make_Defining_Identifier (PN (P_From)),
536 1
                    Make_Defining_Identifier (PN (P_Entity)),
537 1
                    Make_Defining_Identifier (PN (P_Message))));
538 1
            Append_Node_To_List (N, Declarations);
539

540
            N :=
541 1
              Make_Qualified_Expression
542 1
                (RE (RE_Error_Kind),
543 1
                 Make_Record_Aggregate
544 1
                   (Make_List_Id (RE (RE_Error_Transport))));
545 1
            N := Make_Assignment_Statement
546 1
               (Make_Defining_Identifier (PN (P_Error)), N);
547 1
            Append_Node_To_List (N, Statements);
548

549
         else
550
            --  Declarative part
551

552 1
            N := Make_Used_Package (RU (RU_PolyORB_HI_Generated_Deployment));
553 1
            Append_Node_To_List (N, Declarations);
554

555
            N :=
556 1
              Make_Range_Constraint
557 1
                (Make_Literal (New_Integer_Value (1, 1, 10)),
558 1
                 Make_Subprogram_Call
559 1
                   (RE (RE_Size),
560 1
                   Make_List_Id (Make_Defining_Identifier (PN (P_Message)))));
561

562
            Msg_T :=
563 1
              Make_Subprogram_Call
564 1
                (RE (RE_Stream_Element_Array),
565 1
                 Make_List_Id (N));
566

567
            N :=
568 1
              Make_Object_Declaration
569 1
                (Defining_Identifier => Make_Defining_Identifier (PN (P_Msg)),
570
                 Constant_Present    => False,
571
                 Object_Definition   => Msg_T);
572 1
            Append_Node_To_List (N, Declarations);
573

574
            --  Statements
575

576
            --  Call Encapsulate
577

578 1
            N := Make_Subprogram_Call
579 1
              (RE (RE_Encapsulate),
580 1
               Make_List_Id
581 1
                 (Make_Defining_Identifier (PN (P_Message)),
582 1
                  Make_Defining_Identifier (PN (P_From)),
583 1
                  Make_Defining_Identifier (PN (P_Entity)),
584 1
                  Make_Defining_Identifier (PN (P_Msg))));
585 1
            Append_Node_To_List (N, Statements);
586

587
            --  The if/elsif statement: for each thread of the current
588
            --  process, we generate a case statement alternative to
589
            --  call its specific sending routine.
590

591 1
            T := First_Node (Subcomponents (E));
592

593 1
            while Present (T) loop
594 1
               if AAU.Is_Thread (Corresponding_Instance (T))
595 1
                 and then Has_Out_Ports (Corresponding_Instance (T))
596
               then
597
                  --  Generate the spec of the internal sending
598
                  --  routine of thread T. It is important to do this
599
                  --  before adding the global sending body to the
600
                  --  package statemnets because it uses the internal
601
                  --  sending routines.
602

603 1
                  N := Internal_Send_Spec (Corresponding_Instance (T));
604 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
605

606
                  --  Call the internal sending routine of the thread
607

608
                  N :=
609 1
                    Make_Subprogram_Call
610 1
                      (Make_Defining_Identifier
611 1
                         (Map_Send_Name (Corresponding_Instance (T))),
612 1
                       Make_List_Id
613 1
                         (Make_Defining_Identifier (PN (P_Entity)),
614 1
                          Make_Defining_Identifier (PN (P_Msg)),
615 1
                          Make_Defining_Identifier (PN (P_Error))));
616

617
                  --  The case statement alternative
618

619
                  N :=
620 1
                    Make_Elsif_Statement
621 1
                      (Make_Expression
622 1
                         (Make_Defining_Identifier (PN (P_From)),
623
                          Op_Equal,
624 1
                          Extract_Enumerator (Corresponding_Instance (T))),
625 1
                       Make_List_Id (N));
626 1
                  Append_Node_To_List (N, Alternatives);
627
               end if;
628

629 1
               T := Next_Node (T);
630 1
            end loop;
631

632
            declare
633 1
               Elsif_Statements : constant List_Id := New_List (ADN.K_List_Id);
634 1
               Else_Statements  : constant List_Id := New_List (ADN.K_List_Id);
635

636
            begin
637 1
               if Present (ADN.First_Node (Alternatives)) then
638
                  N :=
639 1
                    Make_Qualified_Expression
640 1
                      (RE (RE_Error_Kind),
641 1
                       Make_Record_Aggregate
642 1
                         (Make_List_Id (RE (RE_Error_Transport))));
643 1
                  N := Make_Assignment_Statement
644 1
                  (Make_Defining_Identifier (PN (P_Error)), N);
645

646 1
                  Append_Node_To_List (N, Else_Statements);
647

648 1
                  ADN.Set_First_Node
649
                    (Elsif_Statements,
650 1
                     ADN.Next_Node (ADN.First_Node (Alternatives)));
651

652
                  N :=
653 1
                    Make_If_Statement
654
                      (Condition =>
655 1
                         ADN.Condition (ADN.First_Node (Alternatives)),
656
                       Then_Statements =>
657 1
                         ADN.Then_Statements (ADN.First_Node (Alternatives)),
658
                       Elsif_Statements => Elsif_Statements,
659
                       Else_Statements  => Else_Statements);
660

661 1
                  Append_Node_To_List (N, Statements);
662
               else
663
                  N :=
664 0
                    Make_Qualified_Expression
665 0
                      (RE (RE_Error_Kind),
666 0
                       Make_Record_Aggregate
667 0
                         (Make_List_Id (RE (RE_Error_Transport))));
668 0
                  N := Make_Assignment_Statement
669 0
                  (Make_Defining_Identifier (PN (P_Error)), N);
670 0
                  Append_Node_To_List (N, Statements);
671
               end if;
672
            end;
673
         end if;
674

675 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
676 1
         return N;
677
      end Send_Body;
678

679
      ---------------------------
680
      -- Internal_Deliver_Spec --
681
      ---------------------------
682

683 1
      function Internal_Deliver_Spec (E : Node_Id) return Node_Id is
684 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
685 1
         N       : Node_Id;
686
      begin
687
         --  The Port parameter
688

689
         N :=
690 1
           Make_Parameter_Specification
691 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Port)),
692 1
              Subtype_Mark        => RE (RE_Port_Type_1),
693
              Parameter_Mode      => Mode_In);
694 1
         Append_Node_To_List (N, Profile);
695

696
         --  The Sender parameter
697

698
         N :=
699 1
           Make_Parameter_Specification
700 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_From)),
701 1
              Subtype_Mark        => RE (RE_Entity_Type),
702
              Parameter_Mode      => Mode_In);
703 1
         Append_Node_To_List (N, Profile);
704

705
         --  The Msg parameter
706

707
         N :=
708 1
           Make_Parameter_Specification
709 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Msg)),
710 1
              Subtype_Mark        => RE (RE_Message_Type),
711
              Parameter_Mode      => Mode_Inout);
712 1
         Append_Node_To_List (N, Profile);
713

714
         --  The subprogram spec
715

716
         N :=
717 1
           Make_Subprogram_Specification
718
             (Defining_Identifier =>
719 1
                Make_Defining_Identifier (Map_Deliver_Name (E)),
720
              Parameter_Profile => Profile,
721
              Return_Type       => No_Node);
722 1
         return N;
723
      end Internal_Deliver_Spec;
724

725
      ---------------------------
726
      -- Internal_Deliver_Body --
727
      ---------------------------
728

729 1
      function Internal_Deliver_Body (E : Node_Id) return Node_Id is
730 1
         Spec         : constant Node_Id := Internal_Deliver_Spec (E);
731 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
732 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
733 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
734 1
         N            : Node_Id;
735 1
         F            : Node_Id;
736

737 1
         Time_Stamp_Declared : Boolean := False;
738
      begin
739 1
         if not AAU.Is_Empty (Features (E)) and then Has_In_Ports (E) then
740
            --  Add a 'use' clause to the Activity package
741

742 1
            Add_With_Package
743 1
              (RU (RU_PolyORB_HI_Generated_Activity, False),
744
               Used => True);
745

746
            --  Declare a local variable of type the thread interface
747

748 1
            N := Make_Used_Package (RU (RU_PolyORB_HI_Generated_Deployment));
749 1
            Append_Node_To_List (N, Declarations);
750

751
            N :=
752 1
              Make_Object_Declaration
753
                (Defining_Identifier =>
754 1
                   Make_Defining_Identifier (VN (V_Thread_Interface)),
755
                 Object_Definition =>
756 1
                   Make_Defining_Identifier (Map_Port_Interface_Name (E)));
757 1
            Append_Node_To_List (N, Declarations);
758

759
            --  For each port of the thread, create a switch case
760
            --  alternative to store the message to the proper
761
            --  destination.
762

763 1
            F := First_Node (Features (E));
764

765 1
            while Present (F) loop
766 1
               if Kind (F) = K_Port_Spec_Instance and then Is_In (F) then
767
                  declare
768 1
                     St : constant List_Id := New_List (ADN.K_Statement_List);
769
                     Call_Profile : constant List_Id :=
770 1
                       New_List (ADN.K_List_Id);
771
                  begin
772
                     --  In case of a data port, unmarshalls the time
773
                     --  stamp.
774

775 1
                     if not Is_Event (F) then
776
                        --  Declare the time stamp local variable if
777
                        --  it has not been done yet.
778

779 1
                        if not Time_Stamp_Declared then
780
                           N :=
781 1
                             Make_Object_Declaration
782
                               (Defining_Identifier =>
783 1
                                  Make_Defining_Identifier (VN (V_Time_Stamp)),
784 1
                                Object_Definition => RE (RE_Time));
785 1
                           Append_Node_To_List (N, Declarations);
786

787 1
                           Time_Stamp_Declared := True;
788
                        end if;
789

790
                        N :=
791 1
                          Make_Subprogram_Call
792 1
                            (RE (RE_Unmarshall_2),
793 1
                             Make_List_Id
794 1
                               (Make_Defining_Identifier (VN (V_Time_Stamp)),
795 1
                                Make_Defining_Identifier (PN (P_Msg))));
796 1
                        Append_Node_To_List (N, St);
797
                     end if;
798

799
                     --  Unmarshall the received message
800

801
                     N :=
802 1
                       Make_Subprogram_Call
803 1
                         (Extract_Designator
804 1
                            (ADN.Unmarshall_Node
805 1
                               (Backend_Node (Identifier (E)))),
806 1
                          Make_List_Id
807 1
                            (Map_Ada_Defining_Identifier (F),
808 1
                             Make_Defining_Identifier
809
                               (VN (V_Thread_Interface)),
810 1
                             Make_Defining_Identifier (PN (P_Msg))));
811 1
                     Append_Node_To_List (N, St);
812

813
                     --  Store the received message
814

815
                     N :=
816 1
                       Extract_Designator
817 1
                         (ADN.Store_Received_Message_Node
818 1
                            (Backend_Node (Identifier (E))));
819

820 1
                     Append_Node_To_List
821 1
                       (Extract_Enumerator (E),
822
                        Call_Profile);
823

824 1
                     Append_Node_To_List
825 1
                       (Make_Defining_Identifier (VN (V_Thread_Interface)),
826
                        Call_Profile);
827

828 1
                     Append_Node_To_List
829 1
                       (Make_Defining_Identifier (PN (P_From)),
830
                        Call_Profile);
831

832 1
                     if not Is_Event (F) then
833 1
                        Append_Node_To_List
834 1
                          (Make_Defining_Identifier (VN (V_Time_Stamp)),
835
                           Call_Profile);
836
                     end if;
837

838 1
                     N := Make_Subprogram_Call (N, Call_Profile);
839 1
                     Append_Node_To_List (N, St);
840

841
                     --  Create the case statement alternative
842

843
                     N :=
844 1
                       Make_Elsif_Statement
845 1
                         (Make_Expression
846 1
                            (Make_Defining_Identifier (PN (P_Port)),
847
                             Op_Equal,
848 1
                             Extract_Enumerator (F)),
849
                          St);
850 1
                     Append_Node_To_List (N, Alternatives);
851
                  end;
852
               end if;
853

854 1
               F := Next_Node (F);
855 1
            end loop;
856

857
            declare
858 1
               Elsif_Statements : constant List_Id := New_List (ADN.K_List_Id);
859

860
            begin
861 1
               ADN.Set_First_Node
862
                 (Elsif_Statements,
863 1
                  ADN.Next_Node (ADN.First_Node (Alternatives)));
864

865
               N :=
866 1
                 Make_If_Statement
867 1
                   (Condition => ADN.Condition (ADN.First_Node (Alternatives)),
868
                    Then_Statements =>
869 1
                      ADN.Then_Statements (ADN.First_Node (Alternatives)),
870
                    Elsif_Statements => Elsif_Statements);
871

872 1
               Append_Node_To_List (N, Statements);
873
            end;
874
         end if;
875

876 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
877 1
         return N;
878
      end Internal_Deliver_Body;
879

880
      ------------------------
881
      -- Internal_Send_Spec --
882
      ------------------------
883

884 1
      function Internal_Send_Spec (E : Node_Id) return Node_Id is
885 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
886 1
         N       : Node_Id;
887
      begin
888
         --  Entity
889

890
         N :=
891 1
           Make_Parameter_Specification
892 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Entity)),
893 1
              Subtype_Mark        => RE (RE_Entity_Type),
894
              Parameter_Mode      => Mode_In);
895 1
         Append_Node_To_List (N, Profile);
896

897
         --  Message
898

899
         N :=
900 1
           Make_Parameter_Specification
901 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Message)),
902 1
              Subtype_Mark        => RE (RE_Stream_Element_Array),
903
              Parameter_Mode      => Mode_In);
904 1
         Append_Node_To_List (N, Profile);
905

906
         N :=
907 1
          Make_Parameter_Specification
908 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Error)),
909 1
              Subtype_Mark        => RE (RE_Error_Kind),
910
              Parameter_Mode      => Mode_Out);
911 1
         Append_Node_To_List (N, Profile);
912

913
         --  The subprogram spec
914

915
         N :=
916 1
           Make_Subprogram_Specification
917
             (Defining_Identifier =>
918 1
                Make_Defining_Identifier (Map_Send_Name (E)),
919
              Parameter_Profile => Profile,
920
              Return_Type       => No_Node);
921

922 1
         return N;
923
      end Internal_Send_Spec;
924

925
      ------------------------
926
      -- Internal_Send_Body --
927
      ------------------------
928

929 1
      function Internal_Send_Body (E : Node_Id) return Node_Id is
930
         Handled_Thread : constant String := "%HandledFor%";
931

932
         function Is_Handled (T : Node_Id) return Boolean;
933
         procedure Set_Handled (T : Node_Id);
934
         --  Used to avoid duplicating case statement alternatives
935

936
         ----------------
937
         -- Is_Handled --
938
         ----------------
939

940 1
         function Is_Handled (T : Node_Id) return Boolean is
941
            I_Name : constant Name_Id :=
942 1
              Get_String_Name
943 1
                (Node_Id'Image (T) & Handled_Thread & Node_Id'Image (E));
944
         begin
945 1
            return Get_Name_Table_Byte (I_Name) = 1;
946 1
         end Is_Handled;
947

948
         -----------------
949
         -- Set_Handled --
950
         -----------------
951

952 1
         procedure Set_Handled (T : Node_Id) is
953
            I_Name : constant Name_Id :=
954 1
              Get_String_Name
955 1
                (Node_Id'Image (T) & Handled_Thread & Node_Id'Image (E));
956
         begin
957 1
            Set_Name_Table_Byte (I_Name, 1);
958 1
         end Set_Handled;
959

960 1
         Spec         : constant Node_Id := Internal_Send_Spec (E);
961 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
962 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
963 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
964 1
         N            : Node_Id;
965 1
         F            : Node_Id;
966
      begin
967 1
         if not AAU.Is_Empty (Features (E)) and then Has_Out_Ports (E) then
968
            --  We loop through all the OUT ports of the thread, then
969
            --  through all their destinations and create a switch
970
            --  case alternative for each thread that may be a
971
            --  destination of E to send the message using the proper
972
            --  transport layer.
973

974
            N :=
975 1
              Make_Pragma_Statement
976
                (Pragma_Warnings,
977 1
                 Make_List_Id
978 1
                   (RE (RE_Off),
979 1
                    Make_Defining_Identifier (PN (P_Message))));
980 1
            Append_Node_To_List (N, Declarations);
981
            N :=
982 1
              Make_Pragma_Statement
983
                (Pragma_Warnings,
984 1
                 Make_List_Id
985 1
                   (RE (RE_Off),
986 1
                    Make_Defining_Identifier (PN (P_Entity))));
987 1
            Append_Node_To_List (N, Declarations);
988

989 1
            F := First_Node (Features (E));
990

991 1
            while Present (F) loop
992 1
               if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
993
                  declare
994 1
                     Dest_List : constant List_Id := Get_Destination_Ports (F);
995 1
                     Dest_Th   : Node_Id;
996 1
                     Dest      : Node_Id;
997 1
                     B, K      : Node_Id;
998 1
                     Device    : Node_Id;
999
                  begin
1000 1
                     if not AAU.Is_Empty (Dest_List) then
1001 1
                        Dest := First_Node (Dest_List);
1002

1003 1
                        while Present (Dest) loop
1004
                           --  Get the thread that contains Dest
1005

1006 1
                           Dest_Th := Parent_Component (Item (Dest));
1007

1008
                           --  If Dest_Th has not been handled in the
1009
                           --  context of E yet, then create a case
1010
                           --  statement alternative corresponding to
1011
                           --  Dest_Th and mark it as handled.
1012

1013 1
                           if AAU.Is_Thread (Dest_Th)
1014 1
                             and then not Is_Handled (Dest_Th)
1015
                           then
1016
                              --  Get the bus that connects the two ports
1017

1018 1
                              B := Extra_Item (Dest);
1019

1020 1
                              Device := Get_Device_Of_Process (B, E);
1021

1022 1
                              if No (B) then
1023
                                 --  There is no bus involved in the
1024
                                 --  connection, therefore it is a
1025
                                 --  local communication: use the
1026
                                 --  deliver routine.
1027

1028
                                 K :=
1029 1
                                   Make_Subprogram_Call
1030 1
                                     (Make_Defining_Identifier
1031
                                        (SN (S_Deliver)),
1032 1
                                      Make_List_Id
1033 1
                                        (Make_Defining_Identifier
1034
                                           (PN (P_Entity)),
1035 1
                                         Make_Defining_Identifier
1036
                                           (PN (P_Message))));
1037

1038
                                 --  Local delivery implies no
1039
                                 --  potential error, we return
1040
                                 --  Error_None.
1041

1042
                                 N :=
1043 1
                                   Make_Qualified_Expression
1044 1
                                     (RE (RE_Error_Kind),
1045 1
                                      Make_Record_Aggregate
1046 1
                                        (Make_List_Id (RE (RE_Error_None))));
1047

1048 1
                                 N := Make_Assignment_Statement
1049 1
                                    (Make_Defining_Identifier (PN (P_Error)),
1050
                                    N);
1051

1052
                                 --  Create the case statement alternative
1053

1054
                                 N :=
1055 1
                                   Make_Elsif_Statement
1056 1
                                     (Make_Expression
1057 1
                                        (Make_Defining_Identifier
1058
                                           (PN (P_Entity)),
1059
                                         Op_Equal,
1060 1
                                         Extract_Enumerator (Dest_Th)),
1061 1
                                      Make_List_Id (K, N));
1062 1
                                 Append_Node_To_List (N, Alternatives);
1063

1064 1
                              elsif Device /= No_Node
1065 1
                                and then AAU.Is_Device
1066 1
                                  (Corresponding_Instance (Device))
1067
                              then
1068 1
                                 K :=
1069 1
                                   Message_Comment
1070
                                     ("User-provided transport mechanism, " &
1071 1
                                      "device " &
1072 1
                                      Get_Name_String
1073 1
                                        (Name (Identifier (Device))));
1074

1075
                                 declare
1076
                                    Profile : constant List_Id :=
1077 1
                                      New_List (ADN.K_Parameter_Profile);
1078 1
                                    A : Node_Id;
1079
                                 begin
1080
                                    --  Entity
1081

1082
                                    A :=
1083 1
                                      Make_Parameter_Specification
1084 1
                                        (Make_Defining_Identifier
1085
                                           (PN (P_Node)),
1086 1
                                         RE (RE_Node_Type),
1087
                                         Mode_In);
1088 1
                                    Append_Node_To_List (A, Profile);
1089

1090
                                    --  Message
1091

1092
                                    A :=
1093 1
                                      Make_Parameter_Specification
1094 1
                                        (Make_Defining_Identifier
1095
                                           (PN (P_Message)),
1096 1
                                         RE (RE_Stream_Element_Array),
1097
                                         Mode_In);
1098 1
                                    Append_Node_To_List (A, Profile);
1099

1100
                                    A :=
1101 1
                                      Make_Parameter_Specification
1102 1
                                        (Make_Defining_Identifier
1103
                                           (PN (P_Size)),
1104 1
                                         RE (RE_Stream_Element_Offset),
1105
                                         Mode_In);
1106 1
                                    Append_Node_To_List (A, Profile);
1107
                                 end;
1108

1109
                                 N :=
1110 1
                                   Make_Designator
1111 1
                                     (Unit_Name
1112 1
                                        (Get_Send_Function_Name
1113 1
                                           (Corresponding_Instance (Device))));
1114 1
                                 Add_With_Package (N);
1115

1116
                                 N :=
1117 1
                                   Make_Designator
1118 1
                                     (Local_Name
1119 1
                                        (Get_Send_Function_Name
1120 1
                                           (Corresponding_Instance (Device))),
1121 1
                                      Unit_Name
1122 1
                                        (Get_Send_Function_Name
1123 1
                                           (Corresponding_Instance (Device))));
1124

1125
                                 N :=
1126 1
                                   Make_Subprogram_Call
1127 1
                                     (ADN.Defining_Identifier (N),
1128 1
                                      Make_List_Id
1129 1
                                        (Make_Indexed_Component
1130 1
                                           (RE (RE_Entity_Table),
1131 1
                                            Make_List_Id
1132 1
                                              (Make_Defining_Identifier
1133
                                                 (PN (P_Entity)))),
1134 1
                                         Make_Defining_Identifier
1135
                                           (PN (P_Message)),
1136 1
                                         Make_Attribute_Designator
1137
                                           (Prefix =>
1138 1
                                              Make_Defining_Identifier
1139
                                                (PN (P_Message)),
1140
                                            Attribute => A_Length)));
1141 1
                                 N := Make_Assignment_Statement
1142 1
                                    (Make_Defining_Identifier (PN (P_Error)),
1143
                                    N);
1144

1145
                                 --  Create the case statement alternative
1146

1147
                                 N :=
1148 1
                                   Make_Elsif_Statement
1149 1
                                     (Make_Expression
1150 1
                                        (Make_Defining_Identifier
1151
                                           (PN (P_Entity)),
1152
                                         Op_Equal,
1153 1
                                         Extract_Enumerator (Dest_Th)),
1154 1
                                      Make_List_Id (K, N));
1155 1
                                 Append_Node_To_List (N, Alternatives);
1156

1157
                              else
1158
                                 --  If the user did not specify any
1159
                                 --  specific device drivers in the
1160
                                 --  AADL model, use default transport
1161
                                 --  mechanism provided by the
1162
                                 --  runtime.
1163

1164
                                 pragma Assert
1165 0
                                   (Get_Transport_API (B) /= Transport_None);
1166

1167
                                 K :=
1168 0
                                   Message_Comment
1169
                                     ("Default transport mechanism");
1170

1171
                                 N :=
1172 0
                                   Make_Subprogram_Call
1173 0
                                     (RE (RE_Send_3),
1174 0
                                      Make_List_Id
1175 0
                                        (Make_Indexed_Component
1176 0
                                           (RE (RE_Entity_Table),
1177 0
                                            Make_List_Id
1178 0
                                              (Make_Defining_Identifier
1179
                                                 (PN (P_Entity)))),
1180 0
                                         Make_Defining_Identifier
1181
                                           (PN (P_Message))));
1182

1183 0
                                 N := Make_Return_Statement (N);
1184

1185
                                 --  Create the case statement alternative
1186

1187
                                 N :=
1188 0
                                   Make_Elsif_Statement
1189 0
                                     (Make_Expression
1190 0
                                        (Make_Defining_Identifier
1191
                                           (PN (P_Entity)),
1192
                                         Op_Equal,
1193 0
                                         Extract_Enumerator (Dest_Th)),
1194 0
                                      Make_List_Id (K, N));
1195 0
                                 Append_Node_To_List (N, Alternatives);
1196
                              end if;
1197

1198 1
                              Set_Handled (Dest_Th);
1199

1200 1
                           elsif AAU.Is_Device (Dest_Th)
1201 1
                             and then not Is_Handled (Dest_Th)
1202
                           then
1203

1204 1
                              N := Message_Comment ("Device");
1205 1
                              Append_Node_To_List (N, Statements);
1206

1207 1
                              Set_Handled (Dest_Th);
1208

1209 1
                           elsif not Is_Handled (Dest_Th) then
1210 0
                              raise Program_Error;
1211
                           end if;
1212

1213 1
                           Dest := Next_Node (Dest);
1214 1
                        end loop;
1215
                     end if;
1216
                  end;
1217
               end if;
1218

1219 1
               F := Next_Node (F);
1220 1
            end loop;
1221

1222
            --  Raise an error if other ports are targeted.
1223

1224 1
            if Length (Alternatives) /= 0 then
1225
               N :=
1226 1
                 Make_Used_Package (RU (RU_PolyORB_HI_Generated_Deployment));
1227 1
               Append_Node_To_List (N, Declarations);
1228

1229
               declare
1230
                  Elsif_Statements : constant List_Id :=
1231 1
                    New_List (ADN.K_List_Id);
1232
                  Else_Statements : constant List_Id :=
1233 1
                    New_List (ADN.K_List_Id);
1234

1235
               begin
1236
                  N :=
1237 1
                    Make_Qualified_Expression
1238 1
                      (RE (RE_Error_Kind),
1239 1
                       Make_Record_Aggregate
1240 1
                         (Make_List_Id (RE (RE_Error_Transport))));
1241 1
                  N := Make_Assignment_Statement
1242 1
                  (Make_Defining_Identifier (PN (P_Error)), N);
1243 1
                  Append_Node_To_List (N, Else_Statements);
1244

1245 1
                  ADN.Set_First_Node
1246
                    (Elsif_Statements,
1247 1
                     ADN.Next_Node (ADN.First_Node (Alternatives)));
1248

1249
                  N :=
1250 1
                    Make_If_Statement
1251
                      (Condition =>
1252 1
                         ADN.Condition (ADN.First_Node (Alternatives)),
1253
                       Then_Statements =>
1254 1
                         ADN.Then_Statements (ADN.First_Node (Alternatives)),
1255
                       Elsif_Statements => Elsif_Statements,
1256
                       Else_Statements  => Else_Statements);
1257

1258 1
                  Append_Node_To_List (N, Statements);
1259
               end;
1260

1261
            else
1262
               N :=
1263 1
                 Make_Qualified_Expression
1264 1
                   (RE (RE_Error_Kind),
1265 1
                    Make_Record_Aggregate
1266 1
                      (Make_List_Id (RE (RE_Error_Transport))));
1267 1
               N := Make_Assignment_Statement
1268 1
               (Make_Defining_Identifier (PN (P_Error)), N);
1269 1
               Append_Node_To_List (N, Statements);
1270
            end if;
1271
         end if;
1272

1273 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
1274 1
         return N;
1275
      end Internal_Send_Body;
1276

1277
      -----------
1278
      -- Visit --
1279
      -----------
1280

1281 1
      procedure Visit (E : Node_Id) is
1282
      begin
1283 1
         case Kind (E) is
1284 1
            when K_Architecture_Instance =>
1285 1
               Visit_Architecture_Instance (E);
1286

1287 1
            when K_Component_Instance =>
1288 1
               Visit_Component_Instance (E);
1289

1290 0
            when others =>
1291 0
               null;
1292 1
         end case;
1293 1
      end Visit;
1294

1295
      ---------------------------------
1296
      -- Visit_Architecture_Instance --
1297
      ---------------------------------
1298

1299 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
1300
      begin
1301 1
         Visit (Root_System (E));
1302 1
      end Visit_Architecture_Instance;
1303

1304
      ------------------------------
1305
      -- Visit_Component_Instance --
1306
      ------------------------------
1307

1308 1
      procedure Visit_Component_Instance (E : Node_Id) is
1309
         Category : constant Component_Category :=
1310 1
           Get_Category_Of_Component (E);
1311
      begin
1312 1
         case Category is
1313 1
            when CC_System =>
1314 1
               Visit_System_Instance (E);
1315

1316 1
            when CC_Process =>
1317 1
               Visit_Process_Instance (E);
1318

1319 1
            when CC_Thread =>
1320 1
               Visit_Thread_Instance (E);
1321

1322 1
            when others =>
1323 1
               null;
1324 1
         end case;
1325 1
      end Visit_Component_Instance;
1326

1327
      ----------------------------
1328
      -- Visit_Process_Instance --
1329
      ----------------------------
1330

1331 1
      procedure Visit_Process_Instance (E : Node_Id) is
1332
         U : constant Node_Id :=
1333 1
           ADN.Distributed_Application_Unit
1334 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
1335 1
         P : constant Node_Id := ADN.Entity (U);
1336 1
         N : Node_Id;
1337
      begin
1338 1
         Push_Entity (P);
1339 1
         Push_Entity (U);
1340 1
         Set_Transport_Body;
1341

1342
         --  Generate a delivery body
1343

1344 1
         N := Deliver_Body (E);
1345 1
         Append_Node_To_List (N, ADN.Statements (Current_Package));
1346

1347
         --  Generate a sending body if necessary
1348

1349 1
         N := Send_Body (E);
1350 1
         Append_Node_To_List (N, ADN.Statements (Current_Package));
1351

1352
         --  Visit all the subcomponents of the process
1353

1354 1
         Visit_Subcomponents_Of (E);
1355

1356 1
         Pop_Entity; -- U
1357 1
         Pop_Entity; -- P
1358 1
      end Visit_Process_Instance;
1359

1360
      ---------------------------
1361
      -- Visit_System_Instance --
1362
      ---------------------------
1363

1364 1
      procedure Visit_System_Instance (E : Node_Id) is
1365
      begin
1366 1
         Push_Entity (Ada_Root);
1367

1368
         --  Visit all the subcomponents of the system
1369

1370 1
         Visit_Subcomponents_Of (E);
1371

1372 1
         Pop_Entity; --  Ada_Root
1373 1
      end Visit_System_Instance;
1374

1375
      ---------------------------
1376
      -- Visit_Thread_Instance --
1377
      ---------------------------
1378

1379 1
      procedure Visit_Thread_Instance (E : Node_Id) is
1380 1
         N : Node_Id;
1381
      begin
1382 1
         if Has_In_Ports (E) then
1383
            --  Generate the body of the internal delivery routine
1384

1385 1
            N := Internal_Deliver_Body (E);
1386 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1387
         end if;
1388

1389 1
         if Has_Out_Ports (E) then
1390
            --  Generate the body of the internal sending routine
1391

1392 1
            N := Internal_Send_Body (E);
1393 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1394
         end if;
1395 1
      end Visit_Thread_Instance;
1396

1397
   end Package_Body;
1398

1399
end Ocarina.Backends.PO_HI_Ada.Transport;

Read our documentation on viewing source code .

Loading