1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Exp_Util
; use Exp_Util
;
32 with Elists
; use Elists
;
33 with Fname
; use Fname
;
34 with Fname
.UF
; use Fname
.UF
;
35 with Freeze
; use Freeze
;
36 with Impunit
; use Impunit
;
37 with Inline
; use Inline
;
39 with Lib
.Load
; use Lib
.Load
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Par_SCO
; use Par_SCO
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch7
; use Sem_Ch7
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Ch13
; use Sem_Ch13
;
57 with Sem_Dist
; use Sem_Dist
;
58 with Sem_Prag
; use Sem_Prag
;
59 with Sem_Util
; use Sem_Util
;
60 with Sem_Warn
; use Sem_Warn
;
61 with Stand
; use Stand
;
62 with Sinfo
; use Sinfo
;
63 with Sinfo
.CN
; use Sinfo
.CN
;
64 with Sinput
; use Sinput
;
65 with Snames
; use Snames
;
66 with Style
; use Style
;
67 with Stylesw
; use Stylesw
;
68 with Tbuild
; use Tbuild
;
69 with Uname
; use Uname
;
71 package body Sem_Ch10
is
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Analyze_Context
(N
: Node_Id
);
78 -- Analyzes items in the context clause of compilation unit
80 procedure Build_Limited_Views
(N
: Node_Id
);
81 -- Build and decorate the list of shadow entities for a package mentioned
82 -- in a limited_with clause. If the package was not previously analyzed
83 -- then it also performs a basic decoration of the real entities. This is
84 -- required in order to avoid passing non-decorated entities to the
85 -- back-end. Implements Ada 2005 (AI-50217).
87 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
);
88 -- Check whether the source for the body of a compilation unit must be
89 -- included in a standalone library.
91 procedure Check_Private_Child_Unit
(N
: Node_Id
);
92 -- If a with_clause mentions a private child unit, the compilation unit
93 -- must be a member of the same family, as described in 10.1.2.
95 procedure Check_Stub_Level
(N
: Node_Id
);
96 -- Verify that a stub is declared immediately within a compilation unit,
97 -- and not in an inner frame.
99 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
100 -- When a child unit appears in a context clause, the implicit withs on
101 -- parents are made explicit, and with clauses are inserted in the context
102 -- clause before the one for the child. If a parent in the with_clause
103 -- is a renaming, the implicit with_clause is on the renaming whose name
104 -- is mentioned in the with_clause, and not on the package it renames.
105 -- N is the compilation unit whose list of context items receives the
106 -- implicit with_clauses.
108 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
109 -- Generate cross-reference information for the parents of child units
110 -- and of subunits. N is a defining_program_unit_name, and P_Id is the
111 -- immediate parent scope.
113 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
;
114 -- Get defining entity of parent unit of a child unit. In most cases this
115 -- is the defining entity of the unit, but for a child instance whose
116 -- parent needs a body for inlining, the instantiation node of the parent
117 -- has not yet been rewritten as a package declaration, and the entity has
118 -- to be retrieved from the Instance_Spec of the unit.
120 function Has_With_Clause
123 Is_Limited
: Boolean := False) return Boolean;
124 -- Determine whether compilation unit C_Unit contains a [limited] with
125 -- clause for package Pack. Use the flag Is_Limited to designate desired
128 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
129 -- If the main unit is a child unit, implicit withs are also added for
130 -- all its ancestors.
132 function In_Chain
(E
: Entity_Id
) return Boolean;
133 -- Check that the shadow entity is not already in the homonym chain, for
134 -- example through a limited_with clause in a parent unit.
136 procedure Install_Context_Clauses
(N
: Node_Id
);
137 -- Subsidiary to Install_Context and Install_Parents. Process all with
138 -- and use clauses for current unit and its library unit if any.
140 procedure Install_Limited_Context_Clauses
(N
: Node_Id
);
141 -- Subsidiary to Install_Context. Process only limited with_clauses for
142 -- current unit. Implements Ada 2005 (AI-50217).
144 procedure Install_Limited_Withed_Unit
(N
: Node_Id
);
145 -- Place shadow entities for a limited_with package in the visibility
146 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
148 procedure Install_Withed_Unit
149 (With_Clause
: Node_Id
;
150 Private_With_OK
: Boolean := False);
151 -- If the unit is not a child unit, make unit immediately visible. The
152 -- caller ensures that the unit is not already currently installed. The
153 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
154 -- is called when compiling the private part of a package, or installing
155 -- the private declarations of a parent unit.
157 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean);
158 -- This procedure establishes the context for the compilation of a child
159 -- unit. If Lib_Unit is a child library spec then the context of the parent
160 -- is installed, and the parent itself made immediately visible, so that
161 -- the child unit is processed in the declarative region of the parent.
162 -- Install_Parents makes a recursive call to itself to ensure that all
163 -- parents are loaded in the nested case. If Lib_Unit is a library body,
164 -- the only effect of Install_Parents is to install the private decls of
165 -- the parents, because the visible parent declarations will have been
166 -- installed as part of the context of the corresponding spec.
168 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
169 -- In the compilation of a child unit, a child of any of the ancestor
170 -- units is directly visible if it is visible, because the parent is in
171 -- an enclosing scope. Iterate over context to find child units of U_Name
172 -- or of some ancestor of it.
174 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean;
175 -- When compiling a unit Q descended from some parent unit P, a limited
176 -- with_clause in the context of P that names some other ancestor of Q
177 -- must not be installed because the ancestor is immediately visible.
179 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
180 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
181 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
182 -- a library spec that has a parent. If the call to Is_Child_Spec returns
183 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
184 -- compilation unit for the parent spec.
186 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
187 -- Parent_Spec is non-empty, this is also a child unit.
189 procedure Remove_Context_Clauses
(N
: Node_Id
);
190 -- Subsidiary of previous one. Remove use_ and with_clauses
192 procedure Remove_Limited_With_Clause
(N
: Node_Id
);
193 -- Remove from visibility the shadow entities introduced for a package
194 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
196 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
197 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
198 -- contexts established by the corresponding call to Install_Parents are
199 -- removed. Remove_Parents contains a recursive call to itself to ensure
200 -- that all parents are removed in the nested case.
202 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
203 -- Reset all visibility flags on unit after compiling it, either as a main
204 -- unit or as a unit in the context.
206 procedure Unchain
(E
: Entity_Id
);
207 -- Remove single entity from visibility list
209 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
210 -- Common processing for all stubs (subprograms, tasks, packages, and
211 -- protected cases). N is the stub to be analyzed. Once the subunit name
212 -- is established, load and analyze. Nam is the non-overloadable entity
213 -- for which the proper body provides a completion. Subprogram stubs are
214 -- handled differently because they can be declarations.
217 -- A dummy procedure, for debugging use, called just before analyzing the
218 -- main unit (after dealing with any context clauses).
220 --------------------------
221 -- Limited_With_Clauses --
222 --------------------------
224 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
225 -- mutually recursive types declared in different units. A limited_with
226 -- clause that names package P in the context of unit U makes the types
227 -- declared in the visible part of P available within U, but with the
228 -- restriction that these types can only be used as incomplete types.
229 -- The limited_with clause does not impose a semantic dependence on P,
230 -- and it is possible for two packages to have limited_with_clauses on
231 -- each other without creating an elaboration circularity.
233 -- To support this feature, the analysis of a limited_with clause must
234 -- create an abbreviated view of the package, without performing any
235 -- semantic analysis on it. This "package abstract" contains shadow types
236 -- that are in one-one correspondence with the real types in the package,
237 -- and that have the properties of incomplete types.
239 -- The implementation creates two element lists: one to chain the shadow
240 -- entities, and one to chain the corresponding type entities in the tree
241 -- of the package. Links between corresponding entities in both chains
242 -- allow the compiler to select the proper view of a given type, depending
243 -- on the context. Note that in contrast with the handling of private
244 -- types, the limited view and the non-limited view of a type are treated
245 -- as separate entities, and no entity exchange needs to take place, which
246 -- makes the implementation must simpler than could be feared.
248 ------------------------------
249 -- Analyze_Compilation_Unit --
250 ------------------------------
252 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
253 Unit_Node
: constant Node_Id
:= Unit
(N
);
254 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
256 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
257 Par_Spec_Name
: Unit_Name_Type
;
258 Unum
: Unit_Number_Type
;
260 procedure Check_Redundant_Withs
261 (Context_Items
: List_Id
;
262 Spec_Context_Items
: List_Id
:= No_List
);
263 -- Determine whether the context list of a compilation unit contains
264 -- redundant with clauses. When checking body clauses against spec
265 -- clauses, set Context_Items to the context list of the body and
266 -- Spec_Context_Items to that of the spec. Parent packages are not
267 -- examined for documentation purposes.
269 ---------------------------
270 -- Check_Redundant_Withs --
271 ---------------------------
273 procedure Check_Redundant_Withs
274 (Context_Items
: List_Id
;
275 Spec_Context_Items
: List_Id
:= No_List
)
279 procedure Process_Body_Clauses
280 (Context_List
: List_Id
;
282 Used
: in out Boolean;
283 Used_Type_Or_Elab
: in out Boolean);
284 -- Examine the context clauses of a package body, trying to match the
285 -- name entity of Clause with any list element. If the match occurs
286 -- on a use package clause set Used to True, for a use type clause or
287 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
289 procedure Process_Spec_Clauses
290 (Context_List
: List_Id
;
292 Used
: in out Boolean;
293 Withed
: in out Boolean;
294 Exit_On_Self
: Boolean := False);
295 -- Examine the context clauses of a package spec, trying to match
296 -- the name entity of Clause with any list element. If the match
297 -- occurs on a use package clause, set Used to True, for a with
298 -- package clause other than Clause, set Withed to True. Limited
299 -- with clauses, implicitly generated with clauses and withs
300 -- having pragmas Elaborate or Elaborate_All applied to them are
301 -- skipped. Exit_On_Self is used to control the search loop and
302 -- force an exit whenever Clause sees itself in the search.
304 --------------------------
305 -- Process_Body_Clauses --
306 --------------------------
308 procedure Process_Body_Clauses
309 (Context_List
: List_Id
;
311 Used
: in out Boolean;
312 Used_Type_Or_Elab
: in out Boolean)
314 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
320 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean;
321 -- In an expanded name in a use clause, if the prefix is a renamed
322 -- package, the entity is set to the original package as a result,
323 -- when checking whether the package appears in a previous with
324 -- clause, the renaming has to be taken into account, to prevent
325 -- spurious/incorrect warnings. A common case is use of Text_IO.
331 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean is
333 return Entity
(N
) = P
334 or else (Present
(Renamed_Object
(P
))
335 and then Entity
(N
) = Renamed_Object
(P
));
338 -- Start of processing for Process_Body_Clauses
342 Used_Type_Or_Elab
:= False;
344 Cont_Item
:= First
(Context_List
);
345 while Present
(Cont_Item
) loop
347 -- Package use clause
349 if Nkind
(Cont_Item
) = N_Use_Package_Clause
352 -- Search through use clauses
354 Use_Item
:= First
(Names
(Cont_Item
));
355 while Present
(Use_Item
) and then not Used
loop
357 -- Case of a direct use of the one we are looking for
359 if Entity
(Use_Item
) = Nam_Ent
then
362 -- Handle nested case, as in "with P; use P.Q.R"
369 -- Loop through prefixes looking for match
372 while Nkind
(UE
) = N_Expanded_Name
loop
373 if Same_Unit
(Prefix
(UE
), Nam_Ent
) then
388 elsif Nkind
(Cont_Item
) = N_Use_Type_Clause
389 and then not Used_Type_Or_Elab
391 Subt_Mark
:= First
(Subtype_Marks
(Cont_Item
));
392 while Present
(Subt_Mark
)
393 and then not Used_Type_Or_Elab
395 if Same_Unit
(Prefix
(Subt_Mark
), Nam_Ent
) then
396 Used_Type_Or_Elab
:= True;
402 -- Pragma Elaborate or Elaborate_All
404 elsif Nkind
(Cont_Item
) = N_Pragma
406 Nam_In
(Pragma_Name
(Cont_Item
), Name_Elaborate
,
408 and then not Used_Type_Or_Elab
411 First
(Pragma_Argument_Associations
(Cont_Item
));
412 while Present
(Prag_Unit
) and then not Used_Type_Or_Elab
loop
413 if Entity
(Expression
(Prag_Unit
)) = Nam_Ent
then
414 Used_Type_Or_Elab
:= True;
423 end Process_Body_Clauses
;
425 --------------------------
426 -- Process_Spec_Clauses --
427 --------------------------
429 procedure Process_Spec_Clauses
430 (Context_List
: List_Id
;
432 Used
: in out Boolean;
433 Withed
: in out Boolean;
434 Exit_On_Self
: Boolean := False)
436 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
444 Cont_Item
:= First
(Context_List
);
445 while Present
(Cont_Item
) loop
447 -- Stop the search since the context items after Cont_Item have
448 -- already been examined in a previous iteration of the reverse
449 -- loop in Check_Redundant_Withs.
452 and Cont_Item
= Clause
457 -- Package use clause
459 if Nkind
(Cont_Item
) = N_Use_Package_Clause
462 Use_Item
:= First
(Names
(Cont_Item
));
463 while Present
(Use_Item
) and then not Used
loop
464 if Entity
(Use_Item
) = Nam_Ent
then
471 -- Package with clause. Avoid processing self, implicitly
472 -- generated with clauses or limited with clauses. Note that
473 -- we examine with clauses having pragmas Elaborate or
474 -- Elaborate_All applied to them due to cases such as:
478 -- pragma Elaborate (Pack);
480 -- In this case, the second with clause is redundant since
481 -- the pragma applies only to the first "with Pack;".
483 -- Note that we only consider with_clauses that comes from
484 -- source. In the case of renamings used as prefixes of names
485 -- in with_clauses, we generate a with_clause for the prefix,
486 -- which we do not treat as implicit because it is needed for
487 -- visibility analysis, but is also not redundant.
489 elsif Nkind
(Cont_Item
) = N_With_Clause
490 and then not Implicit_With
(Cont_Item
)
491 and then Comes_From_Source
(Cont_Item
)
492 and then not Limited_Present
(Cont_Item
)
493 and then Cont_Item
/= Clause
494 and then Entity
(Name
(Cont_Item
)) = Nam_Ent
501 end Process_Spec_Clauses
;
503 -- Start of processing for Check_Redundant_Withs
506 Clause
:= Last
(Context_Items
);
507 while Present
(Clause
) loop
509 -- Avoid checking implicitly generated with clauses, limited with
510 -- clauses or withs that have pragma Elaborate or Elaborate_All.
512 if Nkind
(Clause
) = N_With_Clause
513 and then not Implicit_With
(Clause
)
514 and then not Limited_Present
(Clause
)
515 and then not Elaborate_Present
(Clause
)
517 -- Package body-to-spec check
519 if Present
(Spec_Context_Items
) then
521 Used_In_Body
: Boolean := False;
522 Used_In_Spec
: Boolean := False;
523 Used_Type_Or_Elab
: Boolean := False;
524 Withed_In_Spec
: Boolean := False;
528 (Context_List
=> Spec_Context_Items
,
530 Used
=> Used_In_Spec
,
531 Withed
=> Withed_In_Spec
);
534 (Context_List
=> Context_Items
,
536 Used
=> Used_In_Body
,
537 Used_Type_Or_Elab
=> Used_Type_Or_Elab
);
539 -- "Type Elab" refers to the presence of either a use
540 -- type clause, pragmas Elaborate or Elaborate_All.
542 -- +---------------+---------------------------+------+
543 -- | Spec | Body | Warn |
544 -- +--------+------+--------+------+-----------+------+
545 -- | Withed | Used | Withed | Used | Type Elab | |
546 -- | X | | X | | | X |
547 -- | X | | X | X | | |
548 -- | X | | X | | X | |
549 -- | X | | X | X | X | |
550 -- | X | X | X | | | X |
551 -- | X | X | X | | X | |
552 -- | X | X | X | X | | X |
553 -- | X | X | X | X | X | |
554 -- +--------+------+--------+------+-----------+------+
557 and then not Used_Type_Or_Elab
)
559 ((not Used_In_Spec
and then not Used_In_Body
)
560 or else Used_In_Spec
)
562 Error_Msg_N
-- CODEFIX
563 ("redundant with clause in body??", Clause
);
566 Used_In_Body
:= False;
567 Used_In_Spec
:= False;
568 Used_Type_Or_Elab
:= False;
569 Withed_In_Spec
:= False;
572 -- Standalone package spec or body check
576 Dont_Care
: Boolean := False;
577 Withed
: Boolean := False;
580 -- The mechanism for examining the context clauses of a
581 -- package spec can be applied to package body clauses.
584 (Context_List
=> Context_Items
,
588 Exit_On_Self
=> True);
591 Error_Msg_N
-- CODEFIX
592 ("redundant with clause??", Clause
);
600 end Check_Redundant_Withs
;
602 -- Start of processing for Analyze_Compilation_Unit
605 Process_Compilation_Unit_Pragmas
(N
);
607 -- If the unit is a subunit whose parent has not been analyzed (which
608 -- indicates that the main unit is a subunit, either the current one or
609 -- one of its descendents) then the subunit is compiled as part of the
610 -- analysis of the parent, which we proceed to do. Basically this gets
611 -- handled from the top down and we don't want to do anything at this
612 -- level (i.e. this subunit will be handled on the way down from the
613 -- parent), so at this level we immediately return. If the subunit ends
614 -- up not analyzed, it means that the parent did not contain a stub for
615 -- it, or that there errors were detected in some ancestor.
617 if Nkind
(Unit_Node
) = N_Subunit
and then not Analyzed
(Lib_Unit
) then
618 Semantics
(Lib_Unit
);
620 if not Analyzed
(Proper_Body
(Unit_Node
)) then
621 if Serious_Errors_Detected
> 0 then
622 Error_Msg_N
("subunit not analyzed (errors in parent unit)", N
);
624 Error_Msg_N
("missing stub for subunit", N
);
631 -- Analyze context (this will call Sem recursively for with'ed units) To
632 -- detect circularities among with-clauses that are not caught during
633 -- loading, we set the Context_Pending flag on the current unit. If the
634 -- flag is already set there is a potential circularity. We exclude
635 -- predefined units from this check because they are known to be safe.
636 -- We also exclude package bodies that are present because circularities
637 -- between bodies are harmless (and necessary).
639 if Context_Pending
(N
) then
641 Circularity
: Boolean := True;
644 if Is_Predefined_File_Name
645 (Unit_File_Name
(Get_Source_Unit
(Unit
(N
))))
647 Circularity
:= False;
650 for U
in Main_Unit
+ 1 .. Last_Unit
loop
651 if Nkind
(Unit
(Cunit
(U
))) = N_Package_Body
652 and then not Analyzed
(Cunit
(U
))
654 Circularity
:= False;
661 Error_Msg_N
("circular dependency caused by with_clauses", N
);
663 ("\possibly missing limited_with clause"
664 & " in one of the following", N
);
666 for U
in Main_Unit
.. Last_Unit
loop
667 if Context_Pending
(Cunit
(U
)) then
668 Error_Msg_Unit_1
:= Get_Unit_Name
(Unit
(Cunit
(U
)));
669 Error_Msg_N
("\unit$", N
);
673 raise Unrecoverable_Error
;
677 Set_Context_Pending
(N
);
682 Set_Context_Pending
(N
, False);
684 -- If the unit is a package body, the spec is already loaded and must be
685 -- analyzed first, before we analyze the body.
687 if Nkind
(Unit_Node
) = N_Package_Body
then
689 -- If no Lib_Unit, then there was a serious previous error, so just
690 -- ignore the entire analysis effort
692 if No
(Lib_Unit
) then
693 Check_Error_Detected
;
697 -- Analyze the package spec
699 Semantics
(Lib_Unit
);
701 -- Check for unused with's
703 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
705 -- Verify that the library unit is a package declaration
707 if not Nkind_In
(Unit
(Lib_Unit
), N_Package_Declaration
,
708 N_Generic_Package_Declaration
)
711 ("no legal package declaration for package body", N
);
714 -- Otherwise, the entity in the declaration is visible. Update the
715 -- version to reflect dependence of this body on the spec.
718 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
719 Set_Is_Immediately_Visible
(Spec_Id
, True);
720 Version_Update
(N
, Lib_Unit
);
722 if Nkind
(Defining_Unit_Name
(Unit_Node
)) =
723 N_Defining_Program_Unit_Name
725 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
730 -- If the unit is a subprogram body, then we similarly need to analyze
731 -- its spec. However, things are a little simpler in this case, because
732 -- here, this analysis is done mostly for error checking and consistency
733 -- purposes (but not only, e.g. there could be a contract on the spec),
734 -- so there's nothing else to be done.
736 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
737 if Acts_As_Spec
(N
) then
739 -- If the subprogram body is a child unit, we must create a
740 -- declaration for it, in order to properly load the parent(s).
741 -- After this, the original unit does not acts as a spec, because
742 -- there is an explicit one. If this unit appears in a context
743 -- clause, then an implicit with on the parent will be added when
744 -- installing the context. If this is the main unit, there is no
745 -- Unit_Table entry for the declaration (it has the unit number
746 -- of the main unit) and code generation is unaffected.
748 Unum
:= Get_Cunit_Unit_Number
(N
);
749 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
751 if Par_Spec_Name
/= No_Unit_Name
then
754 (Load_Name
=> Par_Spec_Name
,
759 if Unum
/= No_Unit
then
761 -- Build subprogram declaration and attach parent unit to it
762 -- This subprogram declaration does not come from source,
763 -- Nevertheless the backend must generate debugging info for
764 -- it, and this must be indicated explicitly. We also mark
765 -- the body entity as a child unit now, to prevent a
766 -- cascaded error if the spec entity cannot be entered
767 -- in its scope. Finally we create a Units table entry for
768 -- the subprogram declaration, to maintain a one-to-one
769 -- correspondence with compilation unit nodes. This is
770 -- critical for the tree traversals performed by CodePeer.
773 Loc
: constant Source_Ptr
:= Sloc
(N
);
774 SCS
: constant Boolean :=
775 Get_Comes_From_Source_Default
;
778 Set_Comes_From_Source_Default
(False);
780 -- Checks for redundant USE TYPE clauses have a special
781 -- exception for the synthetic spec we create here. This
782 -- special case relies on the two compilation units
783 -- sharing the same context clause.
785 -- Note: We used to do a shallow copy (New_Copy_List),
786 -- which defeated those checks and also created malformed
787 -- trees (subtype mark shared by two distinct
788 -- N_Use_Type_Clause nodes) which crashed the compiler.
791 Make_Compilation_Unit
(Loc
,
792 Context_Items
=> Context_Items
(N
),
794 Make_Subprogram_Declaration
(Sloc
(N
),
797 (Specification
(Unit_Node
))),
799 Make_Compilation_Unit_Aux
(Loc
));
801 Set_Library_Unit
(N
, Lib_Unit
);
802 Set_Parent_Spec
(Unit
(Lib_Unit
), Cunit
(Unum
));
803 Make_Child_Decl_Unit
(N
);
804 Semantics
(Lib_Unit
);
806 -- Now that a separate declaration exists, the body
807 -- of the child unit does not act as spec any longer.
809 Set_Acts_As_Spec
(N
, False);
810 Set_Is_Child_Unit
(Defining_Entity
(Unit_Node
));
811 Set_Debug_Info_Needed
(Defining_Entity
(Unit
(Lib_Unit
)));
812 Set_Comes_From_Source_Default
(SCS
);
817 -- Here for subprogram with separate declaration
820 Semantics
(Lib_Unit
);
821 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
822 Version_Update
(N
, Lib_Unit
);
825 -- If this is a child unit, generate references to the parents
827 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
828 N_Defining_Program_Unit_Name
830 Generate_Parent_References
831 (Specification
(Unit_Node
),
832 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
836 -- If it is a child unit, the parent must be elaborated first and we
837 -- update version, since we are dependent on our parent.
839 if Is_Child_Spec
(Unit_Node
) then
841 -- The analysis of the parent is done with style checks off
844 Save_Style_Check
: constant Boolean := Style_Check
;
847 if not GNAT_Mode
then
848 Style_Check
:= False;
851 Semantics
(Parent_Spec
(Unit_Node
));
852 Version_Update
(N
, Parent_Spec
(Unit_Node
));
854 -- Restore style check settings
856 Style_Check
:= Save_Style_Check
;
860 -- With the analysis done, install the context. Note that we can't
861 -- install the context from the with clauses as we analyze them, because
862 -- each with clause must be analyzed in a clean visibility context, so
863 -- we have to wait and install them all at once.
867 if Is_Child_Spec
(Unit_Node
) then
869 -- Set the entities of all parents in the program_unit_name
871 Generate_Parent_References
872 (Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
875 -- All components of the context: with-clauses, library unit, ancestors
876 -- if any, (and their context) are analyzed and installed.
878 -- Call special debug routine sm if this is the main unit
880 if Current_Sem_Unit
= Main_Unit
then
884 -- Now analyze the unit (package, subprogram spec, body) itself
888 if Warn_On_Redundant_Constructs
then
889 Check_Redundant_Withs
(Context_Items
(N
));
891 if Nkind
(Unit_Node
) = N_Package_Body
then
892 Check_Redundant_Withs
893 (Context_Items
=> Context_Items
(N
),
894 Spec_Context_Items
=> Context_Items
(Lib_Unit
));
898 -- The above call might have made Unit_Node an N_Subprogram_Body from
899 -- something else, so propagate any Acts_As_Spec flag.
901 if Nkind
(Unit_Node
) = N_Subprogram_Body
902 and then Acts_As_Spec
(Unit_Node
)
904 Set_Acts_As_Spec
(N
);
907 -- Register predefined units in Rtsfind
910 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Sloc
(N
));
912 if Is_Predefined_File_Name
(Unit_File_Name
(Unum
)) then
913 Set_RTU_Loaded
(Unit_Node
);
917 -- Treat compilation unit pragmas that appear after the library unit
919 if Present
(Pragmas_After
(Aux_Decls_Node
(N
))) then
921 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
923 while Present
(Prag_Node
) loop
930 -- Generate distribution stubs if requested and no error
933 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
935 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
936 and then not Fatal_Error
(Main_Unit
)
938 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
940 -- Regular RCI package
942 Add_Stub_Constructs
(N
);
944 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
945 and then Is_Shared_Passive
(Defining_Entity
946 (Specification
(Unit_Node
))))
947 or else (Nkind
(Unit_Node
) = N_Package_Body
949 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
951 -- Shared passive package
953 Add_Stub_Constructs
(N
);
955 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
957 Is_Remote_Call_Interface
958 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
960 -- Instantiation of a RCI generic package
962 Add_Stub_Constructs
(N
);
966 -- Remove unit from visibility, so that environment is clean for the
967 -- next compilation, which is either the main unit or some other unit
970 if Nkind_In
(Unit_Node
, N_Package_Declaration
,
971 N_Package_Renaming_Declaration
,
972 N_Subprogram_Declaration
)
973 or else Nkind
(Unit_Node
) in N_Generic_Declaration
974 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
975 and then Acts_As_Spec
(Unit_Node
))
977 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
979 -- If the unit is an instantiation whose body will be elaborated for
980 -- inlining purposes, use the proper entity of the instance. The entity
981 -- may be missing if the instantiation was illegal.
983 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
984 and then not Error_Posted
(Unit_Node
)
985 and then Present
(Instance_Spec
(Unit_Node
))
987 Remove_Unit_From_Visibility
988 (Defining_Entity
(Instance_Spec
(Unit_Node
)));
990 elsif Nkind
(Unit_Node
) = N_Package_Body
991 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
992 and then not Acts_As_Spec
(Unit_Node
))
994 -- Bodies that are not the main unit are compiled if they are generic
995 -- or contain generic or inlined units. Their analysis brings in the
996 -- context of the corresponding spec (unit declaration) which must be
997 -- removed as well, to return the compilation environment to its
1000 Remove_Context
(Lib_Unit
);
1001 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
1004 -- Last step is to deinstall the context we just installed as well as
1005 -- the unit just compiled.
1009 -- If this is the main unit and we are generating code, we must check
1010 -- that all generic units in the context have a body if they need it,
1011 -- even if they have not been instantiated. In the absence of .ali files
1012 -- for generic units, we must force the load of the body, just to
1013 -- produce the proper error if the body is absent. We skip this
1014 -- verification if the main unit itself is generic.
1016 if Get_Cunit_Unit_Number
(N
) = Main_Unit
1017 and then Operating_Mode
= Generate_Code
1018 and then Expander_Active
1020 -- Check whether the source for the body of the unit must be included
1021 -- in a standalone library.
1023 Check_Body_Needed_For_SAL
(Cunit_Entity
(Main_Unit
));
1025 -- Indicate that the main unit is now analyzed, to catch possible
1026 -- circularities between it and generic bodies. Remove main unit from
1027 -- visibility. This might seem superfluous, but the main unit must
1028 -- not be visible in the generic body expansions that follow.
1030 Set_Analyzed
(N
, True);
1031 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
1036 Un
: Unit_Number_Type
;
1038 Save_Style_Check
: constant Boolean := Style_Check
;
1041 Item
:= First
(Context_Items
(N
));
1042 while Present
(Item
) loop
1044 -- Check for explicit with clause
1046 if Nkind
(Item
) = N_With_Clause
1047 and then not Implicit_With
(Item
)
1049 -- Ada 2005 (AI-50217): Ignore limited-withed units
1051 and then not Limited_Present
(Item
)
1053 Nam
:= Entity
(Name
(Item
));
1055 -- Compile generic subprogram, unless it is intrinsic or
1056 -- imported so no body is required, or generic package body
1057 -- if the package spec requires a body.
1059 if (Is_Generic_Subprogram
(Nam
)
1060 and then not Is_Intrinsic_Subprogram
(Nam
)
1061 and then not Is_Imported
(Nam
))
1062 or else (Ekind
(Nam
) = E_Generic_Package
1063 and then Unit_Requires_Body
(Nam
))
1065 Style_Check
:= False;
1067 if Present
(Renamed_Object
(Nam
)) then
1070 (Load_Name
=> Get_Body_Name
1072 (Unit_Declaration_Node
1073 (Renamed_Object
(Nam
)))),
1081 (Load_Name
=> Get_Body_Name
1082 (Get_Unit_Name
(Item
)),
1089 if Un
= No_Unit
then
1091 ("body of generic unit& not found", Item
, Nam
);
1094 elsif not Analyzed
(Cunit
(Un
))
1095 and then Un
/= Main_Unit
1096 and then not Fatal_Error
(Un
)
1098 Style_Check
:= False;
1099 Semantics
(Cunit
(Un
));
1107 -- Restore style checks settings
1109 Style_Check
:= Save_Style_Check
;
1113 -- Deal with creating elaboration Boolean if needed. We create an
1114 -- elaboration boolean only for units that come from source since
1115 -- units manufactured by the compiler never need elab checks.
1117 if Comes_From_Source
(N
)
1118 and then Nkind_In
(Unit_Node
, N_Package_Declaration
,
1119 N_Generic_Package_Declaration
,
1120 N_Subprogram_Declaration
,
1121 N_Generic_Subprogram_Declaration
)
1124 Loc
: constant Source_Ptr
:= Sloc
(N
);
1125 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
1128 Spec_Id
:= Defining_Entity
(Unit_Node
);
1129 Generate_Definition
(Spec_Id
);
1131 -- See if an elaboration entity is required for possible access
1132 -- before elaboration checking. Note that we must allow for this
1133 -- even if -gnatE is not set, since a client may be compiled in
1134 -- -gnatE mode and reference the entity.
1136 -- These entities are also used by the binder to prevent multiple
1137 -- attempts to execute the elaboration code for the library case
1138 -- where the elaboration routine might otherwise be called more
1141 -- Case of units which do not require elaboration checks
1144 -- Pure units do not need checks
1148 -- Preelaborated units do not need checks
1150 or else Is_Preelaborated
(Spec_Id
)
1152 -- No checks needed if pragma Elaborate_Body present
1154 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
1156 -- No checks needed if unit does not require a body
1158 or else not Unit_Requires_Body
(Spec_Id
)
1160 -- No checks needed for predefined files
1162 or else Is_Predefined_File_Name
(Unit_File_Name
(Unum
))
1164 -- No checks required if no separate spec
1166 or else Acts_As_Spec
(N
)
1168 -- This is a case where we only need the entity for
1169 -- checking to prevent multiple elaboration checks.
1171 Set_Elaboration_Entity_Required
(Spec_Id
, False);
1173 -- Case of elaboration entity is required for access before
1174 -- elaboration checking (so certainly we must build it).
1177 Set_Elaboration_Entity_Required
(Spec_Id
, True);
1180 Build_Elaboration_Entity
(N
, Spec_Id
);
1184 -- Freeze the compilation unit entity. This for sure is needed because
1185 -- of some warnings that can be output (see Freeze_Subprogram), but may
1186 -- in general be required. If freezing actions result, place them in the
1187 -- compilation unit actions list, and analyze them.
1190 L
: constant List_Id
:=
1191 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), N
);
1193 while Is_Non_Empty_List
(L
) loop
1194 Insert_Library_Level_Action
(Remove_Head
(L
));
1200 if Nkind
(Unit_Node
) = N_Package_Declaration
1201 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
1202 and then Expander_Active
1205 Save_Style_Check
: constant Boolean := Style_Check
;
1206 Save_Warning
: constant Warning_Mode_Type
:= Warning_Mode
;
1207 Options
: Style_Check_Options
;
1210 Save_Style_Check_Options
(Options
);
1211 Reset_Style_Check_Options
;
1212 Opt
.Warning_Mode
:= Suppress
;
1213 Check_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
1215 Reset_Style_Check_Options
;
1216 Set_Style_Check_Options
(Options
);
1217 Style_Check
:= Save_Style_Check
;
1218 Warning_Mode
:= Save_Warning
;
1222 -- If we are generating obsolescent warnings, then here is where we
1223 -- generate them for the with'ed items. The reason for this special
1224 -- processing is that the normal mechanism of generating the warnings
1225 -- for referenced entities does not work for context clause references.
1226 -- That's because when we first analyze the context, it is too early to
1227 -- know if the with'ing unit is itself obsolescent (which suppresses
1231 and then Warn_On_Obsolescent_Feature
1232 and then Nkind
(Unit_Node
) not in N_Generic_Instantiation
1234 -- Push current compilation unit as scope, so that the test for
1235 -- being within an obsolescent unit will work correctly. The check
1236 -- is not performed within an instantiation, because the warning
1237 -- will have been emitted in the corresponding generic unit.
1239 Push_Scope
(Defining_Entity
(Unit_Node
));
1241 -- Loop through context items to deal with with clauses
1249 Item
:= First
(Context_Items
(N
));
1250 while Present
(Item
) loop
1251 if Nkind
(Item
) = N_With_Clause
1253 -- Suppress this check in limited-withed units. Further work
1254 -- needed here if we decide to incorporate this check on
1255 -- limited-withed units.
1257 and then not Limited_Present
(Item
)
1260 Ent
:= Entity
(Nam
);
1262 if Is_Obsolescent
(Ent
) then
1263 Output_Obsolescent_Entity_Warnings
(Nam
, Ent
);
1271 -- Remove temporary install of current unit as scope
1275 end Analyze_Compilation_Unit
;
1277 ---------------------
1278 -- Analyze_Context --
1279 ---------------------
1281 procedure Analyze_Context
(N
: Node_Id
) is
1282 Ukind
: constant Node_Kind
:= Nkind
(Unit
(N
));
1286 -- First process all configuration pragmas at the start of the context
1287 -- items. Strictly these are not part of the context clause, but that
1288 -- is where the parser puts them. In any case for sure we must analyze
1289 -- these before analyzing the actual context items, since they can have
1290 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1291 -- be with'ed as a result of changing categorizations in Ada 2005).
1293 Item
:= First
(Context_Items
(N
));
1294 while Present
(Item
)
1295 and then Nkind
(Item
) = N_Pragma
1296 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
1302 -- This is the point at which we capture the configuration settings
1303 -- for the unit. At the moment only the Optimize_Alignment setting
1304 -- needs to be captured. Probably more later ???
1306 if Optimize_Alignment_Local
then
1307 Set_OA_Setting
(Current_Sem_Unit
, 'L');
1309 Set_OA_Setting
(Current_Sem_Unit
, Optimize_Alignment
);
1312 -- Loop through actual context items. This is done in two passes:
1314 -- a) The first pass analyzes non-limited with-clauses and also any
1315 -- configuration pragmas (we need to get the latter analyzed right
1316 -- away, since they can affect processing of subsequent items.
1318 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1320 while Present
(Item
) loop
1322 -- For with clause, analyze the with clause, and then update the
1323 -- version, since we are dependent on a unit that we with.
1325 if Nkind
(Item
) = N_With_Clause
1326 and then not Limited_Present
(Item
)
1328 -- Skip analyzing with clause if no unit, nothing to do (this
1329 -- happens for a with that references a non-existent unit). Skip
1330 -- as well if this is a with_clause for the main unit, which
1331 -- happens if a subunit has a useless with_clause on its parent.
1333 if Present
(Library_Unit
(Item
)) then
1334 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
) then
1338 Set_Entity
(Name
(Item
), Cunit_Entity
(Current_Sem_Unit
));
1342 if not Implicit_With
(Item
) then
1343 Version_Update
(N
, Library_Unit
(Item
));
1346 -- Skip pragmas. Configuration pragmas at the start were handled in
1347 -- the loop above, and remaining pragmas are not processed until we
1348 -- actually install the context (see Install_Context). We delay the
1349 -- analysis of these pragmas to make sure that we have installed all
1350 -- the implicit with's on parent units.
1352 -- Skip use clauses at this stage, since we don't want to do any
1353 -- installing of potentially use-visible entities until we
1354 -- actually install the complete context (in Install_Context).
1355 -- Otherwise things can get installed in the wrong context.
1364 -- Second pass: examine all limited_with clauses. All other context
1365 -- items are ignored in this pass.
1367 Item
:= First
(Context_Items
(N
));
1368 while Present
(Item
) loop
1369 if Nkind
(Item
) = N_With_Clause
1370 and then Limited_Present
(Item
)
1372 -- No need to check errors on implicitly generated limited-with
1375 if not Implicit_With
(Item
) then
1377 -- Verify that the illegal contexts given in 10.1.2 (18/2) are
1378 -- properly rejected, including renaming declarations.
1380 if not Nkind_In
(Ukind
, N_Package_Declaration
,
1381 N_Subprogram_Declaration
)
1382 and then Ukind
not in N_Generic_Declaration
1383 and then Ukind
not in N_Generic_Instantiation
1385 Error_Msg_N
("limited with_clause not allowed here", Item
);
1387 -- Check wrong use of a limited with clause applied to the
1388 -- compilation unit containing the limited-with clause.
1390 -- limited with P.Q;
1391 -- package P.Q is ...
1393 elsif Unit
(Library_Unit
(Item
)) = Unit
(N
) then
1394 Error_Msg_N
("wrong use of limited-with clause", Item
);
1396 -- Check wrong use of limited-with clause applied to some
1397 -- immediate ancestor.
1399 elsif Is_Child_Spec
(Unit
(N
)) then
1401 Lib_U
: constant Entity_Id
:= Unit
(Library_Unit
(Item
));
1405 P
:= Parent_Spec
(Unit
(N
));
1407 if Unit
(P
) = Lib_U
then
1408 Error_Msg_N
("limited with_clause cannot "
1409 & "name ancestor", Item
);
1413 exit when not Is_Child_Spec
(Unit
(P
));
1414 P
:= Parent_Spec
(Unit
(P
));
1419 -- Check if the limited-withed unit is already visible through
1420 -- some context clause of the current compilation unit or some
1421 -- ancestor of the current compilation unit.
1424 Lim_Unit_Name
: constant Node_Id
:= Name
(Item
);
1425 Comp_Unit
: Node_Id
;
1427 Unit_Name
: Node_Id
;
1432 It
:= First
(Context_Items
(Comp_Unit
));
1433 while Present
(It
) loop
1435 and then Nkind
(It
) = N_With_Clause
1436 and then not Limited_Present
(It
)
1438 Nkind_In
(Unit
(Library_Unit
(It
)),
1439 N_Package_Declaration
,
1440 N_Package_Renaming_Declaration
)
1442 if Nkind
(Unit
(Library_Unit
(It
))) =
1443 N_Package_Declaration
1445 Unit_Name
:= Name
(It
);
1447 Unit_Name
:= Name
(Unit
(Library_Unit
(It
)));
1450 -- Check if the named package (or some ancestor)
1451 -- leaves visible the full-view of the unit given
1452 -- in the limited-with clause
1455 if Designate_Same_Unit
(Lim_Unit_Name
,
1458 Error_Msg_Sloc
:= Sloc
(It
);
1460 ("simultaneous visibility of limited "
1461 & "and unlimited views not allowed",
1464 ("\unlimited view visible through "
1465 & "context clause #",
1469 elsif Nkind
(Unit_Name
) = N_Identifier
then
1473 Unit_Name
:= Prefix
(Unit_Name
);
1480 exit when not Is_Child_Spec
(Unit
(Comp_Unit
));
1482 Comp_Unit
:= Parent_Spec
(Unit
(Comp_Unit
));
1487 -- Skip analyzing with clause if no unit, see above
1489 if Present
(Library_Unit
(Item
)) then
1493 -- A limited_with does not impose an elaboration order, but
1494 -- there is a semantic dependency for recompilation purposes.
1496 if not Implicit_With
(Item
) then
1497 Version_Update
(N
, Library_Unit
(Item
));
1500 -- Pragmas and use clauses and with clauses other than limited
1501 -- with's are ignored in this pass through the context items.
1509 end Analyze_Context
;
1511 -------------------------------
1512 -- Analyze_Package_Body_Stub --
1513 -------------------------------
1515 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
1516 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1520 -- The package declaration must be in the current declarative part
1522 Check_Stub_Level
(N
);
1523 Nam
:= Current_Entity_In_Scope
(Id
);
1525 if No
(Nam
) or else not Is_Package_Or_Generic_Package
(Nam
) then
1526 Error_Msg_N
("missing specification for package stub", N
);
1528 elsif Has_Completion
(Nam
)
1529 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
1531 Error_Msg_N
("duplicate or redundant stub for package", N
);
1534 -- Indicate that the body of the package exists. If we are doing
1535 -- only semantic analysis, the stub stands for the body. If we are
1536 -- generating code, the existence of the body will be confirmed
1537 -- when we load the proper body.
1539 Set_Has_Completion
(Nam
);
1540 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1541 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
1542 Generate_Reference
(Nam
, Id
, 'b');
1543 Analyze_Proper_Body
(N
, Nam
);
1545 end Analyze_Package_Body_Stub
;
1547 -------------------------
1548 -- Analyze_Proper_Body --
1549 -------------------------
1551 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
1552 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
1553 Unum
: Unit_Number_Type
;
1555 procedure Optional_Subunit
;
1556 -- This procedure is called when the main unit is a stub, or when we
1557 -- are not generating code. In such a case, we analyze the subunit if
1558 -- present, which is user-friendly and in fact required for ASIS, but
1559 -- we don't complain if the subunit is missing.
1561 ----------------------
1562 -- Optional_Subunit --
1563 ----------------------
1565 procedure Optional_Subunit
is
1566 Comp_Unit
: Node_Id
;
1569 -- Try to load subunit, but ignore any errors that occur during the
1570 -- loading of the subunit, by using the special feature in Errout to
1571 -- ignore all errors. Note that Fatal_Error will still be set, so we
1572 -- will be able to check for this case below.
1574 if not ASIS_Mode
then
1575 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
1580 (Load_Name
=> Subunit_Name
,
1585 if not ASIS_Mode
then
1586 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
1589 -- All done if we successfully loaded the subunit
1592 and then (not Fatal_Error
(Unum
) or else Try_Semantics
)
1594 Comp_Unit
:= Cunit
(Unum
);
1596 -- If the file was empty or seriously mangled, the unit itself may
1599 if No
(Unit
(Comp_Unit
)) then
1601 ("subunit does not contain expected proper body", N
);
1603 elsif Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1605 ("expected SEPARATE subunit, found child unit",
1606 Cunit_Entity
(Unum
));
1608 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1609 Analyze_Subunit
(Comp_Unit
);
1610 Set_Library_Unit
(N
, Comp_Unit
);
1613 elsif Unum
= No_Unit
1614 and then Present
(Nam
)
1616 if Is_Protected_Type
(Nam
) then
1617 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
1619 Set_Corresponding_Body
(
1620 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1623 end Optional_Subunit
;
1627 Stub_Id
: Entity_Id
;
1629 -- Start of processing for Analyze_Proper_Body
1632 -- If the subunit is already loaded, it means that the main unit is a
1633 -- subunit, and that the current unit is one of its parents which was
1634 -- being analyzed to provide the needed context for the analysis of the
1635 -- subunit. In this case we analyze the subunit and continue with the
1636 -- parent, without looking at subsequent subunits.
1638 if Is_Loaded
(Subunit_Name
) then
1640 -- If the proper body is already linked to the stub node, the stub is
1641 -- in a generic unit and just needs analyzing.
1643 if Present
(Library_Unit
(N
)) then
1644 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1646 -- If the subunit has severe errors, the spec of the enclosing
1647 -- body may not be available, in which case do not try analysis.
1649 if Serious_Errors_Detected
> 0
1650 and then No
(Library_Unit
(Library_Unit
(N
)))
1655 Analyze_Subunit
(Library_Unit
(N
));
1657 -- Otherwise we must load the subunit and link to it
1660 -- Load the subunit, this must work, since we originally loaded
1661 -- the subunit earlier on. So this will not really load it, just
1662 -- give access to it.
1666 (Load_Name
=> Subunit_Name
,
1671 -- And analyze the subunit in the parent context (note that we
1672 -- do not call Semantics, since that would remove the parent
1673 -- context). Because of this, we have to manually reset the
1674 -- compiler state to Analyzing since it got destroyed by Load.
1676 if Unum
/= No_Unit
then
1677 Compiler_State
:= Analyzing
;
1679 -- Check that the proper body is a subunit and not a child
1680 -- unit. If the unit was previously loaded, the error will
1681 -- have been emitted when copying the generic node, so we
1682 -- just return to avoid cascaded errors.
1684 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1688 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1689 Analyze_Subunit
(Cunit
(Unum
));
1690 Set_Library_Unit
(N
, Cunit
(Unum
));
1694 -- If the main unit is a subunit, then we are just performing semantic
1695 -- analysis on that subunit, and any other subunits of any parent unit
1696 -- should be ignored, except that if we are building trees for ASIS
1697 -- usage we want to annotate the stub properly.
1699 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1700 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1706 -- But before we return, set the flag for unloaded subunits. This
1707 -- will suppress junk warnings of variables in the same declarative
1708 -- part (or a higher level one) that are in danger of looking unused
1709 -- when in fact there might be a declaration in the subunit that we
1710 -- do not intend to load.
1712 Unloaded_Subunits
:= True;
1715 -- If the subunit is not already loaded, and we are generating code,
1716 -- then this is the case where compilation started from the parent, and
1717 -- we are generating code for an entire subunit tree. In that case we
1718 -- definitely need to load the subunit.
1720 -- In order to continue the analysis with the rest of the parent,
1721 -- and other subunits, we load the unit without requiring its
1722 -- presence, and emit a warning if not found, rather than terminating
1723 -- the compilation abruptly, as for other missing file problems.
1725 elsif Original_Operating_Mode
= Generate_Code
then
1727 -- If the proper body is already linked to the stub node, the stub is
1728 -- in a generic unit and just needs analyzing.
1730 -- We update the version. Although we are not strictly technically
1731 -- semantically dependent on the subunit, given our approach of macro
1732 -- substitution of subunits, it makes sense to include it in the
1733 -- version identification.
1735 if Present
(Library_Unit
(N
)) then
1736 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1737 Analyze_Subunit
(Library_Unit
(N
));
1738 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1740 -- Otherwise we must load the subunit and link to it
1743 -- Make sure that, if the subunit is preprocessed and -gnateG is
1744 -- specified, the preprocessed file will be written.
1746 Lib
.Analysing_Subunit_Of_Main
:= True;
1749 (Load_Name
=> Subunit_Name
,
1753 Lib
.Analysing_Subunit_Of_Main
:= False;
1755 -- Give message if we did not get the unit Emit warning even if
1756 -- missing subunit is not within main unit, to simplify debugging.
1758 if Original_Operating_Mode
= Generate_Code
1759 and then Unum
= No_Unit
1761 Error_Msg_Unit_1
:= Subunit_Name
;
1763 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1765 ("subunit$$ in file{ not found??!!", N
);
1766 Subunits_Missing
:= True;
1769 -- Load_Unit may reset Compiler_State, since it may have been
1770 -- necessary to parse an additional units, so we make sure that
1771 -- we reset it to the Analyzing state.
1773 Compiler_State
:= Analyzing
;
1775 if Unum
/= No_Unit
then
1776 if Debug_Flag_L
then
1777 Write_Str
("*** Loaded subunit from stub. Analyze");
1782 Comp_Unit
: constant Node_Id
:= Cunit
(Unum
);
1783 Prop_Body
: Node_Id
;
1786 -- Check for child unit instead of subunit
1788 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1790 ("expected SEPARATE subunit, found child unit",
1791 Cunit_Entity
(Unum
));
1793 -- OK, we have a subunit
1796 Prop_Body
:= Proper_Body
(Unit
(Comp_Unit
));
1798 -- Set corresponding stub (even if errors)
1800 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1802 -- Collect SCO information for loaded subunit if we are
1803 -- in the main unit.
1807 In_Extended_Main_Source_Unit
1808 (Cunit_Entity
(Current_Sem_Unit
))
1813 -- Propagate all aspect specifications associated with
1814 -- the stub to the proper body.
1816 Move_Or_Merge_Aspects
(From
=> N
, To
=> Prop_Body
);
1818 -- Move all source pragmas that follow the body stub and
1819 -- apply to it to the declarations of the proper body.
1821 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1822 Relocate_Pragmas_To_Body
(N
, Target_Body
=> Prop_Body
);
1825 -- Analyze the unit if semantics active
1827 if not Fatal_Error
(Unum
) or else Try_Semantics
then
1828 Analyze_Subunit
(Comp_Unit
);
1831 -- Set the library unit pointer in any case
1833 Set_Library_Unit
(N
, Comp_Unit
);
1835 -- We update the version. Although we are not technically
1836 -- semantically dependent on the subunit, given our
1837 -- approach of macro substitution of subunits, it makes
1838 -- sense to include it in the version identification.
1840 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1844 -- The unit which should contain the proper subprogram body does
1845 -- not exist. Analyze the aspect specifications of the stub (if
1848 elsif Nkind
(N
) = N_Subprogram_Body_Stub
1849 and then Has_Aspects
(N
)
1851 Stub_Id
:= Defining_Unit_Name
(Specification
(N
));
1853 -- Restore the proper visibility of the stub and its formals
1855 Push_Scope
(Stub_Id
);
1856 Install_Formals
(Stub_Id
);
1858 Analyze_Aspect_Specifications
(N
, Stub_Id
);
1864 -- The remaining case is when the subunit is not already loaded and we
1865 -- are not generating code. In this case we are just performing semantic
1866 -- analysis on the parent, and we are not interested in the subunit. For
1867 -- subprograms, analyze the stub as a body. For other entities the stub
1868 -- has already been marked as completed.
1873 end Analyze_Proper_Body
;
1875 ----------------------------------
1876 -- Analyze_Protected_Body_Stub --
1877 ----------------------------------
1879 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1880 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1883 Check_Stub_Level
(N
);
1885 -- First occurrence of name may have been as an incomplete type
1887 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1888 Nam
:= Full_View
(Nam
);
1891 if No
(Nam
) or else not Is_Protected_Type
(Etype
(Nam
)) then
1892 Error_Msg_N
("missing specification for Protected body", N
);
1895 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1896 Set_Has_Completion
(Etype
(Nam
));
1897 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
1898 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
1899 Analyze_Proper_Body
(N
, Etype
(Nam
));
1901 end Analyze_Protected_Body_Stub
;
1903 ----------------------------------
1904 -- Analyze_Subprogram_Body_Stub --
1905 ----------------------------------
1907 -- A subprogram body stub can appear with or without a previous spec. If
1908 -- there is one, then the analysis of the body will find it and verify
1909 -- conformance. The formals appearing in the specification of the stub play
1910 -- no role, except for requiring an additional conformance check. If there
1911 -- is no previous subprogram declaration, the stub acts as a spec, and
1912 -- provides the defining entity for the subprogram.
1914 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
1918 Check_Stub_Level
(N
);
1920 -- Verify that the identifier for the stub is unique within this
1921 -- declarative part.
1923 if Nkind_In
(Parent
(N
), N_Block_Statement
,
1927 Decl
:= First
(Declarations
(Parent
(N
)));
1928 while Present
(Decl
) and then Decl
/= N
loop
1929 if Nkind
(Decl
) = N_Subprogram_Body_Stub
1930 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
))) =
1931 Chars
(Defining_Unit_Name
(Specification
(N
))))
1933 Error_Msg_N
("identifier for stub is not unique", N
);
1940 -- Treat stub as a body, which checks conformance if there is a previous
1941 -- declaration, or else introduces entity and its signature.
1943 Analyze_Subprogram_Body
(N
);
1944 Analyze_Proper_Body
(N
, Empty
);
1945 end Analyze_Subprogram_Body_Stub
;
1947 ---------------------
1948 -- Analyze_Subunit --
1949 ---------------------
1951 -- A subunit is compiled either by itself (for semantic checking) or as
1952 -- part of compiling the parent (for code generation). In either case, by
1953 -- the time we actually process the subunit, the parent has already been
1954 -- installed and analyzed. The node N is a compilation unit, whose context
1955 -- needs to be treated here, because we come directly here from the parent
1956 -- without calling Analyze_Compilation_Unit.
1958 -- The compilation context includes the explicit context of the subunit,
1959 -- and the context of the parent, together with the parent itself. In order
1960 -- to compile the current context, we remove the one inherited from the
1961 -- parent, in order to have a clean visibility table. We restore the parent
1962 -- context before analyzing the proper body itself. On exit, we remove only
1963 -- the explicit context of the subunit.
1965 procedure Analyze_Subunit
(N
: Node_Id
) is
1966 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
1967 Par_Unit
: constant Entity_Id
:= Current_Scope
;
1969 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
1970 Num_Scopes
: Int
:= 0;
1971 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
1972 Enclosing_Child
: Entity_Id
:= Empty
;
1973 Svg
: constant Suppress_Record
:= Scope_Suppress
;
1975 Save_Cunit_Restrictions
: constant Save_Cunit_Boolean_Restrictions
:=
1976 Cunit_Boolean_Restrictions_Save
;
1977 -- Save non-partition wide restrictions before processing the subunit.
1978 -- All subunits are analyzed with config restrictions reset and we need
1979 -- to restore these saved values at the end.
1981 procedure Analyze_Subunit_Context
;
1982 -- Capture names in use clauses of the subunit. This must be done before
1983 -- re-installing parent declarations, because items in the context must
1984 -- not be hidden by declarations local to the parent.
1986 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
1987 -- Recursive procedure to restore scope of all ancestors of subunit,
1988 -- from outermost in. If parent is not a subunit, the call to install
1989 -- context installs context of spec and (if parent is a child unit) the
1990 -- context of its parents as well. It is confusing that parents should
1991 -- be treated differently in both cases, but the semantics are just not
1994 procedure Re_Install_Use_Clauses
;
1995 -- As part of the removal of the parent scope, the use clauses are
1996 -- removed, to be reinstalled when the context of the subunit has been
1997 -- analyzed. Use clauses may also have been affected by the analysis of
1998 -- the context of the subunit, so they have to be applied again, to
1999 -- insure that the compilation environment of the rest of the parent
2000 -- unit is identical.
2002 procedure Remove_Scope
;
2003 -- Remove current scope from scope stack, and preserve the list of use
2004 -- clauses in it, to be reinstalled after context is analyzed.
2006 -----------------------------
2007 -- Analyze_Subunit_Context --
2008 -----------------------------
2010 procedure Analyze_Subunit_Context
is
2013 Unit_Name
: Entity_Id
;
2016 Analyze_Context
(N
);
2018 -- Make withed units immediately visible. If child unit, make the
2019 -- ultimate parent immediately visible.
2021 Item
:= First
(Context_Items
(N
));
2022 while Present
(Item
) loop
2023 if Nkind
(Item
) = N_With_Clause
then
2025 -- Protect frontend against previous errors in context clauses
2027 if Nkind
(Name
(Item
)) /= N_Selected_Component
then
2028 if Error_Posted
(Item
) then
2032 -- If a subunits has serious syntax errors, the context
2033 -- may not have been loaded. Add a harmless unit name to
2034 -- attempt processing.
2036 if Serious_Errors_Detected
> 0
2037 and then No
(Entity
(Name
(Item
)))
2039 Set_Entity
(Name
(Item
), Standard_Standard
);
2042 Unit_Name
:= Entity
(Name
(Item
));
2044 Set_Is_Visible_Lib_Unit
(Unit_Name
);
2045 exit when Scope
(Unit_Name
) = Standard_Standard
;
2046 Unit_Name
:= Scope
(Unit_Name
);
2048 if No
(Unit_Name
) then
2049 Check_Error_Detected
;
2054 if not Is_Immediately_Visible
(Unit_Name
) then
2055 Set_Is_Immediately_Visible
(Unit_Name
);
2056 Set_Context_Installed
(Item
);
2061 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2062 Nam
:= First
(Names
(Item
));
2063 while Present
(Nam
) loop
2068 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2069 Nam
:= First
(Subtype_Marks
(Item
));
2070 while Present
(Nam
) loop
2079 -- Reset visibility of withed units. They will be made visible again
2080 -- when we install the subunit context.
2082 Item
:= First
(Context_Items
(N
));
2083 while Present
(Item
) loop
2084 if Nkind
(Item
) = N_With_Clause
2086 -- Protect frontend against previous errors in context clauses
2088 and then Nkind
(Name
(Item
)) /= N_Selected_Component
2089 and then not Error_Posted
(Item
)
2091 Unit_Name
:= Entity
(Name
(Item
));
2093 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
2094 exit when Scope
(Unit_Name
) = Standard_Standard
;
2095 Unit_Name
:= Scope
(Unit_Name
);
2098 if Context_Installed
(Item
) then
2099 Set_Is_Immediately_Visible
(Unit_Name
, False);
2100 Set_Context_Installed
(Item
, False);
2106 end Analyze_Subunit_Context
;
2108 ------------------------
2109 -- Re_Install_Parents --
2110 ------------------------
2112 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
2116 if Nkind
(Unit
(L
)) = N_Subunit
then
2117 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
2120 Install_Context
(L
);
2122 -- If the subunit occurs within a child unit, we must restore the
2123 -- immediate visibility of any siblings that may occur in context.
2125 if Present
(Enclosing_Child
) then
2126 Install_Siblings
(Enclosing_Child
, L
);
2131 if Scop
/= Par_Unit
then
2132 Set_Is_Immediately_Visible
(Scop
);
2135 -- Make entities in scope visible again. For child units, restore
2136 -- visibility only if they are actually in context.
2138 E
:= First_Entity
(Current_Scope
);
2139 while Present
(E
) loop
2140 if not Is_Child_Unit
(E
) or else Is_Visible_Lib_Unit
(E
) then
2141 Set_Is_Immediately_Visible
(E
);
2147 -- A subunit appears within a body, and for a nested subunits all the
2148 -- parents are bodies. Restore full visibility of their private
2151 if Is_Package_Or_Generic_Package
(Scop
) then
2152 Set_In_Package_Body
(Scop
);
2153 Install_Private_Declarations
(Scop
);
2155 end Re_Install_Parents
;
2157 ----------------------------
2158 -- Re_Install_Use_Clauses --
2159 ----------------------------
2161 procedure Re_Install_Use_Clauses
is
2164 for J
in reverse 1 .. Num_Scopes
loop
2165 U
:= Use_Clauses
(J
);
2166 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
2167 Install_Use_Clauses
(U
, Force_Installation
=> True);
2169 end Re_Install_Use_Clauses
;
2175 procedure Remove_Scope
is
2179 Num_Scopes
:= Num_Scopes
+ 1;
2180 Use_Clauses
(Num_Scopes
) :=
2181 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
2183 E
:= First_Entity
(Current_Scope
);
2184 while Present
(E
) loop
2185 Set_Is_Immediately_Visible
(E
, False);
2189 if Is_Child_Unit
(Current_Scope
) then
2190 Enclosing_Child
:= Current_Scope
;
2196 -- Start of processing for Analyze_Subunit
2199 -- For subunit in main extended unit, we reset the configuration values
2200 -- for the non-partition-wide restrictions. For other units reset them.
2202 if In_Extended_Main_Source_Unit
(N
) then
2203 Restore_Config_Cunit_Boolean_Restrictions
;
2205 Reset_Cunit_Boolean_Restrictions
;
2210 Nam
: Node_Id
:= Name
(Unit
(N
));
2213 if Nkind
(Nam
) = N_Selected_Component
then
2214 Nam
:= Selector_Name
(Nam
);
2217 Check_Identifier
(Nam
, Par_Unit
);
2221 if not Is_Empty_List
(Context_Items
(N
)) then
2223 -- Save current use clauses
2226 Remove_Context
(Lib_Unit
);
2228 -- Now remove parents and their context, including enclosing subunits
2229 -- and the outer parent body which is not a subunit.
2231 if Present
(Lib_Spec
) then
2232 Remove_Context
(Lib_Spec
);
2234 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
2235 Lib_Spec
:= Library_Unit
(Lib_Spec
);
2237 Remove_Context
(Lib_Spec
);
2240 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
2244 if Nkind
(Unit
(Lib_Spec
)) = N_Package_Body
then
2245 Remove_Context
(Library_Unit
(Lib_Spec
));
2249 Set_Is_Immediately_Visible
(Par_Unit
, False);
2251 Analyze_Subunit_Context
;
2253 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
2254 Set_Is_Immediately_Visible
(Par_Unit
);
2256 -- If the context includes a child unit of the parent of the subunit,
2257 -- the parent will have been removed from visibility, after compiling
2258 -- that cousin in the context. The visibility of the parent must be
2259 -- restored now. This also applies if the context includes another
2260 -- subunit of the same parent which in turn includes a child unit in
2263 if Is_Package_Or_Generic_Package
(Par_Unit
) then
2264 if not Is_Immediately_Visible
(Par_Unit
)
2265 or else (Present
(First_Entity
(Par_Unit
))
2267 Is_Immediately_Visible
(First_Entity
(Par_Unit
)))
2269 Set_Is_Immediately_Visible
(Par_Unit
);
2270 Install_Visible_Declarations
(Par_Unit
);
2271 Install_Private_Declarations
(Par_Unit
);
2275 Re_Install_Use_Clauses
;
2276 Install_Context
(N
);
2278 -- Restore state of suppress flags for current body
2280 Scope_Suppress
:= Svg
;
2282 -- If the subunit is within a child unit, then siblings of any parent
2283 -- unit that appear in the context clause of the subunit must also be
2284 -- made immediately visible.
2286 if Present
(Enclosing_Child
) then
2287 Install_Siblings
(Enclosing_Child
, N
);
2291 Generate_Parent_References
(Unit
(N
), Par_Unit
);
2292 Analyze
(Proper_Body
(Unit
(N
)));
2295 -- The subunit may contain a with_clause on a sibling of some ancestor.
2296 -- Removing the context will remove from visibility those ancestor child
2297 -- units, which must be restored to the visibility they have in the
2300 if Present
(Enclosing_Child
) then
2305 while Present
(C
) and then C
/= Standard_Standard
loop
2306 Set_Is_Immediately_Visible
(C
);
2307 Set_Is_Visible_Lib_Unit
(C
);
2313 -- Deal with restore of restrictions
2315 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
2316 end Analyze_Subunit
;
2318 ----------------------------
2319 -- Analyze_Task_Body_Stub --
2320 ----------------------------
2322 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
2323 Loc
: constant Source_Ptr
:= Sloc
(N
);
2324 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
2327 Check_Stub_Level
(N
);
2329 -- First occurrence of name may have been as an incomplete type
2331 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2332 Nam
:= Full_View
(Nam
);
2335 if No
(Nam
) or else not Is_Task_Type
(Etype
(Nam
)) then
2336 Error_Msg_N
("missing specification for task body", N
);
2338 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
2339 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
2340 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
2342 -- Check for duplicate stub, if so give message and terminate
2344 if Has_Completion
(Etype
(Nam
)) then
2345 Error_Msg_N
("duplicate stub for task", N
);
2348 Set_Has_Completion
(Etype
(Nam
));
2351 Analyze_Proper_Body
(N
, Etype
(Nam
));
2353 -- Set elaboration flag to indicate that entity is callable. This
2354 -- cannot be done in the expansion of the body itself, because the
2355 -- proper body is not in a declarative part. This is only done if
2356 -- expansion is active, because the context may be generic and the
2357 -- flag not defined yet.
2359 if Expander_Active
then
2361 Make_Assignment_Statement
(Loc
,
2363 Make_Identifier
(Loc
,
2364 Chars
=> New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
2365 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
2368 end Analyze_Task_Body_Stub
;
2370 -------------------------
2371 -- Analyze_With_Clause --
2372 -------------------------
2374 -- Analyze the declaration of a unit in a with clause. At end, label the
2375 -- with clause with the defining entity for the unit.
2377 procedure Analyze_With_Clause
(N
: Node_Id
) is
2379 -- Retrieve the original kind of the unit node, before analysis. If it
2380 -- is a subprogram instantiation, its analysis below will rewrite the
2381 -- node as the declaration of the wrapper package. If the same
2382 -- instantiation appears indirectly elsewhere in the context, it will
2383 -- have been analyzed already.
2385 Unit_Kind
: constant Node_Kind
:=
2386 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
2387 Nam
: constant Node_Id
:= Name
(N
);
2389 Par_Name
: Entity_Id
;
2394 -- Set True if the unit currently being compiled is an internal unit
2396 Restriction_Violation
: Boolean := False;
2397 -- Set True if a with violates a restriction, no point in giving any
2398 -- warnings if we have this definite error.
2400 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2403 U
:= Unit
(Library_Unit
(N
));
2405 -- If this is an internal unit which is a renaming, then this is a
2406 -- violation of No_Obsolescent_Features.
2408 -- Note: this is not quite right if the user defines one of these units
2409 -- himself, but that's a marginal case, and fixing it is hard ???
2411 if Restriction_Check_Required
(No_Obsolescent_Features
) then
2413 F
: constant File_Name_Type
:=
2414 Unit_File_Name
(Get_Source_Unit
(U
));
2416 if Is_Predefined_File_Name
(F
, Renamings_Included
=> True)
2418 Is_Predefined_File_Name
(F
, Renamings_Included
=> False)
2420 Check_Restriction
(No_Obsolescent_Features
, N
);
2421 Restriction_Violation
:= True;
2426 -- Check No_Implementation_Units violation
2428 if Restriction_Check_Required
(No_Implementation_Units
) then
2429 if Not_Impl_Defined_Unit
(Get_Source_Unit
(U
)) then
2432 Check_Restriction
(No_Implementation_Units
, Nam
);
2433 Restriction_Violation
:= True;
2437 -- Several actions are skipped for dummy packages (those supplied for
2438 -- with's where no matching file could be found). Such packages are
2439 -- identified by the Sloc value being set to No_Location.
2441 if Limited_Present
(N
) then
2443 -- Ada 2005 (AI-50217): Build visibility structures but do not
2444 -- analyze the unit.
2446 if Sloc
(U
) /= No_Location
then
2447 Build_Limited_Views
(N
);
2453 -- If the library unit is a predefined unit, and we are in high
2454 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
2455 -- for the analysis of the with'ed unit. This mode does not prevent
2456 -- explicit with'ing of run-time units.
2458 if Configurable_Run_Time_Mode
2459 and then Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(U
)))
2461 Configurable_Run_Time_Mode
:= False;
2462 Semantics
(Library_Unit
(N
));
2463 Configurable_Run_Time_Mode
:= True;
2466 Semantics
(Library_Unit
(N
));
2469 Intunit
:= Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
));
2471 if Sloc
(U
) /= No_Location
then
2473 -- Check restrictions, except that we skip the check if this is an
2474 -- internal unit unless we are compiling the internal unit as the
2475 -- main unit. We also skip this for dummy packages.
2477 Check_Restriction_No_Dependence
(Nam
, N
);
2479 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
2480 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
2483 -- Deal with special case of GNAT.Current_Exceptions which interacts
2484 -- with the optimization of local raise statements into gotos.
2486 if Nkind
(Nam
) = N_Selected_Component
2487 and then Nkind
(Prefix
(Nam
)) = N_Identifier
2488 and then Chars
(Prefix
(Nam
)) = Name_Gnat
2489 and then Nam_In
(Chars
(Selector_Name
(Nam
)),
2490 Name_Most_Recent_Exception
,
2491 Name_Exception_Traces
)
2493 Check_Restriction
(No_Exception_Propagation
, N
);
2494 Special_Exception_Package_Used
:= True;
2497 -- Check for inappropriate with of internal implementation unit if we
2498 -- are not compiling an internal unit and also check for withing unit
2499 -- in wrong version of Ada. Do not issue these messages for implicit
2500 -- with's generated by the compiler itself.
2502 if Implementation_Unit_Warnings
2503 and then not Intunit
2504 and then not Implicit_With
(N
)
2505 and then not Restriction_Violation
2508 U_Kind
: constant Kind_Of_Unit
:=
2509 Get_Kind_Of_Unit
(Get_Source_Unit
(U
));
2512 if U_Kind
= Implementation_Unit
then
2513 Error_Msg_F
("& is an internal 'G'N'A'T unit?i?", Name
(N
));
2515 -- Add alternative name if available, otherwise issue a
2516 -- general warning message.
2518 if Error_Msg_Strlen
/= 0 then
2519 Error_Msg_F
("\use ""~"" instead?i?", Name
(N
));
2522 ("\use of this unit is non-portable " &
2523 "and version-dependent?i?", Name
(N
));
2526 elsif U_Kind
= Ada_2005_Unit
2527 and then Ada_Version
< Ada_2005
2528 and then Warn_On_Ada_2005_Compatibility
2530 Error_Msg_N
("& is an Ada 2005 unit?i?", Name
(N
));
2532 elsif U_Kind
= Ada_2012_Unit
2533 and then Ada_Version
< Ada_2012
2534 and then Warn_On_Ada_2012_Compatibility
2536 Error_Msg_N
("& is an Ada 2012 unit?i?", Name
(N
));
2542 -- Semantic analysis of a generic unit is performed on a copy of
2543 -- the original tree. Retrieve the entity on which semantic info
2544 -- actually appears.
2546 if Unit_Kind
in N_Generic_Declaration
then
2547 E_Name
:= Defining_Entity
(U
);
2549 -- Note: in the following test, Unit_Kind is the original Nkind, but in
2550 -- the case of an instantiation, semantic analysis above will have
2551 -- replaced the unit by its instantiated version. If the instance body
2552 -- has been generated, the instance now denotes the body entity. For
2553 -- visibility purposes we need the entity of its spec.
2555 elsif (Unit_Kind
= N_Package_Instantiation
2556 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
2557 N_Package_Instantiation
)
2558 and then Nkind
(U
) = N_Package_Body
2560 E_Name
:= Corresponding_Spec
(U
);
2562 elsif Unit_Kind
= N_Package_Instantiation
2563 and then Nkind
(U
) = N_Package_Instantiation
2564 and then Present
(Instance_Spec
(U
))
2566 -- If the instance has not been rewritten as a package declaration,
2567 -- then it appeared already in a previous with clause. Retrieve
2568 -- the entity from the previous instance.
2570 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
2572 elsif Unit_Kind
in N_Subprogram_Instantiation
then
2574 -- The visible subprogram is created during instantiation, and is
2575 -- an attribute of the wrapper package. We retrieve the wrapper
2576 -- package directly from the instantiation node. If the instance
2577 -- is inlined the unit is still an instantiation. Otherwise it has
2578 -- been rewritten as the declaration of the wrapper itself.
2580 if Nkind
(U
) in N_Subprogram_Instantiation
then
2583 (Defining_Entity
(Specification
(Instance_Spec
(U
))));
2585 E_Name
:= Related_Instance
(Defining_Entity
(U
));
2588 elsif Unit_Kind
= N_Package_Renaming_Declaration
2589 or else Unit_Kind
in N_Generic_Renaming_Declaration
2591 E_Name
:= Defining_Entity
(U
);
2593 elsif Unit_Kind
= N_Subprogram_Body
2594 and then Nkind
(Name
(N
)) = N_Selected_Component
2595 and then not Acts_As_Spec
(Library_Unit
(N
))
2597 -- For a child unit that has no spec, one has been created and
2598 -- analyzed. The entity required is that of the spec.
2600 E_Name
:= Corresponding_Spec
(U
);
2603 E_Name
:= Defining_Entity
(U
);
2606 if Nkind
(Name
(N
)) = N_Selected_Component
then
2608 -- Child unit in a with clause
2610 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
2612 -- If this is a child unit without a spec, and it has been analyzed
2613 -- already, a declaration has been created for it. The with_clause
2614 -- must reflect the actual body, and not the generated declaration,
2615 -- to prevent spurious binding errors involving an out-of-date spec.
2616 -- Note that this can only happen if the unit includes more than one
2617 -- with_clause for the child unit (e.g. in separate subunits).
2619 if Unit_Kind
= N_Subprogram_Declaration
2620 and then Analyzed
(Library_Unit
(N
))
2621 and then not Comes_From_Source
(Library_Unit
(N
))
2623 Set_Library_Unit
(N
,
2624 Cunit
(Get_Source_Unit
(Corresponding_Body
(U
))));
2628 -- Restore style checks
2630 Style_Check
:= Save_Style_Check
;
2632 -- Record the reference, but do NOT set the unit as referenced, we want
2633 -- to consider the unit as unreferenced if this is the only reference
2636 Set_Entity_With_Style_Check
(Name
(N
), E_Name
);
2637 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
2639 -- Generate references and check No_Dependence restriction for parents
2641 if Is_Child_Unit
(E_Name
) then
2642 Pref
:= Prefix
(Name
(N
));
2643 Par_Name
:= Scope
(E_Name
);
2644 while Nkind
(Pref
) = N_Selected_Component
loop
2645 Change_Selected_Component_To_Expanded_Name
(Pref
);
2647 if Present
(Entity
(Selector_Name
(Pref
)))
2649 Present
(Renamed_Entity
(Entity
(Selector_Name
(Pref
))))
2650 and then Entity
(Selector_Name
(Pref
)) /= Par_Name
2652 -- The prefix is a child unit that denotes a renaming declaration.
2653 -- Replace the prefix directly with the renamed unit, because the
2654 -- rest of the prefix is irrelevant to the visibility of the real
2657 Rewrite
(Pref
, New_Occurrence_Of
(Par_Name
, Sloc
(Pref
)));
2661 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2663 Generate_Reference
(Par_Name
, Pref
);
2664 Check_Restriction_No_Dependence
(Pref
, N
);
2665 Pref
:= Prefix
(Pref
);
2667 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2668 -- is set to Standard_Standard, and no attempt should be made to
2669 -- further unwind scopes.
2671 if Par_Name
/= Standard_Standard
then
2672 Par_Name
:= Scope
(Par_Name
);
2675 -- Abandon processing in case of previous errors
2677 if No
(Par_Name
) then
2678 Check_Error_Detected
;
2683 if Present
(Entity
(Pref
))
2684 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
2686 -- If the entity is set without its unit being compiled, the
2687 -- original parent is a renaming, and Par_Name is the renamed
2688 -- entity. For visibility purposes, we need the original entity,
2689 -- which must be analyzed now because Load_Unit directly retrieves
2690 -- the renamed unit, and the renaming declaration itself has not
2693 Analyze
(Parent
(Parent
(Entity
(Pref
))));
2694 pragma Assert
(Renamed_Object
(Entity
(Pref
)) = Par_Name
);
2695 Par_Name
:= Entity
(Pref
);
2698 -- Guard against missing or misspelled child units
2700 if Present
(Par_Name
) then
2701 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2702 Generate_Reference
(Par_Name
, Pref
);
2705 pragma Assert
(Serious_Errors_Detected
/= 0);
2707 -- Mark the node to indicate that a related error has been posted.
2708 -- This defends further compilation passes against improper use of
2709 -- the invalid WITH clause node.
2711 Set_Error_Posted
(N
);
2712 Set_Name
(N
, Error
);
2717 -- If the withed unit is System, and a system extension pragma is
2718 -- present, compile the extension now, rather than waiting for a
2719 -- visibility check on a specific entity.
2721 if Chars
(E_Name
) = Name_System
2722 and then Scope
(E_Name
) = Standard_Standard
2723 and then Present
(System_Extend_Unit
)
2724 and then Present_System_Aux
(N
)
2726 -- If the extension is not present, an error will have been emitted
2731 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2732 -- to private_with units; they will be made visible later (just before
2733 -- the private part is analyzed)
2735 if Private_Present
(N
) then
2736 Set_Is_Immediately_Visible
(E_Name
, False);
2738 end Analyze_With_Clause
;
2740 ------------------------------
2741 -- Check_Private_Child_Unit --
2742 ------------------------------
2744 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
2745 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2747 Curr_Unit
: Entity_Id
;
2748 Sub_Parent
: Node_Id
;
2749 Priv_Child
: Entity_Id
;
2750 Par_Lib
: Entity_Id
;
2753 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean;
2754 -- Returns true if and only if the library unit is declared with
2755 -- an explicit designation of private.
2757 -----------------------------
2758 -- Is_Private_Library_Unit --
2759 -----------------------------
2761 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
2762 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
2765 return Private_Present
(Comp_Unit
);
2766 end Is_Private_Library_Unit
;
2768 -- Start of processing for Check_Private_Child_Unit
2771 if Nkind_In
(Lib_Unit
, N_Package_Body
, N_Subprogram_Body
) then
2772 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
2773 Par_Lib
:= Curr_Unit
;
2775 elsif Nkind
(Lib_Unit
) = N_Subunit
then
2777 -- The parent is itself a body. The parent entity is to be found in
2778 -- the corresponding spec.
2780 Sub_Parent
:= Library_Unit
(N
);
2781 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
2783 -- If the parent itself is a subunit, Curr_Unit is the entity of the
2784 -- enclosing body, retrieve the spec entity which is the proper
2785 -- ancestor we need for the following tests.
2787 if Ekind
(Curr_Unit
) = E_Package_Body
then
2788 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2791 Par_Lib
:= Curr_Unit
;
2794 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2796 Par_Lib
:= Curr_Unit
;
2797 Par_Spec
:= Parent_Spec
(Lib_Unit
);
2799 if No
(Par_Spec
) then
2802 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
2806 -- Loop through context items
2808 Item
:= First
(Context_Items
(N
));
2809 while Present
(Item
) loop
2811 -- Ada 2005 (AI-262): Allow private_with of a private child package
2812 -- in public siblings
2814 if Nkind
(Item
) = N_With_Clause
2815 and then not Implicit_With
(Item
)
2816 and then not Limited_Present
(Item
)
2817 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
2819 Priv_Child
:= Entity
(Name
(Item
));
2822 Curr_Parent
: Entity_Id
:= Par_Lib
;
2823 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
2824 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
2825 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
2828 -- If the child unit is a public child then locate the nearest
2829 -- private ancestor. Child_Parent will then be set to the
2830 -- parent of that ancestor.
2832 if not Is_Private_Library_Unit
(Priv_Child
) then
2833 while Present
(Prv_Ancestor
)
2834 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
2836 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
2839 if Present
(Prv_Ancestor
) then
2840 Child_Parent
:= Scope
(Prv_Ancestor
);
2844 while Present
(Curr_Parent
)
2845 and then Curr_Parent
/= Standard_Standard
2846 and then Curr_Parent
/= Child_Parent
2849 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
2850 Curr_Parent
:= Scope
(Curr_Parent
);
2853 if No
(Curr_Parent
) then
2854 Curr_Parent
:= Standard_Standard
;
2857 if Curr_Parent
/= Child_Parent
then
2858 if Ekind
(Priv_Child
) = E_Generic_Package
2859 and then Chars
(Priv_Child
) in Text_IO_Package_Name
2860 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
2863 ("& is a nested package, not a compilation unit",
2864 Name
(Item
), Priv_Child
);
2868 ("unit in with clause is private child unit!", Item
);
2870 ("\current unit must also have parent&!",
2871 Item
, Child_Parent
);
2875 or else Private_Present
(Item
)
2876 or else Nkind_In
(Lib_Unit
, N_Package_Body
, N_Subunit
)
2877 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
2878 and then not Acts_As_Spec
(Parent
(Lib_Unit
)))
2884 ("current unit must also be private descendant of&",
2885 Item
, Child_Parent
);
2893 end Check_Private_Child_Unit
;
2895 ----------------------
2896 -- Check_Stub_Level --
2897 ----------------------
2899 procedure Check_Stub_Level
(N
: Node_Id
) is
2900 Par
: constant Node_Id
:= Parent
(N
);
2901 Kind
: constant Node_Kind
:= Nkind
(Par
);
2904 if Nkind_In
(Kind
, N_Package_Body
,
2908 and then Nkind_In
(Parent
(Par
), N_Compilation_Unit
, N_Subunit
)
2912 -- In an instance, a missing stub appears at any level. A warning
2913 -- message will have been emitted already for the missing file.
2915 elsif not In_Instance
then
2916 Error_Msg_N
("stub cannot appear in an inner scope", N
);
2918 elsif Expander_Active
then
2919 Error_Msg_N
("missing proper body", N
);
2921 end Check_Stub_Level
;
2923 ------------------------
2924 -- Expand_With_Clause --
2925 ------------------------
2927 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
) is
2928 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2929 Ent
: constant Entity_Id
:= Entity
(Nam
);
2933 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
2934 -- Build name to be used in implicit with_clause. In most cases this
2935 -- is the source name, but if renamings are present we must make the
2936 -- original unit visible, not the one it renames. The entity in the
2937 -- with clause is the renamed unit, but the identifier is the one from
2938 -- the source, which allows us to recover the unit renaming.
2940 ---------------------
2941 -- Build_Unit_Name --
2942 ---------------------
2944 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
2949 if Nkind
(Nam
) = N_Identifier
then
2950 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
2953 Ent
:= Entity
(Nam
);
2955 if Present
(Entity
(Selector_Name
(Nam
)))
2956 and then Chars
(Entity
(Selector_Name
(Nam
))) /= Chars
(Ent
)
2958 Nkind
(Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
))))
2959 = N_Package_Renaming_Declaration
2961 -- The name in the with_clause is of the form A.B.C, and B is
2962 -- given by a renaming declaration. In that case we may not
2963 -- have analyzed the unit for B, but replaced it directly in
2964 -- lib-load with the unit it renames. We have to make A.B
2965 -- visible, so analyze the declaration for B now, in case it
2966 -- has not been done yet.
2968 Ent
:= Entity
(Selector_Name
(Nam
));
2971 (Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))));
2975 Make_Expanded_Name
(Loc
,
2976 Chars
=> Chars
(Entity
(Nam
)),
2977 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
2978 Selector_Name
=> New_Occurrence_Of
(Ent
, Loc
));
2979 Set_Entity
(Result
, Ent
);
2982 end Build_Unit_Name
;
2984 -- Start of processing for Expand_With_Clause
2988 Make_With_Clause
(Loc
,
2989 Name
=> Build_Unit_Name
(Nam
));
2991 P
:= Parent
(Unit_Declaration_Node
(Ent
));
2992 Set_Library_Unit
(Withn
, P
);
2993 Set_Corresponding_Spec
(Withn
, Ent
);
2994 Set_First_Name
(Withn
, True);
2995 Set_Implicit_With
(Withn
, True);
2997 -- If the unit is a package or generic package declaration, a private_
2998 -- with_clause on a child unit implies that the implicit with on the
2999 -- parent is also private.
3001 if Nkind_In
(Unit
(N
), N_Package_Declaration
,
3002 N_Generic_Package_Declaration
)
3004 Set_Private_Present
(Withn
, Private_Present
(Item
));
3007 Prepend
(Withn
, Context_Items
(N
));
3008 Mark_Rewrite_Insertion
(Withn
);
3009 Install_Withed_Unit
(Withn
);
3011 -- If we have "with X.Y;", we want to recurse on "X", except in the
3012 -- unusual case where X.Y is a renaming of X. In that case, the scope
3013 -- of X will be null.
3015 if Nkind
(Nam
) = N_Expanded_Name
3016 and then Present
(Scope
(Entity
(Prefix
(Nam
))))
3018 Expand_With_Clause
(Item
, Prefix
(Nam
), N
);
3020 end Expand_With_Clause
;
3022 --------------------------------
3023 -- Generate_Parent_References --
3024 --------------------------------
3026 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
3028 P_Name
: Entity_Id
:= P_Id
;
3031 if Nkind
(N
) = N_Subunit
then
3034 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
3037 if Nkind
(Pref
) = N_Expanded_Name
then
3039 -- Done already, if the unit has been compiled indirectly as
3040 -- part of the closure of its context because of inlining.
3045 while Nkind
(Pref
) = N_Selected_Component
loop
3046 Change_Selected_Component_To_Expanded_Name
(Pref
);
3047 Set_Entity
(Pref
, P_Name
);
3048 Set_Etype
(Pref
, Etype
(P_Name
));
3049 Generate_Reference
(P_Name
, Pref
, 'r');
3050 Pref
:= Prefix
(Pref
);
3051 P_Name
:= Scope
(P_Name
);
3054 -- The guard here on P_Name is to handle the error condition where
3055 -- the parent unit is missing because the file was not found.
3057 if Present
(P_Name
) then
3058 Set_Entity
(Pref
, P_Name
);
3059 Set_Etype
(Pref
, Etype
(P_Name
));
3060 Generate_Reference
(P_Name
, Pref
, 'r');
3061 Style
.Check_Identifier
(Pref
, P_Name
);
3063 end Generate_Parent_References
;
3065 -----------------------
3066 -- Get_Parent_Entity --
3067 -----------------------
3069 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
3071 if Nkind
(Unit
) = N_Package_Body
3072 and then Nkind
(Original_Node
(Unit
)) = N_Package_Instantiation
3074 return Defining_Entity
3075 (Specification
(Instance_Spec
(Original_Node
(Unit
))));
3076 elsif Nkind
(Unit
) = N_Package_Instantiation
then
3077 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
3079 return Defining_Entity
(Unit
);
3081 end Get_Parent_Entity
;
3083 ---------------------
3084 -- Has_With_Clause --
3085 ---------------------
3087 function Has_With_Clause
3090 Is_Limited
: Boolean := False) return Boolean
3094 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
;
3095 -- Return the entity for the unit named in a [limited] with clause
3101 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
is
3103 if Nkind
(Name
(Clause
)) = N_Selected_Component
then
3104 return Entity
(Selector_Name
(Name
(Clause
)));
3106 return Entity
(Name
(Clause
));
3110 -- Start of processing for Has_With_Clause
3113 if Present
(Context_Items
(C_Unit
)) then
3114 Item
:= First
(Context_Items
(C_Unit
));
3115 while Present
(Item
) loop
3116 if Nkind
(Item
) = N_With_Clause
3117 and then Limited_Present
(Item
) = Is_Limited
3118 and then Named_Unit
(Item
) = Pack
3128 end Has_With_Clause
;
3130 -----------------------------
3131 -- Implicit_With_On_Parent --
3132 -----------------------------
3134 procedure Implicit_With_On_Parent
3135 (Child_Unit
: Node_Id
;
3138 Loc
: constant Source_Ptr
:= Sloc
(N
);
3139 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
3140 P_Unit
: Node_Id
:= Unit
(P
);
3141 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
3144 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
3145 -- Build prefix of child unit name. Recurse if needed
3147 function Build_Unit_Name
return Node_Id
;
3148 -- If the unit is a child unit, build qualified name with all ancestors
3150 -------------------------
3151 -- Build_Ancestor_Name --
3152 -------------------------
3154 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
3155 P_Ref
: constant Node_Id
:=
3156 New_Reference_To
(Defining_Entity
(P
), Loc
);
3157 P_Spec
: Node_Id
:= P
;
3160 -- Ancestor may have been rewritten as a package body. Retrieve
3161 -- the original spec to trace earlier ancestors.
3163 if Nkind
(P
) = N_Package_Body
3164 and then Nkind
(Original_Node
(P
)) = N_Package_Instantiation
3166 P_Spec
:= Original_Node
(P
);
3169 if No
(Parent_Spec
(P_Spec
)) then
3173 Make_Selected_Component
(Loc
,
3174 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Spec
))),
3175 Selector_Name
=> P_Ref
);
3177 end Build_Ancestor_Name
;
3179 ---------------------
3180 -- Build_Unit_Name --
3181 ---------------------
3183 function Build_Unit_Name
return Node_Id
is
3187 if No
(Parent_Spec
(P_Unit
)) then
3188 return New_Reference_To
(P_Name
, Loc
);
3192 Make_Expanded_Name
(Loc
,
3193 Chars
=> Chars
(P_Name
),
3194 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
3195 Selector_Name
=> New_Reference_To
(P_Name
, Loc
));
3196 Set_Entity
(Result
, P_Name
);
3199 end Build_Unit_Name
;
3201 -- Start of processing for Implicit_With_On_Parent
3204 -- The unit of the current compilation may be a package body that
3205 -- replaces an instance node. In this case we need the original instance
3206 -- node to construct the proper parent name.
3208 if Nkind
(P_Unit
) = N_Package_Body
3209 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
3211 P_Unit
:= Original_Node
(P_Unit
);
3214 -- We add the implicit with if the child unit is the current unit being
3215 -- compiled. If the current unit is a body, we do not want to add an
3216 -- implicit_with a second time to the corresponding spec.
3218 if Nkind
(Child_Unit
) = N_Package_Declaration
3219 and then Child_Unit
/= Unit
(Cunit
(Current_Sem_Unit
))
3224 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
3226 Set_Library_Unit
(Withn
, P
);
3227 Set_Corresponding_Spec
(Withn
, P_Name
);
3228 Set_First_Name
(Withn
, True);
3229 Set_Implicit_With
(Withn
, True);
3231 -- Node is placed at the beginning of the context items, so that
3232 -- subsequent use clauses on the parent can be validated.
3234 Prepend
(Withn
, Context_Items
(N
));
3235 Mark_Rewrite_Insertion
(Withn
);
3236 Install_Withed_Unit
(Withn
);
3238 if Is_Child_Spec
(P_Unit
) then
3239 Implicit_With_On_Parent
(P_Unit
, N
);
3241 end Implicit_With_On_Parent
;
3247 function In_Chain
(E
: Entity_Id
) return Boolean is
3251 H
:= Current_Entity
(E
);
3252 while Present
(H
) loop
3263 ---------------------
3264 -- Install_Context --
3265 ---------------------
3267 procedure Install_Context
(N
: Node_Id
) is
3268 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3271 Install_Context_Clauses
(N
);
3273 if Is_Child_Spec
(Lib_Unit
) then
3274 Install_Parents
(Lib_Unit
, Private_Present
(Parent
(Lib_Unit
)));
3277 Install_Limited_Context_Clauses
(N
);
3278 end Install_Context
;
3280 -----------------------------
3281 -- Install_Context_Clauses --
3282 -----------------------------
3284 procedure Install_Context_Clauses
(N
: Node_Id
) is
3285 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3287 Uname_Node
: Entity_Id
;
3288 Check_Private
: Boolean := False;
3289 Decl_Node
: Node_Id
;
3290 Lib_Parent
: Entity_Id
;
3293 -- First skip configuration pragmas at the start of the context. They
3294 -- are not technically part of the context clause, but that's where the
3295 -- parser puts them. Note they were analyzed in Analyze_Context.
3297 Item
:= First
(Context_Items
(N
));
3298 while Present
(Item
)
3299 and then Nkind
(Item
) = N_Pragma
3300 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
3305 -- Loop through the actual context clause items. We process everything
3306 -- except Limited_With clauses in this routine. Limited_With clauses
3307 -- are separately installed (see Install_Limited_Context_Clauses).
3309 while Present
(Item
) loop
3311 -- Case of explicit WITH clause
3313 if Nkind
(Item
) = N_With_Clause
3314 and then not Implicit_With
(Item
)
3316 if Limited_Present
(Item
) then
3318 -- Limited withed units will be installed later
3322 -- If Name (Item) is not an entity name, something is wrong, and
3323 -- this will be detected in due course, for now ignore the item
3325 elsif not Is_Entity_Name
(Name
(Item
)) then
3328 elsif No
(Entity
(Name
(Item
))) then
3329 Set_Entity
(Name
(Item
), Any_Id
);
3333 Uname_Node
:= Entity
(Name
(Item
));
3335 if Is_Private_Descendant
(Uname_Node
) then
3336 Check_Private
:= True;
3339 Install_Withed_Unit
(Item
);
3341 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
3343 -- If the unit is a subprogram instance, it appears nested within
3344 -- a package that carries the parent information.
3346 if Is_Generic_Instance
(Uname_Node
)
3347 and then Ekind
(Uname_Node
) /= E_Package
3349 Decl_Node
:= Parent
(Parent
(Decl_Node
));
3352 if Is_Child_Spec
(Decl_Node
) then
3353 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
3354 Expand_With_Clause
(Item
, Prefix
(Name
(Item
)), N
);
3356 -- If not an expanded name, the child unit must be a
3357 -- renaming, nothing to do.
3362 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
3363 and then not Acts_As_Spec
(Parent
(Decl_Node
))
3364 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
3366 Implicit_With_On_Parent
3367 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
3370 -- Check license conditions unless this is a dummy unit
3372 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
3373 License_Check
: declare
3374 Withu
: constant Unit_Number_Type
:=
3375 Get_Source_Unit
(Library_Unit
(Item
));
3376 Withl
: constant License_Type
:=
3377 License
(Source_Index
(Withu
));
3378 Unitl
: constant License_Type
:=
3379 License
(Source_Index
(Current_Sem_Unit
));
3381 procedure License_Error
;
3382 -- Signal error of bad license
3388 procedure License_Error
is
3391 ("license of withed unit & may be inconsistent??",
3395 -- Start of processing for License_Check
3398 -- Exclude license check if withed unit is an internal unit.
3399 -- This situation arises e.g. with the GPL version of GNAT.
3401 if Is_Internal_File_Name
(Unit_File_Name
(Withu
)) then
3404 -- Otherwise check various cases
3416 if Withl
= Restricted
then
3420 when Modified_GPL
=>
3421 if Withl
= Restricted
or else Withl
= GPL
then
3425 when Unrestricted
=>
3432 -- Case of USE PACKAGE clause
3434 elsif Nkind
(Item
) = N_Use_Package_Clause
then
3435 Analyze_Use_Package
(Item
);
3437 -- Case of USE TYPE clause
3439 elsif Nkind
(Item
) = N_Use_Type_Clause
then
3440 Analyze_Use_Type
(Item
);
3444 elsif Nkind
(Item
) = N_Pragma
then
3452 if Is_Child_Spec
(Lib_Unit
) then
3454 -- The unit also has implicit with_clauses on its own parents
3456 if No
(Context_Items
(N
)) then
3457 Set_Context_Items
(N
, New_List
);
3460 Implicit_With_On_Parent
(Lib_Unit
, N
);
3463 -- If the unit is a body, the context of the specification must also
3464 -- be installed. That includes private with_clauses in that context.
3466 if Nkind
(Lib_Unit
) = N_Package_Body
3467 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3468 and then not Acts_As_Spec
(N
))
3470 Install_Context
(Library_Unit
(N
));
3472 -- Only install private with-clauses of a spec that comes from
3473 -- source, excluding specs created for a subprogram body that is
3476 if Comes_From_Source
(Library_Unit
(N
)) then
3477 Install_Private_With_Clauses
3478 (Defining_Entity
(Unit
(Library_Unit
(N
))));
3481 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
3483 -- If the unit is the body of a public child unit, the private
3484 -- declarations of the parent must be made visible. If the child
3485 -- unit is private, the private declarations have been installed
3486 -- already in the call to Install_Parents for the spec. Installing
3487 -- private declarations must be done for all ancestors of public
3488 -- child units. In addition, sibling units mentioned in the
3489 -- context clause of the body are directly visible.
3497 Lib_Spec
:= Unit
(Library_Unit
(N
));
3498 while Is_Child_Spec
(Lib_Spec
) loop
3499 P
:= Unit
(Parent_Spec
(Lib_Spec
));
3500 P_Name
:= Defining_Entity
(P
);
3502 if not (Private_Present
(Parent
(Lib_Spec
)))
3503 and then not In_Private_Part
(P_Name
)
3505 Install_Private_Declarations
(P_Name
);
3506 Install_Private_With_Clauses
(P_Name
);
3507 Set_Use
(Private_Declarations
(Specification
(P
)));
3515 -- For a package body, children in context are immediately visible
3517 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
3520 if Nkind_In
(Lib_Unit
, N_Generic_Package_Declaration
,
3521 N_Generic_Subprogram_Declaration
,
3522 N_Package_Declaration
,
3523 N_Subprogram_Declaration
)
3525 if Is_Child_Spec
(Lib_Unit
) then
3526 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
3527 Set_Is_Private_Descendant
3528 (Defining_Entity
(Lib_Unit
),
3529 Is_Private_Descendant
(Lib_Parent
)
3530 or else Private_Present
(Parent
(Lib_Unit
)));
3533 Set_Is_Private_Descendant
3534 (Defining_Entity
(Lib_Unit
),
3535 Private_Present
(Parent
(Lib_Unit
)));
3539 if Check_Private
then
3540 Check_Private_Child_Unit
(N
);
3542 end Install_Context_Clauses
;
3544 -------------------------------------
3545 -- Install_Limited_Context_Clauses --
3546 -------------------------------------
3548 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
3551 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
);
3552 -- Check that the unlimited view of a given compilation_unit is not
3553 -- already visible through "use + renamings".
3555 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
);
3556 -- Check that if a limited_with clause of a given compilation_unit
3557 -- mentions a descendant of a private child of some library unit, then
3558 -- the given compilation_unit shall be the declaration of a private
3559 -- descendant of that library unit, or a public descendant of such. The
3560 -- code is analogous to that of Check_Private_Child_Unit but we cannot
3561 -- use entities on the limited with_clauses because their units have not
3562 -- been analyzed, so we have to climb the tree of ancestors looking for
3563 -- private keywords.
3565 procedure Expand_Limited_With_Clause
3566 (Comp_Unit
: Node_Id
;
3569 -- If a child unit appears in a limited_with clause, there are implicit
3570 -- limited_with clauses on all parents that are not already visible
3571 -- through a regular with clause. This procedure creates the implicit
3572 -- limited with_clauses for the parents and loads the corresponding
3573 -- units. The shadow entities are created when the inserted clause is
3574 -- analyzed. Implements Ada 2005 (AI-50217).
3576 ---------------------
3577 -- Check_Renamings --
3578 ---------------------
3580 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
) is
3589 pragma Assert
(Nkind
(W
) = N_With_Clause
);
3591 -- Protect the frontend against previous critical errors
3593 case Nkind
(Unit
(Library_Unit
(W
))) is
3594 when N_Subprogram_Declaration |
3595 N_Package_Declaration |
3596 N_Generic_Subprogram_Declaration |
3597 N_Generic_Package_Declaration
=>
3604 -- Check "use + renamings"
3606 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
3607 Spec
:= Specification
(Unit
(P
));
3609 Item
:= First
(Visible_Declarations
(Spec
));
3610 while Present
(Item
) loop
3612 -- Look only at use package clauses
3614 if Nkind
(Item
) = N_Use_Package_Clause
then
3616 -- Traverse the list of packages
3618 Nam
:= First
(Names
(Item
));
3619 while Present
(Nam
) loop
3622 pragma Assert
(Present
(Parent
(E
)));
3624 if Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
3625 and then Renamed_Entity
(E
) = WEnt
3627 -- The unlimited view is visible through use clause and
3628 -- renamings. There is no need to generate the error
3629 -- message here because Is_Visible_Through_Renamings
3630 -- takes care of generating the precise error message.
3634 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
3636 -- The use clause may refer to a local package.
3637 -- Check all the enclosing scopes.
3640 while E2
/= Standard_Standard
and then E2
/= WEnt
loop
3646 ("unlimited view visible through use clause ", W
);
3658 -- Recursive call to check all the ancestors
3660 if Is_Child_Spec
(Unit
(P
)) then
3661 Check_Renamings
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
3663 end Check_Renamings
;
3665 ---------------------------------------
3666 -- Check_Private_Limited_Withed_Unit --
3667 ---------------------------------------
3669 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
) is
3670 Curr_Parent
: Node_Id
;
3671 Child_Parent
: Node_Id
;
3672 Curr_Private
: Boolean;
3675 -- Compilation unit of the parent of the withed library unit
3677 Child_Parent
:= Library_Unit
(Item
);
3679 -- If the child unit is a public child, then locate its nearest
3680 -- private ancestor, if any, then Child_Parent will then be set to
3681 -- the parent of that ancestor.
3683 if not Private_Present
(Library_Unit
(Item
)) then
3684 while Present
(Child_Parent
)
3685 and then not Private_Present
(Child_Parent
)
3687 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3690 if No
(Child_Parent
) then
3695 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3697 -- Traverse all the ancestors of the current compilation unit to
3698 -- check if it is a descendant of named library unit.
3700 Curr_Parent
:= Parent
(Item
);
3701 Curr_Private
:= Private_Present
(Curr_Parent
);
3703 while Present
(Parent_Spec
(Unit
(Curr_Parent
)))
3704 and then Curr_Parent
/= Child_Parent
3706 Curr_Parent
:= Parent_Spec
(Unit
(Curr_Parent
));
3707 Curr_Private
:= Curr_Private
or else Private_Present
(Curr_Parent
);
3710 if Curr_Parent
/= Child_Parent
then
3712 ("unit in with clause is private child unit!", Item
);
3714 ("\current unit must also have parent&!",
3715 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3717 elsif Private_Present
(Parent
(Item
))
3718 or else Curr_Private
3719 or else Private_Present
(Item
)
3720 or else Nkind_In
(Unit
(Parent
(Item
)), N_Package_Body
,
3724 -- Current unit is private, of descendant of a private unit
3730 ("current unit must also be private descendant of&",
3731 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3733 end Check_Private_Limited_Withed_Unit
;
3735 --------------------------------
3736 -- Expand_Limited_With_Clause --
3737 --------------------------------
3739 procedure Expand_Limited_With_Clause
3740 (Comp_Unit
: Node_Id
;
3744 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
3745 Unum
: Unit_Number_Type
;
3748 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean;
3749 -- Returns true if the context already includes a with_clause for
3750 -- this unit. If the with_clause is non-limited, the unit is fully
3751 -- visible and an implicit limited_with should not be created. If
3752 -- there is already a limited_with clause for W, a second one is
3753 -- simply redundant.
3755 --------------------------
3756 -- Previous_Withed_Unit --
3757 --------------------------
3759 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean is
3763 -- A limited with_clause cannot appear in the same context_clause
3764 -- as a nonlimited with_clause which mentions the same library.
3766 Item
:= First
(Context_Items
(Comp_Unit
));
3767 while Present
(Item
) loop
3768 if Nkind
(Item
) = N_With_Clause
3769 and then Library_Unit
(Item
) = Library_Unit
(W
)
3778 end Previous_Withed_Unit
;
3780 -- Start of processing for Expand_Limited_With_Clause
3783 if Nkind
(Nam
) = N_Identifier
then
3785 -- Create node for name of withed unit
3788 Make_With_Clause
(Loc
,
3789 Name
=> New_Copy
(Nam
));
3791 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
3793 Make_With_Clause
(Loc
,
3794 Name
=> Make_Selected_Component
(Loc
,
3795 Prefix
=> New_Copy_Tree
(Prefix
(Nam
)),
3796 Selector_Name
=> New_Copy
(Selector_Name
(Nam
))));
3797 Set_Parent
(Withn
, Parent
(N
));
3800 Set_Limited_Present
(Withn
);
3801 Set_First_Name
(Withn
);
3802 Set_Implicit_With
(Withn
);
3806 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
3811 -- Do not generate a limited_with_clause on the current unit. This
3812 -- path is taken when a unit has a limited_with clause on one of its
3815 if Unum
= Current_Sem_Unit
then
3819 Set_Library_Unit
(Withn
, Cunit
(Unum
));
3820 Set_Corresponding_Spec
3821 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
3823 if not Previous_Withed_Unit
(Withn
) then
3824 Prepend
(Withn
, Context_Items
(Parent
(N
)));
3825 Mark_Rewrite_Insertion
(Withn
);
3827 -- Add implicit limited_with_clauses for parents of child units
3828 -- mentioned in limited_with clauses.
3830 if Nkind
(Nam
) = N_Selected_Component
then
3831 Expand_Limited_With_Clause
(Comp_Unit
, Prefix
(Nam
), N
);
3836 if not Limited_View_Installed
(Withn
) then
3837 Install_Limited_Withed_Unit
(Withn
);
3840 end Expand_Limited_With_Clause
;
3842 -- Start of processing for Install_Limited_Context_Clauses
3845 Item
:= First
(Context_Items
(N
));
3846 while Present
(Item
) loop
3847 if Nkind
(Item
) = N_With_Clause
3848 and then Limited_Present
(Item
)
3849 and then not Error_Posted
(Item
)
3851 if Nkind
(Name
(Item
)) = N_Selected_Component
then
3852 Expand_Limited_With_Clause
3853 (Comp_Unit
=> N
, Nam
=> Prefix
(Name
(Item
)), N
=> Item
);
3856 Check_Private_Limited_Withed_Unit
(Item
);
3858 if not Implicit_With
(Item
) and then Is_Child_Spec
(Unit
(N
)) then
3859 Check_Renamings
(Parent_Spec
(Unit
(N
)), Item
);
3862 -- A unit may have a limited with on itself if it has a limited
3863 -- with_clause on one of its child units. In that case it is
3864 -- already being compiled and it makes no sense to install its
3867 -- If the item is a limited_private_with_clause, install it if the
3868 -- current unit is a body or if it is a private child. Otherwise
3869 -- the private clause is installed before analyzing the private
3870 -- part of the current unit.
3872 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
)
3873 and then not Limited_View_Installed
(Item
)
3875 not Is_Ancestor_Unit
3876 (Library_Unit
(Item
), Cunit
(Current_Sem_Unit
))
3878 if not Private_Present
(Item
)
3879 or else Private_Present
(N
)
3880 or else Nkind_In
(Unit
(N
), N_Package_Body
,
3884 Install_Limited_Withed_Unit
(Item
);
3892 -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
3893 -- looking for incomplete subtype declarations of incomplete types
3894 -- visible through a limited with clause.
3896 if Ada_Version
>= Ada_2005
3897 and then Analyzed
(N
)
3898 and then Nkind
(Unit
(N
)) = N_Package_Declaration
3903 Non_Lim_View
: Entity_Id
;
3906 Decl
:= First
(Visible_Declarations
(Specification
(Unit
(N
))));
3907 while Present
(Decl
) loop
3908 if Nkind
(Decl
) = N_Subtype_Declaration
3910 Ekind
(Defining_Identifier
(Decl
)) = E_Incomplete_Subtype
3912 From_Limited_With
(Defining_Identifier
(Decl
))
3914 Def_Id
:= Defining_Identifier
(Decl
);
3915 Non_Lim_View
:= Non_Limited_View
(Def_Id
);
3917 if not Is_Incomplete_Type
(Non_Lim_View
) then
3919 -- Convert an incomplete subtype declaration into a
3920 -- corresponding non-limited view subtype declaration.
3921 -- This is usually the case when analyzing a body that
3922 -- has regular with clauses, when the spec has limited
3925 -- If the non-limited view is still incomplete, it is
3926 -- the dummy entry already created, and the declaration
3927 -- cannot be reanalyzed. This is the case when installing
3928 -- a parent unit that has limited with-clauses.
3930 Set_Subtype_Indication
(Decl
,
3931 New_Reference_To
(Non_Lim_View
, Sloc
(Def_Id
)));
3932 Set_Etype
(Def_Id
, Non_Lim_View
);
3933 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(Non_Lim_View
)));
3934 Set_Analyzed
(Decl
, False);
3936 -- Reanalyze the declaration, suppressing the call to
3937 -- Enter_Name to avoid duplicate names.
3939 Analyze_Subtype_Declaration
3949 end Install_Limited_Context_Clauses
;
3951 ---------------------
3952 -- Install_Parents --
3953 ---------------------
3955 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean) is
3962 P
:= Unit
(Parent_Spec
(Lib_Unit
));
3963 P_Name
:= Get_Parent_Entity
(P
);
3965 if Etype
(P_Name
) = Any_Type
then
3969 if Ekind
(P_Name
) = E_Generic_Package
3970 and then not Nkind_In
(Lib_Unit
, N_Generic_Subprogram_Declaration
,
3971 N_Generic_Package_Declaration
)
3972 and then Nkind
(Lib_Unit
) not in N_Generic_Renaming_Declaration
3975 ("child of a generic package must be a generic unit", Lib_Unit
);
3977 elsif not Is_Package_Or_Generic_Package
(P_Name
) then
3979 ("parent unit must be package or generic package", Lib_Unit
);
3980 raise Unrecoverable_Error
;
3982 elsif Present
(Renamed_Object
(P_Name
)) then
3983 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
3984 raise Unrecoverable_Error
;
3986 -- Verify that a child of an instance is itself an instance, or the
3987 -- renaming of one. Given that an instance that is a unit is replaced
3988 -- with a package declaration, check against the original node. The
3989 -- parent may be currently being instantiated, in which case it appears
3990 -- as a declaration, but the generic_parent is already established
3991 -- indicating that we deal with an instance.
3993 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
then
3994 if Nkind
(Lib_Unit
) in N_Renaming_Declaration
3995 or else Nkind
(Original_Node
(Lib_Unit
)) in N_Generic_Instantiation
3997 (Nkind
(Lib_Unit
) = N_Package_Declaration
3998 and then Present
(Generic_Parent
(Specification
(Lib_Unit
))))
4003 ("child of an instance must be an instance or renaming",
4008 -- This is the recursive call that ensures all parents are loaded
4010 if Is_Child_Spec
(P
) then
4012 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)));
4015 -- Now we can install the context for this parent
4017 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
));
4018 Install_Limited_Context_Clauses
(Parent_Spec
(Lib_Unit
));
4019 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
4021 -- The child unit is in the declarative region of the parent. The parent
4022 -- must therefore appear in the scope stack and be visible, as when
4023 -- compiling the corresponding body. If the child unit is private or it
4024 -- is a package body, private declarations must be accessible as well.
4025 -- Use declarations in the parent must also be installed. Finally, other
4026 -- child units of the same parent that are in the context are
4027 -- immediately visible.
4029 -- Find entity for compilation unit, and set its private descendant
4030 -- status as needed. Indicate that it is a compilation unit, which is
4031 -- redundant in general, but needed if this is a generated child spec
4032 -- for a child body without previous spec.
4034 E_Name
:= Defining_Entity
(Lib_Unit
);
4036 Set_Is_Child_Unit
(E_Name
);
4037 Set_Is_Compilation_Unit
(E_Name
);
4039 Set_Is_Private_Descendant
(E_Name
,
4040 Is_Private_Descendant
(P_Name
)
4041 or else Private_Present
(Parent
(Lib_Unit
)));
4043 P_Spec
:= Package_Specification
(P_Name
);
4044 Push_Scope
(P_Name
);
4046 -- Save current visibility of unit
4048 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
4049 Is_Immediately_Visible
(P_Name
);
4050 Set_Is_Immediately_Visible
(P_Name
);
4051 Install_Visible_Declarations
(P_Name
);
4052 Set_Use
(Visible_Declarations
(P_Spec
));
4054 -- If the parent is a generic unit, its formal part may contain formal
4055 -- packages and use clauses for them.
4057 if Ekind
(P_Name
) = E_Generic_Package
then
4058 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
4061 if Is_Private
or else Private_Present
(Parent
(Lib_Unit
)) then
4062 Install_Private_Declarations
(P_Name
);
4063 Install_Private_With_Clauses
(P_Name
);
4064 Set_Use
(Private_Declarations
(P_Spec
));
4066 end Install_Parents
;
4068 ----------------------------------
4069 -- Install_Private_With_Clauses --
4070 ----------------------------------
4072 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
4073 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
4077 if Debug_Flag_I
then
4078 Write_Str
("install private with clauses of ");
4079 Write_Name
(Chars
(P
));
4083 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
4084 Item
:= First
(Context_Items
(Parent
(Decl
)));
4085 while Present
(Item
) loop
4086 if Nkind
(Item
) = N_With_Clause
4087 and then Private_Present
(Item
)
4089 -- If the unit is an ancestor of the current one, it is the
4090 -- case of a private limited with clause on a child unit, and
4091 -- the compilation of one of its descendants, In that case the
4092 -- limited view is errelevant.
4094 if Limited_Present
(Item
) then
4095 if not Limited_View_Installed
(Item
)
4097 not Is_Ancestor_Unit
(Library_Unit
(Item
),
4098 Cunit
(Current_Sem_Unit
))
4100 Install_Limited_Withed_Unit
(Item
);
4103 Install_Withed_Unit
(Item
, Private_With_OK
=> True);
4110 end Install_Private_With_Clauses
;
4112 ----------------------
4113 -- Install_Siblings --
4114 ----------------------
4116 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
4122 -- Iterate over explicit with clauses, and check whether the scope of
4123 -- each entity is an ancestor of the current unit, in which case it is
4124 -- immediately visible.
4126 Item
:= First
(Context_Items
(N
));
4127 while Present
(Item
) loop
4129 -- Do not install private_with_clauses declaration, unless unit
4130 -- is itself a private child unit, or is a body. Note that for a
4131 -- subprogram body the private_with_clause does not take effect until
4132 -- after the specification.
4134 if Nkind
(Item
) /= N_With_Clause
4135 or else Implicit_With
(Item
)
4136 or else Limited_Present
(Item
)
4137 or else Error_Posted
(Item
)
4141 elsif not Private_Present
(Item
)
4142 or else Private_Present
(N
)
4143 or else Nkind
(Unit
(N
)) = N_Package_Body
4145 Id
:= Entity
(Name
(Item
));
4147 if Is_Child_Unit
(Id
)
4148 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
4150 Set_Is_Immediately_Visible
(Id
);
4152 -- Check for the presence of another unit in the context that
4153 -- may be inadvertently hidden by the child.
4155 Prev
:= Current_Entity
(Id
);
4158 and then Is_Immediately_Visible
(Prev
)
4159 and then not Is_Child_Unit
(Prev
)
4165 Clause
:= First
(Context_Items
(N
));
4166 while Present
(Clause
) loop
4167 if Nkind
(Clause
) = N_With_Clause
4168 and then Entity
(Name
(Clause
)) = Prev
4171 ("child unit& hides compilation unit " &
4172 "with the same name??",
4182 -- The With_Clause may be on a grand-child or one of its further
4183 -- descendants, which makes a child immediately visible. Examine
4184 -- ancestry to determine whether such a child exists. For example,
4185 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4186 -- is immediately visible.
4188 elsif Is_Child_Unit
(Id
) then
4194 while Is_Child_Unit
(Par
) loop
4195 if Is_Ancestor_Package
(Scope
(Par
), U_Name
) then
4196 Set_Is_Immediately_Visible
(Par
);
4205 -- If the item is a private with-clause on a child unit, the parent
4206 -- may have been installed already, but the child unit must remain
4207 -- invisible until installed in a private part or body, unless there
4208 -- is already a regular with_clause for it in the current unit.
4210 elsif Private_Present
(Item
) then
4211 Id
:= Entity
(Name
(Item
));
4213 if Is_Child_Unit
(Id
) then
4217 function In_Context
return Boolean;
4218 -- Scan context of current unit, to check whether there is
4219 -- a with_clause on the same unit as a private with-clause
4220 -- on a parent, in which case child unit is visible. If the
4221 -- unit is a grand-child, the same applies to its parent.
4227 function In_Context
return Boolean is
4230 First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4231 while Present
(Clause
) loop
4232 if Nkind
(Clause
) = N_With_Clause
4233 and then Comes_From_Source
(Clause
)
4234 and then Is_Entity_Name
(Name
(Clause
))
4235 and then not Private_Present
(Clause
)
4237 if Entity
(Name
(Clause
)) = Id
4239 (Nkind
(Name
(Clause
)) = N_Expanded_Name
4240 and then Entity
(Prefix
(Name
(Clause
))) = Id
)
4253 Set_Is_Visible_Lib_Unit
(Id
, In_Context
);
4260 end Install_Siblings
;
4262 ---------------------------------
4263 -- Install_Limited_Withed_Unit --
4264 ---------------------------------
4266 procedure Install_Limited_Withed_Unit
(N
: Node_Id
) is
4267 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
4270 Is_Child_Package
: Boolean := False;
4271 Lim_Header
: Entity_Id
;
4272 Lim_Typ
: Entity_Id
;
4274 procedure Check_Body_Required
;
4275 -- A unit mentioned in a limited with_clause may not be mentioned in
4276 -- a regular with_clause, but must still be included in the current
4277 -- partition. We need to determine whether the unit needs a body, so
4278 -- that the binder can determine the name of the file to be compiled.
4279 -- Checking whether a unit needs a body can be done without semantic
4280 -- analysis, by examining the nature of the declarations in the package.
4282 function Has_Limited_With_Clause
4283 (C_Unit
: Entity_Id
;
4284 Pack
: Entity_Id
) return Boolean;
4285 -- Determine whether any package in the ancestor chain starting with
4286 -- C_Unit has a limited with clause for package Pack.
4288 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean;
4289 -- Check if some package installed though normal with-clauses has a
4290 -- renaming declaration of package P. AARM 10.1.2(21/2).
4292 -------------------------
4293 -- Check_Body_Required --
4294 -------------------------
4296 procedure Check_Body_Required
is
4297 PA
: constant List_Id
:=
4298 Pragmas_After
(Aux_Decls_Node
(Parent
(P_Unit
)));
4300 procedure Check_Declarations
(Spec
: Node_Id
);
4301 -- Recursive procedure that does the work and checks nested packages
4303 ------------------------
4304 -- Check_Declarations --
4305 ------------------------
4307 procedure Check_Declarations
(Spec
: Node_Id
) is
4309 Incomplete_Decls
: constant Elist_Id
:= New_Elmt_List
;
4311 Subp_List
: constant Elist_Id
:= New_Elmt_List
;
4313 procedure Check_Pragma_Import
(P
: Node_Id
);
4314 -- If a pragma import applies to a previous subprogram, the
4315 -- enclosing unit may not need a body. The processing is syntactic
4316 -- and does not require a declaration to be analyzed. The code
4317 -- below also handles pragma Import when applied to a subprogram
4318 -- that renames another. In this case the pragma applies to the
4321 -- Chains of multiple renames are not handled by the code below.
4322 -- It is probably impossible to handle all cases without proper
4323 -- name resolution. In such cases the algorithm is conservative
4324 -- and will indicate that a body is needed???
4326 -------------------------
4327 -- Check_Pragma_Import --
4328 -------------------------
4330 procedure Check_Pragma_Import
(P
: Node_Id
) is
4336 procedure Remove_Homonyms
(E
: Node_Id
);
4337 -- Make one pass over list of subprograms. Called again if
4338 -- subprogram is a renaming. E is known to be an identifier.
4340 ---------------------
4341 -- Remove_Homonyms --
4342 ---------------------
4344 procedure Remove_Homonyms
(E
: Node_Id
) is
4345 R
: Entity_Id
:= Empty
;
4346 -- Name of renamed entity, if any
4349 Subp_Id
:= First_Elmt
(Subp_List
);
4350 while Present
(Subp_Id
) loop
4351 if Chars
(Node
(Subp_Id
)) = Chars
(E
) then
4352 if Nkind
(Parent
(Parent
(Node
(Subp_Id
))))
4353 /= N_Subprogram_Renaming_Declaration
4356 Next_Elmt
(Subp_Id
);
4357 Remove_Elmt
(Subp_List
, Prev_Id
);
4359 R
:= Name
(Parent
(Parent
(Node
(Subp_Id
))));
4363 Next_Elmt
(Subp_Id
);
4368 if Nkind
(R
) = N_Identifier
then
4369 Remove_Homonyms
(R
);
4371 elsif Nkind
(R
) = N_Selected_Component
then
4372 Remove_Homonyms
(Selector_Name
(R
));
4374 -- Renaming of attribute
4380 end Remove_Homonyms
;
4382 -- Start of processing for Check_Pragma_Import
4385 -- Find name of entity in Import pragma. We have not analyzed
4386 -- the construct, so we must guard against syntax errors.
4388 Arg
:= Next
(First
(Pragma_Argument_Associations
(P
)));
4391 or else Nkind
(Expression
(Arg
)) /= N_Identifier
4395 Imported
:= Expression
(Arg
);
4398 Remove_Homonyms
(Imported
);
4399 end Check_Pragma_Import
;
4401 -- Start of processing for Check_Declarations
4404 -- Search for Elaborate Body pragma
4406 Decl
:= First
(Visible_Declarations
(Spec
));
4407 while Present
(Decl
)
4408 and then Nkind
(Decl
) = N_Pragma
4410 if Get_Pragma_Id
(Decl
) = Pragma_Elaborate_Body
then
4411 Set_Body_Required
(Library_Unit
(N
));
4418 -- Look for declarations that require the presence of a body. We
4419 -- have already skipped pragmas at the start of the list.
4421 while Present
(Decl
) loop
4423 -- Subprogram that comes from source means body may be needed.
4424 -- Save for subsequent examination of import pragmas.
4426 if Comes_From_Source
(Decl
)
4427 and then (Nkind_In
(Decl
, N_Subprogram_Declaration
,
4428 N_Subprogram_Renaming_Declaration
,
4429 N_Generic_Subprogram_Declaration
))
4431 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4433 -- Package declaration of generic package declaration. We need
4434 -- to recursively examine nested declarations.
4436 elsif Nkind_In
(Decl
, N_Package_Declaration
,
4437 N_Generic_Package_Declaration
)
4439 Check_Declarations
(Specification
(Decl
));
4441 elsif Nkind
(Decl
) = N_Pragma
4442 and then Pragma_Name
(Decl
) = Name_Import
4444 Check_Pragma_Import
(Decl
);
4450 -- Same set of tests for private part. In addition to subprograms
4451 -- detect the presence of Taft Amendment types (incomplete types
4452 -- completed in the body).
4454 Decl
:= First
(Private_Declarations
(Spec
));
4455 while Present
(Decl
) loop
4456 if Comes_From_Source
(Decl
)
4457 and then (Nkind_In
(Decl
, N_Subprogram_Declaration
,
4458 N_Subprogram_Renaming_Declaration
,
4459 N_Generic_Subprogram_Declaration
))
4461 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4463 elsif Nkind_In
(Decl
, N_Package_Declaration
,
4464 N_Generic_Package_Declaration
)
4466 Check_Declarations
(Specification
(Decl
));
4468 -- Collect incomplete type declarations for separate pass
4470 elsif Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
4471 Append_Elmt
(Decl
, Incomplete_Decls
);
4473 elsif Nkind
(Decl
) = N_Pragma
4474 and then Pragma_Name
(Decl
) = Name_Import
4476 Check_Pragma_Import
(Decl
);
4482 -- Now check incomplete declarations to locate Taft amendment
4483 -- types. This can be done by examining the defining identifiers
4484 -- of type declarations without real semantic analysis.
4490 Inc
:= First_Elmt
(Incomplete_Decls
);
4491 while Present
(Inc
) loop
4492 Decl
:= Next
(Node
(Inc
));
4493 while Present
(Decl
) loop
4494 if Nkind
(Decl
) = N_Full_Type_Declaration
4495 and then Chars
(Defining_Identifier
(Decl
)) =
4496 Chars
(Defining_Identifier
(Node
(Inc
)))
4504 -- If no completion, this is a TAT, and a body is needed
4507 Set_Body_Required
(Library_Unit
(N
));
4515 -- Finally, check whether there are subprograms that still require
4516 -- a body, i.e. are not renamings or null.
4518 if not Is_Empty_Elmt_List
(Subp_List
) then
4524 Subp_Id
:= First_Elmt
(Subp_List
);
4525 Spec
:= Parent
(Node
(Subp_Id
));
4527 while Present
(Subp_Id
) loop
4528 if Nkind
(Parent
(Spec
))
4529 = N_Subprogram_Renaming_Declaration
4533 elsif Nkind
(Spec
) = N_Procedure_Specification
4534 and then Null_Present
(Spec
)
4539 Set_Body_Required
(Library_Unit
(N
));
4543 Next_Elmt
(Subp_Id
);
4547 end Check_Declarations
;
4549 -- Start of processing for Check_Body_Required
4552 -- If this is an imported package (Java and CIL usage) no body is
4553 -- needed. Scan list of pragmas that may follow a compilation unit
4554 -- to look for a relevant pragma Import.
4556 if Present
(PA
) then
4562 while Present
(Prag
) loop
4563 if Nkind
(Prag
) = N_Pragma
4564 and then Get_Pragma_Id
(Prag
) = Pragma_Import
4574 Check_Declarations
(Specification
(P_Unit
));
4575 end Check_Body_Required
;
4577 -----------------------------
4578 -- Has_Limited_With_Clause --
4579 -----------------------------
4581 function Has_Limited_With_Clause
4582 (C_Unit
: Entity_Id
;
4583 Pack
: Entity_Id
) return Boolean
4590 while Present
(Par
) loop
4591 if Ekind
(Par
) /= E_Package
then
4595 -- Retrieve the Compilation_Unit node for Par and determine if
4596 -- its context clauses contain a limited with for Pack.
4598 Par_Unit
:= Parent
(Parent
(Parent
(Par
)));
4600 if Nkind
(Par_Unit
) = N_Package_Declaration
then
4601 Par_Unit
:= Parent
(Par_Unit
);
4604 if Has_With_Clause
(Par_Unit
, Pack
, True) then
4608 -- If there are more ancestors, climb up the tree, otherwise we
4611 if Is_Child_Unit
(Par
) then
4619 end Has_Limited_With_Clause
;
4621 ----------------------------------
4622 -- Is_Visible_Through_Renamings --
4623 ----------------------------------
4625 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean is
4626 Kind
: constant Node_Kind
:=
4627 Nkind
(Unit
(Cunit
(Current_Sem_Unit
)));
4633 -- Example of the error detected by this subprogram:
4641 -- package Ren_P renames P;
4647 -- limited with P; -- ERROR
4648 -- package R.C is ...
4650 Aux_Unit
:= Cunit
(Current_Sem_Unit
);
4653 Item
:= First
(Context_Items
(Aux_Unit
));
4654 while Present
(Item
) loop
4655 if Nkind
(Item
) = N_With_Clause
4656 and then not Limited_Present
(Item
)
4657 and then Nkind
(Unit
(Library_Unit
(Item
))) =
4658 N_Package_Declaration
4661 First
(Visible_Declarations
4662 (Specification
(Unit
(Library_Unit
(Item
)))));
4663 while Present
(Decl
) loop
4664 if Nkind
(Decl
) = N_Package_Renaming_Declaration
4665 and then Entity
(Name
(Decl
)) = P
4667 -- Generate the error message only if the current unit
4668 -- is a package declaration; in case of subprogram
4669 -- bodies and package bodies we just return True to
4670 -- indicate that the limited view must not be
4673 if Kind
= N_Package_Declaration
then
4675 ("simultaneous visibility of the limited and " &
4676 "unlimited views not allowed", N
);
4677 Error_Msg_Sloc
:= Sloc
(Item
);
4679 ("\\ unlimited view of & visible through the " &
4680 "context clause #", N
, P
);
4681 Error_Msg_Sloc
:= Sloc
(Decl
);
4682 Error_Msg_NE
("\\ and the renaming #", N
, P
);
4695 -- If it is a body not acting as spec, follow pointer to the
4696 -- corresponding spec, otherwise follow pointer to parent spec.
4698 if Present
(Library_Unit
(Aux_Unit
))
4699 and then Nkind_In
(Unit
(Aux_Unit
),
4700 N_Package_Body
, N_Subprogram_Body
)
4702 if Aux_Unit
= Library_Unit
(Aux_Unit
) then
4704 -- Aux_Unit is a body that acts as a spec. Clause has
4705 -- already been flagged as illegal.
4710 Aux_Unit
:= Library_Unit
(Aux_Unit
);
4714 Aux_Unit
:= Parent_Spec
(Unit
(Aux_Unit
));
4717 exit when No
(Aux_Unit
);
4721 end Is_Visible_Through_Renamings
;
4723 -- Start of processing for Install_Limited_Withed_Unit
4726 pragma Assert
(not Limited_View_Installed
(N
));
4728 -- In case of limited with_clause on subprograms, generics, instances,
4729 -- or renamings, the corresponding error was previously posted and we
4730 -- have nothing to do here. If the file is missing altogether, it has
4731 -- no source location.
4733 if Nkind
(P_Unit
) /= N_Package_Declaration
4734 or else Sloc
(P_Unit
) = No_Location
4739 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
4741 -- Handle child packages
4743 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
4744 Is_Child_Package
:= True;
4745 P
:= Defining_Identifier
(P
);
4748 -- Do not install the limited-view if the context of the unit is already
4749 -- available through a regular with clause.
4751 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4752 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4757 -- Do not install the limited-view if the full-view is already visible
4758 -- through renaming declarations.
4760 if Is_Visible_Through_Renamings
(P
) then
4764 -- Do not install the limited view if this is the unit being analyzed.
4765 -- This unusual case will happen when a unit has a limited_with clause
4766 -- on one of its children. The compilation of the child forces the load
4767 -- of the parent which tries to install the limited view of the child
4768 -- again. Installing the limited view must also be disabled when
4769 -- compiling the body of the child unit.
4771 if P
= Cunit_Entity
(Current_Sem_Unit
)
4772 or else (Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4773 and then P
= Main_Unit_Entity
4774 and then Is_Ancestor_Unit
4775 (Cunit
(Main_Unit
), Cunit
(Current_Sem_Unit
)))
4780 -- This scenario is similar to the one above, the difference is that the
4781 -- compilation of sibling Par.Sib forces the load of parent Par which
4782 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
4783 -- has a with clause for Lim_Pack [2] in its body, and thus needs the
4784 -- non-limited views of all entities from Lim_Pack.
4786 -- limited with Lim_Pack; -- [1]
4787 -- package Par is ... package Lim_Pack is ...
4789 -- with Lim_Pack; -- [2]
4790 -- package Par.Sib is ... package body Par.Sib is ...
4792 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
4793 -- Sem_Unit is the body of Par.Sib.
4795 if Ekind
(P
) = E_Package
4796 and then Ekind
(Main_Unit_Entity
) = E_Package
4797 and then Is_Child_Unit
(Main_Unit_Entity
)
4799 -- The body has a regular with clause
4801 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4802 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4804 -- One of the ancestors has a limited with clause
4806 and then Nkind
(Parent
(Parent
(Main_Unit_Entity
))) =
4807 N_Package_Specification
4808 and then Has_Limited_With_Clause
(Scope
(Main_Unit_Entity
), P
)
4813 -- A common use of the limited-with is to have a limited-with in the
4814 -- package spec, and a normal with in its package body. For example:
4816 -- limited with X; -- [1]
4820 -- package body A is ...
4822 -- The compilation of A's body installs the context clauses found at [2]
4823 -- and then the context clauses of its specification (found at [1]). As
4824 -- a consequence, at [1] the specification of X has been analyzed and it
4825 -- is immediately visible. According to the semantics of limited-with
4826 -- context clauses we don't install the limited view because the full
4827 -- view of X supersedes its limited view.
4829 if Analyzed
(P_Unit
)
4831 (Is_Immediately_Visible
(P
)
4832 or else (Is_Child_Package
and then Is_Visible_Lib_Unit
(P
)))
4835 -- The presence of both the limited and the analyzed nonlimited view
4836 -- may also be an error, such as an illegal context for a limited
4837 -- with_clause. In that case, do not process the context item at all.
4839 if Error_Posted
(N
) then
4843 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
4847 Item
:= First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4848 while Present
(Item
) loop
4849 if Nkind
(Item
) = N_With_Clause
4850 and then Comes_From_Source
(Item
)
4851 and then Entity
(Name
(Item
)) = P
4860 -- If this is a child body, assume that the nonlimited with_clause
4861 -- appears in an ancestor. Could be refined ???
4865 (Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)))))
4872 -- If in package declaration, nonlimited view brought in from
4873 -- parent unit or some error condition.
4879 if Debug_Flag_I
then
4880 Write_Str
("install limited view of ");
4881 Write_Name
(Chars
(P
));
4885 -- If the unit has not been analyzed and the limited view has not been
4886 -- already installed then we install it.
4888 if not Analyzed
(P_Unit
) then
4889 if not In_Chain
(P
) then
4891 -- Minimum decoration
4893 Set_Ekind
(P
, E_Package
);
4894 Set_Etype
(P
, Standard_Void_Type
);
4895 Set_Scope
(P
, Standard_Standard
);
4896 Set_Is_Visible_Lib_Unit
(P
);
4898 if Is_Child_Package
then
4899 Set_Is_Child_Unit
(P
);
4900 Set_Scope
(P
, Defining_Entity
(Unit
(Parent_Spec
(P_Unit
))));
4903 -- Place entity on visibility structure
4905 Set_Homonym
(P
, Current_Entity
(P
));
4906 Set_Current_Entity
(P
);
4908 if Debug_Flag_I
then
4909 Write_Str
(" (homonym) chain ");
4910 Write_Name
(Chars
(P
));
4914 -- Install the incomplete view. The first element of the limited
4915 -- view is a header (an E_Package entity) used to reference the
4916 -- first shadow entity in the private part of the package.
4918 Lim_Header
:= Limited_View
(P
);
4919 Lim_Typ
:= First_Entity
(Lim_Header
);
4921 while Present
(Lim_Typ
)
4922 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4924 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
4925 Set_Current_Entity
(Lim_Typ
);
4927 if Debug_Flag_I
then
4928 Write_Str
(" (homonym) chain ");
4929 Write_Name
(Chars
(Lim_Typ
));
4933 Next_Entity
(Lim_Typ
);
4937 -- If the unit appears in a previous regular with_clause, the regular
4938 -- entities of the public part of the withed package must be replaced
4939 -- by the shadow ones.
4941 -- This code must be kept synchronized with the code that replaces the
4942 -- shadow entities by the real entities (see body of Remove_Limited
4943 -- With_Clause); otherwise the contents of the homonym chains are not
4947 -- Hide all the type entities of the public part of the package to
4948 -- avoid its usage. This is needed to cover all the subtype decla-
4949 -- rations because we do not remove them from the homonym chain.
4951 E
:= First_Entity
(P
);
4952 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
4954 Set_Was_Hidden
(E
, Is_Hidden
(E
));
4961 -- Replace the real entities by the shadow entities of the limited
4962 -- view. The first element of the limited view is a header that is
4963 -- used to reference the first shadow entity in the private part
4964 -- of the package. Successive elements are the limited views of the
4965 -- type (including regular incomplete types) declared in the package.
4967 Lim_Header
:= Limited_View
(P
);
4969 Lim_Typ
:= First_Entity
(Lim_Header
);
4970 while Present
(Lim_Typ
)
4971 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4973 pragma Assert
(not In_Chain
(Lim_Typ
));
4975 -- Do not unchain nested packages and child units
4977 if Ekind
(Lim_Typ
) /= E_Package
4978 and then not Is_Child_Unit
(Lim_Typ
)
4984 Prev
:= Current_Entity
(Lim_Typ
);
4987 -- Replace E in the homonyms list, so that the limited view
4988 -- becomes available.
4990 -- If the non-limited view is a record with an anonymous
4991 -- self-referential component, the analysis of the record
4992 -- declaration creates an incomplete type with the same name
4993 -- in order to define an internal access type. The visible
4994 -- entity is now the incomplete type, and that is the one to
4995 -- replace in the visibility structure.
4997 if E
= Non_Limited_View
(Lim_Typ
)
4999 (Ekind
(E
) = E_Incomplete_Type
5000 and then Full_View
(E
) = Non_Limited_View
(Lim_Typ
))
5002 Set_Homonym
(Lim_Typ
, Homonym
(Prev
));
5003 Set_Current_Entity
(Lim_Typ
);
5007 E
:= Homonym
(Prev
);
5009 -- E may have been removed when installing a previous
5010 -- limited_with_clause.
5013 exit when E
= Non_Limited_View
(Lim_Typ
);
5014 Prev
:= Homonym
(Prev
);
5018 Set_Homonym
(Lim_Typ
, Homonym
(Homonym
(Prev
)));
5019 Set_Homonym
(Prev
, Lim_Typ
);
5024 if Debug_Flag_I
then
5025 Write_Str
(" (homonym) chain ");
5026 Write_Name
(Chars
(Lim_Typ
));
5031 Next_Entity
(Lim_Typ
);
5035 -- The package must be visible while the limited-with clause is active
5036 -- because references to the type P.T must resolve in the usual way.
5037 -- In addition, we remember that the limited-view has been installed to
5038 -- uninstall it at the point of context removal.
5040 Set_Is_Immediately_Visible
(P
);
5041 Set_Limited_View_Installed
(N
);
5043 -- If unit has not been analyzed in some previous context, check
5044 -- (imperfectly ???) whether it might need a body.
5046 if not Analyzed
(P_Unit
) then
5047 Check_Body_Required
;
5050 -- If the package in the limited_with clause is a child unit, the clause
5051 -- is unanalyzed and appears as a selected component. Recast it as an
5052 -- expanded name so that the entity can be properly set. Use entity of
5053 -- parent, if available, for higher ancestors in the name.
5055 if Nkind
(Name
(N
)) = N_Selected_Component
then
5063 while Nkind
(Nam
) = N_Selected_Component
5064 and then Present
(Ent
)
5066 Change_Selected_Component_To_Expanded_Name
(Nam
);
5068 -- Set entity of parent identifiers if the unit is a child
5069 -- unit. This ensures that the tree is properly formed from
5070 -- semantic point of view (e.g. for ASIS queries). The unit
5071 -- entities are not fully analyzed, so we need to follow unit
5072 -- links in the tree.
5074 Set_Entity
(Nam
, Ent
);
5076 Nam
:= Prefix
(Nam
);
5079 (Unit
(Parent_Spec
(Unit_Declaration_Node
(Ent
))));
5081 -- Set entity of last ancestor
5083 if Nkind
(Nam
) = N_Identifier
then
5084 Set_Entity
(Nam
, Ent
);
5090 Set_Entity
(Name
(N
), P
);
5091 Set_From_Limited_With
(P
);
5092 end Install_Limited_Withed_Unit
;
5094 -------------------------
5095 -- Install_Withed_Unit --
5096 -------------------------
5098 procedure Install_Withed_Unit
5099 (With_Clause
: Node_Id
;
5100 Private_With_OK
: Boolean := False)
5102 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
5103 P
: constant Entity_Id
:= Scope
(Uname
);
5106 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
5107 -- compiling a package declaration and the Private_With_OK flag was not
5108 -- set by the caller. These declarations will be installed later (before
5109 -- analyzing the private part of the package).
5111 if Private_Present
(With_Clause
)
5112 and then Nkind
(Unit
(Parent
(With_Clause
))) = N_Package_Declaration
5113 and then not (Private_With_OK
)
5118 if Debug_Flag_I
then
5119 if Private_Present
(With_Clause
) then
5120 Write_Str
("install private withed unit ");
5122 Write_Str
("install withed unit ");
5125 Write_Name
(Chars
(Uname
));
5129 -- We do not apply the restrictions to an internal unit unless we are
5130 -- compiling the internal unit as a main unit. This check is also
5131 -- skipped for dummy units (for missing packages).
5133 if Sloc
(Uname
) /= No_Location
5134 and then (not Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
5135 or else Current_Sem_Unit
= Main_Unit
)
5137 Check_Restricted_Unit
5138 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
5141 if P
/= Standard_Standard
then
5143 -- If the unit is not analyzed after analysis of the with clause and
5144 -- it is an instantiation then it awaits a body and is the main unit.
5145 -- Its appearance in the context of some other unit indicates a
5146 -- circular dependency (DEC suite perversity).
5148 if not Analyzed
(Uname
)
5149 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
5152 ("instantiation depends on itself", Name
(With_Clause
));
5154 elsif not Is_Visible_Lib_Unit
(Uname
) then
5156 -- Abandon processing in case of previous errors
5158 if No
(Scope
(Uname
)) then
5159 Check_Error_Detected
;
5163 Set_Is_Visible_Lib_Unit
(Uname
);
5165 -- If the unit is a wrapper package for a compilation unit that is
5166 -- a subprogrm instance, indicate that the instance itself is a
5167 -- visible unit. This is necessary if the instance is inlined.
5169 if Is_Wrapper_Package
(Uname
) then
5170 Set_Is_Visible_Lib_Unit
(Related_Instance
(Uname
));
5173 -- If the child unit appears in the context of its parent, it is
5174 -- immediately visible.
5176 if In_Open_Scopes
(Scope
(Uname
)) then
5177 Set_Is_Immediately_Visible
(Uname
);
5180 if Is_Generic_Instance
(Uname
)
5181 and then Ekind
(Uname
) in Subprogram_Kind
5183 -- Set flag as well on the visible entity that denotes the
5184 -- instance, which renames the current one.
5186 Set_Is_Visible_Lib_Unit
5188 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
5191 -- The parent unit may have been installed already, and may have
5192 -- appeared in a use clause.
5194 if In_Use
(Scope
(Uname
)) then
5195 Set_Is_Potentially_Use_Visible
(Uname
);
5198 Set_Context_Installed
(With_Clause
);
5201 elsif not Is_Immediately_Visible
(Uname
) then
5202 Set_Is_Visible_Lib_Unit
(Uname
);
5204 if not Private_Present
(With_Clause
) or else Private_With_OK
then
5205 Set_Is_Immediately_Visible
(Uname
);
5208 Set_Context_Installed
(With_Clause
);
5211 -- A with-clause overrides a with-type clause: there are no restric-
5212 -- tions on the use of package entities.
5214 if Ekind
(Uname
) = E_Package
then
5215 Set_From_Limited_With
(Uname
, False);
5218 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5219 -- unit if there is a visible homograph for it declared in the same
5220 -- declarative region. This pathological case can only arise when an
5221 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5222 -- G1 has a generic child also named G2, and the context includes with_
5223 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
5224 -- of I1.G2 visible as well. If the child unit is named Standard, do
5225 -- not apply the check to the Standard package itself.
5227 if Is_Child_Unit
(Uname
)
5228 and then Is_Visible_Lib_Unit
(Uname
)
5229 and then Ada_Version
>= Ada_2005
5232 Decl1
: constant Node_Id
:= Unit_Declaration_Node
(P
);
5238 U2
:= Homonym
(Uname
);
5239 while Present
(U2
) and then U2
/= Standard_Standard
loop
5241 Decl2
:= Unit_Declaration_Node
(P2
);
5243 if Is_Child_Unit
(U2
) and then Is_Visible_Lib_Unit
(U2
) then
5244 if Is_Generic_Instance
(P
)
5245 and then Nkind
(Decl1
) = N_Package_Declaration
5246 and then Generic_Parent
(Specification
(Decl1
)) = P2
5248 Error_Msg_N
("illegal with_clause", With_Clause
);
5250 ("\child unit has visible homograph" &
5251 " (RM 8.3(26), 10.1.1(19))",
5255 elsif Is_Generic_Instance
(P2
)
5256 and then Nkind
(Decl2
) = N_Package_Declaration
5257 and then Generic_Parent
(Specification
(Decl2
)) = P
5259 -- With_clause for child unit of instance appears before
5260 -- in the context. We want to place the error message on
5261 -- it, not on the generic child unit itself.
5264 Prev_Clause
: Node_Id
;
5267 Prev_Clause
:= First
(List_Containing
(With_Clause
));
5268 while Entity
(Name
(Prev_Clause
)) /= U2
loop
5272 pragma Assert
(Present
(Prev_Clause
));
5273 Error_Msg_N
("illegal with_clause", Prev_Clause
);
5275 ("\child unit has visible homograph" &
5276 " (RM 8.3(26), 10.1.1(19))",
5287 end Install_Withed_Unit
;
5293 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
5294 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
5297 return (K
in N_Generic_Declaration
or else
5298 K
in N_Generic_Instantiation
or else
5299 K
in N_Generic_Renaming_Declaration
or else
5300 K
= N_Package_Declaration
or else
5301 K
= N_Package_Renaming_Declaration
or else
5302 K
= N_Subprogram_Declaration
or else
5303 K
= N_Subprogram_Renaming_Declaration
)
5304 and then Present
(Parent_Spec
(Lib_Unit
));
5307 ------------------------------------
5308 -- Is_Legal_Shadow_Entity_In_Body --
5309 ------------------------------------
5311 function Is_Legal_Shadow_Entity_In_Body
(T
: Entity_Id
) return Boolean is
5312 C_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
5314 return Nkind
(Unit
(C_Unit
)) = N_Package_Body
5317 (C_Unit
, Cunit_Entity
(Get_Source_Unit
(Non_Limited_View
(T
))));
5318 end Is_Legal_Shadow_Entity_In_Body
;
5320 ----------------------
5321 -- Is_Ancestor_Unit --
5322 ----------------------
5324 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean is
5325 E1
: constant Entity_Id
:= Defining_Entity
(Unit
(U1
));
5328 if Nkind_In
(Unit
(U2
), N_Package_Body
, N_Subprogram_Body
) then
5329 E2
:= Defining_Entity
(Unit
(Library_Unit
(U2
)));
5330 return Is_Ancestor_Package
(E1
, E2
);
5334 end Is_Ancestor_Unit
;
5336 -----------------------
5337 -- Load_Needed_Body --
5338 -----------------------
5340 -- N is a generic unit named in a with clause, or else it is a unit that
5341 -- contains a generic unit or an inlined function. In order to perform an
5342 -- instantiation, the body of the unit must be present. If the unit itself
5343 -- is generic, we assume that an instantiation follows, and load & analyze
5344 -- the body unconditionally. This forces analysis of the spec as well.
5346 -- If the unit is not generic, but contains a generic unit, it is loaded on
5347 -- demand, at the point of instantiation (see ch12).
5349 procedure Load_Needed_Body
5352 Do_Analyze
: Boolean := True)
5354 Body_Name
: Unit_Name_Type
;
5355 Unum
: Unit_Number_Type
;
5357 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
5358 -- The loading and analysis is done with style checks off
5361 if not GNAT_Mode
then
5362 Style_Check
:= False;
5365 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
5368 (Load_Name
=> Body_Name
,
5374 if Unum
= No_Unit
then
5378 Compiler_State
:= Analyzing
; -- reset after load
5380 if not Fatal_Error
(Unum
) or else Try_Semantics
then
5381 if Debug_Flag_L
then
5382 Write_Str
("*** Loaded generic body");
5387 Semantics
(Cunit
(Unum
));
5394 Style_Check
:= Save_Style_Check
;
5395 end Load_Needed_Body
;
5397 -------------------------
5398 -- Build_Limited_Views --
5399 -------------------------
5401 procedure Build_Limited_Views
(N
: Node_Id
) is
5402 Unum
: constant Unit_Number_Type
:=
5403 Get_Source_Unit
(Library_Unit
(N
));
5404 Is_Analyzed
: constant Boolean := Analyzed
(Cunit
(Unum
));
5406 Shadow_Pack
: Entity_Id
;
5407 -- The corresponding shadow entity of the withed package. This entity
5408 -- offers incomplete views of packages and types as well as abstract
5409 -- views of states and variables declared within.
5411 Last_Shadow
: Entity_Id
:= Empty
;
5412 -- The last shadow entity created by routine Build_Shadow_Entity
5414 procedure Build_Shadow_Entity
5417 Shadow
: out Entity_Id
;
5418 Is_Tagged
: Boolean := False);
5419 -- Create a shadow entity that hides Ent and offers an abstract or
5420 -- incomplete view of Ent. Scop is the proper scope. Flag Is_Tagged
5421 -- should be set when Ent is a tagged type. The generated entity is
5422 -- added to Lim_Header. This routine updates the value of Last_Shadow.
5424 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5425 -- Perform minimal decoration of a package or its corresponding shadow
5426 -- entity denoted by Ent. Scop is the proper scope.
5428 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5429 -- Perform full decoration of an abstract state or its corresponding
5430 -- shadow entity denoted by Ent. Scop is the proper scope.
5432 procedure Decorate_Type
5435 Is_Tagged
: Boolean := False;
5436 Materialize
: Boolean := False);
5437 -- Perform minimal decoration of a type or its corresponding shadow
5438 -- entity denoted by Ent. Scop is the proper scope. Flag Is_Tagged
5439 -- should be set when Ent is a tagged type. Flag Materialize should be
5440 -- set when Ent is a tagged type and its class-wide type needs to appear
5443 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5444 -- Perform minimal decoration of a variable denoted by Ent. Scop is the
5447 procedure Process_Declarations_And_States
5451 Create_Abstract_Views
: Boolean);
5452 -- Inspect the states of package Pack and declarative list Decls. Create
5453 -- shadow entities for all nested packages, states, types and variables
5454 -- encountered. Scop is the proper scope. Create_Abstract_Views should
5455 -- be set when the abstract states and variables need to be processed.
5457 -------------------------
5458 -- Build_Shadow_Entity --
5459 -------------------------
5461 procedure Build_Shadow_Entity
5464 Shadow
: out Entity_Id
;
5465 Is_Tagged
: Boolean := False)
5468 Shadow
:= Make_Temporary
(Sloc
(Ent
), 'Z');
5470 -- The shadow entity must share the same name and parent as the
5473 Set_Chars
(Shadow
, Chars
(Ent
));
5474 Set_Parent
(Shadow
, Parent
(Ent
));
5476 -- The abstract view of a variable is a state, not another variable
5478 if Ekind
(Ent
) = E_Variable
then
5479 Set_Ekind
(Shadow
, E_Abstract_State
);
5481 Set_Ekind
(Shadow
, Ekind
(Ent
));
5484 Set_Is_Internal
(Shadow
);
5485 Set_From_Limited_With
(Shadow
);
5487 -- Add the new shadow entity to the limited view of the package
5489 Last_Shadow
:= Shadow
;
5490 Append_Entity
(Shadow
, Shadow_Pack
);
5492 -- Perform context-specific decoration of the shadow entity
5494 if Ekind
(Ent
) = E_Abstract_State
then
5495 Decorate_State
(Shadow
, Scop
);
5496 Set_Non_Limited_View
(Shadow
, Ent
);
5498 elsif Ekind
(Ent
) = E_Package
then
5499 Decorate_Package
(Shadow
, Scop
);
5501 elsif Is_Type
(Ent
) then
5502 Decorate_Type
(Shadow
, Scop
, Is_Tagged
);
5503 Set_Non_Limited_View
(Shadow
, Ent
);
5505 if Is_Incomplete_Or_Private_Type
(Ent
) then
5506 Set_Private_Dependents
(Shadow
, New_Elmt_List
);
5509 elsif Ekind
(Ent
) = E_Variable
then
5510 Decorate_State
(Shadow
, Scop
);
5511 Set_Non_Limited_View
(Shadow
, Ent
);
5513 end Build_Shadow_Entity
;
5515 ----------------------
5516 -- Decorate_Package --
5517 ----------------------
5519 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5521 Set_Ekind
(Ent
, E_Package
);
5522 Set_Etype
(Ent
, Standard_Void_Type
);
5523 Set_Scope
(Ent
, Scop
);
5524 end Decorate_Package
;
5526 --------------------
5527 -- Decorate_State --
5528 --------------------
5530 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5532 Set_Ekind
(Ent
, E_Abstract_State
);
5533 Set_Etype
(Ent
, Standard_Void_Type
);
5534 Set_Scope
(Ent
, Scop
);
5535 Set_Encapsulating_State
(Ent
, Empty
);
5536 Set_Refinement_Constituents
(Ent
, New_Elmt_List
);
5537 Set_Part_Of_Constituents
(Ent
, New_Elmt_List
);
5544 procedure Decorate_Type
5547 Is_Tagged
: Boolean := False;
5548 Materialize
: Boolean := False)
5553 -- An unanalyzed type or a shadow entity of a type is treated as an
5556 Set_Ekind
(Ent
, E_Incomplete_Type
);
5557 Set_Etype
(Ent
, Ent
);
5558 Set_Scope
(Ent
, Scop
);
5559 Set_Is_First_Subtype
(Ent
);
5560 Set_Stored_Constraint
(Ent
, No_Elist
);
5561 Set_Full_View
(Ent
, Empty
);
5562 Init_Size_Align
(Ent
);
5564 -- A tagged type and its corresponding shadow entity share one common
5568 Set_Is_Tagged_Type
(Ent
);
5570 if No
(Class_Wide_Type
(Ent
)) then
5573 (E_Void
, Scope
(Ent
), Sloc
(Ent
), Ent
, 'C', 0, 'T');
5575 Set_Class_Wide_Type
(Ent
, CW_Typ
);
5577 -- Set parent to be the same as the parent of the tagged type.
5578 -- We need a parent field set, and it is supposed to point to
5579 -- the declaration of the type. The tagged type declaration
5580 -- essentially declares two separate types, the tagged type
5581 -- itself and the corresponding class-wide type, so it is
5582 -- reasonable for the parent fields to point to the declaration
5585 Set_Parent
(CW_Typ
, Parent
(Ent
));
5587 Set_Ekind
(CW_Typ
, E_Class_Wide_Type
);
5588 Set_Etype
(CW_Typ
, Ent
);
5589 Set_Scope
(CW_Typ
, Scop
);
5590 Set_Is_Tagged_Type
(CW_Typ
);
5591 Set_Is_First_Subtype
(CW_Typ
);
5592 Init_Size_Align
(CW_Typ
);
5593 Set_Has_Unknown_Discriminants
(CW_Typ
);
5594 Set_Class_Wide_Type
(CW_Typ
, CW_Typ
);
5595 Set_Equivalent_Type
(CW_Typ
, Empty
);
5596 Set_From_Limited_With
(CW_Typ
, From_Limited_With
(Ent
));
5597 Set_Materialize_Entity
(CW_Typ
, Materialize
);
5602 -----------------------
5603 -- Decorate_Variable --
5604 -----------------------
5606 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5608 Set_Ekind
(Ent
, E_Variable
);
5609 Set_Etype
(Ent
, Standard_Void_Type
);
5610 Set_Scope
(Ent
, Scop
);
5611 end Decorate_Variable
;
5613 -------------------------------------
5614 -- Process_Declarations_And_States --
5615 -------------------------------------
5617 procedure Process_Declarations_And_States
5621 Create_Abstract_Views
: Boolean)
5623 procedure Find_And_Process_States
;
5624 -- Determine whether package Pack defines abstract state either by
5625 -- using an aspect or a pragma. If this is the case, build shadow
5626 -- entities for all abstract states of Pack.
5628 procedure Process_States
(States
: Elist_Id
);
5629 -- Generate shadow entities for all abstract states in list States
5631 -----------------------------
5632 -- Find_And_Process_States --
5633 -----------------------------
5635 procedure Find_And_Process_States
is
5636 procedure Process_State
(State
: Node_Id
);
5637 -- Generate shadow entities for a single abstract state or
5638 -- multiple states expressed as an aggregate.
5644 procedure Process_State
(State
: Node_Id
) is
5645 Loc
: constant Source_Ptr
:= Sloc
(State
);
5651 pragma Unreferenced
(Dummy
);
5654 -- Multiple abstract states appear as an aggregate
5656 if Nkind
(State
) = N_Aggregate
then
5657 Elmt
:= First
(Expressions
(State
));
5658 while Present
(Elmt
) loop
5659 Process_State
(Elmt
);
5665 -- A null state has no abstract view
5667 elsif Nkind
(State
) = N_Null
then
5670 -- State declaration with various options appears as an
5671 -- extension aggregate.
5673 elsif Nkind
(State
) = N_Extension_Aggregate
then
5674 Name
:= Chars
(Ancestor_Part
(State
));
5676 -- Simple state declaration
5678 elsif Nkind
(State
) = N_Identifier
then
5679 Name
:= Chars
(State
);
5681 -- Possibly an illegal state declaration
5687 -- Construct a dummy state for the purposes of establishing a
5688 -- non-limited => limited view relation. Note that the dummy
5689 -- state is not added to list Abstract_States to avoid multiple
5692 Id
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Name
));
5693 Set_Parent
(Id
, State
);
5694 Decorate_State
(Id
, Scop
);
5696 Build_Shadow_Entity
(Id
, Scop
, Dummy
);
5701 Pack_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Pack
);
5705 -- Start of processing for Find_And_Process_States
5708 -- Find aspect Abstract_State
5710 Asp
:= First
(Aspect_Specifications
(Pack_Decl
));
5711 while Present
(Asp
) loop
5712 if Chars
(Identifier
(Asp
)) = Name_Abstract_State
then
5713 Process_State
(Expression
(Asp
));
5721 -- Find pragma Abstract_State by inspecting the declarations
5723 Decl
:= First
(Decls
);
5724 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
5725 if Pragma_Name
(Decl
) = Name_Abstract_State
then
5728 (First
(Pragma_Argument_Associations
(Decl
))));
5735 end Find_And_Process_States
;
5737 --------------------
5738 -- Process_States --
5739 --------------------
5741 procedure Process_States
(States
: Elist_Id
) is
5746 Elmt
:= First_Elmt
(States
);
5747 while Present
(Elmt
) loop
5748 Build_Shadow_Entity
(Node
(Elmt
), Scop
, Dummy
);
5756 Is_Tagged
: Boolean;
5762 -- Start of processing for Process_Declarations_And_States
5765 -- Build abstract views for all states defined in the package
5767 if Create_Abstract_Views
then
5769 -- When a package has been analyzed, all states are stored in list
5770 -- Abstract_States. Generate the shadow entities directly.
5773 if Present
(Abstract_States
(Pack
)) then
5774 Process_States
(Abstract_States
(Pack
));
5777 -- The package may declare abstract states by using an aspect or a
5778 -- pragma. Attempt to locate one of these construct and if found,
5779 -- build the shadow entities.
5782 Find_And_Process_States
;
5786 -- Inspect the declarative list, looking for nested packages, types
5787 -- and variable declarations.
5789 Decl
:= First
(Decls
);
5790 while Present
(Decl
) loop
5794 if Nkind
(Decl
) = N_Package_Declaration
then
5795 Def_Id
:= Defining_Entity
(Decl
);
5797 -- Perform minor decoration when the withed package has not
5800 if not Is_Analyzed
then
5801 Decorate_Package
(Def_Id
, Scop
);
5804 -- Create a shadow entity that offers a limited view of all
5805 -- visible types declared within.
5807 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
5809 Process_Declarations_And_States
5811 Decls
=> Visible_Declarations
(Specification
(Decl
)),
5813 Create_Abstract_Views
=> Create_Abstract_Views
);
5817 elsif Nkind_In
(Decl
, N_Full_Type_Declaration
,
5818 N_Incomplete_Type_Declaration
,
5819 N_Private_Extension_Declaration
,
5820 N_Private_Type_Declaration
,
5821 N_Protected_Type_Declaration
,
5822 N_Task_Type_Declaration
)
5824 Def_Id
:= Defining_Entity
(Decl
);
5826 -- Determine whether the type is tagged. Note that packages
5827 -- included via a limited with clause are not always analyzed,
5828 -- hence the tree lookup rather than the use of attribute
5831 if Nkind
(Decl
) = N_Full_Type_Declaration
then
5832 Def
:= Type_Definition
(Decl
);
5835 (Nkind
(Def
) = N_Record_Definition
5836 and then Tagged_Present
(Def
))
5838 (Nkind
(Def
) = N_Derived_Type_Definition
5839 and then Present
(Record_Extension_Part
(Def
)));
5841 elsif Nkind_In
(Decl
, N_Incomplete_Type_Declaration
,
5842 N_Private_Type_Declaration
)
5844 Is_Tagged
:= Tagged_Present
(Decl
);
5846 elsif Nkind
(Decl
) = N_Private_Extension_Declaration
then
5853 -- Perform minor decoration when the withed package has not
5856 if not Is_Analyzed
then
5857 Decorate_Type
(Def_Id
, Scop
, Is_Tagged
, True);
5860 -- Create a shadow entity that hides the type and offers an
5861 -- incomplete view of the said type.
5863 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
, Is_Tagged
);
5867 elsif Create_Abstract_Views
5868 and then Nkind
(Decl
) = N_Object_Declaration
5869 and then not Constant_Present
(Decl
)
5871 Def_Id
:= Defining_Entity
(Decl
);
5873 -- Perform minor decoration when the withed package has not
5876 if not Is_Analyzed
then
5877 Decorate_Variable
(Def_Id
, Scop
);
5880 -- Create a shadow entity that hides the variable and offers an
5881 -- abstract view of the said variable.
5883 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
5888 end Process_Declarations_And_States
;
5892 Nam
: constant Node_Id
:= Name
(N
);
5893 Pack
: constant Entity_Id
:= Cunit_Entity
(Unum
);
5895 Last_Public_Shadow
: Entity_Id
:= Empty
;
5896 Private_Shadow
: Entity_Id
;
5899 -- Start of processing for Build_Limited_Views
5902 pragma Assert
(Limited_Present
(N
));
5904 -- A library_item mentioned in a limited_with_clause is a package
5905 -- declaration, not a subprogram declaration, generic declaration,
5906 -- generic instantiation, or package renaming declaration.
5908 case Nkind
(Unit
(Library_Unit
(N
))) is
5909 when N_Package_Declaration
=>
5912 when N_Subprogram_Declaration
=>
5913 Error_Msg_N
("subprograms not allowed in limited with_clauses", N
);
5916 when N_Generic_Package_Declaration |
5917 N_Generic_Subprogram_Declaration
=>
5918 Error_Msg_N
("generics not allowed in limited with_clauses", N
);
5921 when N_Generic_Instantiation
=>
5923 ("generic instantiations not allowed in limited with_clauses",
5927 when N_Generic_Renaming_Declaration
=>
5929 ("generic renamings not allowed in limited with_clauses", N
);
5932 when N_Subprogram_Renaming_Declaration
=>
5934 ("renamed subprograms not allowed in limited with_clauses", N
);
5937 when N_Package_Renaming_Declaration
=>
5939 ("renamed packages not allowed in limited with_clauses", N
);
5943 raise Program_Error
;
5946 -- The withed unit may not be analyzed, but the with calause itself
5947 -- must be minimally decorated. This ensures that the checks on unused
5948 -- with clauses also process limieted withs.
5950 Set_Ekind
(Pack
, E_Package
);
5951 Set_Etype
(Pack
, Standard_Void_Type
);
5953 if Is_Entity_Name
(Nam
) then
5954 Set_Entity
(Nam
, Pack
);
5956 elsif Nkind
(Nam
) = N_Selected_Component
then
5957 Set_Entity
(Selector_Name
(Nam
), Pack
);
5960 -- Check if the chain is already built
5962 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
5964 if Limited_View_Installed
(Spec
) then
5968 -- Create the shadow package wich hides the withed unit and provides
5969 -- incomplete view of all types and packages declared within.
5971 Shadow_Pack
:= Make_Temporary
(Sloc
(N
), 'Z');
5972 Set_Ekind
(Shadow_Pack
, E_Package
);
5973 Set_Is_Internal
(Shadow_Pack
);
5974 Set_Limited_View
(Pack
, Shadow_Pack
);
5976 -- Inspect the abstract states and visible declarations of the withed
5977 -- unit and create shadow entities that hide existing packages, states,
5978 -- variables and types.
5980 Process_Declarations_And_States
5982 Decls
=> Visible_Declarations
(Spec
),
5984 Create_Abstract_Views
=> True);
5986 Last_Public_Shadow
:= Last_Shadow
;
5988 -- Ada 2005 (AI-262): Build the limited view of the private declarations
5989 -- to accomodate limited private with clauses.
5991 Process_Declarations_And_States
5993 Decls
=> Private_Declarations
(Spec
),
5995 Create_Abstract_Views
=> False);
5997 if Present
(Last_Public_Shadow
) then
5998 Private_Shadow
:= Next_Entity
(Last_Public_Shadow
);
6000 Private_Shadow
:= First_Entity
(Shadow_Pack
);
6003 Set_First_Private_Entity
(Shadow_Pack
, Private_Shadow
);
6004 Set_Limited_View_Installed
(Spec
);
6005 end Build_Limited_Views
;
6007 -------------------------------
6008 -- Check_Body_Needed_For_SAL --
6009 -------------------------------
6011 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
6013 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
6014 -- Determine whether use of entity E might require the presence of its
6015 -- body. For a package this requires a recursive traversal of all nested
6018 ---------------------------
6019 -- Entity_Needed_For_SAL --
6020 ---------------------------
6022 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
6026 if Is_Subprogram
(E
) and then Has_Pragma_Inline
(E
) then
6029 elsif Ekind_In
(E
, E_Generic_Function
, E_Generic_Procedure
) then
6032 elsif Ekind
(E
) = E_Generic_Package
6034 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
6035 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6039 elsif Ekind
(E
) = E_Package
6040 and then Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
6041 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6043 Ent
:= First_Entity
(E
);
6044 while Present
(Ent
) loop
6045 if Entity_Needs_Body
(Ent
) then
6057 end Entity_Needs_Body
;
6059 -- Start of processing for Check_Body_Needed_For_SAL
6062 if Ekind
(Unit_Name
) = E_Generic_Package
6063 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6064 N_Generic_Package_Declaration
6066 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
6068 Set_Body_Needed_For_SAL
(Unit_Name
);
6070 elsif Ekind_In
(Unit_Name
, E_Generic_Procedure
, E_Generic_Function
) then
6071 Set_Body_Needed_For_SAL
(Unit_Name
);
6073 elsif Is_Subprogram
(Unit_Name
)
6074 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6075 N_Subprogram_Declaration
6076 and then Has_Pragma_Inline
(Unit_Name
)
6078 Set_Body_Needed_For_SAL
(Unit_Name
);
6080 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
6081 Check_Body_Needed_For_SAL
6082 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6084 elsif Ekind
(Unit_Name
) = E_Package
6085 and then Entity_Needs_Body
(Unit_Name
)
6087 Set_Body_Needed_For_SAL
(Unit_Name
);
6089 elsif Ekind
(Unit_Name
) = E_Package_Body
6090 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
6092 Check_Body_Needed_For_SAL
6093 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6095 end Check_Body_Needed_For_SAL
;
6097 --------------------
6098 -- Remove_Context --
6099 --------------------
6101 procedure Remove_Context
(N
: Node_Id
) is
6102 Lib_Unit
: constant Node_Id
:= Unit
(N
);
6105 -- If this is a child unit, first remove the parent units
6107 if Is_Child_Spec
(Lib_Unit
) then
6108 Remove_Parents
(Lib_Unit
);
6111 Remove_Context_Clauses
(N
);
6114 ----------------------------
6115 -- Remove_Context_Clauses --
6116 ----------------------------
6118 procedure Remove_Context_Clauses
(N
: Node_Id
) is
6120 Unit_Name
: Entity_Id
;
6123 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
6124 -- limited-views first and regular-views later (to maintain the
6127 -- First Phase: Remove limited_with context clauses
6129 Item
:= First
(Context_Items
(N
));
6130 while Present
(Item
) loop
6132 -- We are interested only in with clauses which got installed
6135 if Nkind
(Item
) = N_With_Clause
6136 and then Limited_Present
(Item
)
6137 and then Limited_View_Installed
(Item
)
6139 Remove_Limited_With_Clause
(Item
);
6145 -- Second Phase: Loop through context items and undo regular
6146 -- with_clauses and use_clauses.
6148 Item
:= First
(Context_Items
(N
));
6149 while Present
(Item
) loop
6151 -- We are interested only in with clauses which got installed on
6152 -- entry, as indicated by their Context_Installed flag set
6154 if Nkind
(Item
) = N_With_Clause
6155 and then Limited_Present
(Item
)
6156 and then Limited_View_Installed
(Item
)
6160 elsif Nkind
(Item
) = N_With_Clause
6161 and then Context_Installed
(Item
)
6163 -- Remove items from one with'ed unit
6165 Unit_Name
:= Entity
(Name
(Item
));
6166 Remove_Unit_From_Visibility
(Unit_Name
);
6167 Set_Context_Installed
(Item
, False);
6169 elsif Nkind
(Item
) = N_Use_Package_Clause
then
6170 End_Use_Package
(Item
);
6172 elsif Nkind
(Item
) = N_Use_Type_Clause
then
6173 End_Use_Type
(Item
);
6178 end Remove_Context_Clauses
;
6180 --------------------------------
6181 -- Remove_Limited_With_Clause --
6182 --------------------------------
6184 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
6185 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
6188 Lim_Header
: Entity_Id
;
6189 Lim_Typ
: Entity_Id
;
6193 pragma Assert
(Limited_View_Installed
(N
));
6195 -- In case of limited with_clause on subprograms, generics, instances,
6196 -- or renamings, the corresponding error was previously posted and we
6197 -- have nothing to do here.
6199 if Nkind
(P_Unit
) /= N_Package_Declaration
then
6203 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
6205 -- Handle child packages
6207 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
6208 P
:= Defining_Identifier
(P
);
6211 if Debug_Flag_I
then
6212 Write_Str
("remove limited view of ");
6213 Write_Name
(Chars
(P
));
6214 Write_Str
(" from visibility");
6218 -- Prepare the removal of the shadow entities from visibility. The first
6219 -- element of the limited view is a header (an E_Package entity) that is
6220 -- used to reference the first shadow entity in the private part of the
6223 Lim_Header
:= Limited_View
(P
);
6224 Lim_Typ
:= First_Entity
(Lim_Header
);
6226 -- Remove package and shadow entities from visibility if it has not
6229 if not Analyzed
(P_Unit
) then
6231 Set_Is_Immediately_Visible
(P
, False);
6233 while Present
(Lim_Typ
) loop
6235 Next_Entity
(Lim_Typ
);
6238 -- Otherwise this package has already appeared in the closure and its
6239 -- shadow entities must be replaced by its real entities. This code
6240 -- must be kept synchronized with the complementary code in Install
6241 -- Limited_Withed_Unit.
6244 -- Real entities that are type or subtype declarations were hidden
6245 -- from visibility at the point of installation of the limited-view.
6246 -- Now we recover the previous value of the hidden attribute.
6248 E
:= First_Entity
(P
);
6249 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
6251 Set_Is_Hidden
(E
, Was_Hidden
(E
));
6257 while Present
(Lim_Typ
)
6258 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
6260 -- Nested packages and child units were not unchained
6262 if Ekind
(Lim_Typ
) /= E_Package
6263 and then not Is_Child_Unit
(Non_Limited_View
(Lim_Typ
))
6265 -- If the package has incomplete types, the limited view of the
6266 -- incomplete type is in fact never visible (AI05-129) but we
6267 -- have created a shadow entity E1 for it, that points to E2,
6268 -- a non-limited incomplete type. This in turn has a full view
6269 -- E3 that is the full declaration. There is a corresponding
6270 -- shadow entity E4. When reinstalling the non-limited view,
6271 -- E2 must become the current entity and E3 must be ignored.
6273 E
:= Non_Limited_View
(Lim_Typ
);
6275 if Present
(Current_Entity
(E
))
6276 and then Ekind
(Current_Entity
(E
)) = E_Incomplete_Type
6277 and then Full_View
(Current_Entity
(E
)) = E
6280 -- Lim_Typ is the limited view of a full type declaration
6281 -- that has a previous incomplete declaration, i.e. E3 from
6282 -- the previous description. Nothing to insert.
6287 pragma Assert
(not In_Chain
(E
));
6289 Prev
:= Current_Entity
(Lim_Typ
);
6291 if Prev
= Lim_Typ
then
6292 Set_Current_Entity
(E
);
6295 while Present
(Prev
)
6296 and then Homonym
(Prev
) /= Lim_Typ
6298 Prev
:= Homonym
(Prev
);
6301 if Present
(Prev
) then
6302 Set_Homonym
(Prev
, E
);
6306 -- Preserve structure of homonym chain
6308 Set_Homonym
(E
, Homonym
(Lim_Typ
));
6312 Next_Entity
(Lim_Typ
);
6316 -- Indicate that the limited view of the package is not installed
6318 Set_From_Limited_With
(P
, False);
6319 Set_Limited_View_Installed
(N
, False);
6320 end Remove_Limited_With_Clause
;
6322 --------------------
6323 -- Remove_Parents --
6324 --------------------
6326 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
6329 P_Spec
: Node_Id
:= Empty
;
6331 Vis
: constant Boolean :=
6332 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
6335 if Is_Child_Spec
(Lib_Unit
) then
6336 P_Spec
:= Parent_Spec
(Lib_Unit
);
6338 elsif Nkind
(Lib_Unit
) = N_Package_Body
6339 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
6341 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
6344 if Present
(P_Spec
) then
6346 P_Name
:= Get_Parent_Entity
(P
);
6347 Remove_Context_Clauses
(P_Spec
);
6348 End_Package_Scope
(P_Name
);
6349 Set_Is_Immediately_Visible
(P_Name
, Vis
);
6351 -- Remove from visibility the siblings as well, which are directly
6352 -- visible while the parent is in scope.
6354 E
:= First_Entity
(P_Name
);
6355 while Present
(E
) loop
6356 if Is_Child_Unit
(E
) then
6357 Set_Is_Immediately_Visible
(E
, False);
6363 Set_In_Package_Body
(P_Name
, False);
6365 -- This is the recursive call to remove the context of any higher
6366 -- level parent. This recursion ensures that all parents are removed
6367 -- in the reverse order of their installation.
6373 ---------------------------------
6374 -- Remove_Private_With_Clauses --
6375 ---------------------------------
6377 procedure Remove_Private_With_Clauses
(Comp_Unit
: Node_Id
) is
6380 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean;
6381 -- Check whether a given unit appears in a regular with_clause. Used to
6382 -- determine whether a private_with_clause, implicit or explicit, should
6385 ----------------------------
6386 -- In_Regular_With_Clause --
6387 ----------------------------
6389 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean
6394 Item
:= First
(Context_Items
(Comp_Unit
));
6395 while Present
(Item
) loop
6396 if Nkind
(Item
) = N_With_Clause
6397 and then Entity
(Name
(Item
)) = E
6398 and then not Private_Present
(Item
)
6406 end In_Regular_With_Clause
;
6408 -- Start of processing for Remove_Private_With_Clauses
6411 Item
:= First
(Context_Items
(Comp_Unit
));
6412 while Present
(Item
) loop
6413 if Nkind
(Item
) = N_With_Clause
and then Private_Present
(Item
) then
6415 -- If private_with_clause is redundant, remove it from context,
6416 -- as a small optimization to subsequent handling of private_with
6417 -- clauses in other nested packages.
6419 if In_Regular_With_Clause
(Entity
(Name
(Item
))) then
6421 Nxt
: constant Node_Id
:= Next
(Item
);
6427 elsif Limited_Present
(Item
) then
6428 if not Limited_View_Installed
(Item
) then
6429 Remove_Limited_With_Clause
(Item
);
6435 Remove_Unit_From_Visibility
(Entity
(Name
(Item
)));
6436 Set_Context_Installed
(Item
, False);
6444 end Remove_Private_With_Clauses
;
6446 ---------------------------------
6447 -- Remove_Unit_From_Visibility --
6448 ---------------------------------
6450 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
6452 if Debug_Flag_I
then
6453 Write_Str
("remove unit ");
6454 Write_Name
(Chars
(Unit_Name
));
6455 Write_Str
(" from visibility");
6459 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
6460 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
6461 Set_Is_Immediately_Visible
(Unit_Name
, False);
6463 -- If the unit is a wrapper package, the subprogram instance is
6464 -- what must be removed from visibility.
6465 -- Should we use Related_Instance instead???
6467 if Is_Wrapper_Package
(Unit_Name
) then
6468 Set_Is_Immediately_Visible
(Current_Entity
(Unit_Name
), False);
6470 end Remove_Unit_From_Visibility
;
6485 procedure Unchain
(E
: Entity_Id
) is
6489 Prev
:= Current_Entity
(E
);
6495 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
6498 while Present
(Prev
) and then Homonym
(Prev
) /= E
loop
6499 Prev
:= Homonym
(Prev
);
6502 if Present
(Prev
) then
6503 Set_Homonym
(Prev
, Homonym
(E
));
6507 if Debug_Flag_I
then
6508 Write_Str
(" (homonym) unchain ");
6509 Write_Name
(Chars
(E
));