1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--               O C A R I N A . B A C K E N D S . U T I L S                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2005-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 GNAT.OS_Lib;
34
with Ada.Directories;
35
with GNAT.Table;
36

37
with Ocarina.Namet;
38
with Locations;
39

40
with Ocarina.ME_AADL;
41
with Ocarina.ME_AADL.AADL_Tree.Nodes;
42
with Ocarina.ME_AADL.AADL_Tree.Nutils;
43
with Ocarina.ME_AADL.AADL_Tree.Entities.Properties;
44
with Ocarina.ME_AADL.AADL_Instances.Nodes;
45
with Ocarina.ME_AADL.AADL_Instances.Nutils;
46
with Ocarina.ME_AADL.AADL_Instances.Entities;
47
with Ocarina.Backends.Messages;
48
with Ocarina.Backends.Ada_Tree.Nodes;
49
with Ocarina.Backends.Ada_Tree.Nutils;
50
with Ocarina.Backends.Ada_Values;
51
with Ocarina.Instances.Queries;
52
with Ocarina.Backends.Helper;
53
with Utils; use Utils;
54

55 2
package body Ocarina.Backends.Utils is
56

57
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
58
   package ATU renames Ocarina.ME_AADL.AADL_Tree.Nutils;
59
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
60
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
61
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
62
   package ADU renames Ocarina.Backends.Ada_Tree.Nutils;
63
   package ADV renames Ocarina.Backends.Ada_Values;
64

65
   use GNAT.OS_Lib;
66
   use Ada.Directories;
67

68
   use Ocarina.Namet;
69
   use Locations;
70
   use Ocarina.ME_AADL;
71
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
72
   use Ocarina.ME_AADL.AADL_Instances.Nutils;
73
   use Ocarina.ME_AADL.AADL_Instances.Entities;
74
   use Ocarina.Backends.Messages;
75
   use Ocarina.Backends.Ada_Tree.Nutils;
76
   use Ocarina.Instances.Queries;
77
   use Ocarina.Backends.Helper;
78

79
   type Browsing_Kind is (By_Source, By_Destination);
80

81
   --  The entered directories stack
82

83
   package Directories_Stack is new GNAT.Table (Name_Id, Int, 1, 5, 10);
84

85
   function Get_Handling_Internal_Name
86
     (E          : Node_Id;
87
      Comparison : Comparison_Kind;
88
      Handling   : Handling_Kind) return Name_Id;
89
   --  Code factorisation between Set_Handling and Get_Handling. This
90
   --  function computes an internal name used to store the handling
91
   --  information.
92

93
   function Map_Ada_Subprogram_Status_Name (S : Node_Id) return Name_Id;
94
   --  Maps an name for the record type corresponding to a hybrid
95
   --  subprogram.
96

97
   function Map_Ada_Call_Seq_Access_Name (S : Node_Id) return Name_Id;
98
   --  Maps an name for the subprogram access type corresponding to a
99
   --  hybrid subprogram.
100

101
   function Map_Ada_Call_Seq_Subprogram_Name
102
     (Spg : Node_Id;
103
      Seq : Node_Id) return Name_Id;
104
   --  Maps an name for the subprogram corresponding to a hybrid
105
   --  subprogram call sequence.
106

107
   type Repository_Entry is record
108
      E          : Node_Id;
109
      Comparison : Comparison_Kind;
110
      Handling   : Handling_Kind;
111
      A          : Node_Id;
112
   end record;
113
   --  One entry of the internal handling repository
114

115
   Recording_Requested : Boolean := False;
116

117
   package Handling_Repository is new GNAT.Table
118
     (Repository_Entry,
119
      Int,
120
      1,
121
      5,
122
      10);
123
   --  The internal handling repository
124

125
   procedure May_Be_Append_Handling_Entry
126
     (E          : Node_Id;
127
      Comparison : Comparison_Kind;
128
      Handling   : Handling_Kind;
129
      A          : Node_Id);
130
   --  Add a new entry corresponding to the given parameters to the
131
   --  internal handling repository. The addition is only done in case
132
   --  the user requested explicitely the recording of handling
133

134
   function Bind_Transport_API_Internal_Name (P : Node_Id) return Name_Id;
135
   --  For code factorization purpose
136

137
   ----------------------
138
   -- Create_Directory --
139
   ----------------------
140

141 2
   procedure Create_Directory (Dir_Full_Name : Name_Id) is
142 1
      Dir_Full_String : constant String := Get_Name_String (Dir_Full_Name);
143
   begin
144 2
      if Is_Regular_File (Dir_Full_String)
145 2
        or else Is_Symbolic_Link (Dir_Full_String)
146
      then
147 0
         Display_Error
148
           ("Cannot create " &
149 0
            Dir_Full_String &
150
            " because there is a file with the same name",
151
            Fatal => True);
152 0
         return;
153
      end if;
154

155 2
      if Is_Directory (Dir_Full_String) then
156 2
         if Dir_Full_String /= "." then
157 2
            Display_Error
158 1
              (Dir_Full_String & " already exists",
159
               Fatal   => False,
160
               Warning => True);
161
         end if;
162 2
         return;
163
      end if;
164

165
      --  The directory name does not clash with anything, create it
166

167 2
      Create_Directory (Dir_Full_String);
168 2
   end Create_Directory;
169

170
   ---------------------
171
   -- Enter_Directory --
172
   ---------------------
173

174 2
   procedure Enter_Directory (Dirname : Name_Id) is
175 0
      use Directories_Stack;
176

177 2
      Current_Dir : constant Name_Id := Get_String_Name (Current_Directory);
178

179
   begin
180 2
      Increment_Last;
181 1
      Table (Last) := Current_Dir;
182 1
      Display_Debug_Message ("Left    : " & Get_Name_String (Current_Dir));
183 2
      Set_Directory (Get_Name_String (Dirname));
184 1
      Display_Debug_Message ("Entered : " & Get_Name_String (Dirname));
185 2
   end Enter_Directory;
186

187
   ---------------------
188
   -- Leave_Directory --
189
   ---------------------
190

191 2
   procedure Leave_Directory is
192
      use Directories_Stack;
193

194 1
      Last_Directory : constant Name_Id := Table (Last);
195

196
   begin
197 2
      Decrement_Last;
198 1
      Display_Debug_Message ("Left    : " & Current_Directory);
199 2
      Set_Directory (Get_Name_String (Last_Directory));
200 1
      Display_Debug_Message ("Entered : " & Get_Name_String (Last_Directory));
201 2
   end Leave_Directory;
202

203
   -----------------------------
204
   -- Add_Directory_Separator --
205
   -----------------------------
206

207 2
   function Add_Directory_Separator (Path : Name_Id) return Name_Id is
208
   begin
209 2
      Get_Name_String (Path);
210 1
      if Name_Buffer (Name_Len) /= Directory_Separator then
211 2
         Add_Char_To_Name_Buffer (Directory_Separator);
212
      end if;
213 2
      return Name_Find;
214
   end Add_Directory_Separator;
215

216
   --------------------------------
217
   -- Remove_Directory_Separator --
218
   --------------------------------
219

220 2
   function Remove_Directory_Separator (Path : Name_Id) return Name_Id is
221
   begin
222 2
      Get_Name_String (Path);
223

224 1
      if Name_Buffer (Name_Len) = Directory_Separator then
225 1
         Name_Len := Name_Len - 1;
226
      end if;
227 2
      return Name_Find;
228
   end Remove_Directory_Separator;
229

230 1
   function Remove_Directory_Separator (Path : String) return String is
231
   begin
232 2
      if Path'Length >= 1 and then
233 1
        Path (Path'Last) = Directory_Separator
234
      then
235 1
         return Path (Path'First .. Path'Last - 1);
236
      end if;
237 0
      return Path;
238
   end Remove_Directory_Separator;
239

240
   --------------------
241
   -- Copy_Directory --
242
   --------------------
243

244 1
   procedure Copy_Directory (From : String; Dest : String) is
245

246 1
      procedure Process_Entry (Directory_Entry : Directory_Entry_Type) is
247
      begin
248 2
         case Kind (Full_Name (Directory_Entry)) is
249 2
            when Ordinary_File =>
250 2
               Copy_File (Full_Name (Directory_Entry),
251
                          Dest & "/"
252 1
                            & Simple_Name (Simple_Name (Directory_Entry)));
253

254 2
            when Directory =>
255 1
               if  Simple_Name (Simple_Name (Directory_Entry)) /= "" and then
256 1
                 Simple_Name (Simple_Name (Directory_Entry)) /= ".." and then
257 1
                 Simple_Name (Simple_Name (Directory_Entry)) /= "."
258
               then
259 2
                  Copy_Directory
260 2
                    (Full_Name (Directory_Entry),
261 2
                     Compose (Dest, Simple_Name (Directory_Entry)));
262
               end if;
263

264 0
            when others => null;
265 1
         end case;
266 2
      end Process_Entry;
267

268
   begin
269 2
      if Kind (From) = Directory then
270 2
         Create_Path (Dest);
271
      else
272 0
         raise Program_Error with "Invalid kind for " & From;
273
      end if;
274

275 2
      Search (From, "", Process => Process_Entry'Access);
276 2
   end Copy_Directory;
277

278
   ----------------------------------
279
   -- May_Be_Append_Handling_Entry --
280
   ----------------------------------
281

282 2
   procedure May_Be_Append_Handling_Entry
283
     (E          : Node_Id;
284
      Comparison : Comparison_Kind;
285
      Handling   : Handling_Kind;
286
      A          : Node_Id)
287
   is
288
      package HR renames Handling_Repository;
289 2
      The_Entry : constant Repository_Entry :=
290
        Repository_Entry'
291
          (E => E, Comparison => Comparison, Handling => Handling, A => A);
292
   begin
293 2
      if Recording_Requested then
294 2
         HR.Increment_Last;
295 1
         HR.Table (HR.Last) := The_Entry;
296
      end if;
297 1
   end May_Be_Append_Handling_Entry;
298

299
   -------------------------------
300
   -- Start_Recording_Handlings --
301
   -------------------------------
302

303 2
   procedure Start_Recording_Handlings is
304
   begin
305 2
      if Recording_Requested then
306 0
         raise Program_Error
307
           with "Consecutive calls to Start_Recording_Handlings are forbidden";
308
      else
309 2
         Recording_Requested := True;
310
      end if;
311 2
   end Start_Recording_Handlings;
312

313
   ------------------------------
314
   -- Stop_Recording_Handlings --
315
   ------------------------------
316

317 0
   procedure Stop_Recording_Handlings is
318
   begin
319 0
      Recording_Requested := False;
320 0
   end Stop_Recording_Handlings;
321

322
   ---------------------
323
   -- Reset_Handlings --
324
   ---------------------
325

326 2
   procedure Reset_Handlings is
327
      package HR renames Handling_Repository;
328

329 2
      Index     : Int := HR.First;
330 2
      The_Entry : Repository_Entry;
331
   begin
332
      --  Disable the user handling request. It is important to do
333
      --  this at the beginning to avoid adding new entries when
334
      --  resetting.
335

336 2
      Recording_Requested := False;
337

338 2
      while Index <= HR.Last loop
339 1
         The_Entry := HR.Table (Index);
340

341
         --  Reset the handling information
342

343 2
         Set_Handling
344
           (The_Entry.E,
345
            The_Entry.Comparison,
346
            The_Entry.Handling,
347
            No_Node);
348

349 1
         Index := Index + 1;
350 2
      end loop;
351

352
      --  Deallocate and reinitialize the repository
353

354 2
      HR.Free;
355 2
      HR.Init;
356 1
   end Reset_Handlings;
357

358
   --------------------
359
   -- Normalize_Name --
360
   --------------------
361

362 2
   function Normalize_Name
363
     (Name      : Name_Id;
364
      Ada_Style : Boolean := False) return Name_Id
365
   is
366 2
      Normalized_Name : Name_Id;
367
   begin
368
      --  FIXME: The algorithm does not ensure a bijection between
369
      --  the input and the output. It should be improved.
370

371 2
      if Name = No_Name then
372 0
         Normalized_Name := Name;
373
      else
374 2
         declare
375 1
            Initial_Name : constant String := Get_Name_String (Name);
376
         begin
377 2
            Name_Len := 0;
378

379 2
            for Index in Initial_Name'First .. Initial_Name'Last loop
380 2
               if Initial_Name (Index) = '.' then
381 2
                  Add_Char_To_Name_Buffer ('_');
382 2
                  if Ada_Style then
383 2
                     Add_Char_To_Name_Buffer ('_');
384
                  end if;
385 2
               elsif Initial_Name (Index) = '-' then
386 2
                  Add_Char_To_Name_Buffer ('_');
387 2
                  if Ada_Style then
388 0
                     Add_Char_To_Name_Buffer ('_');
389
                  end if;
390 2
               elsif Initial_Name (Index) = ':' then
391 2
                  Add_Char_To_Name_Buffer ('_');
392 2
                  if Ada_Style then
393 0
                     Add_Char_To_Name_Buffer ('_');
394
                  end if;
395

396
               else
397 2
                  Add_Char_To_Name_Buffer (Initial_Name (Index));
398
               end if;
399 2
            end loop;
400

401 2
            Normalized_Name := Name_Find;
402 2
         end;
403
      end if;
404

405 2
      return Normalized_Name;
406
   end Normalize_Name;
407

408
   -----------------------------------
409
   -- Fully_Qualified_Instance_Name --
410
   -----------------------------------
411

412 2
   function Fully_Qualified_Instance_Name (E : Node_Id) return Name_Id is
413 2
      Current_Node : Node_Id := Parent_Subcomponent (E);
414 2
      Current_Name : Name_Id;
415

416
   begin
417 2
      Set_Str_To_Name_Buffer ("");
418 2
      Get_Name_String (Normalize_Name (Name (Identifier (Current_Node))));
419 2
      Current_Name := Name_Find;
420 2
      Current_Node := Parent_Component (Current_Node);
421

422 2
      while Present (Current_Node) loop
423 2
         exit when No (Parent_Subcomponent (Current_Node));
424

425 2
         Get_Name_String
426 2
           (Normalize_Name
427 2
              (Name (Identifier (Parent_Subcomponent (Current_Node)))));
428 2
         Set_Str_To_Name_Buffer
429 2
           (Get_Name_String (Name_Find) &
430 1
            "_" &
431 2
            Get_Name_String (Current_Name));
432 2
         Current_Name := Name_Find;
433

434 2
         Current_Node := Parent_Component (Parent_Subcomponent (Current_Node));
435 2
      end loop;
436

437 2
      return Current_Name;
438
   end Fully_Qualified_Instance_Name;
439

440
   ------------------
441
   -- Is_Namespace --
442
   ------------------
443

444 0
   function Is_Namespace (N : Node_Id) return Boolean is
445
   begin
446 0
      return Kind (N) = K_Namespace_Instance;
447
   end Is_Namespace;
448

449
   ----------------
450
   -- Is_Delayed --
451
   ----------------
452

453 2
   function Is_Delayed (E : Node_Id) return Boolean is
454 2
      C : Node_Id;
455 2
      S : Node_Id;
456
   begin
457
      pragma Assert
458 1
        (Kind (E) = K_Port_Spec_Instance and then not Is_Event (E));
459

460 2
      if not AAU.Is_Empty (Sources (E)) then
461 2
         C := Extra_Item (First_Node (Sources (E)));
462

463 1
         case AADL_Version is
464
            when AADL_V1 =>
465 0
               if ATN.Category (Corresponding_Declaration (C)) =
466
                 Connection_Type'Pos (CT_Data_Delayed)
467
               then
468 0
                  return True;
469
               else
470
                  --  Recurse through the connection path
471

472 0
                  S := Item (First_Node (Sources (E)));
473

474 0
                  return S /= E
475 0
                    and then Kind (S) = K_Port_Spec_Instance
476 0
                    and then Is_Delayed (S);
477
               end if;
478

479
            when AADL_V2 =>
480 2
               if Get_Port_Timing (E) = Port_Timing_Delayed then
481 0
                  return True;
482
               else
483
                  --  Recurse through the connection path
484

485 2
                  S := Item (First_Node (Sources (E)));
486

487 2
                  return S /= E
488 2
                    and then Kind (S) = K_Port_Spec_Instance
489 1
                    and then Is_Delayed (S);
490
               end if;
491
         end case;
492
      end if;
493

494 2
      return False;
495
   end Is_Delayed;
496

497
   -----------------------
498
   -- Has_In_Parameters --
499
   -----------------------
500

501 0
   function Has_In_Parameters (E : Node_Id) return Boolean is
502 0
      F : Node_Id;
503
   begin
504 0
      if not AAU.Is_Empty (Features (E)) then
505 0
         F := First_Node (Features (E));
506

507 0
         while Present (F) loop
508 0
            if Kind (F) = K_Parameter_Instance and then Is_In (F) then
509 0
               return True;
510
            end if;
511

512 0
            F := Next_Node (F);
513 0
         end loop;
514
      end if;
515

516 0
      return False;
517
   end Has_In_Parameters;
518

519
   ------------------------
520
   -- Has_Out_Parameters --
521
   ------------------------
522

523 0
   function Has_Out_Parameters (E : Node_Id) return Boolean is
524 0
      F : Node_Id;
525
   begin
526 0
      if not AAU.Is_Empty (Features (E)) then
527 0
         F := First_Node (Features (E));
528

529 0
         while Present (F) loop
530 0
            if Kind (F) = K_Parameter_Instance and then Is_Out (F) then
531 0
               return True;
532
            end if;
533

534 0
            F := Next_Node (F);
535 0
         end loop;
536
      end if;
537

538 0
      return False;
539
   end Has_Out_Parameters;
540

541
   ------------------
542
   -- Has_In_Ports --
543
   ------------------
544

545 2
   function Has_In_Ports (E : Node_Id) return Boolean is
546 2
      F : Node_Id;
547
   begin
548 2
      if not AAU.Is_Empty (Features (E)) then
549 2
         F := First_Node (Features (E));
550

551 2
         while Present (F) loop
552 2
            if Kind (F) = K_Port_Spec_Instance and then Is_In (F) then
553 2
               return True;
554
            end if;
555

556 2
            F := Next_Node (F);
557 2
         end loop;
558
      end if;
559

560 2
      return False;
561
   end Has_In_Ports;
562

563
   ------------------------
564
   -- Has_In_Event_Ports --
565
   ------------------------
566

567 2
   function Has_In_Event_Ports (E : Node_Id) return Boolean is
568 2
      F : Node_Id;
569
   begin
570 2
      if not AAU.Is_Empty (Features (E)) then
571 2
         F := First_Node (Features (E));
572

573 2
         while Present (F) loop
574 2
            if Kind (F) = K_Port_Spec_Instance
575 2
              and then Is_In (F)
576 2
              and then Is_Event (F)
577
            then
578 2
               return True;
579
            end if;
580

581 2
            F := Next_Node (F);
582 2
         end loop;
583
      end if;
584

585 2
      return False;
586
   end Has_In_Event_Ports;
587

588
   -------------------
589
   -- Has_Out_Ports --
590
   -------------------
591

592 2
   function Has_Out_Ports (E : Node_Id) return Boolean is
593 2
      F : Node_Id;
594
   begin
595 2
      if not AAU.Is_Empty (Features (E)) then
596 2
         F := First_Node (Features (E));
597

598 2
         while Present (F) loop
599 2
            if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
600 2
               return True;
601
            end if;
602

603 2
            F := Next_Node (F);
604 2
         end loop;
605
      end if;
606

607 2
      return False;
608
   end Has_Out_Ports;
609

610
   -------------------------
611
   -- Has_Out_Event_Ports --
612
   -------------------------
613

614 2
   function Has_Out_Event_Ports (E : Node_Id) return Boolean is
615 2
      F : Node_Id;
616
   begin
617 2
      if not AAU.Is_Empty (Features (E)) then
618 2
         F := First_Node (Features (E));
619

620 2
         while Present (F) loop
621 2
            if Kind (F) = K_Port_Spec_Instance
622 2
              and then Is_Out (F)
623 2
              and then Is_Event (F)
624
            then
625 2
               return True;
626
            end if;
627

628 2
            F := Next_Node (F);
629 2
         end loop;
630
      end if;
631

632 2
      return False;
633
   end Has_Out_Event_Ports;
634

635
   ---------------
636
   -- Has_Ports --
637
   ---------------
638

639 2
   function Has_Ports (E : Node_Id) return Boolean is
640 2
      F : Node_Id;
641
   begin
642 2
      if not AAU.Is_Empty (Features (E)) then
643 2
         F := First_Node (Features (E));
644

645 2
         while Present (F) loop
646 2
            if Kind (F) = K_Port_Spec_Instance then
647 2
               return True;
648
            end if;
649

650 2
            F := Next_Node (F);
651 2
         end loop;
652
      end if;
653

654 2
      return False;
655
   end Has_Ports;
656

657
   ----------------------
658
   -- Has_Output_Ports --
659
   ----------------------
660

661 0
   function Has_Output_Ports (E : Node_Id) return Boolean is
662 0
      F : Node_Id;
663
   begin
664 0
      if not AAU.Is_Empty (Features (E)) then
665 0
         F := First_Node (Features (E));
666

667 0
         while Present (F) loop
668 0
            if Kind (F) = K_Port_Spec_Instance and then Is_Out (F) then
669 0
               return True;
670
            end if;
671

672 0
            F := Next_Node (F);
673 0
         end loop;
674
      end if;
675

676 0
      return False;
677
   end Has_Output_Ports;
678

679
   ---------------------
680
   -- Has_Input_Ports --
681
   ---------------------
682

683 0
   function Has_Input_Ports (E : Node_Id) return Boolean is
684 0
      F : Node_Id;
685
   begin
686 0
      if not AAU.Is_Empty (Features (E)) then
687 0
         F := First_Node (Features (E));
688

689 0
         while Present (F) loop
690 0
            if Kind (F) = K_Port_Spec_Instance and then Is_In (F) then
691 0
               return True;
692
            end if;
693

694 0
            F := Next_Node (F);
695 0
         end loop;
696
      end if;
697

698 0
      return False;
699
   end Has_Input_Ports;
700

701
   ---------------
702
   -- Has_Modes --
703
   ---------------
704

705 2
   function Has_Modes (E : Node_Id) return Boolean is
706
   begin
707 1
      pragma Assert (Kind (E) = K_Component_Instance);
708

709 2
      return not AAU.Is_Empty (Modes (E));
710
   end Has_Modes;
711

712
   ----------------------
713
   -- Get_Source_Ports --
714
   ----------------------
715

716 2
   function Get_Source_Ports (P : Node_Id) return List_Id is
717
      function Rec_Get_Source_Ports
718
        (P : Node_Id;
719
         B : Node_Id := No_Node) return List_Id;
720
      --  Recursive internal routine
721

722
      --------------------------
723
      -- Rec_Get_Source_Ports --
724
      --------------------------
725

726 2
      function Rec_Get_Source_Ports
727
        (P : Node_Id;
728
         B : Node_Id := No_Node) return List_Id
729
      is
730 2
         Result : constant List_Id := New_List (K_List_Id, No_Location);
731 2
         C      : Node_Id;
732 2
         S      : Node_Id;
733 2
         Bus    : Node_Id;
734
      begin
735 2
         if AAU.Is_Empty (Sources (P)) then
736 2
            AAU.Append_Node_To_List (Make_Node_Container (P, B), Result);
737
         end if;
738

739 2
         S := First_Node (Sources (P));
740

741 2
         while Present (S) loop
742 2
            if Kind (Item (S)) = K_Port_Spec_Instance
743 2
              and then Parent_Component (Item (S)) /= No_Node
744 2
              and then Is_Thread (Parent_Component (Item (S)))
745
            then
746
               --  We reached our end point, append it to the result list
747

748 2
               AAU.Append_Node_To_List
749 2
                 (Make_Node_Container (Item (S), B),
750
                  Result);
751

752 2
            elsif Kind (Item (S)) = K_Port_Spec_Instance
753 2
              and then Parent_Component (Item (S)) /= No_Node
754 2
              and then Is_Process_Or_Device (Parent_Component (Item (S)))
755
            then
756

757 2
               if Is_In (Item (S)) then
758
                  --  See whether the connection to the process is
759
                  --  bound to a bus.
760

761 2
                  C := Extra_Item (S);
762

763 2
                  if No (C) then
764
                     --  There has been definitly a bug while
765
                     --  expanding connections.
766

767 0
                     raise Program_Error with "Wrong expansion of connections";
768
                  end if;
769

770
                  --  Get the bus of the connection
771

772 2
                  Bus := Get_Bound_Bus (C, False);
773
               else
774 2
                  Bus := No_Node;
775
               end if;
776

777 1
               if Present (B) and then Present (Bus) and then B /= Bus then
778 0
                  Display_Located_Error
779 0
                    (Loc (C),
780
                     "This connection is involved in a data flow" &
781
                     " mapped to several different buses",
782
                     Fatal => True);
783
               end if;
784

785
               --  Fetch recursively all the sources of S
786

787 2
               AAU.Append_Node_To_List
788 2
                 (First_Node (Rec_Get_Source_Ports (Item (S), Bus)),
789
                  Result);
790

791 2
            elsif Kind (Item (S)) = K_Port_Spec_Instance
792 0
              and then Present (Parent_Component (Item (S)))
793 0
              and then Is_System (Parent_Component (Item (S)))
794
            then
795 0
               AAU.Append_Node_To_List
796 0
                 (First_Node (Rec_Get_Source_Ports (Item (S), No_Node)),
797
                  Result);
798

799 2
            elsif Kind (Item (S)) = K_Parameter_Instance
800 2
              and then Present (Parent_Component (Item (S)))
801 2
              and then Is_Subprogram (Parent_Component (Item (S)))
802
            then
803 2
               AAU.Append_Node_To_List
804 2
                 (Make_Node_Container (Item (S), B),
805
                  Result);
806

807
            else
808 0
               Display_Located_Error
809 0
                 (Loc (P),
810
                  "This port has a source of a non supported kind",
811
                  Fatal => True);
812
            end if;
813

814 2
            S := Next_Node (S);
815 2
         end loop;
816

817 2
         return Result;
818
      end Rec_Get_Source_Ports;
819

820
   begin
821 2
      if AAU.Is_Empty (Sources (P)) then
822 2
         return No_List;
823
      else
824 2
         return Rec_Get_Source_Ports (P, No_Node);
825
      end if;
826
   end Get_Source_Ports;
827

828
   ---------------------------
829
   -- Get_Destination_Ports --
830
   ---------------------------
831

832 2
   function Get_Destination_Ports
833
     (P             : Node_Id;
834
      Custom_Parent : Node_Id := No_Node) return List_Id
835
   is
836

837
      function Rec_Get_Destination_Ports
838
        (P             : Node_Id;
839
         B             : Node_Id := No_Node;
840
         Custom_Parent : Node_Id := No_Node) return List_Id;
841
      --  Recursive internal routine
842

843
      -------------------------------
844
      -- Rec_Get_Destination_Ports --
845
      -------------------------------
846

847 2
      function Rec_Get_Destination_Ports
848
        (P             : Node_Id;
849
         B             : Node_Id := No_Node;
850
         Custom_Parent : Node_Id := No_Node) return List_Id
851
      is
852 2
         Result : constant List_Id := New_List (K_List_Id, No_Location);
853 2
         C      : Node_Id;
854 2
         D      : Node_Id;
855 2
         Bus    : Node_Id;
856
      begin
857 2
         D := First_Node (Destinations (P));
858

859 2
         while Present (D) loop
860 2
            if Kind (Item (D)) = K_Port_Spec_Instance
861 2
              and then Parent_Component (Item (D)) /= No_Node
862 2
              and then Is_Thread (Parent_Component (Item (D)))
863
            then
864
               --  We reached our end point, append it to the result list
865

866 2
               AAU.Append_Node_To_List
867 2
                 (Make_Node_Container (Item (D), B),
868
                  Result);
869

870 2
            elsif Kind (Item (D)) = K_Port_Spec_Instance
871 2
              and then Parent_Component (Item (D)) /= No_Node
872 2
              and then Is_Process (Parent_Component (Item (D)))
873
            then
874 2
               if Is_In (Item (D)) then
875
                  --  See whether the connection to the process is
876
                  --  bound to a bus.
877

878 2
                  C := Extra_Item (D);
879

880 2
                  if No (C) then
881
                     --  There has been definitly a bug while
882
                     --  expanding connections.
883

884 0
                     raise Program_Error with "Wrong expansion of connections";
885
                  end if;
886

887
                  --  Get the bus of the connection
888

889 2
                  Bus := Get_Bound_Bus (C, False);
890
               else
891 2
                  Bus := No_Node;
892
               end if;
893

894 1
               if Present (B) and then Present (Bus) and then B /= Bus then
895 0
                  Display_Located_Error
896 0
                    (Loc (C),
897
                     "This connection is involved in a data flow" &
898
                     " mapped to several different buses",
899
                     Fatal => True);
900
               end if;
901

902
               --  Fetch recursively all the destinations of D
903

904 2
               AAU.Append_Node_To_List
905 2
                 (First_Node (Rec_Get_Destination_Ports (Item (D), Bus)),
906
                  Result);
907

908 2
            elsif Kind (Item (D)) = K_Port_Spec_Instance
909 2
              and then Parent_Component (Item (D)) /= No_Node
910 2
              and then Is_Device (Parent_Component (Item (D)))
911
            then
912
               --  We reached our end point, append it to the result list
913

914 2
               AAU.Append_Node_To_List
915 2
                 (Make_Node_Container (Item (D), B),
916
                  Result);
917

918 2
            elsif Custom_Parent /= No_Node
919 0
              and then Is_Device (Custom_Parent)
920 0
              and then Get_Port_By_Name (P, Custom_Parent) /= No_Node
921
            then
922 0
               AAU.Append_Node_To_List
923 0
                 (First_Node
924 0
                    (Rec_Get_Destination_Ports
925 0
                       (Get_Port_By_Name (P, Custom_Parent),
926
                        B,
927
                        No_Node)),
928
                  Result);
929

930 2
            elsif Kind (Item (D)) = K_Port_Spec_Instance
931 0
              and then Present (Parent_Component (Item (D)))
932 0
              and then Is_System (Parent_Component (Item (D)))
933
            then
934 0
               AAU.Append_Node_To_List
935 0
                 (First_Node (Rec_Get_Destination_Ports (Item (D), No_Node)),
936
                  Result);
937

938 2
            elsif Kind (Item (D)) = K_Parameter_Instance
939 2
              and then Present (Parent_Component (Item (D)))
940 2
              and then Is_Subprogram (Parent_Component (Item (D)))
941
            then
942 2
               AAU.Append_Node_To_List
943 2
                 (Make_Node_Container (Item (D), B),
944
                  Result);
945

946
            else
947 0
               Display_Located_Error
948 0
                 (Loc (P),
949
                  "This port has a destination of a non supported kind",
950
                  Fatal => True);
951
            end if;
952

953 2
            D := Next_Node (D);
954 2
         end loop;
955

956 2
         return Result;
957
      end Rec_Get_Destination_Ports;
958
   begin
959 2
      return Rec_Get_Destination_Ports (P, No_Node, Custom_Parent);
960
   end Get_Destination_Ports;
961

962
   ----------------------
963
   -- Get_Actual_Owner --
964
   ----------------------
965

966 2
   function Get_Actual_Owner (Spg_Call : Node_Id) return Node_Id is
967 2
      Spg            : constant Node_Id := Corresponding_Instance (Spg_Call);
968 2
      Data_Component : Node_Id;
969 2
      F              : Node_Id;
970
   begin
971
      --  If the subprogram call is not a method return No_Node
972

973 2
      if AAU.Is_Empty (Path (Spg_Call)) then
974 0
         return No_Node;
975
      end if;
976

977 2
      Data_Component := Item (First_Node (Path (Spg_Call)));
978

979
      --  Traverse all the required access of the subprogram instance
980
      --  and find the one corresponding to the owner data component.
981

982 2
      if not AAU.Is_Empty (Features (Spg)) then
983 2
         F := First_Node (Features (Spg));
984

985 2
         while Present (F) loop
986 2
            if Kind (F) = K_Subcomponent_Access_Instance then
987
               --  FIXME: We stop at the first met feature that
988
               --  corresponds to our criteria.
989

990
               --  The corresponding declaration of Data_Component is
991
               --  always a component type and not a component
992
               --  implementation. However the type of the feature F
993
               --  may be a component type as well as a component
994
               --  implementation. We test both cases.
995

996
               declare
997
                  Dcl_Data_Component : constant Node_Id :=
998 2
                    Corresponding_Declaration (Data_Component);
999
                  Dcl_F : constant Node_Id :=
1000 2
                    Corresponding_Declaration (Corresponding_Instance (F));
1001

1002
                  use Ocarina.ME_AADL.AADL_Tree.Nodes;
1003
               begin
1004
                  exit when
1005 2
                    (ATN.Kind (Dcl_F) = K_Component_Type
1006 0
                     and then Dcl_F = Dcl_Data_Component)
1007
                    or else
1008 2
                    (ATN.Kind (Dcl_F) = K_Component_Implementation
1009
                     and then
1010 2
                       ATN.Corresponding_Entity
1011 2
                         (ATN.Component_Type_Identifier (Dcl_F)) =
1012
                       Dcl_Data_Component);
1013
               end;
1014
            end if;
1015

1016 2
            F := Next_Node (F);
1017 2
         end loop;
1018
      end if;
1019

1020
      --  If no feature matched, raise an error
1021

1022 2
      if AAU.Is_Empty (Features (Spg)) or else No (F) then
1023 0
         Display_Located_Error
1024 0
           (Loc (Spg),
1025
            "Feature subprogram has not access to its owner component",
1026
            Fatal => True);
1027
      end if;
1028

1029 2
      return Get_Subcomponent_Access_Source (F);
1030
   end Get_Actual_Owner;
1031

1032
   ---------------------------
1033
   -- Get_Container_Process --
1034
   ---------------------------
1035

1036 2
   function Get_Container_Process (E : Node_Id) return Node_Id is
1037 1
      pragma Assert (Present (E));
1038
   begin
1039 1
      case Kind (E) is
1040 2
         when K_Call_Instance =>
1041 2
            return Get_Container_Process (Parent_Sequence (E));
1042

1043 2
         when K_Call_Sequence_Instance | K_Subcomponent_Instance =>
1044 2
            return Get_Container_Process (Parent_Component (E));
1045

1046 2
         when others =>
1047 2
            if Is_Thread (E)
1048 2
              or else Is_Subprogram (E)
1049 2
              or else AAU.Is_Data (E)
1050
            then
1051 2
               return Get_Container_Process (Parent_Subcomponent (E));
1052

1053 2
            elsif Is_Process (E) or else Is_Device (E) then
1054 2
               return Parent_Subcomponent (E);
1055

1056 2
            elsif Is_Abstract (E) then
1057
               --  It is allowed for a thread to be part of an
1058
               --  abstract component (e.g. a device driver). In this
1059
               --  case, we cannot retrieve the corresponding process
1060
               --  instance.
1061

1062 2
               return No_Node;
1063

1064
            else
1065 0
               raise Program_Error
1066
                 with "Wrong node kind in " &
1067
                 "Get_Container_Process: " &
1068 0
                 Kind (E)'Img &
1069 0
                 " " &
1070 0
                 Get_Category_Of_Component (E)'Img;
1071

1072
            end if;
1073
      end case;
1074
   end Get_Container_Process;
1075

1076
   --------------------------
1077
   -- Get_Container_Thread --
1078
   --------------------------
1079

1080 2
   function Get_Container_Thread (E : Node_Id) return Node_Id is
1081
   begin
1082 1
      case Kind (E) is
1083 2
         when K_Call_Instance =>
1084 2
            return Get_Container_Thread (Parent_Sequence (E));
1085

1086 2
         when K_Call_Sequence_Instance =>
1087 2
            return Parent_Component (E);
1088

1089 2
         when others =>
1090 2
            if Is_Subprogram (E) then
1091 2
               return Get_Container_Thread (Parent_Subcomponent (E));
1092
            else
1093 0
               raise Program_Error
1094
                 with "Wrong node kind in " &
1095 0
                 "Get_Container_Thread: " &
1096 0
                 Kind (E)'Img;
1097
            end if;
1098
      end case;
1099
   end Get_Container_Thread;
1100

1101
   --------------------------------
1102
   -- Get_Handling_Internal_Name --
1103
   --------------------------------
1104

1105 2
   function Get_Handling_Internal_Name
1106
     (E          : Node_Id;
1107
      Comparison : Comparison_Kind;
1108
      Handling   : Handling_Kind) return Name_Id
1109
   is
1110
   begin
1111 1
      case Comparison is
1112
         when By_Name =>
1113 2
            Get_Name_String (Map_Ada_Defining_Identifier (E));
1114
         --  Get_Name_String (Compute_Full_Name_Of_Instance (E));
1115

1116
         when By_Node =>
1117 1
            Set_Nat_To_Name_Buffer (Nat (E));
1118
      end case;
1119

1120 1
      Add_Str_To_Name_Buffer ("%Handling%" & Handling'Img);
1121

1122 2
      return Name_Find;
1123
   end Get_Handling_Internal_Name;
1124

1125
   ------------------
1126
   -- Set_Handling --
1127
   ------------------
1128

1129 2
   procedure Set_Handling
1130
     (E          : Node_Id;
1131
      Comparison : Comparison_Kind;
1132
      Handling   : Handling_Kind;
1133
      A          : Node_Id)
1134
   is
1135
      Internal_Name : constant Name_Id :=
1136 2
        Get_Handling_Internal_Name (E, Comparison, Handling);
1137

1138
   begin
1139 1
      Set_Name_Table_Info (Internal_Name, Nat (A));
1140 2
      May_Be_Append_Handling_Entry (E, Comparison, Handling, A);
1141 2
   end Set_Handling;
1142

1143
   ------------------
1144
   -- Get_Handling --
1145
   ------------------
1146

1147 2
   function Get_Handling
1148
     (E          : Node_Id;
1149
      Comparison : Comparison_Kind;
1150
      Handling   : Handling_Kind) return Node_Id
1151
   is
1152
      Internal_Name : constant Name_Id :=
1153 2
        Get_Handling_Internal_Name (E, Comparison, Handling);
1154
   begin
1155 2
      return Node_Id (Get_Name_Table_Info (Internal_Name));
1156
   end Get_Handling;
1157

1158
   --------------------
1159
   -- Bind_Two_Nodes --
1160
   --------------------
1161

1162 0
   function Bind_Two_Nodes (N_1 : Node_Id; N_2 : Node_Id) return Node_Id is
1163
      function Get_Binding_Internal_Name
1164
        (N_1 : Node_Id;
1165
         N_2 : Node_Id) return Name_Id;
1166
      --  Return an internal name id useful for the binding
1167

1168
      -------------------------------
1169
      -- Get_Binding_Internal_Name --
1170
      -------------------------------
1171

1172 0
      function Get_Binding_Internal_Name
1173
        (N_1 : Node_Id;
1174
         N_2 : Node_Id) return Name_Id
1175
      is
1176
      begin
1177 0
         Set_Nat_To_Name_Buffer (Nat (N_1));
1178 0
         Add_Str_To_Name_Buffer ("%Binding%");
1179 0
         Add_Nat_To_Name_Buffer (Nat (N_2));
1180 0
         return Name_Find;
1181
      end Get_Binding_Internal_Name;
1182

1183 0
      I_Name : constant Name_Id := Get_Binding_Internal_Name (N_1, N_2);
1184 0
      N      : Node_Id;
1185
   begin
1186
      --  If the Bind_Two_Nodes has already been called on N_1 and
1187
      --  N_1, return the result of the first call.
1188

1189 0
      if Get_Name_Table_Info (I_Name) /= 0 then
1190 0
         return Node_Id (Get_Name_Table_Info (I_Name));
1191
      end if;
1192

1193
      --  Otherwise, create a new binding node
1194

1195 0
      N := Make_Identifier (No_Location, No_Name, No_Name, No_Node);
1196 0
      Set_Name_Table_Info (I_Name, Int (N));
1197

1198 0
      return N;
1199
   end Bind_Two_Nodes;
1200

1201
   --------------------------------------
1202
   -- Bind_Transport_API_Internal_Name --
1203
   --------------------------------------
1204

1205 2
   function Bind_Transport_API_Internal_Name (P : Node_Id) return Name_Id is
1206
   begin
1207 1
      pragma Assert (Is_Process (P));
1208

1209 1
      Set_Nat_To_Name_Buffer (Nat (P));
1210 2
      Add_Str_To_Name_Buffer ("%transport%layer%binding%");
1211 2
      return Name_Find;
1212
   end Bind_Transport_API_Internal_Name;
1213

1214
   ------------------------
1215
   -- Bind_Transport_API --
1216
   ------------------------
1217

1218 2
   procedure Bind_Transport_API (P : Node_Id; T : Supported_Transport_APIs) is
1219 2
      I_Name : constant Name_Id := Bind_Transport_API_Internal_Name (P);
1220
   begin
1221 2
      Set_Name_Table_Byte (I_Name, Supported_Transport_APIs'Pos (T));
1222 2
   end Bind_Transport_API;
1223

1224
   -------------------------
1225
   -- Fetch_Transport_API --
1226
   -------------------------
1227

1228 2
   function Fetch_Transport_API
1229
     (P : Node_Id) return Supported_Transport_APIs
1230
   is
1231 2
      I_Name : constant Name_Id := Bind_Transport_API_Internal_Name (P);
1232
   begin
1233 1
      return Supported_Transport_APIs'Val (Get_Name_Table_Byte (I_Name));
1234
   end Fetch_Transport_API;
1235

1236
   -------------------------------
1237
   -- Map_Ada_Full_Feature_Name --
1238
   -------------------------------
1239

1240 2
   function Map_Ada_Full_Feature_Name
1241
     (E      : Node_Id;
1242
      Suffix : Character := ASCII.NUL) return Name_Id
1243
   is
1244
   begin
1245 2
      Get_Name_String
1246 2
        (Compute_Full_Name_Of_Instance
1247
           (Instance         => E,
1248
            Display_Name     => True,
1249
            Keep_Root_System => False));
1250 2
      Get_Name_String (ADU.To_Ada_Name (Name_Find));
1251

1252 2
      if Suffix /= ASCII.NUL then
1253 2
         Add_Str_To_Name_Buffer ('_' & Suffix);
1254
      end if;
1255

1256 2
      return Name_Find;
1257
   end Map_Ada_Full_Feature_Name;
1258

1259
   ----------------------------------
1260
   -- Map_Ada_Data_Type_Designator --
1261
   ----------------------------------
1262

1263 2
   function Map_Ada_Data_Type_Designator (E : Node_Id) return Node_Id is
1264 1
      pragma Assert (AAU.Is_Data (E));
1265

1266
   begin
1267 2
      return ADU.Extract_Designator
1268 2
          (ADN.Type_Definition_Node (Backend_Node (Identifier (E))));
1269
   end Map_Ada_Data_Type_Designator;
1270

1271
   ---------------------------------
1272
   -- Map_Ada_Full_Parameter_Name --
1273
   ---------------------------------
1274

1275 2
   function Map_Ada_Full_Parameter_Name
1276
     (Spg    : Node_Id;
1277
      P      : Node_Id;
1278
      Suffix : Character := ASCII.NUL) return Name_Id
1279
   is
1280
   begin
1281 1
      pragma Assert (Kind (P) = K_Parameter_Instance);
1282

1283 1
      if Kind (Spg) = K_Component_Instance and then Is_Subprogram (Spg) then
1284 0
         Get_Name_String (Compute_Full_Name_Of_Instance (Spg, True));
1285 2
      elsif Kind (Spg) = K_Call_Instance then
1286 2
         Get_Name_String (Display_Name (Identifier (Spg)));
1287
      else
1288 0
         raise Program_Error with "Wrong subprogram kind";
1289
      end if;
1290

1291 2
      Add_Char_To_Name_Buffer ('_');
1292 2
      Get_Name_String_And_Append (Display_Name (Identifier (P)));
1293

1294
      --  Convert the name to a valid Ada identifier name
1295

1296 2
      Get_Name_String (ADU.To_Ada_Name (Name_Find));
1297

1298 2
      if Suffix /= ASCII.NUL then
1299 0
         Add_Str_To_Name_Buffer ('_' & Suffix);
1300
      end if;
1301

1302 2
      return Name_Find;
1303
   end Map_Ada_Full_Parameter_Name;
1304

1305
   -----------------------------
1306
   -- Map_Ada_Enumerator_Name --
1307
   -----------------------------
1308

1309 2
   function Map_Ada_Enumerator_Name
1310
     (E      : Node_Id;
1311
      Server : Boolean := False) return Name_Id
1312
   is
1313 2
      Ada_Name_1 : Name_Id;
1314 2
      Ada_Name_2 : Name_Id;
1315
   begin
1316
      pragma Assert
1317 1
        (Is_Subprogram (E) or else Kind (E) = K_Subcomponent_Instance);
1318

1319 2
      if Is_Subprogram (E)
1320 2
        or else Is_Process (Corresponding_Instance (E))
1321 2
        or else Is_Device (Corresponding_Instance (E))
1322
      then
1323
         --  For subprograms and processes, the enumerator name is
1324
         --  mapped from the entity name.
1325

1326 2
         Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (E))));
1327 2
         Add_Str_To_Name_Buffer ("_K");
1328

1329 2
      elsif Is_Thread (Corresponding_Instance (E)) then
1330
         --  For threads, the enumerator name is mapped from the
1331
         --  containing process or abstract component name and the
1332
         --  thread subcomponent name.
1333

1334
         --  Verifiy that the thread is a subcomponent of a process,
1335
         --  or an abstract component (in the case of threads that
1336
         --  belong to a device driver).
1337

1338
         pragma Assert
1339 1
           (Is_Process (Parent_Component (E))
1340 2
            or else Is_Abstract (Parent_Component (E)));
1341

1342 2
         if Is_Process (Parent_Component (E)) then
1343
            Ada_Name_1 :=
1344 2
              ADU.To_Ada_Name
1345 2
                (Display_Name
1346 2
                   (Identifier (Parent_Subcomponent (Parent_Component (E)))));
1347

1348 2
         elsif Is_Abstract (Parent_Component (E)) then
1349
            Ada_Name_1 :=
1350 2
              ADU.To_Ada_Name
1351 2
                (Display_Name (Identifier (Parent_Component (E))));
1352

1353
         end if;
1354

1355 2
         Ada_Name_2 := ADU.To_Ada_Name (Display_Name (Identifier (E)));
1356

1357 2
         Get_Name_String (Ada_Name_1);
1358 2
         Add_Char_To_Name_Buffer ('_');
1359 2
         Get_Name_String_And_Append (Ada_Name_2);
1360 2
         Add_Str_To_Name_Buffer ("_K");
1361
      else
1362 0
         raise Program_Error
1363 0
           with "Wrong node kind for Map_Ada_Enumerator_Name " & Kind (E)'Img;
1364
      end if;
1365

1366 2
      if Server then
1367 0
         Add_Str_To_Name_Buffer ("_Server");
1368
      end if;
1369

1370 2
      return Name_Find;
1371 1
   end Map_Ada_Enumerator_Name;
1372

1373
   ---------------------------------
1374
   -- Map_Ada_Defining_Identifier --
1375
   ---------------------------------
1376

1377 2
   function Map_Ada_Defining_Identifier
1378
     (A      : Node_Id;
1379
      Suffix : String := "") return Name_Id
1380
   is
1381 2
      I         : Node_Id := A;
1382 2
      N         : Node_Id := No_Node;
1383 2
      J         : Node_Id;
1384 2
      Name_List : List_Id;
1385
   begin
1386 2
      if Kind (A) /= K_Identifier then
1387 2
         I := Identifier (A);
1388
      end if;
1389

1390 2
      if Kind (A) = K_Component_Instance then
1391 2
         N := Namespace (A);
1392

1393 2
      elsif Kind (A) = K_Subcomponent_Instance then
1394 2
         if Present (Parent_Component (A)) then
1395 2
            N := Namespace (Parent_Component (A));
1396
         end if;
1397
      end if;
1398

1399 2
      if N /= No_Node
1400 2
        and then Display_Name (Identifier (N)) /= No_Name
1401 2
        and then Get_Category_Of_Component (A) /= CC_Data
1402
      then
1403
         --  Use both namespace and identifier to build the Ada
1404
         --  defining identifier, to avoid collisions in the Ada
1405
         --  namespace.
1406

1407
         --  XXX Note: we do not handle data component types for now,
1408
         --  as their mapping is unclear for now, see Code generation
1409
         --  annex for more details.
1410

1411 2
         Name_List := AAU.Split_Name (N);
1412

1413 2
         J := First_Node (Name_List);
1414

1415 2
         if Present (J) then
1416 2
            Get_Name_String (To_Ada_Name (Display_Name (J)));
1417 2
            J := Next_Node (J);
1418

1419 2
            while Present (J) loop
1420 2
               Add_Str_To_Name_Buffer
1421 1
                 ("_" & Get_Name_String (Display_Name (J)));
1422 2
               J := Next_Node (J);
1423 2
            end loop;
1424
         end if;
1425 1
         Add_Str_To_Name_Buffer ("_" & Get_Name_String (Display_Name (I)));
1426

1427
      else
1428 2
         Get_Name_String (To_Ada_Name (Display_Name (I)));
1429
      end if;
1430

1431 2
      if Suffix /= "" then
1432 2
         Add_Str_To_Name_Buffer ("_" & Suffix);
1433
      end if;
1434

1435 2
      return Name_Find;
1436
   end Map_Ada_Defining_Identifier;
1437

1438 2
   function Map_Ada_Defining_Identifier
1439
     (A      : Node_Id;
1440
      Suffix : String := "") return Node_Id
1441
   is
1442
   begin
1443 2
      return Make_Defining_Identifier
1444 2
          (Map_Ada_Defining_Identifier (A, Suffix));
1445
   end Map_Ada_Defining_Identifier;
1446

1447
   ----------------------------
1448
   -- Map_Ada_Component_Name --
1449
   ----------------------------
1450

1451 2
   function Map_Ada_Component_Name (F : Node_Id) return Name_Id is
1452
   begin
1453 2
      Get_Name_String (To_Ada_Name (Display_Name (Identifier (F))));
1454 2
      Add_Str_To_Name_Buffer ("_DATA");
1455 2
      return Name_Find;
1456
   end Map_Ada_Component_Name;
1457

1458
   --------------------------------------------
1459
   -- Map_Ada_Protected_Aggregate_Identifier --
1460
   --------------------------------------------
1461

1462 2
   function Map_Ada_Protected_Aggregate_Identifier
1463
     (S : Node_Id;
1464
      A : Node_Id) return Node_Id
1465
   is
1466 2
      S_Name : Name_Id;
1467 2
      A_Name : Name_Id;
1468
   begin
1469
      pragma Assert
1470 1
        (Kind (S) = K_Subcomponent_Access_Instance
1471 2
         and then Kind (A) = K_Subcomponent_Instance);
1472

1473 2
      S_Name := To_Ada_Name (Display_Name (Identifier (S)));
1474 2
      A_Name := To_Ada_Name (Display_Name (Identifier (A)));
1475

1476 2
      Get_Name_String (S_Name);
1477 2
      Add_Char_To_Name_Buffer ('_');
1478 2
      Get_Name_String_And_Append (A_Name);
1479

1480 2
      return Make_Defining_Identifier (Name_Find);
1481
   end Map_Ada_Protected_Aggregate_Identifier;
1482

1483
   --------------------------------------
1484
   -- Map_Ada_Default_Value_Identifier --
1485
   --------------------------------------
1486

1487 2
   function Map_Ada_Default_Value_Identifier (D : Node_Id) return Node_Id is
1488 2
      I : Node_Id;
1489
   begin
1490 2
      if Kind (D) /= K_Identifier then
1491 2
         I := Identifier (D);
1492
      end if;
1493

1494 2
      Get_Name_String (To_Ada_Name (Display_Name (I)));
1495 2
      Add_Str_To_Name_Buffer ("_Default_Value");
1496 2
      return Make_Defining_Identifier (Name_Find);
1497
   end Map_Ada_Default_Value_Identifier;
1498

1499
   --------------------------------
1500
   -- Map_Ada_Package_Identifier --
1501
   --------------------------------
1502

1503 2
   function Map_Ada_Package_Identifier (E : Node_Id) return Node_Id is
1504 2
      Port_Name   : Name_Id;
1505 2
      Thread_Name : Name_Id;
1506
   begin
1507 1
      pragma Assert (AAU.Is_Data (E) or else Kind (E) = K_Port_Spec_Instance);
1508

1509 2
      if AAU.Is_Data (E) then
1510 2
         Get_Name_String (To_Ada_Name (Display_Name (Identifier (E))));
1511
      else
1512 0
         Port_Name   := To_Ada_Name (Display_Name (Identifier (E)));
1513
         Thread_Name :=
1514 0
           To_Ada_Name
1515 0
             (Display_Name
1516 0
                (Identifier (Parent_Subcomponent (Parent_Component (E)))));
1517 0
         Get_Name_String (Thread_Name);
1518 0
         Add_Char_To_Name_Buffer ('_');
1519 0
         Get_Name_String_And_Append (Port_Name);
1520
      end if;
1521

1522 2
      Add_Str_To_Name_Buffer ("_Pkg");
1523

1524 2
      return Make_Defining_Identifier (Name_Find);
1525
   end Map_Ada_Package_Identifier;
1526

1527
   -----------------------------------
1528
   -- Map_Ada_Subprogram_Identifier --
1529
   -----------------------------------
1530

1531 2
   function Map_Ada_Subprogram_Identifier (E : Node_Id) return Node_Id is
1532
      pragma Assert
1533 1
        (Is_Thread (E)
1534 2
         or else Is_Subprogram (E)
1535 2
         or else Kind (E) = K_Port_Spec_Instance);
1536

1537 2
      Spg_Name : Name_Id;
1538

1539
   begin
1540 2
      if Is_Subprogram (E)
1541 2
        and then Get_Source_Language (E) /= Language_Ada_95
1542
      then
1543 0
         Display_Located_Error
1544 0
           (Loc (E),
1545
            "This is not an Ada subprogram",
1546
            Fatal => True);
1547
      end if;
1548

1549
      --  Get the subprogram name
1550

1551 2
      if Is_Subprogram (E) then
1552 2
         Spg_Name := Get_Source_Name (E);
1553

1554 2
      elsif Is_Thread (E) then
1555 2
         Spg_Name := Get_Thread_Compute_Entrypoint (E);
1556

1557
      else
1558 2
         Spg_Name := Get_Port_Compute_Entrypoint (E);
1559
      end if;
1560

1561 2
      return Map_Ada_Subprogram_Identifier (Spg_Name);
1562
   end Map_Ada_Subprogram_Identifier;
1563

1564
   -----------------------------------
1565
   -- Map_Ada_Subprogram_Identifier --
1566
   -----------------------------------
1567

1568 2
   function Map_Ada_Subprogram_Identifier (N : Name_Id) return Node_Id is
1569 2
      P_Name : Name_Id;
1570 2
      Result : Node_Id;
1571 2
      D      : Node_Id;
1572
   begin
1573
      --  Get the package implementation and add the 'with' clause
1574

1575 2
      P_Name := Unit_Name (N);
1576

1577 2
      if P_Name = No_Name then
1578 0
         Display_Error
1579
           ("You must give the subprogram implementation name",
1580
            Fatal => True);
1581
      end if;
1582

1583 2
      D := Make_Designator (P_Name);
1584 2
      ADN.Set_Corresponding_Node
1585 2
        (ADN.Defining_Identifier (D),
1586 2
         New_Node (ADN.K_Package_Specification));
1587 2
      Add_With_Package (D);
1588

1589
      --  Get the full implementation name
1590

1591 2
      Get_Name_String (Local_Name (N));
1592 2
      Result := Make_Defining_Identifier (Name_Find);
1593 2
      Set_Homogeneous_Parent_Unit_Name (Result, D);
1594 2
      return Result;
1595
   end Map_Ada_Subprogram_Identifier;
1596

1597
   -----------------------------
1598
   -- Map_Ada_Subprogram_Spec --
1599
   -----------------------------
1600

1601 2
   function Map_Ada_Subprogram_Spec (S : Node_Id) return Node_Id is
1602 2
      Profile : constant List_Id := ADU.New_List (ADN.K_Parameter_Profile);
1603 2
      Param   : Node_Id;
1604 2
      Mode    : Mode_Id;
1605 2
      F       : Node_Id;
1606 2
      N       : Node_Id;
1607 2
      D       : Node_Id;
1608 2
      Field   : Node_Id;
1609
   begin
1610 1
      pragma Assert (Is_Subprogram (S));
1611

1612
      --  We build the parameter profile of the subprogram instance by
1613
      --  adding:
1614

1615
      --  First, the parameter features mapping
1616

1617 2
      if not AAU.Is_Empty (Features (S)) then
1618 2
         F := First_Node (Features (S));
1619

1620 2
         while Present (F) loop
1621 2
            if Kind (F) = K_Parameter_Instance then
1622 2
               if Is_In (F) and then Is_Out (F) then
1623 0
                  Mode := Mode_Inout;
1624 2
               elsif Is_Out (F) then
1625 2
                  Mode := Mode_Out;
1626 2
               elsif Is_In (F) then
1627 2
                  Mode := Mode_In;
1628
               else
1629 0
                  Display_Located_Error
1630 0
                    (Loc (F),
1631
                     "Unspecified parameter mode",
1632
                     Fatal => True);
1633
               end if;
1634

1635 2
               D := Corresponding_Instance (F);
1636

1637
               Param :=
1638 2
                 ADU.Make_Parameter_Specification
1639 2
                   (Map_Ada_Defining_Identifier (F),
1640 2
                    Map_Ada_Data_Type_Designator (D),
1641
                    Mode);
1642

1643 2
               ADU.Append_Node_To_List (Param, Profile);
1644
            end if;
1645

1646 2
            F := Next_Node (F);
1647 2
         end loop;
1648
      end if;
1649

1650
      --  Second, the data access mapping. The data accesses are not
1651
      --  mapped in the case of pure call sequence subprogram because
1652
      --  they are used only to close the access chain.
1653

1654 2
      if Get_Subprogram_Kind (S) /= Subprogram_Pure_Call_Sequence then
1655 2
         if not AAU.Is_Empty (Features (S)) then
1656 2
            F := First_Node (Features (S));
1657

1658 2
            while Present (F) loop
1659 2
               if Kind (F) = K_Subcomponent_Access_Instance then
1660 1
                  case Get_Required_Data_Access (Corresponding_Instance (F)) is
1661 0
                     when Access_Read_Only =>
1662 0
                        Mode := Mode_In;
1663 0
                     when Access_Write_Only =>
1664 0
                        Mode := Mode_Out;
1665 0
                     when Access_Read_Write =>
1666 0
                        Mode := Mode_Inout;
1667 2
                     when Access_None =>
1668
                        --  By default, we allow read/write access
1669

1670 2
                        Mode := Mode_Inout;
1671 0
                     when others =>
1672 0
                        Display_Located_Error
1673 0
                          (Loc (F),
1674
                           "Unsupported required access",
1675
                           Fatal => True);
1676 1
                  end case;
1677

1678 2
                  D := Corresponding_Instance (F);
1679

1680 1
                  case Get_Data_Representation (D) is
1681 0
                     when Data_Integer     |
1682
                       Data_Boolean        |
1683
                       Data_Float          |
1684
                       Data_Fixed          |
1685
                       Data_String         |
1686
                       Data_Wide_String    |
1687
                       Data_Character      |
1688
                       Data_Wide_Character |
1689
                       Data_Array          =>
1690
                        --  If the data component is a simple data
1691
                        --  component (not a structure), we simply add a
1692
                        --  parameter with the computed mode and with a
1693
                        --  type mapped from the data component.
1694

1695
                        Param :=
1696 0
                          ADU.Make_Parameter_Specification
1697 0
                            (Map_Ada_Defining_Identifier (F),
1698 0
                             Map_Ada_Data_Type_Designator (D),
1699
                             Mode);
1700 0
                        ADU.Append_Node_To_List (Param, Profile);
1701

1702 2
                     when Data_Struct | Data_With_Accessors =>
1703
                        --  If the data component is a complex data
1704
                        --  component (which has subcomponents), we add a
1705
                        --  parameter with the computed mode and with a
1706
                        --  type mapped from each subcomponent type.
1707

1708 2
                        Field := First_Node (Subcomponents (D));
1709

1710 2
                        while Present (Field) loop
1711
                           --  The parameter name is mapped from the
1712
                           --  container data component and the data
1713
                           --  subcomponent.
1714

1715 2
                           if AAU.Is_Data (Corresponding_Instance (Field)) then
1716
                              Param :=
1717 2
                                ADU.Make_Parameter_Specification
1718 2
                                  (Map_Ada_Protected_Aggregate_Identifier
1719
                                     (F,
1720
                                      Field),
1721 2
                                   Map_Ada_Data_Type_Designator
1722 2
                                     (Corresponding_Instance (Field)),
1723
                                   Mode);
1724 2
                              ADU.Append_Node_To_List (Param, Profile);
1725
                           end if;
1726

1727 2
                           Field := Next_Node (Field);
1728 2
                        end loop;
1729

1730 0
                     when others =>
1731 0
                        Display_Located_Error
1732 0
                          (Loc (F),
1733
                           "Unsupported data type",
1734
                           Fatal => True);
1735 1
                  end case;
1736
               end if;
1737

1738 2
               F := Next_Node (F);
1739 2
            end loop;
1740
         end if;
1741
      end if;
1742

1743
      --  Last, if the subprogram has OUT ports, we add an additional
1744
      --  Status parameter.
1745

1746 2
      if Has_Out_Ports (S) then
1747
         Param :=
1748 2
           ADU.Make_Parameter_Specification
1749 2
             (Make_Defining_Identifier (PN (P_Status)),
1750 2
              Extract_Designator
1751 2
                (ADN.Type_Definition_Node (Backend_Node (Identifier (S)))),
1752
              Mode_Inout);
1753 2
         ADU.Append_Node_To_List (Param, Profile);
1754
      end if;
1755

1756
      N :=
1757 2
        ADU.Make_Subprogram_Specification
1758 2
          (Map_Ada_Defining_Identifier (S),
1759
           Profile,
1760
           No_Node);
1761

1762
      --  If the program is an Opaque_C, we add the pragma Import
1763
      --  instruction in the private part of the current package
1764

1765 2
      if Get_Subprogram_Kind (S) = Subprogram_Opaque_C then
1766
         declare
1767
            use ADN;
1768

1769
            P : constant Node_Id :=
1770 2
              Make_Pragma_Statement
1771
                (Pragma_Import,
1772 2
                 Make_List_Id
1773 2
                   (Make_Defining_Identifier (PN (P_C)),
1774 2
                    Map_Ada_Defining_Identifier (S),
1775 2
                    Make_Literal
1776 2
                      (ADV.New_String_Value (Get_Source_Name (S)))));
1777
         begin
1778
            --  We must ensure that we are inside the scope of a
1779
            --  package spec before inserting the pragma. In fact,
1780
            --  Map_Ada_Subprogram_Spec is called also when we build
1781
            --  the body of the subprogram, and we do not want to
1782
            --  insert the pragma when building the body.
1783

1784 2
            if ADN.Kind (Current_Package) = K_Package_Specification then
1785 2
               ADU.Append_Node_To_List (P, Private_Part (Current_Package));
1786
            end if;
1787
         end;
1788
      end if;
1789 2
      return N;
1790
   end Map_Ada_Subprogram_Spec;
1791

1792
   -----------------------------
1793
   -- Map_Ada_Subprogram_Body --
1794
   -----------------------------
1795

1796 2
   function Map_Ada_Subprogram_Body (S : Node_Id) return Node_Id is
1797 2
      Spec         : constant Node_Id := Map_Ada_Subprogram_Spec (S);
1798 2
      Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
1799 2
      Statements   : constant List_Id := New_List (ADN.K_Statement_List);
1800

1801 2
      Profile  : List_Id;
1802 2
      N        : Node_Id;
1803 2
      F        : Node_Id;
1804 2
      Call_Seq : Node_Id;
1805
   begin
1806 1
      case Get_Subprogram_Kind (S) is
1807 2
         when Subprogram_Empty =>
1808
            --  An empty AADL subprogram is mapped into an Ada
1809
            --  subprogram that raises an exception to warn the user.
1810

1811
            N :=
1812 2
              Make_Exception_Declaration
1813 2
                (Make_Defining_Identifier (EN (E_NYI)));
1814 2
            ADU.Append_Node_To_List (N, Declarations);
1815

1816 2
            N := Make_Raise_Statement (Make_Defining_Identifier (EN (E_NYI)));
1817 2
            ADU.Append_Node_To_List (N, Statements);
1818

1819 2
            return Make_Subprogram_Implementation
1820
                (Spec,
1821
                 Declarations,
1822
                 Statements);
1823

1824 2
         when Subprogram_Opaque_C =>
1825
            --  An opaque C AADL subprogram is a subprogram which is
1826
            --  implemented by a C subprogram. We perform the mapping
1827
            --  between the two subprograms using the Ada `Import'
1828
            --  pragma in the specification. Therefore, we have
1829
            --  nothing to do in the body.
1830

1831 2
            return No_Node;
1832

1833 2
         when Subprogram_Opaque_Ada_95 | Subprogram_Default =>
1834
            --  An opaque Ada AADL subprogram is a subprogram which is
1835
            --  implemented by an Ada subprogram. We perform the
1836
            --  mapping between the two subprograms using the Ada
1837
            --  renaming facility.
1838

1839
            --  Add the proper `with' clause
1840

1841 2
            N := Make_Designator (Unit_Name (Get_Source_Name (S)));
1842 2
            Add_With_Package (N);
1843

1844
            --  Perform the renaming
1845

1846
            N :=
1847 2
              Make_Designator
1848 2
                (Local_Name (Get_Source_Name (S)),
1849 2
                 Unit_Name (Get_Source_Name (S)));
1850 2
            ADN.Set_Renamed_Entity (Spec, N);
1851 2
            return Spec;
1852

1853 0
         when Subprogram_Opaque_Ada_95_Transfo =>
1854
            --  Same as above, but does not with the package, because
1855
            --  it is actually an instanciated generic package
1856

1857
            --  Perform the renaming
1858

1859
            N :=
1860 0
              Make_Designator
1861 0
                (Local_Name (Get_Transfo_Source_Name (S)),
1862 0
                 Unit_Name (Get_Transfo_Source_Name (S)));
1863 0
            ADN.Set_Renamed_Entity (Spec, N);
1864 0
            return Spec;
1865

1866 2
         when Subprogram_Pure_Call_Sequence =>
1867
            --  A pure call sequence subprogram is a subprogram that
1868
            --  has exactly one call sequence. The behaviour of this
1869
            --  subprogram is simply the call to the subprograms
1870
            --  present in its call list.
1871

1872 2
            Handle_Call_Sequence
1873
              (S,
1874 2
               Make_Defining_Identifier (PN (P_Status)),
1875 2
               First_Node (Calls (S)),
1876
               Declarations,
1877
               Statements);
1878 2
            return ADU.Make_Subprogram_Implementation
1879
                (Spec,
1880
                 Declarations,
1881
                 Statements);
1882

1883 0
         when Subprogram_Hybrid_Ada_95 =>
1884
            --  Hybrid subprograms are subprograms that contain more
1885
            --  that one call sequence.
1886

1887
            --  Declare the Status local variable
1888

1889
            N :=
1890 0
              Make_Object_Declaration
1891
                (Defining_Identifier =>
1892 0
                   Make_Defining_Identifier (PN (P_Status)),
1893
                 Object_Definition =>
1894 0
                   Make_Defining_Identifier
1895 0
                     (Map_Ada_Subprogram_Status_Name (S)));
1896 0
            ADU.Append_Node_To_List (N, Declarations);
1897

1898
            --  Initialise the record fields that correspond to IN
1899
            --  parameters.
1900

1901 0
            if not AAU.Is_Empty (Features (S)) then
1902 0
               F := First_Node (Features (S));
1903

1904 0
               while Present (F) loop
1905 0
                  if Kind (F) = K_Parameter_Instance and then Is_In (F) then
1906
                     N :=
1907 0
                       Make_Assignment_Statement
1908 0
                         (Make_Designator
1909 0
                            (To_Ada_Name (Display_Name (Identifier (F))),
1910
                             PN (P_Status)),
1911 0
                          Make_Designator
1912 0
                            (To_Ada_Name (Display_Name (Identifier (F)))));
1913 0
                     ADU.Append_Node_To_List (N, Statements);
1914
                  end if;
1915

1916 0
                  F := Next_Node (F);
1917 0
               end loop;
1918
            end if;
1919

1920 0
            Profile := New_List (ADN.K_Parameter_Profile);
1921

1922
            --  Append the 'Status' variable to the call profile
1923

1924 0
            N := Make_Defining_Identifier (PN (P_Status));
1925 0
            ADU.Append_Node_To_List (N, Profile);
1926

1927
            --  For each call sequence, we add the subprogram that
1928
            --  handles it.
1929

1930 0
            Call_Seq := First_Node (Calls (S));
1931

1932 0
            while Present (Call_Seq) loop
1933
               N :=
1934 0
                 Make_Attribute_Designator
1935 0
                   (Make_Defining_Identifier
1936 0
                      (Map_Ada_Call_Seq_Subprogram_Name (S, Call_Seq)),
1937
                    A_Access);
1938 0
               ADU.Append_Node_To_List (N, Profile);
1939

1940 0
               Call_Seq := Next_Node (Call_Seq);
1941 0
            end loop;
1942

1943
            --  Call the implementation subprogram
1944

1945
            --  Add the proper `with' clause
1946

1947 0
            N := Make_Designator (Unit_Name (Get_Source_Name (S)));
1948 0
            Add_With_Package (N);
1949

1950
            N :=
1951 0
              Make_Designator
1952 0
                (Local_Name (Get_Source_Name (S)),
1953 0
                 Unit_Name (Get_Source_Name (S)));
1954

1955 0
            N := Make_Subprogram_Call (ADN.Defining_Identifier (N), Profile);
1956 0
            ADU.Append_Node_To_List (N, Statements);
1957

1958
            --  Update the OUT parameters from the corresponding
1959
            --  record fields.
1960

1961 0
            if not AAU.Is_Empty (Features (S)) then
1962 0
               F := First_Node (Features (S));
1963

1964 0
               while Present (F) loop
1965 0
                  if Kind (F) = K_Parameter_Instance and then Is_Out (F) then
1966
                     N :=
1967 0
                       Make_Assignment_Statement
1968 0
                         (Make_Designator
1969 0
                            (To_Ada_Name (Display_Name (Identifier (F)))),
1970 0
                          Make_Designator
1971 0
                            (To_Ada_Name (Display_Name (Identifier (F))),
1972
                             PN (P_Status)));
1973 0
                     ADU.Append_Node_To_List (N, Statements);
1974
                  end if;
1975

1976 0
                  F := Next_Node (F);
1977 0
               end loop;
1978
            end if;
1979

1980 0
            return Make_Subprogram_Implementation
1981
                (Spec,
1982
                 Declarations,
1983
                 Statements);
1984

1985 0
         when Subprogram_Lustre =>
1986
            --  In PolyORB-HI-Ada, a Lustre subprogram is mapped onto an Ada
1987
            --  subprogram that raises an exception to warn the user.
1988

1989
            N :=
1990 0
              Make_Exception_Declaration
1991 0
                (Make_Defining_Identifier (EN (E_NYI)));
1992 0
            ADU.Append_Node_To_List (N, Declarations);
1993

1994 0
            N := Make_Raise_Statement (Make_Defining_Identifier (EN (E_NYI)));
1995 0
            ADU.Append_Node_To_List (N, Statements);
1996

1997 0
            return Make_Subprogram_Implementation
1998
                (Spec,
1999
                 Declarations,
2000
                 Statements);
2001

2002 0
         when others =>
2003 0
            Display_Located_Error
2004 0
              (Loc (S),
2005 0
               "This kind of subprogram is not supported: " &
2006 0
               Get_Subprogram_Kind (S)'Img,
2007
               Fatal => True);
2008 0
            return No_Node;
2009
      end case;
2010
   end Map_Ada_Subprogram_Body;
2011

2012
   --------------------------------------
2013
   -- Map_Ada_Call_Seq_Subprogram_Spec --
2014
   --------------------------------------
2015

2016 0
   function Map_Ada_Call_Seq_Subprogram_Spec
2017
     (Spg : Node_Id;
2018
      Seq : Node_Id) return Node_Id
2019
   is
2020 0
      Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
2021 0
      N       : Node_Id;
2022
   begin
2023
      N :=
2024 0
        Make_Parameter_Specification
2025 0
          (Make_Defining_Identifier (PN (P_Status)),
2026 0
           Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg)),
2027
           Mode_Inout);
2028 0
      ADU.Append_Node_To_List (N, Profile);
2029

2030
      N :=
2031 0
        Make_Subprogram_Specification
2032 0
          (Make_Defining_Identifier
2033 0
             (Map_Ada_Call_Seq_Subprogram_Name (Spg, Seq)),
2034
           Profile);
2035 0
      return N;
2036
   end Map_Ada_Call_Seq_Subprogram_Spec;
2037

2038
   --------------------------------------
2039
   -- Map_Ada_Call_Seq_Subprogram_Body --
2040
   --------------------------------------
2041

2042 0
   function Map_Ada_Call_Seq_Subprogram_Body
2043
     (Spg : Node_Id;
2044
      Seq : Node_Id) return Node_Id
2045
   is
2046 0
      Spec : constant Node_Id := Map_Ada_Call_Seq_Subprogram_Spec (Spg, Seq);
2047 0
      Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
2048 0
      Statements   : constant List_Id := New_List (ADN.K_Statement_List);
2049
   begin
2050 0
      Handle_Call_Sequence
2051
        (Spg,
2052 0
         Make_Defining_Identifier (PN (P_Status)),
2053
         Seq,
2054
         Declarations,
2055
         Statements);
2056

2057 0
      return Make_Subprogram_Implementation (Spec, Declarations, Statements);
2058
   end Map_Ada_Call_Seq_Subprogram_Body;
2059

2060
   ------------------------------------
2061
   -- Map_Ada_Subprogram_Status_Name --
2062
   ------------------------------------
2063

2064 2
   function Map_Ada_Subprogram_Status_Name (S : Node_Id) return Name_Id is
2065
   begin
2066 1
      pragma Assert (Is_Subprogram (S) or else Kind (S) = K_Call_Instance);
2067

2068 2
      Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (S))));
2069 2
      Add_Str_To_Name_Buffer ("_Status");
2070 2
      return Name_Find;
2071
   end Map_Ada_Subprogram_Status_Name;
2072

2073
   --------------------------------------
2074
   -- Map_Ada_Call_Seq_Subprogram_Name --
2075
   --------------------------------------
2076

2077 0
   function Map_Ada_Call_Seq_Subprogram_Name
2078
     (Spg : Node_Id;
2079
      Seq : Node_Id) return Name_Id
2080
   is
2081 0
      Spg_Name : Name_Id;
2082 0
      Seg_Name : Name_Id;
2083
   begin
2084
      pragma Assert
2085 0
        (Is_Subprogram (Spg) and then Kind (Seq) = K_Call_Sequence_Instance);
2086

2087 0
      Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Spg)));
2088 0
      Seg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Seq)));
2089

2090 0
      Get_Name_String (Spg_Name);
2091 0
      Add_Char_To_Name_Buffer ('_');
2092 0
      Get_Name_String_And_Append (Seg_Name);
2093 0
      return Name_Find;
2094
   end Map_Ada_Call_Seq_Subprogram_Name;
2095

2096
   ----------------------------------
2097
   -- Map_Ada_Call_Seq_Access_Name --
2098
   ----------------------------------
2099

2100 0
   function Map_Ada_Call_Seq_Access_Name (S : Node_Id) return Name_Id is
2101 0
      Spg_Name : Name_Id;
2102
   begin
2103 0
      pragma Assert (Is_Subprogram (S));
2104

2105 0
      Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (S)));
2106

2107 0
      Get_Name_String (Spg_Name);
2108 0
      Add_Str_To_Name_Buffer ("_Sequence_Access");
2109 0
      return Name_Find;
2110
   end Map_Ada_Call_Seq_Access_Name;
2111

2112
   -----------------------------
2113
   -- Map_Ada_Call_Seq_Access --
2114
   -----------------------------
2115

2116 0
   function Map_Ada_Call_Seq_Access (S : Node_Id) return Node_Id is
2117 0
      Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
2118 0
      N       : Node_Id;
2119
   begin
2120
      N :=
2121 0
        Make_Parameter_Specification
2122 0
          (Make_Defining_Identifier (PN (P_Status)),
2123 0
           Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (S)),
2124
           Mode_Inout);
2125 0
      ADU.Append_Node_To_List (N, Profile);
2126

2127 0
      N := Make_Subprogram_Specification (No_Node, Profile);
2128

2129
      N :=
2130 0
        Make_Full_Type_Declaration
2131 0
          (Make_Defining_Identifier (Map_Ada_Call_Seq_Access_Name (S)),
2132 0
           Make_Access_Type_Definition (N));
2133 0
      return N;
2134
   end Map_Ada_Call_Seq_Access;
2135

2136
   -------------------------------
2137
   -- Map_Ada_Subprogram_Status --
2138
   -------------------------------
2139

2140 0
   function Map_Ada_Subprogram_Status (S : Node_Id) return Node_Id is
2141 0
      Fields : constant List_Id := New_List (ADN.K_Component_List);
2142 0
      F      : Node_Id;
2143 0
      N      : Node_Id;
2144
   begin
2145 0
      pragma Assert (Is_Subprogram (S));
2146

2147 0
      if not AAU.Is_Empty (Features (S)) then
2148 0
         F := First_Node (Features (S));
2149

2150 0
         while Present (F) loop
2151
            N :=
2152 0
              Make_Component_Declaration
2153 0
                (Map_Ada_Defining_Identifier (F),
2154 0
                 Map_Ada_Data_Type_Designator (Corresponding_Instance (F)));
2155 0
            ADU.Append_Node_To_List (N, Fields);
2156

2157 0
            F := Next_Node (F);
2158 0
         end loop;
2159
      else
2160 0
         Display_Located_Error
2161 0
           (Loc (S),
2162
            "This hybrid subprogram has no parameters",
2163
            Fatal => True);
2164
      end if;
2165

2166
      N :=
2167 0
        Make_Full_Type_Declaration
2168 0
          (Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (S)),
2169 0
           Make_Record_Definition (Fields));
2170 0
      return N;
2171
   end Map_Ada_Subprogram_Status;
2172

2173
   --------------------------
2174
   -- Handle_Call_Sequence --
2175
   --------------------------
2176

2177 2
   procedure Handle_Call_Sequence
2178
     (Caller       : Node_Id;
2179
      Caller_State : Node_Id;
2180
      Call_Seq     : Node_Id;
2181
      Declarations : List_Id;
2182
      Statements   : List_Id)
2183
   is
2184 2
      Spg_Call      : Node_Id;
2185 2
      Spg           : Node_Id;
2186 2
      Destination_F : Node_Id;
2187 2
      Source_F      : Node_Id;
2188 2
      Source_Parent : Node_Id;
2189 2
      Call_Profile  : List_Id;
2190 2
      Param_Value   : Node_Id;
2191 2
      Owner_Object  : Node_Id;
2192 2
      N             : Node_Id;
2193 2
      M             : Node_Id;
2194 2
      F             : Node_Id;
2195 2
      Parent        : Node_Id;
2196 2
      Hybrid        : constant Boolean :=
2197 2
        Is_Subprogram (Caller)
2198 1
        and then Get_Subprogram_Kind (Caller) = Subprogram_Hybrid_Ada_95;
2199
   begin
2200
      --  The lists have to be created
2201

2202 2
      if Declarations = No_List or else Statements = No_List then
2203 0
         raise Program_Error
2204
           with "Lists have to be created before any call " &
2205
           "to Handle_Call_Sequence";
2206
      end if;
2207

2208
      --  The call sequence must contain at least one call to a
2209
      --  subprogram.
2210

2211 2
      if AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
2212 0
         Display_Located_Error
2213 0
           (Loc (Call_Seq),
2214
            "Empty call sequence",
2215
            Fatal   => False,
2216
            Warning => True);
2217 0
         return;
2218
      end if;
2219

2220 2
      Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
2221

2222 2
      while Present (Spg_Call) loop
2223 2
         Spg := Corresponding_Instance (Spg_Call);
2224

2225 2
         Call_Profile := New_List (ADN.K_List_Id);
2226

2227 2
         if not AAU.Is_Empty (Features (Spg)) then
2228 2
            F := First_Node (Features (Spg));
2229

2230 2
            while Present (F) loop
2231 2
               if Kind (F) = K_Parameter_Instance and then Is_Out (F) then
2232
                  --  Raise an error if the parameter is not connected
2233
                  --  to any source.
2234

2235 2
                  if AAU.Length (Destinations (F)) = 0 then
2236 0
                     Display_Located_Error
2237 0
                       (Loc (F),
2238
                        "This OUT parameter is not connected to" &
2239
                        " any destination",
2240
                        Fatal => True);
2241 2
                  elsif AAU.Length (Destinations (F)) > 1 then
2242 0
                     Display_Located_Error
2243 0
                       (Loc (F),
2244
                        "This OUT parameter has too many destinations",
2245
                        Fatal => True);
2246
                  end if;
2247

2248
                  --  At this point, we have a subprogram call
2249
                  --  parameter that has exactly one destination.
2250

2251 2
                  Destination_F := Item (First_Node (Destinations (F)));
2252

2253
                  --  For each OUT parameter, we declare a local
2254
                  --  variable if the OUT parameter is connected to
2255
                  --  another subprogram call or if the caller is a
2256
                  --  thread. Otherwise, we use the corresponding
2257
                  --  caller subprogram parameter.
2258

2259
                  --  The parameter association value takes 4 possible
2260
                  --  values (see the (1), (2), (3) and (4) comments
2261
                  --  below.
2262

2263 2
                  if Is_Thread (Caller) then
2264
                     --  Here we declare a variable based on the
2265
                     --  thread feature name.
2266

2267
                     N :=
2268 2
                       Make_Object_Declaration
2269
                         (Defining_Identifier =>
2270 2
                            Map_Ada_Defining_Identifier (Destination_F, "V"),
2271
                          Object_Definition =>
2272 2
                            Map_Ada_Data_Type_Designator
2273 2
                              (Corresponding_Instance (Destination_F)));
2274 2
                     ADU.Append_Node_To_List (N, Declarations);
2275

2276
                     --  (1) If we declared a local variable, we use it
2277
                     --      as parameter value.
2278

2279
                     Param_Value :=
2280 2
                       Map_Ada_Defining_Identifier (Destination_F, "V");
2281

2282 2
                  elsif Parent_Component (Destination_F) /= Caller then
2283
                     --  Here, we map the variable name from the
2284
                     --  subprogram *call* name and the feature
2285
                     --  name. This avoids name clashing when a
2286
                     --  subprogram calls twice the same subprogram.
2287

2288
                     N :=
2289 2
                       Make_Object_Declaration
2290
                         (Defining_Identifier =>
2291 2
                            Make_Defining_Identifier
2292 2
                              (Map_Ada_Full_Parameter_Name (Spg_Call, F)),
2293
                          Object_Definition =>
2294 2
                            Map_Ada_Data_Type_Designator
2295 2
                              (Corresponding_Instance (F)));
2296 2
                     ADU.Append_Node_To_List (N, Declarations);
2297

2298
                     --  (2) If we declared a local variable, we use it
2299
                     --      as parameter value.
2300

2301
                     Param_Value :=
2302 2
                       Make_Designator
2303 2
                         (Map_Ada_Full_Parameter_Name (Spg_Call, F));
2304

2305 2
                  elsif Hybrid then
2306
                     --  (3) If the calleD parameter is connected to
2307
                     --      the calleR parameter and then the calleR
2308
                     --      IS hybrid, then we use the 'Status'
2309
                     --      record field corresponding to the calleR
2310
                     --      parameter.
2311

2312
                     Param_Value :=
2313 0
                       Make_Designator
2314 0
                         (To_Ada_Name (Display_Name (Identifier (F))),
2315
                          PN (P_Status));
2316
                  else
2317
                     --  (4) If the calleD parameter is connected to
2318
                     --      the calleR parameter and then then calleR
2319
                     --      is NOT hybrid, then we use simply the
2320
                     --      corresponding parameter of the calleR.
2321

2322
                     Param_Value :=
2323 2
                       Map_Ada_Defining_Identifier (Destination_F);
2324
                  end if;
2325

2326
                  --  For each OUT parameter we build a parameter
2327
                  --  association of the actual profile of the
2328
                  --  implementation subprogram call <Param> =>
2329
                  --  <Param_Value>.
2330

2331
                  N :=
2332 2
                    Make_Parameter_Association
2333 2
                      (Selector_Name    => Map_Ada_Defining_Identifier (F),
2334
                       Actual_Parameter => Param_Value);
2335 2
                  ADU.Append_Node_To_List (N, Call_Profile);
2336

2337 2
               elsif Kind (F) = K_Parameter_Instance and then Is_In (F) then
2338
                  --  Raise an error if the parameter is not connected
2339
                  --  to any source.
2340

2341 2
                  if AAU.Length (Sources (F)) = 0 then
2342 0
                     Display_Located_Error
2343 0
                       (Loc (F),
2344
                        "This IN parameter is not connected to" &
2345 0
                        " any source" &
2346 0
                        Image (Loc (Caller)),
2347
                        Fatal => True);
2348 2
                  elsif AAU.Length (Sources (F)) > 1 then
2349 0
                     Display_Located_Error
2350 0
                       (Loc (F),
2351
                        "This IN parameter has too many sources",
2352
                        Fatal => True);
2353
                  end if;
2354

2355
                  --  Here we have an IN parameter with exactly one
2356
                  --  source.
2357

2358 2
                  Source_F := Item (First_Node (Sources (F)));
2359

2360
                  --  Get the source feature parent
2361

2362 2
                  Source_Parent := Parent_Component (Source_F);
2363

2364
                  --  The parameter value of the built parameter
2365
                  --  association can take 4 different values (see
2366
                  --  comments (1), (2), (3) and (4) below).
2367

2368 2
                  if Is_Thread (Source_Parent) then
2369
                     --  (1) If the Parent of 'Source_F' is a thread,
2370
                     --  then we use the local variable corresponding
2371
                     --  to the IN port.
2372

2373
                     Param_Value :=
2374 2
                       Map_Ada_Defining_Identifier (Source_F, "V");
2375 2
                  elsif Source_Parent /= Caller then
2376
                     --  (2) If the the source call is different from
2377
                     --      the englobing subprogram, we use the
2378
                     --      formerly declared variable.
2379

2380
                     Param_Value :=
2381 2
                       Make_Designator
2382 2
                         (Map_Ada_Full_Parameter_Name
2383 2
                            (Parent_Subcomponent (Source_Parent),
2384
                             Source_F));
2385

2386 2
                  elsif Hybrid then
2387
                     --  (3) If the calleD parameter is connected to
2388
                     --      the calleR parameter and then then calleR
2389
                     --      IS hybrid, the we use the 'Status' record
2390
                     --      field corresponding to the calleR
2391
                     --      parameter.
2392

2393
                     Param_Value :=
2394 0
                       Make_Selected_Component
2395 0
                         (Make_Defining_Identifier (PN (P_Status)),
2396 0
                          Map_Ada_Defining_Identifier (Source_F));
2397
                  else
2398
                     --  (4) If the calleD parameter is connected to
2399
                     --      the calleR parameter and then then calleR
2400
                     --      is NOT hybrid, then we use simply the
2401
                     --      corresponding parameter of the calleR.
2402

2403 2
                     Param_Value := Map_Ada_Defining_Identifier (Source_F);
2404
                  end if;
2405

2406
                  --  For each IN parameter we build a parameter
2407
                  --  association association of the actual profile of
2408
                  --  the implementaion subprogram call <Param> =>
2409
                  --  <Param_Value>.
2410

2411
                  N :=
2412 2
                    Make_Parameter_Association
2413 2
                      (Selector_Name    => Map_Ada_Defining_Identifier (F),
2414
                       Actual_Parameter => Param_Value);
2415 2
                  ADU.Append_Node_To_List (N, Call_Profile);
2416
               end if;
2417

2418 2
               F := Next_Node (F);
2419 2
            end loop;
2420
         end if;
2421

2422 2
         if not AAU.Is_Empty (Path (Spg_Call)) then
2423
            --  FIXME: Feature subprograms that have OUT ports are not
2424
            --  supported yet.
2425

2426 2
            if Has_Out_Ports (Spg) then
2427 0
               Display_Located_Error
2428 0
                 (Loc (Spg),
2429
                  "Feature subprograms that have OUT ports are not" &
2430
                  " supported yet",
2431
                  Fatal => True);
2432
            end if;
2433

2434
            --  If this is a feature subprogram call, generate a call
2435
            --  to the corresponding method.
2436

2437 2
            N := Message_Comment ("Invoking method");
2438 2
            ADU.Append_Node_To_List (N, Statements);
2439

2440
            N :=
2441 2
              Map_Ada_Defining_Identifier (Item (Last_Node (Path (Spg_Call))));
2442

2443
            --  Get the actual owner object
2444

2445
            --  FIXME: THIS WORKS ONLY FOR A LOCAL OBJECT
2446

2447 2
            Owner_Object := Get_Actual_Owner (Spg_Call);
2448

2449 2
            Set_Homogeneous_Parent_Unit_Name
2450
              (N,
2451 2
               Extract_Designator
2452 2
                 (ADN.Object_Node (Backend_Node (Identifier (Owner_Object)))));
2453

2454 2
            N := Make_Subprogram_Call (N, Call_Profile);
2455 2
            ADU.Append_Node_To_List (N, Statements);
2456
         else
2457
            --  If this is a classic subprogram, and if it has OUT
2458
            --  ports, we declare an additional status variable and
2459
            --  pass it to the implementation as the last INOUT
2460
            --  parameter.
2461

2462 2
            if Has_Out_Ports (Spg) then
2463
               N :=
2464 2
                 Make_Object_Declaration
2465
                   (Defining_Identifier =>
2466 2
                      Make_Defining_Identifier
2467 2
                        (Map_Ada_Subprogram_Status_Name (Spg_Call)),
2468
                    Object_Definition =>
2469 2
                      Extract_Designator
2470 2
                        (ADN.Type_Definition_Node
2471 2
                           (Backend_Node (Identifier (Spg)))));
2472 2
               ADU.Append_Node_To_List (N, Declarations);
2473

2474
               N :=
2475 2
                 Make_Parameter_Association
2476 2
                   (Make_Defining_Identifier (PN (P_Status)),
2477 2
                    Make_Defining_Identifier
2478 2
                      (Map_Ada_Subprogram_Status_Name (Spg_Call)));
2479 2
               ADU.Append_Node_To_List (N, Call_Profile);
2480
            end if;
2481

2482
            --  Call the implementation.
2483

2484 2
            N := Message_Comment ("Call implementation");
2485 2
            ADU.Append_Node_To_List (N, Statements);
2486

2487
            N :=
2488 2
              Make_Subprogram_Call
2489 2
                (Extract_Designator
2490 2
                   (ADN.Subprogram_Node (Backend_Node (Identifier (Spg)))),
2491
                 Call_Profile);
2492 2
            ADU.Append_Node_To_List (N, Statements);
2493

2494
            --  After the implementation is called and if the called
2495
            --  subprogram has OUT port, we trigger the destination of
2496
            --  these ports, which are out ports of the containing
2497
            --  thread or subprogram.
2498

2499 2
            if Has_Out_Ports (Spg) then
2500 2
               F := First_Node (Features (Spg));
2501

2502 2
               while Present (F) loop
2503 2
                  if Kind (F) = K_Port_Spec_Instance then
2504
                     --  Verify whether the port has been triggered
2505
                     --  then send the value to all its destinations.
2506

2507
                     declare
2508 2
                        D       : Node_Id;
2509 2
                        Profile : List_Id;
2510 2
                        Aggr    : List_Id;
2511
                        St      : constant List_Id :=
2512 2
                          ADU.New_List (ADN.K_Statement_List);
2513
                     begin
2514 2
                        D := First_Node (Destinations (F));
2515

2516 2
                        while Present (D) loop
2517
                           --  D is necessarily a feature of Caller,
2518
                           --  otherwise we have a serious problem.
2519

2520
                           pragma Assert
2521 1
                             (Parent_Component (Item (D)) = Caller);
2522

2523 2
                           Profile := ADU.New_List (ADN.K_List_Id);
2524 2
                           ADU.Append_Node_To_List
2525 2
                             (ADU.Copy_Node (Caller_State),
2526
                              Profile);
2527

2528 2
                           Aggr := ADU.New_List (ADN.K_List_Id);
2529

2530
                           N :=
2531 2
                             Make_Component_Association
2532 2
                               (Make_Defining_Identifier (CN (C_Port)),
2533 2
                                Map_Ada_Defining_Identifier (Item (D)));
2534 2
                           ADU.Append_Node_To_List (N, Aggr);
2535

2536 2
                           if Ocarina.ME_AADL.AADL_Instances.Nodes.Is_Data
2537 2
                               (Item (D))
2538
                           then
2539

2540 2
                              N := Map_Ada_Defining_Identifier (F);
2541

2542
                              --  We do not put use clause to avoid
2543
                              --  name clashing, so enumerators have
2544
                              --  to be qualified.
2545

2546
                              M :=
2547 2
                                Extract_Designator
2548 2
                                  (ADN.Port_Enumeration_Node
2549 2
                                     (Backend_Node (Identifier (Spg))));
2550 2
                              Parent := ADN.Parent_Unit_Name (M);
2551 2
                              N      := Make_Selected_Component (Parent, N);
2552
                              N      :=
2553 2
                                Make_Qualified_Expression
2554
                                  (M,
2555 2
                                   Make_Record_Aggregate (Make_List_Id (N)));
2556

2557
                              N :=
2558 2
                                Make_Subprogram_Call
2559 2
                                  (Extract_Designator
2560 2
                                     (ADN.Get_Value_Node
2561 2
                                        (Backend_Node (Identifier (Spg)))),
2562 2
                                   Make_List_Id
2563 2
                                     (Make_Defining_Identifier
2564 2
                                        (Map_Ada_Subprogram_Status_Name
2565
                                           (Spg_Call)),
2566
                                      N));
2567

2568
                              N :=
2569 2
                                Make_Component_Association
2570 2
                                  (Make_Defining_Identifier
2571 2
                                     (Map_Ada_Component_Name (Item (D))),
2572 2
                                   Make_Selected_Component
2573
                                     (N,
2574 2
                                      Make_Defining_Identifier
2575 2
                                        (Map_Ada_Component_Name (F))));
2576 2
                              ADU.Append_Node_To_List (N, Aggr);
2577
                           end if;
2578

2579
                           N :=
2580 2
                             Make_Qualified_Expression
2581 2
                               (Extract_Designator
2582 2
                                  (ADN.Port_Interface_Node
2583 2
                                     (Backend_Node (Identifier (Caller)))),
2584 2
                                Make_Record_Aggregate (Aggr));
2585 2
                           ADU.Append_Node_To_List (N, Profile);
2586

2587
                           --  Call, the Put_Value routine
2588
                           --  corresponding to the destination.
2589

2590
                           N :=
2591 2
                             Make_Subprogram_Call
2592 2
                               (Extract_Designator
2593 2
                                  (ADN.Put_Value_Node
2594 2
                                     (Backend_Node (Identifier (Caller)))),
2595
                                Profile);
2596

2597 2
                           ADU.Append_Node_To_List (N, St);
2598

2599 2
                           D := Next_Node (D);
2600 2
                        end loop;
2601

2602
                        --  Make the if statement
2603

2604 2
                        Profile := ADU.New_List (ADN.K_List_Id);
2605

2606
                        N :=
2607 2
                          Make_Defining_Identifier
2608 2
                            (Map_Ada_Subprogram_Status_Name (Spg_Call));
2609 2
                        ADU.Append_Node_To_List (N, Profile);
2610

2611 2
                        N := Map_Ada_Defining_Identifier (F);
2612

2613
                        --  We do not put use clause to avoid name
2614
                        --  clashing, so enumerators have to be fully
2615
                        --  qualified.
2616

2617
                        M :=
2618 2
                          Extract_Designator
2619 2
                            (ADN.Port_Enumeration_Node
2620 2
                               (Backend_Node (Identifier (Spg))));
2621 2
                        Parent := ADN.Parent_Unit_Name (M);
2622

2623 2
                        N := Make_Selected_Component (Parent, N);
2624
                        N :=
2625 2
                          Make_Qualified_Expression
2626
                            (M,
2627 2
                             Make_Record_Aggregate (Make_List_Id (N)));
2628 2
                        ADU.Append_Node_To_List (N, Profile);
2629

2630
                        N :=
2631 2
                          Make_Subprogram_Call
2632 2
                            (Extract_Designator
2633 2
                               (ADN.Get_Count_Node
2634 2
                                  (Backend_Node (Identifier (Spg)))),
2635
                             Profile);
2636
                        N :=
2637 2
                          Make_Expression
2638
                            (N,
2639
                             Op_Greater_Equal,
2640 2
                             Make_Literal (ADV.New_Integer_Value (1, 1, 10)));
2641
                        N :=
2642 2
                          Make_If_Statement
2643
                            (Condition       => N,
2644
                             Then_Statements => St);
2645 2
                        ADU.Append_Node_To_List (N, Statements);
2646
                     end;
2647
                  end if;
2648

2649 2
                  F := Next_Node (F);
2650 2
               end loop;
2651
            end if;
2652
         end if;
2653

2654 2
         Spg_Call := Next_Node (Spg_Call);
2655 2
      end loop;
2656
   end Handle_Call_Sequence;
2657

2658
   ---------------------------
2659
   -- Get_Ada_Default_Value --
2660
   ---------------------------
2661

2662 2
   function Get_Ada_Default_Value (D : Node_Id) return Node_Id is
2663 2
      Data_Representation : Supported_Data_Representation;
2664 2
      Result              : Node_Id;
2665
   begin
2666 1
      pragma Assert (AAU.Is_Data (D));
2667

2668 2
      Data_Representation := Get_Data_Representation (D);
2669

2670 1
      case Data_Representation is
2671 2
         when Data_Integer =>
2672
            --  For integers, default value is 0
2673

2674 2
            Result := ADU.Make_Literal (ADV.New_Integer_Value (0, 1, 10));
2675

2676 2
         when Data_Float | Data_Fixed =>
2677
            --  For reals, the default value is 0.0
2678

2679 2
            Result := ADU.Make_Literal (ADV.New_Floating_Point_Value (0.0));
2680

2681 2
         when Data_Boolean =>
2682
            --  For booleans, the default value is FALSE
2683

2684 2
            Result := ADU.Make_Literal (ADV.New_Boolean_Value (False));
2685

2686 0
         when Data_Character =>
2687
            --  For characters, the default value is the space ' '
2688

2689
            Result :=
2690 0
              ADU.Make_Literal (ADV.New_Character_Value (Character'Pos (' ')));
2691

2692 0
         when Data_Wide_Character =>
2693
            --  For wide characters, the default value is the wide
2694
            --  space ' '.
2695

2696
            Result :=
2697 0
              ADU.Make_Literal
2698 0
                (ADV.New_Character_Value (Wide_Character'Pos (' '), True));
2699

2700 2
         when Data_String =>
2701
            --  For strings, the default value is the null bounded string
2702

2703
            Result :=
2704 2
              Make_Selected_Component
2705 2
                (Map_Ada_Package_Identifier (D),
2706 2
                 Make_Defining_Identifier (PN (P_Null_Bounded_String)));
2707

2708 0
         when Data_Wide_String =>
2709
            --  For wide strings, the default value is the null
2710
            --  bounded wide string.
2711

2712
            Result :=
2713 0
              Make_Selected_Component
2714 0
                (Map_Ada_Package_Identifier (D),
2715 0
                 Make_Defining_Identifier (PN (P_Null_Bounded_Wide_String)));
2716

2717 2
         when Data_Array =>
2718
            --  The default value for an array type is an array
2719
            --  aggregate of the default value of the array element
2720
            --  type.
2721

2722
            --  We use "<T>'Range =>" instead of using "others =>" to
2723
            --  avoid implicit loops.
2724

2725
            Result :=
2726 2
              Make_Record_Aggregate
2727 2
                (Make_List_Id
2728 2
                   (Make_Element_Association
2729 2
                      (Make_Attribute_Designator
2730 2
                         (Map_Ada_Defining_Identifier (D),
2731
                          A_Range),
2732 2
                       Get_Ada_Default_Value
2733 2
                         (ATN.Entity (ATN.First_Node (Get_Base_Type (D)))))));
2734

2735 2
         when Data_Struct =>
2736
            --  For data record, the default value is an aggregate
2737
            --  list of default values of all the record aggregates.
2738

2739
            declare
2740
               Aggregates : constant List_Id :=
2741 2
                 ADU.New_List (ADN.K_Component_List);
2742 2
               S : Node_Id;
2743 2
               C : Node_Id;
2744
            begin
2745 2
               if not AAU.Is_Empty (Subcomponents (D)) then
2746 2
                  S := First_Node (Subcomponents (D));
2747 2
                  while Present (S) loop
2748
                     C :=
2749 2
                       ADU.Make_Component_Association
2750 2
                         (Map_Ada_Defining_Identifier (S),
2751 2
                          Get_Ada_Default_Value (Corresponding_Instance (S)));
2752 2
                     ADU.Append_Node_To_List (C, Aggregates);
2753

2754 2
                     S := Next_Node (S);
2755 2
                  end loop;
2756

2757 2
                  Result := ADU.Make_Record_Aggregate (Aggregates);
2758
               else
2759 0
                  Display_Located_Error
2760 0
                    (Loc (D),
2761
                     "Record types must not be empty!",
2762
                     Fatal => True);
2763
               end if;
2764
            end;
2765

2766 0
         when Data_With_Accessors =>
2767
            --  This is definitely a code generation error
2768

2769 0
            raise Program_Error
2770
              with "Data types with accessors should" &
2771
              " not have default values";
2772

2773 2
         when others =>
2774 2
            Display_Located_Error
2775 2
              (Loc (D),
2776
               "Cannot generate default value for type",
2777
               Fatal   => False,
2778
               Warning => True);
2779 2
            Result := No_Node;
2780 1
      end case;
2781

2782 2
      return Result;
2783
   end Get_Ada_Default_Value;
2784

2785
   -------------------------------------------
2786
   -- Map_Ada_Namespace_Defining_Identifier --
2787
   -------------------------------------------
2788

2789 0
   function Map_Ada_Namespace_Defining_Identifier
2790
     (N      : Node_Id;
2791
      Prefix : String := "") return Node_Id
2792
   is
2793 0
      Name_List : List_Id;
2794 0
      I         : Node_Id;
2795 0
      Id        : Node_Id;
2796 0
      Parent_Id : Node_Id := No_Node;
2797
   begin
2798

2799 0
      if Name (Identifier (N)) = No_Name then
2800
         --  This is the unnamed namespace
2801

2802 0
         if Prefix = "" then
2803
            --  Display an error if the user did not give a prefix
2804

2805 0
            raise Program_Error
2806
              with "You must provide a prefix to map the" &
2807
              " unnamed namespace";
2808
         end if;
2809

2810 0
         return ADU.Make_Defining_Identifier (Get_String_Name (Prefix));
2811
      else
2812
         --  This is a "classical" namespace obtained from the
2813
         --  instanciation of an AADL package.
2814

2815 0
         Name_List := Split_Name (N);
2816

2817 0
         if Prefix /= "" then
2818
            Parent_Id :=
2819 0
              ADU.Make_Defining_Identifier (Get_String_Name (Prefix));
2820
         end if;
2821

2822 0
         I := First_Node (Name_List);
2823

2824 0
         while Present (I) loop
2825 0
            Id := ADU.Make_Defining_Identifier (Display_Name (I));
2826 0
            ADN.Set_Parent_Unit_Name (Id, Parent_Id);
2827 0
            Parent_Id := Id;
2828

2829 0
            I := Next_Node (I);
2830 0
         end loop;
2831

2832 0
         return Id;
2833
      end if;
2834
   end Map_Ada_Namespace_Defining_Identifier;
2835

2836
   -------------
2837
   -- To_Bits --
2838
   -------------
2839

2840
   How_Many_Bits : constant array (Size_Units) of Unsigned_Long_Long :=
2841
     (Bit             => 1,
2842
      Properties.Byte => 8,
2843
      Kilo_Byte       => 8 * 1_000,
2844
      Mega_Byte       => 8 * 1_000_000,
2845
      Giga_Byte       => 8 * 1_000_000_000,
2846
      Tera_Byte       => 8 * 1_000_000_000_000);
2847
   --  To easily convert sizes into bits
2848

2849 2
   function To_Bits (S : Size_Type) return Unsigned_Long_Long is
2850
   begin
2851 2
      return S.S * How_Many_Bits (S.U);
2852
   end To_Bits;
2853

2854
   ----------------
2855
   -- To_Seconds --
2856
   ----------------
2857

2858 2
   function To_Seconds (S : Time_Type) return Long_Double is
2859 2
      Value : constant Long_Double := Long_Double (S.T);
2860
   begin
2861 1
      case S.U is
2862 2
         when Picosecond =>
2863 2
            return Value / 1_000_000_000_000.0;
2864

2865 0
         when Nanosecond =>
2866 0
            return Value / 1_000_000_000.0;
2867

2868 0
         when Microsecond =>
2869 0
            return Value / 1_000_000.0;
2870

2871 2
         when Millisecond =>
2872 2
            return Value / 1_000.0;
2873

2874 2
         when Second =>
2875 2
            return Value;
2876

2877 0
         when Minute =>
2878 0
            return Value * 60.0;
2879

2880 0
         when Hour =>
2881 0
            return Value * 3600.0;
2882

2883
      end case;
2884
   end To_Seconds;
2885

2886
   ---------------------
2887
   -- To_Milliseconds --
2888
   ---------------------
2889

2890 2
   function To_Milliseconds (S : Time_Type) return Unsigned_Long_Long is
2891
   begin
2892 1
      return Unsigned_Long_Long (To_Seconds (S) * 1_000.0);
2893
   end To_Milliseconds;
2894

2895
   ---------------------
2896
   -- To_Microseconds --
2897
   ---------------------
2898

2899 2
   function To_Microseconds (S : Time_Type) return Unsigned_Long_Long is
2900
   begin
2901 1
      return Unsigned_Long_Long (To_Seconds (S) * 1_000_000.0);
2902
   end To_Microseconds;
2903

2904
   ---------------------
2905
   -- To_Nanoseconds --
2906
   ---------------------
2907

2908 2
   function To_Nanoseconds (S : Time_Type) return Unsigned_Long_Long is
2909
   begin
2910 1
      return Unsigned_Long_Long (To_Seconds (S) * 1_000_000_000.0);
2911
   end To_Nanoseconds;
2912

2913
   --------------
2914
   -- To_Bytes --
2915
   --------------
2916

2917
   How_Many_Bytes : constant array (Size_Units) of Unsigned_Long_Long :=
2918
     (Bit             => 0,
2919
      Properties.Byte => 1,
2920
      Kilo_Byte       => 1_000,
2921
      Mega_Byte       => 1_000_000,
2922
      Giga_Byte       => 1_000_000_000,
2923
      Tera_Byte       => 1_000_000_000_000);
2924
   --  To easily convert sizes into bytes
2925

2926 2
   function To_Bytes (S : Size_Type) return Unsigned_Long_Long is
2927
   begin
2928 1
      case S.U is
2929
         when Bit =>
2930
            --  If the size can be converted into byte, we are OK,
2931
            --  else, this is an error.
2932

2933 2
            if S.S mod 8 = 0 then
2934 2
               return S.S / 8;
2935
            else
2936 2
               return 0;
2937
            end if;
2938

2939
         when others =>
2940 2
            return S.S * How_Many_Bytes (S.U);
2941
      end case;
2942
   end To_Bytes;
2943

2944
   ----------------------------------
2945
   -- Check_Connection_Consistency --
2946
   ----------------------------------
2947

2948 2
   procedure Check_Connection_Consistency (C : Node_Id) is
2949 2
      B     : Node_Id;
2950 2
      C_Src : Node_Id;
2951 2
      C_Dst : Node_Id;
2952 2
      P_Src : Node_Id;
2953 2
      P_Dst : Node_Id;
2954

2955
      procedure Check_Port_Consistency (P : Node_Id);
2956
      --  Check that a port belongs to a process and complains with an
2957
      --  error otherwise.
2958

2959
      procedure Check_Processes_Bus_Access (P : Node_Id; Bus : Node_Id);
2960
      --  Check that the process P have access to the bus 'Bus'
2961
      --  through its bound processor.
2962

2963
      ----------------------------
2964
      -- Check_Port_Consistency --
2965
      ----------------------------
2966

2967 0
      procedure Check_Port_Consistency (P : Node_Id) is
2968
      begin
2969 0
         if not Is_Process (Parent_Component (P)) then
2970 0
            Display_Located_Error
2971 0
              (Loc (P),
2972
               "The parent of this port is not a process and it" &
2973 0
               " is involved in a system-level connection in " &
2974 0
               Image (Loc (C)),
2975
               Fatal => True);
2976
         end if;
2977 0
      end Check_Port_Consistency;
2978

2979
      --------------------------------
2980
      -- Check_Processes_Bus_Access --
2981
      --------------------------------
2982

2983 0
      procedure Check_Processes_Bus_Access (P : Node_Id; Bus : Node_Id) is
2984 0
         CPU : Node_Id;
2985 0
         F   : Node_Id := No_Node;
2986 0
         S   : Node_Id;
2987
      begin
2988
         --  Get the processor to which P is bound
2989

2990 0
         CPU := Get_Bound_Processor (P);
2991

2992
         --  Loop on the features of CPU to find the required access
2993
         --  to the Bus.
2994

2995 0
         if not AAU.Is_Empty (Features (CPU)) then
2996 0
            F := First_Node (Features (CPU));
2997
            Outer_Loop :
2998 0
            while Present (F) loop
2999 0
               if Kind (F) = K_Subcomponent_Access_Instance then
3000
                  --  Verify that the required access is indeed connected to
3001
                  --  the bus subcomponent correspondiong to Bus.
3002

3003 0
                  if not AAU.Is_Empty (Sources (F)) then
3004 0
                     S := First_Node (Sources (F));
3005

3006 0
                     while Present (S) loop
3007 0
                        exit Outer_Loop when Item (S) =
3008 0
                          Parent_Subcomponent (B);
3009

3010 0
                        S := Next_Node (S);
3011 0
                     end loop;
3012
                  end if;
3013
               end if;
3014

3015 0
               F := Next_Node (F);
3016 0
            end loop Outer_Loop;
3017
         end if;
3018

3019 0
         if No (F) then
3020
            --  This means we went through all the previous loop
3021
            --  without finding any matching bus access or that we did
3022
            --  never enter the loop.
3023

3024 0
            Display_Located_Error
3025 0
              (Loc (Parent_Subcomponent (CPU)),
3026 0
               "This process has no access to the bus declared at " &
3027 0
               Image (Loc (Parent_Subcomponent (Bus))),
3028
               Fatal => True);
3029
         end if;
3030

3031 0
      end Check_Processes_Bus_Access;
3032

3033
   begin
3034 1
      pragma Assert (Kind (C) = K_Connection_Instance);
3035

3036
      --  We only check connection at system level
3037

3038 2
      if not Is_System (Parent_Component (C)) then
3039 0
         return;
3040
      end if;
3041

3042
      --  We only check port connections
3043

3044
      if not
3045 2
        (Get_Category_Of_Connection (C) in Port_Connection_Type'Range)
3046
      then
3047 2
         return;
3048
      end if;
3049

3050
      --  Get the connecion bus
3051

3052 0
      B := Get_Bound_Bus (C);
3053

3054
      --  Get the connection extremities
3055

3056 0
      C_Src := Get_Referenced_Entity (Source (C));
3057 0
      C_Dst := Get_Referenced_Entity (Destination (C));
3058

3059
      --  Check that the connection connects two ports
3060

3061 0
      if Kind (C_Src) /= K_Port_Spec_Instance
3062 0
        or else Kind (C_Src) /= K_Port_Spec_Instance
3063
      then
3064
         --  FIXME: May be refined in the future when distributed
3065
         --  shared variable will be supported.
3066

3067 0
         Display_Located_Error
3068 0
           (Loc (C),
3069
            "One of the extremities of this connection is not a port",
3070
            Fatal => True);
3071
      end if;
3072

3073
      --  Check that the connected ports belongs to processes
3074

3075 0
      Check_Port_Consistency (C_Src);
3076 0
      Check_Port_Consistency (C_Dst);
3077

3078
      --  Get the processes
3079

3080 0
      P_Src := Parent_Component (C_Src);
3081 0
      P_Dst := Parent_Component (C_Dst);
3082

3083
      --  Check that the two processes have an access to the Bus to
3084
      --  which the connection is bound through their respective bound
3085
      --  processors.
3086

3087 0
      Check_Processes_Bus_Access (P_Src, B);
3088 0
      Check_Processes_Bus_Access (P_Dst, B);
3089

3090
      --  Everything is OK
3091
   end Check_Connection_Consistency;
3092

3093
   ------------------------------
3094
   -- Check_Thread_Consistency --
3095
   ------------------------------
3096

3097 2
   procedure Check_Thread_Consistency (T : Node_Id) is
3098
   begin
3099 1
      pragma Assert (Is_Thread (T));
3100

3101
      --  Check implementation kind
3102

3103 2
      if Get_Thread_Implementation_Kind (T) = Thread_Unknown then
3104 0
         Display_Located_Error
3105 0
           (Loc (T),
3106
            "Unknown thread implementation kind",
3107
            Fatal => True);
3108
      end if;
3109 2
   end Check_Thread_Consistency;
3110

3111
   ------------------------------------
3112
   -- Get_Subcomponent_Access_Source --
3113
   ------------------------------------
3114

3115 2
   function Get_Subcomponent_Access_Source (S : Node_Id) return Node_Id is
3116 2
      Src : Node_Id;
3117
   begin
3118 1
      pragma Assert (Kind (S) = K_Subcomponent_Access_Instance);
3119

3120
      --  Raise an error if the provided access is not connected
3121

3122 2
      if AAU.Is_Empty (Sources (S)) then
3123 0
         Display_Located_Error
3124 0
           (Loc (S),
3125
            "Required access not connected to anything",
3126
            Fatal => True);
3127
      end if;
3128

3129
      --  Loop on the sources of the access until finding a
3130
      --  subcomponent.
3131

3132 2
      Src := First_Node (Sources (S));
3133

3134 2
      while Present (Src) loop
3135

3136 2
         exit when Kind (Item (Src)) = K_Subcomponent_Instance;
3137

3138
         --  Raise an error if the provided access is not connected
3139

3140 2
         if AAU.Is_Empty (Sources (Item (Src))) then
3141 0
            Display_Located_Error
3142 0
              (Loc (Item (Src)),
3143
               "Required access not connected to anything",
3144
               Fatal => True);
3145
         end if;
3146

3147 2
         Src := First_Node (Sources (Item (Src)));
3148 2
      end loop;
3149

3150
      --  If Src is No_Node, this means that the required access chain
3151
      --  does not end with a subcomponent as stated by the AADL
3152
      --  standard.
3153