-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
+with Elists; use Elists;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
procedure Build_Limited_Views (N : Node_Id);
-- Build and decorate the list of shadow entities for a package mentioned
-- in a limited_with clause. If the package was not previously analyzed
- -- then it also performs a basic decoration of the real entities; this
- -- is required to do not pass non-decorated entities to the back-end.
+ -- then it also performs a basic decoration of the real entities. This is
+ -- required to do not pass non-decorated entities to the back-end.
-- Implements Ada 2005 (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
- -- Check whether the source for the body of a compilation unit must
- -- be included in a standalone library.
+ -- Check whether the source for the body of a compilation unit must be
+ -- included in a standalone library.
procedure Check_Private_Child_Unit (N : Node_Id);
- -- If a with_clause mentions a private child unit, the compilation
- -- unit must be a member of the same family, as described in 10.1.2 (8).
+ -- If a with_clause mentions a private child unit, the compilation unit
+ -- must be a member of the same family, as described in 10.1.2.
procedure Check_Stub_Level (N : Node_Id);
-- Verify that a stub is declared immediately within a compilation unit,
-- has not yet been rewritten as a package declaration, and the entity has
-- to be retrieved from the Instance_Spec of the unit.
+ function Has_With_Clause
+ (C_Unit : Node_Id;
+ Pack : Entity_Id;
+ Is_Limited : Boolean := False) return Boolean;
+ -- Determine whether compilation unit C_Unit contains a [limited] with
+ -- clause for package Pack. Use the flag Is_Limited to designate desired
+ -- clause kind.
+
procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
-- If the main unit is a child unit, implicit withs are also added for
-- all its ancestors.
-- example through a limited_with clause in a parent unit.
procedure Install_Context_Clauses (N : Node_Id);
- -- Subsidiary to Install_Context and Install_Parents. Process only with_
- -- and use_clauses for current unit and its library unit if any.
+ -- Subsidiary to Install_Context and Install_Parents. Process all with
+ -- and use clauses for current unit and its library unit if any.
procedure Install_Limited_Context_Clauses (N : Node_Id);
- -- Subsidiary to Install_Context. Process only limited with_clauses
- -- for current unit. Implements Ada 2005 (AI-50217).
+ -- Subsidiary to Install_Context. Process only limited with_clauses for
+ -- current unit. Implements Ada 2005 (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
procedure Install_Withed_Unit
(With_Clause : Node_Id;
Private_With_OK : Boolean := False);
- -- If the unit is not a child unit, make unit immediately visible.
- -- The caller ensures that the unit is not already currently installed.
- -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
- -- which is called when compiling the private part of a package, or
- -- installing the private declarations of a parent unit.
+ -- If the unit is not a child unit, make unit immediately visible. The
+ -- caller ensures that the unit is not already currently installed. The
+ -- flag Private_With_OK is set true in Install_Private_With_Clauses, which
+ -- is called when compiling the private part of a package, or installing
+ -- the private declarations of a parent unit.
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
-- This procedure establishes the context for the compilation of a child
-- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
-- compilation unit for the parent spec.
--
- -- Lib_Unit can also be a subprogram body that acts as its own spec. If
- -- the Parent_Spec is non-empty, this is also a child unit.
+ -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
+ -- Parent_Spec is non-empty, this is also a child unit.
procedure Remove_Context_Clauses (N : Node_Id);
-- Subsidiary of previous one. Remove use_ and with_clauses
-- that all parents are removed in the nested case.
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
- -- Reset all visibility flags on unit after compiling it, either as a
- -- main unit or as a unit in the context.
+ -- Reset all visibility flags on unit after compiling it, either as a main
+ -- unit or as a unit in the context.
procedure Unchain (E : Entity_Id);
-- Remove single entity from visibility list
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
- -- protected cases). N is the stub to be analyzed. Once the subunit
- -- name is established, load and analyze. Nam is the non-overloadable
- -- entity for which the proper body provides a completion. Subprogram
- -- stubs are handled differently because they can be declarations.
+ -- protected cases). N is the stub to be analyzed. Once the subunit name
+ -- is established, load and analyze. Nam is the non-overloadable entity
+ -- for which the proper body provides a completion. Subprogram stubs are
+ -- handled differently because they can be declarations.
procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the
-- Limited_With_Clauses --
--------------------------
- -- Limited_With clauses are the mechanism chosen for Ada05 to support
+ -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
-- mutually recursive types declared in different units. A limited_with
-- clause that names package P in the context of unit U makes the types
-- declared in the visible part of P available within U, but with the
-- To support this feature, the analysis of a limited_with clause must
-- create an abbreviated view of the package, without performing any
- -- semantic analysis on it. This "package abstract" contains shadow
- -- types that are in one-one correspondence with the real types in the
- -- package, and that have the properties of incomplete types.
+ -- semantic analysis on it. This "package abstract" contains shadow types
+ -- that are in one-one correspondence with the real types in the package,
+ -- and that have the properties of incomplete types.
-- The implementation creates two element lists: one to chain the shadow
-- entities, and one to chain the corresponding type entities in the tree
Clause : Node_Id;
Used : in out Boolean;
Used_Type_Or_Elab : in out Boolean);
- -- Examine the context clauses of a package body, trying to match
- -- the name entity of Clause with any list element. If the match
- -- occurs on a use package clause, set Used to True, for a use
- -- type clause, pragma Elaborate or pragma Elaborate_All, set
- -- Used_Type_Or_Elab to True.
+ -- Examine the context clauses of a package body, trying to match the
+ -- name entity of Clause with any list element. If the match occurs
+ -- on a use package clause set Used to True, for a use type clause or
+ -- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
procedure Process_Spec_Clauses
(Context_List : List_Id;
Use_Item : Node_Id;
function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
- -- In an expanded name in a use clause, if the prefix is a
- -- renamed package, the entity is set to the original package
- -- as a result, when checking whether the package appears in a
- -- previous with_clause, the renaming has to be taken into
- -- account, to prevent spurious or incorrect warnings. The
- -- common case is the use of Text_IO.
+ -- In an expanded name in a use clause, if the prefix is a renamed
+ -- package, the entity is set to the original package as a result,
+ -- when checking whether the package appears in a previous with
+ -- clause, the renaming has to be taken into account, to prevent
+ -- spurious/incorrect warnings. A common case is use of Text_IO.
---------------
-- Same_Unit --
elsif Nkind (Cont_Item) = N_Pragma
and then
- (Chars (Cont_Item) = Name_Elaborate
+ (Pragma_Name (Cont_Item) = Name_Elaborate
or else
- Chars (Cont_Item) = Name_Elaborate_All)
+ Pragma_Name (Cont_Item) = Name_Elaborate_All)
and then not Used_Type_Or_Elab
then
Prag_Unit :=
Cont_Item := First (Context_List);
while Present (Cont_Item) loop
- -- Stop the search since the context items after Cont_Item
- -- have already been examined in a previous iteration of
- -- the reverse loop in Check_Redundant_Withs.
+ -- Stop the search since the context items after Cont_Item have
+ -- already been examined in a previous iteration of the reverse
+ -- loop in Check_Redundant_Withs.
if Exit_On_Self
and Cont_Item = Clause
end loop;
-- Package with clause. Avoid processing self, implicitly
- -- generated with clauses or limited with clauses. Note
- -- that we examine with clauses having pragmas Elaborate
- -- or Elaborate_All applied to them due to cases such as:
- --
+ -- generated with clauses or limited with clauses. Note that
+ -- we examine with clauses having pragmas Elaborate or
+ -- Elaborate_All applied to them due to cases such as:
+
-- with Pack;
-- with Pack;
-- pragma Elaborate (Pack);
Clause := Last (Context_Items);
while Present (Clause) loop
- -- Avoid checking implicitly generated with clauses, limited
- -- with clauses or withs that have pragma Elaborate or
- -- Elaborate_All apllied.
+ -- Avoid checking implicitly generated with clauses, limited with
+ -- clauses or withs that have pragma Elaborate or Elaborate_All.
if Nkind (Clause) = N_With_Clause
and then not Implicit_With (Clause)
or else
Used_In_Spec)
then
- Error_Msg_N ("?redundant with clause in body", Clause);
+ Error_Msg_N -- CODEFIX
+ ("?redundant with clause in body", Clause);
end if;
Used_In_Body := False;
Exit_On_Self => True);
if Withed then
- Error_Msg_N ("?redundant with clause", Clause);
+ Error_Msg_N -- CODEFIX
+ ("?redundant with clause", Clause);
end if;
end;
end if;
-- analysis of the parent, which we proceed to do. Basically this gets
-- handled from the top down and we don't want to do anything at this
-- level (i.e. this subunit will be handled on the way down from the
- -- parent), so at this level we immediately return. If the subunit
- -- ends up not analyzed, it means that the parent did not contain a
- -- stub for it, or that there errors were dectected in some ancestor.
+ -- parent), so at this level we immediately return. If the subunit ends
+ -- up not analyzed, it means that the parent did not contain a stub for
+ -- it, or that there errors were detected in some ancestor.
- if Nkind (Unit_Node) = N_Subunit
- and then not Analyzed (Lib_Unit)
- then
+ if Nkind (Unit_Node) = N_Subunit and then not Analyzed (Lib_Unit) then
Semantics (Lib_Unit);
if not Analyzed (Proper_Body (Unit_Node)) then
return;
end if;
- -- Analyze context (this will call Sem recursively for with'ed units)
+ -- Analyze context (this will call Sem recursively for with'ed units) To
+ -- detect circularities among with-clauses that are not caught during
+ -- loading, we set the Context_Pending flag on the current unit. If the
+ -- flag is already set there is a potential circularity. We exclude
+ -- predefined units from this check because they are known to be safe.
+ -- We also exclude package bodies that are present because circularities
+ -- between bodies are harmless (and necessary).
+
+ if Context_Pending (N) then
+ declare
+ Circularity : Boolean := True;
+
+ begin
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Unit (N))))
+ then
+ Circularity := False;
+
+ else
+ for U in Main_Unit + 1 .. Last_Unit loop
+ if Nkind (Unit (Cunit (U))) = N_Package_Body
+ and then not Analyzed (Cunit (U))
+ then
+ Circularity := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Circularity then
+ Error_Msg_N ("circular dependency caused by with_clauses", N);
+ Error_Msg_N
+ ("\possibly missing limited_with clause"
+ & " in one of the following", N);
+
+ for U in Main_Unit .. Last_Unit loop
+ if Context_Pending (Cunit (U)) then
+ Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U)));
+ Error_Msg_N ("\unit$", N);
+ end if;
+ end loop;
+
+ raise Unrecoverable_Error;
+ end if;
+ end;
+ else
+ Set_Context_Pending (N);
+ end if;
Analyze_Context (N);
- -- If the unit is a package body, the spec is already loaded and must
- -- be analyzed first, before we analyze the body.
+ Set_Context_Pending (N, False);
+
+ -- If the unit is a package body, the spec is already loaded and must be
+ -- analyzed first, before we analyze the body.
if Nkind (Unit_Node) = N_Package_Body then
- -- If no Lib_Unit, then there was a serious previous error, so
- -- just ignore the entire analysis effort
+ -- If no Lib_Unit, then there was a serious previous error, so just
+ -- ignore the entire analysis effort
if No (Lib_Unit) then
return;
else
+ -- Analyze the package spec
+
Semantics (Lib_Unit);
+
+ -- Check for unused with's
+
Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
-- Verify that the library unit is a package declaration
- if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
- and then
- Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
+ if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration,
+ N_Generic_Package_Declaration)
then
Error_Msg_N
("no legal package declaration for package body", N);
return;
- -- Otherwise, the entity in the declaration is visible. Update
- -- the version to reflect dependence of this body on the spec.
+ -- Otherwise, the entity in the declaration is visible. Update the
+ -- version to reflect dependence of this body on the spec.
else
Spec_Id := Defining_Entity (Unit (Lib_Unit));
Set_Is_Immediately_Visible (Spec_Id, True);
Version_Update (N, Lib_Unit);
- if Nkind (Defining_Unit_Name (Unit_Node))
- = N_Defining_Program_Unit_Name
+ if Nkind (Defining_Unit_Name (Unit_Node)) =
+ N_Defining_Program_Unit_Name
then
Generate_Parent_References (Unit_Node, Scope (Spec_Id));
end if;
-- If the unit is a subprogram body, then we similarly need to analyze
-- its spec. However, things are a little simpler in this case, because
- -- here, this analysis is done only for error checking and consistency
- -- purposes, so there's nothing else to be done.
+ -- here, this analysis is done mostly for error checking and consistency
+ -- purposes (but not only, e.g. there could be a contract on the spec),
+ -- so there's nothing else to be done.
elsif Nkind (Unit_Node) = N_Subprogram_Body then
if Acts_As_Spec (N) then
-- it, and this must be indicated explicitly. We also mark
-- the body entity as a child unit now, to prevent a
-- cascaded error if the spec entity cannot be entered
- -- in its scope.
+ -- in its scope. Finally we create a Units table entry for
+ -- the subprogram declaration, to maintain a one-to-one
+ -- correspondence with compilation unit nodes. This is
+ -- critical for the tree traversals performed by CodePeer.
declare
Loc : constant Source_Ptr := Sloc (N);
begin
Set_Comes_From_Source_Default (False);
+
+ -- Checks for redundant USE TYPE clauses have a special
+ -- exception for the synthetic spec we create here. This
+ -- special case relies on the two compilation units
+ -- sharing the same context clause.
+
+ -- Note: We used to do a shallow copy (New_Copy_List),
+ -- which defeated those checks and also created malformed
+ -- trees (subtype mark shared by two distinct
+ -- N_Use_Type_Clause nodes) which crashed the compiler.
+
Lib_Unit :=
Make_Compilation_Unit (Loc,
- Context_Items => New_Copy_List (Context_Items (N)),
+ Context_Items => Context_Items (N),
Unit =>
Make_Subprogram_Declaration (Sloc (N),
Specification =>
Set_Library_Unit (N, Lib_Unit);
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
+ Make_Child_Decl_Unit (N);
Semantics (Lib_Unit);
-- Now that a separate declaration exists, the body
Set_Acts_As_Spec (N, False);
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
- Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
+ Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
end;
end if;
Version_Update (N, Lib_Unit);
end if;
+ -- If this is a child unit, generate references to the parents
+
if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
N_Defining_Program_Unit_Name
then
end if;
end if;
- -- If it is a child unit, the parent must be elaborated first
- -- and we update version, since we are dependent on our parent.
+ -- If it is a child unit, the parent must be elaborated first and we
+ -- update version, since we are dependent on our parent.
if Is_Child_Spec (Unit_Node) then
declare
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
begin
if not GNAT_Mode then
Semantics (Parent_Spec (Unit_Node));
Version_Update (N, Parent_Spec (Unit_Node));
+
+ -- Restore style check settings
+
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
Add_Stub_Constructs (N);
end if;
-
end if;
- -- Remove unit from visibility, so that environment is clean for
- -- the next compilation, which is either the main unit or some
- -- other unit in the context.
+ -- Remove unit from visibility, so that environment is clean for the
+ -- next compilation, which is either the main unit or some other unit
+ -- in the context.
- if Nkind (Unit_Node) = N_Package_Declaration
+ if Nkind_In (Unit_Node, N_Package_Declaration,
+ N_Package_Renaming_Declaration,
+ N_Subprogram_Declaration)
or else Nkind (Unit_Node) in N_Generic_Declaration
- or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
- or else Nkind (Unit_Node) = N_Subprogram_Declaration
or else
(Nkind (Unit_Node) = N_Subprogram_Body
and then Acts_As_Spec (Unit_Node))
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
-- If the unit is an instantiation whose body will be elaborated for
- -- inlining purposes, use the the proper entity of the instance. The
- -- entity may be missing if the instantiation was illegal.
+ -- inlining purposes, use the proper entity of the instance. The entity
+ -- may be missing if the instantiation was illegal.
elsif Nkind (Unit_Node) = N_Package_Instantiation
and then not Error_Posted (Unit_Node)
Un : Unit_Number_Type;
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
begin
Item := First (Context_Items (N));
then
Nam := Entity (Name (Item));
+ -- Compile generic subprogram, unless it is intrinsic or
+ -- imported so no body is required, or generic package body
+ -- if the package spec requires a body.
+
if (Is_Generic_Subprogram (Nam)
- and then not Is_Intrinsic_Subprogram (Nam))
+ and then not Is_Intrinsic_Subprogram (Nam)
+ and then not Is_Imported (Nam))
or else (Ekind (Nam) = E_Generic_Package
and then Unit_Requires_Body (Nam))
then
Next (Item);
end loop;
+ -- Restore style checks settings
+
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
-- units manufactured by the compiler never need elab checks.
if Comes_From_Source (N)
- and then
- (Nkind (Unit_Node) = N_Package_Declaration or else
- Nkind (Unit_Node) = N_Generic_Package_Declaration or else
- Nkind (Unit_Node) = N_Subprogram_Declaration or else
- Nkind (Unit_Node) = N_Generic_Subprogram_Declaration)
+ and then Nkind_In (Unit_Node, N_Package_Declaration,
+ N_Generic_Package_Declaration,
+ N_Subprogram_Declaration,
+ N_Generic_Subprogram_Declaration)
then
declare
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
begin
-- Case of units which do not require elaboration checks
if
- -- Pure units do not need checks
+ -- Pure units do not need checks
- Is_Pure (Spec_Id)
+ Is_Pure (Spec_Id)
- -- Preelaborated units do not need checks
+ -- Preelaborated units do not need checks
- or else Is_Preelaborated (Spec_Id)
+ or else Is_Preelaborated (Spec_Id)
- -- No checks needed if pagma Elaborate_Body present
+ -- No checks needed if pragma Elaborate_Body present
- or else Has_Pragma_Elaborate_Body (Spec_Id)
+ or else Has_Pragma_Elaborate_Body (Spec_Id)
- -- No checks needed if unit does not require a body
+ -- No checks needed if unit does not require a body
- or else not Unit_Requires_Body (Spec_Id)
+ or else not Unit_Requires_Body (Spec_Id)
- -- No checks needed for predefined files
+ -- No checks needed for predefined files
- or else Is_Predefined_File_Name (Unit_File_Name (Unum))
+ or else Is_Predefined_File_Name (Unit_File_Name (Unum))
- -- No checks required if no separate spec
+ -- No checks required if no separate spec
- or else Acts_As_Spec (N)
+ or else Acts_As_Spec (N)
then
-- This is a case where we only need the entity for
-- checking to prevent multiple elaboration checks.
-- compilation unit actions list, and analyze them.
declare
- Loc : constant Source_Ptr := Sloc (N);
- L : constant List_Id :=
- Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
+ L : constant List_Id :=
+ Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N);
begin
while Is_Non_Empty_List (L) loop
Insert_Library_Level_Action (Remove_Head (L));
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Chars (Item) in Configuration_Pragma_Names
+ and then Pragma_Name (Item) in Configuration_Pragma_Names
loop
Analyze (Item);
Next (Item);
end loop;
+ -- This is the point at which we capture the configuration settings
+ -- for the unit. At the moment only the Optimize_Alignment setting
+ -- needs to be captured. Probably more later ???
+
+ if Optimize_Alignment_Local then
+ Set_OA_Setting (Current_Sem_Unit, 'L');
+ else
+ Set_OA_Setting (Current_Sem_Unit, Optimize_Alignment);
+ end if;
+
-- Loop through actual context items. This is done in two passes:
-- a) The first pass analyzes non-limited with-clauses and also any
while Present (Item) loop
- -- For with clause, analyze the with clause, and then update
- -- the version, since we are dependent on a unit that we with.
+ -- For with clause, analyze the with clause, and then update the
+ -- version, since we are dependent on a unit that we with.
if Nkind (Item) = N_With_Clause
and then not Limited_Present (Item)
then
-- Skip analyzing with clause if no unit, nothing to do (this
- -- happens for a with that references a non-existant unit)
+ -- happens for a with that references a non-existent unit). Skip
+ -- as well if this is a with_clause for the main unit, which
+ -- happens if a subunit has a useless with_clause on its parent.
if Present (Library_Unit (Item)) then
- Analyze (Item);
+ if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then
+ Analyze (Item);
+
+ else
+ Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit));
+ end if;
end if;
if not Implicit_With (Item) then
-- the implicit with's on parent units.
-- Skip use clauses at this stage, since we don't want to do any
- -- installing of potentially use visible entities until we we
+ -- installing of potentially use-visible entities until we
-- actually install the complete context (in Install_Context).
-- Otherwise things can get installed in the wrong context.
if not Implicit_With (Item) then
- -- Check compilation unit containing the limited-with clause
+ -- Verify that the illegal contexts given in 10.1.2 (18/2) are
+ -- properly rejected, including renaming declarations.
- if Ukind /= N_Package_Declaration
- and then Ukind /= N_Subprogram_Declaration
- and then Ukind /= N_Package_Renaming_Declaration
- and then Ukind /= N_Subprogram_Renaming_Declaration
+ if not Nkind_In (Ukind, N_Package_Declaration,
+ N_Subprogram_Declaration)
and then Ukind not in N_Generic_Declaration
- and then Ukind not in N_Generic_Renaming_Declaration
and then Ukind not in N_Generic_Instantiation
then
Error_Msg_N ("limited with_clause not allowed here", Item);
P := Parent_Spec (Unit (N));
loop
if Unit (P) = Lib_U then
- Error_Msg_N ("limited with_clause of immediate "
- & "ancestor not allowed", Item);
+ Error_Msg_N ("limited with_clause cannot "
+ & "name ancestor", Item);
exit;
end if;
and then Nkind (It) = N_With_Clause
and then not Limited_Present (It)
and then
- (Nkind (Unit (Library_Unit (It)))
- = N_Package_Declaration
- or else
- Nkind (Unit (Library_Unit (It)))
- = N_Package_Renaming_Declaration)
+ Nkind_In (Unit (Library_Unit (It)),
+ N_Package_Declaration,
+ N_Package_Renaming_Declaration)
then
- if Nkind (Unit (Library_Unit (It)))
- = N_Package_Declaration
+ if Nkind (Unit (Library_Unit (It))) =
+ N_Package_Declaration
then
Unit_Name := Name (It);
else
-------------------------
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
- Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
- Unum : Unit_Number_Type;
+ Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
+ Unum : Unit_Number_Type;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
Comp_Unit : Node_Id;
begin
- -- Try to load subunit, but ignore any errors that occur during
- -- the loading of the subunit, by using the special feature in
- -- Errout to ignore all errors. Note that Fatal_Error will still
- -- be set, so we will be able to check for this case below.
+ -- Try to load subunit, but ignore any errors that occur during the
+ -- loading of the subunit, by using the special feature in Errout to
+ -- ignore all errors. Note that Fatal_Error will still be set, so we
+ -- will be able to check for this case below.
if not ASIS_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
then
Comp_Unit := Cunit (Unum);
- -- If the file was empty or seriously mangled, the unit
- -- itself may be missing.
+ -- If the file was empty or seriously mangled, the unit itself may
+ -- be missing.
if No (Unit (Comp_Unit)) then
Error_Msg_N
-- Start of processing for Analyze_Proper_Body
begin
- -- If the subunit is already loaded, it means that the main unit
- -- is a subunit, and that the current unit is one of its parents
- -- which was being analyzed to provide the needed context for the
- -- analysis of the subunit. In this case we analyze the subunit and
- -- continue with the parent, without looking a subsequent subunits.
+ -- If the subunit is already loaded, it means that the main unit is a
+ -- subunit, and that the current unit is one of its parents which was
+ -- being analyzed to provide the needed context for the analysis of the
+ -- subunit. In this case we analyze the subunit and continue with the
+ -- parent, without looking at subsequent subunits.
if Is_Loaded (Subunit_Name) then
- -- If the proper body is already linked to the stub node,
- -- the stub is in a generic unit and just needs analyzing.
+ -- If the proper body is already linked to the stub node, the stub is
+ -- in a generic unit and just needs analyzing.
if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
+
+ -- If the subunit has severe errors, the spec of the enclosing
+ -- body may not be available, in which case do not try analysis.
+
+ if Serious_Errors_Detected > 0
+ and then No (Library_Unit (Library_Unit (N)))
+ then
+ return;
+ end if;
+
Analyze_Subunit (Library_Unit (N));
-- Otherwise we must load the subunit and link to it
else
- -- Load the subunit, this must work, since we originally
- -- loaded the subunit earlier on. So this will not really
- -- load it, just give access to it.
+ -- Load the subunit, this must work, since we originally loaded
+ -- the subunit earlier on. So this will not really load it, just
+ -- give access to it.
Unum :=
Load_Unit
return;
-- If the subunit is not already loaded, and we are generating code,
- -- then this is the case where compilation started from the parent,
- -- and we are generating code for an entire subunit tree. In that
- -- case we definitely need to load the subunit.
+ -- then this is the case where compilation started from the parent, and
+ -- we are generating code for an entire subunit tree. In that case we
+ -- definitely need to load the subunit.
-- In order to continue the analysis with the rest of the parent,
-- and other subunits, we load the unit without requiring its
elsif Original_Operating_Mode = Generate_Code then
- -- If the proper body is already linked to the stub node,
- -- the stub is in a generic unit and just needs analyzing.
+ -- If the proper body is already linked to the stub node, the stub is
+ -- in a generic unit and just needs analyzing.
- -- We update the version. Although we are not technically
- -- semantically dependent on the subunit, given our approach
- -- of macro substitution of subunits, it makes sense to
- -- include it in the version identification.
+ -- We update the version. Although we are not strictly technically
+ -- semantically dependent on the subunit, given our approach of macro
+ -- substitution of subunits, it makes sense to include it in the
+ -- version identification.
if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
-- Otherwise we must load the subunit and link to it
else
+ -- Make sure that, if the subunit is preprocessed and -gnateG is
+ -- specified, the preprocessed file will be written.
+
+ Lib.Analysing_Subunit_Of_Main := True;
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
+ Lib.Analysing_Subunit_Of_Main := False;
+
+ -- Give message if we did not get the unit Emit warning even if
+ -- missing subunit is not within main unit, to simplify debugging.
if Original_Operating_Mode = Generate_Code
and then Unum = No_Unit
Error_Msg_File_1 :=
Get_File_Name (Subunit_Name, Subunit => True);
Error_Msg_N
- ("subunit$$ in file{ not found?", N);
+ ("subunit$$ in file{ not found?!!", N);
Subunits_Missing := True;
end if;
-- Load_Unit may reset Compiler_State, since it may have been
- -- necessary to parse an additional units, so we make sure
- -- that we reset it to the Analyzing state.
+ -- necessary to parse an additional units, so we make sure that
+ -- we reset it to the Analyzing state.
Compiler_State := Analyzing;
Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ -- Collect SCO information for loaded subunit if we are
+ -- in the main unit).
+
+ if Generate_SCO
+ and then
+ In_Extended_Main_Source_Unit
+ (Cunit_Entity (Current_Sem_Unit))
+ then
+ SCO_Record (Unum);
+ end if;
+
-- Analyze the unit if semantics active
if not Fatal_Error (Unum) or else Try_Semantics then
end if;
end if;
- -- The remaining case is when the subunit is not already loaded and
- -- we are not generating code. In this case we are just performing
- -- semantic analysis on the parent, and we are not interested in
- -- the subunit. For subprograms, analyze the stub as a body. For
- -- other entities the stub has already been marked as completed.
+ -- The remaining case is when the subunit is not already loaded and we
+ -- are not generating code. In this case we are just performing semantic
+ -- analysis on the parent, and we are not interested in the subunit. For
+ -- subprograms, analyze the stub as a body. For other entities the stub
+ -- has already been marked as completed.
else
Optional_Subunit;
end if;
-
end Analyze_Proper_Body;
----------------------------------
begin
Check_Stub_Level (N);
- -- First occurence of name may have been as an incomplete type
+ -- First occurrence of name may have been as an incomplete type
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
-- Analyze_Subprogram_Body_Stub --
----------------------------------
- -- A subprogram body stub can appear with or without a previous
- -- specification. If there is one, the analysis of the body will
- -- find it and verify conformance. The formals appearing in the
- -- specification of the stub play no role, except for requiring an
- -- additional conformance check. If there is no previous subprogram
- -- declaration, the stub acts as a spec, and provides the defining
- -- entity for the subprogram.
+ -- A subprogram body stub can appear with or without a previous spec. If
+ -- there is one, then the analysis of the body will find it and verify
+ -- conformance. The formals appearing in the specification of the stub play
+ -- no role, except for requiring an additional conformance check. If there
+ -- is no previous subprogram declaration, the stub acts as a spec, and
+ -- provides the defining entity for the subprogram.
procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
Decl : Node_Id;
-- Verify that the identifier for the stub is unique within this
-- declarative part.
- if Nkind (Parent (N)) = N_Block_Statement
- or else Nkind (Parent (N)) = N_Package_Body
- or else Nkind (Parent (N)) = N_Subprogram_Body
+ if Nkind_In (Parent (N), N_Block_Statement,
+ N_Package_Body,
+ N_Subprogram_Body)
then
Decl := First (Declarations (Parent (N)));
while Present (Decl)
and then Decl /= N
loop
if Nkind (Decl) = N_Subprogram_Body_Stub
- and then (Chars (Defining_Unit_Name (Specification (Decl)))
- = Chars (Defining_Unit_Name (Specification (N))))
+ and then (Chars (Defining_Unit_Name (Specification (Decl))) =
+ Chars (Defining_Unit_Name (Specification (N))))
then
Error_Msg_N ("identifier for stub is not unique", N);
end if;
-- Analyze_Subunit --
---------------------
- -- A subunit is compiled either by itself (for semantic checking)
- -- or as part of compiling the parent (for code generation). In
- -- either case, by the time we actually process the subunit, the
- -- parent has already been installed and analyzed. The node N is
- -- a compilation unit, whose context needs to be treated here,
- -- because we come directly here from the parent without calling
- -- Analyze_Compilation_Unit.
-
- -- The compilation context includes the explicit context of the
- -- subunit, and the context of the parent, together with the parent
- -- itself. In order to compile the current context, we remove the
- -- one inherited from the parent, in order to have a clean visibility
- -- table. We restore the parent context before analyzing the proper
- -- body itself. On exit, we remove only the explicit context of the
- -- subunit.
+ -- A subunit is compiled either by itself (for semantic checking) or as
+ -- part of compiling the parent (for code generation). In either case, by
+ -- the time we actually process the subunit, the parent has already been
+ -- installed and analyzed. The node N is a compilation unit, whose context
+ -- needs to be treated here, because we come directly here from the parent
+ -- without calling Analyze_Compilation_Unit.
+
+ -- The compilation context includes the explicit context of the subunit,
+ -- and the context of the parent, together with the parent itself. In order
+ -- to compile the current context, we remove the one inherited from the
+ -- parent, in order to have a clean visibility table. We restore the parent
+ -- context before analyzing the proper body itself. On exit, we remove only
+ -- the explicit context of the subunit.
procedure Analyze_Subunit (N : Node_Id) is
Lib_Unit : constant Node_Id := Library_Unit (N);
Enclosing_Child : Entity_Id := Empty;
Svg : constant Suppress_Array := Scope_Suppress;
+ Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
+ -- Save non-partition wide restrictions before processing the subunit.
+ -- All subunits are analyzed with config restrictions reset and we need
+ -- to restore these saved values at the end.
+
procedure Analyze_Subunit_Context;
- -- Capture names in use clauses of the subunit. This must be done
- -- before re-installing parent declarations, because items in the
- -- context must not be hidden by declarations local to the parent.
+ -- Capture names in use clauses of the subunit. This must be done before
+ -- re-installing parent declarations, because items in the context must
+ -- not be hidden by declarations local to the parent.
procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
-- Recursive procedure to restore scope of all ancestors of subunit,
-- from outermost in. If parent is not a subunit, the call to install
- -- context installs context of spec and (if parent is a child unit)
- -- the context of its parents as well. It is confusing that parents
- -- should be treated differently in both cases, but the semantics are
- -- just not identical.
+ -- context installs context of spec and (if parent is a child unit) the
+ -- context of its parents as well. It is confusing that parents should
+ -- be treated differently in both cases, but the semantics are just not
+ -- identical.
procedure Re_Install_Use_Clauses;
-- As part of the removal of the parent scope, the use clauses are
- -- removed, to be reinstalled when the context of the subunit has
- -- been analyzed. Use clauses may also have been affected by the
- -- analysis of the context of the subunit, so they have to be applied
- -- again, to insure that the compilation environment of the rest of
- -- the parent unit is identical.
+ -- removed, to be reinstalled when the context of the subunit has been
+ -- analyzed. Use clauses may also have been affected by the analysis of
+ -- the context of the subunit, so they have to be applied again, to
+ -- insure that the compilation environment of the rest of the parent
+ -- unit is identical.
procedure Remove_Scope;
- -- Remove current scope from scope stack, and preserve the list
- -- of use clauses in it, to be reinstalled after context is analyzed.
+ -- Remove current scope from scope stack, and preserve the list of use
+ -- clauses in it, to be reinstalled after context is analyzed.
-----------------------------
-- Analyze_Subunit_Context --
-- Protect frontend against previous errors in context clauses
if Nkind (Name (Item)) /= N_Selected_Component then
- Unit_Name := Entity (Name (Item));
- while Is_Child_Unit (Unit_Name) loop
- Set_Is_Visible_Child_Unit (Unit_Name);
- Unit_Name := Scope (Unit_Name);
- end loop;
+ if Error_Posted (Item) then
+ null;
+
+ else
+ -- If a subunits has serious syntax errors, the context
+ -- may not have been loaded. Add a harmless unit name to
+ -- attempt processing.
+
+ if Serious_Errors_Detected > 0
+ and then No (Entity (Name (Item)))
+ then
+ Set_Entity (Name (Item), Standard_Standard);
+ end if;
+
+ Unit_Name := Entity (Name (Item));
+ while Is_Child_Unit (Unit_Name) loop
+ Set_Is_Visible_Child_Unit (Unit_Name);
+ Unit_Name := Scope (Unit_Name);
+ end loop;
- if not Is_Immediately_Visible (Unit_Name) then
- Set_Is_Immediately_Visible (Unit_Name);
- Set_Context_Installed (Item);
+ if not Is_Immediately_Visible (Unit_Name) then
+ Set_Is_Immediately_Visible (Unit_Name);
+ Set_Context_Installed (Item);
+ end if;
end if;
end if;
Next (Item);
end loop;
- -- Reset visibility of withed units. They will be made visible
- -- again when we install the subunit context.
+ -- Reset visibility of withed units. They will be made visible again
+ -- when we install the subunit context.
Item := First (Context_Items (N));
while Present (Item) loop
-- Protect frontend against previous errors in context clauses
and then Nkind (Name (Item)) /= N_Selected_Component
+ and then not Error_Posted (Item)
then
Unit_Name := Entity (Name (Item));
while Is_Child_Unit (Unit_Name) loop
Next_Entity (E);
end loop;
- -- A subunit appears within a body, and for a nested subunits
- -- all the parents are bodies. Restore full visibility of their
- -- private entities.
+ -- A subunit appears within a body, and for a nested subunits all the
+ -- parents are bodies. Restore full visibility of their private
+ -- entities.
- if Ekind (Scop) = E_Package
- or else Ekind (Scop) = E_Generic_Package
- then
+ if Is_Package_Or_Generic_Package (Scop) then
Set_In_Package_Body (Scop);
Install_Private_Declarations (Scop);
end if;
-- Start of processing for Analyze_Subunit
begin
+ -- For subunit in main extended unit, we reset the configuration values
+ -- for the non-partition-wide restrictions. For other units reset them.
+
+ if In_Extended_Main_Source_Unit (N) then
+ Restore_Config_Cunit_Boolean_Restrictions;
+ else
+ Reset_Cunit_Boolean_Restrictions;
+ end if;
+
+ if Style_Check then
+ declare
+ Nam : Node_Id := Name (Unit (N));
+
+ begin
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ Check_Identifier (Nam, Par_Unit);
+ end;
+ end if;
+
if not Is_Empty_List (Context_Items (N)) then
-- Save current use clauses
Remove_Scope;
Remove_Context (Lib_Unit);
- -- Now remove parents and their context, including enclosing
- -- subunits and the outer parent body which is not a subunit.
+ -- Now remove parents and their context, including enclosing subunits
+ -- and the outer parent body which is not a subunit.
if Present (Lib_Spec) then
Remove_Context (Lib_Spec);
Re_Install_Parents (Lib_Unit, Par_Unit);
Set_Is_Immediately_Visible (Par_Unit);
- -- If the context includes a child unit of the parent of the
- -- subunit, the parent will have been removed from visibility,
- -- after compiling that cousin in the context. The visibility
- -- of the parent must be restored now. This also applies if the
- -- context includes another subunit of the same parent which in
- -- turn includes a child unit in its context.
+ -- If the context includes a child unit of the parent of the subunit,
+ -- the parent will have been removed from visibility, after compiling
+ -- that cousin in the context. The visibility of the parent must be
+ -- restored now. This also applies if the context includes another
+ -- subunit of the same parent which in turn includes a child unit in
+ -- its context.
- if Ekind (Par_Unit) = E_Package
- or else Ekind (Par_Unit) = E_Generic_Package
- then
+ if Is_Package_Or_Generic_Package (Par_Unit) then
if not Is_Immediately_Visible (Par_Unit)
or else (Present (First_Entity (Par_Unit))
and then not Is_Immediately_Visible
Scope_Suppress := Svg;
- -- If the subunit is within a child unit, then siblings of any
- -- parent unit that appear in the context clause of the subunit
- -- must also be made immediately visible.
+ -- If the subunit is within a child unit, then siblings of any parent
+ -- unit that appear in the context clause of the subunit must also be
+ -- made immediately visible.
if Present (Enclosing_Child) then
Install_Siblings (Enclosing_Child, N);
end if;
-
end if;
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
- -- The subunit may contain a with_clause on a sibling of some
- -- ancestor. Removing the context will remove from visibility those
- -- ancestor child units, which must be restored to the visibility
- -- they have in the enclosing body.
+ -- The subunit may contain a with_clause on a sibling of some ancestor.
+ -- Removing the context will remove from visibility those ancestor child
+ -- units, which must be restored to the visibility they have in the
+ -- enclosing body.
if Present (Enclosing_Child) then
declare
end loop;
end;
end if;
+
+ -- Deal with restore of restrictions
+
+ Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
end Analyze_Subunit;
----------------------------
begin
Check_Stub_Level (N);
- -- First occurence of name may have been as an incomplete type
+ -- First occurrence of name may have been as an incomplete type
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
end if;
- if No (Nam)
- or else not Is_Task_Type (Etype (Nam))
- then
+ if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
Error_Msg_N ("missing specification for task body", N);
else
Set_Scope (Defining_Entity (N), Current_Scope);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
- Set_Has_Completion (Etype (Nam));
+
+ -- Check for duplicate stub, if so give message and terminate
+
+ if Has_Completion (Etype (Nam)) then
+ Error_Msg_N ("duplicate stub for task", N);
+ return;
+ else
+ Set_Has_Completion (Etype (Nam));
+ end if;
+
Analyze_Proper_Body (N, Etype (Nam));
- -- Set elaboration flag to indicate that entity is callable.
- -- This cannot be done in the expansion of the body itself,
- -- because the proper body is not in a declarative part. This
- -- is only done if expansion is active, because the context
- -- may be generic and the flag not defined yet.
+ -- Set elaboration flag to indicate that entity is callable. This
+ -- cannot be done in the expansion of the body itself, because the
+ -- proper body is not in a declarative part. This is only done if
+ -- expansion is active, because the context may be generic and the
+ -- flag not defined yet.
- if Expander_Active then
+ if Full_Expander_Active then
Insert_After (N,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc,
- New_External_Name (Chars (Etype (Nam)), 'E')),
+ Chars => New_External_Name (Chars (Etype (Nam)), 'E')),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
-
end if;
end Analyze_Task_Body_Stub;
-- Analyze_With_Clause --
-------------------------
- -- Analyze the declaration of a unit in a with clause. At end,
- -- label the with clause with the defining entity for the unit.
+ -- Analyze the declaration of a unit in a with clause. At end, label the
+ -- with clause with the defining entity for the unit.
procedure Analyze_With_Clause (N : Node_Id) is
- -- Retrieve the original kind of the unit node, before analysis.
- -- If it is a subprogram instantiation, its analysis below will
- -- rewrite as the declaration of the wrapper package. If the same
- -- instantiation appears indirectly elsewhere in the context, it
- -- will have been analyzed already.
+ -- Retrieve the original kind of the unit node, before analysis. If it
+ -- is a subprogram instantiation, its analysis below will rewrite the
+ -- node as the declaration of the wrapper package. If the same
+ -- instantiation appears indirectly elsewhere in the context, it will
+ -- have been analyzed already.
Unit_Kind : constant Node_Kind :=
Nkind (Original_Node (Unit (Library_Unit (N))));
Intunit : Boolean;
-- Set True if the unit currently being compiled is an internal unit
+ Restriction_Violation : Boolean := False;
+ -- Set True if a with violates a restriction, no point in giving any
+ -- warnings if we have this definite error.
+
Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
begin
+ U := Unit (Library_Unit (N));
+
+ -- If this is an internal unit which is a renaming, then this is a
+ -- violation of No_Obsolescent_Features.
+
+ -- Note: this is not quite right if the user defines one of these units
+ -- himself, but that's a marginal case, and fixing it is hard ???
+
+ if Restriction_Check_Required (No_Obsolescent_Features) then
+ declare
+ F : constant File_Name_Type :=
+ Unit_File_Name (Get_Source_Unit (U));
+ begin
+ if Is_Predefined_File_Name (F, Renamings_Included => True)
+ and then not
+ Is_Predefined_File_Name (F, Renamings_Included => False)
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ Restriction_Violation := True;
+ end if;
+ end;
+ end if;
+
+ -- Check No_Implementation_Units violation
+
+ if Restriction_Check_Required (No_Implementation_Units) then
+ if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then
+ null;
+ else
+ Check_Restriction (No_Implementation_Units, Nam);
+ Restriction_Violation := True;
+ end if;
+ end if;
+
+ -- Several actions are skipped for dummy packages (those supplied for
+ -- with's where no matching file could be found). Such packages are
+ -- identified by the Sloc value being set to No_Location.
+
if Limited_Present (N) then
-- Ada 2005 (AI-50217): Build visibility structures but do not
- -- analyze unit
+ -- analyze the unit.
+
+ if Sloc (U) /= No_Location then
+ Build_Limited_Views (N);
+ end if;
- Build_Limited_Views (N);
return;
end if;
-- explicit with'ing of run-time units.
if Configurable_Run_Time_Mode
- and then
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
+ and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U)))
then
Configurable_Run_Time_Mode := False;
Semantics (Library_Unit (N));
Semantics (Library_Unit (N));
end if;
- U := Unit (Library_Unit (N));
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
- -- Following checks are skipped for dummy packages (those supplied for
- -- with's where no matching file could be found). Such packages are
- -- identified by the Sloc value being set to No_Location
-
if Sloc (U) /= No_Location then
-- Check restrictions, except that we skip the check if this is an
end if;
-- Check for inappropriate with of internal implementation unit if we
- -- are currently compiling the main unit and the main unit is itself
- -- not an internal unit. We do not issue this message for implicit
+ -- are not compiling an internal unit and also check for withing unit
+ -- in wrong version of Ada. Do not issue these messages for implicit
-- with's generated by the compiler itself.
if Implementation_Unit_Warnings
- and then Current_Sem_Unit = Main_Unit
and then not Intunit
and then not Implicit_With (N)
- and then not GNAT_Mode
+ and then not Restriction_Violation
then
declare
U_Kind : constant Kind_Of_Unit :=
begin
if U_Kind = Implementation_Unit then
Error_Msg_F ("& is an internal 'G'N'A'T unit?", Name (N));
- Error_Msg_F
- ("\use of this unit is non-portable " &
- "and version-dependent?",
- Name (N));
- elsif U_Kind = Ada_05_Unit
- and then Ada_Version < Ada_05
+ -- Add alternative name if available, otherwise issue a
+ -- general warning message.
+
+ if Error_Msg_Strlen /= 0 then
+ Error_Msg_F ("\use ""~"" instead", Name (N));
+ else
+ Error_Msg_F
+ ("\use of this unit is non-portable " &
+ "and version-dependent?", Name (N));
+ end if;
+
+ elsif U_Kind = Ada_2005_Unit
+ and then Ada_Version < Ada_2005
and then Warn_On_Ada_2005_Compatibility
then
Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
+
+ elsif U_Kind = Ada_2012_Unit
+ and then Ada_Version < Ada_2012
+ and then Warn_On_Ada_2012_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2012 unit?", Name (N));
end if;
end;
end if;
elsif (Unit_Kind = N_Package_Instantiation
or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
- N_Package_Instantiation)
+ N_Package_Instantiation)
and then Nkind (U) = N_Package_Body
then
E_Name := Corresponding_Spec (U);
elsif Unit_Kind = N_Package_Instantiation
and then Nkind (U) = N_Package_Instantiation
+ and then Present (Instance_Spec (U))
then
-- If the instance has not been rewritten as a package declaration,
-- then it appeared already in a previous with clause. Retrieve
elsif Unit_Kind in N_Subprogram_Instantiation then
- -- Instantiation node is replaced with a wrapper package. Retrieve
- -- the visible subprogram created by the instance from corresponding
- -- attribute of the wrapper.
+ -- The visible subprogram is created during instantiation, and is
+ -- an attribute of the wrapper package. We retrieve the wrapper
+ -- package directly from the instantiation node. If the instance
+ -- is inlined the unit is still an instantiation. Otherwise it has
+ -- been rewritten as the declaration of the wrapper itself.
- E_Name := Related_Instance (Defining_Entity (U));
+ if Nkind (U) in N_Subprogram_Instantiation then
+ E_Name :=
+ Related_Instance
+ (Defining_Entity (Specification (Instance_Spec (U))));
+ else
+ E_Name := Related_Instance (Defining_Entity (U));
+ end if;
elsif Unit_Kind = N_Package_Renaming_Declaration
or else Unit_Kind in N_Generic_Renaming_Declaration
-- Child unit in a with clause
Change_Selected_Component_To_Expanded_Name (Name (N));
+
+ -- If this is a child unit without a spec, and it has been analyzed
+ -- already, a declaration has been created for it. The with_clause
+ -- must reflect the actual body, and not the generated declaration,
+ -- to prevent spurious binding errors involving an out-of-date spec.
+ -- Note that this can only happen if the unit includes more than one
+ -- with_clause for the child unit (e.g. in separate subunits).
+
+ if Unit_Kind = N_Subprogram_Declaration
+ and then Analyzed (Library_Unit (N))
+ and then not Comes_From_Source (Library_Unit (N))
+ then
+ Set_Library_Unit (N,
+ Cunit (Get_Source_Unit (Corresponding_Body (U))));
+ end if;
end if;
- -- Restore style checks and restrictions
+ -- Restore style checks
Style_Check := Save_Style_Check;
- Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
-- Record the reference, but do NOT set the unit as referenced, we want
-- to consider the unit as unreferenced if this is the only reference
Set_Entity_With_Style_Check (Name (N), E_Name);
Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
+ -- Generate references and check No_Dependence restriction for parents
+
if Is_Child_Unit (E_Name) then
Pref := Prefix (Name (N));
Par_Name := Scope (E_Name);
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
+
+ if Present (Entity (Selector_Name (Pref)))
+ and then
+ Present (Renamed_Entity (Entity (Selector_Name (Pref))))
+ and then Entity (Selector_Name (Pref)) /= Par_Name
+ then
+ -- The prefix is a child unit that denotes a renaming declaration.
+ -- Replace the prefix directly with the renamed unit, because the
+ -- rest of the prefix is irrelevant to the visibility of the real
+ -- unit.
+
+ Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref)));
+ exit;
+ end if;
+
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
+ Check_Restriction_No_Dependence (Pref, N);
Pref := Prefix (Pref);
-- If E_Name is the dummy entity for a nonexistent unit, its scope
if Par_Name /= Standard_Standard then
Par_Name := Scope (Par_Name);
end if;
+
+ -- Abandon processing in case of previous errors
+
+ if No (Par_Name) then
+ pragma Assert (Serious_Errors_Detected /= 0);
+ return;
+ end if;
end loop;
if Present (Entity (Pref))
Par_Name := Entity (Pref);
end if;
- Set_Entity_With_Style_Check (Pref, Par_Name);
- Generate_Reference (Par_Name, Pref);
+ -- Guard against missing or misspelled child units
+
+ if Present (Par_Name) then
+ Set_Entity_With_Style_Check (Pref, Par_Name);
+ Generate_Reference (Par_Name, Pref);
+
+ else
+ pragma Assert (Serious_Errors_Detected /= 0);
+
+ -- Mark the node to indicate that a related error has been posted.
+ -- This defends further compilation passes against improper use of
+ -- the invalid WITH clause node.
+
+ Set_Error_Posted (N);
+ Set_Name (N, Error);
+ return;
+ end if;
end if;
-- If the withed unit is System, and a system extension pragma is
-- Returns true if and only if the library unit is declared with
-- an explicit designation of private.
+ -----------------------------
+ -- Is_Private_Library_Unit --
+ -----------------------------
+
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
-- Start of processing for Check_Private_Child_Unit
begin
- if Nkind (Lib_Unit) = N_Package_Body
- or else Nkind (Lib_Unit) = N_Subprogram_Body
- then
+ if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then
Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
Par_Lib := Curr_Unit;
Sub_Parent := Library_Unit (N);
Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
- -- If the parent itself is a subunit, Curr_Unit is the entity
- -- of the enclosing body, retrieve the spec entity which is
- -- the proper ancestor we need for the following tests.
+ -- If the parent itself is a subunit, Curr_Unit is the entity of the
+ -- enclosing body, retrieve the spec entity which is the proper
+ -- ancestor we need for the following tests.
if Ekind (Curr_Unit) = E_Package_Body then
Curr_Unit := Spec_Entity (Curr_Unit);
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
+ and then not Limited_Present (Item)
and then Is_Private_Descendant (Entity (Name (Item)))
then
Priv_Child := Entity (Name (Item));
Item, Child_Parent);
end if;
- elsif not Curr_Private
- and then not Private_Present (Item)
- and then Nkind (Lib_Unit) /= N_Package_Body
- and then Nkind (Lib_Unit) /= N_Subprogram_Body
- and then Nkind (Lib_Unit) /= N_Subunit
+ elsif Curr_Private
+ or else Private_Present (Item)
+ or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit)
+ or else (Nkind (Lib_Unit) = N_Subprogram_Body
+ and then not Acts_As_Spec (Parent (Lib_Unit)))
then
+ null;
+
+ else
Error_Msg_NE
("current unit must also be private descendant of&",
Item, Child_Parent);
Kind : constant Node_Kind := Nkind (Par);
begin
- if (Kind = N_Package_Body
- or else Kind = N_Subprogram_Body
- or else Kind = N_Task_Body
- or else Kind = N_Protected_Body)
- and then (Nkind (Parent (Par)) = N_Compilation_Unit
- or else Nkind (Parent (Par)) = N_Subunit)
+ if Nkind_In (Kind, N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body,
+ N_Protected_Body)
+ and then Nkind_In (Parent (Par), N_Compilation_Unit, N_Subunit)
then
null;
P : Node_Id;
function Build_Unit_Name (Nam : Node_Id) return Node_Id;
- -- Comment requireed here ???
+ -- Build name to be used in implicit with_clause. In most cases this
+ -- is the source name, but if renamings are present we must make the
+ -- original unit visible, not the one it renames. The entity in the
+ -- with clause is the renamed unit, but the identifier is the one from
+ -- the source, which allows us to recover the unit renaming.
---------------------
-- Build_Unit_Name --
---------------------
function Build_Unit_Name (Nam : Node_Id) return Node_Id is
- Result : Node_Id;
+ Ent : Entity_Id;
+ Result : Node_Id;
begin
if Nkind (Nam) = N_Identifier then
return New_Occurrence_Of (Entity (Nam), Loc);
else
+ Ent := Entity (Nam);
+
+ if Present (Entity (Selector_Name (Nam)))
+ and then Chars (Entity (Selector_Name (Nam))) /= Chars (Ent)
+ and then
+ Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam))))
+ = N_Package_Renaming_Declaration
+ then
+ -- The name in the with_clause is of the form A.B.C, and B is
+ -- given by a renaming declaration. In that case we may not
+ -- have analyzed the unit for B, but replaced it directly in
+ -- lib-load with the unit it renames. We have to make A.B
+ -- visible, so analyze the declaration for B now, in case it
+ -- has not been done yet.
+
+ Ent := Entity (Selector_Name (Nam));
+ Analyze
+ (Parent
+ (Unit_Declaration_Node (Entity (Selector_Name (Nam)))));
+ end if;
+
Result :=
Make_Expanded_Name (Loc,
Chars => Chars (Entity (Nam)),
Prefix => Build_Unit_Name (Prefix (Nam)),
- Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
- Set_Entity (Result, Entity (Nam));
+ Selector_Name => New_Occurrence_Of (Ent, Loc));
+ Set_Entity (Result, Ent);
return Result;
end if;
end Build_Unit_Name;
begin
New_Nodes_OK := New_Nodes_OK + 1;
Withn :=
- Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
+ Make_With_Clause (Loc,
+ Name => Build_Unit_Name (Nam));
P := Parent (Unit_Declaration_Node (Ent));
- Set_Library_Unit (Withn, P);
- Set_Corresponding_Spec (Withn, Ent);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
+ Set_Library_Unit (Withn, P);
+ Set_Corresponding_Spec (Withn, Ent);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a
- -- child unit implies that the implicit with on the parent is also
- -- private.
+ -- child unit implies the implicit with on the parent is also private.
if Nkind (Unit (N)) = N_Package_Declaration then
- Set_Private_Present (Withn, Private_Present (Item));
+ Set_Private_Present (Withn, Private_Present (Item));
end if;
Prepend (Withn, Context_Items (N));
if Nkind (Unit) = N_Package_Body
and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
then
- return
- Defining_Entity
- (Specification (Instance_Spec (Original_Node (Unit))));
-
+ return Defining_Entity
+ (Specification (Instance_Spec (Original_Node (Unit))));
elsif Nkind (Unit) = N_Package_Instantiation then
return Defining_Entity (Specification (Instance_Spec (Unit)));
-
else
return Defining_Entity (Unit);
end if;
end Get_Parent_Entity;
+ ---------------------
+ -- Has_With_Clause --
+ ---------------------
+
+ function Has_With_Clause
+ (C_Unit : Node_Id;
+ Pack : Entity_Id;
+ Is_Limited : Boolean := False) return Boolean
+ is
+ Item : Node_Id;
+
+ function Named_Unit (Clause : Node_Id) return Entity_Id;
+ -- Return the entity for the unit named in a [limited] with clause
+
+ ----------------
+ -- Named_Unit --
+ ----------------
+
+ function Named_Unit (Clause : Node_Id) return Entity_Id is
+ begin
+ if Nkind (Name (Clause)) = N_Selected_Component then
+ return Entity (Selector_Name (Name (Clause)));
+ else
+ return Entity (Name (Clause));
+ end if;
+ end Named_Unit;
+
+ -- Start of processing for Has_With_Clause
+
+ begin
+ if Present (Context_Items (C_Unit)) then
+ Item := First (Context_Items (C_Unit));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item) = Is_Limited
+ and then Named_Unit (Item) = Pack
+ then
+ return True;
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+
+ return False;
+ end Has_With_Clause;
+
-----------------------------
-- Implicit_With_On_Parent --
-----------------------------
function Build_Unit_Name return Node_Id is
Result : Node_Id;
+
begin
if No (Parent_Spec (P_Unit)) then
return New_Reference_To (P_Name, Loc);
+
else
Result :=
Make_Expanded_Name (Loc,
end if;
Install_Limited_Context_Clauses (N);
-
end Install_Context;
-----------------------------
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Chars (Item) in Configuration_Pragma_Names
+ and then Pragma_Name (Item) in Configuration_Pragma_Names
loop
Next (Item);
end loop;
if Nkind (Name (Item)) = N_Expanded_Name then
Expand_With_Clause (Item, Prefix (Name (Item)), N);
else
- -- if not an expanded name, the child unit must be a
+ -- If not an expanded name, the child unit must be a
-- renaming, nothing to do.
null;
if Sloc (Library_Unit (Item)) /= No_Location then
License_Check : declare
-
Withu : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (Item));
-
Withl : constant License_Type :=
License (Source_Index (Withu));
-
Unitl : constant License_Type :=
License (Source_Index (Current_Sem_Unit));
procedure License_Error is
begin
Error_Msg_N
- ("?license of with'ed unit & may be inconsistent",
+ ("?license of withed unit & may be inconsistent",
Name (Item));
end License_Error;
if Is_Child_Spec (Lib_Unit) then
- -- The unit also has implicit withs on its own parents
+ -- The unit also has implicit with_clauses on its own parents
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
end if;
-- If the unit is a body, the context of the specification must also
- -- be installed.
+ -- be installed. That includes private with_clauses in that context.
if Nkind (Lib_Unit) = N_Package_Body
or else (Nkind (Lib_Unit) = N_Subprogram_Body
then
Install_Context (Library_Unit (N));
+ -- Only install private with-clauses of a spec that comes from
+ -- source, excluding specs created for a subprogram body that is
+ -- a child unit.
+
+ if Comes_From_Source (Library_Unit (N)) then
+ Install_Private_With_Clauses
+ (Defining_Entity (Unit (Library_Unit (N))));
+ end if;
+
if Is_Child_Spec (Unit (Library_Unit (N))) then
-- If the unit is the body of a public child unit, the private
Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
end if;
- if Nkind (Lib_Unit) = N_Generic_Package_Declaration
- or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
- or else Nkind (Lib_Unit) = N_Package_Declaration
- or else Nkind (Lib_Unit) = N_Subprogram_Declaration
+ if Nkind_In (Lib_Unit, N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Package_Declaration,
+ N_Subprogram_Declaration)
then
if Is_Child_Spec (Lib_Unit) then
Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
-- Check that if a limited_with clause of a given compilation_unit
- -- mentions a descendant of a private child of some library unit,
- -- then the given compilation_unit shall be the declaration of a
- -- private descendant of that library unit.
+ -- mentions a descendant of a private child of some library unit, then
+ -- the given compilation_unit shall be the declaration of a private
+ -- descendant of that library unit, or a public descendant of such. The
+ -- code is analogous to that of Check_Private_Child_Unit but we cannot
+ -- use entities on the limited with_clauses because their units have not
+ -- been analyzed, so we have to climb the tree of ancestors looking for
+ -- private keywords.
procedure Expand_Limited_With_Clause
- (Comp_Unit : Node_Id; Nam : Node_Id; N : Node_Id);
+ (Comp_Unit : Node_Id;
+ Nam : Node_Id;
+ N : Node_Id);
-- If a child unit appears in a limited_with clause, there are implicit
-- limited_with clauses on all parents that are not already visible
-- through a regular with clause. This procedure creates the implicit
-- units. The shadow entities are created when the inserted clause is
-- analyzed. Implements Ada 2005 (AI-50217).
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
+ -- When compiling a unit Q descended from some parent unit P, a limited
+ -- with_clause in the context of P that names some other ancestor of Q
+ -- must not be installed because the ancestor is immediately visible.
+
---------------------
-- Check_Renamings --
---------------------
and then Renamed_Entity (E) = WEnt
then
-- The unlimited view is visible through use clause and
- -- renamings. There is not need to generate the error
+ -- renamings. There is no need to generate the error
-- message here because Is_Visible_Through_Renamings
-- takes care of generating the precise error message.
E2 := E;
while E2 /= Standard_Standard
- and then E2 /= WEnt loop
+ and then E2 /= WEnt
+ loop
E2 := Scope (E2);
end loop;
procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is
Curr_Parent : Node_Id;
Child_Parent : Node_Id;
+ Curr_Private : Boolean;
begin
-- Compilation unit of the parent of the withed library unit
- Child_Parent := Parent_Spec (Unit (Library_Unit (Item)));
+ Child_Parent := Library_Unit (Item);
-- If the child unit is a public child, then locate its nearest
- -- private ancestor, if any; Child_Parent will then be set to
+ -- private ancestor, if any, then Child_Parent will then be set to
-- the parent of that ancestor.
if not Private_Present (Library_Unit (Item)) then
if No (Child_Parent) then
return;
end if;
-
- Child_Parent := Parent_Spec (Unit (Child_Parent));
end if;
- -- Traverse all the ancestors of the current compilation
- -- unit to check if it is a descendant of named library unit.
+ Child_Parent := Parent_Spec (Unit (Child_Parent));
+
+ -- Traverse all the ancestors of the current compilation unit to
+ -- check if it is a descendant of named library unit.
Curr_Parent := Parent (Item);
+ Curr_Private := Private_Present (Curr_Parent);
+
while Present (Parent_Spec (Unit (Curr_Parent)))
and then Curr_Parent /= Child_Parent
loop
Curr_Parent := Parent_Spec (Unit (Curr_Parent));
+ Curr_Private := Curr_Private or else Private_Present (Curr_Parent);
end loop;
if Curr_Parent /= Child_Parent then
("\current unit must also have parent&!",
Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
- elsif not Private_Present (Parent (Item))
- and then not Private_Present (Item)
- and then Nkind (Unit (Parent (Item))) /= N_Package_Body
- and then Nkind (Unit (Parent (Item))) /= N_Subprogram_Body
- and then Nkind (Unit (Parent (Item))) /= N_Subunit
+ elsif Private_Present (Parent (Item))
+ or else Curr_Private
+ or else Private_Present (Item)
+ or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
+ N_Subprogram_Body,
+ N_Subunit)
then
+ -- Current unit is private, of descendant of a private unit
+
+ null;
+
+ else
Error_Msg_NE
("current unit must also be private descendant of&",
Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
Subunit => False,
Error_Node => Nam);
- -- Do not generate a limited_with_clause on the current unit.
- -- This path is taken when a unit has a limited_with clause on
- -- one of its child units.
+ -- Do not generate a limited_with_clause on the current unit. This
+ -- path is taken when a unit has a limited_with clause on one of its
+ -- child units.
if Unum = Current_Sem_Unit then
return;
New_Nodes_OK := New_Nodes_OK - 1;
end Expand_Limited_With_Clause;
+ ----------------------
+ -- Is_Ancestor_Unit --
+ ----------------------
+
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
+ E1 : constant Entity_Id := Defining_Entity (Unit (U1));
+ E2 : Entity_Id;
+ begin
+ if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+ E2 := Defining_Entity (Unit (Library_Unit (U2)));
+ return Is_Ancestor_Package (E1, E2);
+ else
+ return False;
+ end if;
+ end Is_Ancestor_Unit;
+
-- Start of processing for Install_Limited_Context_Clauses
begin
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
+ and then not Error_Posted (Item)
then
if Nkind (Name (Item)) = N_Selected_Component then
Expand_Limited_With_Clause
if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
and then not Limited_View_Installed (Item)
+ and then
+ not Is_Ancestor_Unit
+ (Library_Unit (Item), Cunit (Current_Sem_Unit))
then
if not Private_Present (Item)
- or else Private_Present (N)
- or else Nkind (Unit (N)) = N_Package_Body
- or else Nkind (Unit (N)) = N_Subprogram_Body
- or else Nkind (Unit (N)) = N_Subunit
+ or else Private_Present (N)
+ or else Nkind_In (Unit (N), N_Package_Body,
+ N_Subprogram_Body,
+ N_Subunit)
then
Install_Limited_Withed_Unit (Item);
end if;
end if;
-
- -- All items other than Limited_With clauses are ignored (they were
- -- installed separately early on by Install_Context_Clause).
-
- else
- null;
end if;
Next (Item);
end loop;
- -- Ada 2005 (AI-412): Examine the visible declarations of a package
- -- spec, looking for incomplete subtype declarations of incomplete
- -- types visible through a limited with clause.
+ -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
+ -- looking for incomplete subtype declarations of incomplete types
+ -- visible through a limited with clause.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Analyzed (N)
and then Nkind (Unit (N)) = N_Package_Declaration
then
-- Convert an incomplete subtype declaration into a
-- corresponding non-limited view subtype declaration.
-- This is usually the case when analyzing a body that
- -- has regular with-clauses, when the spec has limited
+ -- has regular with clauses, when the spec has limited
-- ones.
-- If the non-limited view is still incomplete, it is
end if;
if Ekind (P_Name) = E_Generic_Package
- and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
- and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
+ and then not Nkind_In (Lib_Unit, N_Generic_Subprogram_Declaration,
+ N_Generic_Package_Declaration)
and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
then
Error_Msg_N
-- indicating that we deal with an instance.
elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
-
if Nkind (Lib_Unit) in N_Renaming_Declaration
or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
or else
-- immediately visible.
-- Find entity for compilation unit, and set its private descendant
- -- status as needed.
+ -- status as needed. Indicate that it is a compilation unit, which is
+ -- redundant in general, but needed if this is a generated child spec
+ -- for a child body without previous spec.
E_Name := Defining_Entity (Lib_Unit);
Set_Is_Child_Unit (E_Name);
+ Set_Is_Compilation_Unit (E_Name);
Set_Is_Private_Descendant (E_Name,
Is_Private_Descendant (P_Name)
Item : Node_Id;
Id : Entity_Id;
Prev : Entity_Id;
+
begin
-- Iterate over explicit with clauses, and check whether the scope of
-- each entity is an ancestor of the current unit, in which case it is
Item := First (Context_Items (N));
while Present (Item) loop
- -- Do not install private_with_clauses if the unit is a package
- -- declaration, unless it is itself a private child unit.
+ -- Do not install private_with_clauses declaration, unless unit
+ -- is itself a private child unit, or is a body. Note that for a
+ -- subprogram body the private_with_clause does not take effect until
+ -- after the specification.
- if Nkind (Item) = N_With_Clause
- and then not Implicit_With (Item)
- and then not Limited_Present (Item)
- and then
- (not Private_Present (Item)
- or else Nkind (Unit (N)) /= N_Package_Declaration
- or else Private_Present (N))
+ if Nkind (Item) /= N_With_Clause
+ or else Implicit_With (Item)
+ or else Limited_Present (Item)
+ or else Error_Posted (Item)
+ then
+ null;
+
+ elsif not Private_Present (Item)
+ or else Private_Present (N)
+ or else Nkind (Unit (N)) = N_Package_Body
then
Id := Entity (Name (Item));
then
Set_Is_Immediately_Visible (Id);
- -- Check for the presence of another unit in the context,
- -- that may be inadvertently hidden by the child.
+ -- Check for the presence of another unit in the context that
+ -- may be inadvertently hidden by the child.
Prev := Current_Entity (Id);
end loop;
end;
end if;
- end if;
- Next (Item);
- end loop;
- end Install_Siblings;
+ -- If the item is a private with-clause on a child unit, the parent
+ -- may have been installed already, but the child unit must remain
+ -- invisible until installed in a private part or body, unless there
+ -- is already a regular with_clause for it in the current unit.
- -------------------------------
- -- Install_Limited_With_Unit --
- -------------------------------
+ elsif Private_Present (Item) then
+ Id := Entity (Name (Item));
- procedure Install_Limited_Withed_Unit (N : Node_Id) is
- P_Unit : constant Entity_Id := Unit (Library_Unit (N));
+ if Is_Child_Unit (Id) then
+ declare
+ Clause : Node_Id;
+
+ function In_Context return Boolean;
+ -- Scan context of current unit, to check whether there is
+ -- a with_clause on the same unit as a private with-clause
+ -- on a parent, in which case child unit is visible. If the
+ -- unit is a grand-child, the same applies to its parent.
+
+ ----------------
+ -- In_Context --
+ ----------------
+
+ function In_Context return Boolean is
+ begin
+ Clause :=
+ First (Context_Items (Cunit (Current_Sem_Unit)));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then Comes_From_Source (Clause)
+ and then Is_Entity_Name (Name (Clause))
+ and then not Private_Present (Clause)
+ then
+ if Entity (Name (Clause)) = Id
+ or else
+ (Nkind (Name (Clause)) = N_Expanded_Name
+ and then Entity (Prefix (Name (Clause))) = Id)
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Clause);
+ end loop;
+
+ return False;
+ end In_Context;
+
+ begin
+ Set_Is_Visible_Child_Unit (Id, In_Context);
+ end;
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+ end Install_Siblings;
+
+ ---------------------------------
+ -- Install_Limited_Withed_Unit --
+ ---------------------------------
+
+ procedure Install_Limited_Withed_Unit (N : Node_Id) is
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
E : Entity_Id;
P : Entity_Id;
Is_Child_Package : Boolean := False;
-
- Lim_Header : Entity_Id;
- Lim_Typ : Entity_Id;
+ Lim_Header : Entity_Id;
+ Lim_Typ : Entity_Id;
+
+ procedure Check_Body_Required;
+ -- A unit mentioned in a limited with_clause may not be mentioned in
+ -- a regular with_clause, but must still be included in the current
+ -- partition. We need to determine whether the unit needs a body, so
+ -- that the binder can determine the name of the file to be compiled.
+ -- Checking whether a unit needs a body can be done without semantic
+ -- analysis, by examining the nature of the declarations in the package.
+
+ function Has_Limited_With_Clause
+ (C_Unit : Entity_Id;
+ Pack : Entity_Id) return Boolean;
+ -- Determine whether any package in the ancestor chain starting with
+ -- C_Unit has a limited with clause for package Pack.
function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
-- Check if some package installed though normal with-clauses has a
-- renaming declaration of package P. AARM 10.1.2(21/2).
+ -------------------------
+ -- Check_Body_Required --
+ -------------------------
+
+ procedure Check_Body_Required is
+ PA : constant List_Id :=
+ Pragmas_After (Aux_Decls_Node (Parent (P_Unit)));
+
+ procedure Check_Declarations (Spec : Node_Id);
+ -- Recursive procedure that does the work and checks nested packages
+
+ ------------------------
+ -- Check_Declarations --
+ ------------------------
+
+ procedure Check_Declarations (Spec : Node_Id) is
+ Decl : Node_Id;
+ Incomplete_Decls : constant Elist_Id := New_Elmt_List;
+
+ Subp_List : constant Elist_Id := New_Elmt_List;
+
+ procedure Check_Pragma_Import (P : Node_Id);
+ -- If a pragma import applies to a previous subprogram, the
+ -- enclosing unit may not need a body. The processing is syntactic
+ -- and does not require a declaration to be analyzed. The code
+ -- below also handles pragma Import when applied to a subprogram
+ -- that renames another. In this case the pragma applies to the
+ -- renamed entity.
+ --
+ -- Chains of multiple renames are not handled by the code below.
+ -- It is probably impossible to handle all cases without proper
+ -- name resolution. In such cases the algorithm is conservative
+ -- and will indicate that a body is needed???
+
+ -------------------------
+ -- Check_Pragma_Import --
+ -------------------------
+
+ procedure Check_Pragma_Import (P : Node_Id) is
+ Arg : Node_Id;
+ Prev_Id : Elmt_Id;
+ Subp_Id : Elmt_Id;
+ Imported : Node_Id;
+
+ procedure Remove_Homonyms (E : Node_Id);
+ -- Make one pass over list of subprograms. Called again if
+ -- subprogram is a renaming. E is known to be an identifier.
+
+ ---------------------
+ -- Remove_Homonyms --
+ ---------------------
+
+ procedure Remove_Homonyms (E : Node_Id) is
+ R : Entity_Id := Empty;
+ -- Name of renamed entity, if any
+
+ begin
+ Subp_Id := First_Elmt (Subp_List);
+ while Present (Subp_Id) loop
+ if Chars (Node (Subp_Id)) = Chars (E) then
+ if Nkind (Parent (Parent (Node (Subp_Id))))
+ /= N_Subprogram_Renaming_Declaration
+ then
+ Prev_Id := Subp_Id;
+ Next_Elmt (Subp_Id);
+ Remove_Elmt (Subp_List, Prev_Id);
+ else
+ R := Name (Parent (Parent (Node (Subp_Id))));
+ exit;
+ end if;
+ else
+ Next_Elmt (Subp_Id);
+ end if;
+ end loop;
+
+ if Present (R) then
+ if Nkind (R) = N_Identifier then
+ Remove_Homonyms (R);
+
+ elsif Nkind (R) = N_Selected_Component then
+ Remove_Homonyms (Selector_Name (R));
+
+ -- Renaming of attribute
+
+ else
+ null;
+ end if;
+ end if;
+ end Remove_Homonyms;
+
+ -- Start of processing for Check_Pragma_Import
+
+ begin
+ -- Find name of entity in Import pragma. We have not analyzed
+ -- the construct, so we must guard against syntax errors.
+
+ Arg := Next (First (Pragma_Argument_Associations (P)));
+
+ if No (Arg)
+ or else Nkind (Expression (Arg)) /= N_Identifier
+ then
+ return;
+ else
+ Imported := Expression (Arg);
+ end if;
+
+ Remove_Homonyms (Imported);
+ end Check_Pragma_Import;
+
+ -- Start of processing for Check_Declarations
+
+ begin
+ -- Search for Elaborate Body pragma
+
+ Decl := First (Visible_Declarations (Spec));
+ while Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ loop
+ if Get_Pragma_Id (Decl) = Pragma_Elaborate_Body then
+ Set_Body_Required (Library_Unit (N));
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Look for declarations that require the presence of a body. We
+ -- have already skipped pragmas at the start of the list.
+
+ while Present (Decl) loop
+
+ -- Subprogram that comes from source means body may be needed.
+ -- Save for subsequent examination of import pragmas.
+
+ if Comes_From_Source (Decl)
+ and then (Nkind_In (Decl, N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration,
+ N_Generic_Subprogram_Declaration))
+ then
+ Append_Elmt (Defining_Entity (Decl), Subp_List);
+
+ -- Package declaration of generic package declaration. We need
+ -- to recursively examine nested declarations.
+
+ elsif Nkind_In (Decl, N_Package_Declaration,
+ N_Generic_Package_Declaration)
+ then
+ Check_Declarations (Specification (Decl));
+
+ elsif Nkind (Decl) = N_Pragma
+ and then Pragma_Name (Decl) = Name_Import
+ then
+ Check_Pragma_Import (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Same set of tests for private part. In addition to subprograms
+ -- detect the presence of Taft Amendment types (incomplete types
+ -- completed in the body).
+
+ Decl := First (Private_Declarations (Spec));
+ while Present (Decl) loop
+ if Comes_From_Source (Decl)
+ and then (Nkind_In (Decl, N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration,
+ N_Generic_Subprogram_Declaration))
+ then
+ Append_Elmt (Defining_Entity (Decl), Subp_List);
+
+ elsif Nkind_In (Decl, N_Package_Declaration,
+ N_Generic_Package_Declaration)
+ then
+ Check_Declarations (Specification (Decl));
+
+ -- Collect incomplete type declarations for separate pass
+
+ elsif Nkind (Decl) = N_Incomplete_Type_Declaration then
+ Append_Elmt (Decl, Incomplete_Decls);
+
+ elsif Nkind (Decl) = N_Pragma
+ and then Pragma_Name (Decl) = Name_Import
+ then
+ Check_Pragma_Import (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Now check incomplete declarations to locate Taft amendment
+ -- types. This can be done by examining the defining identifiers
+ -- of type declarations without real semantic analysis.
+
+ declare
+ Inc : Elmt_Id;
+
+ begin
+ Inc := First_Elmt (Incomplete_Decls);
+ while Present (Inc) loop
+ Decl := Next (Node (Inc));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Full_Type_Declaration
+ and then Chars (Defining_Identifier (Decl)) =
+ Chars (Defining_Identifier (Node (Inc)))
+ then
+ exit;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- If no completion, this is a TAT, and a body is needed
+
+ if No (Decl) then
+ Set_Body_Required (Library_Unit (N));
+ return;
+ end if;
+
+ Next_Elmt (Inc);
+ end loop;
+ end;
+
+ -- Finally, check whether there are subprograms that still require
+ -- a body, i.e. are not renamings or null.
+
+ if not Is_Empty_Elmt_List (Subp_List) then
+ declare
+ Subp_Id : Elmt_Id;
+ Spec : Node_Id;
+
+ begin
+ Subp_Id := First_Elmt (Subp_List);
+ Spec := Parent (Node (Subp_Id));
+
+ while Present (Subp_Id) loop
+ if Nkind (Parent (Spec))
+ = N_Subprogram_Renaming_Declaration
+ then
+ null;
+
+ elsif Nkind (Spec) = N_Procedure_Specification
+ and then Null_Present (Spec)
+ then
+ null;
+
+ else
+ Set_Body_Required (Library_Unit (N));
+ return;
+ end if;
+
+ Next_Elmt (Subp_Id);
+ end loop;
+ end;
+ end if;
+ end Check_Declarations;
+
+ -- Start of processing for Check_Body_Required
+
+ begin
+ -- If this is an imported package (Java and CIL usage) no body is
+ -- needed. Scan list of pragmas that may follow a compilation unit
+ -- to look for a relevant pragma Import.
+
+ if Present (PA) then
+ declare
+ Prag : Node_Id;
+
+ begin
+ Prag := First (PA);
+ while Present (Prag) loop
+ if Nkind (Prag) = N_Pragma
+ and then Get_Pragma_Id (Prag) = Pragma_Import
+ then
+ return;
+ end if;
+
+ Next (Prag);
+ end loop;
+ end;
+ end if;
+
+ Check_Declarations (Specification (P_Unit));
+ end Check_Body_Required;
+
+ -----------------------------
+ -- Has_Limited_With_Clause --
+ -----------------------------
+
+ function Has_Limited_With_Clause
+ (C_Unit : Entity_Id;
+ Pack : Entity_Id) return Boolean
+ is
+ Par : Entity_Id;
+ Par_Unit : Node_Id;
+
+ begin
+ Par := C_Unit;
+ while Present (Par) loop
+ if Ekind (Par) /= E_Package then
+ exit;
+ end if;
+
+ -- Retrieve the Compilation_Unit node for Par and determine if
+ -- its context clauses contain a limited with for Pack.
+
+ Par_Unit := Parent (Parent (Parent (Par)));
+
+ if Nkind (Par_Unit) = N_Package_Declaration then
+ Par_Unit := Parent (Par_Unit);
+ end if;
+
+ if Has_With_Clause (Par_Unit, Pack, True) then
+ return True;
+ end if;
+
+ -- If there are more ancestors, climb up the tree, otherwise we
+ -- are done.
+
+ if Is_Child_Unit (Par) then
+ Par := Scope (Par);
+ else
+ exit;
+ end if;
+ end loop;
+
+ return False;
+ end Has_Limited_With_Clause;
+
----------------------------------
-- Is_Visible_Through_Renamings --
----------------------------------
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Limited_Present (Item)
- and then Nkind (Unit (Library_Unit (Item)))
- = N_Package_Declaration
+ and then Nkind (Unit (Library_Unit (Item))) =
+ N_Package_Declaration
then
Decl :=
First (Visible_Declarations
then
-- Generate the error message only if the current unit
-- is a package declaration; in case of subprogram
- -- bodies and package bodies we just return true to
+ -- bodies and package bodies we just return True to
-- indicate that the limited view must not be
-- installed.
Next (Item);
end loop;
- if Present (Library_Unit (Aux_Unit)) then
+ -- If it is a body not acting as spec, follow pointer to the
+ -- corresponding spec, otherwise follow pointer to parent spec.
+
+ if Present (Library_Unit (Aux_Unit))
+ and then Nkind_In (Unit (Aux_Unit),
+ N_Package_Body, N_Subprogram_Body)
+ then
if Aux_Unit = Library_Unit (Aux_Unit) then
-- Aux_Unit is a body that acts as a spec. Clause has
else
Aux_Unit := Library_Unit (Aux_Unit);
end if;
+
else
Aux_Unit := Parent_Spec (Unit (Aux_Unit));
end if;
-- In case of limited with_clause on subprograms, generics, instances,
-- or renamings, the corresponding error was previously posted and we
- -- have nothing to do here.
+ -- have nothing to do here. If the file is missing altogether, it has
+ -- no source location.
- if Nkind (P_Unit) /= N_Package_Declaration then
+ if Nkind (P_Unit) /= N_Package_Declaration
+ or else Sloc (P_Unit) = No_Location
+ then
return;
end if;
P := Defining_Identifier (P);
end if;
+ -- Do not install the limited-view if the context of the unit is already
+ -- available through a regular with clause.
+
+ if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
+ and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
+ then
+ return;
+ end if;
+
-- Do not install the limited-view if the full-view is already visible
-- through renaming declarations.
-- Do not install the limited view if this is the unit being analyzed.
-- This unusual case will happen when a unit has a limited_with clause
- -- on one of its children. The compilation of the child forces the
- -- load of the parent which tries to install the limited view of the
- -- child again. Installing the limited view must also be disabled
- -- when compiling the body of the child unit.
+ -- on one of its children. The compilation of the child forces the load
+ -- of the parent which tries to install the limited view of the child
+ -- again. Installing the limited view must also be disabled when
+ -- compiling the body of the child unit.
if P = Cunit_Entity (Current_Sem_Unit)
or else
(Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
- and then P = Main_Unit_Entity)
+ and then P = Main_Unit_Entity)
then
return;
end if;
- -- A common use of the limited-with is to have a limited-with
- -- in the package spec, and a normal with in its package body.
- -- For example:
+ -- This scenario is similar to the one above, the difference is that the
+ -- compilation of sibling Par.Sib forces the load of parent Par which
+ -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
+ -- has a with clause for Lim_Pack [2] in its body, and thus needs the
+ -- non-limited views of all entities from Lim_Pack.
+
+ -- limited with Lim_Pack; -- [1]
+ -- package Par is ... package Lim_Pack is ...
+
+ -- with Lim_Pack; -- [2]
+ -- package Par.Sib is ... package body Par.Sib is ...
+
+ -- In this case Main_Unit_Entity is the spec of Par.Sib and Current_
+ -- Sem_Unit is the body of Par.Sib.
+
+ if Ekind (P) = E_Package
+ and then Ekind (Main_Unit_Entity) = E_Package
+ and then Is_Child_Unit (Main_Unit_Entity)
+
+ -- The body has a regular with clause
+
+ and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
+ and then Has_With_Clause (Cunit (Current_Sem_Unit), P)
+
+ -- One of the ancestors has a limited with clause
+
+ and then Nkind (Parent (Parent (Main_Unit_Entity))) =
+ N_Package_Specification
+ and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P)
+ then
+ return;
+ end if;
+
+ -- A common use of the limited-with is to have a limited-with in the
+ -- package spec, and a normal with in its package body. For example:
-- limited with X; -- [1]
-- package A is ...
-- view of X supersedes its limited view.
if Analyzed (P_Unit)
- and then (Is_Immediately_Visible (P)
- or else (Is_Child_Package
- and then Is_Visible_Child_Unit (P)))
+ and then
+ (Is_Immediately_Visible (P)
+ or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
then
- -- Ada 2005 (AI-262): Install the private declarations of P
- if Private_Present (N)
- and then not In_Private_Part (P)
- then
- declare
- Id : Entity_Id;
+ -- The presence of both the limited and the analyzed nonlimited view
+ -- may also be an error, such as an illegal context for a limited
+ -- with_clause. In that case, do not process the context item at all.
+
+ if Error_Posted (N) then
+ return;
+ end if;
+ if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
+ declare
+ Item : Node_Id;
begin
- Id := First_Private_Entity (P);
- while Present (Id) loop
- if not Is_Internal (Id)
- and then not Is_Child_Unit (Id)
+ Item := First (Context_Items (Cunit (Current_Sem_Unit)));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Comes_From_Source (Item)
+ and then Entity (Name (Item)) = P
then
- if not In_Chain (Id) then
- Set_Homonym (Id, Current_Entity (Id));
- Set_Current_Entity (Id);
- end if;
-
- Set_Is_Immediately_Visible (Id);
+ return;
end if;
- Next_Entity (Id);
+ Next (Item);
end loop;
-
- Set_In_Private_Part (P);
end;
- end if;
- return;
+ -- If this is a child body, assume that the nonlimited with_clause
+ -- appears in an ancestor. Could be refined ???
+
+ if Is_Child_Unit
+ (Defining_Entity
+ (Unit (Library_Unit (Cunit (Current_Sem_Unit)))))
+ then
+ return;
+ end if;
+
+ else
+
+ -- If in package declaration, nonlimited view brought in from
+ -- parent unit or some error condition.
+
+ return;
+ end if;
end if;
if Debug_Flag_I then
Prev := Current_Entity (Lim_Typ);
E := Prev;
- -- Replace E in the homonyms list, so that the limited
- -- view becomes available.
+ -- Replace E in the homonyms list, so that the limited view
+ -- becomes available.
if E = Non_Limited_View (Lim_Typ) then
Set_Homonym (Lim_Typ, Homonym (Prev));
loop
E := Homonym (Prev);
- -- E may have been removed when installing a
- -- previous limited_with_clause.
+ -- E may have been removed when installing a previous
+ -- limited_with_clause.
exit when No (E);
Set_Is_Immediately_Visible (P);
Set_Limited_View_Installed (N);
- -- If the package in the limited_with clause is a child unit, the
- -- clause is unanalyzed and appears as a selected component. Recast
- -- it as an expanded name so that the entity can be properly set. Use
- -- entity of parent, if available, for higher ancestors in the name.
+ -- If unit has not been analyzed in some previous context, check
+ -- (imperfectly ???) whether it might need a body.
+
+ if not Analyzed (P_Unit) then
+ Check_Body_Required;
+ end if;
+
+ -- If the package in the limited_with clause is a child unit, the clause
+ -- is unanalyzed and appears as a selected component. Recast it as an
+ -- expanded name so that the entity can be properly set. Use entity of
+ -- parent, if available, for higher ancestors in the name.
if Nkind (Name (N)) = N_Selected_Component then
declare
-- Set entity of parent identifiers if the unit is a child
-- unit. This ensures that the tree is properly formed from
- -- semantic point of view (e.g. for ASIS queries).
+ -- semantic point of view (e.g. for ASIS queries). The unit
+ -- entities are not fully analyzed, so we need to follow unit
+ -- links in the tree.
Set_Entity (Nam, Ent);
Nam := Prefix (Nam);
- Ent := Scope (Ent);
+ Ent :=
+ Defining_Entity
+ (Unit (Parent_Spec (Unit_Declaration_Node (Ent))));
-- Set entity of last ancestor
Write_Eol;
end if;
- -- We do not apply the restrictions to an internal unit unless
- -- we are compiling the internal unit as a main unit. This check
- -- is also skipped for dummy units (for missing packages).
+ -- We do not apply the restrictions to an internal unit unless we are
+ -- compiling the internal unit as a main unit. This check is also
+ -- skipped for dummy units (for missing packages).
if Sloc (Uname) /= No_Location
and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
("instantiation depends on itself", Name (With_Clause));
elsif not Is_Visible_Child_Unit (Uname) then
+
+ -- Abandon processing in case of previous errors
+
+ if No (Scope (Uname)) then
+ pragma Assert (Serious_Errors_Detected /= 0);
+ return;
+ end if;
+
Set_Is_Visible_Child_Unit (Uname);
-- If the child unit appears in the context of its parent, it is
if Is_Child_Unit (Uname)
and then Is_Visible_Child_Unit (Uname)
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Decl1 : constant Node_Id := Unit_Declaration_Node (P);
and then Present (Parent_Spec (Lib_Unit));
end Is_Child_Spec;
+ ------------------------------------
+ -- Is_Legal_Shadow_Entity_In_Body --
+ ------------------------------------
+
+ function Is_Legal_Shadow_Entity_In_Body (T : Entity_Id) return Boolean is
+ C_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
+ begin
+ return Nkind (Unit (C_Unit)) = N_Package_Body
+ and then
+ Has_With_Clause
+ (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
+ end Is_Legal_Shadow_Entity_In_Body;
+
-----------------------
-- Load_Needed_Body --
-----------------------
-- If the unit is not generic, but contains a generic unit, it is loaded on
-- demand, at the point of instantiation (see ch12).
- procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
+ procedure Load_Needed_Body
+ (N : Node_Id;
+ OK : out Boolean;
+ Do_Analyze : Boolean := True)
+ is
Body_Name : Unit_Name_Type;
Unum : Unit_Number_Type;
Write_Eol;
end if;
- Semantics (Cunit (Unum));
+ if Do_Analyze then
+ Semantics (Cunit (Unum));
+ end if;
end if;
OK := True;
Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
P : constant Entity_Id := Cunit_Entity (Unum);
- Spec : Node_Id; -- To denote a package specification
- Lim_Typ : Entity_Id; -- To denote shadow entities
- Comp_Typ : Entity_Id; -- To denote real entities
+ Spec : Node_Id; -- To denote a package specification
+ Lim_Typ : Entity_Id; -- To denote shadow entities
+ Comp_Typ : Entity_Id; -- To denote real entities
- Lim_Header : Entity_Id; -- Package entity
- Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
- Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
+ Lim_Header : Entity_Id; -- Package entity
+ Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
+ Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
- procedure Decorate_Incomplete_Type
- (E : Entity_Id;
- Scop : Entity_Id);
+ procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id);
-- Add attributes of an incomplete type to a shadow entity. The same
-- attributes are placed on the real entity, so that gigi receives
-- a consistent view.
procedure Decorate_Tagged_Type
(Loc : Source_Ptr;
T : Entity_Id;
- Scop : Entity_Id);
- -- Set basic attributes of tagged type T, including its class_wide type.
- -- The parameters Loc, Scope are used to decorate the class_wide type.
+ Scop : Entity_Id;
+ Mark : Boolean := False);
+ -- Set basic attributes of tagged type T, including its class-wide type.
+ -- The parameters Loc, Scope are used to decorate the class-wide type.
+ -- Use flag Mark to label the class-wide type as Materialize_Entity.
- procedure Build_Chain
- (Scope : Entity_Id;
- First_Decl : Node_Id);
+ procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id);
-- Construct list of shadow entities and attach it to entity of
-- package that is mentioned in a limited_with clause.
-- Build a new internal entity and append it to the list of shadow
-- entities available through the limited-header
- ------------------------------
- -- Decorate_Incomplete_Type --
- ------------------------------
-
- procedure Decorate_Incomplete_Type
- (E : Entity_Id;
- Scop : Entity_Id)
- is
- begin
- Set_Ekind (E, E_Incomplete_Type);
- Set_Scope (E, Scop);
- Set_Etype (E, E);
- Set_Is_First_Subtype (E, True);
- Set_Stored_Constraint (E, No_Elist);
- Set_Full_View (E, Empty);
- Init_Size_Align (E);
- end Decorate_Incomplete_Type;
-
- --------------------------
- -- Decorate_Tagged_Type --
- --------------------------
-
- procedure Decorate_Tagged_Type
- (Loc : Source_Ptr;
- T : Entity_Id;
- Scop : Entity_Id)
- is
- CW : Entity_Id;
-
- begin
- Decorate_Incomplete_Type (T, Scop);
- Set_Is_Tagged_Type (T);
-
- -- Build corresponding class_wide type, if not previously done
-
- -- Warning: The class-wide entity is shared by the limited-view
- -- and the full-view.
-
- if No (Class_Wide_Type (T)) then
- CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-
- Set_Ekind (CW, E_Class_Wide_Type);
- Set_Etype (CW, T);
- Set_Scope (CW, Scop);
- Set_Is_Tagged_Type (CW);
- Set_Is_First_Subtype (CW, True);
- Init_Size_Align (CW);
- Set_Has_Unknown_Discriminants (CW, True);
- Set_Class_Wide_Type (CW, CW);
- Set_Equivalent_Type (CW, Empty);
- Set_From_With_Type (CW, From_With_Type (T));
-
- Set_Class_Wide_Type (T, CW);
- end if;
- end Decorate_Tagged_Type;
-
- ------------------------------------
- -- Decorate_Package_Specification --
- ------------------------------------
-
- procedure Decorate_Package_Specification (P : Entity_Id) is
- begin
- -- Place only the most basic attributes
-
- Set_Ekind (P, E_Package);
- Set_Etype (P, Standard_Void_Type);
- end Decorate_Package_Specification;
-
- --------------------------------
- -- New_Internal_Shadow_Entity --
- --------------------------------
-
- function New_Internal_Shadow_Entity
- (Kind : Entity_Kind;
- Sloc_Value : Source_Ptr;
- Id_Char : Character) return Entity_Id
- is
- E : constant Entity_Id :=
- Make_Defining_Identifier (Sloc_Value,
- Chars => New_Internal_Name (Id_Char));
-
- begin
- Set_Ekind (E, Kind);
- Set_Is_Internal (E, True);
-
- if Kind in Type_Kind then
- Init_Size_Align (E);
- end if;
-
- Append_Entity (E, Lim_Header);
- Last_Lim_E := E;
- return E;
- end New_Internal_Shadow_Entity;
-
-----------------
-- Build_Chain --
-----------------
- procedure Build_Chain
- (Scope : Entity_Id;
- First_Decl : Node_Id)
- is
+ procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is
Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean;
Decl : Node_Id;
if not Analyzed_Unit then
if Is_Tagged then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
end if;
-- Create shadow entity for type
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ Lim_Typ :=
+ New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ));
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+ Set_Private_Dependents (Lim_Typ, New_Elmt_List);
- elsif Nkind (Decl) = N_Private_Type_Declaration
- or else Nkind (Decl) = N_Incomplete_Type_Declaration
+ elsif Nkind_In (Decl, N_Private_Type_Declaration,
+ N_Incomplete_Type_Declaration,
+ N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
then
Comp_Typ := Defining_Identifier (Decl);
+ Is_Tagged :=
+ Nkind_In (Decl, N_Private_Type_Declaration,
+ N_Incomplete_Type_Declaration)
+ and then Tagged_Present (Decl);
+
if not Analyzed_Unit then
- if Tagged_Present (Decl) then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ if Is_Tagged then
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
else
Decorate_Incomplete_Type (Comp_Typ, Scope);
end if;
end if;
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ Lim_Typ :=
+ New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
- if Tagged_Present (Decl) then
+ if Is_Tagged then
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
else
Decorate_Incomplete_Type (Lim_Typ, Scope);
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+ -- Initialize Private_Depedents, so the field has the proper
+ -- type, even though the list will remain empty.
+
+ Set_Private_Dependents (Lim_Typ, New_Elmt_List);
+
elsif Nkind (Decl) = N_Private_Extension_Declaration then
Comp_Typ := Defining_Identifier (Decl);
if not Analyzed_Unit then
- Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True);
end if;
-- Create shadow entity for type
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ Lim_Typ :=
+ New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_Scope (Comp_Typ, Scope);
end if;
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ Lim_Typ :=
+ New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
Decorate_Package_Specification (Lim_Typ);
Set_Scope (Lim_Typ, Scope);
- Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
end loop;
end Build_Chain;
+ ------------------------------
+ -- Decorate_Incomplete_Type --
+ ------------------------------
+
+ procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is
+ begin
+ Set_Ekind (E, E_Incomplete_Type);
+ Set_Scope (E, Scop);
+ Set_Etype (E, E);
+ Set_Is_First_Subtype (E, True);
+ Set_Stored_Constraint (E, No_Elist);
+ Set_Full_View (E, Empty);
+ Init_Size_Align (E);
+ end Decorate_Incomplete_Type;
+
+ --------------------------
+ -- Decorate_Tagged_Type --
+ --------------------------
+
+ procedure Decorate_Tagged_Type
+ (Loc : Source_Ptr;
+ T : Entity_Id;
+ Scop : Entity_Id;
+ Mark : Boolean := False)
+ is
+ CW : Entity_Id;
+
+ begin
+ Decorate_Incomplete_Type (T, Scop);
+ Set_Is_Tagged_Type (T);
+
+ -- Build corresponding class_wide type, if not previously done
+
+ -- Note: The class-wide entity is shared by the limited-view
+ -- and the full-view.
+
+ if No (Class_Wide_Type (T)) then
+ CW := New_External_Entity (E_Void, Scope (T), Loc, T, 'C', 0, 'T');
+
+ -- Set parent to be the same as the parent of the tagged type.
+ -- We need a parent field set, and it is supposed to point to
+ -- the declaration of the type. The tagged type declaration
+ -- essentially declares two separate types, the tagged type
+ -- itself and the corresponding class-wide type, so it is
+ -- reasonable for the parent fields to point to the declaration
+ -- in both cases.
+
+ Set_Parent (CW, Parent (T));
+
+ -- Set remaining fields of classwide type
+
+ Set_Ekind (CW, E_Class_Wide_Type);
+ Set_Etype (CW, T);
+ Set_Scope (CW, Scop);
+ Set_Is_Tagged_Type (CW);
+ Set_Is_First_Subtype (CW, True);
+ Init_Size_Align (CW);
+ Set_Has_Unknown_Discriminants (CW, True);
+ Set_Class_Wide_Type (CW, CW);
+ Set_Equivalent_Type (CW, Empty);
+ Set_From_With_Type (CW, From_With_Type (T));
+ Set_Materialize_Entity (CW, Mark);
+
+ -- Link type to its class-wide type
+
+ Set_Class_Wide_Type (T, CW);
+ end if;
+ end Decorate_Tagged_Type;
+
+ ------------------------------------
+ -- Decorate_Package_Specification --
+ ------------------------------------
+
+ procedure Decorate_Package_Specification (P : Entity_Id) is
+ begin
+ -- Place only the most basic attributes
+
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ end Decorate_Package_Specification;
+
+ --------------------------------
+ -- New_Internal_Shadow_Entity --
+ --------------------------------
+
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id
+ is
+ E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
+
+ begin
+ Set_Ekind (E, Kind);
+ Set_Is_Internal (E, True);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (E);
+ end if;
+
+ Append_Entity (E, Lim_Header);
+ Last_Lim_E := E;
+ return E;
+ end New_Internal_Shadow_Entity;
+
-- Start of processing for Build_Limited_Views
begin
pragma Assert (Limited_Present (N));
- -- A library_item mentioned in a limited_with_clause shall
- -- be a package_declaration, not a subprogram_declaration,
- -- generic_declaration, generic_instantiation, or
- -- package_renaming_declaration
+ -- A library_item mentioned in a limited_with_clause is a package
+ -- declaration, not a subprogram declaration, generic declaration,
+ -- generic instantiation, or package renaming declaration.
case Nkind (Unit (Library_Unit (N))) is
-
when N_Package_Declaration =>
null;
-- Build the header of the limited_view
- Lim_Header := Make_Defining_Identifier (Sloc (N),
- Chars => New_Internal_Name (Id_Char => 'Z'));
+ Lim_Header := Make_Temporary (Sloc (N), 'Z');
Set_Ekind (Lim_Header, E_Package);
Set_Is_Internal (Lim_Header);
Set_Limited_View (P, Lim_Header);
First_Decl => First (Private_Declarations (Spec)));
if Last_Pub_Lim_E /= Empty then
- Set_First_Private_Entity (Lim_Header,
- Next_Entity (Last_Pub_Lim_E));
+ Set_First_Private_Entity
+ (Lim_Header, Next_Entity (Last_Pub_Lim_E));
else
- Set_First_Private_Entity (Lim_Header,
- First_Entity (P));
+ Set_First_Private_Entity
+ (Lim_Header, First_Entity (P));
end if;
Set_Limited_View_Installed (Spec);
then
return True;
- elsif Ekind (E) = E_Generic_Function
- or else Ekind (E) = E_Generic_Procedure
- then
+ elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
return True;
elsif Ekind (E) = E_Generic_Package
return True;
elsif Ekind (E) = E_Package
- and then
- Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
+ and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
then
Ent := First_Entity (E);
begin
if Ekind (Unit_Name) = E_Generic_Package
- and then
- Nkind (Unit_Declaration_Node (Unit_Name)) =
+ and then Nkind (Unit_Declaration_Node (Unit_Name)) =
N_Generic_Package_Declaration
and then
Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
then
Set_Body_Needed_For_SAL (Unit_Name);
- elsif Ekind (Unit_Name) = E_Generic_Procedure
- or else Ekind (Unit_Name) = E_Generic_Function
- then
+ elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
Set_Body_Needed_For_SAL (Unit_Name);
elsif Is_Subprogram (Unit_Name)
Write_Eol;
end if;
- -- Prepare the removal of the shadow entities from visibility. The
- -- first element of the limited view is a header (an E_Package
- -- entity) that is used to reference the first shadow entity in the
- -- private part of the package
+ -- Prepare the removal of the shadow entities from visibility. The first
+ -- element of the limited view is a header (an E_Package entity) that is
+ -- used to reference the first shadow entity in the private part of the
+ -- package
Lim_Header := Limited_View (P);
Lim_Typ := First_Entity (Lim_Header);
if Ekind (Lim_Typ) /= E_Package
and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
then
- -- Handle incomplete types of the real view. For this purpose
- -- we traverse the list of visible entities to look for an
- -- incomplete type in the real-view associated with Lim_Typ.
-
- E := First_Entity (P);
- while Present (E) and then E /= First_Private_Entity (P) loop
- exit when Ekind (E) = E_Incomplete_Type
- and then Present (Full_View (E))
- and then Full_View (E) = Lim_Typ;
-
- Next_Entity (E);
- end loop;
+ -- If the package has incomplete types, the limited view of the
+ -- incomplete type is in fact never visible (AI05-129) but we
+ -- have created a shadow entity E1 for it, that points to E2,
+ -- a non-limited incomplete type. This in turn has a full view
+ -- E3 that is the full declaration. There is a corresponding
+ -- shadow entity E4. When reinstalling the non-limited view,
+ -- E2 must become the current entity and E3 must be ignored.
+
+ E := Non_Limited_View (Lim_Typ);
+
+ if Present (Current_Entity (E))
+ and then Ekind (Current_Entity (E)) = E_Incomplete_Type
+ and then Full_View (Current_Entity (E)) = E
+ then
- -- If the previous search was not sucessful then the entity
- -- to be restored in the homonym list is the non-limited view
+ -- Lim_Typ is the limited view of a full type declaration
+ -- that has a previous incomplete declaration, i.e. E3 from
+ -- the previous description. Nothing to insert.
- if E = First_Private_Entity (P) then
- E := Non_Limited_View (Lim_Typ);
- end if;
+ null;
- pragma Assert (not In_Chain (E));
+ else
+ pragma Assert (not In_Chain (E));
- Prev := Current_Entity (Lim_Typ);
+ Prev := Current_Entity (Lim_Typ);
- if Prev = Lim_Typ then
- Set_Current_Entity (E);
+ if Prev = Lim_Typ then
+ Set_Current_Entity (E);
- else
- while Present (Prev)
- and then Homonym (Prev) /= Lim_Typ
- loop
- Prev := Homonym (Prev);
- end loop;
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= Lim_Typ
+ loop
+ Prev := Homonym (Prev);
+ end loop;
- if Present (Prev) then
- Set_Homonym (Prev, E);
+ if Present (Prev) then
+ Set_Homonym (Prev, E);
+ end if;
end if;
- end if;
- -- We must also set the next homonym entity of the real entity
- -- to handle the case in which the next homonym was a shadow
- -- entity.
+ -- Preserve structure of homonym chain
- Set_Homonym (E, Homonym (Lim_Typ));
+ Set_Homonym (E, Homonym (Lim_Typ));
+ end if;
end if;
Next_Entity (Lim_Typ);
end if;
if Present (P_Spec) then
-
P := Unit (P_Spec);
P_Name := Get_Parent_Entity (P);
Remove_Context_Clauses (P_Spec);
Set_In_Package_Body (P_Name, False);
- -- This is the recursive call to remove the context of any
- -- higher level parent. This recursion ensures that all parents
- -- are removed in the reverse order of their installation.
+ -- This is the recursive call to remove the context of any higher
+ -- level parent. This recursion ensures that all parents are removed
+ -- in the reverse order of their installation.
Remove_Parents (P);
end if;
Item : Node_Id;
function In_Regular_With_Clause (E : Entity_Id) return Boolean;
- -- Check whether a given unit appears in a regular with_clause.
- -- Used to determine whether a private_with_clause, implicit or
- -- explicit, should be ignored.
+ -- Check whether a given unit appears in a regular with_clause. Used to
+ -- determine whether a private_with_clause, implicit or explicit, should
+ -- be ignored.
----------------------------
-- In_Regular_With_Clause --
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
-
- -- If private_with_clause is redundant, remove it from
- -- context, as a small optimization to subsequent handling
- -- of private_with clauses in other nested packages..
+ -- If private_with_clause is redundant, remove it from context,
+ -- as a small optimization to subsequent handling of private_with
+ -- clauses in other nested packages.
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
Nxt : constant Node_Id := Next (Item);
-
begin
Remove (Item);
Item := Nxt;
P : constant Entity_Id := Scope (Unit_Name);
begin
-
if Debug_Flag_I then
Write_Str ("remove unit ");
Write_Name (Chars (Unit_Name));
OSDN Git Service
