1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Contracts
; use Contracts
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Errout
; use Errout
;
34 with Exp_Disp
; use Exp_Disp
;
36 with Exp_Util
; use Exp_Util
;
37 with Elists
; use Elists
;
38 with Fname
; use Fname
;
39 with Fname
.UF
; use Fname
.UF
;
40 with Freeze
; use Freeze
;
41 with Impunit
; use Impunit
;
42 with Inline
; use Inline
;
44 with Lib
.Load
; use Lib
.Load
;
45 with Lib
.Xref
; use Lib
.Xref
;
46 with Namet
; use Namet
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch6
; use Sem_Ch6
;
59 with Sem_Ch7
; use Sem_Ch7
;
60 with Sem_Ch8
; use Sem_Ch8
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Dist
; use Sem_Dist
;
63 with Sem_Prag
; use Sem_Prag
;
64 with Sem_Util
; use Sem_Util
;
65 with Sem_Warn
; use Sem_Warn
;
66 with Stand
; use Stand
;
67 with Sinfo
; use Sinfo
;
68 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
69 with Sinfo
.Utils
; use Sinfo
.Utils
;
70 with Sinfo
.CN
; use Sinfo
.CN
;
71 with Sinput
; use Sinput
;
72 with Snames
; use Snames
;
73 with Style
; use Style
;
74 with Stylesw
; use Stylesw
;
75 with Tbuild
; use Tbuild
;
76 with Uname
; use Uname
;
77 with Warnsw
; use Warnsw
;
79 package body Sem_Ch10
is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Analyze_Context
(N
: Node_Id
);
86 -- Analyzes items in the context clause of compilation unit
88 procedure Analyze_Required_Limited_With_Units
(N
: Node_Id
);
89 -- Subsidiary of Analyze_Compilation_Unit. Perform full analysis of the
90 -- limited-with units of N when it is a package declaration that does not
91 -- require a package body, and the profile of some subprogram defined in N
92 -- depends on shadow incomplete type entities visible through limited-with
93 -- context clauses. This analysis is required to provide the backend with
94 -- the non-limited view of these shadow entities.
96 procedure Build_Limited_Views
(N
: Node_Id
);
97 -- Build and decorate the list of shadow entities for a package mentioned
98 -- in a limited_with clause. If the package was not previously analyzed
99 -- then it also performs a basic decoration of the real entities. This is
100 -- required in order to avoid passing non-decorated entities to the
101 -- back-end. Implements Ada 2005 (AI-50217).
103 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
104 -- Common processing for all stubs (subprograms, tasks, packages, and
105 -- protected cases). N is the stub to be analyzed. Once the subunit name
106 -- is established, load and analyze. Nam is the non-overloadable entity
107 -- for which the proper body provides a completion. Subprogram stubs are
108 -- handled differently because they can be declarations.
110 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
);
111 -- Check whether the source for the body of a compilation unit must be
112 -- included in a standalone library.
114 procedure Check_No_Elab_Code_All
(N
: Node_Id
);
115 -- Carries out possible tests for violation of No_Elab_Code all for withed
116 -- units in the Context_Items of unit N.
118 procedure Check_Private_Child_Unit
(N
: Node_Id
);
119 -- If a with_clause mentions a private child unit, the compilation unit
120 -- must be a member of the same family, as described in 10.1.2.
122 procedure Check_Stub_Level
(N
: Node_Id
);
123 -- Verify that a stub is declared immediately within a compilation unit,
124 -- and not in an inner frame.
126 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
127 -- When a child unit appears in a context clause, the implicit withs on
128 -- parents are made explicit, and with clauses are inserted in the context
129 -- clause before the one for the child. If a parent in the with_clause
130 -- is a renaming, the implicit with_clause is on the renaming whose name
131 -- is mentioned in the with_clause, and not on the package it renames.
132 -- N is the compilation unit whose list of context items receives the
133 -- implicit with_clauses.
135 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
136 -- Generate cross-reference information for the parents of child units
137 -- and of subunits. N is a defining_program_unit_name, and P_Id is the
138 -- immediate parent scope.
140 function Has_With_Clause
143 Is_Limited
: Boolean := False) return Boolean;
144 -- Determine whether compilation unit C_Unit contains a [limited] with
145 -- clause for package Pack. Use the flag Is_Limited to designate desired
148 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
149 -- If the main unit is a child unit, implicit withs are also added for
150 -- all its ancestors.
152 function In_Chain
(E
: Entity_Id
) return Boolean;
153 -- Check that the shadow entity is not already in the homonym chain, for
154 -- example through a limited_with clause in a parent unit.
156 procedure Install_Context_Clauses
(N
: Node_Id
; Chain
: Boolean := True);
157 -- Subsidiary to Install_Context and Install_Parents. Process all with
158 -- and use clauses for current unit and its library unit if any. The flag
159 -- Chain is used to control the "chaining" or linking together of use-type
160 -- and use-package clauses to avoid circularities with reinstalling
163 procedure Install_Limited_Context_Clauses
(N
: Node_Id
);
164 -- Subsidiary to Install_Context. Process only limited with_clauses for
165 -- current unit. Implements Ada 2005 (AI-50217).
167 procedure Install_Limited_With_Clause
(N
: Node_Id
);
168 -- Place shadow entities for a limited_with package in the visibility
169 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
171 procedure Install_Parents
173 Is_Private
: Boolean;
174 Chain
: Boolean := True);
175 -- This procedure establishes the context for the compilation of a child
176 -- unit. If Lib_Unit is a child library spec then the context of the parent
177 -- is installed, and the parent itself made immediately visible, so that
178 -- the child unit is processed in the declarative region of the parent.
179 -- Install_Parents makes a recursive call to itself to ensure that all
180 -- parents are loaded in the nested case. If Lib_Unit is a library body,
181 -- the only effect of Install_Parents is to install the private decls of
182 -- the parents, because the visible parent declarations will have been
183 -- installed as part of the context of the corresponding spec. The flag
184 -- Chain is used to control the "chaining" or linking of use-type and
185 -- use-package clauses to avoid circularities when installing context.
187 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
188 -- In the compilation of a child unit, a child of any of the ancestor
189 -- units is directly visible if it is visible, because the parent is in
190 -- an enclosing scope. Iterate over context to find child units of U_Name
191 -- or of some ancestor of it.
193 procedure Install_With_Clause
194 (With_Clause
: Node_Id
;
195 Private_With_OK
: Boolean := False);
196 -- If the unit is not a child unit, make unit immediately visible. The
197 -- caller ensures that the unit is not already currently installed. The
198 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
199 -- is called when compiling the private part of a package, or installing
200 -- the private declarations of a parent unit.
202 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean;
203 -- When compiling a unit Q descended from some parent unit P, a limited
204 -- with_clause in the context of P that names some other ancestor of Q
205 -- must not be installed because the ancestor is immediately visible.
207 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
208 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
209 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
210 -- a library spec that has a parent. If the call to Is_Child_Spec returns
211 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
212 -- compilation unit for the parent spec.
214 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
215 -- Parent_Spec is non-empty, this is also a child unit.
217 procedure Remove_Context_Clauses
(N
: Node_Id
);
218 -- Subsidiary of previous one. Remove use_ and with_clauses
220 procedure Remove_Limited_With_Clause
(N
: Node_Id
);
221 -- Remove the shadow entities from visibility introduced for a package
222 -- mentioned in limited with clause N. Implements Ada 2005 (AI-50217).
224 procedure Remove_Limited_With_Unit
225 (Pack_Decl
: Node_Id
;
226 Lim_Clause
: Node_Id
:= Empty
);
227 -- Remove the shadow entities from visibility introduced for a package
228 -- denoted by declaration Pack_Decl. Lim_Clause is the related limited
229 -- with clause, if any. Implements Ada 2005 (AI-50217).
231 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
232 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
233 -- contexts established by the corresponding call to Install_Parents are
234 -- removed. Remove_Parents contains a recursive call to itself to ensure
235 -- that all parents are removed in the nested case.
237 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
238 -- Reset all visibility flags on unit after compiling it, either as a main
239 -- unit or as a unit in the context.
241 procedure Replace
(Old_E
, New_E
: Entity_Id
);
242 -- Replace Old_E by New_E on visibility list
244 procedure Unchain
(E
: Entity_Id
);
245 -- Remove single entity from visibility list
248 -- A dummy procedure, for debugging use, called just before analyzing the
249 -- main unit (after dealing with any context clauses).
251 --------------------------
252 -- Limited_With_Clauses --
253 --------------------------
255 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
256 -- mutually recursive types declared in different units. A limited_with
257 -- clause that names package P in the context of unit U makes the types
258 -- declared in the visible part of P available within U, but with the
259 -- restriction that these types can only be used as incomplete types.
260 -- The limited_with clause does not impose a semantic dependence on P,
261 -- and it is possible for two packages to have limited_with_clauses on
262 -- each other without creating an elaboration circularity.
264 -- To support this feature, the analysis of a limited_with clause must
265 -- create an abbreviated view of the package, without performing any
266 -- semantic analysis on it. This "package abstract" contains shadow types
267 -- that are in one-one correspondence with the real types in the package,
268 -- and that have the properties of incomplete types.
270 -- The implementation creates two element lists: one to chain the shadow
271 -- entities, and one to chain the corresponding type entities in the tree
272 -- of the package. Links between corresponding entities in both chains
273 -- allow the compiler to select the proper view of a given type, depending
274 -- on the context. Note that in contrast with the handling of private
275 -- types, the limited view and the nonlimited view of a type are treated
276 -- as separate entities, and no entity exchange needs to take place, which
277 -- makes the implementation much simpler than could be feared.
279 ------------------------------
280 -- Analyze_Compilation_Unit --
281 ------------------------------
283 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
284 Unit_Node
: constant Node_Id
:= Unit
(N
);
286 procedure Check_Redundant_Withs
287 (Context_Items
: List_Id
;
288 Spec_Context_Items
: List_Id
:= No_List
);
289 -- Determine whether the context list of a compilation unit contains
290 -- redundant with clauses. When checking body clauses against spec
291 -- clauses, set Context_Items to the context list of the body and
292 -- Spec_Context_Items to that of the spec. Parent packages are not
293 -- examined for documentation purposes.
295 ---------------------------
296 -- Check_Redundant_Withs --
297 ---------------------------
299 procedure Check_Redundant_Withs
300 (Context_Items
: List_Id
;
301 Spec_Context_Items
: List_Id
:= No_List
)
305 procedure Process_Body_Clauses
306 (Context_List
: List_Id
;
309 Used_Type_Or_Elab
: out Boolean);
310 -- Examine the context clauses of a package body, trying to match the
311 -- name entity of Clause with any list element. If the match occurs
312 -- on a use package clause set Used to True, for a use type clause or
313 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
315 procedure Process_Spec_Clauses
316 (Context_List
: List_Id
;
319 Withed
: out Boolean;
320 Exit_On_Self
: Boolean := False);
321 -- Examine the context clauses of a package spec, trying to match
322 -- the name entity of Clause with any list element. If the match
323 -- occurs on a use package clause, set Used to True, for a with
324 -- package clause other than Clause, set Withed to True. Limited
325 -- with clauses, implicitly generated with clauses and withs
326 -- having pragmas Elaborate or Elaborate_All applied to them are
327 -- skipped. Exit_On_Self is used to control the search loop and
328 -- force an exit whenever Clause sees itself in the search.
330 --------------------------
331 -- Process_Body_Clauses --
332 --------------------------
334 procedure Process_Body_Clauses
335 (Context_List
: List_Id
;
338 Used_Type_Or_Elab
: out Boolean)
340 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
345 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean;
346 -- In an expanded name in a use clause, if the prefix is a renamed
347 -- package, the entity is set to the original package as a result,
348 -- when checking whether the package appears in a previous with
349 -- clause, the renaming has to be taken into account, to prevent
350 -- spurious/incorrect warnings. A common case is use of Text_IO.
356 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean is
358 return Entity
(N
) = P
359 or else (Present
(Renamed_Entity
(P
))
360 and then Entity
(N
) = Renamed_Entity
(P
));
363 -- Start of processing for Process_Body_Clauses
367 Used_Type_Or_Elab
:= False;
369 Cont_Item
:= First
(Context_List
);
370 while Present
(Cont_Item
) loop
372 -- Package use clause
374 if Nkind
(Cont_Item
) = N_Use_Package_Clause
377 -- Search through use clauses
379 Use_Item
:= Name
(Cont_Item
);
381 -- Case of a direct use of the one we are looking for
383 if Entity
(Use_Item
) = Nam_Ent
then
386 -- Handle nested case, as in "with P; use P.Q.R"
393 -- Loop through prefixes looking for match
396 while Nkind
(UE
) = N_Expanded_Name
loop
397 if Same_Unit
(Prefix
(UE
), Nam_Ent
) then
409 elsif Nkind
(Cont_Item
) = N_Use_Type_Clause
410 and then not Used_Type_Or_Elab
416 -- Loop through prefixes looking for a match
418 UE
:= Prefix
(Subtype_Mark
(Cont_Item
));
420 if not Used_Type_Or_Elab
421 and then Same_Unit
(UE
, Nam_Ent
)
423 Used_Type_Or_Elab
:= True;
426 exit when Nkind
(UE
) /= N_Expanded_Name
;
431 -- Pragma Elaborate or Elaborate_All
433 elsif Nkind
(Cont_Item
) = N_Pragma
435 Pragma_Name_Unmapped
(Cont_Item
)
436 in Name_Elaborate | Name_Elaborate_All
437 and then not Used_Type_Or_Elab
440 First
(Pragma_Argument_Associations
(Cont_Item
));
441 while Present
(Prag_Unit
) and then not Used_Type_Or_Elab
loop
442 if Entity
(Expression
(Prag_Unit
)) = Nam_Ent
then
443 Used_Type_Or_Elab
:= True;
452 end Process_Body_Clauses
;
454 --------------------------
455 -- Process_Spec_Clauses --
456 --------------------------
458 procedure Process_Spec_Clauses
459 (Context_List
: List_Id
;
462 Withed
: out Boolean;
463 Exit_On_Self
: Boolean := False)
465 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
472 Cont_Item
:= First
(Context_List
);
473 while Present
(Cont_Item
) loop
475 -- Stop the search since the context items after Cont_Item have
476 -- already been examined in a previous iteration of the reverse
477 -- loop in Check_Redundant_Withs.
480 and Cont_Item
= Clause
485 -- Package use clause
487 if Nkind
(Cont_Item
) = N_Use_Package_Clause
490 if Entity
(Name
(Cont_Item
)) = Nam_Ent
then
494 -- Package with clause. Avoid processing self, implicitly
495 -- generated with clauses or limited with clauses. Note that
496 -- we examine with clauses having pragmas Elaborate or
497 -- Elaborate_All applied to them due to cases such as:
501 -- pragma Elaborate (Pack);
503 -- In this case, the second with clause is redundant since
504 -- the pragma applies only to the first "with Pack;".
506 -- Note that we only consider with_clauses that comes from
507 -- source. In the case of renamings used as prefixes of names
508 -- in with_clauses, we generate a with_clause for the prefix,
509 -- which we do not treat as implicit because it is needed for
510 -- visibility analysis, but is also not redundant.
512 elsif Nkind
(Cont_Item
) = N_With_Clause
513 and then Comes_From_Source
(Cont_Item
)
514 and then not Implicit_With
(Cont_Item
)
515 and then not Limited_Present
(Cont_Item
)
516 and then Cont_Item
/= Clause
517 and then Entity
(Name
(Cont_Item
)) = Nam_Ent
524 end Process_Spec_Clauses
;
526 -- Start of processing for Check_Redundant_Withs
529 Clause
:= Last
(Context_Items
);
530 while Present
(Clause
) loop
532 -- Avoid checking implicitly generated with clauses, limited with
533 -- clauses or withs that have pragma Elaborate or Elaborate_All.
535 if Nkind
(Clause
) = N_With_Clause
536 and then not Implicit_With
(Clause
)
537 and then not Limited_Present
(Clause
)
538 and then not Elaborate_Present
(Clause
)
540 -- With_clauses introduced for renamings of parent clauses
541 -- are not marked implicit because they need to be properly
542 -- installed, but they do not come from source and do not
545 and then Comes_From_Source
(Clause
)
547 -- Package body-to-spec check
549 if Present
(Spec_Context_Items
) then
551 Used_In_Body
: Boolean;
552 Used_In_Spec
: Boolean;
553 Used_Type_Or_Elab
: Boolean;
554 Withed_In_Spec
: Boolean;
558 (Context_List
=> Spec_Context_Items
,
560 Used
=> Used_In_Spec
,
561 Withed
=> Withed_In_Spec
);
564 (Context_List
=> Context_Items
,
566 Used
=> Used_In_Body
,
567 Used_Type_Or_Elab
=> Used_Type_Or_Elab
);
569 -- "Type Elab" refers to the presence of either a use
570 -- type clause, pragmas Elaborate or Elaborate_All.
572 -- +---------------+---------------------------+------+
573 -- | Spec | Body | Warn |
574 -- +--------+------+--------+------+-----------+------+
575 -- | Withed | Used | Withed | Used | Type Elab | |
576 -- | X | | X | | | X |
577 -- | X | | X | X | | |
578 -- | X | | X | | X | |
579 -- | X | | X | X | X | |
580 -- | X | X | X | | | X |
581 -- | X | X | X | | X | |
582 -- | X | X | X | X | | X |
583 -- | X | X | X | X | X | |
584 -- +--------+------+--------+------+-----------+------+
587 and then not Used_Type_Or_Elab
)
589 ((not Used_In_Spec
and then not Used_In_Body
)
590 or else Used_In_Spec
)
592 Error_Msg_N
-- CODEFIX
593 ("redundant with clause in body?r?", Clause
);
597 -- Standalone package spec or body check
600 if Is_Ancestor_Package
(Entity
(Name
(Clause
)),
601 Defining_Entity
(Unit_Node
))
604 ("unnecessary with of ancestor?r?", Clause
);
608 Dummy
: Boolean := False;
609 Withed
: Boolean := False;
612 -- The mechanism for examining the context clauses of a
613 -- package spec can be applied to package body clauses.
616 (Context_List
=> Context_Items
,
620 Exit_On_Self
=> True);
623 Error_Msg_N
-- CODEFIX
624 ("redundant with clause?r?", Clause
);
632 end Check_Redundant_Withs
;
636 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
637 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
638 Par_Spec_Name
: Unit_Name_Type
;
640 Unum
: Unit_Number_Type
;
642 -- Start of processing for Analyze_Compilation_Unit
645 Exp_Put_Image
.Preload_Root_Buffer_Type
(N
);
647 Process_Compilation_Unit_Pragmas
(N
);
649 -- If the unit is a subunit whose parent has not been analyzed (which
650 -- indicates that the main unit is a subunit, either the current one or
651 -- one of its descendants) then the subunit is compiled as part of the
652 -- analysis of the parent, which we proceed to do. Basically this gets
653 -- handled from the top down and we don't want to do anything at this
654 -- level (i.e. this subunit will be handled on the way down from the
655 -- parent), so at this level we immediately return. If the subunit ends
656 -- up not analyzed, it means that the parent did not contain a stub for
657 -- it, or that there errors were detected in some ancestor.
659 if Nkind
(Unit_Node
) = N_Subunit
and then not Analyzed
(Lib_Unit
) then
660 Semantics
(Lib_Unit
);
662 if not Analyzed
(Proper_Body
(Unit_Node
)) then
663 if Serious_Errors_Detected
> 0 then
664 Error_Msg_N
("subunit not analyzed (errors in parent unit)", N
);
666 Error_Msg_N
("missing stub for subunit", N
);
673 -- Analyze context (this will call Sem recursively for with'ed units) To
674 -- detect circularities among with-clauses that are not caught during
675 -- loading, we set the Context_Pending flag on the current unit. If the
676 -- flag is already set there is a potential circularity. We exclude
677 -- predefined units from this check because they are known to be safe.
678 -- We also exclude package bodies that are present because circularities
679 -- between bodies are harmless (and necessary).
681 if Context_Pending
(N
) then
683 Circularity
: Boolean := True;
686 if In_Predefined_Unit
(N
) then
687 Circularity
:= False;
690 for U
in Main_Unit
+ 1 .. Last_Unit
loop
691 if Nkind
(Unit
(Cunit
(U
))) = N_Package_Body
692 and then not Analyzed
(Cunit
(U
))
694 Circularity
:= False;
701 Error_Msg_N
("circular dependency caused by with_clauses", N
);
703 ("\possibly missing limited_with clause"
704 & " in one of the following", N
);
706 for U
in Main_Unit
.. Last_Unit
loop
707 if Context_Pending
(Cunit
(U
)) then
708 Error_Msg_Unit_1
:= Get_Unit_Name
(Unit
(Cunit
(U
)));
709 Error_Msg_N
("\unit$", N
);
713 raise Unrecoverable_Error
;
717 Set_Context_Pending
(N
);
722 Set_Context_Pending
(N
, False);
724 -- If the unit is a package body, the spec is already loaded and must be
725 -- analyzed first, before we analyze the body.
727 if Nkind
(Unit_Node
) = N_Package_Body
then
729 -- If no Lib_Unit, then there was a serious previous error, so just
730 -- ignore the entire analysis effort.
732 if No
(Lib_Unit
) then
733 Check_Error_Detected
;
737 -- Analyze the package spec
739 Semantics
(Lib_Unit
);
741 -- Check for unused with's
743 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
745 -- Verify that the library unit is a package declaration
747 if Nkind
(Unit
(Lib_Unit
)) not in
748 N_Package_Declaration | N_Generic_Package_Declaration
751 ("no legal package declaration for package body", N
);
754 -- Otherwise, the entity in the declaration is visible. Update the
755 -- version to reflect dependence of this body on the spec.
758 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
759 Set_Is_Immediately_Visible
(Spec_Id
, True);
760 Version_Update
(N
, Lib_Unit
);
762 if Nkind
(Defining_Unit_Name
(Unit_Node
)) =
763 N_Defining_Program_Unit_Name
765 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
770 -- If the unit is a subprogram body, then we similarly need to analyze
771 -- its spec. However, things are a little simpler in this case, because
772 -- here, this analysis is done mostly for error checking and consistency
773 -- purposes (but not only, e.g. there could be a contract on the spec),
774 -- so there's nothing else to be done.
776 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
777 if Acts_As_Spec
(N
) then
779 -- If the subprogram body is a child unit, we must create a
780 -- declaration for it, in order to properly load the parent(s).
781 -- After this, the original unit does not acts as a spec, because
782 -- there is an explicit one. If this unit appears in a context
783 -- clause, then an implicit with on the parent will be added when
784 -- installing the context. If this is the main unit, there is no
785 -- Unit_Table entry for the declaration (it has the unit number
786 -- of the main unit) and code generation is unaffected.
788 Unum
:= Get_Cunit_Unit_Number
(N
);
789 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
791 if Present
(Par_Spec_Name
) then
794 (Load_Name
=> Par_Spec_Name
,
799 if Unum
/= No_Unit
then
801 -- Build subprogram declaration and attach parent unit to it
802 -- This subprogram declaration does not come from source,
803 -- Nevertheless the backend must generate debugging info for
804 -- it, and this must be indicated explicitly. We also mark
805 -- the body entity as a child unit now, to prevent a
806 -- cascaded error if the spec entity cannot be entered
807 -- in its scope. Finally we create a Units table entry for
808 -- the subprogram declaration, to maintain a one-to-one
809 -- correspondence with compilation unit nodes. This is
810 -- critical for the tree traversals performed by CodePeer.
813 Loc
: constant Source_Ptr
:= Sloc
(N
);
814 SCS
: constant Boolean :=
815 Get_Comes_From_Source_Default
;
818 Set_Comes_From_Source_Default
(False);
820 -- Note: We copy the Context_Items from the explicit body
821 -- to the implicit spec, setting the former to Empty_List
822 -- to preserve the treeish nature of the tree, during
823 -- analysis of the spec. Then we put it back the way it
824 -- was -- copy the Context_Items from the spec to the
825 -- body, and set the spec Context_Items to Empty_List.
826 -- It is necessary to preserve the treeish nature,
827 -- because otherwise we will call End_Use_* twice on the
831 Make_Compilation_Unit
(Loc
,
832 Context_Items
=> Context_Items
(N
),
834 Make_Subprogram_Declaration
(Sloc
(N
),
837 (Specification
(Unit_Node
))),
839 Make_Compilation_Unit_Aux
(Loc
));
841 Set_Context_Items
(N
, Empty_List
);
842 Set_Library_Unit
(N
, Lib_Unit
);
843 Set_Parent_Spec
(Unit
(Lib_Unit
), Cunit
(Unum
));
844 Make_Child_Decl_Unit
(N
);
845 Semantics
(Lib_Unit
);
847 -- Now that a separate declaration exists, the body
848 -- of the child unit does not act as spec any longer.
850 Set_Acts_As_Spec
(N
, False);
851 Move_Aspects
(From
=> Unit_Node
, To
=> Unit
(Lib_Unit
));
852 Set_Is_Child_Unit
(Defining_Entity
(Unit_Node
));
853 Set_Debug_Info_Needed
(Defining_Entity
(Unit
(Lib_Unit
)));
854 Set_Comes_From_Source_Default
(SCS
);
856 -- Restore Context_Items to the body
858 Set_Context_Items
(N
, Context_Items
(Lib_Unit
));
859 Set_Context_Items
(Lib_Unit
, Empty_List
);
864 -- Here for subprogram with separate declaration
867 Semantics
(Lib_Unit
);
868 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
869 Version_Update
(N
, Lib_Unit
);
872 -- If this is a child unit, generate references to the parents
874 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
875 N_Defining_Program_Unit_Name
877 Generate_Parent_References
878 (Specification
(Unit_Node
),
879 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
883 -- If it is a child unit, the parent must be elaborated first and we
884 -- update version, since we are dependent on our parent.
886 if Is_Child_Spec
(Unit_Node
) then
888 -- The analysis of the parent is done with style checks off
891 Save_Style_Check
: constant Boolean := Style_Check
;
894 if not GNAT_Mode
then
895 Style_Check
:= False;
898 Semantics
(Parent_Spec
(Unit_Node
));
899 Version_Update
(N
, Parent_Spec
(Unit_Node
));
901 -- Restore style check settings
903 Style_Check
:= Save_Style_Check
;
907 -- With the analysis done, install the context. Note that we can't
908 -- install the context from the with clauses as we analyze them, because
909 -- each with clause must be analyzed in a clean visibility context, so
910 -- we have to wait and install them all at once.
914 if Is_Child_Spec
(Unit_Node
) then
916 -- Set the entities of all parents in the program_unit_name
918 Generate_Parent_References
919 (Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
922 -- All components of the context: with-clauses, library unit, ancestors
923 -- if any, (and their context) are analyzed and installed.
925 -- Call special debug routine sm if this is the main unit
927 if Current_Sem_Unit
= Main_Unit
then
931 -- Now analyze the unit (package, subprogram spec, body) itself
935 if Warn_On_Redundant_Constructs
then
936 Check_Redundant_Withs
(Context_Items
(N
));
938 if Nkind
(Unit_Node
) = N_Package_Body
then
939 Check_Redundant_Withs
940 (Context_Items
=> Context_Items
(N
),
941 Spec_Context_Items
=> Context_Items
(Lib_Unit
));
945 -- The above call might have made Unit_Node an N_Subprogram_Body from
946 -- something else, so propagate any Acts_As_Spec flag.
948 if Nkind
(Unit_Node
) = N_Subprogram_Body
949 and then Acts_As_Spec
(Unit_Node
)
951 Set_Acts_As_Spec
(N
);
954 -- Register predefined units in Rtsfind
956 if In_Predefined_Unit
(N
) then
957 Set_RTU_Loaded
(Unit_Node
);
960 -- Treat compilation unit pragmas that appear after the library unit
963 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
965 while Present
(Prag_Node
) loop
971 -- Analyze the contract of a [generic] subprogram that acts as a
972 -- compilation unit after all compilation pragmas have been analyzed.
974 if Nkind
(Unit_Node
) in
975 N_Generic_Subprogram_Declaration | N_Subprogram_Declaration
977 Analyze_Entry_Or_Subprogram_Contract
(Defining_Entity
(Unit_Node
));
980 -- Generate distribution stubs if requested and no error
983 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
985 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
986 and then Fatal_Error
(Main_Unit
) /= Error_Detected
988 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
990 -- Regular RCI package
992 Add_Stub_Constructs
(N
);
994 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
995 and then Is_Shared_Passive
(Defining_Entity
996 (Specification
(Unit_Node
))))
997 or else (Nkind
(Unit_Node
) = N_Package_Body
999 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
1001 -- Shared passive package
1003 Add_Stub_Constructs
(N
);
1005 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
1007 Is_Remote_Call_Interface
1008 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
1010 -- Instantiation of a RCI generic package
1012 Add_Stub_Constructs
(N
);
1016 -- Build dispatch tables of library-level tagged types only now because
1017 -- the generation of distribution stubs above may create some of them.
1019 if Expander_Active
and then Tagged_Type_Expansion
then
1020 case Nkind
(Unit_Node
) is
1021 when N_Package_Declaration | N_Package_Body
=>
1022 Build_Static_Dispatch_Tables
(Unit_Node
);
1024 when N_Package_Instantiation
=>
1025 Build_Static_Dispatch_Tables
(Instance_Spec
(Unit_Node
));
1032 -- Remove unit from visibility, so that environment is clean for the
1033 -- next compilation, which is either the main unit or some other unit
1036 if Nkind
(Unit_Node
) in N_Package_Declaration
1037 | N_Package_Renaming_Declaration
1038 | N_Subprogram_Declaration
1039 | N_Generic_Declaration
1040 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
1041 and then Acts_As_Spec
(Unit_Node
))
1043 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
1045 -- If the unit is an instantiation whose body will be elaborated for
1046 -- inlining purposes, use the proper entity of the instance. The entity
1047 -- may be missing if the instantiation was illegal.
1049 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
1050 and then not Error_Posted
(Unit_Node
)
1051 and then Present
(Instance_Spec
(Unit_Node
))
1053 Remove_Unit_From_Visibility
1054 (Defining_Entity
(Instance_Spec
(Unit_Node
)));
1056 elsif Nkind
(Unit_Node
) = N_Package_Body
1057 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
1058 and then not Acts_As_Spec
(Unit_Node
))
1060 -- Bodies that are not the main unit are compiled if they are generic
1061 -- or contain generic or inlined units. Their analysis brings in the
1062 -- context of the corresponding spec (unit declaration) which must be
1063 -- removed as well, to return the compilation environment to its
1066 Remove_Context
(Lib_Unit
);
1067 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
1070 -- Last step is to deinstall the context we just installed as well as
1071 -- the unit just compiled.
1075 -- When generating code for a non-generic main unit, check that withed
1076 -- generic units have a body if they need it, even if the units have not
1077 -- been instantiated. Force the load of the bodies to produce the proper
1078 -- error if the body is absent. The same applies to GNATprove mode, with
1079 -- the added benefit of capturing global references within the generic.
1080 -- This in turn allows for proper inlining of subprogram bodies without
1081 -- a previous declaration.
1083 if Get_Cunit_Unit_Number
(N
) = Main_Unit
1084 and then ((Operating_Mode
= Generate_Code
and then Expander_Active
)
1086 (Operating_Mode
= Check_Semantics
and then GNATprove_Mode
))
1088 -- Check whether the source for the body of the unit must be included
1089 -- in a standalone library.
1091 Check_Body_Needed_For_SAL
(Cunit_Entity
(Main_Unit
));
1093 -- Indicate that the main unit is now analyzed, to catch possible
1094 -- circularities between it and generic bodies. Remove main unit from
1095 -- visibility. This might seem superfluous, but the main unit must
1096 -- not be visible in the generic body expansions that follow.
1098 Set_Analyzed
(N
, True);
1099 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
1104 Un
: Unit_Number_Type
;
1106 Save_Style_Check
: constant Boolean := Style_Check
;
1109 Item
:= First
(Context_Items
(N
));
1110 while Present
(Item
) loop
1112 -- Check for explicit with clause
1114 if Nkind
(Item
) = N_With_Clause
1115 and then not Implicit_With
(Item
)
1117 -- Ada 2005 (AI-50217): Ignore limited-withed units
1119 and then not Limited_Present
(Item
)
1121 Nam
:= Entity
(Name
(Item
));
1123 -- Compile the generic subprogram, unless it is intrinsic or
1124 -- imported so no body is required, or generic package body
1125 -- if the package spec requires a body.
1127 if (Is_Generic_Subprogram
(Nam
)
1128 and then not Is_Intrinsic_Subprogram
(Nam
)
1129 and then not Is_Imported
(Nam
))
1130 or else (Ekind
(Nam
) = E_Generic_Package
1131 and then Unit_Requires_Body
(Nam
))
1133 Style_Check
:= False;
1135 if Present
(Renamed_Entity
(Nam
)) then
1141 (Unit_Declaration_Node
1142 (Renamed_Entity
(Nam
)))),
1151 Get_Body_Name
(Get_Unit_Name
(Item
)),
1158 if Un
= No_Unit
then
1160 ("body of generic unit& not found", Item
, Nam
);
1163 elsif not Analyzed
(Cunit
(Un
))
1164 and then Un
/= Main_Unit
1165 and then Fatal_Error
(Un
) /= Error_Detected
1167 Style_Check
:= False;
1168 Semantics
(Cunit
(Un
));
1176 -- Restore style checks settings
1178 Style_Check
:= Save_Style_Check
;
1181 -- In GNATprove mode, force the loading of an Interrupt_Priority when
1182 -- processing compilation units with potentially "main" subprograms.
1183 -- This is required for the ceiling priority protocol checks, which
1184 -- are triggered by these subprograms.
1187 and then Nkind
(Unit_Node
) in N_Function_Instantiation
1188 | N_Procedure_Instantiation
1195 case Nkind
(Unit_Node
) is
1196 when N_Subprogram_Body
=>
1197 Spec
:= Specification
(Unit_Node
);
1199 when N_Subprogram_Instantiation
=>
1201 Subprogram_Specification
(Entity
(Name
(Unit_Node
)));
1204 raise Program_Error
;
1207 pragma Assert
(Nkind
(Spec
) in N_Subprogram_Specification
);
1209 -- Main subprogram must have no parameters, and if it is a
1210 -- function, it must return an integer.
1212 if No
(Parameter_Specifications
(Spec
))
1213 and then (Nkind
(Spec
) = N_Procedure_Specification
1215 Is_Integer_Type
(Etype
(Result_Definition
(Spec
))))
1217 SPARK_Implicit_Load
(RE_Interrupt_Priority
);
1223 -- Deal with creating elaboration counter if needed. We create an
1224 -- elaboration counter only for units that come from source since
1225 -- units manufactured by the compiler never need elab checks.
1227 if Comes_From_Source
(N
)
1228 and then Nkind
(Unit_Node
) in N_Package_Declaration
1229 | N_Generic_Package_Declaration
1230 | N_Subprogram_Declaration
1231 | N_Generic_Subprogram_Declaration
1234 Loc
: constant Source_Ptr
:= Sloc
(N
);
1235 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
1238 Spec_Id
:= Defining_Entity
(Unit_Node
);
1239 Generate_Definition
(Spec_Id
);
1241 -- See if an elaboration entity is required for possible access
1242 -- before elaboration checking. Note that we must allow for this
1243 -- even if -gnatE is not set, since a client may be compiled in
1244 -- -gnatE mode and reference the entity.
1246 -- These entities are also used by the binder to prevent multiple
1247 -- attempts to execute the elaboration code for the library case
1248 -- where the elaboration routine might otherwise be called more
1251 -- They are also needed to ensure explicit visibility from the
1252 -- binder generated code of all the units involved in a partition
1253 -- when control-flow preservation is requested.
1255 if not Opt
.Suppress_Control_Flow_Optimizations
1257 ( -- Pure units do not need checks
1261 -- Preelaborated units do not need checks
1263 or else Is_Preelaborated
(Spec_Id
)
1265 -- No checks needed if pragma Elaborate_Body present
1267 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
1269 -- No checks needed if unit does not require a body
1271 or else not Unit_Requires_Body
(Spec_Id
)
1273 -- No checks needed for predefined files
1275 or else Is_Predefined_Unit
(Unum
)
1277 -- No checks required if no separate spec
1279 or else Acts_As_Spec
(N
)
1282 -- This is a case where we only need the entity for checking to
1283 -- prevent multiple elaboration checks.
1285 Set_Elaboration_Entity_Required
(Spec_Id
, False);
1287 -- Otherwise the unit requires an elaboration entity because it
1291 Set_Elaboration_Entity_Required
(Spec_Id
);
1294 Build_Elaboration_Entity
(N
, Spec_Id
);
1298 -- Freeze the compilation unit entity. This for sure is needed because
1299 -- of some warnings that can be output (see Freeze_Subprogram), but may
1300 -- in general be required. If freezing actions result, place them in the
1301 -- compilation unit actions list, and analyze them.
1304 L
: constant List_Id
:=
1305 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), N
);
1307 while Is_Non_Empty_List
(L
) loop
1308 Insert_Library_Level_Action
(Remove_Head
(L
));
1314 -- Call Check_Package_Body so that a body containing subprograms with
1315 -- Inline_Always can be made available for front end inlining.
1317 if Nkind
(Unit_Node
) = N_Package_Declaration
1318 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
1320 -- We don't need to do this if the Expander is not active, since there
1321 -- is no code to inline.
1323 and then Expander_Active
1326 Save_Style_Check
: constant Boolean := Style_Check
;
1327 Save_Warning
: constant Warning_Mode_Type
:= Warning_Mode
;
1328 Options
: Style_Check_Options
;
1331 Save_Style_Check_Options
(Options
);
1332 Reset_Style_Check_Options
;
1333 Opt
.Warning_Mode
:= Suppress
;
1335 Check_Package_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
1337 Reset_Style_Check_Options
;
1338 Set_Style_Check_Options
(Options
);
1339 Style_Check
:= Save_Style_Check
;
1340 Warning_Mode
:= Save_Warning
;
1344 -- If we are generating obsolescent warnings, then here is where we
1345 -- generate them for the with'ed items. The reason for this special
1346 -- processing is that the normal mechanism of generating the warnings
1347 -- for referenced entities does not work for context clause references.
1348 -- That's because when we first analyze the context, it is too early to
1349 -- know if the with'ing unit is itself obsolescent (which suppresses
1353 and then Warn_On_Obsolescent_Feature
1354 and then Nkind
(Unit_Node
) not in N_Generic_Instantiation
1356 -- Push current compilation unit as scope, so that the test for
1357 -- being within an obsolescent unit will work correctly. The check
1358 -- is not performed within an instantiation, because the warning
1359 -- will have been emitted in the corresponding generic unit.
1361 Push_Scope
(Defining_Entity
(Unit_Node
));
1363 -- Loop through context items to deal with with clauses
1371 Item
:= First
(Context_Items
(N
));
1372 while Present
(Item
) loop
1373 if Nkind
(Item
) = N_With_Clause
1375 -- Suppress this check in limited-withed units. Further work
1376 -- needed here if we decide to incorporate this check on
1377 -- limited-withed units.
1379 and then not Limited_Present
(Item
)
1382 Ent
:= Entity
(Nam
);
1384 if Is_Obsolescent
(Ent
) then
1385 Output_Obsolescent_Entity_Warnings
(Nam
, Ent
);
1393 -- Remove temporary install of current unit as scope
1398 -- If No_Elaboration_Code_All was encountered, this is where we do the
1399 -- transitive test of with'ed units to make sure they have the aspect.
1400 -- This is delayed till the end of analyzing the compilation unit to
1401 -- ensure that the pragma/aspect, if present, has been analyzed.
1403 Check_No_Elab_Code_All
(N
);
1405 -- If this is a main compilation containing a package declaration that
1406 -- requires no package body, and the profile of some subprogram depends
1407 -- on shadow incomplete entities then perform full analysis of its
1408 -- limited-with units.
1410 Analyze_Required_Limited_With_Units
(N
);
1411 end Analyze_Compilation_Unit
;
1413 ---------------------
1414 -- Analyze_Context --
1415 ---------------------
1417 procedure Analyze_Context
(N
: Node_Id
) is
1418 Ukind
: constant Node_Kind
:= Nkind
(Unit
(N
));
1422 -- First process all configuration pragmas at the start of the context
1423 -- items. Strictly these are not part of the context clause, but that
1424 -- is where the parser puts them. In any case for sure we must analyze
1425 -- these before analyzing the actual context items, since they can have
1426 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1427 -- be with'ed as a result of changing categorizations in Ada 2005).
1429 Item
:= First
(Context_Items
(N
));
1430 while Present
(Item
)
1431 and then Nkind
(Item
) = N_Pragma
1432 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
1438 -- This is the point at which we capture the configuration settings
1439 -- for the unit. At the moment only the Optimize_Alignment setting
1440 -- needs to be captured. Probably more later ???
1442 if Optimize_Alignment_Local
then
1443 Set_OA_Setting
(Current_Sem_Unit
, 'L');
1445 Set_OA_Setting
(Current_Sem_Unit
, Optimize_Alignment
);
1448 -- Loop through actual context items. This is done in two passes:
1450 -- a) The first pass analyzes nonlimited with clauses and also any
1451 -- configuration pragmas (we need to get the latter analyzed right
1452 -- away, since they can affect processing of subsequent items).
1454 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1456 while Present
(Item
) loop
1458 -- For with clause, analyze the with clause, and then update the
1459 -- version, since we are dependent on a unit that we with.
1461 if Nkind
(Item
) = N_With_Clause
1462 and then not Limited_Present
(Item
)
1464 -- Skip analyzing with clause if no unit, nothing to do (this
1465 -- happens for a with that references a non-existent unit).
1467 if Present
(Library_Unit
(Item
)) then
1469 -- Skip analyzing with clause if this is a with_clause for
1470 -- the main unit, which happens if a subunit has a useless
1471 -- with_clause on its parent.
1473 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
) then
1476 -- Here for the case of a useless with for the main unit
1479 Set_Entity
(Name
(Item
), Cunit_Entity
(Current_Sem_Unit
));
1483 -- Do version update (skipped for implicit with)
1485 if not Implicit_With
(Item
) then
1486 Version_Update
(N
, Library_Unit
(Item
));
1489 -- Skip pragmas. Configuration pragmas at the start were handled in
1490 -- the loop above, and remaining pragmas are not processed until we
1491 -- actually install the context (see Install_Context). We delay the
1492 -- analysis of these pragmas to make sure that we have installed all
1493 -- the implicit with's on parent units.
1495 -- Skip use clauses at this stage, since we don't want to do any
1496 -- installing of potentially use-visible entities until we
1497 -- actually install the complete context (in Install_Context).
1498 -- Otherwise things can get installed in the wrong context.
1507 -- Second pass: examine all limited_with clauses. All other context
1508 -- items are ignored in this pass.
1510 Item
:= First
(Context_Items
(N
));
1511 while Present
(Item
) loop
1512 if Nkind
(Item
) = N_With_Clause
1513 and then Limited_Present
(Item
)
1515 -- No need to check errors on implicitly generated limited-with
1518 if not Implicit_With
(Item
) then
1520 -- Verify that the illegal contexts given in 10.1.2 (18/2) are
1521 -- properly rejected, including renaming declarations.
1523 if Ukind
not in N_Package_Declaration
1524 | N_Subprogram_Declaration
1525 | N_Generic_Declaration
1526 | N_Generic_Instantiation
1528 Error_Msg_N
("limited with_clause not allowed here", Item
);
1530 -- Check wrong use of a limited with clause applied to the
1531 -- compilation unit containing the limited-with clause.
1533 -- limited with P.Q;
1534 -- package P.Q is ...
1536 elsif Unit
(Library_Unit
(Item
)) = Unit
(N
) then
1537 Error_Msg_N
("wrong use of limited-with clause", Item
);
1539 -- Check wrong use of limited-with clause applied to some
1540 -- immediate ancestor.
1542 elsif Is_Child_Spec
(Unit
(N
)) then
1544 Lib_U
: constant Entity_Id
:= Unit
(Library_Unit
(Item
));
1548 P
:= Parent_Spec
(Unit
(N
));
1550 if Unit
(P
) = Lib_U
then
1552 ("limited with_clause cannot name ancestor",
1557 exit when not Is_Child_Spec
(Unit
(P
));
1558 P
:= Parent_Spec
(Unit
(P
));
1563 -- Check if the limited-withed unit is already visible through
1564 -- some context clause of the current compilation unit or some
1565 -- ancestor of the current compilation unit.
1568 Lim_Unit_Name
: constant Node_Id
:= Name
(Item
);
1569 Comp_Unit
: Node_Id
;
1571 Unit_Name
: Node_Id
;
1576 It
:= First
(Context_Items
(Comp_Unit
));
1577 while Present
(It
) loop
1579 and then Nkind
(It
) = N_With_Clause
1580 and then not Limited_Present
(It
)
1581 and then Nkind
(Unit
(Library_Unit
(It
))) in
1582 N_Package_Declaration |
1583 N_Package_Renaming_Declaration
1585 if Nkind
(Unit
(Library_Unit
(It
))) =
1586 N_Package_Declaration
1588 Unit_Name
:= Name
(It
);
1590 Unit_Name
:= Name
(Unit
(Library_Unit
(It
)));
1593 -- Check if the named package (or some ancestor)
1594 -- leaves visible the full-view of the unit given
1595 -- in the limited-with clause.
1598 if Designate_Same_Unit
(Lim_Unit_Name
,
1601 Error_Msg_Sloc
:= Sloc
(It
);
1603 ("simultaneous visibility of limited and "
1604 & "unlimited views not allowed", Item
);
1606 ("\unlimited view visible through context "
1607 & "clause #", Item
);
1610 elsif Nkind
(Unit_Name
) = N_Identifier
then
1614 Unit_Name
:= Prefix
(Unit_Name
);
1621 exit when not Is_Child_Spec
(Unit
(Comp_Unit
));
1623 Comp_Unit
:= Parent_Spec
(Unit
(Comp_Unit
));
1628 -- Skip analyzing with clause if no unit, see above
1630 if Present
(Library_Unit
(Item
)) then
1634 -- A limited_with does not impose an elaboration order, but there
1635 -- is a semantic dependency for recompilation purposes.
1637 if not Implicit_With
(Item
) then
1638 Version_Update
(N
, Library_Unit
(Item
));
1641 -- Pragmas and use clauses and with clauses other than limited with's
1642 -- are ignored in this pass through the context items.
1650 end Analyze_Context
;
1652 -------------------------------
1653 -- Analyze_Package_Body_Stub --
1654 -------------------------------
1656 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
1657 Id
: constant Entity_Id
:= Defining_Entity
(N
);
1659 Opts
: Config_Switches_Type
;
1662 -- The package declaration must be in the current declarative part
1664 Check_Stub_Level
(N
);
1665 Nam
:= Current_Entity_In_Scope
(Id
);
1667 if No
(Nam
) or else not Is_Package_Or_Generic_Package
(Nam
) then
1668 Error_Msg_N
("missing specification for package stub", N
);
1670 elsif Has_Completion
(Nam
)
1671 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
1673 Error_Msg_N
("duplicate or redundant stub for package", N
);
1676 -- Retain and restore the configuration options of the enclosing
1677 -- context as the proper body may introduce a set of its own.
1679 Opts
:= Save_Config_Switches
;
1681 -- Indicate that the body of the package exists. If we are doing
1682 -- only semantic analysis, the stub stands for the body. If we are
1683 -- generating code, the existence of the body will be confirmed
1684 -- when we load the proper body.
1686 Set_Scope
(Id
, Current_Scope
);
1687 Mutate_Ekind
(Id
, E_Package_Body
);
1688 Set_Etype
(Id
, Standard_Void_Type
);
1690 if Has_Aspects
(N
) then
1691 Analyze_Aspect_Specifications
(N
, Id
);
1694 Set_Has_Completion
(Nam
);
1695 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
1696 Generate_Reference
(Nam
, Id
, 'b');
1697 Analyze_Proper_Body
(N
, Nam
);
1699 Restore_Config_Switches
(Opts
);
1701 end Analyze_Package_Body_Stub
;
1703 -------------------------
1704 -- Analyze_Proper_Body --
1705 -------------------------
1707 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
1708 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
1710 procedure Optional_Subunit
;
1711 -- This procedure is called when the main unit is a stub, or when we
1712 -- are not generating code. In such a case, we analyze the subunit if
1713 -- present, which is user-friendly, but we don't complain if the subunit
1714 -- is missing. In GNATprove_Mode, we issue an error to avoid formal
1715 -- verification of a partial unit.
1717 ----------------------
1718 -- Optional_Subunit --
1719 ----------------------
1721 procedure Optional_Subunit
is
1722 Comp_Unit
: Node_Id
;
1723 Unum
: Unit_Number_Type
;
1726 -- Try to load subunit, but ignore any errors that occur during the
1727 -- loading of the subunit, by using the special feature in Errout to
1728 -- ignore all errors. Note that Fatal_Error will still be set, so we
1729 -- will be able to check for this case below.
1731 if not GNATprove_Mode
then
1732 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
1737 (Load_Name
=> Subunit_Name
,
1738 Required
=> GNATprove_Mode
,
1742 if not GNATprove_Mode
then
1743 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
1746 -- All done if we successfully loaded the subunit
1749 and then (Fatal_Error
(Unum
) /= Error_Detected
1750 or else Try_Semantics
)
1752 Comp_Unit
:= Cunit
(Unum
);
1754 -- If the file was empty or seriously mangled, the unit itself may
1757 if No
(Unit
(Comp_Unit
)) then
1759 ("subunit does not contain expected proper body", N
);
1761 elsif Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1763 ("expected SEPARATE subunit, found child unit",
1764 Cunit_Entity
(Unum
));
1766 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1767 Analyze_Subunit
(Comp_Unit
);
1768 Set_Library_Unit
(N
, Comp_Unit
);
1769 Set_Corresponding_Body
(N
, Defining_Entity
(Unit
(Comp_Unit
)));
1772 elsif Unum
= No_Unit
1773 and then Present
(Nam
)
1775 if Is_Protected_Type
(Nam
) then
1776 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
1778 Set_Corresponding_Body
(
1779 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1782 end Optional_Subunit
;
1786 Comp_Unit
: Node_Id
;
1787 Unum
: Unit_Number_Type
;
1789 -- Start of processing for Analyze_Proper_Body
1792 -- If the subunit is already loaded, it means that the main unit is a
1793 -- subunit, and that the current unit is one of its parents which was
1794 -- being analyzed to provide the needed context for the analysis of the
1795 -- subunit. In this case we analyze the subunit and continue with the
1796 -- parent, without looking at subsequent subunits.
1798 if Is_Loaded
(Subunit_Name
) then
1800 -- If the proper body is already linked to the stub node, the stub is
1801 -- in a generic unit and just needs analyzing.
1803 if Present
(Library_Unit
(N
)) then
1804 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1806 -- If the subunit has severe errors, the spec of the enclosing
1807 -- body may not be available, in which case do not try analysis.
1809 if Serious_Errors_Detected
> 0
1810 and then No
(Library_Unit
(Library_Unit
(N
)))
1815 -- Collect SCO information for loaded subunit if we are in the
1816 -- extended main unit.
1819 and then In_Extended_Main_Source_Unit
1820 (Cunit_Entity
(Current_Sem_Unit
))
1822 SCO_Record_Raw
(Get_Cunit_Unit_Number
(Library_Unit
(N
)));
1825 Analyze_Subunit
(Library_Unit
(N
));
1827 -- Otherwise we must load the subunit and link to it
1830 -- Load the subunit, this must work, since we originally loaded
1831 -- the subunit earlier on. So this will not really load it, just
1832 -- give access to it.
1836 (Load_Name
=> Subunit_Name
,
1841 -- And analyze the subunit in the parent context (note that we
1842 -- do not call Semantics, since that would remove the parent
1843 -- context). Because of this, we have to manually reset the
1844 -- compiler state to Analyzing since it got destroyed by Load.
1846 if Unum
/= No_Unit
then
1847 Compiler_State
:= Analyzing
;
1849 -- Check that the proper body is a subunit and not a child
1850 -- unit. If the unit was previously loaded, the error will
1851 -- have been emitted when copying the generic node, so we
1852 -- just return to avoid cascaded errors.
1854 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1858 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1859 Analyze_Subunit
(Cunit
(Unum
));
1860 Set_Library_Unit
(N
, Cunit
(Unum
));
1864 -- If the main unit is a subunit, then we are just performing semantic
1865 -- analysis on that subunit, and any other subunits of any parent unit
1866 -- should be ignored. If the main unit is itself a subunit, another
1867 -- subunit is irrelevant unless it is a subunit of the current one, that
1868 -- is to say appears in the current source tree.
1870 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1871 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1873 -- But before we return, set the flag for unloaded subunits. This
1874 -- will suppress junk warnings of variables in the same declarative
1875 -- part (or a higher level one) that are in danger of looking unused
1876 -- when in fact there might be a declaration in the subunit that we
1877 -- do not intend to load.
1879 Unloaded_Subunits
:= True;
1882 -- If the subunit is not already loaded, and we are generating code,
1883 -- then this is the case where compilation started from the parent, and
1884 -- we are generating code for an entire subunit tree. In that case we
1885 -- definitely need to load the subunit.
1887 -- In order to continue the analysis with the rest of the parent,
1888 -- and other subunits, we load the unit without requiring its
1889 -- presence, and emit a warning if not found, rather than terminating
1890 -- the compilation abruptly, as for other missing file problems.
1892 elsif Original_Operating_Mode
= Generate_Code
then
1894 -- If the proper body is already linked to the stub node, the stub is
1895 -- in a generic unit and just needs analyzing.
1897 -- We update the version. Although we are not strictly technically
1898 -- semantically dependent on the subunit, given our approach of macro
1899 -- substitution of subunits, it makes sense to include it in the
1900 -- version identification.
1902 if Present
(Library_Unit
(N
)) then
1903 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1904 Analyze_Subunit
(Library_Unit
(N
));
1905 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1907 -- Otherwise we must load the subunit and link to it
1910 -- Make sure that, if the subunit is preprocessed and -gnateG is
1911 -- specified, the preprocessed file will be written.
1913 Lib
.Analysing_Subunit_Of_Main
:= True;
1916 (Load_Name
=> Subunit_Name
,
1920 Lib
.Analysing_Subunit_Of_Main
:= False;
1922 -- Give message if we did not get the unit Emit warning even if
1923 -- missing subunit is not within main unit, to simplify debugging.
1925 pragma Assert
(Original_Operating_Mode
= Generate_Code
);
1926 if Unum
= No_Unit
then
1927 Error_Msg_Unit_1
:= Subunit_Name
;
1929 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1931 ("subunit$$ in file{ not found??!!", N
);
1932 Subunits_Missing
:= True;
1935 -- Load_Unit may reset Compiler_State, since it may have been
1936 -- necessary to parse an additional units, so we make sure that
1937 -- we reset it to the Analyzing state.
1939 Compiler_State
:= Analyzing
;
1941 if Unum
/= No_Unit
then
1942 if Debug_Flag_L
then
1943 Write_Str
("*** Loaded subunit from stub. Analyze");
1947 Comp_Unit
:= Cunit
(Unum
);
1949 -- Check for child unit instead of subunit
1951 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1953 ("expected SEPARATE subunit, found child unit",
1954 Cunit_Entity
(Unum
));
1956 -- OK, we have a subunit
1959 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1960 Set_Library_Unit
(N
, Comp_Unit
);
1962 -- We update the version. Although we are not technically
1963 -- semantically dependent on the subunit, given our approach
1964 -- of macro substitution of subunits, it makes sense to
1965 -- include it in the version identification.
1967 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1969 -- Collect SCO information for loaded subunit if we are in
1970 -- the extended main unit.
1973 and then In_Extended_Main_Source_Unit
1974 (Cunit_Entity
(Current_Sem_Unit
))
1976 SCO_Record_Raw
(Unum
);
1979 -- Analyze the unit if semantics active
1981 if Fatal_Error
(Unum
) /= Error_Detected
1982 or else Try_Semantics
1984 Analyze_Subunit
(Comp_Unit
);
1990 -- The remaining case is when the subunit is not already loaded and we
1991 -- are not generating code. In this case we are just performing semantic
1992 -- analysis on the parent, and we are not interested in the subunit. For
1993 -- subprograms, analyze the stub as a body. For other entities the stub
1994 -- has already been marked as completed.
1999 end Analyze_Proper_Body
;
2001 ----------------------------------
2002 -- Analyze_Protected_Body_Stub --
2003 ----------------------------------
2005 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
2006 Id
: constant Entity_Id
:= Defining_Entity
(N
);
2007 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Id
);
2008 Opts
: Config_Switches_Type
;
2011 Check_Stub_Level
(N
);
2013 -- First occurrence of name may have been as an incomplete type
2015 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2016 Nam
:= Full_View
(Nam
);
2019 if No
(Nam
) or else not Is_Protected_Type
(Etype
(Nam
)) then
2020 Error_Msg_N
("missing specification for Protected body", N
);
2023 -- Retain and restore the configuration options of the enclosing
2024 -- context as the proper body may introduce a set of its own.
2026 Opts
:= Save_Config_Switches
;
2028 Set_Scope
(Id
, Current_Scope
);
2029 Mutate_Ekind
(Id
, E_Protected_Body
);
2030 Set_Etype
(Id
, Standard_Void_Type
);
2032 if Has_Aspects
(N
) then
2033 Analyze_Aspect_Specifications
(N
, Id
);
2036 Set_Has_Completion
(Etype
(Nam
));
2037 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
2038 Generate_Reference
(Nam
, Id
, 'b');
2039 Analyze_Proper_Body
(N
, Etype
(Nam
));
2041 Restore_Config_Switches
(Opts
);
2043 end Analyze_Protected_Body_Stub
;
2045 -----------------------------------------
2046 -- Analyze_Required_Limited_With_Units --
2047 -----------------------------------------
2049 procedure Analyze_Required_Limited_With_Units
(N
: Node_Id
) is
2050 Unit_Node
: constant Node_Id
:= Unit
(N
);
2051 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Unit_Node
);
2053 function Depends_On_Limited_Views
(Pkg_Id
: Entity_Id
) return Boolean;
2054 -- Determines whether the given package has some subprogram with a
2055 -- profile that depends on shadow incomplete type entities of a
2056 -- limited-with unit.
2058 function Has_Limited_With_Clauses
return Boolean;
2059 -- Determines whether the compilation unit N has limited-with context
2062 ------------------------------
2063 -- Has_Limited_With_Clauses --
2064 ------------------------------
2066 function Has_Limited_With_Clauses
return Boolean is
2067 Item
: Node_Id
:= First
(Context_Items
(N
));
2070 while Present
(Item
) loop
2071 if Nkind
(Item
) = N_With_Clause
2072 and then Limited_Present
(Item
)
2073 and then not Implicit_With
(Item
)
2082 end Has_Limited_With_Clauses
;
2084 ------------------------------
2085 -- Depends_On_Limited_Views --
2086 ------------------------------
2088 function Depends_On_Limited_Views
(Pkg_Id
: Entity_Id
) return Boolean is
2090 function Has_Limited_View_Types
(Subp
: Entity_Id
) return Boolean;
2091 -- Determines whether the type of some formal of Subp, or its return
2092 -- type, is a shadow incomplete entity of a limited-with unit.
2094 ----------------------------
2095 -- Has_Limited_View_Types --
2096 ----------------------------
2098 function Has_Limited_View_Types
(Subp
: Entity_Id
) return Boolean is
2099 Formal
: Entity_Id
:= First_Formal
(Subp
);
2102 while Present
(Formal
) loop
2103 if From_Limited_With
(Etype
(Formal
))
2104 and then Has_Non_Limited_View
(Etype
(Formal
))
2105 and then Ekind
(Non_Limited_View
(Etype
(Formal
)))
2111 Formal
:= Next_Formal
(Formal
);
2114 if Ekind
(Subp
) = E_Function
2115 and then From_Limited_With
(Etype
(Subp
))
2116 and then Has_Non_Limited_View
(Etype
(Subp
))
2117 and then Ekind
(Non_Limited_View
(Etype
(Subp
)))
2124 end Has_Limited_View_Types
;
2128 E
: Entity_Id
:= First_Entity
(Pkg_Id
);
2131 while Present
(E
) loop
2132 if Is_Subprogram
(E
)
2133 and then Has_Limited_View_Types
(E
)
2137 -- Recursion on nested packages skipping package renamings
2139 elsif Ekind
(E
) = E_Package
2140 and then No
(Renamed_Entity
(E
))
2141 and then Depends_On_Limited_Views
(E
)
2150 end Depends_On_Limited_Views
;
2156 -- Start of processing for Analyze_Required_Limited_With_Units
2159 -- Cases where no action is required
2161 if not Expander_Active
2162 or else Nkind
(Unit_Node
) /= N_Package_Declaration
2163 or else Main_Unit_Entity
/= Spec_Id
2164 or else Is_Generic_Unit
(Spec_Id
)
2165 or else Unit_Requires_Body
(Spec_Id
)
2166 or else not Has_Limited_With_Clauses
2167 or else not Depends_On_Limited_Views
(Spec_Id
)
2172 -- Perform full analyis of limited-with units to provide the backend
2173 -- with the full-view of shadow entities.
2175 Item
:= First
(Context_Items
(N
));
2176 while Present
(Item
) loop
2177 if Nkind
(Item
) = N_With_Clause
2178 and then Limited_Present
(Item
)
2179 and then not Implicit_With
(Item
)
2181 Semantics
(Library_Unit
(Item
));
2186 end Analyze_Required_Limited_With_Units
;
2188 ----------------------------------
2189 -- Analyze_Subprogram_Body_Stub --
2190 ----------------------------------
2192 -- A subprogram body stub can appear with or without a previous spec. If
2193 -- there is one, then the analysis of the body will find it and verify
2194 -- conformance. The formals appearing in the specification of the stub play
2195 -- no role, except for requiring an additional conformance check. If there
2196 -- is no previous subprogram declaration, the stub acts as a spec, and
2197 -- provides the defining entity for the subprogram.
2199 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
2201 Opts
: Config_Switches_Type
;
2204 Check_Stub_Level
(N
);
2206 -- Verify that the identifier for the stub is unique within this
2207 -- declarative part.
2209 if Nkind
(Parent
(N
)) in
2210 N_Block_Statement | N_Package_Body | N_Subprogram_Body
2212 Decl
:= First
(Declarations
(Parent
(N
)));
2213 while Present
(Decl
) and then Decl
/= N
loop
2214 if Nkind
(Decl
) = N_Subprogram_Body_Stub
2215 and then Chars
(Defining_Unit_Name
(Specification
(Decl
))) =
2216 Chars
(Defining_Unit_Name
(Specification
(N
)))
2218 Error_Msg_N
("identifier for stub is not unique", N
);
2225 -- Retain and restore the configuration options of the enclosing context
2226 -- as the proper body may introduce a set of its own.
2228 Opts
:= Save_Config_Switches
;
2230 -- Treat stub as a body, which checks conformance if there is a previous
2231 -- declaration, or else introduces entity and its signature.
2233 Analyze_Subprogram_Body
(N
);
2234 Analyze_Proper_Body
(N
, Empty
);
2236 Restore_Config_Switches
(Opts
);
2237 end Analyze_Subprogram_Body_Stub
;
2239 ---------------------
2240 -- Analyze_Subunit --
2241 ---------------------
2243 -- A subunit is compiled either by itself (for semantic checking) or as
2244 -- part of compiling the parent (for code generation). In either case, by
2245 -- the time we actually process the subunit, the parent has already been
2246 -- installed and analyzed. The node N is a compilation unit, whose context
2247 -- needs to be treated here, because we come directly here from the parent
2248 -- without calling Analyze_Compilation_Unit.
2250 -- The compilation context includes the explicit context of the subunit,
2251 -- and the context of the parent, together with the parent itself. In order
2252 -- to compile the current context, we remove the one inherited from the
2253 -- parent, in order to have a clean visibility table. We restore the parent
2254 -- context before analyzing the proper body itself. On exit, we remove only
2255 -- the explicit context of the subunit.
2257 -- WARNING: This routine manages SPARK regions. Return statements must be
2258 -- replaced by gotos which jump to the end of the routine and restore the
2261 procedure Analyze_Subunit
(N
: Node_Id
) is
2262 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
2263 Par_Unit
: constant Entity_Id
:= Current_Scope
;
2265 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
2266 Num_Scopes
: Nat
:= 0;
2267 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
2268 Enclosing_Child
: Entity_Id
:= Empty
;
2269 Svg
: constant Suppress_Record
:= Scope_Suppress
;
2271 Save_Cunit_Restrictions
: constant Save_Cunit_Boolean_Restrictions
:=
2272 Cunit_Boolean_Restrictions_Save
;
2273 -- Save non-partition wide restrictions before processing the subunit.
2274 -- All subunits are analyzed with config restrictions reset and we need
2275 -- to restore these saved values at the end.
2277 procedure Analyze_Subunit_Context
;
2278 -- Capture names in use clauses of the subunit. This must be done before
2279 -- re-installing parent declarations, because items in the context must
2280 -- not be hidden by declarations local to the parent.
2282 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
2283 -- Recursive procedure to restore scope of all ancestors of subunit,
2284 -- from outermost in. If parent is not a subunit, the call to install
2285 -- context installs context of spec and (if parent is a child unit) the
2286 -- context of its parents as well. It is confusing that parents should
2287 -- be treated differently in both cases, but the semantics are just not
2290 procedure Re_Install_Use_Clauses
;
2291 -- As part of the removal of the parent scope, the use clauses are
2292 -- removed, to be reinstalled when the context of the subunit has been
2293 -- analyzed. Use clauses may also have been affected by the analysis of
2294 -- the context of the subunit, so they have to be applied again, to
2295 -- insure that the compilation environment of the rest of the parent
2296 -- unit is identical.
2298 procedure Remove_Scope
;
2299 -- Remove current scope from scope stack, and preserve the list of use
2300 -- clauses in it, to be reinstalled after context is analyzed.
2302 -----------------------------
2303 -- Analyze_Subunit_Context --
2304 -----------------------------
2306 procedure Analyze_Subunit_Context
is
2308 Unit_Name
: Entity_Id
;
2311 Analyze_Context
(N
);
2312 Check_No_Elab_Code_All
(N
);
2314 -- Make withed units immediately visible. If child unit, make the
2315 -- ultimate parent immediately visible.
2317 Item
:= First
(Context_Items
(N
));
2318 while Present
(Item
) loop
2319 if Nkind
(Item
) = N_With_Clause
then
2321 -- Protect frontend against previous errors in context clauses
2323 if Nkind
(Name
(Item
)) /= N_Selected_Component
then
2324 if Error_Posted
(Item
) then
2328 -- If a subunits has serious syntax errors, the context
2329 -- may not have been loaded. Add a harmless unit name to
2330 -- attempt processing.
2332 if Serious_Errors_Detected
> 0
2333 and then No
(Entity
(Name
(Item
)))
2335 Set_Entity
(Name
(Item
), Standard_Standard
);
2338 Unit_Name
:= Entity
(Name
(Item
));
2340 Set_Is_Visible_Lib_Unit
(Unit_Name
);
2341 exit when Scope
(Unit_Name
) = Standard_Standard
;
2342 Unit_Name
:= Scope
(Unit_Name
);
2344 if No
(Unit_Name
) then
2345 Check_Error_Detected
;
2350 if not Is_Immediately_Visible
(Unit_Name
) then
2351 Set_Is_Immediately_Visible
(Unit_Name
);
2352 Set_Context_Installed
(Item
);
2357 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2358 Analyze
(Name
(Item
));
2360 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2361 Analyze
(Subtype_Mark
(Item
));
2367 -- Reset visibility of withed units. They will be made visible again
2368 -- when we install the subunit context.
2370 Item
:= First
(Context_Items
(N
));
2371 while Present
(Item
) loop
2372 if Nkind
(Item
) = N_With_Clause
2374 -- Protect frontend against previous errors in context clauses
2376 and then Nkind
(Name
(Item
)) /= N_Selected_Component
2377 and then not Error_Posted
(Item
)
2379 Unit_Name
:= Entity
(Name
(Item
));
2381 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
2382 exit when Scope
(Unit_Name
) = Standard_Standard
;
2383 Unit_Name
:= Scope
(Unit_Name
);
2386 if Context_Installed
(Item
) then
2387 Set_Is_Immediately_Visible
(Unit_Name
, False);
2388 Set_Context_Installed
(Item
, False);
2394 end Analyze_Subunit_Context
;
2396 ------------------------
2397 -- Re_Install_Parents --
2398 ------------------------
2400 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
2404 if Nkind
(Unit
(L
)) = N_Subunit
then
2405 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
2408 Install_Context
(L
, False);
2410 -- If the subunit occurs within a child unit, we must restore the
2411 -- immediate visibility of any siblings that may occur in context.
2412 -- In addition, we must reset the previous visibility of the
2413 -- parent unit which is now on the scope stack. This is because
2414 -- the Previous_Visibility was previously set when removing the
2415 -- context. This is necessary to prevent the parent entity from
2416 -- remaining visible after the subunit is compiled. This only
2417 -- has an effect if a homonym exists in a body to be processed
2418 -- later if inlining is enabled.
2420 if Present
(Enclosing_Child
) then
2421 Install_Siblings
(Enclosing_Child
, L
);
2422 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
2428 if Scop
/= Par_Unit
then
2429 Set_Is_Immediately_Visible
(Scop
);
2432 -- Make entities in scope visible again. For child units, restore
2433 -- visibility only if they are actually in context.
2435 E
:= First_Entity
(Current_Scope
);
2436 while Present
(E
) loop
2437 if not Is_Child_Unit
(E
) or else Is_Visible_Lib_Unit
(E
) then
2438 Set_Is_Immediately_Visible
(E
);
2444 -- A subunit appears within a body, and for a nested subunits all the
2445 -- parents are bodies. Restore full visibility of their private
2448 if Is_Package_Or_Generic_Package
(Scop
) then
2449 Set_In_Package_Body
(Scop
);
2450 Install_Private_Declarations
(Scop
);
2452 end Re_Install_Parents
;
2454 ----------------------------
2455 -- Re_Install_Use_Clauses --
2456 ----------------------------
2458 procedure Re_Install_Use_Clauses
is
2461 for J
in reverse 1 .. Num_Scopes
loop
2462 U
:= Use_Clauses
(J
);
2463 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
2464 Install_Use_Clauses
(U
);
2466 end Re_Install_Use_Clauses
;
2472 procedure Remove_Scope
is
2476 Num_Scopes
:= Num_Scopes
+ 1;
2477 Use_Clauses
(Num_Scopes
) :=
2478 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
2480 E
:= First_Entity
(Current_Scope
);
2481 while Present
(E
) loop
2482 Set_Is_Immediately_Visible
(E
, False);
2486 if Is_Child_Unit
(Current_Scope
) then
2487 Enclosing_Child
:= Current_Scope
;
2493 Saved_SM
: SPARK_Mode_Type
:= SPARK_Mode
;
2494 Saved_SMP
: Node_Id
:= SPARK_Mode_Pragma
;
2495 -- Save the SPARK mode-related data to restore on exit. Removing
2496 -- enclosing scopes and contexts to provide a clean environment for the
2497 -- context of the subunit will eliminate any previously set SPARK_Mode.
2499 -- Start of processing for Analyze_Subunit
2502 -- For subunit in main extended unit, we reset the configuration values
2503 -- for the non-partition-wide restrictions. For other units reset them.
2505 if In_Extended_Main_Source_Unit
(N
) then
2506 Restore_Config_Cunit_Boolean_Restrictions
;
2508 Reset_Cunit_Boolean_Restrictions
;
2513 Nam
: Node_Id
:= Name
(Unit
(N
));
2516 if Nkind
(Nam
) = N_Selected_Component
then
2517 Nam
:= Selector_Name
(Nam
);
2520 Check_Identifier
(Nam
, Par_Unit
);
2524 if not Is_Empty_List
(Context_Items
(N
)) then
2526 -- Save current use clauses
2529 Remove_Context
(Lib_Unit
);
2531 -- Now remove parents and their context, including enclosing subunits
2532 -- and the outer parent body which is not a subunit.
2534 if Present
(Lib_Spec
) then
2535 Remove_Context
(Lib_Spec
);
2537 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
2538 Lib_Spec
:= Library_Unit
(Lib_Spec
);
2540 Remove_Context
(Lib_Spec
);
2543 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
2547 if Nkind
(Unit
(Lib_Spec
)) in N_Package_Body | N_Subprogram_Body
2549 Remove_Context
(Library_Unit
(Lib_Spec
));
2553 Set_Is_Immediately_Visible
(Par_Unit
, False);
2555 Analyze_Subunit_Context
;
2557 -- Take into account the effect of any SPARK_Mode configuration
2558 -- pragma, which takes precedence over a different value of
2559 -- SPARK_Mode inherited from the context of the stub.
2561 if SPARK_Mode
/= None
then
2562 Saved_SM
:= SPARK_Mode
;
2563 Saved_SMP
:= SPARK_Mode_Pragma
;
2566 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
2567 Set_Is_Immediately_Visible
(Par_Unit
);
2569 -- If the context includes a child unit of the parent of the subunit,
2570 -- the parent will have been removed from visibility, after compiling
2571 -- that cousin in the context. The visibility of the parent must be
2572 -- restored now. This also applies if the context includes another
2573 -- subunit of the same parent which in turn includes a child unit in
2576 if Is_Package_Or_Generic_Package
(Par_Unit
) then
2577 if not Is_Immediately_Visible
(Par_Unit
)
2578 or else (Present
(First_Entity
(Par_Unit
))
2580 Is_Immediately_Visible
(First_Entity
(Par_Unit
)))
2582 Set_Is_Immediately_Visible
(Par_Unit
);
2583 Install_Visible_Declarations
(Par_Unit
);
2584 Install_Private_Declarations
(Par_Unit
);
2588 Re_Install_Use_Clauses
;
2589 Install_Context
(N
, Chain
=> False);
2591 -- Restore state of suppress flags for current body
2593 Scope_Suppress
:= Svg
;
2595 -- If the subunit is within a child unit, then siblings of any parent
2596 -- unit that appear in the context clause of the subunit must also be
2597 -- made immediately visible.
2599 if Present
(Enclosing_Child
) then
2600 Install_Siblings
(Enclosing_Child
, N
);
2604 Generate_Parent_References
(Unit
(N
), Par_Unit
);
2606 -- Reinstall the SPARK_Mode which was in effect prior to any scope and
2607 -- context manipulations, taking into account a possible SPARK_Mode
2608 -- configuration pragma if present.
2610 Install_SPARK_Mode
(Saved_SM
, Saved_SMP
);
2612 -- If the subunit is part of a compilation unit which is subject to
2613 -- pragma Elaboration_Checks, set the model specified by the pragma
2614 -- because it applies to all parts of the unit.
2616 Install_Elaboration_Model
(Par_Unit
);
2618 -- The syntax rules require a proper body for a subprogram subunit
2620 if Nkind
(Proper_Body
(Sinfo
.Nodes
.Unit
(N
))) = N_Subprogram_Declaration
2622 if Null_Present
(Specification
(Proper_Body
(Sinfo
.Nodes
.Unit
(N
))))
2625 ("null procedure not allowed as subunit",
2626 Proper_Body
(Unit
(N
)));
2629 ("subprogram declaration not allowed as subunit",
2630 Defining_Unit_Name
(Specification
(Proper_Body
(Unit
(N
)))));
2634 Analyze
(Proper_Body
(Unit
(N
)));
2637 -- The subunit may contain a with_clause on a sibling of some ancestor.
2638 -- Removing the context will remove from visibility those ancestor child
2639 -- units, which must be restored to the visibility they have in the
2642 if Present
(Enclosing_Child
) then
2647 while Present
(C
) and then C
/= Standard_Standard
loop
2648 Set_Is_Immediately_Visible
(C
);
2649 Set_Is_Visible_Lib_Unit
(C
);
2655 -- Deal with restore of restrictions
2657 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
2658 end Analyze_Subunit
;
2660 ----------------------------
2661 -- Analyze_Task_Body_Stub --
2662 ----------------------------
2664 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
2665 Id
: constant Entity_Id
:= Defining_Entity
(N
);
2666 Loc
: constant Source_Ptr
:= Sloc
(N
);
2667 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Id
);
2670 Check_Stub_Level
(N
);
2672 -- First occurrence of name may have been as an incomplete type
2674 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2675 Nam
:= Full_View
(Nam
);
2678 if No
(Nam
) or else not Is_Task_Type
(Etype
(Nam
)) then
2679 Error_Msg_N
("missing specification for task body", N
);
2682 Set_Scope
(Id
, Current_Scope
);
2683 Mutate_Ekind
(Id
, E_Task_Body
);
2684 Set_Etype
(Id
, Standard_Void_Type
);
2686 if Has_Aspects
(N
) then
2687 Analyze_Aspect_Specifications
(N
, Id
);
2690 Generate_Reference
(Nam
, Id
, 'b');
2691 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
2693 -- Check for duplicate stub, if so give message and terminate
2695 if Has_Completion
(Etype
(Nam
)) then
2696 Error_Msg_N
("duplicate stub for task", N
);
2699 Set_Has_Completion
(Etype
(Nam
));
2702 Analyze_Proper_Body
(N
, Etype
(Nam
));
2704 -- Set elaboration flag to indicate that entity is callable. This
2705 -- cannot be done in the expansion of the body itself, because the
2706 -- proper body is not in a declarative part. This is only done if
2707 -- expansion is active, because the context may be generic and the
2708 -- flag not defined yet.
2710 if Expander_Active
then
2712 Make_Assignment_Statement
(Loc
,
2714 Make_Identifier
(Loc
,
2715 Chars
=> New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
2716 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
2719 end Analyze_Task_Body_Stub
;
2721 -------------------------
2722 -- Analyze_With_Clause --
2723 -------------------------
2725 -- Analyze the declaration of a unit in a with clause. At end, label the
2726 -- with clause with the defining entity for the unit.
2728 procedure Analyze_With_Clause
(N
: Node_Id
) is
2730 -- Retrieve the original kind of the unit node, before analysis. If it
2731 -- is a subprogram instantiation, its analysis below will rewrite the
2732 -- node as the declaration of the wrapper package. If the same
2733 -- instantiation appears indirectly elsewhere in the context, it will
2734 -- have been analyzed already.
2736 Unit_Kind
: constant Node_Kind
:=
2737 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
2738 Nam
: constant Node_Id
:= Name
(N
);
2740 Par_Name
: Entity_Id
;
2745 -- Set True if the unit currently being compiled is an internal unit
2747 Restriction_Violation
: Boolean := False;
2748 -- Set True if a with violates a restriction, no point in giving any
2749 -- warnings if we have this definite error.
2751 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2754 U
:= Unit
(Library_Unit
(N
));
2756 -- If this is an internal unit which is a renaming, then this is a
2757 -- violation of No_Obsolescent_Features.
2759 -- Note: this is not quite right if the user defines one of these units
2760 -- himself, but that's a marginal case, and fixing it is hard ???
2762 if Ada_Version
>= Ada_95
2763 and then In_Predefined_Renaming
(U
)
2765 if Restriction_Check_Required
(No_Obsolescent_Features
) then
2766 Check_Restriction
(No_Obsolescent_Features
, N
);
2767 Restriction_Violation
:= True;
2770 if Warn_On_Obsolescent_Feature
then
2772 ("renamed predefined unit is an obsolescent feature "
2773 & "(RM J.1)?j?", N
);
2777 -- Check No_Implementation_Units violation
2779 if Restriction_Check_Required
(No_Implementation_Units
) then
2780 if Not_Impl_Defined_Unit
(Get_Source_Unit
(U
)) then
2783 Check_Restriction
(No_Implementation_Units
, Nam
);
2784 Restriction_Violation
:= True;
2788 -- Several actions are skipped for dummy packages (those supplied for
2789 -- with's where no matching file could be found). Such packages are
2790 -- identified by the Sloc value being set to No_Location.
2792 if Limited_Present
(N
) then
2794 -- Ada 2005 (AI-50217): Build visibility structures but do not
2795 -- analyze the unit.
2797 -- If the designated unit is a predefined unit, which might be used
2798 -- implicitly through the rtsfind machinery, a limited with clause
2799 -- on such a unit is usually pointless, because run-time units are
2800 -- unlikely to appear in mutually dependent units, and because this
2801 -- disables the rtsfind mechanism. We transform such limited with
2802 -- clauses into regular with clauses.
2804 if Sloc
(U
) /= No_Location
then
2805 if In_Predefined_Unit
(U
) then
2806 Set_Limited_Present
(N
, False);
2807 Analyze_With_Clause
(N
);
2809 Build_Limited_Views
(N
);
2816 -- If we are compiling under "don't quit" mode (-gnatq) and we have
2817 -- already detected serious errors then we mark the with-clause nodes as
2818 -- analyzed before the corresponding compilation unit is analyzed. This
2819 -- is done here to protect the frontend against never ending recursion
2820 -- caused by circularities in the sources (because the previous errors
2821 -- may break the regular machine of the compiler implemented in
2822 -- Load_Unit to detect circularities).
2824 if Serious_Errors_Detected
> 0 and then Try_Semantics
then
2828 Semantics
(Library_Unit
(N
));
2830 Intunit
:= Is_Internal_Unit
(Current_Sem_Unit
);
2832 if Sloc
(U
) /= No_Location
then
2834 -- Check restrictions, except that we skip the check if this is an
2835 -- internal unit unless we are compiling the internal unit as the
2836 -- main unit. We also skip this for dummy packages.
2838 Check_Restriction_No_Dependence
(Nam
, N
);
2840 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
2841 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
2844 -- Deal with special case of GNAT.Current_Exceptions which interacts
2845 -- with the optimization of local raise statements into gotos.
2847 if Nkind
(Nam
) = N_Selected_Component
2848 and then Nkind
(Prefix
(Nam
)) = N_Identifier
2849 and then Chars
(Prefix
(Nam
)) = Name_Gnat
2850 and then Chars
(Selector_Name
(Nam
))
2851 in Name_Most_Recent_Exception | Name_Exception_Traces
2853 Check_Restriction
(No_Exception_Propagation
, N
);
2854 Special_Exception_Package_Used
:= True;
2857 -- Check for inappropriate with of internal implementation unit if we
2858 -- are not compiling an internal unit and also check for withing unit
2859 -- in wrong version of Ada. Do not issue these messages for implicit
2860 -- with's generated by the compiler itself.
2862 if Implementation_Unit_Warnings
2863 and then not Intunit
2864 and then not Implicit_With
(N
)
2865 and then not Restriction_Violation
2867 case Get_Kind_Of_Unit
(Get_Source_Unit
(U
)) is
2868 when Implementation_Unit
=>
2869 Error_Msg_F
("& is an internal 'G'N'A'T unit?i?", Name
(N
));
2871 -- Add alternative name if available, otherwise issue a
2872 -- general warning message.
2874 if Error_Msg_Strlen
/= 0 then
2875 Error_Msg_F
("\use ""~"" instead?i?", Name
(N
));
2878 ("\use of this unit is non-portable and "
2879 & "version-dependent?i?", Name
(N
));
2882 when Not_Predefined_Unit | Ada_95_Unit
=>
2883 null; -- no checks needed
2885 when Ada_2005_Unit
=>
2886 if Ada_Version
< Ada_2005
2887 and then Warn_On_Ada_2005_Compatibility
2889 Error_Msg_N
("& is an Ada 2005 unit?i?", Name
(N
));
2892 when Ada_2012_Unit
=>
2893 if Ada_Version
< Ada_2012
2894 and then Warn_On_Ada_2012_Compatibility
2896 Error_Msg_N
("& is an Ada 2012 unit?i?", Name
(N
));
2899 when Ada_2022_Unit
=>
2900 if Ada_Version
< Ada_2022
2901 and then Warn_On_Ada_2022_Compatibility
2903 Error_Msg_N
("& is an Ada 2022 unit?i?", Name
(N
));
2909 -- Semantic analysis of a generic unit is performed on a copy of
2910 -- the original tree. Retrieve the entity on which semantic info
2911 -- actually appears.
2913 if Unit_Kind
in N_Generic_Declaration
then
2914 E_Name
:= Defining_Entity
(U
);
2916 -- Note: in the following test, Unit_Kind is the original Nkind, but in
2917 -- the case of an instantiation, semantic analysis above will have
2918 -- replaced the unit by its instantiated version. If the instance body
2919 -- has been generated, the instance now denotes the body entity. For
2920 -- visibility purposes we need the entity of its spec.
2922 elsif (Unit_Kind
= N_Package_Instantiation
2923 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
2924 N_Package_Instantiation
)
2925 and then Nkind
(U
) = N_Package_Body
2927 E_Name
:= Corresponding_Spec
(U
);
2929 elsif Unit_Kind
= N_Package_Instantiation
2930 and then Nkind
(U
) = N_Package_Instantiation
2931 and then Present
(Instance_Spec
(U
))
2933 -- If the instance has not been rewritten as a package declaration,
2934 -- then it appeared already in a previous with clause. Retrieve
2935 -- the entity from the previous instance.
2937 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
2939 elsif Unit_Kind
in N_Subprogram_Instantiation
then
2941 -- The visible subprogram is created during instantiation, and is
2942 -- an attribute of the wrapper package. We retrieve the wrapper
2943 -- package directly from the instantiation node. If the instance
2944 -- is inlined the unit is still an instantiation. Otherwise it has
2945 -- been rewritten as the declaration of the wrapper itself.
2947 if Nkind
(U
) in N_Subprogram_Instantiation
then
2950 (Defining_Entity
(Specification
(Instance_Spec
(U
))));
2952 E_Name
:= Related_Instance
(Defining_Entity
(U
));
2955 elsif Unit_Kind
= N_Package_Renaming_Declaration
2956 or else Unit_Kind
in N_Generic_Renaming_Declaration
2958 E_Name
:= Defining_Entity
(U
);
2960 elsif Unit_Kind
= N_Subprogram_Body
2961 and then Nkind
(Name
(N
)) = N_Selected_Component
2962 and then not Acts_As_Spec
(Library_Unit
(N
))
2964 -- For a child unit that has no spec, one has been created and
2965 -- analyzed. The entity required is that of the spec.
2967 E_Name
:= Corresponding_Spec
(U
);
2970 E_Name
:= Defining_Entity
(U
);
2973 if Nkind
(Name
(N
)) = N_Selected_Component
then
2975 -- Child unit in a with clause
2977 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
2979 -- If this is a child unit without a spec, and it has been analyzed
2980 -- already, a declaration has been created for it. The with_clause
2981 -- must reflect the actual body, and not the generated declaration,
2982 -- to prevent spurious binding errors involving an out-of-date spec.
2983 -- Note that this can only happen if the unit includes more than one
2984 -- with_clause for the child unit (e.g. in separate subunits).
2986 if Unit_Kind
= N_Subprogram_Declaration
2987 and then Analyzed
(Library_Unit
(N
))
2988 and then not Comes_From_Source
(Library_Unit
(N
))
2990 Set_Library_Unit
(N
,
2991 Cunit
(Get_Source_Unit
(Corresponding_Body
(U
))));
2995 -- Restore style checks
2997 Style_Check
:= Save_Style_Check
;
2999 -- Record the reference, but do NOT set the unit as referenced, we want
3000 -- to consider the unit as unreferenced if this is the only reference
3003 Set_Entity_With_Checks
(Name
(N
), E_Name
);
3004 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
3006 -- Generate references and check No_Dependence restriction for parents
3008 if Is_Child_Unit
(E_Name
) then
3009 Pref
:= Prefix
(Name
(N
));
3010 Par_Name
:= Scope
(E_Name
);
3011 while Nkind
(Pref
) = N_Selected_Component
loop
3012 Change_Selected_Component_To_Expanded_Name
(Pref
);
3014 if Present
(Entity
(Selector_Name
(Pref
)))
3016 Present
(Renamed_Entity
(Entity
(Selector_Name
(Pref
))))
3017 and then Entity
(Selector_Name
(Pref
)) /= Par_Name
3019 -- The prefix is a child unit that denotes a renaming declaration.
3020 -- Replace the prefix directly with the renamed unit, because the
3021 -- rest of the prefix is irrelevant to the visibility of the real
3024 Rewrite
(Pref
, New_Occurrence_Of
(Par_Name
, Sloc
(Pref
)));
3028 Set_Entity_With_Checks
(Pref
, Par_Name
);
3030 Generate_Reference
(Par_Name
, Pref
);
3031 Check_Restriction_No_Dependence
(Pref
, N
);
3032 Pref
:= Prefix
(Pref
);
3034 -- If E_Name is the dummy entity for a nonexistent unit, its scope
3035 -- is set to Standard_Standard, and no attempt should be made to
3036 -- further unwind scopes.
3038 if Par_Name
/= Standard_Standard
then
3039 Par_Name
:= Scope
(Par_Name
);
3042 -- Abandon processing in case of previous errors
3044 if No
(Par_Name
) then
3045 Check_Error_Detected
;
3050 if Present
(Entity
(Pref
))
3051 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
3053 -- If the entity is set without its unit being compiled, the
3054 -- original parent is a renaming, and Par_Name is the renamed
3055 -- entity. For visibility purposes, we need the original entity,
3056 -- which must be analyzed now because Load_Unit directly retrieves
3057 -- the renamed unit, and the renaming declaration itself has not
3060 Analyze
(Parent
(Parent
(Entity
(Pref
))));
3061 pragma Assert
(Renamed_Entity
(Entity
(Pref
)) = Par_Name
);
3062 Par_Name
:= Entity
(Pref
);
3065 -- Guard against missing or misspelled child units
3067 if Present
(Par_Name
) then
3068 Set_Entity_With_Checks
(Pref
, Par_Name
);
3069 Generate_Reference
(Par_Name
, Pref
);
3072 pragma Assert
(Serious_Errors_Detected
/= 0);
3074 -- Mark the node to indicate that a related error has been posted.
3075 -- This defends further compilation passes against improper use of
3076 -- the invalid WITH clause node.
3078 Set_Error_Posted
(N
);
3079 Set_Name
(N
, Error
);
3084 -- If the withed unit is System, and a system extension pragma is
3085 -- present, compile the extension now, rather than waiting for a
3086 -- visibility check on a specific entity.
3088 if Chars
(E_Name
) = Name_System
3089 and then Scope
(E_Name
) = Standard_Standard
3090 and then Present
(System_Extend_Unit
)
3091 and then Present_System_Aux
(N
)
3093 -- If the extension is not present, an error will have been emitted
3098 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
3099 -- to private_with units; they will be made visible later (just before
3100 -- the private part is analyzed)
3102 if Private_Present
(N
) then
3103 Set_Is_Immediately_Visible
(E_Name
, False);
3106 -- Propagate Fatal_Error setting from with'ed unit to current unit
3108 case Fatal_Error
(Get_Source_Unit
(Library_Unit
(N
))) is
3110 -- Nothing to do if with'ed unit had no error
3115 -- If with'ed unit had a detected fatal error, propagate it
3117 when Error_Detected
=>
3118 Set_Fatal_Error
(Current_Sem_Unit
, Error_Detected
);
3120 -- If with'ed unit had an ignored error, then propagate it but do not
3121 -- overide an existring setting.
3123 when Error_Ignored
=>
3124 if Fatal_Error
(Current_Sem_Unit
) = None
then
3125 Set_Fatal_Error
(Current_Sem_Unit
, Error_Ignored
);
3128 end Analyze_With_Clause
;
3130 ------------------------------
3131 -- Check_Private_Child_Unit --
3132 ------------------------------
3134 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
3135 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3137 Curr_Unit
: Entity_Id
;
3138 Sub_Parent
: Node_Id
;
3139 Priv_Child
: Entity_Id
;
3140 Par_Lib
: Entity_Id
;
3144 if Nkind
(Lib_Unit
) in N_Package_Body | N_Subprogram_Body
then
3145 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
3146 Par_Lib
:= Curr_Unit
;
3148 elsif Nkind
(Lib_Unit
) = N_Subunit
then
3150 -- The parent is itself a body. The parent entity is to be found in
3151 -- the corresponding spec.
3153 Sub_Parent
:= Library_Unit
(N
);
3154 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
3156 -- If the parent itself is a subunit, Curr_Unit is the entity of the
3157 -- enclosing body, retrieve the spec entity which is the proper
3158 -- ancestor we need for the following tests.
3160 if Ekind
(Curr_Unit
) = E_Package_Body
then
3161 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
3164 Par_Lib
:= Curr_Unit
;
3167 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
3169 Par_Lib
:= Curr_Unit
;
3170 Par_Spec
:= Parent_Spec
(Lib_Unit
);
3172 if No
(Par_Spec
) then
3175 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
3179 -- Loop through context items
3181 Item
:= First
(Context_Items
(N
));
3182 while Present
(Item
) loop
3184 -- Ada 2005 (AI-262): Allow private_with of a private child package
3185 -- in public siblings
3187 if Nkind
(Item
) = N_With_Clause
3188 and then not Implicit_With
(Item
)
3189 and then not Limited_Present
(Item
)
3190 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
3192 Priv_Child
:= Entity
(Name
(Item
));
3195 Curr_Parent
: Entity_Id
:= Par_Lib
;
3196 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
3197 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
3198 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
3201 -- If the child unit is a public child then locate the nearest
3202 -- private ancestor. Child_Parent will then be set to the
3203 -- parent of that ancestor.
3205 if not Is_Private_Library_Unit
(Priv_Child
) then
3206 while Present
(Prv_Ancestor
)
3207 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
3209 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
3212 if Present
(Prv_Ancestor
) then
3213 Child_Parent
:= Scope
(Prv_Ancestor
);
3217 while Present
(Curr_Parent
)
3218 and then Curr_Parent
/= Standard_Standard
3219 and then Curr_Parent
/= Child_Parent
3222 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
3223 Curr_Parent
:= Scope
(Curr_Parent
);
3226 if No
(Curr_Parent
) then
3227 Curr_Parent
:= Standard_Standard
;
3230 if Curr_Parent
/= Child_Parent
then
3231 if Ekind
(Priv_Child
) = E_Generic_Package
3232 and then Chars
(Priv_Child
) in Text_IO_Package_Name
3233 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
3234 and then Scope
(Scope
(Scope
(Priv_Child
))) =
3238 ("& is a nested package, not a compilation unit",
3239 Name
(Item
), Priv_Child
);
3243 ("unit in with clause is private child unit!", Item
);
3245 ("\current unit must also have parent&!",
3246 Item
, Child_Parent
);
3250 or else Private_Present
(Item
)
3251 or else Nkind
(Lib_Unit
) in N_Package_Body | N_Subunit
3252 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3253 and then not Acts_As_Spec
(Parent
(Lib_Unit
)))
3259 ("current unit must also be private descendant of&",
3260 Item
, Child_Parent
);
3267 end Check_Private_Child_Unit
;
3269 ----------------------
3270 -- Check_Stub_Level --
3271 ----------------------
3273 procedure Check_Stub_Level
(N
: Node_Id
) is
3274 Par
: constant Node_Id
:= Parent
(N
);
3275 Kind
: constant Node_Kind
:= Nkind
(Par
);
3279 N_Package_Body | N_Subprogram_Body | N_Task_Body | N_Protected_Body
3280 and then Nkind
(Parent
(Par
)) in N_Compilation_Unit | N_Subunit
3284 -- In an instance, a missing stub appears at any level. A warning
3285 -- message will have been emitted already for the missing file.
3287 elsif not In_Instance
then
3288 Error_Msg_N
("stub cannot appear in an inner scope", N
);
3290 elsif Expander_Active
then
3291 Error_Msg_N
("missing proper body", N
);
3293 end Check_Stub_Level
;
3299 procedure Decorate_Type
3302 Is_Tagged
: Boolean := False;
3303 Materialize
: Boolean := False)
3308 -- An unanalyzed type or a shadow entity of a type is treated as an
3309 -- incomplete type, and carries the corresponding attributes.
3311 Mutate_Ekind
(Ent
, E_Incomplete_Type
);
3312 Set_Is_Not_Self_Hidden
(Ent
);
3313 Set_Etype
(Ent
, Ent
);
3314 Set_Full_View
(Ent
, Empty
);
3315 Set_Is_First_Subtype
(Ent
);
3316 Set_Scope
(Ent
, Scop
);
3317 Set_Stored_Constraint
(Ent
, No_Elist
);
3318 Reinit_Size_Align
(Ent
);
3320 if From_Limited_With
(Ent
) then
3321 Set_Private_Dependents
(Ent
, New_Elmt_List
);
3324 -- A tagged type and its corresponding shadow entity share one common
3325 -- class-wide type. The list of primitive operations for the shadow
3329 Set_Is_Tagged_Type
(Ent
);
3330 Set_Direct_Primitive_Operations
(Ent
, New_Elmt_List
);
3334 (E_Void
, Scope
(Ent
), Sloc
(Ent
), Ent
, 'C', 0, 'T');
3336 Set_Class_Wide_Type
(Ent
, CW_Typ
);
3338 -- Set parent to be the same as the parent of the tagged type.
3339 -- We need a parent field set, and it is supposed to point to
3340 -- the declaration of the type. The tagged type declaration
3341 -- essentially declares two separate types, the tagged type
3342 -- itself and the corresponding class-wide type, so it is
3343 -- reasonable for the parent fields to point to the declaration
3346 Set_Parent
(CW_Typ
, Parent
(Ent
));
3348 Mutate_Ekind
(CW_Typ
, E_Class_Wide_Type
);
3349 Set_Class_Wide_Type
(CW_Typ
, CW_Typ
);
3350 Set_Etype
(CW_Typ
, Ent
);
3351 Set_Equivalent_Type
(CW_Typ
, Empty
);
3352 Set_From_Limited_With
(CW_Typ
, From_Limited_With
(Ent
));
3353 Set_Has_Unknown_Discriminants
(CW_Typ
);
3354 Set_Is_First_Subtype
(CW_Typ
);
3355 Set_Is_Tagged_Type
(CW_Typ
);
3356 Set_Materialize_Entity
(CW_Typ
, Materialize
);
3357 Set_Scope
(CW_Typ
, Scop
);
3358 Reinit_Size_Align
(CW_Typ
);
3362 ------------------------
3363 -- Expand_With_Clause --
3364 ------------------------
3366 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
) is
3367 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
3369 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
3370 -- Build name to be used in implicit with_clause. In most cases this
3371 -- is the source name, but if renamings are present we must make the
3372 -- original unit visible, not the one it renames. The entity in the
3373 -- with clause is the renamed unit, but the identifier is the one from
3374 -- the source, which allows us to recover the unit renaming.
3376 ---------------------
3377 -- Build_Unit_Name --
3378 ---------------------
3380 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
3385 if Nkind
(Nam
) = N_Identifier
then
3386 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
3389 Ent
:= Entity
(Nam
);
3391 if Present
(Entity
(Selector_Name
(Nam
)))
3392 and then Chars
(Entity
(Selector_Name
(Nam
))) /= Chars
(Ent
)
3394 Nkind
(Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))) =
3395 N_Package_Renaming_Declaration
3397 -- The name in the with_clause is of the form A.B.C, and B is
3398 -- given by a renaming declaration. In that case we may not
3399 -- have analyzed the unit for B, but replaced it directly in
3400 -- lib-load with the unit it renames. We have to make A.B
3401 -- visible, so analyze the declaration for B now, in case it
3402 -- has not been done yet.
3404 Ent
:= Entity
(Selector_Name
(Nam
));
3407 (Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))));
3411 Make_Expanded_Name
(Loc
,
3412 Chars
=> Chars
(Entity
(Nam
)),
3413 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
3414 Selector_Name
=> New_Occurrence_Of
(Ent
, Loc
));
3415 Set_Entity
(Result
, Ent
);
3419 end Build_Unit_Name
;
3423 Ent
: constant Entity_Id
:= Entity
(Nam
);
3426 -- Start of processing for Expand_With_Clause
3430 Make_With_Clause
(Loc
,
3431 Name
=> Build_Unit_Name
(Nam
));
3433 Set_Corresponding_Spec
(Withn
, Ent
);
3434 Set_First_Name
(Withn
);
3435 Set_Implicit_With
(Withn
);
3436 Set_Library_Unit
(Withn
, Parent
(Unit_Declaration_Node
(Ent
)));
3437 Set_Parent_With
(Withn
);
3439 -- If the unit is a [generic] package or subprogram declaration
3440 -- (including a subprogram body acting as spec), a private_with_clause
3441 -- on a child unit implies that the implicit with on the parent is also
3444 if Nkind
(Unit
(N
)) in N_Generic_Package_Declaration
3445 | N_Package_Declaration
3446 | N_Generic_Subprogram_Declaration
3447 | N_Subprogram_Declaration
3450 Set_Private_Present
(Withn
, Private_Present
(Item
));
3453 Prepend
(Withn
, Context_Items
(N
));
3454 Mark_Rewrite_Insertion
(Withn
);
3456 Install_With_Clause
(Withn
);
3458 -- If we have "with X.Y;", we want to recurse on "X", except in the
3459 -- unusual case where X.Y is a renaming of X. In that case, the scope
3460 -- of X will be null.
3462 if Nkind
(Nam
) = N_Expanded_Name
3463 and then Present
(Scope
(Entity
(Prefix
(Nam
))))
3465 Expand_With_Clause
(Item
, Prefix
(Nam
), N
);
3467 end Expand_With_Clause
;
3469 --------------------------------
3470 -- Generate_Parent_References --
3471 --------------------------------
3473 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
3475 P_Name
: Entity_Id
:= P_Id
;
3478 if Nkind
(N
) = N_Subunit
then
3481 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
3484 if Nkind
(Pref
) = N_Expanded_Name
then
3486 -- Done already, if the unit has been compiled indirectly as
3487 -- part of the closure of its context because of inlining.
3492 while Nkind
(Pref
) = N_Selected_Component
loop
3493 Change_Selected_Component_To_Expanded_Name
(Pref
);
3494 Set_Entity
(Pref
, P_Name
);
3495 Set_Etype
(Pref
, Etype
(P_Name
));
3496 Generate_Reference
(P_Name
, Pref
, 'r');
3497 Pref
:= Prefix
(Pref
);
3498 P_Name
:= Scope
(P_Name
);
3501 -- The guard here on P_Name is to handle the error condition where
3502 -- the parent unit is missing because the file was not found.
3504 if Present
(P_Name
) then
3505 Set_Entity
(Pref
, P_Name
);
3506 Set_Etype
(Pref
, Etype
(P_Name
));
3507 Generate_Reference
(P_Name
, Pref
, 'r');
3508 Style
.Check_Identifier
(Pref
, P_Name
);
3510 end Generate_Parent_References
;
3512 ---------------------
3513 -- Has_With_Clause --
3514 ---------------------
3516 function Has_With_Clause
3519 Is_Limited
: Boolean := False) return Boolean
3523 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
;
3524 -- Return the entity for the unit named in a [limited] with clause
3530 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
is
3532 if Nkind
(Name
(Clause
)) = N_Selected_Component
then
3533 return Entity
(Selector_Name
(Name
(Clause
)));
3535 return Entity
(Name
(Clause
));
3539 -- Start of processing for Has_With_Clause
3542 Item
:= First
(Context_Items
(C_Unit
));
3543 while Present
(Item
) loop
3544 if Nkind
(Item
) = N_With_Clause
3545 and then Limited_Present
(Item
) = Is_Limited
3546 and then Named_Unit
(Item
) = Pack
3555 end Has_With_Clause
;
3557 -----------------------------
3558 -- Implicit_With_On_Parent --
3559 -----------------------------
3561 procedure Implicit_With_On_Parent
3562 (Child_Unit
: Node_Id
;
3565 Loc
: constant Source_Ptr
:= Sloc
(N
);
3566 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
3567 P_Unit
: Node_Id
:= Unit
(P
);
3568 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
3571 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
3572 -- Build prefix of child unit name. Recurse if needed
3574 function Build_Unit_Name
return Node_Id
;
3575 -- If the unit is a child unit, build qualified name with all ancestors
3577 -------------------------
3578 -- Build_Ancestor_Name --
3579 -------------------------
3581 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
3582 P_Ref
: constant Node_Id
:=
3583 New_Occurrence_Of
(Defining_Entity
(P
), Loc
);
3584 P_Spec
: Node_Id
:= P
;
3587 -- Ancestor may have been rewritten as a package body. Retrieve the
3588 -- original spec to trace earlier ancestors.
3590 if Nkind
(P
) = N_Package_Body
3591 and then Nkind
(Original_Node
(P
)) = N_Package_Instantiation
3593 P_Spec
:= Original_Node
(P
);
3596 if No
(Parent_Spec
(P_Spec
)) then
3600 Make_Selected_Component
(Loc
,
3602 Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Spec
))),
3603 Selector_Name
=> P_Ref
);
3605 end Build_Ancestor_Name
;
3607 ---------------------
3608 -- Build_Unit_Name --
3609 ---------------------
3611 function Build_Unit_Name
return Node_Id
is
3615 if No
(Parent_Spec
(P_Unit
)) then
3616 return New_Occurrence_Of
(P_Name
, Loc
);
3620 Make_Expanded_Name
(Loc
,
3621 Chars
=> Chars
(P_Name
),
3623 Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
3624 Selector_Name
=> New_Occurrence_Of
(P_Name
, Loc
));
3625 Set_Entity
(Result
, P_Name
);
3629 end Build_Unit_Name
;
3631 -- Start of processing for Implicit_With_On_Parent
3634 -- The unit of the current compilation may be a package body that
3635 -- replaces an instance node. In this case we need the original instance
3636 -- node to construct the proper parent name.
3638 if Nkind
(P_Unit
) = N_Package_Body
3639 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
3641 P_Unit
:= Original_Node
(P_Unit
);
3644 -- We add the implicit with if the child unit is the current unit being
3645 -- compiled. If the current unit is a body, we do not want to add an
3646 -- implicit_with a second time to the corresponding spec.
3648 if Nkind
(Child_Unit
) = N_Package_Declaration
3649 and then Child_Unit
/= Unit
(Cunit
(Current_Sem_Unit
))
3654 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
3656 Set_Corresponding_Spec
(Withn
, P_Name
);
3657 Set_First_Name
(Withn
);
3658 Set_Implicit_With
(Withn
);
3659 Set_Library_Unit
(Withn
, P
);
3660 Set_Parent_With
(Withn
);
3662 -- Node is placed at the beginning of the context items, so that
3663 -- subsequent use clauses on the parent can be validated.
3665 Prepend
(Withn
, Context_Items
(N
));
3666 Mark_Rewrite_Insertion
(Withn
);
3668 Install_With_Clause
(Withn
);
3670 if Is_Child_Spec
(P_Unit
) then
3671 Implicit_With_On_Parent
(P_Unit
, N
);
3673 end Implicit_With_On_Parent
;
3679 function In_Chain
(E
: Entity_Id
) return Boolean is
3683 H
:= Current_Entity
(E
);
3684 while Present
(H
) loop
3695 ---------------------
3696 -- Install_Context --
3697 ---------------------
3699 procedure Install_Context
(N
: Node_Id
; Chain
: Boolean := True) is
3700 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3703 Install_Context_Clauses
(N
, Chain
);
3705 if Is_Child_Spec
(Lib_Unit
) then
3707 (Lib_Unit
=> Lib_Unit
,
3708 Is_Private
=> Private_Present
(Parent
(Lib_Unit
)),
3712 Install_Limited_Context_Clauses
(N
);
3713 end Install_Context
;
3715 -----------------------------
3716 -- Install_Context_Clauses --
3717 -----------------------------
3719 procedure Install_Context_Clauses
(N
: Node_Id
; Chain
: Boolean := True) is
3720 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3722 Uname_Node
: Entity_Id
;
3723 Check_Private
: Boolean := False;
3724 Decl_Node
: Node_Id
;
3725 Lib_Parent
: Entity_Id
;
3728 -- First skip configuration pragmas at the start of the context. They
3729 -- are not technically part of the context clause, but that's where the
3730 -- parser puts them. Note they were analyzed in Analyze_Context.
3732 Item
:= First
(Context_Items
(N
));
3733 while Present
(Item
)
3734 and then Nkind
(Item
) = N_Pragma
3735 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
3740 -- Loop through the actual context clause items. We process everything
3741 -- except Limited_With clauses in this routine. Limited_With clauses
3742 -- are separately installed (see Install_Limited_Context_Clauses).
3744 while Present
(Item
) loop
3746 -- Case of explicit WITH clause
3748 if Nkind
(Item
) = N_With_Clause
3749 and then not Implicit_With
(Item
)
3751 if Limited_Present
(Item
) then
3753 -- Limited withed units will be installed later
3757 -- If Name (Item) is not an entity name, something is wrong, and
3758 -- this will be detected in due course, for now ignore the item
3760 elsif not Is_Entity_Name
(Name
(Item
)) then
3763 elsif No
(Entity
(Name
(Item
))) then
3764 Set_Entity
(Name
(Item
), Any_Id
);
3768 Uname_Node
:= Entity
(Name
(Item
));
3770 if Is_Private_Descendant
(Uname_Node
) then
3771 Check_Private
:= True;
3774 Install_With_Clause
(Item
);
3776 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
3778 -- If the unit is a subprogram instance, it appears nested within
3779 -- a package that carries the parent information.
3781 if Is_Generic_Instance
(Uname_Node
)
3782 and then Ekind
(Uname_Node
) /= E_Package
3784 Decl_Node
:= Parent
(Parent
(Decl_Node
));
3787 if Is_Child_Spec
(Decl_Node
) then
3788 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
3789 Expand_With_Clause
(Item
, Prefix
(Name
(Item
)), N
);
3791 -- If not an expanded name, the child unit must be a
3792 -- renaming, nothing to do.
3797 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
3798 and then not Acts_As_Spec
(Parent
(Decl_Node
))
3799 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
3801 Implicit_With_On_Parent
3802 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
3805 -- Check license conditions unless this is a dummy unit
3807 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
3808 License_Check
: declare
3809 Withu
: constant Unit_Number_Type
:=
3810 Get_Source_Unit
(Library_Unit
(Item
));
3811 Withl
: constant License_Type
:=
3812 License
(Source_Index
(Withu
));
3813 Unitl
: constant License_Type
:=
3814 License
(Source_Index
(Current_Sem_Unit
));
3816 procedure License_Error
;
3817 -- Signal error of bad license
3823 procedure License_Error
is
3826 ("license of withed unit & may be inconsistent??",
3830 -- Start of processing for License_Check
3833 -- Exclude license check if withed unit is an internal unit.
3834 -- This situation arises e.g. with the GPL version of GNAT.
3836 if Is_Internal_Unit
(Withu
) then
3839 -- Otherwise check various cases
3851 if Withl
= Restricted
then
3855 when Modified_GPL
=>
3856 if Withl
= Restricted
or else Withl
= GPL
then
3860 when Unrestricted
=>
3867 -- Case of USE PACKAGE clause
3869 elsif Nkind
(Item
) = N_Use_Package_Clause
then
3870 Analyze_Use_Package
(Item
, Chain
);
3872 -- Case of USE TYPE clause
3874 elsif Nkind
(Item
) = N_Use_Type_Clause
then
3875 Analyze_Use_Type
(Item
, Chain
);
3879 elsif Nkind
(Item
) = N_Pragma
then
3887 if Is_Child_Spec
(Lib_Unit
) then
3889 -- The unit also has implicit with_clauses on its own parents
3891 if No
(Context_Items
(N
)) then
3892 Set_Context_Items
(N
, New_List
);
3895 Implicit_With_On_Parent
(Lib_Unit
, N
);
3898 -- If the unit is a body, the context of the specification must also
3899 -- be installed. That includes private with_clauses in that context.
3901 if Nkind
(Lib_Unit
) = N_Package_Body
3902 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3903 and then not Acts_As_Spec
(N
))
3905 Install_Context
(Library_Unit
(N
), Chain
);
3907 -- Only install private with-clauses of a spec that comes from
3908 -- source, excluding specs created for a subprogram body that is
3911 if Comes_From_Source
(Library_Unit
(N
)) then
3912 Install_Private_With_Clauses
3913 (Defining_Entity
(Unit
(Library_Unit
(N
))));
3916 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
3918 -- If the unit is the body of a public child unit, the private
3919 -- declarations of the parent must be made visible. If the child
3920 -- unit is private, the private declarations have been installed
3921 -- already in the call to Install_Parents for the spec. Installing
3922 -- private declarations must be done for all ancestors of public
3923 -- child units. In addition, sibling units mentioned in the
3924 -- context clause of the body are directly visible.
3932 Lib_Spec
:= Unit
(Library_Unit
(N
));
3933 while Is_Child_Spec
(Lib_Spec
) loop
3934 P
:= Unit
(Parent_Spec
(Lib_Spec
));
3935 P_Name
:= Defining_Entity
(P
);
3937 if not (Private_Present
(Parent
(Lib_Spec
)))
3938 and then not In_Private_Part
(P_Name
)
3940 Install_Private_Declarations
(P_Name
);
3941 Install_Private_With_Clauses
(P_Name
);
3942 Set_Use
(Private_Declarations
(Specification
(P
)));
3950 -- For a package body, children in context are immediately visible
3952 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
3955 if Nkind
(Lib_Unit
) in N_Generic_Package_Declaration
3956 | N_Generic_Subprogram_Declaration
3957 | N_Package_Declaration
3958 | N_Subprogram_Declaration
3960 if Is_Child_Spec
(Lib_Unit
) then
3961 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
3962 Set_Is_Private_Descendant
3963 (Defining_Entity
(Lib_Unit
),
3964 Is_Private_Descendant
(Lib_Parent
)
3965 or else Private_Present
(Parent
(Lib_Unit
)));
3968 Set_Is_Private_Descendant
3969 (Defining_Entity
(Lib_Unit
),
3970 Private_Present
(Parent
(Lib_Unit
)));
3974 if Check_Private
then
3975 Check_Private_Child_Unit
(N
);
3977 end Install_Context_Clauses
;
3979 -------------------------------------
3980 -- Install_Limited_Context_Clauses --
3981 -------------------------------------
3983 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
3986 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
);
3987 -- Check that the unlimited view of a given compilation_unit is not
3988 -- already visible through "use + renamings".
3990 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
);
3991 -- Check that if a limited_with clause of a given compilation_unit
3992 -- mentions a descendant of a private child of some library unit, then
3993 -- the given compilation_unit must be the declaration of a private
3994 -- descendant of that library unit, or a public descendant of such. The
3995 -- code is analogous to that of Check_Private_Child_Unit but we cannot
3996 -- use entities on the limited with_clauses because their units have not
3997 -- been analyzed, so we have to climb the tree of ancestors looking for
3998 -- private keywords.
4000 procedure Expand_Limited_With_Clause
4001 (Comp_Unit
: Node_Id
;
4004 -- If a child unit appears in a limited_with clause, there are implicit
4005 -- limited_with clauses on all parents that are not already visible
4006 -- through a regular with clause. This procedure creates the implicit
4007 -- limited with_clauses for the parents and loads the corresponding
4008 -- units. The shadow entities are created when the inserted clause is
4009 -- analyzed. Implements Ada 2005 (AI-50217).
4011 ---------------------
4012 -- Check_Renamings --
4013 ---------------------
4015 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
) is
4023 pragma Assert
(Nkind
(W
) = N_With_Clause
);
4025 -- Protect the frontend against previous critical errors
4027 case Nkind
(Unit
(Library_Unit
(W
))) is
4028 when N_Generic_Package_Declaration
4029 | N_Generic_Subprogram_Declaration
4030 | N_Package_Declaration
4031 | N_Subprogram_Declaration
4039 -- Check "use + renamings"
4041 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
4042 Spec
:= Specification
(Unit
(P
));
4044 Item
:= First
(Visible_Declarations
(Spec
));
4045 while Present
(Item
) loop
4047 -- Look only at use package clauses
4049 if Nkind
(Item
) = N_Use_Package_Clause
then
4051 E
:= Entity
(Name
(Item
));
4053 pragma Assert
(Present
(Parent
(E
)));
4055 if Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
4056 and then Renamed_Entity
(E
) = WEnt
4058 -- The unlimited view is visible through use clause and
4059 -- renamings. There is no need to generate the error
4060 -- message here because Is_Visible_Through_Renamings
4061 -- takes care of generating the precise error message.
4065 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
4067 -- The use clause may refer to a local package.
4068 -- Check all the enclosing scopes.
4071 while E2
/= Standard_Standard
and then E2
/= WEnt
loop
4077 ("unlimited view visible through use clause", W
);
4086 -- Recursive call to check all the ancestors
4088 if Is_Child_Spec
(Unit
(P
)) then
4089 Check_Renamings
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
4091 end Check_Renamings
;
4093 ---------------------------------------
4094 -- Check_Private_Limited_Withed_Unit --
4095 ---------------------------------------
4097 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
) is
4098 Curr_Parent
: Node_Id
;
4099 Child_Parent
: Node_Id
;
4100 Curr_Private
: Boolean;
4103 -- Compilation unit of the parent of the withed library unit
4105 Child_Parent
:= Library_Unit
(Item
);
4107 -- If the child unit is a public child, then locate its nearest
4108 -- private ancestor, if any, then Child_Parent will then be set to
4109 -- the parent of that ancestor.
4111 if not Private_Present
(Library_Unit
(Item
)) then
4112 while Present
(Child_Parent
)
4113 and then not Private_Present
(Child_Parent
)
4115 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
4118 if No
(Child_Parent
) then
4123 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
4125 -- Traverse all the ancestors of the current compilation unit to
4126 -- check if it is a descendant of named library unit.
4128 Curr_Parent
:= Parent
(Item
);
4129 Curr_Private
:= Private_Present
(Curr_Parent
);
4131 while Present
(Parent_Spec
(Unit
(Curr_Parent
)))
4132 and then Curr_Parent
/= Child_Parent
4134 Curr_Parent
:= Parent_Spec
(Unit
(Curr_Parent
));
4135 Curr_Private
:= Curr_Private
or else Private_Present
(Curr_Parent
);
4138 if Curr_Parent
/= Child_Parent
then
4140 ("unit in with clause is private child unit!", Item
);
4142 ("\current unit must also have parent&!",
4143 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
4145 elsif Private_Present
(Parent
(Item
))
4146 or else Curr_Private
4147 or else Private_Present
(Item
)
4148 or else Nkind
(Unit
(Parent
(Item
))) in
4149 N_Package_Body | N_Subprogram_Body | N_Subunit
4151 -- Current unit is private, of descendant of a private unit
4157 ("current unit must also be private descendant of&",
4158 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
4160 end Check_Private_Limited_Withed_Unit
;
4162 --------------------------------
4163 -- Expand_Limited_With_Clause --
4164 --------------------------------
4166 procedure Expand_Limited_With_Clause
4167 (Comp_Unit
: Node_Id
;
4171 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
4172 Unum
: Unit_Number_Type
;
4175 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean;
4176 -- Returns true if the context already includes a with_clause for
4177 -- this unit. If the with_clause is nonlimited, the unit is fully
4178 -- visible and an implicit limited_with should not be created. If
4179 -- there is already a limited_with clause for W, a second one is
4180 -- simply redundant.
4182 --------------------------
4183 -- Previous_Withed_Unit --
4184 --------------------------
4186 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean is
4190 -- A limited with_clause cannot appear in the same context_clause
4191 -- as a nonlimited with_clause which mentions the same library.
4193 Item
:= First
(Context_Items
(Comp_Unit
));
4194 while Present
(Item
) loop
4195 if Nkind
(Item
) = N_With_Clause
4196 and then Library_Unit
(Item
) = Library_Unit
(W
)
4205 end Previous_Withed_Unit
;
4207 -- Start of processing for Expand_Limited_With_Clause
4210 if Nkind
(Nam
) = N_Identifier
then
4212 -- Create node for name of withed unit
4215 Make_With_Clause
(Loc
,
4216 Name
=> New_Copy
(Nam
));
4218 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
4220 Make_With_Clause
(Loc
,
4221 Name
=> Make_Selected_Component
(Loc
,
4222 Prefix
=> New_Copy_Tree
(Prefix
(Nam
)),
4223 Selector_Name
=> New_Copy
(Selector_Name
(Nam
))));
4224 Set_Parent
(Withn
, Parent
(N
));
4227 Set_First_Name
(Withn
);
4228 Set_Implicit_With
(Withn
);
4229 Set_Limited_Present
(Withn
);
4233 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
4238 -- Do not generate a limited_with_clause on the current unit. This
4239 -- path is taken when a unit has a limited_with clause on one of its
4242 if Unum
= Current_Sem_Unit
then
4246 Set_Library_Unit
(Withn
, Cunit
(Unum
));
4247 Set_Corresponding_Spec
4248 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
4250 if not Previous_Withed_Unit
(Withn
) then
4251 Prepend
(Withn
, Context_Items
(Parent
(N
)));
4252 Mark_Rewrite_Insertion
(Withn
);
4254 -- Add implicit limited_with_clauses for parents of child units
4255 -- mentioned in limited_with clauses.
4257 if Nkind
(Nam
) = N_Selected_Component
then
4258 Expand_Limited_With_Clause
(Comp_Unit
, Prefix
(Nam
), N
);
4263 if not Limited_View_Installed
(Withn
) then
4264 Install_Limited_With_Clause
(Withn
);
4267 end Expand_Limited_With_Clause
;
4269 -- Start of processing for Install_Limited_Context_Clauses
4272 Item
:= First
(Context_Items
(N
));
4273 while Present
(Item
) loop
4274 if Nkind
(Item
) = N_With_Clause
4275 and then Limited_Present
(Item
)
4276 and then not Error_Posted
(Item
)
4278 if Nkind
(Name
(Item
)) = N_Selected_Component
then
4279 Expand_Limited_With_Clause
4280 (Comp_Unit
=> N
, Nam
=> Prefix
(Name
(Item
)), N
=> Item
);
4283 Check_Private_Limited_Withed_Unit
(Item
);
4285 if not Implicit_With
(Item
) and then Is_Child_Spec
(Unit
(N
)) then
4286 Check_Renamings
(Parent_Spec
(Unit
(N
)), Item
);
4289 -- A unit may have a limited with on itself if it has a limited
4290 -- with_clause on one of its child units. In that case it is
4291 -- already being compiled and it makes no sense to install its
4294 -- If the item is a limited_private_with_clause, install it if the
4295 -- current unit is a body or if it is a private child. Otherwise
4296 -- the private clause is installed before analyzing the private
4297 -- part of the current unit.
4299 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
)
4300 and then not Limited_View_Installed
(Item
)
4302 not Is_Ancestor_Unit
4303 (Library_Unit
(Item
), Cunit
(Current_Sem_Unit
))
4305 if not Private_Present
(Item
)
4306 or else Private_Present
(N
)
4307 or else Nkind
(Unit
(N
)) in
4308 N_Package_Body | N_Subprogram_Body | N_Subunit
4310 Install_Limited_With_Clause
(Item
);
4318 -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
4319 -- looking for incomplete subtype declarations of incomplete types
4320 -- visible through a limited with clause.
4322 if Ada_Version
>= Ada_2005
4323 and then Analyzed
(N
)
4324 and then Nkind
(Unit
(N
)) = N_Package_Declaration
4329 Non_Lim_View
: Entity_Id
;
4332 Decl
:= First
(Visible_Declarations
(Specification
(Unit
(N
))));
4333 while Present
(Decl
) loop
4334 if Nkind
(Decl
) = N_Subtype_Declaration
4336 Ekind
(Defining_Identifier
(Decl
)) = E_Incomplete_Subtype
4338 From_Limited_With
(Defining_Identifier
(Decl
))
4340 Def_Id
:= Defining_Identifier
(Decl
);
4341 Non_Lim_View
:= Non_Limited_View
(Def_Id
);
4343 if not Is_Incomplete_Type
(Non_Lim_View
) then
4345 -- Convert an incomplete subtype declaration into a
4346 -- corresponding nonlimited view subtype declaration.
4347 -- This is usually the case when analyzing a body that
4348 -- has regular with clauses, when the spec has limited
4351 -- If the nonlimited view is still incomplete, it is
4352 -- the dummy entry already created, and the declaration
4353 -- cannot be reanalyzed. This is the case when installing
4354 -- a parent unit that has limited with-clauses.
4356 Set_Subtype_Indication
(Decl
,
4357 New_Occurrence_Of
(Non_Lim_View
, Sloc
(Def_Id
)));
4358 Set_Etype
(Def_Id
, Non_Lim_View
);
4359 Reinit_Field_To_Zero
(Def_Id
, F_Non_Limited_View
,
4360 Old_Ekind
=> (E_Incomplete_Subtype
=> True,
4362 Reinit_Field_To_Zero
(Def_Id
, F_Private_Dependents
);
4364 (Def_Id
, Subtype_Kind
(Ekind
(Non_Lim_View
)));
4365 Set_Analyzed
(Decl
, False);
4367 -- Reanalyze the declaration, suppressing the call to
4368 -- Enter_Name to avoid duplicate names.
4370 Analyze_Subtype_Declaration
4380 end Install_Limited_Context_Clauses
;
4382 ---------------------
4383 -- Install_Parents --
4384 ---------------------
4386 procedure Install_Parents
4387 (Lib_Unit
: Node_Id
;
4388 Is_Private
: Boolean;
4389 Chain
: Boolean := True)
4397 P
:= Unit
(Parent_Spec
(Lib_Unit
));
4398 P_Name
:= Get_Parent_Entity
(P
);
4400 if Etype
(P_Name
) = Any_Type
then
4404 if Ekind
(P_Name
) = E_Generic_Package
4405 and then Nkind
(Lib_Unit
) not in N_Generic_Declaration
4406 | N_Generic_Renaming_Declaration
4409 ("child of a generic package must be a generic unit", Lib_Unit
);
4411 elsif not Is_Package_Or_Generic_Package
(P_Name
) then
4413 ("parent unit must be package or generic package", Lib_Unit
);
4414 raise Unrecoverable_Error
;
4416 elsif Present
(Renamed_Entity
(P_Name
)) then
4417 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
4418 raise Unrecoverable_Error
;
4420 -- Verify that a child of an instance is itself an instance, or the
4421 -- renaming of one. Given that an instance that is a unit is replaced
4422 -- with a package declaration, check against the original node. The
4423 -- parent may be currently being instantiated, in which case it appears
4424 -- as a declaration, but the generic_parent is already established
4425 -- indicating that we deal with an instance.
4427 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
then
4428 if Nkind
(Lib_Unit
) in N_Renaming_Declaration
4429 or else Nkind
(Original_Node
(Lib_Unit
)) in N_Generic_Instantiation
4431 (Nkind
(Lib_Unit
) = N_Package_Declaration
4432 and then Present
(Generic_Parent
(Specification
(Lib_Unit
))))
4437 ("child of an instance must be an instance or renaming",
4442 -- This is the recursive call that ensures all parents are loaded
4444 if Is_Child_Spec
(P
) then
4448 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)),
4452 -- Now we can install the context for this parent
4454 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
), Chain
);
4455 Install_Limited_Context_Clauses
(Parent_Spec
(Lib_Unit
));
4456 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
4458 -- The child unit is in the declarative region of the parent. The parent
4459 -- must therefore appear in the scope stack and be visible, as when
4460 -- compiling the corresponding body. If the child unit is private or it
4461 -- is a package body, private declarations must be accessible as well.
4462 -- Use declarations in the parent must also be installed. Finally, other
4463 -- child units of the same parent that are in the context are
4464 -- immediately visible.
4466 -- Find entity for compilation unit, and set its private descendant
4467 -- status as needed. Indicate that it is a compilation unit, which is
4468 -- redundant in general, but needed if this is a generated child spec
4469 -- for a child body without previous spec.
4471 E_Name
:= Defining_Entity
(Lib_Unit
);
4473 Set_Is_Child_Unit
(E_Name
);
4474 Set_Is_Compilation_Unit
(E_Name
);
4476 Set_Is_Private_Descendant
(E_Name
,
4477 Is_Private_Descendant
(P_Name
)
4478 or else Private_Present
(Parent
(Lib_Unit
)));
4480 P_Spec
:= Package_Specification
(P_Name
);
4481 Push_Scope
(P_Name
);
4483 -- Save current visibility of unit
4485 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
4486 Is_Immediately_Visible
(P_Name
);
4487 Set_Is_Immediately_Visible
(P_Name
);
4488 Install_Visible_Declarations
(P_Name
);
4489 Set_Use
(Visible_Declarations
(P_Spec
));
4491 -- If the parent is a generic unit, its formal part may contain formal
4492 -- packages and use clauses for them.
4494 if Ekind
(P_Name
) = E_Generic_Package
then
4495 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
4498 if Is_Private
or else Private_Present
(Parent
(Lib_Unit
)) then
4499 Install_Private_Declarations
(P_Name
);
4500 Install_Private_With_Clauses
(P_Name
);
4501 Set_Use
(Private_Declarations
(P_Spec
));
4503 end Install_Parents
;
4505 ----------------------------------
4506 -- Install_Private_With_Clauses --
4507 ----------------------------------
4509 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
4510 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
4514 if Debug_Flag_I
then
4515 Write_Str
("install private with clauses of ");
4516 Write_Name
(Chars
(P
));
4520 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
4521 Item
:= First
(Context_Items
(Parent
(Decl
)));
4522 while Present
(Item
) loop
4523 if Nkind
(Item
) = N_With_Clause
4524 and then Private_Present
(Item
)
4526 -- If the unit is an ancestor of the current one, it is the
4527 -- case of a private limited with clause on a child unit, and
4528 -- the compilation of one of its descendants, In that case the
4529 -- limited view is errelevant.
4531 if Limited_Present
(Item
) then
4532 if not Limited_View_Installed
(Item
)
4534 not Is_Ancestor_Unit
(Library_Unit
(Item
),
4535 Cunit
(Current_Sem_Unit
))
4537 Install_Limited_With_Clause
(Item
);
4540 Install_With_Clause
(Item
, Private_With_OK
=> True);
4547 end Install_Private_With_Clauses
;
4549 ----------------------
4550 -- Install_Siblings --
4551 ----------------------
4553 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
4559 -- Iterate over explicit with clauses, and check whether the scope of
4560 -- each entity is an ancestor of the current unit, in which case it is
4561 -- immediately visible.
4563 Item
:= First
(Context_Items
(N
));
4564 while Present
(Item
) loop
4566 -- Do not install private_with_clauses declaration, unless unit
4567 -- is itself a private child unit, or is a body. Note that for a
4568 -- subprogram body the private_with_clause does not take effect
4569 -- until after the specification.
4571 if Nkind
(Item
) /= N_With_Clause
4572 or else Implicit_With
(Item
)
4573 or else Limited_Present
(Item
)
4574 or else Error_Posted
(Item
)
4576 -- Skip processing malformed trees
4578 or else (Try_Semantics
4579 and then Nkind
(Name
(Item
)) not in N_Has_Entity
)
4583 elsif not Private_Present
(Item
)
4584 or else Private_Present
(N
)
4585 or else Nkind
(Unit
(N
)) = N_Package_Body
4587 Id
:= Entity
(Name
(Item
));
4589 if Is_Child_Unit
(Id
)
4590 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
4592 Set_Is_Immediately_Visible
(Id
);
4594 -- Check for the presence of another unit in the context that
4595 -- may be inadvertently hidden by the child.
4597 Prev
:= Current_Entity
(Id
);
4600 and then Is_Immediately_Visible
(Prev
)
4601 and then not Is_Child_Unit
(Prev
)
4607 Clause
:= First
(Context_Items
(N
));
4608 while Present
(Clause
) loop
4609 if Nkind
(Clause
) = N_With_Clause
4610 and then Entity
(Name
(Clause
)) = Prev
4613 ("child unit& hides compilation unit " &
4614 "with the same name??",
4624 -- The With_Clause may be on a grandchild or one of its further
4625 -- descendants, which makes a child immediately visible. Examine
4626 -- ancestry to determine whether such a child exists. For example,
4627 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4628 -- is immediately visible.
4630 elsif Is_Child_Unit
(Id
) then
4636 while Is_Child_Unit
(Par
) loop
4637 if Is_Ancestor_Package
(Scope
(Par
), U_Name
) then
4638 Set_Is_Immediately_Visible
(Par
);
4647 -- If the item is a private with-clause on a child unit, the parent
4648 -- may have been installed already, but the child unit must remain
4649 -- invisible until installed in a private part or body, unless there
4650 -- is already a regular with_clause for it in the current unit.
4652 elsif Private_Present
(Item
) then
4653 Id
:= Entity
(Name
(Item
));
4655 if Is_Child_Unit
(Id
) then
4659 function In_Context
return Boolean;
4660 -- Scan context of current unit, to check whether there is
4661 -- a with_clause on the same unit as a private with-clause
4662 -- on a parent, in which case child unit is visible. If the
4663 -- unit is a grandchild, the same applies to its parent.
4669 function In_Context
return Boolean is
4672 First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4673 while Present
(Clause
) loop
4674 if Nkind
(Clause
) = N_With_Clause
4675 and then Comes_From_Source
(Clause
)
4676 and then Is_Entity_Name
(Name
(Clause
))
4677 and then not Private_Present
(Clause
)
4679 if Entity
(Name
(Clause
)) = Id
4681 (Nkind
(Name
(Clause
)) = N_Expanded_Name
4682 and then Entity
(Prefix
(Name
(Clause
))) = Id
)
4695 Set_Is_Visible_Lib_Unit
(Id
, In_Context
);
4702 end Install_Siblings
;
4704 ---------------------------------
4705 -- Install_Limited_With_Clause --
4706 ---------------------------------
4708 procedure Install_Limited_With_Clause
(N
: Node_Id
) is
4709 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
4712 Is_Child_Package
: Boolean := False;
4713 Lim_Header
: Entity_Id
;
4714 Lim_Typ
: Entity_Id
;
4716 procedure Check_Body_Required
;
4717 -- A unit mentioned in a limited with_clause may not be mentioned in
4718 -- a regular with_clause, but must still be included in the current
4719 -- partition. We need to determine whether the unit needs a body, so
4720 -- that the binder can determine the name of the file to be compiled.
4721 -- Checking whether a unit needs a body can be done without semantic
4722 -- analysis, by examining the nature of the declarations in the package.
4724 function Has_Limited_With_Clause
4725 (C_Unit
: Entity_Id
;
4726 Pack
: Entity_Id
) return Boolean;
4727 -- Determine whether any package in the ancestor chain starting with
4728 -- C_Unit has a limited with clause for package Pack.
4730 -------------------------
4731 -- Check_Body_Required --
4732 -------------------------
4734 procedure Check_Body_Required
is
4735 PA
: constant List_Id
:=
4736 Pragmas_After
(Aux_Decls_Node
(Parent
(P_Unit
)));
4738 procedure Check_Declarations
(Spec
: Node_Id
);
4739 -- Recursive procedure that does the work and checks nested packages
4741 ------------------------
4742 -- Check_Declarations --
4743 ------------------------
4745 procedure Check_Declarations
(Spec
: Node_Id
) is
4747 Incomplete_Decls
: constant Elist_Id
:= New_Elmt_List
;
4749 Subp_List
: constant Elist_Id
:= New_Elmt_List
;
4751 procedure Check_Pragma_Import
(P
: Node_Id
);
4752 -- If a pragma import applies to a previous subprogram, the
4753 -- enclosing unit may not need a body. The processing is syntactic
4754 -- and does not require a declaration to be analyzed. The code
4755 -- below also handles pragma Import when applied to a subprogram
4756 -- that renames another. In this case the pragma applies to the
4759 -- Chains of multiple renames are not handled by the code below.
4760 -- It is probably impossible to handle all cases without proper
4761 -- name resolution. In such cases the algorithm is conservative
4762 -- and will indicate that a body is needed???
4764 -------------------------
4765 -- Check_Pragma_Import --
4766 -------------------------
4768 procedure Check_Pragma_Import
(P
: Node_Id
) is
4774 procedure Remove_Homonyms
(E
: Node_Id
);
4775 -- Make one pass over list of subprograms. Called again if
4776 -- subprogram is a renaming. E is known to be an identifier.
4778 ---------------------
4779 -- Remove_Homonyms --
4780 ---------------------
4782 procedure Remove_Homonyms
(E
: Node_Id
) is
4783 R
: Entity_Id
:= Empty
;
4784 -- Name of renamed entity, if any
4787 Subp_Id
:= First_Elmt
(Subp_List
);
4788 while Present
(Subp_Id
) loop
4789 if Chars
(Node
(Subp_Id
)) = Chars
(E
) then
4790 if Nkind
(Parent
(Parent
(Node
(Subp_Id
))))
4791 /= N_Subprogram_Renaming_Declaration
4794 Next_Elmt
(Subp_Id
);
4795 Remove_Elmt
(Subp_List
, Prev_Id
);
4797 R
:= Name
(Parent
(Parent
(Node
(Subp_Id
))));
4801 Next_Elmt
(Subp_Id
);
4806 if Nkind
(R
) = N_Identifier
then
4807 Remove_Homonyms
(R
);
4809 elsif Nkind
(R
) = N_Selected_Component
then
4810 Remove_Homonyms
(Selector_Name
(R
));
4812 -- Renaming of attribute
4818 end Remove_Homonyms
;
4820 -- Start of processing for Check_Pragma_Import
4823 -- Find name of entity in Import pragma. We have not analyzed
4824 -- the construct, so we must guard against syntax errors.
4826 Arg
:= Next
(First
(Pragma_Argument_Associations
(P
)));
4829 or else Nkind
(Expression
(Arg
)) /= N_Identifier
4833 Imported
:= Expression
(Arg
);
4836 Remove_Homonyms
(Imported
);
4837 end Check_Pragma_Import
;
4839 -- Start of processing for Check_Declarations
4842 -- Search for Elaborate Body pragma
4844 Decl
:= First
(Visible_Declarations
(Spec
));
4845 while Present
(Decl
)
4846 and then Nkind
(Decl
) = N_Pragma
4848 if Get_Pragma_Id
(Decl
) = Pragma_Elaborate_Body
then
4849 Set_Body_Required
(Library_Unit
(N
));
4856 -- Look for declarations that require the presence of a body. We
4857 -- have already skipped pragmas at the start of the list.
4859 while Present
(Decl
) loop
4861 -- Subprogram that comes from source means body may be needed.
4862 -- Save for subsequent examination of import pragmas.
4864 if Comes_From_Source
(Decl
)
4865 and then Nkind
(Decl
) in N_Subprogram_Declaration
4866 | N_Subprogram_Renaming_Declaration
4867 | N_Generic_Subprogram_Declaration
4869 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4871 -- Package declaration of generic package declaration. We need
4872 -- to recursively examine nested declarations.
4874 elsif Nkind
(Decl
) in N_Package_Declaration
4875 | N_Generic_Package_Declaration
4877 Check_Declarations
(Specification
(Decl
));
4879 elsif Nkind
(Decl
) = N_Pragma
4880 and then Pragma_Name
(Decl
) = Name_Import
4882 Check_Pragma_Import
(Decl
);
4888 -- Same set of tests for private part. In addition to subprograms
4889 -- detect the presence of Taft Amendment types (incomplete types
4890 -- completed in the body).
4892 Decl
:= First
(Private_Declarations
(Spec
));
4893 while Present
(Decl
) loop
4894 if Comes_From_Source
(Decl
)
4895 and then Nkind
(Decl
) in N_Subprogram_Declaration
4896 | N_Subprogram_Renaming_Declaration
4897 | N_Generic_Subprogram_Declaration
4899 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4901 elsif Nkind
(Decl
) in N_Package_Declaration
4902 | N_Generic_Package_Declaration
4904 Check_Declarations
(Specification
(Decl
));
4906 -- Collect incomplete type declarations for separate pass
4908 elsif Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
4909 Append_Elmt
(Decl
, Incomplete_Decls
);
4911 elsif Nkind
(Decl
) = N_Pragma
4912 and then Pragma_Name
(Decl
) = Name_Import
4914 Check_Pragma_Import
(Decl
);
4920 -- Now check incomplete declarations to locate Taft amendment
4921 -- types. This can be done by examining the defining identifiers
4922 -- of type declarations without real semantic analysis.
4928 Inc
:= First_Elmt
(Incomplete_Decls
);
4929 while Present
(Inc
) loop
4930 Decl
:= Next
(Node
(Inc
));
4931 while Present
(Decl
) loop
4932 if Nkind
(Decl
) = N_Full_Type_Declaration
4933 and then Chars
(Defining_Identifier
(Decl
)) =
4934 Chars
(Defining_Identifier
(Node
(Inc
)))
4942 -- If no completion, this is a TAT, and a body is needed
4945 Set_Body_Required
(Library_Unit
(N
));
4953 -- Finally, check whether there are subprograms that still require
4954 -- a body, i.e. are not renamings or null.
4956 if not Is_Empty_Elmt_List
(Subp_List
) then
4962 Subp_Id
:= First_Elmt
(Subp_List
);
4963 Spec
:= Parent
(Node
(Subp_Id
));
4965 while Present
(Subp_Id
) loop
4966 if Nkind
(Parent
(Spec
))
4967 = N_Subprogram_Renaming_Declaration
4971 elsif Nkind
(Spec
) = N_Procedure_Specification
4972 and then Null_Present
(Spec
)
4977 Set_Body_Required
(Library_Unit
(N
));
4981 Next_Elmt
(Subp_Id
);
4985 end Check_Declarations
;
4987 -- Start of processing for Check_Body_Required
4990 -- If this is an imported package (Java and CIL usage) no body is
4991 -- needed. Scan list of pragmas that may follow a compilation unit
4992 -- to look for a relevant pragma Import.
4994 if Present
(PA
) then
5000 while Present
(Prag
) loop
5001 if Nkind
(Prag
) = N_Pragma
5002 and then Get_Pragma_Id
(Prag
) = Pragma_Import
5012 Check_Declarations
(Specification
(P_Unit
));
5013 end Check_Body_Required
;
5015 -----------------------------
5016 -- Has_Limited_With_Clause --
5017 -----------------------------
5019 function Has_Limited_With_Clause
5020 (C_Unit
: Entity_Id
;
5021 Pack
: Entity_Id
) return Boolean
5028 while Present
(Par
) loop
5029 if Ekind
(Par
) /= E_Package
then
5033 -- Retrieve the Compilation_Unit node for Par and determine if
5034 -- its context clauses contain a limited with for Pack.
5036 Par_Unit
:= Parent
(Parent
(Parent
(Par
)));
5038 if Nkind
(Par_Unit
) = N_Package_Declaration
then
5039 Par_Unit
:= Parent
(Par_Unit
);
5042 if Has_With_Clause
(Par_Unit
, Pack
, True) then
5046 -- If there are more ancestors, climb up the tree, otherwise we
5049 if Is_Child_Unit
(Par
) then
5057 end Has_Limited_With_Clause
;
5059 -- Start of processing for Install_Limited_With_Clause
5062 pragma Assert
(not Limited_View_Installed
(N
));
5064 -- In case of limited with_clause on subprograms, generics, instances,
5065 -- or renamings, the corresponding error was previously posted and we
5066 -- have nothing to do here. If the file is missing altogether, it has
5067 -- no source location.
5069 if Nkind
(P_Unit
) /= N_Package_Declaration
5070 or else Sloc
(P_Unit
) = No_Location
5075 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
5077 -- Handle child packages
5079 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
5080 Is_Child_Package
:= True;
5081 P
:= Defining_Identifier
(P
);
5084 -- Do not install the limited-view if the context of the unit is already
5085 -- available through a regular with clause.
5087 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
5088 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
5093 -- Do not install the limited-view if the full-view is already visible
5094 -- through renaming declarations.
5096 if Is_Visible_Through_Renamings
(P
, N
) then
5100 -- Do not install the limited view if this is the unit being analyzed.
5101 -- This unusual case will happen when a unit has a limited_with clause
5102 -- on one of its children. The compilation of the child forces the load
5103 -- of the parent which tries to install the limited view of the child
5104 -- again. Installing the limited view must also be disabled when
5105 -- compiling the body of the child unit.
5107 if P
= Cunit_Entity
(Current_Sem_Unit
)
5108 or else (Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
5109 and then P
= Main_Unit_Entity
5110 and then Is_Ancestor_Unit
5111 (Cunit
(Main_Unit
), Cunit
(Current_Sem_Unit
)))
5116 -- This scenario is similar to the one above, the difference is that the
5117 -- compilation of sibling Par.Sib forces the load of parent Par which
5118 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
5119 -- has a with clause for Lim_Pack [2] in its body, and thus needs the
5120 -- nonlimited views of all entities from Lim_Pack.
5122 -- limited with Lim_Pack; -- [1]
5123 -- package Par is ... package Lim_Pack is ...
5125 -- with Lim_Pack; -- [2]
5126 -- package Par.Sib is ... package body Par.Sib is ...
5128 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
5129 -- Sem_Unit is the body of Par.Sib.
5131 if Ekind
(P
) = E_Package
5132 and then Ekind
(Main_Unit_Entity
) = E_Package
5133 and then Is_Child_Unit
(Main_Unit_Entity
)
5135 -- The body has a regular with clause
5137 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
5138 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
5140 -- One of the ancestors has a limited with clause
5142 and then Nkind
(Parent
(Parent
(Main_Unit_Entity
))) =
5143 N_Package_Specification
5144 and then Has_Limited_With_Clause
(Scope
(Main_Unit_Entity
), P
)
5149 -- A common use of the limited-with is to have a limited-with in the
5150 -- package spec, and a normal with in its package body. For example:
5152 -- limited with X; -- [1]
5156 -- package body A is ...
5158 -- The compilation of A's body installs the context clauses found at [2]
5159 -- and then the context clauses of its specification (found at [1]). As
5160 -- a consequence, at [1] the specification of X has been analyzed and it
5161 -- is immediately visible. According to the semantics of limited-with
5162 -- context clauses we don't install the limited view because the full
5163 -- view of X supersedes its limited view.
5165 if Analyzed
(P_Unit
)
5167 (Is_Immediately_Visible
(P
)
5168 or else (Is_Child_Package
and then Is_Visible_Lib_Unit
(P
)))
5171 -- The presence of both the limited and the analyzed nonlimited view
5172 -- may also be an error, such as an illegal context for a limited
5173 -- with_clause. In that case, do not process the context item at all.
5175 if Error_Posted
(N
) then
5179 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
5183 Item
:= First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
5184 while Present
(Item
) loop
5185 if Nkind
(Item
) = N_With_Clause
5186 and then Comes_From_Source
(Item
)
5187 and then Entity
(Name
(Item
)) = P
5196 -- If this is a child body, assume that the nonlimited with_clause
5197 -- appears in an ancestor. Could be refined ???
5201 (Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)))))
5208 -- If in package declaration, nonlimited view brought in from
5209 -- parent unit or some error condition.
5215 if Debug_Flag_I
then
5216 Write_Str
("install limited view of ");
5217 Write_Name
(Chars
(P
));
5221 -- If the unit has not been analyzed and the limited view has not been
5222 -- already installed then we install it.
5224 if not Analyzed
(P_Unit
) then
5225 if not In_Chain
(P
) then
5227 -- Minimum decoration
5229 Mutate_Ekind
(P
, E_Package
);
5230 Set_Etype
(P
, Standard_Void_Type
);
5231 Set_Scope
(P
, Standard_Standard
);
5232 Set_Is_Visible_Lib_Unit
(P
);
5234 if Is_Child_Package
then
5235 Set_Is_Child_Unit
(P
);
5236 Set_Scope
(P
, Defining_Entity
(Unit
(Parent_Spec
(P_Unit
))));
5239 -- Place entity on visibility structure
5241 Set_Homonym
(P
, Current_Entity
(P
));
5242 Set_Current_Entity
(P
);
5244 if Debug_Flag_I
then
5245 Write_Str
(" (homonym) chain ");
5246 Write_Name
(Chars
(P
));
5250 -- Install the incomplete view. The first element of the limited
5251 -- view is a header (an E_Package entity) used to reference the
5252 -- first shadow entity in the private part of the package.
5254 Lim_Header
:= Limited_View
(P
);
5255 Lim_Typ
:= First_Entity
(Lim_Header
);
5257 while Present
(Lim_Typ
)
5258 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
5260 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
5261 Set_Current_Entity
(Lim_Typ
);
5263 if Debug_Flag_I
then
5264 Write_Str
(" (homonym) chain ");
5265 Write_Name
(Chars
(Lim_Typ
));
5269 Next_Entity
(Lim_Typ
);
5273 -- If the unit appears in a previous regular with_clause, the regular
5274 -- entities of the public part of the withed package must be replaced
5275 -- by the shadow ones.
5277 -- This code must be kept synchronized with the code that replaces the
5278 -- shadow entities by the real entities in Remove_Limited_With_Unit,
5279 -- otherwise the contents of the homonym chains are not consistent.
5282 -- Hide all the type entities of the public part of the package to
5283 -- avoid its usage. This is needed to cover all the subtype decla-
5284 -- rations because we do not remove them from the homonym chain.
5286 E
:= First_Entity
(P
);
5287 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
5289 Set_Was_Hidden
(E
, Is_Hidden
(E
));
5296 -- Replace the real entities by the shadow entities of the limited
5297 -- view. The first element of the limited view is a header that is
5298 -- used to reference the first shadow entity in the private part
5299 -- of the package. Successive elements are the limited views of the
5300 -- type (including regular incomplete types) declared in the package.
5302 Lim_Header
:= Limited_View
(P
);
5304 Lim_Typ
:= First_Entity
(Lim_Header
);
5305 while Present
(Lim_Typ
)
5306 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
5308 pragma Assert
(not In_Chain
(Lim_Typ
));
5310 -- Do not unchain nested packages and child units
5312 if Ekind
(Lim_Typ
) /= E_Package
5313 and then not Is_Child_Unit
(Lim_Typ
)
5316 Typ
: constant Entity_Id
:= Non_Limited_View
(Lim_Typ
);
5321 -- Replace Typ by Lim_Typ in the homonyms list, so that the
5322 -- limited view becomes available.
5324 -- If the nonlimited view is a record with an anonymous
5325 -- self-referential component, the analysis of the record
5326 -- declaration creates an incomplete type with the same name
5327 -- in order to define an internal access type. The visible
5328 -- entity is now the incomplete type, and that is the one to
5329 -- replace in the visibility structure.
5331 -- Similarly, if the source already contains the incomplete
5332 -- type declaration, the limited view of the incomplete type
5333 -- is in fact never visible (AI05-129) but we have created a
5334 -- shadow entity E1 for it that points to E2, the incomplete
5335 -- type at stake. This in turn has full view E3 that is the
5336 -- full declaration, with a corresponding shadow entity E4.
5337 -- When reinstalling the limited view, the visible entity E2
5338 -- is first replaced with E1, but E4 must eventually become
5339 -- the visible entity as per the AI and thus displace E1, as
5340 -- it is replacing E3 in the homonyms list.
5342 -- regular views limited views
5344 -- * E2 (incomplete) <-- E1 (shadow)
5349 -- E3 (full) <-- E4 (shadow) *
5351 -- [*] denotes the visible entity (Current_Entity)
5353 Prev
:= Current_Entity
(Lim_Typ
);
5355 while Present
(Prev
) loop
5356 -- This is a regular replacement
5359 or else (Ekind
(Prev
) = E_Incomplete_Type
5360 and then Full_View
(Prev
) = Typ
)
5362 Replace
(Prev
, Lim_Typ
);
5364 if Debug_Flag_I
then
5365 Write_Str
(" (homonym) replace ");
5366 Write_Name
(Chars
(Typ
));
5372 -- This is where E1 is replaced with E4
5374 elsif Ekind
(Prev
) = E_Incomplete_Type
5375 and then From_Limited_With
(Prev
)
5377 Ekind
(Non_Limited_View
(Prev
)) = E_Incomplete_Type
5378 and then Full_View
(Non_Limited_View
(Prev
)) = Typ
5380 Replace
(Prev
, Lim_Typ
);
5382 if Debug_Flag_I
then
5383 Write_Str
(" (homonym) E1 -> E4 ");
5384 Write_Name
(Chars
(Typ
));
5391 Prev
:= Homonym
(Prev
);
5396 Next_Entity
(Lim_Typ
);
5400 -- The package must be visible while the limited-with clause is active
5401 -- because references to the type P.T must resolve in the usual way.
5402 -- In addition, we remember that the limited-view has been installed to
5403 -- uninstall it at the point of context removal.
5405 Set_Is_Immediately_Visible
(P
);
5406 Set_Limited_View_Installed
(N
);
5408 -- If unit has not been analyzed in some previous context, check
5409 -- (imperfectly ???) whether it might need a body.
5411 if not Analyzed
(P_Unit
) then
5412 Check_Body_Required
;
5415 -- If the package in the limited_with clause is a child unit, the clause
5416 -- is unanalyzed and appears as a selected component. Recast it as an
5417 -- expanded name so that the entity can be properly set. Use entity of
5418 -- parent, if available, for higher ancestors in the name.
5420 if Nkind
(Name
(N
)) = N_Selected_Component
then
5428 while Nkind
(Nam
) = N_Selected_Component
5429 and then Present
(Ent
)
5431 Change_Selected_Component_To_Expanded_Name
(Nam
);
5433 -- Set entity of parent identifiers if the unit is a child
5434 -- unit. This ensures that the tree is properly formed from
5435 -- semantic point of view. The unit entities are not fully
5436 -- analyzed, so we need to follow unit links in the tree.
5438 Set_Entity
(Nam
, Ent
);
5440 Nam
:= Prefix
(Nam
);
5443 (Unit
(Parent_Spec
(Unit_Declaration_Node
(Ent
))));
5445 -- Set entity of last ancestor
5447 if Nkind
(Nam
) = N_Identifier
then
5448 Set_Entity
(Nam
, Ent
);
5454 Set_Entity
(Name
(N
), P
);
5455 Set_From_Limited_With
(P
);
5456 end Install_Limited_With_Clause
;
5458 -------------------------
5459 -- Install_With_Clause --
5460 -------------------------
5462 procedure Install_With_Clause
5463 (With_Clause
: Node_Id
;
5464 Private_With_OK
: Boolean := False)
5466 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
5467 P
: constant Entity_Id
:= Scope
(Uname
);
5470 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
5471 -- compiling a package declaration and the Private_With_OK flag was not
5472 -- set by the caller. These declarations will be installed later (before
5473 -- analyzing the private part of the package).
5475 if Private_Present
(With_Clause
)
5476 and then Nkind
(Unit
(Parent
(With_Clause
)))
5477 in N_Package_Declaration | N_Generic_Package_Declaration
5478 and then not Private_With_OK
5483 if Debug_Flag_I
then
5484 if Private_Present
(With_Clause
) then
5485 Write_Str
("install private withed unit ");
5486 elsif Parent_With
(With_Clause
) then
5487 Write_Str
("install parent withed unit ");
5488 elsif Implicit_With
(With_Clause
) then
5489 Write_Str
("install implicit withed unit ");
5491 Write_Str
("install withed unit ");
5494 Write_Name
(Chars
(Uname
));
5498 -- We do not apply the restrictions to an internal unit unless we are
5499 -- compiling the internal unit as a main unit. This check is also
5500 -- skipped for dummy units (for missing packages).
5502 if Sloc
(Uname
) /= No_Location
5503 and then (not Is_Internal_Unit
(Current_Sem_Unit
)
5504 or else Current_Sem_Unit
= Main_Unit
)
5506 Check_Restricted_Unit
5507 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
5510 if P
/= Standard_Standard
then
5512 -- If the unit is not analyzed after analysis of the with clause and
5513 -- it is an instantiation then it awaits a body and is the main unit.
5514 -- Its appearance in the context of some other unit indicates a
5515 -- circular dependency (DEC suite perversity).
5517 if not Analyzed
(Uname
)
5518 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
5521 ("instantiation depends on itself", Name
(With_Clause
));
5523 elsif not Analyzed
(Uname
)
5524 and then Is_Internal_Unit
(Current_Sem_Unit
)
5525 and then not Is_Visible_Lib_Unit
(Uname
)
5526 and then No
(Scope
(Uname
))
5528 if Is_Predefined_Unit
(Current_Sem_Unit
) then
5530 ("predefined unit depends on itself", Name
(With_Clause
));
5533 ("GNAT-defined unit depends on itself", Name
(With_Clause
));
5537 elsif not Is_Visible_Lib_Unit
(Uname
) then
5539 -- Abandon processing in case of previous errors
5541 if No
(Scope
(Uname
)) then
5542 Check_Error_Detected
;
5546 Set_Is_Visible_Lib_Unit
(Uname
);
5548 -- If the unit is a wrapper package for a compilation unit that is
5549 -- a subprogram instance, indicate that the instance itself is a
5550 -- visible unit. This is necessary if the instance is inlined.
5552 if Is_Wrapper_Package
(Uname
) then
5553 Set_Is_Visible_Lib_Unit
(Related_Instance
(Uname
));
5556 -- If the child unit appears in the context of its parent, it is
5557 -- immediately visible.
5559 if In_Open_Scopes
(Scope
(Uname
)) then
5560 Set_Is_Immediately_Visible
(Uname
);
5563 if Is_Generic_Instance
(Uname
)
5564 and then Is_Subprogram
(Uname
)
5566 -- Set flag as well on the visible entity that denotes the
5567 -- instance, which renames the current one.
5569 Set_Is_Visible_Lib_Unit
5571 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
5574 -- The parent unit may have been installed already, and may have
5575 -- appeared in a use clause.
5577 if In_Use
(Scope
(Uname
)) then
5578 Set_Is_Potentially_Use_Visible
(Uname
);
5581 Set_Context_Installed
(With_Clause
);
5584 elsif not Is_Immediately_Visible
(Uname
) then
5585 Set_Is_Visible_Lib_Unit
(Uname
);
5587 if not Private_Present
(With_Clause
) or else Private_With_OK
then
5588 Set_Is_Immediately_Visible
(Uname
);
5591 Set_Context_Installed
(With_Clause
);
5594 -- A [private] with clause overrides a limited with clause. Restore the
5595 -- proper view of the package by performing the following actions:
5597 -- * Remove all shadow entities which hide their corresponding
5598 -- entities from direct visibility by updating the entity and
5601 -- * Enter the corresponding entities back in direct visibility
5603 -- Note that the original limited with clause which installed its view
5604 -- is still marked as "active". This effect is undone when the clause
5605 -- itself is removed, see Remove_Limited_With_Clause.
5607 if Ekind
(Uname
) = E_Package
and then From_Limited_With
(Uname
) then
5608 Remove_Limited_With_Unit
(Unit_Declaration_Node
(Uname
));
5611 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5612 -- unit if there is a visible homograph for it declared in the same
5613 -- declarative region. This pathological case can only arise when an
5614 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5615 -- G1 has a generic child also named G2, and the context includes with_
5616 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
5617 -- of I1.G2 visible as well. If the child unit is named Standard, do
5618 -- not apply the check to the Standard package itself.
5620 if Is_Child_Unit
(Uname
)
5621 and then Is_Visible_Lib_Unit
(Uname
)
5622 and then Ada_Version
>= Ada_2005
5625 Decl1
: constant Node_Id
:= Unit_Declaration_Node
(P
);
5631 U2
:= Homonym
(Uname
);
5632 while Present
(U2
) and then U2
/= Standard_Standard
loop
5634 Decl2
:= Unit_Declaration_Node
(P2
);
5636 if Is_Child_Unit
(U2
) and then Is_Visible_Lib_Unit
(U2
) then
5637 if Is_Generic_Instance
(P
)
5638 and then Nkind
(Decl1
) = N_Package_Declaration
5639 and then Generic_Parent
(Specification
(Decl1
)) = P2
5641 Error_Msg_N
("illegal with_clause", With_Clause
);
5643 ("\child unit has visible homograph" &
5644 " (RM 8.3(26), 10.1.1(19))",
5648 elsif Is_Generic_Instance
(P2
)
5649 and then Nkind
(Decl2
) = N_Package_Declaration
5650 and then Generic_Parent
(Specification
(Decl2
)) = P
5652 -- With_clause for child unit of instance appears before
5653 -- in the context. We want to place the error message on
5654 -- it, not on the generic child unit itself.
5657 Prev_Clause
: Node_Id
;
5660 Prev_Clause
:= First
(List_Containing
(With_Clause
));
5661 while Entity
(Name
(Prev_Clause
)) /= U2
loop
5665 pragma Assert
(Present
(Prev_Clause
));
5666 Error_Msg_N
("illegal with_clause", Prev_Clause
);
5668 ("\child unit has visible homograph" &
5669 " (RM 8.3(26), 10.1.1(19))",
5680 end Install_With_Clause
;
5686 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
5687 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
5690 return (K
in N_Generic_Declaration
or else
5691 K
in N_Generic_Instantiation
or else
5692 K
in N_Generic_Renaming_Declaration
or else
5693 K
= N_Package_Declaration
or else
5694 K
= N_Package_Renaming_Declaration
or else
5695 K
= N_Subprogram_Declaration
or else
5696 K
= N_Subprogram_Renaming_Declaration
)
5697 and then Present
(Parent_Spec
(Lib_Unit
));
5700 ------------------------------------
5701 -- Is_Legal_Shadow_Entity_In_Body --
5702 ------------------------------------
5704 function Is_Legal_Shadow_Entity_In_Body
(T
: Entity_Id
) return Boolean is
5705 C_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
5707 return Nkind
(Unit
(C_Unit
)) = N_Package_Body
5710 (C_Unit
, Cunit_Entity
(Get_Source_Unit
(Non_Limited_View
(T
))));
5711 end Is_Legal_Shadow_Entity_In_Body
;
5713 ----------------------
5714 -- Is_Ancestor_Unit --
5715 ----------------------
5717 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean is
5718 E1
: constant Entity_Id
:= Defining_Entity
(Unit
(U1
));
5721 if Nkind
(Unit
(U2
)) in N_Package_Body | N_Subprogram_Body
then
5722 E2
:= Defining_Entity
(Unit
(Library_Unit
(U2
)));
5723 return Is_Ancestor_Package
(E1
, E2
);
5727 end Is_Ancestor_Unit
;
5729 ----------------------------------
5730 -- Is_Visible_Through_Renamings --
5731 ----------------------------------
5733 function Is_Visible_Through_Renamings
5735 Error_Node
: Node_Id
:= Empty
) return Boolean
5737 function Is_Limited_Withed_Unit
5738 (Lib_Unit
: Node_Id
;
5739 Pkg_Ent
: Entity_Id
) return Boolean;
5740 -- Return True if Pkg_Ent is a limited-withed package of the given
5743 ----------------------------
5744 -- Is_Limited_Withed_Unit --
5745 ----------------------------
5747 function Is_Limited_Withed_Unit
5748 (Lib_Unit
: Node_Id
;
5749 Pkg_Ent
: Entity_Id
) return Boolean
5751 Item
: Node_Id
:= First
(Context_Items
(Lib_Unit
));
5754 while Present
(Item
) loop
5755 if Nkind
(Item
) = N_With_Clause
5756 and then Limited_Present
(Item
)
5757 and then Entity
(Name
(Item
)) = Pkg_Ent
5766 end Is_Limited_Withed_Unit
;
5770 Kind
: constant Node_Kind
:= Nkind
(Unit
(Cunit
(Current_Sem_Unit
)));
5776 -- Example of the error detected by this subprogram:
5784 -- package Ren_P renames P;
5790 -- limited with P; -- ERROR
5791 -- package R.C is ...
5793 Aux_Unit
:= Cunit
(Current_Sem_Unit
);
5796 Item
:= First
(Context_Items
(Aux_Unit
));
5797 while Present
(Item
) loop
5798 if Nkind
(Item
) = N_With_Clause
5799 and then not Limited_Present
(Item
)
5800 and then Nkind
(Unit
(Library_Unit
(Item
))) =
5801 N_Package_Declaration
5804 First
(Visible_Declarations
5805 (Specification
(Unit
(Library_Unit
(Item
)))));
5806 while Present
(Decl
) loop
5807 if Nkind
(Decl
) = N_Package_Renaming_Declaration
5808 and then Entity
(Name
(Decl
)) = P
5809 and then not Is_Limited_Withed_Unit
5810 (Lib_Unit
=> Library_Unit
(Item
),
5811 Pkg_Ent
=> Entity
(Name
(Decl
)))
5813 -- Generate the error message only if the current unit
5814 -- is a package declaration; in case of subprogram
5815 -- bodies and package bodies we just return True to
5816 -- indicate that the limited view must not be
5819 if Kind
= N_Package_Declaration
5820 and then Present
(Error_Node
)
5823 ("simultaneous visibility of the limited and " &
5824 "unlimited views not allowed", Error_Node
);
5825 Error_Msg_Sloc
:= Sloc
(Item
);
5827 ("\\ unlimited view of & visible through the " &
5828 "context clause #", Error_Node
, P
);
5829 Error_Msg_Sloc
:= Sloc
(Decl
);
5830 Error_Msg_NE
("\\ and the renaming #", Error_Node
, P
);
5843 -- If it is a body not acting as spec, follow pointer to the
5844 -- corresponding spec, otherwise follow pointer to parent spec.
5846 if Present
(Library_Unit
(Aux_Unit
))
5847 and then Nkind
(Unit
(Aux_Unit
)) in
5848 N_Package_Body | N_Subprogram_Body
5850 if Aux_Unit
= Library_Unit
(Aux_Unit
) then
5852 -- Aux_Unit is a body that acts as a spec. Clause has
5853 -- already been flagged as illegal.
5858 Aux_Unit
:= Library_Unit
(Aux_Unit
);
5862 Aux_Unit
:= Parent_Spec
(Unit
(Aux_Unit
));
5865 exit when No
(Aux_Unit
);
5869 end Is_Visible_Through_Renamings
;
5871 -----------------------
5872 -- Load_Needed_Body --
5873 -----------------------
5875 -- N is a generic unit named in a with clause, or else it is a unit that
5876 -- contains a generic unit or an inlined function. In order to perform an
5877 -- instantiation, the body of the unit must be present. If the unit itself
5878 -- is generic, we assume that an instantiation follows, and load & analyze
5879 -- the body unconditionally. This forces analysis of the spec as well.
5881 -- If the unit is not generic, but contains a generic unit, it is loaded on
5882 -- demand, at the point of instantiation (see ch12).
5884 procedure Load_Needed_Body
5888 Body_Name
: Unit_Name_Type
;
5889 Unum
: Unit_Number_Type
;
5891 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
5892 -- The loading and analysis is done with style checks off
5895 if not GNAT_Mode
then
5896 Style_Check
:= False;
5899 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
5902 (Load_Name
=> Body_Name
,
5908 if Unum
= No_Unit
then
5912 Compiler_State
:= Analyzing
; -- reset after load
5914 if Fatal_Error
(Unum
) /= Error_Detected
or else Try_Semantics
then
5915 if Debug_Flag_L
then
5916 Write_Str
("*** Loaded generic body");
5920 -- We always perform analyses
5921 Semantics
(Cunit
(Unum
));
5927 Style_Check
:= Save_Style_Check
;
5928 end Load_Needed_Body
;
5930 -------------------------
5931 -- Build_Limited_Views --
5932 -------------------------
5934 procedure Build_Limited_Views
(N
: Node_Id
) is
5935 Unum
: constant Unit_Number_Type
:=
5936 Get_Source_Unit
(Library_Unit
(N
));
5937 Is_Analyzed
: constant Boolean := Analyzed
(Cunit
(Unum
));
5939 Shadow_Pack
: Entity_Id
;
5940 -- The corresponding shadow entity of the withed package. This entity
5941 -- offers incomplete views of packages and types as well as abstract
5942 -- views of states and variables declared within.
5944 Last_Shadow
: Entity_Id
:= Empty
;
5945 -- The last shadow entity created by routine Build_Shadow_Entity
5947 procedure Build_Shadow_Entity
5950 Shadow
: out Entity_Id
;
5951 Is_Tagged
: Boolean := False);
5952 -- Create a shadow entity that hides Ent and offers an abstract or
5953 -- incomplete view of Ent. Scop is the proper scope. Flag Is_Tagged
5954 -- should be set when Ent is a tagged type. The generated entity is
5955 -- added to Shadow_Pack. The routine updates the value of Last_Shadow.
5957 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5958 -- Perform minimal decoration of a package or its corresponding shadow
5959 -- entity denoted by Ent. Scop is the proper scope.
5961 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5962 -- Perform full decoration of an abstract state or its corresponding
5963 -- shadow entity denoted by Ent. Scop is the proper scope.
5965 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5966 -- Perform minimal decoration of a variable denoted by Ent. Scop is the
5969 procedure Process_Declarations_And_States
5973 Create_Abstract_Views
: Boolean);
5974 -- Inspect the states of package Pack and declarative list Decls. Create
5975 -- shadow entities for all nested packages, states, types and variables
5976 -- encountered. Scop is the proper scope. Create_Abstract_Views should
5977 -- be set when the abstract states and variables need to be processed.
5979 -------------------------
5980 -- Build_Shadow_Entity --
5981 -------------------------
5983 procedure Build_Shadow_Entity
5986 Shadow
: out Entity_Id
;
5987 Is_Tagged
: Boolean := False)
5990 Shadow
:= Make_Temporary
(Sloc
(Ent
), 'Z');
5992 -- The shadow entity must share the same name and parent as the
5995 Set_Chars
(Shadow
, Chars
(Ent
));
5996 Set_Parent
(Shadow
, Parent
(Ent
));
5998 -- The abstract view of a variable is a state, not another variable
6000 if Ekind
(Ent
) = E_Variable
then
6001 Mutate_Ekind
(Shadow
, E_Abstract_State
);
6003 Mutate_Ekind
(Shadow
, Ekind
(Ent
));
6006 Set_Is_Not_Self_Hidden
(Shadow
);
6007 Set_Is_Internal
(Shadow
);
6008 Set_From_Limited_With
(Shadow
);
6010 -- Add the new shadow entity to the limited view of the package
6012 Last_Shadow
:= Shadow
;
6013 Append_Entity
(Shadow
, Shadow_Pack
);
6015 -- Perform context-specific decoration of the shadow entity
6017 if Ekind
(Ent
) = E_Abstract_State
then
6018 Decorate_State
(Shadow
, Scop
);
6019 Set_Non_Limited_View
(Shadow
, Ent
);
6021 elsif Ekind
(Ent
) = E_Package
then
6022 Decorate_Package
(Shadow
, Scop
);
6024 elsif Is_Type
(Ent
) then
6025 Decorate_Type
(Shadow
, Scop
, Is_Tagged
);
6027 -- If Ent is a private type and we are analyzing the body of its
6028 -- scope, its private and full views are swapped and, therefore,
6029 -- we need to undo this swapping in order to build the same shadow
6030 -- entity as we would have in other contexts.
6032 if Is_Private_Type
(Ent
)
6033 and then Present
(Full_View
(Ent
))
6034 and then In_Package_Body
(Scop
)
6036 Set_Non_Limited_View
(Shadow
, Full_View
(Ent
));
6038 Set_Non_Limited_View
(Shadow
, Ent
);
6042 Set_Non_Limited_View
6043 (Class_Wide_Type
(Shadow
), Class_Wide_Type
(Ent
));
6046 if Is_Incomplete_Or_Private_Type
(Ent
) then
6047 Set_Private_Dependents
(Shadow
, New_Elmt_List
);
6050 elsif Ekind
(Ent
) = E_Variable
then
6051 Decorate_State
(Shadow
, Scop
);
6052 Set_Non_Limited_View
(Shadow
, Ent
);
6054 end Build_Shadow_Entity
;
6056 ----------------------
6057 -- Decorate_Package --
6058 ----------------------
6060 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
6062 Mutate_Ekind
(Ent
, E_Package
);
6063 Set_Etype
(Ent
, Standard_Void_Type
);
6064 Set_Scope
(Ent
, Scop
);
6065 end Decorate_Package
;
6067 --------------------
6068 -- Decorate_State --
6069 --------------------
6071 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
6073 Mutate_Ekind
(Ent
, E_Abstract_State
);
6074 Set_Is_Not_Self_Hidden
(Ent
);
6075 Set_Etype
(Ent
, Standard_Void_Type
);
6076 Set_Scope
(Ent
, Scop
);
6077 Set_Encapsulating_State
(Ent
, Empty
);
6080 -----------------------
6081 -- Decorate_Variable --
6082 -----------------------
6084 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
6086 Mutate_Ekind
(Ent
, E_Variable
);
6087 Set_Etype
(Ent
, Standard_Void_Type
);
6088 Set_Scope
(Ent
, Scop
);
6089 end Decorate_Variable
;
6091 -------------------------------------
6092 -- Process_Declarations_And_States --
6093 -------------------------------------
6095 procedure Process_Declarations_And_States
6099 Create_Abstract_Views
: Boolean)
6101 procedure Find_And_Process_States
;
6102 -- Determine whether package Pack defines abstract state either by
6103 -- using an aspect or a pragma. If this is the case, build shadow
6104 -- entities for all abstract states of Pack.
6106 procedure Process_States
(States
: Elist_Id
);
6107 -- Generate shadow entities for all abstract states in list States
6109 -----------------------------
6110 -- Find_And_Process_States --
6111 -----------------------------
6113 procedure Find_And_Process_States
is
6114 procedure Process_State
(State
: Node_Id
);
6115 -- Generate shadow entities for a single abstract state or
6116 -- multiple states expressed as an aggregate.
6122 procedure Process_State
(State
: Node_Id
) is
6123 Loc
: constant Source_Ptr
:= Sloc
(State
);
6130 -- Multiple abstract states appear as an aggregate
6132 if Nkind
(State
) = N_Aggregate
then
6133 Elmt
:= First
(Expressions
(State
));
6134 while Present
(Elmt
) loop
6135 Process_State
(Elmt
);
6141 -- A null state has no abstract view
6143 elsif Nkind
(State
) = N_Null
then
6146 -- State declaration with various options appears as an
6147 -- extension aggregate.
6149 elsif Nkind
(State
) = N_Extension_Aggregate
then
6150 Decl
:= Ancestor_Part
(State
);
6152 -- Simple state declaration
6154 elsif Nkind
(State
) = N_Identifier
then
6157 -- Possibly an illegal state declaration
6163 -- Abstract states are elaborated when the related pragma is
6164 -- elaborated. Since the withed package is not analyzed yet,
6165 -- the entities of the abstract states are not available. To
6166 -- overcome this complication, create the entities now and
6167 -- store them in their respective declarations. The entities
6168 -- are later used by routine Create_Abstract_State to declare
6169 -- and enter the states into visibility.
6171 if No
(Entity
(Decl
)) then
6172 Id
:= Make_Defining_Identifier
(Loc
, Chars
(Decl
));
6174 Set_Entity
(Decl
, Id
);
6175 Set_Parent
(Id
, State
);
6176 Decorate_State
(Id
, Scop
);
6178 -- Otherwise the package was previously withed
6181 Id
:= Entity
(Decl
);
6184 Build_Shadow_Entity
(Id
, Scop
, Dummy
);
6189 Pack_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Pack
);
6193 -- Start of processing for Find_And_Process_States
6196 -- Find aspect Abstract_State
6198 Asp
:= First
(Aspect_Specifications
(Pack_Decl
));
6199 while Present
(Asp
) loop
6200 if Chars
(Identifier
(Asp
)) = Name_Abstract_State
then
6201 Process_State
(Expression
(Asp
));
6209 -- Find pragma Abstract_State by inspecting the declarations
6211 Decl
:= First
(Decls
);
6212 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
6213 if Pragma_Name
(Decl
) = Name_Abstract_State
then
6216 (First
(Pragma_Argument_Associations
(Decl
))));
6223 end Find_And_Process_States
;
6225 --------------------
6226 -- Process_States --
6227 --------------------
6229 procedure Process_States
(States
: Elist_Id
) is
6234 Elmt
:= First_Elmt
(States
);
6235 while Present
(Elmt
) loop
6236 Build_Shadow_Entity
(Node
(Elmt
), Scop
, Dummy
);
6244 Is_Tagged
: Boolean;
6250 -- Start of processing for Process_Declarations_And_States
6253 -- Build abstract views for all states defined in the package
6255 if Create_Abstract_Views
then
6257 -- When a package has been analyzed, all states are stored in list
6258 -- Abstract_States. Generate the shadow entities directly.
6261 if Present
(Abstract_States
(Pack
)) then
6262 Process_States
(Abstract_States
(Pack
));
6265 -- The package may declare abstract states by using an aspect or a
6266 -- pragma. Attempt to locate one of these construct and if found,
6267 -- build the shadow entities.
6270 Find_And_Process_States
;
6274 -- Inspect the declarative list, looking for nested packages, types
6275 -- and variable declarations.
6277 Decl
:= First
(Decls
);
6278 while Present
(Decl
) loop
6282 if Nkind
(Decl
) = N_Package_Declaration
then
6283 Def_Id
:= Defining_Entity
(Decl
);
6285 -- Perform minor decoration when the withed package has not
6288 if not Is_Analyzed
then
6289 Decorate_Package
(Def_Id
, Scop
);
6292 -- Create a shadow entity that offers a limited view of all
6293 -- visible types declared within.
6295 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
6297 Process_Declarations_And_States
6300 Visible_Declarations
(Specification
(Decl
)),
6302 Create_Abstract_Views
=> Create_Abstract_Views
);
6306 elsif Nkind
(Decl
) in N_Full_Type_Declaration
6307 | N_Incomplete_Type_Declaration
6308 | N_Private_Extension_Declaration
6309 | N_Private_Type_Declaration
6310 | N_Protected_Type_Declaration
6311 | N_Task_Type_Declaration
6313 Def_Id
:= Defining_Entity
(Decl
);
6315 -- Determine whether the type is tagged. Note that packages
6316 -- included via a limited with clause are not always analyzed,
6317 -- hence the tree lookup rather than the use of attribute
6320 if Nkind
(Decl
) = N_Full_Type_Declaration
then
6321 Def
:= Type_Definition
(Decl
);
6324 (Nkind
(Def
) = N_Record_Definition
6325 and then Tagged_Present
(Def
))
6327 (Nkind
(Def
) = N_Derived_Type_Definition
6328 and then Present
(Record_Extension_Part
(Def
)));
6330 elsif Nkind
(Decl
) in N_Incomplete_Type_Declaration
6331 | N_Private_Type_Declaration
6333 Is_Tagged
:= Tagged_Present
(Decl
);
6335 elsif Nkind
(Decl
) = N_Private_Extension_Declaration
then
6342 -- Perform minor decoration when the withed package has not
6345 if not Is_Analyzed
then
6346 Decorate_Type
(Def_Id
, Scop
, Is_Tagged
, True);
6349 -- Create a shadow entity that hides the type and offers an
6350 -- incomplete view of the said type.
6352 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
, Is_Tagged
);
6356 elsif Create_Abstract_Views
6357 and then Nkind
(Decl
) = N_Object_Declaration
6358 and then not Constant_Present
(Decl
)
6360 Def_Id
:= Defining_Entity
(Decl
);
6362 -- Perform minor decoration when the withed package has not
6365 if not Is_Analyzed
then
6366 Decorate_Variable
(Def_Id
, Scop
);
6369 -- Create a shadow entity that hides the variable and offers an
6370 -- abstract view of the said variable.
6372 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
6377 end Process_Declarations_And_States
;
6381 Nam
: constant Node_Id
:= Name
(N
);
6382 Pack
: constant Entity_Id
:= Cunit_Entity
(Unum
);
6384 Last_Public_Shadow
: Entity_Id
:= Empty
;
6385 Private_Shadow
: Entity_Id
;
6388 -- Start of processing for Build_Limited_Views
6391 pragma Assert
(Limited_Present
(N
));
6393 -- A library_item mentioned in a limited_with_clause is a package
6394 -- declaration, not a subprogram declaration, generic declaration,
6395 -- generic instantiation, or package renaming declaration.
6397 case Nkind
(Unit
(Library_Unit
(N
))) is
6398 when N_Package_Declaration
=>
6401 when N_Subprogram_Declaration
=>
6403 ("subprogram not allowed in `LIMITED WITH` clause", N
);
6406 when N_Generic_Declaration
=>
6407 Error_Msg_N
("generic not allowed in `LIMITED WITH` clause", N
);
6410 when N_Generic_Instantiation
=>
6412 ("generic instantiation not allowed in `LIMITED WITH` clause",
6416 when N_Generic_Renaming_Declaration
=>
6418 ("generic renaming not allowed in `LIMITED WITH` clause", N
);
6421 when N_Subprogram_Renaming_Declaration
=>
6423 ("renamed subprogram not allowed in `LIMITED WITH` clause", N
);
6426 when N_Package_Renaming_Declaration
=>
6428 ("renamed package not allowed in `LIMITED WITH` clause", N
);
6432 raise Program_Error
;
6435 -- The withed unit may not be analyzed, but the with clause itself
6436 -- must be minimally decorated. This ensures that the checks on unused
6437 -- with clauses also process limieted withs.
6439 Mutate_Ekind
(Pack
, E_Package
);
6440 Set_Is_Not_Self_Hidden
(Pack
);
6441 Set_Etype
(Pack
, Standard_Void_Type
);
6443 if Is_Entity_Name
(Nam
) then
6444 Set_Entity
(Nam
, Pack
);
6446 elsif Nkind
(Nam
) = N_Selected_Component
then
6447 Set_Entity
(Selector_Name
(Nam
), Pack
);
6450 -- Check if the chain is already built
6452 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
6454 if Limited_View_Installed
(Spec
) then
6458 -- Create the shadow package wich hides the withed unit and provides
6459 -- incomplete view of all types and packages declared within.
6461 Shadow_Pack
:= Make_Temporary
(Sloc
(N
), 'Z');
6462 Mutate_Ekind
(Shadow_Pack
, E_Package
);
6463 Set_Is_Internal
(Shadow_Pack
);
6464 Set_Limited_View
(Pack
, Shadow_Pack
);
6466 -- Inspect the abstract states and visible declarations of the withed
6467 -- unit and create shadow entities that hide existing packages, states,
6468 -- variables and types.
6470 Process_Declarations_And_States
6472 Decls
=> Visible_Declarations
(Spec
),
6474 Create_Abstract_Views
=> True);
6476 Last_Public_Shadow
:= Last_Shadow
;
6478 -- Ada 2005 (AI-262): Build the limited view of the private declarations
6479 -- to accommodate limited private with clauses.
6481 Process_Declarations_And_States
6483 Decls
=> Private_Declarations
(Spec
),
6485 Create_Abstract_Views
=> False);
6487 if Present
(Last_Public_Shadow
) then
6488 Private_Shadow
:= Next_Entity
(Last_Public_Shadow
);
6490 Private_Shadow
:= First_Entity
(Shadow_Pack
);
6493 Set_First_Private_Entity
(Shadow_Pack
, Private_Shadow
);
6494 Set_Limited_View_Installed
(Spec
);
6495 end Build_Limited_Views
;
6497 ----------------------------
6498 -- Check_No_Elab_Code_All --
6499 ----------------------------
6501 procedure Check_No_Elab_Code_All
(N
: Node_Id
) is
6503 if Present
(No_Elab_Code_All_Pragma
)
6504 and then In_Extended_Main_Source_Unit
(N
)
6505 and then Present
(Context_Items
(N
))
6508 CL
: constant List_Id
:= Context_Items
(N
);
6513 while Present
(CI
) loop
6514 if Nkind
(CI
) = N_With_Clause
6516 No_Elab_Code_All
(Get_Source_Unit
(Library_Unit
(CI
)))
6518 -- In GNATprove mode, some runtime units are implicitly
6519 -- loaded to make their entities available for analysis. In
6520 -- this case, ignore violations of No_Elaboration_Code_All
6521 -- for this special analysis mode.
6524 (GNATprove_Mode
and then Implicit_With
(CI
))
6526 Error_Msg_Sloc
:= Sloc
(No_Elab_Code_All_Pragma
);
6528 ("violation of No_Elaboration_Code_All#", CI
);
6530 ("\unit& does not have No_Elaboration_Code_All",
6531 CI
, Entity
(Name
(CI
)));
6538 end Check_No_Elab_Code_All
;
6540 -------------------------------
6541 -- Check_Body_Needed_For_SAL --
6542 -------------------------------
6544 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
6545 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
6546 -- Determine whether use of entity E might require the presence of its
6547 -- body. For a package this requires a recursive traversal of all nested
6550 -----------------------
6551 -- Entity_Needs_Body --
6552 -----------------------
6554 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
6558 if Is_Subprogram
(E
) and then Has_Pragma_Inline
(E
) then
6561 elsif Is_Generic_Subprogram
(E
) then
6563 -- A generic subprogram always requires the presence of its
6564 -- body because an instantiation needs both templates. The only
6565 -- exceptions is a generic subprogram renaming. In this case the
6566 -- body is needed only when the template is declared outside the
6567 -- compilation unit being checked.
6569 if Present
(Renamed_Entity
(E
)) then
6570 return not Within_Scope
(E
, Unit_Name
);
6575 elsif Ekind
(E
) = E_Generic_Package
6577 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
6578 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6582 elsif Ekind
(E
) = E_Package
6583 and then Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
6584 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6586 Ent
:= First_Entity
(E
);
6587 while Present
(Ent
) loop
6588 if Entity_Needs_Body
(Ent
) then
6600 end Entity_Needs_Body
;
6602 -- Start of processing for Check_Body_Needed_For_SAL
6605 if Ekind
(Unit_Name
) = E_Generic_Package
6606 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6607 N_Generic_Package_Declaration
6609 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
6611 Set_Body_Needed_For_SAL
(Unit_Name
);
6613 elsif Ekind
(Unit_Name
) in E_Generic_Procedure | E_Generic_Function
then
6614 Set_Body_Needed_For_SAL
(Unit_Name
);
6616 elsif Is_Subprogram
(Unit_Name
)
6617 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6618 N_Subprogram_Declaration
6619 and then Has_Pragma_Inline
(Unit_Name
)
6621 Set_Body_Needed_For_SAL
(Unit_Name
);
6623 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
6624 Check_Body_Needed_For_SAL
6625 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6627 elsif Ekind
(Unit_Name
) = E_Package
6628 and then Entity_Needs_Body
(Unit_Name
)
6630 Set_Body_Needed_For_SAL
(Unit_Name
);
6632 elsif Ekind
(Unit_Name
) = E_Package_Body
6633 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
6635 Check_Body_Needed_For_SAL
6636 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6638 end Check_Body_Needed_For_SAL
;
6640 --------------------
6641 -- Remove_Context --
6642 --------------------
6644 procedure Remove_Context
(N
: Node_Id
) is
6645 Lib_Unit
: constant Node_Id
:= Unit
(N
);
6648 -- If this is a child unit, first remove the parent units
6650 if Is_Child_Spec
(Lib_Unit
) then
6651 Remove_Parents
(Lib_Unit
);
6654 Remove_Context_Clauses
(N
);
6657 ----------------------------
6658 -- Remove_Context_Clauses --
6659 ----------------------------
6661 procedure Remove_Context_Clauses
(N
: Node_Id
) is
6663 Unit_Name
: Entity_Id
;
6666 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
6667 -- limited-views first and regular-views later (to maintain the stack
6670 -- First Phase: Remove limited_with context clauses
6672 Item
:= First
(Context_Items
(N
));
6673 while Present
(Item
) loop
6675 -- We are interested only in with clauses that got installed on entry
6677 if Nkind
(Item
) = N_With_Clause
6678 and then Limited_Present
(Item
)
6680 if Limited_View_Installed
(Item
) then
6681 Remove_Limited_With_Clause
(Item
);
6683 -- An unusual case: If the library unit of the Main_Unit has a
6684 -- limited with_clause on some unit P and the context somewhere
6685 -- includes a with_clause on P, P has been analyzed. The entity
6686 -- for P is still visible, which in general is harmless because
6687 -- this is the end of the compilation, but it can affect pending
6688 -- instantiations that may have been generated elsewhere, so it
6689 -- it is necessary to remove U from visibility so that inlining
6690 -- and the analysis of instance bodies can proceed cleanly.
6692 elsif Current_Sem_Unit
= Main_Unit
6693 and then Serious_Errors_Detected
= 0
6694 and then not Implicit_With
(Item
)
6696 Set_Is_Immediately_Visible
6697 (Defining_Entity
(Unit
(Library_Unit
(Item
))), False);
6704 -- Second Phase: Loop through context items and undo regular
6705 -- with_clauses and use_clauses.
6707 Item
:= First
(Context_Items
(N
));
6708 while Present
(Item
) loop
6710 -- We are interested only in with clauses which got installed on
6711 -- entry, as indicated by their Context_Installed flag set
6713 if Nkind
(Item
) = N_With_Clause
6714 and then Limited_Present
(Item
)
6715 and then Limited_View_Installed
(Item
)
6719 elsif Nkind
(Item
) = N_With_Clause
6720 and then Context_Installed
(Item
)
6722 -- Remove items from one with'ed unit
6724 Unit_Name
:= Entity
(Name
(Item
));
6725 Remove_Unit_From_Visibility
(Unit_Name
);
6726 Set_Context_Installed
(Item
, False);
6728 elsif Nkind
(Item
) = N_Use_Package_Clause
then
6729 End_Use_Package
(Item
);
6731 elsif Nkind
(Item
) = N_Use_Type_Clause
then
6732 End_Use_Type
(Item
);
6737 end Remove_Context_Clauses
;
6739 --------------------------------
6740 -- Remove_Limited_With_Clause --
6741 --------------------------------
6743 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
6744 Pack_Decl
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
6747 pragma Assert
(Limited_View_Installed
(N
));
6749 -- Limited with clauses that designate units other than packages are
6750 -- illegal and are never installed.
6752 if Nkind
(Pack_Decl
) = N_Package_Declaration
then
6753 Remove_Limited_With_Unit
(Pack_Decl
, N
);
6756 -- Indicate that the limited views of the clause have been removed
6758 Set_Limited_View_Installed
(N
, False);
6759 end Remove_Limited_With_Clause
;
6761 ------------------------------
6762 -- Remove_Limited_With_Unit --
6763 ------------------------------
6765 procedure Remove_Limited_With_Unit
6766 (Pack_Decl
: Node_Id
;
6767 Lim_Clause
: Node_Id
:= Empty
)
6769 procedure Remove_Shadow_Entities_From_Visibility
(Pack_Id
: Entity_Id
);
6770 -- Remove the shadow entities of package Pack_Id from direct visibility
6772 procedure Remove_Shadow_Entities_With_Restore
(Pack_Id
: Entity_Id
);
6773 -- Remove the shadow entities of package Pack_Id from direct visibility,
6774 -- restore the corresponding entities they hide into direct visibility,
6775 -- and update the entity and homonym chains.
6777 --------------------------------------------
6778 -- Remove_Shadow_Entities_From_Visibility --
6779 --------------------------------------------
6781 procedure Remove_Shadow_Entities_From_Visibility
(Pack_Id
: Entity_Id
) is
6782 Lim_Header
: constant Entity_Id
:= Limited_View
(Pack_Id
);
6783 Upto
: constant Entity_Id
:= First_Private_Entity
(Lim_Header
);
6788 -- Remove the package from direct visibility
6791 Set_Is_Immediately_Visible
(Pack_Id
, False);
6793 -- Remove all shadow entities from direct visibility
6795 Shadow
:= First_Entity
(Lim_Header
);
6796 while Present
(Shadow
) and then Shadow
/= Upto
loop
6798 Next_Entity
(Shadow
);
6800 end Remove_Shadow_Entities_From_Visibility
;
6802 -----------------------------------------
6803 -- Remove_Shadow_Entities_With_Restore --
6804 -----------------------------------------
6806 -- This code must be kept synchronized with the code that replaces the
6807 -- real entities by the shadow entities in Install_Limited_With_Clause,
6808 -- otherwise the contents of the homonym chains are not consistent.
6810 procedure Remove_Shadow_Entities_With_Restore
(Pack_Id
: Entity_Id
) is
6811 procedure Restore_Chain_For_Shadow
(Shadow
: Entity_Id
);
6812 -- Remove shadow entity Shadow by updating the entity and homonym
6815 procedure Restore_Chains
6818 -- Remove a sequence of shadow entities starting from From and ending
6819 -- prior to Upto by updating the entity and homonym chains.
6821 procedure Restore_Type_Visibility
6824 -- Restore a sequence of types starting from From and ending prior to
6825 -- Upto back in direct visibility.
6827 ------------------------------
6828 -- Restore_Chain_For_Shadow --
6829 ------------------------------
6831 procedure Restore_Chain_For_Shadow
(Shadow
: Entity_Id
) is
6832 Typ
: constant Entity_Id
:= Non_Limited_View
(Shadow
);
6833 pragma Assert
(not In_Chain
(Typ
));
6838 -- If the package has incomplete types, the limited view of the
6839 -- incomplete type is in fact never visible (AI05-129) but we
6840 -- have created a shadow entity E1 for it, that points to E2,
6841 -- the incomplete type at stake. This in turn has a full view
6842 -- E3 that is the full declaration, with a corresponding
6843 -- shadow entity E4. When reinstalling the nonlimited view,
6844 -- the visible entity E4 is replaced directly with E2 in the
6845 -- the homonyms list and E3 is simply ignored.
6847 -- regular views limited views
6849 -- * E2 (incomplete) <-- E1 (shadow)
6854 -- E3 (full) <-- E4 (shadow) *
6856 -- [*] denotes the visible entity (Current_Entity)
6858 Prev
:= Current_Entity
(Shadow
);
6860 while Present
(Prev
) loop
6861 -- This is a regular replacement
6863 if Prev
= Shadow
then
6864 Replace
(Prev
, Typ
);
6866 if Debug_Flag_I
then
6867 Write_Str
(" (homonym) replace ");
6868 Write_Name
(Chars
(Typ
));
6874 -- This is where E4 is replaced with E2
6876 elsif Ekind
(Prev
) = E_Incomplete_Type
6877 and then From_Limited_With
(Prev
)
6878 and then Ekind
(Typ
) = E_Incomplete_Type
6879 and then Full_View
(Typ
) = Non_Limited_View
(Prev
)
6881 Replace
(Prev
, Typ
);
6883 if Debug_Flag_I
then
6884 Write_Str
(" (homonym) E4 -> E2 ");
6885 Write_Name
(Chars
(Typ
));
6892 Prev
:= Homonym
(Prev
);
6894 end Restore_Chain_For_Shadow
;
6896 --------------------
6897 -- Restore_Chains --
6898 --------------------
6900 procedure Restore_Chains
6908 while Present
(Shadow
) and then Shadow
/= Upto
loop
6910 -- Do not unchain nested packages and child units
6912 if Ekind
(Shadow
) = E_Package
then
6915 elsif Is_Child_Unit
(Non_Limited_View
(Shadow
)) then
6919 Restore_Chain_For_Shadow
(Shadow
);
6922 Next_Entity
(Shadow
);
6926 -----------------------------
6927 -- Restore_Type_Visibility --
6928 -----------------------------
6930 procedure Restore_Type_Visibility
6938 while Present
(Typ
) and then Typ
/= Upto
loop
6939 if Is_Type
(Typ
) then
6940 Set_Is_Hidden
(Typ
, Was_Hidden
(Typ
));
6945 end Restore_Type_Visibility
;
6949 Lim_Header
: constant Entity_Id
:= Limited_View
(Pack_Id
);
6951 -- Start of processing Remove_Shadow_Entities_With_Restore
6954 -- The limited view of a package is being uninstalled by removing
6955 -- the effects of a limited with clause. If the clause appears in a
6956 -- unit which is not part of the main unit closure, then the related
6957 -- package must not be visible.
6959 if Present
(Lim_Clause
)
6960 and then not In_Extended_Main_Source_Unit
(Lim_Clause
)
6962 Set_Is_Immediately_Visible
(Pack_Id
, False);
6964 -- Otherwise a limited view is being overridden by a nonlimited view.
6965 -- Leave the visibility of the package as is because the unit must be
6966 -- visible when the nonlimited view is installed.
6972 -- Remove the shadow entities from visibility by updating the entity
6973 -- and homonym chains.
6976 (From
=> First_Entity
(Lim_Header
),
6977 Upto
=> First_Private_Entity
(Lim_Header
));
6979 -- Reinstate the types that were hidden by the shadow entities back
6980 -- into direct visibility.
6982 Restore_Type_Visibility
6983 (From
=> First_Entity
(Pack_Id
),
6984 Upto
=> First_Private_Entity
(Pack_Id
));
6985 end Remove_Shadow_Entities_With_Restore
;
6989 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
6991 -- Start of processing for Remove_Limited_With_Unit
6994 -- Nothing to do when the limited view of the package is not installed
6996 if not From_Limited_With
(Pack_Id
) then
7000 if Debug_Flag_I
then
7001 Write_Str
("remove limited view of ");
7002 Write_Name
(Chars
(Pack_Id
));
7003 Write_Str
(" from visibility");
7007 -- The package already appears in the compilation closure. As a result,
7008 -- its shadow entities must be replaced by the real entities they hide
7009 -- and the previously hidden entities must be entered back into direct
7012 if Analyzed
(Pack_Decl
) then
7013 Remove_Shadow_Entities_With_Restore
(Pack_Id
);
7015 -- Otherwise the package is not analyzed and its shadow entities must be
7016 -- removed from direct visibility.
7019 Remove_Shadow_Entities_From_Visibility
(Pack_Id
);
7022 -- Indicate that the limited view of the package is not installed
7024 Set_From_Limited_With
(Pack_Id
, False);
7025 end Remove_Limited_With_Unit
;
7027 --------------------
7028 -- Remove_Parents --
7029 --------------------
7031 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
7034 P_Spec
: Node_Id
:= Empty
;
7036 Vis
: constant Boolean :=
7037 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
7040 if Is_Child_Spec
(Lib_Unit
) then
7041 P_Spec
:= Parent_Spec
(Lib_Unit
);
7043 elsif Nkind
(Lib_Unit
) = N_Package_Body
7044 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
7046 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
7049 if Present
(P_Spec
) then
7051 P_Name
:= Get_Parent_Entity
(P
);
7052 Remove_Context_Clauses
(P_Spec
);
7053 End_Package_Scope
(P_Name
);
7054 Set_Is_Immediately_Visible
(P_Name
, Vis
);
7056 -- Remove from visibility the siblings as well, which are directly
7057 -- visible while the parent is in scope.
7059 E
:= First_Entity
(P_Name
);
7060 while Present
(E
) loop
7061 if Is_Child_Unit
(E
) then
7062 Set_Is_Immediately_Visible
(E
, False);
7068 Set_In_Package_Body
(P_Name
, False);
7070 -- This is the recursive call to remove the context of any higher
7071 -- level parent. This recursion ensures that all parents are removed
7072 -- in the reverse order of their installation.
7078 ---------------------------------
7079 -- Remove_Private_With_Clauses --
7080 ---------------------------------
7082 procedure Remove_Private_With_Clauses
(Comp_Unit
: Node_Id
) is
7085 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean;
7086 -- Check whether a given unit appears in a regular with_clause. Used to
7087 -- determine whether a private_with_clause, implicit or explicit, should
7090 ----------------------------
7091 -- In_Regular_With_Clause --
7092 ----------------------------
7094 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean is
7098 Item
:= First
(Context_Items
(Comp_Unit
));
7100 while Present
(Item
) loop
7101 if Nkind
(Item
) = N_With_Clause
7103 -- The following guard is needed to ensure that the name has
7104 -- been properly analyzed before we go fetching its entity.
7106 and then Is_Entity_Name
(Name
(Item
))
7107 and then Entity
(Name
(Item
)) = E
7108 and then not Private_Present
(Item
)
7117 end In_Regular_With_Clause
;
7119 -- Start of processing for Remove_Private_With_Clauses
7122 Item
:= First
(Context_Items
(Comp_Unit
));
7123 while Present
(Item
) loop
7124 if Nkind
(Item
) = N_With_Clause
and then Private_Present
(Item
) then
7126 -- If private_with_clause is redundant, remove it from context,
7127 -- as a small optimization to subsequent handling of private_with
7128 -- clauses in other nested packages. We replace the clause with
7129 -- a null statement, which is otherwise ignored by the rest of
7132 if In_Regular_With_Clause
(Entity
(Name
(Item
))) then
7134 Nxt
: constant Node_Id
:= Next
(Item
);
7136 Rewrite
(Item
, Make_Null_Statement
(Sloc
(Item
)));
7141 elsif Limited_Present
(Item
) then
7142 if not Limited_View_Installed
(Item
) then
7143 Remove_Limited_With_Clause
(Item
);
7149 Remove_Unit_From_Visibility
(Entity
(Name
(Item
)));
7150 Set_Context_Installed
(Item
, False);
7158 end Remove_Private_With_Clauses
;
7160 ---------------------------------
7161 -- Remove_Unit_From_Visibility --
7162 ---------------------------------
7164 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
7166 if Debug_Flag_I
then
7167 Write_Str
("remove unit ");
7168 Write_Name
(Chars
(Unit_Name
));
7169 Write_Str
(" from visibility");
7173 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
7174 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
7175 Set_Is_Immediately_Visible
(Unit_Name
, False);
7177 -- If the unit is a wrapper package, the subprogram instance is
7178 -- what must be removed from visibility.
7179 -- Should we use Related_Instance instead???
7181 if Is_Wrapper_Package
(Unit_Name
) then
7182 Set_Is_Immediately_Visible
(Current_Entity
(Unit_Name
), False);
7184 end Remove_Unit_From_Visibility
;
7199 procedure Replace
(Old_E
, New_E
: Entity_Id
) is
7203 Prev
:= Current_Entity
(Old_E
);
7208 elsif Prev
= Old_E
then
7209 Set_Current_Entity
(New_E
);
7210 Set_Homonym
(New_E
, Homonym
(Old_E
));
7213 while Present
(Prev
) and then Homonym
(Prev
) /= Old_E
loop
7214 Prev
:= Homonym
(Prev
);
7217 if Present
(Prev
) then
7218 Set_Homonym
(Prev
, New_E
);
7219 Set_Homonym
(New_E
, Homonym
(Old_E
));
7228 procedure Unchain
(E
: Entity_Id
) is
7232 Prev
:= Current_Entity
(E
);
7238 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
7241 while Present
(Prev
) and then Homonym
(Prev
) /= E
loop
7242 Prev
:= Homonym
(Prev
);
7245 if Present
(Prev
) then
7246 Set_Homonym
(Prev
, Homonym
(E
));
7250 if Debug_Flag_I
then
7251 Write_Str
(" (homonym) unchain ");
7252 Write_Name
(Chars
(E
));