OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--  O C A R I N A . B A C K E N D S . P O _ H I _ A D A . 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 1
         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 1
         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 1
         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 1
            case P is
824 1
               when Thread_Periodic =>
825 1
                  N :=
826 1
                    Message_Comment
827 1
                      ("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 1
                      ("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 1
                      ("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 1
            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 1
                   ("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 1
                   ("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 1
                ("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 1
                ("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 1
                        Port_Kind := RE_Id'Val (RE_Id'Pos (Port_Kind) + 3);
1306
                     end if;
1307
                  else
1308 1
                     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 1
                  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 1
                  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 1
                       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 1
                          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 1
                       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
            Statements : List_Id :=
1532 1
              New_List (ADN.K_Statement_List);
1533 1
            Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1534

1535
         begin
1536 1
            F := First_Node (Features (E));
1537

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

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

1563 1
                        D := First_Node (Destinations);
1564

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

1580
                        --  Declare the port specific destination
1581
                        --  array.
1582

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

1598 1
                           Statements := Make_List_Id
1599 1
                             (Make_Pragma_Statement
1600
                                (Pragma_Unreferenced,
1601 1
                                 Make_List_Id
1602 1
                                   (Make_Defining_Identifier
1603
                                      (PN (P_Port)))),
1604 1
                              Make_Return_Statement
1605 1
                                (Make_Designator (Map_Destination_Name (F))));
1606

1607
                           N :=
1608 1
                             Make_Case_Statement_Alternative
1609 1
                             (Make_List_Id
1610 1
                                (Map_Ada_Defining_Identifier (F)),
1611
                              Statements);
1612 1
                           Append_Node_To_List (N, Alternatives);
1613

1614
                        else
1615 1
                           Statements := Make_List_Id
1616 1
                             (Make_Return_Statement
1617 1
                                (RE (RE_Empty_Destination)));
1618

1619
                           N :=
1620 1
                             Make_Case_Statement_Alternative
1621 1
                             (Make_List_Id
1622 1
                                (Map_Ada_Defining_Identifier (F)),
1623
                              Statements);
1624 1
                           Append_Node_To_List (N, Alternatives);
1625
                        end if;
1626

1627
                     end;
1628
                  else
1629
                     --  Dummy element associations
1630 1
                     Statements := Make_List_Id
1631 1
                       (Make_Pragma_Statement
1632
                          (Pragma_Unreferenced,
1633 1
                           Make_List_Id
1634 1
                             (Make_Defining_Identifier
1635
                                (PN (P_Port)))),
1636 1
                        Make_Return_Statement
1637 1
                          (RE (RE_Empty_Destination)));
1638

1639
                     N :=
1640 1
                       Make_Case_Statement_Alternative
1641 1
                       (Make_List_Id
1642 1
                          (Map_Ada_Defining_Identifier (F)),
1643
                        Statements);
1644 1
                     Append_Node_To_List (N, Alternatives);
1645
                  end if;
1646
               end if;
1647

1648 1
               F := Next_Node (F);
1649 1
            end loop;
1650

1651
            --  Define the Destinations function
1652

1653 1
            if Length (Alternatives) > 1 then
1654
               Statements :=
1655 1
                make_list_id (Make_Case_Statement
1656 1
                 (Make_Defining_Identifier (CN (C_Port)),
1657
                  Alternatives));
1658
            end if;
1659

1660
            N :=
1661 1
              Make_Subprogram_Specification
1662
                (Defining_Identifier =>
1663 1
                   Make_Defining_Identifier (Map_Destination_Name (E)),
1664
                 Parameter_Profile =>
1665 1
                   Make_List_Id
1666 1
                   (Make_Parameter_Specification
1667
                      (Defining_Identifier =>
1668 1
                         Make_Defining_Identifier (PN (P_Port)),
1669
                       Subtype_Mark   =>
1670 1
                         Make_Defining_Identifier
1671 1
                         (Map_Port_Enumeration_Name (E)),
1672
                       Parameter_Mode => Mode_In)),
1673 1
                 Return_Type => RE (RE_Destinations_Array));
1674 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1675

1676 1
            N := Make_Subprogram_Implementation (N, No_List, Statements);
1677 1
            Append_Node_To_List (N, Interrogation_Routine_List);
1678
         end;
1679

1680
         --  Instantiate the PolyORB_HI.Interrogators generic
1681

1682
         declare
1683
            Inst_Profile : constant List_Id :=
1684 1
              New_List (ADN.K_Parameter_Profile);
1685
         begin
1686
            --  The 'Port_Type' generic formal
1687

1688
            N :=
1689 1
              Make_Parameter_Association
1690 1
                (Make_Defining_Identifier (TN (T_Port_Type)),
1691 1
                 Make_Defining_Identifier (Map_Port_Enumeration_Name (E)));
1692 1
            Append_Node_To_List (N, Inst_Profile);
1693

1694
            --  The 'Integer_Array' generic formal
1695

1696
            N :=
1697 1
              Make_Parameter_Association
1698 1
                (Make_Defining_Identifier (TN (T_Integer_Array)),
1699 1
                 Make_Defining_Identifier (Map_Integer_Array_Name (E)));
1700 1
            Append_Node_To_List (N, Inst_Profile);
1701

1702
            --  The 'Kind_Array' generic formal
1703

1704
            N :=
1705 1
              Make_Parameter_Association
1706 1
                (Make_Defining_Identifier (TN (T_Port_Kind_Array)),
1707 1
                 Make_Defining_Identifier (Map_Kind_Array_Name (E)));
1708 1
            Append_Node_To_List (N, Inst_Profile);
1709

1710
            --  The 'Image_Array' generic formal
1711

1712
            N :=
1713 1
              Make_Parameter_Association
1714 1
                (Make_Defining_Identifier (TN (T_Port_Image_Array)),
1715 1
                 Make_Defining_Identifier (Map_Image_Array_Name (E)));
1716 1
            Append_Node_To_List (N, Inst_Profile);
1717

1718
            --  The 'Overflow_Protocol_Array' generic formal
1719

1720
            N :=
1721 1
              Make_Parameter_Association
1722 1
                (Make_Defining_Identifier (TN (T_Overflow_Protocol_Array)),
1723 1
                 Make_Defining_Identifier
1724 1
                   (Map_Overflow_Protocol_Array_Name (E)));
1725 1
            Append_Node_To_List (N, Inst_Profile);
1726

1727
            --  The 'Thread_Interface' generic formal
1728

1729
            N :=
1730 1
              Make_Parameter_Association
1731 1
                (Make_Defining_Identifier (TN (T_Thread_Interface_Type)),
1732 1
                 Make_Defining_Identifier (Map_Port_Interface_Name (E)));
1733 1
            Append_Node_To_List (N, Inst_Profile);
1734

1735
            --  The 'Current_Entity' generic formal
1736

1737
            N :=
1738 1
              Make_Parameter_Association
1739 1
                (Make_Defining_Identifier (PN (P_Current_Entity)),
1740 1
                 Extract_Enumerator (E));
1741 1
            Append_Node_To_List (N, Inst_Profile);
1742

1743
            --  The 'Thread_Port_Kinds' generic formal
1744

1745
            N :=
1746 1
              Make_Parameter_Association
1747 1
                (Make_Defining_Identifier (PN (P_Thread_Port_Kinds)),
1748 1
                 Make_Defining_Identifier (Map_Port_Kinds_Name (E)));
1749 1
            Append_Node_To_List (N, Inst_Profile);
1750

1751
            --  The 'Has_Event_Ports' generic formal
1752

1753
            N :=
1754 1
              Make_Parameter_Association
1755 1
                (Make_Defining_Identifier (PN (P_Has_Event_Ports)),
1756 1
                 Make_Literal
1757 1
                   (New_Boolean_Value
1758 1
                      (Has_In_Event_Ports (E)
1759 1
                       or else Has_Out_Event_Ports (E))));
1760 1
            Append_Node_To_List (N, Inst_Profile);
1761

1762
            --  The 'Thread_Port_Images' generic formal
1763

1764
            N :=
1765 1
              Make_Parameter_Association
1766 1
                (Make_Defining_Identifier (PN (P_Thread_Port_Images)),
1767 1
                 Make_Defining_Identifier (Map_Port_Images_Name (E)));
1768 1
            Append_Node_To_List (N, Inst_Profile);
1769

1770
            --  The 'Thread_Fifo_Sizes' generic formal
1771

1772
            N :=
1773 1
              Make_Parameter_Association
1774 1
                (Make_Defining_Identifier (PN (P_Thread_Fifo_Sizes)),
1775 1
                 Make_Defining_Identifier (Map_FIFO_Sizes_Name (E)));
1776 1
            Append_Node_To_List (N, Inst_Profile);
1777

1778
            --  The 'Thread_Fifo_Offsets' generic formal
1779

1780
            N :=
1781 1
              Make_Parameter_Association
1782 1
                (Make_Defining_Identifier (PN (P_Thread_Fifo_Offsets)),
1783 1
                 Make_Defining_Identifier (Map_Offsets_Name (E)));
1784 1
            Append_Node_To_List (N, Inst_Profile);
1785

1786
            --  The 'Thread_Overflow_Protocols' generic formal
1787

1788
            N :=
1789 1
              Make_Parameter_Association
1790 1
                (Make_Defining_Identifier (PN (P_Thread_Overflow_Protocols)),
1791 1
                 Make_Defining_Identifier (Map_Overflow_Protocols_Name (E)));
1792 1
            Append_Node_To_List (N, Inst_Profile);
1793

1794
            --  The 'Urgencies' generic formal
1795

1796
            N :=
1797 1
              Make_Parameter_Association
1798 1
                (Make_Defining_Identifier (PN (P_Urgencies)),
1799 1
                 Make_Defining_Identifier (Map_Urgencies_Name (E)));
1800 1
            Append_Node_To_List (N, Inst_Profile);
1801

1802
            --  The 'Global_Data_Queue_Size' generic formal
1803

1804
            N :=
1805 1
              Make_Parameter_Association
1806 1
                (Make_Defining_Identifier (PN (P_Global_Data_Queue_Size)),
1807 1
                 Make_Defining_Identifier (Map_Total_Size_Name (E)));
1808 1
            Append_Node_To_List (N, Inst_Profile);
1809

1810
            --  The 'Destinations' generic formal
1811

1812
            N :=
1813 1
              Make_Parameter_Association
1814 1
                (Make_Defining_Identifier (PN (P_Destinations)),
1815 1
                 Make_Defining_Identifier (Map_Destination_Name (E)));
1816 1
            Append_Node_To_List (N, Inst_Profile);
1817

1818
            --  The 'Marshall' generic formal
1819

1820
            N :=
1821 1
              Make_Parameter_Association
1822 1
                (Make_Defining_Identifier (SN (S_Marshall)),
1823 1
                 Extract_Designator
1824 1
                   (ADN.Marshall_Node (Backend_Node (Identifier (E)))));
1825 1
            Append_Node_To_List (N, Inst_Profile);
1826

1827
            --  The 'Send' generic formal
1828

1829
            N :=
1830 1
              Make_Parameter_Association
1831 1
                (Make_Defining_Identifier (SN (S_Send)),
1832 1
                 Extract_Designator
1833 1
                   (ADN.Send_Node
1834 1
                      (Backend_Node
1835 1
                         (Identifier
1836 1
                            (Corresponding_Instance
1837 1
                               (Get_Container_Process
1838 1
                                  (Parent_Subcomponent (E))))))));
1839 1
            Append_Node_To_List (N, Inst_Profile);
1840

1841
            --  The 'Next_Deadline' genertic formal
1842

1843
            N :=
1844 1
              Make_Parameter_Association
1845 1
                (Make_Defining_Identifier (SN (S_Next_Deadline)),
1846 1
                 RE (RE_Clock));
1847
            --                 Make_Selected_Component
1848
--                   (Map_Task_Identifier (E),
1849
--                    Make_Defining_Identifier (SN (S_Next_Deadline))));
1850 1
            Append_Node_To_List (N, Inst_Profile);
1851

1852
            N :=
1853 1
              Make_Package_Instantiation
1854
                (Defining_Identifier =>
1855 1
                   Make_Defining_Identifier (Map_Interrogators_Name (E)),
1856
                 Generic_Package =>
1857 1
                   RU (RU_PolyORB_HI_Thread_Interrogators, Elaborated => True),
1858
                 Parameter_List => Inst_Profile);
1859

1860 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
1861
         end;
1862

1863
         --  Implementations of the runtime routines.
1864

1865
         declare
1866
            procedure Implement_Subprogram
1867
              (Spec                 : Node_Id;
1868
               RR                   : Runtime_Routine;
1869
               Add_Error_Management : Boolean := False);
1870
            --  Generate a subprogram implementation from the given
1871
            --  interrogation routine spec. The new subprogram uses
1872
            --  the value of the first parameter in order to invoke
1873
            --  the proper instance specific interrogation routine.
1874

1875
            procedure Add_Alternative (Spec : Node_Id; RR : Runtime_Routine);
1876
            --  Add the case alternative corresponding to runtime 'RR'
1877
            --  and associated to the current thread instance to the
1878
            --  list of case alternative of the corresponding thread
1879
            --  component.
1880

1881
            function Make_RR_Call
1882
              (Spec : Node_Id;
1883
               RR   : Runtime_Routine) return Node_Id;
1884

1885
            --------------------------
1886
            -- Implement_Subprogram --
1887
            --------------------------
1888

1889 1
            procedure Implement_Subprogram
1890
              (Spec                 : Node_Id;
1891
               RR                   : Runtime_Routine;
1892
               Add_Error_Management : Boolean := False)
1893
            is
1894 1
               Alternatives : constant List_Id := New_List (ADN.K_List_Id);
1895
               Declarations : constant List_Id :=
1896 1
                 New_List (ADN.K_Declaration_List);
1897
               Statements : constant List_Id :=
1898 1
                 New_List (ADN.K_Statement_List);
1899 1
               N                : Node_Id;
1900 1
               Else_Statements  : constant List_Id := New_List (ADN.K_List_Id);
1901 1
               Elsif_Statements : constant List_Id := New_List (ADN.K_List_Id);
1902

1903 1
               Pragma_Warnings_Off_Value : Value_Id;
1904

1905
            begin
1906
               --  Initialize the list associated to the current
1907
               --  thread component.
1908

1909 1
               Set_List (E, RR, Alternatives);
1910

1911
               N :=
1912 1
                 Make_Pragma_Statement
1913
                   (Pragma_Unreferenced,
1914 1
                    Make_List_Id (Make_Defining_Identifier (PN (P_Entity))));
1915 1
               Append_Node_To_List (N, Declarations);
1916

1917
               --  Build a string literal for the pragma Warnings On|Off:
1918
               --
1919
               --  If there is no error recovery function, and the
1920
               --  current subprogram is a function, we need to shut
1921
               --  down the warning on missing return: by construction
1922
               --  of the source code, there cannot be situation in
1923
               --  which we exit without entering one of the if
1924
               --  statements.
1925

1926 1
               Set_Str_To_Name_Buffer ("*return*");
1927 1
               Pragma_Warnings_Off_Value := New_String_Value (Name_Find);
1928

1929 1
               if (not Add_Error_Management)
1930 1
                 and then Present (ADN.Return_Type (Spec))
1931
               then
1932
                  N :=
1933 1
                    Make_Pragma_Statement
1934
                      (Pragma_Warnings,
1935 1
                       Make_List_Id
1936 1
                         (RE (RE_Off),
1937 1
                          Make_Literal (Pragma_Warnings_Off_Value)));
1938 1
                  Append_Node_To_List (N, Statements);
1939
               end if;
1940

1941 1
               if Add_Error_Management then
1942
                  N :=
1943 0
                    Make_Qualified_Expression
1944 0
                      (RE (RE_Error_Kind),
1945 0
                       Make_Record_Aggregate
1946 0
                         (Make_List_Id (RE (RE_Error_Transport))));
1947 0
                  N := Make_Return_Statement (N);
1948 0
                  Append_Node_To_List (N, Else_Statements);
1949
               end if;
1950

1951
               --  Add the alternative of the current instance
1952

1953 1
               Add_Alternative (Spec, RR);
1954

1955
               --  Make the if statement: to avoid a useless if
1956
               --  statement, we take the head of the Alternatives as
1957
               --  first statement, and the tail for the elsif part.
1958

1959 1
               ADN.Set_First_Node
1960
                 (Elsif_Statements,
1961 1
                  ADN.Next_Node (ADN.First_Node (Alternatives)));
1962

1963
               N :=
1964 1
                 Make_If_Statement
1965 1
                   (Condition => ADN.Condition (ADN.First_Node (Alternatives)),
1966
                    Then_Statements =>
1967 1
                      ADN.Then_Statements (ADN.First_Node (Alternatives)),
1968
                    Elsif_Statements => Elsif_Statements,
1969
                    Else_Statements  => Else_Statements);
1970

1971 1
               N := Make_RR_Call (Spec, RR);
1972 1
               Append_Node_To_List (N, Statements);
1973

1974 1
               if (not Add_Error_Management)
1975 1
                 and then Present (ADN.Return_Type (Spec))
1976
               then
1977
                  N :=
1978 1
                    Make_Pragma_Statement
1979
                      (Pragma_Warnings,
1980 1
                       Make_List_Id
1981 1
                         (RE (RE_On),
1982 1
                          Make_Literal (Pragma_Warnings_Off_Value)));
1983 1
                  Append_Node_To_List (N, Statements);
1984
               end if;
1985

1986
               --  Make the subprogram implementation
1987

1988
               N :=
1989 1
                 Make_Subprogram_Implementation
1990
                   (Spec,
1991
                    Declarations,
1992
                    Statements,
1993 1
                    Runtime_Body_Aspect_Definition (E, RR));
1994 1
               Append_Node_To_List (N, Interrogation_Routine_List);
1995 1
            end Implement_Subprogram;
1996

1997
            ------------------
1998
            -- Make_RR_Call --
1999
            ------------------
2000

2001 1
            function Make_RR_Call
2002
              (Spec : Node_Id;
2003
               RR   : Runtime_Routine) return Node_Id
2004
            is
2005 1
               Alternatives  : constant List_Id := Get_List (E, RR);
2006
               Actual_Implem : constant Node_Id :=
2007 1
                 Make_Defining_Identifier
2008 1
                   (ADN.Name (ADN.Defining_Identifier (Spec)));
2009 1
               Call_Profile  : constant List_Id := New_List (ADN.K_List_Id);
2010
               Param_Profile : constant List_Id :=
2011 1
                 ADN.Parameter_Profile (Spec);
2012 1
               P : Node_Id;
2013 1
               N : Node_Id;
2014
            begin
2015 1
               pragma Assert (Alternatives /= No_List);
2016

2017 1
               Set_Homogeneous_Parent_Unit_Name
2018
                 (Actual_Implem,
2019 1
                  Make_Defining_Identifier (Map_Interrogators_Name (E)));
2020

2021
               --  Skip the first parameter of Spec
2022

2023 1
               P := ADN.Next_Node (ADN.First_Node (Param_Profile));
2024

2025 1
               while Present (P) loop
2026
                  N :=
2027 1
                    Make_Defining_Identifier
2028 1
                      (ADN.Name (ADN.Defining_Identifier (P)));
2029 1
                  Append_Node_To_List (N, Call_Profile);
2030

2031 1
                  P := ADN.Next_Node (P);
2032 1
               end loop;
2033

2034 1
               N := Make_Subprogram_Call (Actual_Implem, Call_Profile);
2035
               --  If we deal with a function, make a return statement
2036
               --  instead of a procedure call.
2037

2038 1
               if Present (ADN.Return_Type (Spec)) then
2039 1
                  N := Make_Return_Statement (N);
2040
               end if;
2041

2042 1
               return N;
2043
            end Make_RR_Call;
2044

2045
            ---------------------
2046
            -- Add_Alternative --
2047
            ---------------------
2048

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

2062 1
               Set_Homogeneous_Parent_Unit_Name
2063
                 (Actual_Implem,
2064 1
                  Make_Defining_Identifier (Map_Interrogators_Name (E)));
2065

2066
               --  Skip the first parameter of Spec
2067

2068 1
               P := ADN.Next_Node (ADN.First_Node (Param_Profile));
2069

2070 1
               while Present (P) loop
2071
                  N :=
2072 1
                    Make_Defining_Identifier
2073 1
                      (ADN.Name (ADN.Defining_Identifier (P)));
2074 1
                  Append_Node_To_List (N, Call_Profile);
2075

2076 1
                  P := ADN.Next_Node (P);
2077 1
               end loop;
2078

2079 1
               N := Make_Subprogram_Call (Actual_Implem, Call_Profile);
2080
               --  If we deal with a function, make a return statement
2081
               --  instead of a procedure call.
2082

2083 1
               if Present (ADN.Return_Type (Spec)) then
2084 1
                  N := Make_Return_Statement (N);
2085
               end if;
2086

2087
               --  Make the alternative
2088

2089
               N :=
2090 1
                 Make_Elsif_Statement
2091 1
                   (Make_Expression
2092 1
                      (Make_Defining_Identifier (PN (P_Entity)),
2093
                       Op_Equal,
2094 1
                       Extract_Enumerator (E)),
2095 1
                    Make_List_Id (N));
2096 1
               Append_Node_To_List (N, Alternatives);
2097 1
            end Add_Alternative;
2098

2099
         begin
2100
            --  Add the current interrogator to the package refined state
2101

2102 1
            Append_Node_To_List
2103 1
              (Map_Refined_Global_Name (E),
2104
               Package_Body_Refined_States);
2105

2106
            --  All the runtime routines below are also generated once
2107
            --  per thread component.
2108

2109 1
            if Not_Handled then
2110 1
               if Has_Out_Ports (E) then
2111 1
                  Implement_Subprogram
2112 1
                    (Send_Output_Spec (E),
2113
                     RR_Send_Output);
2114 1
                  Implement_Subprogram (Put_Value_Spec (E), RR_Put_Value);
2115
               end if;
2116

2117 1
               if Has_In_Ports (E) then
2118 1
                  Implement_Subprogram
2119 1
                    (Receive_Input_Spec (E),
2120
                     RR_Receive_Input);
2121 1
                  Implement_Subprogram (Get_Value_Spec (E), RR_Get_Value);
2122 1
                  Implement_Subprogram (Get_Value_Spec_2 (E), RR_Get_Value);
2123 1
                  Implement_Subprogram (Get_Sender_Spec (E), RR_Get_Sender);
2124 1
                  Implement_Subprogram (Get_Count_Spec (E), RR_Get_Count);
2125 1
                  Implement_Subprogram
2126 1
                    (Get_Time_Stamp_Spec (E),
2127
                     RR_Get_Time_Stamp);
2128 1
                  Implement_Subprogram (Next_Value_Spec (E), RR_Next_Value);
2129 1
                  Implement_Subprogram
2130 1
                    (Wait_For_Incoming_Events_Spec (E),
2131
                     RR_Wait_For_Incoming_Events);
2132 1
                  Implement_Subprogram
2133 1
                    (Store_Received_Message_Spec (E),
2134
                     RR_Store_Received_Message);
2135
               end if;
2136

2137
            else
2138
               --  Complete the case alternatives corresponding to the
2139
               --  current instance.
2140

2141 1
               if Has_Out_Ports (E) then
2142 1
                  Add_Alternative (Send_Output_Spec (E), RR_Send_Output);
2143 1
                  Add_Alternative (Put_Value_Spec (E), RR_Put_Value);
2144
               end if;
2145

2146 1
               if Has_In_Ports (E) then
2147 1
                  Add_Alternative (Receive_Input_Spec (E), RR_Receive_Input);
2148 1
                  Add_Alternative (Get_Value_Spec (E), RR_Get_Value);
2149 1
                  Add_Alternative (Get_Value_Spec_2 (E), RR_Get_Value);
2150 1
                  Add_Alternative (Get_Sender_Spec (E), RR_Get_Sender);
2151 1
                  Add_Alternative (Get_Count_Spec (E), RR_Get_Count);
2152 1
                  Add_Alternative (Get_Time_Stamp_Spec (E), RR_Get_Time_Stamp);
2153 1
                  Add_Alternative (Next_Value_Spec (E), RR_Next_Value);
2154 1
                  Add_Alternative
2155 1
                    (Store_Received_Message_Spec (E),
2156
                     RR_Store_Received_Message);
2157 1
                  Add_Alternative
2158 1
                    (Wait_For_Incoming_Events_Spec (E),
2159
                     RR_Wait_For_Incoming_Events);
2160
               end if;
2161
            end if;
2162
         end;
2163 1
      end Runtime_Routine_Bodies;
2164

2165
      -----------------------------------
2166
      -- Make_Current_Mode_Declaration --
2167
      -----------------------------------
2168

2169 1
      function Make_Current_Mode_Declaration (E : Node_Id) return Node_Id is
2170 1
         M : Node_Id;
2171 1
         N : Node_Id;
2172
      begin
2173
         --  The value of the global variable is the enumeratioin
2174
         --  literal corresponding to the initial mode of the thread.
2175

2176 1
         M := First_Node (Modes (E));
2177 1
         N := No_Node;
2178

2179 1
         while Present (M) loop
2180 1
            if Is_Initial (M) then
2181 1
               N := Map_Ada_Defining_Identifier (M);
2182 1
               exit;
2183
            end if;
2184

2185 0
            M := Next_Node (M);
2186 0
         end loop;
2187

2188
         --  If no initial mode has been found, there is definitely an
2189
         --  error in the analyzer.
2190

2191 1
         if No (N) then
2192 0
            raise Program_Error with "No initial mode in mode list";
2193
         end if;
2194

2195
         --  Declare the variable
2196

2197 1
         Current_Mode_Identifier :=
2198 1
           Make_Defining_Identifier (Map_Current_Mode_Name (E));
2199

2200
         N :=
2201 1
           Make_Object_Declaration
2202
             (Defining_Identifier => Current_Mode_Identifier,
2203
              Object_Definition   =>
2204 1
                Make_Defining_Identifier (Map_Modes_Enumeration_Name (E)),
2205
              Expression => N);
2206

2207 1
         return N;
2208
      end Make_Current_Mode_Declaration;
2209

2210
      ----------------------------
2211
      -- Get_List_Internal_Name --
2212
      ----------------------------
2213

2214 1
      function Get_List_Internal_Name
2215
        (Thread : Node_Id;
2216
         RR     : Runtime_Routine) return Name_Id
2217
      is
2218
      begin
2219 1
         pragma Assert (AINU.Is_Thread (Thread));
2220

2221 1
         Set_Nat_To_Name_Buffer
2222 1
           (Nat (Parent_Component (Parent_Subcomponent (Thread))));
2223 1
         Add_Str_To_Name_Buffer ("%");
2224 1
         Add_Nat_To_Name_Buffer (Nat (Corresponding_Declaration (Thread)));
2225 1
         Add_Str_To_Name_Buffer ("%RR%" & RR'Img);
2226 1
         return Name_Find;
2227
      end Get_List_Internal_Name;
2228

2229
      --------------
2230
      -- Get_List --
2231
      --------------
2232

2233 1
      function Get_List
2234
        (Thread : Node_Id;
2235
         RR     : Runtime_Routine) return List_Id
2236
      is
2237 1
         I_Name : constant Name_Id := Get_List_Internal_Name (Thread, RR);
2238
      begin
2239 1
         return List_Id (Get_Name_Table_Info (I_Name));
2240
      end Get_List;
2241

2242
      --------------
2243
      -- Set_List --
2244
      --------------
2245

2246 1
      procedure Set_List
2247
        (Thread : Node_Id;
2248
         RR     : Runtime_Routine;
2249
         L      : List_Id)
2250
      is
2251 1
         I_Name : constant Name_Id := Get_List_Internal_Name (Thread, RR);
2252
      begin
2253 1
         Set_Name_Table_Info (I_Name, Nat (L));
2254 1
      end Set_List;
2255

2256
      -----------
2257
      -- Visit --
2258
      -----------
2259

2260 1
      procedure Visit (E : Node_Id) is
2261
      begin
2262 1
         case Kind (E) is
2263 1
            when K_Architecture_Instance =>
2264 1
               Visit_Architecture_Instance (E);
2265

2266 1
            when K_Component_Instance =>
2267 1
               Visit_Component_Instance (E);
2268

2269 0
            when others =>
2270 0
               null;
2271 1
         end case;
2272 1
      end Visit;
2273

2274
      ---------------------------------
2275
      -- Visit_Architecture_Instance --
2276
      ---------------------------------
2277

2278 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
2279
      begin
2280 1
         Visit (Root_System (E));
2281 1
      end Visit_Architecture_Instance;
2282

2283
      ------------------------------
2284
      -- Visit_Component_Instance --
2285
      ------------------------------
2286

2287 1
      procedure Visit_Component_Instance (E : Node_Id) is
2288
         Category : constant Component_Category :=
2289 1
           Get_Category_Of_Component (E);
2290
      begin
2291 1
         case Category is
2292 1
            when CC_System =>
2293 1
               Visit_System_Instance (E);
2294

2295 1
            when CC_Process =>
2296 1
               Visit_Process_Instance (E);
2297

2298 1
            when CC_Thread =>
2299 1
               Visit_Thread_Instance (E);
2300

2301 1
            when others =>
2302 1
               null;
2303 1
         end case;
2304 1
      end Visit_Component_Instance;
2305

2306
      ---------------------------
2307
      -- Visit_Device_Instance --
2308
      ---------------------------
2309

2310 1
      procedure Visit_Device_Instance (E : Node_Id) is
2311 1
         Implementation : constant Node_Id := Get_Implementation (E);
2312

2313
      begin
2314 1
         if Implementation /= No_Node then
2315

2316
            --  A device may be "implemented" using an abstract
2317
            --  component, representing its driver. We iterate on its
2318
            --  subcomponents to attach specific threads associated.
2319

2320 1
            Visit_Subcomponents_Of (Implementation);
2321
         end if;
2322 1
      end Visit_Device_Instance;
2323

2324
      ----------------------------
2325
      -- Visit_Process_Instance --
2326
      ----------------------------
2327

2328 1
      procedure Visit_Process_Instance (E : Node_Id) is
2329
         U : constant Node_Id :=
2330 1
           ADN.Distributed_Application_Unit
2331 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
2332 1
         P          : constant Node_Id := ADN.Entity (U);
2333 1
         S          : Node_Id;
2334 1
         N          : Node_Id;
2335
         The_System : constant Node_Id :=
2336 1
           Parent_Component (Parent_Subcomponent (E));
2337

2338 1
         function Package_Body_Aspect_Definition return Node_Id is
2339
         begin
2340 1
            if Add_SPARK2014_Annotations then
2341 0
               return Make_Aspect_Specification
2342 0
                 (Make_List_Id
2343 0
                    (Make_Aspect
2344
                       (ASN (A_Refined_State),
2345 0
                        Make_Refinement_List
2346 0
                          (Make_List_Id
2347 0
                             (Make_Refinement_Clause
2348 0
                                (Make_Defining_Identifier
2349
                                   (PN (P_Elaborated_Variables)),
2350
                                 Package_Body_Refined_States))))));
2351
            else
2352 1
               return No_Node;
2353
            end if;
2354
         end Package_Body_Aspect_Definition;
2355

2356
      begin
2357 1
         Push_Entity (P);
2358 1
         Push_Entity (U);
2359 1
         Set_Activity_Body;
2360

2361
         --  Start recording the handling since they have to be reset
2362
         --  for each node.
2363

2364 1
         Start_Recording_Handlings;
2365

2366
         --  Initialize the runtime routine list
2367

2368 1
         Interrogation_Routine_List := New_List (ADN.K_Statement_List);
2369 1
         Package_Body_Refined_States := New_List (ADN.K_List_Id);
2370

2371
         --  Visit all the subcomponents of the process
2372

2373 1
         if not AINU.Is_Empty (Subcomponents (E)) then
2374 1
            S := First_Node (Subcomponents (E));
2375 1
            while Present (S) loop
2376
               --  If the process has a data subcomponent, then map a
2377
               --  shared variable.
2378

2379 1
               if AINU.Is_Data (Corresponding_Instance (S))
2380
                 and then
2381 1
                   Get_Concurrency_Protocol (Corresponding_Instance (S)) =
2382
                   Priority_Ceiling
2383
               then
2384
                  --  XXX For now, we disable SPARK_Mode due to the
2385
                  --  inability of SPARK GPL2015 to support
2386
                  --  variable that denotes protected objects.
2387

2388
                  N :=
2389 1
                    Make_Pragma_Statement
2390
                      (Pragma_SPARK_Mode,
2391 1
                       Make_List_Id (RE (RE_Off)));
2392

2393 1
                  Append_Node_To_List
2394
                    (N,
2395 1
                     ADN.Package_Headers (Current_Package));
2396
               end if;
2397

2398
               --  Visit the component instance corresponding to the
2399
               --  subcomponent S.
2400

2401 1
               Visit (Corresponding_Instance (S));
2402 1
               S := Next_Node (S);
2403 1
            end loop;
2404
         end if;
2405

2406
         --  Append the runtime routines
2407

2408 1
         Append_Node_To_List
2409 1
           (ADN.First_Node (Interrogation_Routine_List),
2410 1
            ADN.Statements (Current_Package));
2411

2412
         --  Visit all devices attached to the parent system that
2413
         --  share the same processor as process E.
2414

2415 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
2416 1
            S := First_Node (Subcomponents (The_System));
2417 1
            while Present (S) loop
2418 1
               if AAU.Is_Device (Corresponding_Instance (S))
2419
                 and then
2420 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
2421 1
                   Get_Bound_Processor (E)
2422
               then
2423 1
                  Visit_Device_Instance (Corresponding_Instance (S));
2424
               end if;
2425 1
               S := Next_Node (S);
2426 1
            end loop;
2427
         end if;
2428

2429 1
         ADN.Set_Aspect_Specification
2430 1
           (Current_Package,
2431 1
            Package_Body_Aspect_Definition);
2432

2433
         --  Unmark all the marked types
2434

2435 1
         Reset_Handlings;
2436

2437 1
         Pop_Entity; -- U
2438 1
         Pop_Entity; -- P
2439 1
      end Visit_Process_Instance;
2440

2441
      ---------------------------
2442
      -- Visit_System_Instance --
2443
      ---------------------------
2444

2445 1
      procedure Visit_System_Instance (E : Node_Id) is
2446
      begin
2447 1
         Push_Entity (Ada_Root);
2448

2449
         --  Visit all the subcomponents of the system
2450

2451 1
         Visit_Subcomponents_Of (E);
2452

2453 1
         Pop_Entity; --  Ada_Root
2454 1
      end Visit_System_Instance;
2455

2456
      ---------------------------
2457
      -- Visit_Thread_Instance --
2458
      ---------------------------
2459

2460 1
      procedure Visit_Thread_Instance (E : Node_Id) is
2461
         P : constant Supported_Thread_Dispatch_Protocol :=
2462 1
           Get_Thread_Dispatch_Protocol (E);
2463 1
         S : constant Node_Id := Parent_Subcomponent (E);
2464 1
         N : Node_Id;
2465
      begin
2466 1
         if Has_Ports (E) then
2467
            --  Implement the routines that allow user code to
2468
            --  manipulate the thread.
2469

2470 1
            case P is
2471 1
               when Thread_Periodic =>
2472 1
                  N :=
2473 1
                    Message_Comment
2474 1
                      ("Periodic task : " &
2475 1
                         Get_Name_String (Display_Name (Identifier (S))));
2476 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2477

2478 1
               when Thread_Sporadic =>
2479 1
                  N :=
2480 1
                    Message_Comment
2481 1
                      ("Sporadic task : " &
2482 1
                         Get_Name_String (Display_Name (Identifier (S))));
2483 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2484

2485 0
               when Thread_Aperiodic =>
2486 0
                  N :=
2487 0
                    Message_Comment
2488 0
                      ("Aperiodic task : " &
2489 0
                         Get_Name_String (Display_Name (Identifier (S))));
2490 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2491

2492 0
               when Thread_Background =>
2493 0
                  N :=
2494 0
                    Message_Comment
2495 0
                      ("Background task : " &
2496 0
                         Get_Name_String (Display_Name (Identifier (S))));
2497 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2498

2499 0
               when Thread_ISR =>
2500 0
                  N :=
2501 0
                    Message_Comment
2502 0
                      ("ISR task : " &
2503 0
                         Get_Name_String (Display_Name (Identifier (S))));
2504 0
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2505

2506 1
               when Thread_Hybrid =>
2507 1
                  N :=
2508 1
                    Message_Comment
2509 1
                      ("Hybrid task : " &
2510 1
                         Get_Name_String (Display_Name (Identifier (S))));
2511 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
2512

2513 0
               when others =>
2514 0
                  raise Program_Error;
2515 1
            end case;
2516

2517 1
            Runtime_Routine_Bodies (E);
2518
         end if;
2519

2520 1
         if Has_Modes (E) then
2521
            --  If the thread has operational modes, then generate the
2522
            --  body of the mode updater procedure and the global
2523
            --  variable designating the current mode. there is no
2524
            --  harm using a global variable because
2525
            --  it is accessed exclusively by the thread.
2526
            --  We also with a package instance of teh corresponding
2527
            --  scheduler
2528

2529 1
            N := Make_Current_Mode_Declaration (E);
2530 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
2531

2532 1
            if Is_Fusioned (E) then
2533 0
               N := Make_Mode_Updater_body (E);
2534 0
               Append_Node_To_List (N, ADN.Statements (Current_Package));
2535

2536
               N :=
2537 0
                 Make_Withed_Package
2538 0
                   (Make_Defining_Identifier
2539 0
                      (Map_Scheduler_Instance_Name (E)));
2540 0
               Append_Node_To_List (N, ADN.Withed_Packages (Current_Package));
2541
            end if;
2542
         end if;
2543

2544 1
      end Visit_Thread_Instance;
2545

2546
      ----------------------------
2547
      -- Make_Mode_Updater_Body --
2548
      ----------------------------
2549

2550 0
      function Make_Mode_Updater_body (E : Node_Id) return Node_Id is
2551 0
         N    : Node_Id;
2552
         Spec : constant Node_Id :=
2553 0
           Backend_Node (Identifier (First_Node (Modes (E))));
2554 0
         Stats : constant List_Id := New_List (ADN.K_List_Id);
2555
      begin
2556
         N :=
2557 0
           Make_Assignment_Statement
2558
             (Variable_Identifier => Current_Mode_Identifier,
2559 0
              Expression          => Make_Defining_Identifier (PN (P_Mode)));
2560 0
         Append_Node_To_List (N, Stats);
2561 0
         N := Make_Subprogram_Implementation (Spec, No_List, Stats);
2562 0
         return N;
2563
      end Make_Mode_Updater_body;
2564

2565
   end Package_Body;
2566

2567 1
end Ocarina.Backends.PO_HI_Ada.Activity;

Read our documentation on viewing source code .

Loading