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 Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
985 ("expected SEPARATE subunit, found child unit",
986 Cunit_Entity
(Unum
));
988 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
989 Analyze_Subunit
(Comp_Unit
);
990 Set_Library_Unit
(N
, Comp_Unit
);
994 and then Present
(Nam
)
996 if Is_Protected_Type
(Nam
) then
997 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
999 Set_Corresponding_Body
(
1000 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1003 end Optional_Subunit
;
1005 -- Start of processing for Analyze_Proper_Body
1008 -- If the subunit is already loaded, it means that the main unit
1009 -- is a subunit, and that the current unit is one of its parents
1010 -- which was being analyzed to provide the needed context for the
1011 -- analysis of the subunit. In this case we analyze the subunit and
1012 -- continue with the parent, without looking a subsequent subunits.
1014 if Is_Loaded
(Subunit_Name
) then
1016 -- If the proper body is already linked to the stub node,
1017 -- the stub is in a generic unit and just needs analyzing.
1019 if Present
(Library_Unit
(N
)) then
1020 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1021 Analyze_Subunit
(Library_Unit
(N
));
1023 -- Otherwise we must load the subunit and link to it
1026 -- Load the subunit, this must work, since we originally
1027 -- loaded the subunit earlier on. So this will not really
1028 -- load it, just give access to it.
1032 (Load_Name
=> Subunit_Name
,
1037 -- And analyze the subunit in the parent context (note that we
1038 -- do not call Semantics, since that would remove the parent
1039 -- context). Because of this, we have to manually reset the
1040 -- compiler state to Analyzing since it got destroyed by Load.
1042 if Unum
/= No_Unit
then
1043 Compiler_State
:= Analyzing
;
1045 -- Check that the proper body is a subunit and not a child
1046 -- unit. If the unit was previously loaded, the error will
1047 -- have been emitted when copying the generic node, so we
1048 -- just return to avoid cascaded errors.
1050 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1054 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1055 Analyze_Subunit
(Cunit
(Unum
));
1056 Set_Library_Unit
(N
, Cunit
(Unum
));
1060 -- If the main unit is a subunit, then we are just performing semantic
1061 -- analysis on that subunit, and any other subunits of any parent unit
1062 -- should be ignored, except that if we are building trees for ASIS
1063 -- usage we want to annotate the stub properly.
1065 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1066 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1072 -- But before we return, set the flag for unloaded subunits. This
1073 -- will suppress junk warnings of variables in the same declarative
1074 -- part (or a higher level one) that are in danger of looking unused
1075 -- when in fact there might be a declaration in the subunit that we
1076 -- do not intend to load.
1078 Unloaded_Subunits
:= True;
1081 -- If the subunit is not already loaded, and we are generating code,
1082 -- then this is the case where compilation started from the parent,
1083 -- and we are generating code for an entire subunit tree. In that
1084 -- case we definitely need to load the subunit.
1086 -- In order to continue the analysis with the rest of the parent,
1087 -- and other subunits, we load the unit without requiring its
1088 -- presence, and emit a warning if not found, rather than terminating
1089 -- the compilation abruptly, as for other missing file problems.
1091 elsif Original_Operating_Mode
= Generate_Code
then
1093 -- If the proper body is already linked to the stub node,
1094 -- the stub is in a generic unit and just needs analyzing.
1096 -- We update the version. Although we are not technically
1097 -- semantically dependent on the subunit, given our approach
1098 -- of macro substitution of subunits, it makes sense to
1099 -- include it in the version identification.
1101 if Present
(Library_Unit
(N
)) then
1102 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1103 Analyze_Subunit
(Library_Unit
(N
));
1104 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1106 -- Otherwise we must load the subunit and link to it
1111 (Load_Name
=> Subunit_Name
,
1116 if Original_Operating_Mode
= Generate_Code
1117 and then Unum
= No_Unit
1119 Error_Msg_Name_1
:= Subunit_Name
;
1121 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1123 ("subunit% in file{ not found!?", N
);
1124 Subunits_Missing
:= True;
1127 -- Load_Unit may reset Compiler_State, since it may have been
1128 -- necessary to parse an additional units, so we make sure
1129 -- that we reset it to the Analyzing state.
1131 Compiler_State
:= Analyzing
;
1134 and then (not Fatal_Error
(Unum
) or else Try_Semantics
)
1136 if Debug_Flag_L
then
1137 Write_Str
("*** Loaded subunit from stub. Analyze");
1142 Comp_Unit
: constant Node_Id
:= Cunit
(Unum
);
1145 -- Check for child unit instead of subunit
1147 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1149 ("expected SEPARATE subunit, found child unit",
1150 Cunit_Entity
(Unum
));
1152 -- OK, we have a subunit, so go ahead and analyze it,
1153 -- and set Scope of entity in stub, for ASIS use.
1156 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1157 Analyze_Subunit
(Comp_Unit
);
1158 Set_Library_Unit
(N
, Comp_Unit
);
1160 -- We update the version. Although we are not technically
1161 -- semantically dependent on the subunit, given our
1162 -- approach of macro substitution of subunits, it makes
1163 -- sense to include it in the version identification.
1165 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1171 -- The remaining case is when the subunit is not already loaded and
1172 -- we are not generating code. In this case we are just performing
1173 -- semantic analysis on the parent, and we are not interested in
1174 -- the subunit. For subprograms, analyze the stub as a body. For
1175 -- other entities the stub has already been marked as completed.
1181 end Analyze_Proper_Body
;
1183 ----------------------------------
1184 -- Analyze_Protected_Body_Stub --
1185 ----------------------------------
1187 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1188 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1191 Check_Stub_Level
(N
);
1193 -- First occurence of name may have been as an incomplete type.
1195 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1196 Nam
:= Full_View
(Nam
);
1200 or else not Is_Protected_Type
(Etype
(Nam
))
1202 Error_Msg_N
("missing specification for Protected body", N
);
1204 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1205 Set_Has_Completion
(Etype
(Nam
));
1206 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
1207 Analyze_Proper_Body
(N
, Etype
(Nam
));
1209 end Analyze_Protected_Body_Stub
;
1211 ----------------------------------
1212 -- Analyze_Subprogram_Body_Stub --
1213 ----------------------------------
1215 -- A subprogram body stub can appear with or without a previous
1216 -- specification. If there is one, the analysis of the body will
1217 -- find it and verify conformance. The formals appearing in the
1218 -- specification of the stub play no role, except for requiring an
1219 -- additional conformance check. If there is no previous subprogram
1220 -- declaration, the stub acts as a spec, and provides the defining
1221 -- entity for the subprogram.
1223 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
1227 Check_Stub_Level
(N
);
1229 -- Verify that the identifier for the stub is unique within this
1230 -- declarative part.
1232 if Nkind
(Parent
(N
)) = N_Block_Statement
1233 or else Nkind
(Parent
(N
)) = N_Package_Body
1234 or else Nkind
(Parent
(N
)) = N_Subprogram_Body
1236 Decl
:= First
(Declarations
(Parent
(N
)));
1238 while Present
(Decl
)
1241 if Nkind
(Decl
) = N_Subprogram_Body_Stub
1242 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
)))
1243 = Chars
(Defining_Unit_Name
(Specification
(N
))))
1245 Error_Msg_N
("identifier for stub is not unique", N
);
1252 -- Treat stub as a body, which checks conformance if there is a previous
1253 -- declaration, or else introduces entity and its signature.
1255 Analyze_Subprogram_Body
(N
);
1256 Analyze_Proper_Body
(N
, Empty
);
1257 end Analyze_Subprogram_Body_Stub
;
1259 ---------------------
1260 -- Analyze_Subunit --
1261 ---------------------
1263 -- A subunit is compiled either by itself (for semantic checking)
1264 -- or as part of compiling the parent (for code generation). In
1265 -- either case, by the time we actually process the subunit, the
1266 -- parent has already been installed and analyzed. The node N is
1267 -- a compilation unit, whose context needs to be treated here,
1268 -- because we come directly here from the parent without calling
1269 -- Analyze_Compilation_Unit.
1271 -- The compilation context includes the explicit context of the
1272 -- subunit, and the context of the parent, together with the parent
1273 -- itself. In order to compile the current context, we remove the
1274 -- one inherited from the parent, in order to have a clean visibility
1275 -- table. We restore the parent context before analyzing the proper
1276 -- body itself. On exit, we remove only the explicit context of the
1279 procedure Analyze_Subunit
(N
: Node_Id
) is
1280 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
1281 Par_Unit
: constant Entity_Id
:= Current_Scope
;
1283 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
1284 Num_Scopes
: Int
:= 0;
1285 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
1286 Enclosing_Child
: Entity_Id
:= Empty
;
1287 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1289 procedure Analyze_Subunit_Context
;
1290 -- Capture names in use clauses of the subunit. This must be done
1291 -- before re-installing parent declarations, because items in the
1292 -- context must not be hidden by declarations local to the parent.
1294 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
1295 -- Recursive procedure to restore scope of all ancestors of subunit,
1296 -- from outermost in. If parent is not a subunit, the call to install
1297 -- context installs context of spec and (if parent is a child unit)
1298 -- the context of its parents as well. It is confusing that parents
1299 -- should be treated differently in both cases, but the semantics are
1300 -- just not identical.
1302 procedure Re_Install_Use_Clauses
;
1303 -- As part of the removal of the parent scope, the use clauses are
1304 -- removed, to be reinstalled when the context of the subunit has
1305 -- been analyzed. Use clauses may also have been affected by the
1306 -- analysis of the context of the subunit, so they have to be applied
1307 -- again, to insure that the compilation environment of the rest of
1308 -- the parent unit is identical.
1310 procedure Remove_Scope
;
1311 -- Remove current scope from scope stack, and preserve the list
1312 -- of use clauses in it, to be reinstalled after context is analyzed.
1314 -----------------------------
1315 -- Analyze_Subunit_Context --
1316 -----------------------------
1318 procedure Analyze_Subunit_Context
is
1321 Unit_Name
: Entity_Id
;
1324 Analyze_Context
(N
);
1325 Item
:= First
(Context_Items
(N
));
1327 -- make withed units immediately visible. If child unit, make the
1328 -- ultimate parent immediately visible.
1330 while Present
(Item
) loop
1332 if Nkind
(Item
) = N_With_Clause
then
1333 Unit_Name
:= Entity
(Name
(Item
));
1335 while Is_Child_Unit
(Unit_Name
) loop
1336 Set_Is_Visible_Child_Unit
(Unit_Name
);
1337 Unit_Name
:= Scope
(Unit_Name
);
1340 if not Is_Immediately_Visible
(Unit_Name
) then
1341 Set_Is_Immediately_Visible
(Unit_Name
);
1342 Set_Context_Installed
(Item
);
1345 elsif Nkind
(Item
) = N_Use_Package_Clause
then
1346 Nam
:= First
(Names
(Item
));
1348 while Present
(Nam
) loop
1353 elsif Nkind
(Item
) = N_Use_Type_Clause
then
1354 Nam
:= First
(Subtype_Marks
(Item
));
1356 while Present
(Nam
) loop
1365 Item
:= First
(Context_Items
(N
));
1367 -- reset visibility of withed units. They will be made visible
1368 -- again when we install the subunit context.
1370 while Present
(Item
) loop
1372 if Nkind
(Item
) = N_With_Clause
then
1373 Unit_Name
:= Entity
(Name
(Item
));
1375 while Is_Child_Unit
(Unit_Name
) loop
1376 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
1377 Unit_Name
:= Scope
(Unit_Name
);
1380 if Context_Installed
(Item
) then
1381 Set_Is_Immediately_Visible
(Unit_Name
, False);
1382 Set_Context_Installed
(Item
, False);
1389 end Analyze_Subunit_Context
;
1391 ------------------------
1392 -- Re_Install_Parents --
1393 ------------------------
1395 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
1399 if Nkind
(Unit
(L
)) = N_Subunit
then
1400 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
1403 Install_Context
(L
);
1405 -- If the subunit occurs within a child unit, we must restore the
1406 -- immediate visibility of any siblings that may occur in context.
1408 if Present
(Enclosing_Child
) then
1409 Install_Siblings
(Enclosing_Child
, L
);
1414 if Scop
/= Par_Unit
then
1415 Set_Is_Immediately_Visible
(Scop
);
1418 E
:= First_Entity
(Current_Scope
);
1420 while Present
(E
) loop
1421 Set_Is_Immediately_Visible
(E
);
1425 -- A subunit appears within a body, and for a nested subunits
1426 -- all the parents are bodies. Restore full visibility of their
1427 -- private entities.
1429 if Ekind
(Scop
) = E_Package
then
1430 Set_In_Package_Body
(Scop
);
1431 Install_Private_Declarations
(Scop
);
1433 end Re_Install_Parents
;
1435 ----------------------------
1436 -- Re_Install_Use_Clauses --
1437 ----------------------------
1439 procedure Re_Install_Use_Clauses
is
1443 for J
in reverse 1 .. Num_Scopes
loop
1444 U
:= Use_Clauses
(J
);
1445 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
1446 Install_Use_Clauses
(U
, Force_Installation
=> True);
1448 end Re_Install_Use_Clauses
;
1454 procedure Remove_Scope
is
1458 Num_Scopes
:= Num_Scopes
+ 1;
1459 Use_Clauses
(Num_Scopes
) :=
1460 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
1461 E
:= First_Entity
(Current_Scope
);
1463 while Present
(E
) loop
1464 Set_Is_Immediately_Visible
(E
, False);
1468 if Is_Child_Unit
(Current_Scope
) then
1469 Enclosing_Child
:= Current_Scope
;
1475 -- Start of processing for Analyze_Subunit
1478 if not Is_Empty_List
(Context_Items
(N
)) then
1480 -- Save current use clauses.
1483 Remove_Context
(Lib_Unit
);
1485 -- Now remove parents and their context, including enclosing
1486 -- subunits and the outer parent body which is not a subunit.
1488 if Present
(Lib_Spec
) then
1489 Remove_Context
(Lib_Spec
);
1491 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
1492 Lib_Spec
:= Library_Unit
(Lib_Spec
);
1494 Remove_Context
(Lib_Spec
);
1497 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
1501 if Nkind
(Unit
(Lib_Spec
)) = N_Package_Body
then
1502 Remove_Context
(Library_Unit
(Lib_Spec
));
1506 Set_Is_Immediately_Visible
(Par_Unit
, False);
1508 Analyze_Subunit_Context
;
1510 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
1511 Set_Is_Immediately_Visible
(Par_Unit
);
1513 -- If the context includes a child unit of the parent of the
1514 -- subunit, the parent will have been removed from visibility,
1515 -- after compiling that cousin in the context. The visibility
1516 -- of the parent must be restored now. This also applies if the
1517 -- context includes another subunit of the same parent which in
1518 -- turn includes a child unit in its context.
1520 if Ekind
(Par_Unit
) = E_Package
then
1521 if not Is_Immediately_Visible
(Par_Unit
)
1522 or else (Present
(First_Entity
(Par_Unit
))
1523 and then not Is_Immediately_Visible
1524 (First_Entity
(Par_Unit
)))
1526 Set_Is_Immediately_Visible
(Par_Unit
);
1527 Install_Visible_Declarations
(Par_Unit
);
1528 Install_Private_Declarations
(Par_Unit
);
1532 Re_Install_Use_Clauses
;
1533 Install_Context
(N
);
1535 -- Restore state of suppress flags for current body.
1537 Scope_Suppress
:= Svg
;
1539 -- If the subunit is within a child unit, then siblings of any
1540 -- parent unit that appear in the context clause of the subunit
1541 -- must also be made immediately visible.
1543 if Present
(Enclosing_Child
) then
1544 Install_Siblings
(Enclosing_Child
, N
);
1549 Analyze
(Proper_Body
(Unit
(N
)));
1551 end Analyze_Subunit
;
1553 ----------------------------
1554 -- Analyze_Task_Body_Stub --
1555 ----------------------------
1557 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
1558 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1559 Loc
: constant Source_Ptr
:= Sloc
(N
);
1562 Check_Stub_Level
(N
);
1564 -- First occurence of name may have been as an incomplete type.
1566 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1567 Nam
:= Full_View
(Nam
);
1571 or else not Is_Task_Type
(Etype
(Nam
))
1573 Error_Msg_N
("missing specification for task body", N
);
1575 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1576 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
1577 Set_Has_Completion
(Etype
(Nam
));
1578 Analyze_Proper_Body
(N
, Etype
(Nam
));
1580 -- Set elaboration flag to indicate that entity is callable.
1581 -- This cannot be done in the expansion of the body itself,
1582 -- because the proper body is not in a declarative part. This
1583 -- is only done if expansion is active, because the context
1584 -- may be generic and the flag not defined yet.
1586 if Expander_Active
then
1588 Make_Assignment_Statement
(Loc
,
1590 Make_Identifier
(Loc
,
1591 New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
1592 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
1596 end Analyze_Task_Body_Stub
;
1598 -------------------------
1599 -- Analyze_With_Clause --
1600 -------------------------
1602 -- Analyze the declaration of a unit in a with clause. At end,
1603 -- label the with clause with the defining entity for the unit.
1605 procedure Analyze_With_Clause
(N
: Node_Id
) is
1607 -- Retrieve the original kind of the unit node, before analysis.
1608 -- If it is a subprogram instantiation, its analysis below will
1609 -- rewrite as the declaration of the wrapper package. If the same
1610 -- instantiation appears indirectly elsewhere in the context, it
1611 -- will have been analyzed already.
1613 Unit_Kind
: constant Node_Kind
:=
1614 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
1617 Par_Name
: Entity_Id
;
1622 -- Set True if the unit currently being compiled is an internal unit
1624 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
1625 Save_C_Restrict
: constant Save_Cunit_Boolean_Restrictions
:=
1626 Cunit_Boolean_Restrictions_Save
;
1629 if Limited_Present
(N
) then
1630 -- Ada 2005 (AI-50217): Build visibility structures but do not
1633 Build_Limited_Views
(N
);
1637 -- We reset ordinary style checking during the analysis of a with'ed
1638 -- unit, but we do NOT reset GNAT special analysis mode (the latter
1639 -- definitely *does* apply to with'ed units).
1641 if not GNAT_Mode
then
1642 Style_Check
:= False;
1645 -- If the library unit is a predefined unit, and we are in high
1646 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
1647 -- for the analysis of the with'ed unit. This mode does not prevent
1648 -- explicit with'ing of run-time units.
1650 if Configurable_Run_Time_Mode
1652 Is_Predefined_File_Name
1653 (Unit_File_Name
(Get_Source_Unit
(Unit
(Library_Unit
(N
)))))
1655 Configurable_Run_Time_Mode
:= False;
1656 Semantics
(Library_Unit
(N
));
1657 Configurable_Run_Time_Mode
:= True;
1660 Semantics
(Library_Unit
(N
));
1663 U
:= Unit
(Library_Unit
(N
));
1664 Intunit
:= Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
));
1666 -- Following checks are skipped for dummy packages (those supplied
1667 -- for with's where no matching file could be found). Such packages
1668 -- are identified by the Sloc value being set to No_Location
1670 if Sloc
(U
) /= No_Location
then
1672 -- Check restrictions, except that we skip the check if this
1673 -- is an internal unit unless we are compiling the internal
1674 -- unit as the main unit. We also skip this for dummy packages.
1676 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
1677 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
1680 -- Check for inappropriate with of internal implementation unit
1681 -- if we are currently compiling the main unit and the main unit
1682 -- is itself not an internal unit. We do not issue this message
1683 -- for implicit with's generated by the compiler itself.
1685 if Implementation_Unit_Warnings
1686 and then Current_Sem_Unit
= Main_Unit
1687 and then Implementation_Unit
(Get_Source_Unit
(U
))
1688 and then not Intunit
1689 and then not Implicit_With
(N
)
1691 Error_Msg_N
("& is an internal 'G'N'A'T unit?", Name
(N
));
1693 ("\use of this unit is non-portable and version-dependent?",
1698 -- Semantic analysis of a generic unit is performed on a copy of
1699 -- the original tree. Retrieve the entity on which semantic info
1700 -- actually appears.
1702 if Unit_Kind
in N_Generic_Declaration
then
1703 E_Name
:= Defining_Entity
(U
);
1705 -- Note: in the following test, Unit_Kind is the original Nkind, but
1706 -- in the case of an instantiation, semantic analysis above will
1707 -- have replaced the unit by its instantiated version. If the instance
1708 -- body has been generated, the instance now denotes the body entity.
1709 -- For visibility purposes we need the entity of its spec.
1711 elsif (Unit_Kind
= N_Package_Instantiation
1712 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
1713 N_Package_Instantiation
)
1714 and then Nkind
(U
) = N_Package_Body
1716 E_Name
:= Corresponding_Spec
(U
);
1718 elsif Unit_Kind
= N_Package_Instantiation
1719 and then Nkind
(U
) = N_Package_Instantiation
1721 -- If the instance has not been rewritten as a package declaration,
1722 -- then it appeared already in a previous with clause. Retrieve
1723 -- the entity from the previous instance.
1725 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
1727 elsif Unit_Kind
= N_Procedure_Instantiation
1728 or else Unit_Kind
= N_Function_Instantiation
1730 -- Instantiation node is replaced with a package that contains
1731 -- renaming declarations and instance itself. The subprogram
1732 -- Instance is declared in the visible part of the wrapper package.
1734 E_Name
:= First_Entity
(Defining_Entity
(U
));
1736 while Present
(E_Name
) loop
1737 exit when Is_Subprogram
(E_Name
)
1738 and then Is_Generic_Instance
(E_Name
);
1739 E_Name
:= Next_Entity
(E_Name
);
1742 elsif Unit_Kind
= N_Package_Renaming_Declaration
1743 or else Unit_Kind
in N_Generic_Renaming_Declaration
1745 E_Name
:= Defining_Entity
(U
);
1747 elsif Unit_Kind
= N_Subprogram_Body
1748 and then Nkind
(Name
(N
)) = N_Selected_Component
1749 and then not Acts_As_Spec
(Library_Unit
(N
))
1751 -- For a child unit that has no spec, one has been created and
1752 -- analyzed. The entity required is that of the spec.
1754 E_Name
:= Corresponding_Spec
(U
);
1757 E_Name
:= Defining_Entity
(U
);
1760 if Nkind
(Name
(N
)) = N_Selected_Component
then
1762 -- Child unit in a with clause
1764 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
1767 -- Restore style checks and restrictions
1769 Style_Check
:= Save_Style_Check
;
1770 Cunit_Boolean_Restrictions_Restore
(Save_C_Restrict
);
1772 -- Record the reference, but do NOT set the unit as referenced, we
1773 -- want to consider the unit as unreferenced if this is the only
1774 -- reference that occurs.
1776 Set_Entity_With_Style_Check
(Name
(N
), E_Name
);
1777 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
1779 if Is_Child_Unit
(E_Name
) then
1780 Pref
:= Prefix
(Name
(N
));
1781 Par_Name
:= Scope
(E_Name
);
1783 while Nkind
(Pref
) = N_Selected_Component
loop
1784 Change_Selected_Component_To_Expanded_Name
(Pref
);
1785 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
1787 Generate_Reference
(Par_Name
, Pref
);
1788 Pref
:= Prefix
(Pref
);
1790 -- If E_Name is the dummy entity for a nonexistent unit,
1791 -- its scope is set to Standard_Standard, and no attempt
1792 -- should be made to further unwind scopes.
1794 if Par_Name
/= Standard_Standard
then
1795 Par_Name
:= Scope
(Par_Name
);
1799 if Present
(Entity
(Pref
))
1800 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
1802 -- If the entity is set without its unit being compiled,
1803 -- the original parent is a renaming, and Par_Name is the
1804 -- renamed entity. For visibility purposes, we need the
1805 -- original entity, which must be analyzed now, because
1806 -- Load_Unit retrieves directly the renamed unit, and the
1807 -- renaming declaration itself has not been analyzed.
1809 Analyze
(Parent
(Parent
(Entity
(Pref
))));
1810 pragma Assert
(Renamed_Object
(Entity
(Pref
)) = Par_Name
);
1811 Par_Name
:= Entity
(Pref
);
1814 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
1815 Generate_Reference
(Par_Name
, Pref
);
1818 -- If the withed unit is System, and a system extension pragma is
1819 -- present, compile the extension now, rather than waiting for
1820 -- a visibility check on a specific entity.
1822 if Chars
(E_Name
) = Name_System
1823 and then Scope
(E_Name
) = Standard_Standard
1824 and then Present
(System_Extend_Unit
)
1825 and then Present_System_Aux
(N
)
1827 -- If the extension is not present, an error will have been emitted.
1832 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
1833 -- to private_with units; they will be made visible later (just before
1834 -- the private part is analyzed)
1836 if Private_Present
(N
) then
1837 Set_Is_Immediately_Visible
(E_Name
, False);
1839 end Analyze_With_Clause
;
1841 ------------------------------
1842 -- Analyze_With_Type_Clause --
1843 ------------------------------
1845 procedure Analyze_With_Type_Clause
(N
: Node_Id
) is
1846 Loc
: constant Source_Ptr
:= Sloc
(N
);
1847 Nam
: constant Node_Id
:= Name
(N
);
1851 Unum
: Unit_Number_Type
;
1854 procedure Decorate_Tagged_Type
(T
: Entity_Id
);
1855 -- Set basic attributes of type, including its class_wide type.
1857 function In_Chain
(E
: Entity_Id
) return Boolean;
1858 -- Check that the imported type is not already in the homonym chain,
1859 -- for example through a with_type clause in a parent unit.
1861 --------------------------
1862 -- Decorate_Tagged_Type --
1863 --------------------------
1865 procedure Decorate_Tagged_Type
(T
: Entity_Id
) is
1869 Set_Ekind
(T
, E_Record_Type
);
1870 Set_Is_Tagged_Type
(T
);
1872 Set_From_With_Type
(T
);
1875 if not In_Chain
(T
) then
1876 Set_Homonym
(T
, Current_Entity
(T
));
1877 Set_Current_Entity
(T
);
1880 -- Build bogus class_wide type, if not previously done.
1882 if No
(Class_Wide_Type
(T
)) then
1883 CW
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1885 Set_Ekind
(CW
, E_Class_Wide_Type
);
1888 Set_Is_Tagged_Type
(CW
);
1889 Set_Is_First_Subtype
(CW
, True);
1890 Init_Size_Align
(CW
);
1891 Set_Has_Unknown_Discriminants
1893 Set_Class_Wide_Type
(CW
, CW
);
1894 Set_Equivalent_Type
(CW
, Empty
);
1895 Set_From_With_Type
(CW
);
1897 Set_Class_Wide_Type
(T
, CW
);
1899 end Decorate_Tagged_Type
;
1905 function In_Chain
(E
: Entity_Id
) return Boolean is
1906 H
: Entity_Id
:= Current_Entity
(E
);
1909 while Present
(H
) loop
1921 -- Start of processing for Analyze_With_Type_Clause
1924 if Nkind
(Nam
) = N_Selected_Component
then
1925 Pack
:= New_Copy_Tree
(Prefix
(Nam
));
1926 Sel
:= Selector_Name
(Nam
);
1929 Error_Msg_N
("illegal name for imported type", Nam
);
1934 Make_Package_Declaration
(Loc
,
1936 (Make_Package_Specification
(Loc
,
1937 Defining_Unit_Name
=> Pack
,
1938 Visible_Declarations
=> New_List
,
1939 End_Label
=> Empty
)));
1943 (Load_Name
=> Get_Unit_Name
(Decl
),
1949 or else Nkind
(Unit
(Cunit
(Unum
))) /= N_Package_Declaration
1951 Error_Msg_N
("imported type must be declared in package", Nam
);
1954 elsif Unum
= Current_Sem_Unit
then
1956 -- If type is defined in unit being analyzed, then the clause
1962 P
:= Cunit_Entity
(Unum
);
1965 -- Find declaration for imported type, and set its basic attributes
1966 -- if it has not been analyzed (which will be the case if there is
1967 -- circular dependence).
1974 if not Analyzed
(Cunit
(Unum
))
1975 and then not From_With_Type
(P
)
1977 Set_Ekind
(P
, E_Package
);
1978 Set_Etype
(P
, Standard_Void_Type
);
1979 Set_From_With_Type
(P
);
1980 Set_Scope
(P
, Standard_Standard
);
1981 Set_Homonym
(P
, Current_Entity
(P
));
1982 Set_Current_Entity
(P
);
1984 elsif Analyzed
(Cunit
(Unum
))
1985 and then Is_Child_Unit
(P
)
1987 -- If the child unit is already in scope, indicate that it is
1988 -- visible, and remains so after intervening calls to rtsfind.
1990 Set_Is_Visible_Child_Unit
(P
);
1993 if Nkind
(Parent
(P
)) = N_Defining_Program_Unit_Name
then
1995 -- Make parent packages visible.
1998 Parent_Comp
: Node_Id
;
1999 Parent_Id
: Entity_Id
;
2004 Parent_Comp
:= Parent_Spec
(Unit
(Cunit
(Unum
)));
2007 Parent_Id
:= Defining_Entity
(Unit
(Parent_Comp
));
2008 Set_Scope
(Child
, Parent_Id
);
2010 -- The type may be imported from a child unit, in which
2011 -- case the current compilation appears in the name. Do
2012 -- not change its visibility here because it will conflict
2013 -- with the subsequent normal processing.
2015 if not Analyzed
(Unit_Declaration_Node
(Parent_Id
))
2016 and then Parent_Id
/= Cunit_Entity
(Current_Sem_Unit
)
2018 Set_Ekind
(Parent_Id
, E_Package
);
2019 Set_Etype
(Parent_Id
, Standard_Void_Type
);
2021 -- The same package may appear is several with_type
2024 if not From_With_Type
(Parent_Id
) then
2025 Set_Homonym
(Parent_Id
, Current_Entity
(Parent_Id
));
2026 Set_Current_Entity
(Parent_Id
);
2027 Set_From_With_Type
(Parent_Id
);
2031 Set_Is_Immediately_Visible
(Parent_Id
);
2034 Parent_Comp
:= Parent_Spec
(Unit
(Parent_Comp
));
2035 exit when No
(Parent_Comp
);
2038 Set_Scope
(Parent_Id
, Standard_Standard
);
2042 -- Even if analyzed, the package may not be currently visible. It
2043 -- must be while the with_type clause is active.
2045 Set_Is_Immediately_Visible
(P
);
2048 First
(Visible_Declarations
(Specification
(Unit
(Cunit
(Unum
)))));
2050 while Present
(Decl
) loop
2052 if Nkind
(Decl
) = N_Full_Type_Declaration
2053 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
2055 Typ
:= Defining_Identifier
(Decl
);
2057 if Tagged_Present
(N
) then
2059 -- The declaration must indicate that this is a tagged
2060 -- type or a type extension.
2062 if (Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
2063 and then Tagged_Present
(Type_Definition
(Decl
)))
2065 (Nkind
(Type_Definition
(Decl
))
2066 = N_Derived_Type_Definition
2068 (Record_Extension_Part
(Type_Definition
(Decl
))))
2072 Error_Msg_N
("imported type is not a tagged type", Nam
);
2076 if not Analyzed
(Decl
) then
2078 -- Unit is not currently visible. Add basic attributes
2079 -- to type and build its class-wide type.
2081 Init_Size_Align
(Typ
);
2082 Decorate_Tagged_Type
(Typ
);
2086 if Nkind
(Type_Definition
(Decl
))
2087 /= N_Access_To_Object_Definition
2090 ("imported type is not an access type", Nam
);
2092 elsif not Analyzed
(Decl
) then
2093 Set_Ekind
(Typ
, E_Access_Type
);
2094 Set_Etype
(Typ
, Typ
);
2096 Init_Size
(Typ
, System_Address_Size
);
2097 Init_Alignment
(Typ
);
2098 Set_Directly_Designated_Type
(Typ
, Standard_Integer
);
2099 Set_From_With_Type
(Typ
);
2101 if not In_Chain
(Typ
) then
2102 Set_Homonym
(Typ
, Current_Entity
(Typ
));
2103 Set_Current_Entity
(Typ
);
2108 Set_Entity
(Sel
, Typ
);
2111 elsif ((Nkind
(Decl
) = N_Private_Type_Declaration
2112 and then Tagged_Present
(Decl
))
2113 or else (Nkind
(Decl
) = N_Private_Extension_Declaration
))
2114 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
2116 Typ
:= Defining_Identifier
(Decl
);
2118 if not Tagged_Present
(N
) then
2119 Error_Msg_N
("type must be declared tagged", N
);
2121 elsif not Analyzed
(Decl
) then
2122 Decorate_Tagged_Type
(Typ
);
2125 Set_Entity
(Sel
, Typ
);
2126 Set_From_With_Type
(Typ
);
2130 Decl
:= Next
(Decl
);
2133 Error_Msg_NE
("not a visible access or tagged type in&", Nam
, P
);
2135 end Analyze_With_Type_Clause
;
2137 -----------------------------
2138 -- Check_With_Type_Clauses --
2139 -----------------------------
2141 procedure Check_With_Type_Clauses
(N
: Node_Id
) is
2142 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2144 procedure Check_Parent_Context
(U
: Node_Id
);
2145 -- Examine context items of parent unit to locate with_type clauses.
2147 --------------------------
2148 -- Check_Parent_Context --
2149 --------------------------
2151 procedure Check_Parent_Context
(U
: Node_Id
) is
2155 Item
:= First
(Context_Items
(U
));
2156 while Present
(Item
) loop
2157 if Nkind
(Item
) = N_With_Type_Clause
2158 and then not Error_Posted
(Item
)
2160 From_With_Type
(Scope
(Entity
(Selector_Name
(Name
(Item
)))))
2162 Error_Msg_Sloc
:= Sloc
(Item
);
2163 Error_Msg_N
("Missing With_Clause for With_Type_Clause#", N
);
2168 end Check_Parent_Context
;
2170 -- Start of processing for Check_With_Type_Clauses
2173 if Extensions_Allowed
2174 and then (Nkind
(Lib_Unit
) = N_Package_Body
2175 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
)
2177 Check_Parent_Context
(Library_Unit
(N
));
2179 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
2180 Check_Parent_Context
(Parent_Spec
(Unit
(Library_Unit
(N
))));
2183 end Check_With_Type_Clauses
;
2185 ------------------------------
2186 -- Check_Private_Child_Unit --
2187 ------------------------------
2189 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
2190 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2192 Curr_Unit
: Entity_Id
;
2193 Sub_Parent
: Node_Id
;
2194 Priv_Child
: Entity_Id
;
2195 Par_Lib
: Entity_Id
;
2198 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean;
2199 -- Returns true if and only if the library unit is declared with
2200 -- an explicit designation of private.
2202 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
2203 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
2206 return Private_Present
(Comp_Unit
);
2207 end Is_Private_Library_Unit
;
2209 -- Start of processing for Check_Private_Child_Unit
2212 if Nkind
(Lib_Unit
) = N_Package_Body
2213 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
2215 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
2216 Par_Lib
:= Curr_Unit
;
2218 elsif Nkind
(Lib_Unit
) = N_Subunit
then
2220 -- The parent is itself a body. The parent entity is to be found
2221 -- in the corresponding spec.
2223 Sub_Parent
:= Library_Unit
(N
);
2224 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
2226 -- If the parent itself is a subunit, Curr_Unit is the entity
2227 -- of the enclosing body, retrieve the spec entity which is
2228 -- the proper ancestor we need for the following tests.
2230 if Ekind
(Curr_Unit
) = E_Package_Body
then
2231 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2234 Par_Lib
:= Curr_Unit
;
2237 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2239 Par_Lib
:= Curr_Unit
;
2240 Par_Spec
:= Parent_Spec
(Lib_Unit
);
2242 if No
(Par_Spec
) then
2245 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
2249 -- Loop through context items
2251 Item
:= First
(Context_Items
(N
));
2252 while Present
(Item
) loop
2254 -- Ada 2005 (AI-262): Allow private_with of a private child package
2255 -- in public siblings
2257 if Nkind
(Item
) = N_With_Clause
2258 and then not Implicit_With
(Item
)
2259 and then not Private_Present
(Item
)
2260 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
2262 Priv_Child
:= Entity
(Name
(Item
));
2265 Curr_Parent
: Entity_Id
:= Par_Lib
;
2266 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
2267 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
2268 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
2271 -- If the child unit is a public child then locate
2272 -- the nearest private ancestor; Child_Parent will
2273 -- then be set to the parent of that ancestor.
2275 if not Is_Private_Library_Unit
(Priv_Child
) then
2276 while Present
(Prv_Ancestor
)
2277 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
2279 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
2282 if Present
(Prv_Ancestor
) then
2283 Child_Parent
:= Scope
(Prv_Ancestor
);
2287 while Present
(Curr_Parent
)
2288 and then Curr_Parent
/= Standard_Standard
2289 and then Curr_Parent
/= Child_Parent
2292 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
2293 Curr_Parent
:= Scope
(Curr_Parent
);
2296 if not Present
(Curr_Parent
) then
2297 Curr_Parent
:= Standard_Standard
;
2300 if Curr_Parent
/= Child_Parent
then
2302 if Ekind
(Priv_Child
) = E_Generic_Package
2303 and then Chars
(Priv_Child
) in Text_IO_Package_Name
2304 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
2307 ("& is a nested package, not a compilation unit",
2308 Name
(Item
), Priv_Child
);
2312 ("unit in with clause is private child unit!", Item
);
2314 ("current unit must also have parent&!",
2315 Item
, Child_Parent
);
2318 elsif not Curr_Private
2319 and then Nkind
(Lib_Unit
) /= N_Package_Body
2320 and then Nkind
(Lib_Unit
) /= N_Subprogram_Body
2321 and then Nkind
(Lib_Unit
) /= N_Subunit
2324 ("current unit must also be private descendant of&",
2325 Item
, Child_Parent
);
2333 end Check_Private_Child_Unit
;
2335 ----------------------
2336 -- Check_Stub_Level --
2337 ----------------------
2339 procedure Check_Stub_Level
(N
: Node_Id
) is
2340 Par
: constant Node_Id
:= Parent
(N
);
2341 Kind
: constant Node_Kind
:= Nkind
(Par
);
2344 if (Kind
= N_Package_Body
2345 or else Kind
= N_Subprogram_Body
2346 or else Kind
= N_Task_Body
2347 or else Kind
= N_Protected_Body
)
2349 and then (Nkind
(Parent
(Par
)) = N_Compilation_Unit
2350 or else Nkind
(Parent
(Par
)) = N_Subunit
)
2354 -- In an instance, a missing stub appears at any level. A warning
2355 -- message will have been emitted already for the missing file.
2357 elsif not In_Instance
then
2358 Error_Msg_N
("stub cannot appear in an inner scope", N
);
2360 elsif Expander_Active
then
2361 Error_Msg_N
("missing proper body", N
);
2363 end Check_Stub_Level
;
2365 ------------------------
2366 -- Expand_With_Clause --
2367 ------------------------
2369 procedure Expand_With_Clause
(Nam
: Node_Id
; N
: Node_Id
) is
2370 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2371 Ent
: constant Entity_Id
:= Entity
(Nam
);
2375 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
2377 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
2381 if Nkind
(Nam
) = N_Identifier
then
2382 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
2386 Make_Expanded_Name
(Loc
,
2387 Chars
=> Chars
(Entity
(Nam
)),
2388 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
2389 Selector_Name
=> New_Occurrence_Of
(Entity
(Nam
), Loc
));
2390 Set_Entity
(Result
, Entity
(Nam
));
2393 end Build_Unit_Name
;
2396 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2398 Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
(Nam
));
2400 P
:= Parent
(Unit_Declaration_Node
(Ent
));
2401 Set_Library_Unit
(Withn
, P
);
2402 Set_Corresponding_Spec
(Withn
, Ent
);
2403 Set_First_Name
(Withn
, True);
2404 Set_Implicit_With
(Withn
, True);
2406 Prepend
(Withn
, Context_Items
(N
));
2407 Mark_Rewrite_Insertion
(Withn
);
2408 Install_Withed_Unit
(Withn
);
2410 if Nkind
(Nam
) = N_Expanded_Name
then
2411 Expand_With_Clause
(Prefix
(Nam
), N
);
2414 New_Nodes_OK
:= New_Nodes_OK
- 1;
2415 end Expand_With_Clause
;
2417 --------------------------------
2418 -- Expand_Limited_With_Clause --
2419 --------------------------------
2421 procedure Expand_Limited_With_Clause
(Nam
: Node_Id
; N
: Node_Id
) is
2422 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2423 Unum
: Unit_Number_Type
;
2427 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2429 if Nkind
(Nam
) = N_Identifier
then
2431 Make_With_Clause
(Loc
, Name
=> Nam
);
2432 Set_Limited_Present
(Withn
);
2433 Set_First_Name
(Withn
);
2434 Set_Implicit_With
(Withn
);
2436 -- Load the corresponding parent unit
2440 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
2445 if not Analyzed
(Cunit
(Unum
)) then
2446 Set_Library_Unit
(Withn
, Cunit
(Unum
));
2447 Set_Corresponding_Spec
2448 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
2450 Prepend
(Withn
, Context_Items
(Parent
(N
)));
2451 Mark_Rewrite_Insertion
(Withn
);
2454 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
2459 Make_Selected_Component
2461 Prefix
=> Prefix
(Nam
),
2462 Selector_Name
=> Selector_Name
(Nam
)));
2464 Set_Parent
(Withn
, Parent
(N
));
2465 Set_Limited_Present
(Withn
);
2466 Set_First_Name
(Withn
);
2467 Set_Implicit_With
(Withn
);
2471 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
2476 if not Analyzed
(Cunit
(Unum
)) then
2477 Set_Library_Unit
(Withn
, Cunit
(Unum
));
2478 Set_Corresponding_Spec
2479 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
2480 Prepend
(Withn
, Context_Items
(Parent
(N
)));
2481 Mark_Rewrite_Insertion
(Withn
);
2483 Expand_Limited_With_Clause
(Prefix
(Nam
), N
);
2487 New_Nodes_OK
:= New_Nodes_OK
- 1;
2488 end Expand_Limited_With_Clause
;
2490 -----------------------
2491 -- Get_Parent_Entity --
2492 -----------------------
2494 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
2496 if Nkind
(Unit
) = N_Package_Body
2497 and then Nkind
(Original_Node
(Unit
)) = N_Package_Instantiation
2501 (Specification
(Instance_Spec
(Original_Node
(Unit
))));
2503 elsif Nkind
(Unit
) = N_Package_Instantiation
then
2504 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
2507 return Defining_Entity
(Unit
);
2509 end Get_Parent_Entity
;
2511 -----------------------------
2512 -- Implicit_With_On_Parent --
2513 -----------------------------
2515 procedure Implicit_With_On_Parent
2516 (Child_Unit
: Node_Id
;
2519 Loc
: constant Source_Ptr
:= Sloc
(N
);
2520 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
2522 P_Unit
: Node_Id
:= Unit
(P
);
2524 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
2527 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
2528 -- Build prefix of child unit name. Recurse if needed.
2530 function Build_Unit_Name
return Node_Id
;
2531 -- If the unit is a child unit, build qualified name with all
2534 -------------------------
2535 -- Build_Ancestor_Name --
2536 -------------------------
2538 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
2539 P_Ref
: constant Node_Id
:=
2540 New_Reference_To
(Defining_Entity
(P
), Loc
);
2542 if No
(Parent_Spec
(P
)) then
2546 Make_Selected_Component
(Loc
,
2547 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P
))),
2548 Selector_Name
=> P_Ref
);
2550 end Build_Ancestor_Name
;
2552 ---------------------
2553 -- Build_Unit_Name --
2554 ---------------------
2556 function Build_Unit_Name
return Node_Id
is
2559 if No
(Parent_Spec
(P_Unit
)) then
2560 return New_Reference_To
(P_Name
, Loc
);
2563 Make_Expanded_Name
(Loc
,
2564 Chars
=> Chars
(P_Name
),
2565 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
2566 Selector_Name
=> New_Reference_To
(P_Name
, Loc
));
2567 Set_Entity
(Result
, P_Name
);
2570 end Build_Unit_Name
;
2572 -- Start of processing for Implicit_With_On_Parent
2575 -- The unit of the current compilation may be a package body
2576 -- that replaces an instance node. In this case we need the
2577 -- original instance node to construct the proper parent name.
2579 if Nkind
(P_Unit
) = N_Package_Body
2580 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
2582 P_Unit
:= Original_Node
(P_Unit
);
2585 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2586 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
2588 Set_Library_Unit
(Withn
, P
);
2589 Set_Corresponding_Spec
(Withn
, P_Name
);
2590 Set_First_Name
(Withn
, True);
2591 Set_Implicit_With
(Withn
, True);
2593 -- Node is placed at the beginning of the context items, so that
2594 -- subsequent use clauses on the parent can be validated.
2596 Prepend
(Withn
, Context_Items
(N
));
2597 Mark_Rewrite_Insertion
(Withn
);
2598 Install_Withed_Unit
(Withn
);
2600 if Is_Child_Spec
(P_Unit
) then
2601 Implicit_With_On_Parent
(P_Unit
, N
);
2604 New_Nodes_OK
:= New_Nodes_OK
- 1;
2605 end Implicit_With_On_Parent
;
2607 ---------------------
2608 -- Install_Context --
2609 ---------------------
2611 procedure Install_Context
(N
: Node_Id
) is
2612 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2615 Install_Context_Clauses
(N
);
2617 if Is_Child_Spec
(Lib_Unit
) then
2618 Install_Parents
(Lib_Unit
, Private_Present
(Parent
(Lib_Unit
)));
2621 Install_Limited_Context_Clauses
(N
);
2623 Check_With_Type_Clauses
(N
);
2624 end Install_Context
;
2626 -----------------------------
2627 -- Install_Context_Clauses --
2628 -----------------------------
2630 procedure Install_Context_Clauses
(N
: Node_Id
) is
2631 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2633 Uname_Node
: Entity_Id
;
2634 Check_Private
: Boolean := False;
2635 Decl_Node
: Node_Id
;
2636 Lib_Parent
: Entity_Id
;
2639 -- Loop through context clauses to find the with/use clauses.
2640 -- This is done twice, first for everything except limited_with
2641 -- clauses, and then for those, if any are present.
2643 Item
:= First
(Context_Items
(N
));
2644 while Present
(Item
) loop
2646 -- Case of explicit WITH clause
2648 if Nkind
(Item
) = N_With_Clause
2649 and then not Implicit_With
(Item
)
2651 if Limited_Present
(Item
) then
2653 -- Limited withed units will be installed later.
2657 -- If Name (Item) is not an entity name, something is wrong, and
2658 -- this will be detected in due course, for now ignore the item
2660 elsif not Is_Entity_Name
(Name
(Item
)) then
2663 elsif No
(Entity
(Name
(Item
))) then
2664 Set_Entity
(Name
(Item
), Any_Id
);
2668 Uname_Node
:= Entity
(Name
(Item
));
2670 if Is_Private_Descendant
(Uname_Node
) then
2671 Check_Private
:= True;
2674 Install_Withed_Unit
(Item
);
2676 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
2678 -- If the unit is a subprogram instance, it appears nested
2679 -- within a package that carries the parent information.
2681 if Is_Generic_Instance
(Uname_Node
)
2682 and then Ekind
(Uname_Node
) /= E_Package
2684 Decl_Node
:= Parent
(Parent
(Decl_Node
));
2687 if Is_Child_Spec
(Decl_Node
) then
2688 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
2689 Expand_With_Clause
(Prefix
(Name
(Item
)), N
);
2691 -- if not an expanded name, the child unit must be a
2692 -- renaming, nothing to do.
2697 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
2698 and then not Acts_As_Spec
(Parent
(Decl_Node
))
2699 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
2701 Implicit_With_On_Parent
2702 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
2705 -- Check license conditions unless this is a dummy unit
2707 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
2708 License_Check
: declare
2709 Withl
: constant License_Type
:=
2710 License
(Source_Index
2712 (Library_Unit
(Item
))));
2714 Unitl
: constant License_Type
:=
2715 License
(Source_Index
(Current_Sem_Unit
));
2717 procedure License_Error
;
2718 -- Signal error of bad license
2724 procedure License_Error
is
2727 ("?license of with'ed unit & is incompatible",
2731 -- Start of processing for License_Check
2744 if Withl
= Restricted
then
2748 when Modified_GPL
=>
2749 if Withl
= Restricted
or else Withl
= GPL
then
2753 when Unrestricted
=>
2759 -- Case of USE PACKAGE clause
2761 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2762 Analyze_Use_Package
(Item
);
2764 -- Case of USE TYPE clause
2766 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2767 Analyze_Use_Type
(Item
);
2769 -- Case of WITH TYPE clause
2771 -- A With_Type_Clause is processed when installing the context,
2772 -- because it is a visibility mechanism and does not create a
2773 -- semantic dependence on other units, as a With_Clause does.
2775 elsif Nkind
(Item
) = N_With_Type_Clause
then
2776 Analyze_With_Type_Clause
(Item
);
2780 elsif Nkind
(Item
) = N_Pragma
then
2788 if Is_Child_Spec
(Lib_Unit
) then
2790 -- The unit also has implicit withs on its own parents
2792 if No
(Context_Items
(N
)) then
2793 Set_Context_Items
(N
, New_List
);
2796 Implicit_With_On_Parent
(Lib_Unit
, N
);
2799 -- If the unit is a body, the context of the specification must also
2802 if Nkind
(Lib_Unit
) = N_Package_Body
2803 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
2804 and then not Acts_As_Spec
(N
))
2806 Install_Context
(Library_Unit
(N
));
2808 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
2810 -- If the unit is the body of a public child unit, the private
2811 -- declarations of the parent must be made visible. If the child
2812 -- unit is private, the private declarations have been installed
2813 -- already in the call to Install_Parents for the spec. Installing
2814 -- private declarations must be done for all ancestors of public
2815 -- child units. In addition, sibling units mentioned in the
2816 -- context clause of the body are directly visible.
2819 Lib_Spec
: Node_Id
:= Unit
(Library_Unit
(N
));
2824 while Is_Child_Spec
(Lib_Spec
) loop
2825 P
:= Unit
(Parent_Spec
(Lib_Spec
));
2827 if not (Private_Present
(Parent
(Lib_Spec
))) then
2828 P_Name
:= Defining_Entity
(P
);
2829 Install_Private_Declarations
(P_Name
);
2830 Install_Private_With_Clauses
(P_Name
);
2831 Set_Use
(Private_Declarations
(Specification
(P
)));
2839 -- For a package body, children in context are immediately visible
2841 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
2844 if Nkind
(Lib_Unit
) = N_Generic_Package_Declaration
2845 or else Nkind
(Lib_Unit
) = N_Generic_Subprogram_Declaration
2846 or else Nkind
(Lib_Unit
) = N_Package_Declaration
2847 or else Nkind
(Lib_Unit
) = N_Subprogram_Declaration
2849 if Is_Child_Spec
(Lib_Unit
) then
2850 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
2851 Set_Is_Private_Descendant
2852 (Defining_Entity
(Lib_Unit
),
2853 Is_Private_Descendant
(Lib_Parent
)
2854 or else Private_Present
(Parent
(Lib_Unit
)));
2857 Set_Is_Private_Descendant
2858 (Defining_Entity
(Lib_Unit
),
2859 Private_Present
(Parent
(Lib_Unit
)));
2863 if Check_Private
then
2864 Check_Private_Child_Unit
(N
);
2866 end Install_Context_Clauses
;
2868 -------------------------------------
2869 -- Install_Limited_Context_Clauses --
2870 -------------------------------------
2872 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
2875 procedure Check_Parent
(P
: Node_Id
; W
: Node_Id
);
2876 -- Check that the unlimited view of a given compilation_unit is not
2877 -- already visible in the parents (neither immediately through the
2878 -- context clauses, nor indirectly through "use + renamings").
2880 procedure Check_Private_Limited_Withed_Unit
(N
: Node_Id
);
2881 -- Check that if a limited_with clause of a given compilation_unit
2882 -- mentions a private child of some library unit, then the given
2883 -- compilation_unit shall be the declaration of a private descendant
2884 -- of that library unit.
2886 procedure Check_Withed_Unit
(W
: Node_Id
);
2887 -- Check that a limited with_clause does not appear in the same
2888 -- context_clause as a nonlimited with_clause that mentions
2889 -- the same library.
2895 procedure Check_Parent
(P
: Node_Id
; W
: Node_Id
) is
2904 pragma Assert
(Nkind
(W
) = N_With_Clause
);
2906 -- Step 1: Check if the unlimited view is installed in the parent
2908 Item
:= First
(Context_Items
(P
));
2909 while Present
(Item
) loop
2910 if Nkind
(Item
) = N_With_Clause
2911 and then not Limited_Present
(Item
)
2912 and then not Implicit_With
(Item
)
2913 and then Library_Unit
(Item
) = Library_Unit
(W
)
2915 Error_Msg_N
("unlimited view visible in ancestor", W
);
2922 -- Step 2: Check "use + renamings"
2924 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
2925 Spec
:= Specification
(Unit
(P
));
2927 -- We tried to traverse the list of entities corresponding to the
2928 -- defining entity of the package spec. However, first_entity was
2929 -- found to be 'empty'. Don't know why???
2931 -- Def := Defining_Unit_Name (Spec);
2932 -- Ent := First_Entity (Def);
2934 -- As a workaround we traverse the list of visible declarations ???
2936 Item
:= First
(Visible_Declarations
(Spec
));
2937 while Present
(Item
) loop
2939 if Nkind
(Item
) = N_Use_Package_Clause
then
2941 -- Traverse the list of packages
2943 Nam
:= First
(Names
(Item
));
2945 while Present
(Nam
) loop
2948 pragma Assert
(Present
(Parent
(E
)));
2950 if Nkind
(Parent
(E
))
2951 = N_Package_Renaming_Declaration
2952 and then Renamed_Entity
(E
) = WEnt
2954 Error_Msg_N
("unlimited view visible through "
2955 & "use_clause + renamings", W
);
2958 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
2960 -- The use clause may refer to a local package.
2961 -- Check all the enclosing scopes.
2964 while E2
/= Standard_Standard
2965 and then E2
/= WEnt
loop
2970 Error_Msg_N
("unlimited view visible through "
2971 & "use_clause ", W
);
2984 -- Recursive call to check all the ancestors
2986 if Is_Child_Spec
(Unit
(P
)) then
2987 Check_Parent
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
2991 ---------------------------------------
2992 -- Check_Private_Limited_Withed_Unit --
2993 ---------------------------------------
2995 procedure Check_Private_Limited_Withed_Unit
(N
: Node_Id
) is
2998 Found
: Boolean := False;
3001 -- If the current compilation unit is not private we don't
3002 -- need to check anything else.
3004 if not Private_Present
(Parent
(N
)) then
3008 -- Compilation unit of the parent of the withed library unit
3010 P
:= Parent_Spec
(Unit
(Library_Unit
(N
)));
3012 -- Traverse all the ancestors of the current compilation
3013 -- unit to check if it is a descendant of named library unit.
3016 while Present
(Parent_Spec
(Unit
(C
))) loop
3017 C
:= Parent_Spec
(Unit
(C
));
3027 Error_Msg_N
("current unit is not a private descendant"
3028 & " of the withed unit ('R'M 10.1.2(8)", N
);
3030 end Check_Private_Limited_Withed_Unit
;
3032 -----------------------
3033 -- Check_Withed_Unit --
3034 -----------------------
3036 procedure Check_Withed_Unit
(W
: Node_Id
) is
3040 -- A limited with_clause can not appear in the same context_clause
3041 -- as a nonlimited with_clause which mentions the same library.
3043 Item
:= First
(Context_Items
(N
));
3044 while Present
(Item
) loop
3045 if Nkind
(Item
) = N_With_Clause
3046 and then not Limited_Present
(Item
)
3047 and then not Implicit_With
(Item
)
3048 and then Library_Unit
(Item
) = Library_Unit
(W
)
3050 Error_Msg_N
("limited and unlimited view "
3051 & "not allowed in the same context clauses", W
);
3057 end Check_Withed_Unit
;
3059 -- Start of processing for Install_Limited_Context_Clauses
3062 Item
:= First
(Context_Items
(N
));
3063 while Present
(Item
) loop
3064 if Nkind
(Item
) = N_With_Clause
3065 and then Limited_Present
(Item
)
3067 Check_Withed_Unit
(Item
);
3069 if Private_Present
(Library_Unit
(Item
)) then
3070 Check_Private_Limited_Withed_Unit
(Item
);
3073 if Is_Child_Spec
(Unit
(N
)) then
3074 Check_Parent
(Parent_Spec
(Unit
(N
)), Item
);
3077 Install_Limited_Withed_Unit
(Item
);
3082 end Install_Limited_Context_Clauses
;
3084 ---------------------
3085 -- Install_Parents --
3086 ---------------------
3088 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean) is
3095 P
:= Unit
(Parent_Spec
(Lib_Unit
));
3096 P_Name
:= Get_Parent_Entity
(P
);
3098 if Etype
(P_Name
) = Any_Type
then
3102 if Ekind
(P_Name
) = E_Generic_Package
3103 and then Nkind
(Lib_Unit
) /= N_Generic_Subprogram_Declaration
3104 and then Nkind
(Lib_Unit
) /= N_Generic_Package_Declaration
3105 and then Nkind
(Lib_Unit
) not in N_Generic_Renaming_Declaration
3108 ("child of a generic package must be a generic unit", Lib_Unit
);
3110 elsif not Is_Package
(P_Name
) then
3112 ("parent unit must be package or generic package", Lib_Unit
);
3113 raise Unrecoverable_Error
;
3115 elsif Present
(Renamed_Object
(P_Name
)) then
3116 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
3117 raise Unrecoverable_Error
;
3119 -- Verify that a child of an instance is itself an instance, or
3120 -- the renaming of one. Given that an instance that is a unit is
3121 -- replaced with a package declaration, check against the original
3124 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
3125 and then Nkind
(Lib_Unit
)
3126 not in N_Renaming_Declaration
3127 and then Nkind
(Original_Node
(Lib_Unit
))
3128 not in N_Generic_Instantiation
3131 ("child of an instance must be an instance or renaming", Lib_Unit
);
3134 -- This is the recursive call that ensures all parents are loaded
3136 if Is_Child_Spec
(P
) then
3138 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)));
3141 -- Now we can install the context for this parent
3143 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
));
3144 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
3146 -- The child unit is in the declarative region of the parent. The
3147 -- parent must therefore appear in the scope stack and be visible,
3148 -- as when compiling the corresponding body. If the child unit is
3149 -- private or it is a package body, private declarations must be
3150 -- accessible as well. Use declarations in the parent must also
3151 -- be installed. Finally, other child units of the same parent that
3152 -- are in the context are immediately visible.
3154 -- Find entity for compilation unit, and set its private descendant
3155 -- status as needed.
3157 E_Name
:= Defining_Entity
(Lib_Unit
);
3159 Set_Is_Child_Unit
(E_Name
);
3161 Set_Is_Private_Descendant
(E_Name
,
3162 Is_Private_Descendant
(P_Name
)
3163 or else Private_Present
(Parent
(Lib_Unit
)));
3165 P_Spec
:= Specification
(Unit_Declaration_Node
(P_Name
));
3168 -- Save current visibility of unit
3170 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
3171 Is_Immediately_Visible
(P_Name
);
3172 Set_Is_Immediately_Visible
(P_Name
);
3173 Install_Visible_Declarations
(P_Name
);
3174 Set_Use
(Visible_Declarations
(P_Spec
));
3176 -- If the parent is a generic unit, its formal part may contain
3177 -- formal packages and use clauses for them.
3179 if Ekind
(P_Name
) = E_Generic_Package
then
3180 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
3184 or else Private_Present
(Parent
(Lib_Unit
))
3186 Install_Private_Declarations
(P_Name
);
3187 Install_Private_With_Clauses
(P_Name
);
3188 Set_Use
(Private_Declarations
(P_Spec
));
3190 end Install_Parents
;
3192 ----------------------------------
3193 -- Install_Private_With_Clauses --
3194 ----------------------------------
3196 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
3197 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
3201 if Debug_Flag_I
then
3202 Write_Str
("install private with clauses of ");
3203 Write_Name
(Chars
(P
));
3207 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
3208 Item
:= First
(Context_Items
(Parent
(Decl
)));
3210 while Present
(Item
) loop
3211 if Nkind
(Item
) = N_With_Clause
3212 and then Private_Present
(Item
)
3214 if Limited_Present
(Item
) then
3215 Install_Limited_Withed_Unit
(Item
);
3217 Install_Withed_Unit
(Item
, Private_With_OK
=> True);
3224 end Install_Private_With_Clauses
;
3226 ----------------------
3227 -- Install_Siblings --
3228 ----------------------
3230 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
3235 -- Iterate over explicit with clauses, and check whether the
3236 -- scope of each entity is an ancestor of the current unit.
3238 Item
:= First
(Context_Items
(N
));
3239 while Present
(Item
) loop
3240 if Nkind
(Item
) = N_With_Clause
3241 and then not Implicit_With
(Item
)
3242 and then not Limited_Present
(Item
)
3244 Id
:= Entity
(Name
(Item
));
3246 if Is_Child_Unit
(Id
)
3247 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
3249 Set_Is_Immediately_Visible
(Id
);
3251 -- Check for the presence of another unit in the context,
3252 -- that may be inadvertently hidden by the child.
3254 Prev
:= Current_Entity
(Id
);
3257 and then Is_Immediately_Visible
(Prev
)
3258 and then not Is_Child_Unit
(Prev
)
3264 Clause
:= First
(Context_Items
(N
));
3266 while Present
(Clause
) loop
3267 if Nkind
(Clause
) = N_With_Clause
3268 and then Entity
(Name
(Clause
)) = Prev
3271 ("child unit& hides compilation unit " &
3272 "with the same name?",
3282 -- the With_Clause may be on a grand-child, which makes
3283 -- the child immediately visible.
3285 elsif Is_Child_Unit
(Scope
(Id
))
3286 and then Is_Ancestor_Package
(Scope
(Scope
(Id
)), U_Name
)
3288 Set_Is_Immediately_Visible
(Scope
(Id
));
3294 end Install_Siblings
;
3296 -------------------------------
3297 -- Install_Limited_With_Unit --
3298 -------------------------------
3300 procedure Install_Limited_Withed_Unit
(N
: Node_Id
) is
3301 Unum
: constant Unit_Number_Type
:=
3302 Get_Source_Unit
(Library_Unit
(N
));
3303 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
3305 Is_Child_Package
: Boolean := False;
3307 Lim_Header
: Entity_Id
;
3308 Lim_Typ
: Entity_Id
;
3310 function In_Chain
(E
: Entity_Id
) return Boolean;
3311 -- Check that the shadow entity is not already in the homonym
3312 -- chain, for example through a limited_with clause in a parent unit.
3318 function In_Chain
(E
: Entity_Id
) return Boolean is
3319 H
: Entity_Id
:= Current_Entity
(E
);
3322 while Present
(H
) loop
3333 -- Start of processing for Install_Limited_Withed_Unit
3336 -- In case of limited with_clause on subprograms, generics, instances,
3337 -- or generic renamings, the corresponding error was previously posted
3338 -- and we have nothing to do here.
3340 case Nkind
(P_Unit
) is
3342 when N_Package_Declaration
=>
3345 when N_Subprogram_Declaration |
3346 N_Generic_Package_Declaration |
3347 N_Generic_Subprogram_Declaration |
3348 N_Package_Instantiation |
3349 N_Function_Instantiation |
3350 N_Procedure_Instantiation |
3351 N_Generic_Package_Renaming_Declaration |
3352 N_Generic_Procedure_Renaming_Declaration |
3353 N_Generic_Function_Renaming_Declaration
=>
3357 raise Program_Error
;
3360 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
3362 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
3364 -- Retrieve entity of child package
3366 Is_Child_Package
:= True;
3367 P
:= Defining_Identifier
(P
);
3370 -- A common usage of the limited-with is to have a limited-with
3371 -- in the package spec, and a normal with in its package body.
3374 -- limited with X; -- [1]
3378 -- package body A is ...
3380 -- The compilation of A's body installs the entities of its
3381 -- withed packages (the context clauses found at [2]) and
3382 -- then the context clauses of its specification (found at [1]).
3384 -- As a consequence, at point [1] the specification of X has been
3385 -- analyzed and it is immediately visible. According to the semantics
3386 -- of the limited-with context clauses we don't install the limited
3387 -- view because the full view of X supersedes its limited view.
3389 if Analyzed
(Cunit
(Unum
))
3390 and then (Is_Immediately_Visible
(P
)
3391 or else (Is_Child_Package
3392 and then Is_Visible_Child_Unit
(P
)))
3394 -- Ada 2005 (AI-262): Install the private declarations of P
3396 if Private_Present
(N
)
3397 and then not In_Private_Part
(P
)
3402 Id
:= First_Private_Entity
(P
);
3404 while Present
(Id
) loop
3405 if not Is_Internal
(Id
)
3406 and then not Is_Child_Unit
(Id
)
3408 if not In_Chain
(Id
) then
3409 Set_Homonym
(Id
, Current_Entity
(Id
));
3410 Set_Current_Entity
(Id
);
3413 Set_Is_Immediately_Visible
(Id
);
3419 Set_In_Private_Part
(P
);
3426 if Debug_Flag_I
then
3427 Write_Str
("install limited view of ");
3428 Write_Name
(Chars
(P
));
3432 if not Analyzed
(Cunit
(Unum
)) then
3433 Set_Ekind
(P
, E_Package
);
3434 Set_Etype
(P
, Standard_Void_Type
);
3435 Set_Scope
(P
, Standard_Standard
);
3437 -- Place entity on visibility structure
3439 if Current_Entity
(P
) /= P
then
3440 Set_Homonym
(P
, Current_Entity
(P
));
3441 Set_Current_Entity
(P
);
3443 if Debug_Flag_I
then
3444 Write_Str
(" (homonym) chain ");
3445 Write_Name
(Chars
(P
));
3451 if Is_Child_Package
then
3452 Set_Is_Child_Unit
(P
);
3453 Set_Is_Visible_Child_Unit
(P
);
3456 Parent_Comp
: Node_Id
;
3457 Parent_Id
: Entity_Id
;
3460 Parent_Comp
:= Parent_Spec
(Unit
(Cunit
(Unum
)));
3461 Parent_Id
:= Defining_Entity
(Unit
(Parent_Comp
));
3463 Set_Scope
(P
, Parent_Id
);
3469 -- If the unit appears in a previous regular with_clause, the
3470 -- regular entities must be unchained before the shadow ones
3471 -- are made accessible.
3476 Ent
:= First_Entity
(P
);
3478 while Present
(Ent
) loop
3486 -- The package must be visible while the with_type clause is active,
3487 -- because references to the type P.T must resolve in the usual way.
3489 Set_Is_Immediately_Visible
(P
);
3491 -- Install each incomplete view. The first element of the limited view
3492 -- is a header (an E_Package entity) that is used to reference the first
3493 -- shadow entity in the private part of the package
3495 Lim_Header
:= Limited_View
(P
);
3496 Lim_Typ
:= First_Entity
(Lim_Header
);
3498 while Present
(Lim_Typ
) loop
3500 exit when not Private_Present
(N
)
3501 and then Lim_Typ
= First_Private_Entity
(Lim_Header
);
3503 if not In_Chain
(Lim_Typ
) then
3504 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
3505 Set_Current_Entity
(Lim_Typ
);
3507 if Debug_Flag_I
then
3508 Write_Str
(" (homonym) chain ");
3509 Write_Name
(Chars
(Lim_Typ
));
3514 Next_Entity
(Lim_Typ
);
3517 -- The context clause has installed a limited-view, mark it
3518 -- accordingly, to uninstall it when the context is removed.
3520 Set_Limited_View_Installed
(N
);
3521 Set_From_With_Type
(P
);
3522 end Install_Limited_Withed_Unit
;
3524 -------------------------
3525 -- Install_Withed_Unit --
3526 -------------------------
3528 procedure Install_Withed_Unit
3529 (With_Clause
: Node_Id
;
3530 Private_With_OK
: Boolean := False)
3532 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
3533 P
: constant Entity_Id
:= Scope
(Uname
);
3536 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
3537 -- compiling a package declaration and the Private_With_OK flag was not
3538 -- set by the caller. These declarations will be installed later (before
3539 -- analyzing the private part of the package).
3541 if Private_Present
(With_Clause
)
3542 and then Nkind
(Cunit
(Current_Sem_Unit
)) = N_Package_Declaration
3543 and then not (Private_With_OK
)
3548 if Debug_Flag_I
then
3549 if Private_Present
(With_Clause
) then
3550 Write_Str
("install private withed unit ");
3552 Write_Str
("install withed unit ");
3555 Write_Name
(Chars
(Uname
));
3559 -- We do not apply the restrictions to an internal unit unless
3560 -- we are compiling the internal unit as a main unit. This check
3561 -- is also skipped for dummy units (for missing packages).
3563 if Sloc
(Uname
) /= No_Location
3564 and then (not Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
3565 or else Current_Sem_Unit
= Main_Unit
)
3567 Check_Restricted_Unit
3568 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
3571 if P
/= Standard_Standard
then
3573 -- If the unit is not analyzed after analysis of the with clause,
3574 -- and it is an instantiation, then it awaits a body and is the main
3575 -- unit. Its appearance in the context of some other unit indicates
3576 -- a circular dependency (DEC suite perversity).
3578 if not Analyzed
(Uname
)
3579 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
3582 ("instantiation depends on itself", Name
(With_Clause
));
3584 elsif not Is_Visible_Child_Unit
(Uname
) then
3585 Set_Is_Visible_Child_Unit
(Uname
);
3587 if Is_Generic_Instance
(Uname
)
3588 and then Ekind
(Uname
) in Subprogram_Kind
3590 -- Set flag as well on the visible entity that denotes the
3591 -- instance, which renames the current one.
3593 Set_Is_Visible_Child_Unit
3595 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
3598 -- The parent unit may have been installed already, and
3599 -- may have appeared in a use clause.
3601 if In_Use
(Scope
(Uname
)) then
3602 Set_Is_Potentially_Use_Visible
(Uname
);
3605 Set_Context_Installed
(With_Clause
);
3608 elsif not Is_Immediately_Visible
(Uname
) then
3609 if not Private_Present
(With_Clause
)
3610 or else Private_With_OK
3612 Set_Is_Immediately_Visible
(Uname
);
3615 Set_Context_Installed
(With_Clause
);
3618 -- A with-clause overrides a with-type clause: there are no restric-
3619 -- tions on the use of package entities.
3621 if Ekind
(Uname
) = E_Package
then
3622 Set_From_With_Type
(Uname
, False);
3624 end Install_Withed_Unit
;
3630 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
3631 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
3634 return (K
in N_Generic_Declaration
or else
3635 K
in N_Generic_Instantiation
or else
3636 K
in N_Generic_Renaming_Declaration
or else
3637 K
= N_Package_Declaration
or else
3638 K
= N_Package_Renaming_Declaration
or else
3639 K
= N_Subprogram_Declaration
or else
3640 K
= N_Subprogram_Renaming_Declaration
)
3641 and then Present
(Parent_Spec
(Lib_Unit
));
3644 -----------------------
3645 -- Load_Needed_Body --
3646 -----------------------
3648 -- N is a generic unit named in a with clause, or else it is
3649 -- a unit that contains a generic unit or an inlined function.
3650 -- In order to perform an instantiation, the body of the unit
3651 -- must be present. If the unit itself is generic, we assume
3652 -- that an instantiation follows, and load and analyze the body
3653 -- unconditionally. This forces analysis of the spec as well.
3655 -- If the unit is not generic, but contains a generic unit, it
3656 -- is loaded on demand, at the point of instantiation (see ch12).
3658 procedure Load_Needed_Body
(N
: Node_Id
; OK
: out Boolean) is
3659 Body_Name
: Unit_Name_Type
;
3660 Unum
: Unit_Number_Type
;
3662 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
3663 -- The loading and analysis is done with style checks off
3666 if not GNAT_Mode
then
3667 Style_Check
:= False;
3670 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
3673 (Load_Name
=> Body_Name
,
3679 if Unum
= No_Unit
then
3683 Compiler_State
:= Analyzing
; -- reset after load
3685 if not Fatal_Error
(Unum
) or else Try_Semantics
then
3686 if Debug_Flag_L
then
3687 Write_Str
("*** Loaded generic body");
3691 Semantics
(Cunit
(Unum
));
3697 Style_Check
:= Save_Style_Check
;
3698 end Load_Needed_Body
;
3700 -------------------------
3701 -- Build_Limited_Views --
3702 -------------------------
3704 procedure Build_Limited_Views
(N
: Node_Id
) is
3705 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Library_Unit
(N
));
3706 P
: constant Entity_Id
:= Cunit_Entity
(Unum
);
3708 Spec
: Node_Id
; -- To denote a package specification
3709 Lim_Typ
: Entity_Id
; -- To denote shadow entities
3710 Comp_Typ
: Entity_Id
; -- To denote real entities
3712 Lim_Header
: Entity_Id
; -- Package entity
3713 Last_Lim_E
: Entity_Id
:= Empty
; -- Last limited entity built
3714 Last_Pub_Lim_E
: Entity_Id
; -- To set the first private entity
3716 procedure Decorate_Incomplete_Type
3719 -- Add attributes of an incomplete type to a shadow entity. The same
3720 -- attributes are placed on the real entity, so that gigi receives
3721 -- a consistent view.
3723 procedure Decorate_Package_Specification
(P
: Entity_Id
);
3724 -- Add attributes of a package entity to the entity in a package
3727 procedure Decorate_Tagged_Type
3731 -- Set basic attributes of tagged type T, including its class_wide type.
3732 -- The parameters Loc, Scope are used to decorate the class_wide type.
3734 procedure Build_Chain
3736 First_Decl
: Node_Id
);
3737 -- Construct list of shadow entities and attach it to entity of
3738 -- package that is mentioned in a limited_with clause.
3740 function New_Internal_Shadow_Entity
3741 (Kind
: Entity_Kind
;
3742 Sloc_Value
: Source_Ptr
;
3743 Id_Char
: Character) return Entity_Id
;
3744 -- Build a new internal entity and append it to the list of shadow
3745 -- entities available through the limited-header
3747 ------------------------------
3748 -- Decorate_Incomplete_Type --
3749 ------------------------------
3751 procedure Decorate_Incomplete_Type
3756 Set_Ekind
(E
, E_Incomplete_Type
);
3757 Set_Scope
(E
, Scop
);
3759 Set_Is_First_Subtype
(E
, True);
3760 Set_Stored_Constraint
(E
, No_Elist
);
3761 Set_Full_View
(E
, Empty
);
3762 Init_Size_Align
(E
);
3763 end Decorate_Incomplete_Type
;
3765 --------------------------
3766 -- Decorate_Tagged_Type --
3767 --------------------------
3769 procedure Decorate_Tagged_Type
3777 Decorate_Incomplete_Type
(T
, Scop
);
3778 Set_Is_Tagged_Type
(T
);
3780 -- Build corresponding class_wide type, if not previously done
3782 if No
(Class_Wide_Type
(T
)) then
3783 CW
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3785 Set_Ekind
(CW
, E_Class_Wide_Type
);
3787 Set_Scope
(CW
, Scop
);
3788 Set_Is_Tagged_Type
(CW
);
3789 Set_Is_First_Subtype
(CW
, True);
3790 Init_Size_Align
(CW
);
3791 Set_Has_Unknown_Discriminants
(CW
, True);
3792 Set_Class_Wide_Type
(CW
, CW
);
3793 Set_Equivalent_Type
(CW
, Empty
);
3794 Set_From_With_Type
(CW
, From_With_Type
(T
));
3796 Set_Class_Wide_Type
(T
, CW
);
3798 end Decorate_Tagged_Type
;
3800 ------------------------------------
3801 -- Decorate_Package_Specification --
3802 ------------------------------------
3804 procedure Decorate_Package_Specification
(P
: Entity_Id
) is
3806 -- Place only the most basic attributes
3808 Set_Ekind
(P
, E_Package
);
3809 Set_Etype
(P
, Standard_Void_Type
);
3810 end Decorate_Package_Specification
;
3812 -------------------------
3813 -- New_Internal_Entity --
3814 -------------------------
3816 function New_Internal_Shadow_Entity
3817 (Kind
: Entity_Kind
;
3818 Sloc_Value
: Source_Ptr
;
3819 Id_Char
: Character) return Entity_Id
3821 E
: constant Entity_Id
:=
3822 Make_Defining_Identifier
(Sloc_Value
,
3823 Chars
=> New_Internal_Name
(Id_Char
));
3826 Set_Ekind
(E
, Kind
);
3827 Set_Is_Internal
(E
, True);
3829 if Kind
in Type_Kind
then
3830 Init_Size_Align
(E
);
3833 Append_Entity
(E
, Lim_Header
);
3836 end New_Internal_Shadow_Entity
;
3842 procedure Build_Chain
3844 First_Decl
: Node_Id
)
3846 Analyzed_Unit
: constant Boolean := Analyzed
(Cunit
(Unum
));
3847 Is_Tagged
: Boolean;
3853 while Present
(Decl
) loop
3855 -- For each library_package_declaration in the environment, there
3856 -- is an implicit declaration of a *limited view* of that library
3857 -- package. The limited view of a package contains:
3859 -- * For each nested package_declaration, a declaration of the
3860 -- limited view of that package, with the same defining-
3861 -- program-unit name.
3863 -- * For each type_declaration in the visible part, an incomplete
3864 -- type-declaration with the same defining_identifier, whose
3865 -- completion is the type_declaration. If the type_declaration
3866 -- is tagged, then the incomplete_type_declaration is tagged
3869 if Nkind
(Decl
) = N_Full_Type_Declaration
then
3871 Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
3872 and then Tagged_Present
(Type_Definition
(Decl
));
3874 Comp_Typ
:= Defining_Identifier
(Decl
);
3876 if not Analyzed_Unit
then
3878 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
);
3880 Decorate_Incomplete_Type
(Comp_Typ
, Scope
);
3884 -- Create shadow entity for type
3886 Lim_Typ
:= New_Internal_Shadow_Entity
3887 (Kind
=> Ekind
(Comp_Typ
),
3888 Sloc_Value
=> Sloc
(Comp_Typ
),
3891 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
3892 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
3893 Set_From_With_Type
(Lim_Typ
);
3896 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
3898 Decorate_Incomplete_Type
(Lim_Typ
, Scope
);
3901 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
3903 elsif Nkind
(Decl
) = N_Private_Type_Declaration
3904 and then Tagged_Present
(Decl
)
3906 Comp_Typ
:= Defining_Identifier
(Decl
);
3908 if not Analyzed_Unit
then
3909 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
);
3912 Lim_Typ
:= New_Internal_Shadow_Entity
3913 (Kind
=> Ekind
(Comp_Typ
),
3914 Sloc_Value
=> Sloc
(Comp_Typ
),
3917 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
3918 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
3919 Set_From_With_Type
(Lim_Typ
);
3921 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
3923 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
3925 elsif Nkind
(Decl
) = N_Package_Declaration
then
3930 Spec
: constant Node_Id
:= Specification
(Decl
);
3933 Comp_Typ
:= Defining_Unit_Name
(Spec
);
3935 if not Analyzed
(Cunit
(Unum
)) then
3936 Decorate_Package_Specification
(Comp_Typ
);
3937 Set_Scope
(Comp_Typ
, Scope
);
3940 Lim_Typ
:= New_Internal_Shadow_Entity
3941 (Kind
=> Ekind
(Comp_Typ
),
3942 Sloc_Value
=> Sloc
(Comp_Typ
),
3945 Decorate_Package_Specification
(Lim_Typ
);
3946 Set_Scope
(Lim_Typ
, Scope
);
3948 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
3949 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
3950 Set_From_With_Type
(Lim_Typ
);
3952 -- Note: The non_limited_view attribute is not used
3953 -- for local packages.
3957 First_Decl
=> First
(Visible_Declarations
(Spec
)));
3965 -- Start of processing for Build_Limited_Views
3968 pragma Assert
(Limited_Present
(N
));
3970 -- A library_item mentioned in a limited_with_clause shall be
3971 -- a package_declaration, not a subprogram_declaration,
3972 -- generic_declaration, generic_instantiation, or
3973 -- package_renaming_declaration
3975 case Nkind
(Unit
(Library_Unit
(N
))) is
3977 when N_Package_Declaration
=>
3980 when N_Subprogram_Declaration
=>
3981 Error_Msg_N
("subprograms not allowed in "
3982 & "limited with_clauses", N
);
3985 when N_Generic_Package_Declaration |
3986 N_Generic_Subprogram_Declaration
=>
3987 Error_Msg_N
("generics not allowed in "
3988 & "limited with_clauses", N
);
3991 when N_Package_Instantiation |
3992 N_Function_Instantiation |
3993 N_Procedure_Instantiation
=>
3994 Error_Msg_N
("generic instantiations not allowed in "
3995 & "limited with_clauses", N
);
3998 when N_Generic_Package_Renaming_Declaration |
3999 N_Generic_Procedure_Renaming_Declaration |
4000 N_Generic_Function_Renaming_Declaration
=>
4001 Error_Msg_N
("generic renamings not allowed in "
4002 & "limited with_clauses", N
);
4006 raise Program_Error
;
4009 -- Check if the chain is already built
4011 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
4013 if Limited_View_Installed
(Spec
) then
4017 Set_Ekind
(P
, E_Package
);
4019 -- Build the header of the limited_view
4021 Lim_Header
:= Make_Defining_Identifier
(Sloc
(N
),
4022 Chars
=> New_Internal_Name
(Id_Char
=> 'Z'));
4023 Set_Ekind
(Lim_Header
, E_Package
);
4024 Set_Is_Internal
(Lim_Header
);
4025 Set_Limited_View
(P
, Lim_Header
);
4027 -- Create the auxiliary chain. All the shadow entities are appended
4028 -- to the list of entities of the limited-view header
4032 First_Decl
=> First
(Visible_Declarations
(Spec
)));
4034 -- Save the last built shadow entity. It is needed later to set the
4035 -- reference to the first shadow entity in the private part
4037 Last_Pub_Lim_E
:= Last_Lim_E
;
4039 -- Ada 2005 (AI-262): Add the limited view of the private declarations
4040 -- Required to give support to limited-private-with clauses
4042 Build_Chain
(Scope
=> P
,
4043 First_Decl
=> First
(Private_Declarations
(Spec
)));
4045 if Last_Pub_Lim_E
/= Empty
then
4046 Set_First_Private_Entity
(Lim_Header
,
4047 Next_Entity
(Last_Pub_Lim_E
));
4049 Set_First_Private_Entity
(Lim_Header
,
4053 Set_Limited_View_Installed
(Spec
);
4054 end Build_Limited_Views
;
4056 -------------------------------
4057 -- Check_Body_Needed_For_SAL --
4058 -------------------------------
4060 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
4062 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
4063 -- Determine whether use of entity E might require the presence
4064 -- of its body. For a package this requires a recursive traversal
4065 -- of all nested declarations.
4067 ---------------------------
4068 -- Entity_Needed_For_SAL --
4069 ---------------------------
4071 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
4075 if Is_Subprogram
(E
)
4076 and then Has_Pragma_Inline
(E
)
4080 elsif Ekind
(E
) = E_Generic_Function
4081 or else Ekind
(E
) = E_Generic_Procedure
4085 elsif Ekind
(E
) = E_Generic_Package
4087 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
4088 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
4092 elsif Ekind
(E
) = E_Package
4094 Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
4095 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
4097 Ent
:= First_Entity
(E
);
4099 while Present
(Ent
) loop
4100 if Entity_Needs_Body
(Ent
) then
4112 end Entity_Needs_Body
;
4114 -- Start of processing for Check_Body_Needed_For_SAL
4117 if Ekind
(Unit_Name
) = E_Generic_Package
4119 Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
4120 N_Generic_Package_Declaration
4122 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
4124 Set_Body_Needed_For_SAL
(Unit_Name
);
4126 elsif Ekind
(Unit_Name
) = E_Generic_Procedure
4127 or else Ekind
(Unit_Name
) = E_Generic_Function
4129 Set_Body_Needed_For_SAL
(Unit_Name
);
4131 elsif Is_Subprogram
(Unit_Name
)
4132 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
4133 N_Subprogram_Declaration
4134 and then Has_Pragma_Inline
(Unit_Name
)
4136 Set_Body_Needed_For_SAL
(Unit_Name
);
4138 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
4139 Check_Body_Needed_For_SAL
4140 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
4142 elsif Ekind
(Unit_Name
) = E_Package
4143 and then Entity_Needs_Body
(Unit_Name
)
4145 Set_Body_Needed_For_SAL
(Unit_Name
);
4147 elsif Ekind
(Unit_Name
) = E_Package_Body
4148 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
4150 Check_Body_Needed_For_SAL
4151 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
4153 end Check_Body_Needed_For_SAL
;
4155 --------------------
4156 -- Remove_Context --
4157 --------------------
4159 procedure Remove_Context
(N
: Node_Id
) is
4160 Lib_Unit
: constant Node_Id
:= Unit
(N
);
4163 -- If this is a child unit, first remove the parent units.
4165 if Is_Child_Spec
(Lib_Unit
) then
4166 Remove_Parents
(Lib_Unit
);
4169 Remove_Context_Clauses
(N
);
4172 ----------------------------
4173 -- Remove_Context_Clauses --
4174 ----------------------------
4176 procedure Remove_Context_Clauses
(N
: Node_Id
) is
4178 Unit_Name
: Entity_Id
;
4181 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
4182 -- limited-views first and regular-views later (to maintain the
4185 -- First Phase: Remove limited_with context clauses
4187 Item
:= First
(Context_Items
(N
));
4188 while Present
(Item
) loop
4190 -- We are interested only in with clauses which got installed
4193 if Nkind
(Item
) = N_With_Clause
4194 and then Limited_Present
(Item
)
4195 and then Limited_View_Installed
(Item
)
4197 Remove_Limited_With_Clause
(Item
);
4203 -- Second Phase: Loop through context items and undo regular
4204 -- with_clauses and use_clauses.
4206 Item
:= First
(Context_Items
(N
));
4207 while Present
(Item
) loop
4209 -- We are interested only in with clauses which got installed
4210 -- on entry, as indicated by their Context_Installed flag set
4212 if Nkind
(Item
) = N_With_Clause
4213 and then Limited_Present
(Item
)
4214 and then Limited_View_Installed
(Item
)
4218 elsif Nkind
(Item
) = N_With_Clause
4219 and then Context_Installed
(Item
)
4221 -- Remove items from one with'ed unit
4223 Unit_Name
:= Entity
(Name
(Item
));
4224 Remove_Unit_From_Visibility
(Unit_Name
);
4225 Set_Context_Installed
(Item
, False);
4227 elsif Nkind
(Item
) = N_Use_Package_Clause
then
4228 End_Use_Package
(Item
);
4230 elsif Nkind
(Item
) = N_Use_Type_Clause
then
4231 End_Use_Type
(Item
);
4233 elsif Nkind
(Item
) = N_With_Type_Clause
then
4234 Remove_With_Type_Clause
(Name
(Item
));
4239 end Remove_Context_Clauses
;
4241 --------------------------------
4242 -- Remove_Limited_With_Clause --
4243 --------------------------------
4245 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
4246 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
4247 P
: Entity_Id
:= Defining_Unit_Name
(Specification
(P_Unit
));
4248 Lim_Typ
: Entity_Id
;
4251 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
4253 -- Retrieve entity of Child package
4255 P
:= Defining_Identifier
(P
);
4258 if Debug_Flag_I
then
4259 Write_Str
("remove limited view of ");
4260 Write_Name
(Chars
(P
));
4261 Write_Str
(" from visibility");
4265 -- Remove all shadow entities from visibility. The first element of the
4266 -- limited view is a header (an E_Package entity) that is used to
4267 -- reference the first shadow entity in the private part of the package
4269 Lim_Typ
:= First_Entity
(Limited_View
(P
));
4271 while Present
(Lim_Typ
) loop
4273 Next_Entity
(Lim_Typ
);
4276 -- Indicate that the limited view of the package is not installed
4278 Set_From_With_Type
(P
, False);
4279 Set_Limited_View_Installed
(N
, False);
4281 -- If the exporting package has previously been analyzed, it
4282 -- has appeared in the closure already and should be left alone.
4283 -- Otherwise, remove package itself from visibility.
4285 if not Analyzed
(P_Unit
) then
4287 Set_First_Entity
(P
, Empty
);
4288 Set_Last_Entity
(P
, Empty
);
4289 Set_Ekind
(P
, E_Void
);
4290 Set_Scope
(P
, Empty
);
4291 Set_Is_Immediately_Visible
(P
, False);
4295 -- Reinstall visible entities (entities removed from visibility in
4296 -- Install_Limited_Withed to install the shadow entities).
4302 Ent
:= First_Entity
(P
);
4303 while Present
(Ent
) and then Ent
/= First_Private_Entity
(P
) loop
4305 -- Shadow entities have not been added to the list of
4306 -- entities associated to the package spec. Therefore we
4307 -- just have to re-chain all its visible entities.
4309 if not Is_Class_Wide_Type
(Ent
) then
4311 Set_Homonym
(Ent
, Current_Entity
(Ent
));
4312 Set_Current_Entity
(Ent
);
4314 if Debug_Flag_I
then
4315 Write_Str
(" (homonym) chain ");
4316 Write_Name
(Chars
(Ent
));
4325 end Remove_Limited_With_Clause
;
4327 --------------------
4328 -- Remove_Parents --
4329 --------------------
4331 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
4334 P_Spec
: Node_Id
:= Empty
;
4336 Vis
: constant Boolean :=
4337 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
4340 if Is_Child_Spec
(Lib_Unit
) then
4341 P_Spec
:= Parent_Spec
(Lib_Unit
);
4343 elsif Nkind
(Lib_Unit
) = N_Package_Body
4344 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
4346 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
4349 if Present
(P_Spec
) then
4352 P_Name
:= Get_Parent_Entity
(P
);
4353 Remove_Context_Clauses
(P_Spec
);
4354 End_Package_Scope
(P_Name
);
4355 Set_Is_Immediately_Visible
(P_Name
, Vis
);
4357 -- Remove from visibility the siblings as well, which are directly
4358 -- visible while the parent is in scope.
4360 E
:= First_Entity
(P_Name
);
4362 while Present
(E
) loop
4364 if Is_Child_Unit
(E
) then
4365 Set_Is_Immediately_Visible
(E
, False);
4371 Set_In_Package_Body
(P_Name
, False);
4373 -- This is the recursive call to remove the context of any
4374 -- higher level parent. This recursion ensures that all parents
4375 -- are removed in the reverse order of their installation.
4381 -----------------------------
4382 -- Remove_With_Type_Clause --
4383 -----------------------------
4385 procedure Remove_With_Type_Clause
(Name
: Node_Id
) is
4389 procedure Unchain
(E
: Entity_Id
);
4390 -- Remove entity from visibility list.
4392 procedure Unchain
(E
: Entity_Id
) is
4396 Prev
:= Current_Entity
(E
);
4398 -- Package entity may appear is several with_type_clauses, and
4399 -- may have been removed already.
4405 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
4408 while Present
(Prev
)
4409 and then Homonym
(Prev
) /= E
4411 Prev
:= Homonym
(Prev
);
4414 if Present
(Prev
) then
4415 Set_Homonym
(Prev
, Homonym
(E
));
4420 -- Start of Remove_With_Type_Clause
4423 if Nkind
(Name
) = N_Selected_Component
then
4424 Typ
:= Entity
(Selector_Name
(Name
));
4426 if No
(Typ
) then -- error in declaration.
4435 -- If the exporting package has been analyzed, it has appeared in the
4436 -- context already and should be left alone. Otherwise, remove from
4439 if not Analyzed
(Unit_Declaration_Node
(P
)) then
4442 Set_Is_Frozen
(Typ
, False);
4445 if Ekind
(Typ
) = E_Record_Type
then
4446 Set_From_With_Type
(Class_Wide_Type
(Typ
), False);
4447 Set_From_With_Type
(Typ
, False);
4450 Set_From_With_Type
(P
, False);
4452 -- If P is a child unit, remove parents as well.
4457 and then P
/= Standard_Standard
4459 Set_From_With_Type
(P
, False);
4461 if not Analyzed
(Unit_Declaration_Node
(P
)) then
4468 -- The back-end needs to know that an access type is imported, so it
4469 -- does not need elaboration and can appear in a mutually recursive
4470 -- record definition, so the imported flag on an access type is
4473 end Remove_With_Type_Clause
;
4475 ---------------------------------
4476 -- Remove_Unit_From_Visibility --
4477 ---------------------------------
4479 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
4480 P
: constant Entity_Id
:= Scope
(Unit_Name
);
4484 if Debug_Flag_I
then
4485 Write_Str
("remove unit ");
4486 Write_Name
(Chars
(Unit_Name
));
4487 Write_Str
(" from visibility");
4491 if P
/= Standard_Standard
then
4492 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
4495 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
4496 Set_Is_Immediately_Visible
(Unit_Name
, False);
4498 end Remove_Unit_From_Visibility
;
4504 procedure Unchain
(E
: Entity_Id
) is
4508 Prev
:= Current_Entity
(E
);
4514 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
4517 while Present
(Prev
)
4518 and then Homonym
(Prev
) /= E
4520 Prev
:= Homonym
(Prev
);
4523 if Present
(Prev
) then
4524 Set_Homonym
(Prev
, Homonym
(E
));
4528 if Debug_Flag_I
then
4529 Write_Str
(" (homonym) unchain ");
4530 Write_Name
(Chars
(E
));