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

33
with Ocarina.Namet;
34

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

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

50
package body Ocarina.Backends.PO_HI_Ada.Types is
51

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

64
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
65
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
66
   package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
67
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
68

69
   function Length_Spec (E : Node_Id) return Node_Id;
70
   --  Length of an array type to be exported to C code
71

72
   -----------------
73
   -- Length_Spec --
74
   -----------------
75

76 1
   function Length_Spec (E : Node_Id) return Node_Id is
77 1
      N : Node_Id;
78
   begin
79 1
      pragma Assert (Get_Data_Representation (E) = Data_Array);
80

81
      N :=
82 1
        Make_Subprogram_Specification
83 1
          (Defining_Identifier => Make_Defining_Identifier (SN (S_Length)),
84
           Parameter_Profile   =>
85 1
             Make_List_Id
86 1
               (Make_Parameter_Specification
87 1
                  (Defining_Identifier => Make_Defining_Identifier (PN (P_A)),
88 1
                   Subtype_Mark        => Map_Ada_Defining_Identifier (E))),
89 1
           Return_Type => RE (RE_Integer));
90

91 1
      return N;
92
   end Length_Spec;
93

94
   ------------------
95
   -- Package_Spec --
96
   ------------------
97

98
   package body Package_Spec is
99

100
      procedure Visit_Architecture_Instance (E : Node_Id);
101
      procedure Visit_Component_Instance (E : Node_Id);
102
      procedure Visit_System_Instance (E : Node_Id);
103
      procedure Visit_Process_Instance (E : Node_Id);
104
      procedure Visit_Thread_Instance (E : Node_Id);
105
      procedure Visit_Subprogram_Instance (E : Node_Id);
106
      procedure Visit_Data_Instance (E : Node_Id);
107
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
108

109
      function Feature_Spg_Spec (E : Node_Id) return Node_Id;
110
      --  Builds a spec for a protected object procedure from an AADL
111
      --  subprogram spec E.
112

113
      function Pragma_Export_Length (E : Node_Id) return Node_Id;
114
      --  Length of an array type to be exported to C code
115

116
      ----------------------
117
      -- Feature_Spg_Spec --
118
      ----------------------
119

120 1
      function Feature_Spg_Spec (E : Node_Id) return Node_Id is
121 1
         Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
122 1
         N       : Node_Id;
123 1
         Mode    : Mode_Id;
124 1
         P       : Node_Id;
125 1
         Spg     : Node_Id;
126
      begin
127
         pragma Assert
128 1
           (Kind (E) = K_Subprogram_Spec_Instance
129 1
            or else Kind (E) = K_Subcomponent_Access_Instance);
130

131 1
         Spg := Corresponding_Instance (E);
132

133 1
         pragma Assert (AAU.Is_Subprogram (Spg));
134

135 1
         if not AAU.Is_Empty (Features (Spg)) then
136 1
            P := First_Node (Features (Spg));
137

138 1
            while Present (P) loop
139 1
               if Kind (P) = K_Parameter_Instance then
140

141
                  --  Create a parameter specification
142

143 1
                  if Is_In (P) and then Is_Out (P) then
144 0
                     Mode := Mode_Inout;
145 1
                  elsif Is_Out (P) then
146 1
                     Mode := Mode_Out;
147
                  else
148 1
                     Mode := Mode_In;
149
                  end if;
150

151 1
                  if No (Backend_Node (Identifier (E))) then
152 1
                     Visit_Component_Instance (Corresponding_Instance (P));
153
                  end if;
154

155
                  N :=
156 1
                    Make_Parameter_Specification
157 1
                      (Defining_Identifier => Map_Ada_Defining_Identifier (P),
158
                       Subtype_Mark        =>
159 1
                         Map_Ada_Data_Type_Designator
160 1
                           (Corresponding_Instance (P)),
161
                       Parameter_Mode => Mode);
162 1
                  Append_Node_To_List (N, Profile);
163
               end if;
164

165 1
               P := Next_Node (P);
166 1
            end loop;
167
         end if;
168

169
         N :=
170 1
           Make_Subprogram_Specification
171 1
             (Defining_Identifier => Map_Ada_Defining_Identifier (E),
172
              Parameter_Profile   => Profile);
173

174 1
         return N;
175
      end Feature_Spg_Spec;
176

177
      --------------------------
178
      -- Pragma_Export_Length --
179
      --------------------------
180

181 1
      function Pragma_Export_Length (E : Node_Id) return Node_Id is
182 1
         N : Node_Id;
183
      begin
184 1
         pragma Assert (Get_Data_Representation (E) = Data_Array);
185

186
         N :=
187 1
           Make_Pragma_Statement
188
             (Pragma_Export,
189 1
              Make_List_Id
190 1
                (Make_Defining_Identifier (PN (P_C)),
191 1
                 Make_Defining_Identifier (SN (S_Length)),
192 1
                 Make_Literal
193 1
                   (New_String_Value (Map_Exported_Length_Symbol (E)))));
194

195 1
         return N;
196
      end Pragma_Export_Length;
197

198
      -----------
199
      -- Visit --
200
      -----------
201

202 1
      procedure Visit (E : Node_Id) is
203
      begin
204 1
         case Kind (E) is
205 1
            when K_Architecture_Instance =>
206 1
               Visit_Architecture_Instance (E);
207

208 1
            when K_Component_Instance =>
209 1
               Visit_Component_Instance (E);
210

211 0
            when others =>
212 0
               null;
213 1
         end case;
214 1
      end Visit;
215

216
      ---------------------------------
217
      -- Visit_Architecture_Instance --
218
      ---------------------------------
219

220 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
221
      begin
222 1
         Visit (Root_System (E));
223 1
      end Visit_Architecture_Instance;
224

225
      ------------------------------
226
      -- Visit_Component_Instance --
227
      ------------------------------
228

229 1
      procedure Visit_Component_Instance (E : Node_Id) is
230
         Category : constant Component_Category :=
231 1
           Get_Category_Of_Component (E);
232
      begin
233 1
         case Category is
234 1
            when CC_System =>
235 1
               Visit_System_Instance (E);
236

237 1
            when CC_Process =>
238 1
               Visit_Process_Instance (E);
239

240 1
            when CC_Thread =>
241 1
               Visit_Thread_Instance (E);
242

243 1
            when CC_Data =>
244 1
               Visit_Data_Instance (E);
245

246 1
            when CC_Subprogram =>
247 1
               Visit_Subprogram_Instance (E);
248

249 1
            when others =>
250 1
               null;
251 1
         end case;
252 1
      end Visit_Component_Instance;
253

254
      -------------------------
255
      -- Visit_Data_Instance --
256
      -------------------------
257

258 1
      procedure Visit_Data_Instance (E : Node_Id) is
259 1
         Data_Representation   : Supported_Data_Representation;
260 1
         Language_Type         : Supported_Source_Language;
261 1
         N                     : Node_Id;
262 1
         S                     : Node_Id;
263 1
         Name                  : Name_Id;
264 1
         Actual_Data_Size      : Unsigned_Long_Long;
265 1
         Data_Size             : Size_Type;
266
         Number_Representation : constant Supported_Number_Representation :=
267 1
           Get_Number_Representation (E);
268 1
         Is_Signed : constant Boolean := Number_Representation = Signed;
269
      begin
270
         --  Do not generate Ada type more than once
271

272 1
         if No (Get_Handling (E, By_Name, H_Ada_Type_Spec)) then
273

274
            --  Add a fake handling for now, to avoid infinite recursion
275

276 1
            Set_Handling (E, By_Name, H_Ada_Type_Spec, No_Node + 1);
277

278 1
            Language_Type := Get_Source_Language (E);
279

280 1
            if Language_Type = Language_ASN1 then
281
               --  If the type is defined through an ASN.1
282
               --  specification, then we assume the type is generated
283
               --  in the ASN1_Types package. We simply bind this type
284
               --  to the specification.
285

286 0
               Add_With_Package
287 0
                 (E            => RU (RU_ASN1_Types),
288
                  Used         => True,
289
                  Warnings_Off => True,
290
                  Elaborated   => True);
291

292 0
               Name := Get_Type_Source_Name (E);
293 0
               if Name = No_Name then
294 0
                  Display_Located_Error
295 0
                    (Loc (E),
296
                     "ASN1 types require use of the Type_Source_Name property",
297
                     Fatal => True);
298
               end if;
299

300
               N :=
301 0
                 Make_Designator
302
                   (Name,
303 0
                    Fully_Qualified_Name (RU (RU_ASN1_Types)));
304

305 1
            elsif Language_Type = Language_Ada_95 then
306
               --  If the type is defined through as an Ada type, then
307
               --  we simply drag a dependency onto the Ada package
308
               --  that hosts this type.
309

310 1
               Name := Get_Type_Source_Name (E);
311

312 1
               if Name = No_Name then
313 0
                  Display_Located_Error
314 0
                    (Loc (E),
315
                     "Ada opaque types require the definition of the " &
316
                     "'Type_Source_Name' property",
317
                     Fatal => True);
318
               end if;
319

320
               declare
321 1
                  U : constant Name_Id := Unit_Name (Name);
322 1
                  L : constant Name_Id := Local_Name (Name);
323 1
                  P : Node_Id;
324
               begin
325 1
                  if U /= No_Name then
326
                     --  The user provided a fully qualified name that
327
                     --  is not prefixed by Standard, add this fully
328
                     --  qualified name in the package
329

330 1
                     P := Make_Designator (U);
331 1
                     ADN.Set_Corresponding_Node
332 1
                       (ADN.Defining_Identifier (P),
333 1
                        New_Node (ADN.K_Package_Specification));
334 1
                     Add_With_Package (P);
335

336 1
                     N := Make_Designator (L);
337 1
                     Set_Homogeneous_Parent_Unit_Name (N, P);
338
                  else
339
                     --  Otherwise, simply refer to Standard package
340

341 0
                     N := Make_Designator (L);
342 0
                     Set_Homogeneous_Parent_Unit_Name (N, RU (RU_Standard));
343
                  end if;
344

345
                  N :=
346 1
                    Make_Full_Type_Declaration
347 1
                      (Defining_Identifier => Map_Ada_Defining_Identifier (E),
348
                       Type_Definition     =>
349 1
                         Make_Derived_Type_Definition (N, Is_Subtype => True),
350
                       Is_Subtype => True);
351
               end;
352
            else
353
               --  Otherwise, we extract from the Data_Model specific
354
               --  properties the exact nature of the type and
355
               --  generate its definition.
356

357 1
               Data_Representation := Get_Data_Representation (E);
358 1
               Data_Size           := Get_Data_Size (E);
359 1
               Actual_Data_Size    := To_Bytes (Data_Size);
360

361 1
               case Data_Representation is
362 1
                  when Data_Array =>
363 1
                     declare
364 1
                        Dimension : constant ULL_Array := Get_Dimension (E);
365 1
                        RC : constant List_Id   := New_List (ADN.K_List_Id);
366
                     begin
367 1
                        Visit
368 1
                          (ATN.Entity (ATN.First_Node (Get_Base_Type (E))));
369

370 1
                        for Index in Dimension'Range loop
371
                           N :=
372 1
                             Make_Range_Constraint
373 1
                               (Make_Literal (New_Integer_Value (1, 1, 10)),
374 1
                                Make_Literal
375 1
                                  (New_Integer_Value
376
                                     (Dimension (Index),
377
                                      1,
378
                                      10)),
379 1
                                RE (RE_Positive));
380 1
                           Append_Node_To_List (N, RC);
381 0
                        end loop;
382

383
                        N :=
384 1
                          Make_Full_Type_Declaration
385
                            (Defining_Identifier =>
386 1
                               Map_Ada_Defining_Identifier (E),
387
                             Type_Definition =>
388 1
                               Make_Array_Type_Definition
389
                                 (Range_Constraints    => RC,
390
                                  Component_Definition =>
391 1
                                    Map_Ada_Data_Type_Designator
392 1
                                      (ATN.Entity
393 1
                                         (ATN.First_Node
394 1
                                            (Get_Base_Type (E))))));
395 1
                     end;
396

397 1
                  when Data_Boolean =>
398
                     N :=
399 1
                       Make_Full_Type_Declaration
400
                         (Defining_Identifier =>
401 1
                            Map_Ada_Defining_Identifier (E),
402
                          Type_Definition =>
403 1
                            Make_Derived_Type_Definition (RE (RE_Boolean)));
404

405 0
                  when Data_Bounded_Array =>
406 0
                     raise Program_Error; --  XXX
407

408 0
                  when Data_Character =>
409
                     N :=
410 0
                       Make_Full_Type_Declaration
411
                         (Defining_Identifier =>
412 0
                            Map_Ada_Defining_Identifier (E),
413
                          Type_Definition =>
414 0
                            Make_Derived_Type_Definition (RE (RE_Character)));
415

416 0
                  when Data_Wide_Character =>
417
                     N :=
418 0
                       Make_Full_Type_Declaration
419
                         (Defining_Identifier =>
420 0
                            Map_Ada_Defining_Identifier (E),
421
                          Type_Definition =>
422 0
                            Make_Derived_Type_Definition
423 0
                              (RE (RE_Wide_Character)));
424

425 0
                  when Data_Enum =>
426 0
                     declare
427 0
                        Enumerators : constant Name_Array :=
428 0
                          Get_Enumerators (E);
429
                        Enumeration_List : constant List_Id :=
430 0
                          New_List (ADN.K_Enumeration_Literals);
431
                     begin
432 0
                        for J in Enumerators'Range loop
433 0
                           N := Make_Defining_Identifier (Enumerators (J));
434 0
                           Append_Node_To_List (N, Enumeration_List);
435 0
                        end loop;
436

437
                        N :=
438 0
                          Make_Full_Type_Declaration
439
                            (Defining_Identifier =>
440 0
                               Map_Ada_Defining_Identifier (E),
441
                             Type_Definition =>
442 0
                               Make_Enumeration_Type_Definition
443
                                 (Enumeration_List));
444 0
                     end;
445

446 0
                  when Data_Float =>
447
                     N :=
448 0
                       Make_Full_Type_Declaration
449
                         (Defining_Identifier =>
450 0
                            Map_Ada_Defining_Identifier (E),
451
                          Type_Definition =>
452 0
                            Make_Derived_Type_Definition (RE (RE_Long_Float)));
453

454 1
                  when Data_Fixed =>
455
                     declare
456
                        Data_Digits : constant Unsigned_Long_Long :=
457 1
                          Get_Data_Digits (E);
458
                        Data_Scale : constant Unsigned_Long_Long :=
459 1
                          Get_Data_Scale (E);
460
                     begin
461 1
                        if Data_Digits /= 0 and then Data_Scale /= 0 then
462 1
                           N :=
463 1
                             Make_Full_Type_Declaration
464
                               (Defining_Identifier =>
465 1
                                  Map_Ada_Defining_Identifier (E),
466
                                Type_Definition =>
467 1
                                  Make_Decimal_Type_Definition
468
                                    (Data_Digits,
469
                                     Data_Scale));
470

471
                        else
472 0
                           if Data_Digits = 0 then
473 0
                              Display_Located_Error
474 0
                                (Loc (E),
475
                                 "Missing digit number of fixed point type",
476
                                 Fatal => True);
477
                           end if;
478

479 0
                           if Data_Scale = 0 then
480 0
                              Display_Located_Error
481 0
                                (Loc (E),
482
                                 "Missing the scale of fixed point type!",
483
                                 Fatal => True);
484
                           end if;
485
                        end if;
486
                     end;
487

488 1
                  when Data_Integer =>
489 1
                     if Data_Size.S = 0 then
490
                        --  If no size info is given, we default to a
491
                        --  standard integer
492

493
                        N :=
494 1
                          Make_Full_Type_Declaration
495
                            (Defining_Identifier =>
496 1
                               Map_Ada_Defining_Identifier (E),
497
                             Type_Definition =>
498 1
                               Make_Derived_Type_Definition (RE (RE_Integer)));
499

500 1
                     elsif Actual_Data_Size = 1 and then Is_Signed then
501 0
                        N :=
502 0
                          Make_Full_Type_Declaration
503
                            (Defining_Identifier =>
504 0
                               Map_Ada_Defining_Identifier (E),
505
                             Type_Definition =>
506 0
                               Make_Derived_Type_Definition
507 0
                                 (RE (RE_Integer_8)));
508

509 1
                     elsif Actual_Data_Size = 1 and then not Is_Signed then
510 0
                        N :=
511 0
                          Make_Full_Type_Declaration
512
                            (Defining_Identifier =>
513 0
                               Map_Ada_Defining_Identifier (E),
514
                             Type_Definition =>
515 0
                               Make_Derived_Type_Definition
516 0
                                 (RE (RE_Unsigned_8)));
517

518 1
                     elsif Actual_Data_Size = 2 and then Is_Signed then
519 0
                        N :=
520 0
                          Make_Full_Type_Declaration
521
                            (Defining_Identifier =>
522 0
                               Map_Ada_Defining_Identifier (E),
523
                             Type_Definition =>
524 0
                               Make_Derived_Type_Definition
525 0
                                 (RE (RE_Integer_16)));
526

527 1
                     elsif Actual_Data_Size = 2 and then not Is_Signed then
528 0
                        N :=
529 0
                          Make_Full_Type_Declaration
530
                            (Defining_Identifier =>
531 0
                               Map_Ada_Defining_Identifier (E),
532
                             Type_Definition =>
533 0
                               Make_Derived_Type_Definition
534 0
                                 (RE (RE_Unsigned_16)));
535

536 1
                     elsif Actual_Data_Size = 4 and then Is_Signed then
537 1
                        N :=
538 1
                          Make_Full_Type_Declaration
539
                            (Defining_Identifier =>
540 1
                               Map_Ada_Defining_Identifier (E),
541
                             Type_Definition =>
542 1
                               Make_Derived_Type_Definition
543 1
                                 (RE (RE_Integer_32)));
544

545 0
                     elsif Actual_Data_Size = 4 and then not Is_Signed then
546 0
                        N :=
547 0
                          Make_Full_Type_Declaration
548
                            (Defining_Identifier =>
549 0
                               Map_Ada_Defining_Identifier (E),
550
                             Type_Definition =>
551 0
                               Make_Derived_Type_Definition
552 0
                                 (RE (RE_Unsigned_32)));
553

554 0
                     elsif Actual_Data_Size = 8 and then Is_Signed then
555 0
                        N :=
556 0
                          Make_Full_Type_Declaration
557
                            (Defining_Identifier =>
558 0
                               Map_Ada_Defining_Identifier (E),
559
                             Type_Definition =>
560 0
                               Make_Derived_Type_Definition
561 0
                                 (RE (RE_Integer_64)));
562

563 0
                     elsif Actual_Data_Size = 8 and then not Is_Signed then
564 0
                        N :=
565 0
                          Make_Full_Type_Declaration
566
                            (Defining_Identifier =>
567 0
                               Map_Ada_Defining_Identifier (E),
568
                             Type_Definition =>
569 0
                               Make_Derived_Type_Definition
570 0
                                 (RE (RE_Unsigned_64)));
571

572
                     else
573 0
                        Display_Located_Error
574 0
                          (Loc (E),
575 0
                           "Unsupported data size" & Actual_Data_Size'Img,
576
                           Fatal => True);
577
                     end if;
578

579 1
                  when Data_String =>
580 1
                     declare
581 1
                        Dimension : constant ULL_Array := Get_Dimension (E);
582
                     begin
583
                        N :=
584 1
                          Make_Package_Instantiation
585
                            (Defining_Identifier =>
586 1
                               Map_Ada_Package_Identifier (E),
587
                             Generic_Package =>
588 1
                               RU
589
                               (RU_Ada_Strings_Bounded_Generic_Bounded_Length),
590
                             Parameter_List =>
591 1
                               Make_List_Id
592 1
                                 (Make_Literal
593 1
                                    (New_Integer_Value
594 1
                                       (Dimension (Dimension'First),
595
                                        1,
596
                                        10))));
597 1
                        Append_Node_To_List
598
                          (N,
599 1
                           ADN.Visible_Part (Current_Package));
600

601
                        N :=
602 1
                          Make_Full_Type_Declaration
603
                            (Defining_Identifier =>
604 1
                               Map_Ada_Defining_Identifier (E),
605
                             Is_Subtype      => True,
606
                             Type_Definition =>
607 1
                               Make_Derived_Type_Definition
608 1
                                 (Make_Selected_Component
609 1
                                    (Map_Ada_Package_Identifier (E),
610 1
                                     Make_Defining_Identifier
611
                                       (TN (T_Bounded_String))),
612
                                  Is_Subtype => True));
613 1
                     end;
614

615 0
                  when Data_Wide_String =>
616 0
                     declare
617 0
                        Dimension : constant ULL_Array := Get_Dimension (E);
618 0
                        RU_Wi_Str : constant RU_Id     :=
619
                          RU_Ada_Strings_Wide_Bounded_Generic_Bounded_Length;
620
                     begin
621
                        N :=
622 0
                          Make_Package_Instantiation
623
                            (Defining_Identifier =>
624 0
                               Map_Ada_Package_Identifier (E),
625 0
                             Generic_Package => RU (RU_Wi_Str),
626
                             Parameter_List  =>
627 0
                               Make_List_Id
628 0
                                 (Make_Literal
629 0
                                    (New_Integer_Value
630 0
                                       (Dimension (Dimension'First),
631
                                        1,
632
                                        10))));
633 0
                        Append_Node_To_List
634
                          (N,
635 0
                           ADN.Visible_Part (Current_Package));
636

637
                        N :=
638 0
                          Make_Full_Type_Declaration
639
                            (Defining_Identifier =>
640 0
                               Map_Ada_Defining_Identifier (E),
641
                             Is_Subtype      => True,
642
                             Type_Definition =>
643 0
                               Make_Derived_Type_Definition
644 0
                                 (Make_Selected_Component
645 0
                                    (Map_Ada_Package_Identifier (E),
646 0
                                     Make_Defining_Identifier
647
                                       (TN (T_Bounded_Wide_String))),
648
                                  Is_Subtype => True));
649 0
                     end;
650

651 1
                  when Data_Struct | Data_With_Accessors =>
652
                     declare
653
                        Components : constant List_Id :=
654 1
                          New_List (ADN.K_Component_List);
655 1
                        C         : Node_Id := First_Node (Subcomponents (E));
656 1
                        Visible_P : List_Id;
657 1
                        Private_P : List_Id;
658 1
                        I         : Unsigned_Long_Long;
659 1
                        O         : Node_Id;
660
                     begin
661
                        --  Build the component list
662

663 1
                        while Present (C) loop
664
                           --  Generate the Ada type corresponding to the
665
                           --  subcomponent.
666

667 1
                           Visit (Corresponding_Instance (C));
668

669
                           --  Make the record or private type component
670

671 1
                           if AAU.Is_Data (Corresponding_Instance (C)) then
672
                              N :=
673 1
                                Make_Component_Declaration
674
                                  (Defining_Identifier =>
675 1
                                     Map_Ada_Defining_Identifier (C),
676
                                   Subtype_Indication =>
677 1
                                     Map_Ada_Data_Type_Designator
678 1
                                       (Corresponding_Instance (C)));
679 1
                              Append_Node_To_List (N, Components);
680
                           end if;
681

682 1
                           C := Next_Node (C);
683 1
                        end loop;
684

685 1
                        if Data_Representation = Data_Struct then
686
                           --  Record type
687

688
                           N :=
689 1
                             Make_Full_Type_Declaration
690
                               (Defining_Identifier =>
691 1
                                  Map_Ada_Defining_Identifier (E),
692
                                Type_Definition =>
693 1
                                  Make_Record_Type_Definition
694 1
                                    (Make_Record_Definition (Components)));
695
                        else
696
                           --  Protected type
697

698
                           declare
699 1
                              CCP : Supported_Concurrency_Control_Protocol;
700
                           begin
701
                              --  Per the Ravenscar profile, all
702
                              --  protected objects are supposed to be
703
                              --  PCP, ensure this is true also for
704
                              --  the AADL model.
705

706 1
                              CCP := Get_Concurrency_Protocol (E);
707 1
                              if CCP /= Priority_Ceiling then
708 0
                                 Display_Located_Error
709 0
                                   (Loc (E),
710
                                    "Incompatible concurrency protocol, " &
711
                                    "PolyORB-HI/Ada requires " &
712
                                    "Priority_Ceiling",
713
                                    True);
714
                              end if;
715
                           end;
716

717 1
                           Visible_P := New_List (ADN.K_Declaration_List);
718 1
                           Private_P := Components;
719

720 1
                           S := First_Node (Features (E));
721

722 1
                           while Present (S) loop
723
                              --  We are sure that S is of kind
724
                              --  K_Subprogram_Spec_Instance. Otherwise,
725
                              --  an error whould be raised when trying
726
                              --  to find the data type.
727

728
                              --  Build a subprogram spec and append it
729
                              --  to the visible part of the protected
730
                              --  type.
731

732 1
                              N := Feature_Spg_Spec (S);
733 1
                              Bind_AADL_To_Feature_Subprogram
734 1
                                (Identifier (S),
735
                                 N);
736 1
                              Append_Node_To_List (N, Visible_P);
737

738 1
                              S := Next_Node (S);
739 1
                           end loop;
740

741
                           --  Build the private type spec
742

743
                           N :=
744 1
                             Make_Protected_Object_Spec
745
                               (Defining_Identifier =>
746 1
                                  Map_Ada_Defining_Identifier (E),
747
                                Visible_Part => Visible_P,
748
                                Private_Part => Private_P,
749
                                Is_Type      => True);
750

751 1
                           I := Get_Priority_Celing_Of_Data_Access (E);
752

753 1
                           if I /= 0 then
754
                              --  The data component defines a priority,
755
                              --  use it for the ceiling priority of the
756
                              --  protected object.
757

758
                              O :=
759 1
                                Make_Pragma_Statement
760
                                  (Pragma_Priority,
761 1
                                   Make_List_Id (Map_Ada_Priority (I)));
762 1
                              Append_Node_To_List (O, ADN.Private_Part (N));
763

764
                           else
765
                              --  The data component defines no priority,
766
                              --  use System.Priority'Last for the
767
                              --  ceiling priority of the protected
768
                              --  object.
769

770 1
                              Display_Located_Error
771 1
                                (Loc (E),
772
                                 "No  priority defined, will use" &
773
                                 " default value: System.Priority'Last",
774
                                 False,
775
                                 True);
776

777
                              O :=
778 1
                                Make_Pragma_Statement
779
                                  (Pragma_Priority,
780 1
                                   Make_List_Id
781 1
                                     (Make_Attribute_Designator
782 1
                                        (RE (RE_Priority),
783
                                         A_Last)));
784 1
                              Append_Node_To_List (O, ADN.Private_Part (N));
785
                           end if;
786
                        end if;
787
                     end;
788

789 0
                  when Data_Union =>
790 0
                     Display_Located_Error
791 0
                       (Loc (E),
792
                        "unsupported data type (" &
793
                        Supported_Data_Representation'Image
794
                          (Data_Representation) &
795
                        ")",
796
                        Fatal => True);
797

798 0
                  when Data_None =>
799 0
                     Display_Located_Error
800 0
                       (Loc (E),
801
                        "unspecified data representation",
802
                        Fatal => True);
803 1
               end case;
804
            end if;
805

806
            --  Mark the data type as being handled and append it to
807
            --  the handled list.
808

809 1
            Set_Handling (E, By_Name, H_Ada_Type_Spec, N);
810

811
            --  In the case of a data type with accessor, visit the
812
            --  parameters of its features subprograms. It is
813
            --  important to do this *after* marking the type as
814
            --  handled, to avoid endless loops and *before* adding
815
            --  the type declaration to the package statements because
816
            --  the declaration order of type is important in Ada.
817

818 1
            if Data_Representation = Data_With_Accessors then
819 1
               S := First_Node (Features (E));
820

821 1
               while Present (S) loop
822 1
                  Visit (Corresponding_Instance (S));
823

824 1
                  S := Next_Node (S);
825 1
               end loop;
826
            end if;
827

828
            --  Append the type declaration to the package spec
829

830 1
            if Language_Type /= Language_ASN1 then
831 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
832
            end if;
833

834
            --  If the user specified a data size in the AADL model,
835
            --  generate a corresponding Ada clause.
836

837 1
            if Get_Data_Size (E) /= Null_Size then
838
               N :=
839 1
                 Make_Attribute_Definition_Clause
840 1
                   (Map_Ada_Defining_Identifier (E),
841
                    A_Size,
842 1
                    Make_Literal
843 1
                      (New_Integer_Value
844 1
                         (To_Bits (Get_Data_Size (E)),
845
                          1,
846
                          10)));
847 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
848
            end if;
849

850 1
            if Get_Data_Representation (E) /= Data_With_Accessors then
851
               declare
852 1
                  Data_Size : Unsigned_Long_Long;
853
               begin
854 1
                  if Get_Data_Size (E) /= Null_Size then
855 1
                     Data_Size := To_Bits (Get_Data_Size (E));
856
                  else
857 1
                     Data_Size := Estimate_Data_Size (E);
858
                  end if;
859

860
                  --  A documentary comment for the data size
861

862 1
                  N :=
863 1
                    Message_Comment
864 1
                      (Get_Name_String
865 1
                         (To_Ada_Name (AIN.Name (Identifier (E)))) &
866
                       "'Object_Size ~=" &
867 1
                       Unsigned_Long_Long'Image (Data_Size) &
868
                       " bits");
869 1
                  Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
870 1
               end;
871
            end if;
872

873 1
            if Get_Data_Representation (E) = Data_Struct then
874
               N :=
875 1
                 Make_Attribute_Definition_Clause
876 1
                   (Map_Ada_Defining_Identifier (E),
877
                    Attribute_Designator => A_Alignment,
878 1
                    Expression => Make_Literal (New_Integer_Value (8, 1, 10)));
879 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
880
            end if;
881

882
            --  Array types have also a subprogram 'Length' which is
883
            --  generated for use in other languages in which arrays
884
            --  are not aware of their lengths (such as C).
885

886 1
            if Get_Data_Representation (E) = Data_Array then
887 1
               N := Length_Spec (E);
888 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
889

890
               --  Add a pragma Export for 'Length' in order for it to
891
               --  be seen by C code.
892

893 1
               N := Pragma_Export_Length (E);
894 1
               Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
895
            end if;
896
         end if;
897

898
         --  Bind the type to its mapping
899

900 1
         Bind_AADL_To_Type_Definition
901 1
           (Identifier (E),
902 1
            Get_Handling (E, By_Name, H_Ada_Type_Spec));
903

904
         --  Declare the "default value" of a type.
905

906
         --  Note: If a default value can be computed, then this value
907
         --  is declared as a 'constant' so that the user cannot
908
         --  modify it.
909

910 1
         if No (Get_Handling (E, By_Name, H_Ada_Type_Default_Value)) then
911 1
               Data_Representation := Get_Data_Representation (E);
912

913
               --  We generate default values for all types except
914
               --  protected types.
915

916 1
               if Data_Representation /= Data_With_Accessors then
917
                  declare
918
                     Default_Value : constant Node_Id :=
919 1
                       Get_Ada_Default_Value (E);
920
                  begin
921
                     N :=
922 1
                       Make_Object_Declaration
923
                       (Defining_Identifier =>
924 1
                          Map_Ada_Default_Value_Identifier (E),
925 1
                        Constant_Present  => Present (Default_Value),
926 1
                        Object_Definition => Map_Ada_Defining_Identifier (E),
927
                        Expression        => Default_Value);
928

929 1
                     Set_Handling (E, By_Name, H_Ada_Type_Default_Value, N);
930 1
                     Append_Node_To_List
931 1
                       (N, ADN.Visible_Part (Current_Package));
932
                  end;
933
               else
934 1
                  N := No_Node;
935
               end if;
936
         end if;
937

938
         --  Bind the type to its default value if a default value has
939
         --  been generated.
940

941 1
         if Present (N) then
942 1
            Bind_AADL_To_Default_Value
943 1
              (Identifier (E),
944 1
               Get_Handling (E, By_Name, H_Ada_Type_Default_Value));
945
         end if;
946 1
      end Visit_Data_Instance;
947

948
      ----------------------------
949
      -- Visit_Process_Instance --
950
      ----------------------------
951

952 1
      procedure Visit_Process_Instance (E : Node_Id) is
953
         U : constant Node_Id :=
954 1
           ADN.Distributed_Application_Unit
955 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
956 1
         P : constant Node_Id := ADN.Entity (U);
957
      begin
958 1
         Push_Entity (P);
959 1
         Push_Entity (U);
960 1
         Set_Types_Spec;
961

962
         --  Start recording the handling since they have to be reset
963
         --  for each node.
964

965 1
         Start_Recording_Handlings;
966

967
         --  Visit all the subcomponents of the process
968

969 1
         Visit_Subcomponents_Of (E);
970

971
         --  Unmark all the marked types
972

973 1
         Reset_Handlings;
974

975 1
         Pop_Entity; -- U
976 1
         Pop_Entity; -- P
977 1
      end Visit_Process_Instance;
978

979
      -------------------------------
980
      -- Visit_Subprogram_Instance --
981
      -------------------------------
982

983 1
      procedure Visit_Subprogram_Instance (E : Node_Id) is
984 1
         Call_Seq : Node_Id;
985 1
         Spg_Call : Node_Id;
986 1
         F        : Node_Id;
987
      begin
988
         --  Declare all necessary data types
989

990 1
         if not AAU.Is_Empty (Features (E)) then
991 1
            F := First_Node (Features (E));
992

993 1
            while Present (F) loop
994 1
               if Present (Corresponding_Instance (F)) then
995 1
                  Visit (Corresponding_Instance (F));
996
               end if;
997

998 1
               F := Next_Node (F);
999 1
            end loop;
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
         F        : Node_Id;
1049
      begin
1050
         --  Declare all necessary data types. We cannot rely only on
1051
         --  subprogram calls to generate necessary data type becaus
1052
         --  threads may not contain subprogram calls.
1053

1054 1
         if not AAU.Is_Empty (Features (E)) then
1055 1
            F := First_Node (Features (E));
1056

1057 1
            while Present (F) loop
1058 1
               if Kind (F) = K_Port_Spec_Instance and then AIN.Is_Data (F) then
1059 1
                  Visit (Corresponding_Instance (F));
1060
               end if;
1061

1062 1
               F := Next_Node (F);
1063 1
            end loop;
1064
         end if;
1065

1066
         --  Visit all the call sequences of the thread
1067

1068 1
         if not AAU.Is_Empty (Calls (E)) then
1069 1
            Call_Seq := First_Node (Calls (E));
1070

1071 1
            while Present (Call_Seq) loop
1072
               --  For each call sequence visit all the called
1073
               --  subprograms.
1074

1075 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
1076 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
1077

1078 1
                  while Present (Spg_Call) loop
1079 1
                     Visit (Corresponding_Instance (Spg_Call));
1080

1081 1
                     Spg_Call := Next_Node (Spg_Call);
1082 1
                  end loop;
1083
               end if;
1084

1085 1
               Call_Seq := Next_Node (Call_Seq);
1086 1
            end loop;
1087
         end if;
1088 1
      end Visit_Thread_Instance;
1089

1090
   end Package_Spec;
1091

1092
   ------------------
1093
   -- Package_Body --
1094
   ------------------
1095

1096
   package body Package_Body is
1097

1098
      procedure Visit_Architecture_Instance (E : Node_Id);
1099
      procedure Visit_Component_Instance (E : Node_Id);
1100
      procedure Visit_System_Instance (E : Node_Id);
1101
      procedure Visit_Process_Instance (E : Node_Id);
1102
      procedure Visit_Thread_Instance (E : Node_Id);
1103
      procedure Visit_Subprogram_Instance (E : Node_Id);
1104
      procedure Visit_Data_Instance (E : Node_Id);
1105
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
1106

1107
      function Feature_Spg_Body (E : Node_Id; Data : Node_Id) return Node_Id;
1108
      --  Builds a body for a protected object procedure from an AADL
1109
      --  subprogram spec E.
1110

1111
      function Length_Body (E : Node_Id) return Node_Id;
1112
      --  Body of the 'Length' function associated to array type E
1113

1114
      ----------------------
1115
      -- Feature_Spg_Body --
1116
      ----------------------
1117

1118 1
      function Feature_Spg_Body (E : Node_Id; Data : Node_Id) return Node_Id is
1119 1
         N            : Node_Id;
1120 1
         Call_Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
1121 1
         Param        : Node_Id;
1122 1
         C_Access     : Node_Id;
1123 1
         D            : Node_Id;
1124 1
         Statements   : constant List_Id := New_List (ADN.K_Statement_List);
1125 1
         Spg          : Node_Id;
1126
      begin
1127
         pragma Assert
1128 1
           (Kind (E) = K_Subprogram_Spec_Instance
1129 1
            or else Kind (E) = K_Subcomponent_Access_Instance);
1130

1131 1
         Spg := Corresponding_Instance (E);
1132

1133 1
         pragma Assert (AAU.Is_Subprogram (Spg));
1134

1135
         --  The body of a subprogram contained in a protected type
1136
         --  contains simply a call to the user implementation of the
1137
         --  corresponding AADL subprogram.
1138

1139
         --  Since the subprogram has Data Access to its containing
1140
         --  data component. It gives all the protected fields of the
1141
         --  protected type as IN, OUT or IN OUT (depending on the
1142
         --  data access property) parameters to the subprogram
1143
         --  implementation call. Therefore the parameters for the
1144
         --  subprogram implementation call are:
1145

1146
         --  1 - The list of the AADL subprogram parameters:
1147

1148 1
         if not AAU.Is_Empty (Features (Spg)) then
1149 1
            Param := First_Node (Features (Spg));
1150

1151 1
            while Present (Param) loop
1152 1
               if Kind (Param) = K_Parameter_Instance then
1153
                  --  Create a parameter association
1154

1155
                  N :=
1156 1
                    Make_Parameter_Association
1157 1
                      (Selector_Name    => Map_Ada_Defining_Identifier (Param),
1158
                       Actual_Parameter =>
1159 1
                         Map_Ada_Defining_Identifier (Param));
1160 1
                  Append_Node_To_List (N, Call_Profile);
1161
               end if;
1162

1163 1
               Param := Next_Node (Param);
1164 1
            end loop;
1165
         end if;
1166

1167
         --  2 - The list of all record fields given
1168

1169
         --  FIXME: Respect the mapping rules by setting the correct
1170
         --  parameter orientation. For now all parameter are
1171
         --  considered IN OUT. Provide all necessary routines
1172
         --  (passing through intermediate variables, to prevent the
1173
         --  user from cheating).
1174

1175 1
         if not AAU.Is_Empty (Features (Spg))
1176 1
           and then not Is_Priority_Shifter (Data)
1177
         then
1178

1179 1
            C_Access := First_Node (Features (Spg));
1180

1181 1
            while Present (C_Access) loop
1182 1
               if Kind (C_Access) = K_Subcomponent_Access_Instance then
1183 1
                  D := Corresponding_Instance (C_Access);
1184

1185 1
                  if not AAU.Is_Empty (Subcomponents (D)) then
1186 1
                     Param := First_Node (Subcomponents (D));
1187

1188 1
                     while Present (Param) loop
1189
                        --  Create a parameter association
1190

1191 1
                        if AAU.Is_Data (Corresponding_Instance (Param)) then
1192
                           N :=
1193 1
                             Make_Parameter_Association
1194
                               (Selector_Name =>
1195 1
                                  Map_Ada_Protected_Aggregate_Identifier
1196
                                    (C_Access,
1197
                                     Param),
1198
                                Actual_Parameter =>
1199 1
                                  Map_Ada_Defining_Identifier (Param));
1200

1201 1
                           Append_Node_To_List (N, Call_Profile);
1202
                        end if;
1203

1204 1
                        Param := Next_Node (Param);
1205 1
                     end loop;
1206
                  end if;
1207
               end if;
1208

1209 1
               C_Access := Next_Node (C_Access);
1210 1
            end loop;
1211
         end if;
1212

1213
         --  Call the implementation subprogram with the built profile
1214

1215
         N :=
1216 1
           Make_Subprogram_Call
1217 1
             (Extract_Designator
1218 1
                (ADN.Subprogram_Node
1219 1
                   (Backend_Node (Identifier (Corresponding_Instance (E))))),
1220
              Call_Profile);
1221 1
         Append_Node_To_List (N, Statements);
1222

1223
         --  Build the subprogram implementation
1224

1225
         N :=
1226 1
           Make_Subprogram_Implementation
1227 1
             (ADN.Feature_Subprogram_Node (Backend_Node (Identifier (E))),
1228
              No_List,
1229
              Statements);
1230

1231 1
         return N;
1232
      end Feature_Spg_Body;
1233

1234
      -----------------
1235
      -- Length_Body --
1236
      -----------------
1237

1238 1
      function Length_Body (E : Node_Id) return Node_Id is
1239 1
         N : Node_Id;
1240
      begin
1241
         N :=
1242 1
           Make_Subprogram_Implementation
1243 1
             (Length_Spec (E),
1244
              No_List,
1245 1
              Make_List_Id
1246 1
                (Make_Return_Statement
1247 1
                   (Make_Attribute_Designator
1248 1
                      (Make_Defining_Identifier (PN (P_A)),
1249
                       A_Length))));
1250

1251 1
         return N;
1252
      end Length_Body;
1253

1254
      -----------
1255
      -- Visit --
1256
      -----------
1257

1258 1
      procedure Visit (E : Node_Id) is
1259
      begin
1260 1
         case Kind (E) is
1261 1
            when K_Architecture_Instance =>
1262 1
               Visit_Architecture_Instance (E);
1263

1264 1
            when K_Component_Instance =>
1265 1
               Visit_Component_Instance (E);
1266

1267 0
            when others =>
1268 0
               null;
1269 1
         end case;
1270 1
      end Visit;
1271

1272
      ---------------------------------
1273
      -- Visit_Architecture_Instance --
1274
      ---------------------------------
1275

1276 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
1277
      begin
1278 1
         Visit (Root_System (E));
1279 1
      end Visit_Architecture_Instance;
1280

1281
      ------------------------------
1282
      -- Visit_Component_Instance --
1283
      ------------------------------
1284

1285 1
      procedure Visit_Component_Instance (E : Node_Id) is
1286
         Category : constant Component_Category :=
1287 1
           Get_Category_Of_Component (E);
1288
      begin
1289 1
         case Category is
1290 1
            when CC_System =>
1291 1
               Visit_System_Instance (E);
1292

1293 1
            when CC_Process =>
1294 1
               Visit_Process_Instance (E);
1295

1296 1
            when CC_Thread =>
1297 1
               Visit_Thread_Instance (E);
1298

1299 1
            when CC_Data =>
1300 1
               Visit_Data_Instance (E);
1301

1302 1
            when CC_Subprogram =>
1303 1
               Visit_Subprogram_Instance (E);
1304

1305 1
            when others =>
1306 1
               null;
1307 1
         end case;
1308 1
      end Visit_Component_Instance;
1309

1310
      -------------------------
1311
      -- Visit_Data_Instance --
1312
      -------------------------
1313

1314 1
      procedure Visit_Data_Instance (E : Node_Id) is
1315 1
         Data_Representation : Supported_Data_Representation;
1316 1
         N                   : Node_Id;
1317
      begin
1318
         --  Do not generate Ada type more than once
1319

1320 1
         if No (Get_Handling (E, By_Name, H_Ada_Type_Body)) then
1321

1322
            --  Add a fake handling for now, to avoid infinite recursion
1323 1
            Set_Handling (E, By_Name, H_Ada_Type_Body, No_Node + 1);
1324

1325 1
            Data_Representation := Get_Data_Representation (E);
1326

1327 1
            case Data_Representation is
1328 1
               when Data_Array =>
1329 1
                  N := Length_Body (E);
1330

1331
                  --  Append the type declaration to the package body
1332

1333 1
                  Append_Node_To_List (N, ADN.Statements (Current_Package));
1334

1335
                  --  Mark the data type as being handled
1336

1337 1
                  Set_Handling (E, By_Name, H_Ada_Type_Body, N);
1338

1339 1
               when Data_With_Accessors =>
1340
                  declare
1341
                     Statements : constant List_Id :=
1342 1
                       New_List (ADN.K_Statement_List);
1343 1
                     C : Node_Id := First_Node (Subcomponents (E));
1344 1
                     S : Node_Id;
1345
                  begin
1346
                     --  Visit the subcomponents
1347

1348 1
                     while Present (C) loop
1349 1
                        Visit (Corresponding_Instance (C));
1350 1
                        C := Next_Node (C);
1351 1
                     end loop;
1352

1353
                     --  Protected type
1354

1355 1
                     S := First_Node (Features (E));
1356

1357 1
                     while Present (S) loop
1358
                        --  Build a subprogram spec and append it to
1359
                        --  the visible part of the protected type.
1360

1361 1
                        N := Feature_Spg_Body (S, E);
1362 1
                        Append_Node_To_List (N, Statements);
1363

1364 1
                        S := Next_Node (S);
1365 1
                     end loop;
1366

1367
                     --  Build the private type body
1368

1369
                     N :=
1370 1
                       Make_Protected_Object_Body
1371
                         (Defining_Identifier =>
1372 1
                            Map_Ada_Defining_Identifier (E),
1373
                          Statements => Statements);
1374

1375
                     --  Append the type declaration to the package body
1376

1377 1
                     Append_Node_To_List (N, ADN.Statements (Current_Package));
1378

1379
                     --  Mark the data type as being handled
1380

1381 1
                     Set_Handling (E, By_Name, H_Ada_Type_Body, N);
1382
                  end;
1383

1384 1
               when Data_Struct =>
1385
                  declare
1386 1
                     C : Node_Id := First_Node (Subcomponents (E));
1387
                  begin
1388
                     --  Visit the subcomponents
1389

1390 1
                     while Present (C) loop
1391 1
                        Visit (Corresponding_Instance (C));
1392 1
                        C := Next_Node (C);
1393 1
                     end loop;
1394
                  end;
1395

1396 1
               when others =>
1397 1
                  null;
1398 1
            end case;
1399
         end if;
1400 1
      end Visit_Data_Instance;
1401

1402
      ----------------------------
1403
      -- Visit_Process_Instance --
1404
      ----------------------------
1405

1406 1
      procedure Visit_Process_Instance (E : Node_Id) is
1407
         U : constant Node_Id :=
1408 1
           ADN.Distributed_Application_Unit
1409 1
             (ADN.Deployment_Node (Backend_Node (Identifier (E))));
1410 1
         P : constant Node_Id := ADN.Entity (U);
1411
      begin
1412 1
         Push_Entity (P);
1413 1
         Push_Entity (U);
1414 1
         Set_Types_Body;
1415

1416
         --  Start recording the handling since they have to be reset
1417
         --  for each node.
1418

1419 1
         Start_Recording_Handlings;
1420

1421
         --  Visit all the subcomponents of the process
1422

1423 1
         Visit_Subcomponents_Of (E);
1424

1425
         --  Unmark all the marked types
1426

1427 1
         Reset_Handlings;
1428

1429 1
         Pop_Entity; -- U
1430 1
         Pop_Entity; -- P
1431 1
      end Visit_Process_Instance;
1432

1433
      -------------------------------
1434
      -- Visit_Subprogram_Instance --
1435
      -------------------------------
1436

1437 1
      procedure Visit_Subprogram_Instance (E : Node_Id) is
1438 1
         Call_Seq : Node_Id;
1439 1
         Spg_Call : Node_Id;
1440 1
         F        : Node_Id;
1441
      begin
1442
         --  Declare all necessary data types
1443

1444 1
         if not AAU.Is_Empty (Features (E)) then
1445 1
            F := First_Node (Features (E));
1446

1447 1
            while Present (F) loop
1448 1
               if Present (Corresponding_Instance (F)) then
1449 1
                  Visit (Corresponding_Instance (F));
1450
               end if;
1451

1452 1
               F := Next_Node (F);
1453 1
            end loop;
1454
         end if;
1455

1456
         --  Visit all the call sequences of the subprogram
1457

1458 1
         if not AAU.Is_Empty (Calls (E)) then
1459 1
            Call_Seq := First_Node (Calls (E));
1460

1461 1
            while Present (Call_Seq) loop
1462
               --  For each call sequence visit all the called
1463
               --  subprograms.
1464

1465 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
1466 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
1467

1468 1
                  while Present (Spg_Call) loop
1469 1
                     Visit (Corresponding_Instance (Spg_Call));
1470

1471 1
                     Spg_Call := Next_Node (Spg_Call);
1472 1
                  end loop;
1473
               end if;
1474

1475 1
               Call_Seq := Next_Node (Call_Seq);
1476 1
            end loop;
1477
         end if;
1478 1
      end Visit_Subprogram_Instance;
1479

1480
      ---------------------------
1481
      -- Visit_System_Instance --
1482
      ---------------------------
1483

1484 1
      procedure Visit_System_Instance (E : Node_Id) is
1485
      begin
1486 1
         Push_Entity (Ada_Root);
1487

1488
         --  Visit all the subcomponents of the system
1489

1490 1
         Visit_Subcomponents_Of (E);
1491

1492 1
         Pop_Entity; --  Ada_Root
1493 1
      end Visit_System_Instance;
1494

1495
      ---------------------------
1496
      -- Visit_Thread_Instance --
1497
      ---------------------------
1498

1499 1
      procedure Visit_Thread_Instance (E : Node_Id) is
1500 1
         Call_Seq : Node_Id;
1501 1
         Spg_Call : Node_Id;
1502 1
         F        : Node_Id;
1503
      begin
1504
         --  Declare all necessary data types.
1505

1506 1
         if not AAU.Is_Empty (Features (E)) then
1507 1
            F := First_Node (Features (E));
1508

1509 1
            while Present (F) loop
1510 1
               if Kind (F) = K_Port_Spec_Instance and then AIN.Is_Data (F) then
1511 1
                  Visit (Corresponding_Instance (F));
1512
               end if;
1513

1514 1
               F := Next_Node (F);
1515 1
            end loop;
1516
         end if;
1517

1518
         --  Visit all the call sequences of the thread
1519

1520 1
         if not AAU.Is_Empty (Calls (E)) then
1521 1
            Call_Seq := First_Node (Calls (E));
1522

1523 1
            while Present (Call_Seq) loop
1524
               --  For each call sequence visit all the called
1525
               --  subprograms.
1526

1527 1
               if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
1528 1
                  Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
1529

1530 1
                  while Present (Spg_Call) loop
1531 1
                     Visit (Corresponding_Instance (Spg_Call));
1532

1533 1
                     Spg_Call := Next_Node (Spg_Call);
1534 1
                  end loop;
1535
               end if;
1536

1537 1
               Call_Seq := Next_Node (Call_Seq);
1538 1
            end loop;
1539
         end if;
1540 1
      end Visit_Thread_Instance;
1541

1542
   end Package_Body;
1543

1544
end Ocarina.Backends.PO_HI_Ada.Types;

Read our documentation on viewing source code .

Loading