OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_ch10.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ C H 1 0                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Debug;    use Debug;
28
with Einfo;    use Einfo;
29
with Errout;   use Errout;
30
with Exp_Util; use Exp_Util;
31
with Elists;   use Elists;
32
with Fname;    use Fname;
33
with Fname.UF; use Fname.UF;
34
with Freeze;   use Freeze;
35
with Impunit;  use Impunit;
36
with Inline;   use Inline;
37
with Lib;      use Lib;
38
with Lib.Load; use Lib.Load;
39
with Lib.Xref; use Lib.Xref;
40
with Namet;    use Namet;
41
with Nlists;   use Nlists;
42
with Nmake;    use Nmake;
43
with Opt;      use Opt;
44
with Output;   use Output;
45
with Par_SCO;  use Par_SCO;
46
with Restrict; use Restrict;
47
with Rident;   use Rident;
48
with Rtsfind;  use Rtsfind;
49
with Sem;      use Sem;
50
with Sem_Aux;  use Sem_Aux;
51
with Sem_Ch3;  use Sem_Ch3;
52
with Sem_Ch6;  use Sem_Ch6;
53
with Sem_Ch7;  use Sem_Ch7;
54
with Sem_Ch8;  use Sem_Ch8;
55
with Sem_Dist; use Sem_Dist;
56
with Sem_Prag; use Sem_Prag;
57
with Sem_Util; use Sem_Util;
58
with Sem_Warn; use Sem_Warn;
59
with Stand;    use Stand;
60
with Sinfo;    use Sinfo;
61
with Sinfo.CN; use Sinfo.CN;
62
with Sinput;   use Sinput;
63
with Snames;   use Snames;
64
with Style;    use Style;
65
with Stylesw;  use Stylesw;
66
with Tbuild;   use Tbuild;
67
with Uname;    use Uname;
68
 
69
package body Sem_Ch10 is
70
 
71
   -----------------------
72
   -- Local Subprograms --
73
   -----------------------
74
 
75
   procedure Analyze_Context (N : Node_Id);
76
   --  Analyzes items in the context clause of compilation unit
77
 
78
   procedure Build_Limited_Views (N : Node_Id);
79
   --  Build and decorate the list of shadow entities for a package mentioned
80
   --  in a limited_with clause. If the package was not previously analyzed
81
   --  then it also performs a basic decoration of the real entities. This is
82
   --  required to do not pass non-decorated entities to the back-end.
83
   --  Implements Ada 2005 (AI-50217).
84
 
85
   procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
86
   --  Check whether the source for the body of a compilation unit must be
87
   --  included in a standalone library.
88
 
89
   procedure Check_Private_Child_Unit (N : Node_Id);
90
   --  If a with_clause mentions a private child unit, the compilation unit
91
   --  must be a member of the same family, as described in 10.1.2.
92
 
93
   procedure Check_Stub_Level (N : Node_Id);
94
   --  Verify that a stub is declared immediately within a compilation unit,
95
   --  and not in an inner frame.
96
 
97
   procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
98
   --  When a child unit appears in a context clause, the implicit withs on
99
   --  parents are made explicit, and with clauses are inserted in the context
100
   --  clause before the one for the child. If a parent in the with_clause
101
   --  is a renaming, the implicit with_clause is on the renaming whose name
102
   --  is mentioned in the with_clause, and not on the package it renames.
103
   --  N is the compilation unit whose list of context items receives the
104
   --  implicit with_clauses.
105
 
106
   function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
107
   --  Get defining entity of parent unit of a child unit. In most cases this
108
   --  is the defining entity of the unit, but for a child instance whose
109
   --  parent needs a body for inlining, the instantiation node of the parent
110
   --  has not yet been rewritten as a package declaration, and the entity has
111
   --  to be retrieved from the Instance_Spec of the unit.
112
 
113
   function Has_With_Clause
114
     (C_Unit     : Node_Id;
115
      Pack       : Entity_Id;
116
      Is_Limited : Boolean := False) return Boolean;
117
   --  Determine whether compilation unit C_Unit contains a [limited] with
118
   --  clause for package Pack. Use the flag Is_Limited to designate desired
119
   --  clause kind.
120
 
121
   procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
122
   --  If the main unit is a child unit, implicit withs are also added for
123
   --  all its ancestors.
124
 
125
   function In_Chain (E : Entity_Id) return Boolean;
126
   --  Check that the shadow entity is not already in the homonym chain, for
127
   --  example through a limited_with clause in a parent unit.
128
 
129
   procedure Install_Context_Clauses (N : Node_Id);
130
   --  Subsidiary to Install_Context and Install_Parents. Process all with
131
   --  and use clauses for current unit and its library unit if any.
132
 
133
   procedure Install_Limited_Context_Clauses (N : Node_Id);
134
   --  Subsidiary to Install_Context. Process only limited with_clauses for
135
   --  current unit. Implements Ada 2005 (AI-50217).
136
 
137
   procedure Install_Limited_Withed_Unit (N : Node_Id);
138
   --  Place shadow entities for a limited_with package in the visibility
139
   --  structures for the current compilation. Implements Ada 2005 (AI-50217).
140
 
141
   procedure Install_Withed_Unit
142
     (With_Clause     : Node_Id;
143
      Private_With_OK : Boolean := False);
144
   --  If the unit is not a child unit, make unit immediately visible. The
145
   --  caller ensures that the unit is not already currently installed. The
146
   --  flag Private_With_OK is set true in Install_Private_With_Clauses, which
147
   --  is called when compiling the private part of a package, or installing
148
   --  the private declarations of a parent unit.
149
 
150
   procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
151
   --  This procedure establishes the context for the compilation of a child
152
   --  unit. If Lib_Unit is a child library spec then the context of the parent
153
   --  is installed, and the parent itself made immediately visible, so that
154
   --  the child unit is processed in the declarative region of the parent.
155
   --  Install_Parents makes a recursive call to itself to ensure that all
156
   --  parents are loaded in the nested case. If Lib_Unit is a library body,
157
   --  the only effect of Install_Parents is to install the private decls of
158
   --  the parents, because the visible parent declarations will have been
159
   --  installed as part of the context of the corresponding spec.
160
 
161
   procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
162
   --  In the compilation of a child unit, a child of any of the  ancestor
163
   --  units is directly visible if it is visible, because the parent is in
164
   --  an enclosing scope. Iterate over context to find child units of U_Name
165
   --  or of some ancestor of it.
166
 
167
   function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
168
   --  Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
169
   --  returns True if Lib_Unit is a library spec which is a child spec, i.e.
170
   --  a library spec that has a parent. If the call to Is_Child_Spec returns
171
   --  True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
172
   --  compilation unit for the parent spec.
173
   --
174
   --  Lib_Unit can also be a subprogram body that acts as its own spec. If the
175
   --  Parent_Spec is non-empty, this is also a child unit.
176
 
177
   procedure Remove_Context_Clauses (N : Node_Id);
178
   --  Subsidiary of previous one. Remove use_ and with_clauses
179
 
180
   procedure Remove_Limited_With_Clause (N : Node_Id);
181
   --  Remove from visibility the shadow entities introduced for a package
182
   --  mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
183
 
184
   procedure Remove_Parents (Lib_Unit : Node_Id);
185
   --  Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
186
   --  contexts established by the corresponding call to Install_Parents are
187
   --  removed. Remove_Parents contains a recursive call to itself to ensure
188
   --  that all parents are removed in the nested case.
189
 
190
   procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
191
   --  Reset all visibility flags on unit after compiling it, either as a main
192
   --  unit or as a unit in the context.
193
 
194
   procedure Unchain (E : Entity_Id);
195
   --  Remove single entity from visibility list
196
 
197
   procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
198
   --  Common processing for all stubs (subprograms, tasks, packages, and
199
   --  protected cases). N is the stub to be analyzed. Once the subunit name
200
   --  is established, load and analyze. Nam is the non-overloadable entity
201
   --  for which the proper body provides a completion. Subprogram stubs are
202
   --  handled differently because they can be declarations.
203
 
204
   procedure sm;
205
   --  A dummy procedure, for debugging use, called just before analyzing the
206
   --  main unit (after dealing with any context clauses).
207
 
208
   --------------------------
209
   -- Limited_With_Clauses --
210
   --------------------------
211
 
212
   --  Limited_With clauses are the mechanism chosen for Ada 2005 to support
213
   --  mutually recursive types declared in different units. A limited_with
214
   --  clause that names package P in the context of unit U makes the types
215
   --  declared in the visible part of P available within U, but with the
216
   --  restriction that these types can only be used as incomplete types.
217
   --  The limited_with clause does not impose a semantic dependence on P,
218
   --  and it is possible for two packages to have limited_with_clauses on
219
   --  each other without creating an elaboration circularity.
220
 
221
   --  To support this feature, the analysis of a limited_with clause must
222
   --  create an abbreviated view of the package, without performing any
223
   --  semantic analysis on it. This "package abstract" contains shadow types
224
   --  that are in one-one correspondence with the real types in the package,
225
   --  and that have the properties of incomplete types.
226
 
227
   --  The implementation creates two element lists: one to chain the shadow
228
   --  entities, and one to chain the corresponding type entities in the tree
229
   --  of the package. Links between corresponding entities in both chains
230
   --  allow the compiler to select the proper view of a given type, depending
231
   --  on the context. Note that in contrast with the handling of private
232
   --  types, the limited view and the non-limited view of a type are treated
233
   --  as separate entities, and no entity exchange needs to take place, which
234
   --  makes the implementation must simpler than could be feared.
235
 
236
   ------------------------------
237
   -- Analyze_Compilation_Unit --
238
   ------------------------------
239
 
240
   procedure Analyze_Compilation_Unit (N : Node_Id) is
241
      Unit_Node     : constant Node_Id := Unit (N);
242
      Lib_Unit      : Node_Id          := Library_Unit (N);
243
      Spec_Id       : Entity_Id;
244
      Main_Cunit    : constant Node_Id := Cunit (Main_Unit);
245
      Par_Spec_Name : Unit_Name_Type;
246
      Unum          : Unit_Number_Type;
247
 
248
      procedure Check_Redundant_Withs
249
        (Context_Items      : List_Id;
250
         Spec_Context_Items : List_Id := No_List);
251
      --  Determine whether the context list of a compilation unit contains
252
      --  redundant with clauses. When checking body clauses against spec
253
      --  clauses, set Context_Items to the context list of the body and
254
      --  Spec_Context_Items to that of the spec. Parent packages are not
255
      --  examined for documentation purposes.
256
 
257
      procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
258
      --  Generate cross-reference information for the parents of child units.
259
      --  N is a defining_program_unit_name, and P_Id is the immediate parent.
260
 
261
      ---------------------------
262
      -- Check_Redundant_Withs --
263
      ---------------------------
264
 
265
      procedure Check_Redundant_Withs
266
        (Context_Items      : List_Id;
267
         Spec_Context_Items : List_Id := No_List)
268
      is
269
         Clause : Node_Id;
270
 
271
         procedure Process_Body_Clauses
272
          (Context_List      : List_Id;
273
           Clause            : Node_Id;
274
           Used              : in out Boolean;
275
           Used_Type_Or_Elab : in out Boolean);
276
         --  Examine the context clauses of a package body, trying to match the
277
         --  name entity of Clause with any list element. If the match occurs
278
         --  on a use package clause set Used to True, for a use type clause or
279
         --  pragma Elaborate[_All], set Used_Type_Or_Elab to True.
280
 
281
         procedure Process_Spec_Clauses
282
          (Context_List : List_Id;
283
           Clause       : Node_Id;
284
           Used         : in out Boolean;
285
           Withed       : in out Boolean;
286
           Exit_On_Self : Boolean := False);
287
         --  Examine the context clauses of a package spec, trying to match
288
         --  the name entity of Clause with any list element. If the match
289
         --  occurs on a use package clause, set Used to True, for a with
290
         --  package clause other than Clause, set Withed to True. Limited
291
         --  with clauses, implicitly generated with clauses and withs
292
         --  having pragmas Elaborate or Elaborate_All applied to them are
293
         --  skipped. Exit_On_Self is used to control the search loop and
294
         --  force an exit whenever Clause sees itself in the search.
295
 
296
         --------------------------
297
         -- Process_Body_Clauses --
298
         --------------------------
299
 
300
         procedure Process_Body_Clauses
301
          (Context_List      : List_Id;
302
           Clause            : Node_Id;
303
           Used              : in out Boolean;
304
           Used_Type_Or_Elab : in out Boolean)
305
         is
306
            Nam_Ent   : constant Entity_Id := Entity (Name (Clause));
307
            Cont_Item : Node_Id;
308
            Prag_Unit : Node_Id;
309
            Subt_Mark : Node_Id;
310
            Use_Item  : Node_Id;
311
 
312
            function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
313
            --  In an expanded name in a use clause, if the prefix is a renamed
314
            --  package, the entity is set to the original package as a result,
315
            --  when checking whether the package appears in a previous with
316
            --  clause, the renaming has to be taken into account, to prevent
317
            --  spurious/incorrect warnings. A common case is use of Text_IO.
318
 
319
            ---------------
320
            -- Same_Unit --
321
            ---------------
322
 
323
            function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is
324
            begin
325
               return Entity (N) = P
326
                 or else
327
                   (Present (Renamed_Object (P))
328
                     and then Entity (N) = Renamed_Object (P));
329
            end Same_Unit;
330
 
331
         --  Start of processing for Process_Body_Clauses
332
 
333
         begin
334
            Used := False;
335
            Used_Type_Or_Elab := False;
336
 
337
            Cont_Item := First (Context_List);
338
            while Present (Cont_Item) loop
339
 
340
               --  Package use clause
341
 
342
               if Nkind (Cont_Item) = N_Use_Package_Clause
343
                 and then not Used
344
               then
345
                  --  Search through use clauses
346
 
347
                  Use_Item := First (Names (Cont_Item));
348
                  while Present (Use_Item) and then not Used loop
349
 
350
                     --  Case of a direct use of the one we are looking for
351
 
352
                     if Entity (Use_Item) = Nam_Ent then
353
                        Used := True;
354
 
355
                     --  Handle nested case, as in "with P; use P.Q.R"
356
 
357
                     else
358
                        declare
359
                           UE : Node_Id;
360
 
361
                        begin
362
                           --  Loop through prefixes looking for match
363
 
364
                           UE := Use_Item;
365
                           while Nkind (UE) = N_Expanded_Name loop
366
                              if Same_Unit (Prefix (UE), Nam_Ent) then
367
                                 Used := True;
368
                                 exit;
369
                              end if;
370
 
371
                              UE := Prefix (UE);
372
                           end loop;
373
                        end;
374
                     end if;
375
 
376
                     Next (Use_Item);
377
                  end loop;
378
 
379
               --  USE TYPE clause
380
 
381
               elsif Nkind (Cont_Item) = N_Use_Type_Clause
382
                 and then not Used_Type_Or_Elab
383
               then
384
                  Subt_Mark := First (Subtype_Marks (Cont_Item));
385
                  while Present (Subt_Mark)
386
                    and then not Used_Type_Or_Elab
387
                  loop
388
                     if Same_Unit (Prefix (Subt_Mark), Nam_Ent) then
389
                        Used_Type_Or_Elab := True;
390
                     end if;
391
 
392
                     Next (Subt_Mark);
393
                  end loop;
394
 
395
               --  Pragma Elaborate or Elaborate_All
396
 
397
               elsif Nkind (Cont_Item) = N_Pragma
398
                 and then
399
                   (Pragma_Name (Cont_Item) = Name_Elaborate
400
                      or else
401
                    Pragma_Name (Cont_Item) = Name_Elaborate_All)
402
                 and then not Used_Type_Or_Elab
403
               then
404
                  Prag_Unit :=
405
                    First (Pragma_Argument_Associations (Cont_Item));
406
                  while Present (Prag_Unit)
407
                    and then not Used_Type_Or_Elab
408
                  loop
409
                     if Entity (Expression (Prag_Unit)) = Nam_Ent then
410
                        Used_Type_Or_Elab := True;
411
                     end if;
412
 
413
                     Next (Prag_Unit);
414
                  end loop;
415
               end if;
416
 
417
               Next (Cont_Item);
418
            end loop;
419
         end Process_Body_Clauses;
420
 
421
         --------------------------
422
         -- Process_Spec_Clauses --
423
         --------------------------
424
 
425
         procedure Process_Spec_Clauses
426
          (Context_List : List_Id;
427
           Clause       : Node_Id;
428
           Used         : in out Boolean;
429
           Withed       : in out Boolean;
430
           Exit_On_Self : Boolean := False)
431
         is
432
            Nam_Ent   : constant Entity_Id := Entity (Name (Clause));
433
            Cont_Item : Node_Id;
434
            Use_Item  : Node_Id;
435
 
436
         begin
437
            Used := False;
438
            Withed := False;
439
 
440
            Cont_Item := First (Context_List);
441
            while Present (Cont_Item) loop
442
 
443
               --  Stop the search since the context items after Cont_Item have
444
               --  already been examined in a previous iteration of the reverse
445
               --  loop in Check_Redundant_Withs.
446
 
447
               if Exit_On_Self
448
                 and Cont_Item = Clause
449
               then
450
                  exit;
451
               end if;
452
 
453
               --  Package use clause
454
 
455
               if Nkind (Cont_Item) = N_Use_Package_Clause
456
                 and then not Used
457
               then
458
                  Use_Item := First (Names (Cont_Item));
459
                  while Present (Use_Item) and then not Used loop
460
                     if Entity (Use_Item) = Nam_Ent then
461
                        Used := True;
462
                     end if;
463
 
464
                     Next (Use_Item);
465
                  end loop;
466
 
467
               --  Package with clause. Avoid processing self, implicitly
468
               --  generated with clauses or limited with clauses. Note that
469
               --  we examine with clauses having pragmas Elaborate or
470
               --  Elaborate_All applied to them due to cases such as:
471
 
472
               --     with Pack;
473
               --     with Pack;
474
               --     pragma Elaborate (Pack);
475
               --
476
               --  In this case, the second with clause is redundant since
477
               --  the pragma applies only to the first "with Pack;".
478
 
479
               elsif Nkind (Cont_Item) = N_With_Clause
480
                 and then not Implicit_With (Cont_Item)
481
                 and then not Limited_Present (Cont_Item)
482
                 and then Cont_Item /= Clause
483
                 and then Entity (Name (Cont_Item)) = Nam_Ent
484
               then
485
                  Withed := True;
486
               end if;
487
 
488
               Next (Cont_Item);
489
            end loop;
490
         end Process_Spec_Clauses;
491
 
492
      --  Start of processing for Check_Redundant_Withs
493
 
494
      begin
495
         Clause := Last (Context_Items);
496
         while Present (Clause) loop
497
 
498
            --  Avoid checking implicitly generated with clauses, limited with
499
            --  clauses or withs that have pragma Elaborate or Elaborate_All.
500
 
501
            if Nkind (Clause) = N_With_Clause
502
              and then not Implicit_With (Clause)
503
              and then not Limited_Present (Clause)
504
              and then not Elaborate_Present (Clause)
505
            then
506
               --  Package body-to-spec check
507
 
508
               if Present (Spec_Context_Items) then
509
                  declare
510
                     Used_In_Body      : Boolean := False;
511
                     Used_In_Spec      : Boolean := False;
512
                     Used_Type_Or_Elab : Boolean := False;
513
                     Withed_In_Spec    : Boolean := False;
514
 
515
                  begin
516
                     Process_Spec_Clauses
517
                      (Context_List => Spec_Context_Items,
518
                       Clause       => Clause,
519
                       Used         => Used_In_Spec,
520
                       Withed       => Withed_In_Spec);
521
 
522
                     Process_Body_Clauses
523
                      (Context_List      => Context_Items,
524
                       Clause            => Clause,
525
                       Used              => Used_In_Body,
526
                       Used_Type_Or_Elab => Used_Type_Or_Elab);
527
 
528
                     --  "Type Elab" refers to the presence of either a use
529
                     --  type clause, pragmas Elaborate or Elaborate_All.
530
 
531
                     --  +---------------+---------------------------+------+
532
                     --  | Spec          | Body                      | Warn |
533
                     --  +--------+------+--------+------+-----------+------+
534
                     --  | Withed | Used | Withed | Used | Type Elab |      |
535
                     --  |   X    |      |   X    |      |           |  X   |
536
                     --  |   X    |      |   X    |  X   |           |      |
537
                     --  |   X    |      |   X    |      |     X     |      |
538
                     --  |   X    |      |   X    |  X   |     X     |      |
539
                     --  |   X    |  X   |   X    |      |           |  X   |
540
                     --  |   X    |  X   |   X    |      |     X     |      |
541
                     --  |   X    |  X   |   X    |  X   |           |  X   |
542
                     --  |   X    |  X   |   X    |  X   |     X     |      |
543
                     --  +--------+------+--------+------+-----------+------+
544
 
545
                     if (Withed_In_Spec
546
                           and then not Used_Type_Or_Elab)
547
                             and then
548
                               ((not Used_In_Spec
549
                                   and then not Used_In_Body)
550
                                     or else
551
                                       Used_In_Spec)
552
                     then
553
                        Error_Msg_N -- CODEFIX
554
                          ("?redundant with clause in body", Clause);
555
                     end if;
556
 
557
                     Used_In_Body := False;
558
                     Used_In_Spec := False;
559
                     Used_Type_Or_Elab := False;
560
                     Withed_In_Spec := False;
561
                  end;
562
 
563
               --  Standalone package spec or body check
564
 
565
               else
566
                  declare
567
                     Dont_Care : Boolean := False;
568
                     Withed    : Boolean := False;
569
 
570
                  begin
571
                     --  The mechanism for examining the context clauses of a
572
                     --  package spec can be applied to package body clauses.
573
 
574
                     Process_Spec_Clauses
575
                      (Context_List => Context_Items,
576
                       Clause       => Clause,
577
                       Used         => Dont_Care,
578
                       Withed       => Withed,
579
                       Exit_On_Self => True);
580
 
581
                     if Withed then
582
                        Error_Msg_N -- CODEFIX
583
                          ("?redundant with clause", Clause);
584
                     end if;
585
                  end;
586
               end if;
587
            end if;
588
 
589
            Prev (Clause);
590
         end loop;
591
      end Check_Redundant_Withs;
592
 
593
      --------------------------------
594
      -- Generate_Parent_References --
595
      --------------------------------
596
 
597
      procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
598
         Pref   : Node_Id;
599
         P_Name : Entity_Id := P_Id;
600
 
601
      begin
602
         Pref := Name (Parent (Defining_Entity (N)));
603
 
604
         if Nkind (Pref) = N_Expanded_Name then
605
 
606
            --  Done already, if the unit has been compiled indirectly as
607
            --  part of the closure of its context because of inlining.
608
 
609
            return;
610
         end if;
611
 
612
         while Nkind (Pref) = N_Selected_Component loop
613
            Change_Selected_Component_To_Expanded_Name (Pref);
614
            Set_Entity (Pref, P_Name);
615
            Set_Etype (Pref, Etype (P_Name));
616
            Generate_Reference (P_Name, Pref, 'r');
617
            Pref   := Prefix (Pref);
618
            P_Name := Scope (P_Name);
619
         end loop;
620
 
621
         --  The guard here on P_Name is to handle the error condition where
622
         --  the parent unit is missing because the file was not found.
623
 
624
         if Present (P_Name) then
625
            Set_Entity (Pref, P_Name);
626
            Set_Etype (Pref, Etype (P_Name));
627
            Generate_Reference (P_Name, Pref, 'r');
628
            Style.Check_Identifier (Pref, P_Name);
629
         end if;
630
      end Generate_Parent_References;
631
 
632
   --  Start of processing for Analyze_Compilation_Unit
633
 
634
   begin
635
      Process_Compilation_Unit_Pragmas (N);
636
 
637
      --  If the unit is a subunit whose parent has not been analyzed (which
638
      --  indicates that the main unit is a subunit, either the current one or
639
      --  one of its descendents) then the subunit is compiled as part of the
640
      --  analysis of the parent, which we proceed to do. Basically this gets
641
      --  handled from the top down and we don't want to do anything at this
642
      --  level (i.e. this subunit will be handled on the way down from the
643
      --  parent), so at this level we immediately return. If the subunit ends
644
      --  up not analyzed, it means that the parent did not contain a stub for
645
      --  it, or that there errors were detected in some ancestor.
646
 
647
      if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) then
648
         Semantics (Lib_Unit);
649
 
650
         if not Analyzed (Proper_Body (Unit_Node)) then
651
            if Serious_Errors_Detected > 0 then
652
               Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
653
            else
654
               Error_Msg_N ("missing stub for subunit", N);
655
            end if;
656
         end if;
657
 
658
         return;
659
      end if;
660
 
661
      --  Analyze context (this will call Sem recursively for with'ed units) To
662
      --  detect circularities among with-clauses that are not caught during
663
      --  loading, we set the Context_Pending flag on the current unit. If the
664
      --  flag is already set there is a potential circularity. We exclude
665
      --  predefined units from this check because they are known to be safe.
666
      --  We also exclude package bodies that are present because circularities
667
      --  between bodies are harmless (and necessary).
668
 
669
      if Context_Pending (N) then
670
         declare
671
            Circularity : Boolean := True;
672
 
673
         begin
674
            if Is_Predefined_File_Name
675
                 (Unit_File_Name (Get_Source_Unit (Unit (N))))
676
            then
677
               Circularity := False;
678
 
679
            else
680
               for U in Main_Unit + 1 .. Last_Unit loop
681
                  if Nkind (Unit (Cunit (U))) = N_Package_Body
682
                    and then not Analyzed (Cunit (U))
683
                  then
684
                     Circularity := False;
685
                     exit;
686
                  end if;
687
               end loop;
688
            end if;
689
 
690
            if Circularity then
691
               Error_Msg_N ("circular dependency caused by with_clauses", N);
692
               Error_Msg_N
693
                 ("\possibly missing limited_with clause"
694
                  & " in one of the following", N);
695
 
696
               for U in Main_Unit .. Last_Unit loop
697
                  if Context_Pending (Cunit (U)) then
698
                     Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U)));
699
                     Error_Msg_N ("\unit$", N);
700
                  end if;
701
               end loop;
702
 
703
               raise Unrecoverable_Error;
704
            end if;
705
         end;
706
      else
707
         Set_Context_Pending (N);
708
      end if;
709
 
710
      Analyze_Context (N);
711
 
712
      Set_Context_Pending (N, False);
713
 
714
      --  If the unit is a package body, the spec is already loaded and must be
715
      --  analyzed first, before we analyze the body.
716
 
717
      if Nkind (Unit_Node) = N_Package_Body then
718
 
719
         --  If no Lib_Unit, then there was a serious previous error, so just
720
         --  ignore the entire analysis effort
721
 
722
         if No (Lib_Unit) then
723
            return;
724
 
725
         else
726
            --  Analyze the package spec
727
 
728
            Semantics (Lib_Unit);
729
 
730
            --  Check for unused with's
731
 
732
            Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
733
 
734
            --  Verify that the library unit is a package declaration
735
 
736
            if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration,
737
                                              N_Generic_Package_Declaration)
738
            then
739
               Error_Msg_N
740
                 ("no legal package declaration for package body", N);
741
               return;
742
 
743
            --  Otherwise, the entity in the declaration is visible. Update the
744
            --  version to reflect dependence of this body on the spec.
745
 
746
            else
747
               Spec_Id := Defining_Entity (Unit (Lib_Unit));
748
               Set_Is_Immediately_Visible (Spec_Id, True);
749
               Version_Update (N, Lib_Unit);
750
 
751
               if Nkind (Defining_Unit_Name (Unit_Node)) =
752
                                             N_Defining_Program_Unit_Name
753
               then
754
                  Generate_Parent_References (Unit_Node, Scope (Spec_Id));
755
               end if;
756
            end if;
757
         end if;
758
 
759
      --  If the unit is a subprogram body, then we similarly need to analyze
760
      --  its spec. However, things are a little simpler in this case, because
761
      --  here, this analysis is done mostly for error checking and consistency
762
      --  purposes (but not only, e.g. there could be a contract on the spec),
763
      --  so there's nothing else to be done.
764
 
765
      elsif Nkind (Unit_Node) = N_Subprogram_Body then
766
         if Acts_As_Spec (N) then
767
 
768
            --  If the subprogram body is a child unit, we must create a
769
            --  declaration for it, in order to properly load the parent(s).
770
            --  After this, the original unit does not acts as a spec, because
771
            --  there is an explicit one. If this unit appears in a context
772
            --  clause, then an implicit with on the parent will be added when
773
            --  installing the context. If this is the main unit, there is no
774
            --  Unit_Table entry for the declaration (it has the unit number
775
            --  of the main unit) and code generation is unaffected.
776
 
777
            Unum := Get_Cunit_Unit_Number (N);
778
            Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
779
 
780
            if Par_Spec_Name /= No_Unit_Name then
781
               Unum :=
782
                 Load_Unit
783
                   (Load_Name  => Par_Spec_Name,
784
                    Required   => True,
785
                    Subunit    => False,
786
                    Error_Node => N);
787
 
788
               if Unum /= No_Unit then
789
 
790
                  --  Build subprogram declaration and attach parent unit to it
791
                  --  This subprogram declaration does not come from source,
792
                  --  Nevertheless the backend must generate debugging info for
793
                  --  it, and this must be indicated explicitly. We also mark
794
                  --  the body entity as a child unit now, to prevent a
795
                  --  cascaded error if the spec entity cannot be entered
796
                  --  in its scope. Finally we create a Units table entry for
797
                  --  the subprogram declaration, to maintain a one-to-one
798
                  --  correspondence with compilation unit nodes. This is
799
                  --  critical for the tree traversals performed by CodePeer.
800
 
801
                  declare
802
                     Loc : constant Source_Ptr := Sloc (N);
803
                     SCS : constant Boolean :=
804
                             Get_Comes_From_Source_Default;
805
 
806
                  begin
807
                     Set_Comes_From_Source_Default (False);
808
 
809
                     --  Checks for redundant USE TYPE clauses have a special
810
                     --  exception for the synthetic spec we create here. This
811
                     --  special case relies on the two compilation units
812
                     --  sharing the same context clause.
813
 
814
                     --  Note: We used to do a shallow copy (New_Copy_List),
815
                     --  which defeated those checks and also created malformed
816
                     --  trees (subtype mark shared by two distinct
817
                     --  N_Use_Type_Clause nodes) which crashed the compiler.
818
 
819
                     Lib_Unit :=
820
                       Make_Compilation_Unit (Loc,
821
                         Context_Items => Context_Items (N),
822
                         Unit =>
823
                           Make_Subprogram_Declaration (Sloc (N),
824
                             Specification =>
825
                               Copy_Separate_Tree
826
                                 (Specification (Unit_Node))),
827
                         Aux_Decls_Node =>
828
                           Make_Compilation_Unit_Aux (Loc));
829
 
830
                     Set_Library_Unit (N, Lib_Unit);
831
                     Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
832
                     Make_Child_Decl_Unit (N);
833
                     Semantics (Lib_Unit);
834
 
835
                     --  Now that a separate declaration exists, the body
836
                     --  of the child unit does not act as spec any longer.
837
 
838
                     Set_Acts_As_Spec (N, False);
839
                     Set_Is_Child_Unit (Defining_Entity (Unit_Node));
840
                     Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
841
                     Set_Comes_From_Source_Default (SCS);
842
                  end;
843
               end if;
844
            end if;
845
 
846
         --  Here for subprogram with separate declaration
847
 
848
         else
849
            Semantics (Lib_Unit);
850
            Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
851
            Version_Update (N, Lib_Unit);
852
         end if;
853
 
854
         --  If this is a child unit, generate references to the parents
855
 
856
         if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
857
                                             N_Defining_Program_Unit_Name
858
         then
859
            Generate_Parent_References (
860
              Specification (Unit_Node),
861
                Scope (Defining_Entity (Unit (Lib_Unit))));
862
         end if;
863
      end if;
864
 
865
      --  If it is a child unit, the parent must be elaborated first and we
866
      --  update version, since we are dependent on our parent.
867
 
868
      if Is_Child_Spec (Unit_Node) then
869
 
870
         --  The analysis of the parent is done with style checks off
871
 
872
         declare
873
            Save_Style_Check : constant Boolean := Style_Check;
874
 
875
         begin
876
            if not GNAT_Mode then
877
               Style_Check := False;
878
            end if;
879
 
880
            Semantics (Parent_Spec (Unit_Node));
881
            Version_Update (N, Parent_Spec (Unit_Node));
882
 
883
            --  Restore style check settings
884
 
885
            Style_Check := Save_Style_Check;
886
         end;
887
      end if;
888
 
889
      --  With the analysis done, install the context. Note that we can't
890
      --  install the context from the with clauses as we analyze them, because
891
      --  each with clause must be analyzed in a clean visibility context, so
892
      --  we have to wait and install them all at once.
893
 
894
      Install_Context (N);
895
 
896
      if Is_Child_Spec (Unit_Node) then
897
 
898
         --  Set the entities of all parents in the program_unit_name
899
 
900
         Generate_Parent_References (
901
           Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
902
      end if;
903
 
904
      --  All components of the context: with-clauses, library unit, ancestors
905
      --  if any, (and their context)  are analyzed and installed.
906
 
907
      --  Call special debug routine sm if this is the main unit
908
 
909
      if Current_Sem_Unit = Main_Unit then
910
         sm;
911
      end if;
912
 
913
      --  Now analyze the unit (package, subprogram spec, body) itself
914
 
915
      Analyze (Unit_Node);
916
 
917
      if Warn_On_Redundant_Constructs then
918
         Check_Redundant_Withs (Context_Items (N));
919
 
920
         if Nkind (Unit_Node) = N_Package_Body then
921
            Check_Redundant_Withs
922
              (Context_Items      => Context_Items (N),
923
               Spec_Context_Items => Context_Items (Lib_Unit));
924
         end if;
925
      end if;
926
 
927
      --  The above call might have made Unit_Node an N_Subprogram_Body from
928
      --  something else, so propagate any Acts_As_Spec flag.
929
 
930
      if Nkind (Unit_Node) = N_Subprogram_Body
931
        and then Acts_As_Spec (Unit_Node)
932
      then
933
         Set_Acts_As_Spec (N);
934
      end if;
935
 
936
      --  Register predefined units in Rtsfind
937
 
938
      declare
939
         Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
940
      begin
941
         if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
942
            Set_RTU_Loaded (Unit_Node);
943
         end if;
944
      end;
945
 
946
      --  Treat compilation unit pragmas that appear after the library unit
947
 
948
      if Present (Pragmas_After (Aux_Decls_Node (N))) then
949
         declare
950
            Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
951
         begin
952
            while Present (Prag_Node) loop
953
               Analyze (Prag_Node);
954
               Next (Prag_Node);
955
            end loop;
956
         end;
957
      end if;
958
 
959
      --  Generate distribution stubs if requested and no error
960
 
961
      if N = Main_Cunit
962
        and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
963
                    or else
964
                  Distribution_Stub_Mode = Generate_Caller_Stub_Body)
965
        and then not Fatal_Error (Main_Unit)
966
      then
967
         if Is_RCI_Pkg_Spec_Or_Body (N) then
968
 
969
            --  Regular RCI package
970
 
971
            Add_Stub_Constructs (N);
972
 
973
         elsif (Nkind (Unit_Node) = N_Package_Declaration
974
                 and then Is_Shared_Passive (Defining_Entity
975
                                              (Specification (Unit_Node))))
976
           or else (Nkind (Unit_Node) = N_Package_Body
977
                     and then
978
                       Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
979
         then
980
            --  Shared passive package
981
 
982
            Add_Stub_Constructs (N);
983
 
984
         elsif Nkind (Unit_Node) = N_Package_Instantiation
985
           and then
986
             Is_Remote_Call_Interface
987
               (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
988
         then
989
            --  Instantiation of a RCI generic package
990
 
991
            Add_Stub_Constructs (N);
992
         end if;
993
      end if;
994
 
995
      --  Remove unit from visibility, so that environment is clean for the
996
      --  next compilation, which is either the main unit or some other unit
997
      --  in the context.
998
 
999
      if Nkind_In (Unit_Node, N_Package_Declaration,
1000
                              N_Package_Renaming_Declaration,
1001
                              N_Subprogram_Declaration)
1002
        or else Nkind (Unit_Node) in N_Generic_Declaration
1003
        or else
1004
          (Nkind (Unit_Node) = N_Subprogram_Body
1005
            and then Acts_As_Spec (Unit_Node))
1006
      then
1007
         Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
1008
 
1009
      --  If the unit is an instantiation whose body will be elaborated for
1010
      --  inlining purposes, use the proper entity of the instance. The entity
1011
      --  may be missing if the instantiation was illegal.
1012
 
1013
      elsif Nkind (Unit_Node) = N_Package_Instantiation
1014
        and then not Error_Posted (Unit_Node)
1015
        and then Present (Instance_Spec (Unit_Node))
1016
      then
1017
         Remove_Unit_From_Visibility
1018
           (Defining_Entity (Instance_Spec (Unit_Node)));
1019
 
1020
      elsif Nkind (Unit_Node) = N_Package_Body
1021
        or else (Nkind (Unit_Node) = N_Subprogram_Body
1022
                  and then not Acts_As_Spec (Unit_Node))
1023
      then
1024
         --  Bodies that are not the main unit are compiled if they are generic
1025
         --  or contain generic or inlined units. Their analysis brings in the
1026
         --  context of the corresponding spec (unit declaration) which must be
1027
         --  removed as well, to return the compilation environment to its
1028
         --  proper state.
1029
 
1030
         Remove_Context (Lib_Unit);
1031
         Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
1032
      end if;
1033
 
1034
      --  Last step is to deinstall the context we just installed as well as
1035
      --  the unit just compiled.
1036
 
1037
      Remove_Context (N);
1038
 
1039
      --  If this is the main unit and we are generating code, we must check
1040
      --  that all generic units in the context have a body if they need it,
1041
      --  even if they have not been instantiated. In the absence of .ali files
1042
      --  for generic units, we must force the load of the body, just to
1043
      --  produce the proper error if the body is absent. We skip this
1044
      --  verification if the main unit itself is generic.
1045
 
1046
      if Get_Cunit_Unit_Number (N) = Main_Unit
1047
        and then Operating_Mode = Generate_Code
1048
        and then Expander_Active
1049
      then
1050
         --  Check whether the source for the body of the unit must be included
1051
         --  in a standalone library.
1052
 
1053
         Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
1054
 
1055
         --  Indicate that the main unit is now analyzed, to catch possible
1056
         --  circularities between it and generic bodies. Remove main unit from
1057
         --  visibility. This might seem superfluous, but the main unit must
1058
         --  not be visible in the generic body expansions that follow.
1059
 
1060
         Set_Analyzed (N, True);
1061
         Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
1062
 
1063
         declare
1064
            Item  : Node_Id;
1065
            Nam   : Entity_Id;
1066
            Un    : Unit_Number_Type;
1067
 
1068
            Save_Style_Check : constant Boolean := Style_Check;
1069
 
1070
         begin
1071
            Item := First (Context_Items (N));
1072
            while Present (Item) loop
1073
 
1074
               --  Check for explicit with clause
1075
 
1076
               if Nkind (Item) = N_With_Clause
1077
                 and then not Implicit_With (Item)
1078
 
1079
                  --  Ada 2005 (AI-50217): Ignore limited-withed units
1080
 
1081
                 and then not Limited_Present (Item)
1082
               then
1083
                  Nam := Entity (Name (Item));
1084
 
1085
                  --  Compile generic subprogram, unless it is intrinsic or
1086
                  --  imported so no body is required, or generic package body
1087
                  --  if the package spec requires a body.
1088
 
1089
                  if (Is_Generic_Subprogram (Nam)
1090
                       and then not Is_Intrinsic_Subprogram (Nam)
1091
                       and then not Is_Imported (Nam))
1092
                    or else (Ekind (Nam) = E_Generic_Package
1093
                              and then Unit_Requires_Body (Nam))
1094
                  then
1095
                     Style_Check := False;
1096
 
1097
                     if Present (Renamed_Object (Nam)) then
1098
                        Un :=
1099
                           Load_Unit
1100
                             (Load_Name  => Get_Body_Name
1101
                                              (Get_Unit_Name
1102
                                                (Unit_Declaration_Node
1103
                                                  (Renamed_Object (Nam)))),
1104
                              Required   => False,
1105
                              Subunit    => False,
1106
                              Error_Node => N,
1107
                              Renamings  => True);
1108
                     else
1109
                        Un :=
1110
                          Load_Unit
1111
                            (Load_Name  => Get_Body_Name
1112
                                             (Get_Unit_Name (Item)),
1113
                             Required   => False,
1114
                             Subunit    => False,
1115
                             Error_Node => N,
1116
                             Renamings  => True);
1117
                     end if;
1118
 
1119
                     if Un = No_Unit then
1120
                        Error_Msg_NE
1121
                          ("body of generic unit& not found", Item, Nam);
1122
                        exit;
1123
 
1124
                     elsif not Analyzed (Cunit (Un))
1125
                       and then Un /= Main_Unit
1126
                       and then not Fatal_Error (Un)
1127
                     then
1128
                        Style_Check := False;
1129
                        Semantics (Cunit (Un));
1130
                     end if;
1131
                  end if;
1132
               end if;
1133
 
1134
               Next (Item);
1135
            end loop;
1136
 
1137
            --  Restore style checks settings
1138
 
1139
            Style_Check := Save_Style_Check;
1140
         end;
1141
      end if;
1142
 
1143
      --  Deal with creating elaboration Boolean if needed. We create an
1144
      --  elaboration boolean only for units that come from source since
1145
      --  units manufactured by the compiler never need elab checks.
1146
 
1147
      if Comes_From_Source (N)
1148
        and then Nkind_In (Unit_Node, N_Package_Declaration,
1149
                                      N_Generic_Package_Declaration,
1150
                                      N_Subprogram_Declaration,
1151
                                      N_Generic_Subprogram_Declaration)
1152
      then
1153
         declare
1154
            Loc  : constant Source_Ptr       := Sloc (N);
1155
            Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
1156
 
1157
         begin
1158
            Spec_Id := Defining_Entity (Unit_Node);
1159
            Generate_Definition (Spec_Id);
1160
 
1161
            --  See if an elaboration entity is required for possible access
1162
            --  before elaboration checking. Note that we must allow for this
1163
            --  even if -gnatE is not set, since a client may be compiled in
1164
            --  -gnatE mode and reference the entity.
1165
 
1166
            --  These entities are also used by the binder to prevent multiple
1167
            --  attempts to execute the elaboration code for the library case
1168
            --  where the elaboration routine might otherwise be called more
1169
            --  than once.
1170
 
1171
            --  Case of units which do not require elaboration checks
1172
 
1173
            if
1174
              --  Pure units do not need checks
1175
 
1176
              Is_Pure (Spec_Id)
1177
 
1178
              --  Preelaborated units do not need checks
1179
 
1180
              or else Is_Preelaborated (Spec_Id)
1181
 
1182
              --  No checks needed if pragma Elaborate_Body present
1183
 
1184
              or else Has_Pragma_Elaborate_Body (Spec_Id)
1185
 
1186
              --  No checks needed if unit does not require a body
1187
 
1188
              or else not Unit_Requires_Body (Spec_Id)
1189
 
1190
              --  No checks needed for predefined files
1191
 
1192
              or else Is_Predefined_File_Name (Unit_File_Name (Unum))
1193
 
1194
              --  No checks required if no separate spec
1195
 
1196
              or else Acts_As_Spec (N)
1197
            then
1198
               --  This is a case where we only need the entity for
1199
               --  checking to prevent multiple elaboration checks.
1200
 
1201
               Set_Elaboration_Entity_Required (Spec_Id, False);
1202
 
1203
            --  Case of elaboration entity is required for access before
1204
            --  elaboration checking (so certainly we must build it!)
1205
 
1206
            else
1207
               Set_Elaboration_Entity_Required (Spec_Id, True);
1208
            end if;
1209
 
1210
            Build_Elaboration_Entity (N, Spec_Id);
1211
         end;
1212
      end if;
1213
 
1214
      --  Freeze the compilation unit entity. This for sure is needed because
1215
      --  of some warnings that can be output (see Freeze_Subprogram), but may
1216
      --  in general be required. If freezing actions result, place them in the
1217
      --  compilation unit actions list, and analyze them.
1218
 
1219
      declare
1220
         L : constant List_Id :=
1221
               Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N);
1222
      begin
1223
         while Is_Non_Empty_List (L) loop
1224
            Insert_Library_Level_Action (Remove_Head (L));
1225
         end loop;
1226
      end;
1227
 
1228
      Set_Analyzed (N);
1229
 
1230
      if Nkind (Unit_Node) = N_Package_Declaration
1231
        and then Get_Cunit_Unit_Number (N) /= Main_Unit
1232
        and then Expander_Active
1233
      then
1234
         declare
1235
            Save_Style_Check : constant Boolean := Style_Check;
1236
            Save_Warning     : constant Warning_Mode_Type := Warning_Mode;
1237
            Options          : Style_Check_Options;
1238
 
1239
         begin
1240
            Save_Style_Check_Options (Options);
1241
            Reset_Style_Check_Options;
1242
            Opt.Warning_Mode := Suppress;
1243
            Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
1244
 
1245
            Reset_Style_Check_Options;
1246
            Set_Style_Check_Options (Options);
1247
            Style_Check := Save_Style_Check;
1248
            Warning_Mode := Save_Warning;
1249
         end;
1250
      end if;
1251
 
1252
      --  If we are generating obsolescent warnings, then here is where we
1253
      --  generate them for the with'ed items. The reason for this special
1254
      --  processing is that the normal mechanism of generating the warnings
1255
      --  for referenced entities does not work for context clause references.
1256
      --  That's because when we first analyze the context, it is too early to
1257
      --  know if the with'ing unit is itself obsolescent (which suppresses
1258
      --  the warnings).
1259
 
1260
      if not GNAT_Mode and then Warn_On_Obsolescent_Feature then
1261
 
1262
         --  Push current compilation unit as scope, so that the test for
1263
         --  being within an obsolescent unit will work correctly.
1264
 
1265
         Push_Scope (Defining_Entity (Unit_Node));
1266
 
1267
         --  Loop through context items to deal with with clauses
1268
 
1269
         declare
1270
            Item : Node_Id;
1271
            Nam  : Node_Id;
1272
            Ent  : Entity_Id;
1273
 
1274
         begin
1275
            Item := First (Context_Items (N));
1276
            while Present (Item) loop
1277
               if Nkind (Item) = N_With_Clause
1278
 
1279
                  --  Suppress this check in limited-withed units. Further work
1280
                  --  needed here if we decide to incorporate this check on
1281
                  --  limited-withed units.
1282
 
1283
                 and then not Limited_Present (Item)
1284
               then
1285
                  Nam := Name (Item);
1286
                  Ent := Entity (Nam);
1287
 
1288
                  if Is_Obsolescent (Ent) then
1289
                     Output_Obsolescent_Entity_Warnings (Nam, Ent);
1290
                  end if;
1291
               end if;
1292
 
1293
               Next (Item);
1294
            end loop;
1295
         end;
1296
 
1297
         --  Remove temporary install of current unit as scope
1298
 
1299
         Pop_Scope;
1300
      end if;
1301
   end Analyze_Compilation_Unit;
1302
 
1303
   ---------------------
1304
   -- Analyze_Context --
1305
   ---------------------
1306
 
1307
   procedure Analyze_Context (N : Node_Id) is
1308
      Ukind : constant Node_Kind := Nkind (Unit (N));
1309
      Item  : Node_Id;
1310
 
1311
   begin
1312
      --  First process all configuration pragmas at the start of the context
1313
      --  items. Strictly these are not part of the context clause, but that
1314
      --  is where the parser puts them. In any case for sure we must analyze
1315
      --  these before analyzing the actual context items, since they can have
1316
      --  an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1317
      --  be with'ed as a result of changing categorizations in Ada 2005).
1318
 
1319
      Item := First (Context_Items (N));
1320
      while Present (Item)
1321
        and then Nkind (Item) = N_Pragma
1322
        and then Pragma_Name (Item) in Configuration_Pragma_Names
1323
      loop
1324
         Analyze (Item);
1325
         Next (Item);
1326
      end loop;
1327
 
1328
      --  This is the point at which we capture the configuration settings
1329
      --  for the unit. At the moment only the Optimize_Alignment setting
1330
      --  needs to be captured. Probably more later ???
1331
 
1332
      if Optimize_Alignment_Local then
1333
         Set_OA_Setting (Current_Sem_Unit, 'L');
1334
      else
1335
         Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment);
1336
      end if;
1337
 
1338
      --  Loop through actual context items. This is done in two passes:
1339
 
1340
      --  a) The first pass analyzes non-limited with-clauses and also any
1341
      --     configuration pragmas (we need to get the latter analyzed right
1342
      --     away, since they can affect processing of subsequent items.
1343
 
1344
      --  b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1345
 
1346
      while Present (Item) loop
1347
 
1348
         --  For with clause, analyze the with clause, and then update the
1349
         --  version, since we are dependent on a unit that we with.
1350
 
1351
         if Nkind (Item) = N_With_Clause
1352
           and then not Limited_Present (Item)
1353
         then
1354
            --  Skip analyzing with clause if no unit, nothing to do (this
1355
            --  happens for a with that references a non-existent unit). Skip
1356
            --  as well if this is a with_clause for the main unit, which
1357
            --  happens if a subunit has a useless with_clause on its parent.
1358
 
1359
            if Present (Library_Unit (Item)) then
1360
               if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then
1361
                  Analyze (Item);
1362
 
1363
               else
1364
                  Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit));
1365
               end if;
1366
            end if;
1367
 
1368
            if not Implicit_With (Item) then
1369
               Version_Update (N, Library_Unit (Item));
1370
            end if;
1371
 
1372
         --  Skip pragmas. Configuration pragmas at the start were handled in
1373
         --  the loop above, and remaining pragmas are not processed until we
1374
         --  actually install the context (see Install_Context). We delay the
1375
         --  analysis of these pragmas to make sure that we have installed all
1376
         --  the implicit with's on parent units.
1377
 
1378
         --  Skip use clauses at this stage, since we don't want to do any
1379
         --  installing of potentially use-visible entities until we
1380
         --  actually install the complete context (in Install_Context).
1381
         --  Otherwise things can get installed in the wrong context.
1382
 
1383
         else
1384
            null;
1385
         end if;
1386
 
1387
         Next (Item);
1388
      end loop;
1389
 
1390
      --  Second pass: examine all limited_with clauses. All other context
1391
      --  items are ignored in this pass.
1392
 
1393
      Item := First (Context_Items (N));
1394
      while Present (Item) loop
1395
         if Nkind (Item) = N_With_Clause
1396
           and then Limited_Present (Item)
1397
         then
1398
            --  No need to check errors on implicitly generated limited-with
1399
            --  clauses.
1400
 
1401
            if not Implicit_With (Item) then
1402
 
1403
               --  Verify that the illegal contexts given in 10.1.2 (18/2) are
1404
               --  properly rejected, including renaming declarations.
1405
 
1406
               if not Nkind_In (Ukind, N_Package_Declaration,
1407
                                       N_Subprogram_Declaration)
1408
                 and then Ukind not in N_Generic_Declaration
1409
                 and then Ukind not in N_Generic_Instantiation
1410
               then
1411
                  Error_Msg_N ("limited with_clause not allowed here", Item);
1412
 
1413
               --  Check wrong use of a limited with clause applied to the
1414
               --  compilation unit containing the limited-with clause.
1415
 
1416
               --      limited with P.Q;
1417
               --      package P.Q is ...
1418
 
1419
               elsif Unit (Library_Unit (Item)) = Unit (N) then
1420
                  Error_Msg_N ("wrong use of limited-with clause", Item);
1421
 
1422
               --  Check wrong use of limited-with clause applied to some
1423
               --  immediate ancestor.
1424
 
1425
               elsif Is_Child_Spec (Unit (N)) then
1426
                  declare
1427
                     Lib_U : constant Entity_Id := Unit (Library_Unit (Item));
1428
                     P     : Node_Id;
1429
 
1430
                  begin
1431
                     P := Parent_Spec (Unit (N));
1432
                     loop
1433
                        if Unit (P) = Lib_U then
1434
                           Error_Msg_N ("limited with_clause cannot "
1435
                                        & "name ancestor", Item);
1436
                           exit;
1437
                        end if;
1438
 
1439
                        exit when not Is_Child_Spec (Unit (P));
1440
                        P := Parent_Spec (Unit (P));
1441
                     end loop;
1442
                  end;
1443
               end if;
1444
 
1445
               --  Check if the limited-withed unit is already visible through
1446
               --  some context clause of the current compilation unit or some
1447
               --  ancestor of the current compilation unit.
1448
 
1449
               declare
1450
                  Lim_Unit_Name : constant Node_Id := Name (Item);
1451
                  Comp_Unit     : Node_Id;
1452
                  It            : Node_Id;
1453
                  Unit_Name     : Node_Id;
1454
 
1455
               begin
1456
                  Comp_Unit := N;
1457
                  loop
1458
                     It := First (Context_Items (Comp_Unit));
1459
                     while Present (It) loop
1460
                        if Item /= It
1461
                          and then Nkind (It) = N_With_Clause
1462
                          and then not Limited_Present (It)
1463
                          and then
1464
                            Nkind_In (Unit (Library_Unit (It)),
1465
                                      N_Package_Declaration,
1466
                                      N_Package_Renaming_Declaration)
1467
                        then
1468
                           if Nkind (Unit (Library_Unit (It))) =
1469
                                                      N_Package_Declaration
1470
                           then
1471
                              Unit_Name := Name (It);
1472
                           else
1473
                              Unit_Name := Name (Unit (Library_Unit (It)));
1474
                           end if;
1475
 
1476
                           --  Check if the named package (or some ancestor)
1477
                           --  leaves visible the full-view of the unit given
1478
                           --  in the limited-with clause
1479
 
1480
                           loop
1481
                              if Designate_Same_Unit (Lim_Unit_Name,
1482
                                                      Unit_Name)
1483
                              then
1484
                                 Error_Msg_Sloc := Sloc (It);
1485
                                 Error_Msg_N
1486
                                   ("simultaneous visibility of limited "
1487
                                    & "and unlimited views not allowed",
1488
                                    Item);
1489
                                 Error_Msg_NE
1490
                                   ("\unlimited view visible through "
1491
                                    & "context clause #",
1492
                                    Item, It);
1493
                                 exit;
1494
 
1495
                              elsif Nkind (Unit_Name) = N_Identifier then
1496
                                 exit;
1497
                              end if;
1498
 
1499
                              Unit_Name := Prefix (Unit_Name);
1500
                           end loop;
1501
                        end if;
1502
 
1503
                        Next (It);
1504
                     end loop;
1505
 
1506
                     exit when not Is_Child_Spec (Unit (Comp_Unit));
1507
 
1508
                     Comp_Unit := Parent_Spec (Unit (Comp_Unit));
1509
                  end loop;
1510
               end;
1511
            end if;
1512
 
1513
            --  Skip analyzing with clause if no unit, see above
1514
 
1515
            if Present (Library_Unit (Item)) then
1516
               Analyze (Item);
1517
            end if;
1518
 
1519
            --  A limited_with does not impose an elaboration order, but
1520
            --  there is a semantic dependency for recompilation purposes.
1521
 
1522
            if not Implicit_With (Item) then
1523
               Version_Update (N, Library_Unit (Item));
1524
            end if;
1525
 
1526
            --  Pragmas and use clauses and with clauses other than limited
1527
            --  with's are ignored in this pass through the context items.
1528
 
1529
         else
1530
            null;
1531
         end if;
1532
 
1533
         Next (Item);
1534
      end loop;
1535
   end Analyze_Context;
1536
 
1537
   -------------------------------
1538
   -- Analyze_Package_Body_Stub --
1539
   -------------------------------
1540
 
1541
   procedure Analyze_Package_Body_Stub (N : Node_Id) is
1542
      Id   : constant Entity_Id := Defining_Identifier (N);
1543
      Nam  : Entity_Id;
1544
 
1545
   begin
1546
      --  The package declaration must be in the current declarative part
1547
 
1548
      Check_Stub_Level (N);
1549
      Nam := Current_Entity_In_Scope (Id);
1550
 
1551
      if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then
1552
         Error_Msg_N ("missing specification for package stub", N);
1553
 
1554
      elsif Has_Completion (Nam)
1555
        and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
1556
      then
1557
         Error_Msg_N ("duplicate or redundant stub for package", N);
1558
 
1559
      else
1560
         --  Indicate that the body of the package exists. If we are doing
1561
         --  only semantic analysis, the stub stands for the body. If we are
1562
         --  generating code, the existence of the body will be confirmed
1563
         --  when we load the proper body.
1564
 
1565
         Set_Has_Completion (Nam);
1566
         Set_Scope (Defining_Entity (N), Current_Scope);
1567
         Generate_Reference (Nam, Id, 'b');
1568
         Analyze_Proper_Body (N, Nam);
1569
      end if;
1570
   end Analyze_Package_Body_Stub;
1571
 
1572
   -------------------------
1573
   -- Analyze_Proper_Body --
1574
   -------------------------
1575
 
1576
   procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
1577
      Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
1578
      Unum         : Unit_Number_Type;
1579
 
1580
      procedure Optional_Subunit;
1581
      --  This procedure is called when the main unit is a stub, or when we
1582
      --  are not generating code. In such a case, we analyze the subunit if
1583
      --  present, which is user-friendly and in fact required for ASIS, but
1584
      --  we don't complain if the subunit is missing.
1585
 
1586
      ----------------------
1587
      -- Optional_Subunit --
1588
      ----------------------
1589
 
1590
      procedure Optional_Subunit is
1591
         Comp_Unit : Node_Id;
1592
 
1593
      begin
1594
         --  Try to load subunit, but ignore any errors that occur during the
1595
         --  loading of the subunit, by using the special feature in Errout to
1596
         --  ignore all errors. Note that Fatal_Error will still be set, so we
1597
         --  will be able to check for this case below.
1598
 
1599
         if not ASIS_Mode then
1600
            Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
1601
         end if;
1602
 
1603
         Unum :=
1604
           Load_Unit
1605
             (Load_Name  => Subunit_Name,
1606
              Required   => False,
1607
              Subunit    => True,
1608
              Error_Node => N);
1609
 
1610
         if not ASIS_Mode then
1611
            Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
1612
         end if;
1613
 
1614
         --  All done if we successfully loaded the subunit
1615
 
1616
         if Unum /= No_Unit
1617
           and then (not Fatal_Error (Unum) or else Try_Semantics)
1618
         then
1619
            Comp_Unit := Cunit (Unum);
1620
 
1621
            --  If the file was empty or seriously mangled, the unit itself may
1622
            --  be missing.
1623
 
1624
            if No (Unit (Comp_Unit)) then
1625
               Error_Msg_N
1626
                 ("subunit does not contain expected proper body", N);
1627
 
1628
            elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then
1629
               Error_Msg_N
1630
                 ("expected SEPARATE subunit, found child unit",
1631
                  Cunit_Entity (Unum));
1632
            else
1633
               Set_Corresponding_Stub (Unit (Comp_Unit), N);
1634
               Analyze_Subunit (Comp_Unit);
1635
               Set_Library_Unit (N, Comp_Unit);
1636
            end if;
1637
 
1638
         elsif Unum = No_Unit
1639
           and then Present (Nam)
1640
         then
1641
            if Is_Protected_Type (Nam) then
1642
               Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
1643
            else
1644
               Set_Corresponding_Body (
1645
                 Unit_Declaration_Node (Nam), Defining_Identifier (N));
1646
            end if;
1647
         end if;
1648
      end Optional_Subunit;
1649
 
1650
   --  Start of processing for Analyze_Proper_Body
1651
 
1652
   begin
1653
      --  If the subunit is already loaded, it means that the main unit is a
1654
      --  subunit, and that the current unit is one of its parents which was
1655
      --  being analyzed to provide the needed context for the analysis of the
1656
      --  subunit. In this case we analyze the subunit and continue with the
1657
      --  parent, without looking at subsequent subunits.
1658
 
1659
      if Is_Loaded (Subunit_Name) then
1660
 
1661
         --  If the proper body is already linked to the stub node, the stub is
1662
         --  in a generic unit and just needs analyzing.
1663
 
1664
         if Present (Library_Unit (N)) then
1665
            Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1666
 
1667
            --  If the subunit has severe errors, the spec of the enclosing
1668
            --  body may not be available, in which case do not try analysis.
1669
 
1670
            if Serious_Errors_Detected > 0
1671
              and then  No (Library_Unit (Library_Unit (N)))
1672
            then
1673
               return;
1674
            end if;
1675
 
1676
            Analyze_Subunit (Library_Unit (N));
1677
 
1678
         --  Otherwise we must load the subunit and link to it
1679
 
1680
         else
1681
            --  Load the subunit, this must work, since we originally loaded
1682
            --  the subunit earlier on. So this will not really load it, just
1683
            --  give access to it.
1684
 
1685
            Unum :=
1686
              Load_Unit
1687
                (Load_Name  => Subunit_Name,
1688
                 Required   => True,
1689
                 Subunit    => False,
1690
                 Error_Node => N);
1691
 
1692
            --  And analyze the subunit in the parent context (note that we
1693
            --  do not call Semantics, since that would remove the parent
1694
            --  context). Because of this, we have to manually reset the
1695
            --  compiler state to Analyzing since it got destroyed by Load.
1696
 
1697
            if Unum /= No_Unit then
1698
               Compiler_State := Analyzing;
1699
 
1700
               --  Check that the proper body is a subunit and not a child
1701
               --  unit. If the unit was previously loaded, the error will
1702
               --  have been emitted when copying the generic node, so we
1703
               --  just return to avoid cascaded errors.
1704
 
1705
               if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
1706
                  return;
1707
               end if;
1708
 
1709
               Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
1710
               Analyze_Subunit (Cunit (Unum));
1711
               Set_Library_Unit (N, Cunit (Unum));
1712
            end if;
1713
         end if;
1714
 
1715
      --  If the main unit is a subunit, then we are just performing semantic
1716
      --  analysis on that subunit, and any other subunits of any parent unit
1717
      --  should be ignored, except that if we are building trees for ASIS
1718
      --  usage we want to annotate the stub properly.
1719
 
1720
      elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
1721
        and then Subunit_Name /= Unit_Name (Main_Unit)
1722
      then
1723
         if ASIS_Mode then
1724
            Optional_Subunit;
1725
         end if;
1726
 
1727
         --  But before we return, set the flag for unloaded subunits. This
1728
         --  will suppress junk warnings of variables in the same declarative
1729
         --  part (or a higher level one) that are in danger of looking unused
1730
         --  when in fact there might be a declaration in the subunit that we
1731
         --  do not intend to load.
1732
 
1733
         Unloaded_Subunits := True;
1734
         return;
1735
 
1736
      --  If the subunit is not already loaded, and we are generating code,
1737
      --  then this is the case where compilation started from the parent, and
1738
      --  we are generating code for an entire subunit tree. In that case we
1739
      --  definitely need to load the subunit.
1740
 
1741
      --  In order to continue the analysis with the rest of the parent,
1742
      --  and other subunits, we load the unit without requiring its
1743
      --  presence, and emit a warning if not found, rather than terminating
1744
      --  the compilation abruptly, as for other missing file problems.
1745
 
1746
      elsif Original_Operating_Mode = Generate_Code then
1747
 
1748
         --  If the proper body is already linked to the stub node, the stub is
1749
         --  in a generic unit and just needs analyzing.
1750
 
1751
         --  We update the version. Although we are not strictly technically
1752
         --  semantically dependent on the subunit, given our approach of macro
1753
         --  substitution of subunits, it makes sense to include it in the
1754
         --  version identification.
1755
 
1756
         if Present (Library_Unit (N)) then
1757
            Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1758
            Analyze_Subunit (Library_Unit (N));
1759
            Version_Update (Cunit (Main_Unit), Library_Unit (N));
1760
 
1761
         --  Otherwise we must load the subunit and link to it
1762
 
1763
         else
1764
            --  Make sure that, if the subunit is preprocessed and -gnateG is
1765
            --  specified, the preprocessed file will be written.
1766
 
1767
            Lib.Analysing_Subunit_Of_Main := True;
1768
            Unum :=
1769
              Load_Unit
1770
                (Load_Name  => Subunit_Name,
1771
                 Required   => False,
1772
                 Subunit    => True,
1773
                 Error_Node => N);
1774
            Lib.Analysing_Subunit_Of_Main := False;
1775
 
1776
            --  Give message if we did not get the unit Emit warning even if
1777
            --  missing subunit is not within main unit, to simplify debugging.
1778
 
1779
            if Original_Operating_Mode = Generate_Code
1780
              and then Unum = No_Unit
1781
            then
1782
               Error_Msg_Unit_1 := Subunit_Name;
1783
               Error_Msg_File_1 :=
1784
                 Get_File_Name (Subunit_Name, Subunit => True);
1785
               Error_Msg_N
1786
                 ("subunit$$ in file{ not found?!!", N);
1787
               Subunits_Missing := True;
1788
            end if;
1789
 
1790
            --  Load_Unit may reset Compiler_State, since it may have been
1791
            --  necessary to parse an additional units, so we make sure that
1792
            --  we reset it to the Analyzing state.
1793
 
1794
            Compiler_State := Analyzing;
1795
 
1796
            if Unum /= No_Unit then
1797
               if Debug_Flag_L then
1798
                  Write_Str ("*** Loaded subunit from stub. Analyze");
1799
                  Write_Eol;
1800
               end if;
1801
 
1802
               declare
1803
                  Comp_Unit : constant Node_Id := Cunit (Unum);
1804
 
1805
               begin
1806
                  --  Check for child unit instead of subunit
1807
 
1808
                  if Nkind (Unit (Comp_Unit)) /= N_Subunit then
1809
                     Error_Msg_N
1810
                       ("expected SEPARATE subunit, found child unit",
1811
                        Cunit_Entity (Unum));
1812
 
1813
                  --  OK, we have a subunit
1814
 
1815
                  else
1816
                     --  Set corresponding stub (even if errors)
1817
 
1818
                     Set_Corresponding_Stub (Unit (Comp_Unit), N);
1819
 
1820
                     --  Collect SCO information for loaded subunit if we are
1821
                     --  in the main unit).
1822
 
1823
                     if Generate_SCO
1824
                       and then
1825
                         In_Extended_Main_Source_Unit
1826
                           (Cunit_Entity (Current_Sem_Unit))
1827
                     then
1828
                        SCO_Record (Unum);
1829
                     end if;
1830
 
1831
                     --  Analyze the unit if semantics active
1832
 
1833
                     if not Fatal_Error (Unum) or else Try_Semantics then
1834
                        Analyze_Subunit (Comp_Unit);
1835
                     end if;
1836
 
1837
                     --  Set the library unit pointer in any case
1838
 
1839
                     Set_Library_Unit (N, Comp_Unit);
1840
 
1841
                     --  We update the version. Although we are not technically
1842
                     --  semantically dependent on the subunit, given our
1843
                     --  approach of macro substitution of subunits, it makes
1844
                     --  sense to include it in the version identification.
1845
 
1846
                     Version_Update (Cunit (Main_Unit), Comp_Unit);
1847
                  end if;
1848
               end;
1849
            end if;
1850
         end if;
1851
 
1852
      --  The remaining case is when the subunit is not already loaded and we
1853
      --  are not generating code. In this case we are just performing semantic
1854
      --  analysis on the parent, and we are not interested in the subunit. For
1855
      --  subprograms, analyze the stub as a body. For other entities the stub
1856
      --  has already been marked as completed.
1857
 
1858
      else
1859
         Optional_Subunit;
1860
      end if;
1861
   end Analyze_Proper_Body;
1862
 
1863
   ----------------------------------
1864
   -- Analyze_Protected_Body_Stub --
1865
   ----------------------------------
1866
 
1867
   procedure Analyze_Protected_Body_Stub (N : Node_Id) is
1868
      Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1869
 
1870
   begin
1871
      Check_Stub_Level (N);
1872
 
1873
      --  First occurrence of name may have been as an incomplete type
1874
 
1875
      if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1876
         Nam := Full_View (Nam);
1877
      end if;
1878
 
1879
      if No (Nam)
1880
        or else not Is_Protected_Type (Etype (Nam))
1881
      then
1882
         Error_Msg_N ("missing specification for Protected body", N);
1883
      else
1884
         Set_Scope (Defining_Entity (N), Current_Scope);
1885
         Set_Has_Completion (Etype (Nam));
1886
         Generate_Reference (Nam, Defining_Identifier (N), 'b');
1887
         Analyze_Proper_Body (N, Etype (Nam));
1888
      end if;
1889
   end Analyze_Protected_Body_Stub;
1890
 
1891
   ----------------------------------
1892
   -- Analyze_Subprogram_Body_Stub --
1893
   ----------------------------------
1894
 
1895
   --  A subprogram body stub can appear with or without a previous spec. If
1896
   --  there is one, then the analysis of the body will find it and verify
1897
   --  conformance. The formals appearing in the specification of the stub play
1898
   --  no role, except for requiring an additional conformance check. If there
1899
   --  is no previous subprogram declaration, the stub acts as a spec, and
1900
   --  provides the defining entity for the subprogram.
1901
 
1902
   procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
1903
      Decl : Node_Id;
1904
 
1905
   begin
1906
      Check_Stub_Level (N);
1907
 
1908
      --  Verify that the identifier for the stub is unique within this
1909
      --  declarative part.
1910
 
1911
      if Nkind_In (Parent (N), N_Block_Statement,
1912
                               N_Package_Body,
1913
                               N_Subprogram_Body)
1914
      then
1915
         Decl := First (Declarations (Parent (N)));
1916
         while Present (Decl)
1917
           and then Decl /= N
1918
         loop
1919
            if Nkind (Decl) = N_Subprogram_Body_Stub
1920
              and then (Chars (Defining_Unit_Name (Specification (Decl))) =
1921
                        Chars (Defining_Unit_Name (Specification (N))))
1922
            then
1923
               Error_Msg_N ("identifier for stub is not unique", N);
1924
            end if;
1925
 
1926
            Next (Decl);
1927
         end loop;
1928
      end if;
1929
 
1930
      --  Treat stub as a body, which checks conformance if there is a previous
1931
      --  declaration, or else introduces entity and its signature.
1932
 
1933
      Analyze_Subprogram_Body (N);
1934
      Analyze_Proper_Body (N, Empty);
1935
   end Analyze_Subprogram_Body_Stub;
1936
 
1937
   ---------------------
1938
   -- Analyze_Subunit --
1939
   ---------------------
1940
 
1941
   --  A subunit is compiled either by itself (for semantic checking) or as
1942
   --  part of compiling the parent (for code generation). In either case, by
1943
   --  the time we actually process the subunit, the parent has already been
1944
   --  installed and analyzed. The node N is a compilation unit, whose context
1945
   --  needs to be treated here, because we come directly here from the parent
1946
   --  without calling Analyze_Compilation_Unit.
1947
 
1948
   --  The compilation context includes the explicit context of the subunit,
1949
   --  and the context of the parent, together with the parent itself. In order
1950
   --  to compile the current context, we remove the one inherited from the
1951
   --  parent, in order to have a clean visibility table. We restore the parent
1952
   --  context before analyzing the proper body itself. On exit, we remove only
1953
   --  the explicit context of the subunit.
1954
 
1955
   procedure Analyze_Subunit (N : Node_Id) is
1956
      Lib_Unit : constant Node_Id   := Library_Unit (N);
1957
      Par_Unit : constant Entity_Id := Current_Scope;
1958
 
1959
      Lib_Spec        : Node_Id := Library_Unit (Lib_Unit);
1960
      Num_Scopes      : Int := 0;
1961
      Use_Clauses     : array (1 .. Scope_Stack.Last) of Node_Id;
1962
      Enclosing_Child : Entity_Id := Empty;
1963
      Svg             : constant Suppress_Array := Scope_Suppress;
1964
 
1965
      Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
1966
                                  Cunit_Boolean_Restrictions_Save;
1967
      --  Save non-partition wide restrictions before processing the subunit.
1968
      --  All subunits are analyzed with config restrictions reset and we need
1969
      --  to restore these saved values at the end.
1970
 
1971
      procedure Analyze_Subunit_Context;
1972
      --  Capture names in use clauses of the subunit. This must be done before
1973
      --  re-installing parent declarations, because items in the context must
1974
      --  not be hidden by declarations local to the parent.
1975
 
1976
      procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
1977
      --  Recursive procedure to restore scope of all ancestors of subunit,
1978
      --  from outermost in. If parent is not a subunit, the call to install
1979
      --  context installs context of spec and (if parent is a child unit) the
1980
      --  context of its parents as well. It is confusing that parents should
1981
      --  be treated differently in both cases, but the semantics are just not
1982
      --  identical.
1983
 
1984
      procedure Re_Install_Use_Clauses;
1985
      --  As part of the removal of the parent scope, the use clauses are
1986
      --  removed, to be reinstalled when the context of the subunit has been
1987
      --  analyzed. Use clauses may also have been affected by the analysis of
1988
      --  the context of the subunit, so they have to be applied again, to
1989
      --  insure that the compilation environment of the rest of the parent
1990
      --  unit is identical.
1991
 
1992
      procedure Remove_Scope;
1993
      --  Remove current scope from scope stack, and preserve the list of use
1994
      --  clauses in it, to be reinstalled after context is analyzed.
1995
 
1996
      -----------------------------
1997
      -- Analyze_Subunit_Context --
1998
      -----------------------------
1999
 
2000
      procedure Analyze_Subunit_Context is
2001
         Item      :  Node_Id;
2002
         Nam       :  Node_Id;
2003
         Unit_Name : Entity_Id;
2004
 
2005
      begin
2006
         Analyze_Context (N);
2007
 
2008
         --  Make withed units immediately visible. If child unit, make the
2009
         --  ultimate parent immediately visible.
2010
 
2011
         Item := First (Context_Items (N));
2012
         while Present (Item) loop
2013
            if Nkind (Item) = N_With_Clause then
2014
 
2015
               --  Protect frontend against previous errors in context clauses
2016
 
2017
               if Nkind (Name (Item)) /= N_Selected_Component then
2018
                  if Error_Posted (Item) then
2019
                     null;
2020
 
2021
                  else
2022
                     --  If a subunits has serious syntax errors, the context
2023
                     --  may not have been loaded. Add a harmless unit name to
2024
                     --  attempt processing.
2025
 
2026
                     if Serious_Errors_Detected > 0
2027
                       and then  No (Entity (Name (Item)))
2028
                     then
2029
                        Set_Entity (Name (Item), Standard_Standard);
2030
                     end if;
2031
 
2032
                     Unit_Name := Entity (Name (Item));
2033
                     while Is_Child_Unit (Unit_Name) loop
2034
                        Set_Is_Visible_Child_Unit (Unit_Name);
2035
                        Unit_Name := Scope (Unit_Name);
2036
                     end loop;
2037
 
2038
                     if not Is_Immediately_Visible (Unit_Name) then
2039
                        Set_Is_Immediately_Visible (Unit_Name);
2040
                        Set_Context_Installed (Item);
2041
                     end if;
2042
                  end if;
2043
               end if;
2044
 
2045
            elsif Nkind (Item) = N_Use_Package_Clause then
2046
               Nam := First (Names (Item));
2047
               while Present (Nam) loop
2048
                  Analyze (Nam);
2049
                  Next (Nam);
2050
               end loop;
2051
 
2052
            elsif Nkind (Item) = N_Use_Type_Clause then
2053
               Nam := First (Subtype_Marks (Item));
2054
               while Present (Nam) loop
2055
                  Analyze (Nam);
2056
                  Next (Nam);
2057
               end loop;
2058
            end if;
2059
 
2060
            Next (Item);
2061
         end loop;
2062
 
2063
         --  Reset visibility of withed units. They will be made visible again
2064
         --  when we install the subunit context.
2065
 
2066
         Item := First (Context_Items (N));
2067
         while Present (Item) loop
2068
            if Nkind (Item) = N_With_Clause
2069
 
2070
               --  Protect frontend against previous errors in context clauses
2071
 
2072
              and then Nkind (Name (Item)) /= N_Selected_Component
2073
              and then not Error_Posted (Item)
2074
            then
2075
               Unit_Name := Entity (Name (Item));
2076
               while Is_Child_Unit (Unit_Name) loop
2077
                  Set_Is_Visible_Child_Unit (Unit_Name, False);
2078
                  Unit_Name := Scope (Unit_Name);
2079
               end loop;
2080
 
2081
               if Context_Installed (Item) then
2082
                  Set_Is_Immediately_Visible (Unit_Name, False);
2083
                  Set_Context_Installed (Item, False);
2084
               end if;
2085
            end if;
2086
 
2087
            Next (Item);
2088
         end loop;
2089
      end Analyze_Subunit_Context;
2090
 
2091
      ------------------------
2092
      -- Re_Install_Parents --
2093
      ------------------------
2094
 
2095
      procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
2096
         E : Entity_Id;
2097
 
2098
      begin
2099
         if Nkind (Unit (L)) = N_Subunit then
2100
            Re_Install_Parents (Library_Unit (L), Scope (Scop));
2101
         end if;
2102
 
2103
         Install_Context (L);
2104
 
2105
         --  If the subunit occurs within a child unit, we must restore the
2106
         --  immediate visibility of any siblings that may occur in context.
2107
 
2108
         if Present (Enclosing_Child) then
2109
            Install_Siblings (Enclosing_Child, L);
2110
         end if;
2111
 
2112
         Push_Scope (Scop);
2113
 
2114
         if Scop /= Par_Unit then
2115
            Set_Is_Immediately_Visible (Scop);
2116
         end if;
2117
 
2118
         --  Make entities in scope visible again. For child units, restore
2119
         --  visibility only if they are actually in context.
2120
 
2121
         E := First_Entity (Current_Scope);
2122
         while Present (E) loop
2123
            if not Is_Child_Unit (E)
2124
              or else Is_Visible_Child_Unit (E)
2125
            then
2126
               Set_Is_Immediately_Visible (E);
2127
            end if;
2128
 
2129
            Next_Entity (E);
2130
         end loop;
2131
 
2132
         --  A subunit appears within a body, and for a nested subunits all the
2133
         --  parents are bodies. Restore full visibility of their private
2134
         --  entities.
2135
 
2136
         if Is_Package_Or_Generic_Package (Scop) then
2137
            Set_In_Package_Body (Scop);
2138
            Install_Private_Declarations (Scop);
2139
         end if;
2140
      end Re_Install_Parents;
2141
 
2142
      ----------------------------
2143
      -- Re_Install_Use_Clauses --
2144
      ----------------------------
2145
 
2146
      procedure Re_Install_Use_Clauses is
2147
         U  : Node_Id;
2148
      begin
2149
         for J in reverse 1 .. Num_Scopes loop
2150
            U := Use_Clauses (J);
2151
            Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
2152
            Install_Use_Clauses (U, Force_Installation => True);
2153
         end loop;
2154
      end Re_Install_Use_Clauses;
2155
 
2156
      ------------------
2157
      -- Remove_Scope --
2158
      ------------------
2159
 
2160
      procedure Remove_Scope is
2161
         E : Entity_Id;
2162
 
2163
      begin
2164
         Num_Scopes := Num_Scopes + 1;
2165
         Use_Clauses (Num_Scopes) :=
2166
           Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
2167
 
2168
         E := First_Entity (Current_Scope);
2169
         while Present (E) loop
2170
            Set_Is_Immediately_Visible (E, False);
2171
            Next_Entity (E);
2172
         end loop;
2173
 
2174
         if Is_Child_Unit (Current_Scope) then
2175
            Enclosing_Child := Current_Scope;
2176
         end if;
2177
 
2178
         Pop_Scope;
2179
      end Remove_Scope;
2180
 
2181
   --  Start of processing for Analyze_Subunit
2182
 
2183
   begin
2184
      --  For subunit in main extended unit, we reset the configuration values
2185
      --  for the non-partition-wide restrictions. For other units reset them.
2186
 
2187
      if In_Extended_Main_Source_Unit (N) then
2188
         Restore_Config_Cunit_Boolean_Restrictions;
2189
      else
2190
         Reset_Cunit_Boolean_Restrictions;
2191
      end if;
2192
 
2193
      if Style_Check then
2194
         declare
2195
            Nam : Node_Id := Name (Unit (N));
2196
 
2197
         begin
2198
            if Nkind (Nam) = N_Selected_Component then
2199
               Nam := Selector_Name (Nam);
2200
            end if;
2201
 
2202
            Check_Identifier (Nam, Par_Unit);
2203
         end;
2204
      end if;
2205
 
2206
      if not Is_Empty_List (Context_Items (N)) then
2207
 
2208
         --  Save current use clauses
2209
 
2210
         Remove_Scope;
2211
         Remove_Context (Lib_Unit);
2212
 
2213
         --  Now remove parents and their context, including enclosing subunits
2214
         --  and the outer parent body which is not a subunit.
2215
 
2216
         if Present (Lib_Spec) then
2217
            Remove_Context (Lib_Spec);
2218
 
2219
            while Nkind (Unit (Lib_Spec)) = N_Subunit loop
2220
               Lib_Spec := Library_Unit (Lib_Spec);
2221
               Remove_Scope;
2222
               Remove_Context (Lib_Spec);
2223
            end loop;
2224
 
2225
            if Nkind (Unit (Lib_Unit)) = N_Subunit then
2226
               Remove_Scope;
2227
            end if;
2228
 
2229
            if Nkind (Unit (Lib_Spec)) = N_Package_Body then
2230
               Remove_Context (Library_Unit (Lib_Spec));
2231
            end if;
2232
         end if;
2233
 
2234
         Set_Is_Immediately_Visible (Par_Unit, False);
2235
 
2236
         Analyze_Subunit_Context;
2237
 
2238
         Re_Install_Parents (Lib_Unit, Par_Unit);
2239
         Set_Is_Immediately_Visible (Par_Unit);
2240
 
2241
         --  If the context includes a child unit of the parent of the subunit,
2242
         --  the parent will have been removed from visibility, after compiling
2243
         --  that cousin in the context. The visibility of the parent must be
2244
         --  restored now. This also applies if the context includes another
2245
         --  subunit of the same parent which in turn includes a child unit in
2246
         --  its context.
2247
 
2248
         if Is_Package_Or_Generic_Package (Par_Unit) then
2249
            if not Is_Immediately_Visible (Par_Unit)
2250
              or else (Present (First_Entity (Par_Unit))
2251
                        and then not Is_Immediately_Visible
2252
                                      (First_Entity (Par_Unit)))
2253
            then
2254
               Set_Is_Immediately_Visible   (Par_Unit);
2255
               Install_Visible_Declarations (Par_Unit);
2256
               Install_Private_Declarations (Par_Unit);
2257
            end if;
2258
         end if;
2259
 
2260
         Re_Install_Use_Clauses;
2261
         Install_Context (N);
2262
 
2263
         --  Restore state of suppress flags for current body
2264
 
2265
         Scope_Suppress := Svg;
2266
 
2267
         --  If the subunit is within a child unit, then siblings of any parent
2268
         --  unit that appear in the context clause of the subunit must also be
2269
         --  made immediately visible.
2270
 
2271
         if Present (Enclosing_Child) then
2272
            Install_Siblings (Enclosing_Child, N);
2273
         end if;
2274
      end if;
2275
 
2276
      Analyze (Proper_Body (Unit (N)));
2277
      Remove_Context (N);
2278
 
2279
      --  The subunit may contain a with_clause on a sibling of some ancestor.
2280
      --  Removing the context will remove from visibility those ancestor child
2281
      --  units, which must be restored to the visibility they have in the
2282
      --  enclosing body.
2283
 
2284
      if Present (Enclosing_Child) then
2285
         declare
2286
            C : Entity_Id;
2287
         begin
2288
            C := Current_Scope;
2289
            while Present (C)
2290
              and then Is_Child_Unit (C)
2291
            loop
2292
               Set_Is_Immediately_Visible (C);
2293
               Set_Is_Visible_Child_Unit (C);
2294
               C := Scope (C);
2295
            end loop;
2296
         end;
2297
      end if;
2298
 
2299
      --  Deal with restore of restrictions
2300
 
2301
      Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
2302
   end Analyze_Subunit;
2303
 
2304
   ----------------------------
2305
   -- Analyze_Task_Body_Stub --
2306
   ----------------------------
2307
 
2308
   procedure Analyze_Task_Body_Stub (N : Node_Id) is
2309
      Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
2310
      Loc : constant Source_Ptr := Sloc (N);
2311
 
2312
   begin
2313
      Check_Stub_Level (N);
2314
 
2315
      --  First occurrence of name may have been as an incomplete type
2316
 
2317
      if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
2318
         Nam := Full_View (Nam);
2319
      end if;
2320
 
2321
      if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
2322
         Error_Msg_N ("missing specification for task body", N);
2323
      else
2324
         Set_Scope (Defining_Entity (N), Current_Scope);
2325
         Generate_Reference (Nam, Defining_Identifier (N), 'b');
2326
 
2327
         --  Check for duplicate stub, if so give message and terminate
2328
 
2329
         if Has_Completion (Etype (Nam)) then
2330
            Error_Msg_N ("duplicate stub for task", N);
2331
            return;
2332
         else
2333
            Set_Has_Completion (Etype (Nam));
2334
         end if;
2335
 
2336
         Analyze_Proper_Body (N, Etype (Nam));
2337
 
2338
         --  Set elaboration flag to indicate that entity is callable. This
2339
         --  cannot be done in the expansion of the body itself, because the
2340
         --  proper body is not in a declarative part. This is only done if
2341
         --  expansion is active, because the context may be generic and the
2342
         --  flag not defined yet.
2343
 
2344
         if Full_Expander_Active then
2345
            Insert_After (N,
2346
              Make_Assignment_Statement (Loc,
2347
                Name =>
2348
                  Make_Identifier (Loc,
2349
                    Chars => New_External_Name (Chars (Etype (Nam)), 'E')),
2350
                 Expression => New_Reference_To (Standard_True, Loc)));
2351
         end if;
2352
      end if;
2353
   end Analyze_Task_Body_Stub;
2354
 
2355
   -------------------------
2356
   -- Analyze_With_Clause --
2357
   -------------------------
2358
 
2359
   --  Analyze the declaration of a unit in a with clause. At end, label the
2360
   --  with clause with the defining entity for the unit.
2361
 
2362
   procedure Analyze_With_Clause (N : Node_Id) is
2363
 
2364
      --  Retrieve the original kind of the unit node, before analysis. If it
2365
      --  is a subprogram instantiation, its analysis below will rewrite the
2366
      --  node as the declaration of the wrapper package. If the same
2367
      --  instantiation appears indirectly elsewhere in the context, it will
2368
      --  have been analyzed already.
2369
 
2370
      Unit_Kind : constant Node_Kind :=
2371
                    Nkind (Original_Node (Unit (Library_Unit (N))));
2372
      Nam       : constant Node_Id := Name (N);
2373
      E_Name    : Entity_Id;
2374
      Par_Name  : Entity_Id;
2375
      Pref      : Node_Id;
2376
      U         : Node_Id;
2377
 
2378
      Intunit : Boolean;
2379
      --  Set True if the unit currently being compiled is an internal unit
2380
 
2381
      Restriction_Violation : Boolean := False;
2382
      --  Set True if a with violates a restriction, no point in giving any
2383
      --  warnings if we have this definite error.
2384
 
2385
      Save_Style_Check : constant Boolean := Opt.Style_Check;
2386
 
2387
   begin
2388
      U := Unit (Library_Unit (N));
2389
 
2390
      --  If this is an internal unit which is a renaming, then this is a
2391
      --  violation of No_Obsolescent_Features.
2392
 
2393
      --  Note: this is not quite right if the user defines one of these units
2394
      --  himself, but that's a marginal case, and fixing it is hard ???
2395
 
2396
      if Restriction_Check_Required (No_Obsolescent_Features) then
2397
         declare
2398
            F : constant File_Name_Type :=
2399
                  Unit_File_Name (Get_Source_Unit (U));
2400
         begin
2401
            if Is_Predefined_File_Name (F, Renamings_Included => True)
2402
                 and then not
2403
               Is_Predefined_File_Name (F, Renamings_Included => False)
2404
            then
2405
               Check_Restriction (No_Obsolescent_Features, N);
2406
               Restriction_Violation := True;
2407
            end if;
2408
         end;
2409
      end if;
2410
 
2411
      --  Check No_Implementation_Units violation
2412
 
2413
      if Restriction_Check_Required (No_Implementation_Units) then
2414
         if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then
2415
            null;
2416
         else
2417
            Check_Restriction (No_Implementation_Units, Nam);
2418
            Restriction_Violation := True;
2419
         end if;
2420
      end if;
2421
 
2422
      --  Several actions are skipped for dummy packages (those supplied for
2423
      --  with's where no matching file could be found). Such packages are
2424
      --  identified by the Sloc value being set to No_Location.
2425
 
2426
      if Limited_Present (N) then
2427
 
2428
         --  Ada 2005 (AI-50217): Build visibility structures but do not
2429
         --  analyze the unit.
2430
 
2431
         if Sloc (U) /= No_Location then
2432
            Build_Limited_Views (N);
2433
         end if;
2434
 
2435
         return;
2436
      end if;
2437
 
2438
      --  We reset ordinary style checking during the analysis of a with'ed
2439
      --  unit, but we do NOT reset GNAT special analysis mode (the latter
2440
      --  definitely *does* apply to with'ed units).
2441
 
2442
      if not GNAT_Mode then
2443
         Style_Check := False;
2444
      end if;
2445
 
2446
      --  If the library unit is a predefined unit, and we are in high
2447
      --  integrity mode, then temporarily reset Configurable_Run_Time_Mode
2448
      --  for the analysis of the with'ed unit. This mode does not prevent
2449
      --  explicit with'ing of run-time units.
2450
 
2451
      if Configurable_Run_Time_Mode
2452
        and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U)))
2453
      then
2454
         Configurable_Run_Time_Mode := False;
2455
         Semantics (Library_Unit (N));
2456
         Configurable_Run_Time_Mode := True;
2457
 
2458
      else
2459
         Semantics (Library_Unit (N));
2460
      end if;
2461
 
2462
      Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
2463
 
2464
      if Sloc (U) /= No_Location then
2465
 
2466
         --  Check restrictions, except that we skip the check if this is an
2467
         --  internal unit unless we are compiling the internal unit as the
2468
         --  main unit. We also skip this for dummy packages.
2469
 
2470
         Check_Restriction_No_Dependence (Nam, N);
2471
 
2472
         if not Intunit or else Current_Sem_Unit = Main_Unit then
2473
            Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
2474
         end if;
2475
 
2476
         --  Deal with special case of GNAT.Current_Exceptions which interacts
2477
         --  with the optimization of local raise statements into gotos.
2478
 
2479
         if Nkind (Nam) = N_Selected_Component
2480
           and then Nkind (Prefix (Nam)) = N_Identifier
2481
           and then Chars (Prefix (Nam)) = Name_Gnat
2482
           and then (Chars (Selector_Name (Nam)) = Name_Most_Recent_Exception
2483
                       or else
2484
                     Chars (Selector_Name (Nam)) = Name_Exception_Traces)
2485
         then
2486
            Check_Restriction (No_Exception_Propagation, N);
2487
            Special_Exception_Package_Used := True;
2488
         end if;
2489
 
2490
         --  Check for inappropriate with of internal implementation unit if we
2491
         --  are not compiling an internal unit and also check for withing unit
2492
         --  in wrong version of Ada. Do not issue these messages for implicit
2493
         --  with's generated by the compiler itself.
2494
 
2495
         if Implementation_Unit_Warnings
2496
           and then not Intunit
2497
           and then not Implicit_With (N)
2498
           and then not Restriction_Violation
2499
         then
2500
            declare
2501
               U_Kind : constant Kind_Of_Unit :=
2502
                          Get_Kind_Of_Unit (Get_Source_Unit (U));
2503
 
2504
            begin
2505
               if U_Kind = Implementation_Unit then
2506
                  Error_Msg_F ("& is an internal 'G'N'A'T unit?", Name (N));
2507
 
2508
                  --  Add alternative name if available, otherwise issue a
2509
                  --  general warning message.
2510
 
2511
                  if Error_Msg_Strlen /= 0 then
2512
                     Error_Msg_F ("\use ""~"" instead", Name (N));
2513
                  else
2514
                     Error_Msg_F
2515
                       ("\use of this unit is non-portable " &
2516
                        "and version-dependent?", Name (N));
2517
                  end if;
2518
 
2519
               elsif U_Kind = Ada_2005_Unit
2520
                 and then Ada_Version < Ada_2005
2521
                 and then Warn_On_Ada_2005_Compatibility
2522
               then
2523
                  Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
2524
 
2525
               elsif U_Kind = Ada_2012_Unit
2526
                 and then Ada_Version < Ada_2012
2527
                 and then Warn_On_Ada_2012_Compatibility
2528
               then
2529
                  Error_Msg_N ("& is an Ada 2012 unit?", Name (N));
2530
               end if;
2531
            end;
2532
         end if;
2533
      end if;
2534
 
2535
      --  Semantic analysis of a generic unit is performed on a copy of
2536
      --  the original tree. Retrieve the entity on  which semantic info
2537
      --  actually appears.
2538
 
2539
      if Unit_Kind in N_Generic_Declaration then
2540
         E_Name := Defining_Entity (U);
2541
 
2542
      --  Note: in the following test, Unit_Kind is the original Nkind, but in
2543
      --  the case of an instantiation, semantic analysis above will have
2544
      --  replaced the unit by its instantiated version. If the instance body
2545
      --  has been generated, the instance now denotes the body entity. For
2546
      --  visibility purposes we need the entity of its spec.
2547
 
2548
      elsif (Unit_Kind = N_Package_Instantiation
2549
              or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
2550
                                                  N_Package_Instantiation)
2551
        and then Nkind (U) = N_Package_Body
2552
      then
2553
         E_Name := Corresponding_Spec (U);
2554
 
2555
      elsif Unit_Kind = N_Package_Instantiation
2556
        and then Nkind (U) = N_Package_Instantiation
2557
        and then Present (Instance_Spec (U))
2558
      then
2559
         --  If the instance has not been rewritten as a package declaration,
2560
         --  then it appeared already in a previous with clause. Retrieve
2561
         --  the entity from the previous instance.
2562
 
2563
         E_Name := Defining_Entity (Specification (Instance_Spec (U)));
2564
 
2565
      elsif Unit_Kind in N_Subprogram_Instantiation then
2566
 
2567
         --  The visible subprogram is created during instantiation, and is
2568
         --  an attribute of the wrapper package. We retrieve the wrapper
2569
         --  package directly from the instantiation node. If the instance
2570
         --  is inlined the unit is still an instantiation. Otherwise it has
2571
         --  been rewritten as the declaration of the wrapper itself.
2572
 
2573
         if Nkind (U) in N_Subprogram_Instantiation then
2574
            E_Name :=
2575
              Related_Instance
2576
                (Defining_Entity (Specification (Instance_Spec (U))));
2577
         else
2578
            E_Name := Related_Instance (Defining_Entity (U));
2579
         end if;
2580
 
2581
      elsif Unit_Kind = N_Package_Renaming_Declaration
2582
        or else Unit_Kind in N_Generic_Renaming_Declaration
2583
      then
2584
         E_Name := Defining_Entity (U);
2585
 
2586
      elsif Unit_Kind = N_Subprogram_Body
2587
        and then Nkind (Name (N)) = N_Selected_Component
2588
        and then not Acts_As_Spec (Library_Unit (N))
2589
      then
2590
         --  For a child unit that has no spec, one has been created and
2591
         --  analyzed. The entity required is that of the spec.
2592
 
2593
         E_Name := Corresponding_Spec (U);
2594
 
2595
      else
2596
         E_Name := Defining_Entity (U);
2597
      end if;
2598
 
2599
      if Nkind (Name (N)) = N_Selected_Component then
2600
 
2601
         --  Child unit in a with clause
2602
 
2603
         Change_Selected_Component_To_Expanded_Name (Name (N));
2604
 
2605
         --  If this is a child unit without a spec, and it has been analyzed
2606
         --  already, a declaration has been created for it. The with_clause
2607
         --  must reflect the actual body, and not the generated declaration,
2608
         --  to prevent spurious binding errors involving an out-of-date spec.
2609
         --  Note that this can only happen if the unit includes more than one
2610
         --  with_clause for the child unit (e.g. in separate subunits).
2611
 
2612
         if Unit_Kind = N_Subprogram_Declaration
2613
           and then Analyzed (Library_Unit (N))
2614
           and then not Comes_From_Source (Library_Unit (N))
2615
         then
2616
            Set_Library_Unit (N,
2617
               Cunit (Get_Source_Unit (Corresponding_Body (U))));
2618
         end if;
2619
      end if;
2620
 
2621
      --  Restore style checks
2622
 
2623
      Style_Check := Save_Style_Check;
2624
 
2625
      --  Record the reference, but do NOT set the unit as referenced, we want
2626
      --  to consider the unit as unreferenced if this is the only reference
2627
      --  that occurs.
2628
 
2629
      Set_Entity_With_Style_Check (Name (N), E_Name);
2630
      Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
2631
 
2632
      --  Generate references and check No_Dependence restriction for parents
2633
 
2634
      if Is_Child_Unit (E_Name) then
2635
         Pref     := Prefix (Name (N));
2636
         Par_Name := Scope (E_Name);
2637
         while Nkind (Pref) = N_Selected_Component loop
2638
            Change_Selected_Component_To_Expanded_Name (Pref);
2639
 
2640
            if Present (Entity (Selector_Name (Pref)))
2641
              and then
2642
                Present (Renamed_Entity (Entity (Selector_Name (Pref))))
2643
              and then Entity (Selector_Name (Pref)) /= Par_Name
2644
            then
2645
            --  The prefix is a child unit that denotes a renaming declaration.
2646
            --  Replace the prefix directly with the renamed unit, because the
2647
            --  rest of the prefix is irrelevant to the visibility of the real
2648
            --  unit.
2649
 
2650
               Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref)));
2651
               exit;
2652
            end if;
2653
 
2654
            Set_Entity_With_Style_Check (Pref, Par_Name);
2655
 
2656
            Generate_Reference (Par_Name, Pref);
2657
            Check_Restriction_No_Dependence (Pref, N);
2658
            Pref := Prefix (Pref);
2659
 
2660
            --  If E_Name is the dummy entity for a nonexistent unit, its scope
2661
            --  is set to Standard_Standard, and no attempt should be made to
2662
            --  further unwind scopes.
2663
 
2664
            if Par_Name /= Standard_Standard then
2665
               Par_Name := Scope (Par_Name);
2666
            end if;
2667
 
2668
            --  Abandon processing in case of previous errors
2669
 
2670
            if No (Par_Name) then
2671
               pragma Assert (Serious_Errors_Detected /= 0);
2672
               return;
2673
            end if;
2674
         end loop;
2675
 
2676
         if Present (Entity (Pref))
2677
           and then not Analyzed (Parent (Parent (Entity (Pref))))
2678
         then
2679
            --  If the entity is set without its unit being compiled, the
2680
            --  original parent is a renaming, and Par_Name is the renamed
2681
            --  entity. For visibility purposes, we need the original entity,
2682
            --  which must be analyzed now because Load_Unit directly retrieves
2683
            --  the renamed unit, and the renaming declaration itself has not
2684
            --  been analyzed.
2685
 
2686
            Analyze (Parent (Parent (Entity (Pref))));
2687
            pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
2688
            Par_Name := Entity (Pref);
2689
         end if;
2690
 
2691
         --  Guard against missing or misspelled child units
2692
 
2693
         if Present (Par_Name) then
2694
            Set_Entity_With_Style_Check (Pref, Par_Name);
2695
            Generate_Reference (Par_Name, Pref);
2696
 
2697
         else
2698
            pragma Assert (Serious_Errors_Detected /= 0);
2699
 
2700
            --  Mark the node to indicate that a related error has been posted.
2701
            --  This defends further compilation passes against improper use of
2702
            --  the invalid WITH clause node.
2703
 
2704
            Set_Error_Posted (N);
2705
            Set_Name (N, Error);
2706
            return;
2707
         end if;
2708
      end if;
2709
 
2710
      --  If the withed unit is System, and a system extension pragma is
2711
      --  present, compile the extension now, rather than waiting for a
2712
      --  visibility check on a specific entity.
2713
 
2714
      if Chars (E_Name) = Name_System
2715
        and then Scope (E_Name) = Standard_Standard
2716
        and then Present (System_Extend_Unit)
2717
        and then Present_System_Aux (N)
2718
      then
2719
         --  If the extension is not present, an error will have been emitted
2720
 
2721
         null;
2722
      end if;
2723
 
2724
      --  Ada 2005 (AI-262): Remove from visibility the entity corresponding
2725
      --  to private_with units; they will be made visible later (just before
2726
      --  the private part is analyzed)
2727
 
2728
      if Private_Present (N) then
2729
         Set_Is_Immediately_Visible (E_Name, False);
2730
      end if;
2731
   end Analyze_With_Clause;
2732
 
2733
   ------------------------------
2734
   -- Check_Private_Child_Unit --
2735
   ------------------------------
2736
 
2737
   procedure Check_Private_Child_Unit (N : Node_Id) is
2738
      Lib_Unit   : constant Node_Id := Unit (N);
2739
      Item       : Node_Id;
2740
      Curr_Unit  : Entity_Id;
2741
      Sub_Parent : Node_Id;
2742
      Priv_Child : Entity_Id;
2743
      Par_Lib    : Entity_Id;
2744
      Par_Spec   : Node_Id;
2745
 
2746
      function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
2747
      --  Returns true if and only if the library unit is declared with
2748
      --  an explicit designation of private.
2749
 
2750
      -----------------------------
2751
      -- Is_Private_Library_Unit --
2752
      -----------------------------
2753
 
2754
      function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
2755
         Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
2756
 
2757
      begin
2758
         return Private_Present (Comp_Unit);
2759
      end Is_Private_Library_Unit;
2760
 
2761
   --  Start of processing for Check_Private_Child_Unit
2762
 
2763
   begin
2764
      if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then
2765
         Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
2766
         Par_Lib   := Curr_Unit;
2767
 
2768
      elsif Nkind (Lib_Unit) = N_Subunit then
2769
 
2770
         --  The parent is itself a body. The parent entity is to be found in
2771
         --  the corresponding spec.
2772
 
2773
         Sub_Parent := Library_Unit (N);
2774
         Curr_Unit  := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
2775
 
2776
         --  If the parent itself is a subunit, Curr_Unit is the entity of the
2777
         --  enclosing body, retrieve the spec entity which is the proper
2778
         --  ancestor we need for the following tests.
2779
 
2780
         if Ekind (Curr_Unit) = E_Package_Body then
2781
            Curr_Unit := Spec_Entity (Curr_Unit);
2782
         end if;
2783
 
2784
         Par_Lib    := Curr_Unit;
2785
 
2786
      else
2787
         Curr_Unit := Defining_Entity (Lib_Unit);
2788
 
2789
         Par_Lib := Curr_Unit;
2790
         Par_Spec  := Parent_Spec (Lib_Unit);
2791
 
2792
         if No (Par_Spec) then
2793
            Par_Lib := Empty;
2794
         else
2795
            Par_Lib := Defining_Entity (Unit (Par_Spec));
2796
         end if;
2797
      end if;
2798
 
2799
      --  Loop through context items
2800
 
2801
      Item := First (Context_Items (N));
2802
      while Present (Item) loop
2803
 
2804
         --  Ada 2005 (AI-262): Allow private_with of a private child package
2805
         --  in public siblings
2806
 
2807
         if Nkind (Item) = N_With_Clause
2808
            and then not Implicit_With (Item)
2809
            and then not Limited_Present (Item)
2810
            and then Is_Private_Descendant (Entity (Name (Item)))
2811
         then
2812
            Priv_Child := Entity (Name (Item));
2813
 
2814
            declare
2815
               Curr_Parent  : Entity_Id := Par_Lib;
2816
               Child_Parent : Entity_Id := Scope (Priv_Child);
2817
               Prv_Ancestor : Entity_Id := Child_Parent;
2818
               Curr_Private : Boolean   := Is_Private_Library_Unit (Curr_Unit);
2819
 
2820
            begin
2821
               --  If the child unit is a public child then locate the nearest
2822
               --  private ancestor. Child_Parent will then be set to the
2823
               --  parent of that ancestor.
2824
 
2825
               if not Is_Private_Library_Unit (Priv_Child) then
2826
                  while Present (Prv_Ancestor)
2827
                    and then not Is_Private_Library_Unit (Prv_Ancestor)
2828
                  loop
2829
                     Prv_Ancestor := Scope (Prv_Ancestor);
2830
                  end loop;
2831
 
2832
                  if Present (Prv_Ancestor) then
2833
                     Child_Parent := Scope (Prv_Ancestor);
2834
                  end if;
2835
               end if;
2836
 
2837
               while Present (Curr_Parent)
2838
                 and then Curr_Parent /= Standard_Standard
2839
                 and then Curr_Parent /= Child_Parent
2840
               loop
2841
                  Curr_Private :=
2842
                    Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
2843
                  Curr_Parent := Scope (Curr_Parent);
2844
               end loop;
2845
 
2846
               if No (Curr_Parent) then
2847
                  Curr_Parent := Standard_Standard;
2848
               end if;
2849
 
2850
               if Curr_Parent /= Child_Parent then
2851
                  if Ekind (Priv_Child) = E_Generic_Package
2852
                    and then Chars (Priv_Child) in Text_IO_Package_Name
2853
                    and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
2854
                  then
2855
                     Error_Msg_NE
2856
                       ("& is a nested package, not a compilation unit",
2857
                       Name (Item), Priv_Child);
2858
 
2859
                  else
2860
                     Error_Msg_N
2861
                       ("unit in with clause is private child unit!", Item);
2862
                     Error_Msg_NE
2863
                       ("\current unit must also have parent&!",
2864
                        Item, Child_Parent);
2865
                  end if;
2866
 
2867
               elsif Curr_Private
2868
                 or else Private_Present (Item)
2869
                 or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit)
2870
                 or else (Nkind (Lib_Unit) = N_Subprogram_Body
2871
                            and then not Acts_As_Spec (Parent (Lib_Unit)))
2872
               then
2873
                  null;
2874
 
2875
               else
2876
                  Error_Msg_NE
2877
                    ("current unit must also be private descendant of&",
2878
                     Item, Child_Parent);
2879
               end if;
2880
            end;
2881
         end if;
2882
 
2883
         Next (Item);
2884
      end loop;
2885
 
2886
   end Check_Private_Child_Unit;
2887
 
2888
   ----------------------
2889
   -- Check_Stub_Level --
2890
   ----------------------
2891
 
2892
   procedure Check_Stub_Level (N : Node_Id) is
2893
      Par  : constant Node_Id   := Parent (N);
2894
      Kind : constant Node_Kind := Nkind (Par);
2895
 
2896
   begin
2897
      if Nkind_In (Kind, N_Package_Body,
2898
                         N_Subprogram_Body,
2899
                         N_Task_Body,
2900
                         N_Protected_Body)
2901
        and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit)
2902
      then
2903
         null;
2904
 
2905
      --  In an instance, a missing stub appears at any level. A warning
2906
      --  message will have been emitted already for the missing file.
2907
 
2908
      elsif not In_Instance then
2909
         Error_Msg_N ("stub cannot appear in an inner scope", N);
2910
 
2911
      elsif Expander_Active then
2912
         Error_Msg_N ("missing proper body", N);
2913
      end if;
2914
   end Check_Stub_Level;
2915
 
2916
   ------------------------
2917
   -- Expand_With_Clause --
2918
   ------------------------
2919
 
2920
   procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
2921
      Loc   : constant Source_Ptr := Sloc (Nam);
2922
      Ent   : constant Entity_Id := Entity (Nam);
2923
      Withn : Node_Id;
2924
      P     : Node_Id;
2925
 
2926
      function Build_Unit_Name (Nam : Node_Id) return Node_Id;
2927
      --  Build name to be used in implicit with_clause. In most cases this
2928
      --  is the source name, but if renamings are present we must make the
2929
      --  original unit visible, not the one it renames. The entity in the
2930
      --  with clause is the renamed unit, but the identifier is the one from
2931
      --  the source, which allows us to recover the unit renaming.
2932
 
2933
      ---------------------
2934
      -- Build_Unit_Name --
2935
      ---------------------
2936
 
2937
      function Build_Unit_Name (Nam : Node_Id) return Node_Id is
2938
         Ent      : Entity_Id;
2939
         Result   : Node_Id;
2940
 
2941
      begin
2942
         if Nkind (Nam) = N_Identifier then
2943
            return New_Occurrence_Of (Entity (Nam), Loc);
2944
 
2945
         else
2946
            Ent := Entity (Nam);
2947
 
2948
            if Present (Entity (Selector_Name (Nam)))
2949
              and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent)
2950
              and then
2951
                Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam))))
2952
                  = N_Package_Renaming_Declaration
2953
            then
2954
               --  The name in the with_clause is of the form A.B.C, and B is
2955
               --  given by a renaming declaration. In that case we may not
2956
               --  have analyzed the unit for B, but replaced it directly in
2957
               --  lib-load with the unit it renames. We have to make A.B
2958
               --  visible, so analyze the declaration for B now, in case it
2959
               --  has not been done yet.
2960
 
2961
               Ent :=  Entity (Selector_Name (Nam));
2962
               Analyze
2963
                 (Parent
2964
                   (Unit_Declaration_Node (Entity (Selector_Name (Nam)))));
2965
            end if;
2966
 
2967
            Result :=
2968
              Make_Expanded_Name (Loc,
2969
                Chars  => Chars (Entity (Nam)),
2970
                Prefix => Build_Unit_Name (Prefix (Nam)),
2971
                Selector_Name => New_Occurrence_Of (Ent, Loc));
2972
            Set_Entity (Result, Ent);
2973
            return Result;
2974
         end if;
2975
      end Build_Unit_Name;
2976
 
2977
   --  Start of processing for Expand_With_Clause
2978
 
2979
   begin
2980
      New_Nodes_OK := New_Nodes_OK + 1;
2981
      Withn :=
2982
        Make_With_Clause (Loc,
2983
          Name => Build_Unit_Name (Nam));
2984
 
2985
      P := Parent (Unit_Declaration_Node (Ent));
2986
      Set_Library_Unit       (Withn, P);
2987
      Set_Corresponding_Spec (Withn, Ent);
2988
      Set_First_Name         (Withn, True);
2989
      Set_Implicit_With      (Withn, True);
2990
 
2991
      --  If the unit is a package declaration, a private_with_clause on a
2992
      --  child unit implies the implicit with on the parent is also private.
2993
 
2994
      if Nkind (Unit (N)) = N_Package_Declaration then
2995
         Set_Private_Present (Withn, Private_Present (Item));
2996
      end if;
2997
 
2998
      Prepend (Withn, Context_Items (N));
2999
      Mark_Rewrite_Insertion (Withn);
3000
      Install_Withed_Unit (Withn);
3001
 
3002
      if Nkind (Nam) = N_Expanded_Name then
3003
         Expand_With_Clause (Item, Prefix (Nam), N);
3004
      end if;
3005
 
3006
      New_Nodes_OK := New_Nodes_OK - 1;
3007
   end Expand_With_Clause;
3008
 
3009
   -----------------------
3010
   -- Get_Parent_Entity --
3011
   -----------------------
3012
 
3013
   function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
3014
   begin
3015
      if Nkind (Unit) = N_Package_Body
3016
        and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
3017
      then
3018
         return Defining_Entity
3019
                 (Specification (Instance_Spec (Original_Node (Unit))));
3020
      elsif Nkind (Unit) = N_Package_Instantiation then
3021
         return Defining_Entity (Specification (Instance_Spec (Unit)));
3022
      else
3023
         return Defining_Entity (Unit);
3024
      end if;
3025
   end Get_Parent_Entity;
3026
 
3027
   ---------------------
3028
   -- Has_With_Clause --
3029
   ---------------------
3030
 
3031
   function Has_With_Clause
3032
     (C_Unit     : Node_Id;
3033
      Pack       : Entity_Id;
3034
      Is_Limited : Boolean := False) return Boolean
3035
   is
3036
      Item : Node_Id;
3037
 
3038
      function Named_Unit (Clause : Node_Id) return Entity_Id;
3039
      --  Return the entity for the unit named in a [limited] with clause
3040
 
3041
      ----------------
3042
      -- Named_Unit --
3043
      ----------------
3044
 
3045
      function Named_Unit (Clause : Node_Id) return Entity_Id is
3046
      begin
3047
         if Nkind (Name (Clause)) = N_Selected_Component then
3048
            return Entity (Selector_Name (Name (Clause)));
3049
         else
3050
            return Entity (Name (Clause));
3051
         end if;
3052
      end Named_Unit;
3053
 
3054
   --  Start of processing for Has_With_Clause
3055
 
3056
   begin
3057
      if Present (Context_Items (C_Unit)) then
3058
         Item := First (Context_Items (C_Unit));
3059
         while Present (Item) loop
3060
            if Nkind (Item) = N_With_Clause
3061
              and then Limited_Present (Item) = Is_Limited
3062
              and then Named_Unit (Item) = Pack
3063
            then
3064
               return True;
3065
            end if;
3066
 
3067
            Next (Item);
3068
         end loop;
3069
      end if;
3070
 
3071
      return False;
3072
   end Has_With_Clause;
3073
 
3074
   -----------------------------
3075
   -- Implicit_With_On_Parent --
3076
   -----------------------------
3077
 
3078
   procedure Implicit_With_On_Parent
3079
     (Child_Unit : Node_Id;
3080
      N          : Node_Id)
3081
   is
3082
      Loc    : constant Source_Ptr := Sloc (N);
3083
      P      : constant Node_Id    := Parent_Spec (Child_Unit);
3084
      P_Unit : Node_Id             := Unit (P);
3085
      P_Name : constant Entity_Id  := Get_Parent_Entity (P_Unit);
3086
      Withn  : Node_Id;
3087
 
3088
      function Build_Ancestor_Name (P : Node_Id) return Node_Id;
3089
      --  Build prefix of child unit name. Recurse if needed
3090
 
3091
      function Build_Unit_Name return Node_Id;
3092
      --  If the unit is a child unit, build qualified name with all ancestors
3093
 
3094
      -------------------------
3095
      -- Build_Ancestor_Name --
3096
      -------------------------
3097
 
3098
      function Build_Ancestor_Name (P : Node_Id) return Node_Id is
3099
         P_Ref  : constant Node_Id :=
3100
                   New_Reference_To (Defining_Entity (P), Loc);
3101
         P_Spec : Node_Id := P;
3102
 
3103
      begin
3104
         --  Ancestor may have been rewritten as a package body. Retrieve
3105
         --  the original spec to trace earlier ancestors.
3106
 
3107
         if Nkind (P) = N_Package_Body
3108
           and then Nkind (Original_Node (P)) = N_Package_Instantiation
3109
         then
3110
            P_Spec := Original_Node (P);
3111
         end if;
3112
 
3113
         if No (Parent_Spec (P_Spec)) then
3114
            return P_Ref;
3115
         else
3116
            return
3117
              Make_Selected_Component (Loc,
3118
                Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
3119
                Selector_Name => P_Ref);
3120
         end if;
3121
      end Build_Ancestor_Name;
3122
 
3123
      ---------------------
3124
      -- Build_Unit_Name --
3125
      ---------------------
3126
 
3127
      function Build_Unit_Name return Node_Id is
3128
         Result : Node_Id;
3129
 
3130
      begin
3131
         if No (Parent_Spec (P_Unit)) then
3132
            return New_Reference_To (P_Name, Loc);
3133
 
3134
         else
3135
            Result :=
3136
              Make_Expanded_Name (Loc,
3137
                Chars  => Chars (P_Name),
3138
                Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
3139
                Selector_Name => New_Reference_To (P_Name, Loc));
3140
            Set_Entity (Result, P_Name);
3141
            return Result;
3142
         end if;
3143
      end Build_Unit_Name;
3144
 
3145
   --  Start of processing for Implicit_With_On_Parent
3146
 
3147
   begin
3148
      --  The unit of the current compilation may be a package body that
3149
      --  replaces an instance node. In this case we need the original instance
3150
      --  node to construct the proper parent name.
3151
 
3152
      if Nkind (P_Unit) = N_Package_Body
3153
        and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
3154
      then
3155
         P_Unit := Original_Node (P_Unit);
3156
      end if;
3157
 
3158
      --  We add the implicit with if the child unit is the current unit being
3159
      --  compiled. If the current unit is a body, we do not want to add an
3160
      --  implicit_with a second time to the corresponding spec.
3161
 
3162
      if Nkind (Child_Unit) = N_Package_Declaration
3163
        and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
3164
      then
3165
         return;
3166
      end if;
3167
 
3168
      New_Nodes_OK := New_Nodes_OK + 1;
3169
      Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
3170
 
3171
      Set_Library_Unit          (Withn, P);
3172
      Set_Corresponding_Spec    (Withn, P_Name);
3173
      Set_First_Name            (Withn, True);
3174
      Set_Implicit_With         (Withn, True);
3175
 
3176
      --  Node is placed at the beginning of the context items, so that
3177
      --  subsequent use clauses on the parent can be validated.
3178
 
3179
      Prepend (Withn, Context_Items (N));
3180
      Mark_Rewrite_Insertion (Withn);
3181
      Install_Withed_Unit (Withn);
3182
 
3183
      if Is_Child_Spec (P_Unit) then
3184
         Implicit_With_On_Parent (P_Unit, N);
3185
      end if;
3186
 
3187
      New_Nodes_OK := New_Nodes_OK - 1;
3188
   end Implicit_With_On_Parent;
3189
 
3190
   --------------
3191
   -- In_Chain --
3192
   --------------
3193
 
3194
   function In_Chain (E : Entity_Id) return Boolean is
3195
      H : Entity_Id;
3196
 
3197
   begin
3198
      H := Current_Entity (E);
3199
      while Present (H) loop
3200
         if H = E then
3201
            return True;
3202
         else
3203
            H := Homonym (H);
3204
         end if;
3205
      end loop;
3206
 
3207
      return False;
3208
   end In_Chain;
3209
 
3210
   ---------------------
3211
   -- Install_Context --
3212
   ---------------------
3213
 
3214
   procedure Install_Context (N : Node_Id) is
3215
      Lib_Unit : constant Node_Id := Unit (N);
3216
 
3217
   begin
3218
      Install_Context_Clauses (N);
3219
 
3220
      if Is_Child_Spec (Lib_Unit) then
3221
         Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
3222
      end if;
3223
 
3224
      Install_Limited_Context_Clauses (N);
3225
   end Install_Context;
3226
 
3227
   -----------------------------
3228
   -- Install_Context_Clauses --
3229
   -----------------------------
3230
 
3231
   procedure Install_Context_Clauses (N : Node_Id) is
3232
      Lib_Unit      : constant Node_Id := Unit (N);
3233
      Item          : Node_Id;
3234
      Uname_Node    : Entity_Id;
3235
      Check_Private : Boolean := False;
3236
      Decl_Node     : Node_Id;
3237
      Lib_Parent    : Entity_Id;
3238
 
3239
   begin
3240
      --  First skip configuration pragmas at the start of the context. They
3241
      --  are not technically part of the context clause, but that's where the
3242
      --  parser puts them. Note they were analyzed in Analyze_Context.
3243
 
3244
      Item := First (Context_Items (N));
3245
      while Present (Item)
3246
        and then Nkind (Item) = N_Pragma
3247
        and then Pragma_Name (Item) in Configuration_Pragma_Names
3248
      loop
3249
         Next (Item);
3250
      end loop;
3251
 
3252
      --  Loop through the actual context clause items. We process everything
3253
      --  except Limited_With clauses in this routine. Limited_With clauses
3254
      --  are separately installed (see Install_Limited_Context_Clauses).
3255
 
3256
      while Present (Item) loop
3257
 
3258
         --  Case of explicit WITH clause
3259
 
3260
         if Nkind (Item) = N_With_Clause
3261
           and then not Implicit_With (Item)
3262
         then
3263
            if Limited_Present (Item) then
3264
 
3265
               --  Limited withed units will be installed later
3266
 
3267
               goto Continue;
3268
 
3269
            --  If Name (Item) is not an entity name, something is wrong, and
3270
            --  this will be detected in due course, for now ignore the item
3271
 
3272
            elsif not Is_Entity_Name (Name (Item)) then
3273
               goto Continue;
3274
 
3275
            elsif No (Entity (Name (Item))) then
3276
               Set_Entity (Name (Item), Any_Id);
3277
               goto Continue;
3278
            end if;
3279
 
3280
            Uname_Node := Entity (Name (Item));
3281
 
3282
            if Is_Private_Descendant (Uname_Node) then
3283
               Check_Private := True;
3284
            end if;
3285
 
3286
            Install_Withed_Unit (Item);
3287
 
3288
            Decl_Node := Unit_Declaration_Node (Uname_Node);
3289
 
3290
            --  If the unit is a subprogram instance, it appears nested within
3291
            --  a package that carries the parent information.
3292
 
3293
            if Is_Generic_Instance (Uname_Node)
3294
              and then Ekind (Uname_Node) /= E_Package
3295
            then
3296
               Decl_Node := Parent (Parent (Decl_Node));
3297
            end if;
3298
 
3299
            if Is_Child_Spec (Decl_Node) then
3300
               if Nkind (Name (Item)) = N_Expanded_Name then
3301
                  Expand_With_Clause (Item, Prefix (Name (Item)), N);
3302
               else
3303
                  --  If not an expanded name, the child unit must be a
3304
                  --  renaming, nothing to do.
3305
 
3306
                  null;
3307
               end if;
3308
 
3309
            elsif Nkind (Decl_Node) = N_Subprogram_Body
3310
              and then not Acts_As_Spec (Parent (Decl_Node))
3311
              and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
3312
            then
3313
               Implicit_With_On_Parent
3314
                 (Unit (Library_Unit (Parent (Decl_Node))), N);
3315
            end if;
3316
 
3317
            --  Check license conditions unless this is a dummy unit
3318
 
3319
            if Sloc (Library_Unit (Item)) /= No_Location then
3320
               License_Check : declare
3321
                  Withu : constant Unit_Number_Type :=
3322
                            Get_Source_Unit (Library_Unit (Item));
3323
                  Withl : constant License_Type :=
3324
                            License (Source_Index (Withu));
3325
                  Unitl : constant License_Type :=
3326
                           License (Source_Index (Current_Sem_Unit));
3327
 
3328
                  procedure License_Error;
3329
                  --  Signal error of bad license
3330
 
3331
                  -------------------
3332
                  -- License_Error --
3333
                  -------------------
3334
 
3335
                  procedure License_Error is
3336
                  begin
3337
                     Error_Msg_N
3338
                       ("?license of withed unit & may be inconsistent",
3339
                        Name (Item));
3340
                  end License_Error;
3341
 
3342
               --  Start of processing for License_Check
3343
 
3344
               begin
3345
                  --  Exclude license check if withed unit is an internal unit.
3346
                  --  This situation arises e.g. with the GPL version of GNAT.
3347
 
3348
                  if Is_Internal_File_Name (Unit_File_Name (Withu)) then
3349
                     null;
3350
 
3351
                     --  Otherwise check various cases
3352
                  else
3353
                     case Unitl is
3354
                        when Unknown =>
3355
                           null;
3356
 
3357
                        when Restricted =>
3358
                           if Withl = GPL then
3359
                              License_Error;
3360
                           end if;
3361
 
3362
                        when GPL =>
3363
                           if Withl = Restricted then
3364
                              License_Error;
3365
                           end if;
3366
 
3367
                        when Modified_GPL =>
3368
                           if Withl = Restricted or else Withl = GPL then
3369
                              License_Error;
3370
                           end if;
3371
 
3372
                        when Unrestricted =>
3373
                           null;
3374
                     end case;
3375
                  end if;
3376
               end License_Check;
3377
            end if;
3378
 
3379
         --  Case of USE PACKAGE clause
3380
 
3381
         elsif Nkind (Item) = N_Use_Package_Clause then
3382
            Analyze_Use_Package (Item);
3383
 
3384
         --  Case of USE TYPE clause
3385
 
3386
         elsif Nkind (Item) = N_Use_Type_Clause then
3387
            Analyze_Use_Type (Item);
3388
 
3389
         --  case of PRAGMA
3390
 
3391
         elsif Nkind (Item) = N_Pragma then
3392
            Analyze (Item);
3393
         end if;
3394
 
3395
      <<Continue>>
3396
         Next (Item);
3397
      end loop;
3398
 
3399
      if Is_Child_Spec (Lib_Unit) then
3400
 
3401
         --  The unit also has implicit with_clauses on its own parents
3402
 
3403
         if No (Context_Items (N)) then
3404
            Set_Context_Items (N, New_List);
3405
         end if;
3406
 
3407
         Implicit_With_On_Parent (Lib_Unit, N);
3408
      end if;
3409
 
3410
      --  If the unit is a body, the context of the specification must also
3411
      --  be installed. That includes private with_clauses in that context.
3412
 
3413
      if Nkind (Lib_Unit) = N_Package_Body
3414
        or else (Nkind (Lib_Unit) = N_Subprogram_Body
3415
                   and then not Acts_As_Spec (N))
3416
      then
3417
         Install_Context (Library_Unit (N));
3418
 
3419
         --  Only install private with-clauses of a spec that comes from
3420
         --  source, excluding specs created for a subprogram body that is
3421
         --  a child unit.
3422
 
3423
         if Comes_From_Source (Library_Unit (N)) then
3424
            Install_Private_With_Clauses
3425
              (Defining_Entity (Unit (Library_Unit (N))));
3426
         end if;
3427
 
3428
         if Is_Child_Spec (Unit (Library_Unit (N))) then
3429
 
3430
            --  If the unit is the body of a public child unit, the private
3431
            --  declarations of the parent must be made visible. If the child
3432
            --  unit is private, the private declarations have been installed
3433
            --  already in the call to Install_Parents for the spec. Installing
3434
            --  private declarations must be done for all ancestors of public
3435
            --  child units. In addition, sibling units mentioned in the
3436
            --  context clause of the body are directly visible.
3437
 
3438
            declare
3439
               Lib_Spec : Node_Id;
3440
               P        : Node_Id;
3441
               P_Name   : Entity_Id;
3442
 
3443
            begin
3444
               Lib_Spec := Unit (Library_Unit (N));
3445
               while Is_Child_Spec (Lib_Spec) loop
3446
                  P      := Unit (Parent_Spec (Lib_Spec));
3447
                  P_Name := Defining_Entity (P);
3448
 
3449
                  if not (Private_Present (Parent (Lib_Spec)))
3450
                    and then not In_Private_Part (P_Name)
3451
                  then
3452
                     Install_Private_Declarations (P_Name);
3453
                     Install_Private_With_Clauses (P_Name);
3454
                     Set_Use (Private_Declarations (Specification (P)));
3455
                  end if;
3456
 
3457
                  Lib_Spec := P;
3458
               end loop;
3459
            end;
3460
         end if;
3461
 
3462
         --  For a package body, children in context are immediately visible
3463
 
3464
         Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
3465
      end if;
3466
 
3467
      if Nkind_In (Lib_Unit, N_Generic_Package_Declaration,
3468
                             N_Generic_Subprogram_Declaration,
3469
                             N_Package_Declaration,
3470
                             N_Subprogram_Declaration)
3471
      then
3472
         if Is_Child_Spec (Lib_Unit) then
3473
            Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
3474
            Set_Is_Private_Descendant
3475
              (Defining_Entity (Lib_Unit),
3476
               Is_Private_Descendant (Lib_Parent)
3477
                 or else Private_Present (Parent (Lib_Unit)));
3478
 
3479
         else
3480
            Set_Is_Private_Descendant
3481
              (Defining_Entity (Lib_Unit),
3482
               Private_Present (Parent (Lib_Unit)));
3483
         end if;
3484
      end if;
3485
 
3486
      if Check_Private then
3487
         Check_Private_Child_Unit (N);
3488
      end if;
3489
   end Install_Context_Clauses;
3490
 
3491
   -------------------------------------
3492
   -- Install_Limited_Context_Clauses --
3493
   -------------------------------------
3494
 
3495
   procedure Install_Limited_Context_Clauses (N : Node_Id) is
3496
      Item : Node_Id;
3497
 
3498
      procedure Check_Renamings (P : Node_Id; W : Node_Id);
3499
      --  Check that the unlimited view of a given compilation_unit is not
3500
      --  already visible through "use + renamings".
3501
 
3502
      procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
3503
      --  Check that if a limited_with clause of a given compilation_unit
3504
      --  mentions a descendant of a private child of some library unit, then
3505
      --  the given compilation_unit shall be the declaration of a private
3506
      --  descendant of that library unit, or a public descendant of such. The
3507
      --  code is analogous to that of Check_Private_Child_Unit but we cannot
3508
      --  use entities on the limited with_clauses because their units have not
3509
      --  been analyzed, so we have to climb the tree of ancestors looking for
3510
      --  private keywords.
3511
 
3512
      procedure Expand_Limited_With_Clause
3513
        (Comp_Unit : Node_Id;
3514
         Nam       : Node_Id;
3515
         N         : Node_Id);
3516
      --  If a child unit appears in a limited_with clause, there are implicit
3517
      --  limited_with clauses on all parents that are not already visible
3518
      --  through a regular with clause. This procedure creates the implicit
3519
      --  limited with_clauses for the parents and loads the corresponding
3520
      --  units. The shadow entities are created when the inserted clause is
3521
      --  analyzed. Implements Ada 2005 (AI-50217).
3522
 
3523
      function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
3524
      --  When compiling a unit Q descended from some parent unit P, a limited
3525
      --  with_clause in the context of P that names some other ancestor of Q
3526
      --  must not be installed because the ancestor is immediately visible.
3527
 
3528
      ---------------------
3529
      -- Check_Renamings --
3530
      ---------------------
3531
 
3532
      procedure Check_Renamings (P : Node_Id; W : Node_Id) is
3533
         Item   : Node_Id;
3534
         Spec   : Node_Id;
3535
         WEnt   : Entity_Id;
3536
         Nam    : Node_Id;
3537
         E      : Entity_Id;
3538
         E2     : Entity_Id;
3539
 
3540
      begin
3541
         pragma Assert (Nkind (W) = N_With_Clause);
3542
 
3543
         --  Protect the frontend against previous critical errors
3544
 
3545
         case Nkind (Unit (Library_Unit (W))) is
3546
            when N_Subprogram_Declaration         |
3547
                 N_Package_Declaration            |
3548
                 N_Generic_Subprogram_Declaration |
3549
                 N_Generic_Package_Declaration    =>
3550
               null;
3551
 
3552
            when others =>
3553
               return;
3554
         end case;
3555
 
3556
         --  Check "use + renamings"
3557
 
3558
         WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
3559
         Spec := Specification (Unit (P));
3560
 
3561
         Item := First (Visible_Declarations (Spec));
3562
         while Present (Item) loop
3563
 
3564
            --  Look only at use package clauses
3565
 
3566
            if Nkind (Item) = N_Use_Package_Clause then
3567
 
3568
               --  Traverse the list of packages
3569
 
3570
               Nam := First (Names (Item));
3571
               while Present (Nam) loop
3572
                  E := Entity (Nam);
3573
 
3574
                  pragma Assert (Present (Parent (E)));
3575
 
3576
                  if Nkind (Parent (E)) = N_Package_Renaming_Declaration
3577
                    and then Renamed_Entity (E) = WEnt
3578
                  then
3579
                     --  The unlimited view is visible through use clause and
3580
                     --  renamings. There is no need to generate the error
3581
                     --  message here because Is_Visible_Through_Renamings
3582
                     --  takes care of generating the precise error message.
3583
 
3584
                     return;
3585
 
3586
                  elsif Nkind (Parent (E)) = N_Package_Specification then
3587
 
3588
                     --  The use clause may refer to a local package.
3589
                     --  Check all the enclosing scopes.
3590
 
3591
                     E2 := E;
3592
                     while E2 /= Standard_Standard
3593
                       and then E2 /= WEnt
3594
                     loop
3595
                        E2 := Scope (E2);
3596
                     end loop;
3597
 
3598
                     if E2 = WEnt then
3599
                        Error_Msg_N
3600
                          ("unlimited view visible through use clause ", W);
3601
                        return;
3602
                     end if;
3603
                  end if;
3604
 
3605
                  Next (Nam);
3606
               end loop;
3607
            end if;
3608
 
3609
            Next (Item);
3610
         end loop;
3611
 
3612
         --  Recursive call to check all the ancestors
3613
 
3614
         if Is_Child_Spec (Unit (P)) then
3615
            Check_Renamings (P => Parent_Spec (Unit (P)), W => W);
3616
         end if;
3617
      end Check_Renamings;
3618
 
3619
      ---------------------------------------
3620
      -- Check_Private_Limited_Withed_Unit --
3621
      ---------------------------------------
3622
 
3623
      procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is
3624
         Curr_Parent  : Node_Id;
3625
         Child_Parent : Node_Id;
3626
         Curr_Private : Boolean;
3627
 
3628
      begin
3629
         --  Compilation unit of the parent of the withed library unit
3630
 
3631
         Child_Parent := Library_Unit (Item);
3632
 
3633
         --  If the child unit is a public child, then locate its nearest
3634
         --  private ancestor, if any, then Child_Parent will then be set to
3635
         --  the parent of that ancestor.
3636
 
3637
         if not Private_Present (Library_Unit (Item)) then
3638
            while Present (Child_Parent)
3639
              and then not Private_Present (Child_Parent)
3640
            loop
3641
               Child_Parent := Parent_Spec (Unit (Child_Parent));
3642
            end loop;
3643
 
3644
            if No (Child_Parent) then
3645
               return;
3646
            end if;
3647
         end if;
3648
 
3649
         Child_Parent := Parent_Spec (Unit (Child_Parent));
3650
 
3651
         --  Traverse all the ancestors of the current compilation unit to
3652
         --  check if it is a descendant of named library unit.
3653
 
3654
         Curr_Parent := Parent (Item);
3655
         Curr_Private := Private_Present (Curr_Parent);
3656
 
3657
         while Present (Parent_Spec (Unit (Curr_Parent)))
3658
           and then Curr_Parent /= Child_Parent
3659
         loop
3660
            Curr_Parent := Parent_Spec (Unit (Curr_Parent));
3661
            Curr_Private := Curr_Private or else Private_Present (Curr_Parent);
3662
         end loop;
3663
 
3664
         if Curr_Parent /= Child_Parent then
3665
            Error_Msg_N
3666
              ("unit in with clause is private child unit!", Item);
3667
            Error_Msg_NE
3668
              ("\current unit must also have parent&!",
3669
               Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3670
 
3671
         elsif Private_Present (Parent (Item))
3672
            or else Curr_Private
3673
            or else Private_Present (Item)
3674
            or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
3675
                                                    N_Subprogram_Body,
3676
                                                    N_Subunit)
3677
         then
3678
            --  Current unit is private, of descendant of a private unit
3679
 
3680
            null;
3681
 
3682
         else
3683
            Error_Msg_NE
3684
              ("current unit must also be private descendant of&",
3685
               Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3686
         end if;
3687
      end Check_Private_Limited_Withed_Unit;
3688
 
3689
      --------------------------------
3690
      -- Expand_Limited_With_Clause --
3691
      --------------------------------
3692
 
3693
      procedure Expand_Limited_With_Clause
3694
        (Comp_Unit : Node_Id;
3695
         Nam       : Node_Id;
3696
         N         : Node_Id)
3697
      is
3698
         Loc   : constant Source_Ptr := Sloc (Nam);
3699
         Unum  : Unit_Number_Type;
3700
         Withn : Node_Id;
3701
 
3702
         function Previous_Withed_Unit (W : Node_Id) return Boolean;
3703
         --  Returns true if the context already includes a with_clause for
3704
         --  this unit. If the with_clause is non-limited, the unit is fully
3705
         --  visible and an implicit limited_with should not be created. If
3706
         --  there is already a limited_with clause for W, a second one is
3707
         --  simply redundant.
3708
 
3709
         --------------------------
3710
         -- Previous_Withed_Unit --
3711
         --------------------------
3712
 
3713
         function Previous_Withed_Unit (W : Node_Id) return Boolean is
3714
            Item : Node_Id;
3715
 
3716
         begin
3717
            --  A limited with_clause cannot appear in the same context_clause
3718
            --  as a nonlimited with_clause which mentions the same library.
3719
 
3720
            Item := First (Context_Items (Comp_Unit));
3721
            while Present (Item) loop
3722
               if Nkind (Item) = N_With_Clause
3723
                 and then Library_Unit (Item) = Library_Unit (W)
3724
               then
3725
                  return True;
3726
               end if;
3727
 
3728
               Next (Item);
3729
            end loop;
3730
 
3731
            return False;
3732
         end Previous_Withed_Unit;
3733
 
3734
      --  Start of processing for Expand_Limited_With_Clause
3735
 
3736
      begin
3737
         New_Nodes_OK := New_Nodes_OK + 1;
3738
 
3739
         if Nkind (Nam) = N_Identifier then
3740
 
3741
            --  Create node for name of withed unit
3742
 
3743
            Withn :=
3744
              Make_With_Clause (Loc,
3745
                Name => New_Copy (Nam));
3746
 
3747
         else pragma Assert (Nkind (Nam) = N_Selected_Component);
3748
            Withn :=
3749
              Make_With_Clause (Loc,
3750
                Name => Make_Selected_Component (Loc,
3751
                  Prefix        => New_Copy_Tree (Prefix (Nam)),
3752
                  Selector_Name => New_Copy (Selector_Name (Nam))));
3753
            Set_Parent (Withn, Parent (N));
3754
         end if;
3755
 
3756
         Set_Limited_Present (Withn);
3757
         Set_First_Name      (Withn);
3758
         Set_Implicit_With   (Withn);
3759
 
3760
         Unum :=
3761
           Load_Unit
3762
             (Load_Name  => Get_Spec_Name (Get_Unit_Name (Nam)),
3763
              Required   => True,
3764
              Subunit    => False,
3765
              Error_Node => Nam);
3766
 
3767
         --  Do not generate a limited_with_clause on the current unit. This
3768
         --  path is taken when a unit has a limited_with clause on one of its
3769
         --  child units.
3770
 
3771
         if Unum = Current_Sem_Unit then
3772
            return;
3773
         end if;
3774
 
3775
         Set_Library_Unit (Withn, Cunit (Unum));
3776
         Set_Corresponding_Spec
3777
           (Withn, Specification (Unit (Cunit (Unum))));
3778
 
3779
         if not Previous_Withed_Unit (Withn) then
3780
            Prepend (Withn, Context_Items (Parent (N)));
3781
            Mark_Rewrite_Insertion (Withn);
3782
 
3783
            --  Add implicit limited_with_clauses for parents of child units
3784
            --  mentioned in limited_with clauses.
3785
 
3786
            if Nkind (Nam) = N_Selected_Component then
3787
               Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
3788
            end if;
3789
 
3790
            Analyze (Withn);
3791
 
3792
            if not Limited_View_Installed (Withn) then
3793
               Install_Limited_Withed_Unit (Withn);
3794
            end if;
3795
         end if;
3796
 
3797
         New_Nodes_OK := New_Nodes_OK - 1;
3798
      end Expand_Limited_With_Clause;
3799
 
3800
      ----------------------
3801
      -- Is_Ancestor_Unit --
3802
      ----------------------
3803
 
3804
      function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
3805
         E1 : constant Entity_Id := Defining_Entity (Unit (U1));
3806
         E2 : Entity_Id;
3807
      begin
3808
         if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
3809
            E2 := Defining_Entity (Unit (Library_Unit (U2)));
3810
            return Is_Ancestor_Package (E1, E2);
3811
         else
3812
            return False;
3813
         end if;
3814
      end Is_Ancestor_Unit;
3815
 
3816
   --  Start of processing for Install_Limited_Context_Clauses
3817
 
3818
   begin
3819
      Item := First (Context_Items (N));
3820
      while Present (Item) loop
3821
         if Nkind (Item) = N_With_Clause
3822
           and then Limited_Present (Item)
3823
           and then not Error_Posted (Item)
3824
         then
3825
            if Nkind (Name (Item)) = N_Selected_Component then
3826
               Expand_Limited_With_Clause
3827
                 (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item);
3828
            end if;
3829
 
3830
            Check_Private_Limited_Withed_Unit (Item);
3831
 
3832
            if not Implicit_With (Item)
3833
              and then Is_Child_Spec (Unit (N))
3834
            then
3835
               Check_Renamings (Parent_Spec (Unit (N)), Item);
3836
            end if;
3837
 
3838
            --  A unit may have a limited with on itself if it has a limited
3839
            --  with_clause on one of its child units. In that case it is
3840
            --  already being compiled and it makes no sense to install its
3841
            --  limited view.
3842
 
3843
            --  If the item is a limited_private_with_clause, install it if the
3844
            --  current unit is a body or if it is a private child. Otherwise
3845
            --  the private clause is installed before analyzing the private
3846
            --  part of the current unit.
3847
 
3848
            if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
3849
              and then not Limited_View_Installed (Item)
3850
              and then
3851
                not Is_Ancestor_Unit
3852
                      (Library_Unit (Item), Cunit (Current_Sem_Unit))
3853
            then
3854
               if not Private_Present (Item)
3855
                 or else Private_Present (N)
3856
                 or else Nkind_In (Unit (N), N_Package_Body,
3857
                                             N_Subprogram_Body,
3858
                                             N_Subunit)
3859
               then
3860
                  Install_Limited_Withed_Unit (Item);
3861
               end if;
3862
            end if;
3863
         end if;
3864
 
3865
         Next (Item);
3866
      end loop;
3867
 
3868
      --  Ada 2005 (AI-412): Examine visible declarations of a package spec,
3869
      --  looking for incomplete subtype declarations of incomplete types
3870
      --  visible through a limited with clause.
3871
 
3872
      if Ada_Version >= Ada_2005
3873
        and then Analyzed (N)
3874
        and then Nkind (Unit (N)) = N_Package_Declaration
3875
      then
3876
         declare
3877
            Decl         : Node_Id;
3878
            Def_Id       : Entity_Id;
3879
            Non_Lim_View : Entity_Id;
3880
 
3881
         begin
3882
            Decl := First (Visible_Declarations (Specification (Unit (N))));
3883
            while Present (Decl) loop
3884
               if Nkind (Decl) = N_Subtype_Declaration
3885
                 and then
3886
                   Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype
3887
                 and then
3888
                   From_With_Type (Defining_Identifier (Decl))
3889
               then
3890
                  Def_Id := Defining_Identifier (Decl);
3891
                  Non_Lim_View := Non_Limited_View (Def_Id);
3892
 
3893
                  if not Is_Incomplete_Type (Non_Lim_View) then
3894
 
3895
                     --  Convert an incomplete subtype declaration into a
3896
                     --  corresponding non-limited view subtype declaration.
3897
                     --  This is usually the case when analyzing a body that
3898
                     --  has regular with clauses,  when the spec has limited
3899
                     --  ones.
3900
 
3901
                     --  If the non-limited view is still incomplete, it is
3902
                     --  the dummy entry already created, and the declaration
3903
                     --  cannot be reanalyzed. This is the case when installing
3904
                     --  a parent unit that has limited with-clauses.
3905
 
3906
                     Set_Subtype_Indication (Decl,
3907
                       New_Reference_To (Non_Lim_View, Sloc (Def_Id)));
3908
                     Set_Etype (Def_Id, Non_Lim_View);
3909
                     Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
3910
                     Set_Analyzed (Decl, False);
3911
 
3912
                     --  Reanalyze the declaration, suppressing the call to
3913
                     --  Enter_Name to avoid duplicate names.
3914
 
3915
                     Analyze_Subtype_Declaration
3916
                      (N    => Decl,
3917
                       Skip => True);
3918
                  end if;
3919
               end if;
3920
 
3921
               Next (Decl);
3922
            end loop;
3923
         end;
3924
      end if;
3925
   end Install_Limited_Context_Clauses;
3926
 
3927
   ---------------------
3928
   -- Install_Parents --
3929
   ---------------------
3930
 
3931
   procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
3932
      P      : Node_Id;
3933
      E_Name : Entity_Id;
3934
      P_Name : Entity_Id;
3935
      P_Spec : Node_Id;
3936
 
3937
   begin
3938
      P := Unit (Parent_Spec (Lib_Unit));
3939
      P_Name := Get_Parent_Entity (P);
3940
 
3941
      if Etype (P_Name) = Any_Type then
3942
         return;
3943
      end if;
3944
 
3945
      if Ekind (P_Name) = E_Generic_Package
3946
        and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration,
3947
                                         N_Generic_Package_Declaration)
3948
        and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
3949
      then
3950
         Error_Msg_N
3951
           ("child of a generic package must be a generic unit", Lib_Unit);
3952
 
3953
      elsif not Is_Package_Or_Generic_Package (P_Name) then
3954
         Error_Msg_N
3955
           ("parent unit must be package or generic package", Lib_Unit);
3956
         raise Unrecoverable_Error;
3957
 
3958
      elsif Present (Renamed_Object (P_Name)) then
3959
         Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
3960
         raise Unrecoverable_Error;
3961
 
3962
      --  Verify that a child of an instance is itself an instance, or the
3963
      --  renaming of one. Given that an instance that is a unit is replaced
3964
      --  with a package declaration, check against the original node. The
3965
      --  parent may be currently being instantiated, in which case it appears
3966
      --  as a declaration, but the generic_parent is already established
3967
      --  indicating that we deal with an instance.
3968
 
3969
      elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
3970
         if Nkind (Lib_Unit) in N_Renaming_Declaration
3971
           or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
3972
           or else
3973
             (Nkind (Lib_Unit) = N_Package_Declaration
3974
                and then Present (Generic_Parent (Specification (Lib_Unit))))
3975
         then
3976
            null;
3977
         else
3978
            Error_Msg_N
3979
              ("child of an instance must be an instance or renaming",
3980
                Lib_Unit);
3981
         end if;
3982
      end if;
3983
 
3984
      --  This is the recursive call that ensures all parents are loaded
3985
 
3986
      if Is_Child_Spec (P) then
3987
         Install_Parents (P,
3988
           Is_Private or else Private_Present (Parent (Lib_Unit)));
3989
      end if;
3990
 
3991
      --  Now we can install the context for this parent
3992
 
3993
      Install_Context_Clauses (Parent_Spec (Lib_Unit));
3994
      Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit));
3995
      Install_Siblings (P_Name, Parent (Lib_Unit));
3996
 
3997
      --  The child unit is in the declarative region of the parent. The parent
3998
      --  must therefore appear in the scope stack and be visible, as when
3999
      --  compiling the corresponding body. If the child unit is private or it
4000
      --  is a package body, private declarations must be accessible as well.
4001
      --  Use declarations in the parent must also be installed. Finally, other
4002
      --  child units of the same parent that are in the context are
4003
      --  immediately visible.
4004
 
4005
      --  Find entity for compilation unit, and set its private descendant
4006
      --  status as needed. Indicate that it is a compilation unit, which is
4007
      --  redundant in general, but needed if this is a generated child spec
4008
      --  for a child body without previous spec.
4009
 
4010
      E_Name := Defining_Entity (Lib_Unit);
4011
 
4012
      Set_Is_Child_Unit (E_Name);
4013
      Set_Is_Compilation_Unit (E_Name);
4014
 
4015
      Set_Is_Private_Descendant (E_Name,
4016
         Is_Private_Descendant (P_Name)
4017
           or else Private_Present (Parent (Lib_Unit)));
4018
 
4019
      P_Spec := Specification (Unit_Declaration_Node (P_Name));
4020
      Push_Scope (P_Name);
4021
 
4022
      --  Save current visibility of unit
4023
 
4024
      Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
4025
        Is_Immediately_Visible (P_Name);
4026
      Set_Is_Immediately_Visible (P_Name);
4027
      Install_Visible_Declarations (P_Name);
4028
      Set_Use (Visible_Declarations (P_Spec));
4029
 
4030
      --  If the parent is a generic unit, its formal part may contain formal
4031
      --  packages and use clauses for them.
4032
 
4033
      if Ekind (P_Name) = E_Generic_Package then
4034
         Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
4035
      end if;
4036
 
4037
      if Is_Private
4038
        or else Private_Present (Parent (Lib_Unit))
4039
      then
4040
         Install_Private_Declarations (P_Name);
4041
         Install_Private_With_Clauses (P_Name);
4042
         Set_Use (Private_Declarations (P_Spec));
4043
      end if;
4044
   end Install_Parents;
4045
 
4046
   ----------------------------------
4047
   -- Install_Private_With_Clauses --
4048
   ----------------------------------
4049
 
4050
   procedure Install_Private_With_Clauses (P : Entity_Id) is
4051
      Decl   : constant Node_Id := Unit_Declaration_Node (P);
4052
      Item   : Node_Id;
4053
 
4054
   begin
4055
      if Debug_Flag_I then
4056
         Write_Str ("install private with clauses of ");
4057
         Write_Name (Chars (P));
4058
         Write_Eol;
4059
      end if;
4060
 
4061
      if Nkind (Parent (Decl)) = N_Compilation_Unit then
4062
         Item := First (Context_Items (Parent (Decl)));
4063
         while Present (Item) loop
4064
            if Nkind (Item) = N_With_Clause
4065
              and then Private_Present (Item)
4066
            then
4067
               if Limited_Present (Item) then
4068
                  if not Limited_View_Installed (Item) then
4069
                     Install_Limited_Withed_Unit (Item);
4070
                  end if;
4071
               else
4072
                  Install_Withed_Unit (Item, Private_With_OK => True);
4073
               end if;
4074
            end if;
4075
 
4076
            Next (Item);
4077
         end loop;
4078
      end if;
4079
   end Install_Private_With_Clauses;
4080
 
4081
   ----------------------
4082
   -- Install_Siblings --
4083
   ----------------------
4084
 
4085
   procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
4086
      Item : Node_Id;
4087
      Id   : Entity_Id;
4088
      Prev : Entity_Id;
4089
 
4090
   begin
4091
      --  Iterate over explicit with clauses, and check whether the scope of
4092
      --  each entity is an ancestor of the current unit, in which case it is
4093
      --  immediately visible.
4094
 
4095
      Item := First (Context_Items (N));
4096
      while Present (Item) loop
4097
 
4098
         --  Do not install private_with_clauses declaration, unless unit
4099
         --  is itself a private child unit, or is a body. Note that for a
4100
         --  subprogram body the private_with_clause does not take effect until
4101
         --  after the specification.
4102
 
4103
         if Nkind (Item) /= N_With_Clause
4104
           or else Implicit_With (Item)
4105
           or else Limited_Present (Item)
4106
           or else Error_Posted (Item)
4107
         then
4108
            null;
4109
 
4110
         elsif not Private_Present (Item)
4111
           or else Private_Present (N)
4112
           or else Nkind (Unit (N)) = N_Package_Body
4113
         then
4114
            Id := Entity (Name (Item));
4115
 
4116
            if Is_Child_Unit (Id)
4117
              and then Is_Ancestor_Package (Scope (Id), U_Name)
4118
            then
4119
               Set_Is_Immediately_Visible (Id);
4120
 
4121
               --  Check for the presence of another unit in the context that
4122
               --  may be inadvertently hidden by the child.
4123
 
4124
               Prev := Current_Entity (Id);
4125
 
4126
               if Present (Prev)
4127
                 and then Is_Immediately_Visible (Prev)
4128
                 and then not Is_Child_Unit (Prev)
4129
               then
4130
                  declare
4131
                     Clause : Node_Id;
4132
 
4133
                  begin
4134
                     Clause := First (Context_Items (N));
4135
                     while Present (Clause) loop
4136
                        if Nkind (Clause) = N_With_Clause
4137
                          and then Entity (Name (Clause)) = Prev
4138
                        then
4139
                           Error_Msg_NE
4140
                              ("child unit& hides compilation unit " &
4141
                               "with the same name?",
4142
                                 Name (Item), Id);
4143
                           exit;
4144
                        end if;
4145
 
4146
                        Next (Clause);
4147
                     end loop;
4148
                  end;
4149
               end if;
4150
 
4151
            --  The With_Clause may be on a grand-child or one of its further
4152
            --  descendants, which makes a child immediately visible. Examine
4153
            --  ancestry to determine whether such a child exists. For example,
4154
            --  if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4155
            --  is immediately visible.
4156
 
4157
            elsif Is_Child_Unit (Id) then
4158
               declare
4159
                  Par : Entity_Id;
4160
 
4161
               begin
4162
                  Par := Scope (Id);
4163
                  while Is_Child_Unit (Par) loop
4164
                     if Is_Ancestor_Package (Scope (Par), U_Name) then
4165
                        Set_Is_Immediately_Visible (Par);
4166
                        exit;
4167
                     end if;
4168
 
4169
                     Par := Scope (Par);
4170
                  end loop;
4171
               end;
4172
            end if;
4173
 
4174
         --  If the item is a private with-clause on a child unit, the parent
4175
         --  may have been installed already, but the child unit must remain
4176
         --  invisible until installed in a private part or body, unless there
4177
         --  is already a regular with_clause for it in the current unit.
4178
 
4179
         elsif Private_Present (Item) then
4180
            Id := Entity (Name (Item));
4181
 
4182
            if Is_Child_Unit (Id) then
4183
               declare
4184
                  Clause : Node_Id;
4185
 
4186
                  function In_Context return Boolean;
4187
                  --  Scan context of current unit, to check whether there is
4188
                  --  a with_clause on the same unit as a private with-clause
4189
                  --  on a parent, in which case child unit is visible. If the
4190
                  --  unit is a grand-child, the same applies to its parent.
4191
 
4192
                  ----------------
4193
                  -- In_Context --
4194
                  ----------------
4195
 
4196
                  function In_Context return Boolean is
4197
                  begin
4198
                     Clause :=
4199
                       First (Context_Items (Cunit (Current_Sem_Unit)));
4200
                     while Present (Clause) loop
4201
                        if Nkind (Clause) = N_With_Clause
4202
                          and then Comes_From_Source (Clause)
4203
                          and then Is_Entity_Name (Name (Clause))
4204
                          and then not Private_Present (Clause)
4205
                        then
4206
                           if Entity (Name (Clause)) = Id
4207
                             or else
4208
                               (Nkind (Name (Clause)) = N_Expanded_Name
4209
                                 and then Entity (Prefix (Name (Clause))) = Id)
4210
                           then
4211
                              return True;
4212
                           end if;
4213
                        end if;
4214
 
4215
                        Next (Clause);
4216
                     end loop;
4217
 
4218
                     return False;
4219
                  end In_Context;
4220
 
4221
               begin
4222
                  Set_Is_Visible_Child_Unit (Id, In_Context);
4223
               end;
4224
            end if;
4225
         end if;
4226
 
4227
         Next (Item);
4228
      end loop;
4229
   end Install_Siblings;
4230
 
4231
   ---------------------------------
4232
   -- Install_Limited_Withed_Unit --
4233
   ---------------------------------
4234
 
4235
   procedure Install_Limited_Withed_Unit (N : Node_Id) is
4236
      P_Unit           : constant Entity_Id := Unit (Library_Unit (N));
4237
      E                : Entity_Id;
4238
      P                : Entity_Id;
4239
      Is_Child_Package : Boolean := False;
4240
      Lim_Header       : Entity_Id;
4241
      Lim_Typ          : Entity_Id;
4242
 
4243
      procedure Check_Body_Required;
4244
      --  A unit mentioned in a limited with_clause may not be mentioned in
4245
      --  a regular with_clause, but must still be included in the current
4246
      --  partition. We need to determine whether the unit needs a body, so
4247
      --  that the binder can determine the name of the file to be compiled.
4248
      --  Checking whether a unit needs a body can be done without semantic
4249
      --  analysis, by examining the nature of the declarations in the package.
4250
 
4251
      function Has_Limited_With_Clause
4252
        (C_Unit : Entity_Id;
4253
         Pack   : Entity_Id) return Boolean;
4254
      --  Determine whether any package in the ancestor chain starting with
4255
      --  C_Unit has a limited with clause for package Pack.
4256
 
4257
      function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
4258
      --  Check if some package installed though normal with-clauses has a
4259
      --  renaming declaration of package P. AARM 10.1.2(21/2).
4260
 
4261
      -------------------------
4262
      -- Check_Body_Required --
4263
      -------------------------
4264
 
4265
      procedure Check_Body_Required is
4266
         PA : constant List_Id :=
4267
                Pragmas_After (Aux_Decls_Node (Parent (P_Unit)));
4268
 
4269
         procedure Check_Declarations (Spec : Node_Id);
4270
         --  Recursive procedure that does the work and checks nested packages
4271
 
4272
         ------------------------
4273
         -- Check_Declarations --
4274
         ------------------------
4275
 
4276
         procedure Check_Declarations (Spec : Node_Id) is
4277
            Decl             : Node_Id;
4278
            Incomplete_Decls : constant Elist_Id := New_Elmt_List;
4279
 
4280
            Subp_List        : constant Elist_Id := New_Elmt_List;
4281
 
4282
            procedure Check_Pragma_Import (P : Node_Id);
4283
            --  If a pragma import applies to a previous subprogram, the
4284
            --  enclosing unit may not need a body. The processing is syntactic
4285
            --  and does not require a declaration to be analyzed. The code
4286
            --  below also handles pragma Import when applied to a subprogram
4287
            --  that renames another. In this case the pragma applies to the
4288
            --  renamed entity.
4289
            --
4290
            --  Chains of multiple renames are not handled by the code below.
4291
            --  It is probably impossible to handle all cases without proper
4292
            --  name resolution. In such cases the algorithm is conservative
4293
            --  and will indicate that a body is needed???
4294
 
4295
            -------------------------
4296
            -- Check_Pragma_Import --
4297
            -------------------------
4298
 
4299
            procedure Check_Pragma_Import (P : Node_Id) is
4300
               Arg      : Node_Id;
4301
               Prev_Id  : Elmt_Id;
4302
               Subp_Id  : Elmt_Id;
4303
               Imported : Node_Id;
4304
 
4305
               procedure Remove_Homonyms (E : Node_Id);
4306
               --  Make one pass over list of subprograms. Called again if
4307
               --  subprogram is a renaming. E is known to be an identifier.
4308
 
4309
               ---------------------
4310
               -- Remove_Homonyms --
4311
               ---------------------
4312
 
4313
               procedure Remove_Homonyms (E : Node_Id) is
4314
                  R : Entity_Id := Empty;
4315
                  --  Name of renamed entity, if any
4316
 
4317
               begin
4318
                  Subp_Id := First_Elmt (Subp_List);
4319
                  while Present (Subp_Id) loop
4320
                     if Chars (Node (Subp_Id)) = Chars (E) then
4321
                        if Nkind (Parent (Parent (Node (Subp_Id))))
4322
                          /=  N_Subprogram_Renaming_Declaration
4323
                        then
4324
                           Prev_Id := Subp_Id;
4325
                           Next_Elmt (Subp_Id);
4326
                           Remove_Elmt (Subp_List, Prev_Id);
4327
                        else
4328
                           R := Name (Parent (Parent (Node (Subp_Id))));
4329
                           exit;
4330
                        end if;
4331
                     else
4332
                        Next_Elmt (Subp_Id);
4333
                     end if;
4334
                  end loop;
4335
 
4336
                  if Present (R) then
4337
                     if Nkind (R) = N_Identifier then
4338
                        Remove_Homonyms (R);
4339
 
4340
                     elsif Nkind (R) = N_Selected_Component then
4341
                        Remove_Homonyms (Selector_Name (R));
4342
 
4343
                     --  Renaming of attribute
4344
 
4345
                     else
4346
                        null;
4347
                     end if;
4348
                  end if;
4349
               end Remove_Homonyms;
4350
 
4351
            --  Start of processing for Check_Pragma_Import
4352
 
4353
            begin
4354
               --  Find name of entity in Import pragma. We have not analyzed
4355
               --  the construct, so we must guard against syntax errors.
4356
 
4357
               Arg := Next (First (Pragma_Argument_Associations (P)));
4358
 
4359
               if No (Arg)
4360
                 or else Nkind (Expression (Arg)) /= N_Identifier
4361
               then
4362
                  return;
4363
               else
4364
                  Imported := Expression (Arg);
4365
               end if;
4366
 
4367
               Remove_Homonyms (Imported);
4368
            end Check_Pragma_Import;
4369
 
4370
         --  Start of processing for Check_Declarations
4371
 
4372
         begin
4373
            --  Search for Elaborate Body pragma
4374
 
4375
            Decl := First (Visible_Declarations (Spec));
4376
            while Present (Decl)
4377
              and then Nkind (Decl) = N_Pragma
4378
            loop
4379
               if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then
4380
                  Set_Body_Required (Library_Unit (N));
4381
                  return;
4382
               end if;
4383
 
4384
               Next (Decl);
4385
            end loop;
4386
 
4387
            --  Look for declarations that require the presence of a body. We
4388
            --  have already skipped pragmas at the start of the list.
4389
 
4390
            while Present (Decl) loop
4391
 
4392
               --  Subprogram that comes from source means body may be needed.
4393
               --  Save for subsequent examination of import pragmas.
4394
 
4395
               if Comes_From_Source (Decl)
4396
                 and then (Nkind_In (Decl, N_Subprogram_Declaration,
4397
                                           N_Subprogram_Renaming_Declaration,
4398
                                           N_Generic_Subprogram_Declaration))
4399
               then
4400
                  Append_Elmt (Defining_Entity (Decl), Subp_List);
4401
 
4402
               --  Package declaration of generic package declaration. We need
4403
               --  to recursively examine nested declarations.
4404
 
4405
               elsif Nkind_In (Decl, N_Package_Declaration,
4406
                                     N_Generic_Package_Declaration)
4407
               then
4408
                  Check_Declarations (Specification (Decl));
4409
 
4410
               elsif Nkind (Decl) = N_Pragma
4411
                 and then Pragma_Name (Decl) = Name_Import
4412
               then
4413
                  Check_Pragma_Import (Decl);
4414
               end if;
4415
 
4416
               Next (Decl);
4417
            end loop;
4418
 
4419
            --  Same set of tests for private part. In addition to subprograms
4420
            --  detect the presence of Taft Amendment types (incomplete types
4421
            --  completed in the body).
4422
 
4423
            Decl := First (Private_Declarations (Spec));
4424
            while Present (Decl) loop
4425
               if Comes_From_Source (Decl)
4426
                 and then (Nkind_In (Decl, N_Subprogram_Declaration,
4427
                                           N_Subprogram_Renaming_Declaration,
4428
                                           N_Generic_Subprogram_Declaration))
4429
               then
4430
                  Append_Elmt (Defining_Entity (Decl), Subp_List);
4431
 
4432
               elsif Nkind_In (Decl, N_Package_Declaration,
4433
                                     N_Generic_Package_Declaration)
4434
               then
4435
                  Check_Declarations (Specification (Decl));
4436
 
4437
               --  Collect incomplete type declarations for separate pass
4438
 
4439
               elsif Nkind (Decl) = N_Incomplete_Type_Declaration then
4440
                  Append_Elmt (Decl, Incomplete_Decls);
4441
 
4442
               elsif Nkind (Decl) = N_Pragma
4443
                 and then Pragma_Name (Decl) = Name_Import
4444
               then
4445
                  Check_Pragma_Import (Decl);
4446
               end if;
4447
 
4448
               Next (Decl);
4449
            end loop;
4450
 
4451
            --  Now check incomplete declarations to locate Taft amendment
4452
            --  types. This can be done by examining the defining identifiers
4453
            --  of  type declarations without real semantic analysis.
4454
 
4455
            declare
4456
               Inc : Elmt_Id;
4457
 
4458
            begin
4459
               Inc := First_Elmt (Incomplete_Decls);
4460
               while Present (Inc) loop
4461
                  Decl := Next (Node (Inc));
4462
                  while Present (Decl) loop
4463
                     if Nkind (Decl) = N_Full_Type_Declaration
4464
                       and then Chars (Defining_Identifier (Decl)) =
4465
                                Chars (Defining_Identifier (Node (Inc)))
4466
                     then
4467
                        exit;
4468
                     end if;
4469
 
4470
                     Next (Decl);
4471
                  end loop;
4472
 
4473
                  --  If no completion, this is a TAT, and a body is needed
4474
 
4475
                  if No (Decl) then
4476
                     Set_Body_Required (Library_Unit (N));
4477
                     return;
4478
                  end if;
4479
 
4480
                  Next_Elmt (Inc);
4481
               end loop;
4482
            end;
4483
 
4484
            --  Finally, check whether there are subprograms that still require
4485
            --  a body, i.e. are not renamings or null.
4486
 
4487
            if not Is_Empty_Elmt_List (Subp_List) then
4488
               declare
4489
                  Subp_Id : Elmt_Id;
4490
                  Spec    : Node_Id;
4491
 
4492
               begin
4493
                  Subp_Id := First_Elmt (Subp_List);
4494
                  Spec    := Parent (Node (Subp_Id));
4495
 
4496
                  while Present (Subp_Id) loop
4497
                     if Nkind (Parent (Spec))
4498
                        = N_Subprogram_Renaming_Declaration
4499
                     then
4500
                        null;
4501
 
4502
                     elsif Nkind (Spec) = N_Procedure_Specification
4503
                       and then Null_Present (Spec)
4504
                     then
4505
                        null;
4506
 
4507
                     else
4508
                        Set_Body_Required (Library_Unit (N));
4509
                        return;
4510
                     end if;
4511
 
4512
                     Next_Elmt (Subp_Id);
4513
                  end loop;
4514
               end;
4515
            end if;
4516
         end Check_Declarations;
4517
 
4518
      --  Start of processing for Check_Body_Required
4519
 
4520
      begin
4521
         --  If this is an imported package (Java and CIL usage) no body is
4522
         --  needed. Scan list of pragmas that may follow a compilation unit
4523
         --  to look for a relevant pragma Import.
4524
 
4525
         if Present (PA) then
4526
            declare
4527
               Prag : Node_Id;
4528
 
4529
            begin
4530
               Prag := First (PA);
4531
               while Present (Prag) loop
4532
                  if Nkind (Prag) = N_Pragma
4533
                    and then Get_Pragma_Id (Prag) = Pragma_Import
4534
                  then
4535
                     return;
4536
                  end if;
4537
 
4538
                  Next (Prag);
4539
               end loop;
4540
            end;
4541
         end if;
4542
 
4543
         Check_Declarations (Specification (P_Unit));
4544
      end Check_Body_Required;
4545
 
4546
      -----------------------------
4547
      -- Has_Limited_With_Clause --
4548
      -----------------------------
4549
 
4550
      function Has_Limited_With_Clause
4551
        (C_Unit : Entity_Id;
4552
         Pack   : Entity_Id) return Boolean
4553
      is
4554
         Par      : Entity_Id;
4555
         Par_Unit : Node_Id;
4556
 
4557
      begin
4558
         Par := C_Unit;
4559
         while Present (Par) loop
4560
            if Ekind (Par) /= E_Package then
4561
               exit;
4562
            end if;
4563
 
4564
            --  Retrieve the Compilation_Unit node for Par and determine if
4565
            --  its context clauses contain a limited with for Pack.
4566
 
4567
            Par_Unit := Parent (Parent (Parent (Par)));
4568
 
4569
            if Nkind (Par_Unit) = N_Package_Declaration then
4570
               Par_Unit := Parent (Par_Unit);
4571
            end if;
4572
 
4573
            if Has_With_Clause (Par_Unit, Pack, True) then
4574
               return True;
4575
            end if;
4576
 
4577
            --  If there are more ancestors, climb up the tree, otherwise we
4578
            --  are done.
4579
 
4580
            if Is_Child_Unit (Par) then
4581
               Par := Scope (Par);
4582
            else
4583
               exit;
4584
            end if;
4585
         end loop;
4586
 
4587
         return False;
4588
      end Has_Limited_With_Clause;
4589
 
4590
      ----------------------------------
4591
      -- Is_Visible_Through_Renamings --
4592
      ----------------------------------
4593
 
4594
      function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
4595
         Kind     : constant Node_Kind :=
4596
                      Nkind (Unit (Cunit (Current_Sem_Unit)));
4597
         Aux_Unit : Node_Id;
4598
         Item     : Node_Id;
4599
         Decl     : Entity_Id;
4600
 
4601
      begin
4602
         --  Example of the error detected by this subprogram:
4603
 
4604
         --  package P is
4605
         --    type T is ...
4606
         --  end P;
4607
 
4608
         --  with P;
4609
         --  package Q is
4610
         --     package Ren_P renames P;
4611
         --  end Q;
4612
 
4613
         --  with Q;
4614
         --  package R is ...
4615
 
4616
         --  limited with P; -- ERROR
4617
         --  package R.C is ...
4618
 
4619
         Aux_Unit := Cunit (Current_Sem_Unit);
4620
 
4621
         loop
4622
            Item := First (Context_Items (Aux_Unit));
4623
            while Present (Item) loop
4624
               if Nkind (Item) = N_With_Clause
4625
                 and then not Limited_Present (Item)
4626
                 and then Nkind (Unit (Library_Unit (Item))) =
4627
                                                  N_Package_Declaration
4628
               then
4629
                  Decl :=
4630
                    First (Visible_Declarations
4631
                            (Specification (Unit (Library_Unit (Item)))));
4632
                  while Present (Decl) loop
4633
                     if Nkind (Decl) = N_Package_Renaming_Declaration
4634
                       and then Entity (Name (Decl)) = P
4635
                     then
4636
                        --  Generate the error message only if the current unit
4637
                        --  is a package declaration; in case of subprogram
4638
                        --  bodies and package bodies we just return True to
4639
                        --  indicate that the limited view must not be
4640
                        --  installed.
4641
 
4642
                        if Kind = N_Package_Declaration then
4643
                           Error_Msg_N
4644
                             ("simultaneous visibility of the limited and " &
4645
                              "unlimited views not allowed", N);
4646
                           Error_Msg_Sloc := Sloc (Item);
4647
                           Error_Msg_NE
4648
                             ("\\  unlimited view of & visible through the " &
4649
                              "context clause #", N, P);
4650
                           Error_Msg_Sloc := Sloc (Decl);
4651
                           Error_Msg_NE ("\\  and the renaming #", N, P);
4652
                        end if;
4653
 
4654
                        return True;
4655
                     end if;
4656
 
4657
                     Next (Decl);
4658
                  end loop;
4659
               end if;
4660
 
4661
               Next (Item);
4662
            end loop;
4663
 
4664
            --  If it is a body not acting as spec, follow pointer to the
4665
            --  corresponding spec, otherwise follow pointer to parent spec.
4666
 
4667
            if Present (Library_Unit (Aux_Unit))
4668
              and then Nkind_In (Unit (Aux_Unit),
4669
                                 N_Package_Body, N_Subprogram_Body)
4670
            then
4671
               if Aux_Unit = Library_Unit (Aux_Unit) then
4672
 
4673
                  --  Aux_Unit is a body that acts as a spec. Clause has
4674
                  --  already been flagged as illegal.
4675
 
4676
                  return False;
4677
 
4678
               else
4679
                  Aux_Unit := Library_Unit (Aux_Unit);
4680
               end if;
4681
 
4682
            else
4683
               Aux_Unit := Parent_Spec (Unit (Aux_Unit));
4684
            end if;
4685
 
4686
            exit when No (Aux_Unit);
4687
         end loop;
4688
 
4689
         return False;
4690
      end Is_Visible_Through_Renamings;
4691
 
4692
   --  Start of processing for Install_Limited_Withed_Unit
4693
 
4694
   begin
4695
      pragma Assert (not Limited_View_Installed (N));
4696
 
4697
      --  In case of limited with_clause on subprograms, generics, instances,
4698
      --  or renamings, the corresponding error was previously posted and we
4699
      --  have nothing to do here. If the file is missing altogether, it has
4700
      --  no source location.
4701
 
4702
      if Nkind (P_Unit) /= N_Package_Declaration
4703
        or else Sloc (P_Unit) = No_Location
4704
      then
4705
         return;
4706
      end if;
4707
 
4708
      P := Defining_Unit_Name (Specification (P_Unit));
4709
 
4710
      --  Handle child packages
4711
 
4712
      if Nkind (P) = N_Defining_Program_Unit_Name then
4713
         Is_Child_Package := True;
4714
         P := Defining_Identifier (P);
4715
      end if;
4716
 
4717
      --  Do not install the limited-view if the context of the unit is already
4718
      --  available through a regular with clause.
4719
 
4720
      if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4721
        and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
4722
      then
4723
         return;
4724
      end if;
4725
 
4726
      --  Do not install the limited-view if the full-view is already visible
4727
      --  through renaming declarations.
4728
 
4729
      if Is_Visible_Through_Renamings (P) then
4730
         return;
4731
      end if;
4732
 
4733
      --  Do not install the limited view if this is the unit being analyzed.
4734
      --  This unusual case will happen when a unit has a limited_with clause
4735
      --  on one of its children. The compilation of the child forces the load
4736
      --  of the parent which tries to install the limited view of the child
4737
      --  again. Installing the limited view must also be disabled when
4738
      --  compiling the body of the child unit.
4739
 
4740
      if P = Cunit_Entity (Current_Sem_Unit)
4741
        or else
4742
         (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4743
            and then P = Main_Unit_Entity)
4744
      then
4745
         return;
4746
      end if;
4747
 
4748
      --  This scenario is similar to the one above, the difference is that the
4749
      --  compilation of sibling Par.Sib forces the load of parent Par which
4750
      --  tries to install the limited view of Lim_Pack [1]. However Par.Sib
4751
      --  has a with clause for Lim_Pack [2] in its body, and thus needs the
4752
      --  non-limited views of all entities from Lim_Pack.
4753
 
4754
      --     limited with Lim_Pack;   --  [1]
4755
      --     package Par is ...           package Lim_Pack is ...
4756
 
4757
      --                                  with Lim_Pack;  --  [2]
4758
      --     package Par.Sib is ...       package body Par.Sib is ...
4759
 
4760
      --  In this case Main_Unit_Entity is the spec of Par.Sib and Current_
4761
      --  Sem_Unit is the body of Par.Sib.
4762
 
4763
      if Ekind (P) = E_Package
4764
        and then Ekind (Main_Unit_Entity) = E_Package
4765
        and then Is_Child_Unit (Main_Unit_Entity)
4766
 
4767
         --  The body has a regular with clause
4768
 
4769
        and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4770
        and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
4771
 
4772
         --  One of the ancestors has a limited with clause
4773
 
4774
        and then Nkind (Parent (Parent (Main_Unit_Entity))) =
4775
                                                   N_Package_Specification
4776
        and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P)
4777
      then
4778
         return;
4779
      end if;
4780
 
4781
      --  A common use of the limited-with is to have a limited-with in the
4782
      --  package spec, and a normal with in its package body. For example:
4783
 
4784
      --       limited with X;  -- [1]
4785
      --       package A is ...
4786
 
4787
      --       with X;          -- [2]
4788
      --       package body A is ...
4789
 
4790
      --  The compilation of A's body installs the context clauses found at [2]
4791
      --  and then the context clauses of its specification (found at [1]). As
4792
      --  a consequence, at [1] the specification of X has been analyzed and it
4793
      --  is immediately visible. According to the semantics of limited-with
4794
      --  context clauses we don't install the limited view because the full
4795
      --  view of X supersedes its limited view.
4796
 
4797
      if Analyzed (P_Unit)
4798
        and then
4799
          (Is_Immediately_Visible (P)
4800
            or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
4801
      then
4802
 
4803
         --  The presence of both the limited and the analyzed nonlimited view
4804
         --  may also be an error, such as an illegal context for a limited
4805
         --  with_clause. In that case, do not process the context item at all.
4806
 
4807
         if Error_Posted (N) then
4808
            return;
4809
         end if;
4810
 
4811
         if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
4812
            declare
4813
               Item : Node_Id;
4814
            begin
4815
               Item := First (Context_Items (Cunit (Current_Sem_Unit)));
4816
               while Present (Item) loop
4817
                  if Nkind (Item) = N_With_Clause
4818
                    and then Comes_From_Source (Item)
4819
                    and then Entity (Name (Item)) = P
4820
                  then
4821
                     return;
4822
                  end if;
4823
 
4824
                  Next (Item);
4825
               end loop;
4826
            end;
4827
 
4828
            --  If this is a child body, assume that the nonlimited with_clause
4829
            --  appears in an ancestor. Could be refined ???
4830
 
4831
            if Is_Child_Unit
4832
              (Defining_Entity
4833
                 (Unit (Library_Unit (Cunit (Current_Sem_Unit)))))
4834
            then
4835
               return;
4836
            end if;
4837
 
4838
         else
4839
 
4840
            --  If in package declaration, nonlimited view brought in from
4841
            --  parent unit or some error condition.
4842
 
4843
            return;
4844
         end if;
4845
      end if;
4846
 
4847
      if Debug_Flag_I then
4848
         Write_Str ("install limited view of ");
4849
         Write_Name (Chars (P));
4850
         Write_Eol;
4851
      end if;
4852
 
4853
      --  If the unit has not been analyzed and the limited view has not been
4854
      --  already installed then we install it.
4855
 
4856
      if not Analyzed (P_Unit) then
4857
         if not In_Chain (P) then
4858
 
4859
            --  Minimum decoration
4860
 
4861
            Set_Ekind (P, E_Package);
4862
            Set_Etype (P, Standard_Void_Type);
4863
            Set_Scope (P, Standard_Standard);
4864
 
4865
            if Is_Child_Package then
4866
               Set_Is_Child_Unit (P);
4867
               Set_Is_Visible_Child_Unit (P);
4868
               Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit))));
4869
            end if;
4870
 
4871
            --  Place entity on visibility structure
4872
 
4873
            Set_Homonym (P, Current_Entity (P));
4874
            Set_Current_Entity (P);
4875
 
4876
            if Debug_Flag_I then
4877
               Write_Str ("   (homonym) chain ");
4878
               Write_Name (Chars (P));
4879
               Write_Eol;
4880
            end if;
4881
 
4882
            --  Install the incomplete view. The first element of the limited
4883
            --  view is a header (an E_Package entity) used to reference the
4884
            --  first shadow entity in the private part of the package.
4885
 
4886
            Lim_Header := Limited_View (P);
4887
            Lim_Typ    := First_Entity (Lim_Header);
4888
 
4889
            while Present (Lim_Typ)
4890
              and then Lim_Typ /= First_Private_Entity (Lim_Header)
4891
            loop
4892
               Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
4893
               Set_Current_Entity (Lim_Typ);
4894
 
4895
               if Debug_Flag_I then
4896
                  Write_Str ("   (homonym) chain ");
4897
                  Write_Name (Chars (Lim_Typ));
4898
                  Write_Eol;
4899
               end if;
4900
 
4901
               Next_Entity (Lim_Typ);
4902
            end loop;
4903
         end if;
4904
 
4905
      --  If the unit appears in a previous regular with_clause, the regular
4906
      --  entities of the public part of the withed package must be replaced
4907
      --  by the shadow ones.
4908
 
4909
      --  This code must be kept synchronized with the code that replaces the
4910
      --  shadow entities by the real entities (see body of Remove_Limited
4911
      --  With_Clause); otherwise the contents of the homonym chains are not
4912
      --  consistent.
4913
 
4914
      else
4915
         --  Hide all the type entities of the public part of the package to
4916
         --  avoid its usage. This is needed to cover all the subtype decla-
4917
         --  rations because we do not remove them from the homonym chain.
4918
 
4919
         E := First_Entity (P);
4920
         while Present (E) and then E /= First_Private_Entity (P) loop
4921
            if Is_Type (E) then
4922
               Set_Was_Hidden (E, Is_Hidden (E));
4923
               Set_Is_Hidden (E);
4924
            end if;
4925
 
4926
            Next_Entity (E);
4927
         end loop;
4928
 
4929
         --  Replace the real entities by the shadow entities of the limited
4930
         --  view. The first element of the limited view is a header that is
4931
         --  used to reference the first shadow entity in the private part
4932
         --  of the package. Successive elements are the limited views of the
4933
         --  type (including regular incomplete types) declared in the package.
4934
 
4935
         Lim_Header := Limited_View (P);
4936
 
4937
         Lim_Typ := First_Entity (Lim_Header);
4938
         while Present (Lim_Typ)
4939
           and then Lim_Typ /= First_Private_Entity (Lim_Header)
4940
         loop
4941
            pragma Assert (not In_Chain (Lim_Typ));
4942
 
4943
            --  Do not unchain nested packages and child units
4944
 
4945
            if Ekind (Lim_Typ) /= E_Package
4946
              and then not Is_Child_Unit (Lim_Typ)
4947
            then
4948
               declare
4949
                  Prev : Entity_Id;
4950
 
4951
               begin
4952
                  Prev := Current_Entity (Lim_Typ);
4953
                  E := Prev;
4954
 
4955
                  --  Replace E in the homonyms list, so that the limited view
4956
                  --  becomes available.
4957
 
4958
                  if E = Non_Limited_View (Lim_Typ) then
4959
                     Set_Homonym (Lim_Typ, Homonym (Prev));
4960
                     Set_Current_Entity (Lim_Typ);
4961
 
4962
                  else
4963
                     loop
4964
                        E := Homonym (Prev);
4965
 
4966
                        --  E may have been removed when installing a previous
4967
                        --  limited_with_clause.
4968
 
4969
                        exit when No (E);
4970
 
4971
                        exit when E = Non_Limited_View (Lim_Typ);
4972
 
4973
                        Prev := Homonym (Prev);
4974
                     end loop;
4975
 
4976
                     if Present (E) then
4977
                        Set_Homonym (Lim_Typ, Homonym (Homonym (Prev)));
4978
                        Set_Homonym (Prev, Lim_Typ);
4979
                     end if;
4980
                  end if;
4981
               end;
4982
 
4983
               if Debug_Flag_I then
4984
                  Write_Str ("   (homonym) chain ");
4985
                  Write_Name (Chars (Lim_Typ));
4986
                  Write_Eol;
4987
               end if;
4988
            end if;
4989
 
4990
            Next_Entity (Lim_Typ);
4991
         end loop;
4992
      end if;
4993
 
4994
      --  The package must be visible while the limited-with clause is active
4995
      --  because references to the type P.T must resolve in the usual way.
4996
      --  In addition, we remember that the limited-view has been installed to
4997
      --  uninstall it at the point of context removal.
4998
 
4999
      Set_Is_Immediately_Visible (P);
5000
      Set_Limited_View_Installed (N);
5001
 
5002
      --  If unit has not been analyzed in some previous context, check
5003
      --  (imperfectly ???) whether it might need a body.
5004
 
5005
      if not Analyzed (P_Unit) then
5006
         Check_Body_Required;
5007
      end if;
5008
 
5009
      --  If the package in the limited_with clause is a child unit, the clause
5010
      --  is unanalyzed and appears as a selected component. Recast it as an
5011
      --  expanded name so that the entity can be properly set. Use entity of
5012
      --  parent, if available, for higher ancestors in the name.
5013
 
5014
      if Nkind (Name (N)) = N_Selected_Component then
5015
         declare
5016
            Nam : Node_Id;
5017
            Ent : Entity_Id;
5018
 
5019
         begin
5020
            Nam := Name (N);
5021
            Ent := P;
5022
            while Nkind (Nam) = N_Selected_Component
5023
              and then Present (Ent)
5024
            loop
5025
               Change_Selected_Component_To_Expanded_Name (Nam);
5026
 
5027
               --  Set entity of parent identifiers if the unit is a child
5028
               --  unit. This ensures that the tree is properly formed from
5029
               --  semantic point of view (e.g. for ASIS queries). The unit
5030
               --  entities are not fully analyzed, so we need to follow unit
5031
               --  links in the tree.
5032
 
5033
               Set_Entity (Nam, Ent);
5034
 
5035
               Nam := Prefix (Nam);
5036
               Ent :=
5037
                 Defining_Entity
5038
                   (Unit (Parent_Spec (Unit_Declaration_Node (Ent))));
5039
 
5040
               --  Set entity of last ancestor
5041
 
5042
               if Nkind (Nam) = N_Identifier then
5043
                  Set_Entity (Nam, Ent);
5044
               end if;
5045
            end loop;
5046
         end;
5047
      end if;
5048
 
5049
      Set_Entity (Name (N), P);
5050
      Set_From_With_Type (P);
5051
   end Install_Limited_Withed_Unit;
5052
 
5053
   -------------------------
5054
   -- Install_Withed_Unit --
5055
   -------------------------
5056
 
5057
   procedure Install_Withed_Unit
5058
     (With_Clause     : Node_Id;
5059
      Private_With_OK : Boolean := False)
5060
   is
5061
      Uname : constant Entity_Id := Entity (Name (With_Clause));
5062
      P     : constant Entity_Id := Scope (Uname);
5063
 
5064
   begin
5065
      --  Ada 2005 (AI-262): Do not install the private withed unit if we are
5066
      --  compiling a package declaration and the Private_With_OK flag was not
5067
      --  set by the caller. These declarations will be installed later (before
5068
      --  analyzing the private part of the package).
5069
 
5070
      if Private_Present (With_Clause)
5071
        and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
5072
        and then not (Private_With_OK)
5073
      then
5074
         return;
5075
      end if;
5076
 
5077
      if Debug_Flag_I then
5078
         if Private_Present (With_Clause) then
5079
            Write_Str ("install private withed unit ");
5080
         else
5081
            Write_Str ("install withed unit ");
5082
         end if;
5083
 
5084
         Write_Name (Chars (Uname));
5085
         Write_Eol;
5086
      end if;
5087
 
5088
      --  We do not apply the restrictions to an internal unit unless we are
5089
      --  compiling the internal unit as a main unit. This check is also
5090
      --  skipped for dummy units (for missing packages).
5091
 
5092
      if Sloc (Uname) /= No_Location
5093
        and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
5094
                    or else Current_Sem_Unit = Main_Unit)
5095
      then
5096
         Check_Restricted_Unit
5097
           (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
5098
      end if;
5099
 
5100
      if P /= Standard_Standard then
5101
 
5102
         --  If the unit is not analyzed after analysis of the with clause and
5103
         --  it is an instantiation then it awaits a body and is the main unit.
5104
         --  Its appearance in the context of some other unit indicates a
5105
         --  circular dependency (DEC suite perversity).
5106
 
5107
         if not Analyzed (Uname)
5108
           and then Nkind (Parent (Uname)) = N_Package_Instantiation
5109
         then
5110
            Error_Msg_N
5111
              ("instantiation depends on itself", Name (With_Clause));
5112
 
5113
         elsif not Is_Visible_Child_Unit (Uname) then
5114
 
5115
            --  Abandon processing in case of previous errors
5116
 
5117
            if No (Scope (Uname)) then
5118
               pragma Assert (Serious_Errors_Detected /= 0);
5119
               return;
5120
            end if;
5121
 
5122
            Set_Is_Visible_Child_Unit (Uname);
5123
 
5124
            --  If the child unit appears in the context of its parent, it is
5125
            --  immediately visible.
5126
 
5127
            if In_Open_Scopes (Scope (Uname)) then
5128
               Set_Is_Immediately_Visible (Uname);
5129
            end if;
5130
 
5131
            if Is_Generic_Instance (Uname)
5132
              and then Ekind (Uname) in Subprogram_Kind
5133
            then
5134
               --  Set flag as well on the visible entity that denotes the
5135
               --  instance, which renames the current one.
5136
 
5137
               Set_Is_Visible_Child_Unit
5138
                 (Related_Instance
5139
                   (Defining_Entity (Unit (Library_Unit (With_Clause)))));
5140
            end if;
5141
 
5142
            --  The parent unit may have been installed already, and may have
5143
            --  appeared in a use clause.
5144
 
5145
            if In_Use (Scope (Uname)) then
5146
               Set_Is_Potentially_Use_Visible (Uname);
5147
            end if;
5148
 
5149
            Set_Context_Installed (With_Clause);
5150
         end if;
5151
 
5152
      elsif not Is_Immediately_Visible (Uname) then
5153
         if not Private_Present (With_Clause)
5154
           or else Private_With_OK
5155
         then
5156
            Set_Is_Immediately_Visible (Uname);
5157
         end if;
5158
 
5159
         Set_Context_Installed (With_Clause);
5160
      end if;
5161
 
5162
      --   A with-clause overrides a with-type clause: there are no restric-
5163
      --   tions on the use of package entities.
5164
 
5165
      if Ekind (Uname) = E_Package then
5166
         Set_From_With_Type (Uname, False);
5167
      end if;
5168
 
5169
      --  Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5170
      --  unit if there is a visible homograph for it declared in the same
5171
      --  declarative region. This pathological case can only arise when an
5172
      --  instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5173
      --  G1 has a generic child also named G2, and the context includes with_
5174
      --  clauses for both I1.G2 and for G1.G2, making an implicit declaration
5175
      --  of I1.G2 visible as well. If the child unit is named Standard, do
5176
      --  not apply the check to the Standard package itself.
5177
 
5178
      if Is_Child_Unit (Uname)
5179
        and then Is_Visible_Child_Unit (Uname)
5180
        and then Ada_Version >= Ada_2005
5181
      then
5182
         declare
5183
            Decl1 : constant Node_Id  := Unit_Declaration_Node (P);
5184
            Decl2 : Node_Id;
5185
            P2    : Entity_Id;
5186
            U2    : Entity_Id;
5187
 
5188
         begin
5189
            U2 := Homonym (Uname);
5190
            while Present (U2)
5191
              and then U2 /= Standard_Standard
5192
           loop
5193
               P2 := Scope (U2);
5194
               Decl2  := Unit_Declaration_Node (P2);
5195
 
5196
               if Is_Child_Unit (U2)
5197
                 and then Is_Visible_Child_Unit (U2)
5198
               then
5199
                  if Is_Generic_Instance (P)
5200
                    and then Nkind (Decl1) = N_Package_Declaration
5201
                    and then Generic_Parent (Specification (Decl1)) = P2
5202
                  then
5203
                     Error_Msg_N ("illegal with_clause", With_Clause);
5204
                     Error_Msg_N
5205
                       ("\child unit has visible homograph" &
5206
                           " (RM 8.3(26), 10.1.1(19))",
5207
                         With_Clause);
5208
                     exit;
5209
 
5210
                  elsif Is_Generic_Instance (P2)
5211
                    and then Nkind (Decl2) = N_Package_Declaration
5212
                    and then Generic_Parent (Specification (Decl2)) = P
5213
                  then
5214
                     --  With_clause for child unit of instance appears before
5215
                     --  in the context. We want to place the error message on
5216
                     --  it, not on the generic child unit itself.
5217
 
5218
                     declare
5219
                        Prev_Clause : Node_Id;
5220
 
5221
                     begin
5222
                        Prev_Clause := First (List_Containing (With_Clause));
5223
                        while Entity (Name (Prev_Clause)) /= U2 loop
5224
                           Next (Prev_Clause);
5225
                        end loop;
5226
 
5227
                        pragma Assert (Present (Prev_Clause));
5228
                        Error_Msg_N ("illegal with_clause", Prev_Clause);
5229
                        Error_Msg_N
5230
                          ("\child unit has visible homograph" &
5231
                              " (RM 8.3(26), 10.1.1(19))",
5232
                            Prev_Clause);
5233
                        exit;
5234
                     end;
5235
                  end if;
5236
               end if;
5237
 
5238
               U2 := Homonym (U2);
5239
            end loop;
5240
         end;
5241
      end if;
5242
   end Install_Withed_Unit;
5243
 
5244
   -------------------
5245
   -- Is_Child_Spec --
5246
   -------------------
5247
 
5248
   function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
5249
      K : constant Node_Kind := Nkind (Lib_Unit);
5250
 
5251
   begin
5252
      return (K in N_Generic_Declaration              or else
5253
              K in N_Generic_Instantiation            or else
5254
              K in N_Generic_Renaming_Declaration     or else
5255
              K =  N_Package_Declaration              or else
5256
              K =  N_Package_Renaming_Declaration     or else
5257
              K =  N_Subprogram_Declaration           or else
5258
              K =  N_Subprogram_Renaming_Declaration)
5259
        and then Present (Parent_Spec (Lib_Unit));
5260
   end Is_Child_Spec;
5261
 
5262
   ------------------------------------
5263
   -- Is_Legal_Shadow_Entity_In_Body --
5264
   ------------------------------------
5265
 
5266
   function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is
5267
      C_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
5268
   begin
5269
      return Nkind (Unit (C_Unit)) = N_Package_Body
5270
        and then
5271
          Has_With_Clause
5272
            (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
5273
   end Is_Legal_Shadow_Entity_In_Body;
5274
 
5275
   -----------------------
5276
   -- Load_Needed_Body --
5277
   -----------------------
5278
 
5279
   --  N is a generic unit named in a with clause, or else it is a unit that
5280
   --  contains a generic unit or an inlined function. In order to perform an
5281
   --  instantiation, the body of the unit must be present. If the unit itself
5282
   --  is generic, we assume that an instantiation follows, and load & analyze
5283
   --  the body unconditionally. This forces analysis of the spec as well.
5284
 
5285
   --  If the unit is not generic, but contains a generic unit, it is loaded on
5286
   --  demand, at the point of instantiation (see ch12).
5287
 
5288
   procedure Load_Needed_Body
5289
     (N          : Node_Id;
5290
      OK         : out Boolean;
5291
      Do_Analyze : Boolean := True)
5292
   is
5293
      Body_Name : Unit_Name_Type;
5294
      Unum      : Unit_Number_Type;
5295
 
5296
      Save_Style_Check : constant Boolean := Opt.Style_Check;
5297
      --  The loading and analysis is done with style checks off
5298
 
5299
   begin
5300
      if not GNAT_Mode then
5301
         Style_Check := False;
5302
      end if;
5303
 
5304
      Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
5305
      Unum :=
5306
        Load_Unit
5307
          (Load_Name  => Body_Name,
5308
           Required   => False,
5309
           Subunit    => False,
5310
           Error_Node => N,
5311
           Renamings  => True);
5312
 
5313
      if Unum = No_Unit then
5314
         OK := False;
5315
 
5316
      else
5317
         Compiler_State := Analyzing; -- reset after load
5318
 
5319
         if not Fatal_Error (Unum) or else Try_Semantics then
5320
            if Debug_Flag_L then
5321
               Write_Str ("*** Loaded generic body");
5322
               Write_Eol;
5323
            end if;
5324
 
5325
            if Do_Analyze then
5326
               Semantics (Cunit (Unum));
5327
            end if;
5328
         end if;
5329
 
5330
         OK := True;
5331
      end if;
5332
 
5333
      Style_Check := Save_Style_Check;
5334
   end Load_Needed_Body;
5335
 
5336
   -------------------------
5337
   -- Build_Limited_Views --
5338
   -------------------------
5339
 
5340
   procedure Build_Limited_Views (N : Node_Id) is
5341
      Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
5342
      P    : constant Entity_Id        := Cunit_Entity (Unum);
5343
 
5344
      Spec     : Node_Id;            --  To denote a package specification
5345
      Lim_Typ  : Entity_Id;          --  To denote shadow entities
5346
      Comp_Typ : Entity_Id;          --  To denote real entities
5347
 
5348
      Lim_Header     : Entity_Id;          --  Package entity
5349
      Last_Lim_E     : Entity_Id := Empty; --  Last limited entity built
5350
      Last_Pub_Lim_E : Entity_Id;          --  To set the first private entity
5351
 
5352
      procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id);
5353
      --  Add attributes of an incomplete type to a shadow entity. The same
5354
      --  attributes are placed on the real entity, so that gigi receives
5355
      --  a consistent view.
5356
 
5357
      procedure Decorate_Package_Specification (P : Entity_Id);
5358
      --  Add attributes of a package entity to the entity in a package
5359
      --  declaration
5360
 
5361
      procedure Decorate_Tagged_Type
5362
        (Loc  : Source_Ptr;
5363
         T    : Entity_Id;
5364
         Scop : Entity_Id;
5365
         Mark : Boolean := False);
5366
      --  Set basic attributes of tagged type T, including its class-wide type.
5367
      --  The parameters Loc, Scope are used to decorate the class-wide type.
5368
      --  Use flag Mark to label the class-wide type as Materialize_Entity.
5369
 
5370
      procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id);
5371
      --  Construct list of shadow entities and attach it to entity of
5372
      --  package that is mentioned in a limited_with clause.
5373
 
5374
      function New_Internal_Shadow_Entity
5375
        (Kind       : Entity_Kind;
5376
         Sloc_Value : Source_Ptr;
5377
         Id_Char    : Character) return Entity_Id;
5378
      --  Build a new internal entity and append it to the list of shadow
5379
      --  entities available through the limited-header
5380
 
5381
      -----------------
5382
      -- Build_Chain --
5383
      -----------------
5384
 
5385
      procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is
5386
         Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
5387
         Is_Tagged     : Boolean;
5388
         Decl          : Node_Id;
5389
 
5390
      begin
5391
         Decl := First_Decl;
5392
         while Present (Decl) loop
5393
 
5394
            --  For each library_package_declaration in the environment, there
5395
            --  is an implicit declaration of a *limited view* of that library
5396
            --  package. The limited view of a package contains:
5397
 
5398
            --   * For each nested package_declaration, a declaration of the
5399
            --     limited view of that package, with the same defining-
5400
            --     program-unit name.
5401
 
5402
            --   * For each type_declaration in the visible part, an incomplete
5403
            --     type-declaration with the same defining_identifier, whose
5404
            --     completion is the type_declaration. If the type_declaration
5405
            --     is tagged, then the incomplete_type_declaration is tagged
5406
            --     incomplete.
5407
 
5408
            --     The partial view is tagged if the declaration has the
5409
            --     explicit keyword, or else if it is a type extension, both
5410
            --     of which can be ascertained syntactically.
5411
 
5412
            if Nkind (Decl) = N_Full_Type_Declaration then
5413
               Is_Tagged :=
5414
                  (Nkind (Type_Definition (Decl)) = N_Record_Definition
5415
                    and then Tagged_Present (Type_Definition (Decl)))
5416
                 or else
5417
                   (Nkind (Type_Definition (Decl)) = N_Derived_Type_Definition
5418
                     and then
5419
                       Present
5420
                         (Record_Extension_Part (Type_Definition (Decl))));
5421
 
5422
               Comp_Typ := Defining_Identifier (Decl);
5423
 
5424
               if not Analyzed_Unit then
5425
                  if Is_Tagged then
5426
                     Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
5427
                  else
5428
                     Decorate_Incomplete_Type (Comp_Typ, Scope);
5429
                  end if;
5430
               end if;
5431
 
5432
               --  Create shadow entity for type
5433
 
5434
               Lim_Typ :=
5435
                 New_Internal_Shadow_Entity
5436
                   (Kind       => Ekind (Comp_Typ),
5437
                    Sloc_Value => Sloc (Comp_Typ),
5438
                    Id_Char    => 'Z');
5439
 
5440
               Set_Chars  (Lim_Typ, Chars (Comp_Typ));
5441
               Set_Parent (Lim_Typ, Parent (Comp_Typ));
5442
               Set_From_With_Type (Lim_Typ);
5443
 
5444
               if Is_Tagged then
5445
                  Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
5446
               else
5447
                  Decorate_Incomplete_Type (Lim_Typ, Scope);
5448
               end if;
5449
 
5450
               Set_Non_Limited_View (Lim_Typ, Comp_Typ);
5451
               Set_Private_Dependents (Lim_Typ, New_Elmt_List);
5452
 
5453
            elsif Nkind_In (Decl, N_Private_Type_Declaration,
5454
                                  N_Incomplete_Type_Declaration,
5455
                                  N_Task_Type_Declaration,
5456
                                  N_Protected_Type_Declaration)
5457
            then
5458
               Comp_Typ := Defining_Identifier (Decl);
5459
 
5460
               Is_Tagged :=
5461
                 Nkind_In (Decl, N_Private_Type_Declaration,
5462
                                 N_Incomplete_Type_Declaration)
5463
                 and then Tagged_Present (Decl);
5464
 
5465
               if not Analyzed_Unit then
5466
                  if Is_Tagged then
5467
                     Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
5468
                  else
5469
                     Decorate_Incomplete_Type (Comp_Typ, Scope);
5470
                  end if;
5471
               end if;
5472
 
5473
               Lim_Typ :=
5474
                 New_Internal_Shadow_Entity
5475
                   (Kind       => Ekind (Comp_Typ),
5476
                    Sloc_Value => Sloc (Comp_Typ),
5477
                    Id_Char    => 'Z');
5478
 
5479
               Set_Chars  (Lim_Typ, Chars (Comp_Typ));
5480
               Set_Parent (Lim_Typ, Parent (Comp_Typ));
5481
               Set_From_With_Type (Lim_Typ);
5482
 
5483
               if Is_Tagged then
5484
                  Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
5485
               else
5486
                  Decorate_Incomplete_Type (Lim_Typ, Scope);
5487
               end if;
5488
 
5489
               Set_Non_Limited_View (Lim_Typ, Comp_Typ);
5490
 
5491
               --  Initialize Private_Depedents, so the field has the proper
5492
               --  type, even though the list will remain empty.
5493
 
5494
               Set_Private_Dependents (Lim_Typ, New_Elmt_List);
5495
 
5496
            elsif Nkind (Decl) = N_Private_Extension_Declaration then
5497
               Comp_Typ := Defining_Identifier (Decl);
5498
 
5499
               if not Analyzed_Unit then
5500
                  Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
5501
               end if;
5502
 
5503
               --  Create shadow entity for type
5504
 
5505
               Lim_Typ :=
5506
                 New_Internal_Shadow_Entity
5507
                   (Kind       => Ekind (Comp_Typ),
5508
                    Sloc_Value => Sloc (Comp_Typ),
5509
                    Id_Char    => 'Z');
5510
 
5511
               Set_Chars  (Lim_Typ, Chars (Comp_Typ));
5512
               Set_Parent (Lim_Typ, Parent (Comp_Typ));
5513
               Set_From_With_Type (Lim_Typ);
5514
 
5515
               Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
5516
               Set_Non_Limited_View (Lim_Typ, Comp_Typ);
5517
 
5518
            elsif Nkind (Decl) = N_Package_Declaration then
5519
 
5520
               --  Local package
5521
 
5522
               declare
5523
                  Spec : constant Node_Id := Specification (Decl);
5524
 
5525
               begin
5526
                  Comp_Typ := Defining_Unit_Name (Spec);
5527
 
5528
                  if not Analyzed (Cunit (Unum)) then
5529
                     Decorate_Package_Specification (Comp_Typ);
5530
                     Set_Scope (Comp_Typ, Scope);
5531
                  end if;
5532
 
5533
                  Lim_Typ :=
5534
                    New_Internal_Shadow_Entity
5535
                      (Kind       => Ekind (Comp_Typ),
5536
                       Sloc_Value => Sloc (Comp_Typ),
5537
                       Id_Char    => 'Z');
5538
 
5539
                  Decorate_Package_Specification (Lim_Typ);
5540
                  Set_Scope (Lim_Typ, Scope);
5541
 
5542
                  Set_Chars  (Lim_Typ, Chars (Comp_Typ));
5543
                  Set_Parent (Lim_Typ, Parent (Comp_Typ));
5544
                  Set_From_With_Type (Lim_Typ);
5545
 
5546
                  --  Note: The non_limited_view attribute is not used
5547
                  --  for local packages.
5548
 
5549
                  Build_Chain
5550
                    (Scope      => Lim_Typ,
5551
                     First_Decl => First (Visible_Declarations (Spec)));
5552
               end;
5553
            end if;
5554
 
5555
            Next (Decl);
5556
         end loop;
5557
      end Build_Chain;
5558
 
5559
      ------------------------------
5560
      -- Decorate_Incomplete_Type --
5561
      ------------------------------
5562
 
5563
      procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is
5564
      begin
5565
         Set_Ekind             (E, E_Incomplete_Type);
5566
         Set_Scope             (E, Scop);
5567
         Set_Etype             (E, E);
5568
         Set_Is_First_Subtype  (E, True);
5569
         Set_Stored_Constraint (E, No_Elist);
5570
         Set_Full_View         (E, Empty);
5571
         Init_Size_Align       (E);
5572
      end Decorate_Incomplete_Type;
5573
 
5574
      --------------------------
5575
      -- Decorate_Tagged_Type --
5576
      --------------------------
5577
 
5578
      procedure Decorate_Tagged_Type
5579
        (Loc  : Source_Ptr;
5580
         T    : Entity_Id;
5581
         Scop : Entity_Id;
5582
         Mark : Boolean := False)
5583
      is
5584
         CW : Entity_Id;
5585
 
5586
      begin
5587
         Decorate_Incomplete_Type (T, Scop);
5588
         Set_Is_Tagged_Type (T);
5589
 
5590
         --  Build corresponding class_wide type, if not previously done
5591
 
5592
         --  Note: The class-wide entity is shared by the limited-view
5593
         --  and the full-view.
5594
 
5595
         if No (Class_Wide_Type (T)) then
5596
            CW := New_External_Entity (E_Void, Scope (T), Loc, T, 'C', 0, 'T');
5597
 
5598
            --  Set parent to be the same as the parent of the tagged type.
5599
            --  We need a parent field set, and it is supposed to point to
5600
            --  the declaration of the type. The tagged type declaration
5601
            --  essentially declares two separate types, the tagged type
5602
            --  itself and the corresponding class-wide type, so it is
5603
            --  reasonable for the parent fields to point to the declaration
5604
            --  in both cases.
5605
 
5606
            Set_Parent (CW, Parent (T));
5607
 
5608
            --  Set remaining fields of classwide type
5609
 
5610
            Set_Ekind                     (CW, E_Class_Wide_Type);
5611
            Set_Etype                     (CW, T);
5612
            Set_Scope                     (CW, Scop);
5613
            Set_Is_Tagged_Type            (CW);
5614
            Set_Is_First_Subtype          (CW, True);
5615
            Init_Size_Align               (CW);
5616
            Set_Has_Unknown_Discriminants (CW, True);
5617
            Set_Class_Wide_Type           (CW, CW);
5618
            Set_Equivalent_Type           (CW, Empty);
5619
            Set_From_With_Type            (CW, From_With_Type (T));
5620
            Set_Materialize_Entity        (CW, Mark);
5621
 
5622
            --  Link type to its class-wide type
5623
 
5624
            Set_Class_Wide_Type           (T, CW);
5625
         end if;
5626
      end Decorate_Tagged_Type;
5627
 
5628
      ------------------------------------
5629
      -- Decorate_Package_Specification --
5630
      ------------------------------------
5631
 
5632
      procedure Decorate_Package_Specification (P : Entity_Id) is
5633
      begin
5634
         --  Place only the most basic attributes
5635
 
5636
         Set_Ekind (P, E_Package);
5637
         Set_Etype (P, Standard_Void_Type);
5638
      end Decorate_Package_Specification;
5639
 
5640
      --------------------------------
5641
      -- New_Internal_Shadow_Entity --
5642
      --------------------------------
5643
 
5644
      function New_Internal_Shadow_Entity
5645
        (Kind       : Entity_Kind;
5646
         Sloc_Value : Source_Ptr;
5647
         Id_Char    : Character) return Entity_Id
5648
      is
5649
         E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
5650
 
5651
      begin
5652
         Set_Ekind       (E, Kind);
5653
         Set_Is_Internal (E, True);
5654
 
5655
         if Kind in Type_Kind then
5656
            Init_Size_Align (E);
5657
         end if;
5658
 
5659
         Append_Entity (E, Lim_Header);
5660
         Last_Lim_E := E;
5661
         return E;
5662
      end New_Internal_Shadow_Entity;
5663
 
5664
   --  Start of processing for Build_Limited_Views
5665
 
5666
   begin
5667
      pragma Assert (Limited_Present (N));
5668
 
5669
      --  A library_item mentioned in a limited_with_clause is a package
5670
      --  declaration, not a subprogram declaration, generic declaration,
5671
      --  generic instantiation, or package renaming declaration.
5672
 
5673
      case Nkind (Unit (Library_Unit (N))) is
5674
         when N_Package_Declaration =>
5675
            null;
5676
 
5677
         when N_Subprogram_Declaration =>
5678
            Error_Msg_N ("subprograms not allowed in "
5679
                         & "limited with_clauses", N);
5680
            return;
5681
 
5682
         when N_Generic_Package_Declaration |
5683
              N_Generic_Subprogram_Declaration =>
5684
            Error_Msg_N ("generics not allowed in "
5685
                         & "limited with_clauses", N);
5686
            return;
5687
 
5688
         when N_Generic_Instantiation =>
5689
            Error_Msg_N ("generic instantiations not allowed in "
5690
                         & "limited with_clauses", N);
5691
            return;
5692
 
5693
         when N_Generic_Renaming_Declaration =>
5694
            Error_Msg_N ("generic renamings not allowed in "
5695
                         & "limited with_clauses", N);
5696
            return;
5697
 
5698
         when N_Subprogram_Renaming_Declaration =>
5699
            Error_Msg_N ("renamed subprograms not allowed in "
5700
                         & "limited with_clauses", N);
5701
            return;
5702
 
5703
         when N_Package_Renaming_Declaration =>
5704
            Error_Msg_N ("renamed packages not allowed in "
5705
                         & "limited with_clauses", N);
5706
            return;
5707
 
5708
         when others =>
5709
            raise Program_Error;
5710
      end case;
5711
 
5712
      --  Check if the chain is already built
5713
 
5714
      Spec := Specification (Unit (Library_Unit (N)));
5715
 
5716
      if Limited_View_Installed (Spec) then
5717
         return;
5718
      end if;
5719
 
5720
      Set_Ekind (P, E_Package);
5721
 
5722
      --  Build the header of the limited_view
5723
 
5724
      Lim_Header := Make_Temporary (Sloc (N), 'Z');
5725
      Set_Ekind (Lim_Header, E_Package);
5726
      Set_Is_Internal (Lim_Header);
5727
      Set_Limited_View (P, Lim_Header);
5728
 
5729
      --  Create the auxiliary chain. All the shadow entities are appended to
5730
      --  the list of entities of the limited-view header
5731
 
5732
      Build_Chain
5733
        (Scope      => P,
5734
         First_Decl => First (Visible_Declarations (Spec)));
5735
 
5736
      --  Save the last built shadow entity. It is needed later to set the
5737
      --  reference to the first shadow entity in the private part
5738
 
5739
      Last_Pub_Lim_E := Last_Lim_E;
5740
 
5741
      --  Ada 2005 (AI-262): Add the limited view of the private declarations
5742
      --  Required to give support to limited-private-with clauses
5743
 
5744
      Build_Chain (Scope      => P,
5745
                   First_Decl => First (Private_Declarations (Spec)));
5746
 
5747
      if Last_Pub_Lim_E /= Empty then
5748
         Set_First_Private_Entity
5749
           (Lim_Header, Next_Entity (Last_Pub_Lim_E));
5750
      else
5751
         Set_First_Private_Entity
5752
           (Lim_Header, First_Entity (P));
5753
      end if;
5754
 
5755
      Set_Limited_View_Installed (Spec);
5756
   end Build_Limited_Views;
5757
 
5758
   -------------------------------
5759
   -- Check_Body_Needed_For_SAL --
5760
   -------------------------------
5761
 
5762
   procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
5763
 
5764
      function Entity_Needs_Body (E : Entity_Id) return Boolean;
5765
      --  Determine whether use of entity E might require the presence of its
5766
      --  body. For a package this requires a recursive traversal of all nested
5767
      --  declarations.
5768
 
5769
      ---------------------------
5770
      -- Entity_Needed_For_SAL --
5771
      ---------------------------
5772
 
5773
      function Entity_Needs_Body (E : Entity_Id) return Boolean is
5774
         Ent : Entity_Id;
5775
 
5776
      begin
5777
         if Is_Subprogram (E)
5778
           and then Has_Pragma_Inline (E)
5779
         then
5780
            return True;
5781
 
5782
         elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
5783
            return True;
5784
 
5785
         elsif Ekind (E) = E_Generic_Package
5786
           and then
5787
             Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
5788
           and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
5789
         then
5790
            return True;
5791
 
5792
         elsif Ekind (E) = E_Package
5793
           and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
5794
           and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
5795
         then
5796
            Ent := First_Entity (E);
5797
            while Present (Ent) loop
5798
               if Entity_Needs_Body (Ent) then
5799
                  return True;
5800
               end if;
5801
 
5802
               Next_Entity (Ent);
5803
            end loop;
5804
 
5805
            return False;
5806
 
5807
         else
5808
            return False;
5809
         end if;
5810
      end Entity_Needs_Body;
5811
 
5812
   --  Start of processing for Check_Body_Needed_For_SAL
5813
 
5814
   begin
5815
      if Ekind (Unit_Name) = E_Generic_Package
5816
        and then Nkind (Unit_Declaration_Node (Unit_Name)) =
5817
                                            N_Generic_Package_Declaration
5818
        and then
5819
          Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
5820
      then
5821
         Set_Body_Needed_For_SAL (Unit_Name);
5822
 
5823
      elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
5824
         Set_Body_Needed_For_SAL (Unit_Name);
5825
 
5826
      elsif Is_Subprogram (Unit_Name)
5827
        and then Nkind (Unit_Declaration_Node (Unit_Name)) =
5828
                                            N_Subprogram_Declaration
5829
        and then Has_Pragma_Inline (Unit_Name)
5830
      then
5831
         Set_Body_Needed_For_SAL (Unit_Name);
5832
 
5833
      elsif Ekind (Unit_Name) = E_Subprogram_Body then
5834
         Check_Body_Needed_For_SAL
5835
           (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
5836
 
5837
      elsif Ekind (Unit_Name) = E_Package
5838
        and then Entity_Needs_Body (Unit_Name)
5839
      then
5840
         Set_Body_Needed_For_SAL (Unit_Name);
5841
 
5842
      elsif Ekind (Unit_Name) = E_Package_Body
5843
        and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
5844
      then
5845
         Check_Body_Needed_For_SAL
5846
           (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
5847
      end if;
5848
   end Check_Body_Needed_For_SAL;
5849
 
5850
   --------------------
5851
   -- Remove_Context --
5852
   --------------------
5853
 
5854
   procedure Remove_Context (N : Node_Id) is
5855
      Lib_Unit : constant Node_Id := Unit (N);
5856
 
5857
   begin
5858
      --  If this is a child unit, first remove the parent units
5859
 
5860
      if Is_Child_Spec (Lib_Unit) then
5861
         Remove_Parents (Lib_Unit);
5862
      end if;
5863
 
5864
      Remove_Context_Clauses (N);
5865
   end Remove_Context;
5866
 
5867
   ----------------------------
5868
   -- Remove_Context_Clauses --
5869
   ----------------------------
5870
 
5871
   procedure Remove_Context_Clauses (N : Node_Id) is
5872
      Item      : Node_Id;
5873
      Unit_Name : Entity_Id;
5874
 
5875
   begin
5876
      --  Ada 2005 (AI-50217): We remove the context clauses in two phases:
5877
      --  limited-views first and regular-views later (to maintain the
5878
      --  stack model).
5879
 
5880
      --  First Phase: Remove limited_with context clauses
5881
 
5882
      Item := First (Context_Items (N));
5883
      while Present (Item) loop
5884
 
5885
         --  We are interested only in with clauses which got installed
5886
         --  on entry.
5887
 
5888
         if Nkind (Item) = N_With_Clause
5889
           and then Limited_Present (Item)
5890
           and then Limited_View_Installed (Item)
5891
         then
5892
            Remove_Limited_With_Clause (Item);
5893
         end if;
5894
 
5895
         Next (Item);
5896
      end loop;
5897
 
5898
      --  Second Phase: Loop through context items and undo regular
5899
      --  with_clauses and use_clauses.
5900
 
5901
      Item := First (Context_Items (N));
5902
      while Present (Item) loop
5903
 
5904
         --  We are interested only in with clauses which got installed on
5905
         --  entry, as indicated by their Context_Installed flag set
5906
 
5907
         if Nkind (Item) = N_With_Clause
5908
           and then Limited_Present (Item)
5909
           and then Limited_View_Installed (Item)
5910
         then
5911
            null;
5912
 
5913
         elsif Nkind (Item) = N_With_Clause
5914
            and then Context_Installed (Item)
5915
         then
5916
            --  Remove items from one with'ed unit
5917
 
5918
            Unit_Name := Entity (Name (Item));
5919
            Remove_Unit_From_Visibility (Unit_Name);
5920
            Set_Context_Installed (Item, False);
5921
 
5922
         elsif Nkind (Item) = N_Use_Package_Clause then
5923
            End_Use_Package (Item);
5924
 
5925
         elsif Nkind (Item) = N_Use_Type_Clause then
5926
            End_Use_Type (Item);
5927
         end if;
5928
 
5929
         Next (Item);
5930
      end loop;
5931
   end Remove_Context_Clauses;
5932
 
5933
   --------------------------------
5934
   -- Remove_Limited_With_Clause --
5935
   --------------------------------
5936
 
5937
   procedure Remove_Limited_With_Clause (N : Node_Id) is
5938
      P_Unit     : constant Entity_Id := Unit (Library_Unit (N));
5939
      E          : Entity_Id;
5940
      P          : Entity_Id;
5941
      Lim_Header : Entity_Id;
5942
      Lim_Typ    : Entity_Id;
5943
      Prev       : Entity_Id;
5944
 
5945
   begin
5946
      pragma Assert (Limited_View_Installed (N));
5947
 
5948
      --  In case of limited with_clause on subprograms, generics, instances,
5949
      --  or renamings, the corresponding error was previously posted and we
5950
      --  have nothing to do here.
5951
 
5952
      if Nkind (P_Unit) /= N_Package_Declaration then
5953
         return;
5954
      end if;
5955
 
5956
      P := Defining_Unit_Name (Specification (P_Unit));
5957
 
5958
      --  Handle child packages
5959
 
5960
      if Nkind (P) = N_Defining_Program_Unit_Name then
5961
         P := Defining_Identifier (P);
5962
      end if;
5963
 
5964
      if Debug_Flag_I then
5965
         Write_Str ("remove limited view of ");
5966
         Write_Name (Chars (P));
5967
         Write_Str (" from visibility");
5968
         Write_Eol;
5969
      end if;
5970
 
5971
      --  Prepare the removal of the shadow entities from visibility. The first
5972
      --  element of the limited view is a header (an E_Package entity) that is
5973
      --  used to reference the first shadow entity in the private part of the
5974
      --  package
5975
 
5976
      Lim_Header := Limited_View (P);
5977
      Lim_Typ    := First_Entity (Lim_Header);
5978
 
5979
      --  Remove package and shadow entities from visibility if it has not
5980
      --  been analyzed
5981
 
5982
      if not Analyzed (P_Unit) then
5983
         Unchain (P);
5984
         Set_Is_Immediately_Visible (P, False);
5985
 
5986
         while Present (Lim_Typ) loop
5987
            Unchain (Lim_Typ);
5988
            Next_Entity (Lim_Typ);
5989
         end loop;
5990
 
5991
      --  Otherwise this package has already appeared in the closure and its
5992
      --  shadow entities must be replaced by its real entities. This code
5993
      --  must be kept synchronized with the complementary code in Install
5994
      --  Limited_Withed_Unit.
5995
 
5996
      else
5997
         --  Real entities that are type or subtype declarations were hidden
5998
         --  from visibility at the point of installation of the limited-view.
5999
         --  Now we recover the previous value of the hidden attribute.
6000
 
6001
         E := First_Entity (P);
6002
         while Present (E) and then E /= First_Private_Entity (P) loop
6003
            if Is_Type (E) then
6004
               Set_Is_Hidden (E, Was_Hidden (E));
6005
            end if;
6006
 
6007
            Next_Entity (E);
6008
         end loop;
6009
 
6010
         while Present (Lim_Typ)
6011
           and then Lim_Typ /= First_Private_Entity (Lim_Header)
6012
         loop
6013
            --  Nested packages and child units were not unchained
6014
 
6015
            if Ekind (Lim_Typ) /= E_Package
6016
              and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
6017
            then
6018
               --  If the package has incomplete types, the limited view of the
6019
               --  incomplete type is in fact never visible (AI05-129) but we
6020
               --  have created a shadow entity E1 for it, that points to E2,
6021
               --  a non-limited incomplete type. This in turn has a full view
6022
               --  E3 that is the full declaration. There is a corresponding
6023
               --  shadow entity E4. When reinstalling the non-limited view,
6024
               --  E2 must become the current entity and E3 must be ignored.
6025
 
6026
               E := Non_Limited_View (Lim_Typ);
6027
 
6028
               if Present (Current_Entity (E))
6029
                 and then Ekind (Current_Entity (E)) = E_Incomplete_Type
6030
                 and then Full_View (Current_Entity (E)) = E
6031
               then
6032
 
6033
                  --  Lim_Typ is the limited view of a full type declaration
6034
                  --  that has a previous incomplete declaration, i.e. E3 from
6035
                  --  the previous description. Nothing to insert.
6036
 
6037
                  null;
6038
 
6039
               else
6040
                  pragma Assert (not In_Chain (E));
6041
 
6042
                  Prev := Current_Entity (Lim_Typ);
6043
 
6044
                  if Prev = Lim_Typ then
6045
                     Set_Current_Entity (E);
6046
 
6047
                  else
6048
                     while Present (Prev)
6049
                       and then Homonym (Prev) /= Lim_Typ
6050
                     loop
6051
                        Prev := Homonym (Prev);
6052
                     end loop;
6053
 
6054
                     if Present (Prev) then
6055
                        Set_Homonym (Prev, E);
6056
                     end if;
6057
                  end if;
6058
 
6059
                  --  Preserve structure of homonym chain
6060
 
6061
                  Set_Homonym (E, Homonym (Lim_Typ));
6062
               end if;
6063
            end if;
6064
 
6065
            Next_Entity (Lim_Typ);
6066
         end loop;
6067
      end if;
6068
 
6069
      --  Indicate that the limited view of the package is not installed
6070
 
6071
      Set_From_With_Type         (P, False);
6072
      Set_Limited_View_Installed (N, False);
6073
   end Remove_Limited_With_Clause;
6074
 
6075
   --------------------
6076
   -- Remove_Parents --
6077
   --------------------
6078
 
6079
   procedure Remove_Parents (Lib_Unit : Node_Id) is
6080
      P      : Node_Id;
6081
      P_Name : Entity_Id;
6082
      P_Spec : Node_Id := Empty;
6083
      E      : Entity_Id;
6084
      Vis    : constant Boolean :=
6085
                 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
6086
 
6087
   begin
6088
      if Is_Child_Spec (Lib_Unit) then
6089
         P_Spec := Parent_Spec (Lib_Unit);
6090
 
6091
      elsif Nkind (Lib_Unit) = N_Package_Body
6092
        and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
6093
      then
6094
         P_Spec := Parent_Spec (Original_Node (Lib_Unit));
6095
      end if;
6096
 
6097
      if Present (P_Spec) then
6098
         P := Unit (P_Spec);
6099
         P_Name := Get_Parent_Entity (P);
6100
         Remove_Context_Clauses (P_Spec);
6101
         End_Package_Scope (P_Name);
6102
         Set_Is_Immediately_Visible (P_Name, Vis);
6103
 
6104
         --  Remove from visibility the siblings as well, which are directly
6105
         --  visible while the parent is in scope.
6106
 
6107
         E := First_Entity (P_Name);
6108
         while Present (E) loop
6109
            if Is_Child_Unit (E) then
6110
               Set_Is_Immediately_Visible (E, False);
6111
            end if;
6112
 
6113
            Next_Entity (E);
6114
         end loop;
6115
 
6116
         Set_In_Package_Body (P_Name, False);
6117
 
6118
         --  This is the recursive call to remove the context of any higher
6119
         --  level parent. This recursion ensures that all parents are removed
6120
         --  in the reverse order of their installation.
6121
 
6122
         Remove_Parents (P);
6123
      end if;
6124
   end Remove_Parents;
6125
 
6126
   ---------------------------------
6127
   -- Remove_Private_With_Clauses --
6128
   ---------------------------------
6129
 
6130
   procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is
6131
      Item : Node_Id;
6132
 
6133
      function In_Regular_With_Clause (E : Entity_Id) return Boolean;
6134
      --  Check whether a given unit appears in a regular with_clause. Used to
6135
      --  determine whether a private_with_clause, implicit or explicit, should
6136
      --  be ignored.
6137
 
6138
      ----------------------------
6139
      -- In_Regular_With_Clause --
6140
      ----------------------------
6141
 
6142
      function In_Regular_With_Clause (E : Entity_Id) return Boolean
6143
      is
6144
         Item : Node_Id;
6145
 
6146
      begin
6147
         Item := First (Context_Items (Comp_Unit));
6148
         while Present (Item) loop
6149
            if Nkind (Item) = N_With_Clause
6150
              and then Entity (Name (Item)) = E
6151
              and then not Private_Present (Item)
6152
            then
6153
               return True;
6154
            end if;
6155
            Next (Item);
6156
         end loop;
6157
 
6158
         return False;
6159
      end In_Regular_With_Clause;
6160
 
6161
   --  Start of processing for Remove_Private_With_Clauses
6162
 
6163
   begin
6164
      Item := First (Context_Items (Comp_Unit));
6165
      while Present (Item) loop
6166
         if Nkind (Item) = N_With_Clause
6167
           and then Private_Present (Item)
6168
         then
6169
            --  If private_with_clause is redundant, remove it from context,
6170
            --  as a small optimization to subsequent handling of private_with
6171
            --  clauses in other nested packages.
6172
 
6173
            if In_Regular_With_Clause (Entity (Name (Item))) then
6174
               declare
6175
                  Nxt : constant Node_Id := Next (Item);
6176
               begin
6177
                  Remove (Item);
6178
                  Item := Nxt;
6179
               end;
6180
 
6181
            elsif Limited_Present (Item) then
6182
               if not Limited_View_Installed (Item) then
6183
                  Remove_Limited_With_Clause (Item);
6184
               end if;
6185
 
6186
               Next (Item);
6187
 
6188
            else
6189
               Remove_Unit_From_Visibility (Entity (Name (Item)));
6190
               Set_Context_Installed (Item, False);
6191
               Next (Item);
6192
            end if;
6193
 
6194
         else
6195
            Next (Item);
6196
         end if;
6197
      end loop;
6198
   end Remove_Private_With_Clauses;
6199
 
6200
   ---------------------------------
6201
   -- Remove_Unit_From_Visibility --
6202
   ---------------------------------
6203
 
6204
   procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
6205
      P : constant Entity_Id := Scope (Unit_Name);
6206
 
6207
   begin
6208
      if Debug_Flag_I then
6209
         Write_Str ("remove unit ");
6210
         Write_Name (Chars (Unit_Name));
6211
         Write_Str (" from visibility");
6212
         Write_Eol;
6213
      end if;
6214
 
6215
      if P /= Standard_Standard then
6216
         Set_Is_Visible_Child_Unit (Unit_Name, False);
6217
      end if;
6218
 
6219
      Set_Is_Potentially_Use_Visible (Unit_Name, False);
6220
      Set_Is_Immediately_Visible     (Unit_Name, False);
6221
   end Remove_Unit_From_Visibility;
6222
 
6223
   --------
6224
   -- sm --
6225
   --------
6226
 
6227
   procedure sm is
6228
   begin
6229
      null;
6230
   end sm;
6231
 
6232
   -------------
6233
   -- Unchain --
6234
   -------------
6235
 
6236
   procedure Unchain (E : Entity_Id) is
6237
      Prev : Entity_Id;
6238
 
6239
   begin
6240
      Prev := Current_Entity (E);
6241
 
6242
      if No (Prev) then
6243
         return;
6244
 
6245
      elsif Prev = E then
6246
         Set_Name_Entity_Id (Chars (E), Homonym (E));
6247
 
6248
      else
6249
         while Present (Prev)
6250
           and then Homonym (Prev) /= E
6251
         loop
6252
            Prev := Homonym (Prev);
6253
         end loop;
6254
 
6255
         if Present (Prev) then
6256
            Set_Homonym (Prev, Homonym (E));
6257
         end if;
6258
      end if;
6259
 
6260
      if Debug_Flag_I then
6261
         Write_Str ("   (homonym) unchain ");
6262
         Write_Name (Chars (E));
6263
         Write_Eol;
6264
      end if;
6265
   end Unchain;
6266
 
6267
end Sem_Ch10;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.