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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch10.adb] - Blame information for rev 847

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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