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

33
with Ocarina.Namet;
34

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

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

49 1
package body Ocarina.Backends.PO_HI_Ada.Activity is
50

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

63
   package AAN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
64
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
65
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
66
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
67
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
68

69
   function Send_Output_Spec (E : Node_Id) return Node_Id;
70
   function Put_Value_Spec (E : Node_Id) return Node_Id;
71
   function Receive_Input_Spec (E : Node_Id) return Node_Id;
72
   function Get_Value_Spec (E : Node_Id) return Node_Id;
73
   function Get_Value_Spec_2 (E : Node_Id) return Node_Id;
74
   function Get_Sender_Spec (E : Node_Id) return Node_Id;
75
   function Get_Count_Spec (E : Node_Id) return Node_Id;
76
   function Get_Time_Stamp_Spec (E : Node_Id) return Node_Id;
77
   function Next_Value_Spec (E : Node_Id) return Node_Id;
78
   function Store_Received_Message_Spec (E : Node_Id) return Node_Id;
79
   function Wait_For_Incoming_Events_Spec (E : Node_Id) return Node_Id;
80
   --  Runtime routines provided for each AADL thread
81

82
   function Runtime_Spec_Aspect_Definition return Node_Id;
83
   --  Build aspect definition for runtime services
84

85
   ------------------------------------
86
   -- Runtime_Spec_Aspect_Definition --
87
   ------------------------------------
88

89 1
   function Runtime_Spec_Aspect_Definition return Node_Id is
90
   begin
91 1
      if Add_SPARK2014_Annotations then
92 0
         return Make_Aspect_Specification
93 0
           (Make_List_Id
94 0
              (Make_Aspect (ASN (A_Volatile_Function)),
95 0
               Make_Aspect
96
                 (ASN (A_Global),
97 0
                  Make_Global_Specification
98 0
                    (Make_List_Id
99 0
                       (Make_Moded_Global_List
100
                          (Mode_In,
101 0
                           Make_Defining_Identifier
102
                             (PN (P_Elaborated_Variables))))))));
103
      else
104 1
         return No_Node;
105
      end if;
106
   end Runtime_Spec_Aspect_Definition;
107

108
   ----------------------
109
   -- Send_Output_Spec --
110
   ----------------------
111

112 1
   function Send_Output_Spec (E : Node_Id) return Node_Id is
113 1
      N : Node_Id;
114 1
      Aspect_Node :  Node_Id := No_Node;
115
   begin
116 1
      if Add_SPARK2014_Annotations then
117 0
         Aspect_Node := Make_Aspect_Specification
118 0
             (Make_List_Id
119 0
                (Make_Aspect
120
                   (ASN (A_Global),
121 0
                    Make_Global_Specification
122 0
                      (Make_List_Id
123 0
                         (Make_Moded_Global_List
124
                            (Mode_In,
125 0
                             Make_Defining_Identifier
126
                             (PN (P_Elaborated_Variables))))))));
127
      end if;
128

129
      N :=
130 1
        Make_Subprogram_Specification
131
          (Defining_Identifier =>
132 1
             Make_Defining_Identifier (SN (S_Send_Output)),
133
           Parameter_Profile =>
134 1
             Make_List_Id
135 1
               (Make_Parameter_Specification
136
                  (Defining_Identifier =>
137 1
                     Make_Defining_Identifier (PN (P_Entity)),
138 1
                   Subtype_Mark   => RE (RE_Entity_Type),
139
                   Parameter_Mode => Mode_In),
140 1
                Make_Parameter_Specification
141
                  (Defining_Identifier =>
142 1
                     Make_Defining_Identifier (PN (P_Port)),
143
                   Subtype_Mark =>
144 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
145
                   Parameter_Mode => Mode_In),
146 1
                Make_Parameter_Specification
147
                  (Defining_Identifier =>
148 1
                     Make_Defining_Identifier (PN (P_Result)),
149 1
                   Subtype_Mark => RE (RE_Error_Kind),
150
                   Parameter_Mode => Mode_Out)),
151
           Aspect_Specification => Aspect_Node);
152

153 1
      return N;
154
   end Send_Output_Spec;
155

156
   --------------------
157
   -- Put_Value_Spec --
158
   --------------------
159

160 1
   function Put_Value_Spec (E : Node_Id) return Node_Id is
161 1
      N : Node_Id;
162
   begin
163
      N :=
164 1
        Make_Subprogram_Specification
165 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Put_Value)),
166
           Parameter_Profile   =>
167 1
             Make_List_Id
168 1
               (Make_Parameter_Specification
169
                  (Defining_Identifier =>
170 1
                     Make_Defining_Identifier (PN (P_Entity)),
171 1
                   Subtype_Mark   => RE (RE_Entity_Type),
172
                   Parameter_Mode => Mode_In),
173 1
                Make_Parameter_Specification
174
                  (Defining_Identifier =>
175 1
                     Make_Defining_Identifier (PN (P_Thread_Interface)),
176
                   Subtype_Mark =>
177 1
                     Make_Defining_Identifier (Map_Port_Interface_Name (E)),
178
                   Parameter_Mode => Mode_In)),
179
           Return_Type => No_Node);
180

181 1
      return N;
182
   end Put_Value_Spec;
183

184
   ------------------------
185
   -- Receive_Input_Spec --
186
   ------------------------
187

188 1
   function Receive_Input_Spec (E : Node_Id) return Node_Id is
189 1
      N : Node_Id;
190
   begin
191
      N :=
192 1
        Make_Subprogram_Specification
193
          (Defining_Identifier =>
194 1
             Make_Defining_Identifier (SN (S_Receive_Input)),
195
           Parameter_Profile =>
196 1
             Make_List_Id
197 1
               (Make_Parameter_Specification
198
                  (Defining_Identifier =>
199 1
                     Make_Defining_Identifier (PN (P_Entity)),
200 1
                   Subtype_Mark   => RE (RE_Entity_Type),
201
                   Parameter_Mode => Mode_In),
202 1
                Make_Parameter_Specification
203
                  (Defining_Identifier =>
204 1
                     Make_Defining_Identifier (PN (P_Port)),
205
                   Subtype_Mark =>
206 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
207
                   Parameter_Mode => Mode_In)),
208
           Return_Type => No_Node);
209

210 1
      return N;
211
   end Receive_Input_Spec;
212

213
   --------------------
214
   -- Get_Value_Spec --
215
   --------------------
216

217 1
   function Get_Value_Spec (E : Node_Id) return Node_Id is
218 1
      N : Node_Id;
219 1
      Aspect_Node : Node_Id := No_Node;
220
   begin
221 1
      if Add_SPARK2014_Annotations then
222 0
         Aspect_Node := Make_Aspect_Specification
223 0
           (Make_List_Id
224 0
              (Make_Aspect
225
                 (ASN (A_Global),
226 0
                  Make_Global_Specification
227 0
                    (Make_List_Id
228 0
                       (Make_Moded_Global_List
229
                          (Mode_In,
230 0
                           Make_Defining_Identifier
231
                             (PN (P_Elaborated_Variables))))))));
232

233
      end if;
234

235
      N :=
236 1
        Make_Subprogram_Specification
237 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Value)),
238
           Parameter_Profile   =>
239 1
             Make_List_Id
240 1
               (Make_Parameter_Specification
241
                  (Defining_Identifier =>
242 1
                     Make_Defining_Identifier (PN (P_Entity)),
243 1
                   Subtype_Mark   => RE (RE_Entity_Type),
244
                   Parameter_Mode => Mode_In),
245 1
                Make_Parameter_Specification
246
                  (Defining_Identifier =>
247 1
                     Make_Defining_Identifier (PN (P_Port)),
248
                   Subtype_Mark =>
249 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
250
                   Parameter_Mode => Mode_In),
251 1
                   Make_Parameter_Specification
252
                     (Defining_Identifier =>
253 1
                        Make_Defining_Identifier (PN (P_Result)),
254
                      Subtype_Mark =>
255 1
                        Make_Defining_Identifier (Map_Port_Interface_Name (E)),
256
                      Parameter_Mode => Mode_Inout)
257
               ),
258
           Aspect_Specification => Aspect_Node);
259

260 1
      return N;
261
   end Get_Value_Spec;
262

263 1
   function Get_Value_Spec_2 (E : Node_Id) return Node_Id is
264 1
      N : Node_Id;
265
   begin
266
      N :=
267 1
        Make_Subprogram_Specification
268 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Value)),
269
           Parameter_Profile   =>
270 1
             Make_List_Id
271 1
               (Make_Parameter_Specification
272
                  (Defining_Identifier =>
273 1
                     Make_Defining_Identifier (PN (P_Entity)),
274 1
                   Subtype_Mark   => RE (RE_Entity_Type),
275
                   Parameter_Mode => Mode_In),
276 1
                Make_Parameter_Specification
277
                  (Defining_Identifier =>
278 1
                     Make_Defining_Identifier (PN (P_Port)),
279
                   Subtype_Mark =>
280 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
281
                   Parameter_Mode => Mode_In)),
282
           Return_Type =>
283 1
             Make_Defining_Identifier (Map_Port_Interface_Name (E)),
284 1
           Aspect_Specification => Runtime_Spec_Aspect_Definition);
285 1
      return N;
286
   end Get_Value_Spec_2;
287

288
   ---------------------
289
   -- Get_Sender_Spec --
290
   ---------------------
291

292 1
   function Get_Sender_Spec (E : Node_Id) return Node_Id is
293 1
      N : Node_Id;
294
   begin
295
      N :=
296 1
        Make_Subprogram_Specification
297 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Sender)),
298
           Parameter_Profile   =>
299 1
             Make_List_Id
300 1
               (Make_Parameter_Specification
301
                  (Defining_Identifier =>
302 1
                     Make_Defining_Identifier (PN (P_Entity)),
303 1
                   Subtype_Mark   => RE (RE_Entity_Type),
304
                   Parameter_Mode => Mode_In),
305 1
                Make_Parameter_Specification
306
                  (Defining_Identifier =>
307 1
                     Make_Defining_Identifier (PN (P_Port)),
308
                   Subtype_Mark =>
309 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
310
                   Parameter_Mode => Mode_In)),
311 1
           Return_Type => RE (RE_Entity_Type),
312 1
           Aspect_Specification => Runtime_Spec_Aspect_Definition);
313

314 1
      return N;
315
   end Get_Sender_Spec;
316

317
   --------------------
318
   -- Get_Count_Spec --
319
   --------------------
320

321 1
   function Get_Count_Spec (E : Node_Id) return Node_Id is
322 1
      N : Node_Id;
323
   begin
324
      N :=
325 1
        Make_Subprogram_Specification
326 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Count)),
327
           Parameter_Profile   =>
328 1
             Make_List_Id
329 1
               (Make_Parameter_Specification
330
                  (Defining_Identifier =>
331 1
                     Make_Defining_Identifier (PN (P_Entity)),
332 1
                   Subtype_Mark   => RE (RE_Entity_Type),
333
                   Parameter_Mode => Mode_In),
334 1
                Make_Parameter_Specification
335
                  (Defining_Identifier =>
336 1
                     Make_Defining_Identifier (PN (P_Port)),
337
                   Subtype_Mark =>
338 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
339
                   Parameter_Mode => Mode_In)),
340 1
           Return_Type => RE (RE_Integer),
341 1
           Aspect_Specification => Runtime_Spec_Aspect_Definition);
342

343 1
      return N;
344
   end Get_Count_Spec;
345

346
   -------------------------
347
   -- Get_Time_Stamp_Spec --
348
   -------------------------
349

350 1
   function Get_Time_Stamp_Spec (E : Node_Id) return Node_Id is
351 1
      N : Node_Id;
352
   begin
353
      N :=
354 1
        Make_Subprogram_Specification
355
          (Defining_Identifier =>
356 1
             Make_Defining_Identifier (SN (S_Get_Time_Stamp)),
357
           Parameter_Profile =>
358 1
             Make_List_Id
359 1
               (Make_Parameter_Specification
360
                  (Defining_Identifier =>
361 1
                     Make_Defining_Identifier (PN (P_Entity)),
362 1
                   Subtype_Mark   => RE (RE_Entity_Type),
363
                   Parameter_Mode => Mode_In),
364 1
                Make_Parameter_Specification
365
                  (Defining_Identifier =>
366 1
                     Make_Defining_Identifier (PN (P_Port)),
367
                   Subtype_Mark =>
368 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
369
                   Parameter_Mode => Mode_In)),
370 1
           Return_Type => RE (RE_Time),
371 1
           Aspect_Specification => Runtime_Spec_Aspect_Definition);
372

373 1
      return N;
374
   end Get_Time_Stamp_Spec;
375

376
   ---------------------
377
   -- Next_Value_Spec --
378
   ---------------------
379

380 1
   function Next_Value_Spec (E : Node_Id) return Node_Id is
381 1
      N : Node_Id;
382
   begin
383
      N :=
384 1
        Make_Subprogram_Specification
385 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Next_Value)),
386
           Parameter_Profile   =>
387 1
             Make_List_Id
388 1
               (Make_Parameter_Specification
389
                  (Defining_Identifier =>
390 1
                     Make_Defining_Identifier (PN (P_Entity)),
391 1
                   Subtype_Mark   => RE (RE_Entity_Type),
392
                   Parameter_Mode => Mode_In),
393 1
                Make_Parameter_Specification
394
                  (Defining_Identifier =>
395 1
                     Make_Defining_Identifier (PN (P_Port)),
396
                   Subtype_Mark =>
397 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
398
                   Parameter_Mode => Mode_In)),
399
           Return_Type => No_Node);
400

401 1
      return N;
402
   end Next_Value_Spec;
403

404
   ---------------------------------
405
   -- Store_Received_Message_Spec --
406
   ---------------------------------
407

408 1
   function Store_Received_Message_Spec (E : Node_Id) return Node_Id is
409 1
      N : Node_Id;
410
   begin
411
      N :=
412 1
        Make_Subprogram_Specification
413
          (Defining_Identifier =>
414 1
             Make_Defining_Identifier (SN (S_Store_Received_Message)),
415
           Parameter_Profile =>
416 1
             Make_List_Id
417 1
               (Make_Parameter_Specification
418
                  (Defining_Identifier =>
419 1
                     Make_Defining_Identifier (PN (P_Entity)),
420 1
                   Subtype_Mark   => RE (RE_Entity_Type),
421
                   Parameter_Mode => Mode_In),
422 1
                Make_Parameter_Specification
423
                  (Defining_Identifier =>
424 1
                     Make_Defining_Identifier (PN (P_Thread_Interface)),
425
                   Subtype_Mark =>
426 1
                     Make_Defining_Identifier (Map_Port_Interface_Name (E)),
427
                   Parameter_Mode => Mode_In),
428 1
                Make_Parameter_Specification
429
                  (Defining_Identifier =>
430 1
                     Make_Defining_Identifier (PN (P_From)),
431 1
                   Subtype_Mark   => RE (RE_Entity_Type),
432
                   Parameter_Mode => Mode_In),
433 1
                Make_Parameter_Specification
434
                  (Defining_Identifier =>
435 1
                     Make_Defining_Identifier (PN (P_Time_Stamp)),
436 1
                   Subtype_Mark   => RE (RE_Time),
437
                   Parameter_Mode => Mode_In,
438 1
                   Expression     => RE (RE_Clock))),
439
           Return_Type => No_Node);
440

441 1
      return N;
442
   end Store_Received_Message_Spec;
443

444
   -----------------------------------
445
   -- Wait_For_Incoming_Events_Spec --
446
   -----------------------------------
447

448 1
   function Wait_For_Incoming_Events_Spec (E : Node_Id) return Node_Id is
449 1
      N : Node_Id;
450
   begin
451
      N :=
452 1
        Make_Subprogram_Specification
453
          (Defining_Identifier =>
454 1
             Make_Defining_Identifier (SN (S_Wait_For_Incoming_Events)),
455
           Parameter_Profile =>
456 1
             Make_List_Id
457 1
               (Make_Parameter_Specification
458
                  (Defining_Identifier =>
459 1
                     Make_Defining_Identifier (PN (P_Entity)),
460 1
                   Subtype_Mark   => RE (RE_Entity_Type),
461
                   Parameter_Mode => Mode_In),
462 1
                Make_Parameter_Specification
463
                  (Defining_Identifier =>
464 1
                     Make_Defining_Identifier (PN (P_Port)),
465
                   Subtype_Mark =>
466 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
467
                   Parameter_Mode => Mode_Out)),
468
           Return_Type => No_Node);
469 1
      return N;
470
   end Wait_For_Incoming_Events_Spec;
471

472
   ------------------
473
   -- Package_Spec --
474
   ------------------
475

476
   package body Package_Spec is
477

478
      procedure Visit_Architecture_Instance (E : Node_Id);
479
      procedure Visit_Component_Instance (E : Node_Id);
480
      procedure Visit_System_Instance (E : Node_Id);
481
      procedure Visit_Process_Instance (E : Node_Id);
482
      procedure Visit_Thread_Instance (E : Node_Id);
483
      procedure Visit_Device_Instance (E : Node_Id);
484
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
485

486
      procedure Runtime_Routine_Specs (E : Node_Id);
487
      --  Creates the specs of all the routines provided by the runtime
488
      --  to the user-code to manipulate thread interface.
489

490
      function Make_Mode_Updater_Spec (E : Node_Id) return Node_Id;
491
      --  Create the procedure which will update the current mode
492

493
      function Make_Modes_Enumeration (E : Node_Id) return Node_Id;
494
      --  Create the mode enumeration
495

496
      ---------------------------
497
      -- Runtime_Routine_Specs --
498
      ---------------------------
499

500 1
      procedure Runtime_Routine_Specs (E : Node_Id) is
501 1
         N : Node_Id;
502
      begin
503 1
         if Has_Out_Ports (E) then
504
            --  The following functions are made visible iff the
505
            --  thread has *out* ports
506

507
            --  Send_Output
508

509 1
            N := Send_Output_Spec (E);
510 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
511

512
            --  Put_Value
513

514 1
            N := Put_Value_Spec (E);
515 1
            Bind_AADL_To_Put_Value (Identifier (E), N);
516 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
517
         end if;
518

519 1
         if Has_In_Ports (E) then
520
            --  The following functions are made visible iff the
521
            --  thread has *in* ports
522

523
            --  Receive_Input
524

525 1
            N := Receive_Input_Spec (E);
526 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
527

528
            --  Get_Value
529

530 1
            N := Get_Value_Spec (E);
531 1
            Bind_AADL_To_Get_Value (Identifier (E), N);
532 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
533

534 1
            N := Get_Value_Spec_2 (E);
535 1
            Bind_AADL_To_Get_Value (Identifier (E), N);
536 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
537

538
            --  Get_Sender
539

540 1
            N := Get_Sender_Spec (E);
541 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
542

543
            --  Get_Count
544

545 1
            N := Get_Count_Spec (E);
546 1
            Bind_AADL_To_Get_Count (Identifier (E), N);
547 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
548

549
            --  Get_Time_Stamp
550

551 1
            N := Get_Time_Stamp_Spec (E);
552 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
553

554
            --  Next_Value
555

556 1
            N := Next_Value_Spec (E);
557 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
558

559 1
            N := Store_Received_Message_Spec (E);
560 1
            Bind_AADL_To_Store_Received_Message (Identifier (E), N);
561 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
562

563
            --  Wait_For_Incoming_Events
564

565 1
            N := Wait_For_Incoming_Events_Spec (E);
566 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
567
         end if;
568 1
      end Runtime_Routine_Specs;
569

570
      -----------
571
      -- Visit --
572
      -----------
573

574 1
      procedure Visit (E : Node_Id) is
575
      begin
576
         case Kind (E) is
577 1
            when K_Architecture_Instance =>
578 1
               Visit_Architecture_Instance (E);
579

580 1
            when K_Component_Instance =>
581 1
               Visit_Component_Instance (E);
582

583 0
            when others =>
584 0
               null;
585
         end case;
586 1
      end Visit;
587

588
      ---------------------------------
589
      -- Visit_Architecture_Instance --
590
      ---------------------------------
591

592 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
593
      begin
594 1
         Visit (Root_System (E));
595 1
      end Visit_Architecture_Instance;
596

597
      ------------------------------
598
      -- Visit_Component_Instance --
599
      ------------------------------
600

601 1
      procedure Visit_Component_Instance (E : Node_Id) is
602
         Category : constant Component_Category :=
603 1
           Get_Category_Of_Component (E);
604
      begin
605
         case Category is
606 1
            when CC_System =>
607 1
               Visit_System_Instance (E);
608

609 1
            when CC_Process =>
610 1
               Visit_Process_Instance (E);
611

612 1
            when CC_Thread =>
613 1
               Visit_Thread_Instance (E);
614

615 1
            when others =>
616 1
               null;
617 1
         end case;
618 1
      end Visit_Component_Instance;
619

620
      ----------------------------
621
      -- Visit_Process_Instance --
622
      ----------------------------
623

624 1
      procedure Visit_Process_Instance (E : Node_Id) is
625
         U : constant Node_Id :=
626 1
           ADN.Distributed_Application_Unit
627 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
628 1
         P                   : constant Node_Id              := ADN.Entity (U);
629 1
         S                   : Node_Id;
630 1
         N                   : Node_Id;
631
         Scheduling_Protocol : Supported_Scheduling_Protocol :=
632 1
           Get_Scheduling_Protocol (Get_Bound_Processor (E));
633
         The_System : constant Node_Id :=
634 1
           Parent_Component (Parent_Subcomponent (E));
635

636 1
         function Package_Spec_Aspect_Definition return Node_Id is
637
         begin
638 1
            if Add_SPARK2014_Annotations then
639 0
               return Make_Aspect_Specification
640 0
                 (Make_List_Id
641 0
                    (Make_Aspect (ASN (A_Initializes),
642 0
                                  Make_Initialization_Spec
643 0
                                    (Make_List_Id
644 0
                                       (Make_Defining_Identifier
645
                                          (PN (P_Elaborated_Variables))))),
646 0
                     Make_Aspect
647
                       (ASN (A_Abstract_State),
648 0
                        Make_Abstract_State_List
649 0
                          (Make_List_Id
650 0
                             (Make_State_Name_With_Option
651 0
                                (Make_Defining_Identifier
652
                                   (PN (P_Elaborated_Variables)),
653
                                 Synchronous => True,
654
                                 External => True))))));
655
            else
656 1
               return No_Node;
657
            end if;
658
         end Package_Spec_Aspect_Definition;
659

660
      begin
661 1
         Push_Entity (P);
662 1
         Push_Entity (U);
663 1
         Set_Activity_Spec;
664

665
         --  Start recording the handling since they have to be reset
666
         --  for each node.
667

668 1
         Start_Recording_Handlings;
669

670 1
         if Scheduling_Protocol = Unknown_Scheduler then
671 1
            Display_Located_Error
672 1
              (Loc (Get_Bound_Processor (E)),
673
               "Undefined scheduling protocol, " &
674
               "will use FIFO_WITHIN_PRIORITIES",
675
               Fatal   => False,
676
               Warning => True);
677

678 1
            Scheduling_Protocol := POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL;
679 1
         elsif Scheduling_Protocol /=
680
           POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL
681 0
           and then Scheduling_Protocol /= ROUND_ROBIN_PROTOCOL
682
         then
683 0
            Display_Located_Error
684 0
              (Loc (Parent_Subcomponent (E)),
685
               "Incompatible scheduling protocol, " &
686
               "PolyORB-HI/Ada runtime requires " &
687
               "POSIX_1003_HIGHEST_PRIORITY_FIRST_PROTOCOL or" &
688
               " ROUND_ROBIN_PROTOCOL",
689
               Fatal => True);
690

691
            --  XXX In case of Round robin, we should also check that
692
            --  the scheduler is set to non-preemptive mode.
693
         end if;
694

695 1
         ADN.Set_Aspect_Specification (Current_Package,
696 1
                                       Package_Spec_Aspect_Definition);
697

698
         --  Visit all the subcomponents of the process
699

700 1
         if not AINU.Is_Empty (Subcomponents (E)) then
701 1
            S := First_Node (Subcomponents (E));
702

703 1
            while Present (S) loop
704
               --  If the process has a data subcomponent, then map a
705
               --  shared variable.
706

707 1
               if AINU.Is_Data (Corresponding_Instance (S)) then
708
                  N :=
709 1
                    Make_Object_Declaration
710 1
                      (Defining_Identifier => Map_Ada_Defining_Identifier (S),
711
                       Object_Definition   =>
712 1
                         Map_Ada_Data_Type_Designator
713 1
                           (Corresponding_Instance (S)));
714 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
715

716
                  --  Link the variable and the object
717

718 1
                  Bind_AADL_To_Object (Identifier (S), N);
719

720 1
                  if Get_Concurrency_Protocol (Corresponding_Instance (S)) =
721
                    Priority_Ceiling
722
                  then
723
                     --  XXX For now, we disable SPARK_Mode due to the
724
                     --  inability of SPARK GPL2015 to support
725
                     --  variable that denotes protected objects.
726

727
                     N :=
728 1
                       Make_Pragma_Statement
729
                         (Pragma_SPARK_Mode,
730 1
                          Make_List_Id (RE (RE_Off)));
731

732 1
                     Append_Node_To_List
733
                       (N,
734 1
                        ADN.Package_Headers (Current_Package));
735
                  end if;
736

737
               else
738
                  --  Visit the component instance corresponding to the
739
                  --  subcomponent S.
740

741 1
                  Visit (Corresponding_Instance (S));
742
               end if;
743

744 1
               S := Next_Node (S);
745 1
            end loop;
746
         end if;
747

748
         --  Visit all devices attached to the parent system that
749
         --  share the same processor as process E.
750

751 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
752 1
            S := First_Node (Subcomponents (The_System));
753 1
            while Present (S) loop
754 1
               if AAU.Is_Device (Corresponding_Instance (S))
755
                 and then
756 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
757 1
                   Get_Bound_Processor (E)
758
               then
759 1
                  Visit_Device_Instance (Corresponding_Instance (S));
760
               end if;
761 1
               S := Next_Node (S);
762 1
            end loop;
763
         end if;
764

765
         --  Unmark all the marked types
766

767 1
         Reset_Handlings;
768

769 1
         Pop_Entity; -- U
770 1
         Pop_Entity; -- P
771 1
      end Visit_Process_Instance;
772

773
      ---------------------------
774
      -- Visit_Device_Instance --
775
      ---------------------------
776

777 1
      procedure Visit_Device_Instance (E : Node_Id) is
778 1
         Implementation : constant Node_Id := Get_Implementation (E);
779 1
         S              : Node_Id;
780
      begin
781 1
         if Implementation /= No_Node then
782 1
            if not AAU.Is_Empty (AAN.Subcomponents (Implementation)) then
783 1
               S := First_Node (Subcomponents (Implementation));
784 1
               while Present (S) loop
785 1
                  Visit_Component_Instance (Corresponding_Instance (S));
786 1
                  S := Next_Node (S);
787 1
               end loop;
788
            end if;
789
         end if;
790 1
      end Visit_Device_Instance;
791

792
      ---------------------------
793
      -- Visit_System_Instance --
794
      ---------------------------
795

796 1
      procedure Visit_System_Instance (E : Node_Id) is
797
      begin
798 1
         Push_Entity (Ada_Root);
799

800
         --  Visit all the subcomponents of the system
801

802 1
         Visit_Subcomponents_Of (E);
803

804 1
         Pop_Entity; --  Ada_Root
805 1
      end Visit_System_Instance;
806

807
      ---------------------------
808
      -- Visit_Thread_Instance --
809
      ---------------------------
810

811 1
      procedure Visit_Thread_Instance (E : Node_Id) is
812
         P : constant Supported_Thread_Dispatch_Protocol :=
813 1
           Get_Thread_Dispatch_Protocol (E);
814 1
         S : constant Node_Id := Parent_Subcomponent (E);
815 1
         N : Node_Id;
816 1
         O : Node_Id;
817

818
      begin
819 1
         if Has_Ports (E) then
820
            --  Create the spec of the subprograms to interact with
821
            --  thread ports.
822

823
            case P is
824 1
               when Thread_Periodic =>
825 1
                  N :=
826 1
                    Message_Comment
827
                      ("Periodic task : " &
828 1
                         Get_Name_String (Display_Name (Identifier (S))));
829 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
830

831 1
               when Thread_Sporadic =>
832 1
                  N :=
833 1
                    Message_Comment
834
                      ("Sporadic task : " &
835 1
                         Get_Name_String (Display_Name (Identifier (S))));
836 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
837

838 1
               when Thread_Hybrid =>
839 1
                  N :=
840 1
                    Message_Comment
841
                      ("Hybrid task : " &
842 1
                         Get_Name_String (Display_Name (Identifier (S))));
843 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
844

845 0
               when Thread_Aperiodic =>
846 0
                  N :=
847 0
                    Message_Comment
848 0
                      ("Aperiodic task : " &
849 0
                         Get_Name_String (Display_Name (Identifier (S))));
850 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
851

852 0
               when Thread_Background =>
853 0
                  N :=
854 0
                    Message_Comment
855 0
                      ("Background task : " &
856 0
                         Get_Name_String (Display_Name (Identifier (S))));
857 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
858

859 0
               when Thread_ISR =>
860 0
                  N :=
861 0
                    Message_Comment
862 0
                      ("ISR task : " &
863 0
                         Get_Name_String (Display_Name (Identifier (S))));
864 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
865

866 0
               when others =>
867 0
                  Display_Located_Error
868 0
                    (AIN.Loc (E),
869
                     "Unsupported dispatch protocol",
870
                     Fatal => True);
871
            end case;
872

873
            --  The data types and the interrogation routines
874
            --  generated from a thread are not instance specific. We
875
            --  generate them once per thread component. This allows
876
            --  us to support having multiple instances of the same
877
            --  thread in the model. Multiple thread instances of the
878
            --  same component share the same generated entities. This
879
            --  avoids having instance-specific code inside compute
880
            --  entrypoints.
881

882 1
            if No
883 1
                (Get_Handling
884 1
                   (Corresponding_Declaration (E),
885
                    By_Node,
886
                    H_Ada_Activity_Interr_Spec))
887
            then
888 1
               Set_Handling
889 1
                 (Corresponding_Declaration (E),
890
                  By_Node,
891
                  H_Ada_Activity_Interr_Spec,
892
                  E);
893

894 1
               N :=
895 1
                 Message_Comment
896
                   ("BEGIN: Entities used by all instances of component " &
897 1
                    Get_Name_String (Display_Name (Identifier (E))));
898 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
899

900
               --  Declare the enumeration type gathering all the
901
               --  thread ports.
902

903 1
               N := Map_Port_Enumeration (E);
904 1
               Bind_AADL_To_Port_Enumeration (Identifier (E), N);
905 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
906

907
               --  Declare the thread interface discriminated record type
908

909 1
               N := Map_Port_Interface (E);
910 1
               Bind_AADL_To_Port_Interface (Identifier (E), N);
911 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
912

913
               --  Declare the routines that allow user code to
914
               --  manipulate the thread.
915

916 1
               Runtime_Routine_Specs (E);
917

918 1
               N :=
919 1
                 Message_Comment
920
                   ("END: Entities used by all instances of component " &
921 1
                    Get_Name_String (Display_Name (Identifier (E))));
922 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
923
            else
924
               --  We bind the entities generated for the found
925
               --  instance to be able to reference them later.
926

927
               declare
928
                  Found : constant Node_Id :=
929 1
                    Get_Handling
930 1
                      (Corresponding_Declaration (E),
931
                       By_Node,
932
                       H_Ada_Activity_Interr_Spec);
933 1
                  BE : constant Node_Id := Backend_Node (Identifier (Found));
934
               begin
935
                  --  XXX
936 1
                  if Present (ADN.Port_Enumeration_Node (BE)) then
937 1
                     Bind_AADL_To_Port_Enumeration
938 1
                       (Identifier (E),
939 1
                        ADN.Port_Enumeration_Node (BE));
940
                  end if;
941

942 1
                  if Present (ADN.Port_Interface_Node (BE)) then
943 1
                     Bind_AADL_To_Port_Interface
944 1
                       (Identifier (E),
945 1
                        ADN.Port_Interface_Node (BE));
946
                  end if;
947

948 1
                  if Present (ADN.Put_Value_Node (BE)) then
949 1
                     Bind_AADL_To_Put_Value
950 1
                       (Identifier (E),
951 1
                        ADN.Put_Value_Node (BE));
952
                  end if;
953

954 1
                  if Present (ADN.Get_Value_Node (Be)) then
955 1
                     Bind_AADL_To_Get_Value
956 1
                       (Identifier (E),
957 1
                        ADN.Get_Value_Node (BE));
958
                  end if;
959 1
                  if Present (ADN.Get_Count_Node (BE)) then
960 1
                     Bind_AADL_To_Get_Count
961 1
                       (Identifier (E),
962 1
                        ADN.Get_Count_Node (BE));
963
                  end if;
964 1
                  if Present (ADN.Store_Received_Message_Node (BE)) then
965 1
                     Bind_AADL_To_Store_Received_Message
966 1
                       (Identifier (E),
967 1
                        ADN.Store_Received_Message_Node (BE));
968
                  end if;
969
               end;
970
            end if;
971
         end if;
972

973 1
         if Has_Modes (E) then
974
            --  If the thread has operational modes, then generate the
975
            --  enumeration type corresponding to the thread mode list
976
            --  and the procedure allowing to update the current mode.
977

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

981 1
            if Is_Fusioned (E) then
982 0
               N := Make_Mode_Updater_Spec (E);
983 0
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
984
            end if;
985
         end if;
986

987
         --  Visit thread local objects
988

989 1
         if not AINU.Is_Empty (Subcomponents (E)) then
990 0
            O := First_Node (Subcomponents (E));
991

992 0
            while Present (O) loop
993 0
               if AINU.Is_Data (Corresponding_Instance (O)) then
994
                  N :=
995 0
                    Make_Object_Declaration
996 0
                      (Defining_Identifier => Map_Ada_Defining_Identifier (O),
997
                       Object_Definition   =>
998 0
                         Map_Ada_Data_Type_Designator
999 0
                           (Corresponding_Instance (O)));
1000 0
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
1001

1002
                  --  Link the variable and the object
1003

1004 0
                  Bind_AADL_To_Object (Identifier (O), N);
1005
               end if;
1006

1007 0
               O := Next_Node (O);
1008 0
            end loop;
1009
         end if;
1010 1
      end Visit_Thread_Instance;
1011

1012
      ----------------------------
1013
      -- Make_Modes_Enumeration --
1014
      ----------------------------
1015

1016 1
      function Make_Modes_Enumeration (E : Node_Id) return Node_Id is
1017 1
         Enum_List : constant List_Id := New_List (ADN.K_Enumeration_Literals);
1018 1
         M         : Node_Id;
1019 1
         N         : Node_Id;
1020
      begin
1021 1
         M := First_Node (Modes (E));
1022

1023 1
         while Present (M) loop
1024 1
            N := Map_Ada_Defining_Identifier (M);
1025 1
            Append_Node_To_List (N, Enum_List);
1026

1027 1
            M := Next_Node (M);
1028 1
         end loop;
1029

1030
         N :=
1031 1
           Make_Full_Type_Declaration
1032
             (Defining_Identifier =>
1033 1
                Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)),
1034 1
              Type_Definition => Make_Enumeration_Type_Definition (Enum_List));
1035

1036 1
         return N;
1037
      end Make_Modes_Enumeration;
1038

1039
      ----------------------------
1040
      -- Make_Mode_Updater_Spec --
1041
      ----------------------------
1042

1043 0
      function Make_Mode_Updater_Spec (E : Node_Id) return Node_Id is
1044 0
         N : Node_Id;
1045
      begin
1046
         N :=
1047 0
           Make_Subprogram_Specification
1048
             (Defining_Identifier =>
1049 0
                Make_Defining_Identifier (SN (S_Change_Mode)),
1050
              Parameter_Profile =>
1051 0
                Make_List_Id
1052 0
                  (Make_Parameter_Specification
1053
                     (Defining_Identifier =>
1054 0
                        Make_Defining_Identifier (PN (P_Mode)),
1055
                      Subtype_Mark =>
1056 0
                        Make_Defining_Identifier
1057 0
                          (Map_Modes_Enumeration_Name (E)),
1058
                      Parameter_Mode => Mode_In)),
1059
              Return_Type => No_Node);
1060 0
         Set_Backend_Node (Identifier (First_Node (Modes (E))), N);
1061

1062 0
         return N;
1063
      end Make_Mode_Updater_Spec;
1064

1065
   end Package_Spec;
1066

1067
   ------------------
1068
   -- Package_Body --
1069
   ------------------
1070

1071
   package body Package_Body is
1072

1073
      procedure Visit_Architecture_Instance (E : Node_Id);
1074
      procedure Visit_Component_Instance (E : Node_Id);
1075
      procedure Visit_System_Instance (E : Node_Id);
1076
      procedure Visit_Process_Instance (E : Node_Id);
1077
      procedure Visit_Thread_Instance (E : Node_Id);
1078
      procedure Visit_Device_Instance (E : Node_Id);
1079
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
1080

1081
      procedure Runtime_Routine_Bodies (E : Node_Id);
1082
      --  Creates the implementations of all the routines provided by
1083
      --  the runtime to the user-code to manipulate thread interface.
1084

1085
      function Make_Current_Mode_Declaration (E : Node_Id) return Node_Id;
1086
      --  Create, if necessary, the current mode variable declaration for
1087
      --  thread E.
1088

1089
      function Make_Mode_Updater_body (E : Node_Id) return Node_Id;
1090
      --  Create the procedure which will update the current mode
1091

1092 1
      Current_Mode_Identifier : Node_Id;
1093

1094
      --  The runtime routines are generated per thread component and
1095
      --  not per thread instance. For each thread instance, we must
1096
      --  complete the case alternative specific to it in each one of
1097
      --  the routines. To perform this, we attache to each thread
1098
      --  component a set of List_Id's which represent the case
1099
      --  statement of the corresponding routines. The entities below
1100
      --  allow to Get/Set these list for each thread component.
1101

1102
      type Runtime_Routine is
1103
        (RR_Send_Output,
1104
         RR_Put_Value,
1105
         RR_Receive_Input,
1106
         RR_Get_Value,
1107
         RR_Get_Sender,
1108
         RR_Get_Count,
1109
         RR_Get_Time_Stamp,
1110
         RR_Next_Value,
1111
         RR_Store_Received_Message,
1112
         RR_Wait_For_Incoming_Events);
1113

1114
      function Get_List_Internal_Name
1115
        (Thread : Node_Id;
1116
         RR     : Runtime_Routine) return Name_Id;
1117
      --  Code factorization between the two subprograms below
1118

1119
      function Get_List
1120
        (Thread : Node_Id;
1121
         RR     : Runtime_Routine) return List_Id;
1122
      --  Return the List_Id corresponding to the runtime routine 'RR'
1123
      --  and associated to 'Thread'.
1124

1125
      procedure Set_List (Thread : Node_Id; RR : Runtime_Routine; L : List_Id);
1126
      --  Set a new value (L) to the list corresponding to the runtime
1127
      --  routine 'RR' and associated to 'Thread'.
1128

1129 1
      Interrogation_Routine_List : List_Id;
1130
      --  This list will hold all the bodies declarations of the
1131
      --  interrogation routines. We do this to ensure all the bodies
1132
      --  are appended after all entities generated for threads since
1133
      --  they need visibility on these entities.
1134

1135
      Package_Body_Refined_States : List_Id := No_List;
1136

1137
      function Runtime_Body_Aspect_Definition
1138
        (E : Node_Id; RR : Runtime_Routine) return Node_Id;
1139
      --  Build aspect definition for runtime services
1140

1141
      ------------------------------------
1142
      -- Runtime_Body_Aspect_Definition --
1143
      ------------------------------------
1144

1145 1
      function Runtime_Body_Aspect_Definition
1146
        (E : Node_Id; RR : Runtime_Routine) return Node_Id is
1147
      begin
1148 1
         if Add_SPARK2014_Annotations and then
1149 0
           (RR = RR_Send_Output or else
1150 0
              RR = RR_Get_Value or else
1151 0
              RR = RR_Get_Sender or else
1152 0
              RR = RR_Get_Count or else
1153 0
              RR = Rr_Get_Time_Stamp)
1154
         then
1155 0
            return Make_Aspect_Specification
1156 0
              (Make_List_Id
1157 0
                 (Make_Aspect
1158
                    (ASN (A_Refined_Global),
1159 0
                     Make_Global_Specification
1160 0
                       (Make_List_Id
1161 0
                          (Make_Moded_Global_List
1162
                             (Mode_In,
1163 0
                              Map_Refined_Global_Name (E)))))));
1164
         else
1165 1
            return No_Node;
1166
         end if;
1167
      end Runtime_Body_Aspect_Definition;
1168

1169
      ----------------------------
1170
      -- Runtime_Routine_Bodies --
1171
      ----------------------------
1172

1173 1
      procedure Runtime_Routine_Bodies (E : Node_Id) is
1174 1
         N           : Node_Id;
1175
         Not_Handled : constant Boolean :=
1176 1
           No
1177 1
             (Get_Handling
1178 1
                (Corresponding_Declaration (E),
1179
                 By_Node,
1180
                 H_Ada_Activity_Interr_Body));
1181
      begin
1182
         --  The data types and the interrogation routines generated
1183
         --  from a thread are not instance specific. We generate them
1184
         --  once per thread component. This allows us to support
1185
         --  having multiple instances of the same thread in the
1186
         --  model. Multiple thread instances of the same component
1187
         --  share the same generated entities. This avoids having
1188
         --  instance-specific code inside compute entrypoints.
1189

1190 1
         Set_Handling
1191 1
           (Corresponding_Declaration (E),
1192
            By_Node,
1193
            H_Ada_Activity_Interr_Body,
1194
            E);
1195

1196 1
         if Not_Handled then
1197 1
            N :=
1198 1
              Message_Comment
1199
                ("BEGIN: Data types used by all instances of component " &
1200 1
                 Get_Name_String (Display_Name (Identifier (E))));
1201 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1202

1203
            --  Declare the <Thread>_Integer_Array type
1204

1205
            N :=
1206 1
              Make_Full_Type_Declaration
1207 1
                (Make_Defining_Identifier (Map_Integer_Array_Name (E)),
1208 1
                 Make_Array_Type_Definition
1209 1
                   (Make_List_Id
1210 1
                      (Make_Defining_Identifier
1211 1
                         (Map_Port_Enumeration_Name (E))),
1212 1
                    RE (RE_Integer)));
1213 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1214

1215
            --  Declare the <Thread>_Kind_Array type
1216

1217
            N :=
1218 1
              Make_Full_Type_Declaration
1219 1
                (Make_Defining_Identifier (Map_Kind_Array_Name (E)),
1220 1
                 Make_Array_Type_Definition
1221 1
                   (Make_List_Id
1222 1
                      (Make_Defining_Identifier
1223 1
                         (Map_Port_Enumeration_Name (E))),
1224 1
                    RE (RE_Port_Kind)));
1225 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1226

1227
            --  Declare the <Thread>_Image_Array type
1228

1229
            N :=
1230 1
              Make_Full_Type_Declaration
1231 1
                (Make_Defining_Identifier (Map_Image_Array_Name (E)),
1232 1
                 Make_Array_Type_Definition
1233
                   (Range_Constraints =>
1234 1
                      Make_List_Id
1235 1
                        (Make_Defining_Identifier
1236 1
                           (Map_Port_Enumeration_Name (E))),
1237
                    Component_Definition =>
1238 1
                      Make_Indexed_Component
1239 1
                        (RE (RE_String),
1240 1
                         Make_List_Id
1241 1
                           (Make_Range_Constraint
1242 1
                              (Make_Literal (New_Integer_Value (1, 0, 10)),
1243 1
                               RE (RE_Max_Port_Image_Size))))));
1244 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1245

1246
            --  Declare the <Thread>_Overflow_Protocol_Array type
1247

1248
            N :=
1249 1
              Make_Full_Type_Declaration
1250 1
                (Make_Defining_Identifier
1251 1
                   (Map_Overflow_Protocol_Array_Name (E)),
1252 1
                 Make_Array_Type_Definition
1253 1
                   (Make_List_Id
1254 1
                      (Make_Defining_Identifier
1255 1
                         (Map_Port_Enumeration_Name (E))),
1256 1
                    RE (RE_Overflow_Handling_Protocol)));
1257 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1258

1259 1
            N :=
1260 1
              Message_Comment
1261
                ("END: Data types used by all instances of component " &
1262 1
                 Get_Name_String (Display_Name (Identifier (E))));
1263 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1264
         end if;
1265

1266
         --  Declare the FIFO size related entities
1267

1268
         declare
1269 1
            F                    : Node_Id;
1270
            Port_Kinds_Aggregate : constant List_Id :=
1271 1
              New_List (ADN.K_Element_List);
1272
            Overflow_Protocols_Aggregate : constant List_Id :=
1273 1
              New_List (ADN.K_Element_List);
1274
            Port_Images_Aggregate : constant List_Id :=
1275 1
              New_List (ADN.K_Element_List);
1276
            FIFO_Sizes_Aggregate : constant List_Id :=
1277 1
              New_List (ADN.K_Element_List);
1278
            Offset_Aggregate : constant List_Id :=
1279 1
              New_List (ADN.K_Element_List);
1280
            Urgencies_Aggregate : constant List_Id :=
1281 1
              New_List (ADN.K_Element_List);
1282 1
            Total_FIFO_Size   : Unsigned_Long_Long := 0;
1283 1
            Port_Kind         : RE_Id;
1284 1
            Overflow_Protocol : RE_Id;
1285 1
            Queue_Size        : Long_Long;
1286 1
            Queue_Size_V      : Value_Id;
1287 1
            Offset_V          : Value_Id;
1288
         begin
1289 1
            F := First_Node (Features (E));
1290

1291 1
            while Present (F) loop
1292 1
               if Kind (F) = K_Port_Spec_Instance then
1293 1
                  if Is_Event (F) then
1294 1
                     if not AIN.Is_Data (F) then
1295 1
                        Port_Kind := RE_In_Event_Port;
1296
                     else
1297 1
                        Port_Kind := RE_In_Event_Data_Port;
1298
                     end if;
1299
                  else
1300 1
                     Port_Kind := RE_In_Data_Port;
1301
                  end if;
1302

1303 1
                  if Is_In (F) then
1304 1
                     if Is_Out (F) then
1305
                        Port_Kind := RE_Id'Val (RE_Id'Pos (Port_Kind) + 3);
1306
                     end if;
1307
                  else
1308
                     Port_Kind := RE_Id'Val (RE_Id'Pos (Port_Kind) + 6);
1309
                  end if;
1310

1311
                  N :=
1312 1
                    Make_Element_Association
1313 1
                      (Map_Ada_Defining_Identifier (F),
1314 1
                       RE (Port_Kind));
1315 1
                  Append_Node_To_List (N, Port_Kinds_Aggregate);
1316

1317
                  N :=
1318 1
                    Make_Element_Association
1319 1
                      (Map_Ada_Defining_Identifier (F),
1320 1
                       (Make_Indexed_Component
1321 1
                          (RE (RE_Port_Image),
1322 1
                           Make_List_Id (Extract_Enumerator (F)))));
1323 1
                  Append_Node_To_List (N, Port_Images_Aggregate);
1324

1325
                  case Get_Overflow_Handling_Protocol (F) is
1326 1
                     when Overflow_Handling_Protocol_DropOldest |
1327
                       Overflow_Handling_Protocol_None          =>
1328 1
                        Overflow_Protocol := RE_DropOldest;
1329 0
                     when Overflow_Handling_Protocol_DropNewest =>
1330 0
                        Overflow_Protocol := RE_DropNewest;
1331 0
                     when Overflow_Handling_Protocol_Error =>
1332 0
                        Overflow_Protocol := RE_Error;
1333
                  end case;
1334
                  N :=
1335 1
                    Make_Element_Association
1336 1
                      (Map_Ada_Defining_Identifier (F),
1337 1
                       RE (Overflow_Protocol));
1338 1
                  Append_Node_To_List (N, Overflow_Protocols_Aggregate);
1339

1340
                  --  Element association for the Urgencies array
1341

1342
                  N :=
1343 1
                    Make_Element_Association
1344 1
                      (Map_Ada_Defining_Identifier (F),
1345 1
                       Make_Literal
1346 1
                         (New_Integer_Value (Get_Port_Urgency (F), 1, 10)));
1347 1
                  Append_Node_To_List (N, Urgencies_Aggregate);
1348

1349
                  --  Convention for queue sizes:
1350

1351
                  --  IN [OUT] EVENT [DADA] ports: user-specified or
1352
                  --  else default value.
1353

1354
                  --  IN [OUT] DATA ports: 1 or 2 depending on the
1355
                  --  connection natue.
1356

1357
                  --  OUT [EVENT] [DATA] ports: -2
1358

1359 1
                  Queue_Size := 0;
1360

1361 1
                  if Is_Out (F) then
1362 1
                     Queue_Size_V := New_Integer_Value (1, -1, 10);
1363 1
                     Offset_V     := New_Integer_Value (0, 1, 10);
1364 1
                  elsif AIN.Is_Data (F) and then not Is_Event (F) then
1365

1366
                     --  Get a connection whose source is F
1367

1368 1
                     if Is_Delayed (F) then
1369
                        --  This data port belongs to a delayed
1370
                        --  connection: tell the middlware routines
1371
                        --  about it
1372

1373 0
                        Queue_Size := 2;
1374
                     else
1375
                        --  Immediate connection
1376

1377 1
                        Queue_Size := 1;
1378
                     end if;
1379

1380
                     Queue_Size_V :=
1381
                       New_Integer_Value
1382
                         (Unsigned_Long_Long (Queue_Size),
1383
                          1,
1384
                          10);
1385 1
                     Offset_V :=
1386 1
                       New_Integer_Value (Total_FIFO_Size + 1, 1, 10);
1387
                  else
1388 1
                     Queue_Size := Get_Queue_Size (F);
1389

1390 1
                     if Queue_Size = -1 then
1391 1
                        Queue_Size := Default_Queue_Size;
1392
                        --  For the calculation of the total queue
1393
                        --  size.
1394

1395
                        --  Allocate a default size
1396

1397
                        Queue_Size_V :=
1398 1
                          New_Integer_Value (Default_Queue_Size, 1, 10);
1399 1
                     elsif Queue_Size = 0 then
1400
                        --  0 length queues are not supported
1401

1402 0
                        Display_Located_Error
1403 0
                          (Loc (F),
1404
                           "Zero length port queues are not supported yet",
1405
                           Fatal => True);
1406
                     else
1407
                        Queue_Size_V :=
1408
                          New_Integer_Value
1409
                            (Unsigned_Long_Long (Queue_Size),
1410
                             1,
1411
                             10);
1412
                     end if;
1413

1414
                     --  The offset value is equal to the current
1415
                     --  value of Total_FIFO_Size + 1.
1416

1417
                     Offset_V :=
1418 1
                       New_Integer_Value (Total_FIFO_Size + 1, 1, 10);
1419
                  end if;
1420

1421
                  --  Element association for the FIFO sizes array
1422

1423
                  N :=
1424 1
                    Make_Element_Association
1425 1
                      (Map_Ada_Defining_Identifier (F),
1426 1
                       Make_Literal (Queue_Size_V));
1427 1
                  Append_Node_To_List (N, FIFO_Sizes_Aggregate);
1428

1429
                  --  Element association for the offset array
1430

1431
                  N :=
1432 1
                    Make_Element_Association
1433 1
                      (Map_Ada_Defining_Identifier (F),
1434 1
                       Make_Literal (Offset_V));
1435 1
                  Append_Node_To_List (N, Offset_Aggregate);
1436

1437
                  --  Update the global FIFO size in case Queue_Size is
1438
                  --  positive.
1439

1440 1
                  if Queue_Size > 0 then
1441 1
                     Total_FIFO_Size :=
1442
                       Total_FIFO_Size + Unsigned_Long_Long (Queue_Size);
1443
                  end if;
1444
               end if;
1445

1446 1
               F := Next_Node (F);
1447 1
            end loop;
1448

1449
            --  Declare the entities
1450

1451
            N :=
1452 1
              Make_Object_Declaration
1453
                (Defining_Identifier =>
1454 1
                   Make_Defining_Identifier (Map_Port_Kinds_Name (E)),
1455
                 Object_Definition =>
1456 1
                   Make_Defining_Identifier (Map_Kind_Array_Name (E)),
1457
                 Constant_Present => True,
1458 1
                 Expression => Make_Array_Aggregate (Port_Kinds_Aggregate));
1459 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1460

1461
            N :=
1462 1
              Make_Object_Declaration
1463
                (Defining_Identifier =>
1464 1
                   Make_Defining_Identifier (Map_Port_Images_Name (E)),
1465
                 Object_Definition =>
1466 1
                   Make_Defining_Identifier (Map_Image_Array_Name (E)),
1467
                 Constant_Present => True,
1468 1
                 Expression => Make_Array_Aggregate (Port_Images_Aggregate));
1469 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1470

1471
            N :=
1472 1
              Make_Object_Declaration
1473
                (Defining_Identifier =>
1474 1
                   Make_Defining_Identifier (Map_FIFO_Sizes_Name (E)),
1475
                 Object_Definition =>
1476 1
                   Make_Defining_Identifier (Map_Integer_Array_Name (E)),
1477
                 Constant_Present => True,
1478 1
                 Expression => Make_Array_Aggregate (FIFO_Sizes_Aggregate));
1479 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1480

1481
            N :=
1482 1
              Make_Object_Declaration
1483
                (Defining_Identifier =>
1484 1
                   Make_Defining_Identifier (Map_Offsets_Name (E)),
1485
                 Object_Definition =>
1486 1
                   Make_Defining_Identifier (Map_Integer_Array_Name (E)),
1487
                 Constant_Present => True,
1488 1
                 Expression       => Make_Array_Aggregate (Offset_Aggregate));
1489 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1490

1491
            N :=
1492 1
              Make_Object_Declaration
1493
                (Defining_Identifier =>
1494 1
                   Make_Defining_Identifier (Map_Overflow_Protocols_Name (E)),
1495
                 Object_Definition =>
1496 1
                   Make_Defining_Identifier
1497 1
                     (Map_Overflow_Protocol_Array_Name (E)),
1498
                 Constant_Present => True,
1499
                 Expression       =>
1500 1
                   Make_Array_Aggregate (Overflow_Protocols_Aggregate));
1501 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1502

1503
            N :=
1504 1
              Make_Object_Declaration
1505
                (Defining_Identifier =>
1506 1
                   Make_Defining_Identifier (Map_Urgencies_Name (E)),
1507
                 Object_Definition =>
1508 1
                   Make_Defining_Identifier (Map_Integer_Array_Name (E)),
1509
                 Constant_Present => True,
1510 1
                 Expression => Make_Array_Aggregate (Urgencies_Aggregate));
1511 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1512

1513
            N :=
1514 1
              Make_Object_Declaration
1515
                (Defining_Identifier =>
1516 1
                   Make_Defining_Identifier (Map_Total_Size_Name (E)),
1517 1
                 Object_Definition => RE (RE_Integer),
1518
                 Constant_Present  => True,
1519
                 Expression        =>
1520 1
                   Make_Literal (New_Integer_Value (Total_FIFO_Size, 1, 10)));
1521 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1522
         end;
1523

1524
         --  For each OUT port, we create an array of its
1525
         --  destinations, we declare the number of its destinations
1526
         --  and create an element association in the global
1527
         --  destinations array.
1528

1529
         declare
1530 1
            F                       : Node_Id;
1531
            N_Destination_Aggregate : constant List_Id :=
1532 1
              New_List (ADN.K_Element_List);
1533
            Destination_Aggregate : constant List_Id :=
1534 1
              New_List (ADN.K_Element_List);
1535

1536
            Statements : List_Id :=
1537 1
              New_List (ADN.K_Statement_List);
1538 1
            Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1539

1540
         begin
1541 1
            F := First_Node (Features (E));
1542

1543 1
            while Present (F) loop
1544 1
               if Kind (F) = K_Port_Spec_Instance then
1545
                  --  For OUT ports, we generate an array to indicate
1546
                  --  their destinations and we put relevant element
1547
                  --  associations in the Destinations arrays. For IN
1548
                  --  ports, we generate nothing and we put dummy
1549
                  --  element association.
1550

1551 1
                  if Is_Out (F) then
1552
                     declare
1553 1
                        D                  : Node_Id;
1554
                        Port_Dst_Aggregate : constant List_Id :=
1555 1
                          New_List (ADN.K_Element_List);
1556
                        Destinations : constant List_Id :=
1557 1
                          Get_Destination_Ports (F);
1558 1
                        Dst_Index : Unsigned_Long_Long := 1;
1559
                     begin
1560 1
                        if AINU.Is_Empty (Destinations) then
1561 0
                           Display_Located_Error
1562 0
                             (Loc (F),
1563
                              "This OUT port is not connected to any" &
1564
                              " destination",
1565
                              Fatal => True);
1566
                        end if;
1567

1568 1
                        D := First_Node (Destinations);
1569

1570 1
                        while Present (D) loop
1571 1
                           if not AINU.Is_Device
1572 1
                               (Parent_Component (Item (D)))
1573
                           then
1574
                              N :=
1575 1
                                Make_Element_Association
1576 1
                                  (Make_Literal
1577 1
                                     (New_Integer_Value (Dst_Index, 1, 10)),
1578 1
                                   Extract_Enumerator (Item (D)));
1579 1
                              Append_Node_To_List (N, Port_Dst_Aggregate);
1580 1
                              Dst_Index := Dst_Index + 1;
1581
                           end if;
1582 1
                           D := Next_Node (D);
1583 1
                        end loop;
1584

1585
                        --  Declare the port specific destination
1586
                        --  array.
1587

1588 1
                        if not Is_Empty (Port_Dst_Aggregate) then
1589
                           N :=
1590 1
                             Make_Object_Declaration
1591
                               (Defining_Identifier =>
1592 1
                                  Make_Defining_Identifier
1593 1
                                    (Map_Destination_Name (F)),
1594
                                Object_Definition =>
1595 1
                                  RE (RE_Destinations_Array),
1596
                                Constant_Present => True,
1597
                                Expression       =>
1598 1
                                  Make_Array_Aggregate (Port_Dst_Aggregate));
1599 1
                           Append_Node_To_List
1600
                             (N,
1601 1
                              ADN.Statements (Current_Package));
1602

1603
                           N :=
1604 1
                             Make_Element_Association
1605 1
                               (Map_Ada_Defining_Identifier (F),
1606 1
                                Make_Literal
1607 1
                                  (New_Integer_Value
1608
                                     (Unsigned_Long_Long
1609 1
                                        (AINU.Length (Destinations)),
1610
                                      1,
1611
                                      10)));
1612 1
                           Append_Node_To_List (N, N_Destination_Aggregate);
1613

1614
                           N :=
1615 1
                             Make_Element_Association
1616 1
                               (Map_Ada_Defining_Identifier (F),
1617 1
                                Make_Attribute_Designator
1618 1
                                  (Make_Designator (Map_Destination_Name (F)),
1619
                                   A_Address));
1620 1
                           Append_Node_To_List (N, Destination_Aggregate);
1621

1622 1
                           Statements := Make_List_Id
1623 1
                             (Make_Pragma_Statement
1624
                                (Pragma_Unreferenced,
1625 1
                                 Make_List_Id
1626 1
                                   (Make_Defining_Identifier
1627
                                      (PN (P_Port)))),
1628 1
                              Make_Return_Statement
1629 1
                                (Make_Designator (Map_Destination_Name (F))));
1630

1631
                           N :=
1632 1
                             Make_Case_Statement_Alternative
1633 1
                             (Make_List_Id
1634 1
                                (Map_Ada_Defining_Identifier (F)),
1635
                              Statements);
1636 1
                           Append_Node_To_List (N, Alternatives);
1637

1638
                        else
1639 1
                           Statements := Make_List_Id
1640 1
                             (Make_Return_Statement
1641 1
                                (RE (RE_Empty_Destination)));
1642

1643
                           N :=
1644 1
                             Make_Case_Statement_Alternative
1645 1
                             (Make_List_Id
1646 1
                                (Map_Ada_Defining_Identifier (F)),
1647
                              Statements);
1648 1
                           Append_Node_To_List (N, Alternatives);
1649

1650
                           N :=
1651 1
                             Make_Element_Association
1652 1
                               (Map_Ada_Defining_Identifier (F),
1653 1
                                Make_Literal (New_Integer_Value (0, 1, 10)));
1654 1
                           Append_Node_To_List (N, N_Destination_Aggregate);
1655

1656
                           N :=
1657 1
                             Make_Element_Association
1658 1
                               (Map_Ada_Defining_Identifier (F),
1659 1
                                RE (RE_Null_Address));
1660 1
                           Append_Node_To_List (N, Destination_Aggregate);
1661
                        end if;
1662

1663
                     end;
1664
                  else
1665
                     --  Dummy element associations
1666 1
                     Statements := Make_List_Id
1667 1
                       (Make_Pragma_Statement
1668
                          (Pragma_Unreferenced,
1669 1
                           Make_List_Id
1670 1
                             (Make_Defining_Identifier
1671
                                (PN (P_Port)))),
1672 1
                        Make_Return_Statement
1673 1
                          (RE (RE_Empty_Destination)));
1674

1675
                     N :=
1676 1
                       Make_Case_Statement_Alternative
1677 1
                       (Make_List_Id
1678 1
                          (Map_Ada_Defining_Identifier (F)),
1679
                        Statements);
1680 1
                     Append_Node_To_List (N, Alternatives);
1681

1682
                     N :=
1683 1
                       Make_Element_Association
1684 1
                         (Map_Ada_Defining_Identifier (F),
1685 1
                          Make_Literal (New_Integer_Value (0, 1, 10)));
1686 1
                     Append_Node_To_List (N, N_Destination_Aggregate);
1687

1688
                     N :=
1689 1
                       Make_Element_Association
1690 1
                         (Map_Ada_Defining_Identifier (F),
1691 1
                          RE (RE_Null_Address));
1692 1
                     Append_Node_To_List (N, Destination_Aggregate);
1693
                  end if;
1694

1695
               end if;
1696

1697 1
               F := Next_Node (F);
1698 1
            end loop;
1699

1700
            --  Define the Destinations function
1701

1702 1
            if Length (Alternatives) > 1 then
1703
               Statements :=
1704 1
                make_list_id (Make_Case_Statement
1705 1
                 (Make_Defining_Identifier (CN (C_Port)),
1706
                  Alternatives));
1707
            end if;
1708

1709
            N :=
1710 1
              Make_Subprogram_Specification
1711
                (Defining_Identifier =>
1712 1
                   Make_Defining_Identifier (Map_Destination_Name (E)),
1713
                 Parameter_Profile =>
1714 1
                   Make_List_Id
1715 1
                   (Make_Parameter_Specification
1716
                      (Defining_Identifier =>
1717 1
                         Make_Defining_Identifier (PN (P_Port)),
1718
                       Subtype_Mark   =>
1719 1
                         Make_Defining_Identifier
1720 1
                         (Map_Port_Enumeration_Name (E)),
1721
                       Parameter_Mode => Mode_In)),
1722 1
                 Return_Type => RE (RE_Destinations_Array));
1723 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1724

1725 1
            N := Make_Subprogram_Implementation (N, No_List, Statements);
1726 1
            Append_Node_To_List (N, Interrogation_Routine_List);
1727
         end;
1728

1729
         --  Instantiate the PolyORB_HI.Interrogators generic
1730

1731
         declare
1732
            Inst_Profile : constant List_Id :=
1733 1
              New_List (ADN.K_Parameter_Profile);
1734
         begin
1735
            --  The 'Port_Type' generic formal
1736

1737
            N :=
1738 1
              Make_Parameter_Association
1739 1
                (Make_Defining_Identifier (TN (T_Port_Type)),
1740 1
                 Make_Defining_Identifier (Map_Port_Enumeration_Name (E)));
1741 1
            Append_Node_To_List (N, Inst_Profile);
1742

1743
            --  The 'Integer_Array' generic formal
1744

1745
            N :=
1746 1
              Make_Parameter_Association
1747 1
                (Make_Defining_Identifier (TN (T_Integer_Array)),
1748 1
                 Make_Defining_Identifier (Map_Integer_Array_Name (E)));
1749 1
            Append_Node_To_List (N, Inst_Profile);
1750

1751
            --  The 'Kind_Array' generic formal
1752

1753
            N :=
1754 1
              Make_Parameter_Association
1755 1
                (Make_Defining_Identifier (TN (T_Port_Kind_Array)),
1756 1
                 Make_Defining_Identifier (Map_Kind_Array_Name (E)));
1757 1
            Append_Node_To_List (N, Inst_Profile);
1758

1759
            --  The 'Image_Array' generic formal
1760

1761
            N :=
1762 1
              Make_Parameter_Association
1763 1
                (Make_Defining_Identifier (TN (T_Port_Image_Array)),
1764 1
                 Make_Defining_Identifier (Map_Image_Array_Name (E)));
1765 1
            Append_Node_To_List (N, Inst_Profile);
1766

1767
            --  The 'Overflow_Protocol_Array' generic formal
1768

1769
            N :=
1770 1
              Make_Parameter_Association
1771 1
                (Make_Defining_Identifier (TN (T_Overflow_Protocol_Array)),
1772 1
                 Make_Defining_Identifier
1773 1
                   (Map_Overflow_Protocol_Array_Name (E)));
1774 1
            Append_Node_To_List (N, Inst_Profile);
1775

1776
            --  The 'Thread_Interface' generic formal
1777

1778
            N :=
1779 1
              Make_Parameter_Association
1780 1
                (Make_Defining_Identifier (TN (T_Thread_Interface_Type)),
1781 1
                 Make_Defining_Identifier (Map_Port_Interface_Name (E)));
1782 1
            Append_Node_To_List (N, Inst_Profile);
1783

1784
            --  The 'Current_Entity' generic formal
1785

1786
            N :=
1787 1
              Make_Parameter_Association
1788 1
                (Make_Defining_Identifier (PN (P_Current_Entity)),
1789 1
                 Extract_Enumerator (E));
1790 1
            Append_Node_To_List (N, Inst_Profile);
1791

1792
            --  The 'Thread_Port_Kinds' generic formal
1793

1794
            N :=
1795 1
              Make_Parameter_Association
1796 1
                (Make_Defining_Identifier (PN (P_Thread_Port_Kinds)),
1797 1
                 Make_Defining_Identifier (Map_Port_Kinds_Name (E)));
1798 1
            Append_Node_To_List (N, Inst_Profile);
1799

1800
            --  The 'Has_Event_Ports' generic formal
1801

1802
            N :=
1803 1
              Make_Parameter_Association
1804 1
                (Make_Defining_Identifier (PN (P_Has_Event_Ports)),
1805 1
                 Make_Literal
1806 1
                   (New_Boolean_Value
1807 1
                      (Has_In_Event_Ports (E)
1808 1
                       or else Has_Out_Event_Ports (E))));
1809 1
            Append_Node_To_List (N, Inst_Profile);
1810

1811
            --  The 'Thread_Port_Images' generic formal
1812

1813
            N :=
1814 1
              Make_Parameter_Association
1815 1
                (Make_Defining_Identifier (PN (P_Thread_Port_Images)),
1816 1
                 Make_Defining_Identifier (Map_Port_Images_Name (E)));
1817 1
            Append_Node_To_List (N, Inst_Profile);
1818

1819
            --  The 'Thread_Fifo_Sizes' generic formal
1820

1821
            N :=
1822 1
              Make_Parameter_Association
1823 1
                (Make_Defining_Identifier (PN (P_Thread_Fifo_Sizes)),
1824 1
                 Make_Defining_Identifier (Map_FIFO_Sizes_Name (E)));
1825 1
            Append_Node_To_List (N, Inst_Profile);
1826

1827
            --  The 'Thread_Fifo_Offsets' generic formal
1828

1829
            N :=
1830 1
              Make_Parameter_Association
1831 1
                (Make_Defining_Identifier (PN (P_Thread_Fifo_Offsets)),
1832 1
                 Make_Defining_Identifier (Map_Offsets_Name (E)));
1833 1
            Append_Node_To_List (N, Inst_Profile);
1834

1835
            --  The 'Thread_Overflow_Protocols' generic formal
1836

1837
            N :=
1838 1
              Make_Parameter_Association
1839 1
                (Make_Defining_Identifier (PN (P_Thread_Overflow_Protocols)),
1840 1
                 Make_Defining_Identifier (Map_Overflow_Protocols_Name (E)));
1841 1
            Append_Node_To_List (N, Inst_Profile);
1842

1843
            --  The 'Urgencies' generic formal
1844

1845
            N :=
1846 1
              Make_Parameter_Association
1847 1
                (Make_Defining_Identifier (PN (P_Urgencies)),
1848 1
                 Make_Defining_Identifier (Map_Urgencies_Name (E)));
1849 1
            Append_Node_To_List (N, Inst_Profile);
1850

1851
            --  The 'Global_Data_Queue_Size' generic formal
1852

1853
            N :=
1854 1
              Make_Parameter_Association
1855 1
                (Make_Defining_Identifier (PN (P_Global_Data_Queue_Size)),
1856 1
                 Make_Defining_Identifier (Map_Total_Size_Name (E)));
1857 1
            Append_Node_To_List (N, Inst_Profile);
1858

1859
            --  The 'Destinations' generic formal
1860

1861
            N :=
1862 1
              Make_Parameter_Association
1863 1
                (Make_Defining_Identifier (PN (P_Destinations)),
1864 1
                 Make_Defining_Identifier (Map_Destination_Name (E)));
1865 1
            Append_Node_To_List (N, Inst_Profile);
1866

1867
            --  The 'Marshall' generic formal
1868

1869
            N :=
1870 1
              Make_Parameter_Association
1871 1
                (Make_Defining_Identifier (SN (S_Marshall)),
1872 1
                 Extract_Designator
1873 1
                   (ADN.Marshall_Node (Backend_Node (Identifier (E)))));
1874 1
            Append_Node_To_List (N, Inst_Profile);
1875

1876
            --  The 'Send' generic formal
1877

1878
            N :=
1879 1
              Make_Parameter_Association
1880 1
                (Make_Defining_Identifier (SN (S_Send)),
1881 1
                 Extract_Designator
1882 1
                   (ADN.Send_Node
1883 1
                      (Backend_Node
1884 1
                         (Identifier
1885 1
                            (Corresponding_Instance
1886 1
                               (Get_Container_Process
1887 1
                                  (Parent_Subcomponent (E))))))));
1888 1
            Append_Node_To_List (N, Inst_Profile);
1889

1890
            --  The 'Next_Deadline' genertic formal
1891

1892
            N :=
1893 1
              Make_Parameter_Association
1894 1
                (Make_Defining_Identifier (SN (S_Next_Deadline)),
1895 1
                 RE (RE_Clock));
1896
            --                 Make_Selected_Component
1897
--                   (Map_Task_Identifier (E),
1898
--                    Make_Defining_Identifier (SN (S_Next_Deadline))));
1899 1
            Append_Node_To_List (N, Inst_Profile);
1900

1901
            N :=
1902 1
              Make_Package_Instantiation
1903
                (Defining_Identifier =>
1904 1
                   Make_Defining_Identifier (Map_Interrogators_Name (E)),
1905
                 Generic_Package =>
1906 1
                   RU (RU_PolyORB_HI_Thread_Interrogators, Elaborated => True),
1907
                 Parameter_List => Inst_Profile);
1908

1909 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1910
         end;
1911

1912
         --  Implementations of the runtime routines.
1913

1914
         declare
1915
            procedure Implement_Subprogram
1916
              (Spec                 : Node_Id;
1917
               RR                   : Runtime_Routine;
1918
               Add_Error_Management : Boolean := False);
1919
            --  Generate a subprogram implementation from the given
1920
            --  interrogation routine spec. The new subprogram uses
1921
            --  the value of the first parameter in order to invoke
1922
            --  the proper instance specific interrogation routine.
1923

1924
            procedure Add_Alternative (Spec : Node_Id; RR : Runtime_Routine);
1925
            --  Add the case alternative corresponding to runtime 'RR'
1926
            --  and associated to the current thread instance to the
1927
            --  list of case alternative of the corresponding thread
1928
            --  component.
1929

1930
            function Make_RR_Call
1931
              (Spec : Node_Id;
1932
               RR   : Runtime_Routine) return Node_Id;
1933

1934
            --------------------------
1935
            -- Implement_Subprogram --
1936
            --------------------------
1937

1938 1
            procedure Implement_Subprogram
1939
              (Spec                 : Node_Id;
1940
               RR                   : Runtime_Routine;
1941
               Add_Error_Management : Boolean := False)
1942
            is
1943 1
               Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1944
               Declarations : constant List_Id :=
1945 1
                 New_List (ADN.K_Declaration_List);
1946
               Statements : constant List_Id :=
1947 1
                 New_List (ADN.K_Statement_List);
1948 1
               N                : Node_Id;
1949 1
               Else_Statements  : constant List_Id := New_List (ADN.K_List_Id);
1950 1
               Elsif_Statements : constant List_Id := New_List (ADN.K_List_Id);
1951

1952 1
               Pragma_Warnings_Off_Value : Value_Id;
1953

1954
            begin
1955
               --  Initialize the list associated to the current
1956
               --  thread component.
1957

1958 1
               Set_List (E, RR, Alternatives);
1959

1960
               N :=
1961 1
                 Make_Pragma_Statement
1962
                   (Pragma_Unreferenced,
1963 1
                    Make_List_Id (Make_Defining_Identifier (PN (P_Entity))));
1964 1
               Append_Node_To_List (N, Declarations);
1965

1966
               --  Build a string literal for the pragma Warnings On|Off:
1967
               --
1968
               --  If there is no error recovery function, and the
1969
               --  current subprogram is a function, we need to shut
1970
               --  down the warning on missing return: by construction
1971
               --  of the source code, there cannot be situation in
1972
               --  which we exit without entering one of the if
1973
               --  statements.
1974

1975 1
               Set_Str_To_Name_Buffer ("*return*");
1976 1
               Pragma_Warnings_Off_Value := New_String_Value (Name_Find);
1977

1978 1
               if (not Add_Error_Management)
1979 1
                 and then Present (ADN.Return_Type (Spec))
1980
               then
1981
                  N :=
1982 1
                    Make_Pragma_Statement
1983
                      (Pragma_Warnings,
1984 1
                       Make_List_Id
1985 1
                         (RE (RE_Off),
1986 1
                          Make_Literal (Pragma_Warnings_Off_Value)));
1987 1
                  Append_Node_To_List (N, Statements);
1988
               end if;
1989

1990 1
               if Add_Error_Management then
1991
                  N :=
1992 0
                    Make_Qualified_Expression
1993 0
                      (RE (RE_Error_Kind),
1994 0
                       Make_Record_Aggregate
1995 0
                         (Make_List_Id (RE (RE_Error_Transport))));
1996 0
                  N := Make_Return_Statement (N);
1997 0
                  Append_Node_To_List (N, Else_Statements);
1998
               end if;
1999

2000
               --  Add the alternative of the current instance
2001

2002 1
               Add_Alternative (Spec, RR);
2003

2004
               --  Make the if statement: to avoid a useless if
2005
               --  statement, we take the head of the Alternatives as
2006
               --  first statement, and the tail for the elsif part.
2007

2008 1
               ADN.Set_First_Node
2009
                 (Elsif_Statements,
2010 1
                  ADN.Next_Node (ADN.First_Node (Alternatives)));
2011

2012
               N :=
2013 1
                 Make_If_Statement
2014 1
                   (Condition => ADN.Condition (ADN.First_Node (Alternatives)),
2015
                    Then_Statements =>
2016 1
                      ADN.Then_Statements (ADN.First_Node (Alternatives)),
2017
                    Elsif_Statements => Elsif_Statements,
2018
                    Else_Statements  => Else_Statements);
2019

2020 1
               N := Make_RR_Call (Spec, RR);
2021 1
               Append_Node_To_List (N, Statements);
2022

2023 1
               if (not Add_Error_Management)
2024 1
                 and then Present (ADN.Return_Type (Spec))
2025
               then
2026
                  N :=
2027 1
                    Make_Pragma_Statement
2028
                      (Pragma_Warnings,
2029 1
                       Make_List_Id
2030 1
                         (RE (RE_On),
2031 1
                          Make_Literal (Pragma_Warnings_Off_Value)));
2032 1
                  Append_Node_To_List (N, Statements);
2033
               end if;
2034

2035
               --  Make the subprogram implementation
2036

2037
               N :=
2038 1
                 Make_Subprogram_Implementation
2039
                   (Spec,
2040
                    Declarations,
2041
                    Statements,
2042 1
                    Runtime_Body_Aspect_Definition (E, RR));
2043 1
               Append_Node_To_List (N, Interrogation_Routine_List);
2044 1
            end Implement_Subprogram;
2045

2046
            ------------------
2047
            -- Make_RR_Call --
2048
            ------------------
2049

2050 1
            function Make_RR_Call
2051
              (Spec : Node_Id;
2052
               RR   : Runtime_Routine) return Node_Id
2053
            is
2054 1
               Alternatives  : constant List_Id := Get_List (E, RR);
2055
               Actual_Implem : constant Node_Id :=
2056 1
                 Make_Defining_Identifier
2057 1
                   (ADN.Name (ADN.Defining_Identifier (Spec)));
2058 1
               Call_Profile  : constant List_Id := New_List (ADN.K_List_Id);
2059
               Param_Profile : constant List_Id :=
2060 1
                 ADN.Parameter_Profile (Spec);
2061 1
               P : Node_Id;
2062 1
               N : Node_Id;
2063
            begin
2064
               pragma Assert (Alternatives /= No_List);
2065

2066 1
               Set_Homogeneous_Parent_Unit_Name
2067
                 (Actual_Implem,
2068 1
                  Make_Defining_Identifier (Map_Interrogators_Name (E)));
2069

2070
               --  Skip the first parameter of Spec
2071

2072 1
               P := ADN.Next_Node (ADN.First_Node (Param_Profile));
2073

2074 1
               while Present (P) loop
2075
                  N :=
2076 1
                    Make_Defining_Identifier
2077 1
                      (ADN.Name (ADN.Defining_Identifier (P)));
2078 1
                  Append_Node_To_List (N, Call_Profile);
2079

2080 1
                  P := ADN.Next_Node (P);
2081 1
               end loop;
2082

2083 1
               N := Make_Subprogram_Call (Actual_Implem, Call_Profile);
2084
               --  If we deal with a function, make a return statement
2085
               --  instead of a procedure call.
2086

2087 1
               if Present (ADN.Return_Type (Spec)) then
2088 1
                  N := Make_Return_Statement (N);
2089
               end if;
2090

2091 1
               return N;
2092
            end Make_RR_Call;
2093

2094
            ---------------------
2095
            -- Add_Alternative --
2096
            ---------------------
2097

2098 1
            procedure Add_Alternative (Spec : Node_Id; RR : Runtime_Routine) is
2099 1
               Alternatives  : constant List_Id := Get_List (E, RR);
2100
               Actual_Implem : constant Node_Id :=
2101 1
                 Make_Defining_Identifier
2102 1
                   (ADN.Name (ADN.Defining_Identifier (Spec)));
2103 1
               Call_Profile  : constant List_Id := New_List (ADN.K_List_Id);
2104
               Param_Profile : constant List_Id :=
2105 1
                 ADN.Parameter_Profile (Spec);
2106 1
               P : Node_Id;
2107 1
               N : Node_Id;
2108
            begin
2109
               pragma Assert (Alternatives /= No_List);
2110

2111 1
               Set_Homogeneous_Parent_Unit_Name
2112
                 (Actual_Implem,
2113 1
                  Make_Defining_Identifier (Map_Interrogators_Name (E)));
2114

2115
               --  Skip the first parameter of Spec
2116

2117 1
               P := ADN.Next_Node (ADN.First_Node (Param_Profile));
2118

2119 1
               while Present (P) loop
2120
                  N :=
2121 1
                    Make_Defining_Identifier
2122 1
                      (ADN.Name (ADN.Defining_Identifier (P)));
2123 1
                  Append_Node_To_List (N, Call_Profile);
2124

2125 1
                  P := ADN.Next_Node (P);
2126 1
               end loop;
2127

2128 1
               N := Make_Subprogram_Call (Actual_Implem, Call_Profile);
2129
               --  If we deal with a function, make a return statement
2130
               --  instead of a procedure call.
2131

2132 1
               if Present (ADN.Return_Type (Spec)) then
2133 1
                  N := Make_Return_Statement (N);
2134
               end if;
2135

2136
               --  Make the alternative
2137

2138
               N :=
2139 1
                 Make_Elsif_Statement
2140 1
                   (Make_Expression
2141 1
                      (Make_Defining_Identifier (PN (P_Entity)),
2142
                       Op_Equal,
2143 1
                       Extract_Enumerator (E)),
2144 1
                    Make_List_Id (N));
2145 1
               Append_Node_To_List (N, Alternatives);
2146 1
            end Add_Alternative;
2147

2148
         begin
2149
            --  Add the current interrogator to the package refined state
2150

2151 1
            Append_Node_To_List
2152 1
              (Map_Refined_Global_Name (E),
2153
               Package_Body_Refined_States);
2154

2155
            --  All the runtime routines below are also generated once
2156
            --  per thread component.
2157

2158 1
            if Not_Handled then
2159 1
               if Has_Out_Ports (E) then
2160 1
                  Implement_Subprogram
2161 1
                    (Send_Output_Spec (E),
2162
                     RR_Send_Output);
2163 1
                  Implement_Subprogram (Put_Value_Spec (E), RR_Put_Value);
2164
               end if;
2165

2166 1
               if Has_In_Ports (E) then
2167 1
                  Implement_Subprogram
2168 1
                    (Receive_Input_Spec (E),
2169
                     RR_Receive_Input);
2170 1
                  Implement_Subprogram (Get_Value_Spec (E), RR_Get_Value);
2171 1
                  Implement_Subprogram (Get_Value_Spec_2 (E), RR_Get_Value);
2172 1
                  Implement_Subprogram (Get_Sender_Spec (E), RR_Get_Sender);
2173 1
                  Implement_Subprogram (Get_Count_Spec (E), RR_Get_Count);
2174 1
                  Implement_Subprogram
2175 1
                    (Get_Time_Stamp_Spec (E),
2176
                     RR_Get_Time_Stamp);
2177 1
                  Implement_Subprogram (Next_Value_Spec (E), RR_Next_Value);
2178 1
                  Implement_Subprogram
2179 1
                    (Wait_For_Incoming_Events_Spec (E),
2180
                     RR_Wait_For_Incoming_Events);
2181 1
                  Implement_Subprogram
2182 1
                    (Store_Received_Message_Spec (E),
2183
                     RR_Store_Received_Message);
2184
               end if;
2185

2186
            else
2187
               --  Complete the case alternatives corresponding to the
2188
               --  current instance.
2189

2190 1
               if Has_Out_Ports (E) then
2191 1
                  Add_Alternative (Send_Output_Spec (E), RR_Send_Output);
2192 1
                  Add_Alternative (Put_Value_Spec (E), RR_Put_Value);
2193
               end if;
2194

2195 1
               if Has_In_Ports (E) then
2196 1
                  Add_Alternative (Receive_Input_Spec (E), RR_Receive_Input);
2197 1
                  Add_Alternative (Get_Value_Spec (E), RR_Get_Value);
2198 1
                  Add_Alternative (Get_Value_Spec_2 (E), RR_Get_Value);
2199 1
                  Add_Alternative (Get_Sender_Spec (E), RR_Get_Sender);
2200 1
                  Add_Alternative (Get_Count_Spec (E), RR_Get_Count);
2201 1
                  Add_Alternative (Get_Time_Stamp_Spec (E), RR_Get_Time_Stamp);
2202 1
                  Add_Alternative (Next_Value_Spec (E), RR_Next_Value);
2203 1
                  Add_Alternative
2204 1
                    (Store_Received_Message_Spec (E),
2205
                     RR_Store_Received_Message);
2206 1
                  Add_Alternative
2207 1
                    (Wait_For_Incoming_Events_Spec (E),
2208
                     RR_Wait_For_Incoming_Events);
2209
               end if;
2210
            end if;
2211
         end;
2212 1
      end Runtime_Routine_Bodies;
2213

2214
      -----------------------------------
2215
      -- Make_Current_Mode_Declaration --
2216
      -----------------------------------
2217

2218 1
      function Make_Current_Mode_Declaration (E : Node_Id) return Node_Id is
2219 1
         M : Node_Id;
2220 1
         N : Node_Id;
2221
      begin
2222
         --  The value of the global variable is the enumeratioin
2223
         --  literal corresponding to the initial mode of the thread.
2224

2225 1
         M := First_Node (Modes (E));
2226 1
         N := No_Node;
2227

2228 1
         while Present (M) loop
2229 1
            if Is_Initial (M) then
2230 1
               N := Map_Ada_Defining_Identifier (M);
2231 1
               exit;
2232
            end if;
2233

2234 0
            M := Next_Node (M);
2235 0
         end loop;
2236

2237
         --  If no initial mode has been found, there is definitely an
2238
         --  error in the analyzer.
2239

2240 1
         if No (N) then
2241 0
            raise Program_Error with "No initial mode in mode list";
2242
         end if;
2243

2244
         --  Declare the variable
2245

2246 1
         Current_Mode_Identifier :=
2247 1
           Make_Defining_Identifier (Map_Current_Mode_Name (E));
2248

2249
         N :=
2250 1
           Make_Object_Declaration
2251
             (Defining_Identifier => Current_Mode_Identifier,
2252
              Object_Definition   =>
2253 1
                Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)),
2254
              Expression => N);
2255

2256 1
         return N;
2257
      end Make_Current_Mode_Declaration;
2258

2259
      ----------------------------
2260
      -- Get_List_Internal_Name --
2261
      ----------------------------
2262

2263 1
      function Get_List_Internal_Name
2264
        (Thread : Node_Id;
2265
         RR     : Runtime_Routine) return Name_Id
2266
      is
2267
      begin
2268
         pragma Assert (AINU.Is_Thread (Thread));
2269

2270 1
         Set_Nat_To_Name_Buffer
2271
           (Nat (Parent_Component (Parent_Subcomponent (Thread))));
2272 1
         Add_Str_To_Name_Buffer ("%");
2273
         Add_Nat_To_Name_Buffer (Nat (Corresponding_Declaration (Thread)));
2274
         Add_Str_To_Name_Buffer ("%RR%" & RR'Img);
2275 1
         return Name_Find;
2276
      end Get_List_Internal_Name;
2277

2278
      --------------
2279
      -- Get_List --
2280
      --------------
2281

2282 1
      function Get_List
2283
        (Thread : Node_Id;
2284
         RR     : Runtime_Routine) return List_Id
2285
      is
2286 1
         I_Name : constant Name_Id := Get_List_Internal_Name (Thread, RR);
2287
      begin
2288 1
         return List_Id (Get_Name_Table_Info (I_Name));
2289
      end Get_List;
2290

2291
      --------------
2292
      -- Set_List --
2293
      --------------
2294

2295 1
      procedure Set_List
2296
        (Thread : Node_Id;
2297
         RR     : Runtime_Routine;
2298
         L      : List_Id)
2299
      is
2300 1
         I_Name : constant Name_Id := Get_List_Internal_Name (Thread, RR);
2301
      begin
2302
         Set_Name_Table_Info (I_Name, Nat (L));
2303 1
      end Set_List;
2304

2305
      -----------
2306
      -- Visit --
2307
      -----------
2308

2309 1
      procedure Visit (E : Node_Id) is
2310
      begin
2311
         case Kind (E) is
2312 1
            when K_Architecture_Instance =>
2313 1
               Visit_Architecture_Instance (E);
2314

2315 1
            when K_Component_Instance =>
2316 1
               Visit_Component_Instance (E);
2317

2318 0
            when others =>
2319 0
               null;
2320
         end case;
2321 1
      end Visit;
2322

2323
      ---------------------------------
2324
      -- Visit_Architecture_Instance --
2325
      ---------------------------------
2326

2327 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
2328
      begin
2329 1
         Visit (Root_System (E));
2330 1
      end Visit_Architecture_Instance;
2331

2332
      ------------------------------
2333
      -- Visit_Component_Instance --
2334
      ------------------------------
2335

2336 1
      procedure Visit_Component_Instance (E : Node_Id) is
2337
         Category : constant Component_Category :=
2338 1
           Get_Category_Of_Component (E);
2339
      begin
2340
         case Category is
2341 1
            when CC_System =>
2342 1
               Visit_System_Instance (E);
2343

2344 1
            when CC_Process =>
2345 1
               Visit_Process_Instance (E);
2346

2347 1
            when CC_Thread =>
2348 1
               Visit_Thread_Instance (E);
2349

2350 1
            when others =>
2351 1
               null;
2352 1
         end case;
2353 1
      end Visit_Component_Instance;
2354

2355
      ---------------------------
2356
      -- Visit_Device_Instance --
2357
      ---------------------------
2358

2359 1
      procedure Visit_Device_Instance (E : Node_Id) is
2360 1
         Implementation : constant Node_Id := Get_Implementation (E);
2361

2362
      begin
2363 1
         if Implementation /= No_Node then
2364

2365
            --  A device may be "implemented" using an abstract
2366
            --  component, representing its driver. We iterate on its
2367
            --  subcomponents to attach specific threads associated.
2368

2369 1
            Visit_Subcomponents_Of (Implementation);
2370
         end if;
2371 1
      end Visit_Device_Instance;
2372

2373
      ----------------------------
2374
      -- Visit_Process_Instance --
2375
      ----------------------------
2376

2377 1
      procedure Visit_Process_Instance (E : Node_Id) is
2378
         U : constant Node_Id :=
2379 1
           ADN.Distributed_Application_Unit
2380 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
2381 1
         P          : constant Node_Id := ADN.Entity (U);
2382 1
         S          : Node_Id;
2383 1
         N          : Node_Id;
2384
         The_System : constant Node_Id :=
2385 1
           Parent_Component (Parent_Subcomponent (E));
2386

2387 1
         function Package_Body_Aspect_Definition return Node_Id is
2388
         begin
2389 1
            if Add_SPARK2014_Annotations then
2390 0
               return Make_Aspect_Specification
2391 0
                 (Make_List_Id
2392 0
                    (Make_Aspect
2393
                       (ASN (A_Refined_State),
2394 0
                        Make_Refinement_List
2395 0
                          (Make_List_Id
2396 0
                             (Make_Refinement_Clause
2397 0
                                (Make_Defining_Identifier
2398
                                   (PN (P_Elaborated_Variables)),
2399
                                 Package_Body_Refined_States))))));
2400
            else
2401 1
               return No_Node;
2402
            end if;
2403
         end Package_Body_Aspect_Definition;
2404

2405
      begin
2406 1
         Push_Entity (P);
2407 1
         Push_Entity (U);
2408 1
         Set_Activity_Body;
2409

2410
         --  Start recording the handling since they have to be reset
2411
         --  for each node.
2412

2413 1
         Start_Recording_Handlings;
2414

2415
         --  Initialize the runtime routine list
2416

2417 1
         Interrogation_Routine_List := New_List (ADN.K_Statement_List);
2418 1
         Package_Body_Refined_States := New_List (ADN.K_List_Id);
2419

2420
         --  Visit all the subcomponents of the process
2421

2422 1
         if not AINU.Is_Empty (Subcomponents (E)) then
2423 1
            S := First_Node (Subcomponents (E));
2424 1
            while Present (S) loop
2425
               --  If the process has a data subcomponent, then map a
2426
               --  shared variable.
2427

2428 1
               if AINU.Is_Data (Corresponding_Instance (S))
2429
                 and then
2430 1
                   Get_Concurrency_Protocol (Corresponding_Instance (S)) =
2431
                   Priority_Ceiling
2432
               then
2433
                  --  XXX For now, we disable SPARK_Mode due to the
2434
                  --  inability of SPARK GPL2015 to support
2435
                  --  variable that denotes protected objects.
2436

2437
                  N :=
2438 1
                    Make_Pragma_Statement
2439
                      (Pragma_SPARK_Mode,
2440 1
                       Make_List_Id (RE (RE_Off)));
2441

2442 1
                  Append_Node_To_List
2443
                    (N,
2444 1
                     ADN.Package_Headers (Current_Package));
2445
               end if;
2446

2447
               --  Visit the component instance corresponding to the
2448
               --  subcomponent S.
2449

2450 1
               Visit (Corresponding_Instance (S));
2451 1
               S := Next_Node (S);
2452 1
            end loop;
2453
         end if;
2454

2455
         --  Append the runtime routines
2456

2457 1
         Append_Node_To_List
2458 1
           (ADN.First_Node (Interrogation_Routine_List),
2459 1
            ADN.Statements (Current_Package));
2460

2461
         --  Visit all devices attached to the parent system that
2462
         --  share the same processor as process E.
2463

2464 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
2465 1
            S := First_Node (Subcomponents (The_System));
2466 1
            while Present (S) loop
2467 1
               if AAU.Is_Device (Corresponding_Instance (S))
2468
                 and then
2469 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
2470 1
                   Get_Bound_Processor (E)
2471
               then
2472 1
                  Visit_Device_Instance (Corresponding_Instance (S));
2473
               end if;
2474 1
               S := Next_Node (S);
2475 1
            end loop;
2476
         end if;
2477

2478 1
         ADN.Set_Aspect_Specification
2479 1
           (Current_Package,
2480 1
            Package_Body_Aspect_Definition);
2481

2482
         --  Unmark all the marked types
2483

2484 1
         Reset_Handlings;
2485

2486 1
         Pop_Entity; -- U
2487 1
         Pop_Entity; -- P
2488 1
      end Visit_Process_Instance;
2489

2490
      ---------------------------
2491
      -- Visit_System_Instance --
2492
      ---------------------------
2493

2494 1
      procedure Visit_System_Instance (E : Node_Id) is
2495
      begin
2496 1
         Push_Entity (Ada_Root);
2497

2498
         --  Visit all the subcomponents of the system
2499

2500 1
         Visit_Subcomponents_Of (E);
2501

2502 1
         Pop_Entity; --  Ada_Root
2503 1
      end Visit_System_Instance;
2504

2505
      ---------------------------
2506
      -- Visit_Thread_Instance --
2507
      ---------------------------
2508

2509 1
      procedure Visit_Thread_Instance (E : Node_Id) is
2510
         P : constant Supported_Thread_Dispatch_Protocol :=
2511 1
           Get_Thread_Dispatch_Protocol (E);
2512 1
         S : constant Node_Id := Parent_Subcomponent (E);
2513 1
         N : Node_Id;
2514
      begin
2515 1
         if Has_Ports (E) then
2516
            --  Implement the routines that allow user code to
2517
            --  manipulate the thread.
2518

2519
            case P is
2520 1
               when Thread_Periodic =>
2521 1
                  N :=
2522 1
                    Message_Comment
2523
                      ("Periodic task : " &
2524 1
                         Get_Name_String (Display_Name (Identifier (S))));
2525 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2526

2527 1
               when Thread_Sporadic =>
2528 1
                  N :=
2529 1
                    Message_Comment
2530
                      ("Sporadic task : " &
2531 1
                         Get_Name_String (Display_Name (Identifier (S))));
2532 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2533

2534 0
               when Thread_Aperiodic =>
2535 0
                  N :=
2536 0
                    Message_Comment
2537 0
                      ("Aperiodic task : " &
2538 0
                         Get_Name_String (Display_Name (Identifier (S))));
2539 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2540

2541 0
               when Thread_Background =>
2542 0
                  N :=
2543 0
                    Message_Comment
2544 0
                      ("Background task : " &
2545 0
                         Get_Name_String (Display_Name (Identifier (S))));
2546 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2547

2548 0
               when Thread_ISR =>
2549 0
                  N :=
2550 0
                    Message_Comment
2551 0
                      ("ISR task : " &
2552 0
                         Get_Name_String (Display_Name (Identifier (S))));
2553 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2554

2555 1
               when Thread_Hybrid =>
2556 1
                  N :=
2557 1
                    Message_Comment
2558
                      ("Hybrid task : " &
2559 1
                         Get_Name_String (Display_Name (Identifier (S))));
2560 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2561

2562 0
               when others =>
2563 0
                  raise Program_Error;
2564
            end case;
2565

2566 1
            Runtime_Routine_Bodies (E);
2567
         end if;
2568

2569 1
         if Has_Modes (E) then
2570
            --  If the thread has operational modes, then generate the
2571
            --  body of the mode updater procedure and the global
2572
            --  variable designating the current mode. there is no
2573
            --  harm using a global variable because
2574
            --  it is accessed exclusively by the thread.
2575
            --  We also with a package instance of teh corresponding
2576
            --  scheduler
2577

2578 1
            N := Make_Current_Mode_Declaration (E);
2579 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
2580

2581 1
            if Is_Fusioned (E) then
2582 0
               N := Make_Mode_Updater_body (E);
2583 0
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2584

2585
               N :=
2586 0
                 Make_Withed_Package
2587 0
                   (Make_Defining_Identifier
2588 0
                      (Map_Scheduler_Instance_Name (E)));
2589 0
               Append_Node_To_List (N, ADN.Withed_Packages (Current_Package));
2590
            end if;
2591
         end if;
2592

2593 1
      end Visit_Thread_Instance;
2594

2595
      ----------------------------
2596
      -- Make_Mode_Updater_Body --
2597
      ----------------------------
2598

2599 0
      function Make_Mode_Updater_body (E : Node_Id) return Node_Id is
2600 0
         N    : Node_Id;
2601
         Spec : constant Node_Id :=
2602 0
           Backend_Node (Identifier (First_Node (Modes (E))));
2603 0
         Stats : constant List_Id := New_List (ADN.K_List_Id);
2604
      begin
2605
         N :=
2606 0
           Make_Assignment_Statement
2607
             (Variable_Identifier => Current_Mode_Identifier,
2608 0
              Expression          => Make_Defining_Identifier (PN (P_Mode)));
2609 0
         Append_Node_To_List (N, Stats);
2610 0
         N := Make_Subprogram_Implementation (Spec, No_List, Stats);
2611 0
         return N;
2612
      end Make_Mode_Updater_body;
2613

2614
   end Package_Body;
2615

2616 1
end Ocarina.Backends.PO_HI_Ada.Activity;

Read our documentation on viewing source code .

Loading