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

33
with Ocarina.Namet; use Ocarina.Namet;
34
with Utils;         use Utils;
35

36
with Ocarina.ME_AADL.AADL_Tree.Nodes;
37
with Ocarina.ME_AADL.AADL_Instances.Nodes;
38
with Ocarina.ME_AADL.AADL_Instances.Nutils;
39
with Ocarina.Backends.Utils;
40
with Ocarina.Backends.Ada_Tree.Nodes;
41
with Ocarina.Backends.Ada_Tree.Nutils;
42
with Ocarina.Backends.PO_HI_Ada.Runtime;
43
with Ocarina.Backends.Ada_Values;
44

45
package body Ocarina.Backends.PO_HI_Ada.Mapping is
46

47
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
48
   use Ocarina.Backends.Utils;
49
   use Ocarina.Backends.Ada_Tree.Nodes;
50
   use Ocarina.Backends.Ada_Tree.Nutils;
51
   use Ocarina.Backends.PO_HI_Ada.Runtime;
52
   use Ocarina.Backends.Ada_Values;
53

54
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
55
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
56
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
57
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
58

59
   ---------------------------
60
   -- Bind_AADL_To_Activity --
61
   ---------------------------
62

63 1
   procedure Bind_AADL_To_Activity (G : Node_Id; A : Node_Id) is
64 1
      N : Node_Id;
65
   begin
66 1
      N := AIN.Backend_Node (G);
67

68 1
      if No (N) then
69 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
70 0
         AIN.Set_Backend_Node (G, N);
71
      end if;
72

73 1
      ADN.Set_Activity_Node (N, A);
74 1
      ADN.Set_Frontend_Node (A, G);
75 1
   end Bind_AADL_To_Activity;
76

77
   -----------------------------
78
   -- Bind_AADL_To_Deployment --
79
   -----------------------------
80

81 1
   procedure Bind_AADL_To_Deployment (G : Node_Id; A : Node_Id) is
82 1
      N : Node_Id;
83
   begin
84 1
      N := AIN.Backend_Node (G);
85

86 1
      if No (N) then
87 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
88 0
         AIN.Set_Backend_Node (G, N);
89
      end if;
90

91 1
      ADN.Set_Deployment_Node (N, A);
92 1
      ADN.Set_Frontend_Node (A, G);
93 1
   end Bind_AADL_To_Deployment;
94

95
   -----------------------------
96
   -- Bind_AADL_To_Enumerator --
97
   -----------------------------
98

99 1
   procedure Bind_AADL_To_Enumerator (G : Node_Id; A : Node_Id) is
100 1
      N : Node_Id;
101
   begin
102 1
      N := AIN.Backend_Node (G);
103

104 1
      if No (N) then
105 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
106 1
         AIN.Set_Backend_Node (G, N);
107
      end if;
108

109 1
      ADN.Set_Enumerator_Node (N, A);
110 1
      ADN.Set_Frontend_Node (A, G);
111 1
   end Bind_AADL_To_Enumerator;
112

113
   ----------------------
114
   -- Bind_AADL_To_Job --
115
   ----------------------
116

117 1
   procedure Bind_AADL_To_Job (G : Node_Id; A : Node_Id) is
118 1
      N : Node_Id;
119
   begin
120 1
      N := AIN.Backend_Node (G);
121

122 1
      if No (N) then
123 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
124 0
         AIN.Set_Backend_Node (G, N);
125
      end if;
126

127 1
      ADN.Set_Job_Node (N, A);
128 1
      ADN.Set_Frontend_Node (A, G);
129 1
   end Bind_AADL_To_Job;
130

131
   -----------------------
132
   -- Bind_AADL_To_Main --
133
   -----------------------
134

135 1
   procedure Bind_AADL_To_Main (G : Node_Id; A : Node_Id) is
136 1
      N : Node_Id;
137
   begin
138 1
      N := AIN.Backend_Node (G);
139

140 1
      if No (N) then
141 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
142 0
         AIN.Set_Backend_Node (G, N);
143
      end if;
144

145 1
      ADN.Set_Main_Node (N, A);
146 1
      ADN.Set_Frontend_Node (A, G);
147 1
   end Bind_AADL_To_Main;
148

149
   ---------------------------
150
   -- Bind_AADL_To_Marshall --
151
   ---------------------------
152

153 1
   procedure Bind_AADL_To_Marshall (G : Node_Id; A : Node_Id) is
154 1
      N : Node_Id;
155
   begin
156 1
      N := AIN.Backend_Node (G);
157

158 1
      if No (N) then
159 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
160 0
         AIN.Set_Backend_Node (G, N);
161
      end if;
162

163 1
      ADN.Set_Marshall_Node (N, A);
164 1
      ADN.Set_Frontend_Node (A, G);
165 1
   end Bind_AADL_To_Marshall;
166

167
   ------------------------------
168
   -- Bind_AADL_To_Marshallers --
169
   ------------------------------
170

171 1
   procedure Bind_AADL_To_Marshallers (G : Node_Id; A : Node_Id) is
172 1
      N : Node_Id;
173
   begin
174 1
      N := AIN.Backend_Node (G);
175

176 1
      if No (N) then
177 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
178 0
         AIN.Set_Backend_Node (G, N);
179
      end if;
180

181 1
      ADN.Set_Marshallers_Node (N, A);
182 1
      ADN.Set_Frontend_Node (A, G);
183 1
   end Bind_AADL_To_Marshallers;
184

185
   -------------------------
186
   -- Bind_AADL_To_Naming --
187
   -------------------------
188

189 1
   procedure Bind_AADL_To_Naming (G : Node_Id; A : Node_Id) is
190 1
      N : Node_Id;
191
   begin
192 1
      N := AIN.Backend_Node (G);
193

194 1
      if No (N) then
195 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
196 1
         AIN.Set_Backend_Node (G, N);
197
      end if;
198

199 1
      ADN.Set_Naming_Node (N, A);
200 1
      ADN.Set_Frontend_Node (A, G);
201 1
   end Bind_AADL_To_Naming;
202

203
   ----------------------------
204
   -- Bind_AADL_To_Transport --
205
   ----------------------------
206

207 1
   procedure Bind_AADL_To_Transport (G : Node_Id; A : Node_Id) is
208 1
      N : Node_Id;
209
   begin
210 1
      N := AIN.Backend_Node (G);
211

212 1
      if No (N) then
213 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
214 0
         AIN.Set_Backend_Node (G, N);
215
      end if;
216

217 1
      ADN.Set_Transport_Node (N, A);
218 1
      ADN.Set_Frontend_Node (A, G);
219 1
   end Bind_AADL_To_Transport;
220

221
   -------------------------
222
   -- Bind_AADL_To_Object --
223
   -------------------------
224

225 1
   procedure Bind_AADL_To_Object (G : Node_Id; A : Node_Id) is
226 1
      N : Node_Id;
227
   begin
228 1
      N := AIN.Backend_Node (G);
229

230 1
      if No (N) then
231 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
232 1
         AIN.Set_Backend_Node (G, N);
233
      end if;
234

235 1
      ADN.Set_Object_Node (N, A);
236 1
      ADN.Set_Frontend_Node (A, G);
237 1
   end Bind_AADL_To_Object;
238

239
   -------------------------------------
240
   -- Bind_AADL_To_Feature_Subprogram --
241
   -------------------------------------
242

243 1
   procedure Bind_AADL_To_Feature_Subprogram (G : Node_Id; A : Node_Id) is
244 1
      N : Node_Id;
245
   begin
246 1
      N := AIN.Backend_Node (G);
247

248 1
      if No (N) then
249 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
250 1
         AIN.Set_Backend_Node (G, N);
251
      end if;
252

253 1
      ADN.Set_Feature_Subprogram_Node (N, A);
254 1
      ADN.Set_Frontend_Node (A, G);
255 1
   end Bind_AADL_To_Feature_Subprogram;
256

257
   -----------------------------
258
   -- Bind_AADL_To_Subprogram --
259
   -----------------------------
260

261 1
   procedure Bind_AADL_To_Subprogram (G : Node_Id; A : Node_Id) is
262 1
      N : Node_Id;
263
   begin
264 1
      N := AIN.Backend_Node (G);
265

266 1
      if No (N) then
267 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
268 1
         AIN.Set_Backend_Node (G, N);
269
      end if;
270

271 1
      ADN.Set_Subprogram_Node (N, A);
272 1
      ADN.Set_Frontend_Node (A, G);
273 1
   end Bind_AADL_To_Subprogram;
274

275
   ------------------------------
276
   -- Bind_AADL_To_Subprograms --
277
   ------------------------------
278

279 1
   procedure Bind_AADL_To_Subprograms (G : Node_Id; A : Node_Id) is
280 1
      N : Node_Id;
281
   begin
282 1
      N := AIN.Backend_Node (G);
283

284 1
      if No (N) then
285 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
286 0
         AIN.Set_Backend_Node (G, N);
287
      end if;
288

289 1
      ADN.Set_Subprograms_Node (N, A);
290 1
      ADN.Set_Frontend_Node (A, G);
291 1
   end Bind_AADL_To_Subprograms;
292

293
   ----------------------------------
294
   -- Bind_AADL_To_Type_Definition --
295
   ----------------------------------
296

297 1
   procedure Bind_AADL_To_Type_Definition (G : Node_Id; A : Node_Id) is
298 1
      N : Node_Id;
299
   begin
300 1
      N := AIN.Backend_Node (G);
301

302 1
      if No (N) then
303 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
304 1
         AIN.Set_Backend_Node (G, N);
305
      end if;
306

307 1
      ADN.Set_Type_Definition_Node (N, A);
308 1
      ADN.Set_Frontend_Node (A, G);
309 1
   end Bind_AADL_To_Type_Definition;
310

311
   --------------------------------
312
   -- Bind_AADL_To_Default_Value --
313
   --------------------------------
314

315 1
   procedure Bind_AADL_To_Default_Value (G : Node_Id; A : Node_Id) is
316 1
      N : Node_Id;
317
   begin
318 1
      N := AIN.Backend_Node (G);
319

320 1
      if No (N) then
321 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
322 0
         AIN.Set_Backend_Node (G, N);
323
      end if;
324

325 1
      ADN.Set_Default_Value_Node (N, A);
326 1
      ADN.Set_Frontend_Node (A, G);
327 1
   end Bind_AADL_To_Default_Value;
328

329
   ---------------------------------
330
   -- Bind_AADL_To_Port_Interface --
331
   ---------------------------------
332

333 1
   procedure Bind_AADL_To_Port_Interface (G : Node_Id; A : Node_Id) is
334 1
      N : Node_Id;
335
   begin
336 1
      N := AIN.Backend_Node (G);
337

338 1
      if No (N) then
339 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
340 0
         AIN.Set_Backend_Node (G, N);
341
      end if;
342

343 1
      ADN.Set_Port_Interface_Node (N, A);
344 1
      ADN.Set_Frontend_Node (A, G);
345 1
   end Bind_AADL_To_Port_Interface;
346

347
   -----------------------------------
348
   -- Bind_AADL_To_Port_Enumeration --
349
   -----------------------------------
350

351 1
   procedure Bind_AADL_To_Port_Enumeration (G : Node_Id; A : Node_Id) is
352 1
      N : Node_Id;
353
   begin
354 1
      N := AIN.Backend_Node (G);
355

356 1
      if No (N) then
357 1
         N := New_Node (ADN.K_HI_Tree_Bindings);
358 1
         AIN.Set_Backend_Node (G, N);
359
      end if;
360

361 1
      ADN.Set_Port_Enumeration_Node (N, A);
362 1
      ADN.Set_Frontend_Node (A, G);
363 1
   end Bind_AADL_To_Port_Enumeration;
364

365
   ------------------------
366
   -- Bind_AADL_To_Types --
367
   ------------------------
368

369 1
   procedure Bind_AADL_To_Types (G : Node_Id; A : Node_Id) is
370 1
      N : Node_Id;
371
   begin
372 1
      N := AIN.Backend_Node (G);
373

374 1
      if No (N) then
375 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
376 0
         AIN.Set_Backend_Node (G, N);
377
      end if;
378

379 1
      ADN.Set_Types_Node (N, A);
380 1
      ADN.Set_Frontend_Node (A, G);
381 1
   end Bind_AADL_To_Types;
382

383
   -----------------------------
384
   -- Bind_AADL_To_Unmarshall --
385
   -----------------------------
386

387 1
   procedure Bind_AADL_To_Unmarshall (G : Node_Id; A : Node_Id) is
388 1
      N : Node_Id;
389
   begin
390 1
      N := AIN.Backend_Node (G);
391

392 1
      if No (N) then
393 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
394 0
         AIN.Set_Backend_Node (G, N);
395
      end if;
396

397 1
      ADN.Set_Unmarshall_Node (N, A);
398 1
      ADN.Set_Frontend_Node (A, G);
399 1
   end Bind_AADL_To_Unmarshall;
400

401
   ----------------------------
402
   -- Bind_AADL_To_Get_Value --
403
   ----------------------------
404

405 1
   procedure Bind_AADL_To_Get_Value (G : Node_Id; A : Node_Id) is
406 1
      N : Node_Id;
407
   begin
408 1
      N := AIN.Backend_Node (G);
409

410 1
      if No (N) then
411 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
412 0
         AIN.Set_Backend_Node (G, N);
413
      end if;
414

415 1
      ADN.Set_Get_Value_Node (N, A);
416 1
      ADN.Set_Frontend_Node (A, G);
417 1
   end Bind_AADL_To_Get_Value;
418

419
   ----------------------------
420
   -- Bind_AADL_To_Put_Value --
421
   ----------------------------
422

423 1
   procedure Bind_AADL_To_Put_Value (G : Node_Id; A : Node_Id) is
424 1
      N : Node_Id;
425
   begin
426 1
      N := AIN.Backend_Node (G);
427

428 1
      if No (N) then
429 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
430 0
         AIN.Set_Backend_Node (G, N);
431
      end if;
432

433 1
      ADN.Set_Put_Value_Node (N, A);
434 1
      ADN.Set_Frontend_Node (A, G);
435 1
   end Bind_AADL_To_Put_Value;
436

437
   ----------------------------
438
   -- Bind_AADL_To_Get_Count --
439
   ----------------------------
440

441 1
   procedure Bind_AADL_To_Get_Count (G : Node_Id; A : Node_Id) is
442 1
      N : Node_Id;
443
   begin
444 1
      N := AIN.Backend_Node (G);
445

446 1
      if No (N) then
447 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
448 0
         AIN.Set_Backend_Node (G, N);
449
      end if;
450

451 1
      ADN.Set_Get_Count_Node (N, A);
452 1
      ADN.Set_Frontend_Node (A, G);
453 1
   end Bind_AADL_To_Get_Count;
454

455
   -----------------------------
456
   -- Bind_AADL_To_Next_Value --
457
   -----------------------------
458

459 1
   procedure Bind_AADL_To_Next_Value (G : Node_Id; A : Node_Id) is
460 1
      N : Node_Id;
461
   begin
462 1
      N := AIN.Backend_Node (G);
463

464 1
      if No (N) then
465 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
466 0
         AIN.Set_Backend_Node (G, N);
467
      end if;
468

469 1
      ADN.Set_Next_Value_Node (N, A);
470 1
      ADN.Set_Frontend_Node (A, G);
471 1
   end Bind_AADL_To_Next_Value;
472

473
   -----------------------------------------
474
   -- Bind_AADL_To_Store_Received_Message --
475
   -----------------------------------------
476

477 1
   procedure Bind_AADL_To_Store_Received_Message (G : Node_Id; A : Node_Id) is
478 1
      N : Node_Id;
479
   begin
480 1
      N := AIN.Backend_Node (G);
481

482 1
      if No (N) then
483 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
484 0
         AIN.Set_Backend_Node (G, N);
485
      end if;
486

487 1
      ADN.Set_Store_Received_Message_Node (N, A);
488 1
      ADN.Set_Frontend_Node (A, G);
489 1
   end Bind_AADL_To_Store_Received_Message;
490

491
   --------------------------
492
   -- Bind_AADL_To_Deliver --
493
   --------------------------
494

495 1
   procedure Bind_AADL_To_Deliver (G : Node_Id; A : Node_Id) is
496 1
      N : Node_Id;
497
   begin
498 1
      N := AIN.Backend_Node (G);
499

500 1
      if No (N) then
501 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
502 0
         AIN.Set_Backend_Node (G, N);
503
      end if;
504

505 1
      ADN.Set_Deliver_Node (N, A);
506 1
      ADN.Set_Frontend_Node (A, G);
507 1
   end Bind_AADL_To_Deliver;
508

509
   -----------------------
510
   -- Bind_AADL_To_Send --
511
   -----------------------
512

513 1
   procedure Bind_AADL_To_Send (G : Node_Id; A : Node_Id) is
514 1
      N : Node_Id;
515
   begin
516 1
      N := AIN.Backend_Node (G);
517

518 1
      if No (N) then
519 0
         N := New_Node (ADN.K_HI_Tree_Bindings);
520 0
         AIN.Set_Backend_Node (G, N);
521
      end if;
522

523 1
      ADN.Set_Send_Node (N, A);
524 1
      ADN.Set_Frontend_Node (A, G);
525 1
   end Bind_AADL_To_Send;
526

527
   ------------------------
528
   -- Extract_Enumerator --
529
   ------------------------
530

531 1
   function Extract_Enumerator
532
     (E : Node_Id;
533
      D : Boolean := True) return Node_Id
534
   is
535 1
      I : Node_Id;
536
   begin
537
      pragma Assert
538 1
        (AAU.Is_Process (E)
539 1
         or else AAU.Is_Thread (E)
540 1
         or else AAU.Is_Device (E)
541 1
         or else Kind (E) = K_Port_Spec_Instance);
542

543 1
      if AAU.Is_Process (E) or else AAU.Is_Thread (E) or else D then
544 1
         declare
545 1
            S : Node_Id := E;
546
         begin
547 1
            if AAU.Is_Process (E) or else AAU.Is_Thread (E) then
548 1
               S := Parent_Subcomponent (E);
549
            end if;
550

551 1
            I := Copy_Node (Enumerator_Node (Backend_Node (Identifier (S))));
552 1
            Set_Homogeneous_Parent_Unit_Name
553
              (I,
554 1
               RU (RU_PolyORB_HI_Generated_Deployment));
555
         end;
556
      else
557
         declare
558 1
            T : constant Node_Id := Parent_Component (E);
559
            P : constant Node_Id :=
560 1
              Extract_Designator
561 1
                (ADN.Parent
562 1
                   (ADN.Port_Enumeration_Node
563 1
                      (Backend_Node (Identifier (T)))));
564
         begin
565 1
            I := Map_Ada_Defining_Identifier (E);
566 1
            Set_Homogeneous_Parent_Unit_Name (I, P);
567
         end;
568
      end if;
569

570 1
      return I;
571
   end Extract_Enumerator;
572

573
   ---------------------------------
574
   -- Map_Distributed_Application --
575
   ---------------------------------
576

577 1
   function Map_Distributed_Application (E : Node_Id) return Node_Id is
578 1
      D : constant Node_Id := New_Node (ADN.K_HI_Distributed_Application);
579
   begin
580 1
      pragma Assert (AAU.Is_System (E));
581

582
      --  Update the global variable to be able to fetch the root of
583
      --  the distributed application and generate the source files.
584

585 1
      Ada_Root := D;
586

587 1
      ADN.Set_Name (D, To_Ada_Name (AIN.Name (AIN.Identifier (E))));
588 1
      ADN.Set_Units (D, New_List (ADN.K_List_Id));
589 1
      ADN.Set_HI_Nodes (D, New_List (ADN.K_List_Id));
590

591 1
      return D;
592
   end Map_Distributed_Application;
593

594
   -----------------
595
   -- Map_HI_Node --
596
   -----------------
597

598 1
   function Map_HI_Node (E : Node_Id) return Node_Id is
599 1
      N : constant Node_Id := New_Node (ADN.K_HI_Node);
600
   begin
601 1
      pragma Assert (AAU.Is_Process (E));
602

603
      --  The name of the node is not the name of the process
604
      --  component instance, but the name of the process subcomponent
605
      --  corresponding to this instance.
606

607 1
      ADN.Set_Name
608
        (N,
609 1
         To_Ada_Name
610 1
           (AIN.Name (AIN.Identifier (AIN.Parent_Subcomponent (E)))));
611

612 1
      Set_Units (N, New_List (K_List_Id));
613

614
      --  Append the partition N to the node list of the PolyORB-HI
615
      --  distributed application. We are sure that the top of the
616
      --  entity stack contains the Ada distributed application node.
617

618 1
      Append_Node_To_List (N, HI_Nodes (Current_Entity));
619 1
      Set_Distributed_Application (N, Current_Entity);
620

621 1
      return N;
622
   end Map_HI_Node;
623

624
   -----------------
625
   -- Map_HI_Unit --
626
   -----------------
627

628 1
   function Map_HI_Unit (E : Node_Id) return Node_Id is
629 1
      U        : Node_Id;
630 1
      L        : List_Id;
631 1
      N        : Node_Id;
632 1
      P        : Node_Id;
633 1
      RG       : Node_Id;
634 1
      Ada_Name : Name_Id;
635
   begin
636 1
      pragma Assert (AAU.Is_Process (E));
637

638 1
      U := New_Node (ADN.K_HI_Unit, AIN.Identifier (E));
639 1
      L := New_List (K_Packages);
640 1
      Set_Packages (U, L);
641

642
      Ada_Name :=
643 1
        To_Ada_Name
644 1
          (AIN.Display_Name (AIN.Identifier (AIN.Parent_Subcomponent (E))));
645

646
      --  We build a virtual root corresponding to the
647
      --  PolyORB_HI_Generated package. This is only done to assign
648
      --  the correct parent to all the packages below and does not
649
      --  lead to the generation of the root package.
650

651 1
      N  := Defining_Identifier (RU (RU_PolyORB_HI_Generated, False));
652 1
      RG := Make_Package_Declaration (N);
653 1
      Set_Distributed_Application_Unit (RG, U);
654

655
      --  The 'Naming' package
656

657 1
      N := Defining_Identifier (RU (RU_PolyORB_HI_Generated_Naming, False));
658 1
      P := Make_Package_Declaration (N);
659 1
      ADN.Set_Parent (P, RG);
660 1
      Set_Distributed_Application_Unit (P, U);
661 1
      Set_Naming_Package (U, P);
662 1
      Append_Node_To_List (P, L);
663 1
      Bind_AADL_To_Naming (Identifier (E), P);
664

665
      --  The 'Deployment' package
666

667
      N :=
668 1
        Defining_Identifier (RU (RU_PolyORB_HI_Generated_Deployment, False));
669 1
      P := Make_Package_Declaration (N);
670 1
      ADN.Set_Parent (P, RG);
671 1
      Set_Distributed_Application_Unit (P, U);
672 1
      Set_Deployment_Package (U, P);
673 1
      Append_Node_To_List (P, L);
674 1
      Bind_AADL_To_Deployment (Identifier (E), P);
675

676
      --  The 'Types' package
677

678 1
      N := Defining_Identifier (RU (RU_PolyORB_HI_Generated_Types, False));
679 1
      P := Make_Package_Declaration (N);
680 1
      ADN.Set_Parent (P, RG);
681 1
      Set_Distributed_Application_Unit (P, U);
682 1
      Set_Types_Package (U, P);
683 1
      Append_Node_To_List (P, L);
684 1
      Bind_AADL_To_Types (Identifier (E), P);
685

686
      --  The 'Marshallers' package
687

688
      N :=
689 1
        Defining_Identifier (RU (RU_PolyORB_HI_Generated_Marshallers, False));
690 1
      P := Make_Package_Declaration (N);
691 1
      ADN.Set_Parent (P, RG);
692 1
      Set_Distributed_Application_Unit (P, U);
693 1
      Set_Marshallers_Package (U, P);
694 1
      Append_Node_To_List (P, L);
695 1
      Bind_AADL_To_Marshallers (Identifier (E), P);
696

697
      --  The 'Subprograms' package
698

699
      N :=
700 1
        Defining_Identifier (RU (RU_PolyORB_HI_Generated_Subprograms, False));
701 1
      P := Make_Package_Declaration (N);
702 1
      ADN.Set_Parent (P, RG);
703 1
      Set_Distributed_Application_Unit (P, U);
704 1
      Set_Subprograms_Package (U, P);
705 1
      Append_Node_To_List (P, L);
706 1
      Bind_AADL_To_Subprograms (Identifier (E), P);
707

708
      --  The 'Activity' package
709

710 1
      N := Defining_Identifier (RU (RU_PolyORB_HI_Generated_Activity, False));
711 1
      P := Make_Package_Declaration (N);
712 1
      ADN.Set_Parent (P, RG);
713 1
      Set_Distributed_Application_Unit (P, U);
714 1
      Set_Activity_Package (U, P);
715 1
      Append_Node_To_List (P, L);
716 1
      Bind_AADL_To_Activity (Identifier (E), P);
717

718
      --  The 'Job' package
719

720 1
      N := Defining_Identifier (RU (RU_PolyORB_HI_Generated_Job, False));
721 1
      P := Make_Package_Declaration (N);
722 1
      ADN.Set_Parent (P, RG);
723 1
      Set_Distributed_Application_Unit (P, U);
724 1
      Set_Job_Package (U, P);
725 1
      Append_Node_To_List (P, L);
726 1
      Bind_AADL_To_Job (Identifier (E), P);
727

728
      --  The 'Transport' package
729

730 1
      N := Defining_Identifier (RU (RU_PolyORB_HI_Generated_Transport, False));
731 1
      P := Make_Package_Declaration (N);
732 1
      ADN.Set_Parent (P, RG);
733 1
      Set_Distributed_Application_Unit (P, U);
734 1
      Set_Transport_Package (U, P);
735 1
      Append_Node_To_List (P, L);
736 1
      Bind_AADL_To_Transport (Identifier (E), P);
737

738
      --  Main suprogram
739

740
      P :=
741 1
        Make_Main_Subprogram_Implementation
742 1
          (Make_Defining_Identifier (Ada_Name));
743 1
      Set_Distributed_Application_Unit (P, U);
744 1
      Set_Main_Subprogram (U, P);
745 1
      Append_Node_To_List (P, L);
746 1
      Bind_AADL_To_Main (Identifier (E), P);
747

748
      --  Append the Unit to the units list of the current Ada
749
      --  partition.
750

751 1
      Append_Node_To_List (U, Units (Current_Entity));
752 1
      ADN.Set_Entity (U, Current_Entity);
753

754 1
      return U;
755
   end Map_HI_Unit;
756

757
   ------------------
758
   -- Map_Ada_Time --
759
   ------------------
760

761
   Ada_Time_Routine : constant array (Time_Units) of RE_Id :=
762
     (Picosecond  => RE_Null,
763
      Nanosecond  => RE_Nanoseconds,
764
      Microsecond => RE_Microseconds,
765
      Millisecond => RE_Milliseconds,
766
      Second      => RE_Seconds,
767
      Minute      => RE_Minutes,
768
      Hour        => RE_Null);
769

770 1
   function Map_Ada_Time (T : Time_Type) return Node_Id is
771 1
      Time : Unsigned_Long_Long;
772 1
      S    : Node_Id;
773
   begin
774 1
      case T.U is
775 0
         when Picosecond =>
776
            --  If we can convert it into nanosecond, we are
777
            --  OK. Otherwise this is an error because Ada.Real_Time
778
            --  does not support picoseconds
779

780 0
            if T.T mod 1000 = 0 then
781 0
               Time := T.T / 1000;
782 0
               S    := RE (RE_Nanoseconds);
783
            else
784 0
               return No_Node;
785
            end if;
786

787 0
         when Hour =>
788
            --  Convert it into minutes
789

790 0
            Time := T.T * 60;
791 0
            S    := RE (RE_Minutes);
792

793 1
         when others =>
794 1
            Time := T.T;
795 1
            S    := RE (Ada_Time_Routine (T.U));
796 1
      end case;
797

798 1
      return Make_Subprogram_Call
799
          (S,
800 1
           Make_List_Id (Make_Literal (New_Integer_Value (Time, 1, 10))));
801
   end Map_Ada_Time;
802

803
   ----------------------
804
   -- Map_Ada_Priority --
805
   ----------------------
806

807 1
   function Map_Ada_Priority (P : Unsigned_Long_Long) return Node_Id is
808
   begin
809
      --  XXX we should use the priority_mapping property from AADLv2
810

811 1
      return Make_Literal (New_Integer_Value (P, 1, 10));
812
   end Map_Ada_Priority;
813

814
   --------------------------
815
   -- Map_Marshallers_Name --
816
   --------------------------
817

818 1
   function Map_Marshallers_Name (E : Node_Id) return Name_Id is
819
   begin
820 1
      pragma Assert (AAU.Is_Data (E));
821

822 1
      return Map_Ada_Defining_Identifier (E, "Marshallers");
823
   end Map_Marshallers_Name;
824

825
   -----------------------------
826
   -- Map_Task_Job_Identifier --
827
   -----------------------------
828

829 1
   function Map_Task_Job_Identifier (E : Node_Id) return Node_Id is
830
   begin
831 1
      pragma Assert (AAU.Is_Thread (E));
832

833 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Job");
834
   end Map_Task_Job_Identifier;
835

836
   ------------------------------
837
   -- Map_Task_Init_Identifier --
838
   ------------------------------
839

840 1
   function Map_Task_Init_Identifier (E : Node_Id) return Node_Id is
841
   begin
842 1
      pragma Assert (AAU.Is_Thread (E) or else AAU.Is_Device (E));
843

844 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Init");
845
   end Map_Task_Init_Identifier;
846

847
   ---------------------------------
848
   -- Map_Task_Recover_Identifier --
849
   ---------------------------------
850

851 1
   function Map_Task_Recover_Identifier (E : Node_Id) return Node_Id is
852
   begin
853 1
      pragma Assert (AAU.Is_Thread (E));
854

855 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Recover");
856
   end Map_Task_Recover_Identifier;
857

858
   -------------------------
859
   -- Map_Task_Identifier --
860
   -------------------------
861

862 1
   function Map_Task_Identifier (E : Node_Id) return Node_Id is
863
   begin
864 1
      pragma Assert (AAU.Is_Thread (E));
865

866 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Task");
867
   end Map_Task_Identifier;
868

869
   -------------------------------
870
   -- Map_Port_Enumeration_Name --
871
   -------------------------------
872

873 1
   function Map_Port_Enumeration_Name (E : Node_Id) return Name_Id is
874
   begin
875 1
      pragma Assert (AAU.Is_Thread (E) or else AAU.Is_Subprogram (E));
876

877 1
      return Map_Ada_Defining_Identifier (E, "Port_Type");
878
   end Map_Port_Enumeration_Name;
879

880
   -----------------------------
881
   -- Map_Port_Interface_Name --
882
   -----------------------------
883

884 1
   function Map_Port_Interface_Name (E : Node_Id) return Name_Id is
885
   begin
886 1
      pragma Assert (AAU.Is_Thread (E) or else AAU.Is_Subprogram (E));
887

888 1
      return Map_Ada_Defining_Identifier (E, "Interface");
889
   end Map_Port_Interface_Name;
890

891
   --------------------------
892
   -- Map_Port_Status_Name --
893
   --------------------------
894

895 1
   function Map_Port_Status_Name (E : Node_Id) return Name_Id is
896
   begin
897 1
      pragma Assert (AAU.Is_Subprogram (E));
898

899 1
      return Map_Ada_Defining_Identifier (E, "Status");
900
   end Map_Port_Status_Name;
901

902
   --------------------------
903
   -- Map_Port_Enumeration --
904
   --------------------------
905

906 1
   function Map_Port_Enumeration (E : Node_Id) return Node_Id is
907 1
      Enumerators : constant List_Id := New_List (ADN.K_Enumeration_Literals);
908 1
      F           : Node_Id;
909
   begin
910 1
      if not AAU.Is_Empty (Features (E)) then
911 1
         F := AIN.First_Node (Features (E));
912

913 1
         while Present (F) loop
914 1
            if Kind (F) = K_Port_Spec_Instance then
915 1
               Append_Node_To_List
916 1
                 (Map_Ada_Defining_Identifier (F),
917
                  Enumerators);
918
            end if;
919

920 1
            F := AIN.Next_Node (F);
921 1
         end loop;
922
      end if;
923

924 1
      if Is_Empty (Enumerators) then
925 0
         return No_Node;
926
      else
927 1
         return Make_Full_Type_Declaration
928
             (Defining_Identifier =>
929 1
                Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
930
              Type_Definition =>
931 1
                Make_Enumeration_Type_Definition (Enumerators));
932
      end if;
933
   end Map_Port_Enumeration;
934

935
   ------------------------
936
   -- Map_Port_Interface --
937
   ------------------------
938

939 1
   function Map_Port_Interface (E : Node_Id) return Node_Id is
940 1
      Variants   : constant List_Id := New_List (ADN.K_Variant_List);
941 1
      Variant    : Node_Id;
942 1
      Choice     : Node_Id;
943 1
      Component  : Node_Id;
944 1
      Components : List_Id;
945 1
      F          : Node_Id;
946 1
      N          : Node_Id;
947
   begin
948 1
      if not AAU.Is_Empty (Features (E)) then
949 1
         F := AIN.First_Node (Features (E));
950

951 1
         while Present (F) loop
952 1
            if Kind (F) = K_Port_Spec_Instance then
953
               --  Create a variant with a choice corresponding to
954
               --  the enumerator mapped from the port and with a
955
               --  component having the type of the port (if it is
956
               --  a data port).
957

958 1
               Variant := New_Node (ADN.K_Variant);
959 1
               Append_Node_To_List (Variant, Variants);
960 1
               Choice := Map_Ada_Defining_Identifier (F);
961 1
               ADN.Set_Discrete_Choices (Variant, Make_List_Id (Choice));
962

963 1
               if AIN.Is_Data (F) then
964
                  Component :=
965 1
                    Make_Component_Declaration
966
                      (Defining_Identifier =>
967 1
                         Make_Defining_Identifier (Map_Ada_Component_Name (F)),
968
                       Subtype_Indication =>
969 1
                         Map_Ada_Data_Type_Designator
970 1
                           (Corresponding_Instance (F)));
971 1
                  ADN.Set_Component_List (Variant, Make_List_Id (Component));
972
               end if;
973
            end if;
974

975 1
            F := AIN.Next_Node (F);
976 1
         end loop;
977
      end if;
978

979 1
      if Is_Empty (Variants) then
980 0
         return No_Node;
981
      else
982 1
         Components := New_List (K_Component_List);
983
         N          :=
984 1
           Make_Variant_Part
985 1
             (Discriminant => Make_Defining_Identifier (CN (C_Port)),
986
              Variant_List => Variants);
987 1
         Append_Node_To_List (N, Components);
988

989
         N :=
990 1
           Make_Full_Type_Declaration
991
             (Defining_Identifier =>
992 1
                Make_Defining_Identifier (Map_Port_Interface_Name (E)),
993
              Discriminant_Spec =>
994 1
                Make_Component_Declaration
995
                  (Defining_Identifier =>
996 1
                     Make_Defining_Identifier (CN (C_Port)),
997
                   Subtype_Indication =>
998 1
                     Make_Defining_Identifier (Map_Port_Enumeration_Name (E)),
999
                   Expression =>
1000 1
                     Make_Attribute_Designator
1001 1
                       (Make_Designator (Map_Port_Enumeration_Name (E)),
1002
                        A_First)),
1003
              Type_Definition =>
1004 1
                Make_Record_Type_Definition
1005 1
                  (Make_Record_Definition (Components)));
1006

1007 1
         return N;
1008
      end if;
1009
   end Map_Port_Interface;
1010

1011
   ---------------------
1012
   -- Map_Port_Status --
1013
   ---------------------
1014

1015 1
   function Map_Port_Status
1016
     (E                : Node_Id;
1017
      Full_Declaration : Boolean) return Node_Id
1018
   is
1019 1
      Component_List : List_Id;
1020 1
      F              : Node_Id;
1021 1
      N              : Node_Id;
1022
   begin
1023
      --  FIXME: this implementation assumes that the size of the
1024
      --  FIFOs is 1. we shoulds use arrays of the size of each FIFO.
1025

1026 1
      F := AIN.First_Node (Features (E));
1027

1028 1
      if Full_Declaration then
1029 1
         Component_List := New_List (ADN.K_Component_List);
1030

1031 1
         while Present (F) loop
1032 1
            if Kind (F) = K_Port_Spec_Instance then
1033
               --  For each port, we declare a boolean component to
1034
               --  indicate whether the port is triggered or not.
1035

1036
               N :=
1037 1
                 Make_Component_Declaration
1038 1
                   (Defining_Identifier => Map_Ada_Defining_Identifier (F),
1039 1
                    Subtype_Indication  => RE (RE_Boolean),
1040 1
                    Expression          => RE (RE_False));
1041 1
               Append_Node_To_List (N, Component_List);
1042

1043
               --  If the port is an event data port, we add a
1044
               --  component having the type of the port.
1045

1046 1
               if AIN.Is_Data (F) then
1047
                  N :=
1048 1
                    Make_Component_Declaration
1049
                      (Defining_Identifier =>
1050 1
                         Make_Defining_Identifier (Map_Ada_Component_Name (F)),
1051
                       Subtype_Indication =>
1052 1
                         Map_Ada_Data_Type_Designator
1053 1
                           (Corresponding_Instance (F)));
1054 1
                  Append_Node_To_List (N, Component_List);
1055
               end if;
1056
            end if;
1057

1058 1
            F := AIN.Next_Node (F);
1059 1
         end loop;
1060

1061
         N :=
1062 1
           Make_Record_Type_Definition
1063 1
             (Make_Record_Definition (Component_List));
1064
      else
1065 1
         N := Make_Private_Type_Definition;
1066
      end if;
1067

1068
      N :=
1069 1
        Make_Full_Type_Declaration
1070
          (Defining_Identifier =>
1071 1
             Make_Defining_Identifier (Map_Port_Status_Name (E)),
1072
           Type_Definition => N);
1073 1
      return N;
1074
   end Map_Port_Status;
1075

1076
   ------------------------------
1077
   -- Map_Node_Name_Identifier --
1078
   ------------------------------
1079

1080 0
   function Map_Node_Name_Identifier (E : Node_Id) return Node_Id is
1081
   begin
1082 0
      pragma Assert (Kind (E) = K_Subcomponent_Instance);
1083

1084 0
      return Map_Ada_Defining_Identifier (E, "Node_Name");
1085
   end Map_Node_Name_Identifier;
1086

1087
   ------------------
1088
   -- Map_Bus_Name --
1089
   ------------------
1090

1091 1
   function Map_Bus_Name (E : Node_Id) return Node_Id is
1092
   begin
1093 1
      if AIN.Kind (E) = K_Component_Instance then
1094 1
         return Map_Ada_Defining_Identifier
1095 1
             (Parent_Subcomponent (E),
1096
              "Naming_Table");
1097
      else
1098 1
         return Map_Ada_Defining_Identifier (E, "Naming_Table");
1099
      end if;
1100
   end Map_Bus_Name;
1101

1102
   ----------------------------
1103
   -- Map_Integer_Array_Name --
1104
   ----------------------------
1105

1106 1
   function Map_Integer_Array_Name (E : Node_Id) return Name_Id is
1107
   begin
1108 1
      pragma Assert (AAU.Is_Thread (E));
1109

1110 1
      return Map_Ada_Defining_Identifier (E, "Integer_Array");
1111
   end Map_Integer_Array_Name;
1112

1113
   -------------------------
1114
   -- Map_Kind_Array_Name --
1115
   -------------------------
1116

1117 1
   function Map_Kind_Array_Name (E : Node_Id) return Name_Id is
1118
   begin
1119 1
      pragma Assert (AAU.Is_Thread (E));
1120

1121 1
      return Map_Ada_Defining_Identifier (E, "Port_Kind_Array");
1122
   end Map_Kind_Array_Name;
1123

1124
   --------------------------
1125
   -- Map_Image_Array_Name --
1126
   --------------------------
1127

1128 1
   function Map_Image_Array_Name (E : Node_Id) return Name_Id is
1129
   begin
1130 1
      pragma Assert (AAU.Is_Thread (E));
1131

1132 1
      return Map_Ada_Defining_Identifier (E, "Port_Image_Array");
1133
   end Map_Image_Array_Name;
1134

1135
   ----------------------------
1136
   -- Map_Address_Array_Name --
1137
   ----------------------------
1138

1139 0
   function Map_Address_Array_Name (E : Node_Id) return Name_Id is
1140
   begin
1141 0
      pragma Assert (AAU.Is_Thread (E));
1142

1143 0
      return Map_Ada_Defining_Identifier (E, "Address_Array");
1144
   end Map_Address_Array_Name;
1145

1146
   --------------------------------------
1147
   -- Map_Overflow_Protocol_Array_Name --
1148
   --------------------------------------
1149

1150 1
   function Map_Overflow_Protocol_Array_Name (E : Node_Id) return Name_Id is
1151
   begin
1152 1
      pragma Assert (AAU.Is_Thread (E));
1153

1154 1
      return Map_Ada_Defining_Identifier (E, "Overflow_Protocol_Array");
1155
   end Map_Overflow_Protocol_Array_Name;
1156

1157
   -------------------------
1158
   -- Map_Port_Kinds_Name --
1159
   -------------------------
1160

1161 1
   function Map_Port_Kinds_Name (E : Node_Id) return Name_Id is
1162
   begin
1163 1
      pragma Assert (AAU.Is_Thread (E));
1164

1165 1
      return Map_Ada_Defining_Identifier
1166 1
          (Parent_Subcomponent (E),
1167
           "Port_Kinds");
1168
   end Map_Port_Kinds_Name;
1169

1170
   ---------------------------------
1171
   -- Map_Overflow_Protocols_Name --
1172
   ---------------------------------
1173

1174 1
   function Map_Overflow_Protocols_Name (E : Node_Id) return Name_Id is
1175
   begin
1176 1
      pragma Assert (AAU.Is_Thread (E));
1177

1178 1
      return Map_Ada_Defining_Identifier
1179 1
          (Parent_Subcomponent (E),
1180
           "Overflow_Protocols");
1181
   end Map_Overflow_Protocols_Name;
1182

1183
   ------------------------
1184
   -- Map_Urgencies_Name --
1185
   ------------------------
1186

1187 1
   function Map_Urgencies_Name (E : Node_Id) return Name_Id is
1188
   begin
1189 1
      pragma Assert (AAU.Is_Thread (E));
1190

1191 1
      return Map_Ada_Defining_Identifier
1192 1
          (Parent_Subcomponent (E),
1193
           "Urgencies");
1194
   end Map_Urgencies_Name;
1195

1196
   --------------------------
1197
   -- Map_Port_Images_Name --
1198
   --------------------------
1199

1200 1
   function Map_Port_Images_Name (E : Node_Id) return Name_Id is
1201
   begin
1202 1
      pragma Assert (AAU.Is_Thread (E));
1203

1204 1
      return Map_Ada_Defining_Identifier
1205 1
          (Parent_Subcomponent (E),
1206
           "Port_Images");
1207
   end Map_Port_Images_Name;
1208

1209
   -------------------------
1210
   -- Map_FIFO_Sizes_Name --
1211
   -------------------------
1212

1213 1
   function Map_FIFO_Sizes_Name (E : Node_Id) return Name_Id is
1214
   begin
1215 1
      pragma Assert (AAU.Is_Thread (E));
1216

1217 1
      return Map_Ada_Defining_Identifier
1218 1
          (Parent_Subcomponent (E),
1219
           "FIFO_Sizes");
1220
   end Map_FIFO_Sizes_Name;
1221

1222
   ----------------------
1223
   -- Map_Offsets_Name --
1224
   ----------------------
1225

1226 1
   function Map_Offsets_Name (E : Node_Id) return Name_Id is
1227
   begin
1228 1
      pragma Assert (AAU.Is_Thread (E));
1229

1230 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Offsets");
1231
   end Map_Offsets_Name;
1232

1233
   -------------------------
1234
   -- Map_Total_Size_Name --
1235
   -------------------------
1236

1237 1
   function Map_Total_Size_Name (E : Node_Id) return Name_Id is
1238
   begin
1239 1
      pragma Assert (AAU.Is_Thread (E));
1240

1241 1
      return Map_Ada_Defining_Identifier
1242 1
          (Parent_Subcomponent (E),
1243
           "Total_FIFO_Size");
1244
   end Map_Total_Size_Name;
1245

1246
   --------------------------
1247
   -- Map_Destination_Name --
1248
   --------------------------
1249

1250 1
   function Map_Destination_Name (E : Node_Id) return Name_Id is
1251
   begin
1252
      pragma Assert
1253 1
        (AAU.Is_Thread (E) or else Kind (E) = K_Port_Spec_Instance);
1254

1255 1
      if AAU.Is_Thread (E) then
1256 1
         Get_Name_String
1257 1
           (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E)))));
1258
      else
1259
         declare
1260
            Thread_Name : constant Name_Id :=
1261 1
              To_Ada_Name
1262 1
                (Display_Name
1263 1
                   (Identifier (Parent_Subcomponent (Parent_Component (E)))));
1264
            Port_Name : constant Name_Id :=
1265 1
              To_Ada_Name (Display_Name (Identifier (E)));
1266
         begin
1267 1
            Get_Name_String (Thread_Name);
1268 1
            Add_Char_To_Name_Buffer ('_');
1269 1
            Get_Name_String_And_Append (Port_Name);
1270
         end;
1271
      end if;
1272

1273 1
      Add_Str_To_Name_Buffer ("_Destinations");
1274 1
      return Name_Find;
1275
   end Map_Destination_Name;
1276

1277
   ----------------------------
1278
   -- Map_N_Destination_Name --
1279
   ----------------------------
1280

1281 0
   function Map_N_Destination_Name (E : Node_Id) return Name_Id is
1282
   begin
1283 0
      pragma Assert (AAU.Is_Thread (E));
1284

1285 0
      return Map_Ada_Defining_Identifier
1286 0
          (Parent_Subcomponent (E),
1287
           "N_Destinations");
1288
   end Map_N_Destination_Name;
1289

1290
   ----------------------------
1291
   -- Map_Interrogators_Name --
1292
   ----------------------------
1293

1294 1
   function Map_Interrogators_Name (E : Node_Id) return Name_Id is
1295
   begin
1296 1
      pragma Assert (AAU.Is_Thread (E));
1297

1298 1
      return Map_Ada_Defining_Identifier
1299 1
          (Parent_Subcomponent (E),
1300
           "Interrogators");
1301
   end Map_Interrogators_Name;
1302

1303
   -----------------------------
1304
   -- Map_Refined_Global_Name --
1305
   -----------------------------
1306

1307 1
   function Map_Refined_Global_Name (E : Node_Id) return Node_Id is
1308
   begin
1309 1
      pragma Assert (AAU.Is_Thread (E));
1310

1311 1
      Get_Name_String (Map_Interrogators_Name (E));
1312 1
      Add_Char_To_Name_Buffer ('.');
1313 1
      Get_Name_String_And_Append (PN (P_Elaborated_Variables));
1314 1
      return Make_Defining_Identifier (Name_Find, False);
1315
   end Map_Refined_Global_Name;
1316

1317
   ----------------------
1318
   -- Map_Deliver_Name --
1319
   ----------------------
1320

1321 1
   function Map_Deliver_Name (E : Node_Id) return Name_Id is
1322
   begin
1323 1
      pragma Assert (AAU.Is_Thread (E));
1324

1325 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Deliver");
1326
   end Map_Deliver_Name;
1327

1328
   -------------------
1329
   -- Map_Send_Name --
1330
   -------------------
1331

1332 1
   function Map_Send_Name (E : Node_Id) return Name_Id is
1333
   begin
1334 1
      pragma Assert (AAU.Is_Thread (E));
1335

1336 1
      return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "Send");
1337
   end Map_Send_Name;
1338

1339
   --------------------------------
1340
   -- Map_Modes_Enumeration_Name --
1341
   --------------------------------
1342

1343 1
   function Map_Modes_Enumeration_Name (E : Node_Id) return Name_Id is
1344 1
      N : constant Name_Id := Get_Thread_Reference_Name (E);
1345
   begin
1346 1
      pragma Assert (AAU.Is_Thread (E));
1347

1348 1
      if N = No_Name then
1349 1
         return Map_Ada_Defining_Identifier
1350 1
             (Parent_Subcomponent (E),
1351
              "Mode_Type");
1352
      else
1353 0
         return Get_String_Name (Get_Name_String (N) & "_" & "Mode_Type");
1354
      end if;
1355
   end Map_Modes_Enumeration_Name;
1356

1357
   ---------------------------
1358
   -- Map_Current_Mode_Name --
1359
   ---------------------------
1360

1361 1
   function Map_Current_Mode_Name (E : Node_Id) return Name_Id is
1362
   begin
1363 1
      pragma Assert (AAU.Is_Thread (E));
1364

1365 1
      return Map_Ada_Defining_Identifier
1366 1
          (Parent_Subcomponent (E),
1367
           "Current_Mode");
1368
   end Map_Current_Mode_Name;
1369

1370
   ---------------------------------
1371
   -- Map_Scheduler_Instance_Name --
1372
   ---------------------------------
1373

1374 0
   function Map_Scheduler_Instance_Name (E : Node_Id) return Name_Id is
1375
   begin
1376 0
      pragma Assert (AAU.Is_Thread (E));
1377

1378 0
      return Get_Thread_Scheduler (E);
1379
   end Map_Scheduler_Instance_Name;
1380

1381
   ----------------------------------------
1382
   -- Map_Scheduler_Instance_Object_Name --
1383
   ----------------------------------------
1384

1385 0
   function Map_Scheduler_Instance_Object_Name (E : Node_Id) return Name_Id is
1386 0
      N : constant Name_Id := Get_Thread_Reference_Name (E);
1387
   begin
1388 0
      pragma Assert (AAU.Is_Thread (E));
1389

1390 0
      if N = No_Name then
1391 0
         return Map_Ada_Defining_Identifier (Parent_Subcomponent (E), "mode");
1392
      else
1393 0
         return Get_String_Name (Get_Name_String (N) & "_mode");
1394
      end if;
1395

1396
   end Map_Scheduler_Instance_Object_Name;
1397

1398
   --------------------------------
1399
   -- Map_Exported_Length_Symbol --
1400
   --------------------------------
1401

1402 1
   function Map_Exported_Length_Symbol (E : Node_Id) return Name_Id is
1403
   begin
1404 1
      pragma Assert (Get_Data_Representation (E) = Data_Array);
1405

1406 1
      return To_Lower (Map_Ada_Defining_Identifier (E, "_length"));
1407
   end Map_Exported_Length_Symbol;
1408

1409
   ------------------
1410
   -- Need_Deliver --
1411
   ------------------
1412

1413 1
   function Need_Deliver (E : Node_Id) return Boolean is
1414 1
      Result : Boolean := Has_In_Ports (E);
1415 1
      S      : Node_Id;
1416
   begin
1417 1
      pragma Assert (AAU.Is_Process (E));
1418

1419 1
      if not Result and then not AAU.Is_Empty (Subcomponents (E)) then
1420 1
         S := AIN.First_Node (Subcomponents (E));
1421

1422 1
         while Present (S) and then not Result loop
1423 1
            if AAU.Is_Thread (Corresponding_Instance (S)) then
1424 1
               Result :=
1425 1
                 Result or else Has_In_Ports (Corresponding_Instance (S));
1426
            end if;
1427

1428 1
            S := AIN.Next_Node (S);
1429 1
         end loop;
1430
      end if;
1431

1432 1
      return Result;
1433
   end Need_Deliver;
1434

1435
   ---------------
1436
   -- Need_Send --
1437
   ---------------
1438

1439 1
   function Need_Send (E : Node_Id) return Boolean is
1440 1
      Result : Boolean := Has_Out_Ports (E);
1441 1
      S      : Node_Id;
1442
   begin
1443 1
      pragma Assert (AAU.Is_Process (E));
1444

1445 1
      if not Result and then not AAU.Is_Empty (Subcomponents (E)) then
1446 1
         S := AIN.First_Node (Subcomponents (E));
1447

1448 1
         while Present (S) and then not Result loop
1449 1
            if AAU.Is_Thread (Corresponding_Instance (S)) then
1450 1
               Result :=
1451 1
                 Result or else Has_Out_Ports (Corresponding_Instance (S));
1452
            end if;
1453

1454 1
            S := AIN.Next_Node (S);
1455 1
         end loop;
1456
      end if;
1457

1458 1
      return Result;
1459
   end Need_Send;
1460

1461
   --  The two arrays above give the elementary value to compute
1462
   --  Object sizes for the types mapped from AADL data components. We
1463
   --  cannot rely on the value of 'Size, 'Object_Size and 'Alignment
1464
   --  since the value given by these attributes is not always static.
1465
   --  The values indicate the smallest size for the type.
1466

1467
   Elementary_Type_Sizes : constant array
1468
   (Supported_Data_Representation) of Unsigned_Long_Long :=
1469
     (Data_Integer        => 32,  --  Unique size
1470
      Data_Boolean        => 8,   --  Unique size
1471
      Data_Enum           => 0,   --  Depends on the number of enumerators
1472
      Data_Float          => 0,   --  Unsupported
1473
      Data_Fixed          => 64,  --  Unique size
1474
      Data_String         => 64,  --  MAX_LENGTH'Size + CURRENT_LENGTH'Size
1475
      Data_Wide_String    => 64,  --  MAX_LENGTH'Size + CURRENT_LENGTH'Size
1476
      Data_Character      => 8,   --  Unique size
1477
      Data_Wide_Character => 16,  --  Unique size
1478
      Data_Array          => 0,   --  Initial size
1479
      Data_Bounded_Array  => 0,   --  Initial size
1480
      Data_Struct         => 0,   --  Initial size
1481
      Data_Union          => 0,   --  Initial size
1482
      Data_With_Accessors => 0,   --  Unsupported
1483
      Data_None           => 0);  --  Unsupported
1484

1485
   Elementary_Type_Alignments : constant array
1486
   (Supported_Data_Representation) of Unsigned_Long_Long :=
1487
     (Data_Integer        => 4,
1488
      Data_Boolean        => 1,
1489
      Data_Enum           => 4,
1490
      Data_Float          => 1,    --  Unsupported
1491
      Data_Fixed          => 8,
1492
      Data_String         => 4,
1493
      Data_Wide_String    => 4,
1494
      Data_Character      => 1,
1495
      Data_Wide_Character => 2,
1496
      Data_Array          => 4,
1497
      Data_Bounded_Array  => 4,
1498
      Data_Struct         => 4,
1499
      Data_Union          => 4,
1500
      Data_With_Accessors => 1,    --  Unsupported
1501
      Data_None           => 1);   --  Unsupported
1502

1503
   ------------------------
1504
   -- Estimate_Data_Size --
1505
   ------------------------
1506

1507 1
   function Estimate_Data_Size (E : Node_Id) return Unsigned_Long_Long is
1508
      function Next_Multiple
1509
        (D : Unsigned_Long_Long;
1510
         M : Unsigned_Long_Long) return Unsigned_Long_Long;
1511
      --  Return the smallest multiple of D greater than or equal M
1512

1513
      -------------------
1514
      -- Next_Multiple --
1515
      -------------------
1516

1517 1
      function Next_Multiple
1518
        (D : Unsigned_Long_Long;
1519
         M : Unsigned_Long_Long) return Unsigned_Long_Long
1520
      is
1521
      begin
1522 1
         if M mod D = 0 then
1523 1
            return M;
1524
         else
1525 0
            return D * (1 + M / D);
1526
         end if;
1527
      end Next_Multiple;
1528

1529
      Data_Representation : constant Supported_Data_Representation :=
1530 1
        Get_Data_Representation (E);
1531
   begin
1532 1
      if Get_Data_Size (E) /= Null_Size then
1533
         --  The user provided an exact size, use it
1534

1535 1
         return To_Bits (Get_Data_Size (E));
1536
      end if;
1537

1538 1
      case Data_Representation is
1539 1
         when Data_Integer     |
1540
           Data_Boolean        |
1541
           Data_Fixed          |
1542
           Data_Character      |
1543
           Data_Wide_Character =>
1544 1
            return Elementary_Type_Sizes (Data_Representation);
1545

1546 0
         when Data_Enum =>
1547 0
            declare
1548 0
               N_Enumerators : constant Unsigned_Long_Long :=
1549 0
                 Get_Enumerators (E)'Length;
1550
               pragma Unreferenced (N_Enumerators);
1551
            begin
1552
               --  FIXME: Compute the correct size
1553 0
               return 16;
1554 0
            end;
1555

1556 1
         when Data_String | Data_Wide_String =>
1557 1
            declare
1558 1
               Dimension : constant ULL_Array          := Get_Dimension (E);
1559 1
               L : constant Unsigned_Long_Long := Dimension (Dimension'First);
1560 1
               Result    : constant Unsigned_Long_Long :=
1561 1
                 L * Elementary_Type_Sizes (Data_Representation);
1562
            begin
1563
               --  The type size must be integral multiple of the type
1564
               --  alignment.
1565

1566 1
               return Next_Multiple
1567
                   (Elementary_Type_Alignments (Data_Representation),
1568
                    Result);
1569 1
            end;
1570

1571 1
         when Data_Array | Data_Bounded_Array =>
1572 1
            declare
1573 1
               Dimension : constant ULL_Array := Get_Dimension (E);
1574
               Elt       : constant Node_Id   :=
1575 1
                 ATN.Entity (ATN.First_Node (Get_Base_Type (E)));
1576
               Elt_Type : constant Supported_Data_Representation :=
1577 1
                 Get_Data_Representation (Elt);
1578
               Elt_Size : constant Unsigned_Long_Long :=
1579 1
                 Estimate_Data_Size (Elt);
1580 1
               Result : Unsigned_Long_Long :=
1581
                 Elementary_Type_Sizes (Data_Representation);
1582
            begin
1583 1
               for D in Dimension'Range loop
1584 1
                  for J in 1 .. Dimension (D) loop
1585
                     Result :=
1586 1
                       Next_Multiple
1587
                         (Elementary_Type_Alignments (Elt_Type),
1588
                          Result);
1589 1
                     Result := Result + Elt_Size;
1590 1
                  end loop;
1591 0
               end loop;
1592

1593
               --  The type size must be integral multiple of the type
1594
               --  alignment.
1595

1596 1
               return Next_Multiple
1597
                   (Elementary_Type_Alignments (Data_Representation),
1598
                    Result);
1599 1
            end;
1600

1601 1
         when Data_Struct =>
1602
            declare
1603 1
               Elt      : Node_Id := AIN.First_Node (Subcomponents (E));
1604
               Elt_Type : Supported_Data_Representation :=
1605 1
                 Get_Data_Representation (Corresponding_Instance (Elt));
1606
               Elt_Size : Unsigned_Long_Long :=
1607 1
                 Estimate_Data_Size (Corresponding_Instance (Elt));
1608 1
               Result : Unsigned_Long_Long :=
1609 1
                 Elementary_Type_Sizes (Data_Representation) + Elt_Size;
1610
            begin
1611
               loop
1612 1
                  Elt := AIN.Next_Node (Elt);
1613 1
                  exit when No (Elt);
1614

1615
                  Elt_Type :=
1616 1
                    Get_Data_Representation (Corresponding_Instance (Elt));
1617
                  Elt_Size :=
1618 1
                    Estimate_Data_Size (Corresponding_Instance (Elt));
1619
                  Result :=
1620 1
                    Next_Multiple
1621
                      (Elementary_Type_Alignments (Elt_Type),
1622
                       Result);
1623 1
                  Result := Result + Elt_Size;
1624 1
               end loop;
1625

1626
               --  The type size must be integral multiple of the type
1627
               --  alignment.
1628

1629 1
               return Next_Multiple
1630
                   (Elementary_Type_Alignments (Data_Representation),
1631
                    Result);
1632
            end;
1633

1634 0
         when Data_Union =>
1635 0
            raise Program_Error with "Union type size not implemented yet";
1636

1637 1
         when Data_Float | Data_With_Accessors | Data_None =>
1638 1
            return 0;
1639
      end case;
1640 1
   end Estimate_Data_Size;
1641

1642
end Ocarina.Backends.PO_HI_Ada.Mapping;

Read our documentation on viewing source code .

Loading