1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Util; use Exp_Util;
32 with Fname; use Fname;
33 with Fname.UF; use Fname.UF;
34 with Freeze; use Freeze;
35 with Impunit; use Impunit;
36 with Inline; use Inline;
38 with Lib.Load; use Lib.Load;
39 with Lib.Xref; use Lib.Xref;
40 with Namet; use Namet;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
44 with Output; use Output;
45 with Restrict; use Restrict;
46 with Rtsfind; use Rtsfind;
48 with Sem_Ch6; use Sem_Ch6;
49 with Sem_Ch7; use Sem_Ch7;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Dist; use Sem_Dist;
52 with Sem_Prag; use Sem_Prag;
53 with Sem_Util; use Sem_Util;
54 with Sem_Warn; use Sem_Warn;
55 with Stand; use Stand;
56 with Sinfo; use Sinfo;
57 with Sinfo.CN; use Sinfo.CN;
58 with Sinput; use Sinput;
59 with Snames; use Snames;
60 with Style; use Style;
61 with Stylesw; use Stylesw;
62 with Tbuild; use Tbuild;
63 with Ttypes; use Ttypes;
64 with Uname; use Uname;
66 package body Sem_Ch10 is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Analyze_Context (N : Node_Id);
73 -- Analyzes items in the context clause of compilation unit
75 procedure Build_Limited_Views (N : Node_Id);
76 -- Build and decorate the list of shadow entities for a package mentioned
77 -- in a limited_with clause. If the package was not previously analyzed
78 -- then it also performs a basic decoration of the real entities; this
79 -- is required to do not pass non-decorated entities to the back-end.
80 -- Implements Ada 2005 (AI-50217).
82 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
83 -- Check whether the source for the body of a compilation unit must
84 -- be included in a standalone library.
86 procedure Check_With_Type_Clauses (N : Node_Id);
87 -- If N is a body, verify that any with_type clauses on the spec, or
88 -- on the spec of any parent, have a matching with_clause.
90 procedure Check_Private_Child_Unit (N : Node_Id);
91 -- If a with_clause mentions a private child unit, the compilation
92 -- unit must be a member of the same family, as described in 10.1.2 (8).
94 procedure Check_Stub_Level (N : Node_Id);
95 -- Verify that a stub is declared immediately within a compilation unit,
96 -- and not in an inner frame.
98 procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id);
99 -- If a child unit appears in a limited_with clause, there are implicit
100 -- limited_with clauses on all parents that are not already visible
101 -- through a regular with clause. This procedure creates the implicit
102 -- limited with_clauses for the parents and loads the corresponding units.
103 -- The shadow entities are created when the inserted clause is analyzed.
104 -- Implements Ada 2005 (AI-50217).
106 procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
107 -- When a child unit appears in a context clause, the implicit withs on
108 -- parents are made explicit, and with clauses are inserted in the context
109 -- clause before the one for the child. If a parent in the with_clause
110 -- is a renaming, the implicit with_clause is on the renaming whose name
111 -- is mentioned in the with_clause, and not on the package it renames.
112 -- N is the compilation unit whose list of context items receives the
113 -- implicit with_clauses.
115 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
116 -- Get defining entity of parent unit of a child unit. In most cases this
117 -- is the defining entity of the unit, but for a child instance whose
118 -- parent needs a body for inlining, the instantiation node of the parent
119 -- has not yet been rewritten as a package declaration, and the entity has
120 -- to be retrieved from the Instance_Spec of the unit.
122 procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
123 -- If the main unit is a child unit, implicit withs are also added for
124 -- all its ancestors.
126 procedure Install_Context_Clauses (N : Node_Id);
127 -- Subsidiary to previous one. Process only with_ and use_clauses for
128 -- current unit and its library unit if any.
130 procedure Install_Limited_Context_Clauses (N : Node_Id);
131 -- Subsidiary to Install_Context. Process only limited with_clauses
132 -- for current unit. Implements Ada 2005 (AI-50217).
134 procedure Install_Limited_Withed_Unit (N : Node_Id);
135 -- Place shadow entities for a limited_with package in the visibility
136 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
138 procedure Install_Withed_Unit
139 (With_Clause : Node_Id;
140 Private_With_OK : Boolean := False);
142 -- If the unit is not a child unit, make unit immediately visible.
143 -- The caller ensures that the unit is not already currently installed.
144 -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
145 -- which is called when compiling the private part of a package, or
146 -- installing the private declarations of a parent unit.
148 procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
149 -- This procedure establishes the context for the compilation of a child
150 -- unit. If Lib_Unit is a child library spec then the context of the parent
151 -- is installed, and the parent itself made immediately visible, so that
152 -- the child unit is processed in the declarative region of the parent.
153 -- Install_Parents makes a recursive call to itself to ensure that all
154 -- parents are loaded in the nested case. If Lib_Unit is a library body,
155 -- the only effect of Install_Parents is to install the private decls of
156 -- the parents, because the visible parent declarations will have been
157 -- installed as part of the context of the corresponding spec.
159 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
160 -- In the compilation of a child unit, a child of any of the ancestor
161 -- units is directly visible if it is visible, because the parent is in
162 -- an enclosing scope. Iterate over context to find child units of U_Name
163 -- or of some ancestor of it.
165 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
166 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
167 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
168 -- a library spec that has a parent. If the call to Is_Child_Spec returns
169 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
170 -- compilation unit for the parent spec.
172 -- Lib_Unit can also be a subprogram body that acts as its own spec. If
173 -- the Parent_Spec is non-empty, this is also a child unit.
175 procedure Remove_With_Type_Clause (Name : Node_Id);
176 -- Remove imported type and its enclosing package from visibility, and
177 -- remove attributes of imported type so they don't interfere with its
178 -- analysis (should it appear otherwise in the context).
180 procedure Remove_Context_Clauses (N : Node_Id);
181 -- Subsidiary of previous one. Remove use_ and with_clauses.
183 procedure Remove_Limited_With_Clause (N : Node_Id);
184 -- Remove from visibility the shadow entities introduced for a package
185 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
187 procedure Remove_Parents (Lib_Unit : Node_Id);
188 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
189 -- contexts established by the corresponding call to Install_Parents are
190 -- removed. Remove_Parents contains a recursive call to itself to ensure
191 -- that all parents are removed in the nested case.
193 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
194 -- Reset all visibility flags on unit after compiling it, either as a
195 -- main unit or as a unit in the context.
197 procedure Unchain (E : Entity_Id);
198 -- Remove single entity from visibility list
200 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
201 -- Common processing for all stubs (subprograms, tasks, packages, and
202 -- protected cases). N is the stub to be analyzed. Once the subunit
203 -- name is established, load and analyze. Nam is the non-overloadable
204 -- entity for which the proper body provides a completion. Subprogram
205 -- stubs are handled differently because they can be declarations.
207 --------------------------
208 -- Limited_With_Clauses --
209 --------------------------
211 -- Limited_With clauses are the mechanism chosen for Ada05 to support
212 -- mutually recursive types declared in different units. A limited_with
213 -- clause that names package P in the context of unit U makes the types
214 -- declared in the visible part of P available within U, but with the
215 -- restriction that these types can only be used as incomplete types.
216 -- The limited_with clause does not impose a semantic dependence on P,
217 -- and it is possible for two packages to have limited_with_clauses on
218 -- each other without creating an elaboration circularity.
220 -- To support this feature, the analysis of a limited_with clause must
221 -- create an abbreviated view of the package, without performing any
222 -- semantic analysis on it. This "package abstract" contains shadow
223 -- types that are in one-one correspondence with the real types in the
224 -- package, and that have the properties of incomplete types.
226 -- The implementation creates two element lists: one to chain the shadow
227 -- entities, and one to chain the corresponding type entities in the tree
228 -- of the package. Links between corresponding entities in both chains
229 -- allow the compiler to select the proper view of a given type, depending
230 -- on the context. Note that in contrast with the handling of private
231 -- types, the limited view and the non-limited view of a type are treated
232 -- as separate entities, and no entity exchange needs to take place, which
233 -- makes the implementation must simpler than could be feared.
235 ------------------------------
236 -- Analyze_Compilation_Unit --
237 ------------------------------
239 procedure Analyze_Compilation_Unit (N : Node_Id) is
240 Unit_Node : constant Node_Id := Unit (N);
241 Lib_Unit : Node_Id := Library_Unit (N);
243 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
244 Par_Spec_Name : Unit_Name_Type;
245 Unum : Unit_Number_Type;
247 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
248 -- Generate cross-reference information for the parents of child units.
249 -- N is a defining_program_unit_name, and P_Id is the immediate parent.
251 --------------------------------
252 -- Generate_Parent_References --
253 --------------------------------
255 procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
257 P_Name : Entity_Id := P_Id;
260 Pref := Name (Parent (Defining_Entity (N)));
262 if Nkind (Pref) = N_Expanded_Name then
264 -- Done already, if the unit has been compiled indirectly as
265 -- part of the closure of its context because of inlining.
270 while Nkind (Pref) = N_Selected_Component loop
271 Change_Selected_Component_To_Expanded_Name (Pref);
272 Set_Entity (Pref, P_Name);
273 Set_Etype (Pref, Etype (P_Name));
274 Generate_Reference (P_Name, Pref, 'r');
275 Pref := Prefix (Pref);
276 P_Name := Scope (P_Name);
279 -- The guard here on P_Name is to handle the error condition where
280 -- the parent unit is missing because the file was not found.
282 if Present (P_Name) then
283 Set_Entity (Pref, P_Name);
284 Set_Etype (Pref, Etype (P_Name));
285 Generate_Reference (P_Name, Pref, 'r');
286 Style.Check_Identifier (Pref, P_Name);
288 end Generate_Parent_References;
290 -- Start of processing for Analyze_Compilation_Unit
293 Process_Compilation_Unit_Pragmas (N);
295 -- If the unit is a subunit whose parent has not been analyzed (which
296 -- indicates that the main unit is a subunit, either the current one or
297 -- one of its descendents) then the subunit is compiled as part of the
298 -- analysis of the parent, which we proceed to do. Basically this gets
299 -- handled from the top down and we don't want to do anything at this
300 -- level (i.e. this subunit will be handled on the way down from the
301 -- parent), so at this level we immediately return. If the subunit
302 -- ends up not analyzed, it means that the parent did not contain a
303 -- stub for it, or that there errors were dectected in some ancestor.
305 if Nkind (Unit_Node) = N_Subunit
306 and then not Analyzed (Lib_Unit)
308 Semantics (Lib_Unit);
310 if not Analyzed (Proper_Body (Unit_Node)) then
311 if Serious_Errors_Detected > 0 then
312 Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
314 Error_Msg_N ("missing stub for subunit", N);
321 -- Analyze context (this will call Sem recursively for with'ed units)
325 -- If the unit is a package body, the spec is already loaded and must
326 -- be analyzed first, before we analyze the body.
328 if Nkind (Unit_Node) = N_Package_Body then
330 -- If no Lib_Unit, then there was a serious previous error, so
331 -- just ignore the entire analysis effort
333 if No (Lib_Unit) then
337 Semantics (Lib_Unit);
338 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
340 -- Verify that the library unit is a package declaration.
342 if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
344 Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
347 ("no legal package declaration for package body", N);
350 -- Otherwise, the entity in the declaration is visible. Update
351 -- the version to reflect dependence of this body on the spec.
354 Spec_Id := Defining_Entity (Unit (Lib_Unit));
355 Set_Is_Immediately_Visible (Spec_Id, True);
356 Version_Update (N, Lib_Unit);
358 if Nkind (Defining_Unit_Name (Unit_Node))
359 = N_Defining_Program_Unit_Name
361 Generate_Parent_References (Unit_Node, Scope (Spec_Id));
366 -- If the unit is a subprogram body, then we similarly need to analyze
367 -- its spec. However, things are a little simpler in this case, because
368 -- here, this analysis is done only for error checking and consistency
369 -- purposes, so there's nothing else to be done.
371 elsif Nkind (Unit_Node) = N_Subprogram_Body then
372 if Acts_As_Spec (N) then
374 -- If the subprogram body is a child unit, we must create a
375 -- declaration for it, in order to properly load the parent(s).
376 -- After this, the original unit does not acts as a spec, because
377 -- there is an explicit one. If this unit appears in a context
378 -- clause, then an implicit with on the parent will be added when
379 -- installing the context. If this is the main unit, there is no
380 -- Unit_Table entry for the declaration, (It has the unit number
381 -- of the main unit) and code generation is unaffected.
383 Unum := Get_Cunit_Unit_Number (N);
384 Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
386 if Par_Spec_Name /= No_Name then
389 (Load_Name => Par_Spec_Name,
394 if Unum /= No_Unit then
396 -- Build subprogram declaration and attach parent unit to it
397 -- This subprogram declaration does not come from source,
398 -- Nevertheless the backend must generate debugging info for
399 -- it, and this must be indicated explicitly.
402 Loc : constant Source_Ptr := Sloc (N);
403 SCS : constant Boolean :=
404 Get_Comes_From_Source_Default;
407 Set_Comes_From_Source_Default (False);
409 Make_Compilation_Unit (Loc,
410 Context_Items => New_Copy_List (Context_Items (N)),
412 Make_Subprogram_Declaration (Sloc (N),
415 (Specification (Unit_Node))),
417 Make_Compilation_Unit_Aux (Loc));
419 Set_Library_Unit (N, Lib_Unit);
420 Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
421 Semantics (Lib_Unit);
422 Set_Acts_As_Spec (N, False);
423 Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
424 Set_Comes_From_Source_Default (SCS);
429 -- Here for subprogram with separate declaration
432 Semantics (Lib_Unit);
433 Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
434 Version_Update (N, Lib_Unit);
437 if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
438 N_Defining_Program_Unit_Name
440 Generate_Parent_References (
441 Specification (Unit_Node),
442 Scope (Defining_Entity (Unit (Lib_Unit))));
446 -- If it is a child unit, the parent must be elaborated first
447 -- and we update version, since we are dependent on our parent.
449 if Is_Child_Spec (Unit_Node) then
451 -- The analysis of the parent is done with style checks off
454 Save_Style_Check : constant Boolean := Style_Check;
455 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
456 Cunit_Boolean_Restrictions_Save;
459 if not GNAT_Mode then
460 Style_Check := False;
463 Semantics (Parent_Spec (Unit_Node));
464 Version_Update (N, Parent_Spec (Unit_Node));
465 Style_Check := Save_Style_Check;
466 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
470 -- With the analysis done, install the context. Note that we can't
471 -- install the context from the with clauses as we analyze them,
472 -- because each with clause must be analyzed in a clean visibility
473 -- context, so we have to wait and install them all at once.
477 if Is_Child_Spec (Unit_Node) then
479 -- Set the entities of all parents in the program_unit_name.
481 Generate_Parent_References (
482 Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
485 -- All components of the context: with-clauses, library unit, ancestors
486 -- if any, (and their context) are analyzed and installed. Now analyze
487 -- the unit itself, which is either a package, subprogram spec or body.
491 -- The above call might have made Unit_Node an N_Subprogram_Body
492 -- from something else, so propagate any Acts_As_Spec flag.
494 if Nkind (Unit_Node) = N_Subprogram_Body
495 and then Acts_As_Spec (Unit_Node)
497 Set_Acts_As_Spec (N);
500 -- Register predefined units in Rtsfind
503 Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
505 if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
506 Set_RTU_Loaded (Unit_Node);
510 -- Treat compilation unit pragmas that appear after the library unit
512 if Present (Pragmas_After (Aux_Decls_Node (N))) then
514 Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
517 while Present (Prag_Node) loop
524 -- Generate distribution stubs if requested and no error
527 and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
529 Distribution_Stub_Mode = Generate_Caller_Stub_Body)
530 and then not Fatal_Error (Main_Unit)
532 if Is_RCI_Pkg_Spec_Or_Body (N) then
534 -- Regular RCI package
536 Add_Stub_Constructs (N);
538 elsif (Nkind (Unit_Node) = N_Package_Declaration
539 and then Is_Shared_Passive (Defining_Entity
540 (Specification (Unit_Node))))
541 or else (Nkind (Unit_Node) = N_Package_Body
543 Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
545 -- Shared passive package
547 Add_Stub_Constructs (N);
549 elsif Nkind (Unit_Node) = N_Package_Instantiation
551 Is_Remote_Call_Interface
552 (Defining_Entity (Specification (Instance_Spec (Unit_Node))))
554 -- Instantiation of a RCI generic package
556 Add_Stub_Constructs (N);
561 if Nkind (Unit_Node) = N_Package_Declaration
562 or else Nkind (Unit_Node) in N_Generic_Declaration
563 or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
564 or else Nkind (Unit_Node) = N_Subprogram_Declaration
566 Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
568 -- If the unit is an instantiation whose body will be elaborated
569 -- for inlining purposes, use the the proper entity of the instance.
571 elsif Nkind (Unit_Node) = N_Package_Instantiation
572 and then not Error_Posted (Unit_Node)
574 Remove_Unit_From_Visibility
575 (Defining_Entity (Instance_Spec (Unit_Node)));
577 elsif Nkind (Unit_Node) = N_Package_Body
578 or else (Nkind (Unit_Node) = N_Subprogram_Body
579 and then not Acts_As_Spec (Unit_Node))
581 -- Bodies that are not the main unit are compiled if they
582 -- are generic or contain generic or inlined units. Their
583 -- analysis brings in the context of the corresponding spec
584 -- (unit declaration) which must be removed as well, to
585 -- return the compilation environment to its proper state.
587 Remove_Context (Lib_Unit);
588 Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
591 -- Last step is to deinstall the context we just installed
592 -- as well as the unit just compiled.
596 -- If this is the main unit and we are generating code, we must
597 -- check that all generic units in the context have a body if they
598 -- need it, even if they have not been instantiated. In the absence
599 -- of .ali files for generic units, we must force the load of the body,
600 -- just to produce the proper error if the body is absent. We skip this
601 -- verification if the main unit itself is generic.
603 if Get_Cunit_Unit_Number (N) = Main_Unit
604 and then Operating_Mode = Generate_Code
605 and then Expander_Active
607 -- Check whether the source for the body of the unit must be
608 -- included in a standalone library.
610 Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
612 -- Indicate that the main unit is now analyzed, to catch possible
613 -- circularities between it and generic bodies. Remove main unit
614 -- from visibility. This might seem superfluous, but the main unit
615 -- must not be visible in the generic body expansions that follow.
617 Set_Analyzed (N, True);
618 Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
623 Un : Unit_Number_Type;
625 Save_Style_Check : constant Boolean := Style_Check;
626 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
627 Cunit_Boolean_Restrictions_Save;
630 Item := First (Context_Items (N));
631 while Present (Item) loop
633 -- Ada 2005 (AI-50217): Do not consider limited-withed units
635 if Nkind (Item) = N_With_Clause
636 and then not Implicit_With (Item)
637 and then not Limited_Present (Item)
639 Nam := Entity (Name (Item));
641 if (Is_Generic_Subprogram (Nam)
642 and then not Is_Intrinsic_Subprogram (Nam))
643 or else (Ekind (Nam) = E_Generic_Package
644 and then Unit_Requires_Body (Nam))
646 Style_Check := False;
648 if Present (Renamed_Object (Nam)) then
651 (Load_Name => Get_Body_Name
653 (Unit_Declaration_Node
654 (Renamed_Object (Nam)))),
662 (Load_Name => Get_Body_Name
663 (Get_Unit_Name (Item)),
672 ("body of generic unit& not found", Item, Nam);
675 elsif not Analyzed (Cunit (Un))
676 and then Un /= Main_Unit
677 and then not Fatal_Error (Un)
679 Style_Check := False;
680 Semantics (Cunit (Un));
688 Style_Check := Save_Style_Check;
689 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
693 -- Deal with creating elaboration Boolean if needed. We create an
694 -- elaboration boolean only for units that come from source since
695 -- units manufactured by the compiler never need elab checks.
697 if Comes_From_Source (N)
699 (Nkind (Unit (N)) = N_Package_Declaration or else
700 Nkind (Unit (N)) = N_Generic_Package_Declaration or else
701 Nkind (Unit (N)) = N_Subprogram_Declaration or else
702 Nkind (Unit (N)) = N_Generic_Subprogram_Declaration)
705 Loc : constant Source_Ptr := Sloc (N);
706 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
709 Spec_Id := Defining_Entity (Unit (N));
710 Generate_Definition (Spec_Id);
712 -- See if an elaboration entity is required for possible
713 -- access before elaboration checking. Note that we must
714 -- allow for this even if -gnatE is not set, since a client
715 -- may be compiled in -gnatE mode and reference the entity.
717 -- Case of units which do not require elaboration checks
720 -- Pure units do not need checks
724 -- Preelaborated units do not need checks
726 or else Is_Preelaborated (Spec_Id)
728 -- No checks needed if pagma Elaborate_Body present
730 or else Has_Pragma_Elaborate_Body (Spec_Id)
732 -- No checks needed if unit does not require a body
734 or else not Unit_Requires_Body (Spec_Id)
736 -- No checks needed for predefined files
738 or else Is_Predefined_File_Name (Unit_File_Name (Unum))
740 -- No checks required if no separate spec
742 or else Acts_As_Spec (N)
744 -- This is a case where we only need the entity for
745 -- checking to prevent multiple elaboration checks.
747 Set_Elaboration_Entity_Required (Spec_Id, False);
749 -- Case of elaboration entity is required for access before
750 -- elaboration checking (so certainly we must build it!)
753 Set_Elaboration_Entity_Required (Spec_Id, True);
756 Build_Elaboration_Entity (N, Spec_Id);
760 -- Finally, freeze the compilation unit entity. This for sure is needed
761 -- because of some warnings that can be output (see Freeze_Subprogram),
762 -- but may in general be required. If freezing actions result, place
763 -- them in the compilation unit actions list, and analyze them.
766 Loc : constant Source_Ptr := Sloc (N);
767 L : constant List_Id :=
768 Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
771 while Is_Non_Empty_List (L) loop
772 Insert_Library_Level_Action (Remove_Head (L));
778 if Nkind (Unit_Node) = N_Package_Declaration
779 and then Get_Cunit_Unit_Number (N) /= Main_Unit
780 and then Expander_Active
783 Save_Style_Check : constant Boolean := Style_Check;
784 Save_Warning : constant Warning_Mode_Type := Warning_Mode;
785 Options : Style_Check_Options;
788 Save_Style_Check_Options (Options);
789 Reset_Style_Check_Options;
790 Opt.Warning_Mode := Suppress;
791 Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
793 Reset_Style_Check_Options;
794 Set_Style_Check_Options (Options);
795 Style_Check := Save_Style_Check;
796 Warning_Mode := Save_Warning;
799 end Analyze_Compilation_Unit;
801 ---------------------
802 -- Analyze_Context --
803 ---------------------
805 procedure Analyze_Context (N : Node_Id) is
809 -- Loop through context items. This is done is three passes:
810 -- a) The first pass analyze non-limited with-clauses.
811 -- b) The second pass add implicit limited_with clauses for
812 -- the parents of child units (Ada 2005: AI-50217)
813 -- c) The third pass analyzes limited_with clauses (Ada 2005: AI-50217)
815 Item := First (Context_Items (N));
816 while Present (Item) loop
818 -- For with clause, analyze the with clause, and then update
819 -- the version, since we are dependent on a unit that we with.
821 if Nkind (Item) = N_With_Clause
822 and then not Limited_Present (Item)
825 -- Skip analyzing with clause if no unit, nothing to do (this
826 -- happens for a with that references a non-existant unit)
828 if Present (Library_Unit (Item)) then
832 if not Implicit_With (Item) then
833 Version_Update (N, Library_Unit (Item));
836 -- But skip use clauses at this stage, since we don't want to do
837 -- any installing of potentially use visible entities until we
838 -- we actually install the complete context (in Install_Context).
839 -- Otherwise things can get installed in the wrong context.
840 -- Similarly, pragmas are analyzed in Install_Context, after all
841 -- the implicit with's on parent units are generated.
850 -- Second pass: add implicit limited_with_clauses for parents of
851 -- child units mentioned in limited_with clauses.
853 Item := First (Context_Items (N));
855 while Present (Item) loop
856 if Nkind (Item) = N_With_Clause
857 and then Limited_Present (Item)
858 and then Nkind (Name (Item)) = N_Selected_Component
860 Expand_Limited_With_Clause
861 (Nam => Prefix (Name (Item)), N => Item);
867 -- Third pass: examine all limited_with clauses.
869 Item := First (Context_Items (N));
871 while Present (Item) loop
872 if Nkind (Item) = N_With_Clause
873 and then Limited_Present (Item)
876 if Nkind (Unit (N)) /= N_Package_Declaration then
877 Error_Msg_N ("limited with_clause only allowed in"
878 & " package specification", Item);
881 -- Skip analyzing with clause if no unit, see above.
883 if Present (Library_Unit (Item)) then
887 -- A limited_with does not impose an elaboration order, but
888 -- there is a semantic dependency for recompilation purposes.
890 if not Implicit_With (Item) then
891 Version_Update (N, Library_Unit (Item));
899 -------------------------------
900 -- Analyze_Package_Body_Stub --
901 -------------------------------
903 procedure Analyze_Package_Body_Stub (N : Node_Id) is
904 Id : constant Entity_Id := Defining_Identifier (N);
908 -- The package declaration must be in the current declarative part.
910 Check_Stub_Level (N);
911 Nam := Current_Entity_In_Scope (Id);
913 if No (Nam) or else not Is_Package (Nam) then
914 Error_Msg_N ("missing specification for package stub", N);
916 elsif Has_Completion (Nam)
917 and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
919 Error_Msg_N ("duplicate or redundant stub for package", N);
922 -- Indicate that the body of the package exists. If we are doing
923 -- only semantic analysis, the stub stands for the body. If we are
924 -- generating code, the existence of the body will be confirmed
925 -- when we load the proper body.
927 Set_Has_Completion (Nam);
928 Set_Scope (Defining_Entity (N), Current_Scope);
929 Generate_Reference (Nam, Id, 'b');
930 Analyze_Proper_Body (N, Nam);
932 end Analyze_Package_Body_Stub;
934 -------------------------
935 -- Analyze_Proper_Body --
936 -------------------------
938 procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
939 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
940 Unum : Unit_Number_Type;
942 procedure Optional_Subunit;
943 -- This procedure is called when the main unit is a stub, or when we
944 -- are not generating code. In such a case, we analyze the subunit if
945 -- present, which is user-friendly and in fact required for ASIS, but
946 -- we don't complain if the subunit is missing.
948 ----------------------
949 -- Optional_Subunit --
950 ----------------------
952 procedure Optional_Subunit is
956 -- Try to load subunit, but ignore any errors that occur during
957 -- the loading of the subunit, by using the special feature in
958 -- Errout to ignore all errors. Note that Fatal_Error will still
959 -- be set, so we will be able to check for this case below.
961 if not ASIS_Mode then
962 Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
967 (Load_Name => Subunit_Name,
972 if not ASIS_Mode then
973 Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
976 -- All done if we successfully loaded the subunit
979 and then (not Fatal_Error (Unum) or else Try_Semantics)
981 Comp_Unit := Cunit (Unum);
983 -- If the file was empty or seriously mangled, the unit
984 -- itself may be missing.
986 if No (Unit (Comp_Unit)) then
988 ("subunit does not contain expected proper body", N);
990 elsif Nkind (Unit (Comp_Unit)) /= N_Subunit then
992 ("expected SEPARATE subunit, found child unit",
993 Cunit_Entity (Unum));
995 Set_Corresponding_Stub (Unit (Comp_Unit), N);
996 Analyze_Subunit (Comp_Unit);
997 Set_Library_Unit (N, Comp_Unit);
1000 elsif Unum = No_Unit
1001 and then Present (Nam)
1003 if Is_Protected_Type (Nam) then
1004 Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
1006 Set_Corresponding_Body (
1007 Unit_Declaration_Node (Nam), Defining_Identifier (N));
1010 end Optional_Subunit;
1012 -- Start of processing for Analyze_Proper_Body
1015 -- If the subunit is already loaded, it means that the main unit
1016 -- is a subunit, and that the current unit is one of its parents
1017 -- which was being analyzed to provide the needed context for the
1018 -- analysis of the subunit. In this case we analyze the subunit and
1019 -- continue with the parent, without looking a subsequent subunits.
1021 if Is_Loaded (Subunit_Name) then
1023 -- If the proper body is already linked to the stub node,
1024 -- the stub is in a generic unit and just needs analyzing.
1026 if Present (Library_Unit (N)) then
1027 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1028 Analyze_Subunit (Library_Unit (N));
1030 -- Otherwise we must load the subunit and link to it
1033 -- Load the subunit, this must work, since we originally
1034 -- loaded the subunit earlier on. So this will not really
1035 -- load it, just give access to it.
1039 (Load_Name => Subunit_Name,
1044 -- And analyze the subunit in the parent context (note that we
1045 -- do not call Semantics, since that would remove the parent
1046 -- context). Because of this, we have to manually reset the
1047 -- compiler state to Analyzing since it got destroyed by Load.
1049 if Unum /= No_Unit then
1050 Compiler_State := Analyzing;
1052 -- Check that the proper body is a subunit and not a child
1053 -- unit. If the unit was previously loaded, the error will
1054 -- have been emitted when copying the generic node, so we
1055 -- just return to avoid cascaded errors.
1057 if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
1061 Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
1062 Analyze_Subunit (Cunit (Unum));
1063 Set_Library_Unit (N, Cunit (Unum));
1067 -- If the main unit is a subunit, then we are just performing semantic
1068 -- analysis on that subunit, and any other subunits of any parent unit
1069 -- should be ignored, except that if we are building trees for ASIS
1070 -- usage we want to annotate the stub properly.
1072 elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
1073 and then Subunit_Name /= Unit_Name (Main_Unit)
1079 -- But before we return, set the flag for unloaded subunits. This
1080 -- will suppress junk warnings of variables in the same declarative
1081 -- part (or a higher level one) that are in danger of looking unused
1082 -- when in fact there might be a declaration in the subunit that we
1083 -- do not intend to load.
1085 Unloaded_Subunits := True;
1088 -- If the subunit is not already loaded, and we are generating code,
1089 -- then this is the case where compilation started from the parent,
1090 -- and we are generating code for an entire subunit tree. In that
1091 -- case we definitely need to load the subunit.
1093 -- In order to continue the analysis with the rest of the parent,
1094 -- and other subunits, we load the unit without requiring its
1095 -- presence, and emit a warning if not found, rather than terminating
1096 -- the compilation abruptly, as for other missing file problems.
1098 elsif Original_Operating_Mode = Generate_Code then
1100 -- If the proper body is already linked to the stub node,
1101 -- the stub is in a generic unit and just needs analyzing.
1103 -- We update the version. Although we are not technically
1104 -- semantically dependent on the subunit, given our approach
1105 -- of macro substitution of subunits, it makes sense to
1106 -- include it in the version identification.
1108 if Present (Library_Unit (N)) then
1109 Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
1110 Analyze_Subunit (Library_Unit (N));
1111 Version_Update (Cunit (Main_Unit), Library_Unit (N));
1113 -- Otherwise we must load the subunit and link to it
1118 (Load_Name => Subunit_Name,
1123 if Original_Operating_Mode = Generate_Code
1124 and then Unum = No_Unit
1126 Error_Msg_Name_1 := Subunit_Name;
1128 Get_File_Name (Subunit_Name, Subunit => True);
1130 ("subunit% in file{ not found!?", N);
1131 Subunits_Missing := True;
1134 -- Load_Unit may reset Compiler_State, since it may have been
1135 -- necessary to parse an additional units, so we make sure
1136 -- that we reset it to the Analyzing state.
1138 Compiler_State := Analyzing;
1141 and then (not Fatal_Error (Unum) or else Try_Semantics)
1143 if Debug_Flag_L then
1144 Write_Str ("*** Loaded subunit from stub. Analyze");
1149 Comp_Unit : constant Node_Id := Cunit (Unum);
1152 -- Check for child unit instead of subunit
1154 if Nkind (Unit (Comp_Unit)) /= N_Subunit then
1156 ("expected SEPARATE subunit, found child unit",
1157 Cunit_Entity (Unum));
1159 -- OK, we have a subunit, so go ahead and analyze it,
1160 -- and set Scope of entity in stub, for ASIS use.
1163 Set_Corresponding_Stub (Unit (Comp_Unit), N);
1164 Analyze_Subunit (Comp_Unit);
1165 Set_Library_Unit (N, Comp_Unit);
1167 -- We update the version. Although we are not technically
1168 -- semantically dependent on the subunit, given our
1169 -- approach of macro substitution of subunits, it makes
1170 -- sense to include it in the version identification.
1172 Version_Update (Cunit (Main_Unit), Comp_Unit);
1178 -- The remaining case is when the subunit is not already loaded and
1179 -- we are not generating code. In this case we are just performing
1180 -- semantic analysis on the parent, and we are not interested in
1181 -- the subunit. For subprograms, analyze the stub as a body. For
1182 -- other entities the stub has already been marked as completed.
1188 end Analyze_Proper_Body;
1190 ----------------------------------
1191 -- Analyze_Protected_Body_Stub --
1192 ----------------------------------
1194 procedure Analyze_Protected_Body_Stub (N : Node_Id) is
1195 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1198 Check_Stub_Level (N);
1200 -- First occurence of name may have been as an incomplete type.
1202 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1203 Nam := Full_View (Nam);
1207 or else not Is_Protected_Type (Etype (Nam))
1209 Error_Msg_N ("missing specification for Protected body", N);
1211 Set_Scope (Defining_Entity (N), Current_Scope);
1212 Set_Has_Completion (Etype (Nam));
1213 Generate_Reference (Nam, Defining_Identifier (N), 'b');
1214 Analyze_Proper_Body (N, Etype (Nam));
1216 end Analyze_Protected_Body_Stub;
1218 ----------------------------------
1219 -- Analyze_Subprogram_Body_Stub --
1220 ----------------------------------
1222 -- A subprogram body stub can appear with or without a previous
1223 -- specification. If there is one, the analysis of the body will
1224 -- find it and verify conformance. The formals appearing in the
1225 -- specification of the stub play no role, except for requiring an
1226 -- additional conformance check. If there is no previous subprogram
1227 -- declaration, the stub acts as a spec, and provides the defining
1228 -- entity for the subprogram.
1230 procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
1234 Check_Stub_Level (N);
1236 -- Verify that the identifier for the stub is unique within this
1237 -- declarative part.
1239 if Nkind (Parent (N)) = N_Block_Statement
1240 or else Nkind (Parent (N)) = N_Package_Body
1241 or else Nkind (Parent (N)) = N_Subprogram_Body
1243 Decl := First (Declarations (Parent (N)));
1245 while Present (Decl)
1248 if Nkind (Decl) = N_Subprogram_Body_Stub
1249 and then (Chars (Defining_Unit_Name (Specification (Decl)))
1250 = Chars (Defining_Unit_Name (Specification (N))))
1252 Error_Msg_N ("identifier for stub is not unique", N);
1259 -- Treat stub as a body, which checks conformance if there is a previous
1260 -- declaration, or else introduces entity and its signature.
1262 Analyze_Subprogram_Body (N);
1263 Analyze_Proper_Body (N, Empty);
1264 end Analyze_Subprogram_Body_Stub;
1266 ---------------------
1267 -- Analyze_Subunit --
1268 ---------------------
1270 -- A subunit is compiled either by itself (for semantic checking)
1271 -- or as part of compiling the parent (for code generation). In
1272 -- either case, by the time we actually process the subunit, the
1273 -- parent has already been installed and analyzed. The node N is
1274 -- a compilation unit, whose context needs to be treated here,
1275 -- because we come directly here from the parent without calling
1276 -- Analyze_Compilation_Unit.
1278 -- The compilation context includes the explicit context of the
1279 -- subunit, and the context of the parent, together with the parent
1280 -- itself. In order to compile the current context, we remove the
1281 -- one inherited from the parent, in order to have a clean visibility
1282 -- table. We restore the parent context before analyzing the proper
1283 -- body itself. On exit, we remove only the explicit context of the
1286 procedure Analyze_Subunit (N : Node_Id) is
1287 Lib_Unit : constant Node_Id := Library_Unit (N);
1288 Par_Unit : constant Entity_Id := Current_Scope;
1290 Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
1291 Num_Scopes : Int := 0;
1292 Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
1293 Enclosing_Child : Entity_Id := Empty;
1294 Svg : constant Suppress_Array := Scope_Suppress;
1296 procedure Analyze_Subunit_Context;
1297 -- Capture names in use clauses of the subunit. This must be done
1298 -- before re-installing parent declarations, because items in the
1299 -- context must not be hidden by declarations local to the parent.
1301 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
1302 -- Recursive procedure to restore scope of all ancestors of subunit,
1303 -- from outermost in. If parent is not a subunit, the call to install
1304 -- context installs context of spec and (if parent is a child unit)
1305 -- the context of its parents as well. It is confusing that parents
1306 -- should be treated differently in both cases, but the semantics are
1307 -- just not identical.
1309 procedure Re_Install_Use_Clauses;
1310 -- As part of the removal of the parent scope, the use clauses are
1311 -- removed, to be reinstalled when the context of the subunit has
1312 -- been analyzed. Use clauses may also have been affected by the
1313 -- analysis of the context of the subunit, so they have to be applied
1314 -- again, to insure that the compilation environment of the rest of
1315 -- the parent unit is identical.
1317 procedure Remove_Scope;
1318 -- Remove current scope from scope stack, and preserve the list
1319 -- of use clauses in it, to be reinstalled after context is analyzed.
1321 -----------------------------
1322 -- Analyze_Subunit_Context --
1323 -----------------------------
1325 procedure Analyze_Subunit_Context is
1328 Unit_Name : Entity_Id;
1331 Analyze_Context (N);
1332 Item := First (Context_Items (N));
1334 -- make withed units immediately visible. If child unit, make the
1335 -- ultimate parent immediately visible.
1337 while Present (Item) loop
1339 if Nkind (Item) = N_With_Clause then
1340 Unit_Name := Entity (Name (Item));
1342 while Is_Child_Unit (Unit_Name) loop
1343 Set_Is_Visible_Child_Unit (Unit_Name);
1344 Unit_Name := Scope (Unit_Name);
1347 if not Is_Immediately_Visible (Unit_Name) then
1348 Set_Is_Immediately_Visible (Unit_Name);
1349 Set_Context_Installed (Item);
1352 elsif Nkind (Item) = N_Use_Package_Clause then
1353 Nam := First (Names (Item));
1355 while Present (Nam) loop
1360 elsif Nkind (Item) = N_Use_Type_Clause then
1361 Nam := First (Subtype_Marks (Item));
1363 while Present (Nam) loop
1372 Item := First (Context_Items (N));
1374 -- reset visibility of withed units. They will be made visible
1375 -- again when we install the subunit context.
1377 while Present (Item) loop
1379 if Nkind (Item) = N_With_Clause then
1380 Unit_Name := Entity (Name (Item));
1382 while Is_Child_Unit (Unit_Name) loop
1383 Set_Is_Visible_Child_Unit (Unit_Name, False);
1384 Unit_Name := Scope (Unit_Name);
1387 if Context_Installed (Item) then
1388 Set_Is_Immediately_Visible (Unit_Name, False);
1389 Set_Context_Installed (Item, False);
1396 end Analyze_Subunit_Context;
1398 ------------------------
1399 -- Re_Install_Parents --
1400 ------------------------
1402 procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
1406 if Nkind (Unit (L)) = N_Subunit then
1407 Re_Install_Parents (Library_Unit (L), Scope (Scop));
1410 Install_Context (L);
1412 -- If the subunit occurs within a child unit, we must restore the
1413 -- immediate visibility of any siblings that may occur in context.
1415 if Present (Enclosing_Child) then
1416 Install_Siblings (Enclosing_Child, L);
1421 if Scop /= Par_Unit then
1422 Set_Is_Immediately_Visible (Scop);
1425 E := First_Entity (Current_Scope);
1427 while Present (E) loop
1428 Set_Is_Immediately_Visible (E);
1432 -- A subunit appears within a body, and for a nested subunits
1433 -- all the parents are bodies. Restore full visibility of their
1434 -- private entities.
1436 if Ekind (Scop) = E_Package then
1437 Set_In_Package_Body (Scop);
1438 Install_Private_Declarations (Scop);
1440 end Re_Install_Parents;
1442 ----------------------------
1443 -- Re_Install_Use_Clauses --
1444 ----------------------------
1446 procedure Re_Install_Use_Clauses is
1450 for J in reverse 1 .. Num_Scopes loop
1451 U := Use_Clauses (J);
1452 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
1453 Install_Use_Clauses (U, Force_Installation => True);
1455 end Re_Install_Use_Clauses;
1461 procedure Remove_Scope is
1465 Num_Scopes := Num_Scopes + 1;
1466 Use_Clauses (Num_Scopes) :=
1467 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
1468 E := First_Entity (Current_Scope);
1470 while Present (E) loop
1471 Set_Is_Immediately_Visible (E, False);
1475 if Is_Child_Unit (Current_Scope) then
1476 Enclosing_Child := Current_Scope;
1482 -- Start of processing for Analyze_Subunit
1485 if not Is_Empty_List (Context_Items (N)) then
1487 -- Save current use clauses.
1490 Remove_Context (Lib_Unit);
1492 -- Now remove parents and their context, including enclosing
1493 -- subunits and the outer parent body which is not a subunit.
1495 if Present (Lib_Spec) then
1496 Remove_Context (Lib_Spec);
1498 while Nkind (Unit (Lib_Spec)) = N_Subunit loop
1499 Lib_Spec := Library_Unit (Lib_Spec);
1501 Remove_Context (Lib_Spec);
1504 if Nkind (Unit (Lib_Unit)) = N_Subunit then
1508 if Nkind (Unit (Lib_Spec)) = N_Package_Body then
1509 Remove_Context (Library_Unit (Lib_Spec));
1513 Set_Is_Immediately_Visible (Par_Unit, False);
1515 Analyze_Subunit_Context;
1517 Re_Install_Parents (Lib_Unit, Par_Unit);
1518 Set_Is_Immediately_Visible (Par_Unit);
1520 -- If the context includes a child unit of the parent of the
1521 -- subunit, the parent will have been removed from visibility,
1522 -- after compiling that cousin in the context. The visibility
1523 -- of the parent must be restored now. This also applies if the
1524 -- context includes another subunit of the same parent which in
1525 -- turn includes a child unit in its context.
1527 if Ekind (Par_Unit) = E_Package then
1528 if not Is_Immediately_Visible (Par_Unit)
1529 or else (Present (First_Entity (Par_Unit))
1530 and then not Is_Immediately_Visible
1531 (First_Entity (Par_Unit)))
1533 Set_Is_Immediately_Visible (Par_Unit);
1534 Install_Visible_Declarations (Par_Unit);
1535 Install_Private_Declarations (Par_Unit);
1539 Re_Install_Use_Clauses;
1540 Install_Context (N);
1542 -- Restore state of suppress flags for current body.
1544 Scope_Suppress := Svg;
1546 -- If the subunit is within a child unit, then siblings of any
1547 -- parent unit that appear in the context clause of the subunit
1548 -- must also be made immediately visible.
1550 if Present (Enclosing_Child) then
1551 Install_Siblings (Enclosing_Child, N);
1556 Analyze (Proper_Body (Unit (N)));
1558 end Analyze_Subunit;
1560 ----------------------------
1561 -- Analyze_Task_Body_Stub --
1562 ----------------------------
1564 procedure Analyze_Task_Body_Stub (N : Node_Id) is
1565 Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
1566 Loc : constant Source_Ptr := Sloc (N);
1569 Check_Stub_Level (N);
1571 -- First occurence of name may have been as an incomplete type.
1573 if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
1574 Nam := Full_View (Nam);
1578 or else not Is_Task_Type (Etype (Nam))
1580 Error_Msg_N ("missing specification for task body", N);
1582 Set_Scope (Defining_Entity (N), Current_Scope);
1583 Generate_Reference (Nam, Defining_Identifier (N), 'b');
1584 Set_Has_Completion (Etype (Nam));
1585 Analyze_Proper_Body (N, Etype (Nam));
1587 -- Set elaboration flag to indicate that entity is callable.
1588 -- This cannot be done in the expansion of the body itself,
1589 -- because the proper body is not in a declarative part. This
1590 -- is only done if expansion is active, because the context
1591 -- may be generic and the flag not defined yet.
1593 if Expander_Active then
1595 Make_Assignment_Statement (Loc,
1597 Make_Identifier (Loc,
1598 New_External_Name (Chars (Etype (Nam)), 'E')),
1599 Expression => New_Reference_To (Standard_True, Loc)));
1603 end Analyze_Task_Body_Stub;
1605 -------------------------
1606 -- Analyze_With_Clause --
1607 -------------------------
1609 -- Analyze the declaration of a unit in a with clause. At end,
1610 -- label the with clause with the defining entity for the unit.
1612 procedure Analyze_With_Clause (N : Node_Id) is
1614 -- Retrieve the original kind of the unit node, before analysis.
1615 -- If it is a subprogram instantiation, its analysis below will
1616 -- rewrite as the declaration of the wrapper package. If the same
1617 -- instantiation appears indirectly elsewhere in the context, it
1618 -- will have been analyzed already.
1620 Unit_Kind : constant Node_Kind :=
1621 Nkind (Original_Node (Unit (Library_Unit (N))));
1624 Par_Name : Entity_Id;
1629 -- Set True if the unit currently being compiled is an internal unit
1631 Save_Style_Check : constant Boolean := Opt.Style_Check;
1632 Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
1633 Cunit_Boolean_Restrictions_Save;
1636 if Limited_Present (N) then
1637 -- Ada 2005 (AI-50217): Build visibility structures but do not
1640 Build_Limited_Views (N);
1644 -- We reset ordinary style checking during the analysis of a with'ed
1645 -- unit, but we do NOT reset GNAT special analysis mode (the latter
1646 -- definitely *does* apply to with'ed units).
1648 if not GNAT_Mode then
1649 Style_Check := False;
1652 -- If the library unit is a predefined unit, and we are in high
1653 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
1654 -- for the analysis of the with'ed unit. This mode does not prevent
1655 -- explicit with'ing of run-time units.
1657 if Configurable_Run_Time_Mode
1659 Is_Predefined_File_Name
1660 (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
1662 Configurable_Run_Time_Mode := False;
1663 Semantics (Library_Unit (N));
1664 Configurable_Run_Time_Mode := True;
1667 Semantics (Library_Unit (N));
1670 U := Unit (Library_Unit (N));
1671 Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
1673 -- Following checks are skipped for dummy packages (those supplied
1674 -- for with's where no matching file could be found). Such packages
1675 -- are identified by the Sloc value being set to No_Location
1677 if Sloc (U) /= No_Location then
1679 -- Check restrictions, except that we skip the check if this
1680 -- is an internal unit unless we are compiling the internal
1681 -- unit as the main unit. We also skip this for dummy packages.
1683 if not Intunit or else Current_Sem_Unit = Main_Unit then
1684 Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
1687 -- Check for inappropriate with of internal implementation unit
1688 -- if we are currently compiling the main unit and the main unit
1689 -- is itself not an internal unit. We do not issue this message
1690 -- for implicit with's generated by the compiler itself.
1692 if Implementation_Unit_Warnings
1693 and then Current_Sem_Unit = Main_Unit
1694 and then Implementation_Unit (Get_Source_Unit (U))
1695 and then not Intunit
1696 and then not Implicit_With (N)
1698 Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
1700 ("\use of this unit is non-portable and version-dependent?",
1705 -- Semantic analysis of a generic unit is performed on a copy of
1706 -- the original tree. Retrieve the entity on which semantic info
1707 -- actually appears.
1709 if Unit_Kind in N_Generic_Declaration then
1710 E_Name := Defining_Entity (U);
1712 -- Note: in the following test, Unit_Kind is the original Nkind, but
1713 -- in the case of an instantiation, semantic analysis above will
1714 -- have replaced the unit by its instantiated version. If the instance
1715 -- body has been generated, the instance now denotes the body entity.
1716 -- For visibility purposes we need the entity of its spec.
1718 elsif (Unit_Kind = N_Package_Instantiation
1719 or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
1720 N_Package_Instantiation)
1721 and then Nkind (U) = N_Package_Body
1723 E_Name := Corresponding_Spec (U);
1725 elsif Unit_Kind = N_Package_Instantiation
1726 and then Nkind (U) = N_Package_Instantiation
1728 -- If the instance has not been rewritten as a package declaration,
1729 -- then it appeared already in a previous with clause. Retrieve
1730 -- the entity from the previous instance.
1732 E_Name := Defining_Entity (Specification (Instance_Spec (U)));
1734 elsif Unit_Kind = N_Procedure_Instantiation
1735 or else Unit_Kind = N_Function_Instantiation
1737 -- Instantiation node is replaced with a package that contains
1738 -- renaming declarations and instance itself. The subprogram
1739 -- Instance is declared in the visible part of the wrapper package.
1741 E_Name := First_Entity (Defining_Entity (U));
1743 while Present (E_Name) loop
1744 exit when Is_Subprogram (E_Name)
1745 and then Is_Generic_Instance (E_Name);
1746 E_Name := Next_Entity (E_Name);
1749 elsif Unit_Kind = N_Package_Renaming_Declaration
1750 or else Unit_Kind in N_Generic_Renaming_Declaration
1752 E_Name := Defining_Entity (U);
1754 elsif Unit_Kind = N_Subprogram_Body
1755 and then Nkind (Name (N)) = N_Selected_Component
1756 and then not Acts_As_Spec (Library_Unit (N))
1758 -- For a child unit that has no spec, one has been created and
1759 -- analyzed. The entity required is that of the spec.
1761 E_Name := Corresponding_Spec (U);
1764 E_Name := Defining_Entity (U);
1767 if Nkind (Name (N)) = N_Selected_Component then
1769 -- Child unit in a with clause
1771 Change_Selected_Component_To_Expanded_Name (Name (N));
1774 -- Restore style checks and restrictions
1776 Style_Check := Save_Style_Check;
1777 Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
1779 -- Record the reference, but do NOT set the unit as referenced, we
1780 -- want to consider the unit as unreferenced if this is the only
1781 -- reference that occurs.
1783 Set_Entity_With_Style_Check (Name (N), E_Name);
1784 Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
1786 if Is_Child_Unit (E_Name) then
1787 Pref := Prefix (Name (N));
1788 Par_Name := Scope (E_Name);
1790 while Nkind (Pref) = N_Selected_Component loop
1791 Change_Selected_Component_To_Expanded_Name (Pref);
1792 Set_Entity_With_Style_Check (Pref, Par_Name);
1794 Generate_Reference (Par_Name, Pref);
1795 Pref := Prefix (Pref);
1797 -- If E_Name is the dummy entity for a nonexistent unit,
1798 -- its scope is set to Standard_Standard, and no attempt
1799 -- should be made to further unwind scopes.
1801 if Par_Name /= Standard_Standard then
1802 Par_Name := Scope (Par_Name);
1806 if Present (Entity (Pref))
1807 and then not Analyzed (Parent (Parent (Entity (Pref))))
1809 -- If the entity is set without its unit being compiled,
1810 -- the original parent is a renaming, and Par_Name is the
1811 -- renamed entity. For visibility purposes, we need the
1812 -- original entity, which must be analyzed now, because
1813 -- Load_Unit retrieves directly the renamed unit, and the
1814 -- renaming declaration itself has not been analyzed.
1816 Analyze (Parent (Parent (Entity (Pref))));
1817 pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
1818 Par_Name := Entity (Pref);
1821 Set_Entity_With_Style_Check (Pref, Par_Name);
1822 Generate_Reference (Par_Name, Pref);
1825 -- If the withed unit is System, and a system extension pragma is
1826 -- present, compile the extension now, rather than waiting for
1827 -- a visibility check on a specific entity.
1829 if Chars (E_Name) = Name_System
1830 and then Scope (E_Name) = Standard_Standard
1831 and then Present (System_Extend_Unit)
1832 and then Present_System_Aux (N)
1834 -- If the extension is not present, an error will have been emitted.
1839 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
1840 -- to private_with units; they will be made visible later (just before
1841 -- the private part is analyzed)
1843 if Private_Present (N) then
1844 Set_Is_Immediately_Visible (E_Name, False);
1846 end Analyze_With_Clause;
1848 ------------------------------
1849 -- Analyze_With_Type_Clause --
1850 ------------------------------
1852 procedure Analyze_With_Type_Clause (N : Node_Id) is
1853 Loc : constant Source_Ptr := Sloc (N);
1854 Nam : constant Node_Id := Name (N);
1858 Unum : Unit_Number_Type;
1861 procedure Decorate_Tagged_Type (T : Entity_Id);
1862 -- Set basic attributes of type, including its class_wide type.
1864 function In_Chain (E : Entity_Id) return Boolean;
1865 -- Check that the imported type is not already in the homonym chain,
1866 -- for example through a with_type clause in a parent unit.
1868 --------------------------
1869 -- Decorate_Tagged_Type --
1870 --------------------------
1872 procedure Decorate_Tagged_Type (T : Entity_Id) is
1876 Set_Ekind (T, E_Record_Type);
1877 Set_Is_Tagged_Type (T);
1879 Set_From_With_Type (T);
1882 if not In_Chain (T) then
1883 Set_Homonym (T, Current_Entity (T));
1884 Set_Current_Entity (T);
1887 -- Build bogus class_wide type, if not previously done.
1889 if No (Class_Wide_Type (T)) then
1890 CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1892 Set_Ekind (CW, E_Class_Wide_Type);
1895 Set_Is_Tagged_Type (CW);
1896 Set_Is_First_Subtype (CW, True);
1897 Init_Size_Align (CW);
1898 Set_Has_Unknown_Discriminants
1900 Set_Class_Wide_Type (CW, CW);
1901 Set_Equivalent_Type (CW, Empty);
1902 Set_From_With_Type (CW);
1904 Set_Class_Wide_Type (T, CW);
1906 end Decorate_Tagged_Type;
1912 function In_Chain (E : Entity_Id) return Boolean is
1913 H : Entity_Id := Current_Entity (E);
1916 while Present (H) loop
1928 -- Start of processing for Analyze_With_Type_Clause
1931 if Nkind (Nam) = N_Selected_Component then
1932 Pack := New_Copy_Tree (Prefix (Nam));
1933 Sel := Selector_Name (Nam);
1936 Error_Msg_N ("illegal name for imported type", Nam);
1941 Make_Package_Declaration (Loc,
1943 (Make_Package_Specification (Loc,
1944 Defining_Unit_Name => Pack,
1945 Visible_Declarations => New_List,
1946 End_Label => Empty)));
1950 (Load_Name => Get_Unit_Name (Decl),
1956 or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
1958 Error_Msg_N ("imported type must be declared in package", Nam);
1961 elsif Unum = Current_Sem_Unit then
1963 -- If type is defined in unit being analyzed, then the clause
1969 P := Cunit_Entity (Unum);
1972 -- Find declaration for imported type, and set its basic attributes
1973 -- if it has not been analyzed (which will be the case if there is
1974 -- circular dependence).
1981 if not Analyzed (Cunit (Unum))
1982 and then not From_With_Type (P)
1984 Set_Ekind (P, E_Package);
1985 Set_Etype (P, Standard_Void_Type);
1986 Set_From_With_Type (P);
1987 Set_Scope (P, Standard_Standard);
1988 Set_Homonym (P, Current_Entity (P));
1989 Set_Current_Entity (P);
1991 elsif Analyzed (Cunit (Unum))
1992 and then Is_Child_Unit (P)
1994 -- If the child unit is already in scope, indicate that it is
1995 -- visible, and remains so after intervening calls to rtsfind.
1997 Set_Is_Visible_Child_Unit (P);
2000 if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
2002 -- Make parent packages visible.
2005 Parent_Comp : Node_Id;
2006 Parent_Id : Entity_Id;
2011 Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
2014 Parent_Id := Defining_Entity (Unit (Parent_Comp));
2015 Set_Scope (Child, Parent_Id);
2017 -- The type may be imported from a child unit, in which
2018 -- case the current compilation appears in the name. Do
2019 -- not change its visibility here because it will conflict
2020 -- with the subsequent normal processing.
2022 if not Analyzed (Unit_Declaration_Node (Parent_Id))
2023 and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
2025 Set_Ekind (Parent_Id, E_Package);
2026 Set_Etype (Parent_Id, Standard_Void_Type);
2028 -- The same package may appear is several with_type
2031 if not From_With_Type (Parent_Id) then
2032 Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
2033 Set_Current_Entity (Parent_Id);
2034 Set_From_With_Type (Parent_Id);
2038 Set_Is_Immediately_Visible (Parent_Id);
2041 Parent_Comp := Parent_Spec (Unit (Parent_Comp));
2042 exit when No (Parent_Comp);
2045 Set_Scope (Parent_Id, Standard_Standard);
2049 -- Even if analyzed, the package may not be currently visible. It
2050 -- must be while the with_type clause is active.
2052 Set_Is_Immediately_Visible (P);
2055 First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
2057 while Present (Decl) loop
2059 if Nkind (Decl) = N_Full_Type_Declaration
2060 and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2062 Typ := Defining_Identifier (Decl);
2064 if Tagged_Present (N) then
2066 -- The declaration must indicate that this is a tagged
2067 -- type or a type extension.
2069 if (Nkind (Type_Definition (Decl)) = N_Record_Definition
2070 and then Tagged_Present (Type_Definition (Decl)))
2072 (Nkind (Type_Definition (Decl))
2073 = N_Derived_Type_Definition
2075 (Record_Extension_Part (Type_Definition (Decl))))
2079 Error_Msg_N ("imported type is not a tagged type", Nam);
2083 if not Analyzed (Decl) then
2085 -- Unit is not currently visible. Add basic attributes
2086 -- to type and build its class-wide type.
2088 Init_Size_Align (Typ);
2089 Decorate_Tagged_Type (Typ);
2093 if Nkind (Type_Definition (Decl))
2094 /= N_Access_To_Object_Definition
2097 ("imported type is not an access type", Nam);
2099 elsif not Analyzed (Decl) then
2100 Set_Ekind (Typ, E_Access_Type);
2101 Set_Etype (Typ, Typ);
2103 Init_Size (Typ, System_Address_Size);
2104 Init_Alignment (Typ);
2105 Set_Directly_Designated_Type (Typ, Standard_Integer);
2106 Set_From_With_Type (Typ);
2108 if not In_Chain (Typ) then
2109 Set_Homonym (Typ, Current_Entity (Typ));
2110 Set_Current_Entity (Typ);
2115 Set_Entity (Sel, Typ);
2118 elsif ((Nkind (Decl) = N_Private_Type_Declaration
2119 and then Tagged_Present (Decl))
2120 or else (Nkind (Decl) = N_Private_Extension_Declaration))
2121 and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
2123 Typ := Defining_Identifier (Decl);
2125 if not Tagged_Present (N) then
2126 Error_Msg_N ("type must be declared tagged", N);
2128 elsif not Analyzed (Decl) then
2129 Decorate_Tagged_Type (Typ);
2132 Set_Entity (Sel, Typ);
2133 Set_From_With_Type (Typ);
2137 Decl := Next (Decl);
2140 Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
2142 end Analyze_With_Type_Clause;
2144 -----------------------------
2145 -- Check_With_Type_Clauses --
2146 -----------------------------
2148 procedure Check_With_Type_Clauses (N : Node_Id) is
2149 Lib_Unit : constant Node_Id := Unit (N);
2151 procedure Check_Parent_Context (U : Node_Id);
2152 -- Examine context items of parent unit to locate with_type clauses.
2154 --------------------------
2155 -- Check_Parent_Context --
2156 --------------------------
2158 procedure Check_Parent_Context (U : Node_Id) is
2162 Item := First (Context_Items (U));
2163 while Present (Item) loop
2164 if Nkind (Item) = N_With_Type_Clause
2165 and then not Error_Posted (Item)
2167 From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
2169 Error_Msg_Sloc := Sloc (Item);
2170 Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
2175 end Check_Parent_Context;
2177 -- Start of processing for Check_With_Type_Clauses
2180 if Extensions_Allowed
2181 and then (Nkind (Lib_Unit) = N_Package_Body
2182 or else Nkind (Lib_Unit) = N_Subprogram_Body)
2184 Check_Parent_Context (Library_Unit (N));
2186 if Is_Child_Spec (Unit (Library_Unit (N))) then
2187 Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
2190 end Check_With_Type_Clauses;
2192 ------------------------------
2193 -- Check_Private_Child_Unit --
2194 ------------------------------
2196 procedure Check_Private_Child_Unit (N : Node_Id) is
2197 Lib_Unit : constant Node_Id := Unit (N);
2199 Curr_Unit : Entity_Id;
2200 Sub_Parent : Node_Id;
2201 Priv_Child : Entity_Id;
2202 Par_Lib : Entity_Id;
2205 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
2206 -- Returns true if and only if the library unit is declared with
2207 -- an explicit designation of private.
2209 function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
2210 Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
2213 return Private_Present (Comp_Unit);
2214 end Is_Private_Library_Unit;
2216 -- Start of processing for Check_Private_Child_Unit
2219 if Nkind (Lib_Unit) = N_Package_Body
2220 or else Nkind (Lib_Unit) = N_Subprogram_Body
2222 Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
2223 Par_Lib := Curr_Unit;
2225 elsif Nkind (Lib_Unit) = N_Subunit then
2227 -- The parent is itself a body. The parent entity is to be found
2228 -- in the corresponding spec.
2230 Sub_Parent := Library_Unit (N);
2231 Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
2233 -- If the parent itself is a subunit, Curr_Unit is the entity
2234 -- of the enclosing body, retrieve the spec entity which is
2235 -- the proper ancestor we need for the following tests.
2237 if Ekind (Curr_Unit) = E_Package_Body then
2238 Curr_Unit := Spec_Entity (Curr_Unit);
2241 Par_Lib := Curr_Unit;
2244 Curr_Unit := Defining_Entity (Lib_Unit);
2246 Par_Lib := Curr_Unit;
2247 Par_Spec := Parent_Spec (Lib_Unit);
2249 if No (Par_Spec) then
2252 Par_Lib := Defining_Entity (Unit (Par_Spec));
2256 -- Loop through context items
2258 Item := First (Context_Items (N));
2259 while Present (Item) loop
2261 -- Ada 2005 (AI-262): Allow private_with of a private child package
2262 -- in public siblings
2264 if Nkind (Item) = N_With_Clause
2265 and then not Implicit_With (Item)
2266 and then not Private_Present (Item)
2267 and then Is_Private_Descendant (Entity (Name (Item)))
2269 Priv_Child := Entity (Name (Item));
2272 Curr_Parent : Entity_Id := Par_Lib;
2273 Child_Parent : Entity_Id := Scope (Priv_Child);
2274 Prv_Ancestor : Entity_Id := Child_Parent;
2275 Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
2278 -- If the child unit is a public child then locate
2279 -- the nearest private ancestor; Child_Parent will
2280 -- then be set to the parent of that ancestor.
2282 if not Is_Private_Library_Unit (Priv_Child) then
2283 while Present (Prv_Ancestor)
2284 and then not Is_Private_Library_Unit (Prv_Ancestor)
2286 Prv_Ancestor := Scope (Prv_Ancestor);
2289 if Present (Prv_Ancestor) then
2290 Child_Parent := Scope (Prv_Ancestor);
2294 while Present (Curr_Parent)
2295 and then Curr_Parent /= Standard_Standard
2296 and then Curr_Parent /= Child_Parent
2299 Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
2300 Curr_Parent := Scope (Curr_Parent);
2303 if not Present (Curr_Parent) then
2304 Curr_Parent := Standard_Standard;
2307 if Curr_Parent /= Child_Parent then
2309 if Ekind (Priv_Child) = E_Generic_Package
2310 and then Chars (Priv_Child) in Text_IO_Package_Name
2311 and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
2314 ("& is a nested package, not a compilation unit",
2315 Name (Item), Priv_Child);
2319 ("unit in with clause is private child unit!", Item);
2321 ("current unit must also have parent&!",
2322 Item, Child_Parent);
2325 elsif not Curr_Private
2326 and then Nkind (Lib_Unit) /= N_Package_Body
2327 and then Nkind (Lib_Unit) /= N_Subprogram_Body
2328 and then Nkind (Lib_Unit) /= N_Subunit
2331 ("current unit must also be private descendant of&",
2332 Item, Child_Parent);
2340 end Check_Private_Child_Unit;
2342 ----------------------
2343 -- Check_Stub_Level --
2344 ----------------------
2346 procedure Check_Stub_Level (N : Node_Id) is
2347 Par : constant Node_Id := Parent (N);
2348 Kind : constant Node_Kind := Nkind (Par);
2351 if (Kind = N_Package_Body
2352 or else Kind = N_Subprogram_Body
2353 or else Kind = N_Task_Body
2354 or else Kind = N_Protected_Body)
2356 and then (Nkind (Parent (Par)) = N_Compilation_Unit
2357 or else Nkind (Parent (Par)) = N_Subunit)
2361 -- In an instance, a missing stub appears at any level. A warning
2362 -- message will have been emitted already for the missing file.
2364 elsif not In_Instance then
2365 Error_Msg_N ("stub cannot appear in an inner scope", N);
2367 elsif Expander_Active then
2368 Error_Msg_N ("missing proper body", N);
2370 end Check_Stub_Level;
2372 ------------------------
2373 -- Expand_With_Clause --
2374 ------------------------
2376 procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is
2377 Loc : constant Source_Ptr := Sloc (Nam);
2378 Ent : constant Entity_Id := Entity (Nam);
2382 function Build_Unit_Name (Nam : Node_Id) return Node_Id;
2384 function Build_Unit_Name (Nam : Node_Id) return Node_Id is
2388 if Nkind (Nam) = N_Identifier then
2389 return New_Occurrence_Of (Entity (Nam), Loc);
2393 Make_Expanded_Name (Loc,
2394 Chars => Chars (Entity (Nam)),
2395 Prefix => Build_Unit_Name (Prefix (Nam)),
2396 Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
2397 Set_Entity (Result, Entity (Nam));
2400 end Build_Unit_Name;
2403 New_Nodes_OK := New_Nodes_OK + 1;
2405 Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
2407 P := Parent (Unit_Declaration_Node (Ent));
2408 Set_Library_Unit (Withn, P);
2409 Set_Corresponding_Spec (Withn, Ent);
2410 Set_First_Name (Withn, True);
2411 Set_Implicit_With (Withn, True);
2413 Prepend (Withn, Context_Items (N));
2414 Mark_Rewrite_Insertion (Withn);
2415 Install_Withed_Unit (Withn);
2417 if Nkind (Nam) = N_Expanded_Name then
2418 Expand_With_Clause (Prefix (Nam), N);
2421 New_Nodes_OK := New_Nodes_OK - 1;
2422 end Expand_With_Clause;
2424 --------------------------------
2425 -- Expand_Limited_With_Clause --
2426 --------------------------------
2428 procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
2429 Loc : constant Source_Ptr := Sloc (Nam);
2430 Unum : Unit_Number_Type;
2434 New_Nodes_OK := New_Nodes_OK + 1;
2436 if Nkind (Nam) = N_Identifier then
2438 Make_With_Clause (Loc, Name => Nam);
2439 Set_Limited_Present (Withn);
2440 Set_First_Name (Withn);
2441 Set_Implicit_With (Withn);
2443 -- Load the corresponding parent unit
2447 (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
2452 if not Analyzed (Cunit (Unum)) then
2453 Set_Library_Unit (Withn, Cunit (Unum));
2454 Set_Corresponding_Spec
2455 (Withn, Specification (Unit (Cunit (Unum))));
2457 Prepend (Withn, Context_Items (Parent (N)));
2458 Mark_Rewrite_Insertion (Withn);
2461 else pragma Assert (Nkind (Nam) = N_Selected_Component);
2466 Make_Selected_Component
2468 Prefix => Prefix (Nam),
2469 Selector_Name => Selector_Name (Nam)));
2471 Set_Parent (Withn, Parent (N));
2472 Set_Limited_Present (Withn);
2473 Set_First_Name (Withn);
2474 Set_Implicit_With (Withn);
2478 (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
2483 if not Analyzed (Cunit (Unum)) then
2484 Set_Library_Unit (Withn, Cunit (Unum));
2485 Set_Corresponding_Spec
2486 (Withn, Specification (Unit (Cunit (Unum))));
2487 Prepend (Withn, Context_Items (Parent (N)));
2488 Mark_Rewrite_Insertion (Withn);
2490 Expand_Limited_With_Clause (Prefix (Nam), N);
2494 New_Nodes_OK := New_Nodes_OK - 1;
2495 end Expand_Limited_With_Clause;
2497 -----------------------
2498 -- Get_Parent_Entity --
2499 -----------------------
2501 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
2503 if Nkind (Unit) = N_Package_Body
2504 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
2508 (Specification (Instance_Spec (Original_Node (Unit))));
2510 elsif Nkind (Unit) = N_Package_Instantiation then
2511 return Defining_Entity (Specification (Instance_Spec (Unit)));
2514 return Defining_Entity (Unit);
2516 end Get_Parent_Entity;
2518 -----------------------------
2519 -- Implicit_With_On_Parent --
2520 -----------------------------
2522 procedure Implicit_With_On_Parent
2523 (Child_Unit : Node_Id;
2526 Loc : constant Source_Ptr := Sloc (N);
2527 P : constant Node_Id := Parent_Spec (Child_Unit);
2529 P_Unit : Node_Id := Unit (P);
2531 P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
2534 function Build_Ancestor_Name (P : Node_Id) return Node_Id;
2535 -- Build prefix of child unit name. Recurse if needed.
2537 function Build_Unit_Name return Node_Id;
2538 -- If the unit is a child unit, build qualified name with all
2541 -------------------------
2542 -- Build_Ancestor_Name --
2543 -------------------------
2545 function Build_Ancestor_Name (P : Node_Id) return Node_Id is
2546 P_Ref : constant Node_Id :=
2547 New_Reference_To (Defining_Entity (P), Loc);
2549 if No (Parent_Spec (P)) then
2553 Make_Selected_Component (Loc,
2554 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
2555 Selector_Name => P_Ref);
2557 end Build_Ancestor_Name;
2559 ---------------------
2560 -- Build_Unit_Name --
2561 ---------------------
2563 function Build_Unit_Name return Node_Id is
2566 if No (Parent_Spec (P_Unit)) then
2567 return New_Reference_To (P_Name, Loc);
2570 Make_Expanded_Name (Loc,
2571 Chars => Chars (P_Name),
2572 Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
2573 Selector_Name => New_Reference_To (P_Name, Loc));
2574 Set_Entity (Result, P_Name);
2577 end Build_Unit_Name;
2579 -- Start of processing for Implicit_With_On_Parent
2582 -- The unit of the current compilation may be a package body
2583 -- that replaces an instance node. In this case we need the
2584 -- original instance node to construct the proper parent name.
2586 if Nkind (P_Unit) = N_Package_Body
2587 and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
2589 P_Unit := Original_Node (P_Unit);
2592 New_Nodes_OK := New_Nodes_OK + 1;
2593 Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
2595 Set_Library_Unit (Withn, P);
2596 Set_Corresponding_Spec (Withn, P_Name);
2597 Set_First_Name (Withn, True);
2598 Set_Implicit_With (Withn, True);
2600 -- Node is placed at the beginning of the context items, so that
2601 -- subsequent use clauses on the parent can be validated.
2603 Prepend (Withn, Context_Items (N));
2604 Mark_Rewrite_Insertion (Withn);
2605 Install_Withed_Unit (Withn);
2607 if Is_Child_Spec (P_Unit) then
2608 Implicit_With_On_Parent (P_Unit, N);
2611 New_Nodes_OK := New_Nodes_OK - 1;
2612 end Implicit_With_On_Parent;
2614 ---------------------
2615 -- Install_Context --
2616 ---------------------
2618 procedure Install_Context (N : Node_Id) is
2619 Lib_Unit : constant Node_Id := Unit (N);
2622 Install_Context_Clauses (N);
2624 if Is_Child_Spec (Lib_Unit) then
2625 Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
2628 Install_Limited_Context_Clauses (N);
2630 Check_With_Type_Clauses (N);
2631 end Install_Context;
2633 -----------------------------
2634 -- Install_Context_Clauses --
2635 -----------------------------
2637 procedure Install_Context_Clauses (N : Node_Id) is
2638 Lib_Unit : constant Node_Id := Unit (N);
2640 Uname_Node : Entity_Id;
2641 Check_Private : Boolean := False;
2642 Decl_Node : Node_Id;
2643 Lib_Parent : Entity_Id;
2646 -- Loop through context clauses to find the with/use clauses.
2647 -- This is done twice, first for everything except limited_with
2648 -- clauses, and then for those, if any are present.
2650 Item := First (Context_Items (N));
2651 while Present (Item) loop
2653 -- Case of explicit WITH clause
2655 if Nkind (Item) = N_With_Clause
2656 and then not Implicit_With (Item)
2658 if Limited_Present (Item) then
2660 -- Limited withed units will be installed later.
2664 -- If Name (Item) is not an entity name, something is wrong, and
2665 -- this will be detected in due course, for now ignore the item
2667 elsif not Is_Entity_Name (Name (Item)) then
2670 elsif No (Entity (Name (Item))) then
2671 Set_Entity (Name (Item), Any_Id);
2675 Uname_Node := Entity (Name (Item));
2677 if Is_Private_Descendant (Uname_Node) then
2678 Check_Private := True;
2681 Install_Withed_Unit (Item);
2683 Decl_Node := Unit_Declaration_Node (Uname_Node);
2685 -- If the unit is a subprogram instance, it appears nested
2686 -- within a package that carries the parent information.
2688 if Is_Generic_Instance (Uname_Node)
2689 and then Ekind (Uname_Node) /= E_Package
2691 Decl_Node := Parent (Parent (Decl_Node));
2694 if Is_Child_Spec (Decl_Node) then
2695 if Nkind (Name (Item)) = N_Expanded_Name then
2696 Expand_With_Clause (Prefix (Name (Item)), N);
2698 -- if not an expanded name, the child unit must be a
2699 -- renaming, nothing to do.
2704 elsif Nkind (Decl_Node) = N_Subprogram_Body
2705 and then not Acts_As_Spec (Parent (Decl_Node))
2706 and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
2708 Implicit_With_On_Parent
2709 (Unit (Library_Unit (Parent (Decl_Node))), N);
2712 -- Check license conditions unless this is a dummy unit
2714 if Sloc (Library_Unit (Item)) /= No_Location then
2715 License_Check : declare
2716 Withl : constant License_Type :=
2717 License (Source_Index
2719 (Library_Unit (Item))));
2721 Unitl : constant License_Type :=
2722 License (Source_Index (Current_Sem_Unit));
2724 procedure License_Error;
2725 -- Signal error of bad license
2731 procedure License_Error is
2734 ("?license of with'ed unit & is incompatible",
2738 -- Start of processing for License_Check
2751 if Withl = Restricted then
2755 when Modified_GPL =>
2756 if Withl = Restricted or else Withl = GPL then
2760 when Unrestricted =>
2766 -- Case of USE PACKAGE clause
2768 elsif Nkind (Item) = N_Use_Package_Clause then
2769 Analyze_Use_Package (Item);
2771 -- Case of USE TYPE clause
2773 elsif Nkind (Item) = N_Use_Type_Clause then
2774 Analyze_Use_Type (Item);
2776 -- Case of WITH TYPE clause
2778 -- A With_Type_Clause is processed when installing the context,
2779 -- because it is a visibility mechanism and does not create a
2780 -- semantic dependence on other units, as a With_Clause does.
2782 elsif Nkind (Item) = N_With_Type_Clause then
2783 Analyze_With_Type_Clause (Item);
2787 elsif Nkind (Item) = N_Pragma then
2795 if Is_Child_Spec (Lib_Unit) then
2797 -- The unit also has implicit withs on its own parents
2799 if No (Context_Items (N)) then
2800 Set_Context_Items (N, New_List);
2803 Implicit_With_On_Parent (Lib_Unit, N);
2806 -- If the unit is a body, the context of the specification must also
2809 if Nkind (Lib_Unit) = N_Package_Body
2810 or else (Nkind (Lib_Unit) = N_Subprogram_Body
2811 and then not Acts_As_Spec (N))
2813 Install_Context (Library_Unit (N));
2815 if Is_Child_Spec (Unit (Library_Unit (N))) then
2817 -- If the unit is the body of a public child unit, the private
2818 -- declarations of the parent must be made visible. If the child
2819 -- unit is private, the private declarations have been installed
2820 -- already in the call to Install_Parents for the spec. Installing
2821 -- private declarations must be done for all ancestors of public
2822 -- child units. In addition, sibling units mentioned in the
2823 -- context clause of the body are directly visible.
2826 Lib_Spec : Node_Id := Unit (Library_Unit (N));
2831 while Is_Child_Spec (Lib_Spec) loop
2832 P := Unit (Parent_Spec (Lib_Spec));
2834 if not (Private_Present (Parent (Lib_Spec))) then
2835 P_Name := Defining_Entity (P);
2836 Install_Private_Declarations (P_Name);
2837 Install_Private_With_Clauses (P_Name);
2838 Set_Use (Private_Declarations (Specification (P)));
2846 -- For a package body, children in context are immediately visible
2848 Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
2851 if Nkind (Lib_Unit) = N_Generic_Package_Declaration
2852 or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
2853 or else Nkind (Lib_Unit) = N_Package_Declaration
2854 or else Nkind (Lib_Unit) = N_Subprogram_Declaration
2856 if Is_Child_Spec (Lib_Unit) then
2857 Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
2858 Set_Is_Private_Descendant
2859 (Defining_Entity (Lib_Unit),
2860 Is_Private_Descendant (Lib_Parent)
2861 or else Private_Present (Parent (Lib_Unit)));
2864 Set_Is_Private_Descendant
2865 (Defining_Entity (Lib_Unit),
2866 Private_Present (Parent (Lib_Unit)));
2870 if Check_Private then
2871 Check_Private_Child_Unit (N);
2873 end Install_Context_Clauses;
2875 -------------------------------------
2876 -- Install_Limited_Context_Clauses --
2877 -------------------------------------
2879 procedure Install_Limited_Context_Clauses (N : Node_Id) is
2882 procedure Check_Parent (P : Node_Id; W : Node_Id);
2883 -- Check that the unlimited view of a given compilation_unit is not
2884 -- already visible in the parents (neither immediately through the
2885 -- context clauses, nor indirectly through "use + renamings").
2887 procedure Check_Private_Limited_Withed_Unit (N : Node_Id);
2888 -- Check that if a limited_with clause of a given compilation_unit
2889 -- mentions a private child of some library unit, then the given
2890 -- compilation_unit shall be the declaration of a private descendant
2891 -- of that library unit.
2893 procedure Check_Withed_Unit (W : Node_Id);
2894 -- Check that a limited with_clause does not appear in the same
2895 -- context_clause as a nonlimited with_clause that mentions
2896 -- the same library.
2902 procedure Check_Parent (P : Node_Id; W : Node_Id) is
2911 pragma Assert (Nkind (W) = N_With_Clause);
2913 -- Step 1: Check if the unlimited view is installed in the parent
2915 Item := First (Context_Items (P));
2916 while Present (Item) loop
2917 if Nkind (Item) = N_With_Clause
2918 and then not Limited_Present (Item)
2919 and then not Implicit_With (Item)
2920 and then Library_Unit (Item) = Library_Unit (W)
2922 Error_Msg_N ("unlimited view visible in ancestor", W);
2929 -- Step 2: Check "use + renamings"
2931 WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
2932 Spec := Specification (Unit (P));
2934 -- We tried to traverse the list of entities corresponding to the
2935 -- defining entity of the package spec. However, first_entity was
2936 -- found to be 'empty'. Don't know why???
2938 -- Def := Defining_Unit_Name (Spec);
2939 -- Ent := First_Entity (Def);
2941 -- As a workaround we traverse the list of visible declarations ???
2943 Item := First (Visible_Declarations (Spec));
2944 while Present (Item) loop
2946 if Nkind (Item) = N_Use_Package_Clause then
2948 -- Traverse the list of packages
2950 Nam := First (Names (Item));
2952 while Present (Nam) loop
2955 pragma Assert (Present (Parent (E)));
2957 if Nkind (Parent (E))
2958 = N_Package_Renaming_Declaration
2959 and then Renamed_Entity (E) = WEnt
2961 Error_Msg_N ("unlimited view visible through "
2962 & "use_clause + renamings", W);
2965 elsif Nkind (Parent (E)) = N_Package_Specification then
2967 -- The use clause may refer to a local package.
2968 -- Check all the enclosing scopes.
2971 while E2 /= Standard_Standard
2972 and then E2 /= WEnt loop
2977 Error_Msg_N ("unlimited view visible through "
2978 & "use_clause ", W);
2991 -- Recursive call to check all the ancestors
2993 if Is_Child_Spec (Unit (P)) then
2994 Check_Parent (P => Parent_Spec (Unit (P)), W => W);
2998 ---------------------------------------
2999 -- Check_Private_Limited_Withed_Unit --
3000 ---------------------------------------
3002 procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is
3005 Found : Boolean := False;
3008 -- If the current compilation unit is not private we don't
3009 -- need to check anything else.
3011 if not Private_Present (Parent (N)) then
3015 -- Compilation unit of the parent of the withed library unit
3017 P := Parent_Spec (Unit (Library_Unit (N)));
3019 -- Traverse all the ancestors of the current compilation
3020 -- unit to check if it is a descendant of named library unit.
3023 while Present (Parent_Spec (Unit (C))) loop
3024 C := Parent_Spec (Unit (C));
3034 Error_Msg_N ("current unit is not a private descendant"
3035 & " of the withed unit ('R'M 10.1.2(8)", N);
3037 end Check_Private_Limited_Withed_Unit;
3039 -----------------------
3040 -- Check_Withed_Unit --
3041 -----------------------
3043 procedure Check_Withed_Unit (W : Node_Id) is
3047 -- A limited with_clause can not appear in the same context_clause
3048 -- as a nonlimited with_clause which mentions the same library.
3050 Item := First (Context_Items (N));
3051 while Present (Item) loop
3052 if Nkind (Item) = N_With_Clause
3053 and then not Limited_Present (Item)
3054 and then not Implicit_With (Item)
3055 and then Library_Unit (Item) = Library_Unit (W)
3057 Error_Msg_N ("limited and unlimited view "
3058 & "not allowed in the same context clauses", W);
3064 end Check_Withed_Unit;
3066 -- Start of processing for Install_Limited_Context_Clauses
3069 Item := First (Context_Items (N));
3070 while Present (Item) loop
3071 if Nkind (Item) = N_With_Clause
3072 and then Limited_Present (Item)
3074 Check_Withed_Unit (Item);
3076 if Private_Present (Library_Unit (Item)) then
3077 Check_Private_Limited_Withed_Unit (Item);
3080 if Is_Child_Spec (Unit (N)) then
3081 Check_Parent (Parent_Spec (Unit (N)), Item);
3084 Install_Limited_Withed_Unit (Item);
3089 end Install_Limited_Context_Clauses;
3091 ---------------------
3092 -- Install_Parents --
3093 ---------------------
3095 procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
3102 P := Unit (Parent_Spec (Lib_Unit));
3103 P_Name := Get_Parent_Entity (P);
3105 if Etype (P_Name) = Any_Type then
3109 if Ekind (P_Name) = E_Generic_Package
3110 and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
3111 and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
3112 and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
3115 ("child of a generic package must be a generic unit", Lib_Unit);
3117 elsif not Is_Package (P_Name) then
3119 ("parent unit must be package or generic package", Lib_Unit);
3120 raise Unrecoverable_Error;
3122 elsif Present (Renamed_Object (P_Name)) then
3123 Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
3124 raise Unrecoverable_Error;
3126 -- Verify that a child of an instance is itself an instance, or
3127 -- the renaming of one. Given that an instance that is a unit is
3128 -- replaced with a package declaration, check against the original
3131 elsif Nkind (Original_Node (P)) = N_Package_Instantiation
3132 and then Nkind (Lib_Unit)
3133 not in N_Renaming_Declaration
3134 and then Nkind (Original_Node (Lib_Unit))
3135 not in N_Generic_Instantiation
3138 ("child of an instance must be an instance or renaming", Lib_Unit);
3141 -- This is the recursive call that ensures all parents are loaded
3143 if Is_Child_Spec (P) then
3145 Is_Private or else Private_Present (Parent (Lib_Unit)));
3148 -- Now we can install the context for this parent
3150 Install_Context_Clauses (Parent_Spec (Lib_Unit));
3151 Install_Siblings (P_Name, Parent (Lib_Unit));
3153 -- The child unit is in the declarative region of the parent. The
3154 -- parent must therefore appear in the scope stack and be visible,
3155 -- as when compiling the corresponding body. If the child unit is
3156 -- private or it is a package body, private declarations must be
3157 -- accessible as well. Use declarations in the parent must also
3158 -- be installed. Finally, other child units of the same parent that
3159 -- are in the context are immediately visible.
3161 -- Find entity for compilation unit, and set its private descendant
3162 -- status as needed.
3164 E_Name := Defining_Entity (Lib_Unit);
3166 Set_Is_Child_Unit (E_Name);
3168 Set_Is_Private_Descendant (E_Name,
3169 Is_Private_Descendant (P_Name)
3170 or else Private_Present (Parent (Lib_Unit)));
3172 P_Spec := Specification (Unit_Declaration_Node (P_Name));
3175 -- Save current visibility of unit
3177 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
3178 Is_Immediately_Visible (P_Name);
3179 Set_Is_Immediately_Visible (P_Name);
3180 Install_Visible_Declarations (P_Name);
3181 Set_Use (Visible_Declarations (P_Spec));
3183 -- If the parent is a generic unit, its formal part may contain
3184 -- formal packages and use clauses for them.
3186 if Ekind (P_Name) = E_Generic_Package then
3187 Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
3191 or else Private_Present (Parent (Lib_Unit))
3193 Install_Private_Declarations (P_Name);
3194 Install_Private_With_Clauses (P_Name);
3195 Set_Use (Private_Declarations (P_Spec));
3197 end Install_Parents;
3199 ----------------------------------
3200 -- Install_Private_With_Clauses --
3201 ----------------------------------
3203 procedure Install_Private_With_Clauses (P : Entity_Id) is
3204 Decl : constant Node_Id := Unit_Declaration_Node (P);
3208 if Debug_Flag_I then
3209 Write_Str ("install private with clauses of ");
3210 Write_Name (Chars (P));
3214 if Nkind (Parent (Decl)) = N_Compilation_Unit then
3215 Item := First (Context_Items (Parent (Decl)));
3217 while Present (Item) loop
3218 if Nkind (Item) = N_With_Clause
3219 and then Private_Present (Item)
3221 if Limited_Present (Item) then
3222 Install_Limited_Withed_Unit (Item);
3224 Install_Withed_Unit (Item, Private_With_OK => True);
3231 end Install_Private_With_Clauses;
3233 ----------------------
3234 -- Install_Siblings --
3235 ----------------------
3237 procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
3242 -- Iterate over explicit with clauses, and check whether the
3243 -- scope of each entity is an ancestor of the current unit.
3245 Item := First (Context_Items (N));
3246 while Present (Item) loop
3247 if Nkind (Item) = N_With_Clause
3248 and then not Implicit_With (Item)
3249 and then not Limited_Present (Item)
3251 Id := Entity (Name (Item));
3253 if Is_Child_Unit (Id)
3254 and then Is_Ancestor_Package (Scope (Id), U_Name)
3256 Set_Is_Immediately_Visible (Id);
3258 -- Check for the presence of another unit in the context,
3259 -- that may be inadvertently hidden by the child.
3261 Prev := Current_Entity (Id);
3264 and then Is_Immediately_Visible (Prev)
3265 and then not Is_Child_Unit (Prev)
3271 Clause := First (Context_Items (N));
3273 while Present (Clause) loop
3274 if Nkind (Clause) = N_With_Clause
3275 and then Entity (Name (Clause)) = Prev
3278 ("child unit& hides compilation unit " &
3279 "with the same name?",
3289 -- the With_Clause may be on a grand-child, which makes
3290 -- the child immediately visible.
3292 elsif Is_Child_Unit (Scope (Id))
3293 and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name)
3295 Set_Is_Immediately_Visible (Scope (Id));
3301 end Install_Siblings;
3303 -------------------------------
3304 -- Install_Limited_With_Unit --
3305 -------------------------------
3307 procedure Install_Limited_Withed_Unit (N : Node_Id) is
3308 Unum : constant Unit_Number_Type :=
3309 Get_Source_Unit (Library_Unit (N));
3310 P_Unit : constant Entity_Id := Unit (Library_Unit (N));
3312 Is_Child_Package : Boolean := False;
3314 Lim_Header : Entity_Id;
3315 Lim_Typ : Entity_Id;
3317 function In_Chain (E : Entity_Id) return Boolean;
3318 -- Check that the shadow entity is not already in the homonym
3319 -- chain, for example through a limited_with clause in a parent unit.
3325 function In_Chain (E : Entity_Id) return Boolean is
3326 H : Entity_Id := Current_Entity (E);
3329 while Present (H) loop
3340 -- Start of processing for Install_Limited_Withed_Unit
3343 -- In case of limited with_clause on subprograms, generics, instances,
3344 -- or generic renamings, the corresponding error was previously posted
3345 -- and we have nothing to do here.
3347 case Nkind (P_Unit) is
3349 when N_Package_Declaration =>
3352 when N_Subprogram_Declaration |
3353 N_Generic_Package_Declaration |
3354 N_Generic_Subprogram_Declaration |
3355 N_Package_Instantiation |
3356 N_Function_Instantiation |
3357 N_Procedure_Instantiation |
3358 N_Generic_Package_Renaming_Declaration |
3359 N_Generic_Procedure_Renaming_Declaration |
3360 N_Generic_Function_Renaming_Declaration =>
3364 raise Program_Error;
3367 P := Defining_Unit_Name (Specification (P_Unit));
3369 if Nkind (P) = N_Defining_Program_Unit_Name then
3371 -- Retrieve entity of child package
3373 Is_Child_Package := True;
3374 P := Defining_Identifier (P);
3377 -- A common usage of the limited-with is to have a limited-with
3378 -- in the package spec, and a normal with in its package body.
3381 -- limited with X; -- [1]
3385 -- package body A is ...
3387 -- The compilation of A's body installs the entities of its
3388 -- withed packages (the context clauses found at [2]) and
3389 -- then the context clauses of its specification (found at [1]).
3391 -- As a consequence, at point [1] the specification of X has been
3392 -- analyzed and it is immediately visible. According to the semantics
3393 -- of the limited-with context clauses we don't install the limited
3394 -- view because the full view of X supersedes its limited view.
3396 if Analyzed (Cunit (Unum))
3397 and then (Is_Immediately_Visible (P)
3398 or else (Is_Child_Package
3399 and then Is_Visible_Child_Unit (P)))
3401 -- Ada 2005 (AI-262): Install the private declarations of P
3403 if Private_Present (N)
3404 and then not In_Private_Part (P)
3409 Id := First_Private_Entity (P);
3411 while Present (Id) loop
3412 if not Is_Internal (Id)
3413 and then not Is_Child_Unit (Id)
3415 if not In_Chain (Id) then
3416 Set_Homonym (Id, Current_Entity (Id));
3417 Set_Current_Entity (Id);
3420 Set_Is_Immediately_Visible (Id);
3426 Set_In_Private_Part (P);
3433 if Debug_Flag_I then
3434 Write_Str ("install limited view of ");
3435 Write_Name (Chars (P));
3439 if not Analyzed (Cunit (Unum)) then
3440 Set_Ekind (P, E_Package);
3441 Set_Etype (P, Standard_Void_Type);
3442 Set_Scope (P, Standard_Standard);
3444 -- Place entity on visibility structure
3446 if Current_Entity (P) /= P then
3447 Set_Homonym (P, Current_Entity (P));
3448 Set_Current_Entity (P);
3450 if Debug_Flag_I then
3451 Write_Str (" (homonym) chain ");
3452 Write_Name (Chars (P));
3458 if Is_Child_Package then
3459 Set_Is_Child_Unit (P);
3460 Set_Is_Visible_Child_Unit (P);
3463 Parent_Comp : Node_Id;
3464 Parent_Id : Entity_Id;
3467 Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
3468 Parent_Id := Defining_Entity (Unit (Parent_Comp));
3470 Set_Scope (P, Parent_Id);
3476 -- If the unit appears in a previous regular with_clause, the
3477 -- regular entities must be unchained before the shadow ones
3478 -- are made accessible.
3483 Ent := First_Entity (P);
3485 while Present (Ent) loop
3493 -- The package must be visible while the with_type clause is active,
3494 -- because references to the type P.T must resolve in the usual way.
3496 Set_Is_Immediately_Visible (P);
3498 -- Install each incomplete view. The first element of the limited view
3499 -- is a header (an E_Package entity) that is used to reference the first
3500 -- shadow entity in the private part of the package
3502 Lim_Header := Limited_View (P);
3503 Lim_Typ := First_Entity (Lim_Header);
3505 while Present (Lim_Typ) loop
3507 exit when not Private_Present (N)
3508 and then Lim_Typ = First_Private_Entity (Lim_Header);
3510 if not In_Chain (Lim_Typ) then
3511 Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
3512 Set_Current_Entity (Lim_Typ);
3514 if Debug_Flag_I then
3515 Write_Str (" (homonym) chain ");
3516 Write_Name (Chars (Lim_Typ));
3521 Next_Entity (Lim_Typ);
3524 -- The context clause has installed a limited-view, mark it
3525 -- accordingly, to uninstall it when the context is removed.
3527 Set_Limited_View_Installed (N);
3528 Set_From_With_Type (P);
3529 end Install_Limited_Withed_Unit;
3531 -------------------------
3532 -- Install_Withed_Unit --
3533 -------------------------
3535 procedure Install_Withed_Unit
3536 (With_Clause : Node_Id;
3537 Private_With_OK : Boolean := False)
3539 Uname : constant Entity_Id := Entity (Name (With_Clause));
3540 P : constant Entity_Id := Scope (Uname);
3543 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
3544 -- compiling a package declaration and the Private_With_OK flag was not
3545 -- set by the caller. These declarations will be installed later (before
3546 -- analyzing the private part of the package).
3548 if Private_Present (With_Clause)
3549 and then Nkind (Cunit (Current_Sem_Unit)) = N_Package_Declaration
3550 and then not (Private_With_OK)
3555 if Debug_Flag_I then
3556 if Private_Present (With_Clause) then
3557 Write_Str ("install private withed unit ");
3559 Write_Str ("install withed unit ");
3562 Write_Name (Chars (Uname));
3566 -- We do not apply the restrictions to an internal unit unless
3567 -- we are compiling the internal unit as a main unit. This check
3568 -- is also skipped for dummy units (for missing packages).
3570 if Sloc (Uname) /= No_Location
3571 and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
3572 or else Current_Sem_Unit = Main_Unit)
3574 Check_Restricted_Unit
3575 (Unit_Name (Get_Source_Unit (Uname)), With_Clause);
3578 if P /= Standard_Standard then
3580 -- If the unit is not analyzed after analysis of the with clause,
3581 -- and it is an instantiation, then it awaits a body and is the main
3582 -- unit. Its appearance in the context of some other unit indicates
3583 -- a circular dependency (DEC suite perversity).
3585 if not Analyzed (Uname)
3586 and then Nkind (Parent (Uname)) = N_Package_Instantiation
3589 ("instantiation depends on itself", Name (With_Clause));
3591 elsif not Is_Visible_Child_Unit (Uname) then
3592 Set_Is_Visible_Child_Unit (Uname);
3594 if Is_Generic_Instance (Uname)
3595 and then Ekind (Uname) in Subprogram_Kind
3597 -- Set flag as well on the visible entity that denotes the
3598 -- instance, which renames the current one.
3600 Set_Is_Visible_Child_Unit
3602 (Defining_Entity (Unit (Library_Unit (With_Clause)))));
3605 -- The parent unit may have been installed already, and
3606 -- may have appeared in a use clause.
3608 if In_Use (Scope (Uname)) then
3609 Set_Is_Potentially_Use_Visible (Uname);
3612 Set_Context_Installed (With_Clause);
3615 elsif not Is_Immediately_Visible (Uname) then
3616 if not Private_Present (With_Clause)
3617 or else Private_With_OK
3619 Set_Is_Immediately_Visible (Uname);
3622 Set_Context_Installed (With_Clause);
3625 -- A with-clause overrides a with-type clause: there are no restric-
3626 -- tions on the use of package entities.
3628 if Ekind (Uname) = E_Package then
3629 Set_From_With_Type (Uname, False);
3631 end Install_Withed_Unit;
3637 function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
3638 K : constant Node_Kind := Nkind (Lib_Unit);
3641 return (K in N_Generic_Declaration or else
3642 K in N_Generic_Instantiation or else
3643 K in N_Generic_Renaming_Declaration or else
3644 K = N_Package_Declaration or else
3645 K = N_Package_Renaming_Declaration or else
3646 K = N_Subprogram_Declaration or else
3647 K = N_Subprogram_Renaming_Declaration)
3648 and then Present (Parent_Spec (Lib_Unit));
3651 -----------------------
3652 -- Load_Needed_Body --
3653 -----------------------
3655 -- N is a generic unit named in a with clause, or else it is
3656 -- a unit that contains a generic unit or an inlined function.
3657 -- In order to perform an instantiation, the body of the unit
3658 -- must be present. If the unit itself is generic, we assume
3659 -- that an instantiation follows, and load and analyze the body
3660 -- unconditionally. This forces analysis of the spec as well.
3662 -- If the unit is not generic, but contains a generic unit, it
3663 -- is loaded on demand, at the point of instantiation (see ch12).
3665 procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
3666 Body_Name : Unit_Name_Type;
3667 Unum : Unit_Number_Type;
3669 Save_Style_Check : constant Boolean := Opt.Style_Check;
3670 -- The loading and analysis is done with style checks off
3673 if not GNAT_Mode then
3674 Style_Check := False;
3677 Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
3680 (Load_Name => Body_Name,
3686 if Unum = No_Unit then
3690 Compiler_State := Analyzing; -- reset after load
3692 if not Fatal_Error (Unum) or else Try_Semantics then
3693 if Debug_Flag_L then
3694 Write_Str ("*** Loaded generic body");
3698 Semantics (Cunit (Unum));
3704 Style_Check := Save_Style_Check;
3705 end Load_Needed_Body;
3707 -------------------------
3708 -- Build_Limited_Views --
3709 -------------------------
3711 procedure Build_Limited_Views (N : Node_Id) is
3712 Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
3713 P : constant Entity_Id := Cunit_Entity (Unum);
3715 Spec : Node_Id; -- To denote a package specification
3716 Lim_Typ : Entity_Id; -- To denote shadow entities
3717 Comp_Typ : Entity_Id; -- To denote real entities
3719 Lim_Header : Entity_Id; -- Package entity
3720 Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
3721 Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
3723 procedure Decorate_Incomplete_Type
3726 -- Add attributes of an incomplete type to a shadow entity. The same
3727 -- attributes are placed on the real entity, so that gigi receives
3728 -- a consistent view.
3730 procedure Decorate_Package_Specification (P : Entity_Id);
3731 -- Add attributes of a package entity to the entity in a package
3734 procedure Decorate_Tagged_Type
3738 -- Set basic attributes of tagged type T, including its class_wide type.
3739 -- The parameters Loc, Scope are used to decorate the class_wide type.
3741 procedure Build_Chain
3743 First_Decl : Node_Id);
3744 -- Construct list of shadow entities and attach it to entity of
3745 -- package that is mentioned in a limited_with clause.
3747 function New_Internal_Shadow_Entity
3748 (Kind : Entity_Kind;
3749 Sloc_Value : Source_Ptr;
3750 Id_Char : Character) return Entity_Id;
3751 -- Build a new internal entity and append it to the list of shadow
3752 -- entities available through the limited-header
3754 ------------------------------
3755 -- Decorate_Incomplete_Type --
3756 ------------------------------
3758 procedure Decorate_Incomplete_Type
3763 Set_Ekind (E, E_Incomplete_Type);
3764 Set_Scope (E, Scop);
3766 Set_Is_First_Subtype (E, True);
3767 Set_Stored_Constraint (E, No_Elist);
3768 Set_Full_View (E, Empty);
3769 Init_Size_Align (E);
3770 end Decorate_Incomplete_Type;
3772 --------------------------
3773 -- Decorate_Tagged_Type --
3774 --------------------------
3776 procedure Decorate_Tagged_Type
3784 Decorate_Incomplete_Type (T, Scop);
3785 Set_Is_Tagged_Type (T);
3787 -- Build corresponding class_wide type, if not previously done
3789 if No (Class_Wide_Type (T)) then
3790 CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3792 Set_Ekind (CW, E_Class_Wide_Type);
3794 Set_Scope (CW, Scop);
3795 Set_Is_Tagged_Type (CW);
3796 Set_Is_First_Subtype (CW, True);
3797 Init_Size_Align (CW);
3798 Set_Has_Unknown_Discriminants (CW, True);
3799 Set_Class_Wide_Type (CW, CW);
3800 Set_Equivalent_Type (CW, Empty);
3801 Set_From_With_Type (CW, From_With_Type (T));
3803 Set_Class_Wide_Type (T, CW);
3805 end Decorate_Tagged_Type;
3807 ------------------------------------
3808 -- Decorate_Package_Specification --
3809 ------------------------------------
3811 procedure Decorate_Package_Specification (P : Entity_Id) is
3813 -- Place only the most basic attributes
3815 Set_Ekind (P, E_Package);
3816 Set_Etype (P, Standard_Void_Type);
3817 end Decorate_Package_Specification;
3819 -------------------------
3820 -- New_Internal_Entity --
3821 -------------------------
3823 function New_Internal_Shadow_Entity
3824 (Kind : Entity_Kind;
3825 Sloc_Value : Source_Ptr;
3826 Id_Char : Character) return Entity_Id
3828 E : constant Entity_Id :=
3829 Make_Defining_Identifier (Sloc_Value,
3830 Chars => New_Internal_Name (Id_Char));
3833 Set_Ekind (E, Kind);
3834 Set_Is_Internal (E, True);
3836 if Kind in Type_Kind then
3837 Init_Size_Align (E);
3840 Append_Entity (E, Lim_Header);
3843 end New_Internal_Shadow_Entity;
3849 procedure Build_Chain
3851 First_Decl : Node_Id)
3853 Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
3854 Is_Tagged : Boolean;
3860 while Present (Decl) loop
3862 -- For each library_package_declaration in the environment, there
3863 -- is an implicit declaration of a *limited view* of that library
3864 -- package. The limited view of a package contains:
3866 -- * For each nested package_declaration, a declaration of the
3867 -- limited view of that package, with the same defining-
3868 -- program-unit name.
3870 -- * For each type_declaration in the visible part, an incomplete
3871 -- type-declaration with the same defining_identifier, whose
3872 -- completion is the type_declaration. If the type_declaration
3873 -- is tagged, then the incomplete_type_declaration is tagged
3876 if Nkind (Decl) = N_Full_Type_Declaration then
3878 Nkind (Type_Definition (Decl)) = N_Record_Definition
3879 and then Tagged_Present (Type_Definition (Decl));
3881 Comp_Typ := Defining_Identifier (Decl);
3883 if not Analyzed_Unit then
3885 Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
3887 Decorate_Incomplete_Type (Comp_Typ, Scope);
3891 -- Create shadow entity for type
3893 Lim_Typ := New_Internal_Shadow_Entity
3894 (Kind => Ekind (Comp_Typ),
3895 Sloc_Value => Sloc (Comp_Typ),
3898 Set_Chars (Lim_Typ, Chars (Comp_Typ));
3899 Set_Parent (Lim_Typ, Parent (Comp_Typ));
3900 Set_From_With_Type (Lim_Typ);
3903 Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
3905 Decorate_Incomplete_Type (Lim_Typ, Scope);
3908 Set_Non_Limited_View (Lim_Typ, Comp_Typ);
3910 elsif Nkind (Decl) = N_Private_Type_Declaration
3911 and then Tagged_Present (Decl)
3913 Comp_Typ := Defining_Identifier (Decl);
3915 if not Analyzed_Unit then
3916 Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
3919 Lim_Typ := New_Internal_Shadow_Entity
3920 (Kind => Ekind (Comp_Typ),
3921 Sloc_Value => Sloc (Comp_Typ),
3924 Set_Chars (Lim_Typ, Chars (Comp_Typ));
3925 Set_Parent (Lim_Typ, Parent (Comp_Typ));
3926 Set_From_With_Type (Lim_Typ);
3928 Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
3930 Set_Non_Limited_View (Lim_Typ, Comp_Typ);
3932 elsif Nkind (Decl) = N_Package_Declaration then
3937 Spec : constant Node_Id := Specification (Decl);
3940 Comp_Typ := Defining_Unit_Name (Spec);
3942 if not Analyzed (Cunit (Unum)) then
3943 Decorate_Package_Specification (Comp_Typ);
3944 Set_Scope (Comp_Typ, Scope);
3947 Lim_Typ := New_Internal_Shadow_Entity
3948 (Kind => Ekind (Comp_Typ),
3949 Sloc_Value => Sloc (Comp_Typ),
3952 Decorate_Package_Specification (Lim_Typ);
3953 Set_Scope (Lim_Typ, Scope);
3955 Set_Chars (Lim_Typ, Chars (Comp_Typ));
3956 Set_Parent (Lim_Typ, Parent (Comp_Typ));
3957 Set_From_With_Type (Lim_Typ);
3959 -- Note: The non_limited_view attribute is not used
3960 -- for local packages.
3964 First_Decl => First (Visible_Declarations (Spec)));
3972 -- Start of processing for Build_Limited_Views
3975 pragma Assert (Limited_Present (N));
3977 -- A library_item mentioned in a limited_with_clause shall be
3978 -- a package_declaration, not a subprogram_declaration,
3979 -- generic_declaration, generic_instantiation, or
3980 -- package_renaming_declaration
3982 case Nkind (Unit (Library_Unit (N))) is
3984 when N_Package_Declaration =>
3987 when N_Subprogram_Declaration =>
3988 Error_Msg_N ("subprograms not allowed in "
3989 & "limited with_clauses", N);
3992 when N_Generic_Package_Declaration |
3993 N_Generic_Subprogram_Declaration =>
3994 Error_Msg_N ("generics not allowed in "
3995 & "limited with_clauses", N);
3998 when N_Package_Instantiation |
3999 N_Function_Instantiation |
4000 N_Procedure_Instantiation =>
4001 Error_Msg_N ("generic instantiations not allowed in "
4002 & "limited with_clauses", N);
4005 when N_Generic_Package_Renaming_Declaration |
4006 N_Generic_Procedure_Renaming_Declaration |
4007 N_Generic_Function_Renaming_Declaration =>
4008 Error_Msg_N ("generic renamings not allowed in "
4009 & "limited with_clauses", N);
4013 raise Program_Error;
4016 -- Check if the chain is already built
4018 Spec := Specification (Unit (Library_Unit (N)));
4020 if Limited_View_Installed (Spec) then
4024 Set_Ekind (P, E_Package);
4026 -- Build the header of the limited_view
4028 Lim_Header := Make_Defining_Identifier (Sloc (N),
4029 Chars => New_Internal_Name (Id_Char => 'Z'));
4030 Set_Ekind (Lim_Header, E_Package);
4031 Set_Is_Internal (Lim_Header);
4032 Set_Limited_View (P, Lim_Header);
4034 -- Create the auxiliary chain. All the shadow entities are appended
4035 -- to the list of entities of the limited-view header
4039 First_Decl => First (Visible_Declarations (Spec)));
4041 -- Save the last built shadow entity. It is needed later to set the
4042 -- reference to the first shadow entity in the private part
4044 Last_Pub_Lim_E := Last_Lim_E;
4046 -- Ada 2005 (AI-262): Add the limited view of the private declarations
4047 -- Required to give support to limited-private-with clauses
4049 Build_Chain (Scope => P,
4050 First_Decl => First (Private_Declarations (Spec)));
4052 if Last_Pub_Lim_E /= Empty then
4053 Set_First_Private_Entity (Lim_Header,
4054 Next_Entity (Last_Pub_Lim_E));
4056 Set_First_Private_Entity (Lim_Header,
4060 Set_Limited_View_Installed (Spec);
4061 end Build_Limited_Views;
4063 -------------------------------
4064 -- Check_Body_Needed_For_SAL --
4065 -------------------------------
4067 procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
4069 function Entity_Needs_Body (E : Entity_Id) return Boolean;
4070 -- Determine whether use of entity E might require the presence
4071 -- of its body. For a package this requires a recursive traversal
4072 -- of all nested declarations.
4074 ---------------------------
4075 -- Entity_Needed_For_SAL --
4076 ---------------------------
4078 function Entity_Needs_Body (E : Entity_Id) return Boolean is
4082 if Is_Subprogram (E)
4083 and then Has_Pragma_Inline (E)
4087 elsif Ekind (E) = E_Generic_Function
4088 or else Ekind (E) = E_Generic_Procedure
4092 elsif Ekind (E) = E_Generic_Package
4094 Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
4095 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4099 elsif Ekind (E) = E_Package
4101 Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
4102 and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
4104 Ent := First_Entity (E);
4106 while Present (Ent) loop
4107 if Entity_Needs_Body (Ent) then
4119 end Entity_Needs_Body;
4121 -- Start of processing for Check_Body_Needed_For_SAL
4124 if Ekind (Unit_Name) = E_Generic_Package
4126 Nkind (Unit_Declaration_Node (Unit_Name)) =
4127 N_Generic_Package_Declaration
4129 Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
4131 Set_Body_Needed_For_SAL (Unit_Name);
4133 elsif Ekind (Unit_Name) = E_Generic_Procedure
4134 or else Ekind (Unit_Name) = E_Generic_Function
4136 Set_Body_Needed_For_SAL (Unit_Name);
4138 elsif Is_Subprogram (Unit_Name)
4139 and then Nkind (Unit_Declaration_Node (Unit_Name)) =
4140 N_Subprogram_Declaration
4141 and then Has_Pragma_Inline (Unit_Name)
4143 Set_Body_Needed_For_SAL (Unit_Name);
4145 elsif Ekind (Unit_Name) = E_Subprogram_Body then
4146 Check_Body_Needed_For_SAL
4147 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4149 elsif Ekind (Unit_Name) = E_Package
4150 and then Entity_Needs_Body (Unit_Name)
4152 Set_Body_Needed_For_SAL (Unit_Name);
4154 elsif Ekind (Unit_Name) = E_Package_Body
4155 and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
4157 Check_Body_Needed_For_SAL
4158 (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
4160 end Check_Body_Needed_For_SAL;
4162 --------------------
4163 -- Remove_Context --
4164 --------------------
4166 procedure Remove_Context (N : Node_Id) is
4167 Lib_Unit : constant Node_Id := Unit (N);
4170 -- If this is a child unit, first remove the parent units.
4172 if Is_Child_Spec (Lib_Unit) then
4173 Remove_Parents (Lib_Unit);
4176 Remove_Context_Clauses (N);
4179 ----------------------------
4180 -- Remove_Context_Clauses --
4181 ----------------------------
4183 procedure Remove_Context_Clauses (N : Node_Id) is
4185 Unit_Name : Entity_Id;
4188 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
4189 -- limited-views first and regular-views later (to maintain the
4192 -- First Phase: Remove limited_with context clauses
4194 Item := First (Context_Items (N));
4195 while Present (Item) loop
4197 -- We are interested only in with clauses which got installed
4200 if Nkind (Item) = N_With_Clause
4201 and then Limited_Present (Item)
4202 and then Limited_View_Installed (Item)
4204 Remove_Limited_With_Clause (Item);
4210 -- Second Phase: Loop through context items and undo regular
4211 -- with_clauses and use_clauses.
4213 Item := First (Context_Items (N));
4214 while Present (Item) loop
4216 -- We are interested only in with clauses which got installed
4217 -- on entry, as indicated by their Context_Installed flag set
4219 if Nkind (Item) = N_With_Clause
4220 and then Limited_Present (Item)
4221 and then Limited_View_Installed (Item)
4225 elsif Nkind (Item) = N_With_Clause
4226 and then Context_Installed (Item)
4228 -- Remove items from one with'ed unit
4230 Unit_Name := Entity (Name (Item));
4231 Remove_Unit_From_Visibility (Unit_Name);
4232 Set_Context_Installed (Item, False);
4234 elsif Nkind (Item) = N_Use_Package_Clause then
4235 End_Use_Package (Item);
4237 elsif Nkind (Item) = N_Use_Type_Clause then
4238 End_Use_Type (Item);
4240 elsif Nkind (Item) = N_With_Type_Clause then
4241 Remove_With_Type_Clause (Name (Item));
4246 end Remove_Context_Clauses;
4248 --------------------------------
4249 -- Remove_Limited_With_Clause --
4250 --------------------------------
4252 procedure Remove_Limited_With_Clause (N : Node_Id) is
4253 P_Unit : constant Entity_Id := Unit (Library_Unit (N));
4254 P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
4255 Lim_Typ : Entity_Id;
4258 if Nkind (P) = N_Defining_Program_Unit_Name then
4260 -- Retrieve entity of Child package
4262 P := Defining_Identifier (P);
4265 if Debug_Flag_I then
4266 Write_Str ("remove limited view of ");
4267 Write_Name (Chars (P));
4268 Write_Str (" from visibility");
4272 -- Remove all shadow entities from visibility. The first element of the
4273 -- limited view is a header (an E_Package entity) that is used to
4274 -- reference the first shadow entity in the private part of the package
4276 Lim_Typ := First_Entity (Limited_View (P));
4278 while Present (Lim_Typ) loop
4280 Next_Entity (Lim_Typ);
4283 -- Indicate that the limited view of the package is not installed
4285 Set_From_With_Type (P, False);
4286 Set_Limited_View_Installed (N, False);
4288 -- If the exporting package has previously been analyzed, it
4289 -- has appeared in the closure already and should be left alone.
4290 -- Otherwise, remove package itself from visibility.
4292 if not Analyzed (P_Unit) then
4294 Set_First_Entity (P, Empty);
4295 Set_Last_Entity (P, Empty);
4296 Set_Ekind (P, E_Void);
4297 Set_Scope (P, Empty);
4298 Set_Is_Immediately_Visible (P, False);
4302 -- Reinstall visible entities (entities removed from visibility in
4303 -- Install_Limited_Withed to install the shadow entities).
4309 Ent := First_Entity (P);
4310 while Present (Ent) and then Ent /= First_Private_Entity (P) loop
4312 -- Shadow entities have not been added to the list of
4313 -- entities associated to the package spec. Therefore we
4314 -- just have to re-chain all its visible entities.
4316 if not Is_Class_Wide_Type (Ent) then
4318 Set_Homonym (Ent, Current_Entity (Ent));
4319 Set_Current_Entity (Ent);
4321 if Debug_Flag_I then
4322 Write_Str (" (homonym) chain ");
4323 Write_Name (Chars (Ent));
4332 end Remove_Limited_With_Clause;
4334 --------------------
4335 -- Remove_Parents --
4336 --------------------
4338 procedure Remove_Parents (Lib_Unit : Node_Id) is
4341 P_Spec : Node_Id := Empty;
4343 Vis : constant Boolean :=
4344 Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
4347 if Is_Child_Spec (Lib_Unit) then
4348 P_Spec := Parent_Spec (Lib_Unit);
4350 elsif Nkind (Lib_Unit) = N_Package_Body
4351 and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
4353 P_Spec := Parent_Spec (Original_Node (Lib_Unit));
4356 if Present (P_Spec) then
4359 P_Name := Get_Parent_Entity (P);
4360 Remove_Context_Clauses (P_Spec);
4361 End_Package_Scope (P_Name);
4362 Set_Is_Immediately_Visible (P_Name, Vis);
4364 -- Remove from visibility the siblings as well, which are directly
4365 -- visible while the parent is in scope.
4367 E := First_Entity (P_Name);
4369 while Present (E) loop
4371 if Is_Child_Unit (E) then
4372 Set_Is_Immediately_Visible (E, False);
4378 Set_In_Package_Body (P_Name, False);
4380 -- This is the recursive call to remove the context of any
4381 -- higher level parent. This recursion ensures that all parents
4382 -- are removed in the reverse order of their installation.
4388 -----------------------------
4389 -- Remove_With_Type_Clause --
4390 -----------------------------
4392 procedure Remove_With_Type_Clause (Name : Node_Id) is
4396 procedure Unchain (E : Entity_Id);
4397 -- Remove entity from visibility list.
4399 procedure Unchain (E : Entity_Id) is
4403 Prev := Current_Entity (E);
4405 -- Package entity may appear is several with_type_clauses, and
4406 -- may have been removed already.
4412 Set_Name_Entity_Id (Chars (E), Homonym (E));
4415 while Present (Prev)
4416 and then Homonym (Prev) /= E
4418 Prev := Homonym (Prev);
4421 if Present (Prev) then
4422 Set_Homonym (Prev, Homonym (E));
4427 -- Start of Remove_With_Type_Clause
4430 if Nkind (Name) = N_Selected_Component then
4431 Typ := Entity (Selector_Name (Name));
4433 if No (Typ) then -- error in declaration.
4442 -- If the exporting package has been analyzed, it has appeared in the
4443 -- context already and should be left alone. Otherwise, remove from
4446 if not Analyzed (Unit_Declaration_Node (P)) then
4449 Set_Is_Frozen (Typ, False);
4452 if Ekind (Typ) = E_Record_Type then
4453 Set_From_With_Type (Class_Wide_Type (Typ), False);
4454 Set_From_With_Type (Typ, False);
4457 Set_From_With_Type (P, False);
4459 -- If P is a child unit, remove parents as well.
4464 and then P /= Standard_Standard
4466 Set_From_With_Type (P, False);
4468 if not Analyzed (Unit_Declaration_Node (P)) then
4475 -- The back-end needs to know that an access type is imported, so it
4476 -- does not need elaboration and can appear in a mutually recursive
4477 -- record definition, so the imported flag on an access type is
4480 end Remove_With_Type_Clause;
4482 ---------------------------------
4483 -- Remove_Unit_From_Visibility --
4484 ---------------------------------
4486 procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
4487 P : constant Entity_Id := Scope (Unit_Name);
4491 if Debug_Flag_I then
4492 Write_Str ("remove unit ");
4493 Write_Name (Chars (Unit_Name));
4494 Write_Str (" from visibility");
4498 if P /= Standard_Standard then
4499 Set_Is_Visible_Child_Unit (Unit_Name, False);
4502 Set_Is_Potentially_Use_Visible (Unit_Name, False);
4503 Set_Is_Immediately_Visible (Unit_Name, False);
4505 end Remove_Unit_From_Visibility;
4511 procedure Unchain (E : Entity_Id) is
4515 Prev := Current_Entity (E);
4521 Set_Name_Entity_Id (Chars (E), Homonym (E));
4524 while Present (Prev)
4525 and then Homonym (Prev) /= E
4527 Prev := Homonym (Prev);
4530 if Present (Prev) then
4531 Set_Homonym (Prev, Homonym (E));
4535 if Debug_Flag_I then
4536 Write_Str (" (homonym) unchain ");
4537 Write_Name (Chars (E));