1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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;
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;
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;
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_Ch13; use Sem_Ch13;
58 with Sem_Dist; use Sem_Dist;
59 with Sem_Prag; use Sem_Prag;
60 with Sem_Util; use Sem_Util;
61 with Sem_Warn; use Sem_Warn;
62 with Stand; use Stand;
63 with Sinfo; use Sinfo;
64 with Sinfo.CN; use Sinfo.CN;
65 with Sinput; use Sinput;
66 with Snames; use Snames;
67 with Style; use Style;
68 with Stylesw; use Stylesw;
69 with Tbuild; use Tbuild;
70 with Uname; use Uname;
72 package body Sem_Ch10 is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 procedure Analyze_Context (N : Node_Id);
79 -- Analyzes items in the context clause of compilation unit
81 procedure Build_Limited_Views (N : Node_Id);
82 -- Build and decorate the list of shadow entities for a package mentioned
83 -- in a limited_with clause. If the package was not previously analyzed
84 -- then it also performs a basic decoration of the real entities. This is
85 -- required in order to avoid passing non-decorated entities to the
86 -- back-end. Implements Ada 2005 (AI-50217).
88 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
89 -- Common processing for all stubs (subprograms, tasks, packages, and
90 -- protected cases). N is the stub to be analyzed. Once the subunit name
91 -- is established, load and analyze. Nam is the non-overloadable entity
92 -- for which the proper body provides a completion. Subprogram stubs are
93 -- handled differently because they can be declarations.
95 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
96 -- Check whether the source for the body of a compilation unit must be
97 -- included in a standalone library.
99 procedure Check_No_Elab_Code_All (N : Node_Id);
100 -- Carries out possible tests for violation of No_Elab_Code all for withed
101 -- units in the Context_Items of unit N.
103 procedure Check_Private_Child_Unit (N : Node_Id);
104 -- If a with_clause mentions a private child unit, the compilation unit
105 -- must be a member of the same family, as described in 10.1.2.
107 procedure Check_Stub_Level (N : Node_Id);
108 -- Verify that a stub is declared immediately within a compilation unit,
109 -- and not in an inner frame.
111 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
112 -- When a child unit appears in a context clause, the implicit withs on
113 -- parents are made explicit, and with clauses are inserted in the context
114 -- clause before the one for the child. If a parent in the with_clause
115 -- is a renaming, the implicit with_clause is on the renaming whose name
116 -- is mentioned in the with_clause, and not on the package it renames.
117 -- N is the compilation unit whose list of context items receives the
118 -- implicit with_clauses.
120 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
121 -- Generate cross-reference information for the parents of child units
122 -- and of subunits. N is a defining_program_unit_name, and P_Id is the
123 -- immediate parent scope.
125 function Has_With_Clause
128 Is_Limited : Boolean := False) return Boolean;
129 -- Determine whether compilation unit C_Unit contains a [limited] with
130 -- clause for package Pack. Use the flag Is_Limited to designate desired
133 procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
134 -- If the main unit is a child unit, implicit withs are also added for
135 -- all its ancestors.
137 function In_Chain (E : Entity_Id) return Boolean;
138 -- Check that the shadow entity is not already in the homonym chain, for
139 -- example through a limited_with clause in a parent unit.
141 procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True);
142 -- Subsidiary to Install_Context and Install_Parents. Process all with
143 -- and use clauses for current unit and its library unit if any. The flag
144 -- Chain is used to control the "chaining" or linking together of use-type
145 -- and use-package clauses to avoid circularities with reinstalling
148 procedure Install_Limited_Context_Clauses (N : Node_Id);
149 -- Subsidiary to Install_Context. Process only limited with_clauses for
150 -- current unit. Implements Ada 2005 (AI-50217).
152 procedure Install_Limited_With_Clause (N : Node_Id);
153 -- Place shadow entities for a limited_with package in the visibility
154 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
156 procedure Install_Parents
158 Is_Private : Boolean;
159 Chain : Boolean := True);
160 -- This procedure establishes the context for the compilation of a child
161 -- unit. If Lib_Unit is a child library spec then the context of the parent
162 -- is installed, and the parent itself made immediately visible, so that
163 -- the child unit is processed in the declarative region of the parent.
164 -- Install_Parents makes a recursive call to itself to ensure that all
165 -- parents are loaded in the nested case. If Lib_Unit is a library body,
166 -- the only effect of Install_Parents is to install the private decls of
167 -- the parents, because the visible parent declarations will have been
168 -- installed as part of the context of the corresponding spec. The flag
169 -- Chain is used to control the "chaining" or linking of use-type and
170 -- use-package clauses to avoid circularities when installing context.
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.
178 procedure Install_With_Clause
179 (With_Clause : Node_Id;
180 Private_With_OK : Boolean := False);
181 -- If the unit is not a child unit, make unit immediately visible. The
182 -- caller ensures that the unit is not already currently installed. The
183 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
184 -- is called when compiling the private part of a package, or installing
185 -- the private declarations of a parent unit.
187 function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
188 -- When compiling a unit Q descended from some parent unit P, a limited
189 -- with_clause in the context of P that names some other ancestor of Q
190 -- must not be installed because the ancestor is immediately visible.
192 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
193 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
194 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
195 -- a library spec that has a parent. If the call to Is_Child_Spec returns
196 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
197 -- compilation unit for the parent spec.
199 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
200 -- Parent_Spec is non-empty, this is also a child unit.
202 procedure Remove_Context_Clauses (N : Node_Id);
203 -- Subsidiary of previous one. Remove use_ and with_clauses
205 procedure Remove_Limited_With_Clause (N : Node_Id);
206 -- Remove the shadow entities from visibility introduced for a package
207 -- mentioned in limited with clause N. Implements Ada 2005 (AI-50217).
209 procedure Remove_Limited_With_Unit
210 (Pack_Decl : Node_Id;
211 Lim_Clause : Node_Id := Empty);
212 -- Remove the shadow entities from visibility introduced for a package
213 -- denoted by declaration Pack_Decl. Lim_Clause is the related limited
214 -- with clause, if any. Implements Ada 2005 (AI-50217).
216 procedure Remove_Parents (Lib_Unit : Node_Id);
217 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
218 -- contexts established by the corresponding call to Install_Parents are
219 -- removed. Remove_Parents contains a recursive call to itself to ensure
220 -- that all parents are removed in the nested case.
222 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
223 -- Reset all visibility flags on unit after compiling it, either as a main
224 -- unit or as a unit in the context.
226 procedure Unchain (E : Entity_Id);
227 -- Remove single entity from visibility list
230 -- A dummy procedure, for debugging use, called just before analyzing the
231 -- main unit (after dealing with any context clauses).
233 --------------------------
234 -- Limited_With_Clauses --
235 --------------------------
237 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
238 -- mutually recursive types declared in different units. A limited_with
239 -- clause that names package P in the context of unit U makes the types
240 -- declared in the visible part of P available within U, but with the
241 -- restriction that these types can only be used as incomplete types.
242 -- The limited_with clause does not impose a semantic dependence on P,
243 -- and it is possible for two packages to have limited_with_clauses on
244 -- each other without creating an elaboration circularity.
246 -- To support this feature, the analysis of a limited_with clause must
247 -- create an abbreviated view of the package, without performing any
248 -- semantic analysis on it. This "package abstract" contains shadow types
249 -- that are in one-one correspondence with the real types in the package,
250 -- and that have the properties of incomplete types.
252 -- The implementation creates two element lists: one to chain the shadow
253 -- entities, and one to chain the corresponding type entities in the tree
254 -- of the package. Links between corresponding entities in both chains
255 -- allow the compiler to select the proper view of a given type, depending
256 -- on the context. Note that in contrast with the handling of private
257 -- types, the limited view and the nonlimited view of a type are treated
258 -- as separate entities, and no entity exchange needs to take place, which
259 -- makes the implementation much simpler than could be feared.
261 ------------------------------
262 -- Analyze_Compilation_Unit --
263 ------------------------------
265 procedure Analyze_Compilation_Unit (N : Node_Id) is
266 procedure Check_Redundant_Withs
267 (Context_Items : List_Id;
268 Spec_Context_Items : List_Id := No_List);
269 -- Determine whether the context list of a compilation unit contains
270 -- redundant with clauses. When checking body clauses against spec
271 -- clauses, set Context_Items to the context list of the body and
272 -- Spec_Context_Items to that of the spec. Parent packages are not
273 -- examined for documentation purposes.
275 ---------------------------
276 -- Check_Redundant_Withs --
277 ---------------------------
279 procedure Check_Redundant_Withs
280 (Context_Items : List_Id;
281 Spec_Context_Items : List_Id := No_List)
285 procedure Process_Body_Clauses
286 (Context_List : List_Id;
289 Used_Type_Or_Elab : out Boolean);
290 -- Examine the context clauses of a package body, trying to match the
291 -- name entity of Clause with any list element. If the match occurs
292 -- on a use package clause set Used to True, for a use type clause or
293 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
295 procedure Process_Spec_Clauses
296 (Context_List : List_Id;
299 Withed : out Boolean;
300 Exit_On_Self : Boolean := False);
301 -- Examine the context clauses of a package spec, trying to match
302 -- the name entity of Clause with any list element. If the match
303 -- occurs on a use package clause, set Used to True, for a with
304 -- package clause other than Clause, set Withed to True. Limited
305 -- with clauses, implicitly generated with clauses and withs
306 -- having pragmas Elaborate or Elaborate_All applied to them are
307 -- skipped. Exit_On_Self is used to control the search loop and
308 -- force an exit whenever Clause sees itself in the search.
310 --------------------------
311 -- Process_Body_Clauses --
312 --------------------------
314 procedure Process_Body_Clauses
315 (Context_List : List_Id;
318 Used_Type_Or_Elab : out Boolean)
320 Nam_Ent : constant Entity_Id := Entity (Name (Clause));
326 function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
327 -- In an expanded name in a use clause, if the prefix is a renamed
328 -- package, the entity is set to the original package as a result,
329 -- when checking whether the package appears in a previous with
330 -- clause, the renaming has to be taken into account, to prevent
331 -- spurious/incorrect warnings. A common case is use of Text_IO.
337 function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is
339 return Entity (N) = P
340 or else (Present (Renamed_Object (P))
341 and then Entity (N) = Renamed_Object (P));
344 -- Start of processing for Process_Body_Clauses
348 Used_Type_Or_Elab := False;
350 Cont_Item := First (Context_List);
351 while Present (Cont_Item) loop
353 -- Package use clause
355 if Nkind (Cont_Item) = N_Use_Package_Clause
358 -- Search through use clauses
360 Use_Item := Name (Cont_Item);
362 -- Case of a direct use of the one we are looking for
364 if Entity (Use_Item) = Nam_Ent then
367 -- Handle nested case, as in "with P; use P.Q.R"
374 -- Loop through prefixes looking for match
377 while Nkind (UE) = N_Expanded_Name loop
378 if Same_Unit (Prefix (UE), Nam_Ent) then
390 elsif Nkind (Cont_Item) = N_Use_Type_Clause
391 and then not Used_Type_Or_Elab
393 Subt_Mark := Subtype_Mark (Cont_Item);
394 if not Used_Type_Or_Elab
395 and then Same_Unit (Prefix (Subt_Mark), Nam_Ent)
397 Used_Type_Or_Elab := True;
400 -- Pragma Elaborate or Elaborate_All
402 elsif Nkind (Cont_Item) = N_Pragma
404 Nam_In (Pragma_Name_Unmapped (Cont_Item),
405 Name_Elaborate, Name_Elaborate_All)
406 and then not Used_Type_Or_Elab
409 First (Pragma_Argument_Associations (Cont_Item));
410 while Present (Prag_Unit) and then not Used_Type_Or_Elab loop
411 if Entity (Expression (Prag_Unit)) = Nam_Ent then
412 Used_Type_Or_Elab := True;
421 end Process_Body_Clauses;
423 --------------------------
424 -- Process_Spec_Clauses --
425 --------------------------
427 procedure Process_Spec_Clauses
428 (Context_List : List_Id;
431 Withed : out Boolean;
432 Exit_On_Self : Boolean := False)
434 Nam_Ent : constant Entity_Id := Entity (Name (Clause));
441 Cont_Item := First (Context_List);
442 while Present (Cont_Item) loop
444 -- Stop the search since the context items after Cont_Item have
445 -- already been examined in a previous iteration of the reverse
446 -- loop in Check_Redundant_Withs.
449 and Cont_Item = Clause
454 -- Package use clause
456 if Nkind (Cont_Item) = N_Use_Package_Clause
459 if Entity (Name (Cont_Item)) = Nam_Ent then
463 -- Package with clause. Avoid processing self, implicitly
464 -- generated with clauses or limited with clauses. Note that
465 -- we examine with clauses having pragmas Elaborate or
466 -- Elaborate_All applied to them due to cases such as:
470 -- pragma Elaborate (Pack);
472 -- In this case, the second with clause is redundant since
473 -- the pragma applies only to the first "with Pack;".
475 -- Note that we only consider with_clauses that comes from
476 -- source. In the case of renamings used as prefixes of names
477 -- in with_clauses, we generate a with_clause for the prefix,
478 -- which we do not treat as implicit because it is needed for
479 -- visibility analysis, but is also not redundant.
481 elsif Nkind (Cont_Item) = N_With_Clause
482 and then Comes_From_Source (Cont_Item)
483 and then not Implicit_With (Cont_Item)
484 and then not Limited_Present (Cont_Item)
485 and then Cont_Item /= Clause
486 and then Entity (Name (Cont_Item)) = Nam_Ent
493 end Process_Spec_Clauses;
495 -- Start of processing for Check_Redundant_Withs
498 Clause := Last (Context_Items);
499 while Present (Clause) loop
501 -- Avoid checking implicitly generated with clauses, limited with
502 -- clauses or withs that have pragma Elaborate or Elaborate_All.
504 if Nkind (Clause) = N_With_Clause
505 and then not Implicit_With (Clause)
506 and then not Limited_Present (Clause)
507 and then not Elaborate_Present (Clause)
509 -- With_clauses introduced for renamings of parent clauses
510 -- are not marked implicit because they need to be properly
511 -- installed, but they do not come from source and do not
514 and then Comes_From_Source (Clause)
516 -- Package body-to-spec check
518 if Present (Spec_Context_Items) then
520 Used_In_Body : Boolean;
521 Used_In_Spec : Boolean;
522 Used_Type_Or_Elab : Boolean;
523 Withed_In_Spec : Boolean;
527 (Context_List => Spec_Context_Items,
529 Used => Used_In_Spec,
530 Withed => Withed_In_Spec);
533 (Context_List => Context_Items,
535 Used => Used_In_Body,
536 Used_Type_Or_Elab => Used_Type_Or_Elab);
538 -- "Type Elab" refers to the presence of either a use
539 -- type clause, pragmas Elaborate or Elaborate_All.
541 -- +---------------+---------------------------+------+
542 -- | Spec | Body | Warn |
543 -- +--------+------+--------+------+-----------+------+
544 -- | Withed | Used | Withed | Used | Type Elab | |
545 -- | X | | X | | | X |
546 -- | X | | X | X | | |
547 -- | X | | X | | X | |
548 -- | X | | X | X | X | |
549 -- | X | X | X | | | X |
550 -- | X | X | X | | X | |
551 -- | X | X | X | X | | X |
552 -- | X | X | X | X | X | |
553 -- +--------+------+--------+------+-----------+------+
556 and then not Used_Type_Or_Elab)
558 ((not Used_In_Spec and then not Used_In_Body)
559 or else Used_In_Spec)
561 Error_Msg_N -- CODEFIX
562 ("redundant with clause in body?r?", Clause);
565 Used_In_Body := False;
566 Used_In_Spec := False;
567 Used_Type_Or_Elab := False;
568 Withed_In_Spec := False;
571 -- Standalone package spec or body check
575 Dummy : Boolean := False;
576 Withed : Boolean := False;
579 -- The mechanism for examining the context clauses of a
580 -- package spec can be applied to package body clauses.
583 (Context_List => Context_Items,
587 Exit_On_Self => True);
590 Error_Msg_N -- CODEFIX
591 ("redundant with clause?r?", Clause);
599 end Check_Redundant_Withs;
603 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
604 Unit_Node : constant Node_Id := Unit (N);
605 Lib_Unit : Node_Id := Library_Unit (N);
606 Par_Spec_Name : Unit_Name_Type;
608 Unum : Unit_Number_Type;
610 -- Start of processing for Analyze_Compilation_Unit
613 Process_Compilation_Unit_Pragmas (N);
615 -- If the unit is a subunit whose parent has not been analyzed (which
616 -- indicates that the main unit is a subunit, either the current one or
617 -- one of its descendants) then the subunit is compiled as part of the
618 -- analysis of the parent, which we proceed to do. Basically this gets
619 -- handled from the top down and we don't want to do anything at this
620 -- level (i.e. this subunit will be handled on the way down from the
621 -- parent), so at this level we immediately return. If the subunit ends
622 -- up not analyzed, it means that the parent did not contain a stub for
623 -- it, or that there errors were detected in some ancestor.
625 if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) then
626 Semantics (Lib_Unit);
628 if not Analyzed (Proper_Body (Unit_Node)) then
629 if Serious_Errors_Detected > 0 then
630 Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
632 Error_Msg_N ("missing stub for subunit", N);
639 -- Analyze context (this will call Sem recursively for with'ed units) To
640 -- detect circularities among with-clauses that are not caught during
641 -- loading, we set the Context_Pending flag on the current unit. If the
642 -- flag is already set there is a potential circularity. We exclude
643 -- predefined units from this check because they are known to be safe.
644 -- We also exclude package bodies that are present because circularities
645 -- between bodies are harmless (and necessary).
647 if Context_Pending (N) then
649 Circularity : Boolean := True;
652 if In_Predefined_Unit (N) then
653 Circularity := False;
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))
660 Circularity := False;
667 Error_Msg_N ("circular dependency caused by with_clauses", N);
669 ("\possibly missing limited_with clause"
670 & " in one of the following", N);
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);
679 raise Unrecoverable_Error;
683 Set_Context_Pending (N);
688 Set_Context_Pending (N, False);
690 -- If the unit is a package body, the spec is already loaded and must be
691 -- analyzed first, before we analyze the body.
693 if Nkind (Unit_Node) = N_Package_Body then
695 -- If no Lib_Unit, then there was a serious previous error, so just
696 -- ignore the entire analysis effort.
698 if No (Lib_Unit) then
699 Check_Error_Detected;
703 -- Analyze the package spec
705 Semantics (Lib_Unit);
707 -- Check for unused with's
709 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
711 -- Verify that the library unit is a package declaration
713 if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration,
714 N_Generic_Package_Declaration)
717 ("no legal package declaration for package body", N);
720 -- Otherwise, the entity in the declaration is visible. Update the
721 -- version to reflect dependence of this body on the spec.
724 Spec_Id := Defining_Entity (Unit (Lib_Unit));
725 Set_Is_Immediately_Visible (Spec_Id, True);
726 Version_Update (N, Lib_Unit);
728 if Nkind (Defining_Unit_Name (Unit_Node)) =
729 N_Defining_Program_Unit_Name
731 Generate_Parent_References (Unit_Node, Scope (Spec_Id));
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.
742 elsif Nkind (Unit_Node) = N_Subprogram_Body then
743 if Acts_As_Spec (N) then
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.
754 Unum := Get_Cunit_Unit_Number (N);
755 Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
757 if Par_Spec_Name /= No_Unit_Name then
760 (Load_Name => Par_Spec_Name,
765 if Unum /= No_Unit then
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.
779 Loc : constant Source_Ptr := Sloc (N);
780 SCS : constant Boolean :=
781 Get_Comes_From_Source_Default;
784 Set_Comes_From_Source_Default (False);
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
797 Make_Compilation_Unit (Loc,
798 Context_Items => Context_Items (N),
800 Make_Subprogram_Declaration (Sloc (N),
803 (Specification (Unit_Node))),
805 Make_Compilation_Unit_Aux (Loc));
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);
813 -- Now that a separate declaration exists, the body
814 -- of the child unit does not act as spec any longer.
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);
821 -- Restore Context_Items to the body
823 Set_Context_Items (N, Context_Items (Lib_Unit));
824 Set_Context_Items (Lib_Unit, Empty_List);
829 -- Here for subprogram with separate declaration
832 Semantics (Lib_Unit);
833 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
834 Version_Update (N, Lib_Unit);
837 -- If this is a child unit, generate references to the parents
839 if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
840 N_Defining_Program_Unit_Name
842 Generate_Parent_References
843 (Specification (Unit_Node),
844 Scope (Defining_Entity (Unit (Lib_Unit))));
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.
851 if Is_Child_Spec (Unit_Node) then
853 -- The analysis of the parent is done with style checks off
856 Save_Style_Check : constant Boolean := Style_Check;
859 if not GNAT_Mode then
860 Style_Check := False;
863 Semantics (Parent_Spec (Unit_Node));
864 Version_Update (N, Parent_Spec (Unit_Node));
866 -- Restore style check settings
868 Style_Check := Save_Style_Check;
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.
879 if Is_Child_Spec (Unit_Node) then
881 -- Set the entities of all parents in the program_unit_name
883 Generate_Parent_References
884 (Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
887 -- All components of the context: with-clauses, library unit, ancestors
888 -- if any, (and their context) are analyzed and installed.
890 -- Call special debug routine sm if this is the main unit
892 if Current_Sem_Unit = Main_Unit then
896 -- Now analyze the unit (package, subprogram spec, body) itself
900 if Warn_On_Redundant_Constructs then
901 Check_Redundant_Withs (Context_Items (N));
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));
910 -- The above call might have made Unit_Node an N_Subprogram_Body from
911 -- something else, so propagate any Acts_As_Spec flag.
913 if Nkind (Unit_Node) = N_Subprogram_Body
914 and then Acts_As_Spec (Unit_Node)
916 Set_Acts_As_Spec (N);
919 -- Register predefined units in Rtsfind
921 if In_Predefined_Unit (N) then
922 Set_RTU_Loaded (Unit_Node);
925 -- Treat compilation unit pragmas that appear after the library unit
927 if Present (Pragmas_After (Aux_Decls_Node (N))) then
929 Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
931 while Present (Prag_Node) loop
938 -- Analyze the contract of a [generic] subprogram that acts as a
939 -- compilation unit after all compilation pragmas have been analyzed.
941 if Nkind_In (Unit_Node, N_Generic_Subprogram_Declaration,
942 N_Subprogram_Declaration)
944 Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node));
947 -- Generate distribution stubs if requested and no error
950 and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
952 Distribution_Stub_Mode = Generate_Caller_Stub_Body)
953 and then Fatal_Error (Main_Unit) /= Error_Detected
955 if Is_RCI_Pkg_Spec_Or_Body (N) then
957 -- Regular RCI package
959 Add_Stub_Constructs (N);
961 elsif (Nkind (Unit_Node) = N_Package_Declaration
962 and then Is_Shared_Passive (Defining_Entity
963 (Specification (Unit_Node))))
964 or else (Nkind (Unit_Node) = N_Package_Body
966 Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
968 -- Shared passive package
970 Add_Stub_Constructs (N);
972 elsif Nkind (Unit_Node) = N_Package_Instantiation
974 Is_Remote_Call_Interface
975 (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
977 -- Instantiation of a RCI generic package
979 Add_Stub_Constructs (N);
983 -- Remove unit from visibility, so that environment is clean for the
984 -- next compilation, which is either the main unit or some other unit
987 if Nkind_In (Unit_Node, N_Package_Declaration,
988 N_Package_Renaming_Declaration,
989 N_Subprogram_Declaration)
990 or else Nkind (Unit_Node) in N_Generic_Declaration
991 or else (Nkind (Unit_Node) = N_Subprogram_Body
992 and then Acts_As_Spec (Unit_Node))
994 Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
996 -- If the unit is an instantiation whose body will be elaborated for
997 -- inlining purposes, use the proper entity of the instance. The entity
998 -- may be missing if the instantiation was illegal.
1000 elsif Nkind (Unit_Node) = N_Package_Instantiation
1001 and then not Error_Posted (Unit_Node)
1002 and then Present (Instance_Spec (Unit_Node))
1004 Remove_Unit_From_Visibility
1005 (Defining_Entity (Instance_Spec (Unit_Node)));
1007 elsif Nkind (Unit_Node) = N_Package_Body
1008 or else (Nkind (Unit_Node) = N_Subprogram_Body
1009 and then not Acts_As_Spec (Unit_Node))
1011 -- Bodies that are not the main unit are compiled if they are generic
1012 -- or contain generic or inlined units. Their analysis brings in the
1013 -- context of the corresponding spec (unit declaration) which must be
1014 -- removed as well, to return the compilation environment to its
1017 Remove_Context (Lib_Unit);
1018 Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
1021 -- Last step is to deinstall the context we just installed as well as
1022 -- the unit just compiled.
1026 -- When generating code for a non-generic main unit, check that withed
1027 -- generic units have a body if they need it, even if the units have not
1028 -- been instantiated. Force the load of the bodies to produce the proper
1029 -- error if the body is absent. The same applies to GNATprove mode, with
1030 -- the added benefit of capturing global references within the generic.
1031 -- This in turn allows for proper inlining of subprogram bodies without
1032 -- a previous declaration.
1034 if Get_Cunit_Unit_Number (N) = Main_Unit
1035 and then ((Operating_Mode = Generate_Code and then Expander_Active)
1037 (Operating_Mode = Check_Semantics and then GNATprove_Mode))
1039 -- Check whether the source for the body of the unit must be included
1040 -- in a standalone library.
1042 Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
1044 -- Indicate that the main unit is now analyzed, to catch possible
1045 -- circularities between it and generic bodies. Remove main unit from
1046 -- visibility. This might seem superfluous, but the main unit must
1047 -- not be visible in the generic body expansions that follow.
1049 Set_Analyzed (N, True);
1050 Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
1055 Un : Unit_Number_Type;
1057 Save_Style_Check : constant Boolean := Style_Check;
1060 Item := First (Context_Items (N));
1061 while Present (Item) loop
1063 -- Check for explicit with clause
1065 if Nkind (Item) = N_With_Clause
1066 and then not Implicit_With (Item)
1068 -- Ada 2005 (AI-50217): Ignore limited-withed units
1070 and then not Limited_Present (Item)
1072 Nam := Entity (Name (Item));
1074 -- Compile the generic subprogram, unless it is intrinsic or
1075 -- imported so no body is required, or generic package body
1076 -- if the package spec requires a body.
1078 if (Is_Generic_Subprogram (Nam)
1079 and then not Is_Intrinsic_Subprogram (Nam)
1080 and then not Is_Imported (Nam))
1081 or else (Ekind (Nam) = E_Generic_Package
1082 and then Unit_Requires_Body (Nam))
1084 Style_Check := False;
1086 if Present (Renamed_Object (Nam)) then
1092 (Unit_Declaration_Node
1093 (Renamed_Object (Nam)))),
1102 Get_Body_Name (Get_Unit_Name (Item)),
1109 if Un = No_Unit then
1111 ("body of generic unit& not found", Item, Nam);
1114 elsif not Analyzed (Cunit (Un))
1115 and then Un /= Main_Unit
1116 and then Fatal_Error (Un) /= Error_Detected
1118 Style_Check := False;
1119 Semantics (Cunit (Un));
1127 -- Restore style checks settings
1129 Style_Check := Save_Style_Check;
1132 -- In GNATprove mode, force the loading of an Interrupt_Priority when
1133 -- processing compilation units with potentially "main" subprograms.
1134 -- This is required for the ceiling priority protocol checks, which
1135 -- are triggered by these subprograms.
1138 and then Nkind_In (Unit_Node, N_Function_Instantiation,
1139 N_Procedure_Instantiation,
1146 case Nkind (Unit_Node) is
1147 when N_Subprogram_Body =>
1148 Spec := Specification (Unit_Node);
1150 when N_Subprogram_Instantiation =>
1152 Subprogram_Specification (Entity (Name (Unit_Node)));
1155 raise Program_Error;
1158 pragma Assert (Nkind (Spec) in N_Subprogram_Specification);
1160 -- Main subprogram must have no parameters, and if it is a
1161 -- function, it must return an integer.
1163 if No (Parameter_Specifications (Spec))
1164 and then (Nkind (Spec) = N_Procedure_Specification
1166 Is_Integer_Type (Etype (Result_Definition (Spec))))
1168 SPARK_Implicit_Load (RE_Interrupt_Priority);
1174 -- Deal with creating elaboration counter if needed. We create an
1175 -- elaboration counter only for units that come from source since
1176 -- units manufactured by the compiler never need elab checks.
1178 if Comes_From_Source (N)
1179 and then Nkind_In (Unit_Node, N_Package_Declaration,
1180 N_Generic_Package_Declaration,
1181 N_Subprogram_Declaration,
1182 N_Generic_Subprogram_Declaration)
1185 Loc : constant Source_Ptr := Sloc (N);
1186 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
1189 Spec_Id := Defining_Entity (Unit_Node);
1190 Generate_Definition (Spec_Id);
1192 -- See if an elaboration entity is required for possible access
1193 -- before elaboration checking. Note that we must allow for this
1194 -- even if -gnatE is not set, since a client may be compiled in
1195 -- -gnatE mode and reference the entity.
1197 -- These entities are also used by the binder to prevent multiple
1198 -- attempts to execute the elaboration code for the library case
1199 -- where the elaboration routine might otherwise be called more
1202 -- They are also needed to ensure explicit visibility from the
1203 -- binder generated code of all the units involved in a partition
1204 -- when control-flow preservation is requested.
1206 if not Opt.Suppress_Control_Flow_Optimizations
1208 ( -- Pure units do not need checks
1212 -- Preelaborated units do not need checks
1214 or else Is_Preelaborated (Spec_Id)
1216 -- No checks needed if pragma Elaborate_Body present
1218 or else Has_Pragma_Elaborate_Body (Spec_Id)
1220 -- No checks needed if unit does not require a body
1222 or else not Unit_Requires_Body (Spec_Id)
1224 -- No checks needed for predefined files
1226 or else Is_Predefined_Unit (Unum)
1228 -- No checks required if no separate spec
1230 or else Acts_As_Spec (N)
1233 -- This is a case where we only need the entity for checking to
1234 -- prevent multiple elaboration checks.
1236 Set_Elaboration_Entity_Required (Spec_Id, False);
1238 -- Otherwise the unit requires an elaboration entity because it
1242 Set_Elaboration_Entity_Required (Spec_Id);
1245 Build_Elaboration_Entity (N, Spec_Id);
1249 -- Freeze the compilation unit entity. This for sure is needed because
1250 -- of some warnings that can be output (see Freeze_Subprogram), but may
1251 -- in general be required. If freezing actions result, place them in the
1252 -- compilation unit actions list, and analyze them.
1255 L : constant List_Id :=
1256 Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N);
1258 while Is_Non_Empty_List (L) loop
1259 Insert_Library_Level_Action (Remove_Head (L));
1265 -- Call Check_Package_Body so that a body containing subprograms with
1266 -- Inline_Always can be made available for front end inlining.
1268 if Nkind (Unit_Node) = N_Package_Declaration
1269 and then Get_Cunit_Unit_Number (N) /= Main_Unit
1271 -- We don't need to do this if the Expander is not active, since there
1272 -- is no code to inline.
1274 and then Expander_Active
1277 Save_Style_Check : constant Boolean := Style_Check;
1278 Save_Warning : constant Warning_Mode_Type := Warning_Mode;
1279 Options : Style_Check_Options;
1282 Save_Style_Check_Options (Options);
1283 Reset_Style_Check_Options;
1284 Opt.Warning_Mode := Suppress;
1286 Check_Package_Body_For_Inlining (N, Defining_Entity (Unit_Node));
1288 Reset_Style_Check_Options;
1289 Set_Style_Check_Options (Options);
1290 Style_Check := Save_Style_Check;
1291 Warning_Mode := Save_Warning;
1295 -- If we are generating obsolescent warnings, then here is where we
1296 -- generate them for the with'ed items. The reason for this special
1297 -- processing is that the normal mechanism of generating the warnings
1298 -- for referenced entities does not work for context clause references.
1299 -- That's because when we first analyze the context, it is too early to
1300 -- know if the with'ing unit is itself obsolescent (which suppresses
1304 and then Warn_On_Obsolescent_Feature
1305 and then Nkind (Unit_Node) not in N_Generic_Instantiation
1307 -- Push current compilation unit as scope, so that the test for
1308 -- being within an obsolescent unit will work correctly. The check
1309 -- is not performed within an instantiation, because the warning
1310 -- will have been emitted in the corresponding generic unit.
1312 Push_Scope (Defining_Entity (Unit_Node));
1314 -- Loop through context items to deal with with clauses
1322 Item := First (Context_Items (N));
1323 while Present (Item) loop
1324 if Nkind (Item) = N_With_Clause
1326 -- Suppress this check in limited-withed units. Further work
1327 -- needed here if we decide to incorporate this check on
1328 -- limited-withed units.
1330 and then not Limited_Present (Item)
1333 Ent := Entity (Nam);
1335 if Is_Obsolescent (Ent) then
1336 Output_Obsolescent_Entity_Warnings (Nam, Ent);
1344 -- Remove temporary install of current unit as scope
1349 -- If No_Elaboration_Code_All was encountered, this is where we do the
1350 -- transitive test of with'ed units to make sure they have the aspect.
1351 -- This is delayed till the end of analyzing the compilation unit to
1352 -- ensure that the pragma/aspect, if present, has been analyzed.
1354 Check_No_Elab_Code_All (N);
1355 end Analyze_Compilation_Unit;
1357 ---------------------
1358 -- Analyze_Context --
1359 ---------------------
1361 procedure Analyze_Context (N : Node_Id) is
1362 Ukind : constant Node_Kind := Nkind (Unit (N));
1366 -- First process all configuration pragmas at the start of the context
1367 -- items. Strictly these are not part of the context clause, but that
1368 -- is where the parser puts them. In any case for sure we must analyze
1369 -- these before analyzing the actual context items, since they can have
1370 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1371 -- be with'ed as a result of changing categorizations in Ada 2005).
1373 Item := First (Context_Items (N));
1374 while Present (Item)
1375 and then Nkind (Item) = N_Pragma
1376 and then Pragma_Name (Item) in Configuration_Pragma_Names
1382 -- This is the point at which we capture the configuration settings
1383 -- for the unit. At the moment only the Optimize_Alignment setting
1384 -- needs to be captured. Probably more later ???
1386 if Optimize_Alignment_Local then
1387 Set_OA_Setting (Current_Sem_Unit, 'L');
1389 Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment);
1392 -- Loop through actual context items. This is done in two passes:
1394 -- a) The first pass analyzes nonlimited with clauses and also any
1395 -- configuration pragmas (we need to get the latter analyzed right
1396 -- away, since they can affect processing of subsequent items).
1398 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1400 while Present (Item) loop
1402 -- For with clause, analyze the with clause, and then update the
1403 -- version, since we are dependent on a unit that we with.
1405 if Nkind (Item) = N_With_Clause
1406 and then not Limited_Present (Item)
1408 -- Skip analyzing with clause if no unit, nothing to do (this
1409 -- happens for a with that references a non-existent unit).
1411 if Present (Library_Unit (Item)) then
1413 -- Skip analyzing with clause if this is a with_clause for
1414 -- the main unit, which happens if a subunit has a useless
1415 -- with_clause on its parent.
1417 if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then
1420 -- Here for the case of a useless with for the main unit
1423 Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit));
1427 -- Do version update (skipped for implicit with)
1429 if not Implicit_With (Item) then
1430 Version_Update (N, Library_Unit (Item));
1433 -- Skip pragmas. Configuration pragmas at the start were handled in
1434 -- the loop above, and remaining pragmas are not processed until we
1435 -- actually install the context (see Install_Context). We delay the
1436 -- analysis of these pragmas to make sure that we have installed all
1437 -- the implicit with's on parent units.
1439 -- Skip use clauses at this stage, since we don't want to do any
1440 -- installing of potentially use-visible entities until we
1441 -- actually install the complete context (in Install_Context).
1442 -- Otherwise things can get installed in the wrong context.
1451 -- Second pass: examine all limited_with clauses. All other context
1452 -- items are ignored in this pass.
1454 Item := First (Context_Items (N));
1455 while Present (Item) loop
1456 if Nkind (Item) = N_With_Clause
1457 and then Limited_Present (Item)
1459 -- No need to check errors on implicitly generated limited-with
1462 if not Implicit_With (Item) then
1464 -- Verify that the illegal contexts given in 10.1.2 (18/2) are
1465 -- properly rejected, including renaming declarations.
1467 if not Nkind_In (Ukind, N_Package_Declaration,
1468 N_Subprogram_Declaration)
1469 and then Ukind not in N_Generic_Declaration
1470 and then Ukind not in N_Generic_Instantiation
1472 Error_Msg_N ("limited with_clause not allowed here", Item);
1474 -- Check wrong use of a limited with clause applied to the
1475 -- compilation unit containing the limited-with clause.
1477 -- limited with P.Q;
1478 -- package P.Q is ...
1480 elsif Unit (Library_Unit (Item)) = Unit (N) then
1481 Error_Msg_N ("wrong use of limited-with clause", Item);
1483 -- Check wrong use of limited-with clause applied to some
1484 -- immediate ancestor.
1486 elsif Is_Child_Spec (Unit (N)) then
1488 Lib_U : constant Entity_Id := Unit (Library_Unit (Item));
1492 P := Parent_Spec (Unit (N));
1494 if Unit (P) = Lib_U then
1496 ("limited with_clause cannot name ancestor",
1501 exit when not Is_Child_Spec (Unit (P));
1502 P := Parent_Spec (Unit (P));
1507 -- Check if the limited-withed unit is already visible through
1508 -- some context clause of the current compilation unit or some
1509 -- ancestor of the current compilation unit.
1512 Lim_Unit_Name : constant Node_Id := Name (Item);
1513 Comp_Unit : Node_Id;
1515 Unit_Name : Node_Id;
1520 It := First (Context_Items (Comp_Unit));
1521 while Present (It) loop
1523 and then Nkind (It) = N_With_Clause
1524 and then not Limited_Present (It)
1526 Nkind_In (Unit (Library_Unit (It)),
1527 N_Package_Declaration,
1528 N_Package_Renaming_Declaration)
1530 if Nkind (Unit (Library_Unit (It))) =
1531 N_Package_Declaration
1533 Unit_Name := Name (It);
1535 Unit_Name := Name (Unit (Library_Unit (It)));
1538 -- Check if the named package (or some ancestor)
1539 -- leaves visible the full-view of the unit given
1540 -- in the limited-with clause.
1543 if Designate_Same_Unit (Lim_Unit_Name,
1546 Error_Msg_Sloc := Sloc (It);
1548 ("simultaneous visibility of limited and "
1549 & "unlimited views not allowed", Item);
1551 ("\unlimited view visible through context "
1552 & "clause #", Item, It);
1555 elsif Nkind (Unit_Name) = N_Identifier then
1559 Unit_Name := Prefix (Unit_Name);
1566 exit when not Is_Child_Spec (Unit (Comp_Unit));
1568 Comp_Unit := Parent_Spec (Unit (Comp_Unit));
1573 -- Skip analyzing with clause if no unit, see above
1575 if Present (Library_Unit (Item)) then
1579 -- A limited_with does not impose an elaboration order, but there
1580 -- is a semantic dependency for recompilation purposes.
1582 if not Implicit_With (Item) then
1583 Version_Update (N, Library_Unit (Item));
1586 -- Pragmas and use clauses and with clauses other than limited with's
1587 -- are ignored in this pass through the context items.
1595 end Analyze_Context;
1597 -------------------------------
1598 -- Analyze_Package_Body_Stub --
1599 -------------------------------
1601 procedure Analyze_Package_Body_Stub (N : Node_Id) is
1602 Id : constant Entity_Id := Defining_Entity (N);
1604 Opts : Config_Switches_Type;
1607 -- The package declaration must be in the current declarative part
1609 Check_Stub_Level (N);
1610 Nam := Current_Entity_In_Scope (Id);
1612 if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then
1613 Error_Msg_N ("missing specification for package stub", N);
1615 elsif Has_Completion (Nam)
1616 and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
1618 Error_Msg_N ("duplicate or redundant stub for package", N);
1621 -- Retain and restore the configuration options of the enclosing
1622 -- context as the proper body may introduce a set of its own.
1624 Opts := Save_Config_Switches;
1626 -- Indicate that the body of the package exists. If we are doing
1627 -- only semantic analysis, the stub stands for the body. If we are
1628 -- generating code, the existence of the body will be confirmed
1629 -- when we load the proper body.
1631 Set_Scope (Id, Current_Scope);
1632 Set_Ekind (Id, E_Package_Body);
1633 Set_Etype (Id, Standard_Void_Type);
1635 if Has_Aspects (N) then
1636 Analyze_Aspect_Specifications (N, Id);
1639 Set_Has_Completion (Nam);
1640 Set_Corresponding_Spec_Of_Stub (N, Nam);
1641 Generate_Reference (Nam, Id, 'b');
1642 Analyze_Proper_Body (N, Nam);
1644 Restore_Config_Switches (Opts);
1646 end Analyze_Package_Body_Stub;
1648 -------------------------
1649 -- Analyze_Proper_Body --
1650 -------------------------
1652 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
1653 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
1655 procedure Optional_Subunit;
1656 -- This procedure is called when the main unit is a stub, or when we
1657 -- are not generating code. In such a case, we analyze the subunit if
1658 -- present, which is user-friendly, but we don't complain if the subunit
1659 -- is missing. In GNATprove_Mode, we issue an error to avoid formal
1660 -- verification of a partial unit.
1662 ----------------------
1663 -- Optional_Subunit --
1664 ----------------------
1666 procedure Optional_Subunit is
1667 Comp_Unit : Node_Id;
1668 Unum : Unit_Number_Type;
1671 -- Try to load subunit, but ignore any errors that occur during the
1672 -- loading of the subunit, by using the special feature in Errout to
1673 -- ignore all errors. Note that Fatal_Error will still be set, so we
1674 -- will be able to check for this case below.
1676 if not GNATprove_Mode then
1677 Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
1682 (Load_Name => Subunit_Name,
1683 Required => GNATprove_Mode,
1687 if not GNATprove_Mode then
1688 Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
1691 -- All done if we successfully loaded the subunit
1694 and then (Fatal_Error (Unum) /= Error_Detected
1695 or else Try_Semantics)
1697 Comp_Unit := Cunit (Unum);
1699 -- If the file was empty or seriously mangled, the unit itself may
1702 if No (Unit (Comp_Unit)) then
1704 ("subunit does not contain expected proper body", N);
1706 elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then
1708 ("expected SEPARATE subunit, found child unit",
1709 Cunit_Entity (Unum));
1711 Set_Corresponding_Stub (Unit (Comp_Unit), N);
1712 Analyze_Subunit (Comp_Unit);
1713 Set_Library_Unit (N, Comp_Unit);
1714 Set_Corresponding_Body (N, Defining_Entity (Unit (Comp_Unit)));
1717 elsif Unum = No_Unit
1718 and then Present (Nam)
1720 if Is_Protected_Type (Nam) then
1721 Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
1723 Set_Corresponding_Body (
1724 Unit_Declaration_Node (Nam), Defining_Identifier (N));
1727 end Optional_Subunit;
1731 Comp_Unit : Node_Id;
1732 Unum : Unit_Number_Type;
1734 -- Start of processing for Analyze_Proper_Body
1737 -- If the subunit is already loaded, it means that the main unit is a
1738 -- subunit, and that the current unit is one of its parents which was
1739 -- being analyzed to provide the needed context for the analysis of the
1740 -- subunit. In this case we analyze the subunit and continue with the
1741 -- parent, without looking at subsequent subunits.
1743 if Is_Loaded (Subunit_Name) then
1745 -- If the proper body is already linked to the stub node, the stub is
1746 -- in a generic unit and just needs analyzing.
1748 if Present (Library_Unit (N)) then
1749 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1751 -- If the subunit has severe errors, the spec of the enclosing
1752 -- body may not be available, in which case do not try analysis.
1754 if Serious_Errors_Detected > 0
1755 and then No (Library_Unit (Library_Unit (N)))
1760 -- Collect SCO information for loaded subunit if we are in the
1761 -- extended main unit.
1764 and then In_Extended_Main_Source_Unit
1765 (Cunit_Entity (Current_Sem_Unit))
1767 SCO_Record_Raw (Get_Cunit_Unit_Number (Library_Unit (N)));
1770 Analyze_Subunit (Library_Unit (N));
1772 -- Otherwise we must load the subunit and link to it
1775 -- Load the subunit, this must work, since we originally loaded
1776 -- the subunit earlier on. So this will not really load it, just
1777 -- give access to it.
1781 (Load_Name => Subunit_Name,
1786 -- And analyze the subunit in the parent context (note that we
1787 -- do not call Semantics, since that would remove the parent
1788 -- context). Because of this, we have to manually reset the
1789 -- compiler state to Analyzing since it got destroyed by Load.
1791 if Unum /= No_Unit then
1792 Compiler_State := Analyzing;
1794 -- Check that the proper body is a subunit and not a child
1795 -- unit. If the unit was previously loaded, the error will
1796 -- have been emitted when copying the generic node, so we
1797 -- just return to avoid cascaded errors.
1799 if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
1803 Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
1804 Analyze_Subunit (Cunit (Unum));
1805 Set_Library_Unit (N, Cunit (Unum));
1809 -- If the main unit is a subunit, then we are just performing semantic
1810 -- analysis on that subunit, and any other subunits of any parent unit
1811 -- should be ignored. If the main unit is itself a subunit, another
1812 -- subunit is irrelevant unless it is a subunit of the current one, that
1813 -- is to say appears in the current source tree.
1815 elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
1816 and then Subunit_Name /= Unit_Name (Main_Unit)
1818 -- But before we return, set the flag for unloaded subunits. This
1819 -- will suppress junk warnings of variables in the same declarative
1820 -- part (or a higher level one) that are in danger of looking unused
1821 -- when in fact there might be a declaration in the subunit that we
1822 -- do not intend to load.
1824 Unloaded_Subunits := True;
1827 -- If the subunit is not already loaded, and we are generating code,
1828 -- then this is the case where compilation started from the parent, and
1829 -- we are generating code for an entire subunit tree. In that case we
1830 -- definitely need to load the subunit.
1832 -- In order to continue the analysis with the rest of the parent,
1833 -- and other subunits, we load the unit without requiring its
1834 -- presence, and emit a warning if not found, rather than terminating
1835 -- the compilation abruptly, as for other missing file problems.
1837 elsif Original_Operating_Mode = Generate_Code then
1839 -- If the proper body is already linked to the stub node, the stub is
1840 -- in a generic unit and just needs analyzing.
1842 -- We update the version. Although we are not strictly technically
1843 -- semantically dependent on the subunit, given our approach of macro
1844 -- substitution of subunits, it makes sense to include it in the
1845 -- version identification.
1847 if Present (Library_Unit (N)) then
1848 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1849 Analyze_Subunit (Library_Unit (N));
1850 Version_Update (Cunit (Main_Unit), Library_Unit (N));
1852 -- Otherwise we must load the subunit and link to it
1855 -- Make sure that, if the subunit is preprocessed and -gnateG is
1856 -- specified, the preprocessed file will be written.
1858 Lib.Analysing_Subunit_Of_Main := True;
1861 (Load_Name => Subunit_Name,
1865 Lib.Analysing_Subunit_Of_Main := False;
1867 -- Give message if we did not get the unit Emit warning even if
1868 -- missing subunit is not within main unit, to simplify debugging.
1870 pragma Assert (Original_Operating_Mode = Generate_Code);
1871 if Unum = No_Unit then
1872 Error_Msg_Unit_1 := Subunit_Name;
1874 Get_File_Name (Subunit_Name, Subunit => True);
1876 ("subunit$$ in file{ not found??!!", N);
1877 Subunits_Missing := True;
1880 -- Load_Unit may reset Compiler_State, since it may have been
1881 -- necessary to parse an additional units, so we make sure that
1882 -- we reset it to the Analyzing state.
1884 Compiler_State := Analyzing;
1886 if Unum /= No_Unit then
1887 if Debug_Flag_L then
1888 Write_Str ("*** Loaded subunit from stub. Analyze");
1892 Comp_Unit := Cunit (Unum);
1894 -- Check for child unit instead of subunit
1896 if Nkind (Unit (Comp_Unit)) /= N_Subunit then
1898 ("expected SEPARATE subunit, found child unit",
1899 Cunit_Entity (Unum));
1901 -- OK, we have a subunit
1904 Set_Corresponding_Stub (Unit (Comp_Unit), N);
1905 Set_Library_Unit (N, Comp_Unit);
1907 -- We update the version. Although we are not technically
1908 -- semantically dependent on the subunit, given our approach
1909 -- of macro substitution of subunits, it makes sense to
1910 -- include it in the version identification.
1912 Version_Update (Cunit (Main_Unit), Comp_Unit);
1914 -- Collect SCO information for loaded subunit if we are in
1915 -- the extended main unit.
1918 and then In_Extended_Main_Source_Unit
1919 (Cunit_Entity (Current_Sem_Unit))
1921 SCO_Record_Raw (Unum);
1924 -- Analyze the unit if semantics active
1926 if Fatal_Error (Unum) /= Error_Detected
1927 or else Try_Semantics
1929 Analyze_Subunit (Comp_Unit);
1935 -- The remaining case is when the subunit is not already loaded and we
1936 -- are not generating code. In this case we are just performing semantic
1937 -- analysis on the parent, and we are not interested in the subunit. For
1938 -- subprograms, analyze the stub as a body. For other entities the stub
1939 -- has already been marked as completed.
1944 end Analyze_Proper_Body;
1946 ----------------------------------
1947 -- Analyze_Protected_Body_Stub --
1948 ----------------------------------
1950 procedure Analyze_Protected_Body_Stub (N : Node_Id) is
1951 Id : constant Entity_Id := Defining_Entity (N);
1952 Nam : Entity_Id := Current_Entity_In_Scope (Id);
1953 Opts : Config_Switches_Type;
1956 Check_Stub_Level (N);
1958 -- First occurrence of name may have been as an incomplete type
1960 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1961 Nam := Full_View (Nam);
1964 if No (Nam) or else not Is_Protected_Type (Etype (Nam)) then
1965 Error_Msg_N ("missing specification for Protected body", N);
1968 -- Retain and restore the configuration options of the enclosing
1969 -- context as the proper body may introduce a set of its own.
1971 Opts := Save_Config_Switches;
1973 Set_Scope (Id, Current_Scope);
1974 Set_Ekind (Id, E_Protected_Body);
1975 Set_Etype (Id, Standard_Void_Type);
1977 if Has_Aspects (N) then
1978 Analyze_Aspect_Specifications (N, Id);
1981 Set_Has_Completion (Etype (Nam));
1982 Set_Corresponding_Spec_Of_Stub (N, Nam);
1983 Generate_Reference (Nam, Id, 'b');
1984 Analyze_Proper_Body (N, Etype (Nam));
1986 Restore_Config_Switches (Opts);
1988 end Analyze_Protected_Body_Stub;
1990 ----------------------------------
1991 -- Analyze_Subprogram_Body_Stub --
1992 ----------------------------------
1994 -- A subprogram body stub can appear with or without a previous spec. If
1995 -- there is one, then the analysis of the body will find it and verify
1996 -- conformance. The formals appearing in the specification of the stub play
1997 -- no role, except for requiring an additional conformance check. If there
1998 -- is no previous subprogram declaration, the stub acts as a spec, and
1999 -- provides the defining entity for the subprogram.
2001 procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
2003 Opts : Config_Switches_Type;
2006 Check_Stub_Level (N);
2008 -- Verify that the identifier for the stub is unique within this
2009 -- declarative part.
2011 if Nkind_In (Parent (N), N_Block_Statement,
2015 Decl := First (Declarations (Parent (N)));
2016 while Present (Decl) and then Decl /= N loop
2017 if Nkind (Decl) = N_Subprogram_Body_Stub
2018 and then (Chars (Defining_Unit_Name (Specification (Decl))) =
2019 Chars (Defining_Unit_Name (Specification (N))))
2021 Error_Msg_N ("identifier for stub is not unique", N);
2028 -- Retain and restore the configuration options of the enclosing context
2029 -- as the proper body may introduce a set of its own.
2031 Opts := Save_Config_Switches;
2033 -- Treat stub as a body, which checks conformance if there is a previous
2034 -- declaration, or else introduces entity and its signature.
2036 Analyze_Subprogram_Body (N);
2037 Analyze_Proper_Body (N, Empty);
2039 Restore_Config_Switches (Opts);
2040 end Analyze_Subprogram_Body_Stub;
2042 ---------------------
2043 -- Analyze_Subunit --
2044 ---------------------
2046 -- A subunit is compiled either by itself (for semantic checking) or as
2047 -- part of compiling the parent (for code generation). In either case, by
2048 -- the time we actually process the subunit, the parent has already been
2049 -- installed and analyzed. The node N is a compilation unit, whose context
2050 -- needs to be treated here, because we come directly here from the parent
2051 -- without calling Analyze_Compilation_Unit.
2053 -- The compilation context includes the explicit context of the subunit,
2054 -- and the context of the parent, together with the parent itself. In order
2055 -- to compile the current context, we remove the one inherited from the
2056 -- parent, in order to have a clean visibility table. We restore the parent
2057 -- context before analyzing the proper body itself. On exit, we remove only
2058 -- the explicit context of the subunit.
2060 -- WARNING: This routine manages SPARK regions. Return statements must be
2061 -- replaced by gotos which jump to the end of the routine and restore the
2064 procedure Analyze_Subunit (N : Node_Id) is
2065 Lib_Unit : constant Node_Id := Library_Unit (N);
2066 Par_Unit : constant Entity_Id := Current_Scope;
2068 Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
2069 Num_Scopes : Nat := 0;
2070 Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
2071 Enclosing_Child : Entity_Id := Empty;
2072 Svg : constant Suppress_Record := Scope_Suppress;
2074 Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
2075 Cunit_Boolean_Restrictions_Save;
2076 -- Save non-partition wide restrictions before processing the subunit.
2077 -- All subunits are analyzed with config restrictions reset and we need
2078 -- to restore these saved values at the end.
2080 procedure Analyze_Subunit_Context;
2081 -- Capture names in use clauses of the subunit. This must be done before
2082 -- re-installing parent declarations, because items in the context must
2083 -- not be hidden by declarations local to the parent.
2085 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
2086 -- Recursive procedure to restore scope of all ancestors of subunit,
2087 -- from outermost in. If parent is not a subunit, the call to install
2088 -- context installs context of spec and (if parent is a child unit) the
2089 -- context of its parents as well. It is confusing that parents should
2090 -- be treated differently in both cases, but the semantics are just not
2093 procedure Re_Install_Use_Clauses;
2094 -- As part of the removal of the parent scope, the use clauses are
2095 -- removed, to be reinstalled when the context of the subunit has been
2096 -- analyzed. Use clauses may also have been affected by the analysis of
2097 -- the context of the subunit, so they have to be applied again, to
2098 -- insure that the compilation environment of the rest of the parent
2099 -- unit is identical.
2101 procedure Remove_Scope;
2102 -- Remove current scope from scope stack, and preserve the list of use
2103 -- clauses in it, to be reinstalled after context is analyzed.
2105 -----------------------------
2106 -- Analyze_Subunit_Context --
2107 -----------------------------
2109 procedure Analyze_Subunit_Context is
2111 Unit_Name : Entity_Id;
2114 Analyze_Context (N);
2115 Check_No_Elab_Code_All (N);
2117 -- Make withed units immediately visible. If child unit, make the
2118 -- ultimate parent immediately visible.
2120 Item := First (Context_Items (N));
2121 while Present (Item) loop
2122 if Nkind (Item) = N_With_Clause then
2124 -- Protect frontend against previous errors in context clauses
2126 if Nkind (Name (Item)) /= N_Selected_Component then
2127 if Error_Posted (Item) then
2131 -- If a subunits has serious syntax errors, the context
2132 -- may not have been loaded. Add a harmless unit name to
2133 -- attempt processing.
2135 if Serious_Errors_Detected > 0
2136 and then No (Entity (Name (Item)))
2138 Set_Entity (Name (Item), Standard_Standard);
2141 Unit_Name := Entity (Name (Item));
2143 Set_Is_Visible_Lib_Unit (Unit_Name);
2144 exit when Scope (Unit_Name) = Standard_Standard;
2145 Unit_Name := Scope (Unit_Name);
2147 if No (Unit_Name) then
2148 Check_Error_Detected;
2153 if not Is_Immediately_Visible (Unit_Name) then
2154 Set_Is_Immediately_Visible (Unit_Name);
2155 Set_Context_Installed (Item);
2160 elsif Nkind (Item) = N_Use_Package_Clause then
2161 Analyze (Name (Item));
2163 elsif Nkind (Item) = N_Use_Type_Clause then
2164 Analyze (Subtype_Mark (Item));
2170 -- Reset visibility of withed units. They will be made visible again
2171 -- when we install the subunit context.
2173 Item := First (Context_Items (N));
2174 while Present (Item) loop
2175 if Nkind (Item) = N_With_Clause
2177 -- Protect frontend against previous errors in context clauses
2179 and then Nkind (Name (Item)) /= N_Selected_Component
2180 and then not Error_Posted (Item)
2182 Unit_Name := Entity (Name (Item));
2184 Set_Is_Visible_Lib_Unit (Unit_Name, False);
2185 exit when Scope (Unit_Name) = Standard_Standard;
2186 Unit_Name := Scope (Unit_Name);
2189 if Context_Installed (Item) then
2190 Set_Is_Immediately_Visible (Unit_Name, False);
2191 Set_Context_Installed (Item, False);
2197 end Analyze_Subunit_Context;
2199 ------------------------
2200 -- Re_Install_Parents --
2201 ------------------------
2203 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
2207 if Nkind (Unit (L)) = N_Subunit then
2208 Re_Install_Parents (Library_Unit (L), Scope (Scop));
2211 Install_Context (L, False);
2213 -- If the subunit occurs within a child unit, we must restore the
2214 -- immediate visibility of any siblings that may occur in context.
2215 -- In addition, we must reset the previous visibility of the
2216 -- parent unit which is now on the scope stack. This is because
2217 -- the Previous_Visibility was previously set when removing the
2218 -- context. This is necessary to prevent the parent entity from
2219 -- remaining visible after the subunit is compiled. This only
2220 -- has an effect if a homonym exists in a body to be processed
2221 -- later if inlining is enabled.
2223 if Present (Enclosing_Child) then
2224 Install_Siblings (Enclosing_Child, L);
2225 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
2231 if Scop /= Par_Unit then
2232 Set_Is_Immediately_Visible (Scop);
2235 -- Make entities in scope visible again. For child units, restore
2236 -- visibility only if they are actually in context.
2238 E := First_Entity (Current_Scope);
2239 while Present (E) loop
2240 if not Is_Child_Unit (E) or else Is_Visible_Lib_Unit (E) then
2241 Set_Is_Immediately_Visible (E);
2247 -- A subunit appears within a body, and for a nested subunits all the
2248 -- parents are bodies. Restore full visibility of their private
2251 if Is_Package_Or_Generic_Package (Scop) then
2252 Set_In_Package_Body (Scop);
2253 Install_Private_Declarations (Scop);
2255 end Re_Install_Parents;
2257 ----------------------------
2258 -- Re_Install_Use_Clauses --
2259 ----------------------------
2261 procedure Re_Install_Use_Clauses is
2264 for J in reverse 1 .. Num_Scopes loop
2265 U := Use_Clauses (J);
2266 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
2267 Install_Use_Clauses (U);
2269 end Re_Install_Use_Clauses;
2275 procedure Remove_Scope is
2279 Num_Scopes := Num_Scopes + 1;
2280 Use_Clauses (Num_Scopes) :=
2281 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
2283 E := First_Entity (Current_Scope);
2284 while Present (E) loop
2285 Set_Is_Immediately_Visible (E, False);
2289 if Is_Child_Unit (Current_Scope) then
2290 Enclosing_Child := Current_Scope;
2296 Saved_SM : SPARK_Mode_Type := SPARK_Mode;
2297 Saved_SMP : Node_Id := SPARK_Mode_Pragma;
2298 -- Save the SPARK mode-related data to restore on exit. Removing
2299 -- enclosing scopes and contexts to provide a clean environment for the
2300 -- context of the subunit will eliminate any previously set SPARK_Mode.
2302 -- Start of processing for Analyze_Subunit
2305 -- For subunit in main extended unit, we reset the configuration values
2306 -- for the non-partition-wide restrictions. For other units reset them.
2308 if In_Extended_Main_Source_Unit (N) then
2309 Restore_Config_Cunit_Boolean_Restrictions;
2311 Reset_Cunit_Boolean_Restrictions;
2316 Nam : Node_Id := Name (Unit (N));
2319 if Nkind (Nam) = N_Selected_Component then
2320 Nam := Selector_Name (Nam);
2323 Check_Identifier (Nam, Par_Unit);
2327 if not Is_Empty_List (Context_Items (N)) then
2329 -- Save current use clauses
2332 Remove_Context (Lib_Unit);
2334 -- Now remove parents and their context, including enclosing subunits
2335 -- and the outer parent body which is not a subunit.
2337 if Present (Lib_Spec) then
2338 Remove_Context (Lib_Spec);
2340 while Nkind (Unit (Lib_Spec)) = N_Subunit loop
2341 Lib_Spec := Library_Unit (Lib_Spec);
2343 Remove_Context (Lib_Spec);
2346 if Nkind (Unit (Lib_Unit)) = N_Subunit then
2350 if Nkind_In (Unit (Lib_Spec), N_Package_Body,
2353 Remove_Context (Library_Unit (Lib_Spec));
2357 Set_Is_Immediately_Visible (Par_Unit, False);
2359 Analyze_Subunit_Context;
2361 -- Take into account the effect of any SPARK_Mode configuration
2362 -- pragma, which takes precedence over a different value of
2363 -- SPARK_Mode inherited from the context of the stub.
2365 if SPARK_Mode /= None then
2366 Saved_SM := SPARK_Mode;
2367 Saved_SMP := SPARK_Mode_Pragma;
2370 Re_Install_Parents (Lib_Unit, Par_Unit);
2371 Set_Is_Immediately_Visible (Par_Unit);
2373 -- If the context includes a child unit of the parent of the subunit,
2374 -- the parent will have been removed from visibility, after compiling
2375 -- that cousin in the context. The visibility of the parent must be
2376 -- restored now. This also applies if the context includes another
2377 -- subunit of the same parent which in turn includes a child unit in
2380 if Is_Package_Or_Generic_Package (Par_Unit) then
2381 if not Is_Immediately_Visible (Par_Unit)
2382 or else (Present (First_Entity (Par_Unit))
2384 Is_Immediately_Visible (First_Entity (Par_Unit)))
2386 Set_Is_Immediately_Visible (Par_Unit);
2387 Install_Visible_Declarations (Par_Unit);
2388 Install_Private_Declarations (Par_Unit);
2392 Re_Install_Use_Clauses;
2393 Install_Context (N, Chain => False);
2395 -- Restore state of suppress flags for current body
2397 Scope_Suppress := Svg;
2399 -- If the subunit is within a child unit, then siblings of any parent
2400 -- unit that appear in the context clause of the subunit must also be
2401 -- made immediately visible.
2403 if Present (Enclosing_Child) then
2404 Install_Siblings (Enclosing_Child, N);
2408 Generate_Parent_References (Unit (N), Par_Unit);
2410 -- Reinstall the SPARK_Mode which was in effect prior to any scope and
2411 -- context manipulations, taking into account a possible SPARK_Mode
2412 -- configuration pragma if present.
2414 Install_SPARK_Mode (Saved_SM, Saved_SMP);
2416 -- If the subunit is part of a compilation unit which is subject to
2417 -- pragma Elaboration_Checks, set the model specified by the pragma
2418 -- because it applies to all parts of the unit.
2420 Install_Elaboration_Model (Par_Unit);
2422 -- The syntax rules require a proper body for a subprogram subunit
2424 if Nkind (Proper_Body (Sinfo.Unit (N))) = N_Subprogram_Declaration then
2425 if Null_Present (Specification (Proper_Body (Sinfo.Unit (N)))) then
2427 ("null procedure not allowed as subunit",
2428 Proper_Body (Unit (N)));
2431 ("subprogram declaration not allowed as subunit",
2432 Defining_Unit_Name (Specification (Proper_Body (Unit (N)))));
2436 Analyze (Proper_Body (Unit (N)));
2439 -- The subunit may contain a with_clause on a sibling of some ancestor.
2440 -- Removing the context will remove from visibility those ancestor child
2441 -- units, which must be restored to the visibility they have in the
2444 if Present (Enclosing_Child) then
2449 while Present (C) and then C /= Standard_Standard loop
2450 Set_Is_Immediately_Visible (C);
2451 Set_Is_Visible_Lib_Unit (C);
2457 -- Deal with restore of restrictions
2459 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
2460 end Analyze_Subunit;
2462 ----------------------------
2463 -- Analyze_Task_Body_Stub --
2464 ----------------------------
2466 procedure Analyze_Task_Body_Stub (N : Node_Id) is
2467 Id : constant Entity_Id := Defining_Entity (N);
2468 Loc : constant Source_Ptr := Sloc (N);
2469 Nam : Entity_Id := Current_Entity_In_Scope (Id);
2472 Check_Stub_Level (N);
2474 -- First occurrence of name may have been as an incomplete type
2476 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
2477 Nam := Full_View (Nam);
2480 if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
2481 Error_Msg_N ("missing specification for task body", N);
2484 Set_Scope (Id, Current_Scope);
2485 Set_Ekind (Id, E_Task_Body);
2486 Set_Etype (Id, Standard_Void_Type);
2488 if Has_Aspects (N) then
2489 Analyze_Aspect_Specifications (N, Id);
2492 Generate_Reference (Nam, Id, 'b');
2493 Set_Corresponding_Spec_Of_Stub (N, Nam);
2495 -- Check for duplicate stub, if so give message and terminate
2497 if Has_Completion (Etype (Nam)) then
2498 Error_Msg_N ("duplicate stub for task", N);
2501 Set_Has_Completion (Etype (Nam));
2504 Analyze_Proper_Body (N, Etype (Nam));
2506 -- Set elaboration flag to indicate that entity is callable. This
2507 -- cannot be done in the expansion of the body itself, because the
2508 -- proper body is not in a declarative part. This is only done if
2509 -- expansion is active, because the context may be generic and the
2510 -- flag not defined yet.
2512 if Expander_Active then
2514 Make_Assignment_Statement (Loc,
2516 Make_Identifier (Loc,
2517 Chars => New_External_Name (Chars (Etype (Nam)), 'E')),
2518 Expression => New_Occurrence_Of (Standard_True, Loc)));
2521 end Analyze_Task_Body_Stub;
2523 -------------------------
2524 -- Analyze_With_Clause --
2525 -------------------------
2527 -- Analyze the declaration of a unit in a with clause. At end, label the
2528 -- with clause with the defining entity for the unit.
2530 procedure Analyze_With_Clause (N : Node_Id) is
2532 -- Retrieve the original kind of the unit node, before analysis. If it
2533 -- is a subprogram instantiation, its analysis below will rewrite the
2534 -- node as the declaration of the wrapper package. If the same
2535 -- instantiation appears indirectly elsewhere in the context, it will
2536 -- have been analyzed already.
2538 Unit_Kind : constant Node_Kind :=
2539 Nkind (Original_Node (Unit (Library_Unit (N))));
2540 Nam : constant Node_Id := Name (N);
2542 Par_Name : Entity_Id;
2547 -- Set True if the unit currently being compiled is an internal unit
2549 Restriction_Violation : Boolean := False;
2550 -- Set True if a with violates a restriction, no point in giving any
2551 -- warnings if we have this definite error.
2553 Save_Style_Check : constant Boolean := Opt.Style_Check;
2556 U := Unit (Library_Unit (N));
2558 -- If this is an internal unit which is a renaming, then this is a
2559 -- violation of No_Obsolescent_Features.
2561 -- Note: this is not quite right if the user defines one of these units
2562 -- himself, but that's a marginal case, and fixing it is hard ???
2564 if Restriction_Check_Required (No_Obsolescent_Features) then
2565 if In_Predefined_Renaming (U) then
2566 Check_Restriction (No_Obsolescent_Features, N);
2567 Restriction_Violation := True;
2571 -- Check No_Implementation_Units violation
2573 if Restriction_Check_Required (No_Implementation_Units) then
2574 if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then
2577 Check_Restriction (No_Implementation_Units, Nam);
2578 Restriction_Violation := True;
2582 -- Several actions are skipped for dummy packages (those supplied for
2583 -- with's where no matching file could be found). Such packages are
2584 -- identified by the Sloc value being set to No_Location.
2586 if Limited_Present (N) then
2588 -- Ada 2005 (AI-50217): Build visibility structures but do not
2589 -- analyze the unit.
2591 -- If the designated unit is a predefined unit, which might be used
2592 -- implicitly through the rtsfind machinery, a limited with clause
2593 -- on such a unit is usually pointless, because run-time units are
2594 -- unlikely to appear in mutually dependent units, and because this
2595 -- disables the rtsfind mechanism. We transform such limited with
2596 -- clauses into regular with clauses.
2598 if Sloc (U) /= No_Location then
2599 if In_Predefined_Unit (U) then
2600 Set_Limited_Present (N, False);
2601 Analyze_With_Clause (N);
2603 Build_Limited_Views (N);
2610 -- If we are compiling under "don't quit" mode (-gnatq) and we have
2611 -- already detected serious errors then we mark the with-clause nodes as
2612 -- analyzed before the corresponding compilation unit is analyzed. This
2613 -- is done here to protect the frontend against never ending recursion
2614 -- caused by circularities in the sources (because the previous errors
2615 -- may break the regular machine of the compiler implemented in
2616 -- Load_Unit to detect circularities).
2618 if Serious_Errors_Detected > 0 and then Try_Semantics then
2622 Semantics (Library_Unit (N));
2624 Intunit := Is_Internal_Unit (Current_Sem_Unit);
2626 if Sloc (U) /= No_Location then
2628 -- Check restrictions, except that we skip the check if this is an
2629 -- internal unit unless we are compiling the internal unit as the
2630 -- main unit. We also skip this for dummy packages.
2632 Check_Restriction_No_Dependence (Nam, N);
2634 if not Intunit or else Current_Sem_Unit = Main_Unit then
2635 Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
2638 -- Deal with special case of GNAT.Current_Exceptions which interacts
2639 -- with the optimization of local raise statements into gotos.
2641 if Nkind (Nam) = N_Selected_Component
2642 and then Nkind (Prefix (Nam)) = N_Identifier
2643 and then Chars (Prefix (Nam)) = Name_Gnat
2644 and then Nam_In (Chars (Selector_Name (Nam)),
2645 Name_Most_Recent_Exception,
2646 Name_Exception_Traces)
2648 Check_Restriction (No_Exception_Propagation, N);
2649 Special_Exception_Package_Used := True;
2652 -- Check for inappropriate with of internal implementation unit if we
2653 -- are not compiling an internal unit and also check for withing unit
2654 -- in wrong version of Ada. Do not issue these messages for implicit
2655 -- with's generated by the compiler itself.
2657 if Implementation_Unit_Warnings
2658 and then not Intunit
2659 and then not Implicit_With (N)
2660 and then not Restriction_Violation
2662 case Get_Kind_Of_Unit (Get_Source_Unit (U)) is
2663 when Implementation_Unit =>
2664 Error_Msg_F ("& is an internal 'G'N'A'T unit?i?", Name (N));
2666 -- Add alternative name if available, otherwise issue a
2667 -- general warning message.
2669 if Error_Msg_Strlen /= 0 then
2670 Error_Msg_F ("\use ""~"" instead?i?", Name (N));
2673 ("\use of this unit is non-portable and "
2674 & "version-dependent?i?", Name (N));
2677 when Not_Predefined_Unit | Ada_95_Unit =>
2678 null; -- no checks needed
2680 when Ada_2005_Unit =>
2681 if Ada_Version < Ada_2005
2682 and then Warn_On_Ada_2005_Compatibility
2684 Error_Msg_N ("& is an Ada 2005 unit?i?", Name (N));
2687 when Ada_2012_Unit =>
2688 if Ada_Version < Ada_2012
2689 and then Warn_On_Ada_2012_Compatibility
2691 Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N));
2694 when Ada_202X_Unit =>
2695 if Ada_Version < Ada_2020
2696 and then Warn_On_Ada_202X_Compatibility
2698 Error_Msg_N ("& is an Ada 202X unit?i?", Name (N));
2704 -- Semantic analysis of a generic unit is performed on a copy of
2705 -- the original tree. Retrieve the entity on which semantic info
2706 -- actually appears.
2708 if Unit_Kind in N_Generic_Declaration then
2709 E_Name := Defining_Entity (U);
2711 -- Note: in the following test, Unit_Kind is the original Nkind, but in
2712 -- the case of an instantiation, semantic analysis above will have
2713 -- replaced the unit by its instantiated version. If the instance body
2714 -- has been generated, the instance now denotes the body entity. For
2715 -- visibility purposes we need the entity of its spec.
2717 elsif (Unit_Kind = N_Package_Instantiation
2718 or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
2719 N_Package_Instantiation)
2720 and then Nkind (U) = N_Package_Body
2722 E_Name := Corresponding_Spec (U);
2724 elsif Unit_Kind = N_Package_Instantiation
2725 and then Nkind (U) = N_Package_Instantiation
2726 and then Present (Instance_Spec (U))
2728 -- If the instance has not been rewritten as a package declaration,
2729 -- then it appeared already in a previous with clause. Retrieve
2730 -- the entity from the previous instance.
2732 E_Name := Defining_Entity (Specification (Instance_Spec (U)));
2734 elsif Unit_Kind in N_Subprogram_Instantiation then
2736 -- The visible subprogram is created during instantiation, and is
2737 -- an attribute of the wrapper package. We retrieve the wrapper
2738 -- package directly from the instantiation node. If the instance
2739 -- is inlined the unit is still an instantiation. Otherwise it has
2740 -- been rewritten as the declaration of the wrapper itself.
2742 if Nkind (U) in N_Subprogram_Instantiation then
2745 (Defining_Entity (Specification (Instance_Spec (U))));
2747 E_Name := Related_Instance (Defining_Entity (U));
2750 elsif Unit_Kind = N_Package_Renaming_Declaration
2751 or else Unit_Kind in N_Generic_Renaming_Declaration
2753 E_Name := Defining_Entity (U);
2755 elsif Unit_Kind = N_Subprogram_Body
2756 and then Nkind (Name (N)) = N_Selected_Component
2757 and then not Acts_As_Spec (Library_Unit (N))
2759 -- For a child unit that has no spec, one has been created and
2760 -- analyzed. The entity required is that of the spec.
2762 E_Name := Corresponding_Spec (U);
2765 E_Name := Defining_Entity (U);
2768 if Nkind (Name (N)) = N_Selected_Component then
2770 -- Child unit in a with clause
2772 Change_Selected_Component_To_Expanded_Name (Name (N));
2774 -- If this is a child unit without a spec, and it has been analyzed
2775 -- already, a declaration has been created for it. The with_clause
2776 -- must reflect the actual body, and not the generated declaration,
2777 -- to prevent spurious binding errors involving an out-of-date spec.
2778 -- Note that this can only happen if the unit includes more than one
2779 -- with_clause for the child unit (e.g. in separate subunits).
2781 if Unit_Kind = N_Subprogram_Declaration
2782 and then Analyzed (Library_Unit (N))
2783 and then not Comes_From_Source (Library_Unit (N))
2785 Set_Library_Unit (N,
2786 Cunit (Get_Source_Unit (Corresponding_Body (U))));
2790 -- Restore style checks
2792 Style_Check := Save_Style_Check;
2794 -- Record the reference, but do NOT set the unit as referenced, we want
2795 -- to consider the unit as unreferenced if this is the only reference
2798 Set_Entity_With_Checks (Name (N), E_Name);
2799 Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
2801 -- Generate references and check No_Dependence restriction for parents
2803 if Is_Child_Unit (E_Name) then
2804 Pref := Prefix (Name (N));
2805 Par_Name := Scope (E_Name);
2806 while Nkind (Pref) = N_Selected_Component loop
2807 Change_Selected_Component_To_Expanded_Name (Pref);
2809 if Present (Entity (Selector_Name (Pref)))
2811 Present (Renamed_Entity (Entity (Selector_Name (Pref))))
2812 and then Entity (Selector_Name (Pref)) /= Par_Name
2814 -- The prefix is a child unit that denotes a renaming declaration.
2815 -- Replace the prefix directly with the renamed unit, because the
2816 -- rest of the prefix is irrelevant to the visibility of the real
2819 Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref)));
2823 Set_Entity_With_Checks (Pref, Par_Name);
2825 Generate_Reference (Par_Name, Pref);
2826 Check_Restriction_No_Dependence (Pref, N);
2827 Pref := Prefix (Pref);
2829 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2830 -- is set to Standard_Standard, and no attempt should be made to
2831 -- further unwind scopes.
2833 if Par_Name /= Standard_Standard then
2834 Par_Name := Scope (Par_Name);
2837 -- Abandon processing in case of previous errors
2839 if No (Par_Name) then
2840 Check_Error_Detected;
2845 if Present (Entity (Pref))
2846 and then not Analyzed (Parent (Parent (Entity (Pref))))
2848 -- If the entity is set without its unit being compiled, the
2849 -- original parent is a renaming, and Par_Name is the renamed
2850 -- entity. For visibility purposes, we need the original entity,
2851 -- which must be analyzed now because Load_Unit directly retrieves
2852 -- the renamed unit, and the renaming declaration itself has not
2855 Analyze (Parent (Parent (Entity (Pref))));
2856 pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
2857 Par_Name := Entity (Pref);
2860 -- Guard against missing or misspelled child units
2862 if Present (Par_Name) then
2863 Set_Entity_With_Checks (Pref, Par_Name);
2864 Generate_Reference (Par_Name, Pref);
2867 pragma Assert (Serious_Errors_Detected /= 0);
2869 -- Mark the node to indicate that a related error has been posted.
2870 -- This defends further compilation passes against improper use of
2871 -- the invalid WITH clause node.
2873 Set_Error_Posted (N);
2874 Set_Name (N, Error);
2879 -- If the withed unit is System, and a system extension pragma is
2880 -- present, compile the extension now, rather than waiting for a
2881 -- visibility check on a specific entity.
2883 if Chars (E_Name) = Name_System
2884 and then Scope (E_Name) = Standard_Standard
2885 and then Present (System_Extend_Unit)
2886 and then Present_System_Aux (N)
2888 -- If the extension is not present, an error will have been emitted
2893 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2894 -- to private_with units; they will be made visible later (just before
2895 -- the private part is analyzed)
2897 if Private_Present (N) then
2898 Set_Is_Immediately_Visible (E_Name, False);
2901 -- Propagate Fatal_Error setting from with'ed unit to current unit
2903 case Fatal_Error (Get_Source_Unit (Library_Unit (N))) is
2905 -- Nothing to do if with'ed unit had no error
2910 -- If with'ed unit had a detected fatal error, propagate it
2912 when Error_Detected =>
2913 Set_Fatal_Error (Current_Sem_Unit, Error_Detected);
2915 -- If with'ed unit had an ignored error, then propagate it but do not
2916 -- overide an existring setting.
2918 when Error_Ignored =>
2919 if Fatal_Error (Current_Sem_Unit) = None then
2920 Set_Fatal_Error (Current_Sem_Unit, Error_Ignored);
2923 end Analyze_With_Clause;
2925 ------------------------------
2926 -- Check_Private_Child_Unit --
2927 ------------------------------
2929 procedure Check_Private_Child_Unit (N : Node_Id) is
2930 Lib_Unit : constant Node_Id := Unit (N);
2932 Curr_Unit : Entity_Id;
2933 Sub_Parent : Node_Id;
2934 Priv_Child : Entity_Id;
2935 Par_Lib : Entity_Id;
2938 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
2939 -- Returns true if and only if the library unit is declared with
2940 -- an explicit designation of private.
2942 -----------------------------
2943 -- Is_Private_Library_Unit --
2944 -----------------------------
2946 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
2947 Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
2950 return Private_Present (Comp_Unit);
2951 end Is_Private_Library_Unit;
2953 -- Start of processing for Check_Private_Child_Unit
2956 if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then
2957 Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
2958 Par_Lib := Curr_Unit;
2960 elsif Nkind (Lib_Unit) = N_Subunit then
2962 -- The parent is itself a body. The parent entity is to be found in
2963 -- the corresponding spec.
2965 Sub_Parent := Library_Unit (N);
2966 Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
2968 -- If the parent itself is a subunit, Curr_Unit is the entity of the
2969 -- enclosing body, retrieve the spec entity which is the proper
2970 -- ancestor we need for the following tests.
2972 if Ekind (Curr_Unit) = E_Package_Body then
2973 Curr_Unit := Spec_Entity (Curr_Unit);
2976 Par_Lib := Curr_Unit;
2979 Curr_Unit := Defining_Entity (Lib_Unit);
2981 Par_Lib := Curr_Unit;
2982 Par_Spec := Parent_Spec (Lib_Unit);
2984 if No (Par_Spec) then
2987 Par_Lib := Defining_Entity (Unit (Par_Spec));
2991 -- Loop through context items
2993 Item := First (Context_Items (N));
2994 while Present (Item) loop
2996 -- Ada 2005 (AI-262): Allow private_with of a private child package
2997 -- in public siblings
2999 if Nkind (Item) = N_With_Clause
3000 and then not Implicit_With (Item)
3001 and then not Limited_Present (Item)
3002 and then Is_Private_Descendant (Entity (Name (Item)))
3004 Priv_Child := Entity (Name (Item));
3007 Curr_Parent : Entity_Id := Par_Lib;
3008 Child_Parent : Entity_Id := Scope (Priv_Child);
3009 Prv_Ancestor : Entity_Id := Child_Parent;
3010 Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
3013 -- If the child unit is a public child then locate the nearest
3014 -- private ancestor. Child_Parent will then be set to the
3015 -- parent of that ancestor.
3017 if not Is_Private_Library_Unit (Priv_Child) then
3018 while Present (Prv_Ancestor)
3019 and then not Is_Private_Library_Unit (Prv_Ancestor)
3021 Prv_Ancestor := Scope (Prv_Ancestor);
3024 if Present (Prv_Ancestor) then
3025 Child_Parent := Scope (Prv_Ancestor);
3029 while Present (Curr_Parent)
3030 and then Curr_Parent /= Standard_Standard
3031 and then Curr_Parent /= Child_Parent
3034 Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
3035 Curr_Parent := Scope (Curr_Parent);
3038 if No (Curr_Parent) then
3039 Curr_Parent := Standard_Standard;
3042 if Curr_Parent /= Child_Parent then
3043 if Ekind (Priv_Child) = E_Generic_Package
3044 and then Chars (Priv_Child) in Text_IO_Package_Name
3045 and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
3046 and then Scope (Scope (Scope (Priv_Child))) =
3050 ("& is a nested package, not a compilation unit",
3051 Name (Item), Priv_Child);
3055 ("unit in with clause is private child unit!", Item);
3057 ("\current unit must also have parent&!",
3058 Item, Child_Parent);
3062 or else Private_Present (Item)
3063 or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit)
3064 or else (Nkind (Lib_Unit) = N_Subprogram_Body
3065 and then not Acts_As_Spec (Parent (Lib_Unit)))
3071 ("current unit must also be private descendant of&",
3072 Item, Child_Parent);
3079 end Check_Private_Child_Unit;
3081 ----------------------
3082 -- Check_Stub_Level --
3083 ----------------------
3085 procedure Check_Stub_Level (N : Node_Id) is
3086 Par : constant Node_Id := Parent (N);
3087 Kind : constant Node_Kind := Nkind (Par);
3090 if Nkind_In (Kind, N_Package_Body,
3094 and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit)
3098 -- In an instance, a missing stub appears at any level. A warning
3099 -- message will have been emitted already for the missing file.
3101 elsif not In_Instance then
3102 Error_Msg_N ("stub cannot appear in an inner scope", N);
3104 elsif Expander_Active then
3105 Error_Msg_N ("missing proper body", N);
3107 end Check_Stub_Level;
3109 ------------------------
3110 -- Expand_With_Clause --
3111 ------------------------
3113 procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
3114 Loc : constant Source_Ptr := Sloc (Nam);
3116 function Build_Unit_Name (Nam : Node_Id) return Node_Id;
3117 -- Build name to be used in implicit with_clause. In most cases this
3118 -- is the source name, but if renamings are present we must make the
3119 -- original unit visible, not the one it renames. The entity in the
3120 -- with clause is the renamed unit, but the identifier is the one from
3121 -- the source, which allows us to recover the unit renaming.
3123 ---------------------
3124 -- Build_Unit_Name --
3125 ---------------------
3127 function Build_Unit_Name (Nam : Node_Id) return Node_Id is
3132 if Nkind (Nam) = N_Identifier then
3133 return New_Occurrence_Of (Entity (Nam), Loc);
3136 Ent := Entity (Nam);
3138 if Present (Entity (Selector_Name (Nam)))
3139 and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent)
3141 Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam)))) =
3142 N_Package_Renaming_Declaration
3144 -- The name in the with_clause is of the form A.B.C, and B is
3145 -- given by a renaming declaration. In that case we may not
3146 -- have analyzed the unit for B, but replaced it directly in
3147 -- lib-load with the unit it renames. We have to make A.B
3148 -- visible, so analyze the declaration for B now, in case it
3149 -- has not been done yet.
3151 Ent := Entity (Selector_Name (Nam));
3154 (Unit_Declaration_Node (Entity (Selector_Name (Nam)))));
3158 Make_Expanded_Name (Loc,
3159 Chars => Chars (Entity (Nam)),
3160 Prefix => Build_Unit_Name (Prefix (Nam)),
3161 Selector_Name => New_Occurrence_Of (Ent, Loc));
3162 Set_Entity (Result, Ent);
3166 end Build_Unit_Name;
3170 Ent : constant Entity_Id := Entity (Nam);
3173 -- Start of processing for Expand_With_Clause
3177 Make_With_Clause (Loc,
3178 Name => Build_Unit_Name (Nam));
3180 Set_Corresponding_Spec (Withn, Ent);
3181 Set_First_Name (Withn);
3182 Set_Implicit_With (Withn);
3183 Set_Library_Unit (Withn, Parent (Unit_Declaration_Node (Ent)));
3184 Set_Parent_With (Withn);
3186 -- If the unit is a package or generic package declaration, a private_
3187 -- with_clause on a child unit implies that the implicit with on the
3188 -- parent is also private.
3190 if Nkind_In (Unit (N), N_Generic_Package_Declaration,
3191 N_Package_Declaration)
3193 Set_Private_Present (Withn, Private_Present (Item));
3196 Prepend (Withn, Context_Items (N));
3197 Mark_Rewrite_Insertion (Withn);
3199 Install_With_Clause (Withn);
3201 -- If we have "with X.Y;", we want to recurse on "X", except in the
3202 -- unusual case where X.Y is a renaming of X. In that case, the scope
3203 -- of X will be null.
3205 if Nkind (Nam) = N_Expanded_Name
3206 and then Present (Scope (Entity (Prefix (Nam))))
3208 Expand_With_Clause (Item, Prefix (Nam), N);
3210 end Expand_With_Clause;
3212 --------------------------------
3213 -- Generate_Parent_References --
3214 --------------------------------
3216 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
3218 P_Name : Entity_Id := P_Id;
3221 if Nkind (N) = N_Subunit then
3224 Pref := Name (Parent (Defining_Entity (N)));
3227 if Nkind (Pref) = N_Expanded_Name then
3229 -- Done already, if the unit has been compiled indirectly as
3230 -- part of the closure of its context because of inlining.
3235 while Nkind (Pref) = N_Selected_Component loop
3236 Change_Selected_Component_To_Expanded_Name (Pref);
3237 Set_Entity (Pref, P_Name);
3238 Set_Etype (Pref, Etype (P_Name));
3239 Generate_Reference (P_Name, Pref, 'r');
3240 Pref := Prefix (Pref);
3241 P_Name := Scope (P_Name);
3244 -- The guard here on P_Name is to handle the error condition where
3245 -- the parent unit is missing because the file was not found.
3247 if Present (P_Name) then
3248 Set_Entity (Pref, P_Name);
3249 Set_Etype (Pref, Etype (P_Name));
3250 Generate_Reference (P_Name, Pref, 'r');
3251 Style.Check_Identifier (Pref, P_Name);
3253 end Generate_Parent_References;
3255 ---------------------
3256 -- Has_With_Clause --
3257 ---------------------
3259 function Has_With_Clause
3262 Is_Limited : Boolean := False) return Boolean
3266 function Named_Unit (Clause : Node_Id) return Entity_Id;
3267 -- Return the entity for the unit named in a [limited] with clause
3273 function Named_Unit (Clause : Node_Id) return Entity_Id is
3275 if Nkind (Name (Clause)) = N_Selected_Component then
3276 return Entity (Selector_Name (Name (Clause)));
3278 return Entity (Name (Clause));
3282 -- Start of processing for Has_With_Clause
3285 if Present (Context_Items (C_Unit)) then
3286 Item := First (Context_Items (C_Unit));
3287 while Present (Item) loop
3288 if Nkind (Item) = N_With_Clause
3289 and then Limited_Present (Item) = Is_Limited
3290 and then Named_Unit (Item) = Pack
3300 end Has_With_Clause;
3302 -----------------------------
3303 -- Implicit_With_On_Parent --
3304 -----------------------------
3306 procedure Implicit_With_On_Parent
3307 (Child_Unit : Node_Id;
3310 Loc : constant Source_Ptr := Sloc (N);
3311 P : constant Node_Id := Parent_Spec (Child_Unit);
3312 P_Unit : Node_Id := Unit (P);
3313 P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
3316 function Build_Ancestor_Name (P : Node_Id) return Node_Id;
3317 -- Build prefix of child unit name. Recurse if needed
3319 function Build_Unit_Name return Node_Id;
3320 -- If the unit is a child unit, build qualified name with all ancestors
3322 -------------------------
3323 -- Build_Ancestor_Name --
3324 -------------------------
3326 function Build_Ancestor_Name (P : Node_Id) return Node_Id is
3327 P_Ref : constant Node_Id :=
3328 New_Occurrence_Of (Defining_Entity (P), Loc);
3329 P_Spec : Node_Id := P;
3332 -- Ancestor may have been rewritten as a package body. Retrieve the
3333 -- original spec to trace earlier ancestors.
3335 if Nkind (P) = N_Package_Body
3336 and then Nkind (Original_Node (P)) = N_Package_Instantiation
3338 P_Spec := Original_Node (P);
3341 if No (Parent_Spec (P_Spec)) then
3345 Make_Selected_Component (Loc,
3347 Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
3348 Selector_Name => P_Ref);
3350 end Build_Ancestor_Name;
3352 ---------------------
3353 -- Build_Unit_Name --
3354 ---------------------
3356 function Build_Unit_Name return Node_Id is
3360 if No (Parent_Spec (P_Unit)) then
3361 return New_Occurrence_Of (P_Name, Loc);
3365 Make_Expanded_Name (Loc,
3366 Chars => Chars (P_Name),
3368 Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
3369 Selector_Name => New_Occurrence_Of (P_Name, Loc));
3370 Set_Entity (Result, P_Name);
3374 end Build_Unit_Name;
3376 -- Start of processing for Implicit_With_On_Parent
3379 -- The unit of the current compilation may be a package body that
3380 -- replaces an instance node. In this case we need the original instance
3381 -- node to construct the proper parent name.
3383 if Nkind (P_Unit) = N_Package_Body
3384 and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
3386 P_Unit := Original_Node (P_Unit);
3389 -- We add the implicit with if the child unit is the current unit being
3390 -- compiled. If the current unit is a body, we do not want to add an
3391 -- implicit_with a second time to the corresponding spec.
3393 if Nkind (Child_Unit) = N_Package_Declaration
3394 and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
3399 Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
3401 Set_Corresponding_Spec (Withn, P_Name);
3402 Set_First_Name (Withn);
3403 Set_Implicit_With (Withn);
3404 Set_Library_Unit (Withn, P);
3405 Set_Parent_With (Withn);
3407 -- Node is placed at the beginning of the context items, so that
3408 -- subsequent use clauses on the parent can be validated.
3410 Prepend (Withn, Context_Items (N));
3411 Mark_Rewrite_Insertion (Withn);
3413 Install_With_Clause (Withn);
3415 if Is_Child_Spec (P_Unit) then
3416 Implicit_With_On_Parent (P_Unit, N);
3418 end Implicit_With_On_Parent;
3424 function In_Chain (E : Entity_Id) return Boolean is
3428 H := Current_Entity (E);
3429 while Present (H) loop
3440 ---------------------
3441 -- Install_Context --
3442 ---------------------
3444 procedure Install_Context (N : Node_Id; Chain : Boolean := True) is
3445 Lib_Unit : constant Node_Id := Unit (N);
3448 Install_Context_Clauses (N, Chain);
3450 if Is_Child_Spec (Lib_Unit) then
3452 (Lib_Unit => Lib_Unit,
3453 Is_Private => Private_Present (Parent (Lib_Unit)),
3457 Install_Limited_Context_Clauses (N);
3458 end Install_Context;
3460 -----------------------------
3461 -- Install_Context_Clauses --
3462 -----------------------------
3464 procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True) is
3465 Lib_Unit : constant Node_Id := Unit (N);
3467 Uname_Node : Entity_Id;
3468 Check_Private : Boolean := False;
3469 Decl_Node : Node_Id;
3470 Lib_Parent : Entity_Id;
3473 -- First skip configuration pragmas at the start of the context. They
3474 -- are not technically part of the context clause, but that's where the
3475 -- parser puts them. Note they were analyzed in Analyze_Context.
3477 Item := First (Context_Items (N));
3478 while Present (Item)
3479 and then Nkind (Item) = N_Pragma
3480 and then Pragma_Name (Item) in Configuration_Pragma_Names
3485 -- Loop through the actual context clause items. We process everything
3486 -- except Limited_With clauses in this routine. Limited_With clauses
3487 -- are separately installed (see Install_Limited_Context_Clauses).
3489 while Present (Item) loop
3491 -- Case of explicit WITH clause
3493 if Nkind (Item) = N_With_Clause
3494 and then not Implicit_With (Item)
3496 if Limited_Present (Item) then
3498 -- Limited withed units will be installed later
3502 -- If Name (Item) is not an entity name, something is wrong, and
3503 -- this will be detected in due course, for now ignore the item
3505 elsif not Is_Entity_Name (Name (Item)) then
3508 elsif No (Entity (Name (Item))) then
3509 Set_Entity (Name (Item), Any_Id);
3513 Uname_Node := Entity (Name (Item));
3515 if Is_Private_Descendant (Uname_Node) then
3516 Check_Private := True;
3519 Install_With_Clause (Item);
3521 Decl_Node := Unit_Declaration_Node (Uname_Node);
3523 -- If the unit is a subprogram instance, it appears nested within
3524 -- a package that carries the parent information.
3526 if Is_Generic_Instance (Uname_Node)
3527 and then Ekind (Uname_Node) /= E_Package
3529 Decl_Node := Parent (Parent (Decl_Node));
3532 if Is_Child_Spec (Decl_Node) then
3533 if Nkind (Name (Item)) = N_Expanded_Name then
3534 Expand_With_Clause (Item, Prefix (Name (Item)), N);
3536 -- If not an expanded name, the child unit must be a
3537 -- renaming, nothing to do.
3542 elsif Nkind (Decl_Node) = N_Subprogram_Body
3543 and then not Acts_As_Spec (Parent (Decl_Node))
3544 and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
3546 Implicit_With_On_Parent
3547 (Unit (Library_Unit (Parent (Decl_Node))), N);
3550 -- Check license conditions unless this is a dummy unit
3552 if Sloc (Library_Unit (Item)) /= No_Location then
3553 License_Check : declare
3554 Withu : constant Unit_Number_Type :=
3555 Get_Source_Unit (Library_Unit (Item));
3556 Withl : constant License_Type :=
3557 License (Source_Index (Withu));
3558 Unitl : constant License_Type :=
3559 License (Source_Index (Current_Sem_Unit));
3561 procedure License_Error;
3562 -- Signal error of bad license
3568 procedure License_Error is
3571 ("license of withed unit & may be inconsistent??",
3575 -- Start of processing for License_Check
3578 -- Exclude license check if withed unit is an internal unit.
3579 -- This situation arises e.g. with the GPL version of GNAT.
3581 if Is_Internal_Unit (Withu) then
3584 -- Otherwise check various cases
3596 if Withl = Restricted then
3600 when Modified_GPL =>
3601 if Withl = Restricted or else Withl = GPL then
3605 when Unrestricted =>
3612 -- Case of USE PACKAGE clause
3614 elsif Nkind (Item) = N_Use_Package_Clause then
3615 Analyze_Use_Package (Item, Chain);
3617 -- Case of USE TYPE clause
3619 elsif Nkind (Item) = N_Use_Type_Clause then
3620 Analyze_Use_Type (Item, Chain);
3624 elsif Nkind (Item) = N_Pragma then
3632 if Is_Child_Spec (Lib_Unit) then
3634 -- The unit also has implicit with_clauses on its own parents
3636 if No (Context_Items (N)) then
3637 Set_Context_Items (N, New_List);
3640 Implicit_With_On_Parent (Lib_Unit, N);
3643 -- If the unit is a body, the context of the specification must also
3644 -- be installed. That includes private with_clauses in that context.
3646 if Nkind (Lib_Unit) = N_Package_Body
3647 or else (Nkind (Lib_Unit) = N_Subprogram_Body
3648 and then not Acts_As_Spec (N))
3650 Install_Context (Library_Unit (N), Chain);
3652 -- Only install private with-clauses of a spec that comes from
3653 -- source, excluding specs created for a subprogram body that is
3656 if Comes_From_Source (Library_Unit (N)) then
3657 Install_Private_With_Clauses
3658 (Defining_Entity (Unit (Library_Unit (N))));
3661 if Is_Child_Spec (Unit (Library_Unit (N))) then
3663 -- If the unit is the body of a public child unit, the private
3664 -- declarations of the parent must be made visible. If the child
3665 -- unit is private, the private declarations have been installed
3666 -- already in the call to Install_Parents for the spec. Installing
3667 -- private declarations must be done for all ancestors of public
3668 -- child units. In addition, sibling units mentioned in the
3669 -- context clause of the body are directly visible.
3677 Lib_Spec := Unit (Library_Unit (N));
3678 while Is_Child_Spec (Lib_Spec) loop
3679 P := Unit (Parent_Spec (Lib_Spec));
3680 P_Name := Defining_Entity (P);
3682 if not (Private_Present (Parent (Lib_Spec)))
3683 and then not In_Private_Part (P_Name)
3685 Install_Private_Declarations (P_Name);
3686 Install_Private_With_Clauses (P_Name);
3687 Set_Use (Private_Declarations (Specification (P)));
3695 -- For a package body, children in context are immediately visible
3697 Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
3700 if Nkind_In (Lib_Unit, N_Generic_Package_Declaration,
3701 N_Generic_Subprogram_Declaration,
3702 N_Package_Declaration,
3703 N_Subprogram_Declaration)
3705 if Is_Child_Spec (Lib_Unit) then
3706 Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
3707 Set_Is_Private_Descendant
3708 (Defining_Entity (Lib_Unit),
3709 Is_Private_Descendant (Lib_Parent)
3710 or else Private_Present (Parent (Lib_Unit)));
3713 Set_Is_Private_Descendant
3714 (Defining_Entity (Lib_Unit),
3715 Private_Present (Parent (Lib_Unit)));
3719 if Check_Private then
3720 Check_Private_Child_Unit (N);
3722 end Install_Context_Clauses;
3724 -------------------------------------
3725 -- Install_Limited_Context_Clauses --
3726 -------------------------------------
3728 procedure Install_Limited_Context_Clauses (N : Node_Id) is
3731 procedure Check_Renamings (P : Node_Id; W : Node_Id);
3732 -- Check that the unlimited view of a given compilation_unit is not
3733 -- already visible through "use + renamings".
3735 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
3736 -- Check that if a limited_with clause of a given compilation_unit
3737 -- mentions a descendant of a private child of some library unit, then
3738 -- the given compilation_unit must be the declaration of a private
3739 -- descendant of that library unit, or a public descendant of such. The
3740 -- code is analogous to that of Check_Private_Child_Unit but we cannot
3741 -- use entities on the limited with_clauses because their units have not
3742 -- been analyzed, so we have to climb the tree of ancestors looking for
3743 -- private keywords.
3745 procedure Expand_Limited_With_Clause
3746 (Comp_Unit : Node_Id;
3749 -- If a child unit appears in a limited_with clause, there are implicit
3750 -- limited_with clauses on all parents that are not already visible
3751 -- through a regular with clause. This procedure creates the implicit
3752 -- limited with_clauses for the parents and loads the corresponding
3753 -- units. The shadow entities are created when the inserted clause is
3754 -- analyzed. Implements Ada 2005 (AI-50217).
3756 ---------------------
3757 -- Check_Renamings --
3758 ---------------------
3760 procedure Check_Renamings (P : Node_Id; W : Node_Id) is
3768 pragma Assert (Nkind (W) = N_With_Clause);
3770 -- Protect the frontend against previous critical errors
3772 case Nkind (Unit (Library_Unit (W))) is
3773 when N_Generic_Package_Declaration
3774 | N_Generic_Subprogram_Declaration
3775 | N_Package_Declaration
3776 | N_Subprogram_Declaration
3784 -- Check "use + renamings"
3786 WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
3787 Spec := Specification (Unit (P));
3789 Item := First (Visible_Declarations (Spec));
3790 while Present (Item) loop
3792 -- Look only at use package clauses
3794 if Nkind (Item) = N_Use_Package_Clause then
3796 E := Entity (Name (Item));
3798 pragma Assert (Present (Parent (E)));
3800 if Nkind (Parent (E)) = N_Package_Renaming_Declaration
3801 and then Renamed_Entity (E) = WEnt
3803 -- The unlimited view is visible through use clause and
3804 -- renamings. There is no need to generate the error
3805 -- message here because Is_Visible_Through_Renamings
3806 -- takes care of generating the precise error message.
3810 elsif Nkind (Parent (E)) = N_Package_Specification then
3812 -- The use clause may refer to a local package.
3813 -- Check all the enclosing scopes.
3816 while E2 /= Standard_Standard and then E2 /= WEnt loop
3822 ("unlimited view visible through use clause ", W);
3831 -- Recursive call to check all the ancestors
3833 if Is_Child_Spec (Unit (P)) then
3834 Check_Renamings (P => Parent_Spec (Unit (P)), W => W);
3836 end Check_Renamings;
3838 ---------------------------------------
3839 -- Check_Private_Limited_Withed_Unit --
3840 ---------------------------------------
3842 procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is
3843 Curr_Parent : Node_Id;
3844 Child_Parent : Node_Id;
3845 Curr_Private : Boolean;
3848 -- Compilation unit of the parent of the withed library unit
3850 Child_Parent := Library_Unit (Item);
3852 -- If the child unit is a public child, then locate its nearest
3853 -- private ancestor, if any, then Child_Parent will then be set to
3854 -- the parent of that ancestor.
3856 if not Private_Present (Library_Unit (Item)) then
3857 while Present (Child_Parent)
3858 and then not Private_Present (Child_Parent)
3860 Child_Parent := Parent_Spec (Unit (Child_Parent));
3863 if No (Child_Parent) then
3868 Child_Parent := Parent_Spec (Unit (Child_Parent));
3870 -- Traverse all the ancestors of the current compilation unit to
3871 -- check if it is a descendant of named library unit.
3873 Curr_Parent := Parent (Item);
3874 Curr_Private := Private_Present (Curr_Parent);
3876 while Present (Parent_Spec (Unit (Curr_Parent)))
3877 and then Curr_Parent /= Child_Parent
3879 Curr_Parent := Parent_Spec (Unit (Curr_Parent));
3880 Curr_Private := Curr_Private or else Private_Present (Curr_Parent);
3883 if Curr_Parent /= Child_Parent then
3885 ("unit in with clause is private child unit!", Item);
3887 ("\current unit must also have parent&!",
3888 Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3890 elsif Private_Present (Parent (Item))
3891 or else Curr_Private
3892 or else Private_Present (Item)
3893 or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
3897 -- Current unit is private, of descendant of a private unit
3903 ("current unit must also be private descendant of&",
3904 Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
3906 end Check_Private_Limited_Withed_Unit;
3908 --------------------------------
3909 -- Expand_Limited_With_Clause --
3910 --------------------------------
3912 procedure Expand_Limited_With_Clause
3913 (Comp_Unit : Node_Id;
3917 Loc : constant Source_Ptr := Sloc (Nam);
3918 Unum : Unit_Number_Type;
3921 function Previous_Withed_Unit (W : Node_Id) return Boolean;
3922 -- Returns true if the context already includes a with_clause for
3923 -- this unit. If the with_clause is nonlimited, the unit is fully
3924 -- visible and an implicit limited_with should not be created. If
3925 -- there is already a limited_with clause for W, a second one is
3926 -- simply redundant.
3928 --------------------------
3929 -- Previous_Withed_Unit --
3930 --------------------------
3932 function Previous_Withed_Unit (W : Node_Id) return Boolean is
3936 -- A limited with_clause cannot appear in the same context_clause
3937 -- as a nonlimited with_clause which mentions the same library.
3939 Item := First (Context_Items (Comp_Unit));
3940 while Present (Item) loop
3941 if Nkind (Item) = N_With_Clause
3942 and then Library_Unit (Item) = Library_Unit (W)
3951 end Previous_Withed_Unit;
3953 -- Start of processing for Expand_Limited_With_Clause
3956 if Nkind (Nam) = N_Identifier then
3958 -- Create node for name of withed unit
3961 Make_With_Clause (Loc,
3962 Name => New_Copy (Nam));
3964 else pragma Assert (Nkind (Nam) = N_Selected_Component);
3966 Make_With_Clause (Loc,
3967 Name => Make_Selected_Component (Loc,
3968 Prefix => New_Copy_Tree (Prefix (Nam)),
3969 Selector_Name => New_Copy (Selector_Name (Nam))));
3970 Set_Parent (Withn, Parent (N));
3973 Set_First_Name (Withn);
3974 Set_Implicit_With (Withn);
3975 Set_Limited_Present (Withn);
3979 (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
3984 -- Do not generate a limited_with_clause on the current unit. This
3985 -- path is taken when a unit has a limited_with clause on one of its
3988 if Unum = Current_Sem_Unit then
3992 Set_Library_Unit (Withn, Cunit (Unum));
3993 Set_Corresponding_Spec
3994 (Withn, Specification (Unit (Cunit (Unum))));
3996 if not Previous_Withed_Unit (Withn) then
3997 Prepend (Withn, Context_Items (Parent (N)));
3998 Mark_Rewrite_Insertion (Withn);
4000 -- Add implicit limited_with_clauses for parents of child units
4001 -- mentioned in limited_with clauses.
4003 if Nkind (Nam) = N_Selected_Component then
4004 Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
4009 if not Limited_View_Installed (Withn) then
4010 Install_Limited_With_Clause (Withn);
4013 end Expand_Limited_With_Clause;
4015 -- Start of processing for Install_Limited_Context_Clauses
4018 Item := First (Context_Items (N));
4019 while Present (Item) loop
4020 if Nkind (Item) = N_With_Clause
4021 and then Limited_Present (Item)
4022 and then not Error_Posted (Item)
4024 if Nkind (Name (Item)) = N_Selected_Component then
4025 Expand_Limited_With_Clause
4026 (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item);
4029 Check_Private_Limited_Withed_Unit (Item);
4031 if not Implicit_With (Item) and then Is_Child_Spec (Unit (N)) then
4032 Check_Renamings (Parent_Spec (Unit (N)), Item);
4035 -- A unit may have a limited with on itself if it has a limited
4036 -- with_clause on one of its child units. In that case it is
4037 -- already being compiled and it makes no sense to install its
4040 -- If the item is a limited_private_with_clause, install it if the
4041 -- current unit is a body or if it is a private child. Otherwise
4042 -- the private clause is installed before analyzing the private
4043 -- part of the current unit.
4045 if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
4046 and then not Limited_View_Installed (Item)
4048 not Is_Ancestor_Unit
4049 (Library_Unit (Item), Cunit (Current_Sem_Unit))
4051 if not Private_Present (Item)
4052 or else Private_Present (N)
4053 or else Nkind_In (Unit (N), N_Package_Body,
4057 Install_Limited_With_Clause (Item);
4065 -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
4066 -- looking for incomplete subtype declarations of incomplete types
4067 -- visible through a limited with clause.
4069 if Ada_Version >= Ada_2005
4070 and then Analyzed (N)
4071 and then Nkind (Unit (N)) = N_Package_Declaration
4076 Non_Lim_View : Entity_Id;
4079 Decl := First (Visible_Declarations (Specification (Unit (N))));
4080 while Present (Decl) loop
4081 if Nkind (Decl) = N_Subtype_Declaration
4083 Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype
4085 From_Limited_With (Defining_Identifier (Decl))
4087 Def_Id := Defining_Identifier (Decl);
4088 Non_Lim_View := Non_Limited_View (Def_Id);
4090 if not Is_Incomplete_Type (Non_Lim_View) then
4092 -- Convert an incomplete subtype declaration into a
4093 -- corresponding nonlimited view subtype declaration.
4094 -- This is usually the case when analyzing a body that
4095 -- has regular with clauses, when the spec has limited
4098 -- If the nonlimited view is still incomplete, it is
4099 -- the dummy entry already created, and the declaration
4100 -- cannot be reanalyzed. This is the case when installing
4101 -- a parent unit that has limited with-clauses.
4103 Set_Subtype_Indication (Decl,
4104 New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id)));
4105 Set_Etype (Def_Id, Non_Lim_View);
4106 Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
4107 Set_Analyzed (Decl, False);
4109 -- Reanalyze the declaration, suppressing the call to
4110 -- Enter_Name to avoid duplicate names.
4112 Analyze_Subtype_Declaration
4122 end Install_Limited_Context_Clauses;
4124 ---------------------
4125 -- Install_Parents --
4126 ---------------------
4128 procedure Install_Parents
4129 (Lib_Unit : Node_Id;
4130 Is_Private : Boolean;
4131 Chain : Boolean := True)
4139 P := Unit (Parent_Spec (Lib_Unit));
4140 P_Name := Get_Parent_Entity (P);
4142 if Etype (P_Name) = Any_Type then
4146 if Ekind (P_Name) = E_Generic_Package
4147 and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration,
4148 N_Generic_Package_Declaration)
4149 and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
4152 ("child of a generic package must be a generic unit", Lib_Unit);
4154 elsif not Is_Package_Or_Generic_Package (P_Name) then
4156 ("parent unit must be package or generic package", Lib_Unit);
4157 raise Unrecoverable_Error;
4159 elsif Present (Renamed_Object (P_Name)) then
4160 Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
4161 raise Unrecoverable_Error;
4163 -- Verify that a child of an instance is itself an instance, or the
4164 -- renaming of one. Given that an instance that is a unit is replaced
4165 -- with a package declaration, check against the original node. The
4166 -- parent may be currently being instantiated, in which case it appears
4167 -- as a declaration, but the generic_parent is already established
4168 -- indicating that we deal with an instance.
4170 elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
4171 if Nkind (Lib_Unit) in N_Renaming_Declaration
4172 or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
4174 (Nkind (Lib_Unit) = N_Package_Declaration
4175 and then Present (Generic_Parent (Specification (Lib_Unit))))
4180 ("child of an instance must be an instance or renaming",
4185 -- This is the recursive call that ensures all parents are loaded
4187 if Is_Child_Spec (P) then
4191 Is_Private or else Private_Present (Parent (Lib_Unit)),
4195 -- Now we can install the context for this parent
4197 Install_Context_Clauses (Parent_Spec (Lib_Unit), Chain);
4198 Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit));
4199 Install_Siblings (P_Name, Parent (Lib_Unit));
4201 -- The child unit is in the declarative region of the parent. The parent
4202 -- must therefore appear in the scope stack and be visible, as when
4203 -- compiling the corresponding body. If the child unit is private or it
4204 -- is a package body, private declarations must be accessible as well.
4205 -- Use declarations in the parent must also be installed. Finally, other
4206 -- child units of the same parent that are in the context are
4207 -- immediately visible.
4209 -- Find entity for compilation unit, and set its private descendant
4210 -- status as needed. Indicate that it is a compilation unit, which is
4211 -- redundant in general, but needed if this is a generated child spec
4212 -- for a child body without previous spec.
4214 E_Name := Defining_Entity (Lib_Unit);
4216 Set_Is_Child_Unit (E_Name);
4217 Set_Is_Compilation_Unit (E_Name);
4219 Set_Is_Private_Descendant (E_Name,
4220 Is_Private_Descendant (P_Name)
4221 or else Private_Present (Parent (Lib_Unit)));
4223 P_Spec := Package_Specification (P_Name);
4224 Push_Scope (P_Name);
4226 -- Save current visibility of unit
4228 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
4229 Is_Immediately_Visible (P_Name);
4230 Set_Is_Immediately_Visible (P_Name);
4231 Install_Visible_Declarations (P_Name);
4232 Set_Use (Visible_Declarations (P_Spec));
4234 -- If the parent is a generic unit, its formal part may contain formal
4235 -- packages and use clauses for them.
4237 if Ekind (P_Name) = E_Generic_Package then
4238 Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
4241 if Is_Private or else Private_Present (Parent (Lib_Unit)) then
4242 Install_Private_Declarations (P_Name);
4243 Install_Private_With_Clauses (P_Name);
4244 Set_Use (Private_Declarations (P_Spec));
4246 end Install_Parents;
4248 ----------------------------------
4249 -- Install_Private_With_Clauses --
4250 ----------------------------------
4252 procedure Install_Private_With_Clauses (P : Entity_Id) is
4253 Decl : constant Node_Id := Unit_Declaration_Node (P);
4257 if Debug_Flag_I then
4258 Write_Str ("install private with clauses of ");
4259 Write_Name (Chars (P));
4263 if Nkind (Parent (Decl)) = N_Compilation_Unit then
4264 Item := First (Context_Items (Parent (Decl)));
4265 while Present (Item) loop
4266 if Nkind (Item) = N_With_Clause
4267 and then Private_Present (Item)
4269 -- If the unit is an ancestor of the current one, it is the
4270 -- case of a private limited with clause on a child unit, and
4271 -- the compilation of one of its descendants, In that case the
4272 -- limited view is errelevant.
4274 if Limited_Present (Item) then
4275 if not Limited_View_Installed (Item)
4277 not Is_Ancestor_Unit (Library_Unit (Item),
4278 Cunit (Current_Sem_Unit))
4280 Install_Limited_With_Clause (Item);
4283 Install_With_Clause (Item, Private_With_OK => True);
4290 end Install_Private_With_Clauses;
4292 ----------------------
4293 -- Install_Siblings --
4294 ----------------------
4296 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
4302 -- Iterate over explicit with clauses, and check whether the scope of
4303 -- each entity is an ancestor of the current unit, in which case it is
4304 -- immediately visible.
4306 Item := First (Context_Items (N));
4307 while Present (Item) loop
4309 -- Do not install private_with_clauses declaration, unless unit
4310 -- is itself a private child unit, or is a body. Note that for a
4311 -- subprogram body the private_with_clause does not take effect
4312 -- until after the specification.
4314 if Nkind (Item) /= N_With_Clause
4315 or else Implicit_With (Item)
4316 or else Limited_Present (Item)
4317 or else Error_Posted (Item)
4319 -- Skip processing malformed trees
4321 or else (Try_Semantics
4322 and then Nkind (Name (Item)) not in N_Has_Entity)
4326 elsif not Private_Present (Item)
4327 or else Private_Present (N)
4328 or else Nkind (Unit (N)) = N_Package_Body
4330 Id := Entity (Name (Item));
4332 if Is_Child_Unit (Id)
4333 and then Is_Ancestor_Package (Scope (Id), U_Name)
4335 Set_Is_Immediately_Visible (Id);
4337 -- Check for the presence of another unit in the context that
4338 -- may be inadvertently hidden by the child.
4340 Prev := Current_Entity (Id);
4343 and then Is_Immediately_Visible (Prev)
4344 and then not Is_Child_Unit (Prev)
4350 Clause := First (Context_Items (N));
4351 while Present (Clause) loop
4352 if Nkind (Clause) = N_With_Clause
4353 and then Entity (Name (Clause)) = Prev
4356 ("child unit& hides compilation unit " &
4357 "with the same name??",
4367 -- The With_Clause may be on a grandchild or one of its further
4368 -- descendants, which makes a child immediately visible. Examine
4369 -- ancestry to determine whether such a child exists. For example,
4370 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4371 -- is immediately visible.
4373 elsif Is_Child_Unit (Id) then
4379 while Is_Child_Unit (Par) loop
4380 if Is_Ancestor_Package (Scope (Par), U_Name) then
4381 Set_Is_Immediately_Visible (Par);
4390 -- If the item is a private with-clause on a child unit, the parent
4391 -- may have been installed already, but the child unit must remain
4392 -- invisible until installed in a private part or body, unless there
4393 -- is already a regular with_clause for it in the current unit.
4395 elsif Private_Present (Item) then
4396 Id := Entity (Name (Item));
4398 if Is_Child_Unit (Id) then
4402 function In_Context return Boolean;
4403 -- Scan context of current unit, to check whether there is
4404 -- a with_clause on the same unit as a private with-clause
4405 -- on a parent, in which case child unit is visible. If the
4406 -- unit is a grandchild, the same applies to its parent.
4412 function In_Context return Boolean is
4415 First (Context_Items (Cunit (Current_Sem_Unit)));
4416 while Present (Clause) loop
4417 if Nkind (Clause) = N_With_Clause
4418 and then Comes_From_Source (Clause)
4419 and then Is_Entity_Name (Name (Clause))
4420 and then not Private_Present (Clause)
4422 if Entity (Name (Clause)) = Id
4424 (Nkind (Name (Clause)) = N_Expanded_Name
4425 and then Entity (Prefix (Name (Clause))) = Id)
4438 Set_Is_Visible_Lib_Unit (Id, In_Context);
4445 end Install_Siblings;
4447 ---------------------------------
4448 -- Install_Limited_With_Clause --
4449 ---------------------------------
4451 procedure Install_Limited_With_Clause (N : Node_Id) is
4452 P_Unit : constant Entity_Id := Unit (Library_Unit (N));
4455 Is_Child_Package : Boolean := False;
4456 Lim_Header : Entity_Id;
4457 Lim_Typ : Entity_Id;
4459 procedure Check_Body_Required;
4460 -- A unit mentioned in a limited with_clause may not be mentioned in
4461 -- a regular with_clause, but must still be included in the current
4462 -- partition. We need to determine whether the unit needs a body, so
4463 -- that the binder can determine the name of the file to be compiled.
4464 -- Checking whether a unit needs a body can be done without semantic
4465 -- analysis, by examining the nature of the declarations in the package.
4467 function Has_Limited_With_Clause
4468 (C_Unit : Entity_Id;
4469 Pack : Entity_Id) return Boolean;
4470 -- Determine whether any package in the ancestor chain starting with
4471 -- C_Unit has a limited with clause for package Pack.
4473 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
4474 -- Check if some package installed though normal with-clauses has a
4475 -- renaming declaration of package P. AARM 10.1.2(21/2).
4477 -------------------------
4478 -- Check_Body_Required --
4479 -------------------------
4481 procedure Check_Body_Required is
4482 PA : constant List_Id :=
4483 Pragmas_After (Aux_Decls_Node (Parent (P_Unit)));
4485 procedure Check_Declarations (Spec : Node_Id);
4486 -- Recursive procedure that does the work and checks nested packages
4488 ------------------------
4489 -- Check_Declarations --
4490 ------------------------
4492 procedure Check_Declarations (Spec : Node_Id) is
4494 Incomplete_Decls : constant Elist_Id := New_Elmt_List;
4496 Subp_List : constant Elist_Id := New_Elmt_List;
4498 procedure Check_Pragma_Import (P : Node_Id);
4499 -- If a pragma import applies to a previous subprogram, the
4500 -- enclosing unit may not need a body. The processing is syntactic
4501 -- and does not require a declaration to be analyzed. The code
4502 -- below also handles pragma Import when applied to a subprogram
4503 -- that renames another. In this case the pragma applies to the
4506 -- Chains of multiple renames are not handled by the code below.
4507 -- It is probably impossible to handle all cases without proper
4508 -- name resolution. In such cases the algorithm is conservative
4509 -- and will indicate that a body is needed???
4511 -------------------------
4512 -- Check_Pragma_Import --
4513 -------------------------
4515 procedure Check_Pragma_Import (P : Node_Id) is
4521 procedure Remove_Homonyms (E : Node_Id);
4522 -- Make one pass over list of subprograms. Called again if
4523 -- subprogram is a renaming. E is known to be an identifier.
4525 ---------------------
4526 -- Remove_Homonyms --
4527 ---------------------
4529 procedure Remove_Homonyms (E : Node_Id) is
4530 R : Entity_Id := Empty;
4531 -- Name of renamed entity, if any
4534 Subp_Id := First_Elmt (Subp_List);
4535 while Present (Subp_Id) loop
4536 if Chars (Node (Subp_Id)) = Chars (E) then
4537 if Nkind (Parent (Parent (Node (Subp_Id))))
4538 /= N_Subprogram_Renaming_Declaration
4541 Next_Elmt (Subp_Id);
4542 Remove_Elmt (Subp_List, Prev_Id);
4544 R := Name (Parent (Parent (Node (Subp_Id))));
4548 Next_Elmt (Subp_Id);
4553 if Nkind (R) = N_Identifier then
4554 Remove_Homonyms (R);
4556 elsif Nkind (R) = N_Selected_Component then
4557 Remove_Homonyms (Selector_Name (R));
4559 -- Renaming of attribute
4565 end Remove_Homonyms;
4567 -- Start of processing for Check_Pragma_Import
4570 -- Find name of entity in Import pragma. We have not analyzed
4571 -- the construct, so we must guard against syntax errors.
4573 Arg := Next (First (Pragma_Argument_Associations (P)));
4576 or else Nkind (Expression (Arg)) /= N_Identifier
4580 Imported := Expression (Arg);
4583 Remove_Homonyms (Imported);
4584 end Check_Pragma_Import;
4586 -- Start of processing for Check_Declarations
4589 -- Search for Elaborate Body pragma
4591 Decl := First (Visible_Declarations (Spec));
4592 while Present (Decl)
4593 and then Nkind (Decl) = N_Pragma
4595 if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then
4596 Set_Body_Required (Library_Unit (N));
4603 -- Look for declarations that require the presence of a body. We
4604 -- have already skipped pragmas at the start of the list.
4606 while Present (Decl) loop
4608 -- Subprogram that comes from source means body may be needed.
4609 -- Save for subsequent examination of import pragmas.
4611 if Comes_From_Source (Decl)
4612 and then (Nkind_In (Decl, N_Subprogram_Declaration,
4613 N_Subprogram_Renaming_Declaration,
4614 N_Generic_Subprogram_Declaration))
4616 Append_Elmt (Defining_Entity (Decl), Subp_List);
4618 -- Package declaration of generic package declaration. We need
4619 -- to recursively examine nested declarations.
4621 elsif Nkind_In (Decl, N_Package_Declaration,
4622 N_Generic_Package_Declaration)
4624 Check_Declarations (Specification (Decl));
4626 elsif Nkind (Decl) = N_Pragma
4627 and then Pragma_Name (Decl) = Name_Import
4629 Check_Pragma_Import (Decl);
4635 -- Same set of tests for private part. In addition to subprograms
4636 -- detect the presence of Taft Amendment types (incomplete types
4637 -- completed in the body).
4639 Decl := First (Private_Declarations (Spec));
4640 while Present (Decl) loop
4641 if Comes_From_Source (Decl)
4642 and then (Nkind_In (Decl, N_Subprogram_Declaration,
4643 N_Subprogram_Renaming_Declaration,
4644 N_Generic_Subprogram_Declaration))
4646 Append_Elmt (Defining_Entity (Decl), Subp_List);
4648 elsif Nkind_In (Decl, N_Package_Declaration,
4649 N_Generic_Package_Declaration)
4651 Check_Declarations (Specification (Decl));
4653 -- Collect incomplete type declarations for separate pass
4655 elsif Nkind (Decl) = N_Incomplete_Type_Declaration then
4656 Append_Elmt (Decl, Incomplete_Decls);
4658 elsif Nkind (Decl) = N_Pragma
4659 and then Pragma_Name (Decl) = Name_Import
4661 Check_Pragma_Import (Decl);
4667 -- Now check incomplete declarations to locate Taft amendment
4668 -- types. This can be done by examining the defining identifiers
4669 -- of type declarations without real semantic analysis.
4675 Inc := First_Elmt (Incomplete_Decls);
4676 while Present (Inc) loop
4677 Decl := Next (Node (Inc));
4678 while Present (Decl) loop
4679 if Nkind (Decl) = N_Full_Type_Declaration
4680 and then Chars (Defining_Identifier (Decl)) =
4681 Chars (Defining_Identifier (Node (Inc)))
4689 -- If no completion, this is a TAT, and a body is needed
4692 Set_Body_Required (Library_Unit (N));
4700 -- Finally, check whether there are subprograms that still require
4701 -- a body, i.e. are not renamings or null.
4703 if not Is_Empty_Elmt_List (Subp_List) then
4709 Subp_Id := First_Elmt (Subp_List);
4710 Spec := Parent (Node (Subp_Id));
4712 while Present (Subp_Id) loop
4713 if Nkind (Parent (Spec))
4714 = N_Subprogram_Renaming_Declaration
4718 elsif Nkind (Spec) = N_Procedure_Specification
4719 and then Null_Present (Spec)
4724 Set_Body_Required (Library_Unit (N));
4728 Next_Elmt (Subp_Id);
4732 end Check_Declarations;
4734 -- Start of processing for Check_Body_Required
4737 -- If this is an imported package (Java and CIL usage) no body is
4738 -- needed. Scan list of pragmas that may follow a compilation unit
4739 -- to look for a relevant pragma Import.
4741 if Present (PA) then
4747 while Present (Prag) loop
4748 if Nkind (Prag) = N_Pragma
4749 and then Get_Pragma_Id (Prag) = Pragma_Import
4759 Check_Declarations (Specification (P_Unit));
4760 end Check_Body_Required;
4762 -----------------------------
4763 -- Has_Limited_With_Clause --
4764 -----------------------------
4766 function Has_Limited_With_Clause
4767 (C_Unit : Entity_Id;
4768 Pack : Entity_Id) return Boolean
4775 while Present (Par) loop
4776 if Ekind (Par) /= E_Package then
4780 -- Retrieve the Compilation_Unit node for Par and determine if
4781 -- its context clauses contain a limited with for Pack.
4783 Par_Unit := Parent (Parent (Parent (Par)));
4785 if Nkind (Par_Unit) = N_Package_Declaration then
4786 Par_Unit := Parent (Par_Unit);
4789 if Has_With_Clause (Par_Unit, Pack, True) then
4793 -- If there are more ancestors, climb up the tree, otherwise we
4796 if Is_Child_Unit (Par) then
4804 end Has_Limited_With_Clause;
4806 ----------------------------------
4807 -- Is_Visible_Through_Renamings --
4808 ----------------------------------
4810 function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
4811 Kind : constant Node_Kind :=
4812 Nkind (Unit (Cunit (Current_Sem_Unit)));
4818 -- Example of the error detected by this subprogram:
4826 -- package Ren_P renames P;
4832 -- limited with P; -- ERROR
4833 -- package R.C is ...
4835 Aux_Unit := Cunit (Current_Sem_Unit);
4838 Item := First (Context_Items (Aux_Unit));
4839 while Present (Item) loop
4840 if Nkind (Item) = N_With_Clause
4841 and then not Limited_Present (Item)
4842 and then Nkind (Unit (Library_Unit (Item))) =
4843 N_Package_Declaration
4846 First (Visible_Declarations
4847 (Specification (Unit (Library_Unit (Item)))));
4848 while Present (Decl) loop
4849 if Nkind (Decl) = N_Package_Renaming_Declaration
4850 and then Entity (Name (Decl)) = P
4852 -- Generate the error message only if the current unit
4853 -- is a package declaration; in case of subprogram
4854 -- bodies and package bodies we just return True to
4855 -- indicate that the limited view must not be
4858 if Kind = N_Package_Declaration then
4860 ("simultaneous visibility of the limited and " &
4861 "unlimited views not allowed", N);
4862 Error_Msg_Sloc := Sloc (Item);
4864 ("\\ unlimited view of & visible through the " &
4865 "context clause #", N, P);
4866 Error_Msg_Sloc := Sloc (Decl);
4867 Error_Msg_NE ("\\ and the renaming #", N, P);
4880 -- If it is a body not acting as spec, follow pointer to the
4881 -- corresponding spec, otherwise follow pointer to parent spec.
4883 if Present (Library_Unit (Aux_Unit))
4884 and then Nkind_In (Unit (Aux_Unit),
4885 N_Package_Body, N_Subprogram_Body)
4887 if Aux_Unit = Library_Unit (Aux_Unit) then
4889 -- Aux_Unit is a body that acts as a spec. Clause has
4890 -- already been flagged as illegal.
4895 Aux_Unit := Library_Unit (Aux_Unit);
4899 Aux_Unit := Parent_Spec (Unit (Aux_Unit));
4902 exit when No (Aux_Unit);
4906 end Is_Visible_Through_Renamings;
4908 -- Start of processing for Install_Limited_With_Clause
4911 pragma Assert (not Limited_View_Installed (N));
4913 -- In case of limited with_clause on subprograms, generics, instances,
4914 -- or renamings, the corresponding error was previously posted and we
4915 -- have nothing to do here. If the file is missing altogether, it has
4916 -- no source location.
4918 if Nkind (P_Unit) /= N_Package_Declaration
4919 or else Sloc (P_Unit) = No_Location
4924 P := Defining_Unit_Name (Specification (P_Unit));
4926 -- Handle child packages
4928 if Nkind (P) = N_Defining_Program_Unit_Name then
4929 Is_Child_Package := True;
4930 P := Defining_Identifier (P);
4933 -- Do not install the limited-view if the context of the unit is already
4934 -- available through a regular with clause.
4936 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4937 and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
4942 -- Do not install the limited-view if the full-view is already visible
4943 -- through renaming declarations.
4945 if Is_Visible_Through_Renamings (P) then
4949 -- Do not install the limited view if this is the unit being analyzed.
4950 -- This unusual case will happen when a unit has a limited_with clause
4951 -- on one of its children. The compilation of the child forces the load
4952 -- of the parent which tries to install the limited view of the child
4953 -- again. Installing the limited view must also be disabled when
4954 -- compiling the body of the child unit.
4956 if P = Cunit_Entity (Current_Sem_Unit)
4957 or else (Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4958 and then P = Main_Unit_Entity
4959 and then Is_Ancestor_Unit
4960 (Cunit (Main_Unit), Cunit (Current_Sem_Unit)))
4965 -- This scenario is similar to the one above, the difference is that the
4966 -- compilation of sibling Par.Sib forces the load of parent Par which
4967 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
4968 -- has a with clause for Lim_Pack [2] in its body, and thus needs the
4969 -- nonlimited views of all entities from Lim_Pack.
4971 -- limited with Lim_Pack; -- [1]
4972 -- package Par is ... package Lim_Pack is ...
4974 -- with Lim_Pack; -- [2]
4975 -- package Par.Sib is ... package body Par.Sib is ...
4977 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
4978 -- Sem_Unit is the body of Par.Sib.
4980 if Ekind (P) = E_Package
4981 and then Ekind (Main_Unit_Entity) = E_Package
4982 and then Is_Child_Unit (Main_Unit_Entity)
4984 -- The body has a regular with clause
4986 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
4987 and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
4989 -- One of the ancestors has a limited with clause
4991 and then Nkind (Parent (Parent (Main_Unit_Entity))) =
4992 N_Package_Specification
4993 and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P)
4998 -- A common use of the limited-with is to have a limited-with in the
4999 -- package spec, and a normal with in its package body. For example:
5001 -- limited with X; -- [1]
5005 -- package body A is ...
5007 -- The compilation of A's body installs the context clauses found at [2]
5008 -- and then the context clauses of its specification (found at [1]). As
5009 -- a consequence, at [1] the specification of X has been analyzed and it
5010 -- is immediately visible. According to the semantics of limited-with
5011 -- context clauses we don't install the limited view because the full
5012 -- view of X supersedes its limited view.
5014 if Analyzed (P_Unit)
5016 (Is_Immediately_Visible (P)
5017 or else (Is_Child_Package and then Is_Visible_Lib_Unit (P)))
5020 -- The presence of both the limited and the analyzed nonlimited view
5021 -- may also be an error, such as an illegal context for a limited
5022 -- with_clause. In that case, do not process the context item at all.
5024 if Error_Posted (N) then
5028 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
5032 Item := First (Context_Items (Cunit (Current_Sem_Unit)));
5033 while Present (Item) loop
5034 if Nkind (Item) = N_With_Clause
5035 and then Comes_From_Source (Item)
5036 and then Entity (Name (Item)) = P
5045 -- If this is a child body, assume that the nonlimited with_clause
5046 -- appears in an ancestor. Could be refined ???
5050 (Unit (Library_Unit (Cunit (Current_Sem_Unit)))))
5057 -- If in package declaration, nonlimited view brought in from
5058 -- parent unit or some error condition.
5064 if Debug_Flag_I then
5065 Write_Str ("install limited view of ");
5066 Write_Name (Chars (P));
5070 -- If the unit has not been analyzed and the limited view has not been
5071 -- already installed then we install it.
5073 if not Analyzed (P_Unit) then
5074 if not In_Chain (P) then
5076 -- Minimum decoration
5078 Set_Ekind (P, E_Package);
5079 Set_Etype (P, Standard_Void_Type);
5080 Set_Scope (P, Standard_Standard);
5081 Set_Is_Visible_Lib_Unit (P);
5083 if Is_Child_Package then
5084 Set_Is_Child_Unit (P);
5085 Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit))));
5088 -- Place entity on visibility structure
5090 Set_Homonym (P, Current_Entity (P));
5091 Set_Current_Entity (P);
5093 if Debug_Flag_I then
5094 Write_Str (" (homonym) chain ");
5095 Write_Name (Chars (P));
5099 -- Install the incomplete view. The first element of the limited
5100 -- view is a header (an E_Package entity) used to reference the
5101 -- first shadow entity in the private part of the package.
5103 Lim_Header := Limited_View (P);
5104 Lim_Typ := First_Entity (Lim_Header);
5106 while Present (Lim_Typ)
5107 and then Lim_Typ /= First_Private_Entity (Lim_Header)
5109 Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
5110 Set_Current_Entity (Lim_Typ);
5112 if Debug_Flag_I then
5113 Write_Str (" (homonym) chain ");
5114 Write_Name (Chars (Lim_Typ));
5118 Next_Entity (Lim_Typ);
5122 -- If the unit appears in a previous regular with_clause, the regular
5123 -- entities of the public part of the withed package must be replaced
5124 -- by the shadow ones.
5126 -- This code must be kept synchronized with the code that replaces the
5127 -- shadow entities by the real entities (see body of Remove_Limited
5128 -- With_Clause); otherwise the contents of the homonym chains are not
5132 -- Hide all the type entities of the public part of the package to
5133 -- avoid its usage. This is needed to cover all the subtype decla-
5134 -- rations because we do not remove them from the homonym chain.
5136 E := First_Entity (P);
5137 while Present (E) and then E /= First_Private_Entity (P) loop
5139 Set_Was_Hidden (E, Is_Hidden (E));
5146 -- Replace the real entities by the shadow entities of the limited
5147 -- view. The first element of the limited view is a header that is
5148 -- used to reference the first shadow entity in the private part
5149 -- of the package. Successive elements are the limited views of the
5150 -- type (including regular incomplete types) declared in the package.
5152 Lim_Header := Limited_View (P);
5154 Lim_Typ := First_Entity (Lim_Header);
5155 while Present (Lim_Typ)
5156 and then Lim_Typ /= First_Private_Entity (Lim_Header)
5158 pragma Assert (not In_Chain (Lim_Typ));
5160 -- Do not unchain nested packages and child units
5162 if Ekind (Lim_Typ) /= E_Package
5163 and then not Is_Child_Unit (Lim_Typ)
5169 Prev := Current_Entity (Lim_Typ);
5172 -- Replace E in the homonyms list, so that the limited view
5173 -- becomes available.
5175 -- If the nonlimited view is a record with an anonymous
5176 -- self-referential component, the analysis of the record
5177 -- declaration creates an incomplete type with the same name
5178 -- in order to define an internal access type. The visible
5179 -- entity is now the incomplete type, and that is the one to
5180 -- replace in the visibility structure.
5182 if E = Non_Limited_View (Lim_Typ)
5184 (Ekind (E) = E_Incomplete_Type
5185 and then Full_View (E) = Non_Limited_View (Lim_Typ))
5187 Set_Homonym (Lim_Typ, Homonym (Prev));
5188 Set_Current_Entity (Lim_Typ);
5192 E := Homonym (Prev);
5194 -- E may have been removed when installing a previous
5195 -- limited_with_clause.
5198 exit when E = Non_Limited_View (Lim_Typ);
5199 Prev := Homonym (Prev);
5203 Set_Homonym (Lim_Typ, Homonym (Homonym (Prev)));
5204 Set_Homonym (Prev, Lim_Typ);
5209 if Debug_Flag_I then
5210 Write_Str (" (homonym) chain ");
5211 Write_Name (Chars (Lim_Typ));
5216 Next_Entity (Lim_Typ);
5220 -- The package must be visible while the limited-with clause is active
5221 -- because references to the type P.T must resolve in the usual way.
5222 -- In addition, we remember that the limited-view has been installed to
5223 -- uninstall it at the point of context removal.
5225 Set_Is_Immediately_Visible (P);
5226 Set_Limited_View_Installed (N);
5228 -- If unit has not been analyzed in some previous context, check
5229 -- (imperfectly ???) whether it might need a body.
5231 if not Analyzed (P_Unit) then
5232 Check_Body_Required;
5235 -- If the package in the limited_with clause is a child unit, the clause
5236 -- is unanalyzed and appears as a selected component. Recast it as an
5237 -- expanded name so that the entity can be properly set. Use entity of
5238 -- parent, if available, for higher ancestors in the name.
5240 if Nkind (Name (N)) = N_Selected_Component then
5248 while Nkind (Nam) = N_Selected_Component
5249 and then Present (Ent)
5251 Change_Selected_Component_To_Expanded_Name (Nam);
5253 -- Set entity of parent identifiers if the unit is a child
5254 -- unit. This ensures that the tree is properly formed from
5255 -- semantic point of view. The unit entities are not fully
5256 -- analyzed, so we need to follow unit links in the tree.
5258 Set_Entity (Nam, Ent);
5260 Nam := Prefix (Nam);
5263 (Unit (Parent_Spec (Unit_Declaration_Node (Ent))));
5265 -- Set entity of last ancestor
5267 if Nkind (Nam) = N_Identifier then
5268 Set_Entity (Nam, Ent);
5274 Set_Entity (Name (N), P);
5275 Set_From_Limited_With (P);
5276 end Install_Limited_With_Clause;
5278 -------------------------
5279 -- Install_With_Clause --
5280 -------------------------
5282 procedure Install_With_Clause
5283 (With_Clause : Node_Id;
5284 Private_With_OK : Boolean := False)
5286 Uname : constant Entity_Id := Entity (Name (With_Clause));
5287 P : constant Entity_Id := Scope (Uname);
5290 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
5291 -- compiling a package declaration and the Private_With_OK flag was not
5292 -- set by the caller. These declarations will be installed later (before
5293 -- analyzing the private part of the package).
5295 if Private_Present (With_Clause)
5296 and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
5297 and then not (Private_With_OK)
5302 if Debug_Flag_I then
5303 if Private_Present (With_Clause) then
5304 Write_Str ("install private withed unit ");
5306 Write_Str ("install withed unit ");
5309 Write_Name (Chars (Uname));
5313 -- We do not apply the restrictions to an internal unit unless we are
5314 -- compiling the internal unit as a main unit. This check is also
5315 -- skipped for dummy units (for missing packages).
5317 if Sloc (Uname) /= No_Location
5318 and then (not Is_Internal_Unit (Current_Sem_Unit)
5319 or else Current_Sem_Unit = Main_Unit)
5321 Check_Restricted_Unit
5322 (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
5325 if P /= Standard_Standard then
5327 -- If the unit is not analyzed after analysis of the with clause and
5328 -- it is an instantiation then it awaits a body and is the main unit.
5329 -- Its appearance in the context of some other unit indicates a
5330 -- circular dependency (DEC suite perversity).
5332 if not Analyzed (Uname)
5333 and then Nkind (Parent (Uname)) = N_Package_Instantiation
5336 ("instantiation depends on itself", Name (With_Clause));
5338 elsif not Analyzed (Uname)
5339 and then Is_Internal_Unit (Current_Sem_Unit)
5340 and then not Is_Visible_Lib_Unit (Uname)
5341 and then No (Scope (Uname))
5343 if Is_Predefined_Unit (Current_Sem_Unit) then
5345 ("predefined unit depends on itself", Name (With_Clause));
5348 ("GNAT-defined unit depends on itself", Name (With_Clause));
5352 elsif not Is_Visible_Lib_Unit (Uname) then
5354 -- Abandon processing in case of previous errors
5356 if No (Scope (Uname)) then
5357 Check_Error_Detected;
5361 Set_Is_Visible_Lib_Unit (Uname);
5363 -- If the unit is a wrapper package for a compilation unit that is
5364 -- a subprogrm instance, indicate that the instance itself is a
5365 -- visible unit. This is necessary if the instance is inlined.
5367 if Is_Wrapper_Package (Uname) then
5368 Set_Is_Visible_Lib_Unit (Related_Instance (Uname));
5371 -- If the child unit appears in the context of its parent, it is
5372 -- immediately visible.
5374 if In_Open_Scopes (Scope (Uname)) then
5375 Set_Is_Immediately_Visible (Uname);
5378 if Is_Generic_Instance (Uname)
5379 and then Ekind (Uname) in Subprogram_Kind
5381 -- Set flag as well on the visible entity that denotes the
5382 -- instance, which renames the current one.
5384 Set_Is_Visible_Lib_Unit
5386 (Defining_Entity (Unit (Library_Unit (With_Clause)))));
5389 -- The parent unit may have been installed already, and may have
5390 -- appeared in a use clause.
5392 if In_Use (Scope (Uname)) then
5393 Set_Is_Potentially_Use_Visible (Uname);
5396 Set_Context_Installed (With_Clause);
5399 elsif not Is_Immediately_Visible (Uname) then
5400 Set_Is_Visible_Lib_Unit (Uname);
5402 if not Private_Present (With_Clause) or else Private_With_OK then
5403 Set_Is_Immediately_Visible (Uname);
5406 Set_Context_Installed (With_Clause);
5409 -- A [private] with clause overrides a limited with clause. Restore the
5410 -- proper view of the package by performing the following actions:
5412 -- * Remove all shadow entities which hide their corresponding
5413 -- entities from direct visibility by updating the entity and
5416 -- * Enter the corresponding entities back in direct visibility
5418 -- Note that the original limited with clause which installed its view
5419 -- is still marked as "active". This effect is undone when the clause
5420 -- itself is removed, see Remove_Limited_With_Clause.
5422 if Ekind (Uname) = E_Package and then From_Limited_With (Uname) then
5423 Remove_Limited_With_Unit (Unit_Declaration_Node (Uname));
5426 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5427 -- unit if there is a visible homograph for it declared in the same
5428 -- declarative region. This pathological case can only arise when an
5429 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5430 -- G1 has a generic child also named G2, and the context includes with_
5431 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
5432 -- of I1.G2 visible as well. If the child unit is named Standard, do
5433 -- not apply the check to the Standard package itself.
5435 if Is_Child_Unit (Uname)
5436 and then Is_Visible_Lib_Unit (Uname)
5437 and then Ada_Version >= Ada_2005
5440 Decl1 : constant Node_Id := Unit_Declaration_Node (P);
5446 U2 := Homonym (Uname);
5447 while Present (U2) and then U2 /= Standard_Standard loop
5449 Decl2 := Unit_Declaration_Node (P2);
5451 if Is_Child_Unit (U2) and then Is_Visible_Lib_Unit (U2) then
5452 if Is_Generic_Instance (P)
5453 and then Nkind (Decl1) = N_Package_Declaration
5454 and then Generic_Parent (Specification (Decl1)) = P2
5456 Error_Msg_N ("illegal with_clause", With_Clause);
5458 ("\child unit has visible homograph" &
5459 " (RM 8.3(26), 10.1.1(19))",
5463 elsif Is_Generic_Instance (P2)
5464 and then Nkind (Decl2) = N_Package_Declaration
5465 and then Generic_Parent (Specification (Decl2)) = P
5467 -- With_clause for child unit of instance appears before
5468 -- in the context. We want to place the error message on
5469 -- it, not on the generic child unit itself.
5472 Prev_Clause : Node_Id;
5475 Prev_Clause := First (List_Containing (With_Clause));
5476 while Entity (Name (Prev_Clause)) /= U2 loop
5480 pragma Assert (Present (Prev_Clause));
5481 Error_Msg_N ("illegal with_clause", Prev_Clause);
5483 ("\child unit has visible homograph" &
5484 " (RM 8.3(26), 10.1.1(19))",
5495 end Install_With_Clause;
5501 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
5502 K : constant Node_Kind := Nkind (Lib_Unit);
5505 return (K in N_Generic_Declaration or else
5506 K in N_Generic_Instantiation or else
5507 K in N_Generic_Renaming_Declaration or else
5508 K = N_Package_Declaration or else
5509 K = N_Package_Renaming_Declaration or else
5510 K = N_Subprogram_Declaration or else
5511 K = N_Subprogram_Renaming_Declaration)
5512 and then Present (Parent_Spec (Lib_Unit));
5515 ------------------------------------
5516 -- Is_Legal_Shadow_Entity_In_Body --
5517 ------------------------------------
5519 function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is
5520 C_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
5522 return Nkind (Unit (C_Unit)) = N_Package_Body
5525 (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
5526 end Is_Legal_Shadow_Entity_In_Body;
5528 ----------------------
5529 -- Is_Ancestor_Unit --
5530 ----------------------
5532 function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
5533 E1 : constant Entity_Id := Defining_Entity (Unit (U1));
5536 if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
5537 E2 := Defining_Entity (Unit (Library_Unit (U2)));
5538 return Is_Ancestor_Package (E1, E2);
5542 end Is_Ancestor_Unit;
5544 -----------------------
5545 -- Load_Needed_Body --
5546 -----------------------
5548 -- N is a generic unit named in a with clause, or else it is a unit that
5549 -- contains a generic unit or an inlined function. In order to perform an
5550 -- instantiation, the body of the unit must be present. If the unit itself
5551 -- is generic, we assume that an instantiation follows, and load & analyze
5552 -- the body unconditionally. This forces analysis of the spec as well.
5554 -- If the unit is not generic, but contains a generic unit, it is loaded on
5555 -- demand, at the point of instantiation (see ch12).
5557 procedure Load_Needed_Body
5560 Do_Analyze : Boolean := True)
5562 Body_Name : Unit_Name_Type;
5563 Unum : Unit_Number_Type;
5565 Save_Style_Check : constant Boolean := Opt.Style_Check;
5566 -- The loading and analysis is done with style checks off
5569 if not GNAT_Mode then
5570 Style_Check := False;
5573 Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
5576 (Load_Name => Body_Name,
5582 if Unum = No_Unit then
5586 Compiler_State := Analyzing; -- reset after load
5588 if Fatal_Error (Unum) /= Error_Detected or else Try_Semantics then
5589 if Debug_Flag_L then
5590 Write_Str ("*** Loaded generic body");
5595 Semantics (Cunit (Unum));
5602 Style_Check := Save_Style_Check;
5603 end Load_Needed_Body;
5605 -------------------------
5606 -- Build_Limited_Views --
5607 -------------------------
5609 procedure Build_Limited_Views (N : Node_Id) is
5610 Unum : constant Unit_Number_Type :=
5611 Get_Source_Unit (Library_Unit (N));
5612 Is_Analyzed : constant Boolean := Analyzed (Cunit (Unum));
5614 Shadow_Pack : Entity_Id;
5615 -- The corresponding shadow entity of the withed package. This entity
5616 -- offers incomplete views of packages and types as well as abstract
5617 -- views of states and variables declared within.
5619 Last_Shadow : Entity_Id := Empty;
5620 -- The last shadow entity created by routine Build_Shadow_Entity
5622 procedure Build_Shadow_Entity
5625 Shadow : out Entity_Id;
5626 Is_Tagged : Boolean := False);
5627 -- Create a shadow entity that hides Ent and offers an abstract or
5628 -- incomplete view of Ent. Scop is the proper scope. Flag Is_Tagged
5629 -- should be set when Ent is a tagged type. The generated entity is
5630 -- added to Lim_Header. This routine updates the value of Last_Shadow.
5632 procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id);
5633 -- Perform minimal decoration of a package or its corresponding shadow
5634 -- entity denoted by Ent. Scop is the proper scope.
5636 procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id);
5637 -- Perform full decoration of an abstract state or its corresponding
5638 -- shadow entity denoted by Ent. Scop is the proper scope.
5640 procedure Decorate_Type
5643 Is_Tagged : Boolean := False;
5644 Materialize : Boolean := False);
5645 -- Perform minimal decoration of a type or its corresponding shadow
5646 -- entity denoted by Ent. Scop is the proper scope. Flag Is_Tagged
5647 -- should be set when Ent is a tagged type. Flag Materialize should be
5648 -- set when Ent is a tagged type and its class-wide type needs to appear
5651 procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id);
5652 -- Perform minimal decoration of a variable denoted by Ent. Scop is the
5655 procedure Process_Declarations_And_States
5659 Create_Abstract_Views : Boolean);
5660 -- Inspect the states of package Pack and declarative list Decls. Create
5661 -- shadow entities for all nested packages, states, types and variables
5662 -- encountered. Scop is the proper scope. Create_Abstract_Views should
5663 -- be set when the abstract states and variables need to be processed.
5665 -------------------------
5666 -- Build_Shadow_Entity --
5667 -------------------------
5669 procedure Build_Shadow_Entity
5672 Shadow : out Entity_Id;
5673 Is_Tagged : Boolean := False)
5676 Shadow := Make_Temporary (Sloc (Ent), 'Z');
5678 -- The shadow entity must share the same name and parent as the
5681 Set_Chars (Shadow, Chars (Ent));
5682 Set_Parent (Shadow, Parent (Ent));
5684 -- The abstract view of a variable is a state, not another variable
5686 if Ekind (Ent) = E_Variable then
5687 Set_Ekind (Shadow, E_Abstract_State);
5689 Set_Ekind (Shadow, Ekind (Ent));
5692 Set_Is_Internal (Shadow);
5693 Set_From_Limited_With (Shadow);
5695 -- Add the new shadow entity to the limited view of the package
5697 Last_Shadow := Shadow;
5698 Append_Entity (Shadow, Shadow_Pack);
5700 -- Perform context-specific decoration of the shadow entity
5702 if Ekind (Ent) = E_Abstract_State then
5703 Decorate_State (Shadow, Scop);
5704 Set_Non_Limited_View (Shadow, Ent);
5706 elsif Ekind (Ent) = E_Package then
5707 Decorate_Package (Shadow, Scop);
5709 elsif Is_Type (Ent) then
5710 Decorate_Type (Shadow, Scop, Is_Tagged);
5711 Set_Non_Limited_View (Shadow, Ent);
5714 Set_Non_Limited_View
5715 (Class_Wide_Type (Shadow), Class_Wide_Type (Ent));
5718 if Is_Incomplete_Or_Private_Type (Ent) then
5719 Set_Private_Dependents (Shadow, New_Elmt_List);
5722 elsif Ekind (Ent) = E_Variable then
5723 Decorate_State (Shadow, Scop);
5724 Set_Non_Limited_View (Shadow, Ent);
5726 end Build_Shadow_Entity;
5728 ----------------------
5729 -- Decorate_Package --
5730 ----------------------
5732 procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id) is
5734 Set_Ekind (Ent, E_Package);
5735 Set_Etype (Ent, Standard_Void_Type);
5736 Set_Scope (Ent, Scop);
5737 end Decorate_Package;
5739 --------------------
5740 -- Decorate_State --
5741 --------------------
5743 procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is
5745 Set_Ekind (Ent, E_Abstract_State);
5746 Set_Etype (Ent, Standard_Void_Type);
5747 Set_Scope (Ent, Scop);
5748 Set_Encapsulating_State (Ent, Empty);
5755 procedure Decorate_Type
5758 Is_Tagged : Boolean := False;
5759 Materialize : Boolean := False)
5764 -- An unanalyzed type or a shadow entity of a type is treated as an
5765 -- incomplete type, and carries the corresponding attributes.
5767 Set_Ekind (Ent, E_Incomplete_Type);
5768 Set_Etype (Ent, Ent);
5769 Set_Full_View (Ent, Empty);
5770 Set_Is_First_Subtype (Ent);
5771 Set_Scope (Ent, Scop);
5772 Set_Stored_Constraint (Ent, No_Elist);
5773 Init_Size_Align (Ent);
5775 if From_Limited_With (Ent) then
5776 Set_Private_Dependents (Ent, New_Elmt_List);
5779 -- A tagged type and its corresponding shadow entity share one common
5780 -- class-wide type. The list of primitive operations for the shadow
5784 Set_Is_Tagged_Type (Ent);
5785 Set_Direct_Primitive_Operations (Ent, New_Elmt_List);
5789 (E_Void, Scope (Ent), Sloc (Ent), Ent, 'C', 0, 'T');
5791 Set_Class_Wide_Type (Ent, CW_Typ);
5793 -- Set parent to be the same as the parent of the tagged type.
5794 -- We need a parent field set, and it is supposed to point to
5795 -- the declaration of the type. The tagged type declaration
5796 -- essentially declares two separate types, the tagged type
5797 -- itself and the corresponding class-wide type, so it is
5798 -- reasonable for the parent fields to point to the declaration
5801 Set_Parent (CW_Typ, Parent (Ent));
5803 Set_Ekind (CW_Typ, E_Class_Wide_Type);
5804 Set_Class_Wide_Type (CW_Typ, CW_Typ);
5805 Set_Etype (CW_Typ, Ent);
5806 Set_Equivalent_Type (CW_Typ, Empty);
5807 Set_From_Limited_With (CW_Typ, From_Limited_With (Ent));
5808 Set_Has_Unknown_Discriminants (CW_Typ);
5809 Set_Is_First_Subtype (CW_Typ);
5810 Set_Is_Tagged_Type (CW_Typ);
5811 Set_Materialize_Entity (CW_Typ, Materialize);
5812 Set_Scope (CW_Typ, Scop);
5813 Init_Size_Align (CW_Typ);
5817 -----------------------
5818 -- Decorate_Variable --
5819 -----------------------
5821 procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id) is
5823 Set_Ekind (Ent, E_Variable);
5824 Set_Etype (Ent, Standard_Void_Type);
5825 Set_Scope (Ent, Scop);
5826 end Decorate_Variable;
5828 -------------------------------------
5829 -- Process_Declarations_And_States --
5830 -------------------------------------
5832 procedure Process_Declarations_And_States
5836 Create_Abstract_Views : Boolean)
5838 procedure Find_And_Process_States;
5839 -- Determine whether package Pack defines abstract state either by
5840 -- using an aspect or a pragma. If this is the case, build shadow
5841 -- entities for all abstract states of Pack.
5843 procedure Process_States (States : Elist_Id);
5844 -- Generate shadow entities for all abstract states in list States
5846 -----------------------------
5847 -- Find_And_Process_States --
5848 -----------------------------
5850 procedure Find_And_Process_States is
5851 procedure Process_State (State : Node_Id);
5852 -- Generate shadow entities for a single abstract state or
5853 -- multiple states expressed as an aggregate.
5859 procedure Process_State (State : Node_Id) is
5860 Loc : constant Source_Ptr := Sloc (State);
5867 -- Multiple abstract states appear as an aggregate
5869 if Nkind (State) = N_Aggregate then
5870 Elmt := First (Expressions (State));
5871 while Present (Elmt) loop
5872 Process_State (Elmt);
5878 -- A null state has no abstract view
5880 elsif Nkind (State) = N_Null then
5883 -- State declaration with various options appears as an
5884 -- extension aggregate.
5886 elsif Nkind (State) = N_Extension_Aggregate then
5887 Decl := Ancestor_Part (State);
5889 -- Simple state declaration
5891 elsif Nkind (State) = N_Identifier then
5894 -- Possibly an illegal state declaration
5900 -- Abstract states are elaborated when the related pragma is
5901 -- elaborated. Since the withed package is not analyzed yet,
5902 -- the entities of the abstract states are not available. To
5903 -- overcome this complication, create the entities now and
5904 -- store them in their respective declarations. The entities
5905 -- are later used by routine Create_Abstract_State to declare
5906 -- and enter the states into visibility.
5908 if No (Entity (Decl)) then
5909 Id := Make_Defining_Identifier (Loc, Chars (Decl));
5911 Set_Entity (Decl, Id);
5912 Set_Parent (Id, State);
5913 Decorate_State (Id, Scop);
5915 -- Otherwise the package was previously withed
5918 Id := Entity (Decl);
5921 Build_Shadow_Entity (Id, Scop, Dummy);
5926 Pack_Decl : constant Node_Id := Unit_Declaration_Node (Pack);
5930 -- Start of processing for Find_And_Process_States
5933 -- Find aspect Abstract_State
5935 Asp := First (Aspect_Specifications (Pack_Decl));
5936 while Present (Asp) loop
5937 if Chars (Identifier (Asp)) = Name_Abstract_State then
5938 Process_State (Expression (Asp));
5946 -- Find pragma Abstract_State by inspecting the declarations
5948 Decl := First (Decls);
5949 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
5950 if Pragma_Name (Decl) = Name_Abstract_State then
5953 (First (Pragma_Argument_Associations (Decl))));
5960 end Find_And_Process_States;
5962 --------------------
5963 -- Process_States --
5964 --------------------
5966 procedure Process_States (States : Elist_Id) is
5971 Elmt := First_Elmt (States);
5972 while Present (Elmt) loop
5973 Build_Shadow_Entity (Node (Elmt), Scop, Dummy);
5981 Is_Tagged : Boolean;
5987 -- Start of processing for Process_Declarations_And_States
5990 -- Build abstract views for all states defined in the package
5992 if Create_Abstract_Views then
5994 -- When a package has been analyzed, all states are stored in list
5995 -- Abstract_States. Generate the shadow entities directly.
5998 if Present (Abstract_States (Pack)) then
5999 Process_States (Abstract_States (Pack));
6002 -- The package may declare abstract states by using an aspect or a
6003 -- pragma. Attempt to locate one of these construct and if found,
6004 -- build the shadow entities.
6007 Find_And_Process_States;
6011 -- Inspect the declarative list, looking for nested packages, types
6012 -- and variable declarations.
6014 Decl := First (Decls);
6015 while Present (Decl) loop
6019 if Nkind (Decl) = N_Package_Declaration then
6020 Def_Id := Defining_Entity (Decl);
6022 -- Perform minor decoration when the withed package has not
6025 if not Is_Analyzed then
6026 Decorate_Package (Def_Id, Scop);
6029 -- Create a shadow entity that offers a limited view of all
6030 -- visible types declared within.
6032 Build_Shadow_Entity (Def_Id, Scop, Shadow);
6034 Process_Declarations_And_States
6037 Visible_Declarations (Specification (Decl)),
6039 Create_Abstract_Views => Create_Abstract_Views);
6043 elsif Nkind_In (Decl, N_Full_Type_Declaration,
6044 N_Incomplete_Type_Declaration,
6045 N_Private_Extension_Declaration,
6046 N_Private_Type_Declaration,
6047 N_Protected_Type_Declaration,
6048 N_Task_Type_Declaration)
6050 Def_Id := Defining_Entity (Decl);
6052 -- Determine whether the type is tagged. Note that packages
6053 -- included via a limited with clause are not always analyzed,
6054 -- hence the tree lookup rather than the use of attribute
6057 if Nkind (Decl) = N_Full_Type_Declaration then
6058 Def := Type_Definition (Decl);
6061 (Nkind (Def) = N_Record_Definition
6062 and then Tagged_Present (Def))
6064 (Nkind (Def) = N_Derived_Type_Definition
6065 and then Present (Record_Extension_Part (Def)));
6067 elsif Nkind_In (Decl, N_Incomplete_Type_Declaration,
6068 N_Private_Type_Declaration)
6070 Is_Tagged := Tagged_Present (Decl);
6072 elsif Nkind (Decl) = N_Private_Extension_Declaration then
6079 -- Perform minor decoration when the withed package has not
6082 if not Is_Analyzed then
6083 Decorate_Type (Def_Id, Scop, Is_Tagged, True);
6086 -- Create a shadow entity that hides the type and offers an
6087 -- incomplete view of the said type.
6089 Build_Shadow_Entity (Def_Id, Scop, Shadow, Is_Tagged);
6093 elsif Create_Abstract_Views
6094 and then Nkind (Decl) = N_Object_Declaration
6095 and then not Constant_Present (Decl)
6097 Def_Id := Defining_Entity (Decl);
6099 -- Perform minor decoration when the withed package has not
6102 if not Is_Analyzed then
6103 Decorate_Variable (Def_Id, Scop);
6106 -- Create a shadow entity that hides the variable and offers an
6107 -- abstract view of the said variable.
6109 Build_Shadow_Entity (Def_Id, Scop, Shadow);
6114 end Process_Declarations_And_States;
6118 Nam : constant Node_Id := Name (N);
6119 Pack : constant Entity_Id := Cunit_Entity (Unum);
6121 Last_Public_Shadow : Entity_Id := Empty;
6122 Private_Shadow : Entity_Id;
6125 -- Start of processing for Build_Limited_Views
6128 pragma Assert (Limited_Present (N));
6130 -- A library_item mentioned in a limited_with_clause is a package
6131 -- declaration, not a subprogram declaration, generic declaration,
6132 -- generic instantiation, or package renaming declaration.
6134 case Nkind (Unit (Library_Unit (N))) is
6135 when N_Package_Declaration =>
6138 when N_Subprogram_Declaration =>
6139 Error_Msg_N ("subprograms not allowed in limited with_clauses", N);
6142 when N_Generic_Package_Declaration
6143 | N_Generic_Subprogram_Declaration
6145 Error_Msg_N ("generics not allowed in limited with_clauses", N);
6148 when N_Generic_Instantiation =>
6150 ("generic instantiations not allowed in limited with_clauses",
6154 when N_Generic_Renaming_Declaration =>
6156 ("generic renamings not allowed in limited with_clauses", N);
6159 when N_Subprogram_Renaming_Declaration =>
6161 ("renamed subprograms not allowed in limited with_clauses", N);
6164 when N_Package_Renaming_Declaration =>
6166 ("renamed packages not allowed in limited with_clauses", N);
6170 raise Program_Error;
6173 -- The withed unit may not be analyzed, but the with calause itself
6174 -- must be minimally decorated. This ensures that the checks on unused
6175 -- with clauses also process limieted withs.
6177 Set_Ekind (Pack, E_Package);
6178 Set_Etype (Pack, Standard_Void_Type);
6180 if Is_Entity_Name (Nam) then
6181 Set_Entity (Nam, Pack);
6183 elsif Nkind (Nam) = N_Selected_Component then
6184 Set_Entity (Selector_Name (Nam), Pack);
6187 -- Check if the chain is already built
6189 Spec := Specification (Unit (Library_Unit (N)));
6191 if Limited_View_Installed (Spec) then
6195 -- Create the shadow package wich hides the withed unit and provides
6196 -- incomplete view of all types and packages declared within.
6198 Shadow_Pack := Make_Temporary (Sloc (N), 'Z');
6199 Set_Ekind (Shadow_Pack, E_Package);
6200 Set_Is_Internal (Shadow_Pack);
6201 Set_Limited_View (Pack, Shadow_Pack);
6203 -- Inspect the abstract states and visible declarations of the withed
6204 -- unit and create shadow entities that hide existing packages, states,
6205 -- variables and types.
6207 Process_Declarations_And_States
6209 Decls => Visible_Declarations (Spec),
6211 Create_Abstract_Views => True);
6213 Last_Public_Shadow := Last_Shadow;
6215 -- Ada 2005 (AI-262): Build the limited view of the private declarations
6216 -- to accommodate limited private with clauses.
6218 Process_Declarations_And_States
6220 Decls => Private_Declarations (Spec),
6222 Create_Abstract_Views => False);
6224 if Present (Last_Public_Shadow) then
6225 Private_Shadow := Next_Entity (Last_Public_Shadow);
6227 Private_Shadow := First_Entity (Shadow_Pack);
6230 Set_First_Private_Entity (Shadow_Pack, Private_Shadow);
6231 Set_Limited_View_Installed (Spec);
6232 end Build_Limited_Views;
6234 ----------------------------
6235 -- Check_No_Elab_Code_All --
6236 ----------------------------
6238 procedure Check_No_Elab_Code_All (N : Node_Id) is
6240 if Present (No_Elab_Code_All_Pragma)
6241 and then In_Extended_Main_Source_Unit (N)
6242 and then Present (Context_Items (N))
6245 CL : constant List_Id := Context_Items (N);
6250 while Present (CI) loop
6251 if Nkind (CI) = N_With_Clause
6253 No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI)))
6255 -- In GNATprove mode, some runtime units are implicitly
6256 -- loaded to make their entities available for analysis. In
6257 -- this case, ignore violations of No_Elaboration_Code_All
6258 -- for this special analysis mode.
6261 (GNATprove_Mode and then Implicit_With (CI))
6263 Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma);
6265 ("violation of No_Elaboration_Code_All#", CI);
6267 ("\unit& does not have No_Elaboration_Code_All",
6268 CI, Entity (Name (CI)));
6275 end Check_No_Elab_Code_All;
6277 -------------------------------
6278 -- Check_Body_Needed_For_SAL --
6279 -------------------------------
6281 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
6282 function Entity_Needs_Body (E : Entity_Id) return Boolean;
6283 -- Determine whether use of entity E might require the presence of its
6284 -- body. For a package this requires a recursive traversal of all nested
6287 -----------------------
6288 -- Entity_Needs_Body --
6289 -----------------------
6291 function Entity_Needs_Body (E : Entity_Id) return Boolean is
6295 if Is_Subprogram (E) and then Has_Pragma_Inline (E) then
6298 elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
6300 -- A generic subprogram always requires the presence of its
6301 -- body because an instantiation needs both templates. The only
6302 -- exceptions is a generic subprogram renaming. In this case the
6303 -- body is needed only when the template is declared outside the
6304 -- compilation unit being checked.
6306 if Present (Renamed_Entity (E)) then
6307 return not Within_Scope (E, Unit_Name);
6312 elsif Ekind (E) = E_Generic_Package
6314 Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
6315 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
6319 elsif Ekind (E) = E_Package
6320 and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
6321 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
6323 Ent := First_Entity (E);
6324 while Present (Ent) loop
6325 if Entity_Needs_Body (Ent) then
6337 end Entity_Needs_Body;
6339 -- Start of processing for Check_Body_Needed_For_SAL
6342 if Ekind (Unit_Name) = E_Generic_Package
6343 and then Nkind (Unit_Declaration_Node (Unit_Name)) =
6344 N_Generic_Package_Declaration
6346 Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
6348 Set_Body_Needed_For_SAL (Unit_Name);
6350 elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
6351 Set_Body_Needed_For_SAL (Unit_Name);
6353 elsif Is_Subprogram (Unit_Name)
6354 and then Nkind (Unit_Declaration_Node (Unit_Name)) =
6355 N_Subprogram_Declaration
6356 and then Has_Pragma_Inline (Unit_Name)
6358 Set_Body_Needed_For_SAL (Unit_Name);
6360 elsif Ekind (Unit_Name) = E_Subprogram_Body then
6361 Check_Body_Needed_For_SAL
6362 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
6364 elsif Ekind (Unit_Name) = E_Package
6365 and then Entity_Needs_Body (Unit_Name)
6367 Set_Body_Needed_For_SAL (Unit_Name);
6369 elsif Ekind (Unit_Name) = E_Package_Body
6370 and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
6372 Check_Body_Needed_For_SAL
6373 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
6375 end Check_Body_Needed_For_SAL;
6377 --------------------
6378 -- Remove_Context --
6379 --------------------
6381 procedure Remove_Context (N : Node_Id) is
6382 Lib_Unit : constant Node_Id := Unit (N);
6385 -- If this is a child unit, first remove the parent units
6387 if Is_Child_Spec (Lib_Unit) then
6388 Remove_Parents (Lib_Unit);
6391 Remove_Context_Clauses (N);
6394 ----------------------------
6395 -- Remove_Context_Clauses --
6396 ----------------------------
6398 procedure Remove_Context_Clauses (N : Node_Id) is
6400 Unit_Name : Entity_Id;
6403 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
6404 -- limited-views first and regular-views later (to maintain the stack
6407 -- First Phase: Remove limited_with context clauses
6409 Item := First (Context_Items (N));
6410 while Present (Item) loop
6412 -- We are interested only in with clauses that got installed on entry
6414 if Nkind (Item) = N_With_Clause
6415 and then Limited_Present (Item)
6417 if Limited_View_Installed (Item) then
6418 Remove_Limited_With_Clause (Item);
6420 -- An unusual case: If the library unit of the Main_Unit has a
6421 -- limited with_clause on some unit P and the context somewhere
6422 -- includes a with_clause on P, P has been analyzed. The entity
6423 -- for P is still visible, which in general is harmless because
6424 -- this is the end of the compilation, but it can affect pending
6425 -- instantiations that may have been generated elsewhere, so it
6426 -- it is necessary to remove U from visibility so that inlining
6427 -- and the analysis of instance bodies can proceed cleanly.
6429 elsif Current_Sem_Unit = Main_Unit
6430 and then Serious_Errors_Detected = 0
6431 and then not Implicit_With (Item)
6433 Set_Is_Immediately_Visible
6434 (Defining_Entity (Unit (Library_Unit (Item))), False);
6441 -- Second Phase: Loop through context items and undo regular
6442 -- with_clauses and use_clauses.
6444 Item := First (Context_Items (N));
6445 while Present (Item) loop
6447 -- We are interested only in with clauses which got installed on
6448 -- entry, as indicated by their Context_Installed flag set
6450 if Nkind (Item) = N_With_Clause
6451 and then Limited_Present (Item)
6452 and then Limited_View_Installed (Item)
6456 elsif Nkind (Item) = N_With_Clause
6457 and then Context_Installed (Item)
6459 -- Remove items from one with'ed unit
6461 Unit_Name := Entity (Name (Item));
6462 Remove_Unit_From_Visibility (Unit_Name);
6463 Set_Context_Installed (Item, False);
6465 elsif Nkind (Item) = N_Use_Package_Clause then
6466 End_Use_Package (Item);
6468 elsif Nkind (Item) = N_Use_Type_Clause then
6469 End_Use_Type (Item);
6474 end Remove_Context_Clauses;
6476 --------------------------------
6477 -- Remove_Limited_With_Clause --
6478 --------------------------------
6480 procedure Remove_Limited_With_Clause (N : Node_Id) is
6481 Pack_Decl : constant Entity_Id := Unit (Library_Unit (N));
6484 pragma Assert (Limited_View_Installed (N));
6486 -- Limited with clauses that designate units other than packages are
6487 -- illegal and are never installed.
6489 if Nkind (Pack_Decl) = N_Package_Declaration then
6490 Remove_Limited_With_Unit (Pack_Decl, N);
6493 -- Indicate that the limited views of the clause have been removed
6495 Set_Limited_View_Installed (N, False);
6496 end Remove_Limited_With_Clause;
6498 ------------------------------
6499 -- Remove_Limited_With_Unit --
6500 ------------------------------
6502 procedure Remove_Limited_With_Unit
6503 (Pack_Decl : Node_Id;
6504 Lim_Clause : Node_Id := Empty)
6506 procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id);
6507 -- Remove the shadow entities of package Pack_Id from direct visibility
6509 procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id);
6510 -- Remove the shadow entities of package Pack_Id from direct visibility,
6511 -- restore the corresponding entities they hide into direct visibility,
6512 -- and update the entity and homonym chains.
6514 --------------------------------------------
6515 -- Remove_Shadow_Entities_From_Visibility --
6516 --------------------------------------------
6518 procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id) is
6519 Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
6520 Upto : constant Entity_Id := First_Private_Entity (Lim_Header);
6525 -- Remove the package from direct visibility
6528 Set_Is_Immediately_Visible (Pack_Id, False);
6530 -- Remove all shadow entities from direct visibility
6532 Shadow := First_Entity (Lim_Header);
6533 while Present (Shadow) and then Shadow /= Upto loop
6535 Next_Entity (Shadow);
6537 end Remove_Shadow_Entities_From_Visibility;
6539 -----------------------------------------
6540 -- Remove_Shadow_Entities_With_Restore --
6541 -----------------------------------------
6543 procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id) is
6544 procedure Restore_Chain_For_Shadow (Shadow : Entity_Id);
6545 -- Remove shadow entity Shadow by updating the entity and homonym
6548 procedure Restore_Chains
6551 -- Remove a sequence of shadow entities starting from From and ending
6552 -- prior to Upto by updating the entity and homonym chains.
6554 procedure Restore_Type_Visibility
6557 -- Restore a sequence of types starting from From and ending prior to
6558 -- Upto back in direct visibility.
6560 ------------------------------
6561 -- Restore_Chain_For_Shadow --
6562 ------------------------------
6564 procedure Restore_Chain_For_Shadow (Shadow : Entity_Id) is
6569 -- If the package has incomplete types, the limited view of the
6570 -- incomplete type is in fact never visible (AI05-129) but we
6571 -- have created a shadow entity E1 for it, that points to E2,
6572 -- a nonlimited incomplete type. This in turn has a full view
6573 -- E3 that is the full declaration. There is a corresponding
6574 -- shadow entity E4. When reinstalling the nonlimited view,
6575 -- E2 must become the current entity and E3 must be ignored.
6577 Typ := Non_Limited_View (Shadow);
6579 -- Shadow is the limited view of a full type declaration that has
6580 -- a previous incomplete declaration, i.e. E3 from the previous
6581 -- description. Nothing to insert.
6583 if Present (Current_Entity (Typ))
6584 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
6585 and then Full_View (Current_Entity (Typ)) = Typ
6590 pragma Assert (not In_Chain (Typ));
6592 Prev := Current_Entity (Shadow);
6594 if Prev = Shadow then
6595 Set_Current_Entity (Typ);
6598 while Present (Prev) and then Homonym (Prev) /= Shadow loop
6599 Prev := Homonym (Prev);
6602 if Present (Prev) then
6603 Set_Homonym (Prev, Typ);
6607 Set_Homonym (Typ, Homonym (Shadow));
6608 end Restore_Chain_For_Shadow;
6610 --------------------
6611 -- Restore_Chains --
6612 --------------------
6614 procedure Restore_Chains
6622 while Present (Shadow) and then Shadow /= Upto loop
6624 -- Do not unchain nested packages and child units
6626 if Ekind (Shadow) = E_Package then
6629 elsif Is_Child_Unit (Non_Limited_View (Shadow)) then
6633 Restore_Chain_For_Shadow (Shadow);
6636 Next_Entity (Shadow);
6640 -----------------------------
6641 -- Restore_Type_Visibility --
6642 -----------------------------
6644 procedure Restore_Type_Visibility
6652 while Present (Typ) and then Typ /= Upto loop
6653 if Is_Type (Typ) then
6654 Set_Is_Hidden (Typ, Was_Hidden (Typ));
6659 end Restore_Type_Visibility;
6663 Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
6665 -- Start of processing Remove_Shadow_Entities_With_Restore
6668 -- The limited view of a package is being uninstalled by removing
6669 -- the effects of a limited with clause. If the clause appears in a
6670 -- unit which is not part of the main unit closure, then the related
6671 -- package must not be visible.
6673 if Present (Lim_Clause)
6674 and then not In_Extended_Main_Source_Unit (Lim_Clause)
6676 Set_Is_Immediately_Visible (Pack_Id, False);
6678 -- Otherwise a limited view is being overridden by a nonlimited view.
6679 -- Leave the visibility of the package as is because the unit must be
6680 -- visible when the nonlimited view is installed.
6686 -- Remove the shadow entities from visibility by updating the entity
6687 -- and homonym chains.
6690 (From => First_Entity (Lim_Header),
6691 Upto => First_Private_Entity (Lim_Header));
6693 -- Reinstate the types that were hidden by the shadow entities back
6694 -- into direct visibility.
6696 Restore_Type_Visibility
6697 (From => First_Entity (Pack_Id),
6698 Upto => First_Private_Entity (Pack_Id));
6699 end Remove_Shadow_Entities_With_Restore;
6703 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
6705 -- Start of processing for Remove_Limited_With_Unit
6708 -- Nothing to do when the limited view of the package is not installed
6710 if not From_Limited_With (Pack_Id) then
6714 if Debug_Flag_I then
6715 Write_Str ("remove limited view of ");
6716 Write_Name (Chars (Pack_Id));
6717 Write_Str (" from visibility");
6721 -- The package already appears in the compilation closure. As a result,
6722 -- its shadow entities must be replaced by the real entities they hide
6723 -- and the previously hidden entities must be entered back into direct
6726 -- WARNING: This code must be kept synchronized with that of routine
6727 -- Install_Limited_Withed_Clause.
6729 if Analyzed (Pack_Decl) then
6730 Remove_Shadow_Entities_With_Restore (Pack_Id);
6732 -- Otherwise the package is not analyzed and its shadow entities must be
6733 -- removed from direct visibility.
6736 Remove_Shadow_Entities_From_Visibility (Pack_Id);
6739 -- Indicate that the limited view of the package is not installed
6741 Set_From_Limited_With (Pack_Id, False);
6742 end Remove_Limited_With_Unit;
6744 --------------------
6745 -- Remove_Parents --
6746 --------------------
6748 procedure Remove_Parents (Lib_Unit : Node_Id) is
6751 P_Spec : Node_Id := Empty;
6753 Vis : constant Boolean :=
6754 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
6757 if Is_Child_Spec (Lib_Unit) then
6758 P_Spec := Parent_Spec (Lib_Unit);
6760 elsif Nkind (Lib_Unit) = N_Package_Body
6761 and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
6763 P_Spec := Parent_Spec (Original_Node (Lib_Unit));
6766 if Present (P_Spec) then
6768 P_Name := Get_Parent_Entity (P);
6769 Remove_Context_Clauses (P_Spec);
6770 End_Package_Scope (P_Name);
6771 Set_Is_Immediately_Visible (P_Name, Vis);
6773 -- Remove from visibility the siblings as well, which are directly
6774 -- visible while the parent is in scope.
6776 E := First_Entity (P_Name);
6777 while Present (E) loop
6778 if Is_Child_Unit (E) then
6779 Set_Is_Immediately_Visible (E, False);
6785 Set_In_Package_Body (P_Name, False);
6787 -- This is the recursive call to remove the context of any higher
6788 -- level parent. This recursion ensures that all parents are removed
6789 -- in the reverse order of their installation.
6795 ---------------------------------
6796 -- Remove_Private_With_Clauses --
6797 ---------------------------------
6799 procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is
6802 function In_Regular_With_Clause (E : Entity_Id) return Boolean;
6803 -- Check whether a given unit appears in a regular with_clause. Used to
6804 -- determine whether a private_with_clause, implicit or explicit, should
6807 ----------------------------
6808 -- In_Regular_With_Clause --
6809 ----------------------------
6811 function In_Regular_With_Clause (E : Entity_Id) return Boolean
6816 Item := First (Context_Items (Comp_Unit));
6817 while Present (Item) loop
6818 if Nkind (Item) = N_With_Clause
6820 -- The following guard is needed to ensure that the name has
6821 -- been properly analyzed before we go fetching its entity.
6823 and then Is_Entity_Name (Name (Item))
6824 and then Entity (Name (Item)) = E
6825 and then not Private_Present (Item)
6833 end In_Regular_With_Clause;
6835 -- Start of processing for Remove_Private_With_Clauses
6838 Item := First (Context_Items (Comp_Unit));
6839 while Present (Item) loop
6840 if Nkind (Item) = N_With_Clause and then Private_Present (Item) then
6842 -- If private_with_clause is redundant, remove it from context,
6843 -- as a small optimization to subsequent handling of private_with
6844 -- clauses in other nested packages. We replace the clause with
6845 -- a null statement, which is otherwise ignored by the rest of
6846 -- the compiler, so that ASIS tools can reconstruct the source.
6847 -- Is this still needed now that ASIS mode is removed???
6849 if In_Regular_With_Clause (Entity (Name (Item))) then
6851 Nxt : constant Node_Id := Next (Item);
6853 Rewrite (Item, Make_Null_Statement (Sloc (Item)));
6858 elsif Limited_Present (Item) then
6859 if not Limited_View_Installed (Item) then
6860 Remove_Limited_With_Clause (Item);
6866 Remove_Unit_From_Visibility (Entity (Name (Item)));
6867 Set_Context_Installed (Item, False);
6875 end Remove_Private_With_Clauses;
6877 ---------------------------------
6878 -- Remove_Unit_From_Visibility --
6879 ---------------------------------
6881 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
6883 if Debug_Flag_I then
6884 Write_Str ("remove unit ");
6885 Write_Name (Chars (Unit_Name));
6886 Write_Str (" from visibility");
6890 Set_Is_Visible_Lib_Unit (Unit_Name, False);
6891 Set_Is_Potentially_Use_Visible (Unit_Name, False);
6892 Set_Is_Immediately_Visible (Unit_Name, False);
6894 -- If the unit is a wrapper package, the subprogram instance is
6895 -- what must be removed from visibility.
6896 -- Should we use Related_Instance instead???
6898 if Is_Wrapper_Package (Unit_Name) then
6899 Set_Is_Immediately_Visible (Current_Entity (Unit_Name), False);
6901 end Remove_Unit_From_Visibility;
6916 procedure Unchain (E : Entity_Id) is
6920 Prev := Current_Entity (E);
6926 Set_Name_Entity_Id (Chars (E), Homonym (E));
6929 while Present (Prev) and then Homonym (Prev) /= E loop
6930 Prev := Homonym (Prev);
6933 if Present (Prev) then
6934 Set_Homonym (Prev, Homonym (E));
6938 if Debug_Flag_I then
6939 Write_Str (" (homonym) unchain ");
6940 Write_Name (Chars (E));