OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--                 OCARINA.BACKENDS.PO_HI_ADA.SUBPROGRAMS                   --
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.ME_AADL;
34
with Ocarina.ME_AADL.AADL_Instances.Nodes;
35
with Ocarina.ME_AADL.AADL_Instances.Nutils;
36
with Ocarina.ME_AADL.AADL_Instances.Entities;
37

38
with Ocarina.Backends.Utils;
39
with Ocarina.Backends.Properties;
40
with Ocarina.Backends.Ada_Tree.Nutils;
41
with Ocarina.Backends.Ada_Tree.Nodes;
42
with Ocarina.Backends.Ada_Values;
43
with Ocarina.Backends.PO_HI_Ada.Mapping;
44
with Ocarina.Backends.PO_HI_Ada.Runtime;
45

46
package body Ocarina.Backends.PO_HI_Ada.Subprograms is
47

48
   use Ocarina.ME_AADL;
49
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
50
   use Ocarina.ME_AADL.AADL_Instances.Entities;
51
   use Ocarina.Backends.Utils;
52
   use Ocarina.Backends.Properties;
53
   use Ocarina.Backends.Ada_Tree.Nutils;
54
   use Ocarina.Backends.Ada_Values;
55
   use Ocarina.Backends.PO_HI_Ada.Mapping;
56
   use Ocarina.Backends.PO_HI_Ada.Runtime;
57

58
   package AAN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
59
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
60
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
61

62
   ------------------
63
   -- Package_Spec --
64
   ------------------
65

66
   package body Package_Spec is
67

68
      procedure Visit_Architecture_Instance (E : Node_Id);
69
      procedure Visit_Component_Instance (E : Node_Id);
70
      procedure Visit_System_Instance (E : Node_Id);
71
      procedure Visit_Process_Instance (E : Node_Id);
72
      procedure Visit_Thread_Instance (E : Node_Id);
73
      procedure Visit_Subprogram_Instance (E : Node_Id);
74
      procedure Visit_Data_Instance (E : Node_Id);
75
      procedure Visit_Device_Instance (E : Node_Id);
76
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
77

78
      function Put_Value_Spec (E : Node_Id) return Node_Id;
79
      function Get_Value_Spec (E : Node_Id) return Node_Id;
80
      function Next_Value_Spec (E : Node_Id) return Node_Id;
81
      function Get_Count_Spec (E : Node_Id) return Node_Id;
82
      --  Routines to raise and collect subprogram events in a thread
83
      --  safe manner.
84

85
      --------------------
86
      -- Put_Value_Spec --
87
      --------------------
88

89 1
      function Put_Value_Spec (E : Node_Id) return Node_Id is
90 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
91 1
         N       : Node_Id;
92
      begin
93
         N :=
94 1
           Make_Parameter_Specification
95 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Status)),
96
              Subtype_Mark        =>
97 1
                Make_Defining_Identifier (Map_Port_Status_Name (E)),
98
              Parameter_Mode => Mode_Inout);
99 1
         Append_Node_To_List (N, Profile);
100

101
         N :=
102 1
           Make_Parameter_Specification
103
             (Defining_Identifier =>
104 1
                Make_Defining_Identifier (PN (P_Spg_Interface)),
105
              Subtype_Mark =>
106 1
                Make_Defining_Identifier (Map_Port_Interface_Name (E)),
107
              Parameter_Mode => Mode_In);
108 1
         Append_Node_To_List (N, Profile);
109

110
         N :=
111 1
           Make_Subprogram_Specification
112
             (Defining_Identifier =>
113 1
                Make_Defining_Identifier (SN (S_Put_Value)),
114
              Parameter_Profile => Profile,
115
              Return_Type       => No_Node);
116 1
         return N;
117
      end Put_Value_Spec;
118

119
      --------------------
120
      -- Get_Value_Spec --
121
      --------------------
122

123 1
      function Get_Value_Spec (E : Node_Id) return Node_Id is
124 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
125 1
         N       : Node_Id;
126
      begin
127
         N :=
128 1
           Make_Parameter_Specification
129 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Status)),
130
              Subtype_Mark        =>
131 1
                Make_Defining_Identifier (Map_Port_Status_Name (E)),
132
              Parameter_Mode => Mode_In);
133 1
         Append_Node_To_List (N, Profile);
134

135
         N :=
136 1
           Make_Parameter_Specification
137 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Port)),
138
              Subtype_Mark        =>
139 1
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
140
              Parameter_Mode => Mode_In);
141 1
         Append_Node_To_List (N, Profile);
142

143
         N :=
144 1
           Make_Subprogram_Specification
145
             (Defining_Identifier =>
146 1
                Make_Defining_Identifier (SN (S_Get_Value)),
147
              Parameter_Profile => Profile,
148
              Return_Type       =>
149 1
                Make_Defining_Identifier (Map_Port_Interface_Name (E)));
150 1
         return N;
151
      end Get_Value_Spec;
152

153
      ---------------------
154
      -- Next_Value_Spec --
155
      ---------------------
156

157 1
      function Next_Value_Spec (E : Node_Id) return Node_Id is
158 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
159 1
         N       : Node_Id;
160
      begin
161
         N :=
162 1
           Make_Parameter_Specification
163 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Status)),
164
              Subtype_Mark        =>
165 1
                Make_Defining_Identifier (Map_Port_Status_Name (E)),
166
              Parameter_Mode => Mode_Inout);
167 1
         Append_Node_To_List (N, Profile);
168

169
         N :=
170 1
           Make_Parameter_Specification
171 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Port)),
172
              Subtype_Mark        =>
173 1
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
174
              Parameter_Mode => Mode_In);
175 1
         Append_Node_To_List (N, Profile);
176

177
         N :=
178 1
           Make_Subprogram_Specification
179
             (Defining_Identifier =>
180 1
                Make_Defining_Identifier (SN (S_Next_Value)),
181
              Parameter_Profile => Profile,
182
              Return_Type       => No_Node);
183 1
         return N;
184
      end Next_Value_Spec;
185

186
      --------------------
187
      -- Get_Count_Spec --
188
      --------------------
189

190 1
      function Get_Count_Spec (E : Node_Id) return Node_Id is
191 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
192 1
         N       : Node_Id;
193
      begin
194
         N :=
195 1
           Make_Parameter_Specification
196 1
             (Defining_Identifier => Make_Defining_Identifier (PN (P_Status)),
197
              Subtype_Mark        =>
198 1
                Make_Defining_Identifier (Map_Port_Status_Name (E)),
199
              Parameter_Mode => Mode_In);
200 1
         Append_Node_To_List (N, Profile);
201

202
         N :=
203 1
           Make_Parameter_Specification
204 1
             (Defining_Identifier => 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 1
         Append_Node_To_List (N, Profile);
209

210
         N :=
211 1
           Make_Subprogram_Specification
212
             (Defining_Identifier =>
213 1
                Make_Defining_Identifier (SN (S_Get_Count)),
214
              Parameter_Profile => Profile,
215 1
              Return_Type       => RE (RE_Integer));
216 1
         return N;
217
      end Get_Count_Spec;
218

219
      -----------
220
      -- Visit --
221
      -----------
222

223 1
      procedure Visit (E : Node_Id) is
224
      begin
225 1
         case Kind (E) is
226 1
            when K_Architecture_Instance =>
227 1
               Visit_Architecture_Instance (E);
228

229 1
            when K_Component_Instance =>
230 1
               Visit_Component_Instance (E);
231

232 0
            when others =>
233 0
               null;
234 1
         end case;
235 1
      end Visit;
236

237
      ---------------------------------
238
      -- Visit_Architecture_Instance --
239
      ---------------------------------
240

241 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
242
      begin
243 1
         Visit (Root_System (E));
244 1
      end Visit_Architecture_Instance;
245

246
      ------------------------------
247
      -- Visit_Component_Instance --
248
      ------------------------------
249

250 1
      procedure Visit_Component_Instance (E : Node_Id) is
251
         Category : constant Component_Category :=
252 1
           Get_Category_Of_Component (E);
253
      begin
254 1
         case Category is
255 1
            when CC_System =>
256 1
               Visit_System_Instance (E);
257

258 1
            when CC_Process =>
259 1
               Visit_Process_Instance (E);
260

261 1
            when CC_Thread =>
262 1
               Visit_Thread_Instance (E);
263

264 1
            when CC_Subprogram =>
265 1
               Visit_Subprogram_Instance (E);
266

267 1
            when CC_Data =>
268 1
               Visit_Data_Instance (E);
269

270 1
            when others =>
271 1
               null;
272 1
         end case;
273 1
      end Visit_Component_Instance;
274

275
      -------------------------
276
      -- Visit_Data_Instance --
277
      -------------------------
278

279 1
      procedure Visit_Data_Instance (E : Node_Id) is
280
         Data_Representation : constant Supported_Data_Representation :=
281 1
           Get_Data_Representation (E);
282 1
         S : Node_Id;
283
      begin
284 1
         if Data_Representation = Data_With_Accessors then
285
            --  Visit all the accessor subprograms of the data type
286

287 1
            S := First_Node (Features (E));
288

289 1
            while Present (S) loop
290 1
               Visit (Corresponding_Instance (S));
291 1
               S := Next_Node (S);
292 1
            end loop;
293
         end if;
294 1
      end Visit_Data_Instance;
295

296
      ---------------------------
297
      -- Visit_Device_Instance --
298
      ---------------------------
299

300 1
      procedure Visit_Device_Instance (E : Node_Id) is
301 1
         Implementation : constant Node_Id := Get_Implementation (E);
302 1
         S              : Node_Id;
303
      begin
304 1
         if Implementation /= No_Node then
305 1
            if not AAU.Is_Empty (AAN.Subcomponents (Implementation)) then
306 1
               S := First_Node (Subcomponents (Implementation));
307 1
               while Present (S) loop
308 1
                  if not AAU.Is_Subprogram (Corresponding_Instance (S)) then
309 1
                     Visit_Component_Instance (Corresponding_Instance (S));
310
                  end if;
311 1
                  S := Next_Node (S);
312 1
               end loop;
313
            end if;
314
         end if;
315 1
      end Visit_Device_Instance;
316

317
      ----------------------------
318
      -- Visit_Process_Instance --
319
      ----------------------------
320

321 1
      procedure Visit_Process_Instance (E : Node_Id) is
322
         U : constant Node_Id :=
323 1
           ADN.Distributed_Application_Unit
324 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
325 1
         P          : constant Node_Id := ADN.Entity (U);
326 1
         S          : Node_Id;
327
         The_System : constant Node_Id :=
328 1
           Parent_Component (Parent_Subcomponent (E));
329

330
      begin
331 1
         Push_Entity (P);
332 1
         Push_Entity (U);
333 1
         Set_Subprograms_Spec;
334

335
         --  Start recording all the handlings
336

337 1
         Start_Recording_Handlings;
338

339
         --  Visit all the subcomponents of the process
340

341 1
         Visit_Subcomponents_Of (E);
342

343
         --  Visit all devices attached to the parent system that
344
         --  share the same processor as process E.
345

346 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
347 1
            S := First_Node (Subcomponents (The_System));
348 1
            while Present (S) loop
349 1
               if AAU.Is_Device (Corresponding_Instance (S))
350
                 and then
351 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
352 1
                   Get_Bound_Processor (E)
353
               then
354 1
                  Visit_Device_Instance (Corresponding_Instance (S));
355
               end if;
356 1
               S := Next_Node (S);
357 1
            end loop;
358
         end if;
359

360
         --  Unmark all the marked subprograms
361

362 1
         Reset_Handlings;
363

364 1
         Pop_Entity; -- U
365 1
         Pop_Entity; -- P
366 1
      end Visit_Process_Instance;
367

368
      -------------------------------
369
      -- Visit_Subprogram_Instance --
370
      -------------------------------
371

372 1
      procedure Visit_Subprogram_Instance (E : Node_Id) is
373 1
         N        : Node_Id;
374 1
         Call_Seq : Node_Id;
375 1
         Spg_Call : Node_Id;
376
      begin
377
         --  Generate the spec of the subprogram
378

379 1
         if No (Get_Handling (E, By_Name, H_Ada_Subprogram_Spec)) then
380
            --  Mark the subprogram as being handled
381

382 1
            Set_Handling (E, By_Name, H_Ada_Subprogram_Spec, E);
383

384 1
            if Has_Out_Ports (E) then
385
               --  If the subprogram contains out event [data] ports,
386
               --  declare the following entities.
387

388
               --  An enumeration type for the SPG out ports
389

390 1
               N := Map_Port_Enumeration (E);
391 1
               Bind_AADL_To_Port_Enumeration (Identifier (E), N);
392 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
393

394
               --  A Subprogram_Interface discriminated record
395

396 1
               N := Map_Port_Interface (E);
397 1
               Bind_AADL_To_Port_Interface (Identifier (E), N);
398 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
399

400
               --  The same AADL subprogram, may be invoked by
401
               --  different threads. The user implementation DOES NOT
402
               --  HAVE TO know which thread is actually running the
403
               --  subprogram. In partivular, if a subprogram, raises
404
               --  events on one of its out ports, the venet must be
405
               --  dispatched to the thread running the subprogra in a
406
               --  way which is transparent to the user. A simple way
407
               --  to perform this is the use of an opaque IN OUT
408
               --  parameter which is given to the subprogram. This
409
               --  implies that the thread is aware of the subprogram
410
               --  event raise AFTER the complete run of the
411
               --  subprogram.
412

413
               --  A private type called <spg>_Port_Status.
414

415 1
               N := Map_Port_Status (E, Full_Declaration => False);
416 1
               Bind_AADL_To_Type_Definition (Identifier (E), N);
417 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
418

419 1
               N := Map_Port_Status (E, Full_Declaration => True);
420 1
               Append_Node_To_List (N, ADN.Private_Part (Current_Package));
421

422
               --  Spec of the Put_Value subprogram, generally used by
423
               --  the user code to raise an event [data].
424

425 1
               N := Put_Value_Spec (E);
426 1
               Bind_AADL_To_Put_Value (Identifier (E), N);
427 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
428

429
               --  Spec of the Get_Value subprogram, generally used by
430
               --  the thread code to get the raised events.
431

432 1
               N := Get_Value_Spec (E);
433 1
               Bind_AADL_To_Get_Value (Identifier (E), N);
434 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
435

436
               --  Spec of the Next_Value subprogram, generally used by
437
               --  the thread code to get the raised events.
438

439 1
               N := Next_Value_Spec (E);
440 1
               Bind_AADL_To_Next_Value (Identifier (E), N);
441 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
442

443
               --  Spec of the Get_Count subprogram, generally used
444
               --  by the thread code to get the raised events.
445

446 1
               N := Get_Count_Spec (E);
447 1
               Bind_AADL_To_Get_Count (Identifier (E), N);
448 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
449
            end if;
450

451 1
            N := Map_Ada_Subprogram_Spec (E);
452 1
            Bind_AADL_To_Subprogram (Identifier (E), N);
453 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
454
         else
455
            declare
456
               H : constant Node_Id :=
457 1
                 Get_Handling (E, By_Name, H_Ada_Subprogram_Spec);
458
            begin
459 1
               Bind_AADL_To_Subprogram
460 1
                 (Identifier (E),
461 1
                  ADN.Subprogram_Node (Backend_Node (Identifier (H))));
462

463 1
               if Has_Out_Ports (E) then
464 0
                  Bind_AADL_To_Port_Enumeration
465 0
                    (Identifier (E),
466 0
                     ADN.Port_Enumeration_Node
467 0
                       (Backend_Node (Identifier (H))));
468 0
                  Bind_AADL_To_Port_Interface
469 0
                    (Identifier (E),
470 0
                     ADN.Port_Interface_Node (Backend_Node (Identifier (H))));
471 0
                  Bind_AADL_To_Type_Definition
472 0
                    (Identifier (E),
473 0
                     ADN.Type_Definition_Node (Backend_Node (Identifier (H))));
474 0
                  Bind_AADL_To_Put_Value
475 0
                    (Identifier (E),
476 0
                     ADN.Put_Value_Node (Backend_Node (Identifier (H))));
477 0
                  Bind_AADL_To_Get_Value
478 0
                    (Identifier (E),
479 0
                     ADN.Get_Value_Node (Backend_Node (Identifier (H))));
480
               end if;
481
            end;
482
         end if;
483

484
         --  Visit all the call sequences of the subprogram
485

486 1
         if not AAU.Is_Empty (Calls (E)) then
487 1
            Call_Seq := First_Node (Calls (E));
488

489 1
            while Present (Call_Seq) loop
490
               --  For each call sequence visit all the called
491
               --  subprograms.
492

493 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
494 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
495

496 1
                  while Present (Spg_Call) loop
497 1
                     Visit (Corresponding_Instance (Spg_Call));
498

499 1
                     Spg_Call := Next_Node (Spg_Call);
500 1
                  end loop;
501
               end if;
502

503 1
               Call_Seq := Next_Node (Call_Seq);
504 1
            end loop;
505
         end if;
506 1
      end Visit_Subprogram_Instance;
507

508
      ---------------------------
509
      -- Visit_System_Instance --
510
      ---------------------------
511

512 1
      procedure Visit_System_Instance (E : Node_Id) is
513
      begin
514 1
         Push_Entity (Ada_Root);
515

516
         --  Visit all the subcomponents of the system
517

518 1
         Visit_Subcomponents_Of (E);
519

520 1
         Pop_Entity; --  Ada_Root
521 1
      end Visit_System_Instance;
522

523
      ---------------------------
524
      -- Visit_Thread_Instance --
525
      ---------------------------
526

527 1
      procedure Visit_Thread_Instance (E : Node_Id) is
528 1
         Call_Seq : Node_Id;
529 1
         Spg_Call : Node_Id;
530
      begin
531
         --  Visit all the call sequences of the thread
532

533 1
         if not AAU.Is_Empty (Calls (E)) then
534 1
            Call_Seq := First_Node (Calls (E));
535

536 1
            while Present (Call_Seq) loop
537
               --  For each call sequence visit all the called
538
               --  subprograms.
539

540 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
541 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
542

543 1
                  while Present (Spg_Call) loop
544 1
                     Visit (Corresponding_Instance (Spg_Call));
545

546 1
                     Spg_Call := Next_Node (Spg_Call);
547 1
                  end loop;
548
               end if;
549

550 1
               Call_Seq := Next_Node (Call_Seq);
551 1
            end loop;
552
         end if;
553 1
      end Visit_Thread_Instance;
554

555
   end Package_Spec;
556

557
   ------------------
558
   -- Package_Body --
559
   ------------------
560

561
   package body Package_Body is
562

563
      procedure Visit_Architecture_Instance (E : Node_Id);
564
      procedure Visit_Component_Instance (E : Node_Id);
565
      procedure Visit_System_Instance (E : Node_Id);
566
      procedure Visit_Process_Instance (E : Node_Id);
567
      procedure Visit_Thread_Instance (E : Node_Id);
568
      procedure Visit_Subprogram_Instance (E : Node_Id);
569
      procedure Visit_Data_Instance (E : Node_Id);
570
      procedure Visit_Device_Instance (E : Node_Id);
571
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
572

573
      function Put_Value_Body (E : Node_Id) return Node_Id;
574
      function Get_Value_Body (E : Node_Id) return Node_Id;
575
      function Next_Value_Body (E : Node_Id) return Node_Id;
576
      function Get_Count_Body (E : Node_Id) return Node_Id;
577
      --  Routines to raise and collect subprogram events in a thread
578
      --  safe manner.
579

580
      --------------------
581
      -- Put_Value_Body --
582
      --------------------
583

584 1
      function Put_Value_Body (E : Node_Id) return Node_Id is
585
         Spec : constant Node_Id :=
586 1
           ADN.Put_Value_Node (Backend_Node (Identifier (E)));
587 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
588 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
589 1
         F            : Node_Id;
590 1
         N            : Node_Id;
591
      begin
592 1
         F := First_Node (Features (E));
593

594 1
         while Present (F) loop
595 1
            if Kind (F) = K_Port_Spec_Instance then
596
               declare
597 1
                  St : constant List_Id := New_List (ADN.K_Statement_List);
598
               begin
599
                  --  Set the boolean flag corresponding to the
600
                  --  component to 'True'.
601

602
                  N :=
603 1
                    Make_Assignment_Statement
604 1
                      (Make_Selected_Component
605 1
                         (Make_Defining_Identifier (PN (P_Status)),
606 1
                          Map_Ada_Defining_Identifier (F)),
607 1
                       RE (RE_True));
608 1
                  Append_Node_To_List (N, St);
609

610 1
                  if AAN.Is_Data (F) then
611
                     --  Update the component correspodning to the out
612
                     --  port in the status structure
613

614
                     N :=
615 1
                       Make_Assignment_Statement
616 1
                         (Make_Selected_Component
617 1
                            (Make_Defining_Identifier (PN (P_Status)),
618 1
                             Make_Defining_Identifier
619 1
                               (Map_Ada_Component_Name (F))),
620 1
                          Make_Selected_Component
621 1
                            (Make_Defining_Identifier (PN (P_Spg_Interface)),
622 1
                             Make_Defining_Identifier
623 1
                               (Map_Ada_Component_Name (F))));
624 1
                     Append_Node_To_List (N, St);
625
                  end if;
626

627
                  --  Create the case alternative
628

629
                  N :=
630 1
                    Make_Case_Statement_Alternative
631 1
                      (Make_List_Id (Map_Ada_Defining_Identifier (F)),
632
                       St);
633 1
                  Append_Node_To_List (N, Alternatives);
634
               end;
635
            end if;
636

637 1
            F := Next_Node (F);
638 1
         end loop;
639

640
         N :=
641 1
           Make_Case_Statement
642 1
             (Make_Selected_Component
643 1
                (Make_Defining_Identifier (PN (P_Spg_Interface)),
644 1
                 Make_Defining_Identifier (CN (C_Port))),
645
              Alternatives);
646 1
         Append_Node_To_List (N, Statements);
647

648 1
         N := Make_Subprogram_Implementation (Spec, No_List, Statements);
649 1
         return N;
650
      end Put_Value_Body;
651

652
      --------------------
653
      -- Get_Value_Body --
654
      --------------------
655

656 1
      function Get_Value_Body (E : Node_Id) return Node_Id is
657
         Spec : constant Node_Id :=
658 1
           ADN.Get_Value_Node (Backend_Node (Identifier (E)));
659 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
660 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
661 1
         F            : Node_Id;
662 1
         N            : Node_Id;
663
      begin
664 1
         F := First_Node (Features (E));
665

666 1
         while Present (F) loop
667 1
            if Kind (F) = K_Port_Spec_Instance then
668
               declare
669 1
                  Aggr : constant List_Id := New_List (ADN.K_List_Id);
670
               begin
671
                  N :=
672 1
                    Make_Component_Association
673 1
                      (Make_Defining_Identifier (CN (C_Port)),
674 1
                       Map_Ada_Defining_Identifier (F));
675 1
                  Append_Node_To_List (N, Aggr);
676

677 1
                  if AAN.Is_Data (F) then
678
                     --  Update the component correspodning to the out
679
                     --  port in the status structure.
680

681
                     N :=
682 1
                       Make_Component_Association
683 1
                         (Make_Defining_Identifier
684 1
                            (Map_Ada_Component_Name (F)),
685 1
                          Make_Selected_Component
686 1
                            (Make_Defining_Identifier (PN (P_Status)),
687 1
                             Make_Defining_Identifier
688 1
                               (Map_Ada_Component_Name (F))));
689 1
                     Append_Node_To_List (N, Aggr);
690
                  end if;
691

692 1
                  N := Make_Return_Statement (Make_Record_Aggregate (Aggr));
693

694
                  --  Create the case alternative
695

696
                  N :=
697 1
                    Make_Case_Statement_Alternative
698 1
                      (Make_List_Id (Map_Ada_Defining_Identifier (F)),
699 1
                       Make_List_Id (N));
700 1
                  Append_Node_To_List (N, Alternatives);
701
               end;
702
            end if;
703

704 1
            F := Next_Node (F);
705 1
         end loop;
706

707
         N :=
708 1
           Make_Case_Statement
709 1
             (Make_Defining_Identifier (PN (P_Port)),
710
              Alternatives);
711 1
         Append_Node_To_List (N, Statements);
712

713 1
         N := Make_Subprogram_Implementation (Spec, No_List, Statements);
714 1
         return N;
715
      end Get_Value_Body;
716

717
      ---------------------
718
      -- Next_Value_Body --
719
      ---------------------
720

721 1
      function Next_Value_Body (E : Node_Id) return Node_Id is
722
         Spec : constant Node_Id :=
723 1
           ADN.Next_Value_Node (Backend_Node (Identifier (E)));
724 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
725 1
         Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
726 1
         N            : Node_Id;
727
      begin
728
         --  FIXME: Not implemented yet for now
729

730
         N :=
731 1
           Make_Pragma_Statement
732
             (Pragma_Unreferenced,
733 1
              Make_List_Id
734 1
                (Make_Defining_Identifier (PN (P_Status)),
735 1
                 Make_Defining_Identifier (PN (P_Port))));
736 1
         Append_Node_To_List (N, Declarations);
737

738 1
         N := Message_Comment ("Not implemented yet!");
739 1
         Append_Node_To_List (N, Statements);
740

741
         N :=
742 1
           Make_Raise_Statement
743 1
             (Make_Defining_Identifier (EN (E_Program_Error)));
744 1
         Append_Node_To_List (N, Statements);
745

746 1
         N := Make_Subprogram_Implementation (Spec, Declarations, Statements);
747 1
         return N;
748
      end Next_Value_Body;
749

750
      --------------------
751
      -- Get_Count_Body --
752
      --------------------
753

754 1
      function Get_Count_Body (E : Node_Id) return Node_Id is
755
         Spec : constant Node_Id :=
756 1
           ADN.Get_Count_Node (Backend_Node (Identifier (E)));
757 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
758 1
         Alternatives : constant List_Id := New_List (ADN.K_List_Id);
759 1
         F            : Node_Id;
760 1
         N            : Node_Id;
761
      begin
762
         --  FIXME: For now, the returned value is either 0 or 1, we
763
         --  must take into account the port fifo size.
764

765 1
         F := First_Node (Features (E));
766

767 1
         while Present (F) loop
768 1
            if Kind (F) = K_Port_Spec_Instance then
769
               declare
770 1
                  St : constant List_Id := New_List (ADN.K_Statement_List);
771
               begin
772
                  --  If the boolean flag corresponding to the
773
                  --  component is 'True' then return 1, else return 0
774

775
                  N :=
776 1
                    Make_If_Statement
777
                      (Condition =>
778 1
                         Make_Selected_Component
779 1
                           (Make_Defining_Identifier (PN (P_Status)),
780 1
                            Map_Ada_Defining_Identifier (F)),
781
                       Then_Statements =>
782 1
                         Make_List_Id
783 1
                           (Make_Return_Statement
784 1
                              (Make_Literal (New_Integer_Value (1, 1, 10)))),
785
                       Else_Statements =>
786 1
                         Make_List_Id
787 1
                           (Make_Return_Statement
788 1
                              (Make_Literal (New_Integer_Value (0, 1, 10)))));
789 1
                  Append_Node_To_List (N, St);
790

791
                  --  Create the case alternative
792

793
                  N :=
794 1
                    Make_Case_Statement_Alternative
795 1
                      (Make_List_Id (Map_Ada_Defining_Identifier (F)),
796
                       St);
797 1
                  Append_Node_To_List (N, Alternatives);
798
               end;
799
            end if;
800

801 1
            F := Next_Node (F);
802 1
         end loop;
803

804
         N :=
805 1
           Make_Case_Statement
806 1
             (Make_Defining_Identifier (PN (P_Port)),
807
              Alternatives);
808 1
         Append_Node_To_List (N, Statements);
809

810 1
         N := Make_Subprogram_Implementation (Spec, No_List, Statements);
811 1
         return N;
812
      end Get_Count_Body;
813

814
      -----------
815
      -- Visit --
816
      -----------
817

818 1
      procedure Visit (E : Node_Id) is
819
      begin
820 1
         case Kind (E) is
821 1
            when K_Architecture_Instance =>
822 1
               Visit_Architecture_Instance (E);
823

824 1
            when K_Component_Instance =>
825 1
               Visit_Component_Instance (E);
826

827 0
            when others =>
828 0
               null;
829 1
         end case;
830 1
      end Visit;
831

832
      ---------------------------------
833
      -- Visit_Architecture_Instance --
834
      ---------------------------------
835

836 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
837
      begin
838 1
         Visit (Root_System (E));
839 1
      end Visit_Architecture_Instance;
840

841
      ------------------------------
842
      -- Visit_Component_Instance --
843
      ------------------------------
844

845 1
      procedure Visit_Component_Instance (E : Node_Id) is
846
         Category : constant Component_Category :=
847 1
           Get_Category_Of_Component (E);
848
      begin
849 1
         case Category is
850 1
            when CC_System =>
851 1
               Visit_System_Instance (E);
852

853 1
            when CC_Process =>
854 1
               Visit_Process_Instance (E);
855

856 1
            when CC_Thread =>
857 1
               Visit_Thread_Instance (E);
858

859 1
            when CC_Subprogram =>
860 1
               Visit_Subprogram_Instance (E);
861

862 1
            when CC_Data =>
863 1
               Visit_Data_Instance (E);
864

865 1
            when others =>
866 1
               null;
867 1
         end case;
868 1
      end Visit_Component_Instance;
869

870
      -------------------------
871
      -- Visit_Data_Instance --
872
      -------------------------
873

874 1
      procedure Visit_Data_Instance (E : Node_Id) is
875
         Data_Representation : constant Supported_Data_Representation :=
876 1
           Get_Data_Representation (E);
877 1
         S : Node_Id;
878
      begin
879 1
         if Data_Representation = Data_With_Accessors then
880
            --  Visit all the accessor subprograms of the data type
881

882 1
            S := First_Node (Features (E));
883

884 1
            while Present (S) loop
885

886 1
               Visit (Corresponding_Instance (S));
887

888 1
               S := Next_Node (S);
889 1
            end loop;
890
         end if;
891 1
      end Visit_Data_Instance;
892

893
      ---------------------------
894
      -- Visit_Device_Instance --
895
      ---------------------------
896

897 1
      procedure Visit_Device_Instance (E : Node_Id) is
898 1
         Implementation : constant Node_Id := Get_Implementation (E);
899 1
         S              : Node_Id;
900
      begin
901 1
         if Implementation /= No_Node then
902 1
            if not AAU.Is_Empty (AAN.Subcomponents (Implementation)) then
903 1
               S := First_Node (Subcomponents (Implementation));
904 1
               while Present (S) loop
905 1
                  if not AAU.Is_Subprogram (Corresponding_Instance (S)) then
906 1
                     Visit_Component_Instance (Corresponding_Instance (S));
907
                  end if;
908 1
                  S := Next_Node (S);
909 1
               end loop;
910
            end if;
911
         end if;
912 1
      end Visit_Device_Instance;
913

914
      ----------------------------
915
      -- Visit_Process_Instance --
916
      ----------------------------
917

918 1
      procedure Visit_Process_Instance (E : Node_Id) is
919
         U : constant Node_Id :=
920 1
           ADN.Distributed_Application_Unit
921 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
922 1
         P          : constant Node_Id := ADN.Entity (U);
923 1
         S          : Node_Id;
924
         The_System : constant Node_Id :=
925 1
           Parent_Component (Parent_Subcomponent (E));
926

927
      begin
928 1
         Push_Entity (P);
929 1
         Push_Entity (U);
930 1
         Set_Subprograms_Body;
931

932
         --  Start recording all the handlings
933

934 1
         Start_Recording_Handlings;
935

936
         --  Visit all the subcomponents of the process
937

938 1
         Visit_Subcomponents_Of (E);
939

940
         --  Visit all devices attached to the parent system that
941
         --  share the same processor as process E.
942

943 1
         if not AAU.Is_Empty (Subcomponents (The_System)) then
944 1
            S := First_Node (Subcomponents (The_System));
945 1
            while Present (S) loop
946 1
               if AAU.Is_Device (Corresponding_Instance (S))
947
                 and then
948 1
                   Get_Bound_Processor (Corresponding_Instance (S)) =
949 1
                   Get_Bound_Processor (E)
950
               then
951 1
                  Visit_Device_Instance (Corresponding_Instance (S));
952
               end if;
953 1
               S := Next_Node (S);
954 1
            end loop;
955
         end if;
956

957
         --  Unmark all the marked subprograms
958

959 1
         Reset_Handlings;
960

961 1
         Pop_Entity; -- U
962 1
         Pop_Entity; -- P
963 1
      end Visit_Process_Instance;
964

965
      -------------------------------
966
      -- Visit_Subprogram_Instance --
967
      -------------------------------
968

969 1
      procedure Visit_Subprogram_Instance (E : Node_Id) is
970 1
         N        : Node_Id;
971 1
         Call_Seq : Node_Id;
972 1
         Spg_Call : Node_Id;
973
      begin
974
         --  Generate the body of the subprogram
975

976 1
         if No (Get_Handling (E, By_Name, H_Ada_Subprogram_Body)) then
977 1
            N := Map_Ada_Subprogram_Body (E);
978 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
979

980 1
            if Has_Out_Ports (E) then
981
               --  If the subprogram contains out event [data] ports,
982
               --  declare the following entities.
983

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

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

990 1
               N := Next_Value_Body (E);
991 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
992

993 1
               N := Get_Count_Body (E);
994 1
               Append_Node_To_List (N, ADN.Statements (Current_Package));
995
            end if;
996

997
            --  Mark the data type as being handled
998

999 1
            Set_Handling (E, By_Name, H_Ada_Subprogram_Body, N);
1000
         end if;
1001

1002
         --  Visit all the call sequences of the subprogram
1003

1004 1
         if not AAU.Is_Empty (Calls (E)) then
1005 1
            Call_Seq := First_Node (Calls (E));
1006

1007 1
            while Present (Call_Seq) loop
1008
               --  For each call sequence visit all the called
1009
               --  subprograms.
1010

1011 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
1012 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
1013

1014 1
                  while Present (Spg_Call) loop
1015 1
                     Visit (Corresponding_Instance (Spg_Call));
1016

1017 1
                     Spg_Call := Next_Node (Spg_Call);
1018 1
                  end loop;
1019
               end if;
1020

1021 1
               Call_Seq := Next_Node (Call_Seq);
1022 1
            end loop;
1023
         end if;
1024 1
      end Visit_Subprogram_Instance;
1025

1026
      ---------------------------
1027
      -- Visit_System_Instance --
1028
      ---------------------------
1029

1030 1
      procedure Visit_System_Instance (E : Node_Id) is
1031
      begin
1032 1
         Push_Entity (Ada_Root);
1033

1034
         --  Visit all the subcomponents of the system
1035

1036 1
         Visit_Subcomponents_Of (E);
1037

1038 1
         Pop_Entity; --  Ada_Root
1039 1
      end Visit_System_Instance;
1040

1041
      ---------------------------
1042
      -- Visit_Thread_Instance --
1043
      ---------------------------
1044

1045 1
      procedure Visit_Thread_Instance (E : Node_Id) is
1046 1
         Call_Seq : Node_Id;
1047 1
         Spg_Call : Node_Id;
1048 1
         N        : Node_Id;
1049
      begin
1050
         --  Visit all the call sequences of the thread
1051

1052 1
         if not AAU.Is_Empty (Calls (E)) then
1053 1
            Call_Seq := First_Node (Calls (E));
1054

1055 1
            while Present (Call_Seq) loop
1056
               --  For each call sequence visit all the called
1057
               --  subprograms.
1058

1059 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
1060 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
1061

1062 1
                  while Present (Spg_Call) loop
1063 1
                     Visit (Corresponding_Instance (Spg_Call));
1064

1065 1
                     Spg_Call := Next_Node (Spg_Call);
1066 1
                  end loop;
1067
               end if;
1068

1069 1
               Call_Seq := Next_Node (Call_Seq);
1070 1
            end loop;
1071
         end if;
1072

1073 1
         if Has_Modes (E) and then Is_Fusioned (E) then
1074
            N :=
1075 0
              Make_Withed_Package
1076 0
                (Make_Defining_Identifier (Map_Scheduler_Instance_Name (E)),
1077
                 Used => True);
1078 0
            Append_Node_To_List (N, ADN.Withed_Packages (Current_Package));
1079
         end if;
1080

1081 1
      end Visit_Thread_Instance;
1082

1083
   end Package_Body;
1084

1085
end Ocarina.Backends.PO_HI_Ada.Subprograms;

Read our documentation on viewing source code .

Loading