1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--     O C A R I N A . B A C K E N D S . A D A _ T R E E . N U T I L 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 GNAT.Table;
34
with GNAT.Case_Util;
35

36
with Charset;        use Charset;
37
with Locations;      use Locations;
38
with Ocarina.Namet;  use Ocarina.Namet;
39
with Ocarina.Output; use Ocarina.Output;
40
with Ocarina.Types;  use Ocarina.Types;
41
with Utils;          use Utils;
42

43
with Ocarina.Backends.Ada_Values; use Ocarina.Backends.Ada_Values;
44
with Ocarina.Backends.Utils;      use Ocarina.Backends.Utils;
45
with Ocarina.Backends.Messages;   use Ocarina.Backends.Messages;
46

47
with Ocarina.ME_AADL.AADL_Tree.Nodes;
48

49 1
package body Ocarina.Backends.Ada_Tree.Nutils is
50

51
   package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
52
   package AAN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
53

54
   Var_Suffix  : constant String := "_Ü";
55
   Initialized : Boolean         := False;
56

57
   Keyword_Suffix : constant String := "%Ada";
58
   --  Used to mark Ada keywords and avoid collision with other
59
   --  languages
60

61
   type Entity_Stack_Entry is record
62
      Current_Package : Node_Id;
63
      Current_Entity  : Node_Id;
64
   end record;
65

66
   No_Depth : constant Int := -1;
67
   package Entity_Stack is new GNAT.Table
68
     (Entity_Stack_Entry,
69
      Int,
70
      No_Depth + 1,
71
      10,
72
      10);
73

74
   use Entity_Stack;
75

76
   function Create_Unique_Identifier
77
     (Name   : Name_Id;
78
      Suffix : String := "") return Name_Id;
79
   --  This function returns a unique identifier for Name with a UT_ prefix,
80
   --  followed by the name of the node, name of the package, Name
81
   --  and Suffix if exists.
82

83
   function Get_Style_State return Value_Id;
84
   --  This function returns a string literal which is the value given
85
   --  to the pragma style_checks. The 'Off' value is does not ignore
86
   --  line length.
87

88
   procedure New_Operator (O : Operator_Type; I : String := "");
89

90
   ----------------------
91
   -- Add_With_Package --
92
   ----------------------
93

94 1
   procedure Add_With_Package
95
     (E            : Node_Id;
96
      Used         : Boolean := False;
97
      Warnings_Off : Boolean := False;
98
      Elaborated   : Boolean := False)
99
   is
100

101
      function To_Library_Unit (E : Node_Id) return Node_Id;
102
      --  Return the library unit which E belongs to in order to with
103
      --  it. As a special rule, package Standard returns No_Node.
104

105
      ---------------------
106
      -- To_Library_Unit --
107
      ---------------------
108

109 1
      function To_Library_Unit (E : Node_Id) return Node_Id is
110 1
         U : Node_Id;
111

112
      begin
113
         pragma Assert (Kind (E) = K_Designator);
114 1
         U := Corresponding_Node (Defining_Identifier (E));
115

116
         --  This node is not properly built as the corresponding node
117
         --  is not set.
118

119 1
         if No (U) then
120 1
            if Output_Tree_Warnings then
121 0
               Write_Str ("WARNING: node ");
122 0
               Write_Name (Name (Defining_Identifier (E)));
123 0
               Write_Line (" has a null corresponding node");
124
            end if;
125 1
            return E;
126
         end if;
127

128 1
         if ADN.Kind (U) = K_Package_Declaration then
129 1
            U := Package_Specification (U);
130
         end if;
131

132
         pragma Assert
133
           (Kind (U) = K_Package_Specification
134 0
            or else Kind (U) = K_Package_Instantiation);
135

136
         --  This is a subunit and we do not need to add a with for
137
         --  this unit but for one of its parents.  If the kind of the
138
         --  parent unit name is a K_Package_Instantiation, we
139
         --  consider it as a subunit.
140

141 1
         if Kind (U) = K_Package_Instantiation
142 1
           or else Is_Subunit_Package (U)
143
         then
144 1
            U := Parent_Unit_Name (E);
145

146
            --  This is a special case to handle package Standard
147

148 1
            if No (U) then
149 1
               return No_Node;
150
            end if;
151

152 1
            return To_Library_Unit (U);
153
         end if;
154

155 1
         return E;
156
      end To_Library_Unit;
157

158 1
      P             : constant Node_Id := To_Library_Unit (E);
159 1
      W             : Node_Id;
160 1
      N             : Name_Id;
161 1
      I             : Node_Id;
162 1
      Existing_With : Node_Id;
163

164
   begin
165 1
      if No (P) then
166 1
         return;
167
      end if;
168

169
      --  Build a string "<current_entity>%[s,b] <withed_entity>" that
170
      --  is the current entity name, a character 's' (resp 'b') to
171
      --  indicate whether we consider the spec (resp. body) of the
172
      --  current entity and the withed entity name.
173

174
      --  To avoid that a package "with"es itself
175

176 1
      if Kind (Current_Package) /= K_Subprogram_Implementation
177 1
        and then Kind (Current_Package) /= K_Subprogram_Specification
178
      then
179
         --  and then Corresponding_Node (Defining_Identifier (P))
180
         --  = Package_Declaration (Current_Package)
181

182 1
         if To_Lower (Fully_Qualified_Name (P)) =
183 1
           To_Lower
184 1
             (Fully_Qualified_Name
185 1
                (Defining_Identifier (Package_Declaration (Current_Package))))
186
         then
187 1
            return;
188
         end if;
189
      end if;
190

191
      --  Routine that check wether the package P has already been
192
      --  added to the withed packages of the current package. When we
193
      --  add a 'with' clause to a package specification, we check
194
      --  only if this clause has been added to the current
195
      --  spec. However, when we add a 'with' clause to a package
196
      --  body, we check that the clause has been added in both the
197
      --  spec and the body.
198

199
      --  IMPORTANT: Provided that all specs are generated before all
200
      --  bodies, this behaviour is automatically applied. We just
201
      --  need to encode the package name *without* precising whether
202
      --  it is a spec or a body
203

204
      --  Encoding the withed package and the current entity
205

206 1
      N := Fully_Qualified_Name (P);
207

208 1
      if Kind (Current_Package) /= K_Subprogram_Implementation
209 1
        and then Kind (Current_Package) /= K_Subprogram_Specification
210
      then
211 1
         I := Defining_Identifier (Package_Declaration (Current_Package));
212

213 1
         Get_Name_String (Fully_Qualified_Name (I));
214

215
         --  In both the PolyORB-HI and PolyORB-QoS generators some
216
         --  packages that are generated for different nodes have
217
         --  exactly the same name. We must encode the node name to
218
         --  differenciate them. This happens only when we deal with a
219
         --  package generated for a root node
220

221 1
         if Present
222 1
             (Main_Subprogram
223 1
                (Distributed_Application_Unit
224 1
                   (Package_Declaration (Current_Package))))
225
         then
226 1
            Add_Char_To_Name_Buffer (' ');
227 1
            Get_Name_String_And_Append
228 1
              (ADN.Name
229 1
                 (Defining_Identifier
230 1
                    (Main_Subprogram
231 1
                       (Distributed_Application_Unit
232 1
                          (Package_Declaration (Current_Package))))));
233
         end if;
234

235 1
      elsif Kind (Current_Package) /= K_Subprogram_Specification then
236 1
         I := Defining_Identifier (Specification (Current_Package));
237 1
         Get_Name_String (Fully_Qualified_Name (I));
238
      else
239 0
         I := Defining_Identifier (Current_Package);
240 0
         Get_Name_String (Fully_Qualified_Name (I));
241
      end if;
242

243 1
      Add_Char_To_Name_Buffer (' ');
244 1
      Get_Name_String_And_Append (N);
245 1
      N := To_Lower (Name_Find);
246

247
      --  Get the info associated to the obtained name in the hash
248
      --  table and check whether it is already set to a value
249
      --  different from 0 (No_Node) which means that the withed
250
      --  entity is already in the withed package list. In this case
251
      --  try to enrich the exisiting with clause with eventual 'use',
252
      --  'elaborate' or warning disabling clauses.
253

254 1
      Existing_With := Node_Id (Get_Name_Table_Info (N));
255

256 1
      if Present (Existing_With) then
257 1
         Set_Used (Existing_With, ADN.Used (Existing_With) or else Used);
258 1
         Set_Warnings_Off
259
           (Existing_With,
260 1
            ADN.Warnings_Off (Existing_With) or else Warnings_Off);
261 1
         Set_Elaborated
262
           (Existing_With,
263 1
            ADN.Elaborated (Existing_With) or else Elaborated);
264 1
         return;
265
      end if;
266

267
      --  Debug message (if wanted by the user)
268

269 1
      if Output_Unit_Withing then
270 0
         Write_Name (N);
271 0
         Write_Eol;
272
      end if;
273

274
      --  Add entity to the withed packages list of the current
275
      --  package
276

277 1
      W := Make_Withed_Package (P, Used, Warnings_Off, Elaborated);
278

279
      --  Mark the 'with' clause as being added to the current package
280

281 1
      Set_Name_Table_Info (N, Int (W));
282

283 1
      Append_Node_To_List (W, Withed_Packages (Current_Package));
284
   end Add_With_Package;
285

286
   ------------------------------------
287
   -- Append_Node_To_Current_Package --
288
   ------------------------------------
289

290 1
   procedure Append_Node_To_Current_Package (N : Node_Id) is
291
   begin
292
      case Kind (Current_Package) is
293 1
         when K_Package_Specification =>
294 1
            Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
295 1
         when K_Package_Implementation =>
296 1
            Append_Node_To_List (N, ADN.Statements (Current_Package));
297 0
         when others =>
298 0
            raise Program_Error;
299 1
      end case;
300 1
   end Append_Node_To_Current_Package;
301

302
   -------------------------
303
   -- Append_Node_To_List --
304
   -------------------------
305

306 1
   procedure Append_Node_To_List (E : Node_Id; L : List_Id) is
307 1
      Last : Node_Id;
308

309
   begin
310 1
      Last := Last_Node (L);
311 1
      if No (Last) then
312 1
         Set_First_Node (L, E);
313
      else
314 1
         Set_Next_Node (Last, E);
315
      end if;
316 1
      Last := E;
317 1
      while Present (Last) loop
318 1
         Set_Last_Node (L, Last);
319 1
         Last := Next_Node (Last);
320 1
      end loop;
321 1
   end Append_Node_To_List;
322

323
   -----------------------
324
   -- Insert_After_Node --
325
   -----------------------
326

327 1
   procedure Insert_After_Node (E : Node_Id; N : Node_Id) is
328 1
      Next : constant Node_Id := Next_Node (N);
329
   begin
330 1
      Set_Next_Node (N, E);
331 1
      Set_Next_Node (E, Next);
332 1
   end Insert_After_Node;
333

334
   ------------------------
335
   -- Insert_Before_Node --
336
   ------------------------
337

338 1
   procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id) is
339 1
      Entity : Node_Id;
340
   begin
341 1
      Entity := First_Node (L);
342 1
      if Entity = N then
343 1
         Set_Next_Node (E, Entity);
344 1
         Set_First_Node (L, E);
345
      else
346 1
         while Present (Entity) loop
347 1
            exit when Next_Node (Entity) = N;
348 1
            Entity := Next_Node (Entity);
349 1
         end loop;
350

351 1
         Insert_After_Node (E, Entity);
352
      end if;
353 1
   end Insert_Before_Node;
354

355
   ---------------------
356
   -- Copy_Designator --
357
   ---------------------
358

359 1
   function Copy_Designator
360
     (Designator : Node_Id;
361
      Withed     : Boolean := True) return Node_Id
362
   is
363 1
      D : Node_Id;
364 1
      P : Node_Id := Parent_Unit_Name (Designator);
365

366
   begin
367 1
      D := Copy_Node (Designator);
368 1
      if Kind (Designator) = K_Designator
369 0
        or else Kind (Designator) = K_Defining_Identifier
370
      then
371 1
         P := Parent_Unit_Name (Designator);
372 0
      elsif Kind (Designator) = K_Attribute_Designator then
373 0
         P := Parent_Unit_Name (Prefix (Designator));
374
      end if;
375

376 1
      if Present (P) then
377 1
         P := Copy_Designator (P, False);
378 1
         if Withed then
379 1
            Add_With_Package (P);
380
         end if;
381
      end if;
382 1
      return D;
383
   end Copy_Designator;
384

385
   ---------------
386
   -- Copy_Node --
387
   ---------------
388

389 1
   function Copy_Node (N : Node_Id) return Node_Id is
390 1
      C : Node_Id;
391

392
   begin
393
      case Kind (N) is
394 1
         when K_Designator =>
395 1
            C := New_Node (K_Designator);
396 1
            Set_Defining_Identifier (C, Defining_Identifier (N));
397 1
            Set_Frontend_Node (C, Frontend_Node (N));
398 1
            Set_Homogeneous_Parent_Unit_Name (C, Parent_Unit_Name (N));
399

400 1
         when K_Defining_Identifier =>
401 1
            C := New_Node (K_Defining_Identifier);
402 1
            Set_Name (C, Name (N));
403 1
            Set_Homogeneous_Parent_Unit_Name (C, Parent_Unit_Name (N));
404 1
            Set_Corresponding_Node (C, Corresponding_Node (N));
405

406 0
         when K_Attribute_Designator =>
407 0
            C := New_Node (K_Attribute_Designator);
408 0
            Set_Name (C, Name (N));
409 0
            Set_Prefix (C, Copy_Node (Prefix (N)));
410

411 0
         when others =>
412 0
            raise Program_Error;
413
      end case;
414 1
      return C;
415
   end Copy_Node;
416

417
   ------------------------------------------
418
   -- Create_Subtype_From_Range_Constraint --
419
   ------------------------------------------
420

421 1
   function Create_Subtype_From_Range_Constraint
422
     (R : Node_Id) return Node_Id
423
   is
424 1
      N         : Node_Id := No_Node;
425 1
      C_First   : Node_Id := No_Node;
426 1
      C_Last    : Node_Id := No_Node;
427 1
      C_Index   : Node_Id := No_Node;
428 1
      Ident     : Node_Id := No_Node;
429 1
      Sub_Ident : Node_Id := No_Node;
430
   begin
431
      pragma Assert (Kind (R) = K_Range_Constraint);
432

433
      --  Stock identifier of the node in the variable Ident.
434
      --  If the node is not a literal, only its identifier is necessary.
435
      --  Variables C_first, C_Last and C_Index keep informations to
436
      --  construct the type replacing the range constraint.
437
      --  C_First and C_Last stock identifier of the node except for
438
      --  a literal node.
439

440 1
      if Present (Nodes.First (R)) then
441
         case Kind (Nodes.First (R)) is
442 0
            when K_Attribute_Designator =>
443 0
               C_First := Defining_Identifier (Nodes.Prefix (Nodes.First (R)));
444 0
               Ident   := C_First;
445

446 0
            when K_Designator =>
447 0
               C_First := Defining_Identifier (Nodes.First (R));
448 0
               Ident   := C_First;
449

450 1
            when K_Literal =>
451 1
               C_First := Nodes.First (R);
452 1
               Ident   :=
453 1
                 Make_Defining_Identifier
454 1
                   (Get_String_Name
455 1
                      (Ada_Values.Image (Nodes.Value (C_First))));
456

457 0
            when K_Defining_Identifier =>
458 0
               C_First := Nodes.First (R);
459 0
               Ident   := C_First;
460 0
            when others =>
461 0
               null;
462
         end case;
463
      end if;
464

465 1
      if Present (Nodes.Last (R)) then
466
         case Kind (Nodes.Last (R)) is
467 0
            when K_Attribute_Designator =>
468 0
               C_Last := Defining_Identifier (Nodes.Prefix (Nodes.Last (R)));
469

470 1
            when K_Designator =>
471 1
               C_Last := Defining_Identifier (Nodes.Last (R));
472

473 1
            when K_Literal =>
474 1
               C_Last :=
475 1
                 Make_Defining_Identifier
476 1
                   (Get_String_Name
477 1
                      (Ada_Values.Image (Nodes.Value (Nodes.Last (R)))));
478

479 1
            when K_Defining_Identifier =>
480 1
               C_Last := Nodes.Last (R);
481

482 0
            when others =>
483 0
               null;
484
         end case;
485

486
         --  Construct identifier of the type : First_range_Last_Range
487 1
         Get_Name_String (Name (Ident));
488 1
         Add_Char_To_Name_Buffer ('_');
489 1
         Get_Name_String_And_Append (Name (C_Last));
490 1
         Sub_Ident := Make_Defining_Identifier (Name_Find);
491
      end if;
492

493 1
      if Present (Index_Type (R)) then
494
         case Kind (Index_Type (R)) is
495 1
            when K_Attribute_Designator =>
496 1
               Ident := Defining_Identifier (Nodes.Prefix (Index_Type (R)));
497

498 1
               if C_First = No_Node and then C_Last = No_Node then
499

500
                  --  Consider only Range attribute. Can be problematic
501
                  --  with a size attribute for instance.
502
                  C_Index :=
503 1
                    Make_Range_Constraint
504 1
                      (Make_Attribute_Designator (Ident, A_First),
505 1
                       Make_Attribute_Designator (Ident, A_Last),
506
                       Ident);
507

508
                  Sub_Ident :=
509 1
                    Make_Defining_Identifier (Name (Index_Type (R)));
510
               end if;
511 1
            when K_Designator =>
512 1
               Ident   := Defining_Identifier (Index_Type (R));
513 1
               C_Index := Index_Type (R);
514

515 0
            when others =>
516 0
               null;
517
         end case;
518
      end if;
519

520
      --  Case of unconstraint array (range <>)
521
      --  or a range attribute (Index'Range).
522 1
      if (C_First = No_Node)
523 1
        and then (C_Last = No_Node)
524 1
        and then (C_Index /= No_Node)
525 1
        and then Ident /= No_Node
526
      then
527

528
         --  if C_Index is an unconstraint array (range <>)
529
         --  return a range constraint, else return created type.
530 1
         if Kind (C_Index) = K_Designator then
531 0
            N := Make_Range_Constraint (No_Node, No_Node, Ident);
532
         else
533 1
            Sub_Ident :=
534 1
              Make_Defining_Identifier
535 1
                (Create_Unique_Identifier
536 1
                   (Name (Ident),
537 1
                    Get_Name_String (Name (Sub_Ident))));
538 1
            if Get_Name_Table_Info (Name (Sub_Ident)) = Int (No_Node) then
539
               N :=
540 1
                 Make_Full_Type_Declaration
541
                   (Defining_Identifier => Sub_Ident,
542
                    Type_Definition     => C_Index,
543
                    Is_Subtype          => True);
544 1
               Set_Name_Table_Info (Name (Sub_Ident), Int (Sub_Ident));
545 1
               Append_Node_To_Current_Package (N);
546
            else
547
               N :=
548 1
                 Corresponding_Node
549 1
                   (Node_Id (Get_Name_Table_Info (Name (Sub_Ident))));
550
            end if;
551
         end if;
552

553
      --  Case range constraint is of the form :
554
      --  My_Type range Range_First .. Range_Last
555
      --  create a type : subtype UT_Type is My_Type Range_First ..Range_Last
556 1
      elsif (C_First /= No_Node)
557 1
        and then (C_Last /= No_Node)
558 1
        and then (C_Index /= No_Node)
559
      then
560

561
         Sub_Ident :=
562 1
           Make_Defining_Identifier
563 1
             (Create_Unique_Identifier (Name (Sub_Ident)));
564

565
         N :=
566 1
           Make_Full_Type_Declaration
567
             (Defining_Identifier => Sub_Ident,
568
              Type_Definition     =>
569 1
                Make_Range_Constraint (C_First, C_Last, Ident),
570
              Is_Subtype => True);
571

572 1
         if Get_Name_Table_Info (Name (Sub_Ident)) = Int (No_Node) then
573 1
            Set_Name_Table_Info (Name (Sub_Ident), Int (Sub_Ident));
574 1
            Append_Node_To_Current_Package (N);
575
         else
576
            N :=
577 0
              Corresponding_Node
578 0
                (Node_Id (Get_Name_Table_Info (Name (Sub_Ident))));
579
         end if;
580

581
      --  Case range constraint is of the form : 1 .. Max_Size,
582
      --  create a type : type UT_Type is Integer range 1 .. Max_Size
583 1
      elsif (C_First /= No_Node)
584 1
        and then (C_Last /= No_Node)
585 1
        and then (C_Index = No_Node)
586
      then
587

588
         Sub_Ident :=
589 1
           Make_Defining_Identifier
590 1
             (Create_Unique_Identifier (Name (Sub_Ident)));
591

592
         N :=
593 1
           Make_Full_Type_Declaration
594
             (Defining_Identifier => Sub_Ident,
595
              Type_Definition     =>
596 1
                Make_Range_Constraint
597
                  (C_First,
598
                   C_Last,
599 1
                   Make_Defining_Identifier (TN (T_Integer))),
600
              Is_Subtype => True);
601

602 1
         if Get_Name_Table_Info (Name (Sub_Ident)) = Int (No_Node) then
603 1
            Set_Name_Table_Info (Name (Sub_Ident), Int (Sub_Ident));
604 1
            Append_Node_To_Current_Package (N);
605
         else
606
            N :=
607 1
              Corresponding_Node
608 1
                (Node_Id (Get_Name_Table_Info (Name (Sub_Ident))));
609
         end if;
610
      end if;
611

612 1
      return N;
613
   end Create_Subtype_From_Range_Constraint;
614

615
   --------------------
616
   -- Current_Entity --
617
   --------------------
618

619 1
   function Current_Entity return Node_Id is
620
   begin
621 1
      if Last = No_Depth then
622 0
         return No_Node;
623
      else
624
         return Table (Last).Current_Entity;
625
      end if;
626
   end Current_Entity;
627

628
   ---------------------
629
   -- Current_Package --
630
   ---------------------
631

632 1
   function Current_Package return Node_Id is
633
   begin
634 1
      if Last = No_Depth then
635 0
         return No_Node;
636
      else
637
         return Table (Last).Current_Package;
638
      end if;
639
   end Current_Package;
640

641
   ---------------------------------------
642
   -- Defining_Identifier_To_Designator --
643
   ---------------------------------------
644

645 1
   function Defining_Identifier_To_Designator
646
     (N                       : Node_Id;
647
      Copy                    : Boolean := False;
648
      Keep_Parent             : Boolean := True;
649
      Keep_Corresponding_Node : Boolean := True) return Node_Id
650
   is
651 1
      P      : Node_Id;
652 1
      Def_Id : Node_Id := N;
653
   begin
654
      pragma Assert (ADN.Kind (N) = K_Defining_Identifier);
655

656 1
      if Copy then
657 0
         Def_Id := Copy_Node (N);
658
      end if;
659

660 1
      if not Keep_Parent then
661 1
         Def_Id := Make_Defining_Identifier (ADN.Name (N));
662
      end if;
663

664 1
      if Keep_Corresponding_Node then
665 1
         Set_Corresponding_Node (Def_Id, Corresponding_Node (N));
666
      end if;
667

668 1
      P := New_Node (K_Designator);
669 1
      Set_Defining_Identifier (P, Def_Id);
670

671 1
      if Keep_Parent then
672 0
         Set_Homogeneous_Parent_Unit_Name (P, Parent_Unit_Name (N));
673
      end if;
674

675 1
      return P;
676
   end Defining_Identifier_To_Designator;
677

678
   ---------------------
679
   -- Message_Comment --
680
   ---------------------
681

682 0
   function Message_Comment (M : Name_Id) return Node_Id is
683 0
      C : Node_Id;
684
   begin
685 0
      C := Make_Ada_Comment (M);
686 0
      return C;
687
   end Message_Comment;
688

689
   ---------------------
690
   -- Message_Comment --
691
   ---------------------
692

693
   function Message_Comment (M : String) return Node_Id is
694 1
      C : Node_Id;
695
   begin
696 1
      Set_Str_To_Name_Buffer (M);
697 1
      C := Make_Ada_Comment (Name_Find);
698 1
      return C;
699
   end Message_Comment;
700

701
   --------------------------
702
   -- Fully_Qualified_Name --
703
   --------------------------
704

705 1
   function Fully_Qualified_Name (N : Node_Id) return Name_Id is
706 1
      Parent_Node : Node_Id := No_Node;
707 1
      Parent_Name : Name_Id := No_Name;
708

709
   begin
710
      case Kind (N) is
711 1
         when K_Designator =>
712 1
            Parent_Node := Parent_Unit_Name (N);
713

714 1
            if not Present (Parent_Node) then
715 1
               Parent_Node := Parent_Unit_Name (Defining_Identifier (N));
716
            end if;
717

718 1
            if Present (Parent_Node) then
719 1
               Parent_Name := Fully_Qualified_Name (Parent_Node);
720
            end if;
721

722 1
            Name_Len := 0;
723 1
            if Present (Parent_Node) then
724 1
               Get_Name_String (Parent_Name);
725 1
               Add_Char_To_Name_Buffer ('.');
726
            end if;
727 1
            Get_Name_String_And_Append (Name (Defining_Identifier (N)));
728 1
            return Name_Find;
729

730 1
         when K_Defining_Identifier =>
731 1
            Parent_Node := Parent_Unit_Name (N);
732 1
            if Present (Parent_Node) then
733 1
               Parent_Name := Fully_Qualified_Name (Parent_Node);
734
            end if;
735

736 1
            Name_Len := 0;
737 1
            if Present (Parent_Node) then
738 1
               Get_Name_String (Parent_Name);
739 1
               Add_Char_To_Name_Buffer ('.');
740
            end if;
741 1
            Get_Name_String_And_Append (Name (N));
742 1
            return Name_Find;
743

744 0
         when K_Attribute_Designator =>
745 0
            Get_Name_String (Fully_Qualified_Name (Prefix (N)));
746 0
            Add_Char_To_Name_Buffer (''');
747 0
            Get_Name_String_And_Append (Name (N));
748 0
            return Name_Find;
749

750 0
         when others =>
751 0
            raise Program_Error;
752
      end case;
753
   end Fully_Qualified_Name;
754

755
   ---------------------
756
   -- Get_Style_State --
757
   ---------------------
758

759 1
   function Get_Style_State return Value_Id is
760

761
      --  The maximum line length allowed by GNAT is 32766
762

763 1
      Max_Line_Length : constant Int := 32766;
764 1
      Result          : Value_Id;
765
   begin
766 1
      Set_Str_To_Name_Buffer ("NM");
767 1
      Add_Nat_To_Name_Buffer (Max_Line_Length);
768 1
      Result := New_String_Value (Name_Find);
769 1
      return Result;
770
   end Get_Style_State;
771

772
   -----------
773
   -- Image --
774
   -----------
775

776 1
   function Image (T : Token_Type) return String is
777
      S : String := Token_Type'Image (T);
778
   begin
779 1
      To_Lower (S);
780 1
      return S (5 .. S'Last);
781
   end Image;
782

783
   -----------
784
   -- Image --
785
   -----------
786

787 1
   function Image (O : Operator_Type) return String is
788
      S : String := Operator_Type'Image (O);
789
   begin
790 1
      To_Lower (S);
791 1
      for I in S'First .. S'Last loop
792 1
         if S (I) = '_' then
793 1
            S (I) := ' ';
794
         end if;
795 1
      end loop;
796 1
      return S (4 .. S'Last);
797
   end Image;
798

799
   ----------------
800
   -- Initialize --
801
   ----------------
802

803 1
   procedure Initialize is
804
   begin
805
      --  Initialize Nutils only once
806

807 1
      if Initialized then
808 0
         return;
809
      end if;
810

811 1
      Initialized := True;
812

813
      --  Keywords.
814 1
      for I in Keyword_Type loop
815 1
         New_Token (I);
816 1
      end loop;
817

818
      --  Graphic Characters
819 1
      New_Token (Tok_Double_Asterisk, "**");
820 1
      New_Token (Tok_Ampersand, "&");
821 1
      New_Token (Tok_Minus, "-");
822 1
      New_Token (Tok_Plus, "+");
823 1
      New_Token (Tok_Asterisk, "*");
824 1
      New_Token (Tok_Slash, "/");
825 1
      New_Token (Tok_Dot, ".");
826 1
      New_Token (Tok_Apostrophe, "'");
827 1
      New_Token (Tok_Left_Paren, "(");
828 1
      New_Token (Tok_Right_Paren, ")");
829 1
      New_Token (Tok_Comma, ",");
830 1
      New_Token (Tok_Less, "<");
831 1
      New_Token (Tok_Equal, "=");
832 1
      New_Token (Tok_Greater, ">");
833 1
      New_Token (Tok_Not_Equal, "/=");
834 1
      New_Token (Tok_Greater_Equal, ">=");
835 1
      New_Token (Tok_Less_Equal, "<=");
836 1
      New_Token (Tok_Box, "<>");
837 1
      New_Token (Tok_Colon_Equal, ":=");
838 1
      New_Token (Tok_Colon, ":");
839 1
      New_Token (Tok_Greater_Greater, ">>");
840 1
      New_Token (Tok_Less_Less, "<<");
841 1
      New_Token (Tok_Semicolon, ";");
842 1
      New_Token (Tok_Arrow, "=>");
843 1
      New_Token (Tok_Vertical_Bar, "|");
844 1
      New_Token (Tok_Dot_Dot, "..");
845 1
      New_Token (Tok_Minus_Minus, "--");
846

847 1
      for O in Op_And .. Op_Or_Else loop
848 1
         New_Operator (O);
849 1
      end loop;
850 1
      New_Operator (Op_And_Symbol, "&");
851 1
      New_Operator (Op_Double_Asterisk, "**");
852 1
      New_Operator (Op_Minus, "-");
853 1
      New_Operator (Op_Plus, "+");
854 1
      New_Operator (Op_Asterisk, "*");
855 1
      New_Operator (Op_Slash, "/");
856 1
      New_Operator (Op_Less, "<");
857 1
      New_Operator (Op_Equal, "=");
858 1
      New_Operator (Op_Greater, ">");
859 1
      New_Operator (Op_Not_Equal, "/=");
860 1
      New_Operator (Op_Greater_Equal, ">=");
861 1
      New_Operator (Op_Less_Equal, "<=");
862 1
      New_Operator (Op_Box, "<>");
863 1
      New_Operator (Op_Colon_Equal, ":=");
864 1
      New_Operator (Op_Colon, "--");
865 1
      New_Operator (Op_Greater_Greater, ">>");
866 1
      New_Operator (Op_Less_Less, "<<");
867 1
      New_Operator (Op_Semicolon, ";");
868 1
      New_Operator (Op_Arrow, "=>");
869 1
      New_Operator (Op_Vertical_Bar, "|");
870

871 1
      for A in Attribute_Id loop
872 1
         Set_Str_To_Name_Buffer (Attribute_Id'Image (A));
873
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
874
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
875 1
         AN (A) := Name_Find;
876 1
      end loop;
877

878 1
      for C in Component_Id loop
879 1
         Set_Str_To_Name_Buffer (Component_Id'Image (C));
880
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
881
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
882 1
         CN (C) := Name_Find;
883 1
      end loop;
884

885 1
      for P in Parameter_Id loop
886 1
         Set_Str_To_Name_Buffer (Parameter_Id'Image (P));
887
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
888
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
889 1
         PN (P) := Name_Find;
890 1
      end loop;
891

892 1
      for S in Subprogram_Id loop
893 1
         Set_Str_To_Name_Buffer (Subprogram_Id'Image (S));
894
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
895
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
896 1
         SN (S) := Name_Find;
897 1
      end loop;
898

899 1
      for T in Type_Id loop
900 1
         Set_Str_To_Name_Buffer (Type_Id'Image (T));
901
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
902
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
903 1
         TN (T) := Name_Find;
904 1
      end loop;
905

906 1
      for V in Variable_Id loop
907 1
         Set_Str_To_Name_Buffer (Variable_Id'Image (V));
908
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
909 1
         Add_Str_To_Name_Buffer (Var_Suffix);
910
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
911 1
         VN (V) := Name_Find;
912 1
      end loop;
913

914 1
      for G in Pragma_Id loop
915 1
         Set_Str_To_Name_Buffer (Pragma_Id'Image (G));
916
         Set_Str_To_Name_Buffer (Name_Buffer (8 .. Name_Len));
917
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
918 1
         GN (G) := Name_Find;
919 1
      end loop;
920

921 1
      for E in Error_Id loop
922 1
         Set_Str_To_Name_Buffer (Error_Id'Image (E));
923
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
924
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
925 1
         EN (E) := Name_Find;
926 1
      end loop;
927

928 1
      for A in Aspect_Id loop
929 1
         Set_Str_To_Name_Buffer (Aspect_Id'Image (A));
930
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
931
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
932 1
         ASN (A) := Name_Find;
933 1
      end loop;
934
   end Initialize;
935

936
   -----------
937
   -- Reset --
938
   -----------
939

940 1
   procedure Reset is
941
   begin
942 1
      Entity_Stack.Init;
943

944 1
      Initialized := False;
945 1
   end Reset;
946

947
   --------------
948
   -- Is_Empty --
949
   --------------
950

951 1
   function Is_Empty (L : List_Id) return Boolean is
952
   begin
953 1
      return L = No_List or else No (First_Node (L));
954
   end Is_Empty;
955

956
   ------------
957
   -- Length --
958
   ------------
959

960 1
   function Length (L : List_Id) return Natural is
961 1
      N : Node_Id;
962 1
      C : Natural := 0;
963
   begin
964 1
      if not Is_Empty (L) then
965 1
         N := First_Node (L);
966

967 1
         while Present (N) loop
968
            C := C + 1;
969 1
            N := Next_Node (N);
970 1
         end loop;
971
      end if;
972

973 1
      return C;
974
   end Length;
975

976
   ---------------------------------
977
   -- Make_Access_Type_Definition --
978
   ---------------------------------
979

980 0
   function Make_Access_Type_Definition
981
     (Subtype_Indication : Node_Id;
982
      Is_All             : Boolean := False;
983
      Is_Constant        : Boolean := False;
984
      Is_Not_Null        : Boolean := False) return Node_Id
985
   is
986 0
      N : Node_Id;
987
   begin
988 0
      N := New_Node (K_Access_Type_Definition);
989 0
      Set_Subtype_Indication (N, Subtype_Indication);
990

991 0
      Set_Is_All (N, Is_All);
992 0
      Set_Is_Constant (N, Is_Constant);
993 0
      Set_Is_Not_Null (N, Is_Not_Null);
994 0
      return N;
995
   end Make_Access_Type_Definition;
996

997
   ----------------------
998
   -- Make_Ada_Comment --
999
   ----------------------
1000

1001 1
   function Make_Ada_Comment
1002
     (N                 : Name_Id;
1003
      Has_Header_Spaces : Boolean := True) return Node_Id
1004
   is
1005 1
      C : Node_Id;
1006
   begin
1007 1
      C := New_Node (K_Ada_Comment);
1008 1
      Set_Defining_Identifier (C, New_Node (K_Defining_Identifier));
1009 1
      Set_Name (Defining_Identifier (C), N);
1010 1
      Set_Has_Header_Spaces (C, Has_Header_Spaces);
1011 1
      return C;
1012
   end Make_Ada_Comment;
1013

1014
   --------------------------
1015
   -- Make_Array_Aggregate --
1016
   --------------------------
1017

1018 1
   function Make_Array_Aggregate (Elements : List_Id) return Node_Id is
1019
      pragma Assert (not Is_Empty (Elements));
1020 1
      N : Node_Id;
1021
   begin
1022 1
      N := New_Node (K_Array_Aggregate);
1023 1
      Set_Elements (N, Elements);
1024 1
      return N;
1025
   end Make_Array_Aggregate;
1026

1027
   ------------------------------
1028
   -- Create_Unique_Identifier --
1029
   ------------------------------
1030

1031 1
   function Create_Unique_Identifier
1032
     (Name   : Name_Id;
1033
      Suffix : String := "") return Name_Id
1034
   is
1035 1
      Name_Returned : Name_Id;
1036
      Pack          : constant Name_Id :=
1037 1
        Nodes.Name
1038 1
          (Defining_Identifier (Package_Declaration (Current_Package)));
1039
   begin
1040 1
      Set_Str_To_Name_Buffer ("");
1041 1
      Get_Name_String (Pack);
1042 1
      Add_Char_To_Name_Buffer ('_');
1043 1
      Get_Name_String_And_Append
1044 1
        (ADN.Name
1045 1
           (Defining_Identifier
1046 1
              (Main_Subprogram
1047 1
                 (Distributed_Application_Unit
1048 1
                    (Package_Declaration (Current_Package))))));
1049
      GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
1050 1
      Add_Char_To_Name_Buffer ('_');
1051 1
      Get_Name_String_And_Append (Name);
1052 1
      if Suffix /= "" then
1053 1
         Name_Returned :=
1054 1
           Add_Prefix_To_Name
1055
             ("UT_",
1056 1
              Add_Suffix_To_Name ("_" & Suffix, Name_Find));
1057
      else
1058 1
         Name_Returned := Add_Prefix_To_Name ("UT_", Name_Find);
1059
      end if;
1060 1
      return Name_Returned;
1061
   end Create_Unique_Identifier;
1062

1063
   --------------------------------
1064
   -- Make_Array_Type_Definition --
1065
   --------------------------------
1066

1067 1
   function Make_Array_Type_Definition
1068
     (Range_Constraints    : List_Id;
1069
      Component_Definition : Node_Id;
1070
      Aliased_Present      : Boolean := False) return Node_Id
1071
   is
1072 1
      N : Node_Id;
1073

1074
   begin
1075 1
      N := New_Node (ADN.K_Array_Type_Definition);
1076 1
      Set_Range_Constraints (N, Range_Constraints);
1077 1
      Set_Component_Definition (N, Component_Definition);
1078 1
      Set_Aliased_Present (N, Aliased_Present);
1079 1
      return N;
1080
   end Make_Array_Type_Definition;
1081

1082
   -------------------------------
1083
   -- Make_Aspect_Specification --
1084
   -------------------------------
1085

1086 0
   function Make_Aspect_Specification (Aspects : List_Id) return Node_Id is
1087 0
      N : Node_Id;
1088
   begin
1089 0
      N := New_Node (ADN.K_Aspect_Specification);
1090 0
      Set_Aspect (N, Aspects);
1091 0
      return N;
1092
   end Make_Aspect_Specification;
1093

1094
   --------------
1095
   -- Make_Pre --
1096
   --------------
1097

1098 0
   function Make_Pre (Subprogram_Call : Node_Id) return Node_Id is
1099 0
      N : Node_Id;
1100
   begin
1101 0
      N := New_Node (ADN.K_Pre_Definition);
1102 0
      Set_Subprogram_Call (N, Subprogram_Call);
1103 0
      return N;
1104
   end Make_Pre;
1105

1106
   -------------------------------
1107
   -- Make_Global_Specification --
1108
   -------------------------------
1109

1110 0
   function Make_Global_Specification
1111
     (Moded_Global_List : List_Id)
1112
     return Node_Id
1113
   is
1114 0
      N : Node_Id;
1115
   begin
1116 0
      N := New_Node (ADN.K_Global_Specification);
1117 0
      Set_Moded_Global_List (N, Moded_Global_List);
1118 0
      return N;
1119
   end Make_Global_Specification;
1120

1121 0
   function Make_Moded_Global_List
1122
   (Mode : Mode_Id; Identifier : Node_Id) return Node_Id
1123
   is
1124 0
      N : Node_Id;
1125
   begin
1126 0
      N := New_Node (ADN.K_Moded_Global_List);
1127 0
      Set_Mode_Selector (N, Mode);
1128 0
      Set_Defining_Identifier (N, Identifier);
1129 0
      return N;
1130
   end Make_Moded_Global_List;
1131

1132
   -----------------
1133
   -- Make_Aspect --
1134
   -----------------
1135

1136 0
   function Make_Aspect
1137
     (Aspect_Mark : Name_Id;
1138
      Aspect_Definition : Node_Id := No_Node) return Node_Id
1139
   is
1140 0
      N : Node_Id;
1141
   begin
1142 0
      N := New_Node (ADN.K_Aspect);
1143 0
      Set_Aspect_Mark (N, Aspect_Mark);
1144 0
      Set_Aspect_Definition (N, Aspect_Definition);
1145 0
      return N;
1146
   end Make_Aspect;
1147

1148
   ------------------------------
1149
   -- Make_Initialization_Spec --
1150
   ------------------------------
1151

1152 0
   function Make_Initialization_Spec
1153
     (Initialization_List : List_Id) return Node_Id
1154
   is
1155 0
      N : Node_Id;
1156
   begin
1157 0
      N := New_Node (ADN.K_Initialization_Spec);
1158 0
      Set_Initialization_List (N, Initialization_List);
1159 0
      return N;
1160
   end Make_Initialization_Spec;
1161

1162
   ------------------------------
1163
   -- Make_Abstract_State_List --
1164
   ------------------------------
1165

1166 0
   function Make_Abstract_State_List
1167
     (State_Name_With_Option : List_Id) return Node_Id
1168
   is
1169 0
      N : Node_Id;
1170
   begin
1171 0
      N := New_Node (ADN.K_Abstract_State_List);
1172 0
      Set_State_Name_With_Option (N, State_Name_With_Option);
1173 0
      return N;
1174
   end Make_Abstract_State_List;
1175

1176
   ---------------------------------
1177
   -- Make_State_Name_With_Option --
1178
   ---------------------------------
1179

1180 0
   function Make_State_Name_With_Option
1181
     (Defining_Identifier : Node_Id;
1182
      Synchronous : Boolean;
1183
      External : Boolean) return Node_Id
1184
   is
1185 0
      N : Node_Id;
1186
   begin
1187 0
      N := New_Node (ADN.K_State_Name_With_Option);
1188 0
      Set_Defining_Identifier (N, Defining_Identifier);
1189 0
      Set_Synchronous (N, Synchronous);
1190 0
      Set_External (N, External);
1191 0
      return N;
1192
   end Make_State_Name_With_Option;
1193

1194
   --------------------------
1195
   -- Make_Refinement_List --
1196
   --------------------------
1197

1198 0
   function Make_Refinement_List
1199
     (Refinement_Clause : List_Id) return Node_Id
1200
   is
1201 0
      N : Node_Id;
1202
   begin
1203 0
      N := New_Node (Adn.K_Refinement_List);
1204 0
      Set_Refinement_Clause (N, Refinement_Clause);
1205 0
      return N;
1206
   end Make_Refinement_List;
1207

1208
   ----------------------------
1209
   -- Make_Refinement_Clause --
1210
   ----------------------------
1211

1212 0
   function Make_Refinement_Clause
1213
     (State_Name : Node_Id;
1214
      Constituent : List_Id) return Node_Id
1215
   is
1216 0
      N : Node_Id;
1217
   begin
1218 0
      N := New_Node (Adn.K_Refinement_Clause);
1219 0
      Set_State_Name (N, State_Name);
1220 0
      Set_Constituent (N, Constituent);
1221 0
      return N;
1222
   end Make_Refinement_Clause;
1223

1224
   -------------------------------
1225
   -- Make_Assignment_Statement --
1226
   -------------------------------
1227

1228 1
   function Make_Assignment_Statement
1229
     (Variable_Identifier : Node_Id;
1230
      Expression          : Node_Id) return Node_Id
1231
   is
1232 1
      N : Node_Id;
1233
   begin
1234 1
      N := New_Node (K_Assignment_Statement);
1235 1
      Set_Defining_Identifier (N, Variable_Identifier);
1236 1
      Set_Expression (N, Expression);
1237 1
      return N;
1238
   end Make_Assignment_Statement;
1239

1240
   --------------------------------------
1241
   -- Make_Attribute_Definition_Clause --
1242
   --------------------------------------
1243

1244 1
   function Make_Attribute_Definition_Clause
1245
     (Defining_Identifier  : Node_Id;
1246
      Attribute_Designator : Attribute_Id;
1247
      Expression           : Node_Id) return Node_Id
1248
   is
1249 1
      N : Node_Id;
1250
   begin
1251 1
      N := New_Node (K_Attribute_Definition_Clause);
1252 1
      Set_Defining_Identifier (N, Defining_Identifier);
1253 1
      Set_Attribute_Designator (N, AN (Attribute_Designator));
1254 1
      Set_Expression (N, Expression);
1255

1256 1
      return N;
1257
   end Make_Attribute_Definition_Clause;
1258

1259
   -------------------------------
1260
   -- Make_Attribute_Designator --
1261
   -------------------------------
1262

1263 1
   function Make_Attribute_Designator
1264
     (Prefix    : Node_Id;
1265
      Attribute : Attribute_Id) return Node_Id
1266
   is
1267 1
      N : Node_Id;
1268
   begin
1269 1
      N := New_Node (K_Attribute_Designator);
1270 1
      Set_Prefix (N, Prefix);
1271 1
      Set_Name (N, AN (Attribute));
1272 1
      return N;
1273
   end Make_Attribute_Designator;
1274

1275
   --------------------------
1276
   -- Make_Block_Statement --
1277
   --------------------------
1278

1279 0
   function Make_Block_Statement
1280
     (Statement_Identifier : Node_Id := No_Node;
1281
      Declarative_Part     : List_Id;
1282
      Statements           : List_Id;
1283
      Exception_Handler    : List_Id := No_List) return Node_Id
1284
   is
1285 0
      N : Node_Id;
1286
   begin
1287 0
      N := New_Node (K_Block_Statement);
1288 0
      Set_Defining_Identifier (N, Statement_Identifier);
1289 0
      if Present (Statement_Identifier) then
1290 0
         Set_Corresponding_Node (Statement_Identifier, N);
1291
      end if;
1292 0
      Set_Declarative_Part (N, Declarative_Part);
1293 0
      Set_Statements (N, Statements);
1294 0
      if not Is_Empty (Exception_Handler) then
1295 0
         Set_Exception_Handler (N, Exception_Handler);
1296
      end if;
1297 0
      return N;
1298
   end Make_Block_Statement;
1299

1300
   ---------------------
1301
   -- Make_Case_Label --
1302
   ---------------------
1303

1304 0
   function Make_Case_Label (Value : Value_Id) return Node_Id is
1305 0
      N : Node_Id;
1306
   begin
1307 0
      N := New_Node (K_Case_Label);
1308 0
      Set_Value (N, Value);
1309 0
      return N;
1310
   end Make_Case_Label;
1311

1312
   -------------------------
1313
   -- Make_Case_Statement --
1314
   -------------------------
1315

1316 1
   function Make_Case_Statement
1317
     (Expression                  : Node_Id;
1318
      Case_Statement_Alternatives : List_Id) return Node_Id
1319
   is
1320 1
      N : Node_Id;
1321
   begin
1322 1
      N := New_Node (K_Case_Statement);
1323 1
      Set_Expression (N, Expression);
1324 1
      Set_Case_Statement_Alternatives (N, Case_Statement_Alternatives);
1325 1
      return N;
1326
   end Make_Case_Statement;
1327

1328
   -------------------------------------
1329
   -- Make_Case_Statement_Alternative --
1330
   -------------------------------------
1331

1332 1
   function Make_Case_Statement_Alternative
1333
     (Discret_Choice_List : List_Id;
1334
      Statements          : List_Id) return Node_Id
1335
   is
1336 1
      N : Node_Id;
1337
   begin
1338 1
      N := New_Node (K_Case_Statement_Alternative);
1339 1
      Set_Discret_Choice_List (N, Discret_Choice_List);
1340 1
      Set_Statements (N, Statements);
1341 1
      return N;
1342
   end Make_Case_Statement_Alternative;
1343

1344
   --------------------------------
1345
   -- Make_Component_Association --
1346
   --------------------------------
1347

1348 1
   function Make_Component_Association
1349
     (Selector_Name : Node_Id;
1350
      Expression    : Node_Id) return Node_Id
1351
   is
1352 1
      N : Node_Id;
1353
   begin
1354 1
      N := New_Node (K_Component_Association);
1355 1
      Set_Defining_Identifier (N, Selector_Name);
1356 1
      Set_Expression (N, Expression);
1357 1
      return N;
1358
   end Make_Component_Association;
1359

1360
   --------------------------------
1361
   -- Make_Component_Declaration --
1362
   --------------------------------
1363

1364 1
   function Make_Component_Declaration
1365
     (Defining_Identifier : Node_Id;
1366
      Subtype_Indication  : Node_Id;
1367
      Expression          : Node_Id := No_Node;
1368
      Aliased_Present     : Boolean := False) return Node_Id
1369
   is
1370 1
      N : Node_Id;
1371

1372
   begin
1373 1
      N := New_Node (K_Component_Declaration);
1374 1
      Set_Defining_Identifier (N, Defining_Identifier);
1375 1
      Set_Subtype_Indication (N, Subtype_Indication);
1376 1
      Set_Expression (N, Expression);
1377 1
      Set_Aliased_Present (N, Aliased_Present);
1378 1
      return N;
1379
   end Make_Component_Declaration;
1380

1381
   ----------------------------------
1382
   -- Make_Decimal_Type_Definition --
1383
   ----------------------------------
1384

1385 1
   function Make_Decimal_Type_Definition
1386
     (D_Digits : Unsigned_Long_Long;
1387
      D_Scale  : Unsigned_Long_Long) return Node_Id
1388
   is
1389 1
      N : Node_Id;
1390 1
      V : Value_Id;
1391
   begin
1392 1
      N := New_Node (K_Decimal_Type_Definition);
1393

1394
      V :=
1395 1
        New_Floating_Point_Value
1396
          (Long_Double (1.0 / (10**(Integer (D_Scale)))));
1397

1398 1
      Set_Scale (N, Make_Literal (V));
1399

1400 1
      V := New_Integer_Value (D_Digits, 1, 10);
1401 1
      Set_Total (N, V);
1402

1403 1
      return N;
1404
   end Make_Decimal_Type_Definition;
1405

1406
   ------------------------------
1407
   -- Make_Defining_Identifier --
1408
   ------------------------------
1409

1410 1
   function Make_Defining_Identifier
1411
     (Name : Name_Id; Normalize : Boolean := True) return Node_Id
1412
   is
1413 1
      N : Node_Id;
1414

1415
   begin
1416 1
      N := New_Node (K_Defining_Identifier);
1417 1
      if Normalize then
1418 1
         Set_Name (N, To_Ada_Name (Name));
1419
      else
1420 1
         Set_Name (N, Name);
1421
      end if;
1422

1423 1
      return N;
1424
   end Make_Defining_Identifier;
1425

1426
   --------------------------
1427
   -- Make_Delay_Statement --
1428
   --------------------------
1429

1430 0
   function Make_Delay_Statement
1431
     (Expression : Node_Id;
1432
      Is_Until   : Boolean := False) return Node_Id
1433
   is
1434 0
      N : Node_Id;
1435
   begin
1436 0
      N := New_Node (K_Delay_Statement);
1437 0
      Set_Expression (N, Expression);
1438 0
      Set_Is_Until (N, Is_Until);
1439 0
      return N;
1440
   end Make_Delay_Statement;
1441

1442
   ----------------------------------
1443
   -- Make_Derived_Type_Definition --
1444
   ----------------------------------
1445

1446 1
   function Make_Derived_Type_Definition
1447
     (Subtype_Indication    : Node_Id;
1448
      Record_Extension_Part : Node_Id := No_Node;
1449
      Is_Abstract_Type      : Boolean := False;
1450
      Is_Private_Extention  : Boolean := False;
1451
      Is_Subtype            : Boolean := False) return Node_Id
1452
   is
1453 1
      N : Node_Id;
1454

1455
   begin
1456 1
      N := New_Node (K_Derived_Type_Definition);
1457 1
      Set_Is_Abstract_Type (N, Is_Abstract_Type);
1458 1
      Set_Is_Private_Extention (N, Is_Private_Extention);
1459 1
      Set_Subtype_Indication (N, Subtype_Indication);
1460 1
      Set_Record_Extension_Part (N, Record_Extension_Part);
1461 1
      Set_Is_Subtype (N, Is_Subtype);
1462 1
      return N;
1463
   end Make_Derived_Type_Definition;
1464

1465
   ---------------------
1466
   -- Make_Designator --
1467
   ---------------------
1468

1469 1
   function Make_Designator
1470
     (Designator : Name_Id;
1471
      Parent     : Name_Id := No_Name;
1472
      Is_All     : Boolean := False) return Node_Id
1473
   is
1474 1
      N : Node_Id;
1475 1
      P : Node_Id;
1476
   begin
1477 1
      N := New_Node (K_Designator);
1478 1
      Set_Defining_Identifier (N, Make_Defining_Identifier (Designator));
1479 1
      Set_Is_All (N, Is_All);
1480

1481 1
      if Parent /= No_Name then
1482 1
         P := New_Node (K_Designator);
1483 1
         Set_Defining_Identifier (P, Make_Defining_Identifier (Parent));
1484 1
         Set_Homogeneous_Parent_Unit_Name (N, P);
1485
      end if;
1486

1487 1
      return N;
1488
   end Make_Designator;
1489

1490
   ------------------------------
1491
   -- Make_Element_Association --
1492
   ------------------------------
1493

1494 1
   function Make_Element_Association
1495
     (Index      : Node_Id;
1496
      Expression : Node_Id) return Node_Id
1497
   is
1498 1
      N : Node_Id;
1499
   begin
1500 1
      N := New_Node (K_Element_Association);
1501 1
      Set_Index (N, Index);
1502 1
      Set_Expression (N, Expression);
1503 1
      return N;
1504
   end Make_Element_Association;
1505

1506
   --------------------------
1507
   -- Make_Elsif_Statement --
1508
   --------------------------
1509

1510 1
   function Make_Elsif_Statement
1511
     (Condition       : Node_Id;
1512
      Then_Statements : List_Id) return Node_Id
1513
   is
1514 1
      N : Node_Id;
1515
   begin
1516 1
      N := New_Node (K_Elsif_Statement);
1517 1
      Set_Condition (N, Condition);
1518 1
      Set_Then_Statements (N, Then_Statements);
1519 1
      return N;
1520
   end Make_Elsif_Statement;
1521

1522
   --------------------------------------
1523
   -- Make_Enumeration_Type_Definition --
1524
   --------------------------------------
1525

1526 1
   function Make_Enumeration_Type_Definition
1527
     (Enumeration_Literals : List_Id) return Node_Id
1528
   is
1529 1
      N : Node_Id;
1530

1531
   begin
1532 1
      N := New_Node (K_Enumeration_Type_Definition);
1533 1
      Set_Enumeration_Literals (N, Enumeration_Literals);
1534 1
      return N;
1535
   end Make_Enumeration_Type_Definition;
1536

1537
   --------------------------------------------
1538
   -- Make_Enumeration_Representation_Clause --
1539
   --------------------------------------------
1540

1541 1
   function Make_Enumeration_Representation_Clause
1542
     (Defining_Identifier : Node_Id;
1543
      Array_Aggregate     : Node_Id) return Node_Id
1544
   is
1545 1
      N : Node_Id;
1546
   begin
1547 1
      N := New_Node (K_Enumeration_Representation_Clause);
1548 1
      Set_Defining_Identifier (N, Defining_Identifier);
1549 1
      Set_Array_Aggregate (N, Array_Aggregate);
1550 1
      return N;
1551
   end Make_Enumeration_Representation_Clause;
1552

1553
   -------------------------------
1554
   -- Make_Explicit_Dereference --
1555
   -------------------------------
1556

1557 0
   function Make_Explicit_Dereference (Prefix : Node_Id) return Node_Id is
1558 0
      N : Node_Id;
1559
   begin
1560 0
      N := New_Node (K_Explicit_Dereference);
1561 0
      Set_Prefix (N, Prefix);
1562 0
      return N;
1563
   end Make_Explicit_Dereference;
1564

1565
   --------------------------------
1566
   -- Make_Exception_Declaration --
1567
   --------------------------------
1568

1569 1
   function Make_Exception_Declaration
1570
     (Defining_Identifier : Node_Id;
1571
      Renamed_Exception   : Node_Id := No_Node) return Node_Id
1572
   is
1573 1
      N : Node_Id;
1574

1575
   begin
1576 1
      N := New_Node (K_Exception_Declaration);
1577 1
      Set_Defining_Identifier (N, Defining_Identifier);
1578 1
      Set_Renamed_Entity (N, Renamed_Exception);
1579 1
      Set_Corresponding_Node (Defining_Identifier, N);
1580 1
      Set_Parent (N, Current_Package);
1581 1
      return N;
1582
   end Make_Exception_Declaration;
1583

1584
   ---------------------
1585
   -- Make_Expression --
1586
   ---------------------
1587

1588 1
   function Make_Expression
1589
     (Left_Expr  : Node_Id;
1590
      Operator   : Operator_Type := Op_None;
1591
      Right_Expr : Node_Id       := No_Node) return Node_Id
1592
   is
1593 1
      N : Node_Id;
1594
   begin
1595 1
      N := New_Node (K_Expression);
1596 1
      Set_Left_Expr (N, Left_Expr);
1597 1
      Set_Operator (N, Operator_Type'Pos (Operator));
1598 1
      Set_Right_Expr (N, Right_Expr);
1599 1
      return N;
1600
   end Make_Expression;
1601

1602
   ------------------------
1603
   -- Make_For_Statement --
1604
   ------------------------
1605

1606 0
   function Make_For_Statement
1607
     (Defining_Identifier : Node_Id;
1608
      Range_Constraint    : Node_Id;
1609
      Statements          : List_Id) return Node_Id
1610
   is
1611 0
      N : Node_Id;
1612
   begin
1613 0
      N := New_Node (K_For_Statement);
1614 0
      Set_Defining_Identifier (N, Defining_Identifier);
1615 0
      Set_Range_Constraint (N, Range_Constraint);
1616 0
      Set_Statements (N, Statements);
1617 0
      return N;
1618
   end Make_For_Statement;
1619

1620
   -------------------------
1621
   -- Make_Loop_Statement --
1622
   -------------------------
1623

1624 0
   function Make_Loop_Statement (Statements : List_Id) return Node_Id is
1625 0
      N : Node_Id;
1626
   begin
1627 0
      N := New_Node (K_Loop_Statement);
1628 0
      Set_Statements (N, Statements);
1629 0
      return N;
1630
   end Make_Loop_Statement;
1631

1632
   --------------------------------
1633
   -- Make_Full_Type_Declaration --
1634
   --------------------------------
1635

1636 1
   function Make_Full_Type_Declaration
1637
     (Defining_Identifier : Node_Id;
1638
      Type_Definition     : Node_Id;
1639
      Discriminant_Spec   : Node_Id := No_Node;
1640
      Parent              : Node_Id := No_Node;
1641
      Is_Subtype          : Boolean := False) return Node_Id
1642
   is
1643 1
      N            : Node_Id;
1644 1
      T_Definition : Node_Id := Type_Definition;
1645
   begin
1646
      --  Remove anonymous type if necessary.
1647 1
      if Kind (Type_Definition) = K_Array_Type_Definition then
1648
         T_Definition :=
1649 1
           Remove_Anonymous_Array_Type_Definition
1650 1
             (Range_Constraints (Type_Definition),
1651 1
              Component_Definition (Type_Definition),
1652 1
              Nodes.Aliased_Present (Type_Definition),
1653
              Defining_Identifier,
1654
              True);
1655
      end if;
1656

1657 1
      N := New_Node (K_Full_Type_Declaration);
1658 1
      Set_Defining_Identifier (N, Defining_Identifier);
1659 1
      Set_Corresponding_Node (Defining_Identifier, N);
1660 1
      Set_Type_Definition (N, T_Definition);
1661 1
      Set_Discriminant_Spec (N, Discriminant_Spec);
1662 1
      if Present (Parent) then
1663 0
         Set_Parent (N, Parent);
1664
      else
1665 1
         Set_Parent (N, Current_Package);
1666
      end if;
1667 1
      Set_Is_Subtype (N, Is_Subtype);
1668 1
      return N;
1669
   end Make_Full_Type_Declaration;
1670

1671
   ------------------------------
1672
   -- Make_Exit_When_Statement --
1673
   ------------------------------
1674

1675 0
   function Make_Exit_When_Statement (Condition : Node_Id) return Node_Id is
1676 0
      N : Node_Id;
1677
   begin
1678 0
      N := New_Node (K_Exit_When_Statement);
1679 0
      Set_Condition (N, Condition);
1680 0
      return N;
1681
   end Make_Exit_When_Statement;
1682

1683
   -----------------------
1684
   -- Make_If_Statement --
1685
   -----------------------
1686

1687 1
   function Make_If_Statement
1688
     (Condition        : Node_Id;
1689
      Then_Statements  : List_Id;
1690
      Elsif_Statements : List_Id := No_List;
1691
      Else_Statements  : List_Id := No_List) return Node_Id
1692
   is
1693 1
      N : Node_Id;
1694
   begin
1695 1
      N := New_Node (K_If_Statement);
1696 1
      Set_Condition (N, Condition);
1697 1
      Set_Then_Statements (N, Then_Statements);
1698 1
      Set_Elsif_Statements (N, Elsif_Statements);
1699 1
      Set_Else_Statements (N, Else_Statements);
1700 1
      return N;
1701
   end Make_If_Statement;
1702

1703
   ----------------------------
1704
   -- Make_Indexed_Component --
1705
   ----------------------------
1706

1707 1
   function Make_Indexed_Component
1708
     (Prefix      : Node_Id;
1709
      Expressions : List_Id) return Node_Id
1710
   is
1711 1
      N : Node_Id;
1712
   begin
1713 1
      N := New_Node (K_Indexed_Component);
1714 1
      Set_Prefix (N, Prefix);
1715 1
      Set_Expressions (N, Expressions);
1716 1
      return N;
1717
   end Make_Indexed_Component;
1718

1719
   ------------------
1720
   -- Make_List_Id --
1721
   ------------------
1722

1723 1
   function Make_List_Id
1724
     (N1 : Node_Id;
1725
      N2 : Node_Id := No_Node;
1726
      N3 : Node_Id := No_Node;
1727
      N4 : Node_Id := No_Node) return List_Id
1728
   is
1729 1
      L : List_Id;
1730
   begin
1731 1
      L := New_List (K_List_Id);
1732 1
      Append_Node_To_List (N1, L);
1733 1
      if Present (N2) then
1734 1
         Append_Node_To_List (N2, L);
1735

1736 1
         if Present (N3) then
1737 1
            Append_Node_To_List (N3, L);
1738

1739 1
            if Present (N4) then
1740 1
               Append_Node_To_List (N4, L);
1741
            end if;
1742
         end if;
1743
      end if;
1744 1
      return L;
1745
   end Make_List_Id;
1746

1747
   ------------------
1748
   -- Make_Literal --
1749
   ------------------
1750

1751 1
   function Make_Literal
1752
     (Value             : Value_Id;
1753
      Parent_Designator : Node_Id := No_Node) return Node_Id
1754
   is
1755 1
      N : Node_Id;
1756

1757
   begin
1758 1
      N := New_Node (K_Literal);
1759 1
      Set_Value (N, Value);
1760 1
      Set_Parent_Designator (N, Parent_Designator);
1761 1
      return N;
1762
   end Make_Literal;
1763

1764
   -----------------------------------------
1765
   -- Make_Main_Subprogram_Implementation --
1766
   -----------------------------------------
1767

1768 1
   function Make_Main_Subprogram_Implementation
1769
     (Identifier : Node_Id;
1770
      Build_Spec : Boolean := False;
1771
      Build_Body : Boolean := True) return Node_Id
1772
   is
1773 1
      Unit        : Node_Id;
1774 1
      Spg         : Node_Id;
1775 1
      N           : Node_Id;
1776 1
      Style_State : constant Value_Id := Get_Style_State;
1777
   begin
1778 1
      Unit := New_Node (K_Main_Subprogram_Implementation);
1779 1
      Set_Defining_Identifier (Unit, Identifier);
1780 1
      Set_Corresponding_Node (Identifier, Unit);
1781

1782
      ----------
1783
      -- Spec --
1784
      ----------
1785

1786
      Spg :=
1787 1
        Make_Subprogram_Specification
1788 1
          (Defining_Identifier => Copy_Node (Identifier),
1789
           Parameter_Profile   => No_List,
1790
           Return_Type         => No_Node,
1791
           Parent              => No_Node,
1792
           Renamed_Subprogram  => No_Node);
1793

1794 1
      if Build_Spec then
1795 0
         Set_Withed_Packages (Spg, New_List (K_Withed_Packages));
1796 0
         Set_Package_Headers (Spg, New_List (K_Package_Headers));
1797

1798
         --  Adding a comment header
1799

1800 0
         Make_Comment_Header (Package_Headers (Spg));
1801

1802
         --  Disabling style checks
1803

1804
         N :=
1805 0
           Make_Pragma_Statement
1806
             (Pragma_Style_Checks,
1807 0
              Make_List_Id (Make_Literal (Style_State)));
1808 0
         Append_Node_To_List (N, Package_Headers (Spg));
1809

1810
         --  Binding
1811

1812 0
         Set_Main_Subprogram_Unit (Spg, Unit);
1813 0
         Set_Subprogram_Specification (Unit, Spg);
1814
      end if;
1815

1816 1
      if Build_Body then
1817

1818
         ----------
1819
         -- Body --
1820
         ----------
1821

1822
         Spg :=
1823 1
           Make_Subprogram_Implementation
1824
             (Specification => Spg,
1825 1
              Declarations  => New_List (K_Declaration_List),
1826 1
              Statements    => New_List (K_Statement_List));
1827 1
         Set_Withed_Packages (Spg, New_List (K_Withed_Packages));
1828 1
         Set_Package_Headers (Spg, New_List (K_Package_Headers));
1829

1830
         --  Adding a comment header
1831

1832 1
         Make_Comment_Header (Package_Headers (Spg));
1833

1834
         --  Disabling style checks
1835

1836
         N :=
1837 1
           Make_Pragma_Statement
1838
             (Pragma_Style_Checks,
1839 1
              Make_List_Id (Make_Literal (Style_State)));
1840 1
         Append_Node_To_List (N, Package_Headers (Spg));
1841

1842
         --  Binding
1843

1844 1
         Set_Main_Subprogram_Unit (Spg, Unit);
1845 1
         Set_Subprogram_Implementation (Unit, Spg);
1846
      end if;
1847

1848 1
      return Unit;
1849
   end Make_Main_Subprogram_Implementation;
1850

1851
   -------------------------
1852
   -- Make_Null_Statement --
1853
   -------------------------
1854

1855 1
   function Make_Null_Statement return Node_Id is
1856 1
      N : Node_Id;
1857
   begin
1858 1
      N := New_Node (K_Null_Statement);
1859 1
      return N;
1860
   end Make_Null_Statement;
1861

1862
   -----------------------------
1863
   -- Make_Object_Declaration --
1864
   -----------------------------
1865

1866 1
   function Make_Object_Declaration
1867
     (Defining_Identifier : Node_Id;
1868
      Constant_Present    : Boolean := False;
1869
      Object_Definition   : Node_Id;
1870
      Expression          : Node_Id := No_Node;
1871
      Parent              : Node_Id := No_Node;
1872
      Renamed_Object      : Node_Id := No_Node;
1873
      Aliased_Present     : Boolean := False;
1874
      Discriminant_Spec   : Node_Id := No_Node) return Node_Id
1875
   is
1876 1
      N              : Node_Id;
1877 1
      Obj_Definition : Node_Id := Object_Definition;
1878 1
      Exp            : Node_Id := Expression;
1879
   begin
1880
      --  Remove anonymous type if necessary.
1881 1
      if Kind (Obj_Definition) = K_Array_Type_Definition then
1882
         Obj_Definition :=
1883 1
           Remove_Anonymous_Array_Type_Definition
1884 1
             (Range_Constraints (Object_Definition),
1885 1
              Component_Definition (Object_Definition),
1886 1
              Nodes.Aliased_Present (Object_Definition),
1887
              Defining_Identifier);
1888

1889
         --  Fully qualify aggregates
1890 1
         if Kind (Exp) = K_Array_Aggregate then
1891 1
            Exp := Make_Qualified_Expression (Obj_Definition, Expression);
1892
         end if;
1893
      end if;
1894 1
      N := New_Node (K_Object_Declaration);
1895 1
      Set_Defining_Identifier (N, Defining_Identifier);
1896 1
      Set_Corresponding_Node (Defining_Identifier, N);
1897 1
      Set_Constant_Present (N, Constant_Present);
1898 1
      Set_Aliased_Present (N, Aliased_Present);
1899 1
      Set_Object_Definition (N, Obj_Definition);
1900 1
      Set_Expression (N, Exp);
1901 1
      Set_Renamed_Entity (N, Renamed_Object);
1902 1
      Set_Discriminant_Spec (N, Discriminant_Spec);
1903

1904 1
      if No (Parent) then
1905 1
         Set_Parent (N, Current_Package);
1906
      else
1907 0
         Set_Parent (N, Parent);
1908
      end if;
1909

1910 1
      return N;
1911
   end Make_Object_Declaration;
1912

1913
   -------------------------------
1914
   -- Make_Object_Instantiation --
1915
   -------------------------------
1916

1917 0
   function Make_Object_Instantiation
1918
     (Qualified_Expression : Node_Id) return Node_Id
1919
   is
1920 0
      N : Node_Id;
1921
   begin
1922 0
      N := New_Node (K_Object_Instantiation);
1923 0
      Set_Qualified_Expression (N, Qualified_Expression);
1924 0
      return N;
1925
   end Make_Object_Instantiation;
1926

1927
   ------------------------------
1928
   -- Make_Package_Declaration --
1929
   ------------------------------
1930

1931 1
   function Make_Package_Declaration (Identifier : Node_Id) return Node_Id is
1932 1
      Pkg         : Node_Id;
1933 1
      Unit        : Node_Id;
1934 1
      N           : Node_Id;
1935 1
      Style_State : constant Value_Id := Get_Style_State;
1936
   begin
1937 1
      Unit := New_Node (K_Package_Declaration);
1938 1
      Set_Defining_Identifier (Unit, Identifier);
1939 1
      Set_Corresponding_Node (Identifier, Unit);
1940

1941
      --  FIXME : Set the correct parent!
1942

1943
      ----------
1944
      -- Spec --
1945
      ----------
1946

1947 1
      Pkg := New_Node (K_Package_Specification);
1948 1
      Set_Withed_Packages (Pkg, New_List (K_Withed_Packages));
1949 1
      Set_Package_Headers (Pkg, New_List (K_Package_Headers));
1950

1951
      --  Adding a comment header
1952

1953 1
      Make_Comment_Header (Package_Headers (Pkg));
1954

1955
      --  Disabling style checks
1956

1957
      N :=
1958 1
        Make_Pragma_Statement
1959
          (Pragma_Style_Checks,
1960 1
           Make_List_Id (Make_Literal (Style_State)));
1961 1
      Append_Node_To_List (N, Package_Headers (Pkg));
1962

1963 1
      Set_Visible_Part (Pkg, New_List (K_Declaration_List));
1964 1
      Set_Private_Part (Pkg, New_List (K_Declaration_List));
1965 1
      Set_Package_Declaration (Pkg, Unit);
1966 1
      Set_Package_Specification (Unit, Pkg);
1967

1968
      ----------
1969
      -- Body --
1970
      ----------
1971

1972 1
      Pkg := New_Node (K_Package_Implementation);
1973 1
      Set_Withed_Packages (Pkg, New_List (K_Withed_Packages));
1974 1
      Set_Package_Headers (Pkg, New_List (K_Package_Headers));
1975

1976
      --  Adding a comment header
1977

1978 1
      Make_Comment_Header (Package_Headers (Pkg));
1979

1980
      --  Disabling style checks
1981

1982
      N :=
1983 1
        Make_Pragma_Statement
1984
          (Pragma_Style_Checks,
1985 1
           Make_List_Id (Make_Literal (Style_State)));
1986 1
      Append_Node_To_List (N, Package_Headers (Pkg));
1987

1988 1
      Set_Declarations (Pkg, New_List (K_Declaration_List));
1989 1
      Set_Statements (Pkg, New_List (K_Statement_List));
1990 1
      Set_Package_Declaration (Pkg, Unit);
1991 1
      Set_Package_Implementation (Unit, Pkg);
1992

1993 1
      return Unit;
1994
   end Make_Package_Declaration;
1995

1996
   --------------------------------
1997
   -- Make_Package_Instantiation --
1998
   --------------------------------
1999

2000 1
   function Make_Package_Instantiation
2001
     (Defining_Identifier : Node_Id;
2002
      Generic_Package     : Node_Id;
2003
      Parameter_List      : List_Id := No_List) return Node_Id
2004
   is
2005 1
      N : Node_Id;
2006
   begin
2007 1
      N := New_Node (K_Package_Instantiation);
2008 1
      Set_Defining_Identifier (N, Defining_Identifier);
2009 1
      Set_Corresponding_Node (Defining_Identifier, N);
2010 1
      Set_Generic_Package (N, Generic_Package);
2011 1
      Set_Parameter_List (N, Parameter_List);
2012 1
      return N;
2013
   end Make_Package_Instantiation;
2014

2015
   ----------------------------------
2016
   -- Make_Private_Type_Definition --
2017
   ----------------------------------
2018

2019 1
   function Make_Private_Type_Definition return Node_Id is
2020
   begin
2021 1
      return New_Node (K_Private_Type_Definition);
2022
   end Make_Private_Type_Definition;
2023

2024
   --------------------------------
2025
   -- Make_Parameter_Association --
2026
   --------------------------------
2027

2028 1
   function Make_Parameter_Association
2029
     (Selector_Name    : Node_Id;
2030
      Actual_Parameter : Node_Id) return Node_Id
2031
   is
2032 1
      N : Node_Id;
2033
   begin
2034 1
      N := New_Node (K_Parameter_Association);
2035 1
      Set_Selector_Name (N, Selector_Name);
2036 1
      Set_Actual_Parameter (N, Actual_Parameter);
2037 1
      return N;
2038
   end Make_Parameter_Association;
2039

2040
   ----------------------------------
2041
   -- Make_Parameter_Specification --
2042
   ----------------------------------
2043

2044 1
   function Make_Parameter_Specification
2045
     (Defining_Identifier : Node_Id;
2046
      Subtype_Mark        : Node_Id;
2047
      Parameter_Mode      : Mode_Id := Mode_In;
2048
      Expression          : Node_Id := No_Node) return Node_Id
2049
   is
2050 1
      P : Node_Id;
2051

2052
   begin
2053 1
      P := New_Node (K_Parameter_Specification);
2054 1
      Set_Defining_Identifier (P, Defining_Identifier);
2055 1
      Set_Parameter_Type (P, Subtype_Mark);
2056 1
      Set_Parameter_Mode (P, Parameter_Mode);
2057 1
      Set_Expression (P, Expression);
2058 1
      return P;
2059
   end Make_Parameter_Specification;
2060

2061
   ---------------------------
2062
   -- Make_Pragma_Statement --
2063
   ---------------------------
2064

2065 1
   function Make_Pragma_Statement
2066
     (The_Pragma    : Pragma_Id;
2067
      Argument_List : List_Id := No_List) return Node_Id
2068
   is
2069 1
      N : Node_Id;
2070
   begin
2071 1
      N := New_Node (K_Pragma_Statement);
2072

2073 1
      Set_Defining_Identifier (N, Make_Defining_Identifier (GN (The_Pragma)));
2074 1
      Set_Argument_List (N, Argument_List);
2075 1
      return N;
2076
   end Make_Pragma_Statement;
2077

2078
   --------------------------------
2079
   -- Make_Protected_Object_Spec --
2080
   --------------------------------
2081

2082 1
   function Make_Protected_Object_Spec
2083
     (Defining_Identifier : Node_Id;
2084
      Visible_Part        : List_Id;
2085
      Private_Part        : List_Id;
2086
      Parent              : Node_Id := Current_Package;
2087
      Is_Type             : Boolean := False) return Node_Id
2088
   is
2089 1
      N : Node_Id;
2090
   begin
2091 1
      N := New_Node (K_Protected_Object_Spec);
2092 1
      Set_Defining_Identifier (N, Defining_Identifier);
2093 1
      Set_Visible_Part (N, Visible_Part);
2094 1
      Set_Private_Part (N, Private_Part);
2095 1
      Set_Parent (N, Parent);
2096 1
      Set_Is_Type (N, Is_Type);
2097 1
      return N;
2098
   end Make_Protected_Object_Spec;
2099

2100
   --------------------------------
2101
   -- Make_Protected_Object_Body --
2102
   --------------------------------
2103

2104 1
   function Make_Protected_Object_Body
2105
     (Defining_Identifier : Node_Id;
2106
      Statements          : List_Id) return Node_Id
2107
   is
2108 1
      N : Node_Id;
2109
   begin
2110 1
      N := New_Node (K_Protected_Object_Body);
2111 1
      Set_Defining_Identifier (N, Defining_Identifier);
2112 1
      Set_Statements (N, Statements);
2113 1
      return N;
2114
   end Make_Protected_Object_Body;
2115

2116
   -------------------------------
2117
   -- Make_Qualified_Expression --
2118
   -------------------------------
2119

2120 1
   function Make_Qualified_Expression
2121
     (Subtype_Mark : Node_Id;
2122
      Aggregate    : Node_Id) return Node_Id
2123
   is
2124 1
      N : Node_Id;
2125
   begin
2126 1
      N := New_Node (K_Qualified_Expression);
2127 1
      Set_Subtype_Mark (N, Subtype_Mark);
2128 1
      Set_Aggregate (N, Aggregate);
2129 1
      return N;
2130
   end Make_Qualified_Expression;
2131

2132
   --------------------------
2133
   -- Make_Raise_Statement --
2134
   --------------------------
2135

2136 1
   function Make_Raise_Statement
2137
     (Raised_Error : Node_Id := No_Node) return Node_Id
2138
   is
2139 1
      N : Node_Id;
2140
   begin
2141 1
      N := New_Node (K_Raise_Statement);
2142 1
      Set_Raised_Error (N, Raised_Error);
2143 1
      return N;
2144
   end Make_Raise_Statement;
2145

2146
   ---------------------------
2147
   -- Make_Range_Constraint --
2148
   ---------------------------
2149

2150 1
   function Make_Range_Constraint
2151
     (First      : Node_Id;
2152
      Last       : Node_Id;
2153
      Index_Type : Node_Id := No_Node) return Node_Id
2154
   is
2155 1
      N : Node_Id;
2156
   begin
2157 1
      N := New_Node (K_Range_Constraint);
2158 1
      Set_First (N, First);
2159 1
      Set_Last (N, Last);
2160 1
      Set_Index_Type (N, Index_Type);
2161 1
      return N;
2162
   end Make_Range_Constraint;
2163

2164
   ---------------------------
2165
   -- Make_Record_Aggregate --
2166
   ---------------------------
2167

2168 1
   function Make_Record_Aggregate (L : List_Id) return Node_Id is
2169 1
      N : Node_Id;
2170
   begin
2171 1
      N := New_Node (K_Record_Aggregate);
2172 1
      Set_Component_Association_List (N, L);
2173 1
      return N;
2174
   end Make_Record_Aggregate;
2175

2176
   ----------------------------
2177
   -- Make_Record_Definition --
2178
   ----------------------------
2179

2180 1
   function Make_Record_Definition (Component_List : List_Id) return Node_Id is
2181 1
      N : Node_Id;
2182

2183
   begin
2184 1
      N := New_Node (K_Record_Definition);
2185 1
      Set_Component_List (N, Component_List);
2186 1
      return N;
2187
   end Make_Record_Definition;
2188

2189
   ---------------------------------
2190
   -- Make_Record_Type_Definition --
2191
   ---------------------------------
2192

2193 1
   function Make_Record_Type_Definition
2194
     (Record_Definition : Node_Id;
2195
      Is_Abstract_Type  : Boolean := False;
2196
      Is_Tagged_Type    : Boolean := False;
2197
      Is_Limited_Type   : Boolean := False) return Node_Id
2198
   is
2199 1
      N : Node_Id;
2200

2201
   begin
2202 1
      N := New_Node (K_Record_Type_Definition);
2203 1
      Set_Is_Abstract_Type (N, Is_Abstract_Type);
2204 1
      Set_Is_Tagged_Type (N, Is_Tagged_Type);
2205 1
      Set_Is_Limited_Type (N, Is_Limited_Type);
2206 1
      Set_Record_Definition (N, Record_Definition);
2207 1
      return N;
2208
   end Make_Record_Type_Definition;
2209

2210
   ---------------------------
2211
   -- Make_Return_Statement --
2212
   ---------------------------
2213

2214 1
   function Make_Return_Statement (Expression : Node_Id) return Node_Id is
2215 1
      N : Node_Id;
2216
   begin
2217 1
      N := New_Node (K_Return_Statement);
2218 1
      Set_Expression (N, Expression);
2219 1
      return N;
2220
   end Make_Return_Statement;
2221

2222
   -----------------------------
2223
   -- Make_Selected_Component --
2224
   -----------------------------
2225

2226 1
   function Make_Selected_Component
2227
     (Prefix        : Node_Id;
2228
      Selector_Name : Node_Id) return Node_Id
2229
   is
2230 1
      N : Node_Id;
2231
   begin
2232 1
      N := New_Node (K_Selected_Component);
2233 1
      Set_Prefix (N, Prefix);
2234 1
      Set_Selector_Name (N, Selector_Name);
2235 1
      return N;
2236
   end Make_Selected_Component;
2237

2238
   --------------------------
2239
   -- Make_Subprogram_Call --
2240
   --------------------------
2241

2242 1
   function Make_Subprogram_Call
2243
     (Defining_Identifier   : Node_Id;
2244
      Actual_Parameter_Part : List_Id := No_List) return Node_Id
2245
   is
2246 1
      N : Node_Id;
2247
   begin
2248 1
      N := New_Node (K_Subprogram_Call);
2249 1
      Set_Defining_Identifier (N, Defining_Identifier);
2250 1
      Set_Actual_Parameter_Part (N, Actual_Parameter_Part);
2251 1
      return N;
2252
   end Make_Subprogram_Call;
2253

2254
   ------------------------------------
2255
   -- Make_Subprogram_Implementation --
2256
   ------------------------------------
2257

2258 1
   function Make_Subprogram_Implementation
2259
     (Specification        : Node_Id;
2260
      Declarations         : List_Id;
2261
      Statements           : List_Id;
2262
      Aspect_Specification : Node_Id := No_Node) return Node_Id
2263
   is
2264 1
      N : Node_Id;
2265

2266
   begin
2267 1
      N := New_Node (K_Subprogram_Implementation);
2268 1
      Set_Specification (N, Specification);
2269 1
      if Present (Aspect_Specification) then
2270 0
         Set_Aspect_Specification (ADN.Specification (N),
2271
                                   Aspect_Specification);
2272
      end if;
2273

2274 1
      Set_Declarations (N, Declarations);
2275 1
      Set_Statements (N, Statements);
2276 1
      return N;
2277
   end Make_Subprogram_Implementation;
2278

2279
   -----------------------------------
2280
   -- Make_Subprogram_Specification --
2281
   -----------------------------------
2282

2283 1
   function Make_Subprogram_Specification
2284
     (Defining_Identifier     : Node_Id;
2285
      Parameter_Profile       : List_Id;
2286
      Return_Type             : Node_Id := No_Node;
2287
      Aspect_Specification    : Node_Id := No_Node;
2288
      Parent                  : Node_Id := Current_Package;
2289
      Renamed_Subprogram      : Node_Id := No_Node;
2290
      Instantiated_Subprogram : Node_Id := No_Node) return Node_Id
2291
   is
2292 1
      N : Node_Id;
2293
   begin
2294 1
      N := New_Node (K_Subprogram_Specification);
2295 1
      Set_Defining_Identifier (N, Defining_Identifier);
2296 1
      Set_Parameter_Profile (N, Parameter_Profile);
2297 1
      Set_Return_Type (N, Return_Type);
2298 1
      Set_Aspect_Specification (N, Aspect_Specification);
2299 1
      Set_Parent (N, Parent);
2300 1
      Set_Renamed_Entity (N, Renamed_Subprogram);
2301 1
      Set_Instantiated_Entity (N, Instantiated_Subprogram);
2302 1
      return N;
2303
   end Make_Subprogram_Specification;
2304

2305
   -------------------------
2306
   -- Make_Type_Attribute --
2307
   -------------------------
2308

2309 0
   function Make_Type_Attribute
2310
     (Designator : Node_Id;
2311
      Attribute  : Attribute_Id) return Node_Id
2312
   is
2313
      procedure Get_Scoped_Name_String (S : Node_Id);
2314

2315
      ----------------------------
2316
      -- Get_Scoped_Name_String --
2317
      ----------------------------
2318

2319 0
      procedure Get_Scoped_Name_String (S : Node_Id) is
2320 0
         P : Node_Id;
2321

2322
      begin
2323 0
         P := Parent_Unit_Name (S);
2324 0
         if Present (P) then
2325 0
            Get_Scoped_Name_String (P);
2326 0
            Add_Char_To_Name_Buffer ('.');
2327
         end if;
2328 0
         Get_Name_String_And_Append (Name (Defining_Identifier (S)));
2329 0
      end Get_Scoped_Name_String;
2330

2331
   begin
2332 0
      Name_Len := 0;
2333 0
      Get_Scoped_Name_String (Designator);
2334 0
      Add_Char_To_Name_Buffer (''');
2335 0
      Get_Name_String_And_Append (AN (Attribute));
2336 0
      return Make_Defining_Identifier (Name_Find);
2337
   end Make_Type_Attribute;
2338

2339
   --------------------------
2340
   -- Make_Type_Conversion --
2341
   --------------------------
2342

2343 0
   function Make_Type_Conversion
2344
     (Subtype_Mark : Node_Id;
2345
      Expression   : Node_Id) return Node_Id
2346
   is
2347 0
      N : Node_Id;
2348
   begin
2349 0
      N := New_Node (K_Type_Conversion);
2350 0
      Set_Subtype_Mark (N, Subtype_Mark);
2351 0
      Set_Expression (N, Expression);
2352 0
      return N;
2353
   end Make_Type_Conversion;
2354

2355
   --------------------
2356
   -- Make_Used_Type --
2357
   --------------------
2358

2359 1
   function Make_Used_Type (The_Used_Type : Node_Id) return Node_Id is
2360 1
      N : Node_Id;
2361
   begin
2362 1
      N := New_Node (K_Used_Type);
2363

2364 1
      Set_The_Used_Entity (N, The_Used_Type);
2365 1
      return N;
2366
   end Make_Used_Type;
2367

2368
   -------------------------
2369
   -- Make_Withed_Package --
2370
   -------------------------
2371

2372 1
   function Make_Withed_Package
2373
     (Defining_Identifier : Node_Id;
2374
      Used                : Boolean := False;
2375
      Warnings_Off        : Boolean := False;
2376
      Elaborated          : Boolean := False) return Node_Id
2377
   is
2378 1
      N : Node_Id;
2379
   begin
2380 1
      N := New_Node (K_Withed_Package);
2381 1
      Set_Defining_Identifier (N, Defining_Identifier);
2382 1
      Set_Used (N, Used);
2383 1
      Set_Warnings_Off (N, Warnings_Off);
2384 1
      Set_Elaborated (N, Elaborated);
2385 1
      return N;
2386
   end Make_Withed_Package;
2387

2388
   -----------------------
2389
   -- Make_Used_Package --
2390
   -----------------------
2391

2392 1
   function Make_Used_Package (The_Used_Package : Node_Id) return Node_Id is
2393 1
      N : Node_Id;
2394
   begin
2395 1
      N := New_Node (K_Used_Package);
2396

2397 1
      Set_The_Used_Entity (N, The_Used_Package);
2398 1
      return N;
2399
   end Make_Used_Package;
2400

2401
   -----------------------
2402
   -- Make_Variant_Part --
2403
   -----------------------
2404

2405 1
   function Make_Variant_Part
2406
     (Discriminant : Node_Id;
2407
      Variant_List : List_Id) return Node_Id
2408
   is
2409 1
      N : Node_Id;
2410

2411
   begin
2412 1
      N := New_Node (K_Variant_Part);
2413 1
      Set_Variants (N, Variant_List);
2414 1
      Set_Discriminant (N, Discriminant);
2415 1
      return N;
2416
   end Make_Variant_Part;
2417

2418
   -------------------------
2419
   -- Make_Comment_Header --
2420
   -------------------------
2421

2422 1
   procedure Make_Comment_Header (Package_Header : List_Id) is
2423 1
      N : Node_Id;
2424
   begin
2425
      --  Appending the comment header lines to the package header
2426

2427 1
      Set_Str_To_Name_Buffer
2428
        ("------------------------------------------------------");
2429 1
      N := Make_Ada_Comment (Name_Find, False);
2430 1
      Append_Node_To_List (N, Package_Header);
2431

2432 1
      Set_Str_To_Name_Buffer
2433
        ("This file was automatically generated by Ocarina  --");
2434 1
      N := Make_Ada_Comment (Name_Find);
2435 1
      Append_Node_To_List (N, Package_Header);
2436

2437 1
      Set_Str_To_Name_Buffer
2438
        (SCM_Version.all);
2439 1
      N := Make_Ada_Comment (Name_Find);
2440 1
      Append_Node_To_List (N, Package_Header);
2441

2442 1
      Set_Str_To_Name_Buffer
2443
        ("Do NOT hand-modify this file, as your             --");
2444 1
      N := Make_Ada_Comment (Name_Find);
2445 1
      Append_Node_To_List (N, Package_Header);
2446

2447 1
      Set_Str_To_Name_Buffer
2448
        ("changes will be lost when you re-run Ocarina      --");
2449 1
      N := Make_Ada_Comment (Name_Find);
2450 1
      Append_Node_To_List (N, Package_Header);
2451

2452 1
      Set_Str_To_Name_Buffer
2453
        ("------------------------------------------------------");
2454 1
      N := Make_Ada_Comment (Name_Find, False);
2455 1
      Append_Node_To_List (N, Package_Header);
2456

2457 1
   end Make_Comment_Header;
2458

2459
   -----------------
2460
   -- Next_N_Node --
2461
   -----------------
2462

2463 0
   function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id is
2464 0
      Result : Node_Id := N;
2465
   begin
2466 0
      for I in 1 .. Num loop
2467 0
         Result := Next_Node (Result);
2468 0
      end loop;
2469

2470 0
      return Result;
2471
   end Next_N_Node;
2472

2473
   --------------
2474
   -- New_List --
2475
   --------------
2476

2477 1
   function New_List
2478
     (Kind : Node_Kind;
2479
      From : Node_Id := No_Node) return List_Id
2480
   is
2481 1
      N : Node_Id;
2482

2483
   begin
2484 1
      Entries.Increment_Last;
2485 1
      N                 := Entries.Last;
2486
      Entries.Table (N) := Default_Node;
2487 1
      Set_Kind (N, Kind);
2488 1
      if Present (From) then
2489 0
         Set_Loc (N, Loc (From));
2490
      else
2491 1
         Set_Loc (N, No_Location);
2492
      end if;
2493 1
      return List_Id (N);
2494
   end New_List;
2495

2496
   --------------
2497
   -- New_Node --
2498
   --------------
2499

2500 1
   function New_Node
2501
     (Kind : Node_Kind;
2502
      From : Node_Id := No_Node) return Node_Id
2503
   is
2504 1
      N : Node_Id;
2505
   begin
2506 1
      Entries.Increment_Last;
2507 1
      N                 := Entries.Last;
2508
      Entries.Table (N) := Default_Node;
2509 1
      Set_Kind (N, Kind);
2510

2511 1
      if Present (From) then
2512 1
         Set_Loc (N, AAN.Loc (From));
2513
      else
2514 1
         Set_Loc (N, No_Location);
2515
      end if;
2516

2517 1
      return N;
2518
   end New_Node;
2519

2520
   ---------------
2521
   -- New_Token --
2522
   ---------------
2523

2524 1
   procedure New_Token (T : Token_Type; I : String := "") is
2525 1
      Name : Name_Id;
2526
   begin
2527 1
      if T in Keyword_Type then
2528
         --  Marking the token image as a keyword for fast searching
2529
         --  purpose, we add the prefix to avoir collision with other
2530
         --  languages keywords
2531

2532 1
         Set_Str_To_Name_Buffer (Image (T));
2533 1
         Name := Name_Find;
2534 1
         Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
2535
         Set_Name_Table_Byte (Name, Byte (Token_Type'Pos (T) + 1));
2536

2537 1
         Set_Str_To_Name_Buffer (Image (T));
2538
      else
2539 1
         Set_Str_To_Name_Buffer (I);
2540
      end if;
2541
      Token_Image (T) := Name_Find;
2542 1
   end New_Token;
2543

2544
   ------------------
2545
   -- New_Operator --
2546
   ------------------
2547

2548 1
   procedure New_Operator (O : Operator_Type; I : String := "") is
2549
   begin
2550 1
      if O in Keyword_Operator then
2551 1
         Set_Str_To_Name_Buffer (Image (O));
2552
      else
2553 1
         Set_Str_To_Name_Buffer (I);
2554
      end if;
2555
      Operator_Image (Operator_Type'Pos (O)) := Name_Find;
2556 1
   end New_Operator;
2557

2558
   ----------------
2559
   -- Pop_Entity --
2560
   ----------------
2561

2562 1
   procedure Pop_Entity is
2563
   begin
2564 1
      if Last > No_Depth then
2565 1
         Decrement_Last;
2566
      end if;
2567 1
   end Pop_Entity;
2568

2569
   -----------------
2570
   -- Push_Entity --
2571
   -----------------
2572

2573 1
   procedure Push_Entity (E : Node_Id) is
2574
   begin
2575 1
      Increment_Last;
2576
      Table (Last).Current_Entity := E;
2577 1
   end Push_Entity;
2578

2579
   --------------------------
2580
   -- Qualified_Designator --
2581
   --------------------------
2582

2583 0
   function Qualified_Designator (P : Node_Id) return Node_Id is
2584 0
      N : Node_Id;
2585
   begin
2586 0
      N := New_Node (K_Designator);
2587 0
      Set_Defining_Identifier (N, Make_Defining_Identifier (Name (P)));
2588 0
      if Present (Parent_Unit_Name (P)) then
2589 0
         Set_Homogeneous_Parent_Unit_Name
2590
           (N,
2591 0
            Qualified_Designator (Parent_Unit_Name (P)));
2592
      else
2593 0
         Set_Homogeneous_Parent_Unit_Name (N, No_Node);
2594
      end if;
2595

2596 0
      return N;
2597
   end Qualified_Designator;
2598

2599
   --------------------------------------------
2600
   -- Remove_Anonymous_Array_Type_Definition --
2601
   --------------------------------------------
2602

2603 1
   function Remove_Anonymous_Array_Type_Definition
2604
     (Range_Constraints    : List_Id;
2605
      Component_Definition : Node_Id;
2606
      Aliased_Present      : Boolean := False;
2607
      Variable_Name        : Node_Id;
2608
      Is_Full_Type         : Boolean := False) return Node_Id
2609
   is
2610 1
      N                : Node_Id;
2611 1
      R                : Node_Id;
2612 1
      Comp             : Node_Id          := No_Node;
2613 1
      T_Def            : Node_Id;
2614 1
      Tmp_Id           : Node_Id;
2615 1
      List_Constraints : constant List_Id := New_List (K_List_Id);
2616 1
      List_Comp        : constant List_Id := New_List (K_List_Id);
2617

2618
   begin
2619 1
      R := First_Node (Range_Constraints);
2620

2621
      loop
2622
         case Kind (R) is
2623 1
            when K_Defining_Identifier =>
2624 1
               Append_Node_To_List (R, List_Constraints);
2625

2626 1
            when K_Range_Constraint =>
2627 1
               N := Create_Subtype_From_Range_Constraint (R);
2628

2629
               --  if N is not a full type then it's an
2630
               --  unconstraint array type. In this case,
2631
               --  we need to add the the type to the list,
2632
               --  not only its identifier.
2633

2634 1
               if Kind (N) = K_Full_Type_Declaration then
2635 1
                  Append_Node_To_List
2636 1
                    (Defining_Identifier (N),
2637
                     List_Constraints);
2638
               else
2639 0
                  Append_Node_To_List (N, List_Constraints);
2640
               end if;
2641

2642 0
            when others =>
2643 0
               raise Program_Error;
2644 1
         end case;
2645

2646 1
         R := Next_Node (R);
2647 1
         exit when No (R);
2648 0
      end loop;
2649

2650
      case Kind (Component_Definition) is
2651 1
         when K_Defining_Identifier =>
2652 1
            Comp := Component_Definition;
2653

2654 1
         when K_Indexed_Component =>
2655 1
            R := First_Node (Expressions (Component_Definition));
2656
            loop
2657 1
               N := Create_Subtype_From_Range_Constraint (R);
2658

2659
               --  if N is not a full type then it's an
2660
               --  unconstraint array type. In this case,
2661
               --  we need to add the the type to the list,
2662
               --  not only its identifier.
2663

2664 1
               if Kind (N) = K_Full_Type_Declaration then
2665 1
                  Append_Node_To_List (Defining_Identifier (N), List_Comp);
2666
               else
2667 0
                  Append_Node_To_List (N, List_Comp);
2668
               end if;
2669

2670 1
               R := Next_Node (R);
2671 1
               exit when No (R);
2672 0
            end loop;
2673

2674
            Comp :=
2675 1
              Make_Indexed_Component
2676 1
                (Prefix      => Nodes.Prefix (Component_Definition),
2677
                 Expressions => List_Comp);
2678

2679
            --  Create a unique name for component type
2680

2681
            Tmp_Id :=
2682 1
              Make_Defining_Identifier
2683 1
                (Create_Unique_Identifier (Name (Variable_Name), "Component"));
2684

2685
            N :=
2686 1
              Make_Full_Type_Declaration
2687
                (Defining_Identifier => Tmp_Id,
2688
                 Type_Definition     => Comp,
2689
                 Is_Subtype          => True);
2690

2691 1
            Comp := Defining_Identifier (N);
2692

2693 1
            if Get_Name_Table_Info (Name (Tmp_Id)) = Int (No_Node) then
2694 1
               Set_Name_Table_Info (Name (Tmp_Id), Int (Tmp_Id));
2695 1
               Append_Node_To_Current_Package (N);
2696
            end if;
2697

2698 1
         when others =>
2699 1
            Comp := Component_Definition;
2700 1
      end case;
2701

2702
      N :=
2703 1
        Make_Array_Type_Definition (List_Constraints, Comp, Aliased_Present);
2704

2705
      --  Add a full type node, only if the caller of
2706
      --  Remove_Anonymous_Array_Type_Definition is Make_Object_Declaration.
2707

2708 1
      if not Is_Full_Type then
2709

2710
         Tmp_Id :=
2711 1
           Make_Defining_Identifier
2712 1
             (Create_Unique_Identifier (Name (Variable_Name), "Array"));
2713

2714
         --  We don't call Make_Full_Type_Declaration in order to
2715
         --  avoid recursive calls.
2716

2717 1
         T_Def := New_Node (K_Full_Type_Declaration);
2718 1
         Set_Defining_Identifier (T_Def, Tmp_Id);
2719 1
         Set_Corresponding_Node (Tmp_Id, T_Def);
2720 1
         Set_Type_Definition (T_Def, N);
2721 1
         Set_Discriminant_Spec (T_Def, No_Node);
2722 1
         Set_Parent (T_Def, Current_Package);
2723 1
         Set_Is_Subtype (T_Def, False);
2724 1
         Set_Name_Table_Info (Name (Tmp_Id), Int (No_Node));
2725

2726 1
         if Get_Name_Table_Info (Name (Tmp_Id)) = Int (No_Node) then
2727 1
            Set_Name_Table_Info (Name (Tmp_Id), Int (Tmp_Id));
2728 1
            Append_Node_To_Current_Package (T_Def);
2729
         end if;
2730 1
         N := Defining_Identifier (T_Def);
2731
      end if;
2732

2733 1
      return N;
2734
   end Remove_Anonymous_Array_Type_Definition;
2735

2736
   ---------------------------
2737
   -- Remove_Node_From_List --
2738
   ---------------------------
2739

2740 0
   procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is
2741 0
      C : Node_Id;
2742

2743
   begin
2744 0
      C := First_Node (L);
2745 0
      if C = E then
2746 0
         Set_First_Node (L, Next_Node (E));
2747 0
         if Last_Node (L) = E then
2748 0
            Set_Last_Node (L, No_Node);
2749
         end if;
2750
      else
2751 0
         while Present (C) loop
2752 0
            if Next_Node (C) = E then
2753 0
               Set_Next_Node (C, Next_Node (E));
2754 0
               if Last_Node (L) = E then
2755 0
                  Set_Last_Node (L, C);
2756
               end if;
2757 0
               exit;
2758
            end if;
2759 0
            C := Next_Node (C);
2760 0
         end loop;
2761
      end if;
2762 0
   end Remove_Node_From_List;
2763

2764
   --------------------------------------
2765
   -- Set_Homogeneous_Parent_Unit_Name --
2766
   --------------------------------------
2767

2768 1
   procedure Set_Homogeneous_Parent_Unit_Name
2769
     (Child  : Node_Id;
2770
      Parent : Node_Id)
2771
   is
2772
   begin
2773
      pragma Assert
2774
        (ADN.Kind (Child) = K_Defining_Identifier
2775 1
         or else ADN.Kind (Child) = K_Designator);
2776

2777
      pragma Assert
2778
        (Parent = No_Node
2779 1
         or else ADN.Kind (Parent) = K_Defining_Identifier
2780 1
         or else ADN.Kind (Parent) = K_Designator);
2781

2782
      case ADN.Kind (Child) is
2783

2784 1
         when K_Defining_Identifier =>
2785 1
            if Parent = No_Node then
2786 1
               Set_Parent_Unit_Name (Child, Parent);
2787 1
            elsif ADN.Kind (Parent) = K_Defining_Identifier then
2788 1
               Set_Parent_Unit_Name (Child, Parent);
2789 1
            elsif ADN.Kind (Parent) = K_Designator then
2790 1
               Set_Parent_Unit_Name (Child, Defining_Identifier (Parent));
2791
            else
2792 0
               raise Program_Error;
2793
            end if;
2794

2795 1
         when K_Designator =>
2796 1
            if Parent = No_Node then
2797 1
               Set_Parent_Unit_Name (Child, Parent);
2798 1
               if Present (Defining_Identifier (Child)) then
2799 1
                  Set_Parent_Unit_Name (Defining_Identifier (Child), Parent);
2800
               end if;
2801 1
            elsif ADN.Kind (Parent) = K_Defining_Identifier then
2802 0
               Set_Parent_Unit_Name
2803
                 (Child,
2804 0
                  Defining_Identifier_To_Designator (Parent));
2805 0
               if Present (Defining_Identifier (Child)) then
2806 0
                  Set_Parent_Unit_Name (Defining_Identifier (Child), Parent);
2807
               end if;
2808 1
            elsif ADN.Kind (Parent) = K_Designator then
2809 1
               Set_Parent_Unit_Name (Child, Parent);
2810 1
               if Present (Defining_Identifier (Child)) then
2811 1
                  Set_Parent_Unit_Name
2812 1
                    (Defining_Identifier (Child),
2813 1
                     Defining_Identifier (Parent));
2814
               end if;
2815
            else
2816 0
               raise Program_Error;
2817
            end if;
2818

2819 0
         when others =>
2820 0
            raise Program_Error;
2821

2822 1
      end case;
2823 1
   end Set_Homogeneous_Parent_Unit_Name;
2824

2825
   -------------------
2826
   -- Set_Main_Body --
2827
   -------------------
2828

2829 1
   procedure Set_Main_Body (N : Node_Id := No_Node) is
2830 1
      X : Node_Id := N;
2831
   begin
2832 1
      if No (X) then
2833
         X := Table (Last).Current_Entity;
2834
      end if;
2835
      Table (Last).Current_Package :=
2836 1
        Subprogram_Implementation (Main_Subprogram (X));
2837 1
   end Set_Main_Body;
2838

2839
   -------------------
2840
   -- Set_Main_Spec --
2841
   -------------------
2842

2843 0
   procedure Set_Main_Spec (N : Node_Id := No_Node) is
2844 0
      X : Node_Id := N;
2845
   begin
2846 0
      if No (X) then
2847 0
         X := Table (Last).Current_Entity;
2848
      end if;
2849 0
      Table (Last).Current_Package :=
2850 0
        Subprogram_Specification (Main_Subprogram (X));
2851 0
   end Set_Main_Spec;
2852

2853
   --------------------------
2854
   -- Set_Marshallers_Spec --
2855
   --------------------------
2856

2857 1
   procedure Set_Marshallers_Spec (N : Node_Id := No_Node) is
2858 1
      X : Node_Id := N;
2859
   begin
2860 1
      if No (X) then
2861
         X := Table (Last).Current_Entity;
2862
      end if;
2863
      Table (Last).Current_Package :=
2864 1
        Package_Specification (Marshallers_Package (X));
2865 1
   end Set_Marshallers_Spec;
2866

2867
   --------------------------
2868
   -- Set_Marshallers_Body --
2869
   --------------------------
2870

2871 1
   procedure Set_Marshallers_Body (N : Node_Id := No_Node) is
2872 1
      X : Node_Id := N;
2873
   begin
2874 1
      if No (X) then
2875
         X := Table (Last).Current_Entity;
2876
      end if;
2877
      Table (Last).Current_Package :=
2878 1
        Package_Implementation (Marshallers_Package (X));
2879 1
   end Set_Marshallers_Body;
2880

2881
   -----------------------
2882
   -- Set_Activity_Body --
2883
   -----------------------
2884

2885 1
   procedure Set_Activity_Body (N : Node_Id := No_Node) is
2886 1
      X : Node_Id := N;
2887
   begin
2888 1
      if No (X) then
2889
         X := Table (Last).Current_Entity;
2890
      end if;
2891
      Table (Last).Current_Package :=
2892 1
        Package_Implementation (Activity_Package (X));
2893 1
   end Set_Activity_Body;
2894

2895
   -----------------------
2896
   -- Set_Activity_Spec --
2897
   -----------------------
2898

2899 1
   procedure Set_Activity_Spec (N : Node_Id := No_Node) is
2900 1
      X : Node_Id := N;
2901
   begin
2902 1
      if No (X) then
2903
         X := Table (Last).Current_Entity;
2904
      end if;
2905
      Table (Last).Current_Package :=
2906 1
        Package_Specification (Activity_Package (X));
2907 1
   end Set_Activity_Spec;
2908

2909
   ------------------
2910
   -- Set_Job_Body --
2911
   ------------------
2912

2913 1
   procedure Set_Job_Body (N : Node_Id := No_Node) is
2914 1
      X : Node_Id := N;
2915
   begin
2916 1
      if No (X) then
2917
         X := Table (Last).Current_Entity;
2918
      end if;
2919
      Table (Last).Current_Package :=
2920 1
        Package_Implementation (Job_Package (X));
2921 1
   end Set_Job_Body;
2922

2923
   ------------------
2924
   -- Set_Job_Spec --
2925
   ------------------
2926

2927 1
   procedure Set_Job_Spec (N : Node_Id := No_Node) is
2928 1
      X : Node_Id := N;
2929
   begin
2930 1
      if No (X) then
2931
         X := Table (Last).Current_Entity;
2932
      end if;
2933
      Table (Last).Current_Package :=
2934 1
        Package_Specification (Job_Package (X));
2935 1
   end Set_Job_Spec;
2936

2937
   ------------------------
2938
   -- Set_Transport_Body --
2939
   ------------------------
2940

2941 1
   procedure Set_Transport_Body (N : Node_Id := No_Node) is
2942 1
      X : Node_Id := N;
2943
   begin
2944 1
      if No (X) then
2945
         X := Table (Last).Current_Entity;
2946
      end if;
2947
      Table (Last).Current_Package :=
2948 1
        Package_Implementation (Transport_Package (X));
2949 1
   end Set_Transport_Body;
2950

2951
   ------------------------
2952
   -- Set_Transport_Spec --
2953
   ------------------------
2954

2955 1
   procedure Set_Transport_Spec (N : Node_Id := No_Node) is
2956 1
      X : Node_Id := N;
2957
   begin
2958 1
      if No (X) then
2959
         X := Table (Last).Current_Entity;
2960
      end if;
2961
      Table (Last).Current_Package :=
2962 1
        Package_Specification (Transport_Package (X));
2963 1
   end Set_Transport_Spec;
2964

2965
   --------------------
2966
   -- Set_Types_Body --
2967
   --------------------
2968

2969 1
   procedure Set_Types_Body (N : Node_Id := No_Node) is
2970 1
      X : Node_Id := N;
2971
   begin
2972 1
      if No (X) then
2973
         X := Table (Last).Current_Entity;
2974
      end if;
2975
      Table (Last).Current_Package :=
2976 1
        Package_Implementation (Types_Package (X));
2977 1
   end Set_Types_Body;
2978

2979
   --------------------
2980
   -- Set_Types_Spec --
2981
   --------------------
2982

2983 1
   procedure Set_Types_Spec (N : Node_Id := No_Node) is
2984 1
      X : Node_Id := N;
2985
   begin
2986 1
      if No (X) then
2987
         X := Table (Last).Current_Entity;
2988
      end if;
2989
      Table (Last).Current_Package :=
2990 1
        Package_Specification (Types_Package (X));
2991 1
   end Set_Types_Spec;
2992

2993
   --------------------------
2994
   -- Set_Subprograms_Body --
2995
   --------------------------
2996

2997 1
   procedure Set_Subprograms_Body (N : Node_Id := No_Node) is
2998 1
      X : Node_Id := N;
2999
   begin
3000 1
      if No (X) then
3001
         X := Table (Last).Current_Entity;
3002
      end if;
3003
      Table (Last).Current_Package :=
3004 1
        Package_Implementation (Subprograms_Package (X));
3005 1
   end Set_Subprograms_Body;
3006

3007
   --------------------------
3008
   -- Set_Subprograms_Spec --
3009
   --------------------------
3010

3011 1
   procedure Set_Subprograms_Spec (N : Node_Id := No_Node) is
3012 1
      X : Node_Id := N;
3013
   begin
3014 1
      if No (X) then
3015
         X := Table (Last).Current_Entity;
3016
      end if;
3017
      Table (Last).Current_Package :=
3018 1
        Package_Specification (Subprograms_Package (X));
3019 1
   end Set_Subprograms_Spec;
3020

3021
   -------------------------
3022
   -- Set_Deployment_Spec --
3023
   -------------------------
3024

3025 1
   procedure Set_Deployment_Spec (N : Node_Id := No_Node) is
3026 1
      X : Node_Id := N;
3027
   begin
3028 1
      if No (X) then
3029
         X := Table (Last).Current_Entity;
3030
      end if;
3031
      Table (Last).Current_Package :=
3032 1
        Package_Specification (Deployment_Package (X));
3033 1
   end Set_Deployment_Spec;
3034

3035
   ---------------------
3036
   -- Set_Naming_Spec --
3037
   ---------------------
3038

3039 1
   procedure Set_Naming_Spec (N : Node_Id := No_Node) is
3040 1
      X : Node_Id := N;
3041
   begin
3042 1
      if No (X) then
3043
         X := Table (Last).Current_Entity;
3044
      end if;
3045
      Table (Last).Current_Package :=
3046 1
        Package_Specification (Naming_Package (X));
3047 1
   end Set_Naming_Spec;
3048

3049
   -----------------
3050
   -- To_Ada_Name --
3051
   -----------------
3052

3053 1
   function To_Ada_Name (N : Name_Id) return Name_Id is
3054 1
      First     : Natural := 1;
3055 1
      Name      : Name_Id;
3056 1
      Test_Name : Name_Id;
3057 1
      V         : Byte;
3058
   begin
3059 1
      Get_Name_String (Normalize_Name (N));
3060
      while First <= Name_Len and then Name_Buffer (First) = '_' loop
3061 0
         First := First + 1;
3062 0
      end loop;
3063

3064 1
      for I in First .. Name_Len loop
3065
         if Name_Buffer (I) = '_'
3066 1
           and then I < Name_Len
3067
           and then Name_Buffer (I + 1) = '_'
3068
         then
3069 0
            Name_Buffer (I + 1) := 'U';
3070
         end if;
3071 1
      end loop;
3072

3073
      if Name_Buffer (Name_Len) = '_' then
3074 0
         Add_Char_To_Name_Buffer ('U');
3075
      end if;
3076 1
      Name := Name_Find;
3077

3078
      --  If the identifier collides with an Ada reserved word insert
3079
      --  "AADL_" string before the identifier.
3080

3081 1
      Test_Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
3082 1
      V         := Get_Name_Table_Byte (Test_Name);
3083 1
      if V > 0 then
3084 1
         Set_Str_To_Name_Buffer ("AADL_");
3085 1
         Get_Name_String_And_Append (Name);
3086 1
         Name := Name_Find;
3087
      end if;
3088

3089 1
      return Name;
3090
   end To_Ada_Name;
3091

3092
   ------------------------
3093
   -- Extract_Designator --
3094
   ------------------------
3095

3096 1
   function Extract_Designator
3097
     (N               : Node_Id;
3098
      Add_With_Clause : Boolean := True) return Node_Id
3099
   is
3100 1
      P  : Node_Id;
3101 1
      D  : Node_Id := No_Node;
3102 1
      X  : Node_Id := N;
3103 1
      FE : Node_Id;
3104

3105
   begin
3106
      case Kind (N) is
3107 1
         when K_Full_Type_Declaration | K_Subprogram_Specification =>
3108 1
            P  := Parent (X);
3109 1
            FE := Frontend_Node (X);
3110

3111 1
         when K_Object_Declaration | K_Exception_Declaration =>
3112 1
            P  := Parent (X);
3113 1
            FE := Frontend_Node (X);
3114

3115 1
         when K_Package_Specification =>
3116 1
            X  := Package_Declaration (N);
3117 1
            P  := Parent (X);
3118 1
            FE := Frontend_Node (Distributed_Application_Unit (X));
3119

3120 1
         when K_Package_Declaration =>
3121 1
            P  := Parent (N);
3122 1
            FE := Frontend_Node (Distributed_Application_Unit (X));
3123

3124 0
         when K_Designator =>
3125 0
            return Copy_Designator (N);
3126

3127 1
         when K_Protected_Object_Spec =>
3128 1
            P := Parent (N);
3129

3130 0
         when K_Package_Instantiation =>
3131 0
            P := Parent (X);
3132

3133 0
         when others =>
3134 0
            raise Program_Error;
3135
      end case;
3136

3137
      D :=
3138 1
        Defining_Identifier_To_Designator
3139 1
          (N           => Defining_Identifier (X),
3140
           Keep_Parent => False);
3141 1
      Set_Frontend_Node (D, FE);
3142

3143 1
      if No (P) then
3144 1
         return D;
3145
      end if;
3146

3147
      --  This handles the particular case of package instanciations
3148

3149 1
      if Kind (N) = K_Full_Type_Declaration
3150 1
        and then Present (Parent_Unit_Name (Defining_Identifier (N)))
3151
        and then
3152 0
          Kind
3153 0
            (Corresponding_Node (Parent_Unit_Name (Defining_Identifier (N)))) =
3154
          K_Package_Instantiation
3155
      then
3156 0
         Set_Homogeneous_Parent_Unit_Name
3157
           (D,
3158 0
            Parent_Unit_Name (Defining_Identifier (N)));
3159 0
         P := Extract_Designator (P);
3160
      else
3161 1
         Set_Homogeneous_Parent_Unit_Name (D, Extract_Designator (P, False));
3162 1
         P := Parent_Unit_Name (D);
3163
      end if;
3164

3165
      --  Adding the with clause in the case the parent is a package
3166

3167