OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--                 OCARINA.BACKENDS.PO_HI_ADA.MARSHALLERS                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2006-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

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

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

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

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

65
   function Get_Marshalled_Type (E : Node_Id) return Node_Id;
66
   --  Return depending on the category of component E, the type that
67
   --  should be used in procedure Marshall and Unmarshall.
68

69
   -------------------------
70
   -- Get_Marshalled_Type --
71
   -------------------------
72

73 1
   function Get_Marshalled_Type (E : Node_Id) return Node_Id is
74 1
      Category : constant Component_Category := Get_Category_Of_Component (E);
75 1
      T        : Node_Id;
76
   begin
77 1
      case Category is
78 1
         when CC_Thread =>
79
            T :=
80 1
              Extract_Designator
81 1
                (ADN.Port_Interface_Node (Backend_Node (Identifier (E))));
82

83 1
         when CC_Data =>
84
            T :=
85 1
              Extract_Designator
86 1
                (ADN.Type_Definition_Node (Backend_Node (Identifier (E))));
87

88 0
         when others =>
89 0
            raise Program_Error
90
              with "Cannot generate Marshall procedure" &
91 0
              " for a " &
92 0
              Component_Category'Image (Category);
93 1
      end case;
94

95 1
      return T;
96
   end Get_Marshalled_Type;
97

98
   ------------------
99
   -- Package_Spec --
100
   ------------------
101

102
   package body Package_Spec is
103

104
      procedure Visit_Architecture_Instance (E : Node_Id);
105
      procedure Visit_Component_Instance (E : Node_Id);
106
      procedure Visit_System_Instance (E : Node_Id);
107
      procedure Visit_Process_Instance (E : Node_Id);
108
      procedure Visit_Thread_Instance (E : Node_Id);
109
      procedure Visit_Subprogram_Instance (E : Node_Id);
110
      procedure Visit_Data_Instance (E : Node_Id);
111
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
112

113
      function Marshall_Spec (E : Node_Id) return Node_Id;
114
      --  Creates a spec for a Marshall procedure for a data type
115
      --  generated from an AADL data component, a Thread_Port type
116
      --  generated from an AADL thread component or a Port_Type type
117
      --  generated from an AADL process component.
118

119
      function Unmarshall_Spec (E : Node_Id) return Node_Id;
120
      --  Same as above but with an Unmarshall procedure
121

122
      -------------------
123
      -- Marshall_Spec --
124
      -------------------
125

126 1
      function Marshall_Spec (E : Node_Id) return Node_Id is
127 1
         N       : Node_Id;
128 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
129
      begin
130
         --  The 'Data' parameter
131

132
         N :=
133 1
           Make_Parameter_Specification
134 1
             (Make_Defining_Identifier (PN (P_Data)),
135 1
              Get_Marshalled_Type (E),
136
              Mode_In);
137 1
         Append_Node_To_List (N, Profile);
138

139
         --  The 'Message' parameter
140

141
         N :=
142 1
           Make_Parameter_Specification
143 1
             (Make_Defining_Identifier (PN (P_Message)),
144 1
              RE (RE_Message_Type),
145
              Mode_Inout);
146 1
         Append_Node_To_List (N, Profile);
147

148
         N :=
149 1
           Make_Subprogram_Specification
150 1
             (Make_Defining_Identifier (SN (S_Marshall)),
151
              Profile);
152

153 1
         return N;
154
      end Marshall_Spec;
155

156
      ---------------------
157
      -- Unmarshall_Spec --
158
      ---------------------
159

160 1
      function Unmarshall_Spec (E : Node_Id) return Node_Id is
161
         Category : constant Component_Category :=
162 1
           Get_Category_Of_Component (E);
163 1
         N       : Node_Id;
164 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
165
      begin
166
         --  If we deal with a thread, there is an extra parameter
167
         --  correspodning to the <T>_Ports enumerator useful for the
168
         --  marshalling.
169

170 1
         if Category = CC_Thread then
171
            N :=
172 1
              Make_Parameter_Specification
173 1
                (Make_Defining_Identifier (PN (P_Port)),
174 1
                 Extract_Designator
175 1
                   (ADN.Port_Enumeration_Node (Backend_Node (Identifier (E)))),
176
                 Mode_In);
177 1
            Append_Node_To_List (N, Profile);
178
         end if;
179

180
         --  The 'Data' parameter
181

182
         N :=
183 1
           Make_Parameter_Specification
184 1
             (Make_Defining_Identifier (PN (P_Data)),
185 1
              Get_Marshalled_Type (E),
186
              Mode_Out);
187 1
         Append_Node_To_List (N, Profile);
188

189
         --  The 'Message' parameter
190

191
         N :=
192 1
           Make_Parameter_Specification
193 1
             (Make_Defining_Identifier (PN (P_Message)),
194 1
              RE (RE_Message_Type),
195
              Mode_Inout);
196 1
         Append_Node_To_List (N, Profile);
197

198
         N :=
199 1
           Make_Subprogram_Specification
200 1
             (Make_Defining_Identifier (SN (S_Unmarshall)),
201
              Profile);
202

203 1
         return N;
204
      end Unmarshall_Spec;
205

206
      -----------
207
      -- Visit --
208
      -----------
209

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

216 1
            when K_Component_Instance =>
217 1
               Visit_Component_Instance (E);
218

219 0
            when others =>
220 0
               null;
221 1
         end case;
222 1
      end Visit;
223

224
      ---------------------------------
225
      -- Visit_Architecture_Instance --
226
      ---------------------------------
227

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

233
      ------------------------------
234
      -- Visit_Component_Instance --
235
      ------------------------------
236

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

245 1
            when CC_Process =>
246 1
               Visit_Process_Instance (E);
247

248 1
            when CC_Thread =>
249 1
               Visit_Thread_Instance (E);
250

251 1
            when CC_Data =>
252 1
               Visit_Data_Instance (E);
253

254 0
            when CC_Subprogram =>
255 0
               Visit_Subprogram_Instance (E);
256

257 1
            when others =>
258 1
               null;
259 1
         end case;
260 1
      end Visit_Component_Instance;
261

262
      -------------------------
263
      -- Visit_Data_Instance --
264
      -------------------------
265

266 1
      procedure Visit_Data_Instance (E : Node_Id) is
267 1
         N : Node_Id;
268
      begin
269
         --  Do not generate Marshallers more than once per node
270

271 1
         if No (Get_Handling (E, By_Name, H_Ada_Marshallers_Spec)) then
272
            --  Marshallers are generated only for types which can
273
            --  sent through data ports and event data ports.
274

275 1
            if Get_Data_Representation (E) /= Data_With_Accessors then
276

277 1
               N :=
278 1
                 Message_Comment
279 1
                   ("Marshallers for DATA type " &
280 1
                    Get_Name_String (Name (Identifier (E))));
281 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
282

283
               --  Marshall procedure
284

285 1
               N := Marshall_Spec (E);
286 1
               Bind_AADL_To_Marshall (Identifier (E), N);
287 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
288

289
               --  Unmarshall procedure
290

291 1
               N := Unmarshall_Spec (E);
292 1
               Bind_AADL_To_Unmarshall (Identifier (E), N);
293 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
294

295
               --  Mark the data type as being handled.
296

297 1
               Set_Handling
298
                 (E,
299
                  By_Name,
300
                  H_Ada_Marshallers_Spec,
301 1
                  Identifier (E));
302
            end if;
303
         else
304
            --  Do the tree bindings only
305

306 1
            Bind_AADL_To_Marshall
307 1
              (Identifier (E),
308 1
               ADN.Marshall_Node
309 1
                 (Backend_Node
310 1
                    (Get_Handling (E, By_Name, H_Ada_Marshallers_Spec))));
311

312 1
            Bind_AADL_To_Unmarshall
313 1
              (Identifier (E),
314 1
               ADN.Unmarshall_Node
315 1
                 (Backend_Node
316 1
                    (Get_Handling (E, By_Name, H_Ada_Marshallers_Spec))));
317
         end if;
318 1
      end Visit_Data_Instance;
319

320
      ----------------------------
321
      -- Visit_Process_Instance --
322
      ----------------------------
323

324 1
      procedure Visit_Process_Instance (E : Node_Id) is
325
         U : constant Node_Id :=
326 1
           ADN.Distributed_Application_Unit
327 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
328 1
         P : constant Node_Id := ADN.Entity (U);
329
      begin
330 1
         Push_Entity (P);
331 1
         Push_Entity (U);
332 1
         Set_Marshallers_Spec;
333

334
         --  Start recording the handling since they have to be reset
335
         --  for each node.
336

337 1
         Start_Recording_Handlings;
338

339
         --  Visit all the subcomponents of the process
340

341 1
         Visit_Subcomponents_Of (E);
342

343
         --  Unmark all the marked types
344

345 1
         Reset_Handlings;
346

347 1
         Pop_Entity; -- U
348 1
         Pop_Entity; -- P
349 1
      end Visit_Process_Instance;
350

351
      -------------------------------
352
      -- Visit_Subprogram_Instance --
353
      -------------------------------
354

355 0
      procedure Visit_Subprogram_Instance (E : Node_Id) is
356 0
         F : Node_Id;
357
      begin
358
         --  Declare all necessary data types
359

360 0
         if not AAU.Is_Empty (Features (E)) then
361 0
            F := First_Node (Features (E));
362

363 0
            while Present (F) loop
364 0
               if Kind (F) = K_Port_Spec_Instance then
365 0
                  Display_Located_Error
366 0
                    (Loc (F),
367
                     "Port features in subprogram are not supported",
368
                     Fatal => True);
369
               end if;
370

371 0
               if Present (Corresponding_Instance (F)) then
372 0
                  Visit (Corresponding_Instance (F));
373
               end if;
374

375 0
               F := Next_Node (F);
376 0
            end loop;
377
         end if;
378 0
      end Visit_Subprogram_Instance;
379

380
      ---------------------------
381
      -- Visit_System_Instance --
382
      ---------------------------
383

384 1
      procedure Visit_System_Instance (E : Node_Id) is
385
      begin
386 1
         Push_Entity (Ada_Root);
387

388
         --  Visit all the subcomponents of the system
389

390 1
         Visit_Subcomponents_Of (E);
391

392 1
         Pop_Entity; --  Ada_Root
393 1
      end Visit_System_Instance;
394

395
      ---------------------------
396
      -- Visit_Thread_Instance --
397
      ---------------------------
398

399 1
      procedure Visit_Thread_Instance (E : Node_Id) is
400 1
         N : Node_Id;
401 1
         F : Node_Id;
402
      begin
403 1
         if Has_Ports (E) then
404
            --  Generate marshallers for the Port_Type enumeration
405

406 1
            if No
407 1
                (Get_Handling
408 1
                   (Corresponding_Declaration (E),
409
                    By_Node,
410
                    H_Ada_Marshallers_Spec))
411
            then
412 1
               Set_Handling
413 1
                 (Corresponding_Declaration (E),
414
                  By_Node,
415
                  H_Ada_Marshallers_Spec,
416
                  E);
417

418 1
               N :=
419 1
                 Message_Comment
420 1
                   ("Marshallers for interface type of thread " &
421 1
                    Get_Name_String (Name (Identifier (E))));
422 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
423

424
               --  Marshall procedure
425

426 1
               N := Marshall_Spec (E);
427 1
               Bind_AADL_To_Marshall (Identifier (E), N);
428 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
429

430
               --  Unmarshall procedure
431

432 1
               N := Unmarshall_Spec (E);
433 1
               Bind_AADL_To_Unmarshall (Identifier (E), N);
434 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
435
            else
436
               declare
437
                  Found : constant Node_Id :=
438 1
                    Get_Handling
439 1
                      (Corresponding_Declaration (E),
440
                       By_Node,
441
                       H_Ada_Marshallers_Spec);
442 1
                  BE : constant Node_Id := Backend_Node (Identifier (Found));
443
               begin
444 1
                  Bind_AADL_To_Marshall
445 1
                    (Identifier (E),
446 1
                     ADN.Marshall_Node (BE));
447 1
                  Bind_AADL_To_Unmarshall
448 1
                    (Identifier (E),
449 1
                     ADN.Unmarshall_Node (BE));
450
               end;
451
            end if;
452

453
         end if;
454

455
         --  The only data that need to be marshalled or unmarshalled
456
         --  is the data that is meant to be sent between threads
457
         --  (locally or remotly). So we visit only thread features.
458

459 1
         if not AAU.Is_Empty (Features (E)) then
460 1
            F := First_Node (Features (E));
461

462 1
            while Present (F) loop
463 1
               if Kind (F) = K_Port_Spec_Instance and then AAN.Is_Data (F) then
464 1
                  Visit (Corresponding_Instance (F));
465
               end if;
466

467 1
               F := Next_Node (F);
468 1
            end loop;
469
         end if;
470 1
      end Visit_Thread_Instance;
471

472
   end Package_Spec;
473

474
   ------------------
475
   -- Package_Body --
476
   ------------------
477

478
   package body Package_Body is
479

480
      procedure Visit_Architecture_Instance (E : Node_Id);
481
      procedure Visit_Component_Instance (E : Node_Id);
482
      procedure Visit_System_Instance (E : Node_Id);
483
      procedure Visit_Process_Instance (E : Node_Id);
484
      procedure Visit_Thread_Instance (E : Node_Id);
485
      procedure Visit_Subprogram_Instance (E : Node_Id);
486
      procedure Visit_Data_Instance (E : Node_Id);
487
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
488

489
      function Marshall_Implementation (E : Node_Id) return Node_Id;
490
      --  Creates an implementation for a Marshall procedure
491

492
      function Unmarshall_Implementation (E : Node_Id) return Node_Id;
493
      --  Same as above but with an Unmarshall procedure
494

495
      function Marshallers_Instantiation (E : Node_Id) return Node_Id;
496
      --  Creates a generic instantiation for the Marshallers_G
497
      --  package corresponding to the node E.
498

499
      -----------------------------
500
      -- Marshall_Implementation --
501
      -----------------------------
502

503 1
      function Marshall_Implementation (E : Node_Id) return Node_Id is
504
         Spec : constant Node_Id :=
505 1
           ADN.Marshall_Node (Backend_Node (Identifier (E)));
506 1
         N : Node_Id;
507
      begin
508
         --  The marshallers for data component are simple renaming of
509
         --  intantiated ones. Fo thread components, the body is more
510
         --  complex.
511

512 1
         if not AAU.Is_Thread (E) then
513
            N :=
514 1
              Make_Selected_Component
515 1
                (Make_Defining_Identifier (Map_Marshallers_Name (E)),
516 1
                 Make_Defining_Identifier (SN (S_Marshall)));
517

518
            N :=
519 1
              Make_Subprogram_Specification
520 1
                (Defining_Identifier => ADN.Defining_Identifier (Spec),
521 1
                 Parameter_Profile   => ADN.Parameter_Profile (Spec),
522 1
                 Return_Type         => ADN.Return_Type (Spec),
523
                 Renamed_Subprogram  => N);
524
         else
525
            declare
526 1
               Alternatives : constant List_Id := New_List (ADN.K_List_Id);
527 1
               Statements   : List_Id;
528 1
               Declarations : List_Id;
529 1
               F            : Node_Id;
530 1
               Has_Data     : Boolean          := False;
531
            begin
532
               --  Check if the thread conrains at least one OUT DATA
533
               --  port, other wise, there is nothing to marshall
534

535 1
               F := First_Node (Features (E));
536

537 1
               while Present (F) loop
538 1
                  if Kind (F) = K_Port_Spec_Instance
539 1
                    and then Is_Out (F)
540 1
                    and then AAN.Is_Data (F)
541
                  then
542 1
                     Has_Data := True;
543 1
                     exit;
544
                  end if;
545

546 1
                  F := Next_Node (F);
547 1
               end loop;
548

549 1
               if Has_Data then
550
                  --  If we are at this point, we are sure that the
551
                  --  thread contains at least one data port. We must
552
                  --  also take in account the presence of pure event
553
                  --  ports, bu adding null case alternative for them
554

555 1
                  F := First_Node (Features (E));
556

557 1
                  while Present (F) loop
558 1
                     if Kind (F) = K_Port_Spec_Instance
559 1
                       and then Is_Out (F)
560
                     then
561
                        --  The statements (if any)
562

563 1
                        Statements := New_List (ADN.K_Statement_List);
564

565 1
                        if AAN.Is_Data (F) then
566
                           N :=
567 1
                             Make_Subprogram_Call
568 1
                               (Extract_Designator
569 1
                                  (ADN.Marshall_Node
570 1
                                     (Backend_Node
571 1
                                        (Identifier
572 1
                                           (Corresponding_Instance (F))))),
573 1
                                Make_List_Id
574 1
                                  (Make_Selected_Component
575 1
                                     (Make_Designator (PN (P_Data)),
576 1
                                      Make_Defining_Identifier
577 1
                                        (Map_Ada_Component_Name (F))),
578 1
                                   Make_Defining_Identifier (PN (P_Message))));
579 1
                           Append_Node_To_List (N, Statements);
580
                        else
581 1
                           Append_Node_To_List
582 1
                             (Make_Null_Statement,
583
                              Statements);
584
                        end if;
585

586
                        N :=
587 1
                          Make_Elsif_Statement
588 1
                            (Make_Expression
589 1
                               (Make_Selected_Component
590 1
                                  (Make_Designator (PN (P_Data)),
591 1
                                   Make_Designator (PN (P_Port))),
592
                                Op_Equal,
593 1
                                Extract_Enumerator (F, False)),
594
                             Statements);
595 1
                        Append_Node_To_List (N, Alternatives);
596
                     end if;
597

598 1
                     F := Next_Node (F);
599 1
                  end loop;
600

601
                  declare
602
                     Declarations : constant List_Id :=
603 1
                       New_List (ADN.K_Declaration_List);
604
                     Elsif_Statements : constant List_Id :=
605 1
                       New_List (ADN.K_List_Id);
606
                  begin
607
                     N :=
608 1
                       Make_Used_Package
609 1
                         (RU (RU_PolyORB_HI_Generated_Activity));
610 1
                     Append_Node_To_List (N, Declarations);
611

612 1
                     ADN.Set_First_Node
613
                       (Elsif_Statements,
614 1
                        ADN.Next_Node (ADN.First_Node (Alternatives)));
615

616
                     N :=
617 1
                       Make_If_Statement
618
                         (Condition =>
619 1
                            ADN.Condition (ADN.First_Node (Alternatives)),
620
                          Then_Statements =>
621 1
                            ADN.Then_Statements
622 1
                              (ADN.First_Node (Alternatives)),
623
                          Elsif_Statements => Elsif_Statements);
624

625
                     N :=
626 1
                       Make_Subprogram_Implementation
627
                         (Spec,
628
                          Declarations,
629 1
                          Make_List_Id (N));
630
                  end;
631

632
               else
633 1
                  Declarations := New_List (ADN.K_Declaration_List);
634

635
                  --  Add a pragma unreferenced for parameters
636

637
                  N :=
638 1
                    Make_Pragma_Statement
639
                      (Pragma_Unreferenced,
640 1
                       Make_List_Id
641 1
                         (Make_Defining_Identifier (PN (P_Message))));
642 1
                  Append_Node_To_List (N, Declarations);
643

644
                  N :=
645 1
                    Make_Pragma_Statement
646
                      (Pragma_Unreferenced,
647 1
                       Make_List_Id (Make_Defining_Identifier (PN (P_Data))));
648 1
                  Append_Node_To_List (N, Declarations);
649

650
                  N :=
651 1
                    Make_Subprogram_Implementation
652
                      (Spec,
653
                       Declarations,
654
                       No_List);
655
               end if;
656
            end;
657
         end if;
658

659 1
         return N;
660
      end Marshall_Implementation;
661

662
      -------------------------------
663
      -- Unmarshall_Implementation --
664
      -------------------------------
665

666 1
      function Unmarshall_Implementation (E : Node_Id) return Node_Id is
667
         Spec : constant Node_Id :=
668 1
           ADN.Unmarshall_Node (Backend_Node (Identifier (E)));
669 1
         N : Node_Id;
670
      begin
671
         --  The marshallers for data component are simple renaming of
672
         --  intantiated ones. Fo thread components, the body is more
673
         --  complex.
674

675 1
         if not AAU.Is_Thread (E) then
676
            N :=
677 1
              Make_Selected_Component
678 1
                (Make_Defining_Identifier (Map_Marshallers_Name (E)),
679 1
                 Make_Defining_Identifier (SN (S_Unmarshall)));
680

681
            N :=
682 1
              Make_Subprogram_Specification
683 1
                (Defining_Identifier => ADN.Defining_Identifier (Spec),
684 1
                 Parameter_Profile   => ADN.Parameter_Profile (Spec),
685 1
                 Return_Type         => ADN.Return_Type (Spec),
686
                 Renamed_Subprogram  => N);
687
         else
688
            declare
689 1
               Alternatives : constant List_Id := New_List (ADN.K_List_Id);
690
               Declarations : constant List_Id :=
691 1
                 New_List (ADN.K_Declaration_List);
692 1
               Statements  : List_Id;
693 1
               Aggregates  : List_Id;
694 1
               Ref_Message : Boolean := False;
695 1
               F           : Node_Id;
696 1
               Cases       : Integer := 0;
697
            begin
698
               --  If the thread has not IN port, there is nothing to
699
               --  unmarshall
700

701 1
               if Has_In_Ports (E) then
702
                  --  If we are at this point, we are sure that the
703
                  --  thread contains at least one port
704

705 1
                  F := First_Node (Features (E));
706

707 1
                  while Present (F) loop
708 1
                     if Kind (F) = K_Port_Spec_Instance and then Is_In (F) then
709
                        --  The record aggregate
710

711 1
                        Aggregates := New_List (ADN.K_Statement_List);
712

713
                        N :=
714 1
                          Make_Component_Association
715 1
                            (Make_Defining_Identifier (PN (P_Port)),
716 1
                             Extract_Enumerator (F, False));
717 1
                        Append_Node_To_List (N, Aggregates);
718

719
                        --  The statements (if any)
720

721 1
                        Statements := New_List (ADN.K_Statement_List);
722

723 1
                        if AAN.Is_Data (F) then
724
                           --  Declare the temporary variable
725

726
                           N :=
727 1
                             Make_Object_Declaration
728
                               (Defining_Identifier =>
729 1
                                  Make_Defining_Identifier
730 1
                                    (Map_Ada_Component_Name (F)),
731
                                Object_Definition =>
732 1
                                  Map_Ada_Data_Type_Designator
733 1
                                    (Corresponding_Instance (F)));
734 1
                           Append_Node_To_List (N, Declarations);
735

736
                           N :=
737 1
                             Make_Subprogram_Call
738 1
                               (Extract_Designator
739 1
                                  (ADN.Unmarshall_Node
740 1
                                     (Backend_Node
741 1
                                        (Identifier
742 1
                                           (Corresponding_Instance (F))))),
743 1
                                Make_List_Id
744 1
                                  (Make_Defining_Identifier
745 1
                                     (Map_Ada_Component_Name (F)),
746 1
                                   Make_Defining_Identifier (PN (P_Message))));
747 1
                           Append_Node_To_List (N, Statements);
748

749
                           --  Append the extra aggregate
750

751
                           N :=
752 1
                             Make_Component_Association
753 1
                               (Make_Defining_Identifier
754 1
                                  (Map_Ada_Component_Name (F)),
755 1
                                Make_Defining_Identifier
756 1
                                  (Map_Ada_Component_Name (F)));
757 1
                           Append_Node_To_List (N, Aggregates);
758

759
                           --  Mark the message formal parameter as
760
                           --  being referenced.
761

762 1
                           Ref_Message := True;
763
                        end if;
764

765
                        --  Assign the port value
766

767
                        N :=
768 1
                          Make_Assignment_Statement
769 1
                            (Make_Defining_Identifier (PN (P_Data)),
770 1
                             Make_Qualified_Expression
771 1
                               (Extract_Designator
772 1
                                  (ADN.Port_Interface_Node
773 1
                                     (Backend_Node (Identifier (E)))),
774 1
                                Make_Record_Aggregate (Aggregates)));
775 1
                        Append_Node_To_List (N, Statements);
776

777
                        N :=
778 1
                          Make_Elsif_Statement
779 1
                            (Make_Expression
780 1
                               (Make_Defining_Identifier (PN (P_Port)),
781
                                Op_Equal,
782 1
                                Extract_Enumerator (F, False)),
783
                             Statements);
784 1
                        Append_Node_To_List (N, Alternatives);
785 1
                        Cases := Cases + 1;
786
                     end if;
787

788 1
                     F := Next_Node (F);
789 1
                  end loop;
790

791 1
                  if not Ref_Message then
792
                     --  Add a pragma unreferenced for 'Message'
793

794
                     N :=
795 1
                       Make_Pragma_Statement
796
                         (Pragma_Unreferenced,
797 1
                          Make_List_Id
798 1
                            (Make_Defining_Identifier (PN (P_Message))));
799 1
                     Append_Node_To_List (N, Declarations);
800
                  end if;
801

802
                  declare
803
                     Elsif_Statements : constant List_Id :=
804 1
                       New_List (ADN.K_List_Id);
805
                  begin
806
                     N :=
807 1
                       Make_Used_Package
808 1
                         (RU (RU_PolyORB_HI_Generated_Activity));
809 1
                     Append_Node_To_List (N, Declarations);
810

811 1
                     ADN.Set_First_Node
812
                       (Elsif_Statements,
813 1
                        ADN.Next_Node (ADN.First_Node (Alternatives)));
814

815 1
                     if Cases > 1 then
816
                        --  We have more than one port to consider,
817
                        --  generate a if/elsif
818
                        N :=
819 1
                        Make_If_Statement
820
                           (Condition =>
821 1
                              ADN.Condition (ADN.First_Node (Alternatives)),
822
                           Then_Statements =>
823 1
                              ADN.Then_Statements
824 1
                                 (ADN.First_Node (Alternatives)),
825
                           Elsif_Statements => Elsif_Statements);
826

827
                        N :=
828 1
                        Make_Subprogram_Implementation
829
                           (Spec,
830
                           Declarations,
831 1
                           Make_List_Id (N));
832
                     else
833
                        --  Only one port to unmarshall, we generate
834
                        --  minimal code
835
                        N :=
836 1
                        Make_Pragma_Statement
837
                           (Pragma_Unreferenced,
838 1
                           Make_List_Id
839 1
                             (Make_Defining_Identifier (PN (P_Port))));
840 1
                        Append_Node_To_List (N, Declarations);
841

842
                        N :=
843 1
                        Make_Subprogram_Implementation
844
                           (Spec,
845
                           Declarations,
846 1
                           ADN.Then_Statements
847 1
                              (ADN.First_Node (Alternatives)));
848
                     end if;
849
                  end;
850

851
               else
852
                  --  Add a pragma unreferenced for parameters
853

854
                  N :=
855 1
                    Make_Pragma_Statement
856
                      (Pragma_Unreferenced,
857 1
                       Make_List_Id (Make_Defining_Identifier (PN (P_Port))));
858 1
                  Append_Node_To_List (N, Declarations);
859

860
                  N :=
861 1
                    Make_Pragma_Statement
862
                      (Pragma_Unreferenced,
863 1
                       Make_List_Id
864 1
                         (Make_Defining_Identifier (PN (P_Message))));
865 1
                  Append_Node_To_List (N, Declarations);
866

867
                  N :=
868 1
                    Make_Pragma_Statement
869
                      (Pragma_Unreferenced,
870 1
                       Make_List_Id (Make_Defining_Identifier (PN (P_Data))));
871 1
                  Append_Node_To_List (N, Declarations);
872

873
                  N :=
874 1
                    Make_Subprogram_Implementation
875
                      (Spec,
876
                       Declarations,
877
                       No_List);
878
               end if;
879
            end;
880
         end if;
881

882 1
         return N;
883
      end Unmarshall_Implementation;
884

885
      -------------------------------
886
      -- Marshallers_Instantiation --
887
      -------------------------------
888

889 1
      function Marshallers_Instantiation (E : Node_Id) return Node_Id is
890
      begin
891 1
         return Make_Package_Instantiation
892
             (Defining_Identifier =>
893 1
                Make_Defining_Identifier (Map_Marshallers_Name (E)),
894
              Generic_Package =>
895 1
                RU (RU_PolyORB_HI_Marshallers_G, Elaborated => True),
896 1
              Parameter_List => Make_List_Id (Get_Marshalled_Type (E)));
897
      end Marshallers_Instantiation;
898

899
      -----------
900
      -- Visit --
901
      -----------
902

903 1
      procedure Visit (E : Node_Id) is
904
      begin
905 1
         case Kind (E) is
906 1
            when K_Architecture_Instance =>
907 1
               Visit_Architecture_Instance (E);
908

909 1
            when K_Component_Instance =>
910 1
               Visit_Component_Instance (E);
911

912 0
            when others =>
913 0
               null;
914 1
         end case;
915 1
      end Visit;
916

917
      ---------------------------------
918
      -- Visit_Architecture_Instance --
919
      ---------------------------------
920

921 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
922
      begin
923 1
         Visit (Root_System (E));
924 1
      end Visit_Architecture_Instance;
925

926
      ------------------------------
927
      -- Visit_Component_Instance --
928
      ------------------------------
929

930 1
      procedure Visit_Component_Instance (E : Node_Id) is
931
         Category : constant Component_Category :=
932 1
           Get_Category_Of_Component (E);
933
      begin
934 1
         case Category is
935 1
            when CC_System =>
936 1
               Visit_System_Instance (E);
937

938 1
            when CC_Process =>
939 1
               Visit_Process_Instance (E);
940

941 1
            when CC_Thread =>
942 1
               Visit_Thread_Instance (E);
943

944 1
            when CC_Data =>
945 1
               Visit_Data_Instance (E);
946

947 0
            when CC_Subprogram =>
948 0
               Visit_Subprogram_Instance (E);
949

950 1
            when others =>
951 1
               null;
952 1
         end case;
953 1
      end Visit_Component_Instance;
954

955
      -------------------------
956
      -- Visit_Data_Instance --
957
      -------------------------
958

959 1
      procedure Visit_Data_Instance (E : Node_Id) is
960 1
         N : Node_Id;
961
      begin
962
         --  Do not generate Marshallers more than once per node
963

964 1
         if No (Get_Handling (E, By_Name, H_Ada_Marshallers_Body)) then
965
            --  Marshallers are generated only for types which can
966
            --  sent through data ports and event data ports.
967

968 1
            if Get_Data_Representation (E) /= Data_With_Accessors then
969

970 1
               N :=
971 1
                 Message_Comment
972 1
                   ("Marshallers for DATA type " &
973 1
                    Get_Name_String (Name (Identifier (E))));
974 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
975

976
               --  Package instantiation
977

978 1
               N := Marshallers_Instantiation (E);
979 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
980

981
               --  Marshall procedure
982

983 1
               N := Marshall_Implementation (E);
984 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
985

986
               --  Unmarshall procedure
987

988 1
               N := Unmarshall_Implementation (E);
989 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
990

991
               --  Mark the data type as being handled.
992

993 1
               Set_Handling
994
                 (E,
995
                  By_Name,
996
                  H_Ada_Marshallers_Body,
997 1
                  Identifier (E));
998
            end if;
999
         end if;
1000 1
      end Visit_Data_Instance;
1001

1002
      ----------------------------
1003
      -- Visit_Process_Instance --
1004
      ----------------------------
1005

1006 1
      procedure Visit_Process_Instance (E : Node_Id) is
1007
         U : constant Node_Id :=
1008 1
           ADN.Distributed_Application_Unit
1009 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
1010 1
         P : constant Node_Id := ADN.Entity (U);
1011
      begin
1012 1
         Push_Entity (P);
1013 1
         Push_Entity (U);
1014 1
         Set_Marshallers_Body;
1015

1016
         --  Start recording the handling since they have to be reset
1017
         --  for each node.
1018

1019 1
         Start_Recording_Handlings;
1020

1021
         --  Visit all the subcomponents of the process
1022

1023 1
         Visit_Subcomponents_Of (E);
1024

1025
         --  Unmark all the marked types
1026

1027 1
         Reset_Handlings;
1028

1029 1
         Pop_Entity; -- U
1030 1
         Pop_Entity; -- P
1031 1
      end Visit_Process_Instance;
1032

1033
      -------------------------------
1034
      -- Visit_Subprogram_Instance --
1035
      -------------------------------
1036

1037 0
      procedure Visit_Subprogram_Instance (E : Node_Id) is
1038 0
         F : Node_Id;
1039
      begin
1040
         --  Declare all necessary data types
1041

1042 0
         if not AAU.Is_Empty (Features (E)) then
1043 0
            F := First_Node (Features (E));
1044

1045 0
            while Present (F) loop
1046 0
               if Kind (F) = K_Port_Spec_Instance then
1047 0
                  Display_Located_Error
1048 0
                    (Loc (F),
1049
                     "Port features in subprogram are not supported",
1050
                     Fatal => True);
1051
               end if;
1052

1053 0
               if Present (Corresponding_Instance (F)) then
1054 0
                  Visit (Corresponding_Instance (F));
1055
               end if;
1056

1057 0
               F := Next_Node (F);
1058 0
            end loop;
1059
         end if;
1060 0
      end Visit_Subprogram_Instance;
1061

1062
      ---------------------------
1063
      -- Visit_System_Instance --
1064
      ---------------------------
1065

1066 1
      procedure Visit_System_Instance (E : Node_Id) is
1067
      begin
1068 1
         Push_Entity (Ada_Root);
1069

1070
         --  Visit all the subcomponents of the system
1071

1072 1
         Visit_Subcomponents_Of (E);
1073

1074 1
         Pop_Entity; --  Ada_Root
1075 1
      end Visit_System_Instance;
1076

1077
      ---------------------------
1078
      -- Visit_Thread_Instance --
1079
      ---------------------------
1080

1081 1
      procedure Visit_Thread_Instance (E : Node_Id) is
1082 1
         N : Node_Id;
1083 1
         F : Node_Id;
1084
      begin
1085 1
         if Has_Ports (E) then
1086 1
            if No
1087 1
                (Get_Handling
1088 1
                   (Corresponding_Declaration (E),
1089
                    By_Node,
1090
                    H_Ada_Marshallers_Body))
1091
            then
1092 1
               Set_Handling
1093 1
                 (Corresponding_Declaration (E),
1094
                  By_Node,
1095
                  H_Ada_Marshallers_Body,
1096
                  E);
1097

1098
               --  Generate marshallers for the Port_Type enumeration
1099

1100 1
               N :=
1101 1
                 Message_Comment
1102 1
                   ("Marshallers for interface type of thread " &
1103 1
                    Get_Name_String (Name (Identifier (E))));
1104 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
1105

1106
               --  Marshall procedure
1107

1108 1
               N := Marshall_Implementation (E);
1109 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
1110

1111
               --  Unmarshall procedure
1112

1113 1
               N := Unmarshall_Implementation (E);
1114 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
1115
            end if;
1116
         end if;
1117

1118
         --  The only data that need to be marshalled or unmarshalled
1119
         --  is the data that is meant to be sent between threads
1120
         --  (locally or remotly). So we visit only thread features.
1121

1122 1
         if not AAU.Is_Empty (Features (E)) then
1123 1
            F := First_Node (Features (E));
1124

1125 1
            while Present (F) loop
1126 1
               if Kind (F) = K_Port_Spec_Instance and then AAN.Is_Data (F) then
1127 1
                  Visit (Corresponding_Instance (F));
1128
               end if;
1129

1130 1
               F := Next_Node (F);
1131 1
            end loop;
1132
         end if;
1133 1
      end Visit_Thread_Instance;
1134

1135
   end Package_Body;
1136

1137
end Ocarina.Backends.PO_HI_Ada.Marshallers;

Read our documentation on viewing source code .

Loading