OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--    O C A R I N A . B A C K E N D S . P O _ H I _ A D A . N A M I N G     --
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.Instances.Queries;
41

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

50
with Ocarina.Backends.Ada_Values;
51
with Ocarina.AADL_Values;
52

53
package body Ocarina.Backends.PO_HI_Ada.Naming is
54

55
   use Ocarina.Namet;
56
   use Ocarina.ME_AADL;
57
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
58
   use Ocarina.ME_AADL.AADL_Instances.Entities;
59
   use Ocarina.Backends.Utils;
60
   use Ocarina.Backends.Properties;
61
   use Ocarina.Backends.Messages;
62
   use Ocarina.Backends.PO_HI_Ada.Mapping;
63
   use Ocarina.Backends.PO_HI_Ada.Runtime;
64
   use Ocarina.Backends.Ada_Tree.Nutils;
65
   use Ocarina.Backends.Ada_Values;
66
   use Ocarina.Instances.Queries;
67

68
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
69
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
70

71
   ------------------
72
   -- Package_Spec --
73
   ------------------
74

75
   package body Package_Spec is
76

77
      procedure Visit_Architecture_Instance (E : Node_Id);
78
      procedure Visit_Component_Instance (E : Node_Id);
79
      procedure Visit_System_Instance (E : Node_Id);
80
      procedure Visit_Process_Instance (E : Node_Id);
81
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
82

83
      function Added_Internal_Name
84
        (P : Node_Id;
85
         B : Node_Id;
86
         E : Node_Id) return Name_Id;
87
      function Is_Added (P : Node_Id; B : Node_Id; E : Node_Id) return Boolean;
88
      procedure Set_Added (P : Node_Id; B : Node_Id; E : Node_Id);
89
      --  Used to ensure that the naming information are added only
90
      --  for the nodes connected to a particular node.
91

92
      function Naming_Information (E : Node_Id) return Node_Id;
93
      --  Build an array element association that contains the
94
      --  informations about a particular node of the distributed
95
      --  application.
96

97
      -------------------------
98
      -- Added_Internal_Name --
99
      -------------------------
100

101 1
      function Added_Internal_Name
102
        (P : Node_Id;
103
         B : Node_Id;
104
         E : Node_Id) return Name_Id
105
      is
106
      begin
107 1
         Set_Str_To_Name_Buffer ("%naming%info%");
108 1
         Add_Nat_To_Name_Buffer (Nat (P));
109 1
         Add_Char_To_Name_Buffer ('%');
110 1
         Add_Nat_To_Name_Buffer (Nat (B));
111 1
         Add_Char_To_Name_Buffer ('%');
112 1
         Add_Nat_To_Name_Buffer (Nat (E));
113

114 1
         return Name_Find;
115
      end Added_Internal_Name;
116

117
      --------------
118
      -- Is_Added --
119
      --------------
120

121 1
      function Is_Added
122
        (P : Node_Id;
123
         B : Node_Id;
124
         E : Node_Id) return Boolean
125
      is
126 1
         I_Name : constant Name_Id := Added_Internal_Name (P, B, E);
127
      begin
128 1
         return Get_Name_Table_Byte (I_Name) = 1;
129
      end Is_Added;
130

131
      ---------------
132
      -- Set_Added --
133
      ---------------
134

135 1
      procedure Set_Added (P : Node_Id; B : Node_Id; E : Node_Id) is
136 1
         I_Name : constant Name_Id := Added_Internal_Name (P, B, E);
137
      begin
138 1
         Set_Name_Table_Byte (I_Name, 1);
139 1
      end Set_Added;
140

141
      ------------------------
142
      -- Naming_Information --
143
      ------------------------
144

145 1
      function Naming_Information (E : Node_Id) return Node_Id is
146 1
         Location           : Name_Id;
147 1
         Port_Number        : Value_Id;
148 1
         N                  : Node_Id;
149 1
         L                  : Node_Id;
150 1
         P                  : Node_Id;
151 1
         V                  : Node_Id;
152 1
         Configuration_Data : Name_Id := No_Name;
153

154
      begin
155 1
         if AAU.Is_Process (E) then
156 0
            Location    := Get_Location (Get_Bound_Processor (E));
157 0
            Port_Number := Get_Port_Number (E);
158

159 1
         elsif AAU.Is_Device (E) then
160 1
            Location           := Get_Location (E);
161 1
            Port_Number        := Get_Port_Number (E);
162 1
            Configuration_Data := Get_Type_Source_Name (E);
163
         end if;
164

165 1
         if Location = No_Name then
166 0
            if Is_Defined_Property (E, "deployment::configuration")
167
              and then
168 0
                Get_String_Property (E, "deployment::configuration") /=
169
                No_Name
170
            then
171 0
               Get_Name_String
172 0
                 (Get_String_Property (E, "deployment::configuration"));
173 0
               L :=
174 0
                 Make_Subprogram_Call
175 0
                   (RE (RE_To_HI_String),
176 0
                    Make_List_Id
177 0
                      (Make_Literal (New_String_Value (Name_Find))));
178
            else
179
               L :=
180 0
                 Make_Subprogram_Call
181 0
                   (RE (RE_To_HI_String),
182 0
                    Make_List_Id (Make_Literal (New_String_Value (No_Name))));
183
            end if;
184
         else
185
            L :=
186 1
              Make_Subprogram_Call
187 1
                (RE (RE_To_HI_String),
188 1
                 Make_List_Id (Make_Literal (New_String_Value (Location))));
189
         end if;
190

191 1
         if Port_Number = Ocarina.AADL_Values.No_Value then
192 1
            P := Make_Literal (New_Integer_Value (0, 1, 10));
193
         else
194 0
            P := Make_Literal (To_Ada_Value (Port_Number));
195
         end if;
196

197 1
         if Configuration_Data = No_Name then
198 1
            V := RE (RE_Null_Address);
199
         else
200
            V :=
201 0
              Make_Attribute_Designator
202 0
                (Map_Ada_Subprogram_Identifier (Configuration_Data),
203
                 A_Address);
204
         end if;
205

206
         --  Build the record aggregate
207

208 1
         N := Make_Record_Aggregate (Make_List_Id (L, P, V));
209 1
         N := Make_Element_Association (Extract_Enumerator (E), N);
210 1
         return N;
211
      end Naming_Information;
212

213
      -----------
214
      -- Visit --
215
      -----------
216

217 1
      procedure Visit (E : Node_Id) is
218
      begin
219 1
         case Kind (E) is
220 1
            when K_Architecture_Instance =>
221 1
               Visit_Architecture_Instance (E);
222

223 1
            when K_Component_Instance =>
224 1
               Visit_Component_Instance (E);
225

226 0
            when others =>
227 0
               null;
228 1
         end case;
229 1
      end Visit;
230

231
      ---------------------------------
232
      -- Visit_Architecture_Instance --
233
      ---------------------------------
234

235 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
236
      begin
237 1
         Visit (Root_System (E));
238 1
      end Visit_Architecture_Instance;
239

240
      ------------------------------
241
      -- Visit_Component_Instance --
242
      ------------------------------
243

244 1
      procedure Visit_Component_Instance (E : Node_Id) is
245
         Category : constant Component_Category :=
246 1
           Get_Category_Of_Component (E);
247
      begin
248 1
         case Category is
249 1
            when CC_System =>
250 1
               Visit_System_Instance (E);
251

252 1
            when CC_Process =>
253 1
               Visit_Process_Instance (E);
254

255 1
            when others =>
256 1
               null;
257 1
         end case;
258 1
      end Visit_Component_Instance;
259

260
      ------------------------
261
      -- Visit_Bus_Instance --
262
      ------------------------
263

264
      procedure Visit_Bus_Instance (Bus : Node_Id; E : Node_Id);
265

266 1
      procedure Visit_Bus_Instance (Bus : Node_Id; E : Node_Id) is
267 1
         N                 : Node_Id;
268 1
         S                 : Node_Id;
269 1
         F                 : Node_Id;
270 1
         B                 : Node_Id;
271 1
         C                 : Node_Id;
272 1
         C_End             : Node_Id;
273 1
         End_List          : List_Id;
274 1
         Parent            : Node_Id;
275 1
         Naming_Table_List : constant List_Id := New_List (ADN.K_List_Id);
276
         Root_Sys          : constant Node_Id :=
277 1
           Parent_Component (Parent_Subcomponent (E));
278 1
         Transport_API : Supported_Transport_APIs := Transport_None;
279
      begin
280
         --  We perform a first loop to designate the nodes to be
281
         --  included in the naming table. For a particular node, the
282
         --  nodes in its naming table are (1) itself and (2) all the
283
         --  nodes directly connected to it. This factorizes a lot of
284
         --  code between the handling of the different platforms.
285

286
         --  In parallel, we check the consistency of the transport
287
         --  layers that have to be used by the connection involving
288
         --  these features.
289

290
         --  (1) Add current process E to the naming table
291

292 1
         if Is_Added (E, Bus, E) then
293 1
            return;
294
         end if;
295

296 1
         Set_Added (E, Bus, E);
297

298
         --  (2) Add other processes connected to E
299

300 1
         if not AAU.Is_Empty (Features (E)) then
301 1
            F := First_Node (Features (E));
302

303 1
            while Present (F) loop
304
               --  We make two iterations to traverse (1) the sources
305
               --  of F then (2) the destinations of F.
306

307 1
               End_List := Sources (F);
308

309 1
               for J in 1 .. 2 loop
310 1
                  if not AAU.Is_Empty (End_List) then
311 1
                     C_End := First_Node (End_List);
312

313 1
                     while Present (C_End) loop
314 1
                        Parent := Parent_Component (Item (C_End));
315

316 1
                        if AAU.Is_Process (Parent) then
317 1
                           if Parent /= E then
318
                              --  Mark the parent component of the
319
                              --  remote feature as involved with the
320
                              --  current process.
321

322 1
                              Set_Added (Parent, Bus, E);
323
                           end if;
324

325
                           --  Get the connection involving C_End
326

327 1
                           C := Extra_Item (C_End);
328 1
                           pragma Assert (Present (C));
329

330
                           --  Get the bus of the connection
331

332 1
                           B := Get_Bound_Bus (C);
333

334
                           --  Get the transport layer of the Bus and
335
                           --  verify that all the features use the
336
                           --  same transport layer for their
337
                           --  connections.
338

339 1
                           if Transport_API /= Transport_None
340 1
                             and then Transport_API /= Get_Transport_API (B, E)
341
                           then
342 0
                              Display_Located_Error
343 0
                                (Loc (Parent_Subcomponent (E)),
344
                                 "The features of this process are involved" &
345
                                 " in connections that do not use the same" &
346
                                 " transport layer. This is not supported" &
347
                                 " yet.",
348
                                 Fatal => True);
349
                           else
350 1
                              Transport_API := Get_Transport_API (B, E);
351

352
                              --  If we have a bus for which no
353
                              --  transport layer has been specified,
354
                              --  we raise an error.
355

356 1
                              if Transport_API = Transport_None then
357 0
                                 Display_Located_Error
358 0
                                   (Loc (B),
359
                                    "No transport layer has been specified" &
360
                                    " for this bus",
361
                                    Fatal => True);
362
                              end if;
363
                           end if;
364
                        end if;
365

366 1
                        C_End := Next_Node (C_End);
367 1
                     end loop;
368
                  end if;
369

370
                  --  In the next iteration, we traverse the
371
                  --  Destinations of F.
372

373 1
                  End_List := Destinations (F);
374 1
               end loop;
375

376 1
               F := Next_Node (F);
377 1
            end loop;
378
         end if;
379

380
         --  Generate the naming table
381

382 1
         case Transport_API is
383 1
            when Transport_BSD_Sockets | Transport_User =>
384
               --  Build the node information for all the nodes
385
               --  involved with the current one and append it to the
386
               --  naming list.
387

388 1
               S := First_Node (Subcomponents (Root_Sys));
389

390 1
               while Present (S) loop
391 1
                  if Transport_API = Transport_BSD_Sockets
392 0
                    and then AAU.Is_Process (Corresponding_Instance (S))
393 0
                    and then Is_Added (Corresponding_Instance (S), Bus, E)
394
                  then
395
                     --  For default transport API, the configuration
396
                     --  is captured at the level of the process
397

398 0
                     N := Naming_Information (Corresponding_Instance (S));
399 0
                     Append_Node_To_List (N, Naming_Table_List);
400

401 1
                  elsif Transport_API = Transport_User
402 1
                    and then AAU.Is_Process (Corresponding_Instance (S))
403 1
                    and then Is_Added (Corresponding_Instance (S), Bus, E)
404
                  then
405
                     --  For user-defined transport, the configuration
406
                     --  is captured in the device that supports the
407
                     --  communication
408

409 1
                     N := Naming_Information
410 1
                       (Corresponding_Instance
411 1
                          (Get_Device_Of_Process
412 1
                             (Bus, Corresponding_Instance (S))));
413

414 1
                     Append_Node_To_List (N, Naming_Table_List);
415
                  end if;
416

417 1
                  S := Next_Node (S);
418 1
               end loop;
419

420
               N :=
421 1
                 Make_Element_Association
422
                   (No_Node,
423 1
                    Make_Record_Aggregate
424 1
                      (Make_List_Id
425 1
                         (Make_Subprogram_Call
426 1
                            (RE (RE_To_HI_String),
427 1
                             Make_List_Id
428 1
                               (Make_Literal (New_String_Value (No_Name)))),
429 1
                          Make_Literal (New_Integer_Value (0, 1, 10)),
430 1
                          RE (RE_Null_Address))));
431 1
               Append_Node_To_List (N, Naming_Table_List);
432

433
               --  Declare the Naming Table
434

435 1
               N :=
436 1
                 Message_Comment
437 1
                   ("Naming Table for bus " &
438 1
                    Get_Name_String
439 1
                      (Name (Identifier (Parent_Subcomponent (Bus)))));
440 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
441

442 1
               if Transport_API = Transport_User then
443
                  --  We are building a name table specific to a bus
444

445
                  N :=
446 1
                    Make_Object_Declaration
447 1
                      (Defining_Identifier => Map_Bus_Name (Bus),
448
                       Constant_Present    => True,
449 1
                       Object_Definition   => RE (RE_Naming_Table_Type),
450 1
                       Expression => Make_Array_Aggregate (Naming_Table_List));
451 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
452

453
               else
454
                  --  We generate the default name table
455

456
                  N :=
457 0
                    Make_Object_Declaration
458
                      (Defining_Identifier =>
459 0
                         Make_Defining_Identifier (PN (P_Naming_Table)),
460
                       Constant_Present  => True,
461 0
                       Object_Definition => RE (RE_Naming_Table_Type),
462 0
                       Expression => Make_Array_Aggregate (Naming_Table_List));
463 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
464
               end if;
465

466 0
            when Transport_SpaceWire =>
467 0
               Display_Located_Error
468 0
                 (Loc (E),
469
                  "SpaceWire bus is no longer supported",
470
                  Fatal => True);
471

472 0
            when Transport_None =>
473
               --  If we did not fetch a meaningful transport layer,
474
               --  this means the application does not use the
475
               --  network. No naming table will be generated.
476

477 0
               null;
478 1
         end case;
479
      end Visit_Bus_Instance;
480

481
      ----------------------------
482
      -- Visit_Process_Instance --
483
      ----------------------------
484

485 1
      procedure Visit_Process_Instance (E : Node_Id) is
486
         U : constant Node_Id :=
487 1
           ADN.Distributed_Application_Unit
488 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
489 1
         P        : constant Node_Id := ADN.Entity (U);
490 1
         S        : Node_Id;
491 1
         Parent   : Node_Id;
492
         Root_Sys : constant Node_Id :=
493 1
           Parent_Component (Parent_Subcomponent (E));
494 1
         F         : Node_Id;
495 1
         B         : Node_Id;
496 1
         C         : Node_Id;
497 1
         C_End     : Node_Id;
498 1
         End_List  : List_Id;
499 1
         Transport : Supported_Transport_APIs;
500

501
      begin
502 1
         pragma Assert (AAU.Is_System (Root_Sys));
503 1
         Push_Entity (P);
504 1
         Push_Entity (U);
505 1
         Set_Naming_Spec;
506

507
         --  We go through all bus
508

509 1
         Transport := Transport_None;
510

511 1
         S := First_Node (Subcomponents (Root_Sys));
512

513
         Main_Loop :
514 1
         while Present (S) loop
515 1
            if AAU.Is_Bus (Corresponding_Instance (S)) then
516 1
               if not AAU.Is_Empty (Features (E)) then
517 1
                  F := First_Node (Features (E));
518

519 1
                  while Present (F) loop
520
                     --  We make two iterations to traverse (1) the
521
                     --  sources of F then (2) the destinations of F.
522

523 1
                     End_List := Sources (F);
524 1
                     for J in 1 .. 2 loop
525 1
                        if not AAU.Is_Empty (End_List) then
526 1
                           C_End := First_Node (End_List);
527

528 1
                           while Present (C_End) loop
529 1
                              Parent := Parent_Component (Item (C_End));
530 1
                              if AAU.Is_Process (Parent) then
531
                                 --  Get the connection involving C_End
532

533 1
                                 C := Extra_Item (C_End);
534 1
                                 pragma Assert (Present (C));
535

536
                                 --  Get the bus of the connection
537

538 1
                                 B := Get_Bound_Bus (C);
539

540 1
                                 Transport := Get_Transport_API (B);
541

542 1
                                 if Present (B)
543 1
                                   and then B = Corresponding_Instance (S)
544
                                 then
545 1
                                    Visit_Bus_Instance
546 1
                                      (Corresponding_Instance (S),
547
                                       E);
548 1
                                    if Transport /= Transport_User
549 1
                                      and then Transport /= Transport_None
550
                                    then
551 0
                                       exit Main_Loop;
552
                                    end if;
553
                                 end if;
554
                              end if;
555 1
                              C_End := Next_Node (C_End);
556 1
                           end loop;
557

558
                           --  In the next iteration, we traverse the
559
                           --  Destinations of F.
560

561 1
                           End_List := Destinations (F);
562

563
                        end if;
564 1
                     end loop;
565

566 1
                     F := Next_Node (F);
567 1
                  end loop;
568
               end if;
569
            end if;
570 1
            S := Next_Node (S);
571

572 1
         end loop Main_Loop;
573

574 1
         Bind_Transport_API (E, Transport);
575
         --  XXX dubious. Actually, it is used only through
576
         --  Fetch_Transport_API to run Transport_API initialization
577
         --  in main thread.
578

579 1
         Pop_Entity; --  U
580 1
         Pop_Entity; --  P
581 1
      end Visit_Process_Instance;
582

583
      ---------------------------
584
      -- Visit_System_Instance --
585
      ---------------------------
586

587 1
      procedure Visit_System_Instance (E : Node_Id) is
588 1
         C : Node_Id;
589
      begin
590 1
         Push_Entity (Ada_Root);
591

592
         --  Verify the consistency of the distributed application
593
         --  hierachy.
594

595 1
         if not AAU.Is_Empty (Connections (E)) then
596 1
            C := First_Node (Connections (E));
597 1
            while Present (C) loop
598 1
               Check_Connection_Consistency (C);
599

600 1
               C := Next_Node (C);
601 1
            end loop;
602
         end if;
603

604
         --  Visit all the subcomponents of the system
605

606 1
         Visit_Subcomponents_Of (E);
607

608 1
         Pop_Entity; --  Ada_Root
609 1
      end Visit_System_Instance;
610

611
   end Package_Spec;
612

613
end Ocarina.Backends.PO_HI_Ada.Naming;

Read our documentation on viewing source code .

Loading