1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Util
; use Exp_Util
;
31 with Elists
; use Elists
;
32 with Fname
; use Fname
;
33 with Fname
.UF
; use Fname
.UF
;
34 with Freeze
; use Freeze
;
35 with Impunit
; use Impunit
;
36 with Inline
; use Inline
;
38 with Lib
.Load
; use Lib
.Load
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Namet
; use Namet
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Par_SCO
; use Par_SCO
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch7
; use Sem_Ch7
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Dist
; use Sem_Dist
;
56 with Sem_Prag
; use Sem_Prag
;
57 with Sem_Util
; use Sem_Util
;
58 with Sem_Warn
; use Sem_Warn
;
59 with Stand
; use Stand
;
60 with Sinfo
; use Sinfo
;
61 with Sinfo
.CN
; use Sinfo
.CN
;
62 with Sinput
; use Sinput
;
63 with Snames
; use Snames
;
64 with Style
; use Style
;
65 with Stylesw
; use Stylesw
;
66 with Tbuild
; use Tbuild
;
67 with Uname
; use Uname
;
69 package body Sem_Ch10
is
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 procedure Analyze_Context
(N
: Node_Id
);
76 -- Analyzes items in the context clause of compilation unit
78 procedure Build_Limited_Views
(N
: Node_Id
);
79 -- Build and decorate the list of shadow entities for a package mentioned
80 -- in a limited_with clause. If the package was not previously analyzed
81 -- then it also performs a basic decoration of the real entities. This is
82 -- required to do not pass non-decorated entities to the back-end.
83 -- Implements Ada 2005 (AI-50217).
85 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
);
86 -- Check whether the source for the body of a compilation unit must be
87 -- included in a standalone library.
89 procedure Check_Private_Child_Unit
(N
: Node_Id
);
90 -- If a with_clause mentions a private child unit, the compilation unit
91 -- must be a member of the same family, as described in 10.1.2.
93 procedure Check_Stub_Level
(N
: Node_Id
);
94 -- Verify that a stub is declared immediately within a compilation unit,
95 -- and not in an inner frame.
97 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
);
98 -- When a child unit appears in a context clause, the implicit withs on
99 -- parents are made explicit, and with clauses are inserted in the context
100 -- clause before the one for the child. If a parent in the with_clause
101 -- is a renaming, the implicit with_clause is on the renaming whose name
102 -- is mentioned in the with_clause, and not on the package it renames.
103 -- N is the compilation unit whose list of context items receives the
104 -- implicit with_clauses.
106 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
;
107 -- Get defining entity of parent unit of a child unit. In most cases this
108 -- is the defining entity of the unit, but for a child instance whose
109 -- parent needs a body for inlining, the instantiation node of the parent
110 -- has not yet been rewritten as a package declaration, and the entity has
111 -- to be retrieved from the Instance_Spec of the unit.
113 function Has_With_Clause
116 Is_Limited
: Boolean := False) return Boolean;
117 -- Determine whether compilation unit C_Unit contains a [limited] with
118 -- clause for package Pack. Use the flag Is_Limited to designate desired
121 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
122 -- If the main unit is a child unit, implicit withs are also added for
123 -- all its ancestors.
125 function In_Chain
(E
: Entity_Id
) return Boolean;
126 -- Check that the shadow entity is not already in the homonym chain, for
127 -- example through a limited_with clause in a parent unit.
129 procedure Install_Context_Clauses
(N
: Node_Id
);
130 -- Subsidiary to Install_Context and Install_Parents. Process all with
131 -- and use clauses for current unit and its library unit if any.
133 procedure Install_Limited_Context_Clauses
(N
: Node_Id
);
134 -- Subsidiary to Install_Context. Process only limited with_clauses for
135 -- current unit. Implements Ada 2005 (AI-50217).
137 procedure Install_Limited_Withed_Unit
(N
: Node_Id
);
138 -- Place shadow entities for a limited_with package in the visibility
139 -- structures for the current compilation. Implements Ada 2005 (AI-50217).
141 procedure Install_Withed_Unit
142 (With_Clause
: Node_Id
;
143 Private_With_OK
: Boolean := False);
144 -- If the unit is not a child unit, make unit immediately visible. The
145 -- caller ensures that the unit is not already currently installed. The
146 -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
147 -- is called when compiling the private part of a package, or installing
148 -- the private declarations of a parent unit.
150 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean);
151 -- This procedure establishes the context for the compilation of a child
152 -- unit. If Lib_Unit is a child library spec then the context of the parent
153 -- is installed, and the parent itself made immediately visible, so that
154 -- the child unit is processed in the declarative region of the parent.
155 -- Install_Parents makes a recursive call to itself to ensure that all
156 -- parents are loaded in the nested case. If Lib_Unit is a library body,
157 -- the only effect of Install_Parents is to install the private decls of
158 -- the parents, because the visible parent declarations will have been
159 -- installed as part of the context of the corresponding spec.
161 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
162 -- In the compilation of a child unit, a child of any of the ancestor
163 -- units is directly visible if it is visible, because the parent is in
164 -- an enclosing scope. Iterate over context to find child units of U_Name
165 -- or of some ancestor of it.
167 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
168 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
169 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
170 -- a library spec that has a parent. If the call to Is_Child_Spec returns
171 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
172 -- compilation unit for the parent spec.
174 -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
175 -- Parent_Spec is non-empty, this is also a child unit.
177 procedure Remove_Context_Clauses
(N
: Node_Id
);
178 -- Subsidiary of previous one. Remove use_ and with_clauses
180 procedure Remove_Limited_With_Clause
(N
: Node_Id
);
181 -- Remove from visibility the shadow entities introduced for a package
182 -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
184 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
185 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
186 -- contexts established by the corresponding call to Install_Parents are
187 -- removed. Remove_Parents contains a recursive call to itself to ensure
188 -- that all parents are removed in the nested case.
190 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
191 -- Reset all visibility flags on unit after compiling it, either as a main
192 -- unit or as a unit in the context.
194 procedure Unchain
(E
: Entity_Id
);
195 -- Remove single entity from visibility list
197 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
198 -- Common processing for all stubs (subprograms, tasks, packages, and
199 -- protected cases). N is the stub to be analyzed. Once the subunit name
200 -- is established, load and analyze. Nam is the non-overloadable entity
201 -- for which the proper body provides a completion. Subprogram stubs are
202 -- handled differently because they can be declarations.
205 -- A dummy procedure, for debugging use, called just before analyzing the
206 -- main unit (after dealing with any context clauses).
208 --------------------------
209 -- Limited_With_Clauses --
210 --------------------------
212 -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
213 -- mutually recursive types declared in different units. A limited_with
214 -- clause that names package P in the context of unit U makes the types
215 -- declared in the visible part of P available within U, but with the
216 -- restriction that these types can only be used as incomplete types.
217 -- The limited_with clause does not impose a semantic dependence on P,
218 -- and it is possible for two packages to have limited_with_clauses on
219 -- each other without creating an elaboration circularity.
221 -- To support this feature, the analysis of a limited_with clause must
222 -- create an abbreviated view of the package, without performing any
223 -- semantic analysis on it. This "package abstract" contains shadow types
224 -- that are in one-one correspondence with the real types in the package,
225 -- and that have the properties of incomplete types.
227 -- The implementation creates two element lists: one to chain the shadow
228 -- entities, and one to chain the corresponding type entities in the tree
229 -- of the package. Links between corresponding entities in both chains
230 -- allow the compiler to select the proper view of a given type, depending
231 -- on the context. Note that in contrast with the handling of private
232 -- types, the limited view and the non-limited view of a type are treated
233 -- as separate entities, and no entity exchange needs to take place, which
234 -- makes the implementation must simpler than could be feared.
236 ------------------------------
237 -- Analyze_Compilation_Unit --
238 ------------------------------
240 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
241 Unit_Node
: constant Node_Id
:= Unit
(N
);
242 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
244 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
245 Par_Spec_Name
: Unit_Name_Type
;
246 Unum
: Unit_Number_Type
;
248 procedure Check_Redundant_Withs
249 (Context_Items
: List_Id
;
250 Spec_Context_Items
: List_Id
:= No_List
);
251 -- Determine whether the context list of a compilation unit contains
252 -- redundant with clauses. When checking body clauses against spec
253 -- clauses, set Context_Items to the context list of the body and
254 -- Spec_Context_Items to that of the spec. Parent packages are not
255 -- examined for documentation purposes.
257 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
258 -- Generate cross-reference information for the parents of child units.
259 -- N is a defining_program_unit_name, and P_Id is the immediate parent.
261 ---------------------------
262 -- Check_Redundant_Withs --
263 ---------------------------
265 procedure Check_Redundant_Withs
266 (Context_Items
: List_Id
;
267 Spec_Context_Items
: List_Id
:= No_List
)
271 procedure Process_Body_Clauses
272 (Context_List
: List_Id
;
274 Used
: in out Boolean;
275 Used_Type_Or_Elab
: in out Boolean);
276 -- Examine the context clauses of a package body, trying to match the
277 -- name entity of Clause with any list element. If the match occurs
278 -- on a use package clause set Used to True, for a use type clause or
279 -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
281 procedure Process_Spec_Clauses
282 (Context_List
: List_Id
;
284 Used
: in out Boolean;
285 Withed
: in out Boolean;
286 Exit_On_Self
: Boolean := False);
287 -- Examine the context clauses of a package spec, trying to match
288 -- the name entity of Clause with any list element. If the match
289 -- occurs on a use package clause, set Used to True, for a with
290 -- package clause other than Clause, set Withed to True. Limited
291 -- with clauses, implicitly generated with clauses and withs
292 -- having pragmas Elaborate or Elaborate_All applied to them are
293 -- skipped. Exit_On_Self is used to control the search loop and
294 -- force an exit whenever Clause sees itself in the search.
296 --------------------------
297 -- Process_Body_Clauses --
298 --------------------------
300 procedure Process_Body_Clauses
301 (Context_List
: List_Id
;
303 Used
: in out Boolean;
304 Used_Type_Or_Elab
: in out Boolean)
306 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
312 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean;
313 -- In an expanded name in a use clause, if the prefix is a renamed
314 -- package, the entity is set to the original package as a result,
315 -- when checking whether the package appears in a previous with
316 -- clause, the renaming has to be taken into account, to prevent
317 -- spurious/incorrect warnings. A common case is use of Text_IO.
323 function Same_Unit
(N
: Node_Id
; P
: Entity_Id
) return Boolean is
325 return Entity
(N
) = P
327 (Present
(Renamed_Object
(P
))
328 and then Entity
(N
) = Renamed_Object
(P
));
331 -- Start of processing for Process_Body_Clauses
335 Used_Type_Or_Elab
:= False;
337 Cont_Item
:= First
(Context_List
);
338 while Present
(Cont_Item
) loop
340 -- Package use clause
342 if Nkind
(Cont_Item
) = N_Use_Package_Clause
345 -- Search through use clauses
347 Use_Item
:= First
(Names
(Cont_Item
));
348 while Present
(Use_Item
) and then not Used
loop
350 -- Case of a direct use of the one we are looking for
352 if Entity
(Use_Item
) = Nam_Ent
then
355 -- Handle nested case, as in "with P; use P.Q.R"
362 -- Loop through prefixes looking for match
365 while Nkind
(UE
) = N_Expanded_Name
loop
366 if Same_Unit
(Prefix
(UE
), Nam_Ent
) then
381 elsif Nkind
(Cont_Item
) = N_Use_Type_Clause
382 and then not Used_Type_Or_Elab
384 Subt_Mark
:= First
(Subtype_Marks
(Cont_Item
));
385 while Present
(Subt_Mark
)
386 and then not Used_Type_Or_Elab
388 if Same_Unit
(Prefix
(Subt_Mark
), Nam_Ent
) then
389 Used_Type_Or_Elab
:= True;
395 -- Pragma Elaborate or Elaborate_All
397 elsif Nkind
(Cont_Item
) = N_Pragma
399 (Pragma_Name
(Cont_Item
) = Name_Elaborate
401 Pragma_Name
(Cont_Item
) = Name_Elaborate_All
)
402 and then not Used_Type_Or_Elab
405 First
(Pragma_Argument_Associations
(Cont_Item
));
406 while Present
(Prag_Unit
)
407 and then not Used_Type_Or_Elab
409 if Entity
(Expression
(Prag_Unit
)) = Nam_Ent
then
410 Used_Type_Or_Elab
:= True;
419 end Process_Body_Clauses
;
421 --------------------------
422 -- Process_Spec_Clauses --
423 --------------------------
425 procedure Process_Spec_Clauses
426 (Context_List
: List_Id
;
428 Used
: in out Boolean;
429 Withed
: in out Boolean;
430 Exit_On_Self
: Boolean := False)
432 Nam_Ent
: constant Entity_Id
:= Entity
(Name
(Clause
));
440 Cont_Item
:= First
(Context_List
);
441 while Present
(Cont_Item
) loop
443 -- Stop the search since the context items after Cont_Item have
444 -- already been examined in a previous iteration of the reverse
445 -- loop in Check_Redundant_Withs.
448 and Cont_Item
= Clause
453 -- Package use clause
455 if Nkind
(Cont_Item
) = N_Use_Package_Clause
458 Use_Item
:= First
(Names
(Cont_Item
));
459 while Present
(Use_Item
) and then not Used
loop
460 if Entity
(Use_Item
) = Nam_Ent
then
467 -- Package with clause. Avoid processing self, implicitly
468 -- generated with clauses or limited with clauses. Note that
469 -- we examine with clauses having pragmas Elaborate or
470 -- Elaborate_All applied to them due to cases such as:
474 -- pragma Elaborate (Pack);
476 -- In this case, the second with clause is redundant since
477 -- the pragma applies only to the first "with Pack;".
479 elsif Nkind
(Cont_Item
) = N_With_Clause
480 and then not Implicit_With
(Cont_Item
)
481 and then not Limited_Present
(Cont_Item
)
482 and then Cont_Item
/= Clause
483 and then Entity
(Name
(Cont_Item
)) = Nam_Ent
490 end Process_Spec_Clauses
;
492 -- Start of processing for Check_Redundant_Withs
495 Clause
:= Last
(Context_Items
);
496 while Present
(Clause
) loop
498 -- Avoid checking implicitly generated with clauses, limited with
499 -- clauses or withs that have pragma Elaborate or Elaborate_All.
501 if Nkind
(Clause
) = N_With_Clause
502 and then not Implicit_With
(Clause
)
503 and then not Limited_Present
(Clause
)
504 and then not Elaborate_Present
(Clause
)
506 -- Package body-to-spec check
508 if Present
(Spec_Context_Items
) then
510 Used_In_Body
: Boolean := False;
511 Used_In_Spec
: Boolean := False;
512 Used_Type_Or_Elab
: Boolean := False;
513 Withed_In_Spec
: Boolean := False;
517 (Context_List
=> Spec_Context_Items
,
519 Used
=> Used_In_Spec
,
520 Withed
=> Withed_In_Spec
);
523 (Context_List
=> Context_Items
,
525 Used
=> Used_In_Body
,
526 Used_Type_Or_Elab
=> Used_Type_Or_Elab
);
528 -- "Type Elab" refers to the presence of either a use
529 -- type clause, pragmas Elaborate or Elaborate_All.
531 -- +---------------+---------------------------+------+
532 -- | Spec | Body | Warn |
533 -- +--------+------+--------+------+-----------+------+
534 -- | Withed | Used | Withed | Used | Type Elab | |
535 -- | X | | X | | | X |
536 -- | X | | X | X | | |
537 -- | X | | X | | X | |
538 -- | X | | X | X | X | |
539 -- | X | X | X | | | X |
540 -- | X | X | X | | X | |
541 -- | X | X | X | X | | X |
542 -- | X | X | X | X | X | |
543 -- +--------+------+--------+------+-----------+------+
546 and then not Used_Type_Or_Elab
)
549 and then not Used_In_Body
)
553 Error_Msg_N
-- CODEFIX
554 ("?redundant with clause in body", Clause
);
557 Used_In_Body
:= False;
558 Used_In_Spec
:= False;
559 Used_Type_Or_Elab
:= False;
560 Withed_In_Spec
:= False;
563 -- Standalone package spec or body check
567 Dont_Care
: Boolean := False;
568 Withed
: Boolean := False;
571 -- The mechanism for examining the context clauses of a
572 -- package spec can be applied to package body clauses.
575 (Context_List
=> Context_Items
,
579 Exit_On_Self
=> True);
582 Error_Msg_N
-- CODEFIX
583 ("?redundant with clause", Clause
);
591 end Check_Redundant_Withs
;
593 --------------------------------
594 -- Generate_Parent_References --
595 --------------------------------
597 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
599 P_Name
: Entity_Id
:= P_Id
;
602 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
604 if Nkind
(Pref
) = N_Expanded_Name
then
606 -- Done already, if the unit has been compiled indirectly as
607 -- part of the closure of its context because of inlining.
612 while Nkind
(Pref
) = N_Selected_Component
loop
613 Change_Selected_Component_To_Expanded_Name
(Pref
);
614 Set_Entity
(Pref
, P_Name
);
615 Set_Etype
(Pref
, Etype
(P_Name
));
616 Generate_Reference
(P_Name
, Pref
, 'r');
617 Pref
:= Prefix
(Pref
);
618 P_Name
:= Scope
(P_Name
);
621 -- The guard here on P_Name is to handle the error condition where
622 -- the parent unit is missing because the file was not found.
624 if Present
(P_Name
) then
625 Set_Entity
(Pref
, P_Name
);
626 Set_Etype
(Pref
, Etype
(P_Name
));
627 Generate_Reference
(P_Name
, Pref
, 'r');
628 Style
.Check_Identifier
(Pref
, P_Name
);
630 end Generate_Parent_References
;
632 -- Start of processing for Analyze_Compilation_Unit
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 descendents) 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 Is_Predefined_File_Name
675 (Unit_File_Name
(Get_Source_Unit
(Unit
(N
))))
677 Circularity
:= False;
680 for U
in Main_Unit
+ 1 .. Last_Unit
loop
681 if Nkind
(Unit
(Cunit
(U
))) = N_Package_Body
682 and then not Analyzed
(Cunit
(U
))
684 Circularity
:= False;
691 Error_Msg_N
("circular dependency caused by with_clauses", N
);
693 ("\possibly missing limited_with clause"
694 & " in one of the following", N
);
696 for U
in Main_Unit
.. Last_Unit
loop
697 if Context_Pending
(Cunit
(U
)) then
698 Error_Msg_Unit_1
:= Get_Unit_Name
(Unit
(Cunit
(U
)));
699 Error_Msg_N
("\unit$", N
);
703 raise Unrecoverable_Error
;
707 Set_Context_Pending
(N
);
712 Set_Context_Pending
(N
, False);
714 -- If the unit is a package body, the spec is already loaded and must be
715 -- analyzed first, before we analyze the body.
717 if Nkind
(Unit_Node
) = N_Package_Body
then
719 -- If no Lib_Unit, then there was a serious previous error, so just
720 -- ignore the entire analysis effort
722 if No
(Lib_Unit
) then
726 -- Analyze the package spec
728 Semantics
(Lib_Unit
);
730 -- Check for unused with's
732 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
734 -- Verify that the library unit is a package declaration
736 if not Nkind_In
(Unit
(Lib_Unit
), N_Package_Declaration
,
737 N_Generic_Package_Declaration
)
740 ("no legal package declaration for package body", N
);
743 -- Otherwise, the entity in the declaration is visible. Update the
744 -- version to reflect dependence of this body on the spec.
747 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
748 Set_Is_Immediately_Visible
(Spec_Id
, True);
749 Version_Update
(N
, Lib_Unit
);
751 if Nkind
(Defining_Unit_Name
(Unit_Node
)) =
752 N_Defining_Program_Unit_Name
754 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
759 -- If the unit is a subprogram body, then we similarly need to analyze
760 -- its spec. However, things are a little simpler in this case, because
761 -- here, this analysis is done mostly for error checking and consistency
762 -- purposes (but not only, e.g. there could be a contract on the spec),
763 -- so there's nothing else to be done.
765 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
766 if Acts_As_Spec
(N
) then
768 -- If the subprogram body is a child unit, we must create a
769 -- declaration for it, in order to properly load the parent(s).
770 -- After this, the original unit does not acts as a spec, because
771 -- there is an explicit one. If this unit appears in a context
772 -- clause, then an implicit with on the parent will be added when
773 -- installing the context. If this is the main unit, there is no
774 -- Unit_Table entry for the declaration (it has the unit number
775 -- of the main unit) and code generation is unaffected.
777 Unum
:= Get_Cunit_Unit_Number
(N
);
778 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
780 if Par_Spec_Name
/= No_Unit_Name
then
783 (Load_Name
=> Par_Spec_Name
,
788 if Unum
/= No_Unit
then
790 -- Build subprogram declaration and attach parent unit to it
791 -- This subprogram declaration does not come from source,
792 -- Nevertheless the backend must generate debugging info for
793 -- it, and this must be indicated explicitly. We also mark
794 -- the body entity as a child unit now, to prevent a
795 -- cascaded error if the spec entity cannot be entered
796 -- in its scope. Finally we create a Units table entry for
797 -- the subprogram declaration, to maintain a one-to-one
798 -- correspondence with compilation unit nodes. This is
799 -- critical for the tree traversals performed by CodePeer.
802 Loc
: constant Source_Ptr
:= Sloc
(N
);
803 SCS
: constant Boolean :=
804 Get_Comes_From_Source_Default
;
807 Set_Comes_From_Source_Default
(False);
809 -- Checks for redundant USE TYPE clauses have a special
810 -- exception for the synthetic spec we create here. This
811 -- special case relies on the two compilation units
812 -- sharing the same context clause.
814 -- Note: We used to do a shallow copy (New_Copy_List),
815 -- which defeated those checks and also created malformed
816 -- trees (subtype mark shared by two distinct
817 -- N_Use_Type_Clause nodes) which crashed the compiler.
820 Make_Compilation_Unit
(Loc
,
821 Context_Items
=> Context_Items
(N
),
823 Make_Subprogram_Declaration
(Sloc
(N
),
826 (Specification
(Unit_Node
))),
828 Make_Compilation_Unit_Aux
(Loc
));
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 Set_Is_Child_Unit
(Defining_Entity
(Unit_Node
));
840 Set_Debug_Info_Needed
(Defining_Entity
(Unit
(Lib_Unit
)));
841 Set_Comes_From_Source_Default
(SCS
);
846 -- Here for subprogram with separate declaration
849 Semantics
(Lib_Unit
);
850 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
851 Version_Update
(N
, Lib_Unit
);
854 -- If this is a child unit, generate references to the parents
856 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
857 N_Defining_Program_Unit_Name
859 Generate_Parent_References
(
860 Specification
(Unit_Node
),
861 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
865 -- If it is a child unit, the parent must be elaborated first and we
866 -- update version, since we are dependent on our parent.
868 if Is_Child_Spec
(Unit_Node
) then
870 -- The analysis of the parent is done with style checks off
873 Save_Style_Check
: constant Boolean := Style_Check
;
876 if not GNAT_Mode
then
877 Style_Check
:= False;
880 Semantics
(Parent_Spec
(Unit_Node
));
881 Version_Update
(N
, Parent_Spec
(Unit_Node
));
883 -- Restore style check settings
885 Style_Check
:= Save_Style_Check
;
889 -- With the analysis done, install the context. Note that we can't
890 -- install the context from the with clauses as we analyze them, because
891 -- each with clause must be analyzed in a clean visibility context, so
892 -- we have to wait and install them all at once.
896 if Is_Child_Spec
(Unit_Node
) then
898 -- Set the entities of all parents in the program_unit_name
900 Generate_Parent_References
(
901 Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
904 -- All components of the context: with-clauses, library unit, ancestors
905 -- if any, (and their context) are analyzed and installed.
907 -- Call special debug routine sm if this is the main unit
909 if Current_Sem_Unit
= Main_Unit
then
913 -- Now analyze the unit (package, subprogram spec, body) itself
917 if Warn_On_Redundant_Constructs
then
918 Check_Redundant_Withs
(Context_Items
(N
));
920 if Nkind
(Unit_Node
) = N_Package_Body
then
921 Check_Redundant_Withs
922 (Context_Items
=> Context_Items
(N
),
923 Spec_Context_Items
=> Context_Items
(Lib_Unit
));
927 -- The above call might have made Unit_Node an N_Subprogram_Body from
928 -- something else, so propagate any Acts_As_Spec flag.
930 if Nkind
(Unit_Node
) = N_Subprogram_Body
931 and then Acts_As_Spec
(Unit_Node
)
933 Set_Acts_As_Spec
(N
);
936 -- Register predefined units in Rtsfind
939 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Sloc
(N
));
941 if Is_Predefined_File_Name
(Unit_File_Name
(Unum
)) then
942 Set_RTU_Loaded
(Unit_Node
);
946 -- Treat compilation unit pragmas that appear after the library unit
948 if Present
(Pragmas_After
(Aux_Decls_Node
(N
))) then
950 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
952 while Present
(Prag_Node
) loop
959 -- Generate distribution stubs if requested and no error
962 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
964 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
965 and then not Fatal_Error
(Main_Unit
)
967 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
969 -- Regular RCI package
971 Add_Stub_Constructs
(N
);
973 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
974 and then Is_Shared_Passive
(Defining_Entity
975 (Specification
(Unit_Node
))))
976 or else (Nkind
(Unit_Node
) = N_Package_Body
978 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
980 -- Shared passive package
982 Add_Stub_Constructs
(N
);
984 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
986 Is_Remote_Call_Interface
987 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
989 -- Instantiation of a RCI generic package
991 Add_Stub_Constructs
(N
);
995 -- Remove unit from visibility, so that environment is clean for the
996 -- next compilation, which is either the main unit or some other unit
999 if Nkind_In
(Unit_Node
, N_Package_Declaration
,
1000 N_Package_Renaming_Declaration
,
1001 N_Subprogram_Declaration
)
1002 or else Nkind
(Unit_Node
) in N_Generic_Declaration
1004 (Nkind
(Unit_Node
) = N_Subprogram_Body
1005 and then Acts_As_Spec
(Unit_Node
))
1007 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
1009 -- If the unit is an instantiation whose body will be elaborated for
1010 -- inlining purposes, use the proper entity of the instance. The entity
1011 -- may be missing if the instantiation was illegal.
1013 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
1014 and then not Error_Posted
(Unit_Node
)
1015 and then Present
(Instance_Spec
(Unit_Node
))
1017 Remove_Unit_From_Visibility
1018 (Defining_Entity
(Instance_Spec
(Unit_Node
)));
1020 elsif Nkind
(Unit_Node
) = N_Package_Body
1021 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
1022 and then not Acts_As_Spec
(Unit_Node
))
1024 -- Bodies that are not the main unit are compiled if they are generic
1025 -- or contain generic or inlined units. Their analysis brings in the
1026 -- context of the corresponding spec (unit declaration) which must be
1027 -- removed as well, to return the compilation environment to its
1030 Remove_Context
(Lib_Unit
);
1031 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
1034 -- Last step is to deinstall the context we just installed as well as
1035 -- the unit just compiled.
1039 -- If this is the main unit and we are generating code, we must check
1040 -- that all generic units in the context have a body if they need it,
1041 -- even if they have not been instantiated. In the absence of .ali files
1042 -- for generic units, we must force the load of the body, just to
1043 -- produce the proper error if the body is absent. We skip this
1044 -- verification if the main unit itself is generic.
1046 if Get_Cunit_Unit_Number
(N
) = Main_Unit
1047 and then Operating_Mode
= Generate_Code
1048 and then Expander_Active
1050 -- Check whether the source for the body of the unit must be included
1051 -- in a standalone library.
1053 Check_Body_Needed_For_SAL
(Cunit_Entity
(Main_Unit
));
1055 -- Indicate that the main unit is now analyzed, to catch possible
1056 -- circularities between it and generic bodies. Remove main unit from
1057 -- visibility. This might seem superfluous, but the main unit must
1058 -- not be visible in the generic body expansions that follow.
1060 Set_Analyzed
(N
, True);
1061 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
1066 Un
: Unit_Number_Type
;
1068 Save_Style_Check
: constant Boolean := Style_Check
;
1071 Item
:= First
(Context_Items
(N
));
1072 while Present
(Item
) loop
1074 -- Check for explicit with clause
1076 if Nkind
(Item
) = N_With_Clause
1077 and then not Implicit_With
(Item
)
1079 -- Ada 2005 (AI-50217): Ignore limited-withed units
1081 and then not Limited_Present
(Item
)
1083 Nam
:= Entity
(Name
(Item
));
1085 -- Compile generic subprogram, unless it is intrinsic or
1086 -- imported so no body is required, or generic package body
1087 -- if the package spec requires a body.
1089 if (Is_Generic_Subprogram
(Nam
)
1090 and then not Is_Intrinsic_Subprogram
(Nam
)
1091 and then not Is_Imported
(Nam
))
1092 or else (Ekind
(Nam
) = E_Generic_Package
1093 and then Unit_Requires_Body
(Nam
))
1095 Style_Check
:= False;
1097 if Present
(Renamed_Object
(Nam
)) then
1100 (Load_Name
=> Get_Body_Name
1102 (Unit_Declaration_Node
1103 (Renamed_Object
(Nam
)))),
1111 (Load_Name
=> Get_Body_Name
1112 (Get_Unit_Name
(Item
)),
1119 if Un
= No_Unit
then
1121 ("body of generic unit& not found", Item
, Nam
);
1124 elsif not Analyzed
(Cunit
(Un
))
1125 and then Un
/= Main_Unit
1126 and then not Fatal_Error
(Un
)
1128 Style_Check
:= False;
1129 Semantics
(Cunit
(Un
));
1137 -- Restore style checks settings
1139 Style_Check
:= Save_Style_Check
;
1143 -- Deal with creating elaboration Boolean if needed. We create an
1144 -- elaboration boolean only for units that come from source since
1145 -- units manufactured by the compiler never need elab checks.
1147 if Comes_From_Source
(N
)
1148 and then Nkind_In
(Unit_Node
, N_Package_Declaration
,
1149 N_Generic_Package_Declaration
,
1150 N_Subprogram_Declaration
,
1151 N_Generic_Subprogram_Declaration
)
1154 Loc
: constant Source_Ptr
:= Sloc
(N
);
1155 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
1158 Spec_Id
:= Defining_Entity
(Unit_Node
);
1159 Generate_Definition
(Spec_Id
);
1161 -- See if an elaboration entity is required for possible access
1162 -- before elaboration checking. Note that we must allow for this
1163 -- even if -gnatE is not set, since a client may be compiled in
1164 -- -gnatE mode and reference the entity.
1166 -- These entities are also used by the binder to prevent multiple
1167 -- attempts to execute the elaboration code for the library case
1168 -- where the elaboration routine might otherwise be called more
1171 -- Case of units which do not require elaboration checks
1174 -- Pure units do not need checks
1178 -- Preelaborated units do not need checks
1180 or else Is_Preelaborated
(Spec_Id
)
1182 -- No checks needed if pragma Elaborate_Body present
1184 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
1186 -- No checks needed if unit does not require a body
1188 or else not Unit_Requires_Body
(Spec_Id
)
1190 -- No checks needed for predefined files
1192 or else Is_Predefined_File_Name
(Unit_File_Name
(Unum
))
1194 -- No checks required if no separate spec
1196 or else Acts_As_Spec
(N
)
1198 -- This is a case where we only need the entity for
1199 -- checking to prevent multiple elaboration checks.
1201 Set_Elaboration_Entity_Required
(Spec_Id
, False);
1203 -- Case of elaboration entity is required for access before
1204 -- elaboration checking (so certainly we must build it!)
1207 Set_Elaboration_Entity_Required
(Spec_Id
, True);
1210 Build_Elaboration_Entity
(N
, Spec_Id
);
1214 -- Freeze the compilation unit entity. This for sure is needed because
1215 -- of some warnings that can be output (see Freeze_Subprogram), but may
1216 -- in general be required. If freezing actions result, place them in the
1217 -- compilation unit actions list, and analyze them.
1220 L
: constant List_Id
:=
1221 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), N
);
1223 while Is_Non_Empty_List
(L
) loop
1224 Insert_Library_Level_Action
(Remove_Head
(L
));
1230 if Nkind
(Unit_Node
) = N_Package_Declaration
1231 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
1232 and then Expander_Active
1235 Save_Style_Check
: constant Boolean := Style_Check
;
1236 Save_Warning
: constant Warning_Mode_Type
:= Warning_Mode
;
1237 Options
: Style_Check_Options
;
1240 Save_Style_Check_Options
(Options
);
1241 Reset_Style_Check_Options
;
1242 Opt
.Warning_Mode
:= Suppress
;
1243 Check_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
1245 Reset_Style_Check_Options
;
1246 Set_Style_Check_Options
(Options
);
1247 Style_Check
:= Save_Style_Check
;
1248 Warning_Mode
:= Save_Warning
;
1252 -- If we are generating obsolescent warnings, then here is where we
1253 -- generate them for the with'ed items. The reason for this special
1254 -- processing is that the normal mechanism of generating the warnings
1255 -- for referenced entities does not work for context clause references.
1256 -- That's because when we first analyze the context, it is too early to
1257 -- know if the with'ing unit is itself obsolescent (which suppresses
1261 and then Warn_On_Obsolescent_Feature
1262 and then Nkind
(Unit_Node
) not in N_Generic_Instantiation
1264 -- Push current compilation unit as scope, so that the test for
1265 -- being within an obsolescent unit will work correctly. The check
1266 -- is not performed within an instantiation, because the warning
1267 -- will have been emitted in the corresponding generic unit.
1269 Push_Scope
(Defining_Entity
(Unit_Node
));
1271 -- Loop through context items to deal with with clauses
1279 Item
:= First
(Context_Items
(N
));
1280 while Present
(Item
) loop
1281 if Nkind
(Item
) = N_With_Clause
1283 -- Suppress this check in limited-withed units. Further work
1284 -- needed here if we decide to incorporate this check on
1285 -- limited-withed units.
1287 and then not Limited_Present
(Item
)
1290 Ent
:= Entity
(Nam
);
1292 if Is_Obsolescent
(Ent
) then
1293 Output_Obsolescent_Entity_Warnings
(Nam
, Ent
);
1301 -- Remove temporary install of current unit as scope
1305 end Analyze_Compilation_Unit
;
1307 ---------------------
1308 -- Analyze_Context --
1309 ---------------------
1311 procedure Analyze_Context
(N
: Node_Id
) is
1312 Ukind
: constant Node_Kind
:= Nkind
(Unit
(N
));
1316 -- First process all configuration pragmas at the start of the context
1317 -- items. Strictly these are not part of the context clause, but that
1318 -- is where the parser puts them. In any case for sure we must analyze
1319 -- these before analyzing the actual context items, since they can have
1320 -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to
1321 -- be with'ed as a result of changing categorizations in Ada 2005).
1323 Item
:= First
(Context_Items
(N
));
1324 while Present
(Item
)
1325 and then Nkind
(Item
) = N_Pragma
1326 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
1332 -- This is the point at which we capture the configuration settings
1333 -- for the unit. At the moment only the Optimize_Alignment setting
1334 -- needs to be captured. Probably more later ???
1336 if Optimize_Alignment_Local
then
1337 Set_OA_Setting
(Current_Sem_Unit
, 'L');
1339 Set_OA_Setting
(Current_Sem_Unit
, Optimize_Alignment
);
1342 -- Loop through actual context items. This is done in two passes:
1344 -- a) The first pass analyzes non-limited with-clauses and also any
1345 -- configuration pragmas (we need to get the latter analyzed right
1346 -- away, since they can affect processing of subsequent items.
1348 -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217)
1350 while Present
(Item
) loop
1352 -- For with clause, analyze the with clause, and then update the
1353 -- version, since we are dependent on a unit that we with.
1355 if Nkind
(Item
) = N_With_Clause
1356 and then not Limited_Present
(Item
)
1358 -- Skip analyzing with clause if no unit, nothing to do (this
1359 -- happens for a with that references a non-existent unit). Skip
1360 -- as well if this is a with_clause for the main unit, which
1361 -- happens if a subunit has a useless with_clause on its parent.
1363 if Present
(Library_Unit
(Item
)) then
1364 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
) then
1368 Set_Entity
(Name
(Item
), Cunit_Entity
(Current_Sem_Unit
));
1372 if not Implicit_With
(Item
) then
1373 Version_Update
(N
, Library_Unit
(Item
));
1376 -- Skip pragmas. Configuration pragmas at the start were handled in
1377 -- the loop above, and remaining pragmas are not processed until we
1378 -- actually install the context (see Install_Context). We delay the
1379 -- analysis of these pragmas to make sure that we have installed all
1380 -- the implicit with's on parent units.
1382 -- Skip use clauses at this stage, since we don't want to do any
1383 -- installing of potentially use-visible entities until we
1384 -- actually install the complete context (in Install_Context).
1385 -- Otherwise things can get installed in the wrong context.
1394 -- Second pass: examine all limited_with clauses. All other context
1395 -- items are ignored in this pass.
1397 Item
:= First
(Context_Items
(N
));
1398 while Present
(Item
) loop
1399 if Nkind
(Item
) = N_With_Clause
1400 and then Limited_Present
(Item
)
1402 -- No need to check errors on implicitly generated limited-with
1405 if not Implicit_With
(Item
) then
1407 -- Verify that the illegal contexts given in 10.1.2 (18/2) are
1408 -- properly rejected, including renaming declarations.
1410 if not Nkind_In
(Ukind
, N_Package_Declaration
,
1411 N_Subprogram_Declaration
)
1412 and then Ukind
not in N_Generic_Declaration
1413 and then Ukind
not in N_Generic_Instantiation
1415 Error_Msg_N
("limited with_clause not allowed here", Item
);
1417 -- Check wrong use of a limited with clause applied to the
1418 -- compilation unit containing the limited-with clause.
1420 -- limited with P.Q;
1421 -- package P.Q is ...
1423 elsif Unit
(Library_Unit
(Item
)) = Unit
(N
) then
1424 Error_Msg_N
("wrong use of limited-with clause", Item
);
1426 -- Check wrong use of limited-with clause applied to some
1427 -- immediate ancestor.
1429 elsif Is_Child_Spec
(Unit
(N
)) then
1431 Lib_U
: constant Entity_Id
:= Unit
(Library_Unit
(Item
));
1435 P
:= Parent_Spec
(Unit
(N
));
1437 if Unit
(P
) = Lib_U
then
1438 Error_Msg_N
("limited with_clause cannot "
1439 & "name ancestor", Item
);
1443 exit when not Is_Child_Spec
(Unit
(P
));
1444 P
:= Parent_Spec
(Unit
(P
));
1449 -- Check if the limited-withed unit is already visible through
1450 -- some context clause of the current compilation unit or some
1451 -- ancestor of the current compilation unit.
1454 Lim_Unit_Name
: constant Node_Id
:= Name
(Item
);
1455 Comp_Unit
: Node_Id
;
1457 Unit_Name
: Node_Id
;
1462 It
:= First
(Context_Items
(Comp_Unit
));
1463 while Present
(It
) loop
1465 and then Nkind
(It
) = N_With_Clause
1466 and then not Limited_Present
(It
)
1468 Nkind_In
(Unit
(Library_Unit
(It
)),
1469 N_Package_Declaration
,
1470 N_Package_Renaming_Declaration
)
1472 if Nkind
(Unit
(Library_Unit
(It
))) =
1473 N_Package_Declaration
1475 Unit_Name
:= Name
(It
);
1477 Unit_Name
:= Name
(Unit
(Library_Unit
(It
)));
1480 -- Check if the named package (or some ancestor)
1481 -- leaves visible the full-view of the unit given
1482 -- in the limited-with clause
1485 if Designate_Same_Unit
(Lim_Unit_Name
,
1488 Error_Msg_Sloc
:= Sloc
(It
);
1490 ("simultaneous visibility of limited "
1491 & "and unlimited views not allowed",
1494 ("\unlimited view visible through "
1495 & "context clause #",
1499 elsif Nkind
(Unit_Name
) = N_Identifier
then
1503 Unit_Name
:= Prefix
(Unit_Name
);
1510 exit when not Is_Child_Spec
(Unit
(Comp_Unit
));
1512 Comp_Unit
:= Parent_Spec
(Unit
(Comp_Unit
));
1517 -- Skip analyzing with clause if no unit, see above
1519 if Present
(Library_Unit
(Item
)) then
1523 -- A limited_with does not impose an elaboration order, but
1524 -- there is a semantic dependency for recompilation purposes.
1526 if not Implicit_With
(Item
) then
1527 Version_Update
(N
, Library_Unit
(Item
));
1530 -- Pragmas and use clauses and with clauses other than limited
1531 -- with's are ignored in this pass through the context items.
1539 end Analyze_Context
;
1541 -------------------------------
1542 -- Analyze_Package_Body_Stub --
1543 -------------------------------
1545 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
1546 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1550 -- The package declaration must be in the current declarative part
1552 Check_Stub_Level
(N
);
1553 Nam
:= Current_Entity_In_Scope
(Id
);
1555 if No
(Nam
) or else not Is_Package_Or_Generic_Package
(Nam
) then
1556 Error_Msg_N
("missing specification for package stub", N
);
1558 elsif Has_Completion
(Nam
)
1559 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
1561 Error_Msg_N
("duplicate or redundant stub for package", N
);
1564 -- Indicate that the body of the package exists. If we are doing
1565 -- only semantic analysis, the stub stands for the body. If we are
1566 -- generating code, the existence of the body will be confirmed
1567 -- when we load the proper body.
1569 Set_Has_Completion
(Nam
);
1570 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1571 Generate_Reference
(Nam
, Id
, 'b');
1572 Analyze_Proper_Body
(N
, Nam
);
1574 end Analyze_Package_Body_Stub
;
1576 -------------------------
1577 -- Analyze_Proper_Body --
1578 -------------------------
1580 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
1581 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
1582 Unum
: Unit_Number_Type
;
1584 procedure Optional_Subunit
;
1585 -- This procedure is called when the main unit is a stub, or when we
1586 -- are not generating code. In such a case, we analyze the subunit if
1587 -- present, which is user-friendly and in fact required for ASIS, but
1588 -- we don't complain if the subunit is missing.
1590 ----------------------
1591 -- Optional_Subunit --
1592 ----------------------
1594 procedure Optional_Subunit
is
1595 Comp_Unit
: Node_Id
;
1598 -- Try to load subunit, but ignore any errors that occur during the
1599 -- loading of the subunit, by using the special feature in Errout to
1600 -- ignore all errors. Note that Fatal_Error will still be set, so we
1601 -- will be able to check for this case below.
1603 if not ASIS_Mode
then
1604 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
1609 (Load_Name
=> Subunit_Name
,
1614 if not ASIS_Mode
then
1615 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
1618 -- All done if we successfully loaded the subunit
1621 and then (not Fatal_Error
(Unum
) or else Try_Semantics
)
1623 Comp_Unit
:= Cunit
(Unum
);
1625 -- If the file was empty or seriously mangled, the unit itself may
1628 if No
(Unit
(Comp_Unit
)) then
1630 ("subunit does not contain expected proper body", N
);
1632 elsif Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1634 ("expected SEPARATE subunit, found child unit",
1635 Cunit_Entity
(Unum
));
1637 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1638 Analyze_Subunit
(Comp_Unit
);
1639 Set_Library_Unit
(N
, Comp_Unit
);
1642 elsif Unum
= No_Unit
1643 and then Present
(Nam
)
1645 if Is_Protected_Type
(Nam
) then
1646 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
1648 Set_Corresponding_Body
(
1649 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
1652 end Optional_Subunit
;
1654 -- Start of processing for Analyze_Proper_Body
1657 -- If the subunit is already loaded, it means that the main unit is a
1658 -- subunit, and that the current unit is one of its parents which was
1659 -- being analyzed to provide the needed context for the analysis of the
1660 -- subunit. In this case we analyze the subunit and continue with the
1661 -- parent, without looking at subsequent subunits.
1663 if Is_Loaded
(Subunit_Name
) then
1665 -- If the proper body is already linked to the stub node, the stub is
1666 -- in a generic unit and just needs analyzing.
1668 if Present
(Library_Unit
(N
)) then
1669 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1671 -- If the subunit has severe errors, the spec of the enclosing
1672 -- body may not be available, in which case do not try analysis.
1674 if Serious_Errors_Detected
> 0
1675 and then No
(Library_Unit
(Library_Unit
(N
)))
1680 Analyze_Subunit
(Library_Unit
(N
));
1682 -- Otherwise we must load the subunit and link to it
1685 -- Load the subunit, this must work, since we originally loaded
1686 -- the subunit earlier on. So this will not really load it, just
1687 -- give access to it.
1691 (Load_Name
=> Subunit_Name
,
1696 -- And analyze the subunit in the parent context (note that we
1697 -- do not call Semantics, since that would remove the parent
1698 -- context). Because of this, we have to manually reset the
1699 -- compiler state to Analyzing since it got destroyed by Load.
1701 if Unum
/= No_Unit
then
1702 Compiler_State
:= Analyzing
;
1704 -- Check that the proper body is a subunit and not a child
1705 -- unit. If the unit was previously loaded, the error will
1706 -- have been emitted when copying the generic node, so we
1707 -- just return to avoid cascaded errors.
1709 if Nkind
(Unit
(Cunit
(Unum
))) /= N_Subunit
then
1713 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
1714 Analyze_Subunit
(Cunit
(Unum
));
1715 Set_Library_Unit
(N
, Cunit
(Unum
));
1719 -- If the main unit is a subunit, then we are just performing semantic
1720 -- analysis on that subunit, and any other subunits of any parent unit
1721 -- should be ignored, except that if we are building trees for ASIS
1722 -- usage we want to annotate the stub properly.
1724 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
1725 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
1731 -- But before we return, set the flag for unloaded subunits. This
1732 -- will suppress junk warnings of variables in the same declarative
1733 -- part (or a higher level one) that are in danger of looking unused
1734 -- when in fact there might be a declaration in the subunit that we
1735 -- do not intend to load.
1737 Unloaded_Subunits
:= True;
1740 -- If the subunit is not already loaded, and we are generating code,
1741 -- then this is the case where compilation started from the parent, and
1742 -- we are generating code for an entire subunit tree. In that case we
1743 -- definitely need to load the subunit.
1745 -- In order to continue the analysis with the rest of the parent,
1746 -- and other subunits, we load the unit without requiring its
1747 -- presence, and emit a warning if not found, rather than terminating
1748 -- the compilation abruptly, as for other missing file problems.
1750 elsif Original_Operating_Mode
= Generate_Code
then
1752 -- If the proper body is already linked to the stub node, the stub is
1753 -- in a generic unit and just needs analyzing.
1755 -- We update the version. Although we are not strictly technically
1756 -- semantically dependent on the subunit, given our approach of macro
1757 -- substitution of subunits, it makes sense to include it in the
1758 -- version identification.
1760 if Present
(Library_Unit
(N
)) then
1761 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
1762 Analyze_Subunit
(Library_Unit
(N
));
1763 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
1765 -- Otherwise we must load the subunit and link to it
1768 -- Make sure that, if the subunit is preprocessed and -gnateG is
1769 -- specified, the preprocessed file will be written.
1771 Lib
.Analysing_Subunit_Of_Main
:= True;
1774 (Load_Name
=> Subunit_Name
,
1778 Lib
.Analysing_Subunit_Of_Main
:= False;
1780 -- Give message if we did not get the unit Emit warning even if
1781 -- missing subunit is not within main unit, to simplify debugging.
1783 if Original_Operating_Mode
= Generate_Code
1784 and then Unum
= No_Unit
1786 Error_Msg_Unit_1
:= Subunit_Name
;
1788 Get_File_Name
(Subunit_Name
, Subunit
=> True);
1790 ("subunit$$ in file{ not found?!!", N
);
1791 Subunits_Missing
:= True;
1794 -- Load_Unit may reset Compiler_State, since it may have been
1795 -- necessary to parse an additional units, so we make sure that
1796 -- we reset it to the Analyzing state.
1798 Compiler_State
:= Analyzing
;
1800 if Unum
/= No_Unit
then
1801 if Debug_Flag_L
then
1802 Write_Str
("*** Loaded subunit from stub. Analyze");
1807 Comp_Unit
: constant Node_Id
:= Cunit
(Unum
);
1810 -- Check for child unit instead of subunit
1812 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
1814 ("expected SEPARATE subunit, found child unit",
1815 Cunit_Entity
(Unum
));
1817 -- OK, we have a subunit
1820 -- Set corresponding stub (even if errors)
1822 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
1824 -- Collect SCO information for loaded subunit if we are
1825 -- in the main unit).
1829 In_Extended_Main_Source_Unit
1830 (Cunit_Entity
(Current_Sem_Unit
))
1835 -- Analyze the unit if semantics active
1837 if not Fatal_Error
(Unum
) or else Try_Semantics
then
1838 Analyze_Subunit
(Comp_Unit
);
1841 -- Set the library unit pointer in any case
1843 Set_Library_Unit
(N
, Comp_Unit
);
1845 -- We update the version. Although we are not technically
1846 -- semantically dependent on the subunit, given our
1847 -- approach of macro substitution of subunits, it makes
1848 -- sense to include it in the version identification.
1850 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
1856 -- The remaining case is when the subunit is not already loaded and we
1857 -- are not generating code. In this case we are just performing semantic
1858 -- analysis on the parent, and we are not interested in the subunit. For
1859 -- subprograms, analyze the stub as a body. For other entities the stub
1860 -- has already been marked as completed.
1865 end Analyze_Proper_Body
;
1867 ----------------------------------
1868 -- Analyze_Protected_Body_Stub --
1869 ----------------------------------
1871 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1872 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1875 Check_Stub_Level
(N
);
1877 -- First occurrence of name may have been as an incomplete type
1879 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1880 Nam
:= Full_View
(Nam
);
1884 or else not Is_Protected_Type
(Etype
(Nam
))
1886 Error_Msg_N
("missing specification for Protected body", N
);
1888 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1889 Set_Has_Completion
(Etype
(Nam
));
1890 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
1891 Analyze_Proper_Body
(N
, Etype
(Nam
));
1893 end Analyze_Protected_Body_Stub
;
1895 ----------------------------------
1896 -- Analyze_Subprogram_Body_Stub --
1897 ----------------------------------
1899 -- A subprogram body stub can appear with or without a previous spec. If
1900 -- there is one, then the analysis of the body will find it and verify
1901 -- conformance. The formals appearing in the specification of the stub play
1902 -- no role, except for requiring an additional conformance check. If there
1903 -- is no previous subprogram declaration, the stub acts as a spec, and
1904 -- provides the defining entity for the subprogram.
1906 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
1910 Check_Stub_Level
(N
);
1912 -- Verify that the identifier for the stub is unique within this
1913 -- declarative part.
1915 if Nkind_In
(Parent
(N
), N_Block_Statement
,
1919 Decl
:= First
(Declarations
(Parent
(N
)));
1920 while Present
(Decl
)
1923 if Nkind
(Decl
) = N_Subprogram_Body_Stub
1924 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
))) =
1925 Chars
(Defining_Unit_Name
(Specification
(N
))))
1927 Error_Msg_N
("identifier for stub is not unique", N
);
1934 -- Treat stub as a body, which checks conformance if there is a previous
1935 -- declaration, or else introduces entity and its signature.
1937 Analyze_Subprogram_Body
(N
);
1938 Analyze_Proper_Body
(N
, Empty
);
1939 end Analyze_Subprogram_Body_Stub
;
1941 ---------------------
1942 -- Analyze_Subunit --
1943 ---------------------
1945 -- A subunit is compiled either by itself (for semantic checking) or as
1946 -- part of compiling the parent (for code generation). In either case, by
1947 -- the time we actually process the subunit, the parent has already been
1948 -- installed and analyzed. The node N is a compilation unit, whose context
1949 -- needs to be treated here, because we come directly here from the parent
1950 -- without calling Analyze_Compilation_Unit.
1952 -- The compilation context includes the explicit context of the subunit,
1953 -- and the context of the parent, together with the parent itself. In order
1954 -- to compile the current context, we remove the one inherited from the
1955 -- parent, in order to have a clean visibility table. We restore the parent
1956 -- context before analyzing the proper body itself. On exit, we remove only
1957 -- the explicit context of the subunit.
1959 procedure Analyze_Subunit
(N
: Node_Id
) is
1960 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
1961 Par_Unit
: constant Entity_Id
:= Current_Scope
;
1963 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
1964 Num_Scopes
: Int
:= 0;
1965 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
1966 Enclosing_Child
: Entity_Id
:= Empty
;
1967 Svg
: constant Suppress_Record
:= Scope_Suppress
;
1969 Save_Cunit_Restrictions
: constant Save_Cunit_Boolean_Restrictions
:=
1970 Cunit_Boolean_Restrictions_Save
;
1971 -- Save non-partition wide restrictions before processing the subunit.
1972 -- All subunits are analyzed with config restrictions reset and we need
1973 -- to restore these saved values at the end.
1975 procedure Analyze_Subunit_Context
;
1976 -- Capture names in use clauses of the subunit. This must be done before
1977 -- re-installing parent declarations, because items in the context must
1978 -- not be hidden by declarations local to the parent.
1980 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
1981 -- Recursive procedure to restore scope of all ancestors of subunit,
1982 -- from outermost in. If parent is not a subunit, the call to install
1983 -- context installs context of spec and (if parent is a child unit) the
1984 -- context of its parents as well. It is confusing that parents should
1985 -- be treated differently in both cases, but the semantics are just not
1988 procedure Re_Install_Use_Clauses
;
1989 -- As part of the removal of the parent scope, the use clauses are
1990 -- removed, to be reinstalled when the context of the subunit has been
1991 -- analyzed. Use clauses may also have been affected by the analysis of
1992 -- the context of the subunit, so they have to be applied again, to
1993 -- insure that the compilation environment of the rest of the parent
1994 -- unit is identical.
1996 procedure Remove_Scope
;
1997 -- Remove current scope from scope stack, and preserve the list of use
1998 -- clauses in it, to be reinstalled after context is analyzed.
2000 -----------------------------
2001 -- Analyze_Subunit_Context --
2002 -----------------------------
2004 procedure Analyze_Subunit_Context
is
2007 Unit_Name
: Entity_Id
;
2010 Analyze_Context
(N
);
2012 -- Make withed units immediately visible. If child unit, make the
2013 -- ultimate parent immediately visible.
2015 Item
:= First
(Context_Items
(N
));
2016 while Present
(Item
) loop
2017 if Nkind
(Item
) = N_With_Clause
then
2019 -- Protect frontend against previous errors in context clauses
2021 if Nkind
(Name
(Item
)) /= N_Selected_Component
then
2022 if Error_Posted
(Item
) then
2026 -- If a subunits has serious syntax errors, the context
2027 -- may not have been loaded. Add a harmless unit name to
2028 -- attempt processing.
2030 if Serious_Errors_Detected
> 0
2031 and then No
(Entity
(Name
(Item
)))
2033 Set_Entity
(Name
(Item
), Standard_Standard
);
2036 Unit_Name
:= Entity
(Name
(Item
));
2037 while Is_Child_Unit
(Unit_Name
) loop
2038 Set_Is_Visible_Child_Unit
(Unit_Name
);
2039 Unit_Name
:= Scope
(Unit_Name
);
2042 if not Is_Immediately_Visible
(Unit_Name
) then
2043 Set_Is_Immediately_Visible
(Unit_Name
);
2044 Set_Context_Installed
(Item
);
2049 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2050 Nam
:= First
(Names
(Item
));
2051 while Present
(Nam
) loop
2056 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2057 Nam
:= First
(Subtype_Marks
(Item
));
2058 while Present
(Nam
) loop
2067 -- Reset visibility of withed units. They will be made visible again
2068 -- when we install the subunit context.
2070 Item
:= First
(Context_Items
(N
));
2071 while Present
(Item
) loop
2072 if Nkind
(Item
) = N_With_Clause
2074 -- Protect frontend against previous errors in context clauses
2076 and then Nkind
(Name
(Item
)) /= N_Selected_Component
2077 and then not Error_Posted
(Item
)
2079 Unit_Name
:= Entity
(Name
(Item
));
2080 while Is_Child_Unit
(Unit_Name
) loop
2081 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
2082 Unit_Name
:= Scope
(Unit_Name
);
2085 if Context_Installed
(Item
) then
2086 Set_Is_Immediately_Visible
(Unit_Name
, False);
2087 Set_Context_Installed
(Item
, False);
2093 end Analyze_Subunit_Context
;
2095 ------------------------
2096 -- Re_Install_Parents --
2097 ------------------------
2099 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
2103 if Nkind
(Unit
(L
)) = N_Subunit
then
2104 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
2107 Install_Context
(L
);
2109 -- If the subunit occurs within a child unit, we must restore the
2110 -- immediate visibility of any siblings that may occur in context.
2112 if Present
(Enclosing_Child
) then
2113 Install_Siblings
(Enclosing_Child
, L
);
2118 if Scop
/= Par_Unit
then
2119 Set_Is_Immediately_Visible
(Scop
);
2122 -- Make entities in scope visible again. For child units, restore
2123 -- visibility only if they are actually in context.
2125 E
:= First_Entity
(Current_Scope
);
2126 while Present
(E
) loop
2127 if not Is_Child_Unit
(E
)
2128 or else Is_Visible_Child_Unit
(E
)
2130 Set_Is_Immediately_Visible
(E
);
2136 -- A subunit appears within a body, and for a nested subunits all the
2137 -- parents are bodies. Restore full visibility of their private
2140 if Is_Package_Or_Generic_Package
(Scop
) then
2141 Set_In_Package_Body
(Scop
);
2142 Install_Private_Declarations
(Scop
);
2144 end Re_Install_Parents
;
2146 ----------------------------
2147 -- Re_Install_Use_Clauses --
2148 ----------------------------
2150 procedure Re_Install_Use_Clauses
is
2153 for J
in reverse 1 .. Num_Scopes
loop
2154 U
:= Use_Clauses
(J
);
2155 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
2156 Install_Use_Clauses
(U
, Force_Installation
=> True);
2158 end Re_Install_Use_Clauses
;
2164 procedure Remove_Scope
is
2168 Num_Scopes
:= Num_Scopes
+ 1;
2169 Use_Clauses
(Num_Scopes
) :=
2170 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
2172 E
:= First_Entity
(Current_Scope
);
2173 while Present
(E
) loop
2174 Set_Is_Immediately_Visible
(E
, False);
2178 if Is_Child_Unit
(Current_Scope
) then
2179 Enclosing_Child
:= Current_Scope
;
2185 -- Start of processing for Analyze_Subunit
2188 -- For subunit in main extended unit, we reset the configuration values
2189 -- for the non-partition-wide restrictions. For other units reset them.
2191 if In_Extended_Main_Source_Unit
(N
) then
2192 Restore_Config_Cunit_Boolean_Restrictions
;
2194 Reset_Cunit_Boolean_Restrictions
;
2199 Nam
: Node_Id
:= Name
(Unit
(N
));
2202 if Nkind
(Nam
) = N_Selected_Component
then
2203 Nam
:= Selector_Name
(Nam
);
2206 Check_Identifier
(Nam
, Par_Unit
);
2210 if not Is_Empty_List
(Context_Items
(N
)) then
2212 -- Save current use clauses
2215 Remove_Context
(Lib_Unit
);
2217 -- Now remove parents and their context, including enclosing subunits
2218 -- and the outer parent body which is not a subunit.
2220 if Present
(Lib_Spec
) then
2221 Remove_Context
(Lib_Spec
);
2223 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
2224 Lib_Spec
:= Library_Unit
(Lib_Spec
);
2226 Remove_Context
(Lib_Spec
);
2229 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
2233 if Nkind
(Unit
(Lib_Spec
)) = N_Package_Body
then
2234 Remove_Context
(Library_Unit
(Lib_Spec
));
2238 Set_Is_Immediately_Visible
(Par_Unit
, False);
2240 Analyze_Subunit_Context
;
2242 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
2243 Set_Is_Immediately_Visible
(Par_Unit
);
2245 -- If the context includes a child unit of the parent of the subunit,
2246 -- the parent will have been removed from visibility, after compiling
2247 -- that cousin in the context. The visibility of the parent must be
2248 -- restored now. This also applies if the context includes another
2249 -- subunit of the same parent which in turn includes a child unit in
2252 if Is_Package_Or_Generic_Package
(Par_Unit
) then
2253 if not Is_Immediately_Visible
(Par_Unit
)
2254 or else (Present
(First_Entity
(Par_Unit
))
2255 and then not Is_Immediately_Visible
2256 (First_Entity
(Par_Unit
)))
2258 Set_Is_Immediately_Visible
(Par_Unit
);
2259 Install_Visible_Declarations
(Par_Unit
);
2260 Install_Private_Declarations
(Par_Unit
);
2264 Re_Install_Use_Clauses
;
2265 Install_Context
(N
);
2267 -- Restore state of suppress flags for current body
2269 Scope_Suppress
:= Svg
;
2271 -- If the subunit is within a child unit, then siblings of any parent
2272 -- unit that appear in the context clause of the subunit must also be
2273 -- made immediately visible.
2275 if Present
(Enclosing_Child
) then
2276 Install_Siblings
(Enclosing_Child
, N
);
2280 Analyze
(Proper_Body
(Unit
(N
)));
2283 -- The subunit may contain a with_clause on a sibling of some ancestor.
2284 -- Removing the context will remove from visibility those ancestor child
2285 -- units, which must be restored to the visibility they have in the
2288 if Present
(Enclosing_Child
) then
2294 and then Is_Child_Unit
(C
)
2296 Set_Is_Immediately_Visible
(C
);
2297 Set_Is_Visible_Child_Unit
(C
);
2303 -- Deal with restore of restrictions
2305 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
2306 end Analyze_Subunit
;
2308 ----------------------------
2309 -- Analyze_Task_Body_Stub --
2310 ----------------------------
2312 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
2313 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
2314 Loc
: constant Source_Ptr
:= Sloc
(N
);
2317 Check_Stub_Level
(N
);
2319 -- First occurrence of name may have been as an incomplete type
2321 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
2322 Nam
:= Full_View
(Nam
);
2325 if No
(Nam
) or else not Is_Task_Type
(Etype
(Nam
)) then
2326 Error_Msg_N
("missing specification for task body", N
);
2328 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
2329 Generate_Reference
(Nam
, Defining_Identifier
(N
), 'b');
2331 -- Check for duplicate stub, if so give message and terminate
2333 if Has_Completion
(Etype
(Nam
)) then
2334 Error_Msg_N
("duplicate stub for task", N
);
2337 Set_Has_Completion
(Etype
(Nam
));
2340 Analyze_Proper_Body
(N
, Etype
(Nam
));
2342 -- Set elaboration flag to indicate that entity is callable. This
2343 -- cannot be done in the expansion of the body itself, because the
2344 -- proper body is not in a declarative part. This is only done if
2345 -- expansion is active, because the context may be generic and the
2346 -- flag not defined yet.
2348 if Full_Expander_Active
then
2350 Make_Assignment_Statement
(Loc
,
2352 Make_Identifier
(Loc
,
2353 Chars
=> New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
2354 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
2357 end Analyze_Task_Body_Stub
;
2359 -------------------------
2360 -- Analyze_With_Clause --
2361 -------------------------
2363 -- Analyze the declaration of a unit in a with clause. At end, label the
2364 -- with clause with the defining entity for the unit.
2366 procedure Analyze_With_Clause
(N
: Node_Id
) is
2368 -- Retrieve the original kind of the unit node, before analysis. If it
2369 -- is a subprogram instantiation, its analysis below will rewrite the
2370 -- node as the declaration of the wrapper package. If the same
2371 -- instantiation appears indirectly elsewhere in the context, it will
2372 -- have been analyzed already.
2374 Unit_Kind
: constant Node_Kind
:=
2375 Nkind
(Original_Node
(Unit
(Library_Unit
(N
))));
2376 Nam
: constant Node_Id
:= Name
(N
);
2378 Par_Name
: Entity_Id
;
2383 -- Set True if the unit currently being compiled is an internal unit
2385 Restriction_Violation
: Boolean := False;
2386 -- Set True if a with violates a restriction, no point in giving any
2387 -- warnings if we have this definite error.
2389 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2392 U
:= Unit
(Library_Unit
(N
));
2394 -- If this is an internal unit which is a renaming, then this is a
2395 -- violation of No_Obsolescent_Features.
2397 -- Note: this is not quite right if the user defines one of these units
2398 -- himself, but that's a marginal case, and fixing it is hard ???
2400 if Restriction_Check_Required
(No_Obsolescent_Features
) then
2402 F
: constant File_Name_Type
:=
2403 Unit_File_Name
(Get_Source_Unit
(U
));
2405 if Is_Predefined_File_Name
(F
, Renamings_Included
=> True)
2407 Is_Predefined_File_Name
(F
, Renamings_Included
=> False)
2409 Check_Restriction
(No_Obsolescent_Features
, N
);
2410 Restriction_Violation
:= True;
2415 -- Check No_Implementation_Units violation
2417 if Restriction_Check_Required
(No_Implementation_Units
) then
2418 if Not_Impl_Defined_Unit
(Get_Source_Unit
(U
)) then
2421 Check_Restriction
(No_Implementation_Units
, Nam
);
2422 Restriction_Violation
:= True;
2426 -- Several actions are skipped for dummy packages (those supplied for
2427 -- with's where no matching file could be found). Such packages are
2428 -- identified by the Sloc value being set to No_Location.
2430 if Limited_Present
(N
) then
2432 -- Ada 2005 (AI-50217): Build visibility structures but do not
2433 -- analyze the unit.
2435 if Sloc
(U
) /= No_Location
then
2436 Build_Limited_Views
(N
);
2442 -- We reset ordinary style checking during the analysis of a with'ed
2443 -- unit, but we do NOT reset GNAT special analysis mode (the latter
2444 -- definitely *does* apply to with'ed units).
2446 if not GNAT_Mode
then
2447 Style_Check
:= False;
2450 -- If the library unit is a predefined unit, and we are in high
2451 -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
2452 -- for the analysis of the with'ed unit. This mode does not prevent
2453 -- explicit with'ing of run-time units.
2455 if Configurable_Run_Time_Mode
2456 and then Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(U
)))
2458 Configurable_Run_Time_Mode
:= False;
2459 Semantics
(Library_Unit
(N
));
2460 Configurable_Run_Time_Mode
:= True;
2463 Semantics
(Library_Unit
(N
));
2466 Intunit
:= Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
));
2468 if Sloc
(U
) /= No_Location
then
2470 -- Check restrictions, except that we skip the check if this is an
2471 -- internal unit unless we are compiling the internal unit as the
2472 -- main unit. We also skip this for dummy packages.
2474 Check_Restriction_No_Dependence
(Nam
, N
);
2476 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
2477 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
2480 -- Deal with special case of GNAT.Current_Exceptions which interacts
2481 -- with the optimization of local raise statements into gotos.
2483 if Nkind
(Nam
) = N_Selected_Component
2484 and then Nkind
(Prefix
(Nam
)) = N_Identifier
2485 and then Chars
(Prefix
(Nam
)) = Name_Gnat
2486 and then (Chars
(Selector_Name
(Nam
)) = Name_Most_Recent_Exception
2488 Chars
(Selector_Name
(Nam
)) = Name_Exception_Traces
)
2490 Check_Restriction
(No_Exception_Propagation
, N
);
2491 Special_Exception_Package_Used
:= True;
2494 -- Check for inappropriate with of internal implementation unit if we
2495 -- are not compiling an internal unit and also check for withing unit
2496 -- in wrong version of Ada. Do not issue these messages for implicit
2497 -- with's generated by the compiler itself.
2499 if Implementation_Unit_Warnings
2500 and then not Intunit
2501 and then not Implicit_With
(N
)
2502 and then not Restriction_Violation
2505 U_Kind
: constant Kind_Of_Unit
:=
2506 Get_Kind_Of_Unit
(Get_Source_Unit
(U
));
2509 if U_Kind
= Implementation_Unit
then
2510 Error_Msg_F
("& is an internal 'G'N'A'T unit?", Name
(N
));
2512 -- Add alternative name if available, otherwise issue a
2513 -- general warning message.
2515 if Error_Msg_Strlen
/= 0 then
2516 Error_Msg_F
("\use ""~"" instead", Name
(N
));
2519 ("\use of this unit is non-portable " &
2520 "and version-dependent?", Name
(N
));
2523 elsif U_Kind
= Ada_2005_Unit
2524 and then Ada_Version
< Ada_2005
2525 and then Warn_On_Ada_2005_Compatibility
2527 Error_Msg_N
("& is an Ada 2005 unit?", Name
(N
));
2529 elsif U_Kind
= Ada_2012_Unit
2530 and then Ada_Version
< Ada_2012
2531 and then Warn_On_Ada_2012_Compatibility
2533 Error_Msg_N
("& is an Ada 2012 unit?", Name
(N
));
2539 -- Semantic analysis of a generic unit is performed on a copy of
2540 -- the original tree. Retrieve the entity on which semantic info
2541 -- actually appears.
2543 if Unit_Kind
in N_Generic_Declaration
then
2544 E_Name
:= Defining_Entity
(U
);
2546 -- Note: in the following test, Unit_Kind is the original Nkind, but in
2547 -- the case of an instantiation, semantic analysis above will have
2548 -- replaced the unit by its instantiated version. If the instance body
2549 -- has been generated, the instance now denotes the body entity. For
2550 -- visibility purposes we need the entity of its spec.
2552 elsif (Unit_Kind
= N_Package_Instantiation
2553 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
2554 N_Package_Instantiation
)
2555 and then Nkind
(U
) = N_Package_Body
2557 E_Name
:= Corresponding_Spec
(U
);
2559 elsif Unit_Kind
= N_Package_Instantiation
2560 and then Nkind
(U
) = N_Package_Instantiation
2561 and then Present
(Instance_Spec
(U
))
2563 -- If the instance has not been rewritten as a package declaration,
2564 -- then it appeared already in a previous with clause. Retrieve
2565 -- the entity from the previous instance.
2567 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
2569 elsif Unit_Kind
in N_Subprogram_Instantiation
then
2571 -- The visible subprogram is created during instantiation, and is
2572 -- an attribute of the wrapper package. We retrieve the wrapper
2573 -- package directly from the instantiation node. If the instance
2574 -- is inlined the unit is still an instantiation. Otherwise it has
2575 -- been rewritten as the declaration of the wrapper itself.
2577 if Nkind
(U
) in N_Subprogram_Instantiation
then
2580 (Defining_Entity
(Specification
(Instance_Spec
(U
))));
2582 E_Name
:= Related_Instance
(Defining_Entity
(U
));
2585 elsif Unit_Kind
= N_Package_Renaming_Declaration
2586 or else Unit_Kind
in N_Generic_Renaming_Declaration
2588 E_Name
:= Defining_Entity
(U
);
2590 elsif Unit_Kind
= N_Subprogram_Body
2591 and then Nkind
(Name
(N
)) = N_Selected_Component
2592 and then not Acts_As_Spec
(Library_Unit
(N
))
2594 -- For a child unit that has no spec, one has been created and
2595 -- analyzed. The entity required is that of the spec.
2597 E_Name
:= Corresponding_Spec
(U
);
2600 E_Name
:= Defining_Entity
(U
);
2603 if Nkind
(Name
(N
)) = N_Selected_Component
then
2605 -- Child unit in a with clause
2607 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
2609 -- If this is a child unit without a spec, and it has been analyzed
2610 -- already, a declaration has been created for it. The with_clause
2611 -- must reflect the actual body, and not the generated declaration,
2612 -- to prevent spurious binding errors involving an out-of-date spec.
2613 -- Note that this can only happen if the unit includes more than one
2614 -- with_clause for the child unit (e.g. in separate subunits).
2616 if Unit_Kind
= N_Subprogram_Declaration
2617 and then Analyzed
(Library_Unit
(N
))
2618 and then not Comes_From_Source
(Library_Unit
(N
))
2620 Set_Library_Unit
(N
,
2621 Cunit
(Get_Source_Unit
(Corresponding_Body
(U
))));
2625 -- Restore style checks
2627 Style_Check
:= Save_Style_Check
;
2629 -- Record the reference, but do NOT set the unit as referenced, we want
2630 -- to consider the unit as unreferenced if this is the only reference
2633 Set_Entity_With_Style_Check
(Name
(N
), E_Name
);
2634 Generate_Reference
(E_Name
, Name
(N
), 'w', Set_Ref
=> False);
2636 -- Generate references and check No_Dependence restriction for parents
2638 if Is_Child_Unit
(E_Name
) then
2639 Pref
:= Prefix
(Name
(N
));
2640 Par_Name
:= Scope
(E_Name
);
2641 while Nkind
(Pref
) = N_Selected_Component
loop
2642 Change_Selected_Component_To_Expanded_Name
(Pref
);
2644 if Present
(Entity
(Selector_Name
(Pref
)))
2646 Present
(Renamed_Entity
(Entity
(Selector_Name
(Pref
))))
2647 and then Entity
(Selector_Name
(Pref
)) /= Par_Name
2649 -- The prefix is a child unit that denotes a renaming declaration.
2650 -- Replace the prefix directly with the renamed unit, because the
2651 -- rest of the prefix is irrelevant to the visibility of the real
2654 Rewrite
(Pref
, New_Occurrence_Of
(Par_Name
, Sloc
(Pref
)));
2658 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2660 Generate_Reference
(Par_Name
, Pref
);
2661 Check_Restriction_No_Dependence
(Pref
, N
);
2662 Pref
:= Prefix
(Pref
);
2664 -- If E_Name is the dummy entity for a nonexistent unit, its scope
2665 -- is set to Standard_Standard, and no attempt should be made to
2666 -- further unwind scopes.
2668 if Par_Name
/= Standard_Standard
then
2669 Par_Name
:= Scope
(Par_Name
);
2672 -- Abandon processing in case of previous errors
2674 if No
(Par_Name
) then
2675 pragma Assert
(Serious_Errors_Detected
/= 0);
2680 if Present
(Entity
(Pref
))
2681 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
2683 -- If the entity is set without its unit being compiled, the
2684 -- original parent is a renaming, and Par_Name is the renamed
2685 -- entity. For visibility purposes, we need the original entity,
2686 -- which must be analyzed now because Load_Unit directly retrieves
2687 -- the renamed unit, and the renaming declaration itself has not
2690 Analyze
(Parent
(Parent
(Entity
(Pref
))));
2691 pragma Assert
(Renamed_Object
(Entity
(Pref
)) = Par_Name
);
2692 Par_Name
:= Entity
(Pref
);
2695 -- Guard against missing or misspelled child units
2697 if Present
(Par_Name
) then
2698 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
2699 Generate_Reference
(Par_Name
, Pref
);
2702 pragma Assert
(Serious_Errors_Detected
/= 0);
2704 -- Mark the node to indicate that a related error has been posted.
2705 -- This defends further compilation passes against improper use of
2706 -- the invalid WITH clause node.
2708 Set_Error_Posted
(N
);
2709 Set_Name
(N
, Error
);
2714 -- If the withed unit is System, and a system extension pragma is
2715 -- present, compile the extension now, rather than waiting for a
2716 -- visibility check on a specific entity.
2718 if Chars
(E_Name
) = Name_System
2719 and then Scope
(E_Name
) = Standard_Standard
2720 and then Present
(System_Extend_Unit
)
2721 and then Present_System_Aux
(N
)
2723 -- If the extension is not present, an error will have been emitted
2728 -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
2729 -- to private_with units; they will be made visible later (just before
2730 -- the private part is analyzed)
2732 if Private_Present
(N
) then
2733 Set_Is_Immediately_Visible
(E_Name
, False);
2735 end Analyze_With_Clause
;
2737 ------------------------------
2738 -- Check_Private_Child_Unit --
2739 ------------------------------
2741 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
2742 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2744 Curr_Unit
: Entity_Id
;
2745 Sub_Parent
: Node_Id
;
2746 Priv_Child
: Entity_Id
;
2747 Par_Lib
: Entity_Id
;
2750 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean;
2751 -- Returns true if and only if the library unit is declared with
2752 -- an explicit designation of private.
2754 -----------------------------
2755 -- Is_Private_Library_Unit --
2756 -----------------------------
2758 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
2759 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
2762 return Private_Present
(Comp_Unit
);
2763 end Is_Private_Library_Unit
;
2765 -- Start of processing for Check_Private_Child_Unit
2768 if Nkind_In
(Lib_Unit
, N_Package_Body
, N_Subprogram_Body
) then
2769 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
2770 Par_Lib
:= Curr_Unit
;
2772 elsif Nkind
(Lib_Unit
) = N_Subunit
then
2774 -- The parent is itself a body. The parent entity is to be found in
2775 -- the corresponding spec.
2777 Sub_Parent
:= Library_Unit
(N
);
2778 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
2780 -- If the parent itself is a subunit, Curr_Unit is the entity of the
2781 -- enclosing body, retrieve the spec entity which is the proper
2782 -- ancestor we need for the following tests.
2784 if Ekind
(Curr_Unit
) = E_Package_Body
then
2785 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2788 Par_Lib
:= Curr_Unit
;
2791 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2793 Par_Lib
:= Curr_Unit
;
2794 Par_Spec
:= Parent_Spec
(Lib_Unit
);
2796 if No
(Par_Spec
) then
2799 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
2803 -- Loop through context items
2805 Item
:= First
(Context_Items
(N
));
2806 while Present
(Item
) loop
2808 -- Ada 2005 (AI-262): Allow private_with of a private child package
2809 -- in public siblings
2811 if Nkind
(Item
) = N_With_Clause
2812 and then not Implicit_With
(Item
)
2813 and then not Limited_Present
(Item
)
2814 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
2816 Priv_Child
:= Entity
(Name
(Item
));
2819 Curr_Parent
: Entity_Id
:= Par_Lib
;
2820 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
2821 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
2822 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
2825 -- If the child unit is a public child then locate the nearest
2826 -- private ancestor. Child_Parent will then be set to the
2827 -- parent of that ancestor.
2829 if not Is_Private_Library_Unit
(Priv_Child
) then
2830 while Present
(Prv_Ancestor
)
2831 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
2833 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
2836 if Present
(Prv_Ancestor
) then
2837 Child_Parent
:= Scope
(Prv_Ancestor
);
2841 while Present
(Curr_Parent
)
2842 and then Curr_Parent
/= Standard_Standard
2843 and then Curr_Parent
/= Child_Parent
2846 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
2847 Curr_Parent
:= Scope
(Curr_Parent
);
2850 if No
(Curr_Parent
) then
2851 Curr_Parent
:= Standard_Standard
;
2854 if Curr_Parent
/= Child_Parent
then
2855 if Ekind
(Priv_Child
) = E_Generic_Package
2856 and then Chars
(Priv_Child
) in Text_IO_Package_Name
2857 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
2860 ("& is a nested package, not a compilation unit",
2861 Name
(Item
), Priv_Child
);
2865 ("unit in with clause is private child unit!", Item
);
2867 ("\current unit must also have parent&!",
2868 Item
, Child_Parent
);
2872 or else Private_Present
(Item
)
2873 or else Nkind_In
(Lib_Unit
, N_Package_Body
, N_Subunit
)
2874 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
2875 and then not Acts_As_Spec
(Parent
(Lib_Unit
)))
2881 ("current unit must also be private descendant of&",
2882 Item
, Child_Parent
);
2890 end Check_Private_Child_Unit
;
2892 ----------------------
2893 -- Check_Stub_Level --
2894 ----------------------
2896 procedure Check_Stub_Level
(N
: Node_Id
) is
2897 Par
: constant Node_Id
:= Parent
(N
);
2898 Kind
: constant Node_Kind
:= Nkind
(Par
);
2901 if Nkind_In
(Kind
, N_Package_Body
,
2905 and then Nkind_In
(Parent
(Par
), N_Compilation_Unit
, N_Subunit
)
2909 -- In an instance, a missing stub appears at any level. A warning
2910 -- message will have been emitted already for the missing file.
2912 elsif not In_Instance
then
2913 Error_Msg_N
("stub cannot appear in an inner scope", N
);
2915 elsif Expander_Active
then
2916 Error_Msg_N
("missing proper body", N
);
2918 end Check_Stub_Level
;
2920 ------------------------
2921 -- Expand_With_Clause --
2922 ------------------------
2924 procedure Expand_With_Clause
(Item
: Node_Id
; Nam
: Node_Id
; N
: Node_Id
) is
2925 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2926 Ent
: constant Entity_Id
:= Entity
(Nam
);
2930 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
2931 -- Build name to be used in implicit with_clause. In most cases this
2932 -- is the source name, but if renamings are present we must make the
2933 -- original unit visible, not the one it renames. The entity in the
2934 -- with clause is the renamed unit, but the identifier is the one from
2935 -- the source, which allows us to recover the unit renaming.
2937 ---------------------
2938 -- Build_Unit_Name --
2939 ---------------------
2941 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
2946 if Nkind
(Nam
) = N_Identifier
then
2947 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
2950 Ent
:= Entity
(Nam
);
2952 if Present
(Entity
(Selector_Name
(Nam
)))
2953 and then Chars
(Entity
(Selector_Name
(Nam
))) /= Chars
(Ent
)
2955 Nkind
(Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
))))
2956 = N_Package_Renaming_Declaration
2958 -- The name in the with_clause is of the form A.B.C, and B is
2959 -- given by a renaming declaration. In that case we may not
2960 -- have analyzed the unit for B, but replaced it directly in
2961 -- lib-load with the unit it renames. We have to make A.B
2962 -- visible, so analyze the declaration for B now, in case it
2963 -- has not been done yet.
2965 Ent
:= Entity
(Selector_Name
(Nam
));
2968 (Unit_Declaration_Node
(Entity
(Selector_Name
(Nam
)))));
2972 Make_Expanded_Name
(Loc
,
2973 Chars
=> Chars
(Entity
(Nam
)),
2974 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
2975 Selector_Name
=> New_Occurrence_Of
(Ent
, Loc
));
2976 Set_Entity
(Result
, Ent
);
2979 end Build_Unit_Name
;
2981 -- Start of processing for Expand_With_Clause
2985 Make_With_Clause
(Loc
,
2986 Name
=> Build_Unit_Name
(Nam
));
2988 P
:= Parent
(Unit_Declaration_Node
(Ent
));
2989 Set_Library_Unit
(Withn
, P
);
2990 Set_Corresponding_Spec
(Withn
, Ent
);
2991 Set_First_Name
(Withn
, True);
2992 Set_Implicit_With
(Withn
, True);
2994 -- If the unit is a package or generic package declaration, a private_
2995 -- with_clause on a child unit implies that the implicit with on the
2996 -- parent is also private.
2998 if Nkind_In
(Unit
(N
), N_Package_Declaration
,
2999 N_Generic_Package_Declaration
)
3001 Set_Private_Present
(Withn
, Private_Present
(Item
));
3004 Prepend
(Withn
, Context_Items
(N
));
3005 Mark_Rewrite_Insertion
(Withn
);
3006 Install_Withed_Unit
(Withn
);
3008 if Nkind
(Nam
) = N_Expanded_Name
then
3009 Expand_With_Clause
(Item
, Prefix
(Nam
), N
);
3011 end Expand_With_Clause
;
3013 -----------------------
3014 -- Get_Parent_Entity --
3015 -----------------------
3017 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
3019 if Nkind
(Unit
) = N_Package_Body
3020 and then Nkind
(Original_Node
(Unit
)) = N_Package_Instantiation
3022 return Defining_Entity
3023 (Specification
(Instance_Spec
(Original_Node
(Unit
))));
3024 elsif Nkind
(Unit
) = N_Package_Instantiation
then
3025 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
3027 return Defining_Entity
(Unit
);
3029 end Get_Parent_Entity
;
3031 ---------------------
3032 -- Has_With_Clause --
3033 ---------------------
3035 function Has_With_Clause
3038 Is_Limited
: Boolean := False) return Boolean
3042 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
;
3043 -- Return the entity for the unit named in a [limited] with clause
3049 function Named_Unit
(Clause
: Node_Id
) return Entity_Id
is
3051 if Nkind
(Name
(Clause
)) = N_Selected_Component
then
3052 return Entity
(Selector_Name
(Name
(Clause
)));
3054 return Entity
(Name
(Clause
));
3058 -- Start of processing for Has_With_Clause
3061 if Present
(Context_Items
(C_Unit
)) then
3062 Item
:= First
(Context_Items
(C_Unit
));
3063 while Present
(Item
) loop
3064 if Nkind
(Item
) = N_With_Clause
3065 and then Limited_Present
(Item
) = Is_Limited
3066 and then Named_Unit
(Item
) = Pack
3076 end Has_With_Clause
;
3078 -----------------------------
3079 -- Implicit_With_On_Parent --
3080 -----------------------------
3082 procedure Implicit_With_On_Parent
3083 (Child_Unit
: Node_Id
;
3086 Loc
: constant Source_Ptr
:= Sloc
(N
);
3087 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
3088 P_Unit
: Node_Id
:= Unit
(P
);
3089 P_Name
: constant Entity_Id
:= Get_Parent_Entity
(P_Unit
);
3092 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
3093 -- Build prefix of child unit name. Recurse if needed
3095 function Build_Unit_Name
return Node_Id
;
3096 -- If the unit is a child unit, build qualified name with all ancestors
3098 -------------------------
3099 -- Build_Ancestor_Name --
3100 -------------------------
3102 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
3103 P_Ref
: constant Node_Id
:=
3104 New_Reference_To
(Defining_Entity
(P
), Loc
);
3105 P_Spec
: Node_Id
:= P
;
3108 -- Ancestor may have been rewritten as a package body. Retrieve
3109 -- the original spec to trace earlier ancestors.
3111 if Nkind
(P
) = N_Package_Body
3112 and then Nkind
(Original_Node
(P
)) = N_Package_Instantiation
3114 P_Spec
:= Original_Node
(P
);
3117 if No
(Parent_Spec
(P_Spec
)) then
3121 Make_Selected_Component
(Loc
,
3122 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Spec
))),
3123 Selector_Name
=> P_Ref
);
3125 end Build_Ancestor_Name
;
3127 ---------------------
3128 -- Build_Unit_Name --
3129 ---------------------
3131 function Build_Unit_Name
return Node_Id
is
3135 if No
(Parent_Spec
(P_Unit
)) then
3136 return New_Reference_To
(P_Name
, Loc
);
3140 Make_Expanded_Name
(Loc
,
3141 Chars
=> Chars
(P_Name
),
3142 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
3143 Selector_Name
=> New_Reference_To
(P_Name
, Loc
));
3144 Set_Entity
(Result
, P_Name
);
3147 end Build_Unit_Name
;
3149 -- Start of processing for Implicit_With_On_Parent
3152 -- The unit of the current compilation may be a package body that
3153 -- replaces an instance node. In this case we need the original instance
3154 -- node to construct the proper parent name.
3156 if Nkind
(P_Unit
) = N_Package_Body
3157 and then Nkind
(Original_Node
(P_Unit
)) = N_Package_Instantiation
3159 P_Unit
:= Original_Node
(P_Unit
);
3162 -- We add the implicit with if the child unit is the current unit being
3163 -- compiled. If the current unit is a body, we do not want to add an
3164 -- implicit_with a second time to the corresponding spec.
3166 if Nkind
(Child_Unit
) = N_Package_Declaration
3167 and then Child_Unit
/= Unit
(Cunit
(Current_Sem_Unit
))
3172 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
3174 Set_Library_Unit
(Withn
, P
);
3175 Set_Corresponding_Spec
(Withn
, P_Name
);
3176 Set_First_Name
(Withn
, True);
3177 Set_Implicit_With
(Withn
, True);
3179 -- Node is placed at the beginning of the context items, so that
3180 -- subsequent use clauses on the parent can be validated.
3182 Prepend
(Withn
, Context_Items
(N
));
3183 Mark_Rewrite_Insertion
(Withn
);
3184 Install_Withed_Unit
(Withn
);
3186 if Is_Child_Spec
(P_Unit
) then
3187 Implicit_With_On_Parent
(P_Unit
, N
);
3189 end Implicit_With_On_Parent
;
3195 function In_Chain
(E
: Entity_Id
) return Boolean is
3199 H
:= Current_Entity
(E
);
3200 while Present
(H
) loop
3211 ---------------------
3212 -- Install_Context --
3213 ---------------------
3215 procedure Install_Context
(N
: Node_Id
) is
3216 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3219 Install_Context_Clauses
(N
);
3221 if Is_Child_Spec
(Lib_Unit
) then
3222 Install_Parents
(Lib_Unit
, Private_Present
(Parent
(Lib_Unit
)));
3225 Install_Limited_Context_Clauses
(N
);
3226 end Install_Context
;
3228 -----------------------------
3229 -- Install_Context_Clauses --
3230 -----------------------------
3232 procedure Install_Context_Clauses
(N
: Node_Id
) is
3233 Lib_Unit
: constant Node_Id
:= Unit
(N
);
3235 Uname_Node
: Entity_Id
;
3236 Check_Private
: Boolean := False;
3237 Decl_Node
: Node_Id
;
3238 Lib_Parent
: Entity_Id
;
3241 -- First skip configuration pragmas at the start of the context. They
3242 -- are not technically part of the context clause, but that's where the
3243 -- parser puts them. Note they were analyzed in Analyze_Context.
3245 Item
:= First
(Context_Items
(N
));
3246 while Present
(Item
)
3247 and then Nkind
(Item
) = N_Pragma
3248 and then Pragma_Name
(Item
) in Configuration_Pragma_Names
3253 -- Loop through the actual context clause items. We process everything
3254 -- except Limited_With clauses in this routine. Limited_With clauses
3255 -- are separately installed (see Install_Limited_Context_Clauses).
3257 while Present
(Item
) loop
3259 -- Case of explicit WITH clause
3261 if Nkind
(Item
) = N_With_Clause
3262 and then not Implicit_With
(Item
)
3264 if Limited_Present
(Item
) then
3266 -- Limited withed units will be installed later
3270 -- If Name (Item) is not an entity name, something is wrong, and
3271 -- this will be detected in due course, for now ignore the item
3273 elsif not Is_Entity_Name
(Name
(Item
)) then
3276 elsif No
(Entity
(Name
(Item
))) then
3277 Set_Entity
(Name
(Item
), Any_Id
);
3281 Uname_Node
:= Entity
(Name
(Item
));
3283 if Is_Private_Descendant
(Uname_Node
) then
3284 Check_Private
:= True;
3287 Install_Withed_Unit
(Item
);
3289 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
3291 -- If the unit is a subprogram instance, it appears nested within
3292 -- a package that carries the parent information.
3294 if Is_Generic_Instance
(Uname_Node
)
3295 and then Ekind
(Uname_Node
) /= E_Package
3297 Decl_Node
:= Parent
(Parent
(Decl_Node
));
3300 if Is_Child_Spec
(Decl_Node
) then
3301 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
3302 Expand_With_Clause
(Item
, Prefix
(Name
(Item
)), N
);
3304 -- If not an expanded name, the child unit must be a
3305 -- renaming, nothing to do.
3310 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
3311 and then not Acts_As_Spec
(Parent
(Decl_Node
))
3312 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
3314 Implicit_With_On_Parent
3315 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
3318 -- Check license conditions unless this is a dummy unit
3320 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
3321 License_Check
: declare
3322 Withu
: constant Unit_Number_Type
:=
3323 Get_Source_Unit
(Library_Unit
(Item
));
3324 Withl
: constant License_Type
:=
3325 License
(Source_Index
(Withu
));
3326 Unitl
: constant License_Type
:=
3327 License
(Source_Index
(Current_Sem_Unit
));
3329 procedure License_Error
;
3330 -- Signal error of bad license
3336 procedure License_Error
is
3339 ("?license of withed unit & may be inconsistent",
3343 -- Start of processing for License_Check
3346 -- Exclude license check if withed unit is an internal unit.
3347 -- This situation arises e.g. with the GPL version of GNAT.
3349 if Is_Internal_File_Name
(Unit_File_Name
(Withu
)) then
3352 -- Otherwise check various cases
3364 if Withl
= Restricted
then
3368 when Modified_GPL
=>
3369 if Withl
= Restricted
or else Withl
= GPL
then
3373 when Unrestricted
=>
3380 -- Case of USE PACKAGE clause
3382 elsif Nkind
(Item
) = N_Use_Package_Clause
then
3383 Analyze_Use_Package
(Item
);
3385 -- Case of USE TYPE clause
3387 elsif Nkind
(Item
) = N_Use_Type_Clause
then
3388 Analyze_Use_Type
(Item
);
3392 elsif Nkind
(Item
) = N_Pragma
then
3400 if Is_Child_Spec
(Lib_Unit
) then
3402 -- The unit also has implicit with_clauses on its own parents
3404 if No
(Context_Items
(N
)) then
3405 Set_Context_Items
(N
, New_List
);
3408 Implicit_With_On_Parent
(Lib_Unit
, N
);
3411 -- If the unit is a body, the context of the specification must also
3412 -- be installed. That includes private with_clauses in that context.
3414 if Nkind
(Lib_Unit
) = N_Package_Body
3415 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
3416 and then not Acts_As_Spec
(N
))
3418 Install_Context
(Library_Unit
(N
));
3420 -- Only install private with-clauses of a spec that comes from
3421 -- source, excluding specs created for a subprogram body that is
3424 if Comes_From_Source
(Library_Unit
(N
)) then
3425 Install_Private_With_Clauses
3426 (Defining_Entity
(Unit
(Library_Unit
(N
))));
3429 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
3431 -- If the unit is the body of a public child unit, the private
3432 -- declarations of the parent must be made visible. If the child
3433 -- unit is private, the private declarations have been installed
3434 -- already in the call to Install_Parents for the spec. Installing
3435 -- private declarations must be done for all ancestors of public
3436 -- child units. In addition, sibling units mentioned in the
3437 -- context clause of the body are directly visible.
3445 Lib_Spec
:= Unit
(Library_Unit
(N
));
3446 while Is_Child_Spec
(Lib_Spec
) loop
3447 P
:= Unit
(Parent_Spec
(Lib_Spec
));
3448 P_Name
:= Defining_Entity
(P
);
3450 if not (Private_Present
(Parent
(Lib_Spec
)))
3451 and then not In_Private_Part
(P_Name
)
3453 Install_Private_Declarations
(P_Name
);
3454 Install_Private_With_Clauses
(P_Name
);
3455 Set_Use
(Private_Declarations
(Specification
(P
)));
3463 -- For a package body, children in context are immediately visible
3465 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
3468 if Nkind_In
(Lib_Unit
, N_Generic_Package_Declaration
,
3469 N_Generic_Subprogram_Declaration
,
3470 N_Package_Declaration
,
3471 N_Subprogram_Declaration
)
3473 if Is_Child_Spec
(Lib_Unit
) then
3474 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
3475 Set_Is_Private_Descendant
3476 (Defining_Entity
(Lib_Unit
),
3477 Is_Private_Descendant
(Lib_Parent
)
3478 or else Private_Present
(Parent
(Lib_Unit
)));
3481 Set_Is_Private_Descendant
3482 (Defining_Entity
(Lib_Unit
),
3483 Private_Present
(Parent
(Lib_Unit
)));
3487 if Check_Private
then
3488 Check_Private_Child_Unit
(N
);
3490 end Install_Context_Clauses
;
3492 -------------------------------------
3493 -- Install_Limited_Context_Clauses --
3494 -------------------------------------
3496 procedure Install_Limited_Context_Clauses
(N
: Node_Id
) is
3499 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
);
3500 -- Check that the unlimited view of a given compilation_unit is not
3501 -- already visible through "use + renamings".
3503 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
);
3504 -- Check that if a limited_with clause of a given compilation_unit
3505 -- mentions a descendant of a private child of some library unit, then
3506 -- the given compilation_unit shall be the declaration of a private
3507 -- descendant of that library unit, or a public descendant of such. The
3508 -- code is analogous to that of Check_Private_Child_Unit but we cannot
3509 -- use entities on the limited with_clauses because their units have not
3510 -- been analyzed, so we have to climb the tree of ancestors looking for
3511 -- private keywords.
3513 procedure Expand_Limited_With_Clause
3514 (Comp_Unit
: Node_Id
;
3517 -- If a child unit appears in a limited_with clause, there are implicit
3518 -- limited_with clauses on all parents that are not already visible
3519 -- through a regular with clause. This procedure creates the implicit
3520 -- limited with_clauses for the parents and loads the corresponding
3521 -- units. The shadow entities are created when the inserted clause is
3522 -- analyzed. Implements Ada 2005 (AI-50217).
3524 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean;
3525 -- When compiling a unit Q descended from some parent unit P, a limited
3526 -- with_clause in the context of P that names some other ancestor of Q
3527 -- must not be installed because the ancestor is immediately visible.
3529 ---------------------
3530 -- Check_Renamings --
3531 ---------------------
3533 procedure Check_Renamings
(P
: Node_Id
; W
: Node_Id
) is
3542 pragma Assert
(Nkind
(W
) = N_With_Clause
);
3544 -- Protect the frontend against previous critical errors
3546 case Nkind
(Unit
(Library_Unit
(W
))) is
3547 when N_Subprogram_Declaration |
3548 N_Package_Declaration |
3549 N_Generic_Subprogram_Declaration |
3550 N_Generic_Package_Declaration
=>
3557 -- Check "use + renamings"
3559 WEnt
:= Defining_Unit_Name
(Specification
(Unit
(Library_Unit
(W
))));
3560 Spec
:= Specification
(Unit
(P
));
3562 Item
:= First
(Visible_Declarations
(Spec
));
3563 while Present
(Item
) loop
3565 -- Look only at use package clauses
3567 if Nkind
(Item
) = N_Use_Package_Clause
then
3569 -- Traverse the list of packages
3571 Nam
:= First
(Names
(Item
));
3572 while Present
(Nam
) loop
3575 pragma Assert
(Present
(Parent
(E
)));
3577 if Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
3578 and then Renamed_Entity
(E
) = WEnt
3580 -- The unlimited view is visible through use clause and
3581 -- renamings. There is no need to generate the error
3582 -- message here because Is_Visible_Through_Renamings
3583 -- takes care of generating the precise error message.
3587 elsif Nkind
(Parent
(E
)) = N_Package_Specification
then
3589 -- The use clause may refer to a local package.
3590 -- Check all the enclosing scopes.
3593 while E2
/= Standard_Standard
3601 ("unlimited view visible through use clause ", W
);
3613 -- Recursive call to check all the ancestors
3615 if Is_Child_Spec
(Unit
(P
)) then
3616 Check_Renamings
(P
=> Parent_Spec
(Unit
(P
)), W
=> W
);
3618 end Check_Renamings
;
3620 ---------------------------------------
3621 -- Check_Private_Limited_Withed_Unit --
3622 ---------------------------------------
3624 procedure Check_Private_Limited_Withed_Unit
(Item
: Node_Id
) is
3625 Curr_Parent
: Node_Id
;
3626 Child_Parent
: Node_Id
;
3627 Curr_Private
: Boolean;
3630 -- Compilation unit of the parent of the withed library unit
3632 Child_Parent
:= Library_Unit
(Item
);
3634 -- If the child unit is a public child, then locate its nearest
3635 -- private ancestor, if any, then Child_Parent will then be set to
3636 -- the parent of that ancestor.
3638 if not Private_Present
(Library_Unit
(Item
)) then
3639 while Present
(Child_Parent
)
3640 and then not Private_Present
(Child_Parent
)
3642 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3645 if No
(Child_Parent
) then
3650 Child_Parent
:= Parent_Spec
(Unit
(Child_Parent
));
3652 -- Traverse all the ancestors of the current compilation unit to
3653 -- check if it is a descendant of named library unit.
3655 Curr_Parent
:= Parent
(Item
);
3656 Curr_Private
:= Private_Present
(Curr_Parent
);
3658 while Present
(Parent_Spec
(Unit
(Curr_Parent
)))
3659 and then Curr_Parent
/= Child_Parent
3661 Curr_Parent
:= Parent_Spec
(Unit
(Curr_Parent
));
3662 Curr_Private
:= Curr_Private
or else Private_Present
(Curr_Parent
);
3665 if Curr_Parent
/= Child_Parent
then
3667 ("unit in with clause is private child unit!", Item
);
3669 ("\current unit must also have parent&!",
3670 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3672 elsif Private_Present
(Parent
(Item
))
3673 or else Curr_Private
3674 or else Private_Present
(Item
)
3675 or else Nkind_In
(Unit
(Parent
(Item
)), N_Package_Body
,
3679 -- Current unit is private, of descendant of a private unit
3685 ("current unit must also be private descendant of&",
3686 Item
, Defining_Unit_Name
(Specification
(Unit
(Child_Parent
))));
3688 end Check_Private_Limited_Withed_Unit
;
3690 --------------------------------
3691 -- Expand_Limited_With_Clause --
3692 --------------------------------
3694 procedure Expand_Limited_With_Clause
3695 (Comp_Unit
: Node_Id
;
3699 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
3700 Unum
: Unit_Number_Type
;
3703 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean;
3704 -- Returns true if the context already includes a with_clause for
3705 -- this unit. If the with_clause is non-limited, the unit is fully
3706 -- visible and an implicit limited_with should not be created. If
3707 -- there is already a limited_with clause for W, a second one is
3708 -- simply redundant.
3710 --------------------------
3711 -- Previous_Withed_Unit --
3712 --------------------------
3714 function Previous_Withed_Unit
(W
: Node_Id
) return Boolean is
3718 -- A limited with_clause cannot appear in the same context_clause
3719 -- as a nonlimited with_clause which mentions the same library.
3721 Item
:= First
(Context_Items
(Comp_Unit
));
3722 while Present
(Item
) loop
3723 if Nkind
(Item
) = N_With_Clause
3724 and then Library_Unit
(Item
) = Library_Unit
(W
)
3733 end Previous_Withed_Unit
;
3735 -- Start of processing for Expand_Limited_With_Clause
3738 if Nkind
(Nam
) = N_Identifier
then
3740 -- Create node for name of withed unit
3743 Make_With_Clause
(Loc
,
3744 Name
=> New_Copy
(Nam
));
3746 else pragma Assert
(Nkind
(Nam
) = N_Selected_Component
);
3748 Make_With_Clause
(Loc
,
3749 Name
=> Make_Selected_Component
(Loc
,
3750 Prefix
=> New_Copy_Tree
(Prefix
(Nam
)),
3751 Selector_Name
=> New_Copy
(Selector_Name
(Nam
))));
3752 Set_Parent
(Withn
, Parent
(N
));
3755 Set_Limited_Present
(Withn
);
3756 Set_First_Name
(Withn
);
3757 Set_Implicit_With
(Withn
);
3761 (Load_Name
=> Get_Spec_Name
(Get_Unit_Name
(Nam
)),
3766 -- Do not generate a limited_with_clause on the current unit. This
3767 -- path is taken when a unit has a limited_with clause on one of its
3770 if Unum
= Current_Sem_Unit
then
3774 Set_Library_Unit
(Withn
, Cunit
(Unum
));
3775 Set_Corresponding_Spec
3776 (Withn
, Specification
(Unit
(Cunit
(Unum
))));
3778 if not Previous_Withed_Unit
(Withn
) then
3779 Prepend
(Withn
, Context_Items
(Parent
(N
)));
3780 Mark_Rewrite_Insertion
(Withn
);
3782 -- Add implicit limited_with_clauses for parents of child units
3783 -- mentioned in limited_with clauses.
3785 if Nkind
(Nam
) = N_Selected_Component
then
3786 Expand_Limited_With_Clause
(Comp_Unit
, Prefix
(Nam
), N
);
3791 if not Limited_View_Installed
(Withn
) then
3792 Install_Limited_Withed_Unit
(Withn
);
3795 end Expand_Limited_With_Clause
;
3797 ----------------------
3798 -- Is_Ancestor_Unit --
3799 ----------------------
3801 function Is_Ancestor_Unit
(U1
: Node_Id
; U2
: Node_Id
) return Boolean is
3802 E1
: constant Entity_Id
:= Defining_Entity
(Unit
(U1
));
3805 if Nkind_In
(Unit
(U2
), N_Package_Body
, N_Subprogram_Body
) then
3806 E2
:= Defining_Entity
(Unit
(Library_Unit
(U2
)));
3807 return Is_Ancestor_Package
(E1
, E2
);
3811 end Is_Ancestor_Unit
;
3813 -- Start of processing for Install_Limited_Context_Clauses
3816 Item
:= First
(Context_Items
(N
));
3817 while Present
(Item
) loop
3818 if Nkind
(Item
) = N_With_Clause
3819 and then Limited_Present
(Item
)
3820 and then not Error_Posted
(Item
)
3822 if Nkind
(Name
(Item
)) = N_Selected_Component
then
3823 Expand_Limited_With_Clause
3824 (Comp_Unit
=> N
, Nam
=> Prefix
(Name
(Item
)), N
=> Item
);
3827 Check_Private_Limited_Withed_Unit
(Item
);
3829 if not Implicit_With
(Item
)
3830 and then Is_Child_Spec
(Unit
(N
))
3832 Check_Renamings
(Parent_Spec
(Unit
(N
)), Item
);
3835 -- A unit may have a limited with on itself if it has a limited
3836 -- with_clause on one of its child units. In that case it is
3837 -- already being compiled and it makes no sense to install its
3840 -- If the item is a limited_private_with_clause, install it if the
3841 -- current unit is a body or if it is a private child. Otherwise
3842 -- the private clause is installed before analyzing the private
3843 -- part of the current unit.
3845 if Library_Unit
(Item
) /= Cunit
(Current_Sem_Unit
)
3846 and then not Limited_View_Installed
(Item
)
3848 not Is_Ancestor_Unit
3849 (Library_Unit
(Item
), Cunit
(Current_Sem_Unit
))
3851 if not Private_Present
(Item
)
3852 or else Private_Present
(N
)
3853 or else Nkind_In
(Unit
(N
), N_Package_Body
,
3857 Install_Limited_Withed_Unit
(Item
);
3865 -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
3866 -- looking for incomplete subtype declarations of incomplete types
3867 -- visible through a limited with clause.
3869 if Ada_Version
>= Ada_2005
3870 and then Analyzed
(N
)
3871 and then Nkind
(Unit
(N
)) = N_Package_Declaration
3876 Non_Lim_View
: Entity_Id
;
3879 Decl
:= First
(Visible_Declarations
(Specification
(Unit
(N
))));
3880 while Present
(Decl
) loop
3881 if Nkind
(Decl
) = N_Subtype_Declaration
3883 Ekind
(Defining_Identifier
(Decl
)) = E_Incomplete_Subtype
3885 From_With_Type
(Defining_Identifier
(Decl
))
3887 Def_Id
:= Defining_Identifier
(Decl
);
3888 Non_Lim_View
:= Non_Limited_View
(Def_Id
);
3890 if not Is_Incomplete_Type
(Non_Lim_View
) then
3892 -- Convert an incomplete subtype declaration into a
3893 -- corresponding non-limited view subtype declaration.
3894 -- This is usually the case when analyzing a body that
3895 -- has regular with clauses, when the spec has limited
3898 -- If the non-limited view is still incomplete, it is
3899 -- the dummy entry already created, and the declaration
3900 -- cannot be reanalyzed. This is the case when installing
3901 -- a parent unit that has limited with-clauses.
3903 Set_Subtype_Indication
(Decl
,
3904 New_Reference_To
(Non_Lim_View
, Sloc
(Def_Id
)));
3905 Set_Etype
(Def_Id
, Non_Lim_View
);
3906 Set_Ekind
(Def_Id
, Subtype_Kind
(Ekind
(Non_Lim_View
)));
3907 Set_Analyzed
(Decl
, False);
3909 -- Reanalyze the declaration, suppressing the call to
3910 -- Enter_Name to avoid duplicate names.
3912 Analyze_Subtype_Declaration
3922 end Install_Limited_Context_Clauses
;
3924 ---------------------
3925 -- Install_Parents --
3926 ---------------------
3928 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean) is
3935 P
:= Unit
(Parent_Spec
(Lib_Unit
));
3936 P_Name
:= Get_Parent_Entity
(P
);
3938 if Etype
(P_Name
) = Any_Type
then
3942 if Ekind
(P_Name
) = E_Generic_Package
3943 and then not Nkind_In
(Lib_Unit
, N_Generic_Subprogram_Declaration
,
3944 N_Generic_Package_Declaration
)
3945 and then Nkind
(Lib_Unit
) not in N_Generic_Renaming_Declaration
3948 ("child of a generic package must be a generic unit", Lib_Unit
);
3950 elsif not Is_Package_Or_Generic_Package
(P_Name
) then
3952 ("parent unit must be package or generic package", Lib_Unit
);
3953 raise Unrecoverable_Error
;
3955 elsif Present
(Renamed_Object
(P_Name
)) then
3956 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
3957 raise Unrecoverable_Error
;
3959 -- Verify that a child of an instance is itself an instance, or the
3960 -- renaming of one. Given that an instance that is a unit is replaced
3961 -- with a package declaration, check against the original node. The
3962 -- parent may be currently being instantiated, in which case it appears
3963 -- as a declaration, but the generic_parent is already established
3964 -- indicating that we deal with an instance.
3966 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
then
3967 if Nkind
(Lib_Unit
) in N_Renaming_Declaration
3968 or else Nkind
(Original_Node
(Lib_Unit
)) in N_Generic_Instantiation
3970 (Nkind
(Lib_Unit
) = N_Package_Declaration
3971 and then Present
(Generic_Parent
(Specification
(Lib_Unit
))))
3976 ("child of an instance must be an instance or renaming",
3981 -- This is the recursive call that ensures all parents are loaded
3983 if Is_Child_Spec
(P
) then
3985 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)));
3988 -- Now we can install the context for this parent
3990 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
));
3991 Install_Limited_Context_Clauses
(Parent_Spec
(Lib_Unit
));
3992 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
3994 -- The child unit is in the declarative region of the parent. The parent
3995 -- must therefore appear in the scope stack and be visible, as when
3996 -- compiling the corresponding body. If the child unit is private or it
3997 -- is a package body, private declarations must be accessible as well.
3998 -- Use declarations in the parent must also be installed. Finally, other
3999 -- child units of the same parent that are in the context are
4000 -- immediately visible.
4002 -- Find entity for compilation unit, and set its private descendant
4003 -- status as needed. Indicate that it is a compilation unit, which is
4004 -- redundant in general, but needed if this is a generated child spec
4005 -- for a child body without previous spec.
4007 E_Name
:= Defining_Entity
(Lib_Unit
);
4009 Set_Is_Child_Unit
(E_Name
);
4010 Set_Is_Compilation_Unit
(E_Name
);
4012 Set_Is_Private_Descendant
(E_Name
,
4013 Is_Private_Descendant
(P_Name
)
4014 or else Private_Present
(Parent
(Lib_Unit
)));
4016 P_Spec
:= Specification
(Unit_Declaration_Node
(P_Name
));
4017 Push_Scope
(P_Name
);
4019 -- Save current visibility of unit
4021 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
4022 Is_Immediately_Visible
(P_Name
);
4023 Set_Is_Immediately_Visible
(P_Name
);
4024 Install_Visible_Declarations
(P_Name
);
4025 Set_Use
(Visible_Declarations
(P_Spec
));
4027 -- If the parent is a generic unit, its formal part may contain formal
4028 -- packages and use clauses for them.
4030 if Ekind
(P_Name
) = E_Generic_Package
then
4031 Set_Use
(Generic_Formal_Declarations
(Parent
(P_Spec
)));
4035 or else Private_Present
(Parent
(Lib_Unit
))
4037 Install_Private_Declarations
(P_Name
);
4038 Install_Private_With_Clauses
(P_Name
);
4039 Set_Use
(Private_Declarations
(P_Spec
));
4041 end Install_Parents
;
4043 ----------------------------------
4044 -- Install_Private_With_Clauses --
4045 ----------------------------------
4047 procedure Install_Private_With_Clauses
(P
: Entity_Id
) is
4048 Decl
: constant Node_Id
:= Unit_Declaration_Node
(P
);
4052 if Debug_Flag_I
then
4053 Write_Str
("install private with clauses of ");
4054 Write_Name
(Chars
(P
));
4058 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
4059 Item
:= First
(Context_Items
(Parent
(Decl
)));
4060 while Present
(Item
) loop
4061 if Nkind
(Item
) = N_With_Clause
4062 and then Private_Present
(Item
)
4064 if Limited_Present
(Item
) then
4065 if not Limited_View_Installed
(Item
) then
4066 Install_Limited_Withed_Unit
(Item
);
4069 Install_Withed_Unit
(Item
, Private_With_OK
=> True);
4076 end Install_Private_With_Clauses
;
4078 ----------------------
4079 -- Install_Siblings --
4080 ----------------------
4082 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
4088 -- Iterate over explicit with clauses, and check whether the scope of
4089 -- each entity is an ancestor of the current unit, in which case it is
4090 -- immediately visible.
4092 Item
:= First
(Context_Items
(N
));
4093 while Present
(Item
) loop
4095 -- Do not install private_with_clauses declaration, unless unit
4096 -- is itself a private child unit, or is a body. Note that for a
4097 -- subprogram body the private_with_clause does not take effect until
4098 -- after the specification.
4100 if Nkind
(Item
) /= N_With_Clause
4101 or else Implicit_With
(Item
)
4102 or else Limited_Present
(Item
)
4103 or else Error_Posted
(Item
)
4107 elsif not Private_Present
(Item
)
4108 or else Private_Present
(N
)
4109 or else Nkind
(Unit
(N
)) = N_Package_Body
4111 Id
:= Entity
(Name
(Item
));
4113 if Is_Child_Unit
(Id
)
4114 and then Is_Ancestor_Package
(Scope
(Id
), U_Name
)
4116 Set_Is_Immediately_Visible
(Id
);
4118 -- Check for the presence of another unit in the context that
4119 -- may be inadvertently hidden by the child.
4121 Prev
:= Current_Entity
(Id
);
4124 and then Is_Immediately_Visible
(Prev
)
4125 and then not Is_Child_Unit
(Prev
)
4131 Clause
:= First
(Context_Items
(N
));
4132 while Present
(Clause
) loop
4133 if Nkind
(Clause
) = N_With_Clause
4134 and then Entity
(Name
(Clause
)) = Prev
4137 ("child unit& hides compilation unit " &
4138 "with the same name?",
4148 -- The With_Clause may be on a grand-child or one of its further
4149 -- descendants, which makes a child immediately visible. Examine
4150 -- ancestry to determine whether such a child exists. For example,
4151 -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
4152 -- is immediately visible.
4154 elsif Is_Child_Unit
(Id
) then
4160 while Is_Child_Unit
(Par
) loop
4161 if Is_Ancestor_Package
(Scope
(Par
), U_Name
) then
4162 Set_Is_Immediately_Visible
(Par
);
4171 -- If the item is a private with-clause on a child unit, the parent
4172 -- may have been installed already, but the child unit must remain
4173 -- invisible until installed in a private part or body, unless there
4174 -- is already a regular with_clause for it in the current unit.
4176 elsif Private_Present
(Item
) then
4177 Id
:= Entity
(Name
(Item
));
4179 if Is_Child_Unit
(Id
) then
4183 function In_Context
return Boolean;
4184 -- Scan context of current unit, to check whether there is
4185 -- a with_clause on the same unit as a private with-clause
4186 -- on a parent, in which case child unit is visible. If the
4187 -- unit is a grand-child, the same applies to its parent.
4193 function In_Context
return Boolean is
4196 First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4197 while Present
(Clause
) loop
4198 if Nkind
(Clause
) = N_With_Clause
4199 and then Comes_From_Source
(Clause
)
4200 and then Is_Entity_Name
(Name
(Clause
))
4201 and then not Private_Present
(Clause
)
4203 if Entity
(Name
(Clause
)) = Id
4205 (Nkind
(Name
(Clause
)) = N_Expanded_Name
4206 and then Entity
(Prefix
(Name
(Clause
))) = Id
)
4219 Set_Is_Visible_Child_Unit
(Id
, In_Context
);
4226 end Install_Siblings
;
4228 ---------------------------------
4229 -- Install_Limited_Withed_Unit --
4230 ---------------------------------
4232 procedure Install_Limited_Withed_Unit
(N
: Node_Id
) is
4233 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
4236 Is_Child_Package
: Boolean := False;
4237 Lim_Header
: Entity_Id
;
4238 Lim_Typ
: Entity_Id
;
4240 procedure Check_Body_Required
;
4241 -- A unit mentioned in a limited with_clause may not be mentioned in
4242 -- a regular with_clause, but must still be included in the current
4243 -- partition. We need to determine whether the unit needs a body, so
4244 -- that the binder can determine the name of the file to be compiled.
4245 -- Checking whether a unit needs a body can be done without semantic
4246 -- analysis, by examining the nature of the declarations in the package.
4248 function Has_Limited_With_Clause
4249 (C_Unit
: Entity_Id
;
4250 Pack
: Entity_Id
) return Boolean;
4251 -- Determine whether any package in the ancestor chain starting with
4252 -- C_Unit has a limited with clause for package Pack.
4254 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean;
4255 -- Check if some package installed though normal with-clauses has a
4256 -- renaming declaration of package P. AARM 10.1.2(21/2).
4258 -------------------------
4259 -- Check_Body_Required --
4260 -------------------------
4262 procedure Check_Body_Required
is
4263 PA
: constant List_Id
:=
4264 Pragmas_After
(Aux_Decls_Node
(Parent
(P_Unit
)));
4266 procedure Check_Declarations
(Spec
: Node_Id
);
4267 -- Recursive procedure that does the work and checks nested packages
4269 ------------------------
4270 -- Check_Declarations --
4271 ------------------------
4273 procedure Check_Declarations
(Spec
: Node_Id
) is
4275 Incomplete_Decls
: constant Elist_Id
:= New_Elmt_List
;
4277 Subp_List
: constant Elist_Id
:= New_Elmt_List
;
4279 procedure Check_Pragma_Import
(P
: Node_Id
);
4280 -- If a pragma import applies to a previous subprogram, the
4281 -- enclosing unit may not need a body. The processing is syntactic
4282 -- and does not require a declaration to be analyzed. The code
4283 -- below also handles pragma Import when applied to a subprogram
4284 -- that renames another. In this case the pragma applies to the
4287 -- Chains of multiple renames are not handled by the code below.
4288 -- It is probably impossible to handle all cases without proper
4289 -- name resolution. In such cases the algorithm is conservative
4290 -- and will indicate that a body is needed???
4292 -------------------------
4293 -- Check_Pragma_Import --
4294 -------------------------
4296 procedure Check_Pragma_Import
(P
: Node_Id
) is
4302 procedure Remove_Homonyms
(E
: Node_Id
);
4303 -- Make one pass over list of subprograms. Called again if
4304 -- subprogram is a renaming. E is known to be an identifier.
4306 ---------------------
4307 -- Remove_Homonyms --
4308 ---------------------
4310 procedure Remove_Homonyms
(E
: Node_Id
) is
4311 R
: Entity_Id
:= Empty
;
4312 -- Name of renamed entity, if any
4315 Subp_Id
:= First_Elmt
(Subp_List
);
4316 while Present
(Subp_Id
) loop
4317 if Chars
(Node
(Subp_Id
)) = Chars
(E
) then
4318 if Nkind
(Parent
(Parent
(Node
(Subp_Id
))))
4319 /= N_Subprogram_Renaming_Declaration
4322 Next_Elmt
(Subp_Id
);
4323 Remove_Elmt
(Subp_List
, Prev_Id
);
4325 R
:= Name
(Parent
(Parent
(Node
(Subp_Id
))));
4329 Next_Elmt
(Subp_Id
);
4334 if Nkind
(R
) = N_Identifier
then
4335 Remove_Homonyms
(R
);
4337 elsif Nkind
(R
) = N_Selected_Component
then
4338 Remove_Homonyms
(Selector_Name
(R
));
4340 -- Renaming of attribute
4346 end Remove_Homonyms
;
4348 -- Start of processing for Check_Pragma_Import
4351 -- Find name of entity in Import pragma. We have not analyzed
4352 -- the construct, so we must guard against syntax errors.
4354 Arg
:= Next
(First
(Pragma_Argument_Associations
(P
)));
4357 or else Nkind
(Expression
(Arg
)) /= N_Identifier
4361 Imported
:= Expression
(Arg
);
4364 Remove_Homonyms
(Imported
);
4365 end Check_Pragma_Import
;
4367 -- Start of processing for Check_Declarations
4370 -- Search for Elaborate Body pragma
4372 Decl
:= First
(Visible_Declarations
(Spec
));
4373 while Present
(Decl
)
4374 and then Nkind
(Decl
) = N_Pragma
4376 if Get_Pragma_Id
(Decl
) = Pragma_Elaborate_Body
then
4377 Set_Body_Required
(Library_Unit
(N
));
4384 -- Look for declarations that require the presence of a body. We
4385 -- have already skipped pragmas at the start of the list.
4387 while Present
(Decl
) loop
4389 -- Subprogram that comes from source means body may be needed.
4390 -- Save for subsequent examination of import pragmas.
4392 if Comes_From_Source
(Decl
)
4393 and then (Nkind_In
(Decl
, N_Subprogram_Declaration
,
4394 N_Subprogram_Renaming_Declaration
,
4395 N_Generic_Subprogram_Declaration
))
4397 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4399 -- Package declaration of generic package declaration. We need
4400 -- to recursively examine nested declarations.
4402 elsif Nkind_In
(Decl
, N_Package_Declaration
,
4403 N_Generic_Package_Declaration
)
4405 Check_Declarations
(Specification
(Decl
));
4407 elsif Nkind
(Decl
) = N_Pragma
4408 and then Pragma_Name
(Decl
) = Name_Import
4410 Check_Pragma_Import
(Decl
);
4416 -- Same set of tests for private part. In addition to subprograms
4417 -- detect the presence of Taft Amendment types (incomplete types
4418 -- completed in the body).
4420 Decl
:= First
(Private_Declarations
(Spec
));
4421 while Present
(Decl
) loop
4422 if Comes_From_Source
(Decl
)
4423 and then (Nkind_In
(Decl
, N_Subprogram_Declaration
,
4424 N_Subprogram_Renaming_Declaration
,
4425 N_Generic_Subprogram_Declaration
))
4427 Append_Elmt
(Defining_Entity
(Decl
), Subp_List
);
4429 elsif Nkind_In
(Decl
, N_Package_Declaration
,
4430 N_Generic_Package_Declaration
)
4432 Check_Declarations
(Specification
(Decl
));
4434 -- Collect incomplete type declarations for separate pass
4436 elsif Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
4437 Append_Elmt
(Decl
, Incomplete_Decls
);
4439 elsif Nkind
(Decl
) = N_Pragma
4440 and then Pragma_Name
(Decl
) = Name_Import
4442 Check_Pragma_Import
(Decl
);
4448 -- Now check incomplete declarations to locate Taft amendment
4449 -- types. This can be done by examining the defining identifiers
4450 -- of type declarations without real semantic analysis.
4456 Inc
:= First_Elmt
(Incomplete_Decls
);
4457 while Present
(Inc
) loop
4458 Decl
:= Next
(Node
(Inc
));
4459 while Present
(Decl
) loop
4460 if Nkind
(Decl
) = N_Full_Type_Declaration
4461 and then Chars
(Defining_Identifier
(Decl
)) =
4462 Chars
(Defining_Identifier
(Node
(Inc
)))
4470 -- If no completion, this is a TAT, and a body is needed
4473 Set_Body_Required
(Library_Unit
(N
));
4481 -- Finally, check whether there are subprograms that still require
4482 -- a body, i.e. are not renamings or null.
4484 if not Is_Empty_Elmt_List
(Subp_List
) then
4490 Subp_Id
:= First_Elmt
(Subp_List
);
4491 Spec
:= Parent
(Node
(Subp_Id
));
4493 while Present
(Subp_Id
) loop
4494 if Nkind
(Parent
(Spec
))
4495 = N_Subprogram_Renaming_Declaration
4499 elsif Nkind
(Spec
) = N_Procedure_Specification
4500 and then Null_Present
(Spec
)
4505 Set_Body_Required
(Library_Unit
(N
));
4509 Next_Elmt
(Subp_Id
);
4513 end Check_Declarations
;
4515 -- Start of processing for Check_Body_Required
4518 -- If this is an imported package (Java and CIL usage) no body is
4519 -- needed. Scan list of pragmas that may follow a compilation unit
4520 -- to look for a relevant pragma Import.
4522 if Present
(PA
) then
4528 while Present
(Prag
) loop
4529 if Nkind
(Prag
) = N_Pragma
4530 and then Get_Pragma_Id
(Prag
) = Pragma_Import
4540 Check_Declarations
(Specification
(P_Unit
));
4541 end Check_Body_Required
;
4543 -----------------------------
4544 -- Has_Limited_With_Clause --
4545 -----------------------------
4547 function Has_Limited_With_Clause
4548 (C_Unit
: Entity_Id
;
4549 Pack
: Entity_Id
) return Boolean
4556 while Present
(Par
) loop
4557 if Ekind
(Par
) /= E_Package
then
4561 -- Retrieve the Compilation_Unit node for Par and determine if
4562 -- its context clauses contain a limited with for Pack.
4564 Par_Unit
:= Parent
(Parent
(Parent
(Par
)));
4566 if Nkind
(Par_Unit
) = N_Package_Declaration
then
4567 Par_Unit
:= Parent
(Par_Unit
);
4570 if Has_With_Clause
(Par_Unit
, Pack
, True) then
4574 -- If there are more ancestors, climb up the tree, otherwise we
4577 if Is_Child_Unit
(Par
) then
4585 end Has_Limited_With_Clause
;
4587 ----------------------------------
4588 -- Is_Visible_Through_Renamings --
4589 ----------------------------------
4591 function Is_Visible_Through_Renamings
(P
: Entity_Id
) return Boolean is
4592 Kind
: constant Node_Kind
:=
4593 Nkind
(Unit
(Cunit
(Current_Sem_Unit
)));
4599 -- Example of the error detected by this subprogram:
4607 -- package Ren_P renames P;
4613 -- limited with P; -- ERROR
4614 -- package R.C is ...
4616 Aux_Unit
:= Cunit
(Current_Sem_Unit
);
4619 Item
:= First
(Context_Items
(Aux_Unit
));
4620 while Present
(Item
) loop
4621 if Nkind
(Item
) = N_With_Clause
4622 and then not Limited_Present
(Item
)
4623 and then Nkind
(Unit
(Library_Unit
(Item
))) =
4624 N_Package_Declaration
4627 First
(Visible_Declarations
4628 (Specification
(Unit
(Library_Unit
(Item
)))));
4629 while Present
(Decl
) loop
4630 if Nkind
(Decl
) = N_Package_Renaming_Declaration
4631 and then Entity
(Name
(Decl
)) = P
4633 -- Generate the error message only if the current unit
4634 -- is a package declaration; in case of subprogram
4635 -- bodies and package bodies we just return True to
4636 -- indicate that the limited view must not be
4639 if Kind
= N_Package_Declaration
then
4641 ("simultaneous visibility of the limited and " &
4642 "unlimited views not allowed", N
);
4643 Error_Msg_Sloc
:= Sloc
(Item
);
4645 ("\\ unlimited view of & visible through the " &
4646 "context clause #", N
, P
);
4647 Error_Msg_Sloc
:= Sloc
(Decl
);
4648 Error_Msg_NE
("\\ and the renaming #", N
, P
);
4661 -- If it is a body not acting as spec, follow pointer to the
4662 -- corresponding spec, otherwise follow pointer to parent spec.
4664 if Present
(Library_Unit
(Aux_Unit
))
4665 and then Nkind_In
(Unit
(Aux_Unit
),
4666 N_Package_Body
, N_Subprogram_Body
)
4668 if Aux_Unit
= Library_Unit
(Aux_Unit
) then
4670 -- Aux_Unit is a body that acts as a spec. Clause has
4671 -- already been flagged as illegal.
4676 Aux_Unit
:= Library_Unit
(Aux_Unit
);
4680 Aux_Unit
:= Parent_Spec
(Unit
(Aux_Unit
));
4683 exit when No
(Aux_Unit
);
4687 end Is_Visible_Through_Renamings
;
4689 -- Start of processing for Install_Limited_Withed_Unit
4692 pragma Assert
(not Limited_View_Installed
(N
));
4694 -- In case of limited with_clause on subprograms, generics, instances,
4695 -- or renamings, the corresponding error was previously posted and we
4696 -- have nothing to do here. If the file is missing altogether, it has
4697 -- no source location.
4699 if Nkind
(P_Unit
) /= N_Package_Declaration
4700 or else Sloc
(P_Unit
) = No_Location
4705 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
4707 -- Handle child packages
4709 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
4710 Is_Child_Package
:= True;
4711 P
:= Defining_Identifier
(P
);
4714 -- Do not install the limited-view if the context of the unit is already
4715 -- available through a regular with clause.
4717 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4718 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4723 -- Do not install the limited-view if the full-view is already visible
4724 -- through renaming declarations.
4726 if Is_Visible_Through_Renamings
(P
) then
4730 -- Do not install the limited view if this is the unit being analyzed.
4731 -- This unusual case will happen when a unit has a limited_with clause
4732 -- on one of its children. The compilation of the child forces the load
4733 -- of the parent which tries to install the limited view of the child
4734 -- again. Installing the limited view must also be disabled when
4735 -- compiling the body of the child unit.
4737 if P
= Cunit_Entity
(Current_Sem_Unit
)
4739 (Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4740 and then P
= Main_Unit_Entity
)
4745 -- This scenario is similar to the one above, the difference is that the
4746 -- compilation of sibling Par.Sib forces the load of parent Par which
4747 -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
4748 -- has a with clause for Lim_Pack [2] in its body, and thus needs the
4749 -- non-limited views of all entities from Lim_Pack.
4751 -- limited with Lim_Pack; -- [1]
4752 -- package Par is ... package Lim_Pack is ...
4754 -- with Lim_Pack; -- [2]
4755 -- package Par.Sib is ... package body Par.Sib is ...
4757 -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
4758 -- Sem_Unit is the body of Par.Sib.
4760 if Ekind
(P
) = E_Package
4761 and then Ekind
(Main_Unit_Entity
) = E_Package
4762 and then Is_Child_Unit
(Main_Unit_Entity
)
4764 -- The body has a regular with clause
4766 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
4767 and then Has_With_Clause
(Cunit
(Current_Sem_Unit
), P
)
4769 -- One of the ancestors has a limited with clause
4771 and then Nkind
(Parent
(Parent
(Main_Unit_Entity
))) =
4772 N_Package_Specification
4773 and then Has_Limited_With_Clause
(Scope
(Main_Unit_Entity
), P
)
4778 -- A common use of the limited-with is to have a limited-with in the
4779 -- package spec, and a normal with in its package body. For example:
4781 -- limited with X; -- [1]
4785 -- package body A is ...
4787 -- The compilation of A's body installs the context clauses found at [2]
4788 -- and then the context clauses of its specification (found at [1]). As
4789 -- a consequence, at [1] the specification of X has been analyzed and it
4790 -- is immediately visible. According to the semantics of limited-with
4791 -- context clauses we don't install the limited view because the full
4792 -- view of X supersedes its limited view.
4794 if Analyzed
(P_Unit
)
4796 (Is_Immediately_Visible
(P
)
4797 or else (Is_Child_Package
and then Is_Visible_Child_Unit
(P
)))
4800 -- The presence of both the limited and the analyzed nonlimited view
4801 -- may also be an error, such as an illegal context for a limited
4802 -- with_clause. In that case, do not process the context item at all.
4804 if Error_Posted
(N
) then
4808 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Body
then
4812 Item
:= First
(Context_Items
(Cunit
(Current_Sem_Unit
)));
4813 while Present
(Item
) loop
4814 if Nkind
(Item
) = N_With_Clause
4815 and then Comes_From_Source
(Item
)
4816 and then Entity
(Name
(Item
)) = P
4825 -- If this is a child body, assume that the nonlimited with_clause
4826 -- appears in an ancestor. Could be refined ???
4830 (Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)))))
4837 -- If in package declaration, nonlimited view brought in from
4838 -- parent unit or some error condition.
4844 if Debug_Flag_I
then
4845 Write_Str
("install limited view of ");
4846 Write_Name
(Chars
(P
));
4850 -- If the unit has not been analyzed and the limited view has not been
4851 -- already installed then we install it.
4853 if not Analyzed
(P_Unit
) then
4854 if not In_Chain
(P
) then
4856 -- Minimum decoration
4858 Set_Ekind
(P
, E_Package
);
4859 Set_Etype
(P
, Standard_Void_Type
);
4860 Set_Scope
(P
, Standard_Standard
);
4862 if Is_Child_Package
then
4863 Set_Is_Child_Unit
(P
);
4864 Set_Is_Visible_Child_Unit
(P
);
4865 Set_Scope
(P
, Defining_Entity
(Unit
(Parent_Spec
(P_Unit
))));
4868 -- Place entity on visibility structure
4870 Set_Homonym
(P
, Current_Entity
(P
));
4871 Set_Current_Entity
(P
);
4873 if Debug_Flag_I
then
4874 Write_Str
(" (homonym) chain ");
4875 Write_Name
(Chars
(P
));
4879 -- Install the incomplete view. The first element of the limited
4880 -- view is a header (an E_Package entity) used to reference the
4881 -- first shadow entity in the private part of the package.
4883 Lim_Header
:= Limited_View
(P
);
4884 Lim_Typ
:= First_Entity
(Lim_Header
);
4886 while Present
(Lim_Typ
)
4887 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4889 Set_Homonym
(Lim_Typ
, Current_Entity
(Lim_Typ
));
4890 Set_Current_Entity
(Lim_Typ
);
4892 if Debug_Flag_I
then
4893 Write_Str
(" (homonym) chain ");
4894 Write_Name
(Chars
(Lim_Typ
));
4898 Next_Entity
(Lim_Typ
);
4902 -- If the unit appears in a previous regular with_clause, the regular
4903 -- entities of the public part of the withed package must be replaced
4904 -- by the shadow ones.
4906 -- This code must be kept synchronized with the code that replaces the
4907 -- shadow entities by the real entities (see body of Remove_Limited
4908 -- With_Clause); otherwise the contents of the homonym chains are not
4912 -- Hide all the type entities of the public part of the package to
4913 -- avoid its usage. This is needed to cover all the subtype decla-
4914 -- rations because we do not remove them from the homonym chain.
4916 E
:= First_Entity
(P
);
4917 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
4919 Set_Was_Hidden
(E
, Is_Hidden
(E
));
4926 -- Replace the real entities by the shadow entities of the limited
4927 -- view. The first element of the limited view is a header that is
4928 -- used to reference the first shadow entity in the private part
4929 -- of the package. Successive elements are the limited views of the
4930 -- type (including regular incomplete types) declared in the package.
4932 Lim_Header
:= Limited_View
(P
);
4934 Lim_Typ
:= First_Entity
(Lim_Header
);
4935 while Present
(Lim_Typ
)
4936 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
4938 pragma Assert
(not In_Chain
(Lim_Typ
));
4940 -- Do not unchain nested packages and child units
4942 if Ekind
(Lim_Typ
) /= E_Package
4943 and then not Is_Child_Unit
(Lim_Typ
)
4949 Prev
:= Current_Entity
(Lim_Typ
);
4952 -- Replace E in the homonyms list, so that the limited view
4953 -- becomes available.
4955 if E
= Non_Limited_View
(Lim_Typ
) then
4956 Set_Homonym
(Lim_Typ
, Homonym
(Prev
));
4957 Set_Current_Entity
(Lim_Typ
);
4961 E
:= Homonym
(Prev
);
4963 -- E may have been removed when installing a previous
4964 -- limited_with_clause.
4968 exit when E
= Non_Limited_View
(Lim_Typ
);
4970 Prev
:= Homonym
(Prev
);
4974 Set_Homonym
(Lim_Typ
, Homonym
(Homonym
(Prev
)));
4975 Set_Homonym
(Prev
, Lim_Typ
);
4980 if Debug_Flag_I
then
4981 Write_Str
(" (homonym) chain ");
4982 Write_Name
(Chars
(Lim_Typ
));
4987 Next_Entity
(Lim_Typ
);
4991 -- The package must be visible while the limited-with clause is active
4992 -- because references to the type P.T must resolve in the usual way.
4993 -- In addition, we remember that the limited-view has been installed to
4994 -- uninstall it at the point of context removal.
4996 Set_Is_Immediately_Visible
(P
);
4997 Set_Limited_View_Installed
(N
);
4999 -- If unit has not been analyzed in some previous context, check
5000 -- (imperfectly ???) whether it might need a body.
5002 if not Analyzed
(P_Unit
) then
5003 Check_Body_Required
;
5006 -- If the package in the limited_with clause is a child unit, the clause
5007 -- is unanalyzed and appears as a selected component. Recast it as an
5008 -- expanded name so that the entity can be properly set. Use entity of
5009 -- parent, if available, for higher ancestors in the name.
5011 if Nkind
(Name
(N
)) = N_Selected_Component
then
5019 while Nkind
(Nam
) = N_Selected_Component
5020 and then Present
(Ent
)
5022 Change_Selected_Component_To_Expanded_Name
(Nam
);
5024 -- Set entity of parent identifiers if the unit is a child
5025 -- unit. This ensures that the tree is properly formed from
5026 -- semantic point of view (e.g. for ASIS queries). The unit
5027 -- entities are not fully analyzed, so we need to follow unit
5028 -- links in the tree.
5030 Set_Entity
(Nam
, Ent
);
5032 Nam
:= Prefix
(Nam
);
5035 (Unit
(Parent_Spec
(Unit_Declaration_Node
(Ent
))));
5037 -- Set entity of last ancestor
5039 if Nkind
(Nam
) = N_Identifier
then
5040 Set_Entity
(Nam
, Ent
);
5046 Set_Entity
(Name
(N
), P
);
5047 Set_From_With_Type
(P
);
5048 end Install_Limited_Withed_Unit
;
5050 -------------------------
5051 -- Install_Withed_Unit --
5052 -------------------------
5054 procedure Install_Withed_Unit
5055 (With_Clause
: Node_Id
;
5056 Private_With_OK
: Boolean := False)
5058 Uname
: constant Entity_Id
:= Entity
(Name
(With_Clause
));
5059 P
: constant Entity_Id
:= Scope
(Uname
);
5062 -- Ada 2005 (AI-262): Do not install the private withed unit if we are
5063 -- compiling a package declaration and the Private_With_OK flag was not
5064 -- set by the caller. These declarations will be installed later (before
5065 -- analyzing the private part of the package).
5067 if Private_Present
(With_Clause
)
5068 and then Nkind
(Unit
(Parent
(With_Clause
))) = N_Package_Declaration
5069 and then not (Private_With_OK
)
5074 if Debug_Flag_I
then
5075 if Private_Present
(With_Clause
) then
5076 Write_Str
("install private withed unit ");
5078 Write_Str
("install withed unit ");
5081 Write_Name
(Chars
(Uname
));
5085 -- We do not apply the restrictions to an internal unit unless we are
5086 -- compiling the internal unit as a main unit. This check is also
5087 -- skipped for dummy units (for missing packages).
5089 if Sloc
(Uname
) /= No_Location
5090 and then (not Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
5091 or else Current_Sem_Unit
= Main_Unit
)
5093 Check_Restricted_Unit
5094 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
5097 if P
/= Standard_Standard
then
5099 -- If the unit is not analyzed after analysis of the with clause and
5100 -- it is an instantiation then it awaits a body and is the main unit.
5101 -- Its appearance in the context of some other unit indicates a
5102 -- circular dependency (DEC suite perversity).
5104 if not Analyzed
(Uname
)
5105 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
5108 ("instantiation depends on itself", Name
(With_Clause
));
5110 elsif not Is_Visible_Child_Unit
(Uname
) then
5112 -- Abandon processing in case of previous errors
5114 if No
(Scope
(Uname
)) then
5115 pragma Assert
(Serious_Errors_Detected
/= 0);
5119 Set_Is_Visible_Child_Unit
(Uname
);
5121 -- If the child unit appears in the context of its parent, it is
5122 -- immediately visible.
5124 if In_Open_Scopes
(Scope
(Uname
)) then
5125 Set_Is_Immediately_Visible
(Uname
);
5128 if Is_Generic_Instance
(Uname
)
5129 and then Ekind
(Uname
) in Subprogram_Kind
5131 -- Set flag as well on the visible entity that denotes the
5132 -- instance, which renames the current one.
5134 Set_Is_Visible_Child_Unit
5136 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
5139 -- The parent unit may have been installed already, and may have
5140 -- appeared in a use clause.
5142 if In_Use
(Scope
(Uname
)) then
5143 Set_Is_Potentially_Use_Visible
(Uname
);
5146 Set_Context_Installed
(With_Clause
);
5149 elsif not Is_Immediately_Visible
(Uname
) then
5150 if not Private_Present
(With_Clause
)
5151 or else Private_With_OK
5153 Set_Is_Immediately_Visible
(Uname
);
5156 Set_Context_Installed
(With_Clause
);
5159 -- A with-clause overrides a with-type clause: there are no restric-
5160 -- tions on the use of package entities.
5162 if Ekind
(Uname
) = E_Package
then
5163 Set_From_With_Type
(Uname
, False);
5166 -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
5167 -- unit if there is a visible homograph for it declared in the same
5168 -- declarative region. This pathological case can only arise when an
5169 -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
5170 -- G1 has a generic child also named G2, and the context includes with_
5171 -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
5172 -- of I1.G2 visible as well. If the child unit is named Standard, do
5173 -- not apply the check to the Standard package itself.
5175 if Is_Child_Unit
(Uname
)
5176 and then Is_Visible_Child_Unit
(Uname
)
5177 and then Ada_Version
>= Ada_2005
5180 Decl1
: constant Node_Id
:= Unit_Declaration_Node
(P
);
5186 U2
:= Homonym
(Uname
);
5188 and then U2
/= Standard_Standard
5191 Decl2
:= Unit_Declaration_Node
(P2
);
5193 if Is_Child_Unit
(U2
)
5194 and then Is_Visible_Child_Unit
(U2
)
5196 if Is_Generic_Instance
(P
)
5197 and then Nkind
(Decl1
) = N_Package_Declaration
5198 and then Generic_Parent
(Specification
(Decl1
)) = P2
5200 Error_Msg_N
("illegal with_clause", With_Clause
);
5202 ("\child unit has visible homograph" &
5203 " (RM 8.3(26), 10.1.1(19))",
5207 elsif Is_Generic_Instance
(P2
)
5208 and then Nkind
(Decl2
) = N_Package_Declaration
5209 and then Generic_Parent
(Specification
(Decl2
)) = P
5211 -- With_clause for child unit of instance appears before
5212 -- in the context. We want to place the error message on
5213 -- it, not on the generic child unit itself.
5216 Prev_Clause
: Node_Id
;
5219 Prev_Clause
:= First
(List_Containing
(With_Clause
));
5220 while Entity
(Name
(Prev_Clause
)) /= U2
loop
5224 pragma Assert
(Present
(Prev_Clause
));
5225 Error_Msg_N
("illegal with_clause", Prev_Clause
);
5227 ("\child unit has visible homograph" &
5228 " (RM 8.3(26), 10.1.1(19))",
5239 end Install_Withed_Unit
;
5245 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
5246 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
5249 return (K
in N_Generic_Declaration
or else
5250 K
in N_Generic_Instantiation
or else
5251 K
in N_Generic_Renaming_Declaration
or else
5252 K
= N_Package_Declaration
or else
5253 K
= N_Package_Renaming_Declaration
or else
5254 K
= N_Subprogram_Declaration
or else
5255 K
= N_Subprogram_Renaming_Declaration
)
5256 and then Present
(Parent_Spec
(Lib_Unit
));
5259 ------------------------------------
5260 -- Is_Legal_Shadow_Entity_In_Body --
5261 ------------------------------------
5263 function Is_Legal_Shadow_Entity_In_Body
(T
: Entity_Id
) return Boolean is
5264 C_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
5266 return Nkind
(Unit
(C_Unit
)) = N_Package_Body
5269 (C_Unit
, Cunit_Entity
(Get_Source_Unit
(Non_Limited_View
(T
))));
5270 end Is_Legal_Shadow_Entity_In_Body
;
5272 -----------------------
5273 -- Load_Needed_Body --
5274 -----------------------
5276 -- N is a generic unit named in a with clause, or else it is a unit that
5277 -- contains a generic unit or an inlined function. In order to perform an
5278 -- instantiation, the body of the unit must be present. If the unit itself
5279 -- is generic, we assume that an instantiation follows, and load & analyze
5280 -- the body unconditionally. This forces analysis of the spec as well.
5282 -- If the unit is not generic, but contains a generic unit, it is loaded on
5283 -- demand, at the point of instantiation (see ch12).
5285 procedure Load_Needed_Body
5288 Do_Analyze
: Boolean := True)
5290 Body_Name
: Unit_Name_Type
;
5291 Unum
: Unit_Number_Type
;
5293 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
5294 -- The loading and analysis is done with style checks off
5297 if not GNAT_Mode
then
5298 Style_Check
:= False;
5301 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
5304 (Load_Name
=> Body_Name
,
5310 if Unum
= No_Unit
then
5314 Compiler_State
:= Analyzing
; -- reset after load
5316 if not Fatal_Error
(Unum
) or else Try_Semantics
then
5317 if Debug_Flag_L
then
5318 Write_Str
("*** Loaded generic body");
5323 Semantics
(Cunit
(Unum
));
5330 Style_Check
:= Save_Style_Check
;
5331 end Load_Needed_Body
;
5333 -------------------------
5334 -- Build_Limited_Views --
5335 -------------------------
5337 procedure Build_Limited_Views
(N
: Node_Id
) is
5338 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Library_Unit
(N
));
5339 P
: constant Entity_Id
:= Cunit_Entity
(Unum
);
5341 Spec
: Node_Id
; -- To denote a package specification
5342 Lim_Typ
: Entity_Id
; -- To denote shadow entities
5343 Comp_Typ
: Entity_Id
; -- To denote real entities
5345 Lim_Header
: Entity_Id
; -- Package entity
5346 Last_Lim_E
: Entity_Id
:= Empty
; -- Last limited entity built
5347 Last_Pub_Lim_E
: Entity_Id
; -- To set the first private entity
5349 procedure Decorate_Incomplete_Type
(E
: Entity_Id
; Scop
: Entity_Id
);
5350 -- Add attributes of an incomplete type to a shadow entity. The same
5351 -- attributes are placed on the real entity, so that gigi receives
5352 -- a consistent view.
5354 procedure Decorate_Package_Specification
(P
: Entity_Id
);
5355 -- Add attributes of a package entity to the entity in a package
5358 procedure Decorate_Tagged_Type
5362 Mark
: Boolean := False);
5363 -- Set basic attributes of tagged type T, including its class-wide type.
5364 -- The parameters Loc, Scope are used to decorate the class-wide type.
5365 -- Use flag Mark to label the class-wide type as Materialize_Entity.
5367 procedure Build_Chain
(Scope
: Entity_Id
; First_Decl
: Node_Id
);
5368 -- Construct list of shadow entities and attach it to entity of
5369 -- package that is mentioned in a limited_with clause.
5371 function New_Internal_Shadow_Entity
5372 (Kind
: Entity_Kind
;
5373 Sloc_Value
: Source_Ptr
;
5374 Id_Char
: Character) return Entity_Id
;
5375 -- Build a new internal entity and append it to the list of shadow
5376 -- entities available through the limited-header
5382 procedure Build_Chain
(Scope
: Entity_Id
; First_Decl
: Node_Id
) is
5383 Analyzed_Unit
: constant Boolean := Analyzed
(Cunit
(Unum
));
5384 Is_Tagged
: Boolean;
5389 while Present
(Decl
) loop
5391 -- For each library_package_declaration in the environment, there
5392 -- is an implicit declaration of a *limited view* of that library
5393 -- package. The limited view of a package contains:
5395 -- * For each nested package_declaration, a declaration of the
5396 -- limited view of that package, with the same defining-
5397 -- program-unit name.
5399 -- * For each type_declaration in the visible part, an incomplete
5400 -- type-declaration with the same defining_identifier, whose
5401 -- completion is the type_declaration. If the type_declaration
5402 -- is tagged, then the incomplete_type_declaration is tagged
5405 -- The partial view is tagged if the declaration has the
5406 -- explicit keyword, or else if it is a type extension, both
5407 -- of which can be ascertained syntactically.
5409 if Nkind
(Decl
) = N_Full_Type_Declaration
then
5411 (Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
5412 and then Tagged_Present
(Type_Definition
(Decl
)))
5414 (Nkind
(Type_Definition
(Decl
)) = N_Derived_Type_Definition
5417 (Record_Extension_Part
(Type_Definition
(Decl
))));
5419 Comp_Typ
:= Defining_Identifier
(Decl
);
5421 if not Analyzed_Unit
then
5423 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
, True);
5425 Decorate_Incomplete_Type
(Comp_Typ
, Scope
);
5429 -- Create shadow entity for type
5432 New_Internal_Shadow_Entity
5433 (Kind
=> Ekind
(Comp_Typ
),
5434 Sloc_Value
=> Sloc
(Comp_Typ
),
5437 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
5438 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
5439 Set_From_With_Type
(Lim_Typ
);
5442 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
5444 Decorate_Incomplete_Type
(Lim_Typ
, Scope
);
5447 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
5448 Set_Private_Dependents
(Lim_Typ
, New_Elmt_List
);
5450 elsif Nkind_In
(Decl
, N_Private_Type_Declaration
,
5451 N_Incomplete_Type_Declaration
,
5452 N_Task_Type_Declaration
,
5453 N_Protected_Type_Declaration
)
5455 Comp_Typ
:= Defining_Identifier
(Decl
);
5458 Nkind_In
(Decl
, N_Private_Type_Declaration
,
5459 N_Incomplete_Type_Declaration
)
5460 and then Tagged_Present
(Decl
);
5462 if not Analyzed_Unit
then
5464 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
, True);
5466 Decorate_Incomplete_Type
(Comp_Typ
, Scope
);
5471 New_Internal_Shadow_Entity
5472 (Kind
=> Ekind
(Comp_Typ
),
5473 Sloc_Value
=> Sloc
(Comp_Typ
),
5476 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
5477 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
5478 Set_From_With_Type
(Lim_Typ
);
5481 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
5483 Decorate_Incomplete_Type
(Lim_Typ
, Scope
);
5486 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
5488 -- Initialize Private_Depedents, so the field has the proper
5489 -- type, even though the list will remain empty.
5491 Set_Private_Dependents
(Lim_Typ
, New_Elmt_List
);
5493 elsif Nkind
(Decl
) = N_Private_Extension_Declaration
then
5494 Comp_Typ
:= Defining_Identifier
(Decl
);
5496 if not Analyzed_Unit
then
5497 Decorate_Tagged_Type
(Sloc
(Decl
), Comp_Typ
, Scope
, True);
5500 -- Create shadow entity for type
5503 New_Internal_Shadow_Entity
5504 (Kind
=> Ekind
(Comp_Typ
),
5505 Sloc_Value
=> Sloc
(Comp_Typ
),
5508 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
5509 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
5510 Set_From_With_Type
(Lim_Typ
);
5512 Decorate_Tagged_Type
(Sloc
(Decl
), Lim_Typ
, Scope
);
5513 Set_Non_Limited_View
(Lim_Typ
, Comp_Typ
);
5515 elsif Nkind
(Decl
) = N_Package_Declaration
then
5520 Spec
: constant Node_Id
:= Specification
(Decl
);
5523 Comp_Typ
:= Defining_Unit_Name
(Spec
);
5525 if not Analyzed
(Cunit
(Unum
)) then
5526 Decorate_Package_Specification
(Comp_Typ
);
5527 Set_Scope
(Comp_Typ
, Scope
);
5531 New_Internal_Shadow_Entity
5532 (Kind
=> Ekind
(Comp_Typ
),
5533 Sloc_Value
=> Sloc
(Comp_Typ
),
5536 Decorate_Package_Specification
(Lim_Typ
);
5537 Set_Scope
(Lim_Typ
, Scope
);
5539 Set_Chars
(Lim_Typ
, Chars
(Comp_Typ
));
5540 Set_Parent
(Lim_Typ
, Parent
(Comp_Typ
));
5541 Set_From_With_Type
(Lim_Typ
);
5543 -- Note: The non_limited_view attribute is not used
5544 -- for local packages.
5548 First_Decl
=> First
(Visible_Declarations
(Spec
)));
5556 ------------------------------
5557 -- Decorate_Incomplete_Type --
5558 ------------------------------
5560 procedure Decorate_Incomplete_Type
(E
: Entity_Id
; Scop
: Entity_Id
) is
5562 Set_Ekind
(E
, E_Incomplete_Type
);
5563 Set_Scope
(E
, Scop
);
5565 Set_Is_First_Subtype
(E
, True);
5566 Set_Stored_Constraint
(E
, No_Elist
);
5567 Set_Full_View
(E
, Empty
);
5568 Init_Size_Align
(E
);
5569 end Decorate_Incomplete_Type
;
5571 --------------------------
5572 -- Decorate_Tagged_Type --
5573 --------------------------
5575 procedure Decorate_Tagged_Type
5579 Mark
: Boolean := False)
5584 Decorate_Incomplete_Type
(T
, Scop
);
5585 Set_Is_Tagged_Type
(T
);
5587 -- Build corresponding class_wide type, if not previously done
5589 -- Note: The class-wide entity is shared by the limited-view
5590 -- and the full-view.
5592 if No
(Class_Wide_Type
(T
)) then
5593 CW
:= New_External_Entity
(E_Void
, Scope
(T
), Loc
, T
, 'C', 0, 'T');
5595 -- Set parent to be the same as the parent of the tagged type.
5596 -- We need a parent field set, and it is supposed to point to
5597 -- the declaration of the type. The tagged type declaration
5598 -- essentially declares two separate types, the tagged type
5599 -- itself and the corresponding class-wide type, so it is
5600 -- reasonable for the parent fields to point to the declaration
5603 Set_Parent
(CW
, Parent
(T
));
5605 -- Set remaining fields of classwide type
5607 Set_Ekind
(CW
, E_Class_Wide_Type
);
5609 Set_Scope
(CW
, Scop
);
5610 Set_Is_Tagged_Type
(CW
);
5611 Set_Is_First_Subtype
(CW
, True);
5612 Init_Size_Align
(CW
);
5613 Set_Has_Unknown_Discriminants
(CW
, True);
5614 Set_Class_Wide_Type
(CW
, CW
);
5615 Set_Equivalent_Type
(CW
, Empty
);
5616 Set_From_With_Type
(CW
, From_With_Type
(T
));
5617 Set_Materialize_Entity
(CW
, Mark
);
5619 -- Link type to its class-wide type
5621 Set_Class_Wide_Type
(T
, CW
);
5623 end Decorate_Tagged_Type
;
5625 ------------------------------------
5626 -- Decorate_Package_Specification --
5627 ------------------------------------
5629 procedure Decorate_Package_Specification
(P
: Entity_Id
) is
5631 -- Place only the most basic attributes
5633 Set_Ekind
(P
, E_Package
);
5634 Set_Etype
(P
, Standard_Void_Type
);
5635 end Decorate_Package_Specification
;
5637 --------------------------------
5638 -- New_Internal_Shadow_Entity --
5639 --------------------------------
5641 function New_Internal_Shadow_Entity
5642 (Kind
: Entity_Kind
;
5643 Sloc_Value
: Source_Ptr
;
5644 Id_Char
: Character) return Entity_Id
5646 E
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
5649 Set_Ekind
(E
, Kind
);
5650 Set_Is_Internal
(E
, True);
5652 if Kind
in Type_Kind
then
5653 Init_Size_Align
(E
);
5656 Append_Entity
(E
, Lim_Header
);
5659 end New_Internal_Shadow_Entity
;
5661 -- Start of processing for Build_Limited_Views
5664 pragma Assert
(Limited_Present
(N
));
5666 -- A library_item mentioned in a limited_with_clause is a package
5667 -- declaration, not a subprogram declaration, generic declaration,
5668 -- generic instantiation, or package renaming declaration.
5670 case Nkind
(Unit
(Library_Unit
(N
))) is
5671 when N_Package_Declaration
=>
5674 when N_Subprogram_Declaration
=>
5675 Error_Msg_N
("subprograms not allowed in "
5676 & "limited with_clauses", N
);
5679 when N_Generic_Package_Declaration |
5680 N_Generic_Subprogram_Declaration
=>
5681 Error_Msg_N
("generics not allowed in "
5682 & "limited with_clauses", N
);
5685 when N_Generic_Instantiation
=>
5686 Error_Msg_N
("generic instantiations not allowed in "
5687 & "limited with_clauses", N
);
5690 when N_Generic_Renaming_Declaration
=>
5691 Error_Msg_N
("generic renamings not allowed in "
5692 & "limited with_clauses", N
);
5695 when N_Subprogram_Renaming_Declaration
=>
5696 Error_Msg_N
("renamed subprograms not allowed in "
5697 & "limited with_clauses", N
);
5700 when N_Package_Renaming_Declaration
=>
5701 Error_Msg_N
("renamed packages not allowed in "
5702 & "limited with_clauses", N
);
5706 raise Program_Error
;
5709 -- Check if the chain is already built
5711 Spec
:= Specification
(Unit
(Library_Unit
(N
)));
5713 if Limited_View_Installed
(Spec
) then
5717 Set_Ekind
(P
, E_Package
);
5719 -- Build the header of the limited_view
5721 Lim_Header
:= Make_Temporary
(Sloc
(N
), 'Z');
5722 Set_Ekind
(Lim_Header
, E_Package
);
5723 Set_Is_Internal
(Lim_Header
);
5724 Set_Limited_View
(P
, Lim_Header
);
5726 -- Create the auxiliary chain. All the shadow entities are appended to
5727 -- the list of entities of the limited-view header
5731 First_Decl
=> First
(Visible_Declarations
(Spec
)));
5733 -- Save the last built shadow entity. It is needed later to set the
5734 -- reference to the first shadow entity in the private part
5736 Last_Pub_Lim_E
:= Last_Lim_E
;
5738 -- Ada 2005 (AI-262): Add the limited view of the private declarations
5739 -- Required to give support to limited-private-with clauses
5741 Build_Chain
(Scope
=> P
,
5742 First_Decl
=> First
(Private_Declarations
(Spec
)));
5744 if Last_Pub_Lim_E
/= Empty
then
5745 Set_First_Private_Entity
5746 (Lim_Header
, Next_Entity
(Last_Pub_Lim_E
));
5748 Set_First_Private_Entity
5749 (Lim_Header
, First_Entity
(P
));
5752 Set_Limited_View_Installed
(Spec
);
5753 end Build_Limited_Views
;
5755 -------------------------------
5756 -- Check_Body_Needed_For_SAL --
5757 -------------------------------
5759 procedure Check_Body_Needed_For_SAL
(Unit_Name
: Entity_Id
) is
5761 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean;
5762 -- Determine whether use of entity E might require the presence of its
5763 -- body. For a package this requires a recursive traversal of all nested
5766 ---------------------------
5767 -- Entity_Needed_For_SAL --
5768 ---------------------------
5770 function Entity_Needs_Body
(E
: Entity_Id
) return Boolean is
5774 if Is_Subprogram
(E
)
5775 and then Has_Pragma_Inline
(E
)
5779 elsif Ekind_In
(E
, E_Generic_Function
, E_Generic_Procedure
) then
5782 elsif Ekind
(E
) = E_Generic_Package
5784 Nkind
(Unit_Declaration_Node
(E
)) = N_Generic_Package_Declaration
5785 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
5789 elsif Ekind
(E
) = E_Package
5790 and then Nkind
(Unit_Declaration_Node
(E
)) = N_Package_Declaration
5791 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(E
)))
5793 Ent
:= First_Entity
(E
);
5794 while Present
(Ent
) loop
5795 if Entity_Needs_Body
(Ent
) then
5807 end Entity_Needs_Body
;
5809 -- Start of processing for Check_Body_Needed_For_SAL
5812 if Ekind
(Unit_Name
) = E_Generic_Package
5813 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
5814 N_Generic_Package_Declaration
5816 Present
(Corresponding_Body
(Unit_Declaration_Node
(Unit_Name
)))
5818 Set_Body_Needed_For_SAL
(Unit_Name
);
5820 elsif Ekind_In
(Unit_Name
, E_Generic_Procedure
, E_Generic_Function
) then
5821 Set_Body_Needed_For_SAL
(Unit_Name
);
5823 elsif Is_Subprogram
(Unit_Name
)
5824 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) =
5825 N_Subprogram_Declaration
5826 and then Has_Pragma_Inline
(Unit_Name
)
5828 Set_Body_Needed_For_SAL
(Unit_Name
);
5830 elsif Ekind
(Unit_Name
) = E_Subprogram_Body
then
5831 Check_Body_Needed_For_SAL
5832 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
5834 elsif Ekind
(Unit_Name
) = E_Package
5835 and then Entity_Needs_Body
(Unit_Name
)
5837 Set_Body_Needed_For_SAL
(Unit_Name
);
5839 elsif Ekind
(Unit_Name
) = E_Package_Body
5840 and then Nkind
(Unit_Declaration_Node
(Unit_Name
)) = N_Package_Body
5842 Check_Body_Needed_For_SAL
5843 (Corresponding_Spec
(Unit_Declaration_Node
(Unit_Name
)));
5845 end Check_Body_Needed_For_SAL
;
5847 --------------------
5848 -- Remove_Context --
5849 --------------------
5851 procedure Remove_Context
(N
: Node_Id
) is
5852 Lib_Unit
: constant Node_Id
:= Unit
(N
);
5855 -- If this is a child unit, first remove the parent units
5857 if Is_Child_Spec
(Lib_Unit
) then
5858 Remove_Parents
(Lib_Unit
);
5861 Remove_Context_Clauses
(N
);
5864 ----------------------------
5865 -- Remove_Context_Clauses --
5866 ----------------------------
5868 procedure Remove_Context_Clauses
(N
: Node_Id
) is
5870 Unit_Name
: Entity_Id
;
5873 -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
5874 -- limited-views first and regular-views later (to maintain the
5877 -- First Phase: Remove limited_with context clauses
5879 Item
:= First
(Context_Items
(N
));
5880 while Present
(Item
) loop
5882 -- We are interested only in with clauses which got installed
5885 if Nkind
(Item
) = N_With_Clause
5886 and then Limited_Present
(Item
)
5887 and then Limited_View_Installed
(Item
)
5889 Remove_Limited_With_Clause
(Item
);
5895 -- Second Phase: Loop through context items and undo regular
5896 -- with_clauses and use_clauses.
5898 Item
:= First
(Context_Items
(N
));
5899 while Present
(Item
) loop
5901 -- We are interested only in with clauses which got installed on
5902 -- entry, as indicated by their Context_Installed flag set
5904 if Nkind
(Item
) = N_With_Clause
5905 and then Limited_Present
(Item
)
5906 and then Limited_View_Installed
(Item
)
5910 elsif Nkind
(Item
) = N_With_Clause
5911 and then Context_Installed
(Item
)
5913 -- Remove items from one with'ed unit
5915 Unit_Name
:= Entity
(Name
(Item
));
5916 Remove_Unit_From_Visibility
(Unit_Name
);
5917 Set_Context_Installed
(Item
, False);
5919 elsif Nkind
(Item
) = N_Use_Package_Clause
then
5920 End_Use_Package
(Item
);
5922 elsif Nkind
(Item
) = N_Use_Type_Clause
then
5923 End_Use_Type
(Item
);
5928 end Remove_Context_Clauses
;
5930 --------------------------------
5931 -- Remove_Limited_With_Clause --
5932 --------------------------------
5934 procedure Remove_Limited_With_Clause
(N
: Node_Id
) is
5935 P_Unit
: constant Entity_Id
:= Unit
(Library_Unit
(N
));
5938 Lim_Header
: Entity_Id
;
5939 Lim_Typ
: Entity_Id
;
5943 pragma Assert
(Limited_View_Installed
(N
));
5945 -- In case of limited with_clause on subprograms, generics, instances,
5946 -- or renamings, the corresponding error was previously posted and we
5947 -- have nothing to do here.
5949 if Nkind
(P_Unit
) /= N_Package_Declaration
then
5953 P
:= Defining_Unit_Name
(Specification
(P_Unit
));
5955 -- Handle child packages
5957 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
5958 P
:= Defining_Identifier
(P
);
5961 if Debug_Flag_I
then
5962 Write_Str
("remove limited view of ");
5963 Write_Name
(Chars
(P
));
5964 Write_Str
(" from visibility");
5968 -- Prepare the removal of the shadow entities from visibility. The first
5969 -- element of the limited view is a header (an E_Package entity) that is
5970 -- used to reference the first shadow entity in the private part of the
5973 Lim_Header
:= Limited_View
(P
);
5974 Lim_Typ
:= First_Entity
(Lim_Header
);
5976 -- Remove package and shadow entities from visibility if it has not
5979 if not Analyzed
(P_Unit
) then
5981 Set_Is_Immediately_Visible
(P
, False);
5983 while Present
(Lim_Typ
) loop
5985 Next_Entity
(Lim_Typ
);
5988 -- Otherwise this package has already appeared in the closure and its
5989 -- shadow entities must be replaced by its real entities. This code
5990 -- must be kept synchronized with the complementary code in Install
5991 -- Limited_Withed_Unit.
5994 -- Real entities that are type or subtype declarations were hidden
5995 -- from visibility at the point of installation of the limited-view.
5996 -- Now we recover the previous value of the hidden attribute.
5998 E
:= First_Entity
(P
);
5999 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
6001 Set_Is_Hidden
(E
, Was_Hidden
(E
));
6007 while Present
(Lim_Typ
)
6008 and then Lim_Typ
/= First_Private_Entity
(Lim_Header
)
6010 -- Nested packages and child units were not unchained
6012 if Ekind
(Lim_Typ
) /= E_Package
6013 and then not Is_Child_Unit
(Non_Limited_View
(Lim_Typ
))
6015 -- If the package has incomplete types, the limited view of the
6016 -- incomplete type is in fact never visible (AI05-129) but we
6017 -- have created a shadow entity E1 for it, that points to E2,
6018 -- a non-limited incomplete type. This in turn has a full view
6019 -- E3 that is the full declaration. There is a corresponding
6020 -- shadow entity E4. When reinstalling the non-limited view,
6021 -- E2 must become the current entity and E3 must be ignored.
6023 E
:= Non_Limited_View
(Lim_Typ
);
6025 if Present
(Current_Entity
(E
))
6026 and then Ekind
(Current_Entity
(E
)) = E_Incomplete_Type
6027 and then Full_View
(Current_Entity
(E
)) = E
6030 -- Lim_Typ is the limited view of a full type declaration
6031 -- that has a previous incomplete declaration, i.e. E3 from
6032 -- the previous description. Nothing to insert.
6037 pragma Assert
(not In_Chain
(E
));
6039 Prev
:= Current_Entity
(Lim_Typ
);
6041 if Prev
= Lim_Typ
then
6042 Set_Current_Entity
(E
);
6045 while Present
(Prev
)
6046 and then Homonym
(Prev
) /= Lim_Typ
6048 Prev
:= Homonym
(Prev
);
6051 if Present
(Prev
) then
6052 Set_Homonym
(Prev
, E
);
6056 -- Preserve structure of homonym chain
6058 Set_Homonym
(E
, Homonym
(Lim_Typ
));
6062 Next_Entity
(Lim_Typ
);
6066 -- Indicate that the limited view of the package is not installed
6068 Set_From_With_Type
(P
, False);
6069 Set_Limited_View_Installed
(N
, False);
6070 end Remove_Limited_With_Clause
;
6072 --------------------
6073 -- Remove_Parents --
6074 --------------------
6076 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
6079 P_Spec
: Node_Id
:= Empty
;
6081 Vis
: constant Boolean :=
6082 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
6085 if Is_Child_Spec
(Lib_Unit
) then
6086 P_Spec
:= Parent_Spec
(Lib_Unit
);
6088 elsif Nkind
(Lib_Unit
) = N_Package_Body
6089 and then Nkind
(Original_Node
(Lib_Unit
)) = N_Package_Instantiation
6091 P_Spec
:= Parent_Spec
(Original_Node
(Lib_Unit
));
6094 if Present
(P_Spec
) then
6096 P_Name
:= Get_Parent_Entity
(P
);
6097 Remove_Context_Clauses
(P_Spec
);
6098 End_Package_Scope
(P_Name
);
6099 Set_Is_Immediately_Visible
(P_Name
, Vis
);
6101 -- Remove from visibility the siblings as well, which are directly
6102 -- visible while the parent is in scope.
6104 E
:= First_Entity
(P_Name
);
6105 while Present
(E
) loop
6106 if Is_Child_Unit
(E
) then
6107 Set_Is_Immediately_Visible
(E
, False);
6113 Set_In_Package_Body
(P_Name
, False);
6115 -- This is the recursive call to remove the context of any higher
6116 -- level parent. This recursion ensures that all parents are removed
6117 -- in the reverse order of their installation.
6123 ---------------------------------
6124 -- Remove_Private_With_Clauses --
6125 ---------------------------------
6127 procedure Remove_Private_With_Clauses
(Comp_Unit
: Node_Id
) is
6130 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean;
6131 -- Check whether a given unit appears in a regular with_clause. Used to
6132 -- determine whether a private_with_clause, implicit or explicit, should
6135 ----------------------------
6136 -- In_Regular_With_Clause --
6137 ----------------------------
6139 function In_Regular_With_Clause
(E
: Entity_Id
) return Boolean
6144 Item
:= First
(Context_Items
(Comp_Unit
));
6145 while Present
(Item
) loop
6146 if Nkind
(Item
) = N_With_Clause
6147 and then Entity
(Name
(Item
)) = E
6148 and then not Private_Present
(Item
)
6156 end In_Regular_With_Clause
;
6158 -- Start of processing for Remove_Private_With_Clauses
6161 Item
:= First
(Context_Items
(Comp_Unit
));
6162 while Present
(Item
) loop
6163 if Nkind
(Item
) = N_With_Clause
6164 and then Private_Present
(Item
)
6166 -- If private_with_clause is redundant, remove it from context,
6167 -- as a small optimization to subsequent handling of private_with
6168 -- clauses in other nested packages.
6170 if In_Regular_With_Clause
(Entity
(Name
(Item
))) then
6172 Nxt
: constant Node_Id
:= Next
(Item
);
6178 elsif Limited_Present
(Item
) then
6179 if not Limited_View_Installed
(Item
) then
6180 Remove_Limited_With_Clause
(Item
);
6186 Remove_Unit_From_Visibility
(Entity
(Name
(Item
)));
6187 Set_Context_Installed
(Item
, False);
6195 end Remove_Private_With_Clauses
;
6197 ---------------------------------
6198 -- Remove_Unit_From_Visibility --
6199 ---------------------------------
6201 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
6202 P
: constant Entity_Id
:= Scope
(Unit_Name
);
6205 if Debug_Flag_I
then
6206 Write_Str
("remove unit ");
6207 Write_Name
(Chars
(Unit_Name
));
6208 Write_Str
(" from visibility");
6212 if P
/= Standard_Standard
then
6213 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
6216 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
6217 Set_Is_Immediately_Visible
(Unit_Name
, False);
6219 -- If the unit is a wrapper package, the subprogram instance is
6220 -- what must be removed from visibility.
6222 if Is_Wrapper_Package
(Unit_Name
) then
6223 Set_Is_Immediately_Visible
(Current_Entity
(Unit_Name
), False);
6225 end Remove_Unit_From_Visibility
;
6240 procedure Unchain
(E
: Entity_Id
) is
6244 Prev
:= Current_Entity
(E
);
6250 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
6253 while Present
(Prev
)
6254 and then Homonym
(Prev
) /= E
6256 Prev
:= Homonym
(Prev
);
6259 if Present
(Prev
) then
6260 Set_Homonym
(Prev
, Homonym
(E
));
6264 if Debug_Flag_I
then
6265 Write_Str
(" (homonym) unchain ");
6266 Write_Name
(Chars
(E
));