1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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
;
78 package body Sem_Ch10
is
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 procedure Analyze_Context
(N
: Node_Id
);
85 -- Analyzes items in the context clause of compilation unit
87 procedure Build_Limited_Views
(N
: Node_Id
);
88 -- Build and decorate the list of shadow entities for a package mentioned
89 -- in a limited_with clause. If the package was not previously analyzed
90 -- then it also performs a basic decoration of the real entities. This is
91 -- required in order to avoid passing non-decorated entities to the
92 -- back-end. Implements Ada 2005 (AI-50217).
94 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
95 -- Common processing for all stubs (subprograms, tasks, packages, and
96 -- protected cases). N is the stub to be analyzed. Once the subunit name
97 -- is established, load and analyze. Nam is the non-overloadable entity
98 -- for which the proper body provides a completion. Subprogram stubs are
99 -- handled differently because they can be declarations.
101 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
);
102 -- Check whether the source for the body of a compilation unit must be
103 -- included in a standalone library.
105 procedure Check_No_Elab_Code_All
(N
: Node_Id
);
106 -- Carries out possible tests for violation of No_Elab_Code all for withed
107 -- units in the Context_Items of unit N.
109 procedure Check_Private_Child_Unit
(N
: Node_Id
);
110 -- If a with_clause mentions a private child unit, the compilation unit
111 -- must be a member of the same family, as described in 10.1.2.
113 procedure Check_Stub_Level
(N
: Node_Id
);
114 -- Verify that a stub is declared immediately within a compilation unit,
115 -- and not in an inner frame.
117 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
118 -- When a child unit appears in a context clause, the implicit withs on
119 -- parents are made explicit, and with clauses are inserted in the context
120 -- clause before the one for the child. If a parent in the with_clause
121 -- is a renaming, the implicit with_clause is on the renaming whose name
122 -- is mentioned in the with_clause, and not on the package it renames.
123 -- N is the compilation unit whose list of context items receives the
124 -- implicit with_clauses.
126 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
127 -- Generate cross-reference information for the parents of child units
128 -- and of subunits. N is a defining_program_unit_name, and P_Id is the
129 -- immediate parent scope.
131 function Has_With_Clause
134 Is_Limited
: Boolean := False) return Boolean;
135 -- Determine whether compilation unit C_Unit contains a [limited] with
136 -- clause for package Pack. Use the flag Is_Limited to designate desired
139 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
140 -- If the main unit is a child unit, implicit withs are also added for
141 -- all its ancestors.
143 function In_Chain
(E
: Entity_Id
) return Boolean;
144 -- Check that the shadow entity is not already in the homonym chain, for
145 -- example through a limited_with clause in a parent unit.
147 procedure Install_Context_Clauses
(N
: Node_Id
; Chain
: Boolean := True);
148 -- Subsidiary to Install_Context and Install_Parents. Process all with
149 -- and use clauses for current unit and its library unit if any. The flag
150 -- Chain is used to control the "chaining" or linking together of use-type
151 -- and use-package clauses to avoid circularities with reinstalling
154 procedure Install_Limited_Context_Clauses
(N
: Node_Id
);
155 -- Subsidiary to Install_Context. Process only limited with_clauses for
156 -- current unit. Implements Ada 2005 (AI-50217).
158 procedure Install_Limited_With_Clause
(N
: Node_Id
);
159 -- Place shadow entities for a limited_with package in the visibility
160 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
162 procedure Install_Parents
164 Is_Private
: Boolean;
165 Chain
: Boolean := True);
166 -- This procedure establishes the context for the compilation of a child
167 -- unit. If Lib_Unit is a child library spec then the context of the parent
168 -- is installed, and the parent itself made immediately visible, so that
169 -- the child unit is processed in the declarative region of the parent.
170 -- Install_Parents makes a recursive call to itself to ensure that all
171 -- parents are loaded in the nested case. If Lib_Unit is a library body,
172 -- the only effect of Install_Parents is to install the private decls of
173 -- the parents, because the visible parent declarations will have been
174 -- installed as part of the context of the corresponding spec. The flag
175 -- Chain is used to control the "chaining" or linking of use-type and
176 -- use-package clauses to avoid circularities when installing context.
178 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
179 -- In the compilation of a child unit, a child of any of the ancestor
180 -- units is directly visible if it is visible, because the parent is in
181 -- an enclosing scope. Iterate over context to find child units of U_Name
182 -- or of some ancestor of it.
184 procedure Install_With_Clause
185 (With_Clause
: Node_Id
;
186 Private_With_OK
: Boolean := False);
187 -- If the unit is not a child unit, make unit immediately visible. The
188 -- caller ensures that the unit is not already currently installed. The
189 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
190 -- is called when compiling the private part of a package, or installing
191 -- the private declarations of a parent unit.
193 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean;
194 -- When compiling a unit Q descended from some parent unit P, a limited
195 -- with_clause in the context of P that names some other ancestor of Q
196 -- must not be installed because the ancestor is immediately visible.
198 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
199 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
200 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
201 -- a library spec that has a parent. If the call to Is_Child_Spec returns
202 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
203 -- compilation unit for the parent spec.
205 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
206 -- Parent_Spec is non-empty, this is also a child unit.
208 procedure Remove_Context_Clauses
(N
: Node_Id
);
209 -- Subsidiary of previous one. Remove use_ and with_clauses
211 procedure Remove_Limited_With_Clause
(N
: Node_Id
);
212 -- Remove the shadow entities from visibility introduced for a package
213 -- mentioned in limited with clause N. Implements Ada 2005 (AI-50217).
215 procedure Remove_Limited_With_Unit
216 (Pack_Decl
: Node_Id
;
217 Lim_Clause
: Node_Id
:= Empty
);
218 -- Remove the shadow entities from visibility introduced for a package
219 -- denoted by declaration Pack_Decl. Lim_Clause is the related limited
220 -- with clause, if any. Implements Ada 2005 (AI-50217).
222 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
223 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
224 -- contexts established by the corresponding call to Install_Parents are
225 -- removed. Remove_Parents contains a recursive call to itself to ensure
226 -- that all parents are removed in the nested case.
228 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
229 -- Reset all visibility flags on unit after compiling it, either as a main
230 -- unit or as a unit in the context.
232 procedure Unchain
(E
: Entity_Id
);
233 -- Remove single entity from visibility list
236 -- A dummy procedure, for debugging use, called just before analyzing the
237 -- main unit (after dealing with any context clauses).
239 --------------------------
240 -- Limited_With_Clauses --
241 --------------------------
243 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
244 -- mutually recursive types declared in different units. A limited_with
245 -- clause that names package P in the context of unit U makes the types
246 -- declared in the visible part of P available within U, but with the
247 -- restriction that these types can only be used as incomplete types.
248 -- The limited_with clause does not impose a semantic dependence on P,
249 -- and it is possible for two packages to have limited_with_clauses on
250 -- each other without creating an elaboration circularity.
252 -- To support this feature, the analysis of a limited_with clause must
253 -- create an abbreviated view of the package, without performing any
254 -- semantic analysis on it. This "package abstract" contains shadow types
255 -- that are in one-one correspondence with the real types in the package,
256 -- and that have the properties of incomplete types.
258 -- The implementation creates two element lists: one to chain the shadow
259 -- entities, and one to chain the corresponding type entities in the tree
260 -- of the package. Links between corresponding entities in both chains
261 -- allow the compiler to select the proper view of a given type, depending
262 -- on the context. Note that in contrast with the handling of private
263 -- types, the limited view and the nonlimited view of a type are treated
264 -- as separate entities, and no entity exchange needs to take place, which
265 -- makes the implementation much simpler than could be feared.
267 ------------------------------
268 -- Analyze_Compilation_Unit --
269 ------------------------------
271 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
272 Unit_Node
: constant Node_Id
:= Unit
(N
);
274 procedure Check_Redundant_Withs
275 (Context_Items
: List_Id
;
276 Spec_Context_Items
: List_Id
:= No_List
);
277 -- Determine whether the context list of a compilation unit contains
278 -- redundant with clauses. When checking body clauses against spec
279 -- clauses, set Context_Items to the context list of the body and
280 -- Spec_Context_Items to that of the spec. Parent packages are not
281 -- examined for documentation purposes.
283 ---------------------------
284 -- Check_Redundant_Withs --
285 ---------------------------
287 procedure Check_Redundant_Withs
288 (Context_Items
: List_Id
;
289 Spec_Context_Items
: List_Id
:= No_List
)
293 procedure Process_Body_Clauses
294 (Context_List
: List_Id
;
297 Used_Type_Or_Elab
: out Boolean);
298 -- Examine the context clauses of a package body, trying to match the
299 -- name entity of Clause with any list element. If the match occurs
300 -- on a use package clause set Used to True, for a use type clause or
301 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
303 procedure Process_Spec_Clauses
304 (Context_List
: List_Id
;
307 Withed
: out Boolean;
308 Exit_On_Self
: Boolean := False);
309 -- Examine the context clauses of a package spec, trying to match
310 -- the name entity of Clause with any list element. If the match
311 -- occurs on a use package clause, set Used to True, for a with
312 -- package clause other than Clause, set Withed to True. Limited
313 -- with clauses, implicitly generated with clauses and withs
314 -- having pragmas Elaborate or Elaborate_All applied to them are
315 -- skipped. Exit_On_Self is used to control the search loop and
316 -- force an exit whenever Clause sees itself in the search.
318 --------------------------
319 -- Process_Body_Clauses --
320 --------------------------
322 procedure Process_Body_Clauses
323 (Context_List
: List_Id
;
326 Used_Type_Or_Elab
: out Boolean)
328 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
333 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean;
334 -- In an expanded name in a use clause, if the prefix is a renamed
335 -- package, the entity is set to the original package as a result,
336 -- when checking whether the package appears in a previous with
337 -- clause, the renaming has to be taken into account, to prevent
338 -- spurious/incorrect warnings. A common case is use of Text_IO.
344 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean is
346 return Entity
(N
) = P
347 or else (Present
(Renamed_Entity
(P
))
348 and then Entity
(N
) = Renamed_Entity
(P
));
351 -- Start of processing for Process_Body_Clauses
355 Used_Type_Or_Elab
:= False;
357 Cont_Item
:= First
(Context_List
);
358 while Present
(Cont_Item
) loop
360 -- Package use clause
362 if Nkind
(Cont_Item
) = N_Use_Package_Clause
365 -- Search through use clauses
367 Use_Item
:= Name
(Cont_Item
);
369 -- Case of a direct use of the one we are looking for
371 if Entity
(Use_Item
) = Nam_Ent
then
374 -- Handle nested case, as in "with P; use P.Q.R"
381 -- Loop through prefixes looking for match
384 while Nkind
(UE
) = N_Expanded_Name
loop
385 if Same_Unit
(Prefix
(UE
), Nam_Ent
) then
397 elsif Nkind
(Cont_Item
) = N_Use_Type_Clause
398 and then not Used_Type_Or_Elab
404 -- Loop through prefixes looking for a match
406 UE
:= Prefix
(Subtype_Mark
(Cont_Item
));
408 if not Used_Type_Or_Elab
409 and then Same_Unit
(UE
, Nam_Ent
)
411 Used_Type_Or_Elab
:= True;
414 exit when Nkind
(UE
) /= N_Expanded_Name
;
419 -- Pragma Elaborate or Elaborate_All
421 elsif Nkind
(Cont_Item
) = N_Pragma
423 Pragma_Name_Unmapped
(Cont_Item
)
424 in Name_Elaborate | Name_Elaborate_All
425 and then not Used_Type_Or_Elab
428 First
(Pragma_Argument_Associations
(Cont_Item
));
429 while Present
(Prag_Unit
) and then not Used_Type_Or_Elab
loop
430 if Entity
(Expression
(Prag_Unit
)) = Nam_Ent
then
431 Used_Type_Or_Elab
:= True;
440 end Process_Body_Clauses
;
442 --------------------------
443 -- Process_Spec_Clauses --
444 --------------------------
446 procedure Process_Spec_Clauses
447 (Context_List
: List_Id
;
450 Withed
: out Boolean;
451 Exit_On_Self
: Boolean := False)
453 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
460 Cont_Item
:= First
(Context_List
);
461 while Present
(Cont_Item
) loop
463 -- Stop the search since the context items after Cont_Item have
464 -- already been examined in a previous iteration of the reverse
465 -- loop in Check_Redundant_Withs.
468 and Cont_Item
= Clause
473 -- Package use clause
475 if Nkind
(Cont_Item
) = N_Use_Package_Clause
478 if Entity
(Name
(Cont_Item
)) = Nam_Ent
then
482 -- Package with clause. Avoid processing self, implicitly
483 -- generated with clauses or limited with clauses. Note that
484 -- we examine with clauses having pragmas Elaborate or
485 -- Elaborate_All applied to them due to cases such as:
489 -- pragma Elaborate (Pack);
491 -- In this case, the second with clause is redundant since
492 -- the pragma applies only to the first "with Pack;".
494 -- Note that we only consider with_clauses that comes from
495 -- source. In the case of renamings used as prefixes of names
496 -- in with_clauses, we generate a with_clause for the prefix,
497 -- which we do not treat as implicit because it is needed for
498 -- visibility analysis, but is also not redundant.
500 elsif Nkind
(Cont_Item
) = N_With_Clause
501 and then Comes_From_Source
(Cont_Item
)
502 and then not Implicit_With
(Cont_Item
)
503 and then not Limited_Present
(Cont_Item
)
504 and then Cont_Item
/= Clause
505 and then Entity
(Name
(Cont_Item
)) = Nam_Ent
512 end Process_Spec_Clauses
;
514 -- Start of processing for Check_Redundant_Withs
517 Clause
:= Last
(Context_Items
);
518 while Present
(Clause
) loop
520 -- Avoid checking implicitly generated with clauses, limited with
521 -- clauses or withs that have pragma Elaborate or Elaborate_All.
523 if Nkind
(Clause
) = N_With_Clause
524 and then not Implicit_With
(Clause
)
525 and then not Limited_Present
(Clause
)
526 and then not Elaborate_Present
(Clause
)
528 -- With_clauses introduced for renamings of parent clauses
529 -- are not marked implicit because they need to be properly
530 -- installed, but they do not come from source and do not
533 and then Comes_From_Source
(Clause
)
535 -- Package body-to-spec check
537 if Present
(Spec_Context_Items
) then
539 Used_In_Body
: Boolean;
540 Used_In_Spec
: Boolean;
541 Used_Type_Or_Elab
: Boolean;
542 Withed_In_Spec
: Boolean;
546 (Context_List
=> Spec_Context_Items
,
548 Used
=> Used_In_Spec
,
549 Withed
=> Withed_In_Spec
);
552 (Context_List
=> Context_Items
,
554 Used
=> Used_In_Body
,
555 Used_Type_Or_Elab
=> Used_Type_Or_Elab
);
557 -- "Type Elab" refers to the presence of either a use
558 -- type clause, pragmas Elaborate or Elaborate_All.
560 -- +---------------+---------------------------+------+
561 -- | Spec | Body | Warn |
562 -- +--------+------+--------+------+-----------+------+
563 -- | Withed | Used | Withed | Used | Type Elab | |
564 -- | X | | X | | | X |
565 -- | X | | X | X | | |
566 -- | X | | X | | X | |
567 -- | X | | X | X | X | |
568 -- | X | X | X | | | X |
569 -- | X | X | X | | X | |
570 -- | X | X | X | X | | X |
571 -- | X | X | X | X | X | |
572 -- +--------+------+--------+------+-----------+------+
575 and then not Used_Type_Or_Elab
)
577 ((not Used_In_Spec
and then not Used_In_Body
)
578 or else Used_In_Spec
)
580 Error_Msg_N
-- CODEFIX
581 ("redundant with clause in body?r?", Clause
);
585 -- Standalone package spec or body check
588 if Is_Ancestor_Package
(Entity
(Name
(Clause
)),
589 Defining_Entity
(Unit_Node
))
592 ("unnecessary with of ancestor?r?", Clause
);
596 Dummy
: Boolean := False;
597 Withed
: Boolean := False;
600 -- The mechanism for examining the context clauses of a
601 -- package spec can be applied to package body clauses.
604 (Context_List
=> Context_Items
,
608 Exit_On_Self
=> True);
611 Error_Msg_N
-- CODEFIX
612 ("redundant with clause?r?", Clause
);
620 end Check_Redundant_Withs
;
624 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
625 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
626 Par_Spec_Name
: Unit_Name_Type
;
628 Unum
: Unit_Number_Type
;
630 -- Start of processing for Analyze_Compilation_Unit
633 Exp_Put_Image
.Preload_Root_Buffer_Type
(N
);
635 Process_Compilation_Unit_Pragmas
(N
);
637 -- If the unit is a subunit whose parent has not been analyzed (which
638 -- indicates that the main unit is a subunit, either the current one or
639 -- one of its descendants) then the subunit is compiled as part of the
640 -- analysis of the parent, which we proceed to do. Basically this gets
641 -- handled from the top down and we don't want to do anything at this
642 -- level (i.e. this subunit will be handled on the way down from the
643 -- parent), so at this level we immediately return. If the subunit ends
644 -- up not analyzed, it means that the parent did not contain a stub for
645 -- it, or that there errors were detected in some ancestor.
647 if Nkind
(Unit_Node
) = N_Subunit
and then not Analyzed
(Lib_Unit
) then
648 Semantics
(Lib_Unit
);
650 if not Analyzed
(Proper_Body
(Unit_Node
)) then
651 if Serious_Errors_Detected
> 0 then
652 Error_Msg_N
("subunit not analyzed (errors in parent unit)", N
);
654 Error_Msg_N
("missing stub for subunit", N
);
661 -- Analyze context (this will call Sem recursively for with'ed units) To
662 -- detect circularities among with-clauses that are not caught during
663 -- loading, we set the Context_Pending flag on the current unit. If the
664 -- flag is already set there is a potential circularity. We exclude
665 -- predefined units from this check because they are known to be safe.
666 -- We also exclude package bodies that are present because circularities
667 -- between bodies are harmless (and necessary).
669 if Context_Pending
(N
) then
671 Circularity
: Boolean := True;
674 if In_Predefined_Unit
(N
) then
675 Circularity
:= False;
678 for U
in Main_Unit
+ 1 .. Last_Unit
loop
679 if Nkind
(Unit
(Cunit
(U
))) = N_Package_Body
680 and then not Analyzed
(Cunit
(U
))
682 Circularity
:= False;
689 Error_Msg_N
("circular dependency caused by with_clauses", N
);
691 ("\possibly missing limited_with clause"
692 & " in one of the following", N
);
694 for U
in Main_Unit
.. Last_Unit
loop
695 if Context_Pending
(Cunit
(U
)) then
696 Error_Msg_Unit_1
:= Get_Unit_Name
(Unit
(Cunit
(U
)));
697 Error_Msg_N
("\unit$", N
);
701 raise Unrecoverable_Error
;
705 Set_Context_Pending
(N
);
710 Set_Context_Pending
(N
, False);
712 -- If the unit is a package body, the spec is already loaded and must be
713 -- analyzed first, before we analyze the body.
715 if Nkind
(Unit_Node
) = N_Package_Body
then
717 -- If no Lib_Unit, then there was a serious previous error, so just
718 -- ignore the entire analysis effort.
720 if No
(Lib_Unit
) then
721 Check_Error_Detected
;
725 -- Analyze the package spec
727 Semantics
(Lib_Unit
);
729 -- Check for unused with's
731 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
733 -- Verify that the library unit is a package declaration
735 if Nkind
(Unit
(Lib_Unit
)) not in
736 N_Package_Declaration | N_Generic_Package_Declaration
739 ("no legal package declaration for package body", N
);
742 -- Otherwise, the entity in the declaration is visible. Update the
743 -- version to reflect dependence of this body on the spec.
746 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
747 Set_Is_Immediately_Visible
(Spec_Id
, True);
748 Version_Update
(N
, Lib_Unit
);
750 if Nkind
(Defining_Unit_Name
(Unit_Node
)) =
751 N_Defining_Program_Unit_Name
753 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
758 -- If the unit is a subprogram body, then we similarly need to analyze
759 -- its spec. However, things are a little simpler in this case, because
760 -- here, this analysis is done mostly for error checking and consistency
761 -- purposes (but not only, e.g. there could be a contract on the spec),
762 -- so there's nothing else to be done.
764 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
765 if Acts_As_Spec
(N
) then
767 -- If the subprogram body is a child unit, we must create a
768 -- declaration for it, in order to properly load the parent(s).
769 -- After this, the original unit does not acts as a spec, because
770 -- there is an explicit one. If this unit appears in a context
771 -- clause, then an implicit with on the parent will be added when
772 -- installing the context. If this is the main unit, there is no
773 -- Unit_Table entry for the declaration (it has the unit number
774 -- of the main unit) and code generation is unaffected.
776 Unum
:= Get_Cunit_Unit_Number
(N
);
777 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
779 if Present
(Par_Spec_Name
) then
782 (Load_Name
=> Par_Spec_Name
,
787 if Unum
/= No_Unit
then
789 -- Build subprogram declaration and attach parent unit to it
790 -- This subprogram declaration does not come from source,
791 -- Nevertheless the backend must generate debugging info for
792 -- it, and this must be indicated explicitly. We also mark
793 -- the body entity as a child unit now, to prevent a
794 -- cascaded error if the spec entity cannot be entered
795 -- in its scope. Finally we create a Units table entry for
796 -- the subprogram declaration, to maintain a one-to-one
797 -- correspondence with compilation unit nodes. This is
798 -- critical for the tree traversals performed by CodePeer.
801 Loc
: constant Source_Ptr
:= Sloc
(N
);
802 SCS
: constant Boolean :=
803 Get_Comes_From_Source_Default
;
806 Set_Comes_From_Source_Default
(False);
808 -- Note: We copy the Context_Items from the explicit body
809 -- to the implicit spec, setting the former to Empty_List
810 -- to preserve the treeish nature of the tree, during
811 -- analysis of the spec. Then we put it back the way it
812 -- was -- copy the Context_Items from the spec to the
813 -- body, and set the spec Context_Items to Empty_List.
814 -- It is necessary to preserve the treeish nature,
815 -- because otherwise we will call End_Use_* twice on the
819 Make_Compilation_Unit
(Loc
,
820 Context_Items
=> Context_Items
(N
),
822 Make_Subprogram_Declaration
(Sloc
(N
),
825 (Specification
(Unit_Node
))),
827 Make_Compilation_Unit_Aux
(Loc
));
829 Set_Context_Items
(N
, Empty_List
);
830 Set_Library_Unit
(N
, Lib_Unit
);
831 Set_Parent_Spec
(Unit
(Lib_Unit
), Cunit
(Unum
));
832 Make_Child_Decl_Unit
(N
);
833 Semantics
(Lib_Unit
);
835 -- Now that a separate declaration exists, the body
836 -- of the child unit does not act as spec any longer.
838 Set_Acts_As_Spec
(N
, False);
839 Move_Aspects
(From
=> Unit_Node
, To
=> Unit
(Lib_Unit
));
840 Set_Is_Child_Unit
(Defining_Entity
(Unit_Node
));
841 Set_Debug_Info_Needed
(Defining_Entity
(Unit
(Lib_Unit
)));
842 Set_Comes_From_Source_Default
(SCS
);
844 -- Restore Context_Items to the body
846 Set_Context_Items
(N
, Context_Items
(Lib_Unit
));
847 Set_Context_Items
(Lib_Unit
, Empty_List
);
852 -- Here for subprogram with separate declaration
855 Semantics
(Lib_Unit
);
856 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
857 Version_Update
(N
, Lib_Unit
);
860 -- If this is a child unit, generate references to the parents
862 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
863 N_Defining_Program_Unit_Name
865 Generate_Parent_References
866 (Specification
(Unit_Node
),
867 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
871 -- If it is a child unit, the parent must be elaborated first and we
872 -- update version, since we are dependent on our parent.
874 if Is_Child_Spec
(Unit_Node
) then
876 -- The analysis of the parent is done with style checks off
879 Save_Style_Check
: constant Boolean := Style_Check
;
882 if not GNAT_Mode
then
883 Style_Check
:= False;
886 Semantics
(Parent_Spec
(Unit_Node
));
887 Version_Update
(N
, Parent_Spec
(Unit_Node
));
889 -- Restore style check settings
891 Style_Check
:= Save_Style_Check
;
895 -- With the analysis done, install the context. Note that we can't
896 -- install the context from the with clauses as we analyze them, because
897 -- each with clause must be analyzed in a clean visibility context, so
898 -- we have to wait and install them all at once.
902 if Is_Child_Spec
(Unit_Node
) then
904 -- Set the entities of all parents in the program_unit_name
906 Generate_Parent_References
907 (Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
910 -- All components of the context: with-clauses, library unit, ancestors
911 -- if any, (and their context) are analyzed and installed.
913 -- Call special debug routine sm if this is the main unit
915 if Current_Sem_Unit
= Main_Unit
then
919 -- Now analyze the unit (package, subprogram spec, body) itself
923 if Warn_On_Redundant_Constructs
then
924 Check_Redundant_Withs
(Context_Items
(N
));
926 if Nkind
(Unit_Node
) = N_Package_Body
then
927 Check_Redundant_Withs
928 (Context_Items
=> Context_Items
(N
),
929 Spec_Context_Items
=> Context_Items
(Lib_Unit
));
933 -- The above call might have made Unit_Node an N_Subprogram_Body from
934 -- something else, so propagate any Acts_As_Spec flag.
936 if Nkind
(Unit_Node
) = N_Subprogram_Body
937 and then Acts_As_Spec
(Unit_Node
)
939 Set_Acts_As_Spec
(N
);
942 -- Register predefined units in Rtsfind
944 if In_Predefined_Unit
(N
) then
945 Set_RTU_Loaded
(Unit_Node
);
948 -- Treat compilation unit pragmas that appear after the library unit
951 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
953 while Present
(Prag_Node
) loop
959 -- Analyze the contract of a [generic] subprogram that acts as a
960 -- compilation unit after all compilation pragmas have been analyzed.
962 if Nkind
(Unit_Node
) in
963 N_Generic_Subprogram_Declaration | N_Subprogram_Declaration
965 Analyze_Entry_Or_Subprogram_Contract
(Defining_Entity
(Unit_Node
));
968 -- Generate distribution stubs if requested and no error
971 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
973 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
974 and then Fatal_Error
(Main_Unit
) /= Error_Detected
976 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
978 -- Regular RCI package
980 Add_Stub_Constructs
(N
);
982 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
983 and then Is_Shared_Passive
(Defining_Entity
984 (Specification
(Unit_Node
))))
985 or else (Nkind
(Unit_Node
) = N_Package_Body
987 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
989 -- Shared passive package
991 Add_Stub_Constructs
(N
);
993 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
995 Is_Remote_Call_Interface
996 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
998 -- Instantiation of a RCI generic package
1000 Add_Stub_Constructs
(N
);
1004 -- Build dispatch tables of library-level tagged types only now because
1005 -- the generation of distribution stubs above may create some of them.
1007 if Expander_Active
and then Tagged_Type_Expansion
then
1008 case Nkind
(Unit_Node
) is
1009 when N_Package_Declaration | N_Package_Body
=>
1010 Build_Static_Dispatch_Tables
(Unit_Node
);
1012 when N_Package_Instantiation
=>
1013 Build_Static_Dispatch_Tables
(Instance_Spec
(Unit_Node
));
1020 -- Remove unit from visibility, so that environment is clean for the
1021 -- next compilation, which is either the main unit or some other unit
1024 if Nkind
(Unit_Node
) in N_Package_Declaration
1025 | N_Package_Renaming_Declaration
1026 | N_Subprogram_Declaration
1027 | N_Generic_Declaration
1028 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
1029 and then Acts_As_Spec
(Unit_Node
))
1031 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
1033 -- If the unit is an instantiation whose body will be elaborated for
1034 -- inlining purposes, use the proper entity of the instance. The entity
1035 -- may be missing if the instantiation was illegal.
1037 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
1038 and then not Error_Posted
(Unit_Node
)
1039 and then Present
(Instance_Spec
(Unit_Node
))
1041 Remove_Unit_From_Visibility
1042 (Defining_Entity
(Instance_Spec
(Unit_Node
)));
1044 elsif Nkind
(Unit_Node
) = N_Package_Body
1045 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
1046 and then not Acts_As_Spec
(Unit_Node
))
1048 -- Bodies that are not the main unit are compiled if they are generic
1049 -- or contain generic or inlined units. Their analysis brings in the
1050 -- context of the corresponding spec (unit declaration) which must be
1051 -- removed as well, to return the compilation environment to its
1054 Remove_Context
(Lib_Unit
);
1055 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
1058 -- Last step is to deinstall the context we just installed as well as
1059 -- the unit just compiled.
1063 -- When generating code for a non-generic main unit, check that withed
1064 -- generic units have a body if they need it, even if the units have not
1065 -- been instantiated. Force the load of the bodies to produce the proper
1066 -- error if the body is absent. The same applies to GNATprove mode, with
1067 -- the added benefit of capturing global references within the generic.
1068 -- This in turn allows for proper inlining of subprogram bodies without
1069 -- a previous declaration.
1071 if Get_Cunit_Unit_Number
(N
) = Main_Unit
1072 and then ((Operating_Mode
= Generate_Code
and then Expander_Active
)
1074 (Operating_Mode
= Check_Semantics
and then GNATprove_Mode
))
1076 -- Check whether the source for the body of the unit must be included
1077 -- in a standalone library.
1079 Check_Body_Needed_For_SAL
(Cunit_Entity
(Main_Unit
));
1081 -- Indicate that the main unit is now analyzed, to catch possible
1082 -- circularities between it and generic bodies. Remove main unit from
1083 -- visibility. This might seem superfluous, but the main unit must
1084 -- not be visible in the generic body expansions that follow.
1086 Set_Analyzed
(N
, True);
1087 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
1092 Un
: Unit_Number_Type
;
1094 Save_Style_Check
: constant Boolean := Style_Check
;
1097 Item
:= First
(Context_Items
(N
));
1098 while Present
(Item
) loop
1100 -- Check for explicit with clause
1102 if Nkind
(Item
) = N_With_Clause
1103 and then not Implicit_With
(Item
)
1105 -- Ada 2005 (AI-50217): Ignore limited-withed units
1107 and then not Limited_Present
(Item
)
1109 Nam
:= Entity
(Name
(Item
));
1111 -- Compile the generic subprogram, unless it is intrinsic or
1112 -- imported so no body is required, or generic package body
1113 -- if the package spec requires a body.
1115 if (Is_Generic_Subprogram
(Nam
)
1116 and then not Is_Intrinsic_Subprogram
(Nam
)
1117 and then not Is_Imported
(Nam
))
1118 or else (Ekind
(Nam
) = E_Generic_Package
1119 and then Unit_Requires_Body
(Nam
))
1121 Style_Check
:= False;
1123 if Present
(Renamed_Entity
(Nam
)) then
1129 (Unit_Declaration_Node
1130 (Renamed_Entity
(Nam
)))),
1139 Get_Body_Name
(Get_Unit_Name
(Item
)),
1146 if Un
= No_Unit
then
1148 ("body of generic unit& not found", Item
, Nam
);
1151 elsif not Analyzed
(Cunit
(Un
))
1152 and then Un
/= Main_Unit
1153 and then Fatal_Error
(Un
) /= Error_Detected
1155 Style_Check
:= False;
1156 Semantics
(Cunit
(Un
));
1164 -- Restore style checks settings
1166 Style_Check
:= Save_Style_Check
;
1169 -- In GNATprove mode, force the loading of an Interrupt_Priority when
1170 -- processing compilation units with potentially "main" subprograms.
1171 -- This is required for the ceiling priority protocol checks, which
1172 -- are triggered by these subprograms.
1175 and then Nkind
(Unit_Node
) in N_Function_Instantiation
1176 | N_Procedure_Instantiation
1183 case Nkind
(Unit_Node
) is
1184 when N_Subprogram_Body
=>
1185 Spec
:= Specification
(Unit_Node
);
1187 when N_Subprogram_Instantiation
=>
1189 Subprogram_Specification
(Entity
(Name
(Unit_Node
)));
1192 raise Program_Error
;
1195 pragma Assert
(Nkind
(Spec
) in N_Subprogram_Specification
);
1197 -- Main subprogram must have no parameters, and if it is a
1198 -- function, it must return an integer.
1200 if No
(Parameter_Specifications
(Spec
))
1201 and then (Nkind
(Spec
) = N_Procedure_Specification
1203 Is_Integer_Type
(Etype
(Result_Definition
(Spec
))))
1205 SPARK_Implicit_Load
(RE_Interrupt_Priority
);
1211 -- Deal with creating elaboration counter if needed. We create an
1212 -- elaboration counter only for units that come from source since
1213 -- units manufactured by the compiler never need elab checks.
1215 if Comes_From_Source
(N
)
1216 and then Nkind
(Unit_Node
) in N_Package_Declaration
1217 | N_Generic_Package_Declaration
1218 | N_Subprogram_Declaration
1219 | N_Generic_Subprogram_Declaration
1222 Loc
: constant Source_Ptr
:= Sloc
(N
);
1223 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
1226 Spec_Id
:= Defining_Entity
(Unit_Node
);
1227 Generate_Definition
(Spec_Id
);
1229 -- See if an elaboration entity is required for possible access
1230 -- before elaboration checking. Note that we must allow for this
1231 -- even if -gnatE is not set, since a client may be compiled in
1232 -- -gnatE mode and reference the entity.
1234 -- These entities are also used by the binder to prevent multiple
1235 -- attempts to execute the elaboration code for the library case
1236 -- where the elaboration routine might otherwise be called more
1239 -- They are also needed to ensure explicit visibility from the
1240 -- binder generated code of all the units involved in a partition
1241 -- when control-flow preservation is requested.
1243 if not Opt
.Suppress_Control_Flow_Optimizations
1245 ( -- Pure units do not need checks
1249 -- Preelaborated units do not need checks
1251 or else Is_Preelaborated
(Spec_Id
)
1253 -- No checks needed if pragma Elaborate_Body present
1255 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
1257 -- No checks needed if unit does not require a body
1259 or else not Unit_Requires_Body
(Spec_Id
)
1261 -- No checks needed for predefined files
1263 or else Is_Predefined_Unit
(Unum
)
1265 -- No checks required if no separate spec
1267 or else Acts_As_Spec
(N
)
1270 -- This is a case where we only need the entity for checking to
1271 -- prevent multiple elaboration checks.
1273 Set_Elaboration_Entity_Required
(Spec_Id
, False);
1275 -- Otherwise the unit requires an elaboration entity because it
1279 Set_Elaboration_Entity_Required
(Spec_Id
);
1282 Build_Elaboration_Entity
(N
, Spec_Id
);
1286 -- Freeze the compilation unit entity. This for sure is needed because
1287 -- of some warnings that can be output (see Freeze_Subprogram), but may
1288 -- in general be required. If freezing actions result, place them in the
1289 -- compilation unit actions list, and analyze them.
1292 L
: constant List_Id
:=
1293 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), N
);
1295 while Is_Non_Empty_List
(L
) loop
1296 Insert_Library_Level_Action
(Remove_Head
(L
));
1302 -- Call Check_Package_Body so that a body containing subprograms with
1303 -- Inline_Always can be made available for front end inlining.
1305 if Nkind
(Unit_Node
) = N_Package_Declaration
1306 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
1308 -- We don't need to do this if the Expander is not active, since there
1309 -- is no code to inline.
1311 and then Expander_Active
1314 Save_Style_Check
: constant Boolean := Style_Check
;
1315 Save_Warning
: constant Warning_Mode_Type
:= Warning_Mode
;
1316 Options
: Style_Check_Options
;
1319 Save_Style_Check_Options
(Options
);
1320 Reset_Style_Check_Options
;
1321 Opt
.Warning_Mode
:= Suppress
;
1323 Check_Package_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
1325 Reset_Style_Check_Options
;
1326 Set_Style_Check_Options
(Options
);
1327 Style_Check
:= Save_Style_Check
;
1328 Warning_Mode
:= Save_Warning
;
1332 -- If we are generating obsolescent warnings, then here is where we
1333 -- generate them for the with'ed items. The reason for this special
1334 -- processing is that the normal mechanism of generating the warnings
1335 -- for referenced entities does not work for context clause references.
1336 -- That's because when we first analyze the context, it is too early to
1337 -- know if the with'ing unit is itself obsolescent (which suppresses
1341 and then Warn_On_Obsolescent_Feature
1342 and then Nkind
(Unit_Node
) not in N_Generic_Instantiation
1344 -- Push current compilation unit as scope, so that the test for
1345 -- being within an obsolescent unit will work correctly. The check
1346 -- is not performed within an instantiation, because the warning
1347 -- will have been emitted in the corresponding generic unit.
1349 Push_Scope
(Defining_Entity
(Unit_Node
));
1351 -- Loop through context items to deal with with clauses
1359 Item
:= First
(Context_Items
(N
));
1360 while Present
(Item
) loop
1361 if Nkind
(Item
) = N_With_Clause
1363 -- Suppress this check in limited-withed units. Further work
1364 -- needed here if we decide to incorporate this check on
1365 -- limited-withed units.
1367 and then not Limited_Present
(Item
)
1370 Ent
:= Entity
(Nam
);
1372 if Is_Obsolescent
(Ent
) then
1373 Output_Obsolescent_Entity_Warnings
(Nam
, Ent
);
1381 -- Remove temporary install of current unit as scope
1386 -- If No_Elaboration_Code_All was encountered, this is where we do the
1387 -- transitive test of with'ed units to make sure they have the aspect.
1388 -- This is delayed till the end of analyzing the compilation unit to
1389 -- ensure that the pragma/aspect, if present, has been analyzed.
1391 Check_No_Elab_Code_All
(N
);
1392 end Analyze_Compilation_Unit
;
1394 ---------------------
1395 -- Analyze_Context --
1396 ---------------------
1398 procedure Analyze_Context
(N
: Node_Id
) is
1399 Ukind
: constant Node_Kind
:= Nkind
(Unit
(N
));
1403 -- First process all configuration pragmas at the start of the context
1404 -- items. Strictly these are not part of the context clause, but that
1405 -- is where the parser puts them. In any case for sure we must analyze
1406 -- these before analyzing the actual context items, since they can have
1407 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1408 -- be with'ed as a result of changing categorizations in Ada 2005).
1410 Item
:= First
(Context_Items
(N
));
1411 while Present
(Item
)
1412 and then Nkind
(Item
) = N_Pragma
1413 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
1419 -- This is the point at which we capture the configuration settings
1420 -- for the unit. At the moment only the Optimize_Alignment setting
1421 -- needs to be captured. Probably more later ???
1423 if Optimize_Alignment_Local
then
1424 Set_OA_Setting
(Current_Sem_Unit
, 'L');
1426 Set_OA_Setting
(Current_Sem_Unit
, Optimize_Alignment
);
1429 -- Loop through actual context items. This is done in two passes:
1431 -- a) The first pass analyzes nonlimited with clauses and also any
1432 -- configuration pragmas (we need to get the latter analyzed right
1433 -- away, since they can affect processing of subsequent items).
1435 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1437 while Present
(Item
) loop
1439 -- For with clause, analyze the with clause, and then update the
1440 -- version, since we are dependent on a unit that we with.
1442 if Nkind
(Item
) = N_With_Clause
1443 and then not Limited_Present
(Item
)
1445 -- Skip analyzing with clause if no unit, nothing to do (this
1446 -- happens for a with that references a non-existent unit).
1448 if Present
(Library_Unit
(Item
)) then
1450 -- Skip analyzing with clause if this is a with_clause for
1451 -- the main unit, which happens if a subunit has a useless
1452 -- with_clause on its parent.
1454 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
) then
1457 -- Here for the case of a useless with for the main unit
1460 Set_Entity
(Name
(Item
), Cunit_Entity
(Current_Sem_Unit
));
1464 -- Do version update (skipped for implicit with)
1466 if not Implicit_With
(Item
) then
1467 Version_Update
(N
, Library_Unit
(Item
));
1470 -- Skip pragmas. Configuration pragmas at the start were handled in
1471 -- the loop above, and remaining pragmas are not processed until we
1472 -- actually install the context (see Install_Context). We delay the
1473 -- analysis of these pragmas to make sure that we have installed all
1474 -- the implicit with's on parent units.
1476 -- Skip use clauses at this stage, since we don't want to do any
1477 -- installing of potentially use-visible entities until we
1478 -- actually install the complete context (in Install_Context).
1479 -- Otherwise things can get installed in the wrong context.
1488 -- Second pass: examine all limited_with clauses. All other context
1489 -- items are ignored in this pass.
1491 Item
:= First
(Context_Items
(N
));
1492 while Present
(Item
) loop
1493 if Nkind
(Item
) = N_With_Clause
1494 and then Limited_Present
(Item
)
1496 -- No need to check errors on implicitly generated limited-with
1499 if not Implicit_With
(Item
) then
1501 -- Verify that the illegal contexts given in 10.1.2 (18/2) are
1502 -- properly rejected, including renaming declarations.
1504 if Ukind
not in N_Package_Declaration
1505 | N_Subprogram_Declaration
1506 | N_Generic_Declaration
1507 | N_Generic_Instantiation
1509 Error_Msg_N
("limited with_clause not allowed here", Item
);
1511 -- Check wrong use of a limited with clause applied to the
1512 -- compilation unit containing the limited-with clause.
1514 -- limited with P.Q;
1515 -- package P.Q is ...
1517 elsif Unit
(Library_Unit
(Item
)) = Unit
(N
) then
1518 Error_Msg_N
("wrong use of limited-with clause", Item
);
1520 -- Check wrong use of limited-with clause applied to some
1521 -- immediate ancestor.
1523 elsif Is_Child_Spec
(Unit
(N
)) then
1525 Lib_U
: constant Entity_Id
:= Unit
(Library_Unit
(Item
));
1529 P
:= Parent_Spec
(Unit
(N
));
1531 if Unit
(P
) = Lib_U
then
1533 ("limited with_clause cannot name ancestor",
1538 exit when not Is_Child_Spec
(Unit
(P
));
1539 P
:= Parent_Spec
(Unit
(P
));
1544 -- Check if the limited-withed unit is already visible through
1545 -- some context clause of the current compilation unit or some
1546 -- ancestor of the current compilation unit.
1549 Lim_Unit_Name
: constant Node_Id
:= Name
(Item
);
1550 Comp_Unit
: Node_Id
;
1552 Unit_Name
: Node_Id
;
1557 It
:= First
(Context_Items
(Comp_Unit
));
1558 while Present
(It
) loop
1560 and then Nkind
(It
) = N_With_Clause
1561 and then not Limited_Present
(It
)
1562 and then Nkind
(Unit
(Library_Unit
(It
))) in
1563 N_Package_Declaration |
1564 N_Package_Renaming_Declaration
1566 if Nkind
(Unit
(Library_Unit
(It
))) =
1567 N_Package_Declaration
1569 Unit_Name
:= Name
(It
);
1571 Unit_Name
:= Name
(Unit
(Library_Unit
(It
)));
1574 -- Check if the named package (or some ancestor)
1575 -- leaves visible the full-view of the unit given
1576 -- in the limited-with clause.
1579 if Designate_Same_Unit
(Lim_Unit_Name
,
1582 Error_Msg_Sloc
:= Sloc
(It
);
1584 ("simultaneous visibility of limited and "
1585 & "unlimited views not allowed", Item
);
1587 ("\unlimited view visible through context "
1588 & "clause #", Item
);
1591 elsif Nkind
(Unit_Name
) = N_Identifier
then
1595 Unit_Name
:= Prefix
(Unit_Name
);
1602 exit when not Is_Child_Spec
(Unit
(Comp_Unit
));
1604 Comp_Unit
:= Parent_Spec
(Unit
(Comp_Unit
));
1609 -- Skip analyzing with clause if no unit, see above
1611 if Present
(Library_Unit
(Item
)) then
1615 -- A limited_with does not impose an elaboration order, but there
1616 -- is a semantic dependency for recompilation purposes.
1618 if not Implicit_With
(Item
) then
1619 Version_Update
(N
, Library_Unit
(Item
));
1622 -- Pragmas and use clauses and with clauses other than limited with's
1623 -- are ignored in this pass through the context items.
1631 end Analyze_Context
;
1633 -------------------------------
1634 -- Analyze_Package_Body_Stub --
1635 -------------------------------
1637 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
1638 Id
: constant Entity_Id
:= Defining_Entity
(N
);
1640 Opts
: Config_Switches_Type
;
1643 -- The package declaration must be in the current declarative part
1645 Check_Stub_Level
(N
);
1646 Nam
:= Current_Entity_In_Scope
(Id
);
1648 if No
(Nam
) or else not Is_Package_Or_Generic_Package
(Nam
) then
1649 Error_Msg_N
("missing specification for package stub", N
);
1651 elsif Has_Completion
(Nam
)
1652 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
1654 Error_Msg_N
("duplicate or redundant stub for package", N
);
1657 -- Retain and restore the configuration options of the enclosing
1658 -- context as the proper body may introduce a set of its own.
1660 Opts
:= Save_Config_Switches
;
1662 -- Indicate that the body of the package exists. If we are doing
1663 -- only semantic analysis, the stub stands for the body. If we are
1664 -- generating code, the existence of the body will be confirmed
1665 -- when we load the proper body.
1667 Set_Scope
(Id
, Current_Scope
);
1668 Mutate_Ekind
(Id
, E_Package_Body
);
1669 Set_Etype
(Id
, Standard_Void_Type
);
1671 if Has_Aspects
(N
) then
1672 Analyze_Aspect_Specifications
(N
, Id
);
1675 Set_Has_Completion
(Nam
);
1676 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
1677 Generate_Reference
(Nam
, Id
, 'b');
1678 Analyze_Proper_Body
(N
, Nam
);
1680 Restore_Config_Switches
(Opts
);
1682 end Analyze_Package_Body_Stub
;
1684 -------------------------
1685 -- Analyze_Proper_Body --
1686 -------------------------
1688 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
1689 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
1691 procedure Optional_Subunit
;
1692 -- This procedure is called when the main unit is a stub, or when we
1693 -- are not generating code. In such a case, we analyze the subunit if
1694 -- present, which is user-friendly, but we don't complain if the subunit
1695 -- is missing. In GNATprove_Mode, we issue an error to avoid formal
1696 -- verification of a partial unit.
1698 ----------------------
1699 -- Optional_Subunit --
1700 ----------------------
1702 procedure Optional_Subunit
is
1703 Comp_Unit
: Node_Id
;
1704 Unum
: Unit_Number_Type
;
1707 -- Try to load subunit, but ignore any errors that occur during the
1708 -- loading of the subunit, by using the special feature in Errout to
1709 -- ignore all errors. Note that Fatal_Error will still be set, so we
1710 -- will be able to check for this case below.
1712 if not GNATprove_Mode
then
1713 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
1718 (Load_Name
=> Subunit_Name
,
1719 Required
=> GNATprove_Mode
,
1723 if not GNATprove_Mode
then
1724 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
1727 -- All done if we successfully loaded the subunit
1730 and then (Fatal_Error
(Unum
) /= Error_Detected
1731 or else Try_Semantics
)
1733 Comp_Unit
:= Cunit
(Unum
);
1735 -- If the file was empty or seriously mangled, the unit itself may
1738 if No
(Unit
(Comp_Unit
)) then
1740 ("subunit does not contain expected proper body", N
);
1742 elsif Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1744 ("expected SEPARATE subunit, found child unit",
1745 Cunit_Entity
(Unum
));
1747 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1748 Analyze_Subunit
(Comp_Unit
);
1749 Set_Library_Unit
(N
, Comp_Unit
);
1750 Set_Corresponding_Body
(N
, Defining_Entity
(Unit
(Comp_Unit
)));
1753 elsif Unum
= No_Unit
1754 and then Present
(Nam
)
1756 if Is_Protected_Type
(Nam
) then
1757 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
1759 Set_Corresponding_Body
(
1760 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1763 end Optional_Subunit
;
1767 Comp_Unit
: Node_Id
;
1768 Unum
: Unit_Number_Type
;
1770 -- Start of processing for Analyze_Proper_Body
1773 -- If the subunit is already loaded, it means that the main unit is a
1774 -- subunit, and that the current unit is one of its parents which was
1775 -- being analyzed to provide the needed context for the analysis of the
1776 -- subunit. In this case we analyze the subunit and continue with the
1777 -- parent, without looking at subsequent subunits.
1779 if Is_Loaded
(Subunit_Name
) then
1781 -- If the proper body is already linked to the stub node, the stub is
1782 -- in a generic unit and just needs analyzing.
1784 if Present
(Library_Unit
(N
)) then
1785 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1787 -- If the subunit has severe errors, the spec of the enclosing
1788 -- body may not be available, in which case do not try analysis.
1790 if Serious_Errors_Detected
> 0
1791 and then No
(Library_Unit
(Library_Unit
(N
)))
1796 -- Collect SCO information for loaded subunit if we are in the
1797 -- extended main unit.
1800 and then In_Extended_Main_Source_Unit
1801 (Cunit_Entity
(Current_Sem_Unit
))
1803 SCO_Record_Raw
(Get_Cunit_Unit_Number
(Library_Unit
(N
)));
1806 Analyze_Subunit
(Library_Unit
(N
));
1808 -- Otherwise we must load the subunit and link to it
1811 -- Load the subunit, this must work, since we originally loaded
1812 -- the subunit earlier on. So this will not really load it, just
1813 -- give access to it.
1817 (Load_Name
=> Subunit_Name
,
1822 -- And analyze the subunit in the parent context (note that we
1823 -- do not call Semantics, since that would remove the parent
1824 -- context). Because of this, we have to manually reset the
1825 -- compiler state to Analyzing since it got destroyed by Load.
1827 if Unum
/= No_Unit
then
1828 Compiler_State
:= Analyzing
;
1830 -- Check that the proper body is a subunit and not a child
1831 -- unit. If the unit was previously loaded, the error will
1832 -- have been emitted when copying the generic node, so we
1833 -- just return to avoid cascaded errors.
1835 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1839 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1840 Analyze_Subunit
(Cunit
(Unum
));
1841 Set_Library_Unit
(N
, Cunit
(Unum
));
1845 -- If the main unit is a subunit, then we are just performing semantic
1846 -- analysis on that subunit, and any other subunits of any parent unit
1847 -- should be ignored. If the main unit is itself a subunit, another
1848 -- subunit is irrelevant unless it is a subunit of the current one, that
1849 -- is to say appears in the current source tree.
1851 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1852 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1854 -- But before we return, set the flag for unloaded subunits. This
1855 -- will suppress junk warnings of variables in the same declarative
1856 -- part (or a higher level one) that are in danger of looking unused
1857 -- when in fact there might be a declaration in the subunit that we
1858 -- do not intend to load.
1860 Unloaded_Subunits
:= True;
1863 -- If the subunit is not already loaded, and we are generating code,
1864 -- then this is the case where compilation started from the parent, and
1865 -- we are generating code for an entire subunit tree. In that case we
1866 -- definitely need to load the subunit.
1868 -- In order to continue the analysis with the rest of the parent,
1869 -- and other subunits, we load the unit without requiring its
1870 -- presence, and emit a warning if not found, rather than terminating
1871 -- the compilation abruptly, as for other missing file problems.
1873 elsif Original_Operating_Mode
= Generate_Code
then
1875 -- If the proper body is already linked to the stub node, the stub is
1876 -- in a generic unit and just needs analyzing.
1878 -- We update the version. Although we are not strictly technically
1879 -- semantically dependent on the subunit, given our approach of macro
1880 -- substitution of subunits, it makes sense to include it in the
1881 -- version identification.
1883 if Present
(Library_Unit
(N
)) then
1884 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1885 Analyze_Subunit
(Library_Unit
(N
));
1886 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1888 -- Otherwise we must load the subunit and link to it
1891 -- Make sure that, if the subunit is preprocessed and -gnateG is
1892 -- specified, the preprocessed file will be written.
1894 Lib
.Analysing_Subunit_Of_Main
:= True;
1897 (Load_Name
=> Subunit_Name
,
1901 Lib
.Analysing_Subunit_Of_Main
:= False;
1903 -- Give message if we did not get the unit Emit warning even if
1904 -- missing subunit is not within main unit, to simplify debugging.
1906 pragma Assert
(Original_Operating_Mode
= Generate_Code
);
1907 if Unum
= No_Unit
then
1908 Error_Msg_Unit_1
:= Subunit_Name
;
1910 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1912 ("subunit$$ in file{ not found??!!", N
);
1913 Subunits_Missing
:= True;
1916 -- Load_Unit may reset Compiler_State, since it may have been
1917 -- necessary to parse an additional units, so we make sure that
1918 -- we reset it to the Analyzing state.
1920 Compiler_State
:= Analyzing
;
1922 if Unum
/= No_Unit
then
1923 if Debug_Flag_L
then
1924 Write_Str
("*** Loaded subunit from stub. Analyze");
1928 Comp_Unit
:= Cunit
(Unum
);
1930 -- Check for child unit instead of subunit
1932 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1934 ("expected SEPARATE subunit, found child unit",
1935 Cunit_Entity
(Unum
));
1937 -- OK, we have a subunit
1940 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1941 Set_Library_Unit
(N
, Comp_Unit
);
1943 -- We update the version. Although we are not technically
1944 -- semantically dependent on the subunit, given our approach
1945 -- of macro substitution of subunits, it makes sense to
1946 -- include it in the version identification.
1948 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1950 -- Collect SCO information for loaded subunit if we are in
1951 -- the extended main unit.
1954 and then In_Extended_Main_Source_Unit
1955 (Cunit_Entity
(Current_Sem_Unit
))
1957 SCO_Record_Raw
(Unum
);
1960 -- Analyze the unit if semantics active
1962 if Fatal_Error
(Unum
) /= Error_Detected
1963 or else Try_Semantics
1965 Analyze_Subunit
(Comp_Unit
);
1971 -- The remaining case is when the subunit is not already loaded and we
1972 -- are not generating code. In this case we are just performing semantic
1973 -- analysis on the parent, and we are not interested in the subunit. For
1974 -- subprograms, analyze the stub as a body. For other entities the stub
1975 -- has already been marked as completed.
1980 end Analyze_Proper_Body
;
1982 ----------------------------------
1983 -- Analyze_Protected_Body_Stub --
1984 ----------------------------------
1986 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1987 Id
: constant Entity_Id
:= Defining_Entity
(N
);
1988 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Id
);
1989 Opts
: Config_Switches_Type
;
1992 Check_Stub_Level
(N
);
1994 -- First occurrence of name may have been as an incomplete type
1996 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1997 Nam
:= Full_View
(Nam
);
2000 if No
(Nam
) or else not Is_Protected_Type
(Etype
(Nam
)) then
2001 Error_Msg_N
("missing specification for Protected body", N
);
2004 -- Retain and restore the configuration options of the enclosing
2005 -- context as the proper body may introduce a set of its own.
2007 Opts
:= Save_Config_Switches
;
2009 Set_Scope
(Id
, Current_Scope
);
2010 Mutate_Ekind
(Id
, E_Protected_Body
);
2011 Set_Etype
(Id
, Standard_Void_Type
);
2013 if Has_Aspects
(N
) then
2014 Analyze_Aspect_Specifications
(N
, Id
);
2017 Set_Has_Completion
(Etype
(Nam
));
2018 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
2019 Generate_Reference
(Nam
, Id
, 'b');
2020 Analyze_Proper_Body
(N
, Etype
(Nam
));
2022 Restore_Config_Switches
(Opts
);
2024 end Analyze_Protected_Body_Stub
;
2026 ----------------------------------
2027 -- Analyze_Subprogram_Body_Stub --
2028 ----------------------------------
2030 -- A subprogram body stub can appear with or without a previous spec. If
2031 -- there is one, then the analysis of the body will find it and verify
2032 -- conformance. The formals appearing in the specification of the stub play
2033 -- no role, except for requiring an additional conformance check. If there
2034 -- is no previous subprogram declaration, the stub acts as a spec, and
2035 -- provides the defining entity for the subprogram.
2037 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
2039 Opts
: Config_Switches_Type
;
2042 Check_Stub_Level
(N
);
2044 -- Verify that the identifier for the stub is unique within this
2045 -- declarative part.
2047 if Nkind
(Parent
(N
)) in
2048 N_Block_Statement | N_Package_Body | N_Subprogram_Body
2050 Decl
:= First
(Declarations
(Parent
(N
)));
2051 while Present
(Decl
) and then Decl
/= N
loop
2052 if Nkind
(Decl
) = N_Subprogram_Body_Stub
2053 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
))) =
2054 Chars
(Defining_Unit_Name
(Specification
(N
))))
2056 Error_Msg_N
("identifier for stub is not unique", N
);
2063 -- Retain and restore the configuration options of the enclosing context
2064 -- as the proper body may introduce a set of its own.
2066 Opts
:= Save_Config_Switches
;
2068 -- Treat stub as a body, which checks conformance if there is a previous
2069 -- declaration, or else introduces entity and its signature.
2071 Analyze_Subprogram_Body
(N
);
2072 Analyze_Proper_Body
(N
, Empty
);
2074 Restore_Config_Switches
(Opts
);
2075 end Analyze_Subprogram_Body_Stub
;
2077 ---------------------
2078 -- Analyze_Subunit --
2079 ---------------------
2081 -- A subunit is compiled either by itself (for semantic checking) or as
2082 -- part of compiling the parent (for code generation). In either case, by
2083 -- the time we actually process the subunit, the parent has already been
2084 -- installed and analyzed. The node N is a compilation unit, whose context
2085 -- needs to be treated here, because we come directly here from the parent
2086 -- without calling Analyze_Compilation_Unit.
2088 -- The compilation context includes the explicit context of the subunit,
2089 -- and the context of the parent, together with the parent itself. In order
2090 -- to compile the current context, we remove the one inherited from the
2091 -- parent, in order to have a clean visibility table. We restore the parent
2092 -- context before analyzing the proper body itself. On exit, we remove only
2093 -- the explicit context of the subunit.
2095 -- WARNING: This routine manages SPARK regions. Return statements must be
2096 -- replaced by gotos which jump to the end of the routine and restore the
2099 procedure Analyze_Subunit
(N
: Node_Id
) is
2100 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
2101 Par_Unit
: constant Entity_Id
:= Current_Scope
;
2103 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
2104 Num_Scopes
: Nat
:= 0;
2105 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
2106 Enclosing_Child
: Entity_Id
:= Empty
;
2107 Svg
: constant Suppress_Record
:= Scope_Suppress
;
2109 Save_Cunit_Restrictions
: constant Save_Cunit_Boolean_Restrictions
:=
2110 Cunit_Boolean_Restrictions_Save
;
2111 -- Save non-partition wide restrictions before processing the subunit.
2112 -- All subunits are analyzed with config restrictions reset and we need
2113 -- to restore these saved values at the end.
2115 procedure Analyze_Subunit_Context
;
2116 -- Capture names in use clauses of the subunit. This must be done before
2117 -- re-installing parent declarations, because items in the context must
2118 -- not be hidden by declarations local to the parent.
2120 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
2121 -- Recursive procedure to restore scope of all ancestors of subunit,
2122 -- from outermost in. If parent is not a subunit, the call to install
2123 -- context installs context of spec and (if parent is a child unit) the
2124 -- context of its parents as well. It is confusing that parents should
2125 -- be treated differently in both cases, but the semantics are just not
2128 procedure Re_Install_Use_Clauses
;
2129 -- As part of the removal of the parent scope, the use clauses are
2130 -- removed, to be reinstalled when the context of the subunit has been
2131 -- analyzed. Use clauses may also have been affected by the analysis of
2132 -- the context of the subunit, so they have to be applied again, to
2133 -- insure that the compilation environment of the rest of the parent
2134 -- unit is identical.
2136 procedure Remove_Scope
;
2137 -- Remove current scope from scope stack, and preserve the list of use
2138 -- clauses in it, to be reinstalled after context is analyzed.
2140 -----------------------------
2141 -- Analyze_Subunit_Context --
2142 -----------------------------
2144 procedure Analyze_Subunit_Context
is
2146 Unit_Name
: Entity_Id
;
2149 Analyze_Context
(N
);
2150 Check_No_Elab_Code_All
(N
);
2152 -- Make withed units immediately visible. If child unit, make the
2153 -- ultimate parent immediately visible.
2155 Item
:= First
(Context_Items
(N
));
2156 while Present
(Item
) loop
2157 if Nkind
(Item
) = N_With_Clause
then
2159 -- Protect frontend against previous errors in context clauses
2161 if Nkind
(Name
(Item
)) /= N_Selected_Component
then
2162 if Error_Posted
(Item
) then
2166 -- If a subunits has serious syntax errors, the context
2167 -- may not have been loaded. Add a harmless unit name to
2168 -- attempt processing.
2170 if Serious_Errors_Detected
> 0
2171 and then No
(Entity
(Name
(Item
)))
2173 Set_Entity
(Name
(Item
), Standard_Standard
);
2176 Unit_Name
:= Entity
(Name
(Item
));
2178 Set_Is_Visible_Lib_Unit
(Unit_Name
);
2179 exit when Scope
(Unit_Name
) = Standard_Standard
;
2180 Unit_Name
:= Scope
(Unit_Name
);
2182 if No
(Unit_Name
) then
2183 Check_Error_Detected
;
2188 if not Is_Immediately_Visible
(Unit_Name
) then
2189 Set_Is_Immediately_Visible
(Unit_Name
);
2190 Set_Context_Installed
(Item
);
2195 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2196 Analyze
(Name
(Item
));
2198 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2199 Analyze
(Subtype_Mark
(Item
));
2205 -- Reset visibility of withed units. They will be made visible again
2206 -- when we install the subunit context.
2208 Item
:= First
(Context_Items
(N
));
2209 while Present
(Item
) loop
2210 if Nkind
(Item
) = N_With_Clause
2212 -- Protect frontend against previous errors in context clauses
2214 and then Nkind
(Name
(Item
)) /= N_Selected_Component
2215 and then not Error_Posted
(Item
)
2217 Unit_Name
:= Entity
(Name
(Item
));
2219 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
2220 exit when Scope
(Unit_Name
) = Standard_Standard
;
2221 Unit_Name
:= Scope
(Unit_Name
);
2224 if Context_Installed
(Item
) then
2225 Set_Is_Immediately_Visible
(Unit_Name
, False);
2226 Set_Context_Installed
(Item
, False);
2232 end Analyze_Subunit_Context
;
2234 ------------------------
2235 -- Re_Install_Parents --
2236 ------------------------
2238 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
2242 if Nkind
(Unit
(L
)) = N_Subunit
then
2243 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
2246 Install_Context
(L
, False);
2248 -- If the subunit occurs within a child unit, we must restore the
2249 -- immediate visibility of any siblings that may occur in context.
2250 -- In addition, we must reset the previous visibility of the
2251 -- parent unit which is now on the scope stack. This is because
2252 -- the Previous_Visibility was previously set when removing the
2253 -- context. This is necessary to prevent the parent entity from
2254 -- remaining visible after the subunit is compiled. This only
2255 -- has an effect if a homonym exists in a body to be processed
2256 -- later if inlining is enabled.
2258 if Present
(Enclosing_Child
) then
2259 Install_Siblings
(Enclosing_Child
, L
);
2260 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
2266 if Scop
/= Par_Unit
then
2267 Set_Is_Immediately_Visible
(Scop
);
2270 -- Make entities in scope visible again. For child units, restore
2271 -- visibility only if they are actually in context.
2273 E
:= First_Entity
(Current_Scope
);
2274 while Present
(E
) loop
2275 if not Is_Child_Unit
(E
) or else Is_Visible_Lib_Unit
(E
) then
2276 Set_Is_Immediately_Visible
(E
);
2282 -- A subunit appears within a body, and for a nested subunits all the
2283 -- parents are bodies. Restore full visibility of their private
2286 if Is_Package_Or_Generic_Package
(Scop
) then
2287 Set_In_Package_Body
(Scop
);
2288 Install_Private_Declarations
(Scop
);
2290 end Re_Install_Parents
;
2292 ----------------------------
2293 -- Re_Install_Use_Clauses --
2294 ----------------------------
2296 procedure Re_Install_Use_Clauses
is
2299 for J
in reverse 1 .. Num_Scopes
loop
2300 U
:= Use_Clauses
(J
);
2301 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
2302 Install_Use_Clauses
(U
);
2304 end Re_Install_Use_Clauses
;
2310 procedure Remove_Scope
is
2314 Num_Scopes
:= Num_Scopes
+ 1;
2315 Use_Clauses
(Num_Scopes
) :=
2316 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
2318 E
:= First_Entity
(Current_Scope
);
2319 while Present
(E
) loop
2320 Set_Is_Immediately_Visible
(E
, False);
2324 if Is_Child_Unit
(Current_Scope
) then
2325 Enclosing_Child
:= Current_Scope
;
2331 Saved_SM
: SPARK_Mode_Type
:= SPARK_Mode
;
2332 Saved_SMP
: Node_Id
:= SPARK_Mode_Pragma
;
2333 -- Save the SPARK mode-related data to restore on exit. Removing
2334 -- enclosing scopes and contexts to provide a clean environment for the
2335 -- context of the subunit will eliminate any previously set SPARK_Mode.
2337 -- Start of processing for Analyze_Subunit
2340 -- For subunit in main extended unit, we reset the configuration values
2341 -- for the non-partition-wide restrictions. For other units reset them.
2343 if In_Extended_Main_Source_Unit
(N
) then
2344 Restore_Config_Cunit_Boolean_Restrictions
;
2346 Reset_Cunit_Boolean_Restrictions
;
2351 Nam
: Node_Id
:= Name
(Unit
(N
));
2354 if Nkind
(Nam
) = N_Selected_Component
then
2355 Nam
:= Selector_Name
(Nam
);
2358 Check_Identifier
(Nam
, Par_Unit
);
2362 if not Is_Empty_List
(Context_Items
(N
)) then
2364 -- Save current use clauses
2367 Remove_Context
(Lib_Unit
);
2369 -- Now remove parents and their context, including enclosing subunits
2370 -- and the outer parent body which is not a subunit.
2372 if Present
(Lib_Spec
) then
2373 Remove_Context
(Lib_Spec
);
2375 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
2376 Lib_Spec
:= Library_Unit
(Lib_Spec
);
2378 Remove_Context
(Lib_Spec
);
2381 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
2385 if Nkind
(Unit
(Lib_Spec
)) in N_Package_Body | N_Subprogram_Body
2387 Remove_Context
(Library_Unit
(Lib_Spec
));
2391 Set_Is_Immediately_Visible
(Par_Unit
, False);
2393 Analyze_Subunit_Context
;
2395 -- Take into account the effect of any SPARK_Mode configuration
2396 -- pragma, which takes precedence over a different value of
2397 -- SPARK_Mode inherited from the context of the stub.
2399 if SPARK_Mode
/= None
then
2400 Saved_SM
:= SPARK_Mode
;
2401 Saved_SMP
:= SPARK_Mode_Pragma
;
2404 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
2405 Set_Is_Immediately_Visible
(Par_Unit
);
2407 -- If the context includes a child unit of the parent of the subunit,
2408 -- the parent will have been removed from visibility, after compiling
2409 -- that cousin in the context. The visibility of the parent must be
2410 -- restored now. This also applies if the context includes another
2411 -- subunit of the same parent which in turn includes a child unit in
2414 if Is_Package_Or_Generic_Package
(Par_Unit
) then
2415 if not Is_Immediately_Visible
(Par_Unit
)
2416 or else (Present
(First_Entity
(Par_Unit
))
2418 Is_Immediately_Visible
(First_Entity
(Par_Unit
)))
2420 Set_Is_Immediately_Visible
(Par_Unit
);
2421 Install_Visible_Declarations
(Par_Unit
);
2422 Install_Private_Declarations
(Par_Unit
);
2426 Re_Install_Use_Clauses
;
2427 Install_Context
(N
, Chain
=> False);
2429 -- Restore state of suppress flags for current body
2431 Scope_Suppress
:= Svg
;
2433 -- If the subunit is within a child unit, then siblings of any parent
2434 -- unit that appear in the context clause of the subunit must also be
2435 -- made immediately visible.
2437 if Present
(Enclosing_Child
) then
2438 Install_Siblings
(Enclosing_Child
, N
);
2442 Generate_Parent_References
(Unit
(N
), Par_Unit
);
2444 -- Reinstall the SPARK_Mode which was in effect prior to any scope and
2445 -- context manipulations, taking into account a possible SPARK_Mode
2446 -- configuration pragma if present.
2448 Install_SPARK_Mode
(Saved_SM
, Saved_SMP
);
2450 -- If the subunit is part of a compilation unit which is subject to
2451 -- pragma Elaboration_Checks, set the model specified by the pragma
2452 -- because it applies to all parts of the unit.
2454 Install_Elaboration_Model
(Par_Unit
);
2456 -- The syntax rules require a proper body for a subprogram subunit
2458 if Nkind
(Proper_Body
(Sinfo
.Nodes
.Unit
(N
))) = N_Subprogram_Declaration
2460 if Null_Present
(Specification
(Proper_Body
(Sinfo
.Nodes
.Unit
(N
))))
2463 ("null procedure not allowed as subunit",
2464 Proper_Body
(Unit
(N
)));
2467 ("subprogram declaration not allowed as subunit",
2468 Defining_Unit_Name
(Specification
(Proper_Body
(Unit
(N
)))));
2472 Analyze
(Proper_Body
(Unit
(N
)));
2475 -- The subunit may contain a with_clause on a sibling of some ancestor.
2476 -- Removing the context will remove from visibility those ancestor child
2477 -- units, which must be restored to the visibility they have in the
2480 if Present
(Enclosing_Child
) then
2485 while Present
(C
) and then C
/= Standard_Standard
loop
2486 Set_Is_Immediately_Visible
(C
);
2487 Set_Is_Visible_Lib_Unit
(C
);
2493 -- Deal with restore of restrictions
2495 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
2496 end Analyze_Subunit
;
2498 ----------------------------
2499 -- Analyze_Task_Body_Stub --
2500 ----------------------------
2502 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
2503 Id
: constant Entity_Id
:= Defining_Entity
(N
);
2504 Loc
: constant Source_Ptr
:= Sloc
(N
);
2505 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Id
);
2508 Check_Stub_Level
(N
);
2510 -- First occurrence of name may have been as an incomplete type
2512 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2513 Nam
:= Full_View
(Nam
);
2516 if No
(Nam
) or else not Is_Task_Type
(Etype
(Nam
)) then
2517 Error_Msg_N
("missing specification for task body", N
);
2520 Set_Scope
(Id
, Current_Scope
);
2521 Mutate_Ekind
(Id
, E_Task_Body
);
2522 Set_Etype
(Id
, Standard_Void_Type
);
2524 if Has_Aspects
(N
) then
2525 Analyze_Aspect_Specifications
(N
, Id
);
2528 Generate_Reference
(Nam
, Id
, 'b');
2529 Set_Corresponding_Spec_Of_Stub
(N
, Nam
);
2531 -- Check for duplicate stub, if so give message and terminate
2533 if Has_Completion
(Etype
(Nam
)) then
2534 Error_Msg_N
("duplicate stub for task", N
);
2537 Set_Has_Completion
(Etype
(Nam
));
2540 Analyze_Proper_Body
(N
, Etype
(Nam
));
2542 -- Set elaboration flag to indicate that entity is callable. This
2543 -- cannot be done in the expansion of the body itself, because the
2544 -- proper body is not in a declarative part. This is only done if
2545 -- expansion is active, because the context may be generic and the
2546 -- flag not defined yet.
2548 if Expander_Active
then
2550 Make_Assignment_Statement
(Loc
,
2552 Make_Identifier
(Loc
,
2553 Chars
=> New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
2554 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
2557 end Analyze_Task_Body_Stub
;
2559 -------------------------
2560 -- Analyze_With_Clause --
2561 -------------------------
2563 -- Analyze the declaration of a unit in a with clause. At end, label the
2564 -- with clause with the defining entity for the unit.
2566 procedure Analyze_With_Clause
(N
: Node_Id
) is
2568 -- Retrieve the original kind of the unit node, before analysis. If it
2569 -- is a subprogram instantiation, its analysis below will rewrite the
2570 -- node as the declaration of the wrapper package. If the same
2571 -- instantiation appears indirectly elsewhere in the context, it will
2572 -- have been analyzed already.
2574 Unit_Kind
: constant Node_Kind
:=
2575 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
2576 Nam
: constant Node_Id
:= Name
(N
);
2578 Par_Name
: Entity_Id
;
2583 -- Set True if the unit currently being compiled is an internal unit
2585 Restriction_Violation
: Boolean := False;
2586 -- Set True if a with violates a restriction, no point in giving any
2587 -- warnings if we have this definite error.
2589 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2592 U
:= Unit
(Library_Unit
(N
));
2594 -- If this is an internal unit which is a renaming, then this is a
2595 -- violation of No_Obsolescent_Features.
2597 -- Note: this is not quite right if the user defines one of these units
2598 -- himself, but that's a marginal case, and fixing it is hard ???
2600 if Restriction_Check_Required
(No_Obsolescent_Features
) then
2601 if In_Predefined_Renaming
(U
) then
2602 Check_Restriction
(No_Obsolescent_Features
, N
);
2603 Restriction_Violation
:= True;
2607 -- Check No_Implementation_Units violation
2609 if Restriction_Check_Required
(No_Implementation_Units
) then
2610 if Not_Impl_Defined_Unit
(Get_Source_Unit
(U
)) then
2613 Check_Restriction
(No_Implementation_Units
, Nam
);
2614 Restriction_Violation
:= True;
2618 -- Several actions are skipped for dummy packages (those supplied for
2619 -- with's where no matching file could be found). Such packages are
2620 -- identified by the Sloc value being set to No_Location.
2622 if Limited_Present
(N
) then
2624 -- Ada 2005 (AI-50217): Build visibility structures but do not
2625 -- analyze the unit.
2627 -- If the designated unit is a predefined unit, which might be used
2628 -- implicitly through the rtsfind machinery, a limited with clause
2629 -- on such a unit is usually pointless, because run-time units are
2630 -- unlikely to appear in mutually dependent units, and because this
2631 -- disables the rtsfind mechanism. We transform such limited with
2632 -- clauses into regular with clauses.
2634 if Sloc
(U
) /= No_Location
then
2635 if In_Predefined_Unit
(U
) then
2636 Set_Limited_Present
(N
, False);
2637 Analyze_With_Clause
(N
);
2639 Build_Limited_Views
(N
);
2646 -- If we are compiling under "don't quit" mode (-gnatq) and we have
2647 -- already detected serious errors then we mark the with-clause nodes as
2648 -- analyzed before the corresponding compilation unit is analyzed. This
2649 -- is done here to protect the frontend against never ending recursion
2650 -- caused by circularities in the sources (because the previous errors
2651 -- may break the regular machine of the compiler implemented in
2652 -- Load_Unit to detect circularities).
2654 if Serious_Errors_Detected
> 0 and then Try_Semantics
then
2658 Semantics
(Library_Unit
(N
));
2660 Intunit
:= Is_Internal_Unit
(Current_Sem_Unit
);
2662 if Sloc
(U
) /= No_Location
then
2664 -- Check restrictions, except that we skip the check if this is an
2665 -- internal unit unless we are compiling the internal unit as the
2666 -- main unit. We also skip this for dummy packages.
2668 Check_Restriction_No_Dependence
(Nam
, N
);
2670 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
2671 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
2674 -- Deal with special case of GNAT.Current_Exceptions which interacts
2675 -- with the optimization of local raise statements into gotos.
2677 if Nkind
(Nam
) = N_Selected_Component
2678 and then Nkind
(Prefix
(Nam
)) = N_Identifier
2679 and then Chars
(Prefix
(Nam
)) = Name_Gnat
2680 and then Chars
(Selector_Name
(Nam
))
2681 in Name_Most_Recent_Exception | Name_Exception_Traces
2683 Check_Restriction
(No_Exception_Propagation
, N
);
2684 Special_Exception_Package_Used
:= True;
2687 -- Check for inappropriate with of internal implementation unit if we
2688 -- are not compiling an internal unit and also check for withing unit
2689 -- in wrong version of Ada. Do not issue these messages for implicit
2690 -- with's generated by the compiler itself.
2692 if Implementation_Unit_Warnings
2693 and then not Intunit
2694 and then not Implicit_With
(N
)
2695 and then not Restriction_Violation
2697 case Get_Kind_Of_Unit
(Get_Source_Unit
(U
)) is
2698 when Implementation_Unit
=>
2699 Error_Msg_F
("& is an internal 'G'N'A'T unit?i?", Name
(N
));
2701 -- Add alternative name if available, otherwise issue a
2702 -- general warning message.
2704 if Error_Msg_Strlen
/= 0 then
2705 Error_Msg_F
("\use ""~"" instead?i?", Name
(N
));
2708 ("\use of this unit is non-portable and "
2709 & "version-dependent?i?", Name
(N
));
2712 when Not_Predefined_Unit | Ada_95_Unit
=>
2713 null; -- no checks needed
2715 when Ada_2005_Unit
=>
2716 if Ada_Version
< Ada_2005
2717 and then Warn_On_Ada_2005_Compatibility
2719 Error_Msg_N
("& is an Ada 2005 unit?i?", Name
(N
));
2722 when Ada_2012_Unit
=>
2723 if Ada_Version
< Ada_2012
2724 and then Warn_On_Ada_2012_Compatibility
2726 Error_Msg_N
("& is an Ada 2012 unit?i?", Name
(N
));
2729 when Ada_2022_Unit
=>
2730 if Ada_Version
< Ada_2022
2731 and then Warn_On_Ada_2022_Compatibility
2733 Error_Msg_N
("& is an Ada 2022 unit?i?", Name
(N
));
2739 -- Semantic analysis of a generic unit is performed on a copy of
2740 -- the original tree. Retrieve the entity on which semantic info
2741 -- actually appears.
2743 if Unit_Kind
in N_Generic_Declaration
then
2744 E_Name
:= Defining_Entity
(U
);
2746 -- Note: in the following test, Unit_Kind is the original Nkind, but in
2747 -- the case of an instantiation, semantic analysis above will have
2748 -- replaced the unit by its instantiated version. If the instance body
2749 -- has been generated, the instance now denotes the body entity. For
2750 -- visibility purposes we need the entity of its spec.
2752 elsif (Unit_Kind
= N_Package_Instantiation
2753 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
2754 N_Package_Instantiation
)
2755 and then Nkind
(U
) = N_Package_Body
2757 E_Name
:= Corresponding_Spec
(U
);
2759 elsif Unit_Kind
= N_Package_Instantiation
2760 and then Nkind
(U
) = N_Package_Instantiation
2761 and then Present
(Instance_Spec
(U
))
2763 -- If the instance has not been rewritten as a package declaration,
2764 -- then it appeared already in a previous with clause. Retrieve
2765 -- the entity from the previous instance.
2767 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
2769 elsif Unit_Kind
in N_Subprogram_Instantiation
then
2771 -- The visible subprogram is created during instantiation, and is
2772 -- an attribute of the wrapper package. We retrieve the wrapper
2773 -- package directly from the instantiation node. If the instance
2774 -- is inlined the unit is still an instantiation. Otherwise it has
2775 -- been rewritten as the declaration of the wrapper itself.
2777 if Nkind
(U
) in N_Subprogram_Instantiation
then
2780 (Defining_Entity
(Specification
(Instance_Spec
(U
))));
2782 E_Name
:= Related_Instance
(Defining_Entity
(U
));
2785 elsif Unit_Kind
= N_Package_Renaming_Declaration
2786 or else Unit_Kind
in N_Generic_Renaming_Declaration
2788 E_Name
:= Defining_Entity
(U
);
2790 elsif Unit_Kind
= N_Subprogram_Body
2791 and then Nkind
(Name
(N
)) = N_Selected_Component
2792 and then not Acts_As_Spec
(Library_Unit
(N
))
2794 -- For a child unit that has no spec, one has been created and
2795 -- analyzed. The entity required is that of the spec.
2797 E_Name
:= Corresponding_Spec
(U
);
2800 E_Name
:= Defining_Entity
(U
);
2803 if Nkind
(Name
(N
)) = N_Selected_Component
then
2805 -- Child unit in a with clause
2807 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
2809 -- If this is a child unit without a spec, and it has been analyzed
2810 -- already, a declaration has been created for it. The with_clause
2811 -- must reflect the actual body, and not the generated declaration,
2812 -- to prevent spurious binding errors involving an out-of-date spec.
2813 -- Note that this can only happen if the unit includes more than one
2814 -- with_clause for the child unit (e.g. in separate subunits).
2816 if Unit_Kind
= N_Subprogram_Declaration
2817 and then Analyzed
(Library_Unit
(N
))
2818 and then not Comes_From_Source
(Library_Unit
(N
))
2820 Set_Library_Unit
(N
,
2821 Cunit
(Get_Source_Unit
(Corresponding_Body
(U
))));
2825 -- Restore style checks
2827 Style_Check
:= Save_Style_Check
;
2829 -- Record the reference, but do NOT set the unit as referenced, we want
2830 -- to consider the unit as unreferenced if this is the only reference
2833 Set_Entity_With_Checks
(Name
(N
), E_Name
);
2834 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
2836 -- Generate references and check No_Dependence restriction for parents
2838 if Is_Child_Unit
(E_Name
) then
2839 Pref
:= Prefix
(Name
(N
));
2840 Par_Name
:= Scope
(E_Name
);
2841 while Nkind
(Pref
) = N_Selected_Component
loop
2842 Change_Selected_Component_To_Expanded_Name
(Pref
);
2844 if Present
(Entity
(Selector_Name
(Pref
)))
2846 Present
(Renamed_Entity
(Entity
(Selector_Name
(Pref
))))
2847 and then Entity
(Selector_Name
(Pref
)) /= Par_Name
2849 -- The prefix is a child unit that denotes a renaming declaration.
2850 -- Replace the prefix directly with the renamed unit, because the
2851 -- rest of the prefix is irrelevant to the visibility of the real
2854 Rewrite
(Pref
, New_Occurrence_Of
(Par_Name
, Sloc
(Pref
)));
2858 Set_Entity_With_Checks
(Pref
, Par_Name
);
2860 Generate_Reference
(Par_Name
, Pref
);
2861 Check_Restriction_No_Dependence
(Pref
, N
);
2862 Pref
:= Prefix
(Pref
);
2864 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2865 -- is set to Standard_Standard, and no attempt should be made to
2866 -- further unwind scopes.
2868 if Par_Name
/= Standard_Standard
then
2869 Par_Name
:= Scope
(Par_Name
);
2872 -- Abandon processing in case of previous errors
2874 if No
(Par_Name
) then
2875 Check_Error_Detected
;
2880 if Present
(Entity
(Pref
))
2881 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
2883 -- If the entity is set without its unit being compiled, the
2884 -- original parent is a renaming, and Par_Name is the renamed
2885 -- entity. For visibility purposes, we need the original entity,
2886 -- which must be analyzed now because Load_Unit directly retrieves
2887 -- the renamed unit, and the renaming declaration itself has not
2890 Analyze
(Parent
(Parent
(Entity
(Pref
))));
2891 pragma Assert
(Renamed_Entity
(Entity
(Pref
)) = Par_Name
);
2892 Par_Name
:= Entity
(Pref
);
2895 -- Guard against missing or misspelled child units
2897 if Present
(Par_Name
) then
2898 Set_Entity_With_Checks
(Pref
, Par_Name
);
2899 Generate_Reference
(Par_Name
, Pref
);
2902 pragma Assert
(Serious_Errors_Detected
/= 0);
2904 -- Mark the node to indicate that a related error has been posted.
2905 -- This defends further compilation passes against improper use of
2906 -- the invalid WITH clause node.
2908 Set_Error_Posted
(N
);
2909 Set_Name
(N
, Error
);
2914 -- If the withed unit is System, and a system extension pragma is
2915 -- present, compile the extension now, rather than waiting for a
2916 -- visibility check on a specific entity.
2918 if Chars
(E_Name
) = Name_System
2919 and then Scope
(E_Name
) = Standard_Standard
2920 and then Present
(System_Extend_Unit
)
2921 and then Present_System_Aux
(N
)
2923 -- If the extension is not present, an error will have been emitted
2928 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2929 -- to private_with units; they will be made visible later (just before
2930 -- the private part is analyzed)
2932 if Private_Present
(N
) then
2933 Set_Is_Immediately_Visible
(E_Name
, False);
2936 -- Propagate Fatal_Error setting from with'ed unit to current unit
2938 case Fatal_Error
(Get_Source_Unit
(Library_Unit
(N
))) is
2940 -- Nothing to do if with'ed unit had no error
2945 -- If with'ed unit had a detected fatal error, propagate it
2947 when Error_Detected
=>
2948 Set_Fatal_Error
(Current_Sem_Unit
, Error_Detected
);
2950 -- If with'ed unit had an ignored error, then propagate it but do not
2951 -- overide an existring setting.
2953 when Error_Ignored
=>
2954 if Fatal_Error
(Current_Sem_Unit
) = None
then
2955 Set_Fatal_Error
(Current_Sem_Unit
, Error_Ignored
);
2958 end Analyze_With_Clause
;
2960 ------------------------------
2961 -- Check_Private_Child_Unit --
2962 ------------------------------
2964 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
2965 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2967 Curr_Unit
: Entity_Id
;
2968 Sub_Parent
: Node_Id
;
2969 Priv_Child
: Entity_Id
;
2970 Par_Lib
: Entity_Id
;
2974 if Nkind
(Lib_Unit
) in N_Package_Body | N_Subprogram_Body
then
2975 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
2976 Par_Lib
:= Curr_Unit
;
2978 elsif Nkind
(Lib_Unit
) = N_Subunit
then
2980 -- The parent is itself a body. The parent entity is to be found in
2981 -- the corresponding spec.
2983 Sub_Parent
:= Library_Unit
(N
);
2984 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
2986 -- If the parent itself is a subunit, Curr_Unit is the entity of the
2987 -- enclosing body, retrieve the spec entity which is the proper
2988 -- ancestor we need for the following tests.
2990 if Ekind
(Curr_Unit
) = E_Package_Body
then
2991 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2994 Par_Lib
:= Curr_Unit
;
2997 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2999 Par_Lib
:= Curr_Unit
;
3000 Par_Spec
:= Parent_Spec
(Lib_Unit
);
3002 if No
(Par_Spec
) then
3005 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
3009 -- Loop through context items
3011 Item
:= First
(Context_Items
(N
));
3012 while Present
(Item
) loop
3014 -- Ada 2005 (AI-262): Allow private_with of a private child package
3015 -- in public siblings
3017 if Nkind
(Item
) = N_With_Clause
3018 and then not Implicit_With
(Item
)
3019 and then not Limited_Present
(Item
)
3020 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
3022 Priv_Child
:= Entity
(Name
(Item
));
3025 Curr_Parent
: Entity_Id
:= Par_Lib
;
3026 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
3027 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
3028 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
3031 -- If the child unit is a public child then locate the nearest
3032 -- private ancestor. Child_Parent will then be set to the
3033 -- parent of that ancestor.
3035 if not Is_Private_Library_Unit
(Priv_Child
) then
3036 while Present
(Prv_Ancestor
)
3037 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
3039 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
3042 if Present
(Prv_Ancestor
) then
3043 Child_Parent
:= Scope
(Prv_Ancestor
);
3047 while Present
(Curr_Parent
)
3048 and then Curr_Parent
/= Standard_Standard
3049 and then Curr_Parent
/= Child_Parent
3052 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
3053 Curr_Parent
:= Scope
(Curr_Parent
);
3056 if No
(Curr_Parent
) then
3057 Curr_Parent
:= Standard_Standard
;
3060 if Curr_Parent
/= Child_Parent
then
3061 if Ekind
(Priv_Child
) = E_Generic_Package
3062 and then Chars
(Priv_Child
) in Text_IO_Package_Name
3063 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
3064 and then Scope
(Scope
(Scope
(Priv_Child
))) =
3068 ("& is a nested package, not a compilation unit",
3069 Name
(Item
), Priv_Child
);
3073 ("unit in with clause is private child unit!", Item
);
3075 ("\current unit must also have parent&!",
3076 Item
, Child_Parent
);
3080 or else Private_Present
(Item
)
3081 or else Nkind
(Lib_Unit
) in N_Package_Body | N_Subunit
3082 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3083 and then not Acts_As_Spec
(Parent
(Lib_Unit
)))
3089 ("current unit must also be private descendant of&",
3090 Item
, Child_Parent
);
3097 end Check_Private_Child_Unit
;
3099 ----------------------
3100 -- Check_Stub_Level --
3101 ----------------------
3103 procedure Check_Stub_Level
(N
: Node_Id
) is
3104 Par
: constant Node_Id
:= Parent
(N
);
3105 Kind
: constant Node_Kind
:= Nkind
(Par
);
3109 N_Package_Body | N_Subprogram_Body | N_Task_Body | N_Protected_Body
3110 and then Nkind
(Parent
(Par
)) in N_Compilation_Unit | N_Subunit
3114 -- In an instance, a missing stub appears at any level. A warning
3115 -- message will have been emitted already for the missing file.
3117 elsif not In_Instance
then
3118 Error_Msg_N
("stub cannot appear in an inner scope", N
);
3120 elsif Expander_Active
then
3121 Error_Msg_N
("missing proper body", N
);
3123 end Check_Stub_Level
;
3129 procedure Decorate_Type
3132 Is_Tagged
: Boolean := False;
3133 Materialize
: Boolean := False)
3138 -- An unanalyzed type or a shadow entity of a type is treated as an
3139 -- incomplete type, and carries the corresponding attributes.
3141 Mutate_Ekind
(Ent
, E_Incomplete_Type
);
3142 Set_Etype
(Ent
, Ent
);
3143 Set_Full_View
(Ent
, Empty
);
3144 Set_Is_First_Subtype
(Ent
);
3145 Set_Scope
(Ent
, Scop
);
3146 Set_Stored_Constraint
(Ent
, No_Elist
);
3147 Reinit_Size_Align
(Ent
);
3149 if From_Limited_With
(Ent
) then
3150 Set_Private_Dependents
(Ent
, New_Elmt_List
);
3153 -- A tagged type and its corresponding shadow entity share one common
3154 -- class-wide type. The list of primitive operations for the shadow
3158 Set_Is_Tagged_Type
(Ent
);
3159 Set_Direct_Primitive_Operations
(Ent
, New_Elmt_List
);
3163 (E_Void
, Scope
(Ent
), Sloc
(Ent
), Ent
, 'C', 0, 'T');
3165 Set_Class_Wide_Type
(Ent
, CW_Typ
);
3167 -- Set parent to be the same as the parent of the tagged type.
3168 -- We need a parent field set, and it is supposed to point to
3169 -- the declaration of the type. The tagged type declaration
3170 -- essentially declares two separate types, the tagged type
3171 -- itself and the corresponding class-wide type, so it is
3172 -- reasonable for the parent fields to point to the declaration
3175 Set_Parent
(CW_Typ
, Parent
(Ent
));
3177 Mutate_Ekind
(CW_Typ
, E_Class_Wide_Type
);
3178 Set_Class_Wide_Type
(CW_Typ
, CW_Typ
);
3179 Set_Etype
(CW_Typ
, Ent
);
3180 Set_Equivalent_Type
(CW_Typ
, Empty
);
3181 Set_From_Limited_With
(CW_Typ
, From_Limited_With
(Ent
));
3182 Set_Has_Unknown_Discriminants
(CW_Typ
);
3183 Set_Is_First_Subtype
(CW_Typ
);
3184 Set_Is_Tagged_Type
(CW_Typ
);
3185 Set_Materialize_Entity
(CW_Typ
, Materialize
);
3186 Set_Scope
(CW_Typ
, Scop
);
3187 Reinit_Size_Align
(CW_Typ
);
3191 ------------------------
3192 -- Expand_With_Clause --
3193 ------------------------
3195 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
) is
3196 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
3198 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
3199 -- Build name to be used in implicit with_clause. In most cases this
3200 -- is the source name, but if renamings are present we must make the
3201 -- original unit visible, not the one it renames. The entity in the
3202 -- with clause is the renamed unit, but the identifier is the one from
3203 -- the source, which allows us to recover the unit renaming.
3205 ---------------------
3206 -- Build_Unit_Name --
3207 ---------------------
3209 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
3214 if Nkind
(Nam
) = N_Identifier
then
3215 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
3218 Ent
:= Entity
(Nam
);
3220 if Present
(Entity
(Selector_Name
(Nam
)))
3221 and then Chars
(Entity
(Selector_Name
(Nam
))) /= Chars
(Ent
)
3223 Nkind
(Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))) =
3224 N_Package_Renaming_Declaration
3226 -- The name in the with_clause is of the form A.B.C, and B is
3227 -- given by a renaming declaration. In that case we may not
3228 -- have analyzed the unit for B, but replaced it directly in
3229 -- lib-load with the unit it renames. We have to make A.B
3230 -- visible, so analyze the declaration for B now, in case it
3231 -- has not been done yet.
3233 Ent
:= Entity
(Selector_Name
(Nam
));
3236 (Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))));
3240 Make_Expanded_Name
(Loc
,
3241 Chars
=> Chars
(Entity
(Nam
)),
3242 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
3243 Selector_Name
=> New_Occurrence_Of
(Ent
, Loc
));
3244 Set_Entity
(Result
, Ent
);
3248 end Build_Unit_Name
;
3252 Ent
: constant Entity_Id
:= Entity
(Nam
);
3255 -- Start of processing for Expand_With_Clause
3259 Make_With_Clause
(Loc
,
3260 Name
=> Build_Unit_Name
(Nam
));
3262 Set_Corresponding_Spec
(Withn
, Ent
);
3263 Set_First_Name
(Withn
);
3264 Set_Implicit_With
(Withn
);
3265 Set_Library_Unit
(Withn
, Parent
(Unit_Declaration_Node
(Ent
)));
3266 Set_Parent_With
(Withn
);
3268 -- If the unit is a [generic] package or subprogram declaration
3269 -- (including a subprogram body acting as spec), a private_with_clause
3270 -- on a child unit implies that the implicit with on the parent is also
3273 if Nkind
(Unit
(N
)) in N_Generic_Package_Declaration
3274 | N_Package_Declaration
3275 | N_Generic_Subprogram_Declaration
3276 | N_Subprogram_Declaration
3279 Set_Private_Present
(Withn
, Private_Present
(Item
));
3282 Prepend
(Withn
, Context_Items
(N
));
3283 Mark_Rewrite_Insertion
(Withn
);
3285 Install_With_Clause
(Withn
);
3287 -- If we have "with X.Y;", we want to recurse on "X", except in the
3288 -- unusual case where X.Y is a renaming of X. In that case, the scope
3289 -- of X will be null.
3291 if Nkind
(Nam
) = N_Expanded_Name
3292 and then Present
(Scope
(Entity
(Prefix
(Nam
))))
3294 Expand_With_Clause
(Item
, Prefix
(Nam
), N
);
3296 end Expand_With_Clause
;
3298 --------------------------------
3299 -- Generate_Parent_References --
3300 --------------------------------
3302 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
3304 P_Name
: Entity_Id
:= P_Id
;
3307 if Nkind
(N
) = N_Subunit
then
3310 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
3313 if Nkind
(Pref
) = N_Expanded_Name
then
3315 -- Done already, if the unit has been compiled indirectly as
3316 -- part of the closure of its context because of inlining.
3321 while Nkind
(Pref
) = N_Selected_Component
loop
3322 Change_Selected_Component_To_Expanded_Name
(Pref
);
3323 Set_Entity
(Pref
, P_Name
);
3324 Set_Etype
(Pref
, Etype
(P_Name
));
3325 Generate_Reference
(P_Name
, Pref
, 'r');
3326 Pref
:= Prefix
(Pref
);
3327 P_Name
:= Scope
(P_Name
);
3330 -- The guard here on P_Name is to handle the error condition where
3331 -- the parent unit is missing because the file was not found.
3333 if Present
(P_Name
) then
3334 Set_Entity
(Pref
, P_Name
);
3335 Set_Etype
(Pref
, Etype
(P_Name
));
3336 Generate_Reference
(P_Name
, Pref
, 'r');
3337 Style
.Check_Identifier
(Pref
, P_Name
);
3339 end Generate_Parent_References
;
3341 ---------------------
3342 -- Has_With_Clause --
3343 ---------------------
3345 function Has_With_Clause
3348 Is_Limited
: Boolean := False) return Boolean
3352 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
;
3353 -- Return the entity for the unit named in a [limited] with clause
3359 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
is
3361 if Nkind
(Name
(Clause
)) = N_Selected_Component
then
3362 return Entity
(Selector_Name
(Name
(Clause
)));
3364 return Entity
(Name
(Clause
));
3368 -- Start of processing for Has_With_Clause
3371 Item
:= First
(Context_Items
(C_Unit
));
3372 while Present
(Item
) loop
3373 if Nkind
(Item
) = N_With_Clause
3374 and then Limited_Present
(Item
) = Is_Limited
3375 and then Named_Unit
(Item
) = Pack
3384 end Has_With_Clause
;
3386 -----------------------------
3387 -- Implicit_With_On_Parent --
3388 -----------------------------
3390 procedure Implicit_With_On_Parent
3391 (Child_Unit
: Node_Id
;
3394 Loc
: constant Source_Ptr
:= Sloc
(N
);
3395 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
3396 P_Unit
: Node_Id
:= Unit
(P
);
3397 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
3400 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
3401 -- Build prefix of child unit name. Recurse if needed
3403 function Build_Unit_Name
return Node_Id
;
3404 -- If the unit is a child unit, build qualified name with all ancestors
3406 -------------------------
3407 -- Build_Ancestor_Name --
3408 -------------------------
3410 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
3411 P_Ref
: constant Node_Id
:=
3412 New_Occurrence_Of
(Defining_Entity
(P
), Loc
);
3413 P_Spec
: Node_Id
:= P
;
3416 -- Ancestor may have been rewritten as a package body. Retrieve the
3417 -- original spec to trace earlier ancestors.
3419 if Nkind
(P
) = N_Package_Body
3420 and then Nkind
(Original_Node
(P
)) = N_Package_Instantiation
3422 P_Spec
:= Original_Node
(P
);
3425 if No
(Parent_Spec
(P_Spec
)) then
3429 Make_Selected_Component
(Loc
,
3431 Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Spec
))),
3432 Selector_Name
=> P_Ref
);
3434 end Build_Ancestor_Name
;
3436 ---------------------
3437 -- Build_Unit_Name --
3438 ---------------------
3440 function Build_Unit_Name
return Node_Id
is
3444 if No
(Parent_Spec
(P_Unit
)) then
3445 return New_Occurrence_Of
(P_Name
, Loc
);
3449 Make_Expanded_Name
(Loc
,
3450 Chars
=> Chars
(P_Name
),
3452 Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
3453 Selector_Name
=> New_Occurrence_Of
(P_Name
, Loc
));
3454 Set_Entity
(Result
, P_Name
);
3458 end Build_Unit_Name
;
3460 -- Start of processing for Implicit_With_On_Parent
3463 -- The unit of the current compilation may be a package body that
3464 -- replaces an instance node. In this case we need the original instance
3465 -- node to construct the proper parent name.
3467 if Nkind
(P_Unit
) = N_Package_Body
3468 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
3470 P_Unit
:= Original_Node
(P_Unit
);
3473 -- We add the implicit with if the child unit is the current unit being
3474 -- compiled. If the current unit is a body, we do not want to add an
3475 -- implicit_with a second time to the corresponding spec.
3477 if Nkind
(Child_Unit
) = N_Package_Declaration
3478 and then Child_Unit
/= Unit
(Cunit
(Current_Sem_Unit
))
3483 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
3485 Set_Corresponding_Spec
(Withn
, P_Name
);
3486 Set_First_Name
(Withn
);
3487 Set_Implicit_With
(Withn
);
3488 Set_Library_Unit
(Withn
, P
);
3489 Set_Parent_With
(Withn
);
3491 -- Node is placed at the beginning of the context items, so that
3492 -- subsequent use clauses on the parent can be validated.
3494 Prepend
(Withn
, Context_Items
(N
));
3495 Mark_Rewrite_Insertion
(Withn
);
3497 Install_With_Clause
(Withn
);
3499 if Is_Child_Spec
(P_Unit
) then
3500 Implicit_With_On_Parent
(P_Unit
, N
);
3502 end Implicit_With_On_Parent
;
3508 function In_Chain
(E
: Entity_Id
) return Boolean is
3512 H
:= Current_Entity
(E
);
3513 while Present
(H
) loop
3524 ---------------------
3525 -- Install_Context --
3526 ---------------------
3528 procedure Install_Context
(N
: Node_Id
; Chain
: Boolean := True) is
3529 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3532 Install_Context_Clauses
(N
, Chain
);
3534 if Is_Child_Spec
(Lib_Unit
) then
3536 (Lib_Unit
=> Lib_Unit
,
3537 Is_Private
=> Private_Present
(Parent
(Lib_Unit
)),
3541 Install_Limited_Context_Clauses
(N
);
3542 end Install_Context
;
3544 -----------------------------
3545 -- Install_Context_Clauses --
3546 -----------------------------
3548 procedure Install_Context_Clauses
(N
: Node_Id
; Chain
: Boolean := True) is
3549 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3551 Uname_Node
: Entity_Id
;
3552 Check_Private
: Boolean := False;
3553 Decl_Node
: Node_Id
;
3554 Lib_Parent
: Entity_Id
;
3557 -- First skip configuration pragmas at the start of the context. They
3558 -- are not technically part of the context clause, but that's where the
3559 -- parser puts them. Note they were analyzed in Analyze_Context.
3561 Item
:= First
(Context_Items
(N
));
3562 while Present
(Item
)
3563 and then Nkind
(Item
) = N_Pragma
3564 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
3569 -- Loop through the actual context clause items. We process everything
3570 -- except Limited_With clauses in this routine. Limited_With clauses
3571 -- are separately installed (see Install_Limited_Context_Clauses).
3573 while Present
(Item
) loop
3575 -- Case of explicit WITH clause
3577 if Nkind
(Item
) = N_With_Clause
3578 and then not Implicit_With
(Item
)
3580 if Limited_Present
(Item
) then
3582 -- Limited withed units will be installed later
3586 -- If Name (Item) is not an entity name, something is wrong, and
3587 -- this will be detected in due course, for now ignore the item
3589 elsif not Is_Entity_Name
(Name
(Item
)) then
3592 elsif No
(Entity
(Name
(Item
))) then
3593 Set_Entity
(Name
(Item
), Any_Id
);
3597 Uname_Node
:= Entity
(Name
(Item
));
3599 if Is_Private_Descendant
(Uname_Node
) then
3600 Check_Private
:= True;
3603 Install_With_Clause
(Item
);
3605 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
3607 -- If the unit is a subprogram instance, it appears nested within
3608 -- a package that carries the parent information.
3610 if Is_Generic_Instance
(Uname_Node
)
3611 and then Ekind
(Uname_Node
) /= E_Package
3613 Decl_Node
:= Parent
(Parent
(Decl_Node
));
3616 if Is_Child_Spec
(Decl_Node
) then
3617 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
3618 Expand_With_Clause
(Item
, Prefix
(Name
(Item
)), N
);
3620 -- If not an expanded name, the child unit must be a
3621 -- renaming, nothing to do.
3626 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
3627 and then not Acts_As_Spec
(Parent
(Decl_Node
))
3628 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
3630 Implicit_With_On_Parent
3631 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
3634 -- Check license conditions unless this is a dummy unit
3636 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
3637 License_Check
: declare
3638 Withu
: constant Unit_Number_Type
:=
3639 Get_Source_Unit
(Library_Unit
(Item
));
3640 Withl
: constant License_Type
:=
3641 License
(Source_Index
(Withu
));
3642 Unitl
: constant License_Type
:=
3643 License
(Source_Index
(Current_Sem_Unit
));
3645 procedure License_Error
;
3646 -- Signal error of bad license
3652 procedure License_Error
is
3655 ("license of withed unit & may be inconsistent??",
3659 -- Start of processing for License_Check
3662 -- Exclude license check if withed unit is an internal unit.
3663 -- This situation arises e.g. with the GPL version of GNAT.
3665 if Is_Internal_Unit
(Withu
) then
3668 -- Otherwise check various cases
3680 if Withl
= Restricted
then
3684 when Modified_GPL
=>
3685 if Withl
= Restricted
or else Withl
= GPL
then
3689 when Unrestricted
=>
3696 -- Case of USE PACKAGE clause
3698 elsif Nkind
(Item
) = N_Use_Package_Clause
then
3699 Analyze_Use_Package
(Item
, Chain
);
3701 -- Case of USE TYPE clause
3703 elsif Nkind
(Item
) = N_Use_Type_Clause
then
3704 Analyze_Use_Type
(Item
, Chain
);
3708 elsif Nkind
(Item
) = N_Pragma
then
3716 if Is_Child_Spec
(Lib_Unit
) then
3718 -- The unit also has implicit with_clauses on its own parents
3720 if No
(Context_Items
(N
)) then
3721 Set_Context_Items
(N
, New_List
);
3724 Implicit_With_On_Parent
(Lib_Unit
, N
);
3727 -- If the unit is a body, the context of the specification must also
3728 -- be installed. That includes private with_clauses in that context.
3730 if Nkind
(Lib_Unit
) = N_Package_Body
3731 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3732 and then not Acts_As_Spec
(N
))
3734 Install_Context
(Library_Unit
(N
), Chain
);
3736 -- Only install private with-clauses of a spec that comes from
3737 -- source, excluding specs created for a subprogram body that is
3740 if Comes_From_Source
(Library_Unit
(N
)) then
3741 Install_Private_With_Clauses
3742 (Defining_Entity
(Unit
(Library_Unit
(N
))));
3745 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
3747 -- If the unit is the body of a public child unit, the private
3748 -- declarations of the parent must be made visible. If the child
3749 -- unit is private, the private declarations have been installed
3750 -- already in the call to Install_Parents for the spec. Installing
3751 -- private declarations must be done for all ancestors of public
3752 -- child units. In addition, sibling units mentioned in the
3753 -- context clause of the body are directly visible.
3761 Lib_Spec
:= Unit
(Library_Unit
(N
));
3762 while Is_Child_Spec
(Lib_Spec
) loop
3763 P
:= Unit
(Parent_Spec
(Lib_Spec
));
3764 P_Name
:= Defining_Entity
(P
);
3766 if not (Private_Present
(Parent
(Lib_Spec
)))
3767 and then not In_Private_Part
(P_Name
)
3769 Install_Private_Declarations
(P_Name
);
3770 Install_Private_With_Clauses
(P_Name
);
3771 Set_Use
(Private_Declarations
(Specification
(P
)));
3779 -- For a package body, children in context are immediately visible
3781 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
3784 if Nkind
(Lib_Unit
) in N_Generic_Package_Declaration
3785 | N_Generic_Subprogram_Declaration
3786 | N_Package_Declaration
3787 | N_Subprogram_Declaration
3789 if Is_Child_Spec
(Lib_Unit
) then
3790 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
3791 Set_Is_Private_Descendant
3792 (Defining_Entity
(Lib_Unit
),
3793 Is_Private_Descendant
(Lib_Parent
)
3794 or else Private_Present
(Parent
(Lib_Unit
)));
3797 Set_Is_Private_Descendant
3798 (Defining_Entity
(Lib_Unit
),
3799 Private_Present
(Parent
(Lib_Unit
)));
3803 if Check_Private
then
3804 Check_Private_Child_Unit
(N
);
3806 end Install_Context_Clauses
;
3808 -------------------------------------
3809 -- Install_Limited_Context_Clauses --
3810 -------------------------------------
3812 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
3815 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
);
3816 -- Check that the unlimited view of a given compilation_unit is not
3817 -- already visible through "use + renamings".
3819 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
);
3820 -- Check that if a limited_with clause of a given compilation_unit
3821 -- mentions a descendant of a private child of some library unit, then
3822 -- the given compilation_unit must be the declaration of a private
3823 -- descendant of that library unit, or a public descendant of such. The
3824 -- code is analogous to that of Check_Private_Child_Unit but we cannot
3825 -- use entities on the limited with_clauses because their units have not
3826 -- been analyzed, so we have to climb the tree of ancestors looking for
3827 -- private keywords.
3829 procedure Expand_Limited_With_Clause
3830 (Comp_Unit
: Node_Id
;
3833 -- If a child unit appears in a limited_with clause, there are implicit
3834 -- limited_with clauses on all parents that are not already visible
3835 -- through a regular with clause. This procedure creates the implicit
3836 -- limited with_clauses for the parents and loads the corresponding
3837 -- units. The shadow entities are created when the inserted clause is
3838 -- analyzed. Implements Ada 2005 (AI-50217).
3840 ---------------------
3841 -- Check_Renamings --
3842 ---------------------
3844 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
) is
3852 pragma Assert
(Nkind
(W
) = N_With_Clause
);
3854 -- Protect the frontend against previous critical errors
3856 case Nkind
(Unit
(Library_Unit
(W
))) is
3857 when N_Generic_Package_Declaration
3858 | N_Generic_Subprogram_Declaration
3859 | N_Package_Declaration
3860 | N_Subprogram_Declaration
3868 -- Check "use + renamings"
3870 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
3871 Spec
:= Specification
(Unit
(P
));
3873 Item
:= First
(Visible_Declarations
(Spec
));
3874 while Present
(Item
) loop
3876 -- Look only at use package clauses
3878 if Nkind
(Item
) = N_Use_Package_Clause
then
3880 E
:= Entity
(Name
(Item
));
3882 pragma Assert
(Present
(Parent
(E
)));
3884 if Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
3885 and then Renamed_Entity
(E
) = WEnt
3887 -- The unlimited view is visible through use clause and
3888 -- renamings. There is no need to generate the error
3889 -- message here because Is_Visible_Through_Renamings
3890 -- takes care of generating the precise error message.
3894 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
3896 -- The use clause may refer to a local package.
3897 -- Check all the enclosing scopes.
3900 while E2
/= Standard_Standard
and then E2
/= WEnt
loop
3906 ("unlimited view visible through use clause", W
);
3915 -- Recursive call to check all the ancestors
3917 if Is_Child_Spec
(Unit
(P
)) then
3918 Check_Renamings
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
3920 end Check_Renamings
;
3922 ---------------------------------------
3923 -- Check_Private_Limited_Withed_Unit --
3924 ---------------------------------------
3926 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
) is
3927 Curr_Parent
: Node_Id
;
3928 Child_Parent
: Node_Id
;
3929 Curr_Private
: Boolean;
3932 -- Compilation unit of the parent of the withed library unit
3934 Child_Parent
:= Library_Unit
(Item
);
3936 -- If the child unit is a public child, then locate its nearest
3937 -- private ancestor, if any, then Child_Parent will then be set to
3938 -- the parent of that ancestor.
3940 if not Private_Present
(Library_Unit
(Item
)) then
3941 while Present
(Child_Parent
)
3942 and then not Private_Present
(Child_Parent
)
3944 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3947 if No
(Child_Parent
) then
3952 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3954 -- Traverse all the ancestors of the current compilation unit to
3955 -- check if it is a descendant of named library unit.
3957 Curr_Parent
:= Parent
(Item
);
3958 Curr_Private
:= Private_Present
(Curr_Parent
);
3960 while Present
(Parent_Spec
(Unit
(Curr_Parent
)))
3961 and then Curr_Parent
/= Child_Parent
3963 Curr_Parent
:= Parent_Spec
(Unit
(Curr_Parent
));
3964 Curr_Private
:= Curr_Private
or else Private_Present
(Curr_Parent
);
3967 if Curr_Parent
/= Child_Parent
then
3969 ("unit in with clause is private child unit!", Item
);
3971 ("\current unit must also have parent&!",
3972 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3974 elsif Private_Present
(Parent
(Item
))
3975 or else Curr_Private
3976 or else Private_Present
(Item
)
3977 or else Nkind
(Unit
(Parent
(Item
))) in
3978 N_Package_Body | N_Subprogram_Body | N_Subunit
3980 -- Current unit is private, of descendant of a private unit
3986 ("current unit must also be private descendant of&",
3987 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3989 end Check_Private_Limited_Withed_Unit
;
3991 --------------------------------
3992 -- Expand_Limited_With_Clause --
3993 --------------------------------
3995 procedure Expand_Limited_With_Clause
3996 (Comp_Unit
: Node_Id
;
4000 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
4001 Unum
: Unit_Number_Type
;
4004 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean;
4005 -- Returns true if the context already includes a with_clause for
4006 -- this unit. If the with_clause is nonlimited, the unit is fully
4007 -- visible and an implicit limited_with should not be created. If
4008 -- there is already a limited_with clause for W, a second one is
4009 -- simply redundant.
4011 --------------------------
4012 -- Previous_Withed_Unit --
4013 --------------------------
4015 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean is
4019 -- A limited with_clause cannot appear in the same context_clause
4020 -- as a nonlimited with_clause which mentions the same library.
4022 Item
:= First
(Context_Items
(Comp_Unit
));
4023 while Present
(Item
) loop
4024 if Nkind
(Item
) = N_With_Clause
4025 and then Library_Unit
(Item
) = Library_Unit
(W
)
4034 end Previous_Withed_Unit
;
4036 -- Start of processing for Expand_Limited_With_Clause
4039 if Nkind
(Nam
) = N_Identifier
then
4041 -- Create node for name of withed unit
4044 Make_With_Clause
(Loc
,
4045 Name
=> New_Copy
(Nam
));
4047 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
4049 Make_With_Clause
(Loc
,
4050 Name
=> Make_Selected_Component
(Loc
,
4051 Prefix
=> New_Copy_Tree
(Prefix
(Nam
)),
4052 Selector_Name
=> New_Copy
(Selector_Name
(Nam
))));
4053 Set_Parent
(Withn
, Parent
(N
));
4056 Set_First_Name
(Withn
);
4057 Set_Implicit_With
(Withn
);
4058 Set_Limited_Present
(Withn
);
4062 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
4067 -- Do not generate a limited_with_clause on the current unit. This
4068 -- path is taken when a unit has a limited_with clause on one of its
4071 if Unum
= Current_Sem_Unit
then
4075 Set_Library_Unit
(Withn
, Cunit
(Unum
));
4076 Set_Corresponding_Spec
4077 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
4079 if not Previous_Withed_Unit
(Withn
) then
4080 Prepend
(Withn
, Context_Items
(Parent
(N
)));
4081 Mark_Rewrite_Insertion
(Withn
);
4083 -- Add implicit limited_with_clauses for parents of child units
4084 -- mentioned in limited_with clauses.
4086 if Nkind
(Nam
) = N_Selected_Component
then
4087 Expand_Limited_With_Clause
(Comp_Unit
, Prefix
(Nam
), N
);
4092 if not Limited_View_Installed
(Withn
) then
4093 Install_Limited_With_Clause
(Withn
);
4096 end Expand_Limited_With_Clause
;
4098 -- Start of processing for Install_Limited_Context_Clauses
4101 Item
:= First
(Context_Items
(N
));
4102 while Present
(Item
) loop
4103 if Nkind
(Item
) = N_With_Clause
4104 and then Limited_Present
(Item
)
4105 and then not Error_Posted
(Item
)
4107 if Nkind
(Name
(Item
)) = N_Selected_Component
then
4108 Expand_Limited_With_Clause
4109 (Comp_Unit
=> N
, Nam
=> Prefix
(Name
(Item
)), N
=> Item
);
4112 Check_Private_Limited_Withed_Unit
(Item
);
4114 if not Implicit_With
(Item
) and then Is_Child_Spec
(Unit
(N
)) then
4115 Check_Renamings
(Parent_Spec
(Unit
(N
)), Item
);
4118 -- A unit may have a limited with on itself if it has a limited
4119 -- with_clause on one of its child units. In that case it is
4120 -- already being compiled and it makes no sense to install its
4123 -- If the item is a limited_private_with_clause, install it if the
4124 -- current unit is a body or if it is a private child. Otherwise
4125 -- the private clause is installed before analyzing the private
4126 -- part of the current unit.
4128 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
)
4129 and then not Limited_View_Installed
(Item
)
4131 not Is_Ancestor_Unit
4132 (Library_Unit
(Item
), Cunit
(Current_Sem_Unit
))
4134 if not Private_Present
(Item
)
4135 or else Private_Present
(N
)
4136 or else Nkind
(Unit
(N
)) in
4137 N_Package_Body | N_Subprogram_Body | N_Subunit
4139 Install_Limited_With_Clause
(Item
);
4147 -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
4148 -- looking for incomplete subtype declarations of incomplete types
4149 -- visible through a limited with clause.
4151 if Ada_Version
>= Ada_2005
4152 and then Analyzed
(N
)
4153 and then Nkind
(Unit
(N
)) = N_Package_Declaration
4158 Non_Lim_View
: Entity_Id
;
4161 Decl
:= First
(Visible_Declarations
(Specification
(Unit
(N
))));
4162 while Present
(Decl
) loop
4163 if Nkind
(Decl
) = N_Subtype_Declaration
4165 Ekind
(Defining_Identifier
(Decl
)) = E_Incomplete_Subtype
4167 From_Limited_With
(Defining_Identifier
(Decl
))
4169 Def_Id
:= Defining_Identifier
(Decl
);
4170 Non_Lim_View
:= Non_Limited_View
(Def_Id
);
4172 if not Is_Incomplete_Type
(Non_Lim_View
) then
4174 -- Convert an incomplete subtype declaration into a
4175 -- corresponding nonlimited view subtype declaration.
4176 -- This is usually the case when analyzing a body that
4177 -- has regular with clauses, when the spec has limited
4180 -- If the nonlimited view is still incomplete, it is
4181 -- the dummy entry already created, and the declaration
4182 -- cannot be reanalyzed. This is the case when installing
4183 -- a parent unit that has limited with-clauses.
4185 Set_Subtype_Indication
(Decl
,
4186 New_Occurrence_Of
(Non_Lim_View
, Sloc
(Def_Id
)));
4187 Set_Etype
(Def_Id
, Non_Lim_View
);
4189 (Def_Id
, Subtype_Kind
(Ekind
(Non_Lim_View
)));
4190 Set_Analyzed
(Decl
, False);
4192 -- Reanalyze the declaration, suppressing the call to
4193 -- Enter_Name to avoid duplicate names.
4195 Analyze_Subtype_Declaration
4205 end Install_Limited_Context_Clauses
;
4207 ---------------------
4208 -- Install_Parents --
4209 ---------------------
4211 procedure Install_Parents
4212 (Lib_Unit
: Node_Id
;
4213 Is_Private
: Boolean;
4214 Chain
: Boolean := True)
4222 P
:= Unit
(Parent_Spec
(Lib_Unit
));
4223 P_Name
:= Get_Parent_Entity
(P
);
4225 if Etype
(P_Name
) = Any_Type
then
4229 if Ekind
(P_Name
) = E_Generic_Package
4230 and then Nkind
(Lib_Unit
) not in N_Generic_Declaration
4231 | N_Generic_Renaming_Declaration
4234 ("child of a generic package must be a generic unit", Lib_Unit
);
4236 elsif not Is_Package_Or_Generic_Package
(P_Name
) then
4238 ("parent unit must be package or generic package", Lib_Unit
);
4239 raise Unrecoverable_Error
;
4241 elsif Present
(Renamed_Entity
(P_Name
)) then
4242 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
4243 raise Unrecoverable_Error
;
4245 -- Verify that a child of an instance is itself an instance, or the
4246 -- renaming of one. Given that an instance that is a unit is replaced
4247 -- with a package declaration, check against the original node. The
4248 -- parent may be currently being instantiated, in which case it appears
4249 -- as a declaration, but the generic_parent is already established
4250 -- indicating that we deal with an instance.
4252 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
then
4253 if Nkind
(Lib_Unit
) in N_Renaming_Declaration
4254 or else Nkind
(Original_Node
(Lib_Unit
)) in N_Generic_Instantiation
4256 (Nkind
(Lib_Unit
) = N_Package_Declaration
4257 and then Present
(Generic_Parent
(Specification
(Lib_Unit
))))
4262 ("child of an instance must be an instance or renaming",
4267 -- This is the recursive call that ensures all parents are loaded
4269 if Is_Child_Spec
(P
) then
4273 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)),
4277 -- Now we can install the context for this parent
4279 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
), Chain
);
4280 Install_Limited_Context_Clauses
(Parent_Spec
(Lib_Unit
));
4281 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
4283 -- The child unit is in the declarative region of the parent. The parent
4284 -- must therefore appear in the scope stack and be visible, as when
4285 -- compiling the corresponding body. If the child unit is private or it
4286 -- is a package body, private declarations must be accessible as well.
4287 -- Use declarations in the parent must also be installed. Finally, other
4288 -- child units of the same parent that are in the context are
4289 -- immediately visible.
4291 -- Find entity for compilation unit, and set its private descendant
4292 -- status as needed. Indicate that it is a compilation unit, which is
4293 -- redundant in general, but needed if this is a generated child spec
4294 -- for a child body without previous spec.
4296 E_Name
:= Defining_Entity
(Lib_Unit
);
4298 Set_Is_Child_Unit
(E_Name
);
4299 Set_Is_Compilation_Unit
(E_Name
);
4301 Set_Is_Private_Descendant
(E_Name
,
4302 Is_Private_Descendant
(P_Name
)
4303 or else Private_Present
(Parent
(Lib_Unit
)));
4305 P_Spec
:= Package_Specification
(P_Name
);
4306 Push_Scope
(P_Name
);
4308 -- Save current visibility of unit
4310 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
4311 Is_Immediately_Visible
(P_Name
);
4312 Set_Is_Immediately_Visible
(P_Name
);
4313 Install_Visible_Declarations
(P_Name
);
4314 Set_Use
(Visible_Declarations
(P_Spec
));
4316 -- If the parent is a generic unit, its formal part may contain formal
4317 -- packages and use clauses for them.
4319 if Ekind
(P_Name
) = E_Generic_Package
then
4320 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
4323 if Is_Private
or else Private_Present
(Parent
(Lib_Unit
)) then
4324 Install_Private_Declarations
(P_Name
);
4325 Install_Private_With_Clauses
(P_Name
);
4326 Set_Use
(Private_Declarations
(P_Spec
));
4328 end Install_Parents
;
4330 ----------------------------------
4331 -- Install_Private_With_Clauses --
4332 ----------------------------------
4334 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
4335 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
4339 if Debug_Flag_I
then
4340 Write_Str
("install private with clauses of ");
4341 Write_Name
(Chars
(P
));
4345 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
4346 Item
:= First
(Context_Items
(Parent
(Decl
)));
4347 while Present
(Item
) loop
4348 if Nkind
(Item
) = N_With_Clause
4349 and then Private_Present
(Item
)
4351 -- If the unit is an ancestor of the current one, it is the
4352 -- case of a private limited with clause on a child unit, and
4353 -- the compilation of one of its descendants, In that case the
4354 -- limited view is errelevant.
4356 if Limited_Present
(Item
) then
4357 if not Limited_View_Installed
(Item
)
4359 not Is_Ancestor_Unit
(Library_Unit
(Item
),
4360 Cunit
(Current_Sem_Unit
))
4362 Install_Limited_With_Clause
(Item
);
4365 Install_With_Clause
(Item
, Private_With_OK
=> True);
4372 end Install_Private_With_Clauses
;
4374 ----------------------
4375 -- Install_Siblings --
4376 ----------------------
4378 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
4384 -- Iterate over explicit with clauses, and check whether the scope of
4385 -- each entity is an ancestor of the current unit, in which case it is
4386 -- immediately visible.
4388 Item
:= First
(Context_Items
(N
));
4389 while Present
(Item
) loop
4391 -- Do not install private_with_clauses declaration, unless unit
4392 -- is itself a private child unit, or is a body. Note that for a
4393 -- subprogram body the private_with_clause does not take effect
4394 -- until after the specification.
4396 if Nkind
(Item
) /= N_With_Clause
4397 or else Implicit_With
(Item
)
4398 or else Limited_Present
(Item
)
4399 or else Error_Posted
(Item
)
4401 -- Skip processing malformed trees
4403 or else (Try_Semantics
4404 and then Nkind
(Name
(Item
)) not in N_Has_Entity
)
4408 elsif not Private_Present
(Item
)
4409 or else Private_Present
(N
)
4410 or else Nkind
(Unit
(N
)) = N_Package_Body
4412 Id
:= Entity
(Name
(Item
));
4414 if Is_Child_Unit
(Id
)
4415 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
4417 Set_Is_Immediately_Visible
(Id
);
4419 -- Check for the presence of another unit in the context that
4420 -- may be inadvertently hidden by the child.
4422 Prev
:= Current_Entity
(Id
);
4425 and then Is_Immediately_Visible
(Prev
)
4426 and then not Is_Child_Unit
(Prev
)
4432 Clause
:= First
(Context_Items
(N
));
4433 while Present
(Clause
) loop
4434 if Nkind
(Clause
) = N_With_Clause
4435 and then Entity
(Name
(Clause
)) = Prev
4438 ("child unit& hides compilation unit " &
4439 "with the same name??",
4449 -- The With_Clause may be on a grandchild or one of its further
4450 -- descendants, which makes a child immediately visible. Examine
4451 -- ancestry to determine whether such a child exists. For example,
4452 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4453 -- is immediately visible.
4455 elsif Is_Child_Unit
(Id
) then
4461 while Is_Child_Unit
(Par
) loop
4462 if Is_Ancestor_Package
(Scope
(Par
), U_Name
) then
4463 Set_Is_Immediately_Visible
(Par
);
4472 -- If the item is a private with-clause on a child unit, the parent
4473 -- may have been installed already, but the child unit must remain
4474 -- invisible until installed in a private part or body, unless there
4475 -- is already a regular with_clause for it in the current unit.
4477 elsif Private_Present
(Item
) then
4478 Id
:= Entity
(Name
(Item
));
4480 if Is_Child_Unit
(Id
) then
4484 function In_Context
return Boolean;
4485 -- Scan context of current unit, to check whether there is
4486 -- a with_clause on the same unit as a private with-clause
4487 -- on a parent, in which case child unit is visible. If the
4488 -- unit is a grandchild, the same applies to its parent.
4494 function In_Context
return Boolean is
4497 First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4498 while Present
(Clause
) loop
4499 if Nkind
(Clause
) = N_With_Clause
4500 and then Comes_From_Source
(Clause
)
4501 and then Is_Entity_Name
(Name
(Clause
))
4502 and then not Private_Present
(Clause
)
4504 if Entity
(Name
(Clause
)) = Id
4506 (Nkind
(Name
(Clause
)) = N_Expanded_Name
4507 and then Entity
(Prefix
(Name
(Clause
))) = Id
)
4520 Set_Is_Visible_Lib_Unit
(Id
, In_Context
);
4527 end Install_Siblings
;
4529 ---------------------------------
4530 -- Install_Limited_With_Clause --
4531 ---------------------------------
4533 procedure Install_Limited_With_Clause
(N
: Node_Id
) is
4534 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
4537 Is_Child_Package
: Boolean := False;
4538 Lim_Header
: Entity_Id
;
4539 Lim_Typ
: Entity_Id
;
4541 procedure Check_Body_Required
;
4542 -- A unit mentioned in a limited with_clause may not be mentioned in
4543 -- a regular with_clause, but must still be included in the current
4544 -- partition. We need to determine whether the unit needs a body, so
4545 -- that the binder can determine the name of the file to be compiled.
4546 -- Checking whether a unit needs a body can be done without semantic
4547 -- analysis, by examining the nature of the declarations in the package.
4549 function Has_Limited_With_Clause
4550 (C_Unit
: Entity_Id
;
4551 Pack
: Entity_Id
) return Boolean;
4552 -- Determine whether any package in the ancestor chain starting with
4553 -- C_Unit has a limited with clause for package Pack.
4555 -------------------------
4556 -- Check_Body_Required --
4557 -------------------------
4559 procedure Check_Body_Required
is
4560 PA
: constant List_Id
:=
4561 Pragmas_After
(Aux_Decls_Node
(Parent
(P_Unit
)));
4563 procedure Check_Declarations
(Spec
: Node_Id
);
4564 -- Recursive procedure that does the work and checks nested packages
4566 ------------------------
4567 -- Check_Declarations --
4568 ------------------------
4570 procedure Check_Declarations
(Spec
: Node_Id
) is
4572 Incomplete_Decls
: constant Elist_Id
:= New_Elmt_List
;
4574 Subp_List
: constant Elist_Id
:= New_Elmt_List
;
4576 procedure Check_Pragma_Import
(P
: Node_Id
);
4577 -- If a pragma import applies to a previous subprogram, the
4578 -- enclosing unit may not need a body. The processing is syntactic
4579 -- and does not require a declaration to be analyzed. The code
4580 -- below also handles pragma Import when applied to a subprogram
4581 -- that renames another. In this case the pragma applies to the
4584 -- Chains of multiple renames are not handled by the code below.
4585 -- It is probably impossible to handle all cases without proper
4586 -- name resolution. In such cases the algorithm is conservative
4587 -- and will indicate that a body is needed???
4589 -------------------------
4590 -- Check_Pragma_Import --
4591 -------------------------
4593 procedure Check_Pragma_Import
(P
: Node_Id
) is
4599 procedure Remove_Homonyms
(E
: Node_Id
);
4600 -- Make one pass over list of subprograms. Called again if
4601 -- subprogram is a renaming. E is known to be an identifier.
4603 ---------------------
4604 -- Remove_Homonyms --
4605 ---------------------
4607 procedure Remove_Homonyms
(E
: Node_Id
) is
4608 R
: Entity_Id
:= Empty
;
4609 -- Name of renamed entity, if any
4612 Subp_Id
:= First_Elmt
(Subp_List
);
4613 while Present
(Subp_Id
) loop
4614 if Chars
(Node
(Subp_Id
)) = Chars
(E
) then
4615 if Nkind
(Parent
(Parent
(Node
(Subp_Id
))))
4616 /= N_Subprogram_Renaming_Declaration
4619 Next_Elmt
(Subp_Id
);
4620 Remove_Elmt
(Subp_List
, Prev_Id
);
4622 R
:= Name
(Parent
(Parent
(Node
(Subp_Id
))));
4626 Next_Elmt
(Subp_Id
);
4631 if Nkind
(R
) = N_Identifier
then
4632 Remove_Homonyms
(R
);
4634 elsif Nkind
(R
) = N_Selected_Component
then
4635 Remove_Homonyms
(Selector_Name
(R
));
4637 -- Renaming of attribute
4643 end Remove_Homonyms
;
4645 -- Start of processing for Check_Pragma_Import
4648 -- Find name of entity in Import pragma. We have not analyzed
4649 -- the construct, so we must guard against syntax errors.
4651 Arg
:= Next
(First
(Pragma_Argument_Associations
(P
)));
4654 or else Nkind
(Expression
(Arg
)) /= N_Identifier
4658 Imported
:= Expression
(Arg
);
4661 Remove_Homonyms
(Imported
);
4662 end Check_Pragma_Import
;
4664 -- Start of processing for Check_Declarations
4667 -- Search for Elaborate Body pragma
4669 Decl
:= First
(Visible_Declarations
(Spec
));
4670 while Present
(Decl
)
4671 and then Nkind
(Decl
) = N_Pragma
4673 if Get_Pragma_Id
(Decl
) = Pragma_Elaborate_Body
then
4674 Set_Body_Required
(Library_Unit
(N
));
4681 -- Look for declarations that require the presence of a body. We
4682 -- have already skipped pragmas at the start of the list.
4684 while Present
(Decl
) loop
4686 -- Subprogram that comes from source means body may be needed.
4687 -- Save for subsequent examination of import pragmas.
4689 if Comes_From_Source
(Decl
)
4690 and then (Nkind
(Decl
) in N_Subprogram_Declaration
4691 | N_Subprogram_Renaming_Declaration
4692 | N_Generic_Subprogram_Declaration
)
4694 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4696 -- Package declaration of generic package declaration. We need
4697 -- to recursively examine nested declarations.
4699 elsif Nkind
(Decl
) in N_Package_Declaration
4700 | N_Generic_Package_Declaration
4702 Check_Declarations
(Specification
(Decl
));
4704 elsif Nkind
(Decl
) = N_Pragma
4705 and then Pragma_Name
(Decl
) = Name_Import
4707 Check_Pragma_Import
(Decl
);
4713 -- Same set of tests for private part. In addition to subprograms
4714 -- detect the presence of Taft Amendment types (incomplete types
4715 -- completed in the body).
4717 Decl
:= First
(Private_Declarations
(Spec
));
4718 while Present
(Decl
) loop
4719 if Comes_From_Source
(Decl
)
4720 and then Nkind
(Decl
) in N_Subprogram_Declaration
4721 | N_Subprogram_Renaming_Declaration
4722 | N_Generic_Subprogram_Declaration
4724 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4726 elsif Nkind
(Decl
) in N_Package_Declaration
4727 | N_Generic_Package_Declaration
4729 Check_Declarations
(Specification
(Decl
));
4731 -- Collect incomplete type declarations for separate pass
4733 elsif Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
4734 Append_Elmt
(Decl
, Incomplete_Decls
);
4736 elsif Nkind
(Decl
) = N_Pragma
4737 and then Pragma_Name
(Decl
) = Name_Import
4739 Check_Pragma_Import
(Decl
);
4745 -- Now check incomplete declarations to locate Taft amendment
4746 -- types. This can be done by examining the defining identifiers
4747 -- of type declarations without real semantic analysis.
4753 Inc
:= First_Elmt
(Incomplete_Decls
);
4754 while Present
(Inc
) loop
4755 Decl
:= Next
(Node
(Inc
));
4756 while Present
(Decl
) loop
4757 if Nkind
(Decl
) = N_Full_Type_Declaration
4758 and then Chars
(Defining_Identifier
(Decl
)) =
4759 Chars
(Defining_Identifier
(Node
(Inc
)))
4767 -- If no completion, this is a TAT, and a body is needed
4770 Set_Body_Required
(Library_Unit
(N
));
4778 -- Finally, check whether there are subprograms that still require
4779 -- a body, i.e. are not renamings or null.
4781 if not Is_Empty_Elmt_List
(Subp_List
) then
4787 Subp_Id
:= First_Elmt
(Subp_List
);
4788 Spec
:= Parent
(Node
(Subp_Id
));
4790 while Present
(Subp_Id
) loop
4791 if Nkind
(Parent
(Spec
))
4792 = N_Subprogram_Renaming_Declaration
4796 elsif Nkind
(Spec
) = N_Procedure_Specification
4797 and then Null_Present
(Spec
)
4802 Set_Body_Required
(Library_Unit
(N
));
4806 Next_Elmt
(Subp_Id
);
4810 end Check_Declarations
;
4812 -- Start of processing for Check_Body_Required
4815 -- If this is an imported package (Java and CIL usage) no body is
4816 -- needed. Scan list of pragmas that may follow a compilation unit
4817 -- to look for a relevant pragma Import.
4819 if Present
(PA
) then
4825 while Present
(Prag
) loop
4826 if Nkind
(Prag
) = N_Pragma
4827 and then Get_Pragma_Id
(Prag
) = Pragma_Import
4837 Check_Declarations
(Specification
(P_Unit
));
4838 end Check_Body_Required
;
4840 -----------------------------
4841 -- Has_Limited_With_Clause --
4842 -----------------------------
4844 function Has_Limited_With_Clause
4845 (C_Unit
: Entity_Id
;
4846 Pack
: Entity_Id
) return Boolean
4853 while Present
(Par
) loop
4854 if Ekind
(Par
) /= E_Package
then
4858 -- Retrieve the Compilation_Unit node for Par and determine if
4859 -- its context clauses contain a limited with for Pack.
4861 Par_Unit
:= Parent
(Parent
(Parent
(Par
)));
4863 if Nkind
(Par_Unit
) = N_Package_Declaration
then
4864 Par_Unit
:= Parent
(Par_Unit
);
4867 if Has_With_Clause
(Par_Unit
, Pack
, True) then
4871 -- If there are more ancestors, climb up the tree, otherwise we
4874 if Is_Child_Unit
(Par
) then
4882 end Has_Limited_With_Clause
;
4884 -- Start of processing for Install_Limited_With_Clause
4887 pragma Assert
(not Limited_View_Installed
(N
));
4889 -- In case of limited with_clause on subprograms, generics, instances,
4890 -- or renamings, the corresponding error was previously posted and we
4891 -- have nothing to do here. If the file is missing altogether, it has
4892 -- no source location.
4894 if Nkind
(P_Unit
) /= N_Package_Declaration
4895 or else Sloc
(P_Unit
) = No_Location
4900 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
4902 -- Handle child packages
4904 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
4905 Is_Child_Package
:= True;
4906 P
:= Defining_Identifier
(P
);
4909 -- Do not install the limited-view if the context of the unit is already
4910 -- available through a regular with clause.
4912 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4913 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4918 -- Do not install the limited-view if the full-view is already visible
4919 -- through renaming declarations.
4921 if Is_Visible_Through_Renamings
(P
, N
) then
4925 -- Do not install the limited view if this is the unit being analyzed.
4926 -- This unusual case will happen when a unit has a limited_with clause
4927 -- on one of its children. The compilation of the child forces the load
4928 -- of the parent which tries to install the limited view of the child
4929 -- again. Installing the limited view must also be disabled when
4930 -- compiling the body of the child unit.
4932 if P
= Cunit_Entity
(Current_Sem_Unit
)
4933 or else (Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4934 and then P
= Main_Unit_Entity
4935 and then Is_Ancestor_Unit
4936 (Cunit
(Main_Unit
), Cunit
(Current_Sem_Unit
)))
4941 -- This scenario is similar to the one above, the difference is that the
4942 -- compilation of sibling Par.Sib forces the load of parent Par which
4943 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
4944 -- has a with clause for Lim_Pack [2] in its body, and thus needs the
4945 -- nonlimited views of all entities from Lim_Pack.
4947 -- limited with Lim_Pack; -- [1]
4948 -- package Par is ... package Lim_Pack is ...
4950 -- with Lim_Pack; -- [2]
4951 -- package Par.Sib is ... package body Par.Sib is ...
4953 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
4954 -- Sem_Unit is the body of Par.Sib.
4956 if Ekind
(P
) = E_Package
4957 and then Ekind
(Main_Unit_Entity
) = E_Package
4958 and then Is_Child_Unit
(Main_Unit_Entity
)
4960 -- The body has a regular with clause
4962 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4963 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4965 -- One of the ancestors has a limited with clause
4967 and then Nkind
(Parent
(Parent
(Main_Unit_Entity
))) =
4968 N_Package_Specification
4969 and then Has_Limited_With_Clause
(Scope
(Main_Unit_Entity
), P
)
4974 -- A common use of the limited-with is to have a limited-with in the
4975 -- package spec, and a normal with in its package body. For example:
4977 -- limited with X; -- [1]
4981 -- package body A is ...
4983 -- The compilation of A's body installs the context clauses found at [2]
4984 -- and then the context clauses of its specification (found at [1]). As
4985 -- a consequence, at [1] the specification of X has been analyzed and it
4986 -- is immediately visible. According to the semantics of limited-with
4987 -- context clauses we don't install the limited view because the full
4988 -- view of X supersedes its limited view.
4990 if Analyzed
(P_Unit
)
4992 (Is_Immediately_Visible
(P
)
4993 or else (Is_Child_Package
and then Is_Visible_Lib_Unit
(P
)))
4996 -- The presence of both the limited and the analyzed nonlimited view
4997 -- may also be an error, such as an illegal context for a limited
4998 -- with_clause. In that case, do not process the context item at all.
5000 if Error_Posted
(N
) then
5004 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
5008 Item
:= First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
5009 while Present
(Item
) loop
5010 if Nkind
(Item
) = N_With_Clause
5011 and then Comes_From_Source
(Item
)
5012 and then Entity
(Name
(Item
)) = P
5021 -- If this is a child body, assume that the nonlimited with_clause
5022 -- appears in an ancestor. Could be refined ???
5026 (Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)))))
5033 -- If in package declaration, nonlimited view brought in from
5034 -- parent unit or some error condition.
5040 if Debug_Flag_I
then
5041 Write_Str
("install limited view of ");
5042 Write_Name
(Chars
(P
));
5046 -- If the unit has not been analyzed and the limited view has not been
5047 -- already installed then we install it.
5049 if not Analyzed
(P_Unit
) then
5050 if not In_Chain
(P
) then
5052 -- Minimum decoration
5054 Mutate_Ekind
(P
, E_Package
);
5055 Set_Etype
(P
, Standard_Void_Type
);
5056 Set_Scope
(P
, Standard_Standard
);
5057 Set_Is_Visible_Lib_Unit
(P
);
5059 if Is_Child_Package
then
5060 Set_Is_Child_Unit
(P
);
5061 Set_Scope
(P
, Defining_Entity
(Unit
(Parent_Spec
(P_Unit
))));
5064 -- Place entity on visibility structure
5066 Set_Homonym
(P
, Current_Entity
(P
));
5067 Set_Current_Entity
(P
);
5069 if Debug_Flag_I
then
5070 Write_Str
(" (homonym) chain ");
5071 Write_Name
(Chars
(P
));
5075 -- Install the incomplete view. The first element of the limited
5076 -- view is a header (an E_Package entity) used to reference the
5077 -- first shadow entity in the private part of the package.
5079 Lim_Header
:= Limited_View
(P
);
5080 Lim_Typ
:= First_Entity
(Lim_Header
);
5082 while Present
(Lim_Typ
)
5083 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
5085 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
5086 Set_Current_Entity
(Lim_Typ
);
5088 if Debug_Flag_I
then
5089 Write_Str
(" (homonym) chain ");
5090 Write_Name
(Chars
(Lim_Typ
));
5094 Next_Entity
(Lim_Typ
);
5098 -- If the unit appears in a previous regular with_clause, the regular
5099 -- entities of the public part of the withed package must be replaced
5100 -- by the shadow ones.
5102 -- This code must be kept synchronized with the code that replaces the
5103 -- shadow entities by the real entities in Remove_Limited_With_Unit,
5104 -- otherwise the contents of the homonym chains are not consistent.
5107 -- Hide all the type entities of the public part of the package to
5108 -- avoid its usage. This is needed to cover all the subtype decla-
5109 -- rations because we do not remove them from the homonym chain.
5111 E
:= First_Entity
(P
);
5112 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
5114 Set_Was_Hidden
(E
, Is_Hidden
(E
));
5121 -- Replace the real entities by the shadow entities of the limited
5122 -- view. The first element of the limited view is a header that is
5123 -- used to reference the first shadow entity in the private part
5124 -- of the package. Successive elements are the limited views of the
5125 -- type (including regular incomplete types) declared in the package.
5127 Lim_Header
:= Limited_View
(P
);
5129 Lim_Typ
:= First_Entity
(Lim_Header
);
5130 while Present
(Lim_Typ
)
5131 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
5133 pragma Assert
(not In_Chain
(Lim_Typ
));
5135 -- Do not unchain nested packages and child units
5137 if Ekind
(Lim_Typ
) /= E_Package
5138 and then not Is_Child_Unit
(Lim_Typ
)
5141 Non_Lim_View
: constant Entity_Id
:=
5142 Non_Limited_View
(Lim_Typ
);
5147 Prev
:= Current_Entity
(Lim_Typ
);
5149 -- Replace Non_Lim_View in the homonyms list, so that the
5150 -- limited view becomes available.
5152 -- If the nonlimited view is a record with an anonymous
5153 -- self-referential component, the analysis of the record
5154 -- declaration creates an incomplete type with the same name
5155 -- in order to define an internal access type. The visible
5156 -- entity is now the incomplete type, and that is the one to
5157 -- replace in the visibility structure.
5159 -- Similarly, if the source already contains the incomplete
5160 -- type declaration, the limited view of the incomplete type
5161 -- is in fact never visible (AI05-129) but we have created a
5162 -- shadow entity E1 for it that points to E2, the incomplete
5163 -- type at stake. This in turn has full view E3 that is the
5164 -- full declaration, with a corresponding shadow entity E4.
5165 -- When reinstalling the limited view, the visible entity E2
5166 -- is first replaced with E1, but E4 must eventually become
5167 -- the visible entity as per the AI and thus displace E1, as
5168 -- it is replacing E3 in the homonyms list.
5170 -- regular views limited views
5172 -- * E2 (incomplete) <-- E1 (shadow)
5177 -- E3 (full) <-- E4 (shadow) *
5179 -- [*] denotes the visible entity (Current_Entity)
5181 if Prev
= Non_Lim_View
5183 (Ekind
(Prev
) = E_Incomplete_Type
5184 and then Full_View
(Prev
) = Non_Lim_View
)
5186 (Ekind
(Prev
) = E_Incomplete_Type
5187 and then From_Limited_With
(Prev
)
5189 Ekind
(Non_Limited_View
(Prev
)) = E_Incomplete_Type
5191 Full_View
(Non_Limited_View
(Prev
)) = Non_Lim_View
)
5193 Set_Current_Entity
(Lim_Typ
);
5196 while Present
(Homonym
(Prev
))
5197 and then Homonym
(Prev
) /= Non_Lim_View
5199 Prev
:= Homonym
(Prev
);
5202 Set_Homonym
(Prev
, Lim_Typ
);
5205 Set_Homonym
(Lim_Typ
, Homonym
(Non_Lim_View
));
5208 if Debug_Flag_I
then
5209 Write_Str
(" (homonym) chain ");
5210 Write_Name
(Chars
(Lim_Typ
));
5215 Next_Entity
(Lim_Typ
);
5219 -- The package must be visible while the limited-with clause is active
5220 -- because references to the type P.T must resolve in the usual way.
5221 -- In addition, we remember that the limited-view has been installed to
5222 -- uninstall it at the point of context removal.
5224 Set_Is_Immediately_Visible
(P
);
5225 Set_Limited_View_Installed
(N
);
5227 -- If unit has not been analyzed in some previous context, check
5228 -- (imperfectly ???) whether it might need a body.
5230 if not Analyzed
(P_Unit
) then
5231 Check_Body_Required
;
5234 -- If the package in the limited_with clause is a child unit, the clause
5235 -- is unanalyzed and appears as a selected component. Recast it as an
5236 -- expanded name so that the entity can be properly set. Use entity of
5237 -- parent, if available, for higher ancestors in the name.
5239 if Nkind
(Name
(N
)) = N_Selected_Component
then
5247 while Nkind
(Nam
) = N_Selected_Component
5248 and then Present
(Ent
)
5250 Change_Selected_Component_To_Expanded_Name
(Nam
);
5252 -- Set entity of parent identifiers if the unit is a child
5253 -- unit. This ensures that the tree is properly formed from
5254 -- semantic point of view. The unit entities are not fully
5255 -- analyzed, so we need to follow unit links in the tree.
5257 Set_Entity
(Nam
, Ent
);
5259 Nam
:= Prefix
(Nam
);
5262 (Unit
(Parent_Spec
(Unit_Declaration_Node
(Ent
))));
5264 -- Set entity of last ancestor
5266 if Nkind
(Nam
) = N_Identifier
then
5267 Set_Entity
(Nam
, Ent
);
5273 Set_Entity
(Name
(N
), P
);
5274 Set_From_Limited_With
(P
);
5275 end Install_Limited_With_Clause
;
5277 -------------------------
5278 -- Install_With_Clause --
5279 -------------------------
5281 procedure Install_With_Clause
5282 (With_Clause
: Node_Id
;
5283 Private_With_OK
: Boolean := False)
5285 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
5286 P
: constant Entity_Id
:= Scope
(Uname
);
5289 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
5290 -- compiling a package declaration and the Private_With_OK flag was not
5291 -- set by the caller. These declarations will be installed later (before
5292 -- analyzing the private part of the package).
5294 if Private_Present
(With_Clause
)
5295 and then Nkind
(Unit
(Parent
(With_Clause
)))
5296 in N_Package_Declaration | N_Generic_Package_Declaration
5297 and then not Private_With_OK
5302 if Debug_Flag_I
then
5303 if Private_Present
(With_Clause
) then
5304 Write_Str
("install private withed unit ");
5306 Write_Str
("install withed unit ");
5309 Write_Name
(Chars
(Uname
));
5313 -- We do not apply the restrictions to an internal unit unless we are
5314 -- compiling the internal unit as a main unit. This check is also
5315 -- skipped for dummy units (for missing packages).
5317 if Sloc
(Uname
) /= No_Location
5318 and then (not Is_Internal_Unit
(Current_Sem_Unit
)
5319 or else Current_Sem_Unit
= Main_Unit
)
5321 Check_Restricted_Unit
5322 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
5325 if P
/= Standard_Standard
then
5327 -- If the unit is not analyzed after analysis of the with clause and
5328 -- it is an instantiation then it awaits a body and is the main unit.
5329 -- Its appearance in the context of some other unit indicates a
5330 -- circular dependency (DEC suite perversity).
5332 if not Analyzed
(Uname
)
5333 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
5336 ("instantiation depends on itself", Name
(With_Clause
));
5338 elsif not Analyzed
(Uname
)
5339 and then Is_Internal_Unit
(Current_Sem_Unit
)
5340 and then not Is_Visible_Lib_Unit
(Uname
)
5341 and then No
(Scope
(Uname
))
5343 if Is_Predefined_Unit
(Current_Sem_Unit
) then
5345 ("predefined unit depends on itself", Name
(With_Clause
));
5348 ("GNAT-defined unit depends on itself", Name
(With_Clause
));
5352 elsif not Is_Visible_Lib_Unit
(Uname
) then
5354 -- Abandon processing in case of previous errors
5356 if No
(Scope
(Uname
)) then
5357 Check_Error_Detected
;
5361 Set_Is_Visible_Lib_Unit
(Uname
);
5363 -- If the unit is a wrapper package for a compilation unit that is
5364 -- a subprogram instance, indicate that the instance itself is a
5365 -- visible unit. This is necessary if the instance is inlined.
5367 if Is_Wrapper_Package
(Uname
) then
5368 Set_Is_Visible_Lib_Unit
(Related_Instance
(Uname
));
5371 -- If the child unit appears in the context of its parent, it is
5372 -- immediately visible.
5374 if In_Open_Scopes
(Scope
(Uname
)) then
5375 Set_Is_Immediately_Visible
(Uname
);
5378 if Is_Generic_Instance
(Uname
)
5379 and then Is_Subprogram
(Uname
)
5381 -- Set flag as well on the visible entity that denotes the
5382 -- instance, which renames the current one.
5384 Set_Is_Visible_Lib_Unit
5386 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
5389 -- The parent unit may have been installed already, and may have
5390 -- appeared in a use clause.
5392 if In_Use
(Scope
(Uname
)) then
5393 Set_Is_Potentially_Use_Visible
(Uname
);
5396 Set_Context_Installed
(With_Clause
);
5399 elsif not Is_Immediately_Visible
(Uname
) then
5400 Set_Is_Visible_Lib_Unit
(Uname
);
5402 if not Private_Present
(With_Clause
) or else Private_With_OK
then
5403 Set_Is_Immediately_Visible
(Uname
);
5406 Set_Context_Installed
(With_Clause
);
5409 -- A [private] with clause overrides a limited with clause. Restore the
5410 -- proper view of the package by performing the following actions:
5412 -- * Remove all shadow entities which hide their corresponding
5413 -- entities from direct visibility by updating the entity and
5416 -- * Enter the corresponding entities back in direct visibility
5418 -- Note that the original limited with clause which installed its view
5419 -- is still marked as "active". This effect is undone when the clause
5420 -- itself is removed, see Remove_Limited_With_Clause.
5422 if Ekind
(Uname
) = E_Package
and then From_Limited_With
(Uname
) then
5423 Remove_Limited_With_Unit
(Unit_Declaration_Node
(Uname
));
5426 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5427 -- unit if there is a visible homograph for it declared in the same
5428 -- declarative region. This pathological case can only arise when an
5429 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5430 -- G1 has a generic child also named G2, and the context includes with_
5431 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
5432 -- of I1.G2 visible as well. If the child unit is named Standard, do
5433 -- not apply the check to the Standard package itself.
5435 if Is_Child_Unit
(Uname
)
5436 and then Is_Visible_Lib_Unit
(Uname
)
5437 and then Ada_Version
>= Ada_2005
5440 Decl1
: constant Node_Id
:= Unit_Declaration_Node
(P
);
5446 U2
:= Homonym
(Uname
);
5447 while Present
(U2
) and then U2
/= Standard_Standard
loop
5449 Decl2
:= Unit_Declaration_Node
(P2
);
5451 if Is_Child_Unit
(U2
) and then Is_Visible_Lib_Unit
(U2
) then
5452 if Is_Generic_Instance
(P
)
5453 and then Nkind
(Decl1
) = N_Package_Declaration
5454 and then Generic_Parent
(Specification
(Decl1
)) = P2
5456 Error_Msg_N
("illegal with_clause", With_Clause
);
5458 ("\child unit has visible homograph" &
5459 " (RM 8.3(26), 10.1.1(19))",
5463 elsif Is_Generic_Instance
(P2
)
5464 and then Nkind
(Decl2
) = N_Package_Declaration
5465 and then Generic_Parent
(Specification
(Decl2
)) = P
5467 -- With_clause for child unit of instance appears before
5468 -- in the context. We want to place the error message on
5469 -- it, not on the generic child unit itself.
5472 Prev_Clause
: Node_Id
;
5475 Prev_Clause
:= First
(List_Containing
(With_Clause
));
5476 while Entity
(Name
(Prev_Clause
)) /= U2
loop
5480 pragma Assert
(Present
(Prev_Clause
));
5481 Error_Msg_N
("illegal with_clause", Prev_Clause
);
5483 ("\child unit has visible homograph" &
5484 " (RM 8.3(26), 10.1.1(19))",
5495 end Install_With_Clause
;
5501 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
5502 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
5505 return (K
in N_Generic_Declaration
or else
5506 K
in N_Generic_Instantiation
or else
5507 K
in N_Generic_Renaming_Declaration
or else
5508 K
= N_Package_Declaration
or else
5509 K
= N_Package_Renaming_Declaration
or else
5510 K
= N_Subprogram_Declaration
or else
5511 K
= N_Subprogram_Renaming_Declaration
)
5512 and then Present
(Parent_Spec
(Lib_Unit
));
5515 ------------------------------------
5516 -- Is_Legal_Shadow_Entity_In_Body --
5517 ------------------------------------
5519 function Is_Legal_Shadow_Entity_In_Body
(T
: Entity_Id
) return Boolean is
5520 C_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
5522 return Nkind
(Unit
(C_Unit
)) = N_Package_Body
5525 (C_Unit
, Cunit_Entity
(Get_Source_Unit
(Non_Limited_View
(T
))));
5526 end Is_Legal_Shadow_Entity_In_Body
;
5528 ----------------------
5529 -- Is_Ancestor_Unit --
5530 ----------------------
5532 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean is
5533 E1
: constant Entity_Id
:= Defining_Entity
(Unit
(U1
));
5536 if Nkind
(Unit
(U2
)) in N_Package_Body | N_Subprogram_Body
then
5537 E2
:= Defining_Entity
(Unit
(Library_Unit
(U2
)));
5538 return Is_Ancestor_Package
(E1
, E2
);
5542 end Is_Ancestor_Unit
;
5544 ----------------------------------
5545 -- Is_Visible_Through_Renamings --
5546 ----------------------------------
5548 function Is_Visible_Through_Renamings
5550 Error_Node
: Node_Id
:= Empty
) return Boolean
5552 function Is_Limited_Withed_Unit
5553 (Lib_Unit
: Node_Id
;
5554 Pkg_Ent
: Entity_Id
) return Boolean;
5555 -- Return True if Pkg_Ent is a limited-withed package of the given
5558 ----------------------------
5559 -- Is_Limited_Withed_Unit --
5560 ----------------------------
5562 function Is_Limited_Withed_Unit
5563 (Lib_Unit
: Node_Id
;
5564 Pkg_Ent
: Entity_Id
) return Boolean
5566 Item
: Node_Id
:= First
(Context_Items
(Lib_Unit
));
5569 while Present
(Item
) loop
5570 if Nkind
(Item
) = N_With_Clause
5571 and then Limited_Present
(Item
)
5572 and then Entity
(Name
(Item
)) = Pkg_Ent
5581 end Is_Limited_Withed_Unit
;
5585 Kind
: constant Node_Kind
:= Nkind
(Unit
(Cunit
(Current_Sem_Unit
)));
5591 -- Example of the error detected by this subprogram:
5599 -- package Ren_P renames P;
5605 -- limited with P; -- ERROR
5606 -- package R.C is ...
5608 Aux_Unit
:= Cunit
(Current_Sem_Unit
);
5611 Item
:= First
(Context_Items
(Aux_Unit
));
5612 while Present
(Item
) loop
5613 if Nkind
(Item
) = N_With_Clause
5614 and then not Limited_Present
(Item
)
5615 and then Nkind
(Unit
(Library_Unit
(Item
))) =
5616 N_Package_Declaration
5619 First
(Visible_Declarations
5620 (Specification
(Unit
(Library_Unit
(Item
)))));
5621 while Present
(Decl
) loop
5622 if Nkind
(Decl
) = N_Package_Renaming_Declaration
5623 and then Entity
(Name
(Decl
)) = P
5624 and then not Is_Limited_Withed_Unit
5625 (Lib_Unit
=> Library_Unit
(Item
),
5626 Pkg_Ent
=> Entity
(Name
(Decl
)))
5628 -- Generate the error message only if the current unit
5629 -- is a package declaration; in case of subprogram
5630 -- bodies and package bodies we just return True to
5631 -- indicate that the limited view must not be
5634 if Kind
= N_Package_Declaration
5635 and then Present
(Error_Node
)
5638 ("simultaneous visibility of the limited and " &
5639 "unlimited views not allowed", Error_Node
);
5640 Error_Msg_Sloc
:= Sloc
(Item
);
5642 ("\\ unlimited view of & visible through the " &
5643 "context clause #", Error_Node
, P
);
5644 Error_Msg_Sloc
:= Sloc
(Decl
);
5645 Error_Msg_NE
("\\ and the renaming #", Error_Node
, P
);
5658 -- If it is a body not acting as spec, follow pointer to the
5659 -- corresponding spec, otherwise follow pointer to parent spec.
5661 if Present
(Library_Unit
(Aux_Unit
))
5662 and then Nkind
(Unit
(Aux_Unit
)) in
5663 N_Package_Body | N_Subprogram_Body
5665 if Aux_Unit
= Library_Unit
(Aux_Unit
) then
5667 -- Aux_Unit is a body that acts as a spec. Clause has
5668 -- already been flagged as illegal.
5673 Aux_Unit
:= Library_Unit
(Aux_Unit
);
5677 Aux_Unit
:= Parent_Spec
(Unit
(Aux_Unit
));
5680 exit when No
(Aux_Unit
);
5684 end Is_Visible_Through_Renamings
;
5686 -----------------------
5687 -- Load_Needed_Body --
5688 -----------------------
5690 -- N is a generic unit named in a with clause, or else it is a unit that
5691 -- contains a generic unit or an inlined function. In order to perform an
5692 -- instantiation, the body of the unit must be present. If the unit itself
5693 -- is generic, we assume that an instantiation follows, and load & analyze
5694 -- the body unconditionally. This forces analysis of the spec as well.
5696 -- If the unit is not generic, but contains a generic unit, it is loaded on
5697 -- demand, at the point of instantiation (see ch12).
5699 procedure Load_Needed_Body
5703 Body_Name
: Unit_Name_Type
;
5704 Unum
: Unit_Number_Type
;
5706 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
5707 -- The loading and analysis is done with style checks off
5710 if not GNAT_Mode
then
5711 Style_Check
:= False;
5714 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
5717 (Load_Name
=> Body_Name
,
5723 if Unum
= No_Unit
then
5727 Compiler_State
:= Analyzing
; -- reset after load
5729 if Fatal_Error
(Unum
) /= Error_Detected
or else Try_Semantics
then
5730 if Debug_Flag_L
then
5731 Write_Str
("*** Loaded generic body");
5735 -- We always perform analyses
5736 Semantics
(Cunit
(Unum
));
5742 Style_Check
:= Save_Style_Check
;
5743 end Load_Needed_Body
;
5745 -------------------------
5746 -- Build_Limited_Views --
5747 -------------------------
5749 procedure Build_Limited_Views
(N
: Node_Id
) is
5750 Unum
: constant Unit_Number_Type
:=
5751 Get_Source_Unit
(Library_Unit
(N
));
5752 Is_Analyzed
: constant Boolean := Analyzed
(Cunit
(Unum
));
5754 Shadow_Pack
: Entity_Id
;
5755 -- The corresponding shadow entity of the withed package. This entity
5756 -- offers incomplete views of packages and types as well as abstract
5757 -- views of states and variables declared within.
5759 Last_Shadow
: Entity_Id
:= Empty
;
5760 -- The last shadow entity created by routine Build_Shadow_Entity
5762 procedure Build_Shadow_Entity
5765 Shadow
: out Entity_Id
;
5766 Is_Tagged
: Boolean := False);
5767 -- Create a shadow entity that hides Ent and offers an abstract or
5768 -- incomplete view of Ent. Scop is the proper scope. Flag Is_Tagged
5769 -- should be set when Ent is a tagged type. The generated entity is
5770 -- added to Shadow_Pack. The routine updates the value of Last_Shadow.
5772 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5773 -- Perform minimal decoration of a package or its corresponding shadow
5774 -- entity denoted by Ent. Scop is the proper scope.
5776 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5777 -- Perform full decoration of an abstract state or its corresponding
5778 -- shadow entity denoted by Ent. Scop is the proper scope.
5780 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
);
5781 -- Perform minimal decoration of a variable denoted by Ent. Scop is the
5784 procedure Process_Declarations_And_States
5788 Create_Abstract_Views
: Boolean);
5789 -- Inspect the states of package Pack and declarative list Decls. Create
5790 -- shadow entities for all nested packages, states, types and variables
5791 -- encountered. Scop is the proper scope. Create_Abstract_Views should
5792 -- be set when the abstract states and variables need to be processed.
5794 -------------------------
5795 -- Build_Shadow_Entity --
5796 -------------------------
5798 procedure Build_Shadow_Entity
5801 Shadow
: out Entity_Id
;
5802 Is_Tagged
: Boolean := False)
5805 Shadow
:= Make_Temporary
(Sloc
(Ent
), 'Z');
5807 -- The shadow entity must share the same name and parent as the
5810 Set_Chars
(Shadow
, Chars
(Ent
));
5811 Set_Parent
(Shadow
, Parent
(Ent
));
5813 -- The abstract view of a variable is a state, not another variable
5815 if Ekind
(Ent
) = E_Variable
then
5816 Mutate_Ekind
(Shadow
, E_Abstract_State
);
5818 Mutate_Ekind
(Shadow
, Ekind
(Ent
));
5821 Set_Is_Internal
(Shadow
);
5822 Set_From_Limited_With
(Shadow
);
5824 -- Add the new shadow entity to the limited view of the package
5826 Last_Shadow
:= Shadow
;
5827 Append_Entity
(Shadow
, Shadow_Pack
);
5829 -- Perform context-specific decoration of the shadow entity
5831 if Ekind
(Ent
) = E_Abstract_State
then
5832 Decorate_State
(Shadow
, Scop
);
5833 Set_Non_Limited_View
(Shadow
, Ent
);
5835 elsif Ekind
(Ent
) = E_Package
then
5836 Decorate_Package
(Shadow
, Scop
);
5838 elsif Is_Type
(Ent
) then
5839 Decorate_Type
(Shadow
, Scop
, Is_Tagged
);
5841 -- If Ent is a private type and we are analyzing the body of its
5842 -- scope, its private and full views are swapped and, therefore,
5843 -- we need to undo this swapping in order to build the same shadow
5844 -- entity as we would have in other contexts.
5846 if Is_Private_Type
(Ent
)
5847 and then Present
(Full_View
(Ent
))
5848 and then In_Package_Body
(Scop
)
5850 Set_Non_Limited_View
(Shadow
, Full_View
(Ent
));
5852 Set_Non_Limited_View
(Shadow
, Ent
);
5856 Set_Non_Limited_View
5857 (Class_Wide_Type
(Shadow
), Class_Wide_Type
(Ent
));
5860 if Is_Incomplete_Or_Private_Type
(Ent
) then
5861 Set_Private_Dependents
(Shadow
, New_Elmt_List
);
5864 elsif Ekind
(Ent
) = E_Variable
then
5865 Decorate_State
(Shadow
, Scop
);
5866 Set_Non_Limited_View
(Shadow
, Ent
);
5868 end Build_Shadow_Entity
;
5870 ----------------------
5871 -- Decorate_Package --
5872 ----------------------
5874 procedure Decorate_Package
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5876 Mutate_Ekind
(Ent
, E_Package
);
5877 Set_Etype
(Ent
, Standard_Void_Type
);
5878 Set_Scope
(Ent
, Scop
);
5879 end Decorate_Package
;
5881 --------------------
5882 -- Decorate_State --
5883 --------------------
5885 procedure Decorate_State
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5887 Mutate_Ekind
(Ent
, E_Abstract_State
);
5888 Set_Etype
(Ent
, Standard_Void_Type
);
5889 Set_Scope
(Ent
, Scop
);
5890 Set_Encapsulating_State
(Ent
, Empty
);
5893 -----------------------
5894 -- Decorate_Variable --
5895 -----------------------
5897 procedure Decorate_Variable
(Ent
: Entity_Id
; Scop
: Entity_Id
) is
5899 Mutate_Ekind
(Ent
, E_Variable
);
5900 Set_Etype
(Ent
, Standard_Void_Type
);
5901 Set_Scope
(Ent
, Scop
);
5902 end Decorate_Variable
;
5904 -------------------------------------
5905 -- Process_Declarations_And_States --
5906 -------------------------------------
5908 procedure Process_Declarations_And_States
5912 Create_Abstract_Views
: Boolean)
5914 procedure Find_And_Process_States
;
5915 -- Determine whether package Pack defines abstract state either by
5916 -- using an aspect or a pragma. If this is the case, build shadow
5917 -- entities for all abstract states of Pack.
5919 procedure Process_States
(States
: Elist_Id
);
5920 -- Generate shadow entities for all abstract states in list States
5922 -----------------------------
5923 -- Find_And_Process_States --
5924 -----------------------------
5926 procedure Find_And_Process_States
is
5927 procedure Process_State
(State
: Node_Id
);
5928 -- Generate shadow entities for a single abstract state or
5929 -- multiple states expressed as an aggregate.
5935 procedure Process_State
(State
: Node_Id
) is
5936 Loc
: constant Source_Ptr
:= Sloc
(State
);
5943 -- Multiple abstract states appear as an aggregate
5945 if Nkind
(State
) = N_Aggregate
then
5946 Elmt
:= First
(Expressions
(State
));
5947 while Present
(Elmt
) loop
5948 Process_State
(Elmt
);
5954 -- A null state has no abstract view
5956 elsif Nkind
(State
) = N_Null
then
5959 -- State declaration with various options appears as an
5960 -- extension aggregate.
5962 elsif Nkind
(State
) = N_Extension_Aggregate
then
5963 Decl
:= Ancestor_Part
(State
);
5965 -- Simple state declaration
5967 elsif Nkind
(State
) = N_Identifier
then
5970 -- Possibly an illegal state declaration
5976 -- Abstract states are elaborated when the related pragma is
5977 -- elaborated. Since the withed package is not analyzed yet,
5978 -- the entities of the abstract states are not available. To
5979 -- overcome this complication, create the entities now and
5980 -- store them in their respective declarations. The entities
5981 -- are later used by routine Create_Abstract_State to declare
5982 -- and enter the states into visibility.
5984 if No
(Entity
(Decl
)) then
5985 Id
:= Make_Defining_Identifier
(Loc
, Chars
(Decl
));
5987 Set_Entity
(Decl
, Id
);
5988 Set_Parent
(Id
, State
);
5989 Decorate_State
(Id
, Scop
);
5991 -- Otherwise the package was previously withed
5994 Id
:= Entity
(Decl
);
5997 Build_Shadow_Entity
(Id
, Scop
, Dummy
);
6002 Pack_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Pack
);
6006 -- Start of processing for Find_And_Process_States
6009 -- Find aspect Abstract_State
6011 Asp
:= First
(Aspect_Specifications
(Pack_Decl
));
6012 while Present
(Asp
) loop
6013 if Chars
(Identifier
(Asp
)) = Name_Abstract_State
then
6014 Process_State
(Expression
(Asp
));
6022 -- Find pragma Abstract_State by inspecting the declarations
6024 Decl
:= First
(Decls
);
6025 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
6026 if Pragma_Name
(Decl
) = Name_Abstract_State
then
6029 (First
(Pragma_Argument_Associations
(Decl
))));
6036 end Find_And_Process_States
;
6038 --------------------
6039 -- Process_States --
6040 --------------------
6042 procedure Process_States
(States
: Elist_Id
) is
6047 Elmt
:= First_Elmt
(States
);
6048 while Present
(Elmt
) loop
6049 Build_Shadow_Entity
(Node
(Elmt
), Scop
, Dummy
);
6057 Is_Tagged
: Boolean;
6063 -- Start of processing for Process_Declarations_And_States
6066 -- Build abstract views for all states defined in the package
6068 if Create_Abstract_Views
then
6070 -- When a package has been analyzed, all states are stored in list
6071 -- Abstract_States. Generate the shadow entities directly.
6074 if Present
(Abstract_States
(Pack
)) then
6075 Process_States
(Abstract_States
(Pack
));
6078 -- The package may declare abstract states by using an aspect or a
6079 -- pragma. Attempt to locate one of these construct and if found,
6080 -- build the shadow entities.
6083 Find_And_Process_States
;
6087 -- Inspect the declarative list, looking for nested packages, types
6088 -- and variable declarations.
6090 Decl
:= First
(Decls
);
6091 while Present
(Decl
) loop
6095 if Nkind
(Decl
) = N_Package_Declaration
then
6096 Def_Id
:= Defining_Entity
(Decl
);
6098 -- Perform minor decoration when the withed package has not
6101 if not Is_Analyzed
then
6102 Decorate_Package
(Def_Id
, Scop
);
6105 -- Create a shadow entity that offers a limited view of all
6106 -- visible types declared within.
6108 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
6110 Process_Declarations_And_States
6113 Visible_Declarations
(Specification
(Decl
)),
6115 Create_Abstract_Views
=> Create_Abstract_Views
);
6119 elsif Nkind
(Decl
) in N_Full_Type_Declaration
6120 | N_Incomplete_Type_Declaration
6121 | N_Private_Extension_Declaration
6122 | N_Private_Type_Declaration
6123 | N_Protected_Type_Declaration
6124 | N_Task_Type_Declaration
6126 Def_Id
:= Defining_Entity
(Decl
);
6128 -- Determine whether the type is tagged. Note that packages
6129 -- included via a limited with clause are not always analyzed,
6130 -- hence the tree lookup rather than the use of attribute
6133 if Nkind
(Decl
) = N_Full_Type_Declaration
then
6134 Def
:= Type_Definition
(Decl
);
6137 (Nkind
(Def
) = N_Record_Definition
6138 and then Tagged_Present
(Def
))
6140 (Nkind
(Def
) = N_Derived_Type_Definition
6141 and then Present
(Record_Extension_Part
(Def
)));
6143 elsif Nkind
(Decl
) in N_Incomplete_Type_Declaration
6144 | N_Private_Type_Declaration
6146 Is_Tagged
:= Tagged_Present
(Decl
);
6148 elsif Nkind
(Decl
) = N_Private_Extension_Declaration
then
6155 -- Perform minor decoration when the withed package has not
6158 if not Is_Analyzed
then
6159 Decorate_Type
(Def_Id
, Scop
, Is_Tagged
, True);
6162 -- Create a shadow entity that hides the type and offers an
6163 -- incomplete view of the said type.
6165 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
, Is_Tagged
);
6169 elsif Create_Abstract_Views
6170 and then Nkind
(Decl
) = N_Object_Declaration
6171 and then not Constant_Present
(Decl
)
6173 Def_Id
:= Defining_Entity
(Decl
);
6175 -- Perform minor decoration when the withed package has not
6178 if not Is_Analyzed
then
6179 Decorate_Variable
(Def_Id
, Scop
);
6182 -- Create a shadow entity that hides the variable and offers an
6183 -- abstract view of the said variable.
6185 Build_Shadow_Entity
(Def_Id
, Scop
, Shadow
);
6190 end Process_Declarations_And_States
;
6194 Nam
: constant Node_Id
:= Name
(N
);
6195 Pack
: constant Entity_Id
:= Cunit_Entity
(Unum
);
6197 Last_Public_Shadow
: Entity_Id
:= Empty
;
6198 Private_Shadow
: Entity_Id
;
6201 -- Start of processing for Build_Limited_Views
6204 pragma Assert
(Limited_Present
(N
));
6206 -- A library_item mentioned in a limited_with_clause is a package
6207 -- declaration, not a subprogram declaration, generic declaration,
6208 -- generic instantiation, or package renaming declaration.
6210 case Nkind
(Unit
(Library_Unit
(N
))) is
6211 when N_Package_Declaration
=>
6214 when N_Subprogram_Declaration
=>
6216 ("subprogram not allowed in `LIMITED WITH` clause", N
);
6219 when N_Generic_Declaration
=>
6220 Error_Msg_N
("generic not allowed in `LIMITED WITH` clause", N
);
6223 when N_Generic_Instantiation
=>
6225 ("generic instantiation not allowed in `LIMITED WITH` clause",
6229 when N_Generic_Renaming_Declaration
=>
6231 ("generic renaming not allowed in `LIMITED WITH` clause", N
);
6234 when N_Subprogram_Renaming_Declaration
=>
6236 ("renamed subprogram not allowed in `LIMITED WITH` clause", N
);
6239 when N_Package_Renaming_Declaration
=>
6241 ("renamed package not allowed in `LIMITED WITH` clause", N
);
6245 raise Program_Error
;
6248 -- The withed unit may not be analyzed, but the with calause itself
6249 -- must be minimally decorated. This ensures that the checks on unused
6250 -- with clauses also process limieted withs.
6252 Mutate_Ekind
(Pack
, E_Package
);
6253 Set_Etype
(Pack
, Standard_Void_Type
);
6255 if Is_Entity_Name
(Nam
) then
6256 Set_Entity
(Nam
, Pack
);
6258 elsif Nkind
(Nam
) = N_Selected_Component
then
6259 Set_Entity
(Selector_Name
(Nam
), Pack
);
6262 -- Check if the chain is already built
6264 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
6266 if Limited_View_Installed
(Spec
) then
6270 -- Create the shadow package wich hides the withed unit and provides
6271 -- incomplete view of all types and packages declared within.
6273 Shadow_Pack
:= Make_Temporary
(Sloc
(N
), 'Z');
6274 Mutate_Ekind
(Shadow_Pack
, E_Package
);
6275 Set_Is_Internal
(Shadow_Pack
);
6276 Set_Limited_View
(Pack
, Shadow_Pack
);
6278 -- Inspect the abstract states and visible declarations of the withed
6279 -- unit and create shadow entities that hide existing packages, states,
6280 -- variables and types.
6282 Process_Declarations_And_States
6284 Decls
=> Visible_Declarations
(Spec
),
6286 Create_Abstract_Views
=> True);
6288 Last_Public_Shadow
:= Last_Shadow
;
6290 -- Ada 2005 (AI-262): Build the limited view of the private declarations
6291 -- to accommodate limited private with clauses.
6293 Process_Declarations_And_States
6295 Decls
=> Private_Declarations
(Spec
),
6297 Create_Abstract_Views
=> False);
6299 if Present
(Last_Public_Shadow
) then
6300 Private_Shadow
:= Next_Entity
(Last_Public_Shadow
);
6302 Private_Shadow
:= First_Entity
(Shadow_Pack
);
6305 Set_First_Private_Entity
(Shadow_Pack
, Private_Shadow
);
6306 Set_Limited_View_Installed
(Spec
);
6307 end Build_Limited_Views
;
6309 ----------------------------
6310 -- Check_No_Elab_Code_All --
6311 ----------------------------
6313 procedure Check_No_Elab_Code_All
(N
: Node_Id
) is
6315 if Present
(No_Elab_Code_All_Pragma
)
6316 and then In_Extended_Main_Source_Unit
(N
)
6317 and then Present
(Context_Items
(N
))
6320 CL
: constant List_Id
:= Context_Items
(N
);
6325 while Present
(CI
) loop
6326 if Nkind
(CI
) = N_With_Clause
6328 No_Elab_Code_All
(Get_Source_Unit
(Library_Unit
(CI
)))
6330 -- In GNATprove mode, some runtime units are implicitly
6331 -- loaded to make their entities available for analysis. In
6332 -- this case, ignore violations of No_Elaboration_Code_All
6333 -- for this special analysis mode.
6336 (GNATprove_Mode
and then Implicit_With
(CI
))
6338 Error_Msg_Sloc
:= Sloc
(No_Elab_Code_All_Pragma
);
6340 ("violation of No_Elaboration_Code_All#", CI
);
6342 ("\unit& does not have No_Elaboration_Code_All",
6343 CI
, Entity
(Name
(CI
)));
6350 end Check_No_Elab_Code_All
;
6352 -------------------------------
6353 -- Check_Body_Needed_For_SAL --
6354 -------------------------------
6356 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
6357 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
6358 -- Determine whether use of entity E might require the presence of its
6359 -- body. For a package this requires a recursive traversal of all nested
6362 -----------------------
6363 -- Entity_Needs_Body --
6364 -----------------------
6366 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
6370 if Is_Subprogram
(E
) and then Has_Pragma_Inline
(E
) then
6373 elsif Is_Generic_Subprogram
(E
) then
6375 -- A generic subprogram always requires the presence of its
6376 -- body because an instantiation needs both templates. The only
6377 -- exceptions is a generic subprogram renaming. In this case the
6378 -- body is needed only when the template is declared outside the
6379 -- compilation unit being checked.
6381 if Present
(Renamed_Entity
(E
)) then
6382 return not Within_Scope
(E
, Unit_Name
);
6387 elsif Ekind
(E
) = E_Generic_Package
6389 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
6390 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6394 elsif Ekind
(E
) = E_Package
6395 and then Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
6396 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
6398 Ent
:= First_Entity
(E
);
6399 while Present
(Ent
) loop
6400 if Entity_Needs_Body
(Ent
) then
6412 end Entity_Needs_Body
;
6414 -- Start of processing for Check_Body_Needed_For_SAL
6417 if Ekind
(Unit_Name
) = E_Generic_Package
6418 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6419 N_Generic_Package_Declaration
6421 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
6423 Set_Body_Needed_For_SAL
(Unit_Name
);
6425 elsif Ekind
(Unit_Name
) in E_Generic_Procedure | E_Generic_Function
then
6426 Set_Body_Needed_For_SAL
(Unit_Name
);
6428 elsif Is_Subprogram
(Unit_Name
)
6429 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
6430 N_Subprogram_Declaration
6431 and then Has_Pragma_Inline
(Unit_Name
)
6433 Set_Body_Needed_For_SAL
(Unit_Name
);
6435 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
6436 Check_Body_Needed_For_SAL
6437 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6439 elsif Ekind
(Unit_Name
) = E_Package
6440 and then Entity_Needs_Body
(Unit_Name
)
6442 Set_Body_Needed_For_SAL
(Unit_Name
);
6444 elsif Ekind
(Unit_Name
) = E_Package_Body
6445 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
6447 Check_Body_Needed_For_SAL
6448 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
6450 end Check_Body_Needed_For_SAL
;
6452 --------------------
6453 -- Remove_Context --
6454 --------------------
6456 procedure Remove_Context
(N
: Node_Id
) is
6457 Lib_Unit
: constant Node_Id
:= Unit
(N
);
6460 -- If this is a child unit, first remove the parent units
6462 if Is_Child_Spec
(Lib_Unit
) then
6463 Remove_Parents
(Lib_Unit
);
6466 Remove_Context_Clauses
(N
);
6469 ----------------------------
6470 -- Remove_Context_Clauses --
6471 ----------------------------
6473 procedure Remove_Context_Clauses
(N
: Node_Id
) is
6475 Unit_Name
: Entity_Id
;
6478 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
6479 -- limited-views first and regular-views later (to maintain the stack
6482 -- First Phase: Remove limited_with context clauses
6484 Item
:= First
(Context_Items
(N
));
6485 while Present
(Item
) loop
6487 -- We are interested only in with clauses that got installed on entry
6489 if Nkind
(Item
) = N_With_Clause
6490 and then Limited_Present
(Item
)
6492 if Limited_View_Installed
(Item
) then
6493 Remove_Limited_With_Clause
(Item
);
6495 -- An unusual case: If the library unit of the Main_Unit has a
6496 -- limited with_clause on some unit P and the context somewhere
6497 -- includes a with_clause on P, P has been analyzed. The entity
6498 -- for P is still visible, which in general is harmless because
6499 -- this is the end of the compilation, but it can affect pending
6500 -- instantiations that may have been generated elsewhere, so it
6501 -- it is necessary to remove U from visibility so that inlining
6502 -- and the analysis of instance bodies can proceed cleanly.
6504 elsif Current_Sem_Unit
= Main_Unit
6505 and then Serious_Errors_Detected
= 0
6506 and then not Implicit_With
(Item
)
6508 Set_Is_Immediately_Visible
6509 (Defining_Entity
(Unit
(Library_Unit
(Item
))), False);
6516 -- Second Phase: Loop through context items and undo regular
6517 -- with_clauses and use_clauses.
6519 Item
:= First
(Context_Items
(N
));
6520 while Present
(Item
) loop
6522 -- We are interested only in with clauses which got installed on
6523 -- entry, as indicated by their Context_Installed flag set
6525 if Nkind
(Item
) = N_With_Clause
6526 and then Limited_Present
(Item
)
6527 and then Limited_View_Installed
(Item
)
6531 elsif Nkind
(Item
) = N_With_Clause
6532 and then Context_Installed
(Item
)
6534 -- Remove items from one with'ed unit
6536 Unit_Name
:= Entity
(Name
(Item
));
6537 Remove_Unit_From_Visibility
(Unit_Name
);
6538 Set_Context_Installed
(Item
, False);
6540 elsif Nkind
(Item
) = N_Use_Package_Clause
then
6541 End_Use_Package
(Item
);
6543 elsif Nkind
(Item
) = N_Use_Type_Clause
then
6544 End_Use_Type
(Item
);
6549 end Remove_Context_Clauses
;
6551 --------------------------------
6552 -- Remove_Limited_With_Clause --
6553 --------------------------------
6555 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
6556 Pack_Decl
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
6559 pragma Assert
(Limited_View_Installed
(N
));
6561 -- Limited with clauses that designate units other than packages are
6562 -- illegal and are never installed.
6564 if Nkind
(Pack_Decl
) = N_Package_Declaration
then
6565 Remove_Limited_With_Unit
(Pack_Decl
, N
);
6568 -- Indicate that the limited views of the clause have been removed
6570 Set_Limited_View_Installed
(N
, False);
6571 end Remove_Limited_With_Clause
;
6573 ------------------------------
6574 -- Remove_Limited_With_Unit --
6575 ------------------------------
6577 procedure Remove_Limited_With_Unit
6578 (Pack_Decl
: Node_Id
;
6579 Lim_Clause
: Node_Id
:= Empty
)
6581 procedure Remove_Shadow_Entities_From_Visibility
(Pack_Id
: Entity_Id
);
6582 -- Remove the shadow entities of package Pack_Id from direct visibility
6584 procedure Remove_Shadow_Entities_With_Restore
(Pack_Id
: Entity_Id
);
6585 -- Remove the shadow entities of package Pack_Id from direct visibility,
6586 -- restore the corresponding entities they hide into direct visibility,
6587 -- and update the entity and homonym chains.
6589 --------------------------------------------
6590 -- Remove_Shadow_Entities_From_Visibility --
6591 --------------------------------------------
6593 procedure Remove_Shadow_Entities_From_Visibility
(Pack_Id
: Entity_Id
) is
6594 Lim_Header
: constant Entity_Id
:= Limited_View
(Pack_Id
);
6595 Upto
: constant Entity_Id
:= First_Private_Entity
(Lim_Header
);
6600 -- Remove the package from direct visibility
6603 Set_Is_Immediately_Visible
(Pack_Id
, False);
6605 -- Remove all shadow entities from direct visibility
6607 Shadow
:= First_Entity
(Lim_Header
);
6608 while Present
(Shadow
) and then Shadow
/= Upto
loop
6610 Next_Entity
(Shadow
);
6612 end Remove_Shadow_Entities_From_Visibility
;
6614 -----------------------------------------
6615 -- Remove_Shadow_Entities_With_Restore --
6616 -----------------------------------------
6618 -- This code must be kept synchronized with the code that replaces the
6619 -- real entities by the shadow entities in Install_Limited_With_Clause,
6620 -- otherwise the contents of the homonym chains are not consistent.
6622 procedure Remove_Shadow_Entities_With_Restore
(Pack_Id
: Entity_Id
) is
6623 procedure Restore_Chain_For_Shadow
(Shadow
: Entity_Id
);
6624 -- Remove shadow entity Shadow by updating the entity and homonym
6627 procedure Restore_Chains
6630 -- Remove a sequence of shadow entities starting from From and ending
6631 -- prior to Upto by updating the entity and homonym chains.
6633 procedure Restore_Type_Visibility
6636 -- Restore a sequence of types starting from From and ending prior to
6637 -- Upto back in direct visibility.
6639 ------------------------------
6640 -- Restore_Chain_For_Shadow --
6641 ------------------------------
6643 procedure Restore_Chain_For_Shadow
(Shadow
: Entity_Id
) is
6649 -- If the package has incomplete types, the limited view of the
6650 -- incomplete type is in fact never visible (AI05-129) but we
6651 -- have created a shadow entity E1 for it, that points to E2,
6652 -- the incomplete type at stake. This in turn has a full view
6653 -- E3 that is the full declaration, with a corresponding
6654 -- shadow entity E4. When reinstalling the nonlimited view,
6655 -- the nonvisible entity E1 is first replaced with E2, but then
6656 -- E3 must *not* become the visible entity as it is replacing E4
6657 -- in the homonyms list and simply be ignored.
6659 -- regular views limited views
6661 -- * E2 (incomplete) <-- E1 (shadow)
6666 -- E3 (full) <-- E4 (shadow) *
6668 -- [*] denotes the visible entity (Current_Entity)
6670 Typ
:= Non_Limited_View
(Shadow
);
6671 pragma Assert
(not In_Chain
(Typ
));
6673 Is_E3
:= Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
6674 and then Present
(Incomplete_View
(Parent
(Typ
)));
6676 Prev
:= Current_Entity
(Shadow
);
6678 if Prev
= Shadow
then
6680 Set_Name_Entity_Id
(Chars
(Prev
), Homonym
(Prev
));
6684 Set_Current_Entity
(Typ
);
6688 while Present
(Homonym
(Prev
))
6689 and then Homonym
(Prev
) /= Shadow
6691 Prev
:= Homonym
(Prev
);
6695 Set_Homonym
(Prev
, Homonym
(Shadow
));
6699 Set_Homonym
(Prev
, Typ
);
6703 Set_Homonym
(Typ
, Homonym
(Shadow
));
6704 end Restore_Chain_For_Shadow
;
6706 --------------------
6707 -- Restore_Chains --
6708 --------------------
6710 procedure Restore_Chains
6718 while Present
(Shadow
) and then Shadow
/= Upto
loop
6720 -- Do not unchain nested packages and child units
6722 if Ekind
(Shadow
) = E_Package
then
6725 elsif Is_Child_Unit
(Non_Limited_View
(Shadow
)) then
6729 Restore_Chain_For_Shadow
(Shadow
);
6732 Next_Entity
(Shadow
);
6736 -----------------------------
6737 -- Restore_Type_Visibility --
6738 -----------------------------
6740 procedure Restore_Type_Visibility
6748 while Present
(Typ
) and then Typ
/= Upto
loop
6749 if Is_Type
(Typ
) then
6750 Set_Is_Hidden
(Typ
, Was_Hidden
(Typ
));
6755 end Restore_Type_Visibility
;
6759 Lim_Header
: constant Entity_Id
:= Limited_View
(Pack_Id
);
6761 -- Start of processing Remove_Shadow_Entities_With_Restore
6764 -- The limited view of a package is being uninstalled by removing
6765 -- the effects of a limited with clause. If the clause appears in a
6766 -- unit which is not part of the main unit closure, then the related
6767 -- package must not be visible.
6769 if Present
(Lim_Clause
)
6770 and then not In_Extended_Main_Source_Unit
(Lim_Clause
)
6772 Set_Is_Immediately_Visible
(Pack_Id
, False);
6774 -- Otherwise a limited view is being overridden by a nonlimited view.
6775 -- Leave the visibility of the package as is because the unit must be
6776 -- visible when the nonlimited view is installed.
6782 -- Remove the shadow entities from visibility by updating the entity
6783 -- and homonym chains.
6786 (From
=> First_Entity
(Lim_Header
),
6787 Upto
=> First_Private_Entity
(Lim_Header
));
6789 -- Reinstate the types that were hidden by the shadow entities back
6790 -- into direct visibility.
6792 Restore_Type_Visibility
6793 (From
=> First_Entity
(Pack_Id
),
6794 Upto
=> First_Private_Entity
(Pack_Id
));
6795 end Remove_Shadow_Entities_With_Restore
;
6799 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
6801 -- Start of processing for Remove_Limited_With_Unit
6804 -- Nothing to do when the limited view of the package is not installed
6806 if not From_Limited_With
(Pack_Id
) then
6810 if Debug_Flag_I
then
6811 Write_Str
("remove limited view of ");
6812 Write_Name
(Chars
(Pack_Id
));
6813 Write_Str
(" from visibility");
6817 -- The package already appears in the compilation closure. As a result,
6818 -- its shadow entities must be replaced by the real entities they hide
6819 -- and the previously hidden entities must be entered back into direct
6822 if Analyzed
(Pack_Decl
) then
6823 Remove_Shadow_Entities_With_Restore
(Pack_Id
);
6825 -- Otherwise the package is not analyzed and its shadow entities must be
6826 -- removed from direct visibility.
6829 Remove_Shadow_Entities_From_Visibility
(Pack_Id
);
6832 -- Indicate that the limited view of the package is not installed
6834 Set_From_Limited_With
(Pack_Id
, False);
6835 end Remove_Limited_With_Unit
;
6837 --------------------
6838 -- Remove_Parents --
6839 --------------------
6841 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
6844 P_Spec
: Node_Id
:= Empty
;
6846 Vis
: constant Boolean :=
6847 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
6850 if Is_Child_Spec
(Lib_Unit
) then
6851 P_Spec
:= Parent_Spec
(Lib_Unit
);
6853 elsif Nkind
(Lib_Unit
) = N_Package_Body
6854 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
6856 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
6859 if Present
(P_Spec
) then
6861 P_Name
:= Get_Parent_Entity
(P
);
6862 Remove_Context_Clauses
(P_Spec
);
6863 End_Package_Scope
(P_Name
);
6864 Set_Is_Immediately_Visible
(P_Name
, Vis
);
6866 -- Remove from visibility the siblings as well, which are directly
6867 -- visible while the parent is in scope.
6869 E
:= First_Entity
(P_Name
);
6870 while Present
(E
) loop
6871 if Is_Child_Unit
(E
) then
6872 Set_Is_Immediately_Visible
(E
, False);
6878 Set_In_Package_Body
(P_Name
, False);
6880 -- This is the recursive call to remove the context of any higher
6881 -- level parent. This recursion ensures that all parents are removed
6882 -- in the reverse order of their installation.
6888 ---------------------------------
6889 -- Remove_Private_With_Clauses --
6890 ---------------------------------
6892 procedure Remove_Private_With_Clauses
(Comp_Unit
: Node_Id
) is
6895 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean;
6896 -- Check whether a given unit appears in a regular with_clause. Used to
6897 -- determine whether a private_with_clause, implicit or explicit, should
6900 ----------------------------
6901 -- In_Regular_With_Clause --
6902 ----------------------------
6904 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean is
6908 Item
:= First
(Context_Items
(Comp_Unit
));
6910 while Present
(Item
) loop
6911 if Nkind
(Item
) = N_With_Clause
6913 -- The following guard is needed to ensure that the name has
6914 -- been properly analyzed before we go fetching its entity.
6916 and then Is_Entity_Name
(Name
(Item
))
6917 and then Entity
(Name
(Item
)) = E
6918 and then not Private_Present
(Item
)
6927 end In_Regular_With_Clause
;
6929 -- Start of processing for Remove_Private_With_Clauses
6932 Item
:= First
(Context_Items
(Comp_Unit
));
6933 while Present
(Item
) loop
6934 if Nkind
(Item
) = N_With_Clause
and then Private_Present
(Item
) then
6936 -- If private_with_clause is redundant, remove it from context,
6937 -- as a small optimization to subsequent handling of private_with
6938 -- clauses in other nested packages. We replace the clause with
6939 -- a null statement, which is otherwise ignored by the rest of
6942 if In_Regular_With_Clause
(Entity
(Name
(Item
))) then
6944 Nxt
: constant Node_Id
:= Next
(Item
);
6946 Rewrite
(Item
, Make_Null_Statement
(Sloc
(Item
)));
6951 elsif Limited_Present
(Item
) then
6952 if not Limited_View_Installed
(Item
) then
6953 Remove_Limited_With_Clause
(Item
);
6959 Remove_Unit_From_Visibility
(Entity
(Name
(Item
)));
6960 Set_Context_Installed
(Item
, False);
6968 end Remove_Private_With_Clauses
;
6970 ---------------------------------
6971 -- Remove_Unit_From_Visibility --
6972 ---------------------------------
6974 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
6976 if Debug_Flag_I
then
6977 Write_Str
("remove unit ");
6978 Write_Name
(Chars
(Unit_Name
));
6979 Write_Str
(" from visibility");
6983 Set_Is_Visible_Lib_Unit
(Unit_Name
, False);
6984 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
6985 Set_Is_Immediately_Visible
(Unit_Name
, False);
6987 -- If the unit is a wrapper package, the subprogram instance is
6988 -- what must be removed from visibility.
6989 -- Should we use Related_Instance instead???
6991 if Is_Wrapper_Package
(Unit_Name
) then
6992 Set_Is_Immediately_Visible
(Current_Entity
(Unit_Name
), False);
6994 end Remove_Unit_From_Visibility
;
7009 procedure Unchain
(E
: Entity_Id
) is
7013 Prev
:= Current_Entity
(E
);
7019 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
7022 while Present
(Prev
) and then Homonym
(Prev
) /= E
loop
7023 Prev
:= Homonym
(Prev
);
7026 if Present
(Prev
) then
7027 Set_Homonym
(Prev
, Homonym
(E
));
7031 if Debug_Flag_I
then
7032 Write_Str
(" (homonym) unchain ");
7033 Write_Name
(Chars
(E
));