1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
99 -- When a child unit appears in a context clause, the implicit withs on
100 -- parents are made explicit, and with clauses are inserted in the context
101 -- clause before the one for the child. If a parent in the with_clause
102 -- is a renaming, the implicit with_clause is on the renaming whose name
103 -- is mentioned in the with_clause, and not on the package it renames.
104 -- N is the compilation unit whose list of context items receives the
105 -- implicit with_clauses.
107 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
;
108 -- Get defining entity of parent unit of a child unit. In most cases this
109 -- is the defining entity of the unit, but for a child instance whose
110 -- parent needs a body for inlining, the instantiation node of the parent
111 -- has not yet been rewritten as a package declaration, and the entity has
112 -- to be retrieved from the Instance_Spec of the unit.
114 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
115 -- If the main unit is a child unit, implicit withs are also added for
116 -- all its ancestors.
118 function In_Chain
(E
: Entity_Id
) return Boolean;
119 -- Check that the shadow entity is not already in the homonym chain, for
120 -- example through a limited_with clause in a parent unit.
122 procedure Install_Context_Clauses
(N
: Node_Id
);
123 -- Subsidiary to Install_Context and Install_Parents. Process only with_
124 -- and use_clauses for current unit and its library unit if any.
126 procedure Install_Limited_Context_Clauses
(N
: Node_Id
);
127 -- Subsidiary to Install_Context. Process only limited with_clauses
128 -- for current unit. Implements Ada 2005 (AI-50217).
130 procedure Install_Limited_Withed_Unit
(N
: Node_Id
);
131 -- Place shadow entities for a limited_with package in the visibility
132 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
134 procedure Install_Withed_Unit
135 (With_Clause
: Node_Id
;
136 Private_With_OK
: Boolean := False);
137 -- If the unit is not a child unit, make unit immediately visible.
138 -- The caller ensures that the unit is not already currently installed.
139 -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
140 -- which is called when compiling the private part of a package, or
141 -- installing the private declarations of a parent unit.
143 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean);
144 -- This procedure establishes the context for the compilation of a child
145 -- unit. If Lib_Unit is a child library spec then the context of the parent
146 -- is installed, and the parent itself made immediately visible, so that
147 -- the child unit is processed in the declarative region of the parent.
148 -- Install_Parents makes a recursive call to itself to ensure that all
149 -- parents are loaded in the nested case. If Lib_Unit is a library body,
150 -- the only effect of Install_Parents is to install the private decls of
151 -- the parents, because the visible parent declarations will have been
152 -- installed as part of the context of the corresponding spec.
154 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
155 -- In the compilation of a child unit, a child of any of the ancestor
156 -- units is directly visible if it is visible, because the parent is in
157 -- an enclosing scope. Iterate over context to find child units of U_Name
158 -- or of some ancestor of it.
160 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
161 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
162 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
163 -- a library spec that has a parent. If the call to Is_Child_Spec returns
164 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
165 -- compilation unit for the parent spec.
167 -- Lib_Unit can also be a subprogram body that acts as its own spec. If
168 -- the Parent_Spec is non-empty, this is also a child unit.
170 procedure Remove_With_Type_Clause
(Name
: Node_Id
);
171 -- Remove imported type and its enclosing package from visibility, and
172 -- remove attributes of imported type so they don't interfere with its
173 -- analysis (should it appear otherwise in the context).
175 procedure Remove_Context_Clauses
(N
: Node_Id
);
176 -- Subsidiary of previous one. Remove use_ and with_clauses
178 procedure Remove_Limited_With_Clause
(N
: Node_Id
);
179 -- Remove from visibility the shadow entities introduced for a package
180 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
182 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
183 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
184 -- contexts established by the corresponding call to Install_Parents are
185 -- removed. Remove_Parents contains a recursive call to itself to ensure
186 -- that all parents are removed in the nested case.
188 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
189 -- Reset all visibility flags on unit after compiling it, either as a
190 -- main unit or as a unit in the context.
192 procedure Unchain
(E
: Entity_Id
);
193 -- Remove single entity from visibility list
195 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
196 -- Common processing for all stubs (subprograms, tasks, packages, and
197 -- protected cases). N is the stub to be analyzed. Once the subunit
198 -- name is established, load and analyze. Nam is the non-overloadable
199 -- entity for which the proper body provides a completion. Subprogram
200 -- stubs are handled differently because they can be declarations.
202 --------------------------
203 -- Limited_With_Clauses --
204 --------------------------
206 -- Limited_With clauses are the mechanism chosen for Ada05 to support
207 -- mutually recursive types declared in different units. A limited_with
208 -- clause that names package P in the context of unit U makes the types
209 -- declared in the visible part of P available within U, but with the
210 -- restriction that these types can only be used as incomplete types.
211 -- The limited_with clause does not impose a semantic dependence on P,
212 -- and it is possible for two packages to have limited_with_clauses on
213 -- each other without creating an elaboration circularity.
215 -- To support this feature, the analysis of a limited_with clause must
216 -- create an abbreviated view of the package, without performing any
217 -- semantic analysis on it. This "package abstract" contains shadow
218 -- types that are in one-one correspondence with the real types in the
219 -- package, and that have the properties of incomplete types.
221 -- The implementation creates two element lists: one to chain the shadow
222 -- entities, and one to chain the corresponding type entities in the tree
223 -- of the package. Links between corresponding entities in both chains
224 -- allow the compiler to select the proper view of a given type, depending
225 -- on the context. Note that in contrast with the handling of private
226 -- types, the limited view and the non-limited view of a type are treated
227 -- as separate entities, and no entity exchange needs to take place, which
228 -- makes the implementation must simpler than could be feared.
230 ------------------------------
231 -- Analyze_Compilation_Unit --
232 ------------------------------
234 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
235 Unit_Node
: constant Node_Id
:= Unit
(N
);
236 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
238 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
239 Par_Spec_Name
: Unit_Name_Type
;
240 Unum
: Unit_Number_Type
;
242 procedure Check_Redundant_Withs
243 (Context_Items
: List_Id
;
244 Spec_Context_Items
: List_Id
:= No_List
);
245 -- Determine whether the context list of a compilation unit contains
246 -- redundant with clauses. When checking body clauses against spec
247 -- clauses, set Context_Items to the context list of the body and
248 -- Spec_Context_Items to that of the spec. Parent packages are not
249 -- examined for documentation purposes.
251 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
252 -- Generate cross-reference information for the parents of child units.
253 -- N is a defining_program_unit_name, and P_Id is the immediate parent.
255 ---------------------------
256 -- Check_Redundant_Withs --
257 ---------------------------
259 procedure Check_Redundant_Withs
260 (Context_Items
: List_Id
;
261 Spec_Context_Items
: List_Id
:= No_List
)
265 procedure Process_Body_Clauses
266 (Context_List
: List_Id
;
268 Used
: in out Boolean;
269 Used_Type_Or_Elab
: in out Boolean);
270 -- Examine the context clauses of a package body, trying to match
271 -- the name entity of Clause with any list element. If the match
272 -- occurs on a use package clause, set Used to True, for a use
273 -- type clause, pragma Elaborate or pragma Elaborate_All, set
274 -- Used_Type_Or_Elab to True.
276 procedure Process_Spec_Clauses
277 (Context_List
: List_Id
;
279 Used
: in out Boolean;
280 Withed
: in out Boolean;
281 Exit_On_Self
: Boolean := False);
282 -- Examine the context clauses of a package spec, trying to match
283 -- the name entity of Clause with any list element. If the match
284 -- occurs on a use package clause, set Used to True, for a with
285 -- package clause other than Clause, set Withed to True. Limited
286 -- with clauses, implicitly generated with clauses and withs
287 -- having pragmas Elaborate or Elaborate_All applied to them are
288 -- skipped. Exit_On_Self is used to control the search loop and
289 -- force an exit whenever Clause sees itself in the search.
291 --------------------------
292 -- Process_Body_Clauses --
293 --------------------------
295 procedure Process_Body_Clauses
296 (Context_List
: List_Id
;
298 Used
: in out Boolean;
299 Used_Type_Or_Elab
: in out Boolean)
301 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
309 Used_Type_Or_Elab
:= False;
311 Cont_Item
:= First
(Context_List
);
312 while Present
(Cont_Item
) loop
314 -- Package use clause
316 if Nkind
(Cont_Item
) = N_Use_Package_Clause
319 Use_Item
:= First
(Names
(Cont_Item
));
320 while Present
(Use_Item
) and then not Used
loop
321 if Entity
(Use_Item
) = Nam_Ent
then
330 elsif Nkind
(Cont_Item
) = N_Use_Type_Clause
331 and then not Used_Type_Or_Elab
333 Subt_Mark
:= First
(Subtype_Marks
(Cont_Item
));
334 while Present
(Subt_Mark
)
335 and then not Used_Type_Or_Elab
337 if Entity
(Prefix
(Subt_Mark
)) = Nam_Ent
then
338 Used_Type_Or_Elab
:= True;
344 -- Pragma Elaborate or Elaborate_All
346 elsif Nkind
(Cont_Item
) = N_Pragma
348 (Chars
(Cont_Item
) = Name_Elaborate
350 Chars
(Cont_Item
) = Name_Elaborate_All
)
351 and then not Used_Type_Or_Elab
354 First
(Pragma_Argument_Associations
(Cont_Item
));
355 while Present
(Prag_Unit
)
356 and then not Used_Type_Or_Elab
358 if Entity
(Expression
(Prag_Unit
)) = Nam_Ent
then
359 Used_Type_Or_Elab
:= True;
368 end Process_Body_Clauses
;
370 --------------------------
371 -- Process_Spec_Clauses --
372 --------------------------
374 procedure Process_Spec_Clauses
375 (Context_List
: List_Id
;
377 Used
: in out Boolean;
378 Withed
: in out Boolean;
379 Exit_On_Self
: Boolean := False)
381 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
389 Cont_Item
:= First
(Context_List
);
390 while Present
(Cont_Item
) loop
392 -- Stop the search since the context items after Cont_Item
393 -- have already been examined in a previous iteration of
394 -- the reverse loop in Check_Redundant_Withs.
397 and Cont_Item
= Clause
402 -- Package use clause
404 if Nkind
(Cont_Item
) = N_Use_Package_Clause
407 Use_Item
:= First
(Names
(Cont_Item
));
408 while Present
(Use_Item
) and then not Used
loop
409 if Entity
(Use_Item
) = Nam_Ent
then
416 -- Package with clause. Avoid processing self, implicitly
417 -- generated with clauses or limited with clauses. Note
418 -- that we examine with clauses having pragmas Elaborate
419 -- or Elaborate_All applied to them due to cases such as:
423 -- pragma Elaborate (Pack);
425 -- In this case, the second with clause is redundant since
426 -- the pragma applies only to the first "with Pack;".
428 elsif Nkind
(Cont_Item
) = N_With_Clause
429 and then not Implicit_With
(Cont_Item
)
430 and then not Limited_Present
(Cont_Item
)
431 and then Cont_Item
/= Clause
432 and then Entity
(Name
(Cont_Item
)) = Nam_Ent
439 end Process_Spec_Clauses
;
441 -- Start of processing for Check_Redundant_Withs
444 Clause
:= Last
(Context_Items
);
445 while Present
(Clause
) loop
447 -- Avoid checking implicitly generated with clauses, limited
448 -- with clauses or withs that have pragma Elaborate or
449 -- Elaborate_All apllied.
451 if Nkind
(Clause
) = N_With_Clause
452 and then not Implicit_With
(Clause
)
453 and then not Limited_Present
(Clause
)
454 and then not Elaborate_Present
(Clause
)
456 -- Package body-to-spec check
458 if Present
(Spec_Context_Items
) then
460 Used_In_Body
: Boolean := False;
461 Used_In_Spec
: Boolean := False;
462 Used_Type_Or_Elab
: Boolean := False;
463 Withed_In_Spec
: Boolean := False;
467 (Context_List
=> Spec_Context_Items
,
469 Used
=> Used_In_Spec
,
470 Withed
=> Withed_In_Spec
);
473 (Context_List
=> Context_Items
,
475 Used
=> Used_In_Body
,
476 Used_Type_Or_Elab
=> Used_Type_Or_Elab
);
478 -- "Type Elab" refers to the presence of either a use
479 -- type clause, pragmas Elaborate or Elaborate_All.
481 -- +---------------+---------------------------+------+
482 -- | Spec | Body | Warn |
483 -- +--------+------+--------+------+-----------+------+
484 -- | Withed | Used | Withed | Used | Type Elab | |
485 -- | X | | X | | | X |
486 -- | X | | X | X | | |
487 -- | X | | X | | X | |
488 -- | X | | X | X | X | |
489 -- | X | X | X | | | X |
490 -- | X | X | X | | X | |
491 -- | X | X | X | X | | X |
492 -- | X | X | X | X | X | |
493 -- +--------+------+--------+------+-----------+------+
496 and then not Used_Type_Or_Elab
)
499 and then not Used_In_Body
)
503 Error_Msg_N
("?redundant with clause in body", Clause
);
506 Used_In_Body
:= False;
507 Used_In_Spec
:= False;
508 Used_Type_Or_Elab
:= False;
509 Withed_In_Spec
:= False;
512 -- Standalone package spec or body check
516 Dont_Care
: Boolean := False;
517 Withed
: Boolean := False;
520 -- The mechanism for examining the context clauses of a
521 -- package spec can be applied to package body clauses.
524 (Context_List
=> Context_Items
,
528 Exit_On_Self
=> True);
531 Error_Msg_N
("?redundant with clause", Clause
);
539 end Check_Redundant_Withs
;
541 --------------------------------
542 -- Generate_Parent_References --
543 --------------------------------
545 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
547 P_Name
: Entity_Id
:= P_Id
;
550 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
552 if Nkind
(Pref
) = N_Expanded_Name
then
554 -- Done already, if the unit has been compiled indirectly as
555 -- part of the closure of its context because of inlining.
560 while Nkind
(Pref
) = N_Selected_Component
loop
561 Change_Selected_Component_To_Expanded_Name
(Pref
);
562 Set_Entity
(Pref
, P_Name
);
563 Set_Etype
(Pref
, Etype
(P_Name
));
564 Generate_Reference
(P_Name
, Pref
, 'r');
565 Pref
:= Prefix
(Pref
);
566 P_Name
:= Scope
(P_Name
);
569 -- The guard here on P_Name is to handle the error condition where
570 -- the parent unit is missing because the file was not found.
572 if Present
(P_Name
) then
573 Set_Entity
(Pref
, P_Name
);
574 Set_Etype
(Pref
, Etype
(P_Name
));
575 Generate_Reference
(P_Name
, Pref
, 'r');
576 Style
.Check_Identifier
(Pref
, P_Name
);
578 end Generate_Parent_References
;
580 -- Start of processing for Analyze_Compilation_Unit
583 Process_Compilation_Unit_Pragmas
(N
);
585 -- If the unit is a subunit whose parent has not been analyzed (which
586 -- indicates that the main unit is a subunit, either the current one or
587 -- one of its descendents) then the subunit is compiled as part of the
588 -- analysis of the parent, which we proceed to do. Basically this gets
589 -- handled from the top down and we don't want to do anything at this
590 -- level (i.e. this subunit will be handled on the way down from the
591 -- parent), so at this level we immediately return. If the subunit
592 -- ends up not analyzed, it means that the parent did not contain a
593 -- stub for it, or that there errors were dectected in some ancestor.
595 if Nkind
(Unit_Node
) = N_Subunit
596 and then not Analyzed
(Lib_Unit
)
598 Semantics
(Lib_Unit
);
600 if not Analyzed
(Proper_Body
(Unit_Node
)) then
601 if Serious_Errors_Detected
> 0 then
602 Error_Msg_N
("subunit not analyzed (errors in parent unit)", N
);
604 Error_Msg_N
("missing stub for subunit", N
);
611 -- Analyze context (this will call Sem recursively for with'ed units)
615 -- If the unit is a package body, the spec is already loaded and must
616 -- be analyzed first, before we analyze the body.
618 if Nkind
(Unit_Node
) = N_Package_Body
then
620 -- If no Lib_Unit, then there was a serious previous error, so
621 -- just ignore the entire analysis effort
623 if No
(Lib_Unit
) then
627 Semantics
(Lib_Unit
);
628 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
630 -- Verify that the library unit is a package declaration
632 if Nkind
(Unit
(Lib_Unit
)) /= N_Package_Declaration
634 Nkind
(Unit
(Lib_Unit
)) /= N_Generic_Package_Declaration
637 ("no legal package declaration for package body", N
);
640 -- Otherwise, the entity in the declaration is visible. Update
641 -- the version to reflect dependence of this body on the spec.
644 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
645 Set_Is_Immediately_Visible
(Spec_Id
, True);
646 Version_Update
(N
, Lib_Unit
);
648 if Nkind
(Defining_Unit_Name
(Unit_Node
))
649 = N_Defining_Program_Unit_Name
651 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
656 -- If the unit is a subprogram body, then we similarly need to analyze
657 -- its spec. However, things are a little simpler in this case, because
658 -- here, this analysis is done only for error checking and consistency
659 -- purposes, so there's nothing else to be done.
661 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
662 if Acts_As_Spec
(N
) then
664 -- If the subprogram body is a child unit, we must create a
665 -- declaration for it, in order to properly load the parent(s).
666 -- After this, the original unit does not acts as a spec, because
667 -- there is an explicit one. If this unit appears in a context
668 -- clause, then an implicit with on the parent will be added when
669 -- installing the context. If this is the main unit, there is no
670 -- Unit_Table entry for the declaration, (It has the unit number
671 -- of the main unit) and code generation is unaffected.
673 Unum
:= Get_Cunit_Unit_Number
(N
);
674 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
676 if Par_Spec_Name
/= No_Name
then
679 (Load_Name
=> Par_Spec_Name
,
684 if Unum
/= No_Unit
then
686 -- Build subprogram declaration and attach parent unit to it
687 -- This subprogram declaration does not come from source,
688 -- Nevertheless the backend must generate debugging info for
689 -- it, and this must be indicated explicitly.
692 Loc
: constant Source_Ptr
:= Sloc
(N
);
693 SCS
: constant Boolean :=
694 Get_Comes_From_Source_Default
;
697 Set_Comes_From_Source_Default
(False);
699 Make_Compilation_Unit
(Loc
,
700 Context_Items
=> New_Copy_List
(Context_Items
(N
)),
702 Make_Subprogram_Declaration
(Sloc
(N
),
705 (Specification
(Unit_Node
))),
707 Make_Compilation_Unit_Aux
(Loc
));
709 Set_Library_Unit
(N
, Lib_Unit
);
710 Set_Parent_Spec
(Unit
(Lib_Unit
), Cunit
(Unum
));
711 Semantics
(Lib_Unit
);
712 Set_Acts_As_Spec
(N
, False);
713 Set_Needs_Debug_Info
(Defining_Entity
(Unit
(Lib_Unit
)));
714 Set_Comes_From_Source_Default
(SCS
);
719 -- Here for subprogram with separate declaration
722 Semantics
(Lib_Unit
);
723 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
724 Version_Update
(N
, Lib_Unit
);
727 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
728 N_Defining_Program_Unit_Name
730 Generate_Parent_References
(
731 Specification
(Unit_Node
),
732 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
736 -- If it is a child unit, the parent must be elaborated first
737 -- and we update version, since we are dependent on our parent.
739 if Is_Child_Spec
(Unit_Node
) then
741 -- The analysis of the parent is done with style checks off
744 Save_Style_Check
: constant Boolean := Style_Check
;
745 Save_C_Restrict
: constant Save_Cunit_Boolean_Restrictions
:=
746 Cunit_Boolean_Restrictions_Save
;
749 if not GNAT_Mode
then
750 Style_Check
:= False;
753 Semantics
(Parent_Spec
(Unit_Node
));
754 Version_Update
(N
, Parent_Spec
(Unit_Node
));
755 Style_Check
:= Save_Style_Check
;
756 Cunit_Boolean_Restrictions_Restore
(Save_C_Restrict
);
760 -- With the analysis done, install the context. Note that we can't
761 -- install the context from the with clauses as we analyze them,
762 -- because each with clause must be analyzed in a clean visibility
763 -- context, so we have to wait and install them all at once.
767 if Is_Child_Spec
(Unit_Node
) then
769 -- Set the entities of all parents in the program_unit_name
771 Generate_Parent_References
(
772 Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
775 -- All components of the context: with-clauses, library unit, ancestors
776 -- if any, (and their context) are analyzed and installed. Now analyze
777 -- the unit itself, which is either a package, subprogram spec or body.
781 if Warn_On_Redundant_Constructs
then
782 Check_Redundant_Withs
(Context_Items
(N
));
784 if Nkind
(Unit_Node
) = N_Package_Body
then
785 Check_Redundant_Withs
786 (Context_Items
=> Context_Items
(N
),
787 Spec_Context_Items
=> Context_Items
(Lib_Unit
));
791 -- The above call might have made Unit_Node an N_Subprogram_Body
792 -- from something else, so propagate any Acts_As_Spec flag.
794 if Nkind
(Unit_Node
) = N_Subprogram_Body
795 and then Acts_As_Spec
(Unit_Node
)
797 Set_Acts_As_Spec
(N
);
800 -- Register predefined units in Rtsfind
803 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Sloc
(N
));
805 if Is_Predefined_File_Name
(Unit_File_Name
(Unum
)) then
806 Set_RTU_Loaded
(Unit_Node
);
810 -- Treat compilation unit pragmas that appear after the library unit
812 if Present
(Pragmas_After
(Aux_Decls_Node
(N
))) then
814 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
817 while Present
(Prag_Node
) loop
824 -- Generate distribution stubs if requested and no error
827 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
829 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
830 and then not Fatal_Error
(Main_Unit
)
832 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
834 -- Regular RCI package
836 Add_Stub_Constructs
(N
);
838 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
839 and then Is_Shared_Passive
(Defining_Entity
840 (Specification
(Unit_Node
))))
841 or else (Nkind
(Unit_Node
) = N_Package_Body
843 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
845 -- Shared passive package
847 Add_Stub_Constructs
(N
);
849 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
851 Is_Remote_Call_Interface
852 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
854 -- Instantiation of a RCI generic package
856 Add_Stub_Constructs
(N
);
861 if Nkind
(Unit_Node
) = N_Package_Declaration
862 or else Nkind
(Unit_Node
) in N_Generic_Declaration
863 or else Nkind
(Unit_Node
) = N_Package_Renaming_Declaration
864 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
866 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
868 -- If the unit is an instantiation whose body will be elaborated
869 -- for inlining purposes, use the the proper entity of the instance.
871 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
872 and then not Error_Posted
(Unit_Node
)
874 Remove_Unit_From_Visibility
875 (Defining_Entity
(Instance_Spec
(Unit_Node
)));
877 elsif Nkind
(Unit_Node
) = N_Package_Body
878 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
879 and then not Acts_As_Spec
(Unit_Node
))
881 -- Bodies that are not the main unit are compiled if they
882 -- are generic or contain generic or inlined units. Their
883 -- analysis brings in the context of the corresponding spec
884 -- (unit declaration) which must be removed as well, to
885 -- return the compilation environment to its proper state.
887 Remove_Context
(Lib_Unit
);
888 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
891 -- Last step is to deinstall the context we just installed
892 -- as well as the unit just compiled.
896 -- If this is the main unit and we are generating code, we must
897 -- check that all generic units in the context have a body if they
898 -- need it, even if they have not been instantiated. In the absence
899 -- of .ali files for generic units, we must force the load of the body,
900 -- just to produce the proper error if the body is absent. We skip this
901 -- verification if the main unit itself is generic.
903 if Get_Cunit_Unit_Number
(N
) = Main_Unit
904 and then Operating_Mode
= Generate_Code
905 and then Expander_Active
907 -- Check whether the source for the body of the unit must be
908 -- included in a standalone library.
910 Check_Body_Needed_For_SAL
(Cunit_Entity
(Main_Unit
));
912 -- Indicate that the main unit is now analyzed, to catch possible
913 -- circularities between it and generic bodies. Remove main unit
914 -- from visibility. This might seem superfluous, but the main unit
915 -- must not be visible in the generic body expansions that follow.
917 Set_Analyzed
(N
, True);
918 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
923 Un
: Unit_Number_Type
;
925 Save_Style_Check
: constant Boolean := Style_Check
;
926 Save_C_Restrict
: constant Save_Cunit_Boolean_Restrictions
:=
927 Cunit_Boolean_Restrictions_Save
;
930 Item
:= First
(Context_Items
(N
));
931 while Present
(Item
) loop
933 -- Ada 2005 (AI-50217): Do not consider limited-withed units
935 if Nkind
(Item
) = N_With_Clause
936 and then not Implicit_With
(Item
)
937 and then not Limited_Present
(Item
)
939 Nam
:= Entity
(Name
(Item
));
941 if (Is_Generic_Subprogram
(Nam
)
942 and then not Is_Intrinsic_Subprogram
(Nam
))
943 or else (Ekind
(Nam
) = E_Generic_Package
944 and then Unit_Requires_Body
(Nam
))
946 Style_Check
:= False;
948 if Present
(Renamed_Object
(Nam
)) then
951 (Load_Name
=> Get_Body_Name
953 (Unit_Declaration_Node
954 (Renamed_Object
(Nam
)))),
962 (Load_Name
=> Get_Body_Name
963 (Get_Unit_Name
(Item
)),
972 ("body of generic unit& not found", Item
, Nam
);
975 elsif not Analyzed
(Cunit
(Un
))
976 and then Un
/= Main_Unit
977 and then not Fatal_Error
(Un
)
979 Style_Check
:= False;
980 Semantics
(Cunit
(Un
));
988 Style_Check
:= Save_Style_Check
;
989 Cunit_Boolean_Restrictions_Restore
(Save_C_Restrict
);
993 -- Deal with creating elaboration Boolean if needed. We create an
994 -- elaboration boolean only for units that come from source since
995 -- units manufactured by the compiler never need elab checks.
997 if Comes_From_Source
(N
)
999 (Nkind
(Unit
(N
)) = N_Package_Declaration
or else
1000 Nkind
(Unit
(N
)) = N_Generic_Package_Declaration
or else
1001 Nkind
(Unit
(N
)) = N_Subprogram_Declaration
or else
1002 Nkind
(Unit
(N
)) = N_Generic_Subprogram_Declaration
)
1005 Loc
: constant Source_Ptr
:= Sloc
(N
);
1006 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
1009 Spec_Id
:= Defining_Entity
(Unit
(N
));
1010 Generate_Definition
(Spec_Id
);
1012 -- See if an elaboration entity is required for possible
1013 -- access before elaboration checking. Note that we must
1014 -- allow for this even if -gnatE is not set, since a client
1015 -- may be compiled in -gnatE mode and reference the entity.
1017 -- Case of units which do not require elaboration checks
1020 -- Pure units do not need checks
1024 -- Preelaborated units do not need checks
1026 or else Is_Preelaborated
(Spec_Id
)
1028 -- No checks needed if pagma Elaborate_Body present
1030 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
1032 -- No checks needed if unit does not require a body
1034 or else not Unit_Requires_Body
(Spec_Id
)
1036 -- No checks needed for predefined files
1038 or else Is_Predefined_File_Name
(Unit_File_Name
(Unum
))
1040 -- No checks required if no separate spec
1042 or else Acts_As_Spec
(N
)
1044 -- This is a case where we only need the entity for
1045 -- checking to prevent multiple elaboration checks.
1047 Set_Elaboration_Entity_Required
(Spec_Id
, False);
1049 -- Case of elaboration entity is required for access before
1050 -- elaboration checking (so certainly we must build it!)
1053 Set_Elaboration_Entity_Required
(Spec_Id
, True);
1056 Build_Elaboration_Entity
(N
, Spec_Id
);
1060 -- Finally, freeze the compilation unit entity. This for sure is needed
1061 -- because of some warnings that can be output (see Freeze_Subprogram),
1062 -- but may in general be required. If freezing actions result, place
1063 -- them in the compilation unit actions list, and analyze them.
1066 Loc
: constant Source_Ptr
:= Sloc
(N
);
1067 L
: constant List_Id
:=
1068 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), Loc
);
1071 while Is_Non_Empty_List
(L
) loop
1072 Insert_Library_Level_Action
(Remove_Head
(L
));
1078 if Nkind
(Unit_Node
) = N_Package_Declaration
1079 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
1080 and then Expander_Active
1083 Save_Style_Check
: constant Boolean := Style_Check
;
1084 Save_Warning
: constant Warning_Mode_Type
:= Warning_Mode
;
1085 Options
: Style_Check_Options
;
1088 Save_Style_Check_Options
(Options
);
1089 Reset_Style_Check_Options
;
1090 Opt
.Warning_Mode
:= Suppress
;
1091 Check_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
1093 Reset_Style_Check_Options
;
1094 Set_Style_Check_Options
(Options
);
1095 Style_Check
:= Save_Style_Check
;
1096 Warning_Mode
:= Save_Warning
;
1099 end Analyze_Compilation_Unit
;
1101 ---------------------
1102 -- Analyze_Context --
1103 ---------------------
1105 procedure Analyze_Context
(N
: Node_Id
) is
1106 Ukind
: constant Node_Kind
:= Nkind
(Unit
(N
));
1110 -- First process all configuration pragmas at the start of the context
1111 -- items. Strictly these are not part of the context clause, but that
1112 -- is where the parser puts them. In any case for sure we must analyze
1113 -- these before analyzing the actual context items, since they can have
1114 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1115 -- be with'ed as a result of changing categorizations in Ada 2005).
1117 Item
:= First
(Context_Items
(N
));
1118 while Present
(Item
)
1119 and then Nkind
(Item
) = N_Pragma
1120 and then Chars
(Item
) in Configuration_Pragma_Names
1126 -- Loop through actual context items. This is done in two passes:
1128 -- a) The first pass analyzes non-limited with-clauses and also any
1129 -- configuration pragmas (we need to get the latter analyzed right
1130 -- away, since they can affect processing of subsequent items.
1132 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1134 while Present
(Item
) loop
1136 -- For with clause, analyze the with clause, and then update
1137 -- the version, since we are dependent on a unit that we with.
1139 if Nkind
(Item
) = N_With_Clause
1140 and then not Limited_Present
(Item
)
1142 -- Skip analyzing with clause if no unit, nothing to do (this
1143 -- happens for a with that references a non-existant unit)
1145 if Present
(Library_Unit
(Item
)) then
1149 if not Implicit_With
(Item
) then
1150 Version_Update
(N
, Library_Unit
(Item
));
1153 -- Skip pragmas. Configuration pragmas at the start were handled in
1154 -- the loop above, and remaining pragmas are not processed until we
1155 -- actually install the context (see Install_Context). We delay the
1156 -- analysis of these pragmas to make sure that we have installed all
1157 -- the implicit with's on parent units.
1159 -- Skip use clauses at this stage, since we don't want to do any
1160 -- installing of potentially use visible entities until we we
1161 -- actually install the complete context (in Install_Context).
1162 -- Otherwise things can get installed in the wrong context.
1171 -- Second pass: examine all limited_with clauses. All other context
1172 -- items are ignored in this pass.
1174 Item
:= First
(Context_Items
(N
));
1175 while Present
(Item
) loop
1176 if Nkind
(Item
) = N_With_Clause
1177 and then Limited_Present
(Item
)
1179 -- No need to check errors on implicitly generated limited-with
1182 if not Implicit_With
(Item
) then
1184 -- Check compilation unit containing the limited-with clause
1186 if Ukind
/= N_Package_Declaration
1187 and then Ukind
/= N_Subprogram_Declaration
1188 and then Ukind
/= N_Package_Renaming_Declaration
1189 and then Ukind
/= N_Subprogram_Renaming_Declaration
1190 and then Ukind
not in N_Generic_Declaration
1191 and then Ukind
not in N_Generic_Renaming_Declaration
1192 and then Ukind
not in N_Generic_Instantiation
1194 Error_Msg_N
("limited with_clause not allowed here", Item
);
1196 -- Check wrong use of a limited with clause applied to the
1197 -- compilation unit containing the limited-with clause.
1199 -- limited with P.Q;
1200 -- package P.Q is ...
1202 elsif Unit
(Library_Unit
(Item
)) = Unit
(N
) then
1203 Error_Msg_N
("wrong use of limited-with clause", Item
);
1205 -- Check wrong use of limited-with clause applied to some
1206 -- immediate ancestor.
1208 elsif Is_Child_Spec
(Unit
(N
)) then
1210 Lib_U
: constant Entity_Id
:= Unit
(Library_Unit
(Item
));
1214 P
:= Parent_Spec
(Unit
(N
));
1216 if Unit
(P
) = Lib_U
then
1217 Error_Msg_N
("limited with_clause of immediate "
1218 & "ancestor not allowed", Item
);
1222 exit when not Is_Child_Spec
(Unit
(P
));
1223 P
:= Parent_Spec
(Unit
(P
));
1228 -- Check if the limited-withed unit is already visible through
1229 -- some context clause of the current compilation unit or some
1230 -- ancestor of the current compilation unit.
1233 Lim_Unit_Name
: constant Node_Id
:= Name
(Item
);
1234 Comp_Unit
: Node_Id
;
1236 Unit_Name
: Node_Id
;
1241 It
:= First
(Context_Items
(Comp_Unit
));
1242 while Present
(It
) loop
1244 and then Nkind
(It
) = N_With_Clause
1245 and then not Limited_Present
(It
)
1247 (Nkind
(Unit
(Library_Unit
(It
)))
1248 = N_Package_Declaration
1250 Nkind
(Unit
(Library_Unit
(It
)))
1251 = N_Package_Renaming_Declaration
)
1253 if Nkind
(Unit
(Library_Unit
(It
)))
1254 = N_Package_Declaration
1256 Unit_Name
:= Name
(It
);
1258 Unit_Name
:= Name
(Unit
(Library_Unit
(It
)));
1261 -- Check if the named package (or some ancestor)
1262 -- leaves visible the full-view of the unit given
1263 -- in the limited-with clause
1266 if Designate_Same_Unit
(Lim_Unit_Name
,
1269 Error_Msg_Sloc
:= Sloc
(It
);
1271 ("unlimited view visible through the"
1272 & " context clause found #",
1275 ("simultaneous visibility of the limited"
1276 & " and unlimited views not allowed"
1280 elsif Nkind
(Unit_Name
) = N_Identifier
then
1284 Unit_Name
:= Prefix
(Unit_Name
);
1291 exit when not Is_Child_Spec
(Unit
(Comp_Unit
));
1293 Comp_Unit
:= Parent_Spec
(Unit
(Comp_Unit
));
1298 -- Skip analyzing with clause if no unit, see above
1300 if Present
(Library_Unit
(Item
)) then
1304 -- A limited_with does not impose an elaboration order, but
1305 -- there is a semantic dependency for recompilation purposes.
1307 if not Implicit_With
(Item
) then
1308 Version_Update
(N
, Library_Unit
(Item
));
1311 -- Pragmas and use clauses and with clauses other than limited
1312 -- with's are ignored in this pass through the context items.
1320 end Analyze_Context
;
1322 -------------------------------
1323 -- Analyze_Package_Body_Stub --
1324 -------------------------------
1326 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
1327 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1331 -- The package declaration must be in the current declarative part
1333 Check_Stub_Level
(N
);
1334 Nam
:= Current_Entity_In_Scope
(Id
);
1336 if No
(Nam
) or else not Is_Package_Or_Generic_Package
(Nam
) then
1337 Error_Msg_N
("missing specification for package stub", N
);
1339 elsif Has_Completion
(Nam
)
1340 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
1342 Error_Msg_N
("duplicate or redundant stub for package", N
);
1345 -- Indicate that the body of the package exists. If we are doing
1346 -- only semantic analysis, the stub stands for the body. If we are
1347 -- generating code, the existence of the body will be confirmed
1348 -- when we load the proper body.
1350 Set_Has_Completion
(Nam
);
1351 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1352 Generate_Reference
(Nam
, Id
, 'b');
1353 Analyze_Proper_Body
(N
, Nam
);
1355 end Analyze_Package_Body_Stub
;
1357 -------------------------
1358 -- Analyze_Proper_Body --
1359 -------------------------
1361 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
1362 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
1363 Unum
: Unit_Number_Type
;
1365 procedure Optional_Subunit
;
1366 -- This procedure is called when the main unit is a stub, or when we
1367 -- are not generating code. In such a case, we analyze the subunit if
1368 -- present, which is user-friendly and in fact required for ASIS, but
1369 -- we don't complain if the subunit is missing.
1371 ----------------------
1372 -- Optional_Subunit --
1373 ----------------------
1375 procedure Optional_Subunit
is
1376 Comp_Unit
: Node_Id
;
1379 -- Try to load subunit, but ignore any errors that occur during
1380 -- the loading of the subunit, by using the special feature in
1381 -- Errout to ignore all errors. Note that Fatal_Error will still
1382 -- be set, so we will be able to check for this case below.
1384 if not ASIS_Mode
then
1385 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
1390 (Load_Name
=> Subunit_Name
,
1395 if not ASIS_Mode
then
1396 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
1399 -- All done if we successfully loaded the subunit
1402 and then (not Fatal_Error
(Unum
) or else Try_Semantics
)
1404 Comp_Unit
:= Cunit
(Unum
);
1406 -- If the file was empty or seriously mangled, the unit
1407 -- itself may be missing.
1409 if No
(Unit
(Comp_Unit
)) then
1411 ("subunit does not contain expected proper body", N
);
1413 elsif Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1415 ("expected SEPARATE subunit, found child unit",
1416 Cunit_Entity
(Unum
));
1418 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1419 Analyze_Subunit
(Comp_Unit
);
1420 Set_Library_Unit
(N
, Comp_Unit
);
1423 elsif Unum
= No_Unit
1424 and then Present
(Nam
)
1426 if Is_Protected_Type
(Nam
) then
1427 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
1429 Set_Corresponding_Body
(
1430 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1433 end Optional_Subunit
;
1435 -- Start of processing for Analyze_Proper_Body
1438 -- If the subunit is already loaded, it means that the main unit
1439 -- is a subunit, and that the current unit is one of its parents
1440 -- which was being analyzed to provide the needed context for the
1441 -- analysis of the subunit. In this case we analyze the subunit and
1442 -- continue with the parent, without looking a subsequent subunits.
1444 if Is_Loaded
(Subunit_Name
) then
1446 -- If the proper body is already linked to the stub node,
1447 -- the stub is in a generic unit and just needs analyzing.
1449 if Present
(Library_Unit
(N
)) then
1450 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1451 Analyze_Subunit
(Library_Unit
(N
));
1453 -- Otherwise we must load the subunit and link to it
1456 -- Load the subunit, this must work, since we originally
1457 -- loaded the subunit earlier on. So this will not really
1458 -- load it, just give access to it.
1462 (Load_Name
=> Subunit_Name
,
1467 -- And analyze the subunit in the parent context (note that we
1468 -- do not call Semantics, since that would remove the parent
1469 -- context). Because of this, we have to manually reset the
1470 -- compiler state to Analyzing since it got destroyed by Load.
1472 if Unum
/= No_Unit
then
1473 Compiler_State
:= Analyzing
;
1475 -- Check that the proper body is a subunit and not a child
1476 -- unit. If the unit was previously loaded, the error will
1477 -- have been emitted when copying the generic node, so we
1478 -- just return to avoid cascaded errors.
1480 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1484 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1485 Analyze_Subunit
(Cunit
(Unum
));
1486 Set_Library_Unit
(N
, Cunit
(Unum
));
1490 -- If the main unit is a subunit, then we are just performing semantic
1491 -- analysis on that subunit, and any other subunits of any parent unit
1492 -- should be ignored, except that if we are building trees for ASIS
1493 -- usage we want to annotate the stub properly.
1495 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1496 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1502 -- But before we return, set the flag for unloaded subunits. This
1503 -- will suppress junk warnings of variables in the same declarative
1504 -- part (or a higher level one) that are in danger of looking unused
1505 -- when in fact there might be a declaration in the subunit that we
1506 -- do not intend to load.
1508 Unloaded_Subunits
:= True;
1511 -- If the subunit is not already loaded, and we are generating code,
1512 -- then this is the case where compilation started from the parent,
1513 -- and we are generating code for an entire subunit tree. In that
1514 -- case we definitely need to load the subunit.
1516 -- In order to continue the analysis with the rest of the parent,
1517 -- and other subunits, we load the unit without requiring its
1518 -- presence, and emit a warning if not found, rather than terminating
1519 -- the compilation abruptly, as for other missing file problems.
1521 elsif Original_Operating_Mode
= Generate_Code
then
1523 -- If the proper body is already linked to the stub node,
1524 -- the stub is in a generic unit and just needs analyzing.
1526 -- We update the version. Although we are not technically
1527 -- semantically dependent on the subunit, given our approach
1528 -- of macro substitution of subunits, it makes sense to
1529 -- include it in the version identification.
1531 if Present
(Library_Unit
(N
)) then
1532 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1533 Analyze_Subunit
(Library_Unit
(N
));
1534 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1536 -- Otherwise we must load the subunit and link to it
1541 (Load_Name
=> Subunit_Name
,
1546 if Original_Operating_Mode
= Generate_Code
1547 and then Unum
= No_Unit
1549 Error_Msg_Name_1
:= Subunit_Name
;
1551 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1553 ("subunit% in file{ not found?", N
);
1554 Subunits_Missing
:= True;
1557 -- Load_Unit may reset Compiler_State, since it may have been
1558 -- necessary to parse an additional units, so we make sure
1559 -- that we reset it to the Analyzing state.
1561 Compiler_State
:= Analyzing
;
1564 and then (not Fatal_Error
(Unum
) or else Try_Semantics
)
1566 if Debug_Flag_L
then
1567 Write_Str
("*** Loaded subunit from stub. Analyze");
1572 Comp_Unit
: constant Node_Id
:= Cunit
(Unum
);
1575 -- Check for child unit instead of subunit
1577 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1579 ("expected SEPARATE subunit, found child unit",
1580 Cunit_Entity
(Unum
));
1582 -- OK, we have a subunit, so go ahead and analyze it,
1583 -- and set Scope of entity in stub, for ASIS use.
1586 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1587 Analyze_Subunit
(Comp_Unit
);
1588 Set_Library_Unit
(N
, Comp_Unit
);
1590 -- We update the version. Although we are not technically
1591 -- semantically dependent on the subunit, given our
1592 -- approach of macro substitution of subunits, it makes
1593 -- sense to include it in the version identification.
1595 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1601 -- The remaining case is when the subunit is not already loaded and
1602 -- we are not generating code. In this case we are just performing
1603 -- semantic analysis on the parent, and we are not interested in
1604 -- the subunit. For subprograms, analyze the stub as a body. For
1605 -- other entities the stub has already been marked as completed.
1611 end Analyze_Proper_Body
;
1613 ----------------------------------
1614 -- Analyze_Protected_Body_Stub --
1615 ----------------------------------
1617 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1618 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1621 Check_Stub_Level
(N
);
1623 -- First occurence of name may have been as an incomplete type
1625 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1626 Nam
:= Full_View
(Nam
);
1630 or else not Is_Protected_Type
(Etype
(Nam
))
1632 Error_Msg_N
("missing specification for Protected body", N
);
1634 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1635 Set_Has_Completion
(Etype
(Nam
));
1636 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
1637 Analyze_Proper_Body
(N
, Etype
(Nam
));
1639 end Analyze_Protected_Body_Stub
;
1641 ----------------------------------
1642 -- Analyze_Subprogram_Body_Stub --
1643 ----------------------------------
1645 -- A subprogram body stub can appear with or without a previous
1646 -- specification. If there is one, the analysis of the body will
1647 -- find it and verify conformance. The formals appearing in the
1648 -- specification of the stub play no role, except for requiring an
1649 -- additional conformance check. If there is no previous subprogram
1650 -- declaration, the stub acts as a spec, and provides the defining
1651 -- entity for the subprogram.
1653 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
1657 Check_Stub_Level
(N
);
1659 -- Verify that the identifier for the stub is unique within this
1660 -- declarative part.
1662 if Nkind
(Parent
(N
)) = N_Block_Statement
1663 or else Nkind
(Parent
(N
)) = N_Package_Body
1664 or else Nkind
(Parent
(N
)) = N_Subprogram_Body
1666 Decl
:= First
(Declarations
(Parent
(N
)));
1667 while Present
(Decl
)
1670 if Nkind
(Decl
) = N_Subprogram_Body_Stub
1671 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
)))
1672 = Chars
(Defining_Unit_Name
(Specification
(N
))))
1674 Error_Msg_N
("identifier for stub is not unique", N
);
1681 -- Treat stub as a body, which checks conformance if there is a previous
1682 -- declaration, or else introduces entity and its signature.
1684 Analyze_Subprogram_Body
(N
);
1685 Analyze_Proper_Body
(N
, Empty
);
1686 end Analyze_Subprogram_Body_Stub
;
1688 ---------------------
1689 -- Analyze_Subunit --
1690 ---------------------
1692 -- A subunit is compiled either by itself (for semantic checking)
1693 -- or as part of compiling the parent (for code generation). In
1694 -- either case, by the time we actually process the subunit, the
1695 -- parent has already been installed and analyzed. The node N is
1696 -- a compilation unit, whose context needs to be treated here,
1697 -- because we come directly here from the parent without calling
1698 -- Analyze_Compilation_Unit.
1700 -- The compilation context includes the explicit context of the
1701 -- subunit, and the context of the parent, together with the parent
1702 -- itself. In order to compile the current context, we remove the
1703 -- one inherited from the parent, in order to have a clean visibility
1704 -- table. We restore the parent context before analyzing the proper
1705 -- body itself. On exit, we remove only the explicit context of the
1708 procedure Analyze_Subunit
(N
: Node_Id
) is
1709 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
1710 Par_Unit
: constant Entity_Id
:= Current_Scope
;
1712 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
1713 Num_Scopes
: Int
:= 0;
1714 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
1715 Enclosing_Child
: Entity_Id
:= Empty
;
1716 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1718 procedure Analyze_Subunit_Context
;
1719 -- Capture names in use clauses of the subunit. This must be done
1720 -- before re-installing parent declarations, because items in the
1721 -- context must not be hidden by declarations local to the parent.
1723 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
1724 -- Recursive procedure to restore scope of all ancestors of subunit,
1725 -- from outermost in. If parent is not a subunit, the call to install
1726 -- context installs context of spec and (if parent is a child unit)
1727 -- the context of its parents as well. It is confusing that parents
1728 -- should be treated differently in both cases, but the semantics are
1729 -- just not identical.
1731 procedure Re_Install_Use_Clauses
;
1732 -- As part of the removal of the parent scope, the use clauses are
1733 -- removed, to be reinstalled when the context of the subunit has
1734 -- been analyzed. Use clauses may also have been affected by the
1735 -- analysis of the context of the subunit, so they have to be applied
1736 -- again, to insure that the compilation environment of the rest of
1737 -- the parent unit is identical.
1739 procedure Remove_Scope
;
1740 -- Remove current scope from scope stack, and preserve the list
1741 -- of use clauses in it, to be reinstalled after context is analyzed.
1743 -----------------------------
1744 -- Analyze_Subunit_Context --
1745 -----------------------------
1747 procedure Analyze_Subunit_Context
is
1750 Unit_Name
: Entity_Id
;
1753 Analyze_Context
(N
);
1755 -- Make withed units immediately visible. If child unit, make the
1756 -- ultimate parent immediately visible.
1758 Item
:= First
(Context_Items
(N
));
1759 while Present
(Item
) loop
1760 if Nkind
(Item
) = N_With_Clause
then
1762 -- Protect frontend against previous errors in context clauses
1764 if Nkind
(Name
(Item
)) /= N_Selected_Component
then
1765 Unit_Name
:= Entity
(Name
(Item
));
1766 while Is_Child_Unit
(Unit_Name
) loop
1767 Set_Is_Visible_Child_Unit
(Unit_Name
);
1768 Unit_Name
:= Scope
(Unit_Name
);
1771 if not Is_Immediately_Visible
(Unit_Name
) then
1772 Set_Is_Immediately_Visible
(Unit_Name
);
1773 Set_Context_Installed
(Item
);
1777 elsif Nkind
(Item
) = N_Use_Package_Clause
then
1778 Nam
:= First
(Names
(Item
));
1779 while Present
(Nam
) loop
1784 elsif Nkind
(Item
) = N_Use_Type_Clause
then
1785 Nam
:= First
(Subtype_Marks
(Item
));
1786 while Present
(Nam
) loop
1795 -- Reset visibility of withed units. They will be made visible
1796 -- again when we install the subunit context.
1798 Item
:= First
(Context_Items
(N
));
1799 while Present
(Item
) loop
1800 if Nkind
(Item
) = N_With_Clause
1802 -- Protect frontend against previous errors in context clauses
1804 and then Nkind
(Name
(Item
)) /= N_Selected_Component
1806 Unit_Name
:= Entity
(Name
(Item
));
1807 while Is_Child_Unit
(Unit_Name
) loop
1808 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
1809 Unit_Name
:= Scope
(Unit_Name
);
1812 if Context_Installed
(Item
) then
1813 Set_Is_Immediately_Visible
(Unit_Name
, False);
1814 Set_Context_Installed
(Item
, False);
1820 end Analyze_Subunit_Context
;
1822 ------------------------
1823 -- Re_Install_Parents --
1824 ------------------------
1826 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
1830 if Nkind
(Unit
(L
)) = N_Subunit
then
1831 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
1834 Install_Context
(L
);
1836 -- If the subunit occurs within a child unit, we must restore the
1837 -- immediate visibility of any siblings that may occur in context.
1839 if Present
(Enclosing_Child
) then
1840 Install_Siblings
(Enclosing_Child
, L
);
1845 if Scop
/= Par_Unit
then
1846 Set_Is_Immediately_Visible
(Scop
);
1849 -- Make entities in scope visible again. For child units, restore
1850 -- visibility only if they are actually in context.
1852 E
:= First_Entity
(Current_Scope
);
1853 while Present
(E
) loop
1854 if not Is_Child_Unit
(E
)
1855 or else Is_Visible_Child_Unit
(E
)
1857 Set_Is_Immediately_Visible
(E
);
1863 -- A subunit appears within a body, and for a nested subunits
1864 -- all the parents are bodies. Restore full visibility of their
1865 -- private entities.
1867 if Ekind
(Scop
) = E_Package
then
1868 Set_In_Package_Body
(Scop
);
1869 Install_Private_Declarations
(Scop
);
1871 end Re_Install_Parents
;
1873 ----------------------------
1874 -- Re_Install_Use_Clauses --
1875 ----------------------------
1877 procedure Re_Install_Use_Clauses
is
1880 for J
in reverse 1 .. Num_Scopes
loop
1881 U
:= Use_Clauses
(J
);
1882 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
1883 Install_Use_Clauses
(U
, Force_Installation
=> True);
1885 end Re_Install_Use_Clauses
;
1891 procedure Remove_Scope
is
1895 Num_Scopes
:= Num_Scopes
+ 1;
1896 Use_Clauses
(Num_Scopes
) :=
1897 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
1899 E
:= First_Entity
(Current_Scope
);
1900 while Present
(E
) loop
1901 Set_Is_Immediately_Visible
(E
, False);
1905 if Is_Child_Unit
(Current_Scope
) then
1906 Enclosing_Child
:= Current_Scope
;
1912 -- Start of processing for Analyze_Subunit
1915 if not Is_Empty_List
(Context_Items
(N
)) then
1917 -- Save current use clauses
1920 Remove_Context
(Lib_Unit
);
1922 -- Now remove parents and their context, including enclosing
1923 -- subunits and the outer parent body which is not a subunit.
1925 if Present
(Lib_Spec
) then
1926 Remove_Context
(Lib_Spec
);
1928 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
1929 Lib_Spec
:= Library_Unit
(Lib_Spec
);
1931 Remove_Context
(Lib_Spec
);
1934 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
1938 if Nkind
(Unit
(Lib_Spec
)) = N_Package_Body
then
1939 Remove_Context
(Library_Unit
(Lib_Spec
));
1943 Set_Is_Immediately_Visible
(Par_Unit
, False);
1945 Analyze_Subunit_Context
;
1947 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
1948 Set_Is_Immediately_Visible
(Par_Unit
);
1950 -- If the context includes a child unit of the parent of the
1951 -- subunit, the parent will have been removed from visibility,
1952 -- after compiling that cousin in the context. The visibility
1953 -- of the parent must be restored now. This also applies if the
1954 -- context includes another subunit of the same parent which in
1955 -- turn includes a child unit in its context.
1957 if Ekind
(Par_Unit
) = E_Package
then
1958 if not Is_Immediately_Visible
(Par_Unit
)
1959 or else (Present
(First_Entity
(Par_Unit
))
1960 and then not Is_Immediately_Visible
1961 (First_Entity
(Par_Unit
)))
1963 Set_Is_Immediately_Visible
(Par_Unit
);
1964 Install_Visible_Declarations
(Par_Unit
);
1965 Install_Private_Declarations
(Par_Unit
);
1969 Re_Install_Use_Clauses
;
1970 Install_Context
(N
);
1972 -- Restore state of suppress flags for current body
1974 Scope_Suppress
:= Svg
;
1976 -- If the subunit is within a child unit, then siblings of any
1977 -- parent unit that appear in the context clause of the subunit
1978 -- must also be made immediately visible.
1980 if Present
(Enclosing_Child
) then
1981 Install_Siblings
(Enclosing_Child
, N
);
1986 Analyze
(Proper_Body
(Unit
(N
)));
1988 end Analyze_Subunit
;
1990 ----------------------------
1991 -- Analyze_Task_Body_Stub --
1992 ----------------------------
1994 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
1995 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1996 Loc
: constant Source_Ptr
:= Sloc
(N
);
1999 Check_Stub_Level
(N
);
2001 -- First occurence of name may have been as an incomplete type
2003 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2004 Nam
:= Full_View
(Nam
);
2008 or else not Is_Task_Type
(Etype
(Nam
))
2010 Error_Msg_N
("missing specification for task body", N
);
2012 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
2013 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
2014 Set_Has_Completion
(Etype
(Nam
));
2015 Analyze_Proper_Body
(N
, Etype
(Nam
));
2017 -- Set elaboration flag to indicate that entity is callable.
2018 -- This cannot be done in the expansion of the body itself,
2019 -- because the proper body is not in a declarative part. This
2020 -- is only done if expansion is active, because the context
2021 -- may be generic and the flag not defined yet.
2023 if Expander_Active
then
2025 Make_Assignment_Statement
(Loc
,
2027 Make_Identifier
(Loc
,
2028 New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
2029 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
2033 end Analyze_Task_Body_Stub
;
2035 -------------------------
2036 -- Analyze_With_Clause --
2037 -------------------------
2039 -- Analyze the declaration of a unit in a with clause. At end,
2040 -- label the with clause with the defining entity for the unit.
2042 procedure Analyze_With_Clause
(N
: Node_Id
) is
2044 -- Retrieve the original kind of the unit node, before analysis.
2045 -- If it is a subprogram instantiation, its analysis below will
2046 -- rewrite as the declaration of the wrapper package. If the same
2047 -- instantiation appears indirectly elsewhere in the context, it
2048 -- will have been analyzed already.
2050 Unit_Kind
: constant Node_Kind
:=
2051 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
2054 Par_Name
: Entity_Id
;
2059 -- Set True if the unit currently being compiled is an internal unit
2061 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2062 Save_C_Restrict
: constant Save_Cunit_Boolean_Restrictions
:=
2063 Cunit_Boolean_Restrictions_Save
;
2066 if Limited_Present
(N
) then
2068 -- Ada 2005 (AI-50217): Build visibility structures but do not
2071 Build_Limited_Views
(N
);
2075 -- We reset ordinary style checking during the analysis of a with'ed
2076 -- unit, but we do NOT reset GNAT special analysis mode (the latter
2077 -- definitely *does* apply to with'ed units).
2079 if not GNAT_Mode
then
2080 Style_Check
:= False;
2083 -- If the library unit is a predefined unit, and we are in high
2084 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
2085 -- for the analysis of the with'ed unit. This mode does not prevent
2086 -- explicit with'ing of run-time units.
2088 if Configurable_Run_Time_Mode
2090 Is_Predefined_File_Name
2091 (Unit_File_Name
(Get_Source_Unit
(Unit
(Library_Unit
(N
)))))
2093 Configurable_Run_Time_Mode
:= False;
2094 Semantics
(Library_Unit
(N
));
2095 Configurable_Run_Time_Mode
:= True;
2098 Semantics
(Library_Unit
(N
));
2101 U
:= Unit
(Library_Unit
(N
));
2102 Check_Restriction_No_Dependence
(Name
(N
), N
);
2103 Intunit
:= Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
));
2105 -- Following checks are skipped for dummy packages (those supplied
2106 -- for with's where no matching file could be found). Such packages
2107 -- are identified by the Sloc value being set to No_Location
2109 if Sloc
(U
) /= No_Location
then
2111 -- Check restrictions, except that we skip the check if this
2112 -- is an internal unit unless we are compiling the internal
2113 -- unit as the main unit. We also skip this for dummy packages.
2115 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
2116 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
2119 -- Check for inappropriate with of internal implementation unit
2120 -- if we are currently compiling the main unit and the main unit
2121 -- is itself not an internal unit. We do not issue this message
2122 -- for implicit with's generated by the compiler itself.
2124 if Implementation_Unit_Warnings
2125 and then Current_Sem_Unit
= Main_Unit
2126 and then not Intunit
2127 and then not Implicit_With
(N
)
2128 and then not GNAT_Mode
2131 U_Kind
: constant Kind_Of_Unit
:=
2132 Get_Kind_Of_Unit
(Get_Source_Unit
(U
));
2135 if U_Kind
= Implementation_Unit
then
2136 Error_Msg_N
("& is an internal 'G'N'A'T unit?", Name
(N
));
2138 ("\use of this unit is non-portable " &
2139 "and version-dependent?",
2142 elsif U_Kind
= Ada_05_Unit
2143 and then Ada_Version
< Ada_05
2144 and then Warn_On_Ada_2005_Compatibility
2146 Error_Msg_N
("& is an Ada 2005 unit?", Name
(N
));
2152 -- Semantic analysis of a generic unit is performed on a copy of
2153 -- the original tree. Retrieve the entity on which semantic info
2154 -- actually appears.
2156 if Unit_Kind
in N_Generic_Declaration
then
2157 E_Name
:= Defining_Entity
(U
);
2159 -- Note: in the following test, Unit_Kind is the original Nkind, but
2160 -- in the case of an instantiation, semantic analysis above will
2161 -- have replaced the unit by its instantiated version. If the instance
2162 -- body has been generated, the instance now denotes the body entity.
2163 -- For visibility purposes we need the entity of its spec.
2165 elsif (Unit_Kind
= N_Package_Instantiation
2166 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
2167 N_Package_Instantiation
)
2168 and then Nkind
(U
) = N_Package_Body
2170 E_Name
:= Corresponding_Spec
(U
);
2172 elsif Unit_Kind
= N_Package_Instantiation
2173 and then Nkind
(U
) = N_Package_Instantiation
2175 -- If the instance has not been rewritten as a package declaration,
2176 -- then it appeared already in a previous with clause. Retrieve
2177 -- the entity from the previous instance.
2179 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
2181 elsif Unit_Kind
in N_Subprogram_Instantiation
then
2183 -- Instantiation node is replaced with a wrapper package.
2184 -- Retrieve the visible subprogram created by the instance from
2185 -- the corresponding attribute of the wrapper.
2187 E_Name
:= Related_Instance
(Defining_Entity
(U
));
2189 elsif Unit_Kind
= N_Package_Renaming_Declaration
2190 or else Unit_Kind
in N_Generic_Renaming_Declaration
2192 E_Name
:= Defining_Entity
(U
);
2194 elsif Unit_Kind
= N_Subprogram_Body
2195 and then Nkind
(Name
(N
)) = N_Selected_Component
2196 and then not Acts_As_Spec
(Library_Unit
(N
))
2198 -- For a child unit that has no spec, one has been created and
2199 -- analyzed. The entity required is that of the spec.
2201 E_Name
:= Corresponding_Spec
(U
);
2204 E_Name
:= Defining_Entity
(U
);
2207 if Nkind
(Name
(N
)) = N_Selected_Component
then
2209 -- Child unit in a with clause
2211 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
2214 -- Restore style checks and restrictions
2216 Style_Check
:= Save_Style_Check
;
2217 Cunit_Boolean_Restrictions_Restore
(Save_C_Restrict
);
2219 -- Record the reference, but do NOT set the unit as referenced, we want
2220 -- to consider the unit as unreferenced if this is the only reference
2223 Set_Entity_With_Style_Check
(Name
(N
), E_Name
);
2224 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
2226 if Is_Child_Unit
(E_Name
) then
2227 Pref
:= Prefix
(Name
(N
));
2228 Par_Name
:= Scope
(E_Name
);
2229 while Nkind
(Pref
) = N_Selected_Component
loop
2230 Change_Selected_Component_To_Expanded_Name
(Pref
);
2231 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2233 Generate_Reference
(Par_Name
, Pref
);
2234 Pref
:= Prefix
(Pref
);
2236 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2237 -- is set to Standard_Standard, and no attempt should be made to
2238 -- further unwind scopes.
2240 if Par_Name
/= Standard_Standard
then
2241 Par_Name
:= Scope
(Par_Name
);
2245 if Present
(Entity
(Pref
))
2246 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
2248 -- If the entity is set without its unit being compiled, the
2249 -- original parent is a renaming, and Par_Name is the renamed
2250 -- entity. For visibility purposes, we need the original entity,
2251 -- which must be analyzed now because Load_Unit directly retrieves
2252 -- the renamed unit, and the renaming declaration itself has not
2255 Analyze
(Parent
(Parent
(Entity
(Pref
))));
2256 pragma Assert
(Renamed_Object
(Entity
(Pref
)) = Par_Name
);
2257 Par_Name
:= Entity
(Pref
);
2260 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2261 Generate_Reference
(Par_Name
, Pref
);
2264 -- If the withed unit is System, and a system extension pragma is
2265 -- present, compile the extension now, rather than waiting for a
2266 -- visibility check on a specific entity.
2268 if Chars
(E_Name
) = Name_System
2269 and then Scope
(E_Name
) = Standard_Standard
2270 and then Present
(System_Extend_Unit
)
2271 and then Present_System_Aux
(N
)
2273 -- If the extension is not present, an error will have been emitted
2278 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2279 -- to private_with units; they will be made visible later (just before
2280 -- the private part is analyzed)
2282 if Private_Present
(N
) then
2283 Set_Is_Immediately_Visible
(E_Name
, False);
2286 -- Check for with'ing obsolescent package. Exclude subprograms here
2287 -- since we will catch those on the call rather than the WITH.
2289 if Is_Package_Or_Generic_Package
(E_Name
) then
2290 Check_Obsolescent
(E_Name
, N
);
2292 end Analyze_With_Clause
;
2294 ------------------------------
2295 -- Analyze_With_Type_Clause --
2296 ------------------------------
2298 procedure Analyze_With_Type_Clause
(N
: Node_Id
) is
2299 Loc
: constant Source_Ptr
:= Sloc
(N
);
2300 Nam
: constant Node_Id
:= Name
(N
);
2304 Unum
: Unit_Number_Type
;
2307 procedure Decorate_Tagged_Type
(T
: Entity_Id
);
2308 -- Set basic attributes of type, including its class_wide type
2310 function In_Chain
(E
: Entity_Id
) return Boolean;
2311 -- Check that the imported type is not already in the homonym chain,
2312 -- for example through a with_type clause in a parent unit.
2314 --------------------------
2315 -- Decorate_Tagged_Type --
2316 --------------------------
2318 procedure Decorate_Tagged_Type
(T
: Entity_Id
) is
2322 Set_Ekind
(T
, E_Record_Type
);
2323 Set_Is_Tagged_Type
(T
);
2325 Set_From_With_Type
(T
);
2328 if not In_Chain
(T
) then
2329 Set_Homonym
(T
, Current_Entity
(T
));
2330 Set_Current_Entity
(T
);
2333 -- Build bogus class_wide type, if not previously done
2335 if No
(Class_Wide_Type
(T
)) then
2336 CW
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2338 Set_Ekind
(CW
, E_Class_Wide_Type
);
2341 Set_Is_Tagged_Type
(CW
);
2342 Set_Is_First_Subtype
(CW
, True);
2343 Init_Size_Align
(CW
);
2344 Set_Has_Unknown_Discriminants
2346 Set_Class_Wide_Type
(CW
, CW
);
2347 Set_Equivalent_Type
(CW
, Empty
);
2348 Set_From_With_Type
(CW
);
2350 Set_Class_Wide_Type
(T
, CW
);
2352 end Decorate_Tagged_Type
;
2358 function In_Chain
(E
: Entity_Id
) return Boolean is
2362 H
:= Current_Entity
(E
);
2363 while Present
(H
) loop
2374 -- Start of processing for Analyze_With_Type_Clause
2377 if Nkind
(Nam
) = N_Selected_Component
then
2378 Pack
:= New_Copy_Tree
(Prefix
(Nam
));
2379 Sel
:= Selector_Name
(Nam
);
2382 Error_Msg_N
("illegal name for imported type", Nam
);
2387 Make_Package_Declaration
(Loc
,
2389 (Make_Package_Specification
(Loc
,
2390 Defining_Unit_Name
=> Pack
,
2391 Visible_Declarations
=> New_List
,
2392 End_Label
=> Empty
)));
2396 (Load_Name
=> Get_Unit_Name
(Decl
),
2402 or else Nkind
(Unit
(Cunit
(Unum
))) /= N_Package_Declaration
2404 Error_Msg_N
("imported type must be declared in package", Nam
);
2407 elsif Unum
= Current_Sem_Unit
then
2409 -- If type is defined in unit being analyzed, then the clause
2415 P
:= Cunit_Entity
(Unum
);
2418 -- Find declaration for imported type, and set its basic attributes
2419 -- if it has not been analyzed (which will be the case if there is
2420 -- circular dependence).
2427 if not Analyzed
(Cunit
(Unum
))
2428 and then not From_With_Type
(P
)
2430 Set_Ekind
(P
, E_Package
);
2431 Set_Etype
(P
, Standard_Void_Type
);
2432 Set_From_With_Type
(P
);
2433 Set_Scope
(P
, Standard_Standard
);
2434 Set_Homonym
(P
, Current_Entity
(P
));
2435 Set_Current_Entity
(P
);
2437 elsif Analyzed
(Cunit
(Unum
))
2438 and then Is_Child_Unit
(P
)
2440 -- If the child unit is already in scope, indicate that it is
2441 -- visible, and remains so after intervening calls to rtsfind.
2443 Set_Is_Visible_Child_Unit
(P
);
2446 if Nkind
(Parent
(P
)) = N_Defining_Program_Unit_Name
then
2448 -- Make parent packages visible
2451 Parent_Comp
: Node_Id
;
2452 Parent_Id
: Entity_Id
;
2457 Parent_Comp
:= Parent_Spec
(Unit
(Cunit
(Unum
)));
2460 Parent_Id
:= Defining_Entity
(Unit
(Parent_Comp
));
2461 Set_Scope
(Child
, Parent_Id
);
2463 -- The type may be imported from a child unit, in which
2464 -- case the current compilation appears in the name. Do
2465 -- not change its visibility here because it will conflict
2466 -- with the subsequent normal processing.
2468 if not Analyzed
(Unit_Declaration_Node
(Parent_Id
))
2469 and then Parent_Id
/= Cunit_Entity
(Current_Sem_Unit
)
2471 Set_Ekind
(Parent_Id
, E_Package
);
2472 Set_Etype
(Parent_Id
, Standard_Void_Type
);
2474 -- The same package may appear is several with_type
2477 if not From_With_Type
(Parent_Id
) then
2478 Set_Homonym
(Parent_Id
, Current_Entity
(Parent_Id
));
2479 Set_Current_Entity
(Parent_Id
);
2480 Set_From_With_Type
(Parent_Id
);
2484 Set_Is_Immediately_Visible
(Parent_Id
);
2487 Parent_Comp
:= Parent_Spec
(Unit
(Parent_Comp
));
2488 exit when No
(Parent_Comp
);
2491 Set_Scope
(Parent_Id
, Standard_Standard
);
2495 -- Even if analyzed, the package may not be currently visible. It
2496 -- must be while the with_type clause is active.
2498 Set_Is_Immediately_Visible
(P
);
2501 First
(Visible_Declarations
(Specification
(Unit
(Cunit
(Unum
)))));
2502 while Present
(Decl
) loop
2503 if Nkind
(Decl
) = N_Full_Type_Declaration
2504 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
2506 Typ
:= Defining_Identifier
(Decl
);
2508 if Tagged_Present
(N
) then
2510 -- The declaration must indicate that this is a tagged
2511 -- type or a type extension.
2513 if (Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
2514 and then Tagged_Present
(Type_Definition
(Decl
)))
2516 (Nkind
(Type_Definition
(Decl
))
2517 = N_Derived_Type_Definition
2519 (Record_Extension_Part
(Type_Definition
(Decl
))))
2523 Error_Msg_N
("imported type is not a tagged type", Nam
);
2527 if not Analyzed
(Decl
) then
2529 -- Unit is not currently visible. Add basic attributes
2530 -- to type and build its class-wide type.
2532 Init_Size_Align
(Typ
);
2533 Decorate_Tagged_Type
(Typ
);
2537 if Nkind
(Type_Definition
(Decl
))
2538 /= N_Access_To_Object_Definition
2541 ("imported type is not an access type", Nam
);
2543 elsif not Analyzed
(Decl
) then
2544 Set_Ekind
(Typ
, E_Access_Type
);
2545 Set_Etype
(Typ
, Typ
);
2547 Init_Size
(Typ
, System_Address_Size
);
2548 Init_Alignment
(Typ
);
2549 Set_Directly_Designated_Type
(Typ
, Standard_Integer
);
2550 Set_From_With_Type
(Typ
);
2552 if not In_Chain
(Typ
) then
2553 Set_Homonym
(Typ
, Current_Entity
(Typ
));
2554 Set_Current_Entity
(Typ
);
2559 Set_Entity
(Sel
, Typ
);
2562 elsif ((Nkind
(Decl
) = N_Private_Type_Declaration
2563 and then Tagged_Present
(Decl
))
2564 or else (Nkind
(Decl
) = N_Private_Extension_Declaration
))
2565 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
2567 Typ
:= Defining_Identifier
(Decl
);
2569 if not Tagged_Present
(N
) then
2570 Error_Msg_N
("type must be declared tagged", N
);
2572 elsif not Analyzed
(Decl
) then
2573 Decorate_Tagged_Type
(Typ
);
2576 Set_Entity
(Sel
, Typ
);
2577 Set_From_With_Type
(Typ
);
2581 Decl
:= Next
(Decl
);
2584 Error_Msg_NE
("not a visible access or tagged type in&", Nam
, P
);
2586 end Analyze_With_Type_Clause
;
2588 -----------------------------
2589 -- Check_With_Type_Clauses --
2590 -----------------------------
2592 procedure Check_With_Type_Clauses
(N
: Node_Id
) is
2593 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2595 procedure Check_Parent_Context
(U
: Node_Id
);
2596 -- Examine context items of parent unit to locate with_type clauses
2598 --------------------------
2599 -- Check_Parent_Context --
2600 --------------------------
2602 procedure Check_Parent_Context
(U
: Node_Id
) is
2606 Item
:= First
(Context_Items
(U
));
2607 while Present
(Item
) loop
2608 if Nkind
(Item
) = N_With_Type_Clause
2609 and then not Error_Posted
(Item
)
2611 From_With_Type
(Scope
(Entity
(Selector_Name
(Name
(Item
)))))
2613 Error_Msg_Sloc
:= Sloc
(Item
);
2614 Error_Msg_N
("missing With_Clause for With_Type_Clause#", N
);
2619 end Check_Parent_Context
;
2621 -- Start of processing for Check_With_Type_Clauses
2624 if Extensions_Allowed
2625 and then (Nkind
(Lib_Unit
) = N_Package_Body
2626 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
)
2628 Check_Parent_Context
(Library_Unit
(N
));
2630 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
2631 Check_Parent_Context
(Parent_Spec
(Unit
(Library_Unit
(N
))));
2634 end Check_With_Type_Clauses
;
2636 ------------------------------
2637 -- Check_Private_Child_Unit --
2638 ------------------------------
2640 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
2641 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2643 Curr_Unit
: Entity_Id
;
2644 Sub_Parent
: Node_Id
;
2645 Priv_Child
: Entity_Id
;
2646 Par_Lib
: Entity_Id
;
2649 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean;
2650 -- Returns true if and only if the library unit is declared with
2651 -- an explicit designation of private.
2653 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
2654 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
2657 return Private_Present
(Comp_Unit
);
2658 end Is_Private_Library_Unit
;
2660 -- Start of processing for Check_Private_Child_Unit
2663 if Nkind
(Lib_Unit
) = N_Package_Body
2664 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
2666 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
2667 Par_Lib
:= Curr_Unit
;
2669 elsif Nkind
(Lib_Unit
) = N_Subunit
then
2671 -- The parent is itself a body. The parent entity is to be found
2672 -- in the corresponding spec.
2674 Sub_Parent
:= Library_Unit
(N
);
2675 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
2677 -- If the parent itself is a subunit, Curr_Unit is the entity
2678 -- of the enclosing body, retrieve the spec entity which is
2679 -- the proper ancestor we need for the following tests.
2681 if Ekind
(Curr_Unit
) = E_Package_Body
then
2682 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2685 Par_Lib
:= Curr_Unit
;
2688 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2690 Par_Lib
:= Curr_Unit
;
2691 Par_Spec
:= Parent_Spec
(Lib_Unit
);
2693 if No
(Par_Spec
) then
2696 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
2700 -- Loop through context items
2702 Item
:= First
(Context_Items
(N
));
2703 while Present
(Item
) loop
2705 -- Ada 2005 (AI-262): Allow private_with of a private child package
2706 -- in public siblings
2708 if Nkind
(Item
) = N_With_Clause
2709 and then not Implicit_With
(Item
)
2710 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
2712 Priv_Child
:= Entity
(Name
(Item
));
2715 Curr_Parent
: Entity_Id
:= Par_Lib
;
2716 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
2717 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
2718 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
2721 -- If the child unit is a public child then locate
2722 -- the nearest private ancestor; Child_Parent will
2723 -- then be set to the parent of that ancestor.
2725 if not Is_Private_Library_Unit
(Priv_Child
) then
2726 while Present
(Prv_Ancestor
)
2727 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
2729 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
2732 if Present
(Prv_Ancestor
) then
2733 Child_Parent
:= Scope
(Prv_Ancestor
);
2737 while Present
(Curr_Parent
)
2738 and then Curr_Parent
/= Standard_Standard
2739 and then Curr_Parent
/= Child_Parent
2742 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
2743 Curr_Parent
:= Scope
(Curr_Parent
);
2746 if No
(Curr_Parent
) then
2747 Curr_Parent
:= Standard_Standard
;
2750 if Curr_Parent
/= Child_Parent
then
2751 if Ekind
(Priv_Child
) = E_Generic_Package
2752 and then Chars
(Priv_Child
) in Text_IO_Package_Name
2753 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
2756 ("& is a nested package, not a compilation unit",
2757 Name
(Item
), Priv_Child
);
2761 ("unit in with clause is private child unit!", Item
);
2763 ("current unit must also have parent&!",
2764 Item
, Child_Parent
);
2767 elsif not Curr_Private
2768 and then not Private_Present
(Item
)
2769 and then Nkind
(Lib_Unit
) /= N_Package_Body
2770 and then Nkind
(Lib_Unit
) /= N_Subprogram_Body
2771 and then Nkind
(Lib_Unit
) /= N_Subunit
2774 ("current unit must also be private descendant of&",
2775 Item
, Child_Parent
);
2783 end Check_Private_Child_Unit
;
2785 ----------------------
2786 -- Check_Stub_Level --
2787 ----------------------
2789 procedure Check_Stub_Level
(N
: Node_Id
) is
2790 Par
: constant Node_Id
:= Parent
(N
);
2791 Kind
: constant Node_Kind
:= Nkind
(Par
);
2794 if (Kind
= N_Package_Body
2795 or else Kind
= N_Subprogram_Body
2796 or else Kind
= N_Task_Body
2797 or else Kind
= N_Protected_Body
)
2798 and then (Nkind
(Parent
(Par
)) = N_Compilation_Unit
2799 or else Nkind
(Parent
(Par
)) = N_Subunit
)
2803 -- In an instance, a missing stub appears at any level. A warning
2804 -- message will have been emitted already for the missing file.
2806 elsif not In_Instance
then
2807 Error_Msg_N
("stub cannot appear in an inner scope", N
);
2809 elsif Expander_Active
then
2810 Error_Msg_N
("missing proper body", N
);
2812 end Check_Stub_Level
;
2814 ------------------------
2815 -- Expand_With_Clause --
2816 ------------------------
2818 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
) is
2819 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2820 Ent
: constant Entity_Id
:= Entity
(Nam
);
2824 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
2825 -- Comment requireed here ???
2827 ---------------------
2828 -- Build_Unit_Name --
2829 ---------------------
2831 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
2835 if Nkind
(Nam
) = N_Identifier
then
2836 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
2840 Make_Expanded_Name
(Loc
,
2841 Chars
=> Chars
(Entity
(Nam
)),
2842 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
2843 Selector_Name
=> New_Occurrence_Of
(Entity
(Nam
), Loc
));
2844 Set_Entity
(Result
, Entity
(Nam
));
2847 end Build_Unit_Name
;
2849 -- Start of processing for Expand_With_Clause
2852 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2854 Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
(Nam
));
2856 P
:= Parent
(Unit_Declaration_Node
(Ent
));
2857 Set_Library_Unit
(Withn
, P
);
2858 Set_Corresponding_Spec
(Withn
, Ent
);
2859 Set_First_Name
(Withn
, True);
2860 Set_Implicit_With
(Withn
, True);
2862 -- If the unit is a package declaration, a private_with_clause on a
2863 -- child unit implies that the implicit with on the parent is also
2866 if Nkind
(Unit
(N
)) = N_Package_Declaration
then
2867 Set_Private_Present
(Withn
, Private_Present
(Item
));
2870 Prepend
(Withn
, Context_Items
(N
));
2871 Mark_Rewrite_Insertion
(Withn
);
2872 Install_Withed_Unit
(Withn
);
2874 if Nkind
(Nam
) = N_Expanded_Name
then
2875 Expand_With_Clause
(Item
, Prefix
(Nam
), N
);
2878 New_Nodes_OK
:= New_Nodes_OK
- 1;
2879 end Expand_With_Clause
;
2881 -----------------------
2882 -- Get_Parent_Entity --
2883 -----------------------
2885 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
2887 if Nkind
(Unit
) = N_Package_Body
2888 and then Nkind
(Original_Node
(Unit
)) = N_Package_Instantiation
2892 (Specification
(Instance_Spec
(Original_Node
(Unit
))));
2894 elsif Nkind
(Unit
) = N_Package_Instantiation
then
2895 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
2898 return Defining_Entity
(Unit
);
2900 end Get_Parent_Entity
;
2902 -----------------------------
2903 -- Implicit_With_On_Parent --
2904 -----------------------------
2906 procedure Implicit_With_On_Parent
2907 (Child_Unit
: Node_Id
;
2910 Loc
: constant Source_Ptr
:= Sloc
(N
);
2911 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
2913 P_Unit
: Node_Id
:= Unit
(P
);
2915 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
2918 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
2919 -- Build prefix of child unit name. Recurse if needed
2921 function Build_Unit_Name
return Node_Id
;
2922 -- If the unit is a child unit, build qualified name with all
2925 -------------------------
2926 -- Build_Ancestor_Name --
2927 -------------------------
2929 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
2930 P_Ref
: constant Node_Id
:=
2931 New_Reference_To
(Defining_Entity
(P
), Loc
);
2932 P_Spec
: Node_Id
:= P
;
2935 -- Ancestor may have been rewritten as a package body. Retrieve
2936 -- the original spec to trace earlier ancestors.
2938 if Nkind
(P
) = N_Package_Body
2939 and then Nkind
(Original_Node
(P
)) = N_Package_Instantiation
2941 P_Spec
:= Original_Node
(P
);
2944 if No
(Parent_Spec
(P_Spec
)) then
2948 Make_Selected_Component
(Loc
,
2949 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Spec
))),
2950 Selector_Name
=> P_Ref
);
2952 end Build_Ancestor_Name
;
2954 ---------------------
2955 -- Build_Unit_Name --
2956 ---------------------
2958 function Build_Unit_Name
return Node_Id
is
2961 if No
(Parent_Spec
(P_Unit
)) then
2962 return New_Reference_To
(P_Name
, Loc
);
2965 Make_Expanded_Name
(Loc
,
2966 Chars
=> Chars
(P_Name
),
2967 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
2968 Selector_Name
=> New_Reference_To
(P_Name
, Loc
));
2969 Set_Entity
(Result
, P_Name
);
2972 end Build_Unit_Name
;
2974 -- Start of processing for Implicit_With_On_Parent
2977 -- The unit of the current compilation may be a package body
2978 -- that replaces an instance node. In this case we need the
2979 -- original instance node to construct the proper parent name.
2981 if Nkind
(P_Unit
) = N_Package_Body
2982 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
2984 P_Unit
:= Original_Node
(P_Unit
);
2987 -- We add the implicit with if the child unit is the current unit
2988 -- being compiled. If the current unit is a body, we do not want
2989 -- to add an implicit_with a second time to the corresponding spec.
2991 if Nkind
(Child_Unit
) = N_Package_Declaration
2992 and then Child_Unit
/= Unit
(Cunit
(Current_Sem_Unit
))
2997 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2998 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
3000 Set_Library_Unit
(Withn
, P
);
3001 Set_Corresponding_Spec
(Withn
, P_Name
);
3002 Set_First_Name
(Withn
, True);
3003 Set_Implicit_With
(Withn
, True);
3005 -- Node is placed at the beginning of the context items, so that
3006 -- subsequent use clauses on the parent can be validated.
3008 Prepend
(Withn
, Context_Items
(N
));
3009 Mark_Rewrite_Insertion
(Withn
);
3010 Install_Withed_Unit
(Withn
);
3012 if Is_Child_Spec
(P_Unit
) then
3013 Implicit_With_On_Parent
(P_Unit
, N
);
3016 New_Nodes_OK
:= New_Nodes_OK
- 1;
3017 end Implicit_With_On_Parent
;
3023 function In_Chain
(E
: Entity_Id
) return Boolean is
3027 H
:= Current_Entity
(E
);
3028 while Present
(H
) loop
3039 ---------------------
3040 -- Install_Context --
3041 ---------------------
3043 procedure Install_Context
(N
: Node_Id
) is
3044 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3047 Install_Context_Clauses
(N
);
3049 if Is_Child_Spec
(Lib_Unit
) then
3050 Install_Parents
(Lib_Unit
, Private_Present
(Parent
(Lib_Unit
)));
3053 Install_Limited_Context_Clauses
(N
);
3055 Check_With_Type_Clauses
(N
);
3056 end Install_Context
;
3058 -----------------------------
3059 -- Install_Context_Clauses --
3060 -----------------------------
3062 procedure Install_Context_Clauses
(N
: Node_Id
) is
3063 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3065 Uname_Node
: Entity_Id
;
3066 Check_Private
: Boolean := False;
3067 Decl_Node
: Node_Id
;
3068 Lib_Parent
: Entity_Id
;
3071 -- First skip configuration pragmas at the start of the context. They
3072 -- are not technically part of the context clause, but that's where the
3073 -- parser puts them. Note they were analyzed in Analyze_Context.
3075 Item
:= First
(Context_Items
(N
));
3076 while Present
(Item
)
3077 and then Nkind
(Item
) = N_Pragma
3078 and then Chars
(Item
) in Configuration_Pragma_Names
3083 -- Loop through the actual context clause items. We process everything
3084 -- except Limited_With clauses in this routine. Limited_With clauses
3085 -- are separately installed (see Install_Limited_Context_Clauses).
3087 while Present
(Item
) loop
3089 -- Case of explicit WITH clause
3091 if Nkind
(Item
) = N_With_Clause
3092 and then not Implicit_With
(Item
)
3094 if Limited_Present
(Item
) then
3096 -- Limited withed units will be installed later
3100 -- If Name (Item) is not an entity name, something is wrong, and
3101 -- this will be detected in due course, for now ignore the item
3103 elsif not Is_Entity_Name
(Name
(Item
)) then
3106 elsif No
(Entity
(Name
(Item
))) then
3107 Set_Entity
(Name
(Item
), Any_Id
);
3111 Uname_Node
:= Entity
(Name
(Item
));
3113 if Is_Private_Descendant
(Uname_Node
) then
3114 Check_Private
:= True;
3117 Install_Withed_Unit
(Item
);
3119 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
3121 -- If the unit is a subprogram instance, it appears nested
3122 -- within a package that carries the parent information.
3124 if Is_Generic_Instance
(Uname_Node
)
3125 and then Ekind
(Uname_Node
) /= E_Package
3127 Decl_Node
:= Parent
(Parent
(Decl_Node
));
3130 if Is_Child_Spec
(Decl_Node
) then
3131 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
3132 Expand_With_Clause
(Item
, Prefix
(Name
(Item
)), N
);
3134 -- if not an expanded name, the child unit must be a
3135 -- renaming, nothing to do.
3140 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
3141 and then not Acts_As_Spec
(Parent
(Decl_Node
))
3142 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
3144 Implicit_With_On_Parent
3145 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
3148 -- Check license conditions unless this is a dummy unit
3150 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
3151 License_Check
: declare
3153 Withu
: constant Unit_Number_Type
:=
3154 Get_Source_Unit
(Library_Unit
(Item
));
3156 Withl
: constant License_Type
:=
3157 License
(Source_Index
(Withu
));
3159 Unitl
: constant License_Type
:=
3160 License
(Source_Index
(Current_Sem_Unit
));
3162 procedure License_Error
;
3163 -- Signal error of bad license
3169 procedure License_Error
is
3172 ("?license of with'ed unit & may be inconsistent",
3176 -- Start of processing for License_Check
3179 -- Exclude license check if withed unit is an internal unit.
3180 -- This situation arises e.g. with the GPL version of GNAT.
3182 if Is_Internal_File_Name
(Unit_File_Name
(Withu
)) then
3185 -- Otherwise check various cases
3197 if Withl
= Restricted
then
3201 when Modified_GPL
=>
3202 if Withl
= Restricted
or else Withl
= GPL
then
3206 when Unrestricted
=>
3213 -- Case of USE PACKAGE clause
3215 elsif Nkind
(Item
) = N_Use_Package_Clause
then
3216 Analyze_Use_Package
(Item
);
3218 -- Case of USE TYPE clause
3220 elsif Nkind
(Item
) = N_Use_Type_Clause
then
3221 Analyze_Use_Type
(Item
);
3223 -- Case of WITH TYPE clause
3225 -- A With_Type_Clause is processed when installing the context,
3226 -- because it is a visibility mechanism and does not create a
3227 -- semantic dependence on other units, as a With_Clause does.
3229 elsif Nkind
(Item
) = N_With_Type_Clause
then
3230 Analyze_With_Type_Clause
(Item
);
3234 elsif Nkind
(Item
) = N_Pragma
then
3242 if Is_Child_Spec
(Lib_Unit
) then
3244 -- The unit also has implicit withs on its own parents
3246 if No
(Context_Items
(N
)) then
3247 Set_Context_Items
(N
, New_List
);
3250 Implicit_With_On_Parent
(Lib_Unit
, N
);
3253 -- If the unit is a body, the context of the specification must also
3256 if Nkind
(Lib_Unit
) = N_Package_Body
3257 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3258 and then not Acts_As_Spec
(N
))
3260 Install_Context
(Library_Unit
(N
));
3262 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
3264 -- If the unit is the body of a public child unit, the private
3265 -- declarations of the parent must be made visible. If the child
3266 -- unit is private, the private declarations have been installed
3267 -- already in the call to Install_Parents for the spec. Installing
3268 -- private declarations must be done for all ancestors of public
3269 -- child units. In addition, sibling units mentioned in the
3270 -- context clause of the body are directly visible.
3278 Lib_Spec
:= Unit
(Library_Unit
(N
));
3279 while Is_Child_Spec
(Lib_Spec
) loop
3280 P
:= Unit
(Parent_Spec
(Lib_Spec
));
3281 P_Name
:= Defining_Entity
(P
);
3283 if not (Private_Present
(Parent
(Lib_Spec
)))
3284 and then not In_Private_Part
(P_Name
)
3286 Install_Private_Declarations
(P_Name
);
3287 Install_Private_With_Clauses
(P_Name
);
3288 Set_Use
(Private_Declarations
(Specification
(P
)));
3296 -- For a package body, children in context are immediately visible
3298 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
3301 if Nkind
(Lib_Unit
) = N_Generic_Package_Declaration
3302 or else Nkind
(Lib_Unit
) = N_Generic_Subprogram_Declaration
3303 or else Nkind
(Lib_Unit
) = N_Package_Declaration
3304 or else Nkind
(Lib_Unit
) = N_Subprogram_Declaration
3306 if Is_Child_Spec
(Lib_Unit
) then
3307 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
3308 Set_Is_Private_Descendant
3309 (Defining_Entity
(Lib_Unit
),
3310 Is_Private_Descendant
(Lib_Parent
)
3311 or else Private_Present
(Parent
(Lib_Unit
)));
3314 Set_Is_Private_Descendant
3315 (Defining_Entity
(Lib_Unit
),
3316 Private_Present
(Parent
(Lib_Unit
)));
3320 if Check_Private
then
3321 Check_Private_Child_Unit
(N
);
3323 end Install_Context_Clauses
;
3325 -------------------------------------
3326 -- Install_Limited_Context_Clauses --
3327 -------------------------------------
3329 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
3332 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
);
3333 -- Check that the unlimited view of a given compilation_unit is not
3334 -- already visible through "use + renamings".
3336 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
);
3337 -- Check that if a limited_with clause of a given compilation_unit
3338 -- mentions a descendant of a private child of some library unit,
3339 -- then the given compilation_unit shall be the declaration of a
3340 -- private descendant of that library unit.
3342 procedure Expand_Limited_With_Clause
3343 (Comp_Unit
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
3344 -- If a child unit appears in a limited_with clause, there are implicit
3345 -- limited_with clauses on all parents that are not already visible
3346 -- through a regular with clause. This procedure creates the implicit
3347 -- limited with_clauses for the parents and loads the corresponding
3348 -- units. The shadow entities are created when the inserted clause is
3349 -- analyzed. Implements Ada 2005 (AI-50217).
3351 ---------------------
3352 -- Check_Renamings --
3353 ---------------------
3355 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
) is
3364 pragma Assert
(Nkind
(W
) = N_With_Clause
);
3366 -- Protect the frontend against previous critical errors
3368 case Nkind
(Unit
(Library_Unit
(W
))) is
3369 when N_Subprogram_Declaration |
3370 N_Package_Declaration |
3371 N_Generic_Subprogram_Declaration |
3372 N_Generic_Package_Declaration
=>
3379 -- Check "use + renamings"
3381 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
3382 Spec
:= Specification
(Unit
(P
));
3384 Item
:= First
(Visible_Declarations
(Spec
));
3385 while Present
(Item
) loop
3387 if Nkind
(Item
) = N_Use_Package_Clause
then
3389 -- Traverse the list of packages
3391 Nam
:= First
(Names
(Item
));
3392 while Present
(Nam
) loop
3395 pragma Assert
(Present
(Parent
(E
)));
3397 if Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
3398 and then Renamed_Entity
(E
) = WEnt
3400 Error_Msg_N
("unlimited view visible through " &
3401 "use clause and renamings", W
);
3404 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
3406 -- The use clause may refer to a local package.
3407 -- Check all the enclosing scopes.
3410 while E2
/= Standard_Standard
3411 and then E2
/= WEnt
loop
3417 ("unlimited view visible through use clause ", W
);
3430 -- Recursive call to check all the ancestors
3432 if Is_Child_Spec
(Unit
(P
)) then
3433 Check_Renamings
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
3435 end Check_Renamings
;
3437 ---------------------------------------
3438 -- Check_Private_Limited_Withed_Unit --
3439 ---------------------------------------
3441 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
) is
3442 Curr_Parent
: Node_Id
;
3443 Child_Parent
: Node_Id
;
3446 -- Compilation unit of the parent of the withed library unit
3448 Child_Parent
:= Parent_Spec
(Unit
(Library_Unit
(Item
)));
3450 -- If the child unit is a public child, then locate its nearest
3451 -- private ancestor, if any; Child_Parent will then be set to
3452 -- the parent of that ancestor.
3454 if not Private_Present
(Library_Unit
(Item
)) then
3455 while Present
(Child_Parent
)
3456 and then not Private_Present
(Child_Parent
)
3458 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3461 if No
(Child_Parent
) then
3465 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3468 -- Traverse all the ancestors of the current compilation
3469 -- unit to check if it is a descendant of named library unit.
3471 Curr_Parent
:= Parent
(Item
);
3473 while Present
(Parent_Spec
(Unit
(Curr_Parent
)))
3474 and then Curr_Parent
/= Child_Parent
3476 Curr_Parent
:= Parent_Spec
(Unit
(Curr_Parent
));
3479 if Curr_Parent
/= Child_Parent
then
3481 ("unit in with clause is private child unit!", Item
);
3483 ("current unit must also have parent&!",
3484 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3486 elsif not Private_Present
(Parent
(Item
))
3487 and then not Private_Present
(Item
)
3488 and then Nkind
(Unit
(Parent
(Item
))) /= N_Package_Body
3489 and then Nkind
(Unit
(Parent
(Item
))) /= N_Subprogram_Body
3490 and then Nkind
(Unit
(Parent
(Item
))) /= N_Subunit
3493 ("current unit must also be private descendant of&",
3494 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3496 end Check_Private_Limited_Withed_Unit
;
3498 --------------------------------
3499 -- Expand_Limited_With_Clause --
3500 --------------------------------
3502 procedure Expand_Limited_With_Clause
3503 (Comp_Unit
: Node_Id
;
3507 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
3508 Unum
: Unit_Number_Type
;
3511 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean;
3512 -- Returns true if the context already includes a with_clause for
3513 -- this unit. If the with_clause is non-limited, the unit is fully
3514 -- visible and an implicit limited_with should not be created. If
3515 -- there is already a limited_with clause for W, a second one is
3516 -- simply redundant.
3518 --------------------------
3519 -- Previous_Withed_Unit --
3520 --------------------------
3522 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean is
3526 -- A limited with_clause cannot appear in the same context_clause
3527 -- as a nonlimited with_clause which mentions the same library.
3529 Item
:= First
(Context_Items
(Comp_Unit
));
3530 while Present
(Item
) loop
3531 if Nkind
(Item
) = N_With_Clause
3532 and then Library_Unit
(Item
) = Library_Unit
(W
)
3541 end Previous_Withed_Unit
;
3543 -- Start of processing for Expand_Limited_With_Clause
3546 New_Nodes_OK
:= New_Nodes_OK
+ 1;
3548 if Nkind
(Nam
) = N_Identifier
then
3550 Make_With_Clause
(Loc
,
3553 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
3555 Make_With_Clause
(Loc
,
3556 Name
=> Make_Selected_Component
(Loc
,
3557 Prefix
=> New_Copy_Tree
(Prefix
(Nam
)),
3558 Selector_Name
=> Selector_Name
(Nam
)));
3559 Set_Parent
(Withn
, Parent
(N
));
3562 Set_Limited_Present
(Withn
);
3563 Set_First_Name
(Withn
);
3564 Set_Implicit_With
(Withn
);
3568 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
3573 -- Do not generate a limited_with_clause on the current unit.
3574 -- This path is taken when a unit has a limited_with clause on
3575 -- one of its child units.
3577 if Unum
= Current_Sem_Unit
then
3581 Set_Library_Unit
(Withn
, Cunit
(Unum
));
3582 Set_Corresponding_Spec
3583 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
3585 if not Previous_Withed_Unit
(Withn
) then
3586 Prepend
(Withn
, Context_Items
(Parent
(N
)));
3587 Mark_Rewrite_Insertion
(Withn
);
3589 -- Add implicit limited_with_clauses for parents of child units
3590 -- mentioned in limited_with clauses.
3592 if Nkind
(Nam
) = N_Selected_Component
then
3593 Expand_Limited_With_Clause
(Comp_Unit
, Prefix
(Nam
), N
);
3598 if not Limited_View_Installed
(Withn
) then
3599 Install_Limited_Withed_Unit
(Withn
);
3603 New_Nodes_OK
:= New_Nodes_OK
- 1;
3604 end Expand_Limited_With_Clause
;
3606 -- Start of processing for Install_Limited_Context_Clauses
3609 Item
:= First
(Context_Items
(N
));
3610 while Present
(Item
) loop
3611 if Nkind
(Item
) = N_With_Clause
3612 and then Limited_Present
(Item
)
3614 if Nkind
(Name
(Item
)) = N_Selected_Component
then
3615 Expand_Limited_With_Clause
3616 (Comp_Unit
=> N
, Nam
=> Prefix
(Name
(Item
)), N
=> Item
);
3619 Check_Private_Limited_Withed_Unit
(Item
);
3621 if not Implicit_With
(Item
)
3622 and then Is_Child_Spec
(Unit
(N
))
3624 Check_Renamings
(Parent_Spec
(Unit
(N
)), Item
);
3627 -- A unit may have a limited with on itself if it has a
3628 -- limited with_clause on one of its child units. In that
3629 -- case it is already being compiled and it makes no sense
3630 -- to install its limited view.
3632 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
)
3633 and then not Limited_View_Installed
(Item
)
3635 Install_Limited_Withed_Unit
(Item
);
3638 -- All items other than Limited_With clauses are ignored (they were
3639 -- installed separately early on by Install_Context_Clause).
3647 end Install_Limited_Context_Clauses
;
3649 ---------------------
3650 -- Install_Parents --
3651 ---------------------
3653 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean) is
3660 P
:= Unit
(Parent_Spec
(Lib_Unit
));
3661 P_Name
:= Get_Parent_Entity
(P
);
3663 if Etype
(P_Name
) = Any_Type
then
3667 if Ekind
(P_Name
) = E_Generic_Package
3668 and then Nkind
(Lib_Unit
) /= N_Generic_Subprogram_Declaration
3669 and then Nkind
(Lib_Unit
) /= N_Generic_Package_Declaration
3670 and then Nkind
(Lib_Unit
) not in N_Generic_Renaming_Declaration
3673 ("child of a generic package must be a generic unit", Lib_Unit
);
3675 elsif not Is_Package_Or_Generic_Package
(P_Name
) then
3677 ("parent unit must be package or generic package", Lib_Unit
);
3678 raise Unrecoverable_Error
;
3680 elsif Present
(Renamed_Object
(P_Name
)) then
3681 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
3682 raise Unrecoverable_Error
;
3684 -- Verify that a child of an instance is itself an instance, or
3685 -- the renaming of one. Given that an instance that is a unit is
3686 -- replaced with a package declaration, check against the original
3687 -- node. The parent may be currently being instantiated, in which
3688 -- case it appears as a declaration, but the generic_parent is
3689 -- already established indicating that we deal with an instance.
3691 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
then
3693 if Nkind
(Lib_Unit
) in N_Renaming_Declaration
3694 or else Nkind
(Original_Node
(Lib_Unit
)) in N_Generic_Instantiation
3696 (Nkind
(Lib_Unit
) = N_Package_Declaration
3697 and then Present
(Generic_Parent
(Specification
(Lib_Unit
))))
3702 ("child of an instance must be an instance or renaming",
3707 -- This is the recursive call that ensures all parents are loaded
3709 if Is_Child_Spec
(P
) then
3711 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)));
3714 -- Now we can install the context for this parent
3716 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
));
3717 Install_Limited_Context_Clauses
(Parent_Spec
(Lib_Unit
));
3718 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
3720 -- The child unit is in the declarative region of the parent. The
3721 -- parent must therefore appear in the scope stack and be visible,
3722 -- as when compiling the corresponding body. If the child unit is
3723 -- private or it is a package body, private declarations must be
3724 -- accessible as well. Use declarations in the parent must also
3725 -- be installed. Finally, other child units of the same parent that
3726 -- are in the context are immediately visible.
3728 -- Find entity for compilation unit, and set its private descendant
3729 -- status as needed.
3731 E_Name
:= Defining_Entity
(Lib_Unit
);
3733 Set_Is_Child_Unit
(E_Name
);
3735 Set_Is_Private_Descendant
(E_Name
,
3736 Is_Private_Descendant
(P_Name
)
3737 or else Private_Present
(Parent
(Lib_Unit
)));
3739 P_Spec
:= Specification
(Unit_Declaration_Node
(P_Name
));
3742 -- Save current visibility of unit
3744 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
3745 Is_Immediately_Visible
(P_Name
);
3746 Set_Is_Immediately_Visible
(P_Name
);
3747 Install_Visible_Declarations
(P_Name
);
3748 Set_Use
(Visible_Declarations
(P_Spec
));
3750 -- If the parent is a generic unit, its formal part may contain
3751 -- formal packages and use clauses for them.
3753 if Ekind
(P_Name
) = E_Generic_Package
then
3754 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
3758 or else Private_Present
(Parent
(Lib_Unit
))
3760 Install_Private_Declarations
(P_Name
);
3761 Install_Private_With_Clauses
(P_Name
);
3762 Set_Use
(Private_Declarations
(P_Spec
));
3764 end Install_Parents
;
3766 ----------------------------------
3767 -- Install_Private_With_Clauses --
3768 ----------------------------------
3770 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
3771 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
3775 if Debug_Flag_I
then
3776 Write_Str
("install private with clauses of ");
3777 Write_Name
(Chars
(P
));
3781 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
3782 Item
:= First
(Context_Items
(Parent
(Decl
)));
3783 while Present
(Item
) loop
3784 if Nkind
(Item
) = N_With_Clause
3785 and then Private_Present
(Item
)
3787 if Limited_Present
(Item
) then
3788 if not Limited_View_Installed
(Item
) then
3789 Install_Limited_Withed_Unit
(Item
);
3792 Install_Withed_Unit
(Item
, Private_With_OK
=> True);
3799 end Install_Private_With_Clauses
;
3801 ----------------------
3802 -- Install_Siblings --
3803 ----------------------
3805 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
3810 -- Iterate over explicit with clauses, and check whether the
3811 -- scope of each entity is an ancestor of the current unit.
3813 Item
:= First
(Context_Items
(N
));
3814 while Present
(Item
) loop
3816 -- Do not install private_with_clauses if the unit is a package
3817 -- declaration, unless it is itself a private child unit.
3819 if Nkind
(Item
) = N_With_Clause
3820 and then not Implicit_With
(Item
)
3821 and then not Limited_Present
(Item
)
3823 (not Private_Present
(Item
)
3824 or else Nkind
(Unit
(N
)) /= N_Package_Declaration
3825 or else Private_Present
(N
))
3827 Id
:= Entity
(Name
(Item
));
3829 if Is_Child_Unit
(Id
)
3830 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
3832 Set_Is_Immediately_Visible
(Id
);
3834 -- Check for the presence of another unit in the context,
3835 -- that may be inadvertently hidden by the child.
3837 Prev
:= Current_Entity
(Id
);
3840 and then Is_Immediately_Visible
(Prev
)
3841 and then not Is_Child_Unit
(Prev
)
3847 Clause
:= First
(Context_Items
(N
));
3848 while Present
(Clause
) loop
3849 if Nkind
(Clause
) = N_With_Clause
3850 and then Entity
(Name
(Clause
)) = Prev
3853 ("child unit& hides compilation unit " &
3854 "with the same name?",
3864 -- the With_Clause may be on a grand-child, which makes
3865 -- the child immediately visible.
3867 elsif Is_Child_Unit
(Scope
(Id
))
3868 and then Is_Ancestor_Package
(Scope
(Scope
(Id
)), U_Name
)
3870 Set_Is_Immediately_Visible
(Scope
(Id
));
3876 end Install_Siblings
;
3878 -------------------------------
3879 -- Install_Limited_With_Unit --
3880 -------------------------------
3882 procedure Install_Limited_Withed_Unit
(N
: Node_Id
) is
3883 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
3885 Is_Child_Package
: Boolean := False;
3887 Lim_Header
: Entity_Id
;
3888 Lim_Typ
: Entity_Id
;
3890 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean;
3891 -- Check if some package installed though normal with-clauses has a
3892 -- renaming declaration of package P. AARM 10.1.2(21/2).
3894 ----------------------------------
3895 -- Is_Visible_Through_Renamings --
3896 ----------------------------------
3898 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean is
3899 Kind
: constant Node_Kind
:=
3900 Nkind
(Unit
(Cunit
(Current_Sem_Unit
)));
3906 -- Example of the error detected by this subprogram:
3914 -- package Ren_P renames P;
3920 -- limited with P; -- ERROR
3921 -- package R.C is ...
3923 Aux_Unit
:= Cunit
(Current_Sem_Unit
);
3926 Item
:= First
(Context_Items
(Aux_Unit
));
3927 while Present
(Item
) loop
3928 if Nkind
(Item
) = N_With_Clause
3929 and then not Limited_Present
(Item
)
3930 and then Nkind
(Unit
(Library_Unit
(Item
)))
3931 = N_Package_Declaration
3934 First
(Visible_Declarations
3935 (Specification
(Unit
(Library_Unit
(Item
)))));
3936 while Present
(Decl
) loop
3937 if Nkind
(Decl
) = N_Package_Renaming_Declaration
3938 and then Entity
(Name
(Decl
)) = P
3940 -- Generate the error message only if the current unit
3941 -- is a package declaration; in case of subprogram
3942 -- bodies and package bodies we just return true to
3943 -- indicate that the limited view must not be
3946 if Kind
= N_Package_Declaration
then
3947 Error_Msg_Sloc
:= Sloc
(Item
);
3949 ("unlimited view of & visible through the context"
3950 & " clause found #", N
, P
);
3952 Error_Msg_Sloc
:= Sloc
(Decl
);
3954 ("unlimited view of & visible through the"
3955 & " renaming found #", N
, P
);
3958 ("simultaneous visibility of the limited and"
3959 & " unlimited views not allowed", N
);
3972 if Present
(Library_Unit
(Aux_Unit
)) then
3973 if Aux_Unit
= Library_Unit
(Aux_Unit
) then
3975 -- Aux_Unit is a body that acts as a spec. Clause has
3976 -- already been flagged as illegal.
3981 Aux_Unit
:= Library_Unit
(Aux_Unit
);
3984 Aux_Unit
:= Parent_Spec
(Unit
(Aux_Unit
));
3987 exit when No
(Aux_Unit
);
3991 end Is_Visible_Through_Renamings
;
3993 -- Start of processing for Install_Limited_Withed_Unit
3996 pragma Assert
(not Limited_View_Installed
(N
));
3998 -- In case of limited with_clause on subprograms, generics, instances,
3999 -- or renamings, the corresponding error was previously posted and we
4000 -- have nothing to do here.
4002 if Nkind
(P_Unit
) /= N_Package_Declaration
then
4006 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
4008 -- Handle child packages
4010 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
4011 Is_Child_Package
:= True;
4012 P
:= Defining_Identifier
(P
);
4015 -- Do not install the limited-view if the full-view is already visible
4016 -- through renaming declarations.
4018 if Is_Visible_Through_Renamings
(P
) then
4022 -- A common use of the limited-with is to have a limited-with
4023 -- in the package spec, and a normal with in its package body.
4026 -- limited with X; -- [1]
4030 -- package body A is ...
4032 -- The compilation of A's body installs the context clauses found at [2]
4033 -- and then the context clauses of its specification (found at [1]). As
4034 -- a consequence, at [1] the specification of X has been analyzed and it
4035 -- is immediately visible. According to the semantics of limited-with
4036 -- context clauses we don't install the limited view because the full
4037 -- view of X supersedes its limited view.
4039 if Analyzed
(P_Unit
)
4040 and then (Is_Immediately_Visible
(P
)
4041 or else (Is_Child_Package
4042 and then Is_Visible_Child_Unit
(P
)))
4044 -- Ada 2005 (AI-262): Install the private declarations of P
4046 if Private_Present
(N
)
4047 and then not In_Private_Part
(P
)
4053 Id
:= First_Private_Entity
(P
);
4054 while Present
(Id
) loop
4055 if not Is_Internal
(Id
)
4056 and then not Is_Child_Unit
(Id
)
4058 if not In_Chain
(Id
) then
4059 Set_Homonym
(Id
, Current_Entity
(Id
));
4060 Set_Current_Entity
(Id
);
4063 Set_Is_Immediately_Visible
(Id
);
4069 Set_In_Private_Part
(P
);
4076 if Debug_Flag_I
then
4077 Write_Str
("install limited view of ");
4078 Write_Name
(Chars
(P
));
4082 -- If the unit has not been analyzed and the limited view has not been
4083 -- already installed then we install it.
4085 if not Analyzed
(P_Unit
) then
4086 if not In_Chain
(P
) then
4088 -- Minimum decoration
4090 Set_Ekind
(P
, E_Package
);
4091 Set_Etype
(P
, Standard_Void_Type
);
4092 Set_Scope
(P
, Standard_Standard
);
4094 if Is_Child_Package
then
4095 Set_Is_Child_Unit
(P
);
4096 Set_Is_Visible_Child_Unit
(P
);
4097 Set_Scope
(P
, Defining_Entity
(Unit
(Parent_Spec
(P_Unit
))));
4100 -- Place entity on visibility structure
4102 Set_Homonym
(P
, Current_Entity
(P
));
4103 Set_Current_Entity
(P
);
4105 if Debug_Flag_I
then
4106 Write_Str
(" (homonym) chain ");
4107 Write_Name
(Chars
(P
));
4111 -- Install the incomplete view. The first element of the limited
4112 -- view is a header (an E_Package entity) used to reference the
4113 -- first shadow entity in the private part of the package.
4115 Lim_Header
:= Limited_View
(P
);
4116 Lim_Typ
:= First_Entity
(Lim_Header
);
4118 while Present
(Lim_Typ
)
4119 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4121 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
4122 Set_Current_Entity
(Lim_Typ
);
4124 if Debug_Flag_I
then
4125 Write_Str
(" (homonym) chain ");
4126 Write_Name
(Chars
(Lim_Typ
));
4130 Next_Entity
(Lim_Typ
);
4134 -- If the unit appears in a previous regular with_clause, the regular
4135 -- entities of the public part of the withed package must be replaced
4136 -- by the shadow ones.
4138 -- This code must be kept synchronized with the code that replaces the
4139 -- the shadow entities by the real entities (see body of Remove_Limited
4140 -- With_Clause); otherwise the contents of the homonym chains are not
4144 -- Hide all the type entities of the public part of the package to
4145 -- avoid its usage. This is needed to cover all the subtype decla-
4146 -- rations because we do not remove them from the homonym chain.
4152 E
:= First_Entity
(P
);
4153 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
4155 Set_Was_Hidden
(E
, Is_Hidden
(E
));
4163 -- Replace the real entities by the shadow entities of the limited
4164 -- view. The first element of the limited view is a header that is
4165 -- used to reference the first shadow entity in the private part
4168 Lim_Header
:= Limited_View
(P
);
4170 Lim_Typ
:= First_Entity
(Lim_Header
);
4171 while Present
(Lim_Typ
)
4172 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4174 pragma Assert
(not In_Chain
(Lim_Typ
));
4176 -- Do not unchain child units
4178 if not Is_Child_Unit
(Lim_Typ
) then
4183 Set_Homonym
(Lim_Typ
, Homonym
(Non_Limited_View
(Lim_Typ
)));
4184 Prev
:= Current_Entity
(Lim_Typ
);
4186 if Prev
= Non_Limited_View
(Lim_Typ
) then
4187 Set_Current_Entity
(Lim_Typ
);
4189 while Present
(Prev
)
4190 and then Homonym
(Prev
) /= Non_Limited_View
(Lim_Typ
)
4192 Prev
:= Homonym
(Prev
);
4195 Set_Homonym
(Prev
, Lim_Typ
);
4199 if Debug_Flag_I
then
4200 Write_Str
(" (homonym) chain ");
4201 Write_Name
(Chars
(Lim_Typ
));
4206 Next_Entity
(Lim_Typ
);
4210 -- The package must be visible while the limited-with clause is active
4211 -- because references to the type P.T must resolve in the usual way.
4212 -- In addition, we remember that the limited-view has been installed to
4213 -- uninstall it at the point of context removal.
4215 Set_Is_Immediately_Visible
(P
);
4216 Set_Limited_View_Installed
(N
);
4218 -- If the package in the limited_with clause is a child unit, the
4219 -- clause is unanalyzed and appears as a selected component. Recast
4220 -- it as an expanded name so that the entity can be properly set. Use
4221 -- entity of parent, if available, for higher ancestors in the name.
4223 if Nkind
(Name
(N
)) = N_Selected_Component
then
4230 while Nkind
(Nam
) = N_Selected_Component
4231 and then Present
(Ent
)
4233 Change_Selected_Component_To_Expanded_Name
(Nam
);
4234 Nam
:= Prefix
(Nam
);
4240 Set_Entity
(Name
(N
), P
);
4241 Set_From_With_Type
(P
);
4242 end Install_Limited_Withed_Unit
;
4244 -------------------------
4245 -- Install_Withed_Unit --
4246 -------------------------
4248 procedure Install_Withed_Unit
4249 (With_Clause
: Node_Id
;
4250 Private_With_OK
: Boolean := False)
4252 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
4253 P
: constant Entity_Id
:= Scope
(Uname
);
4256 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
4257 -- compiling a package declaration and the Private_With_OK flag was not
4258 -- set by the caller. These declarations will be installed later (before
4259 -- analyzing the private part of the package).
4261 if Private_Present
(With_Clause
)
4262 and then Nkind
(Unit
(Parent
(With_Clause
))) = N_Package_Declaration
4263 and then not (Private_With_OK
)
4268 if Debug_Flag_I
then
4269 if Private_Present
(With_Clause
) then
4270 Write_Str
("install private withed unit ");
4272 Write_Str
("install withed unit ");
4275 Write_Name
(Chars
(Uname
));
4279 -- We do not apply the restrictions to an internal unit unless
4280 -- we are compiling the internal unit as a main unit. This check
4281 -- is also skipped for dummy units (for missing packages).
4283 if Sloc
(Uname
) /= No_Location
4284 and then (not Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
4285 or else Current_Sem_Unit
= Main_Unit
)
4287 Check_Restricted_Unit
4288 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
4291 if P
/= Standard_Standard
then
4293 -- If the unit is not analyzed after analysis of the with clause and
4294 -- it is an instantiation then it awaits a body and is the main unit.
4295 -- Its appearance in the context of some other unit indicates a
4296 -- circular dependency (DEC suite perversity).
4298 if not Analyzed
(Uname
)
4299 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
4302 ("instantiation depends on itself", Name
(With_Clause
));
4304 elsif not Is_Visible_Child_Unit
(Uname
) then
4305 Set_Is_Visible_Child_Unit
(Uname
);
4307 -- If the child unit appears in the context of its parent, it is
4308 -- immediately visible.
4310 if In_Open_Scopes
(Scope
(Uname
)) then
4311 Set_Is_Immediately_Visible
(Uname
);
4314 if Is_Generic_Instance
(Uname
)
4315 and then Ekind
(Uname
) in Subprogram_Kind
4317 -- Set flag as well on the visible entity that denotes the
4318 -- instance, which renames the current one.
4320 Set_Is_Visible_Child_Unit
4322 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
4325 -- The parent unit may have been installed already, and may have
4326 -- appeared in a use clause.
4328 if In_Use
(Scope
(Uname
)) then
4329 Set_Is_Potentially_Use_Visible
(Uname
);
4332 Set_Context_Installed
(With_Clause
);
4335 elsif not Is_Immediately_Visible
(Uname
) then
4336 if not Private_Present
(With_Clause
)
4337 or else Private_With_OK
4339 Set_Is_Immediately_Visible
(Uname
);
4342 Set_Context_Installed
(With_Clause
);
4345 -- A with-clause overrides a with-type clause: there are no restric-
4346 -- tions on the use of package entities.
4348 if Ekind
(Uname
) = E_Package
then
4349 Set_From_With_Type
(Uname
, False);
4352 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
4353 -- unit if there is a visible homograph for it declared in the same
4354 -- declarative region. This pathological case can only arise when an
4355 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
4356 -- G1 has a generic child also named G2, and the context includes with_
4357 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
4358 -- of I1.G2 visible as well. If the child unit is named Standard, do
4359 -- not apply the check to the Standard package itself.
4361 if Is_Child_Unit
(Uname
)
4362 and then Is_Visible_Child_Unit
(Uname
)
4363 and then Ada_Version
>= Ada_05
4366 Decl1
: constant Node_Id
:= Unit_Declaration_Node
(P
);
4372 U2
:= Homonym
(Uname
);
4374 and U2
/= Standard_Standard
4377 Decl2
:= Unit_Declaration_Node
(P2
);
4379 if Is_Child_Unit
(U2
)
4380 and then Is_Visible_Child_Unit
(U2
)
4382 if Is_Generic_Instance
(P
)
4383 and then Nkind
(Decl1
) = N_Package_Declaration
4384 and then Generic_Parent
(Specification
(Decl1
)) = P2
4386 Error_Msg_N
("illegal with_clause", With_Clause
);
4388 ("\child unit has visible homograph" &
4389 " ('R'M 8.3(26), 10.1.1(19))",
4393 elsif Is_Generic_Instance
(P2
)
4394 and then Nkind
(Decl2
) = N_Package_Declaration
4395 and then Generic_Parent
(Specification
(Decl2
)) = P
4397 -- With_clause for child unit of instance appears before
4398 -- in the context. We want to place the error message on
4399 -- it, not on the generic child unit itself.
4402 Prev_Clause
: Node_Id
;
4405 Prev_Clause
:= First
(List_Containing
(With_Clause
));
4406 while Entity
(Name
(Prev_Clause
)) /= U2
loop
4410 pragma Assert
(Present
(Prev_Clause
));
4411 Error_Msg_N
("illegal with_clause", Prev_Clause
);
4413 ("\child unit has visible homograph" &
4414 " ('R'M 8.3(26), 10.1.1(19))",
4425 end Install_Withed_Unit
;
4431 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
4432 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
4435 return (K
in N_Generic_Declaration
or else
4436 K
in N_Generic_Instantiation
or else
4437 K
in N_Generic_Renaming_Declaration
or else
4438 K
= N_Package_Declaration
or else
4439 K
= N_Package_Renaming_Declaration
or else
4440 K
= N_Subprogram_Declaration
or else
4441 K
= N_Subprogram_Renaming_Declaration
)
4442 and then Present
(Parent_Spec
(Lib_Unit
));
4445 -----------------------
4446 -- Load_Needed_Body --
4447 -----------------------
4449 -- N is a generic unit named in a with clause, or else it is
4450 -- a unit that contains a generic unit or an inlined function.
4451 -- In order to perform an instantiation, the body of the unit
4452 -- must be present. If the unit itself is generic, we assume
4453 -- that an instantiation follows, and load and analyze the body
4454 -- unconditionally. This forces analysis of the spec as well.
4456 -- If the unit is not generic, but contains a generic unit, it
4457 -- is loaded on demand, at the point of instantiation (see ch12).
4459 procedure Load_Needed_Body
(N
: Node_Id
; OK
: out Boolean) is
4460 Body_Name
: Unit_Name_Type
;
4461 Unum
: Unit_Number_Type
;
4463 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
4464 -- The loading and analysis is done with style checks off
4467 if not GNAT_Mode
then
4468 Style_Check
:= False;
4471 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
4474 (Load_Name
=> Body_Name
,
4480 if Unum
= No_Unit
then
4484 Compiler_State
:= Analyzing
; -- reset after load
4486 if not Fatal_Error
(Unum
) or else Try_Semantics
then
4487 if Debug_Flag_L
then
4488 Write_Str
("*** Loaded generic body");
4492 Semantics
(Cunit
(Unum
));
4498 Style_Check
:= Save_Style_Check
;
4499 end Load_Needed_Body
;
4501 -------------------------
4502 -- Build_Limited_Views --
4503 -------------------------
4505 procedure Build_Limited_Views
(N
: Node_Id
) is
4506 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Library_Unit
(N
));
4507 P
: constant Entity_Id
:= Cunit_Entity
(Unum
);
4509 Spec
: Node_Id
; -- To denote a package specification
4510 Lim_Typ
: Entity_Id
; -- To denote shadow entities
4511 Comp_Typ
: Entity_Id
; -- To denote real entities
4513 Lim_Header
: Entity_Id
; -- Package entity
4514 Last_Lim_E
: Entity_Id
:= Empty
; -- Last limited entity built
4515 Last_Pub_Lim_E
: Entity_Id
; -- To set the first private entity
4517 procedure Decorate_Incomplete_Type
4520 -- Add attributes of an incomplete type to a shadow entity. The same
4521 -- attributes are placed on the real entity, so that gigi receives
4522 -- a consistent view.
4524 procedure Decorate_Package_Specification
(P
: Entity_Id
);
4525 -- Add attributes of a package entity to the entity in a package
4528 procedure Decorate_Tagged_Type
4532 -- Set basic attributes of tagged type T, including its class_wide type.
4533 -- The parameters Loc, Scope are used to decorate the class_wide type.
4535 procedure Build_Chain
4537 First_Decl
: Node_Id
);
4538 -- Construct list of shadow entities and attach it to entity of
4539 -- package that is mentioned in a limited_with clause.
4541 function New_Internal_Shadow_Entity
4542 (Kind
: Entity_Kind
;
4543 Sloc_Value
: Source_Ptr
;
4544 Id_Char
: Character) return Entity_Id
;
4545 -- Build a new internal entity and append it to the list of shadow
4546 -- entities available through the limited-header
4548 ------------------------------
4549 -- Decorate_Incomplete_Type --
4550 ------------------------------
4552 procedure Decorate_Incomplete_Type
4557 Set_Ekind
(E
, E_Incomplete_Type
);
4558 Set_Scope
(E
, Scop
);
4560 Set_Is_First_Subtype
(E
, True);
4561 Set_Stored_Constraint
(E
, No_Elist
);
4562 Set_Full_View
(E
, Empty
);
4563 Init_Size_Align
(E
);
4564 end Decorate_Incomplete_Type
;
4566 --------------------------
4567 -- Decorate_Tagged_Type --
4568 --------------------------
4570 procedure Decorate_Tagged_Type
4578 Decorate_Incomplete_Type
(T
, Scop
);
4579 Set_Is_Tagged_Type
(T
);
4581 -- Build corresponding class_wide type, if not previously done
4583 if No
(Class_Wide_Type
(T
)) then
4584 CW
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
4586 Set_Ekind
(CW
, E_Class_Wide_Type
);
4588 Set_Scope
(CW
, Scop
);
4589 Set_Is_Tagged_Type
(CW
);
4590 Set_Is_First_Subtype
(CW
, True);
4591 Init_Size_Align
(CW
);
4592 Set_Has_Unknown_Discriminants
(CW
, True);
4593 Set_Class_Wide_Type
(CW
, CW
);
4594 Set_Equivalent_Type
(CW
, Empty
);
4595 Set_From_With_Type
(CW
, From_With_Type
(T
));
4597 Set_Class_Wide_Type
(T
, CW
);
4599 end Decorate_Tagged_Type
;
4601 ------------------------------------
4602 -- Decorate_Package_Specification --
4603 ------------------------------------
4605 procedure Decorate_Package_Specification
(P
: Entity_Id
) is
4607 -- Place only the most basic attributes
4609 Set_Ekind
(P
, E_Package
);
4610 Set_Etype
(P
, Standard_Void_Type
);
4611 end Decorate_Package_Specification
;
4613 -------------------------
4614 -- New_Internal_Entity --
4615 -------------------------
4617 function New_Internal_Shadow_Entity
4618 (Kind
: Entity_Kind
;
4619 Sloc_Value
: Source_Ptr
;
4620 Id_Char
: Character) return Entity_Id
4622 E
: constant Entity_Id
:=
4623 Make_Defining_Identifier
(Sloc_Value
,
4624 Chars
=> New_Internal_Name
(Id_Char
));
4627 Set_Ekind
(E
, Kind
);
4628 Set_Is_Internal
(E
, True);
4630 if Kind
in Type_Kind
then
4631 Init_Size_Align
(E
);
4634 Append_Entity
(E
, Lim_Header
);
4637 end New_Internal_Shadow_Entity
;
4643 procedure Build_Chain
4645 First_Decl
: Node_Id
)
4647 Analyzed_Unit
: constant Boolean := Analyzed
(Cunit
(Unum
));
4648 Is_Tagged
: Boolean;
4653 while Present
(Decl
) loop
4655 -- For each library_package_declaration in the environment, there
4656 -- is an implicit declaration of a *limited view* of that library
4657 -- package. The limited view of a package contains:
4659 -- * For each nested package_declaration, a declaration of the
4660 -- limited view of that package, with the same defining-
4661 -- program-unit name.
4663 -- * For each type_declaration in the visible part, an incomplete
4664 -- type-declaration with the same defining_identifier, whose
4665 -- completion is the type_declaration. If the type_declaration
4666 -- is tagged, then the incomplete_type_declaration is tagged
4669 if Nkind
(Decl
) = N_Full_Type_Declaration
then
4671 Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
4672 and then Tagged_Present
(Type_Definition
(Decl
));
4674 Comp_Typ
:= Defining_Identifier
(Decl
);
4676 if not Analyzed_Unit
then
4678 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
);
4680 Decorate_Incomplete_Type
(Comp_Typ
, Scope
);
4684 -- Create shadow entity for type
4686 Lim_Typ
:= New_Internal_Shadow_Entity
4687 (Kind
=> Ekind
(Comp_Typ
),
4688 Sloc_Value
=> Sloc
(Comp_Typ
),
4691 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
4692 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
4693 Set_From_With_Type
(Lim_Typ
);
4696 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
4698 Decorate_Incomplete_Type
(Lim_Typ
, Scope
);
4701 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
4703 elsif Nkind
(Decl
) = N_Private_Type_Declaration
then
4704 Comp_Typ
:= Defining_Identifier
(Decl
);
4706 if not Analyzed_Unit
then
4707 if Tagged_Present
(Decl
) then
4708 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
);
4710 Decorate_Incomplete_Type
(Comp_Typ
, Scope
);
4714 Lim_Typ
:= New_Internal_Shadow_Entity
4715 (Kind
=> Ekind
(Comp_Typ
),
4716 Sloc_Value
=> Sloc
(Comp_Typ
),
4719 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
4720 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
4721 Set_From_With_Type
(Lim_Typ
);
4723 if Tagged_Present
(Decl
) then
4724 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
4726 Decorate_Incomplete_Type
(Lim_Typ
, Scope
);
4729 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
4731 elsif Nkind
(Decl
) = N_Private_Extension_Declaration
then
4732 Comp_Typ
:= Defining_Identifier
(Decl
);
4734 if not Analyzed_Unit
then
4735 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
);
4738 -- Create shadow entity for type
4740 Lim_Typ
:= New_Internal_Shadow_Entity
4741 (Kind
=> Ekind
(Comp_Typ
),
4742 Sloc_Value
=> Sloc
(Comp_Typ
),
4745 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
4746 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
4747 Set_From_With_Type
(Lim_Typ
);
4749 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
4750 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
4752 elsif Nkind
(Decl
) = N_Package_Declaration
then
4757 Spec
: constant Node_Id
:= Specification
(Decl
);
4760 Comp_Typ
:= Defining_Unit_Name
(Spec
);
4762 if not Analyzed
(Cunit
(Unum
)) then
4763 Decorate_Package_Specification
(Comp_Typ
);
4764 Set_Scope
(Comp_Typ
, Scope
);
4767 Lim_Typ
:= New_Internal_Shadow_Entity
4768 (Kind
=> Ekind
(Comp_Typ
),
4769 Sloc_Value
=> Sloc
(Comp_Typ
),
4772 Decorate_Package_Specification
(Lim_Typ
);
4773 Set_Scope
(Lim_Typ
, Scope
);
4775 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
4776 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
4777 Set_From_With_Type
(Lim_Typ
);
4779 -- Note: The non_limited_view attribute is not used
4780 -- for local packages.
4784 First_Decl
=> First
(Visible_Declarations
(Spec
)));
4792 -- Start of processing for Build_Limited_Views
4795 pragma Assert
(Limited_Present
(N
));
4797 -- A library_item mentioned in a limited_with_clause shall be
4798 -- a package_declaration, not a subprogram_declaration,
4799 -- generic_declaration, generic_instantiation, or
4800 -- package_renaming_declaration
4802 case Nkind
(Unit
(Library_Unit
(N
))) is
4804 when N_Package_Declaration
=>
4807 when N_Subprogram_Declaration
=>
4808 Error_Msg_N
("subprograms not allowed in "
4809 & "limited with_clauses", N
);
4812 when N_Generic_Package_Declaration |
4813 N_Generic_Subprogram_Declaration
=>
4814 Error_Msg_N
("generics not allowed in "
4815 & "limited with_clauses", N
);
4818 when N_Generic_Instantiation
=>
4819 Error_Msg_N
("generic instantiations not allowed in "
4820 & "limited with_clauses", N
);
4823 when N_Generic_Renaming_Declaration
=>
4824 Error_Msg_N
("generic renamings not allowed in "
4825 & "limited with_clauses", N
);
4828 when N_Subprogram_Renaming_Declaration
=>
4829 Error_Msg_N
("renamed subprograms not allowed in "
4830 & "limited with_clauses", N
);
4833 when N_Package_Renaming_Declaration
=>
4834 Error_Msg_N
("renamed packages not allowed in "
4835 & "limited with_clauses", N
);
4839 raise Program_Error
;
4842 -- Check if the chain is already built
4844 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
4846 if Limited_View_Installed
(Spec
) then
4850 Set_Ekind
(P
, E_Package
);
4852 -- Build the header of the limited_view
4854 Lim_Header
:= Make_Defining_Identifier
(Sloc
(N
),
4855 Chars
=> New_Internal_Name
(Id_Char
=> 'Z'));
4856 Set_Ekind
(Lim_Header
, E_Package
);
4857 Set_Is_Internal
(Lim_Header
);
4858 Set_Limited_View
(P
, Lim_Header
);
4860 -- Create the auxiliary chain. All the shadow entities are appended
4861 -- to the list of entities of the limited-view header
4865 First_Decl
=> First
(Visible_Declarations
(Spec
)));
4867 -- Save the last built shadow entity. It is needed later to set the
4868 -- reference to the first shadow entity in the private part
4870 Last_Pub_Lim_E
:= Last_Lim_E
;
4872 -- Ada 2005 (AI-262): Add the limited view of the private declarations
4873 -- Required to give support to limited-private-with clauses
4875 Build_Chain
(Scope
=> P
,
4876 First_Decl
=> First
(Private_Declarations
(Spec
)));
4878 if Last_Pub_Lim_E
/= Empty
then
4879 Set_First_Private_Entity
(Lim_Header
,
4880 Next_Entity
(Last_Pub_Lim_E
));
4882 Set_First_Private_Entity
(Lim_Header
,
4886 Set_Limited_View_Installed
(Spec
);
4887 end Build_Limited_Views
;
4889 -------------------------------
4890 -- Check_Body_Needed_For_SAL --
4891 -------------------------------
4893 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
4895 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
4896 -- Determine whether use of entity E might require the presence
4897 -- of its body. For a package this requires a recursive traversal
4898 -- of all nested declarations.
4900 ---------------------------
4901 -- Entity_Needed_For_SAL --
4902 ---------------------------
4904 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
4908 if Is_Subprogram
(E
)
4909 and then Has_Pragma_Inline
(E
)
4913 elsif Ekind
(E
) = E_Generic_Function
4914 or else Ekind
(E
) = E_Generic_Procedure
4918 elsif Ekind
(E
) = E_Generic_Package
4920 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
4921 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
4925 elsif Ekind
(E
) = E_Package
4927 Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
4928 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
4930 Ent
:= First_Entity
(E
);
4931 while Present
(Ent
) loop
4932 if Entity_Needs_Body
(Ent
) then
4944 end Entity_Needs_Body
;
4946 -- Start of processing for Check_Body_Needed_For_SAL
4949 if Ekind
(Unit_Name
) = E_Generic_Package
4951 Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
4952 N_Generic_Package_Declaration
4954 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
4956 Set_Body_Needed_For_SAL
(Unit_Name
);
4958 elsif Ekind
(Unit_Name
) = E_Generic_Procedure
4959 or else Ekind
(Unit_Name
) = E_Generic_Function
4961 Set_Body_Needed_For_SAL
(Unit_Name
);
4963 elsif Is_Subprogram
(Unit_Name
)
4964 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
4965 N_Subprogram_Declaration
4966 and then Has_Pragma_Inline
(Unit_Name
)
4968 Set_Body_Needed_For_SAL
(Unit_Name
);
4970 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
4971 Check_Body_Needed_For_SAL
4972 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
4974 elsif Ekind
(Unit_Name
) = E_Package
4975 and then Entity_Needs_Body
(Unit_Name
)
4977 Set_Body_Needed_For_SAL
(Unit_Name
);
4979 elsif Ekind
(Unit_Name
) = E_Package_Body
4980 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
4982 Check_Body_Needed_For_SAL
4983 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
4985 end Check_Body_Needed_For_SAL
;
4987 --------------------
4988 -- Remove_Context --
4989 --------------------
4991 procedure Remove_Context
(N
: Node_Id
) is
4992 Lib_Unit
: constant Node_Id
:= Unit
(N
);
4995 -- If this is a child unit, first remove the parent units
4997 if Is_Child_Spec
(Lib_Unit
) then
4998 Remove_Parents
(Lib_Unit
);
5001 Remove_Context_Clauses
(N
);
5004 ----------------------------
5005 -- Remove_Context_Clauses --
5006 ----------------------------
5008 procedure Remove_Context_Clauses
(N
: Node_Id
) is
5010 Unit_Name
: Entity_Id
;
5013 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
5014 -- limited-views first and regular-views later (to maintain the
5017 -- First Phase: Remove limited_with context clauses
5019 Item
:= First
(Context_Items
(N
));
5020 while Present
(Item
) loop
5022 -- We are interested only in with clauses which got installed
5025 if Nkind
(Item
) = N_With_Clause
5026 and then Limited_Present
(Item
)
5027 and then Limited_View_Installed
(Item
)
5029 Remove_Limited_With_Clause
(Item
);
5035 -- Second Phase: Loop through context items and undo regular
5036 -- with_clauses and use_clauses.
5038 Item
:= First
(Context_Items
(N
));
5039 while Present
(Item
) loop
5041 -- We are interested only in with clauses which got installed
5042 -- on entry, as indicated by their Context_Installed flag set
5044 if Nkind
(Item
) = N_With_Clause
5045 and then Limited_Present
(Item
)
5046 and then Limited_View_Installed
(Item
)
5050 elsif Nkind
(Item
) = N_With_Clause
5051 and then Context_Installed
(Item
)
5053 -- Remove items from one with'ed unit
5055 Unit_Name
:= Entity
(Name
(Item
));
5056 Remove_Unit_From_Visibility
(Unit_Name
);
5057 Set_Context_Installed
(Item
, False);
5059 elsif Nkind
(Item
) = N_Use_Package_Clause
then
5060 End_Use_Package
(Item
);
5062 elsif Nkind
(Item
) = N_Use_Type_Clause
then
5063 End_Use_Type
(Item
);
5065 elsif Nkind
(Item
) = N_With_Type_Clause
then
5066 Remove_With_Type_Clause
(Name
(Item
));
5071 end Remove_Context_Clauses
;
5073 --------------------------------
5074 -- Remove_Limited_With_Clause --
5075 --------------------------------
5077 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
5078 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
5080 Lim_Header
: Entity_Id
;
5081 Lim_Typ
: Entity_Id
;
5085 pragma Assert
(Limited_View_Installed
(N
));
5087 -- In case of limited with_clause on subprograms, generics, instances,
5088 -- or renamings, the corresponding error was previously posted and we
5089 -- have nothing to do here.
5091 if Nkind
(P_Unit
) /= N_Package_Declaration
then
5095 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
5097 -- Handle child packages
5099 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
5100 P
:= Defining_Identifier
(P
);
5103 if Debug_Flag_I
then
5104 Write_Str
("remove limited view of ");
5105 Write_Name
(Chars
(P
));
5106 Write_Str
(" from visibility");
5110 -- Prepare the removal of the shadow entities from visibility. The
5111 -- first element of the limited view is a header (an E_Package
5112 -- entity) that is used to reference the first shadow entity in the
5113 -- private part of the package
5115 Lim_Header
:= Limited_View
(P
);
5116 Lim_Typ
:= First_Entity
(Lim_Header
);
5118 -- Remove package and shadow entities from visibility if it has not
5121 if not Analyzed
(P_Unit
) then
5123 Set_Is_Immediately_Visible
(P
, False);
5125 while Present
(Lim_Typ
) loop
5127 Next_Entity
(Lim_Typ
);
5130 -- Otherwise this package has already appeared in the closure and its
5131 -- shadow entities must be replaced by its real entities. This code
5132 -- must be kept synchronized with the complementary code in Install
5133 -- Limited_Withed_Unit.
5136 -- Real entities that are type or subtype declarations were hidden
5137 -- from visibility at the point of installation of the limited-view.
5138 -- Now we recover the previous value of the hidden attribute.
5144 E
:= First_Entity
(P
);
5145 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
5147 Set_Is_Hidden
(E
, Was_Hidden
(E
));
5154 while Present
(Lim_Typ
)
5155 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
5157 pragma Assert
(not In_Chain
(Non_Limited_View
(Lim_Typ
)));
5159 -- Child units have not been unchained
5161 if not Is_Child_Unit
(Non_Limited_View
(Lim_Typ
)) then
5162 Prev
:= Current_Entity
(Lim_Typ
);
5164 if Prev
= Lim_Typ
then
5165 Set_Current_Entity
(Non_Limited_View
(Lim_Typ
));
5167 while Present
(Prev
)
5168 and then Homonym
(Prev
) /= Lim_Typ
5170 Prev
:= Homonym
(Prev
);
5173 pragma Assert
(Present
(Prev
));
5174 Set_Homonym
(Prev
, Non_Limited_View
(Lim_Typ
));
5177 -- We must also set the next homonym entity of the real entity
5178 -- to handle the case in which the next homonym was a shadow
5181 Set_Homonym
(Non_Limited_View
(Lim_Typ
), Homonym
(Lim_Typ
));
5184 Next_Entity
(Lim_Typ
);
5188 -- Indicate that the limited view of the package is not installed
5190 Set_From_With_Type
(P
, False);
5191 Set_Limited_View_Installed
(N
, False);
5192 end Remove_Limited_With_Clause
;
5194 --------------------
5195 -- Remove_Parents --
5196 --------------------
5198 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
5201 P_Spec
: Node_Id
:= Empty
;
5203 Vis
: constant Boolean :=
5204 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
5207 if Is_Child_Spec
(Lib_Unit
) then
5208 P_Spec
:= Parent_Spec
(Lib_Unit
);
5210 elsif Nkind
(Lib_Unit
) = N_Package_Body
5211 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
5213 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
5216 if Present
(P_Spec
) then
5219 P_Name
:= Get_Parent_Entity
(P
);
5220 Remove_Context_Clauses
(P_Spec
);
5221 End_Package_Scope
(P_Name
);
5222 Set_Is_Immediately_Visible
(P_Name
, Vis
);
5224 -- Remove from visibility the siblings as well, which are directly
5225 -- visible while the parent is in scope.
5227 E
:= First_Entity
(P_Name
);
5228 while Present
(E
) loop
5229 if Is_Child_Unit
(E
) then
5230 Set_Is_Immediately_Visible
(E
, False);
5236 Set_In_Package_Body
(P_Name
, False);
5238 -- This is the recursive call to remove the context of any
5239 -- higher level parent. This recursion ensures that all parents
5240 -- are removed in the reverse order of their installation.
5246 -----------------------------
5247 -- Remove_With_Type_Clause --
5248 -----------------------------
5250 procedure Remove_With_Type_Clause
(Name
: Node_Id
) is
5254 procedure Unchain
(E
: Entity_Id
);
5255 -- Remove entity from visibility list
5261 procedure Unchain
(E
: Entity_Id
) is
5265 Prev
:= Current_Entity
(E
);
5267 -- Package entity may appear is several with_type_clauses, and
5268 -- may have been removed already.
5274 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
5277 while Present
(Prev
)
5278 and then Homonym
(Prev
) /= E
5280 Prev
:= Homonym
(Prev
);
5283 if Present
(Prev
) then
5284 Set_Homonym
(Prev
, Homonym
(E
));
5289 -- Start of processing for Remove_With_Type_Clause
5292 if Nkind
(Name
) = N_Selected_Component
then
5293 Typ
:= Entity
(Selector_Name
(Name
));
5295 -- If no Typ, then error in declaration, ignore
5306 -- If the exporting package has been analyzed, it has appeared in the
5307 -- context already and should be left alone. Otherwise, remove from
5310 if not Analyzed
(Unit_Declaration_Node
(P
)) then
5313 Set_Is_Frozen
(Typ
, False);
5316 if Ekind
(Typ
) = E_Record_Type
then
5317 Set_From_With_Type
(Class_Wide_Type
(Typ
), False);
5318 Set_From_With_Type
(Typ
, False);
5321 Set_From_With_Type
(P
, False);
5323 -- If P is a child unit, remove parents as well
5327 and then P
/= Standard_Standard
5329 Set_From_With_Type
(P
, False);
5331 if not Analyzed
(Unit_Declaration_Node
(P
)) then
5338 -- The back-end needs to know that an access type is imported, so it
5339 -- does not need elaboration and can appear in a mutually recursive
5340 -- record definition, so the imported flag on an access type is
5343 end Remove_With_Type_Clause
;
5345 ---------------------------------
5346 -- Remove_Unit_From_Visibility --
5347 ---------------------------------
5349 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
5350 P
: constant Entity_Id
:= Scope
(Unit_Name
);
5354 if Debug_Flag_I
then
5355 Write_Str
("remove unit ");
5356 Write_Name
(Chars
(Unit_Name
));
5357 Write_Str
(" from visibility");
5361 if P
/= Standard_Standard
then
5362 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
5365 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
5366 Set_Is_Immediately_Visible
(Unit_Name
, False);
5368 end Remove_Unit_From_Visibility
;
5374 procedure Unchain
(E
: Entity_Id
) is
5378 Prev
:= Current_Entity
(E
);
5384 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
5387 while Present
(Prev
)
5388 and then Homonym
(Prev
) /= E
5390 Prev
:= Homonym
(Prev
);
5393 if Present
(Prev
) then
5394 Set_Homonym
(Prev
, Homonym
(E
));
5398 if Debug_Flag_I
then
5399 Write_Str
(" (homonym) unchain ");
5400 Write_Name
(Chars
(E
));