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