1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Exp_Util
; use Exp_Util
;
33 with Fname
; use Fname
;
34 with Fname
.UF
; use Fname
.UF
;
35 with Freeze
; use Freeze
;
36 with Impunit
; use Impunit
;
37 with Inline
; use Inline
;
39 with Lib
.Load
; use Lib
.Load
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
48 with Sem_Ch6
; use Sem_Ch6
;
49 with Sem_Ch7
; use Sem_Ch7
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Dist
; use Sem_Dist
;
52 with Sem_Prag
; use Sem_Prag
;
53 with Sem_Util
; use Sem_Util
;
54 with Sem_Warn
; use Sem_Warn
;
55 with Stand
; use Stand
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.CN
; use Sinfo
.CN
;
58 with Sinput
; use Sinput
;
59 with Snames
; use Snames
;
60 with Style
; use Style
;
61 with Tbuild
; use Tbuild
;
62 with Ttypes
; use Ttypes
;
63 with Uname
; use Uname
;
65 package body Sem_Ch10
is
67 -----------------------
68 -- Local Subprograms --
69 -----------------------
71 procedure Analyze_Context
(N
: Node_Id
);
72 -- Analyzes items in the context clause of compilation unit
74 procedure Check_With_Type_Clauses
(N
: Node_Id
);
75 -- If N is a body, verify that any with_type clauses on the spec, or
76 -- on the spec of any parent, have a matching with_clause.
78 procedure Check_Private_Child_Unit
(N
: Node_Id
);
79 -- If a with_clause mentions a private child unit, the compilation
80 -- unit must be a member of the same family, as described in 10.1.2 (8).
82 procedure Check_Stub_Level
(N
: Node_Id
);
83 -- Verify that a stub is declared immediately within a compilation unit,
84 -- and not in an inner frame.
86 procedure Expand_With_Clause
(Nam
: Node_Id
; N
: Node_Id
);
87 -- When a child unit appears in a context clause, the implicit withs on
88 -- parents are made explicit, and with clauses are inserted in the context
89 -- clause before the one for the child. If a parent in the with_clause
90 -- is a renaming, the implicit with_clause is on the renaming whose name
91 -- is mentioned in the with_clause, and not on the package it renames.
92 -- N is the compilation unit whose list of context items receives the
93 -- implicit with_clauses.
95 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
;
96 -- Get defining entity of parent unit of a child unit. In most cases this
97 -- is the defining entity of the unit, but for a child instance whose
98 -- parent needs a body for inlining, the instantiation node of the parent
99 -- has not yet been rewritten as a package declaration, and the entity has
100 -- to be retrieved from the Instance_Spec of the unit.
102 procedure Implicit_With_On_Parent
(Child_Unit
: Node_Id
; N
: Node_Id
);
103 -- If the main unit is a child unit, implicit withs are also added for
104 -- all its ancestors.
106 procedure Install_Context_Clauses
(N
: Node_Id
);
107 -- Subsidiary to previous one. Process only with_ and use_clauses for
108 -- current unit and its library unit if any.
110 procedure Install_Withed_Unit
(With_Clause
: Node_Id
);
111 -- If the unit is not a child unit, make unit immediately visible.
112 -- The caller ensures that the unit is not already currently installed.
114 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean);
115 -- This procedure establishes the context for the compilation of a child
116 -- unit. If Lib_Unit is a child library spec then the context of the parent
117 -- is installed, and the parent itself made immediately visible, so that
118 -- the child unit is processed in the declarative region of the parent.
119 -- Install_Parents makes a recursive call to itself to ensure that all
120 -- parents are loaded in the nested case. If Lib_Unit is a library body,
121 -- the only effect of Install_Parents is to install the private decls of
122 -- the parents, because the visible parent declarations will have been
123 -- installed as part of the context of the corresponding spec.
125 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
);
126 -- In the compilation of a child unit, a child of any of the ancestor
127 -- units is directly visible if it is visible, because the parent is in
128 -- an enclosing scope. Iterate over context to find child units of U_Name
129 -- or of some ancestor of it.
131 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean;
132 -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
133 -- returns True if Lib_Unit is a library spec which is a child spec, i.e.
134 -- a library spec that has a parent. If the call to Is_Child_Spec returns
135 -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
136 -- compilation unit for the parent spec.
138 -- Lib_Unit can also be a subprogram body that acts as its own spec. If
139 -- the Parent_Spec is non-empty, this is also a child unit.
141 procedure Remove_With_Type_Clause
(Name
: Node_Id
);
142 -- Remove imported type and its enclosing package from visibility, and
143 -- remove attributes of imported type so they don't interfere with its
144 -- analysis (should it appear otherwise in the context).
146 procedure Remove_Context_Clauses
(N
: Node_Id
);
147 -- Subsidiary of previous one. Remove use_ and with_clauses.
149 procedure Remove_Parents
(Lib_Unit
: Node_Id
);
150 -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
151 -- contexts established by the corresponding call to Install_Parents are
152 -- removed. Remove_Parents contains a recursive call to itself to ensure
153 -- that all parents are removed in the nested case.
155 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
);
156 -- Reset all visibility flags on unit after compiling it, either as a
157 -- main unit or as a unit in the context.
159 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
);
160 -- Common processing for all stubs (subprograms, tasks, packages, and
161 -- protected cases). N is the stub to be analyzed. Once the subunit
162 -- name is established, load and analyze. Nam is the non-overloadable
163 -- entity for which the proper body provides a completion. Subprogram
164 -- stubs are handled differently because they can be declarations.
166 ------------------------------
167 -- Analyze_Compilation_Unit --
168 ------------------------------
170 procedure Analyze_Compilation_Unit
(N
: Node_Id
) is
171 Unit_Node
: constant Node_Id
:= Unit
(N
);
172 Lib_Unit
: Node_Id
:= Library_Unit
(N
);
174 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
175 Par_Spec_Name
: Unit_Name_Type
;
176 Unum
: Unit_Number_Type
;
178 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
);
179 -- Generate cross-reference information for the parents of child units.
180 -- N is a defining_program_unit_name, and P_Id is the immediate parent.
182 --------------------------------
183 -- Generate_Parent_References --
184 --------------------------------
186 procedure Generate_Parent_References
(N
: Node_Id
; P_Id
: Entity_Id
) is
188 P_Name
: Entity_Id
:= P_Id
;
191 Pref
:= Name
(Parent
(Defining_Entity
(N
)));
193 if Nkind
(Pref
) = N_Expanded_Name
then
195 -- Done already, if the unit has been compiled indirectly as
196 -- part of the closure of its context because of inlining.
201 while Nkind
(Pref
) = N_Selected_Component
loop
202 Change_Selected_Component_To_Expanded_Name
(Pref
);
203 Set_Entity
(Pref
, P_Name
);
204 Set_Etype
(Pref
, Etype
(P_Name
));
205 Generate_Reference
(P_Name
, Pref
, 'r');
206 Pref
:= Prefix
(Pref
);
207 P_Name
:= Scope
(P_Name
);
210 -- The guard here on P_Name is to handle the error condition where
211 -- the parent unit is missing because the file was not found.
213 if Present
(P_Name
) then
214 Set_Entity
(Pref
, P_Name
);
215 Set_Etype
(Pref
, Etype
(P_Name
));
216 Generate_Reference
(P_Name
, Pref
, 'r');
217 Style
.Check_Identifier
(Pref
, P_Name
);
219 end Generate_Parent_References
;
221 -- Start of processing for Analyze_Compilation_Unit
224 Process_Compilation_Unit_Pragmas
(N
);
226 -- If the unit is a subunit whose parent has not been analyzed (which
227 -- indicates that the main unit is a subunit, either the current one or
228 -- one of its descendents) then the subunit is compiled as part of the
229 -- analysis of the parent, which we proceed to do. Basically this gets
230 -- handled from the top down and we don't want to do anything at this
231 -- level (i.e. this subunit will be handled on the way down from the
232 -- parent), so at this level we immediately return. If the subunit
233 -- ends up not analyzed, it means that the parent did not contain a
234 -- stub for it, or that there errors were dectected in some ancestor.
236 if Nkind
(Unit_Node
) = N_Subunit
237 and then not Analyzed
(Lib_Unit
)
239 Semantics
(Lib_Unit
);
241 if not Analyzed
(Proper_Body
(Unit_Node
)) then
242 if Serious_Errors_Detected
> 0 then
243 Error_Msg_N
("subunit not analyzed (errors in parent unit)", N
);
245 Error_Msg_N
("missing stub for subunit", N
);
252 -- Analyze context (this will call Sem recursively for with'ed units)
256 -- If the unit is a package body, the spec is already loaded and must
257 -- be analyzed first, before we analyze the body.
259 if Nkind
(Unit_Node
) = N_Package_Body
then
261 -- If no Lib_Unit, then there was a serious previous error, so
262 -- just ignore the entire analysis effort
264 if No
(Lib_Unit
) then
268 Semantics
(Lib_Unit
);
269 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
271 -- Verify that the library unit is a package declaration.
273 if Nkind
(Unit
(Lib_Unit
)) /= N_Package_Declaration
275 Nkind
(Unit
(Lib_Unit
)) /= N_Generic_Package_Declaration
278 ("no legal package declaration for package body", N
);
281 -- Otherwise, the entity in the declaration is visible. Update
282 -- the version to reflect dependence of this body on the spec.
285 Spec_Id
:= Defining_Entity
(Unit
(Lib_Unit
));
286 Set_Is_Immediately_Visible
(Spec_Id
, True);
287 Version_Update
(N
, Lib_Unit
);
289 if Nkind
(Defining_Unit_Name
(Unit_Node
))
290 = N_Defining_Program_Unit_Name
292 Generate_Parent_References
(Unit_Node
, Scope
(Spec_Id
));
297 -- If the unit is a subprogram body, then we similarly need to analyze
298 -- its spec. However, things are a little simpler in this case, because
299 -- here, this analysis is done only for error checking and consistency
300 -- purposes, so there's nothing else to be done.
302 elsif Nkind
(Unit_Node
) = N_Subprogram_Body
then
303 if Acts_As_Spec
(N
) then
305 -- If the subprogram body is a child unit, we must create a
306 -- declaration for it, in order to properly load the parent(s).
307 -- After this, the original unit does not acts as a spec, because
308 -- there is an explicit one. If this unit appears in a context
309 -- clause, then an implicit with on the parent will be added when
310 -- installing the context. If this is the main unit, there is no
311 -- Unit_Table entry for the declaration, (It has the unit number
312 -- of the main unit) and code generation is unaffected.
314 Unum
:= Get_Cunit_Unit_Number
(N
);
315 Par_Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Unum
));
317 if Par_Spec_Name
/= No_Name
then
320 (Load_Name
=> Par_Spec_Name
,
325 if Unum
/= No_Unit
then
327 -- Build subprogram declaration and attach parent unit to it
328 -- This subprogram declaration does not come from source!
331 Loc
: constant Source_Ptr
:= Sloc
(N
);
332 SCS
: constant Boolean :=
333 Get_Comes_From_Source_Default
;
336 Set_Comes_From_Source_Default
(False);
338 Make_Compilation_Unit
(Loc
,
339 Context_Items
=> New_Copy_List
(Context_Items
(N
)),
341 Make_Subprogram_Declaration
(Sloc
(N
),
344 (Specification
(Unit_Node
))),
346 Make_Compilation_Unit_Aux
(Loc
));
348 Set_Library_Unit
(N
, Lib_Unit
);
349 Set_Parent_Spec
(Unit
(Lib_Unit
), Cunit
(Unum
));
350 Semantics
(Lib_Unit
);
351 Set_Acts_As_Spec
(N
, False);
352 Set_Comes_From_Source_Default
(SCS
);
357 -- Here for subprogram with separate declaration
360 Semantics
(Lib_Unit
);
361 Check_Unused_Withs
(Get_Cunit_Unit_Number
(Lib_Unit
));
362 Version_Update
(N
, Lib_Unit
);
365 if Nkind
(Defining_Unit_Name
(Specification
(Unit_Node
))) =
366 N_Defining_Program_Unit_Name
368 Generate_Parent_References
(
369 Specification
(Unit_Node
),
370 Scope
(Defining_Entity
(Unit
(Lib_Unit
))));
374 -- If it is a child unit, the parent must be elaborated first
375 -- and we update version, since we are dependent on our parent.
377 if Is_Child_Spec
(Unit_Node
) then
379 -- The analysis of the parent is done with style checks off
382 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
383 Save_C_Restrict
: constant Save_Compilation_Unit_Restrictions
:=
384 Compilation_Unit_Restrictions_Save
;
387 if not GNAT_Mode
then
388 Style_Check
:= False;
391 Semantics
(Parent_Spec
(Unit_Node
));
392 Version_Update
(N
, Parent_Spec
(Unit_Node
));
393 Style_Check
:= Save_Style_Check
;
394 Compilation_Unit_Restrictions_Restore
(Save_C_Restrict
);
398 -- With the analysis done, install the context. Note that we can't
399 -- install the context from the with clauses as we analyze them,
400 -- because each with clause must be analyzed in a clean visibility
401 -- context, so we have to wait and install them all at once.
405 if Is_Child_Spec
(Unit_Node
) then
407 -- Set the entities of all parents in the program_unit_name.
409 Generate_Parent_References
(
410 Unit_Node
, Get_Parent_Entity
(Unit
(Parent_Spec
(Unit_Node
))));
413 -- All components of the context: with-clauses, library unit, ancestors
414 -- if any, (and their context) are analyzed and installed. Now analyze
415 -- the unit itself, which is either a package, subprogram spec or body.
419 -- The above call might have made Unit_Node an N_Subprogram_Body
420 -- from something else, so propagate any Acts_As_Spec flag.
422 if Nkind
(Unit_Node
) = N_Subprogram_Body
423 and then Acts_As_Spec
(Unit_Node
)
425 Set_Acts_As_Spec
(N
);
428 -- Treat compilation unit pragmas that appear after the library unit
430 if Present
(Pragmas_After
(Aux_Decls_Node
(N
))) then
432 Prag_Node
: Node_Id
:= First
(Pragmas_After
(Aux_Decls_Node
(N
)));
435 while Present
(Prag_Node
) loop
442 -- Generate distribution stub files if requested and no error
445 and then (Distribution_Stub_Mode
= Generate_Receiver_Stub_Body
447 Distribution_Stub_Mode
= Generate_Caller_Stub_Body
)
448 and then not Fatal_Error
(Main_Unit
)
450 if Is_RCI_Pkg_Spec_Or_Body
(N
) then
452 -- Regular RCI package
454 Add_Stub_Constructs
(N
);
456 elsif (Nkind
(Unit_Node
) = N_Package_Declaration
457 and then Is_Shared_Passive
(Defining_Entity
458 (Specification
(Unit_Node
))))
459 or else (Nkind
(Unit_Node
) = N_Package_Body
461 Is_Shared_Passive
(Corresponding_Spec
(Unit_Node
)))
463 -- Shared passive package
465 Add_Stub_Constructs
(N
);
467 elsif Nkind
(Unit_Node
) = N_Package_Instantiation
469 Is_Remote_Call_Interface
470 (Defining_Entity
(Specification
(Instance_Spec
(Unit_Node
))))
472 -- Instantiation of a RCI generic package
474 Add_Stub_Constructs
(N
);
477 -- Reanalyze the unit with the new constructs
482 if Nkind
(Unit_Node
) = N_Package_Declaration
483 or else Nkind
(Unit_Node
) in N_Generic_Declaration
484 or else Nkind
(Unit_Node
) = N_Package_Renaming_Declaration
485 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
487 Remove_Unit_From_Visibility
(Defining_Entity
(Unit_Node
));
489 elsif Nkind
(Unit_Node
) = N_Package_Body
490 or else (Nkind
(Unit_Node
) = N_Subprogram_Body
491 and then not Acts_As_Spec
(Unit_Node
))
493 -- Bodies that are not the main unit are compiled if they
494 -- are generic or contain generic or inlined units. Their
495 -- analysis brings in the context of the corresponding spec
496 -- (unit declaration) which must be removed as well, to
497 -- return the compilation environment to its proper state.
499 Remove_Context
(Lib_Unit
);
500 Set_Is_Immediately_Visible
(Defining_Entity
(Unit
(Lib_Unit
)), False);
503 -- Last step is to deinstall the context we just installed
504 -- as well as the unit just compiled.
508 -- If this is the main unit and we are generating code, we must
509 -- check that all generic units in the context have a body if they
510 -- need it, even if they have not been instantiated. In the absence
511 -- of .ali files for generic units, we must force the load of the body,
512 -- just to produce the proper error if the body is absent. We skip this
513 -- verification if the main unit itself is generic.
515 if Get_Cunit_Unit_Number
(N
) = Main_Unit
516 and then Operating_Mode
= Generate_Code
517 and then Expander_Active
519 -- Indicate that the main unit is now analyzed, to catch possible
520 -- circularities between it and generic bodies. Remove main unit
521 -- from visibility. This might seem superfluous, but the main unit
522 -- must not be visible in the generic body expansions that follow.
524 Set_Analyzed
(N
, True);
525 Set_Is_Immediately_Visible
(Cunit_Entity
(Main_Unit
), False);
530 Un
: Unit_Number_Type
;
532 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
533 Save_C_Restrict
: constant Save_Compilation_Unit_Restrictions
:=
534 Compilation_Unit_Restrictions_Save
;
537 Item
:= First
(Context_Items
(N
));
539 while Present
(Item
) loop
541 if Nkind
(Item
) = N_With_Clause
542 and then not Implicit_With
(Item
)
544 Nam
:= Entity
(Name
(Item
));
546 if (Ekind
(Nam
) = E_Generic_Procedure
547 and then not Is_Intrinsic_Subprogram
(Nam
))
548 or else (Ekind
(Nam
) = E_Generic_Function
549 and then not Is_Intrinsic_Subprogram
(Nam
))
550 or else (Ekind
(Nam
) = E_Generic_Package
551 and then Unit_Requires_Body
(Nam
))
553 Opt
.Style_Check
:= False;
555 if Present
(Renamed_Object
(Nam
)) then
558 (Load_Name
=> Get_Body_Name
560 (Unit_Declaration_Node
561 (Renamed_Object
(Nam
)))),
569 (Load_Name
=> Get_Body_Name
570 (Get_Unit_Name
(Item
)),
579 ("body of generic unit& not found", Item
, Nam
);
582 elsif not Analyzed
(Cunit
(Un
))
583 and then Un
/= Main_Unit
585 Opt
.Style_Check
:= False;
586 Semantics
(Cunit
(Un
));
594 Style_Check
:= Save_Style_Check
;
595 Compilation_Unit_Restrictions_Restore
(Save_C_Restrict
);
599 -- Deal with creating elaboration Boolean if needed. We create an
600 -- elaboration boolean only for units that come from source since
601 -- units manufactured by the compiler never need elab checks.
603 if Comes_From_Source
(N
)
605 (Nkind
(Unit
(N
)) = N_Package_Declaration
or else
606 Nkind
(Unit
(N
)) = N_Generic_Package_Declaration
or else
607 Nkind
(Unit
(N
)) = N_Subprogram_Declaration
or else
608 Nkind
(Unit
(N
)) = N_Generic_Subprogram_Declaration
)
611 Loc
: constant Source_Ptr
:= Sloc
(N
);
612 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
615 Spec_Id
:= Defining_Entity
(Unit
(N
));
616 Generate_Definition
(Spec_Id
);
618 -- See if an elaboration entity is required for possible
619 -- access before elaboration checking. Note that we must
620 -- allow for this even if -gnatE is not set, since a client
621 -- may be compiled in -gnatE mode and reference the entity.
623 -- Case of units which do not require elaboration checks
626 -- Pure units do not need checks
630 -- Preelaborated units do not need checks
632 or else Is_Preelaborated
(Spec_Id
)
634 -- No checks needed if pagma Elaborate_Body present
636 or else Has_Pragma_Elaborate_Body
(Spec_Id
)
638 -- No checks needed if unit does not require a body
640 or else not Unit_Requires_Body
(Spec_Id
)
642 -- No checks needed for predefined files
644 or else Is_Predefined_File_Name
(Unit_File_Name
(Unum
))
646 -- No checks required if no separate spec
648 or else Acts_As_Spec
(N
)
650 -- This is a case where we only need the entity for
651 -- checking to prevent multiple elaboration checks.
653 Set_Elaboration_Entity_Required
(Spec_Id
, False);
655 -- Case of elaboration entity is required for access before
656 -- elaboration checking (so certainly we must build it!)
659 Set_Elaboration_Entity_Required
(Spec_Id
, True);
662 Build_Elaboration_Entity
(N
, Spec_Id
);
666 -- Finally, freeze the compilation unit entity. This for sure is needed
667 -- because of some warnings that can be output (see Freeze_Subprogram),
668 -- but may in general be required. If freezing actions result, place
669 -- them in the compilation unit actions list, and analyze them.
672 Loc
: constant Source_Ptr
:= Sloc
(N
);
673 L
: constant List_Id
:=
674 Freeze_Entity
(Cunit_Entity
(Current_Sem_Unit
), Loc
);
677 while Is_Non_Empty_List
(L
) loop
678 Insert_Library_Level_Action
(Remove_Head
(L
));
684 if Nkind
(Unit_Node
) = N_Package_Declaration
685 and then Get_Cunit_Unit_Number
(N
) /= Main_Unit
686 and then Front_End_Inlining
687 and then Expander_Active
689 Check_Body_For_Inlining
(N
, Defining_Entity
(Unit_Node
));
691 end Analyze_Compilation_Unit
;
693 ---------------------
694 -- Analyze_Context --
695 ---------------------
697 procedure Analyze_Context
(N
: Node_Id
) is
701 -- Loop through context items
703 Item
:= First
(Context_Items
(N
));
704 while Present
(Item
) loop
706 -- For with clause, analyze the with clause, and then update
707 -- the version, since we are dependent on a unit that we with.
709 if Nkind
(Item
) = N_With_Clause
then
711 -- Skip analyzing with clause if no unit, nothing to do (this
712 -- happens for a with that references a non-existent unit)
714 if Present
(Library_Unit
(Item
)) then
718 if not Implicit_With
(Item
) then
719 Version_Update
(N
, Library_Unit
(Item
));
722 -- But skip use clauses at this stage, since we don't want to do
723 -- any installing of potentially use visible entities until we
724 -- we actually install the complete context (in Install_Context).
725 -- Otherwise things can get installed in the wrong context.
726 -- Similarly, pragmas are analyzed in Install_Context, after all
727 -- the implicit with's on parent units are generated.
737 -------------------------------
738 -- Analyze_Package_Body_Stub --
739 -------------------------------
741 procedure Analyze_Package_Body_Stub
(N
: Node_Id
) is
742 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
746 -- The package declaration must be in the current declarative part.
748 Check_Stub_Level
(N
);
749 Nam
:= Current_Entity_In_Scope
(Id
);
751 if No
(Nam
) or else not Is_Package
(Nam
) then
752 Error_Msg_N
("missing specification for package stub", N
);
754 elsif Has_Completion
(Nam
)
755 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Nam
)))
757 Error_Msg_N
("duplicate or redundant stub for package", N
);
760 -- Indicate that the body of the package exists. If we are doing
761 -- only semantic analysis, the stub stands for the body. If we are
762 -- generating code, the existence of the body will be confirmed
763 -- when we load the proper body.
765 Set_Has_Completion
(Nam
);
766 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
767 Analyze_Proper_Body
(N
, Nam
);
769 end Analyze_Package_Body_Stub
;
771 -------------------------
772 -- Analyze_Proper_Body --
773 -------------------------
775 procedure Analyze_Proper_Body
(N
: Node_Id
; Nam
: Entity_Id
) is
776 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
777 Unum
: Unit_Number_Type
;
778 Subunit_Not_Found
: Boolean := False;
780 procedure Optional_Subunit
;
781 -- This procedure is called when the main unit is a stub, or when we
782 -- are not generating code. In such a case, we analyze the subunit if
783 -- present, which is user-friendly and in fact required for ASIS, but
784 -- we don't complain if the subunit is missing.
786 ----------------------
787 -- Optional_Subunit --
788 ----------------------
790 procedure Optional_Subunit
is
794 -- Try to load subunit, but ignore any errors that occur during
795 -- the loading of the subunit, by using the special feature in
796 -- Errout to ignore all errors. Note that Fatal_Error will still
797 -- be set, so we will be able to check for this case below.
799 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
802 (Load_Name
=> Subunit_Name
,
806 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
808 -- All done if we successfully loaded the subunit
810 if Unum
/= No_Unit
and then not Fatal_Error
(Unum
) then
811 Comp_Unit
:= Cunit
(Unum
);
813 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
814 Analyze_Subunit
(Comp_Unit
);
815 Set_Library_Unit
(N
, Comp_Unit
);
818 and then Present
(Nam
)
820 if Is_Protected_Type
(Nam
) then
821 Set_Corresponding_Body
(Parent
(Nam
), Defining_Identifier
(N
));
823 Set_Corresponding_Body
(
824 Unit_Declaration_Node
(Nam
), Defining_Identifier
(N
));
827 end Optional_Subunit
;
829 -- Start of processing for Analyze_Proper_Body
832 -- If the subunit is already loaded, it means that the main unit
833 -- is a subunit, and that the current unit is one of its parents
834 -- which was being analyzed to provide the needed context for the
835 -- analysis of the subunit. In this case we analyze the subunit and
836 -- continue with the parent, without looking a subsequent subunits.
838 if Is_Loaded
(Subunit_Name
) then
840 -- If the proper body is already linked to the stub node,
841 -- the stub is in a generic unit and just needs analyzing.
843 if Present
(Library_Unit
(N
)) then
844 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
845 Analyze_Subunit
(Library_Unit
(N
));
847 -- Otherwise we must load the subunit and link to it
850 -- Load the subunit, this must work, since we originally
851 -- loaded the subunit earlier on. So this will not really
852 -- load it, just give access to it.
856 (Load_Name
=> Subunit_Name
,
861 -- And analyze the subunit in the parent context (note that we
862 -- do not call Semantics, since that would remove the parent
863 -- context). Because of this, we have to manually reset the
864 -- compiler state to Analyzing since it got destroyed by Load.
866 if Unum
/= No_Unit
then
867 Compiler_State
:= Analyzing
;
868 Set_Corresponding_Stub
(Unit
(Cunit
(Unum
)), N
);
869 Analyze_Subunit
(Cunit
(Unum
));
870 Set_Library_Unit
(N
, Cunit
(Unum
));
874 -- If the main unit is a subunit, then we are just performing semantic
875 -- analysis on that subunit, and any other subunits of any parent unit
876 -- should be ignored, except that if we are building trees for ASIS
877 -- usage we want to annotate the stub properly.
879 elsif Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
880 and then Subunit_Name
/= Unit_Name
(Main_Unit
)
886 -- But before we return, set the flag for unloaded subunits. This
887 -- will suppress junk warnings of variables in the same declarative
888 -- part (or a higher level one) that are in danger of looking unused
889 -- when in fact there might be a declaration in the subunit that we
890 -- do not intend to load.
892 Unloaded_Subunits
:= True;
895 -- If the subunit is not already loaded, and we are generating code,
896 -- then this is the case where compilation started from the parent,
897 -- and we are generating code for an entire subunit tree. In that
898 -- case we definitely need to load the subunit.
900 -- In order to continue the analysis with the rest of the parent,
901 -- and other subunits, we load the unit without requiring its
902 -- presence, and emit a warning if not found, rather than terminating
903 -- the compilation abruptly, as for other missing file problems.
905 elsif Operating_Mode
= Generate_Code
then
907 -- If the proper body is already linked to the stub node,
908 -- the stub is in a generic unit and just needs analyzing.
910 -- We update the version. Although we are not technically
911 -- semantically dependent on the subunit, given our approach
912 -- of macro substitution of subunits, it makes sense to
913 -- include it in the version identification.
915 if Present
(Library_Unit
(N
)) then
916 Set_Corresponding_Stub
(Unit
(Library_Unit
(N
)), N
);
917 Analyze_Subunit
(Library_Unit
(N
));
918 Version_Update
(Cunit
(Main_Unit
), Library_Unit
(N
));
920 -- Otherwise we must load the subunit and link to it
925 (Load_Name
=> Subunit_Name
,
930 if Operating_Mode
= Generate_Code
931 and then Unum
= No_Unit
933 Error_Msg_Name_1
:= Subunit_Name
;
935 Get_File_Name
(Subunit_Name
, Subunit
=> True);
937 ("subunit% in file{ not found!?", N
);
938 Subunits_Missing
:= True;
939 Subunit_Not_Found
:= True;
942 -- Load_Unit may reset Compiler_State, since it may have been
943 -- necessary to parse an additional units, so we make sure
944 -- that we reset it to the Analyzing state.
946 Compiler_State
:= Analyzing
;
948 if Unum
/= No_Unit
and then not Fatal_Error
(Unum
) then
951 Write_Str
("*** Loaded subunit from stub. Analyze");
956 Comp_Unit
: constant Node_Id
:= Cunit
(Unum
);
959 -- Check for child unit instead of subunit
961 if Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
963 ("expected SEPARATE subunit, found child unit",
964 Cunit_Entity
(Unum
));
966 -- OK, we have a subunit, so go ahead and analyze it,
967 -- and set Scope of entity in stub, for ASIS use.
970 Set_Corresponding_Stub
(Unit
(Comp_Unit
), N
);
971 Analyze_Subunit
(Comp_Unit
);
972 Set_Library_Unit
(N
, Comp_Unit
);
974 -- We update the version. Although we are not technically
975 -- semantically dependent on the subunit, given our
976 -- approach of macro substitution of subunits, it makes
977 -- sense to include it in the version identification.
979 Version_Update
(Cunit
(Main_Unit
), Comp_Unit
);
985 -- The remaining case is when the subunit is not already loaded and
986 -- we are not generating code. In this case we are just performing
987 -- semantic analysis on the parent, and we are not interested in
988 -- the subunit. For subprograms, analyze the stub as a body. For
989 -- other entities the stub has already been marked as completed.
995 end Analyze_Proper_Body
;
997 ----------------------------------
998 -- Analyze_Protected_Body_Stub --
999 ----------------------------------
1001 procedure Analyze_Protected_Body_Stub
(N
: Node_Id
) is
1002 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1005 Check_Stub_Level
(N
);
1007 -- First occurrence of name may have been as an incomplete type.
1009 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1010 Nam
:= Full_View
(Nam
);
1014 or else not Is_Protected_Type
(Etype
(Nam
))
1016 Error_Msg_N
("missing specification for Protected body", N
);
1018 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1019 Set_Has_Completion
(Etype
(Nam
));
1020 Analyze_Proper_Body
(N
, Etype
(Nam
));
1022 end Analyze_Protected_Body_Stub
;
1024 ----------------------------------
1025 -- Analyze_Subprogram_Body_Stub --
1026 ----------------------------------
1028 -- A subprogram body stub can appear with or without a previous
1029 -- specification. If there is one, the analysis of the body will
1030 -- find it and verify conformance. The formals appearing in the
1031 -- specification of the stub play no role, except for requiring an
1032 -- additional conformance check. If there is no previous subprogram
1033 -- declaration, the stub acts as a spec, and provides the defining
1034 -- entity for the subprogram.
1036 procedure Analyze_Subprogram_Body_Stub
(N
: Node_Id
) is
1040 Check_Stub_Level
(N
);
1042 -- Verify that the identifier for the stub is unique within this
1043 -- declarative part.
1045 if Nkind
(Parent
(N
)) = N_Block_Statement
1046 or else Nkind
(Parent
(N
)) = N_Package_Body
1047 or else Nkind
(Parent
(N
)) = N_Subprogram_Body
1049 Decl
:= First
(Declarations
(Parent
(N
)));
1051 while Present
(Decl
)
1054 if Nkind
(Decl
) = N_Subprogram_Body_Stub
1055 and then (Chars
(Defining_Unit_Name
(Specification
(Decl
)))
1056 = Chars
(Defining_Unit_Name
(Specification
(N
))))
1058 Error_Msg_N
("identifier for stub is not unique", N
);
1065 -- Treat stub as a body, which checks conformance if there is a previous
1066 -- declaration, or else introduces entity and its signature.
1068 Analyze_Subprogram_Body
(N
);
1070 if Serious_Errors_Detected
= 0 then
1071 Analyze_Proper_Body
(N
, Empty
);
1074 end Analyze_Subprogram_Body_Stub
;
1076 ---------------------
1077 -- Analyze_Subunit --
1078 ---------------------
1080 -- A subunit is compiled either by itself (for semantic checking)
1081 -- or as part of compiling the parent (for code generation). In
1082 -- either case, by the time we actually process the subunit, the
1083 -- parent has already been installed and analyzed. The node N is
1084 -- a compilation unit, whose context needs to be treated here,
1085 -- because we come directly here from the parent without calling
1086 -- Analyze_Compilation_Unit.
1088 -- The compilation context includes the explicit context of the
1089 -- subunit, and the context of the parent, together with the parent
1090 -- itself. In order to compile the current context, we remove the
1091 -- one inherited from the parent, in order to have a clean visibility
1092 -- table. We restore the parent context before analyzing the proper
1093 -- body itself. On exit, we remove only the explicit context of the
1096 procedure Analyze_Subunit
(N
: Node_Id
) is
1097 Lib_Unit
: constant Node_Id
:= Library_Unit
(N
);
1098 Par_Unit
: constant Entity_Id
:= Current_Scope
;
1100 Lib_Spec
: Node_Id
:= Library_Unit
(Lib_Unit
);
1101 Num_Scopes
: Int
:= 0;
1102 Use_Clauses
: array (1 .. Scope_Stack
.Last
) of Node_Id
;
1103 Enclosing_Child
: Entity_Id
:= Empty
;
1105 procedure Analyze_Subunit_Context
;
1106 -- Capture names in use clauses of the subunit. This must be done
1107 -- before re-installing parent declarations, because items in the
1108 -- context must not be hidden by declarations local to the parent.
1110 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
);
1111 -- Recursive procedure to restore scope of all ancestors of subunit,
1112 -- from outermost in. If parent is not a subunit, the call to install
1113 -- context installs context of spec and (if parent is a child unit)
1114 -- the context of its parents as well. It is confusing that parents
1115 -- should be treated differently in both cases, but the semantics are
1116 -- just not identical.
1118 procedure Re_Install_Use_Clauses
;
1119 -- As part of the removal of the parent scope, the use clauses are
1120 -- removed, to be reinstalled when the context of the subunit has
1121 -- been analyzed. Use clauses may also have been affected by the
1122 -- analysis of the context of the subunit, so they have to be applied
1123 -- again, to insure that the compilation environment of the rest of
1124 -- the parent unit is identical.
1126 procedure Remove_Scope
;
1127 -- Remove current scope from scope stack, and preserve the list
1128 -- of use clauses in it, to be reinstalled after context is analyzed.
1130 ------------------------------
1131 -- Analyze_Subunit_Context --
1132 ------------------------------
1134 procedure Analyze_Subunit_Context
is
1137 Unit_Name
: Entity_Id
;
1140 Analyze_Context
(N
);
1141 Item
:= First
(Context_Items
(N
));
1143 -- make withed units immediately visible. If child unit, make the
1144 -- ultimate parent immediately visible.
1146 while Present
(Item
) loop
1148 if Nkind
(Item
) = N_With_Clause
then
1149 Unit_Name
:= Entity
(Name
(Item
));
1151 while Is_Child_Unit
(Unit_Name
) loop
1152 Set_Is_Visible_Child_Unit
(Unit_Name
);
1153 Unit_Name
:= Scope
(Unit_Name
);
1156 if not Is_Immediately_Visible
(Unit_Name
) then
1157 Set_Is_Immediately_Visible
(Unit_Name
);
1158 Set_Context_Installed
(Item
);
1161 elsif Nkind
(Item
) = N_Use_Package_Clause
then
1162 Nam
:= First
(Names
(Item
));
1164 while Present
(Nam
) loop
1169 elsif Nkind
(Item
) = N_Use_Type_Clause
then
1170 Nam
:= First
(Subtype_Marks
(Item
));
1172 while Present
(Nam
) loop
1181 Item
:= First
(Context_Items
(N
));
1183 -- reset visibility of withed units. They will be made visible
1184 -- again when we install the subunit context.
1186 while Present
(Item
) loop
1188 if Nkind
(Item
) = N_With_Clause
then
1189 Unit_Name
:= Entity
(Name
(Item
));
1191 while Is_Child_Unit
(Unit_Name
) loop
1192 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
1193 Unit_Name
:= Scope
(Unit_Name
);
1196 if Context_Installed
(Item
) then
1197 Set_Is_Immediately_Visible
(Unit_Name
, False);
1198 Set_Context_Installed
(Item
, False);
1205 end Analyze_Subunit_Context
;
1207 ------------------------
1208 -- Re_Install_Parents --
1209 ------------------------
1211 procedure Re_Install_Parents
(L
: Node_Id
; Scop
: Entity_Id
) is
1215 if Nkind
(Unit
(L
)) = N_Subunit
then
1216 Re_Install_Parents
(Library_Unit
(L
), Scope
(Scop
));
1219 Install_Context
(L
);
1221 -- If the subunit occurs within a child unit, we must restore the
1222 -- immediate visibility of any siblings that may occur in context.
1224 if Present
(Enclosing_Child
) then
1225 Install_Siblings
(Enclosing_Child
, L
);
1230 if Scop
/= Par_Unit
then
1231 Set_Is_Immediately_Visible
(Scop
);
1234 E
:= First_Entity
(Current_Scope
);
1236 while Present
(E
) loop
1237 Set_Is_Immediately_Visible
(E
);
1241 -- A subunit appears within a body, and for a nested subunits
1242 -- all the parents are bodies. Restore full visibility of their
1243 -- private entities.
1245 if Ekind
(Scop
) = E_Package
then
1246 Set_In_Package_Body
(Scop
);
1247 Install_Private_Declarations
(Scop
);
1249 end Re_Install_Parents
;
1251 ----------------------------
1252 -- Re_Install_Use_Clauses --
1253 ----------------------------
1255 procedure Re_Install_Use_Clauses
is
1259 for J
in reverse 1 .. Num_Scopes
loop
1260 U
:= Use_Clauses
(J
);
1261 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:= U
;
1262 Install_Use_Clauses
(U
);
1264 end Re_Install_Use_Clauses
;
1270 procedure Remove_Scope
is
1274 Num_Scopes
:= Num_Scopes
+ 1;
1275 Use_Clauses
(Num_Scopes
) :=
1276 Scope_Stack
.Table
(Scope_Stack
.Last
).First_Use_Clause
;
1277 E
:= First_Entity
(Current_Scope
);
1279 while Present
(E
) loop
1280 Set_Is_Immediately_Visible
(E
, False);
1284 if Is_Child_Unit
(Current_Scope
) then
1285 Enclosing_Child
:= Current_Scope
;
1291 -- Start of processing for Analyze_Subunit
1294 if not Is_Empty_List
(Context_Items
(N
)) then
1296 -- Save current use clauses.
1299 Remove_Context
(Lib_Unit
);
1301 -- Now remove parents and their context, including enclosing
1302 -- subunits and the outer parent body which is not a subunit.
1304 if Present
(Lib_Spec
) then
1305 Remove_Context
(Lib_Spec
);
1307 while Nkind
(Unit
(Lib_Spec
)) = N_Subunit
loop
1308 Lib_Spec
:= Library_Unit
(Lib_Spec
);
1310 Remove_Context
(Lib_Spec
);
1313 if Nkind
(Unit
(Lib_Unit
)) = N_Subunit
then
1317 if Nkind
(Unit
(Lib_Spec
)) = N_Package_Body
then
1318 Remove_Context
(Library_Unit
(Lib_Spec
));
1322 Analyze_Subunit_Context
;
1323 Re_Install_Parents
(Lib_Unit
, Par_Unit
);
1325 -- If the context includes a child unit of the parent of the
1326 -- subunit, the parent will have been removed from visibility,
1327 -- after compiling that cousin in the context. The visibility
1328 -- of the parent must be restored now. This also applies if the
1329 -- context includes another subunit of the same parent which in
1330 -- turn includes a child unit in its context.
1332 if Ekind
(Par_Unit
) = E_Package
then
1333 if not Is_Immediately_Visible
(Par_Unit
)
1334 or else (Present
(First_Entity
(Par_Unit
))
1335 and then not Is_Immediately_Visible
1336 (First_Entity
(Par_Unit
)))
1338 Set_Is_Immediately_Visible
(Par_Unit
);
1339 Install_Visible_Declarations
(Par_Unit
);
1340 Install_Private_Declarations
(Par_Unit
);
1344 Re_Install_Use_Clauses
;
1345 Install_Context
(N
);
1347 -- If the subunit is within a child unit, then siblings of any
1348 -- parent unit that appear in the context clause of the subunit
1349 -- must also be made immediately visible.
1351 if Present
(Enclosing_Child
) then
1352 Install_Siblings
(Enclosing_Child
, N
);
1357 Analyze
(Proper_Body
(Unit
(N
)));
1360 end Analyze_Subunit
;
1362 ----------------------------
1363 -- Analyze_Task_Body_Stub --
1364 ----------------------------
1366 procedure Analyze_Task_Body_Stub
(N
: Node_Id
) is
1367 Nam
: Entity_Id
:= Current_Entity_In_Scope
(Defining_Identifier
(N
));
1368 Loc
: constant Source_Ptr
:= Sloc
(N
);
1371 Check_Stub_Level
(N
);
1373 -- First occurrence of name may have been as an incomplete type.
1375 if Present
(Nam
) and then Ekind
(Nam
) = E_Incomplete_Type
then
1376 Nam
:= Full_View
(Nam
);
1380 or else not Is_Task_Type
(Etype
(Nam
))
1382 Error_Msg_N
("missing specification for task body", N
);
1384 Set_Scope
(Defining_Entity
(N
), Current_Scope
);
1385 Set_Has_Completion
(Etype
(Nam
));
1386 Analyze_Proper_Body
(N
, Etype
(Nam
));
1388 -- Set elaboration flag to indicate that entity is callable.
1389 -- This cannot be done in the expansion of the body itself,
1390 -- because the proper body is not in a declarative part. This
1391 -- is only done if expansion is active, because the context
1392 -- may be generic and the flag not defined yet.
1394 if Expander_Active
then
1396 Make_Assignment_Statement
(Loc
,
1398 Make_Identifier
(Loc
,
1399 New_External_Name
(Chars
(Etype
(Nam
)), 'E')),
1400 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
1404 end Analyze_Task_Body_Stub
;
1406 -------------------------
1407 -- Analyze_With_Clause --
1408 -------------------------
1410 -- Analyze the declaration of a unit in a with clause. At end,
1411 -- label the with clause with the defining entity for the unit.
1413 procedure Analyze_With_Clause
(N
: Node_Id
) is
1414 Unit_Kind
: constant Node_Kind
:= Nkind
(Unit
(Library_Unit
(N
)));
1416 Par_Name
: Entity_Id
;
1421 -- Set True if the unit currently being compiled is an internal unit
1423 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
1424 Save_C_Restrict
: constant Save_Compilation_Unit_Restrictions
:=
1425 Compilation_Unit_Restrictions_Save
;
1428 -- We reset ordinary style checking during the analysis of a with'ed
1429 -- unit, but we do NOT reset GNAT special analysis mode (the latter
1430 -- definitely *does* apply to with'ed units).
1432 if not GNAT_Mode
then
1433 Style_Check
:= False;
1436 -- If the library unit is a predefined unit, and we are in no
1437 -- run time mode, then temporarily reset No_Run_Time mode for the
1438 -- analysis of the with'ed unit. The No_Run_Time pragma does not
1439 -- prevent explicit with'ing of run-time units.
1443 Is_Predefined_File_Name
1444 (Unit_File_Name
(Get_Source_Unit
(Unit
(Library_Unit
(N
)))))
1446 No_Run_Time
:= False;
1447 Semantics
(Library_Unit
(N
));
1448 No_Run_Time
:= True;
1451 Semantics
(Library_Unit
(N
));
1454 U
:= Unit
(Library_Unit
(N
));
1455 Intunit
:= Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
));
1457 -- Following checks are skipped for dummy packages (those supplied
1458 -- for with's where no matching file could be found). Such packages
1459 -- are identified by the Sloc value being set to No_Location
1461 if Sloc
(U
) /= No_Location
then
1463 -- Check restrictions, except that we skip the check if this
1464 -- is an internal unit unless we are compiling the internal
1465 -- unit as the main unit. We also skip this for dummy packages.
1467 if not Intunit
or else Current_Sem_Unit
= Main_Unit
then
1468 Check_Restricted_Unit
(Unit_Name
(Get_Source_Unit
(U
)), N
);
1471 -- Check for inappropriate with of internal implementation unit
1472 -- if we are currently compiling the main unit and the main unit
1473 -- is itself not an internal unit.
1475 if Implementation_Unit_Warnings
1476 and then Current_Sem_Unit
= Main_Unit
1477 and then Implementation_Unit
(Get_Source_Unit
(U
))
1478 and then not Intunit
1480 Error_Msg_N
("& is an internal 'G'N'A'T unit?", Name
(N
));
1482 ("\use of this unit is non-portable and version-dependent?",
1487 -- Semantic analysis of a generic unit is performed on a copy of
1488 -- the original tree. Retrieve the entity on which semantic info
1489 -- actually appears.
1491 if Unit_Kind
in N_Generic_Declaration
then
1492 E_Name
:= Defining_Entity
(U
);
1494 -- Note: in the following test, Unit_Kind is the original Nkind, but
1495 -- in the case of an instantiation, semantic analysis above will
1496 -- have replaced the unit by its instantiated version. If the instance
1497 -- body has been generated, the instance now denotes the body entity.
1498 -- For visibility purposes we need the entity of its spec.
1500 elsif (Unit_Kind
= N_Package_Instantiation
1501 or else Nkind
(Original_Node
(Unit
(Library_Unit
(N
)))) =
1502 N_Package_Instantiation
)
1503 and then Nkind
(U
) = N_Package_Body
1505 E_Name
:= Corresponding_Spec
(U
);
1507 elsif Unit_Kind
= N_Package_Instantiation
1508 and then Nkind
(U
) = N_Package_Instantiation
1510 -- If the instance has not been rewritten as a package declaration,
1511 -- then it appeared already in a previous with clause. Retrieve
1512 -- the entity from the previous instance.
1514 E_Name
:= Defining_Entity
(Specification
(Instance_Spec
(U
)));
1516 elsif Unit_Kind
= N_Procedure_Instantiation
1517 or else Unit_Kind
= N_Function_Instantiation
1519 -- Instantiation node is replaced with a package that contains
1520 -- renaming declarations and instance itself. The subprogram
1521 -- Instance is declared in the visible part of the wrapper package.
1523 E_Name
:= First_Entity
(Defining_Entity
(U
));
1525 while Present
(E_Name
) loop
1526 exit when Is_Subprogram
(E_Name
)
1527 and then Is_Generic_Instance
(E_Name
);
1528 E_Name
:= Next_Entity
(E_Name
);
1531 elsif Unit_Kind
= N_Package_Renaming_Declaration
1532 or else Unit_Kind
in N_Generic_Renaming_Declaration
1534 E_Name
:= Defining_Entity
(U
);
1536 elsif Unit_Kind
= N_Subprogram_Body
1537 and then Nkind
(Name
(N
)) = N_Selected_Component
1538 and then not Acts_As_Spec
(Library_Unit
(N
))
1540 -- For a child unit that has no spec, one has been created and
1541 -- analyzed. The entity required is that of the spec.
1543 E_Name
:= Corresponding_Spec
(U
);
1546 E_Name
:= Defining_Entity
(U
);
1549 if Nkind
(Name
(N
)) = N_Selected_Component
then
1551 -- Child unit in a with clause
1553 Change_Selected_Component_To_Expanded_Name
(Name
(N
));
1556 -- Restore style checks and restrictions
1558 Style_Check
:= Save_Style_Check
;
1559 Compilation_Unit_Restrictions_Restore
(Save_C_Restrict
);
1561 -- Record the reference, but do NOT set the unit as referenced, we
1562 -- want to consider the unit as unreferenced if this is the only
1563 -- reference that occurs.
1565 Set_Entity_With_Style_Check
(Name
(N
), E_Name
);
1566 Generate_Reference
(E_Name
, Name
(N
), Set_Ref
=> False);
1568 if Is_Child_Unit
(E_Name
) then
1569 Pref
:= Prefix
(Name
(N
));
1570 Par_Name
:= Scope
(E_Name
);
1572 while Nkind
(Pref
) = N_Selected_Component
loop
1573 Change_Selected_Component_To_Expanded_Name
(Pref
);
1574 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
1576 Generate_Reference
(Par_Name
, Pref
);
1577 Pref
:= Prefix
(Pref
);
1578 Par_Name
:= Scope
(Par_Name
);
1581 if Present
(Entity
(Pref
))
1582 and then not Analyzed
(Parent
(Parent
(Entity
(Pref
))))
1584 -- If the entity is set without its unit being compiled,
1585 -- the original parent is a renaming, and Par_Name is the
1586 -- renamed entity. For visibility purposes, we need the
1587 -- original entity, which must be analyzed now, because
1588 -- Load_Unit retrieves directly the renamed unit, and the
1589 -- renaming declaration itself has not been analyzed.
1591 Analyze
(Parent
(Parent
(Entity
(Pref
))));
1592 pragma Assert
(Renamed_Object
(Entity
(Pref
)) = Par_Name
);
1593 Par_Name
:= Entity
(Pref
);
1596 Set_Entity_With_Style_Check
(Pref
, Par_Name
);
1597 Generate_Reference
(Par_Name
, Pref
);
1600 -- If the withed unit is System, and a system extension pragma is
1601 -- present, compile the extension now, rather than waiting for
1602 -- a visibility check on a specific entity.
1604 if Chars
(E_Name
) = Name_System
1605 and then Scope
(E_Name
) = Standard_Standard
1606 and then Present
(System_Extend_Pragma_Arg
)
1607 and then Present_System_Aux
(N
)
1609 -- If the extension is not present, an error will have been emitted.
1613 end Analyze_With_Clause
;
1615 ------------------------------
1616 -- Analyze_With_Type_Clause --
1617 ------------------------------
1619 procedure Analyze_With_Type_Clause
(N
: Node_Id
) is
1620 Loc
: constant Source_Ptr
:= Sloc
(N
);
1621 Nam
: Node_Id
:= Name
(N
);
1625 Unum
: Unit_Number_Type
;
1628 procedure Decorate_Tagged_Type
(T
: Entity_Id
);
1629 -- Set basic attributes of type, including its class_wide type.
1631 function In_Chain
(E
: Entity_Id
) return Boolean;
1632 -- Check that the imported type is not already in the homonym chain,
1633 -- for example through a with_type clause in a parent unit.
1635 --------------------------
1636 -- Decorate_Tagged_Type --
1637 --------------------------
1639 procedure Decorate_Tagged_Type
(T
: Entity_Id
) is
1643 Set_Ekind
(T
, E_Record_Type
);
1644 Set_Is_Tagged_Type
(T
);
1646 Set_From_With_Type
(T
);
1649 if not In_Chain
(T
) then
1650 Set_Homonym
(T
, Current_Entity
(T
));
1651 Set_Current_Entity
(T
);
1654 -- Build bogus class_wide type, if not previously done.
1656 if No
(Class_Wide_Type
(T
)) then
1657 CW
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1659 Set_Ekind
(CW
, E_Class_Wide_Type
);
1662 Set_Is_Tagged_Type
(CW
);
1663 Set_Is_First_Subtype
(CW
, True);
1664 Init_Size_Align
(CW
);
1665 Set_Has_Unknown_Discriminants
1667 Set_Class_Wide_Type
(CW
, CW
);
1668 Set_Equivalent_Type
(CW
, Empty
);
1669 Set_From_With_Type
(CW
);
1671 Set_Class_Wide_Type
(T
, CW
);
1673 end Decorate_Tagged_Type
;
1679 function In_Chain
(E
: Entity_Id
) return Boolean is
1680 H
: Entity_Id
:= Current_Entity
(E
);
1683 while Present
(H
) loop
1695 -- Start of processing for Analyze_With_Type_Clause
1698 if Nkind
(Nam
) = N_Selected_Component
then
1699 Pack
:= New_Copy_Tree
(Prefix
(Nam
));
1700 Sel
:= Selector_Name
(Nam
);
1703 Error_Msg_N
("illegal name for imported type", Nam
);
1708 Make_Package_Declaration
(Loc
,
1710 (Make_Package_Specification
(Loc
,
1711 Defining_Unit_Name
=> Pack
,
1712 Visible_Declarations
=> New_List
,
1713 End_Label
=> Empty
)));
1717 (Load_Name
=> Get_Unit_Name
(Decl
),
1723 or else Nkind
(Unit
(Cunit
(Unum
))) /= N_Package_Declaration
1725 Error_Msg_N
("imported type must be declared in package", Nam
);
1728 elsif Unum
= Current_Sem_Unit
then
1730 -- If type is defined in unit being analyzed, then the clause
1736 P
:= Cunit_Entity
(Unum
);
1739 -- Find declaration for imported type, and set its basic attributes
1740 -- if it has not been analyzed (which will be the case if there is
1741 -- circular dependence).
1748 if not Analyzed
(Cunit
(Unum
))
1749 and then not From_With_Type
(P
)
1751 Set_Ekind
(P
, E_Package
);
1752 Set_Etype
(P
, Standard_Void_Type
);
1753 Set_From_With_Type
(P
);
1754 Set_Scope
(P
, Standard_Standard
);
1755 Set_Homonym
(P
, Current_Entity
(P
));
1756 Set_Current_Entity
(P
);
1758 elsif Analyzed
(Cunit
(Unum
))
1759 and then Is_Child_Unit
(P
)
1761 -- If the child unit is already in scope, indicate that it is
1762 -- visible, and remains so after intervening calls to rtsfind.
1764 Set_Is_Visible_Child_Unit
(P
);
1767 if Nkind
(Parent
(P
)) = N_Defining_Program_Unit_Name
then
1769 -- Make parent packages visible.
1772 Parent_Comp
: Node_Id
;
1773 Parent_Id
: Entity_Id
;
1778 Parent_Comp
:= Parent_Spec
(Unit
(Cunit
(Unum
)));
1781 Parent_Id
:= Defining_Entity
(Unit
(Parent_Comp
));
1782 Set_Scope
(Child
, Parent_Id
);
1784 -- The type may be imported from a child unit, in which
1785 -- case the current compilation appears in the name. Do
1786 -- not change its visibility here because it will conflict
1787 -- with the subsequent normal processing.
1789 if not Analyzed
(Unit_Declaration_Node
(Parent_Id
))
1790 and then Parent_Id
/= Cunit_Entity
(Current_Sem_Unit
)
1792 Set_Ekind
(Parent_Id
, E_Package
);
1793 Set_Etype
(Parent_Id
, Standard_Void_Type
);
1795 -- The same package may appear is several with_type
1798 if not From_With_Type
(Parent_Id
) then
1799 Set_Homonym
(Parent_Id
, Current_Entity
(Parent_Id
));
1800 Set_Current_Entity
(Parent_Id
);
1801 Set_From_With_Type
(Parent_Id
);
1805 Set_Is_Immediately_Visible
(Parent_Id
);
1808 Parent_Comp
:= Parent_Spec
(Unit
(Parent_Comp
));
1809 exit when No
(Parent_Comp
);
1812 Set_Scope
(Parent_Id
, Standard_Standard
);
1816 -- Even if analyzed, the package may not be currently visible. It
1817 -- must be while the with_type clause is active.
1819 Set_Is_Immediately_Visible
(P
);
1822 First
(Visible_Declarations
(Specification
(Unit
(Cunit
(Unum
)))));
1824 while Present
(Decl
) loop
1826 if Nkind
(Decl
) = N_Full_Type_Declaration
1827 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
1829 Typ
:= Defining_Identifier
(Decl
);
1831 if Tagged_Present
(N
) then
1833 -- The declaration must indicate that this is a tagged
1834 -- type or a type extension.
1836 if (Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
1837 and then Tagged_Present
(Type_Definition
(Decl
)))
1839 (Nkind
(Type_Definition
(Decl
))
1840 = N_Derived_Type_Definition
1842 (Record_Extension_Part
(Type_Definition
(Decl
))))
1846 Error_Msg_N
("imported type is not a tagged type", Nam
);
1850 if not Analyzed
(Decl
) then
1852 -- Unit is not currently visible. Add basic attributes
1853 -- to type and build its class-wide type.
1855 Init_Size_Align
(Typ
);
1856 Decorate_Tagged_Type
(Typ
);
1860 if Nkind
(Type_Definition
(Decl
))
1861 /= N_Access_To_Object_Definition
1864 ("imported type is not an access type", Nam
);
1866 elsif not Analyzed
(Decl
) then
1867 Set_Ekind
(Typ
, E_Access_Type
);
1868 Set_Etype
(Typ
, Typ
);
1870 Init_Size
(Typ
, System_Address_Size
);
1871 Init_Alignment
(Typ
);
1872 Set_Directly_Designated_Type
(Typ
, Standard_Integer
);
1873 Set_From_With_Type
(Typ
);
1875 if not In_Chain
(Typ
) then
1876 Set_Homonym
(Typ
, Current_Entity
(Typ
));
1877 Set_Current_Entity
(Typ
);
1882 Set_Entity
(Sel
, Typ
);
1885 elsif ((Nkind
(Decl
) = N_Private_Type_Declaration
1886 and then Tagged_Present
(Decl
))
1887 or else (Nkind
(Decl
) = N_Private_Extension_Declaration
))
1888 and then Chars
(Defining_Identifier
(Decl
)) = Chars
(Sel
)
1890 Typ
:= Defining_Identifier
(Decl
);
1892 if not Tagged_Present
(N
) then
1893 Error_Msg_N
("type must be declared tagged", N
);
1895 elsif not Analyzed
(Decl
) then
1896 Decorate_Tagged_Type
(Typ
);
1899 Set_Entity
(Sel
, Typ
);
1900 Set_From_With_Type
(Typ
);
1904 Decl
:= Next
(Decl
);
1907 Error_Msg_NE
("not a visible access or tagged type in&", Nam
, P
);
1909 end Analyze_With_Type_Clause
;
1911 -----------------------------
1912 -- Check_With_Type_Clauses --
1913 -----------------------------
1915 procedure Check_With_Type_Clauses
(N
: Node_Id
) is
1916 Lib_Unit
: constant Node_Id
:= Unit
(N
);
1918 procedure Check_Parent_Context
(U
: Node_Id
);
1919 -- Examine context items of parent unit to locate with_type clauses.
1921 --------------------------
1922 -- Check_Parent_Context --
1923 --------------------------
1925 procedure Check_Parent_Context
(U
: Node_Id
) is
1929 Item
:= First
(Context_Items
(U
));
1930 while Present
(Item
) loop
1931 if Nkind
(Item
) = N_With_Type_Clause
1932 and then not Error_Posted
(Item
)
1934 From_With_Type
(Scope
(Entity
(Selector_Name
(Name
(Item
)))))
1936 Error_Msg_Sloc
:= Sloc
(Item
);
1937 Error_Msg_N
("Missing With_Clause for With_Type_Clause#", N
);
1942 end Check_Parent_Context
;
1944 -- Start of processing for Check_With_Type_Clauses
1947 if Extensions_Allowed
1948 and then (Nkind
(Lib_Unit
) = N_Package_Body
1949 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
)
1951 Check_Parent_Context
(Library_Unit
(N
));
1952 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
1953 Check_Parent_Context
(Parent_Spec
(Unit
(Library_Unit
(N
))));
1956 end Check_With_Type_Clauses
;
1958 ------------------------------
1959 -- Check_Private_Child_Unit --
1960 ------------------------------
1962 procedure Check_Private_Child_Unit
(N
: Node_Id
) is
1963 Lib_Unit
: constant Node_Id
:= Unit
(N
);
1965 Curr_Unit
: Entity_Id
;
1966 Sub_Parent
: Node_Id
;
1967 Priv_Child
: Entity_Id
;
1968 Par_Lib
: Entity_Id
;
1971 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean;
1972 -- Returns true if and only if the library unit is declared with
1973 -- an explicit designation of private.
1975 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
1977 return Private_Present
(Parent
(Unit_Declaration_Node
(Unit
)));
1978 end Is_Private_Library_Unit
;
1980 -- Start of processing for Check_Private_Child_Unit
1983 if Nkind
(Lib_Unit
) = N_Package_Body
1984 or else Nkind
(Lib_Unit
) = N_Subprogram_Body
1986 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(N
)));
1987 Par_Lib
:= Curr_Unit
;
1989 elsif Nkind
(Lib_Unit
) = N_Subunit
then
1991 -- The parent is itself a body. The parent entity is to be found
1992 -- in the corresponding spec.
1994 Sub_Parent
:= Library_Unit
(N
);
1995 Curr_Unit
:= Defining_Entity
(Unit
(Library_Unit
(Sub_Parent
)));
1997 -- If the parent itself is a subunit, Curr_Unit is the entity
1998 -- of the enclosing body, retrieve the spec entity which is
1999 -- the proper ancestor we need for the following tests.
2001 if Ekind
(Curr_Unit
) = E_Package_Body
then
2002 Curr_Unit
:= Spec_Entity
(Curr_Unit
);
2005 Par_Lib
:= Curr_Unit
;
2008 Curr_Unit
:= Defining_Entity
(Lib_Unit
);
2010 Par_Lib
:= Curr_Unit
;
2011 Par_Spec
:= Parent_Spec
(Lib_Unit
);
2013 if No
(Par_Spec
) then
2016 Par_Lib
:= Defining_Entity
(Unit
(Par_Spec
));
2020 -- Loop through context items
2022 Item
:= First
(Context_Items
(N
));
2023 while Present
(Item
) loop
2025 if Nkind
(Item
) = N_With_Clause
2026 and then not Implicit_With
(Item
)
2027 and then Is_Private_Descendant
(Entity
(Name
(Item
)))
2029 Priv_Child
:= Entity
(Name
(Item
));
2032 Curr_Parent
: Entity_Id
:= Par_Lib
;
2033 Child_Parent
: Entity_Id
:= Scope
(Priv_Child
);
2034 Prv_Ancestor
: Entity_Id
:= Child_Parent
;
2035 Curr_Private
: Boolean := Is_Private_Library_Unit
(Curr_Unit
);
2038 -- If the child unit is a public child then locate
2039 -- the nearest private ancestor; Child_Parent will
2040 -- then be set to the parent of that ancestor.
2042 if not Is_Private_Library_Unit
(Priv_Child
) then
2043 while Present
(Prv_Ancestor
)
2044 and then not Is_Private_Library_Unit
(Prv_Ancestor
)
2046 Prv_Ancestor
:= Scope
(Prv_Ancestor
);
2049 if Present
(Prv_Ancestor
) then
2050 Child_Parent
:= Scope
(Prv_Ancestor
);
2054 while Present
(Curr_Parent
)
2055 and then Curr_Parent
/= Standard_Standard
2056 and then Curr_Parent
/= Child_Parent
2059 Curr_Private
or else Is_Private_Library_Unit
(Curr_Parent
);
2060 Curr_Parent
:= Scope
(Curr_Parent
);
2063 if not Present
(Curr_Parent
) then
2064 Curr_Parent
:= Standard_Standard
;
2067 if Curr_Parent
/= Child_Parent
then
2069 if Ekind
(Priv_Child
) = E_Generic_Package
2070 and then Chars
(Priv_Child
) in Text_IO_Package_Name
2071 and then Chars
(Scope
(Scope
(Priv_Child
))) = Name_Ada
2074 ("& is a nested package, not a compilation unit",
2075 Name
(Item
), Priv_Child
);
2079 ("unit in with clause is private child unit!", Item
);
2081 ("current unit must also have parent&!",
2082 Item
, Child_Parent
);
2085 elsif not Curr_Private
2086 and then Nkind
(Lib_Unit
) /= N_Package_Body
2087 and then Nkind
(Lib_Unit
) /= N_Subprogram_Body
2088 and then Nkind
(Lib_Unit
) /= N_Subunit
2091 ("current unit must also be private descendant of&",
2092 Item
, Child_Parent
);
2100 end Check_Private_Child_Unit
;
2102 ----------------------
2103 -- Check_Stub_Level --
2104 ----------------------
2106 procedure Check_Stub_Level
(N
: Node_Id
) is
2107 Par
: constant Node_Id
:= Parent
(N
);
2108 Kind
: constant Node_Kind
:= Nkind
(Par
);
2111 if (Kind
= N_Package_Body
2112 or else Kind
= N_Subprogram_Body
2113 or else Kind
= N_Task_Body
2114 or else Kind
= N_Protected_Body
)
2116 and then (Nkind
(Parent
(Par
)) = N_Compilation_Unit
2117 or else Nkind
(Parent
(Par
)) = N_Subunit
)
2121 -- In an instance, a missing stub appears at any level. A warning
2122 -- message will have been emitted already for the missing file.
2124 elsif not In_Instance
then
2125 Error_Msg_N
("stub cannot appear in an inner scope", N
);
2127 elsif Expander_Active
then
2128 Error_Msg_N
("missing proper body", N
);
2130 end Check_Stub_Level
;
2132 ------------------------
2133 -- Expand_With_Clause --
2134 ------------------------
2136 procedure Expand_With_Clause
(Nam
: Node_Id
; N
: Node_Id
) is
2137 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
2138 Ent
: constant Entity_Id
:= Entity
(Nam
);
2142 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
;
2144 function Build_Unit_Name
(Nam
: Node_Id
) return Node_Id
is
2148 if Nkind
(Nam
) = N_Identifier
then
2149 return New_Occurrence_Of
(Entity
(Nam
), Loc
);
2153 Make_Expanded_Name
(Loc
,
2154 Chars
=> Chars
(Entity
(Nam
)),
2155 Prefix
=> Build_Unit_Name
(Prefix
(Nam
)),
2156 Selector_Name
=> New_Occurrence_Of
(Entity
(Nam
), Loc
));
2157 Set_Entity
(Result
, Entity
(Nam
));
2160 end Build_Unit_Name
;
2163 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2165 Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
(Nam
));
2167 P
:= Parent
(Unit_Declaration_Node
(Ent
));
2168 Set_Library_Unit
(Withn
, P
);
2169 Set_Corresponding_Spec
(Withn
, Ent
);
2170 Set_First_Name
(Withn
, True);
2171 Set_Implicit_With
(Withn
, True);
2173 Prepend
(Withn
, Context_Items
(N
));
2174 Mark_Rewrite_Insertion
(Withn
);
2175 Install_Withed_Unit
(Withn
);
2177 if Nkind
(Nam
) = N_Expanded_Name
then
2178 Expand_With_Clause
(Prefix
(Nam
), N
);
2181 New_Nodes_OK
:= New_Nodes_OK
- 1;
2182 end Expand_With_Clause
;
2184 -----------------------
2185 -- Get_Parent_Entity --
2186 -----------------------
2188 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
2190 if Nkind
(Unit
) = N_Package_Instantiation
then
2191 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
2193 return Defining_Entity
(Unit
);
2195 end Get_Parent_Entity
;
2197 -----------------------------
2198 -- Implicit_With_On_Parent --
2199 -----------------------------
2201 procedure Implicit_With_On_Parent
2202 (Child_Unit
: Node_Id
;
2205 Loc
: constant Source_Ptr
:= Sloc
(N
);
2206 P
: constant Node_Id
:= Parent_Spec
(Child_Unit
);
2207 P_Unit
: constant Node_Id
:= Unit
(P
);
2209 P_Name
: Entity_Id
:= Get_Parent_Entity
(P_Unit
);
2212 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
;
2213 -- Build prefix of child unit name. Recurse if needed.
2215 function Build_Unit_Name
return Node_Id
;
2216 -- If the unit is a child unit, build qualified name with all
2219 -------------------------
2220 -- Build_Ancestor_Name --
2221 -------------------------
2223 function Build_Ancestor_Name
(P
: Node_Id
) return Node_Id
is
2224 P_Ref
: Node_Id
:= New_Reference_To
(Defining_Entity
(P
), Loc
);
2227 if No
(Parent_Spec
(P
)) then
2231 Make_Selected_Component
(Loc
,
2232 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P
))),
2233 Selector_Name
=> P_Ref
);
2235 end Build_Ancestor_Name
;
2237 ---------------------
2238 -- Build_Unit_Name --
2239 ---------------------
2241 function Build_Unit_Name
return Node_Id
is
2245 if No
(Parent_Spec
(P_Unit
)) then
2246 return New_Reference_To
(P_Name
, Loc
);
2249 Make_Expanded_Name
(Loc
,
2250 Chars
=> Chars
(P_Name
),
2251 Prefix
=> Build_Ancestor_Name
(Unit
(Parent_Spec
(P_Unit
))),
2252 Selector_Name
=> New_Reference_To
(P_Name
, Loc
));
2253 Set_Entity
(Result
, P_Name
);
2256 end Build_Unit_Name
;
2258 -- Start of processing for Implicit_With_On_Parent
2261 New_Nodes_OK
:= New_Nodes_OK
+ 1;
2262 Withn
:= Make_With_Clause
(Loc
, Name
=> Build_Unit_Name
);
2264 Set_Library_Unit
(Withn
, P
);
2265 Set_Corresponding_Spec
(Withn
, P_Name
);
2266 Set_First_Name
(Withn
, True);
2267 Set_Implicit_With
(Withn
, True);
2269 -- Node is placed at the beginning of the context items, so that
2270 -- subsequent use clauses on the parent can be validated.
2272 Prepend
(Withn
, Context_Items
(N
));
2273 Mark_Rewrite_Insertion
(Withn
);
2274 Install_Withed_Unit
(Withn
);
2276 if Is_Child_Spec
(P_Unit
) then
2277 Implicit_With_On_Parent
(P_Unit
, N
);
2279 New_Nodes_OK
:= New_Nodes_OK
- 1;
2280 end Implicit_With_On_Parent
;
2282 ---------------------
2283 -- Install_Context --
2284 ---------------------
2286 procedure Install_Context
(N
: Node_Id
) is
2287 Lib_Unit
: Node_Id
:= Unit
(N
);
2290 Install_Context_Clauses
(N
);
2292 if Is_Child_Spec
(Lib_Unit
) then
2293 Install_Parents
(Lib_Unit
, Private_Present
(Parent
(Lib_Unit
)));
2296 Check_With_Type_Clauses
(N
);
2297 end Install_Context
;
2299 -----------------------------
2300 -- Install_Context_Clauses --
2301 -----------------------------
2303 procedure Install_Context_Clauses
(N
: Node_Id
) is
2304 Lib_Unit
: Node_Id
:= Unit
(N
);
2306 Uname_Node
: Entity_Id
;
2307 Check_Private
: Boolean := False;
2308 Decl_Node
: Node_Id
;
2309 Lib_Parent
: Entity_Id
;
2312 -- Loop through context clauses to find the with/use clauses
2314 Item
:= First
(Context_Items
(N
));
2315 while Present
(Item
) loop
2317 -- Case of explicit WITH clause
2319 if Nkind
(Item
) = N_With_Clause
2320 and then not Implicit_With
(Item
)
2322 -- If Name (Item) is not an entity name, something is wrong, and
2323 -- this will be detected in due course, for now ignore the item
2325 if not Is_Entity_Name
(Name
(Item
)) then
2329 Uname_Node
:= Entity
(Name
(Item
));
2331 if Is_Private_Descendant
(Uname_Node
) then
2332 Check_Private
:= True;
2335 Install_Withed_Unit
(Item
);
2337 Decl_Node
:= Unit_Declaration_Node
(Uname_Node
);
2339 -- If the unit is a subprogram instance, it appears nested
2340 -- within a package that carries the parent information.
2342 if Is_Generic_Instance
(Uname_Node
)
2343 and then Ekind
(Uname_Node
) /= E_Package
2345 Decl_Node
:= Parent
(Parent
(Decl_Node
));
2348 if Is_Child_Spec
(Decl_Node
) then
2349 if Nkind
(Name
(Item
)) = N_Expanded_Name
then
2350 Expand_With_Clause
(Prefix
(Name
(Item
)), N
);
2352 -- if not an expanded name, the child unit must be a
2353 -- renaming, nothing to do.
2358 elsif Nkind
(Decl_Node
) = N_Subprogram_Body
2359 and then not Acts_As_Spec
(Parent
(Decl_Node
))
2360 and then Is_Child_Spec
(Unit
(Library_Unit
(Parent
(Decl_Node
))))
2362 Implicit_With_On_Parent
2363 (Unit
(Library_Unit
(Parent
(Decl_Node
))), N
);
2366 -- Check license conditions unless this is a dummy unit
2368 if Sloc
(Library_Unit
(Item
)) /= No_Location
then
2369 License_Check
: declare
2370 Withl
: constant License_Type
:=
2371 License
(Source_Index
2373 (Library_Unit
(Item
))));
2375 Unitl
: constant License_Type
:=
2376 License
(Source_Index
(Current_Sem_Unit
));
2378 procedure License_Error
;
2379 -- Signal error of bad license
2385 procedure License_Error
is
2388 ("?license of with'ed unit & is incompatible",
2392 -- Start of processing for License_Check
2405 if Withl
= Restricted
then
2409 when Modified_GPL
=>
2410 if Withl
= Restricted
or else Withl
= GPL
then
2414 when Unrestricted
=>
2420 -- Case of USE PACKAGE clause
2422 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2423 Analyze_Use_Package
(Item
);
2425 -- Case of USE TYPE clause
2427 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2428 Analyze_Use_Type
(Item
);
2430 -- Case of WITH TYPE clause
2432 -- A With_Type_Clause is processed when installing the context,
2433 -- because it is a visibility mechanism and does not create a
2434 -- semantic dependence on other units, as a With_Clause does.
2436 elsif Nkind
(Item
) = N_With_Type_Clause
then
2437 Analyze_With_Type_Clause
(Item
);
2441 elsif Nkind
(Item
) = N_Pragma
then
2449 if Is_Child_Spec
(Lib_Unit
) then
2451 -- The unit also has implicit withs on its own parents.
2453 if No
(Context_Items
(N
)) then
2454 Set_Context_Items
(N
, New_List
);
2457 Implicit_With_On_Parent
(Lib_Unit
, N
);
2460 -- If the unit is a body, the context of the specification must also
2463 if Nkind
(Lib_Unit
) = N_Package_Body
2464 or else (Nkind
(Lib_Unit
) = N_Subprogram_Body
2465 and then not Acts_As_Spec
(N
))
2467 Install_Context
(Library_Unit
(N
));
2469 if Is_Child_Spec
(Unit
(Library_Unit
(N
))) then
2471 -- If the unit is the body of a public child unit, the private
2472 -- declarations of the parent must be made visible. If the child
2473 -- unit is private, the private declarations have been installed
2474 -- already in the call to Install_Parents for the spec. Installing
2475 -- private declarations must be done for all ancestors of public
2476 -- child units. In addition, sibling units mentioned in the
2477 -- context clause of the body are directly visible.
2480 Lib_Spec
: Node_Id
:= Unit
(Library_Unit
(N
));
2485 while Is_Child_Spec
(Lib_Spec
) loop
2486 P
:= Unit
(Parent_Spec
(Lib_Spec
));
2488 if not (Private_Present
(Parent
(Lib_Spec
))) then
2489 P_Name
:= Defining_Entity
(P
);
2490 Install_Private_Declarations
(P_Name
);
2491 Set_Use
(Private_Declarations
(Specification
(P
)));
2499 -- For a package body, children in context are immediately visible
2501 Install_Siblings
(Defining_Entity
(Unit
(Library_Unit
(N
))), N
);
2504 if Nkind
(Lib_Unit
) = N_Generic_Package_Declaration
2505 or else Nkind
(Lib_Unit
) = N_Generic_Subprogram_Declaration
2506 or else Nkind
(Lib_Unit
) = N_Package_Declaration
2507 or else Nkind
(Lib_Unit
) = N_Subprogram_Declaration
2509 if Is_Child_Spec
(Lib_Unit
) then
2510 Lib_Parent
:= Defining_Entity
(Unit
(Parent_Spec
(Lib_Unit
)));
2511 Set_Is_Private_Descendant
2512 (Defining_Entity
(Lib_Unit
),
2513 Is_Private_Descendant
(Lib_Parent
)
2514 or else Private_Present
(Parent
(Lib_Unit
)));
2517 Set_Is_Private_Descendant
2518 (Defining_Entity
(Lib_Unit
),
2519 Private_Present
(Parent
(Lib_Unit
)));
2523 if Check_Private
then
2524 Check_Private_Child_Unit
(N
);
2526 end Install_Context_Clauses
;
2528 ---------------------
2529 -- Install_Parents --
2530 ---------------------
2532 procedure Install_Parents
(Lib_Unit
: Node_Id
; Is_Private
: Boolean) is
2539 P
:= Unit
(Parent_Spec
(Lib_Unit
));
2540 P_Name
:= Get_Parent_Entity
(P
);
2542 if Etype
(P_Name
) = Any_Type
then
2546 if Ekind
(P_Name
) = E_Generic_Package
2547 and then Nkind
(Lib_Unit
) /= N_Generic_Subprogram_Declaration
2548 and then Nkind
(Lib_Unit
) /= N_Generic_Package_Declaration
2549 and then Nkind
(Lib_Unit
) not in N_Generic_Renaming_Declaration
2552 ("child of a generic package must be a generic unit", Lib_Unit
);
2554 elsif not Is_Package
(P_Name
) then
2556 ("parent unit must be package or generic package", Lib_Unit
);
2557 raise Unrecoverable_Error
;
2559 elsif Present
(Renamed_Object
(P_Name
)) then
2560 Error_Msg_N
("parent unit cannot be a renaming", Lib_Unit
);
2561 raise Unrecoverable_Error
;
2563 -- Verify that a child of an instance is itself an instance, or
2564 -- the renaming of one. Given that an instance that is a unit is
2565 -- replaced with a package declaration, check against the original
2568 elsif Nkind
(Original_Node
(P
)) = N_Package_Instantiation
2569 and then Nkind
(Lib_Unit
)
2570 not in N_Renaming_Declaration
2571 and then Nkind
(Original_Node
(Lib_Unit
))
2572 not in N_Generic_Instantiation
2575 ("child of an instance must be an instance or renaming", Lib_Unit
);
2578 -- This is the recursive call that ensures all parents are loaded
2580 if Is_Child_Spec
(P
) then
2582 Is_Private
or else Private_Present
(Parent
(Lib_Unit
)));
2585 -- Now we can install the context for this parent
2587 Install_Context_Clauses
(Parent_Spec
(Lib_Unit
));
2588 Install_Siblings
(P_Name
, Parent
(Lib_Unit
));
2590 -- The child unit is in the declarative region of the parent. The
2591 -- parent must therefore appear in the scope stack and be visible,
2592 -- as when compiling the corresponding body. If the child unit is
2593 -- private or it is a package body, private declarations must be
2594 -- accessible as well. Use declarations in the parent must also
2595 -- be installed. Finally, other child units of the same parent that
2596 -- are in the context are immediately visible.
2598 -- Find entity for compilation unit, and set its private descendant
2599 -- status as needed.
2601 E_Name
:= Defining_Entity
(Lib_Unit
);
2603 Set_Is_Child_Unit
(E_Name
);
2605 Set_Is_Private_Descendant
(E_Name
,
2606 Is_Private_Descendant
(P_Name
)
2607 or else Private_Present
(Parent
(Lib_Unit
)));
2609 P_Spec
:= Specification
(Unit_Declaration_Node
(P_Name
));
2612 -- Save current visibility of unit
2614 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
:=
2615 Is_Immediately_Visible
(P_Name
);
2616 Set_Is_Immediately_Visible
(P_Name
);
2617 Install_Visible_Declarations
(P_Name
);
2618 Set_Use
(Visible_Declarations
(P_Spec
));
2621 or else Private_Present
(Parent
(Lib_Unit
))
2623 Install_Private_Declarations
(P_Name
);
2624 Set_Use
(Private_Declarations
(P_Spec
));
2626 end Install_Parents
;
2628 ----------------------
2629 -- Install_Siblings --
2630 ----------------------
2632 procedure Install_Siblings
(U_Name
: Entity_Id
; N
: Node_Id
) is
2637 function Is_Ancestor
(E
: Entity_Id
) return Boolean;
2638 -- Determine whether the scope of a child unit is an ancestor of
2639 -- the current unit.
2640 -- Shouldn't this be somewhere more general ???
2642 function Is_Ancestor
(E
: Entity_Id
) return Boolean is
2649 and then Par
/= Standard_Standard
2662 -- Start of processing for Install_Siblings
2665 -- Iterate over explicit with clauses, and check whether the
2666 -- scope of each entity is an ancestor of the current unit.
2668 Item
:= First
(Context_Items
(N
));
2670 while Present
(Item
) loop
2672 if Nkind
(Item
) = N_With_Clause
2673 and then not Implicit_With
(Item
)
2675 Id
:= Entity
(Name
(Item
));
2677 if Is_Child_Unit
(Id
)
2678 and then Is_Ancestor
(Scope
(Id
))
2680 Set_Is_Immediately_Visible
(Id
);
2681 Prev
:= Current_Entity
(Id
);
2683 -- Check for the presence of another unit in the context,
2684 -- that may be inadvertently hidden by the child.
2687 and then Is_Immediately_Visible
(Prev
)
2688 and then not Is_Child_Unit
(Prev
)
2694 Clause
:= First
(Context_Items
(N
));
2696 while Present
(Clause
) loop
2697 if Nkind
(Clause
) = N_With_Clause
2698 and then Entity
(Name
(Clause
)) = Prev
2701 ("child unit& hides compilation unit " &
2702 "with the same name?",
2712 -- the With_Clause may be on a grand-child, which makes
2713 -- the child immediately visible.
2715 elsif Is_Child_Unit
(Scope
(Id
))
2716 and then Is_Ancestor
(Scope
(Scope
(Id
)))
2718 Set_Is_Immediately_Visible
(Scope
(Id
));
2724 end Install_Siblings
;
2726 -------------------------
2727 -- Install_Withed_Unit --
2728 -------------------------
2730 procedure Install_Withed_Unit
(With_Clause
: Node_Id
) is
2731 Uname
: Entity_Id
:= Entity
(Name
(With_Clause
));
2732 P
: constant Entity_Id
:= Scope
(Uname
);
2735 -- We do not apply the restrictions to an internal unit unless
2736 -- we are compiling the internal unit as a main unit. This check
2737 -- is also skipped for dummy units (for missing packages).
2739 if Sloc
(Uname
) /= No_Location
2740 and then (not Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
2741 or else Current_Sem_Unit
= Main_Unit
)
2743 Check_Restricted_Unit
2744 (Unit_Name
(Get_Source_Unit
(Uname
)), With_Clause
);
2747 if P
/= Standard_Standard
then
2749 -- If the unit is not analyzed after analysis of the with clause,
2750 -- and it is an instantiation, then it awaits a body and is the main
2751 -- unit. Its appearance in the context of some other unit indicates
2752 -- a circular dependency (DEC suite perversity).
2754 if not Analyzed
(Uname
)
2755 and then Nkind
(Parent
(Uname
)) = N_Package_Instantiation
2758 ("instantiation depends on itself", Name
(With_Clause
));
2760 elsif not Is_Visible_Child_Unit
(Uname
) then
2761 Set_Is_Visible_Child_Unit
(Uname
);
2763 if Is_Generic_Instance
(Uname
)
2764 and then Ekind
(Uname
) in Subprogram_Kind
2766 -- Set flag as well on the visible entity that denotes the
2767 -- instance, which renames the current one.
2769 Set_Is_Visible_Child_Unit
2771 (Defining_Entity
(Unit
(Library_Unit
(With_Clause
)))));
2775 -- The parent unit may have been installed already, and
2776 -- may have appeared in a use clause.
2778 if In_Use
(Scope
(Uname
)) then
2779 Set_Is_Potentially_Use_Visible
(Uname
);
2782 Set_Context_Installed
(With_Clause
);
2785 elsif not Is_Immediately_Visible
(Uname
) then
2786 Set_Is_Immediately_Visible
(Uname
);
2787 Set_Context_Installed
(With_Clause
);
2790 -- A with-clause overrides a with-type clause: there are no restric-
2791 -- tions on the use of package entities.
2793 if Ekind
(Uname
) = E_Package
then
2794 Set_From_With_Type
(Uname
, False);
2796 end Install_Withed_Unit
;
2802 function Is_Child_Spec
(Lib_Unit
: Node_Id
) return Boolean is
2803 K
: constant Node_Kind
:= Nkind
(Lib_Unit
);
2806 return (K
in N_Generic_Declaration
or else
2807 K
in N_Generic_Instantiation
or else
2808 K
in N_Generic_Renaming_Declaration
or else
2809 K
= N_Package_Declaration
or else
2810 K
= N_Package_Renaming_Declaration
or else
2811 K
= N_Subprogram_Declaration
or else
2812 K
= N_Subprogram_Renaming_Declaration
)
2813 and then Present
(Parent_Spec
(Lib_Unit
));
2816 -----------------------
2817 -- Load_Needed_Body --
2818 -----------------------
2820 -- N is a generic unit named in a with clause, or else it is
2821 -- a unit that contains a generic unit or an inlined function.
2822 -- In order to perform an instantiation, the body of the unit
2823 -- must be present. If the unit itself is generic, we assume
2824 -- that an instantiation follows, and load and analyze the body
2825 -- unconditionally. This forces analysis of the spec as well.
2827 -- If the unit is not generic, but contains a generic unit, it
2828 -- is loaded on demand, at the point of instantiation (see ch12).
2830 procedure Load_Needed_Body
(N
: Node_Id
; OK
: out Boolean) is
2831 Body_Name
: Unit_Name_Type
;
2832 Unum
: Unit_Number_Type
;
2834 Save_Style_Check
: constant Boolean := Opt
.Style_Check
;
2835 -- The loading and analysis is done with style checks off
2838 if not GNAT_Mode
then
2839 Style_Check
:= False;
2842 Body_Name
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2845 (Load_Name
=> Body_Name
,
2851 if Unum
= No_Unit
then
2855 Compiler_State
:= Analyzing
; -- reset after load
2857 if not Fatal_Error
(Unum
) then
2858 if Debug_Flag_L
then
2859 Write_Str
("*** Loaded generic body");
2863 Semantics
(Cunit
(Unum
));
2869 Style_Check
:= Save_Style_Check
;
2870 end Load_Needed_Body
;
2872 --------------------
2873 -- Remove_Context --
2874 --------------------
2876 procedure Remove_Context
(N
: Node_Id
) is
2877 Lib_Unit
: constant Node_Id
:= Unit
(N
);
2880 -- If this is a child unit, first remove the parent units.
2882 if Is_Child_Spec
(Lib_Unit
) then
2883 Remove_Parents
(Lib_Unit
);
2886 Remove_Context_Clauses
(N
);
2889 ----------------------------
2890 -- Remove_Context_Clauses --
2891 ----------------------------
2893 procedure Remove_Context_Clauses
(N
: Node_Id
) is
2895 Unit_Name
: Entity_Id
;
2899 -- Loop through context items and undo with_clauses and use_clauses.
2901 Item
:= First
(Context_Items
(N
));
2903 while Present
(Item
) loop
2905 -- We are interested only in with clauses which got installed
2906 -- on entry, as indicated by their Context_Installed flag set
2908 if Nkind
(Item
) = N_With_Clause
2909 and then Context_Installed
(Item
)
2911 -- Remove items from one with'ed unit
2913 Unit_Name
:= Entity
(Name
(Item
));
2914 Remove_Unit_From_Visibility
(Unit_Name
);
2915 Set_Context_Installed
(Item
, False);
2917 elsif Nkind
(Item
) = N_Use_Package_Clause
then
2918 End_Use_Package
(Item
);
2920 elsif Nkind
(Item
) = N_Use_Type_Clause
then
2921 End_Use_Type
(Item
);
2923 elsif Nkind
(Item
) = N_With_Type_Clause
then
2924 Remove_With_Type_Clause
(Name
(Item
));
2930 end Remove_Context_Clauses
;
2932 --------------------
2933 -- Remove_Parents --
2934 --------------------
2936 procedure Remove_Parents
(Lib_Unit
: Node_Id
) is
2940 Vis
: constant Boolean :=
2941 Scope_Stack
.Table
(Scope_Stack
.Last
).Previous_Visibility
;
2944 if Is_Child_Spec
(Lib_Unit
) then
2945 P
:= Unit
(Parent_Spec
(Lib_Unit
));
2946 P_Name
:= Defining_Entity
(P
);
2948 Remove_Context_Clauses
(Parent_Spec
(Lib_Unit
));
2949 End_Package_Scope
(P_Name
);
2950 Set_Is_Immediately_Visible
(P_Name
, Vis
);
2952 -- Remove from visibility the siblings as well, which are directly
2953 -- visible while the parent is in scope.
2955 E
:= First_Entity
(P_Name
);
2957 while Present
(E
) loop
2959 if Is_Child_Unit
(E
) then
2960 Set_Is_Immediately_Visible
(E
, False);
2966 Set_In_Package_Body
(P_Name
, False);
2968 -- This is the recursive call to remove the context of any
2969 -- higher level parent. This recursion ensures that all parents
2970 -- are removed in the reverse order of their installation.
2976 -----------------------------
2977 -- Remove_With_Type_Clause --
2978 -----------------------------
2980 procedure Remove_With_Type_Clause
(Name
: Node_Id
) is
2984 procedure Unchain
(E
: Entity_Id
);
2985 -- Remove entity from visibility list.
2987 procedure Unchain
(E
: Entity_Id
) is
2991 Prev
:= Current_Entity
(E
);
2993 -- Package entity may appear is several with_type_clauses, and
2994 -- may have been removed already.
3000 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
3003 while Present
(Prev
)
3004 and then Homonym
(Prev
) /= E
3006 Prev
:= Homonym
(Prev
);
3009 if (Present
(Prev
)) then
3010 Set_Homonym
(Prev
, Homonym
(E
));
3016 if Nkind
(Name
) = N_Selected_Component
then
3017 Typ
:= Entity
(Selector_Name
(Name
));
3019 if No
(Typ
) then -- error in declaration.
3028 -- If the exporting package has been analyzed, it has appeared in the
3029 -- context already and should be left alone. Otherwise, remove from
3032 if not Analyzed
(Unit_Declaration_Node
(P
)) then
3035 Set_Is_Frozen
(Typ
, False);
3038 if Ekind
(Typ
) = E_Record_Type
then
3039 Set_From_With_Type
(Class_Wide_Type
(Typ
), False);
3040 Set_From_With_Type
(Typ
, False);
3043 Set_From_With_Type
(P
, False);
3045 -- If P is a child unit, remove parents as well.
3050 and then P
/= Standard_Standard
3052 Set_From_With_Type
(P
, False);
3054 if not Analyzed
(Unit_Declaration_Node
(P
)) then
3061 -- The back-end needs to know that an access type is imported, so it
3062 -- does not need elaboration and can appear in a mutually recursive
3063 -- record definition, so the imported flag on an access type is
3066 end Remove_With_Type_Clause
;
3068 ---------------------------------
3069 -- Remove_Unit_From_Visibility --
3070 ---------------------------------
3072 procedure Remove_Unit_From_Visibility
(Unit_Name
: Entity_Id
) is
3073 P
: Entity_Id
:= Scope
(Unit_Name
);
3077 if Debug_Flag_I
then
3078 Write_Str
("remove withed unit ");
3079 Write_Name
(Chars
(Unit_Name
));
3083 if P
/= Standard_Standard
then
3084 Set_Is_Visible_Child_Unit
(Unit_Name
, False);
3087 Set_Is_Potentially_Use_Visible
(Unit_Name
, False);
3088 Set_Is_Immediately_Visible
(Unit_Name
, False);
3090 end Remove_Unit_From_Visibility
;