-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Debug; use Debug;
-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 Impunit; use Impunit;
-with Inline; use Inline;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-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;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Dist; use Sem_Dist;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Style; use Style;
-with Stylesw; use Stylesw;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Put_Image;
+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 Impunit; use Impunit;
+with Inline; use Inline;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+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;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dist; use Sem_Dist;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Style; use Style;
+with Stylesw; use Stylesw;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
package body Sem_Ch10 is
-- required in order to avoid passing non-decorated entities to the
-- back-end. Implements Ada 2005 (AI-50217).
+ 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.
+
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 that the shadow entity is not already in the homonym chain, for
-- example through a limited_with clause in a parent unit.
- procedure Install_Context_Clauses (N : Node_Id);
+ procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True);
-- Subsidiary to Install_Context and Install_Parents. Process all with
- -- and use clauses for current unit and its library unit if any.
+ -- and use clauses for current unit and its library unit if any. The flag
+ -- Chain is used to control the "chaining" or linking together of use-type
+ -- and use-package clauses to avoid circularities with reinstalling
+ -- clauses.
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).
- procedure Install_Limited_Withed_Unit (N : Node_Id);
+ procedure Install_Limited_With_Clause (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
-- structures for the current compilation. Implements Ada 2005 (AI-50217).
- 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.
-
- procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
+ procedure Install_Parents
+ (Lib_Unit : Node_Id;
+ Is_Private : Boolean;
+ Chain : Boolean := True);
-- This procedure establishes the context for the compilation of a child
-- unit. If Lib_Unit is a child library spec then the context of the parent
-- is installed, and the parent itself made immediately visible, so that
-- parents are loaded in the nested case. If Lib_Unit is a library body,
-- the only effect of Install_Parents is to install the private decls of
-- the parents, because the visible parent declarations will have been
- -- installed as part of the context of the corresponding spec.
+ -- installed as part of the context of the corresponding spec. The flag
+ -- Chain is used to control the "chaining" or linking of use-type and
+ -- use-package clauses to avoid circularities when installing context.
procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
-- In the compilation of a child unit, a child of any of the ancestor
-- an enclosing scope. Iterate over context to find child units of U_Name
-- or of some ancestor of it.
+ procedure Install_With_Clause
+ (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.
+
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
-- Subsidiary of previous one. Remove use_ and with_clauses
procedure Remove_Limited_With_Clause (N : Node_Id);
- -- Remove from visibility the shadow entities introduced for a package
- -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
+ -- Remove the shadow entities from visibility introduced for a package
+ -- mentioned in limited with clause N. Implements Ada 2005 (AI-50217).
+
+ procedure Remove_Limited_With_Unit
+ (Pack_Decl : Node_Id;
+ Lim_Clause : Node_Id := Empty);
+ -- Remove the shadow entities from visibility introduced for a package
+ -- denoted by declaration Pack_Decl. Lim_Clause is the related limited
+ -- with clause, if any. Implements Ada 2005 (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
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.
-
procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the
-- main unit (after dealing with any context clauses).
-- of the package. Links between corresponding entities in both chains
-- allow the compiler to select the proper view of a given type, depending
-- on the context. Note that in contrast with the handling of private
- -- types, the limited view and the non-limited view of a type are treated
+ -- types, the limited view and the nonlimited view of a type are treated
-- as separate entities, and no entity exchange needs to take place, which
-- makes the implementation much simpler than could be feared.
------------------------------
procedure Analyze_Compilation_Unit (N : Node_Id) is
- Unit_Node : constant Node_Id := Unit (N);
- Lib_Unit : Node_Id := Library_Unit (N);
- Spec_Id : Entity_Id;
- Main_Cunit : constant Node_Id := Cunit (Main_Unit);
- Par_Spec_Name : Unit_Name_Type;
- Unum : Unit_Number_Type;
-
procedure Check_Redundant_Withs
(Context_Items : List_Id;
Spec_Context_Items : List_Id := No_List);
procedure Process_Body_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Used_Type_Or_Elab : in out Boolean);
+ Used : out Boolean;
+ Used_Type_Or_Elab : 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 or
procedure Process_Spec_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Withed : in out Boolean;
+ Used : out Boolean;
+ Withed : out Boolean;
Exit_On_Self : Boolean := False);
-- Examine the context clauses of a package spec, trying to match
-- the name entity of Clause with any list element. If the match
procedure Process_Body_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Used_Type_Or_Elab : in out Boolean)
+ Used : out Boolean;
+ Used_Type_Or_Elab : out Boolean)
is
Nam_Ent : constant Entity_Id := Entity (Name (Clause));
Cont_Item : Node_Id;
Prag_Unit : Node_Id;
- Subt_Mark : Node_Id;
Use_Item : Node_Id;
function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
then
-- Search through use clauses
- Use_Item := First (Names (Cont_Item));
- while Present (Use_Item) and then not Used loop
+ Use_Item := Name (Cont_Item);
- -- Case of a direct use of the one we are looking for
+ -- Case of a direct use of the one we are looking for
- if Entity (Use_Item) = Nam_Ent then
- Used := True;
+ if Entity (Use_Item) = Nam_Ent then
+ Used := True;
- -- Handle nested case, as in "with P; use P.Q.R"
-
- else
- declare
- UE : Node_Id;
+ -- Handle nested case, as in "with P; use P.Q.R"
- begin
- -- Loop through prefixes looking for match
+ else
+ declare
+ UE : Node_Id;
- UE := Use_Item;
- while Nkind (UE) = N_Expanded_Name loop
- if Same_Unit (Prefix (UE), Nam_Ent) then
- Used := True;
- exit;
- end if;
+ begin
+ -- Loop through prefixes looking for match
- UE := Prefix (UE);
- end loop;
- end;
- end if;
+ UE := Use_Item;
+ while Nkind (UE) = N_Expanded_Name loop
+ if Same_Unit (Prefix (UE), Nam_Ent) then
+ Used := True;
+ exit;
+ end if;
- Next (Use_Item);
- end loop;
+ UE := Prefix (UE);
+ end loop;
+ end;
+ end if;
-- USE TYPE clause
elsif Nkind (Cont_Item) = N_Use_Type_Clause
and then not Used_Type_Or_Elab
then
- Subt_Mark := First (Subtype_Marks (Cont_Item));
- while Present (Subt_Mark)
- and then not Used_Type_Or_Elab
- loop
- if Same_Unit (Prefix (Subt_Mark), Nam_Ent) then
- Used_Type_Or_Elab := True;
- end if;
+ declare
+ UE : Node_Id;
- Next (Subt_Mark);
- end loop;
+ begin
+ -- Loop through prefixes looking for a match
+
+ UE := Prefix (Subtype_Mark (Cont_Item));
+ loop
+ if not Used_Type_Or_Elab
+ and then Same_Unit (UE, Nam_Ent)
+ then
+ Used_Type_Or_Elab := True;
+ end if;
+
+ exit when Nkind (UE) /= N_Expanded_Name;
+ UE := Prefix (UE);
+ end loop;
+ end;
-- Pragma Elaborate or Elaborate_All
elsif Nkind (Cont_Item) = N_Pragma
and then
- Nam_In (Pragma_Name (Cont_Item), Name_Elaborate,
- Name_Elaborate_All)
+ Pragma_Name_Unmapped (Cont_Item)
+ in Name_Elaborate | Name_Elaborate_All
and then not Used_Type_Or_Elab
then
Prag_Unit :=
procedure Process_Spec_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Withed : in out Boolean;
+ Used : out Boolean;
+ Withed : out Boolean;
Exit_On_Self : Boolean := False)
is
Nam_Ent : constant Entity_Id := Entity (Name (Clause));
Cont_Item : Node_Id;
- Use_Item : Node_Id;
begin
Used := False;
if Nkind (Cont_Item) = N_Use_Package_Clause
and then not Used
then
- Use_Item := First (Names (Cont_Item));
- while Present (Use_Item) and then not Used loop
- if Entity (Use_Item) = Nam_Ent then
- Used := True;
- end if;
-
- Next (Use_Item);
- end loop;
+ if Entity (Name (Cont_Item)) = Nam_Ent then
+ Used := True;
+ end if;
-- Package with clause. Avoid processing self, implicitly
-- generated with clauses or limited with clauses. Note that
-- visibility analysis, but is also not redundant.
elsif Nkind (Cont_Item) = N_With_Clause
- and then not Implicit_With (Cont_Item)
and then Comes_From_Source (Cont_Item)
+ and then not Implicit_With (Cont_Item)
and then not Limited_Present (Cont_Item)
and then Cont_Item /= Clause
and then Entity (Name (Cont_Item)) = Nam_Ent
if Present (Spec_Context_Items) then
declare
- Used_In_Body : Boolean := False;
- Used_In_Spec : Boolean := False;
- Used_Type_Or_Elab : Boolean := False;
- Withed_In_Spec : Boolean := False;
+ Used_In_Body : Boolean;
+ Used_In_Spec : Boolean;
+ Used_Type_Or_Elab : Boolean;
+ Withed_In_Spec : Boolean;
begin
Process_Spec_Clauses
- (Context_List => Spec_Context_Items,
- Clause => Clause,
- Used => Used_In_Spec,
- Withed => Withed_In_Spec);
+ (Context_List => Spec_Context_Items,
+ Clause => Clause,
+ Used => Used_In_Spec,
+ Withed => Withed_In_Spec);
Process_Body_Clauses
- (Context_List => Context_Items,
- Clause => Clause,
- Used => Used_In_Body,
- Used_Type_Or_Elab => Used_Type_Or_Elab);
+ (Context_List => Context_Items,
+ Clause => Clause,
+ Used => Used_In_Body,
+ Used_Type_Or_Elab => Used_Type_Or_Elab);
-- "Type Elab" refers to the presence of either a use
-- type clause, pragmas Elaborate or Elaborate_All.
or else Used_In_Spec)
then
Error_Msg_N -- CODEFIX
- ("redundant with clause in body??", Clause);
+ ("redundant with clause in body?r?", Clause);
end if;
- Used_In_Body := False;
- Used_In_Spec := False;
+ Used_In_Body := False;
+ Used_In_Spec := False;
Used_Type_Or_Elab := False;
- Withed_In_Spec := False;
+ Withed_In_Spec := False;
end;
-- Standalone package spec or body check
else
declare
- Dont_Care : Boolean := False;
- Withed : Boolean := False;
+ Dummy : Boolean := False;
+ Withed : Boolean := False;
begin
-- The mechanism for examining the context clauses of a
-- package spec can be applied to package body clauses.
Process_Spec_Clauses
- (Context_List => Context_Items,
- Clause => Clause,
- Used => Dont_Care,
- Withed => Withed,
- Exit_On_Self => True);
+ (Context_List => Context_Items,
+ Clause => Clause,
+ Used => Dummy,
+ Withed => Withed,
+ Exit_On_Self => True);
if Withed then
Error_Msg_N -- CODEFIX
- ("redundant with clause??", Clause);
+ ("redundant with clause?r?", Clause);
end if;
end;
end if;
end loop;
end Check_Redundant_Withs;
+ -- Local variables
+
+ Main_Cunit : constant Node_Id := Cunit (Main_Unit);
+ Unit_Node : constant Node_Id := Unit (N);
+ Lib_Unit : Node_Id := Library_Unit (N);
+ Par_Spec_Name : Unit_Name_Type;
+ Spec_Id : Entity_Id;
+ Unum : Unit_Number_Type;
+
-- Start of processing for Analyze_Compilation_Unit
begin
+ Exp_Put_Image.Preload_Sink (N);
+
Process_Compilation_Unit_Pragmas (N);
-- If the unit is a subunit whose parent has not been analyzed (which
-- indicates that the main unit is a subunit, either the current one or
- -- one of its descendents) then the subunit is compiled as part of the
+ -- one of its descendants) then the subunit is compiled as part of the
-- 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
Circularity : Boolean := True;
begin
- if Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Unit (N))))
- then
+ if In_Predefined_Unit (N) then
Circularity := False;
else
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
+ -- ignore the entire analysis effort.
if No (Lib_Unit) then
Check_Error_Detected;
-- Verify that the library unit is a package declaration
- if not Nkind_In (Unit (Lib_Unit), N_Package_Declaration,
- N_Generic_Package_Declaration)
+ if Nkind (Unit (Lib_Unit)) not in
+ N_Package_Declaration | N_Generic_Package_Declaration
then
Error_Msg_N
("no legal package declaration for package body", N);
Unum := Get_Cunit_Unit_Number (N);
Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
- if Par_Spec_Name /= No_Unit_Name then
+ if Present (Par_Spec_Name) then
Unum :=
Load_Unit
(Load_Name => Par_Spec_Name,
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.
+ -- Note: We copy the Context_Items from the explicit body
+ -- to the implicit spec, setting the former to Empty_List
+ -- to preserve the treeish nature of the tree, during
+ -- analysis of the spec. Then we put it back the way it
+ -- was -- copy the Context_Items from the spec to the
+ -- body, and set the spec Context_Items to Empty_List.
+ -- It is necessary to preserve the treeish nature,
+ -- because otherwise we will call End_Use_* twice on the
+ -- same thing.
Lib_Unit :=
Make_Compilation_Unit (Loc,
Aux_Decls_Node =>
Make_Compilation_Unit_Aux (Loc));
+ Set_Context_Items (N, Empty_List);
Set_Library_Unit (N, Lib_Unit);
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
Make_Child_Decl_Unit (N);
-- of the child unit does not act as spec any longer.
Set_Acts_As_Spec (N, False);
+ Move_Aspects (From => Unit_Node, To => Unit (Lib_Unit));
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
+
+ -- Restore Context_Items to the body
+
+ Set_Context_Items (N, Context_Items (Lib_Unit));
+ Set_Context_Items (Lib_Unit, Empty_List);
end;
end if;
end if;
end if;
-- All components of the context: with-clauses, library unit, ancestors
- -- if any, (and their context) are analyzed and installed.
+ -- if any, (and their context) are analyzed and installed.
-- Call special debug routine sm if this is the main unit
-- Register predefined units in Rtsfind
- declare
- Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
- begin
- if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
- Set_RTU_Loaded (Unit_Node);
- end if;
- end;
+ if In_Predefined_Unit (N) then
+ Set_RTU_Loaded (Unit_Node);
+ end if;
-- Treat compilation unit pragmas that appear after the library unit
end;
end if;
+ -- Analyze the contract of a [generic] subprogram that acts as a
+ -- compilation unit after all compilation pragmas have been analyzed.
+
+ if Nkind (Unit_Node) in
+ N_Generic_Subprogram_Declaration | N_Subprogram_Declaration
+ then
+ Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node));
+ end if;
+
-- Generate distribution stubs if requested and no error
if N = Main_Cunit
and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
- and then not Fatal_Error (Main_Unit)
+ and then Fatal_Error (Main_Unit) /= Error_Detected
then
if Is_RCI_Pkg_Spec_Or_Body (N) then
-- next compilation, which is either the main unit or some other unit
-- in the context.
- if Nkind_In (Unit_Node, N_Package_Declaration,
- N_Package_Renaming_Declaration,
- N_Subprogram_Declaration)
- or else Nkind (Unit_Node) in N_Generic_Declaration
+ if Nkind (Unit_Node) in N_Package_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Declaration
or else (Nkind (Unit_Node) = N_Subprogram_Body
and then Acts_As_Spec (Unit_Node))
then
Remove_Context (N);
- -- If this is the main unit and we are generating code, we must check
- -- that all generic units in the context have a body if they need it,
- -- even if they have not been instantiated. In the absence of .ali files
- -- for generic units, we must force the load of the body, just to
- -- produce the proper error if the body is absent. We skip this
- -- verification if the main unit itself is generic.
+ -- When generating code for a non-generic main unit, check that withed
+ -- generic units have a body if they need it, even if the units have not
+ -- been instantiated. Force the load of the bodies to produce the proper
+ -- error if the body is absent. The same applies to GNATprove mode, with
+ -- the added benefit of capturing global references within the generic.
+ -- This in turn allows for proper inlining of subprogram bodies without
+ -- a previous declaration.
if Get_Cunit_Unit_Number (N) = Main_Unit
- and then Operating_Mode = Generate_Code
- and then Expander_Active
+ and then ((Operating_Mode = Generate_Code and then Expander_Active)
+ or else
+ (Operating_Mode = Check_Semantics and then GNATprove_Mode))
then
-- Check whether the source for the body of the unit must be included
-- in a standalone library.
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
- -- Ada 2005 (AI-50217): Ignore limited-withed units
+ -- Ada 2005 (AI-50217): Ignore limited-withed units
and then not Limited_Present (Item)
then
Nam := Entity (Name (Item));
- -- Compile generic subprogram, unless it is intrinsic or
+ -- Compile the 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 Present (Renamed_Object (Nam)) then
Un :=
- Load_Unit
- (Load_Name => Get_Body_Name
- (Get_Unit_Name
- (Unit_Declaration_Node
- (Renamed_Object (Nam)))),
- Required => False,
- Subunit => False,
- Error_Node => N,
- Renamings => True);
+ Load_Unit
+ (Load_Name =>
+ Get_Body_Name
+ (Get_Unit_Name
+ (Unit_Declaration_Node
+ (Renamed_Object (Nam)))),
+ Required => False,
+ Subunit => False,
+ Error_Node => N,
+ Renamings => True);
else
Un :=
Load_Unit
- (Load_Name => Get_Body_Name
- (Get_Unit_Name (Item)),
+ (Load_Name =>
+ Get_Body_Name (Get_Unit_Name (Item)),
Required => False,
Subunit => False,
Error_Node => N,
elsif not Analyzed (Cunit (Un))
and then Un /= Main_Unit
- and then not Fatal_Error (Un)
+ and then Fatal_Error (Un) /= Error_Detected
then
Style_Check := False;
Semantics (Cunit (Un));
Style_Check := Save_Style_Check;
end;
+
+ -- In GNATprove mode, force the loading of an Interrupt_Priority when
+ -- processing compilation units with potentially "main" subprograms.
+ -- This is required for the ceiling priority protocol checks, which
+ -- are triggered by these subprograms.
+
+ if GNATprove_Mode
+ and then Nkind (Unit_Node) in N_Function_Instantiation
+ | N_Procedure_Instantiation
+ | N_Subprogram_Body
+ then
+ declare
+ Spec : Node_Id;
+
+ begin
+ case Nkind (Unit_Node) is
+ when N_Subprogram_Body =>
+ Spec := Specification (Unit_Node);
+
+ when N_Subprogram_Instantiation =>
+ Spec :=
+ Subprogram_Specification (Entity (Name (Unit_Node)));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ pragma Assert (Nkind (Spec) in N_Subprogram_Specification);
+
+ -- Main subprogram must have no parameters, and if it is a
+ -- function, it must return an integer.
+
+ if No (Parameter_Specifications (Spec))
+ and then (Nkind (Spec) = N_Procedure_Specification
+ or else
+ Is_Integer_Type (Etype (Result_Definition (Spec))))
+ then
+ SPARK_Implicit_Load (RE_Interrupt_Priority);
+ end if;
+ end;
+ end if;
end if;
-- Deal with creating elaboration counter if needed. We create an
-- units manufactured by the compiler never need elab checks.
if Comes_From_Source (N)
- and then Nkind_In (Unit_Node, N_Package_Declaration,
- N_Generic_Package_Declaration,
- N_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration)
+ and then Nkind (Unit_Node) in N_Package_Declaration
+ | N_Generic_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Subprogram_Declaration
then
declare
Loc : constant Source_Ptr := Sloc (N);
-- where the elaboration routine might otherwise be called more
-- than once.
- -- Case of units which do not require elaboration checks
+ -- They are also needed to ensure explicit visibility from the
+ -- binder generated code of all the units involved in a partition
+ -- when control-flow preservation is requested.
- if
- -- Pure units do not need checks
+ if not Opt.Suppress_Control_Flow_Optimizations
+ and then
+ ( -- 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 pragma 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_Unit (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.
+ -- This is a case where we only need the entity for checking to
+ -- prevent multiple elaboration checks.
Set_Elaboration_Entity_Required (Spec_Id, False);
- -- Case of elaboration entity is required for access before
- -- elaboration checking (so certainly we must build it).
+ -- Otherwise the unit requires an elaboration entity because it
+ -- carries a body.
else
- Set_Elaboration_Entity_Required (Spec_Id, True);
+ Set_Elaboration_Entity_Required (Spec_Id);
end if;
Build_Elaboration_Entity (N, Spec_Id);
-- Loop through actual context items. This is done in two passes:
- -- a) The first pass analyzes non-limited with-clauses and also any
+ -- a) The first pass analyzes nonlimited with clauses and also any
-- configuration pragmas (we need to get the latter analyzed right
-- away, since they can affect processing of subsequent items).
-- Verify that the illegal contexts given in 10.1.2 (18/2) are
-- properly rejected, including renaming declarations.
- 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_Instantiation
+ if Ukind not in N_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Declaration
+ | 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 cannot "
- & "name ancestor", Item);
+ Error_Msg_N
+ ("limited with_clause cannot name ancestor",
+ Item);
exit;
end if;
if Item /= It
and then Nkind (It) = N_With_Clause
and then not Limited_Present (It)
- and then
- Nkind_In (Unit (Library_Unit (It)),
- N_Package_Declaration,
- N_Package_Renaming_Declaration)
+ and then Nkind (Unit (Library_Unit (It))) in
+ N_Package_Declaration |
+ N_Package_Renaming_Declaration
then
if Nkind (Unit (Library_Unit (It))) =
N_Package_Declaration
-- Check if the named package (or some ancestor)
-- leaves visible the full-view of the unit given
- -- in the limited-with clause
+ -- in the limited-with clause.
loop
if Designate_Same_Unit (Lim_Unit_Name,
then
Error_Msg_Sloc := Sloc (It);
Error_Msg_N
- ("simultaneous visibility of limited "
- & "and unlimited views not allowed",
- Item);
- Error_Msg_NE
- ("\unlimited view visible through "
- & "context clause #",
- Item, It);
+ ("simultaneous visibility of limited and "
+ & "unlimited views not allowed", Item);
+ Error_Msg_N
+ ("\unlimited view visible through context "
+ & "clause #", Item);
exit;
elsif Nkind (Unit_Name) = N_Identifier then
Analyze (Item);
end if;
- -- A limited_with does not impose an elaboration order, but
- -- there is a semantic dependency for recompilation purposes.
+ -- A limited_with does not impose an elaboration order, but there
+ -- is a semantic dependency for recompilation purposes.
if not Implicit_With (Item) then
Version_Update (N, Library_Unit (Item));
end if;
- -- Pragmas and use clauses and with clauses other than limited
- -- with's are ignored in this pass through the context items.
+ -- Pragmas and use clauses and with clauses other than limited with's
+ -- are ignored in this pass through the context items.
else
null;
-------------------------------
procedure Analyze_Package_Body_Stub (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
+ Id : constant Entity_Id := Defining_Entity (N);
Nam : Entity_Id;
Opts : Config_Switches_Type;
-- Retain and restore the configuration options of the enclosing
-- context as the proper body may introduce a set of its own.
- Save_Opt_Config_Switches (Opts);
+ Opts := Save_Config_Switches;
-- Indicate that the body of the package exists. If we are doing
-- only semantic analysis, the stub stands for the body. If we are
-- generating code, the existence of the body will be confirmed
-- when we load the proper body.
+ Set_Scope (Id, Current_Scope);
+ Mutate_Ekind (Id, E_Package_Body);
+ Set_Etype (Id, Standard_Void_Type);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
+
Set_Has_Completion (Nam);
- Set_Scope (Defining_Entity (N), Current_Scope);
Set_Corresponding_Spec_Of_Stub (N, Nam);
Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Nam);
- Restore_Opt_Config_Switches (Opts);
+ Restore_Config_Switches (Opts);
end if;
end Analyze_Package_Body_Stub;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
-- are not generating code. In such a case, we analyze the subunit if
- -- present, which is user-friendly and in fact required for ASIS, but we
- -- don't complain if the subunit is missing. In GNATprove_Mode, we issue
- -- an error to avoid formal verification of a partial unit.
+ -- present, which is user-friendly, but we don't complain if the subunit
+ -- is missing. In GNATprove_Mode, we issue an error to avoid formal
+ -- verification of a partial unit.
----------------------
-- Optional_Subunit --
-- 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 or GNATprove_Mode) then
+ if not GNATprove_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
end if;
Subunit => True,
Error_Node => N);
- if not (ASIS_Mode or GNATprove_Mode) then
+ if not GNATprove_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
end if;
-- All done if we successfully loaded the subunit
if Unum /= No_Unit
- and then (not Fatal_Error (Unum) or else Try_Semantics)
+ and then (Fatal_Error (Unum) /= Error_Detected
+ or else Try_Semantics)
then
Comp_Unit := Cunit (Unum);
-- 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)))
+ and then No (Library_Unit (Library_Unit (N)))
then
return;
end if;
+ -- Collect SCO information for loaded subunit if we are in the
+ -- extended main unit.
+
+ if Generate_SCO
+ and then In_Extended_Main_Source_Unit
+ (Cunit_Entity (Current_Sem_Unit))
+ then
+ SCO_Record_Raw (Get_Cunit_Unit_Number (Library_Unit (N)));
+ end if;
+
Analyze_Subunit (Library_Unit (N));
-- Otherwise we must load the subunit and link to it
-- If the main unit is a subunit, then we are just performing semantic
-- analysis on that subunit, and any other subunits of any parent unit
- -- should be ignored, except that if we are building trees for ASIS
- -- usage we want to annotate the stub properly. If the main unit is
- -- itself a subunit, another subunit is irrelevant unless it is a
- -- subunit of the current one, that is to say appears in the current
- -- source tree.
+ -- should be ignored. If the main unit is itself a subunit, another
+ -- subunit is irrelevant unless it is a subunit of the current one, that
+ -- is to say appears in the current source tree.
elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
and then Subunit_Name /= Unit_Name (Main_Unit)
then
- if ASIS_Mode then
- declare
- PB : constant Node_Id := Proper_Body (Unit (Cunit (Main_Unit)));
- begin
- if Nkind_In (PB, N_Package_Body, N_Subprogram_Body)
- and then List_Containing (N) = Declarations (PB)
- then
- Optional_Subunit;
- end if;
- end;
- end if;
-
-- But before we return, set the flag for unloaded subunits. This
-- will suppress junk warnings of variables in the same declarative
-- part (or a higher level one) that are in danger of looking unused
-- 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
- then
+ pragma Assert (Original_Operating_Mode = Generate_Code);
+ if Unum = No_Unit then
Error_Msg_Unit_1 := Subunit_Name;
Error_Msg_File_1 :=
Get_File_Name (Subunit_Name, Subunit => True);
Version_Update (Cunit (Main_Unit), Comp_Unit);
-- Collect SCO information for loaded subunit if we are in
- -- the main unit.
+ -- the extended main unit.
if Generate_SCO
- and then
- In_Extended_Main_Source_Unit
- (Cunit_Entity (Current_Sem_Unit))
+ and then In_Extended_Main_Source_Unit
+ (Cunit_Entity (Current_Sem_Unit))
then
- SCO_Record (Unum);
+ SCO_Record_Raw (Unum);
end if;
-- Analyze the unit if semantics active
- if not Fatal_Error (Unum) or else Try_Semantics then
+ if Fatal_Error (Unum) /= Error_Detected
+ or else Try_Semantics
+ then
Analyze_Subunit (Comp_Unit);
end if;
end if;
----------------------------------
procedure Analyze_Protected_Body_Stub (N : Node_Id) is
- Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+ Id : constant Entity_Id := Defining_Entity (N);
+ Nam : Entity_Id := Current_Entity_In_Scope (Id);
+ Opts : Config_Switches_Type;
begin
Check_Stub_Level (N);
Error_Msg_N ("missing specification for Protected body", N);
else
- -- Currently there are no language-defined aspects that can apply to
- -- a protected body stub. Issue an error and remove the aspects to
- -- prevent cascaded errors.
+ -- Retain and restore the configuration options of the enclosing
+ -- context as the proper body may introduce a set of its own.
+
+ Opts := Save_Config_Switches;
+
+ Set_Scope (Id, Current_Scope);
+ Mutate_Ekind (Id, E_Protected_Body);
+ Set_Etype (Id, Standard_Void_Type);
if Has_Aspects (N) then
- Error_Msg_N
- ("aspects on protected bodies are not allowed",
- First (Aspect_Specifications (N)));
- Remove_Aspects (N);
+ Analyze_Aspect_Specifications (N, Id);
end if;
- Set_Scope (Defining_Entity (N), Current_Scope);
Set_Has_Completion (Etype (Nam));
Set_Corresponding_Spec_Of_Stub (N, Nam);
- Generate_Reference (Nam, Defining_Identifier (N), 'b');
+ Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Etype (Nam));
- end if;
- end Analyze_Protected_Body_Stub;
-
- -------------------------------------------
- -- Analyze_Subprogram_Body_Stub_Contract --
- -------------------------------------------
-
- procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id) is
- Stub_Decl : constant Node_Id := Parent (Parent (Stub_Id));
- Spec_Id : constant Entity_Id := Corresponding_Spec_Of_Stub (Stub_Decl);
-
- begin
- -- A subprogram body stub may act as its own spec or as the completion
- -- of a previous declaration. Depending on the context, the contract of
- -- the stub may contain two sets of pragmas.
-
- -- The stub is a completion, the applicable pragmas are:
- -- Contract_Cases
- -- Depends
- -- Global
- -- Postcondition
- -- Precondition
- -- Test_Case
- if Present (Spec_Id) then
- Analyze_Subprogram_Body_Contract (Stub_Id);
-
- -- The stub acts as its own spec, the applicable pragmas are:
- -- Refined_Depends
- -- Refined_Global
-
- else
- Analyze_Subprogram_Contract (Stub_Id);
+ Restore_Config_Switches (Opts);
end if;
- end Analyze_Subprogram_Body_Stub_Contract;
+ end Analyze_Protected_Body_Stub;
----------------------------------
-- Analyze_Subprogram_Body_Stub --
-- Verify that the identifier for the stub is unique within this
-- declarative part.
- if Nkind_In (Parent (N), N_Block_Statement,
- N_Package_Body,
- N_Subprogram_Body)
+ if Nkind (Parent (N)) in
+ N_Block_Statement | N_Package_Body | N_Subprogram_Body
then
Decl := First (Declarations (Parent (N)));
while Present (Decl) and then Decl /= N loop
-- Retain and restore the configuration options of the enclosing context
-- as the proper body may introduce a set of its own.
- Save_Opt_Config_Switches (Opts);
+ Opts := Save_Config_Switches;
-- Treat stub as a body, which checks conformance if there is a previous
-- declaration, or else introduces entity and its signature.
Analyze_Subprogram_Body (N);
Analyze_Proper_Body (N, Empty);
- Restore_Opt_Config_Switches (Opts);
+ Restore_Config_Switches (Opts);
end Analyze_Subprogram_Body_Stub;
---------------------
-- context before analyzing the proper body itself. On exit, we remove only
-- the explicit context of the subunit.
+ -- WARNING: This routine manages SPARK regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- SPARK mode.
+
procedure Analyze_Subunit (N : Node_Id) is
Lib_Unit : constant Node_Id := Library_Unit (N);
Par_Unit : constant Entity_Id := Current_Scope;
Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
- Num_Scopes : Int := 0;
+ Num_Scopes : Nat := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
Svg : constant Suppress_Record := Scope_Suppress;
procedure Analyze_Subunit_Context is
Item : Node_Id;
- Nam : Node_Id;
Unit_Name : Entity_Id;
begin
-- attempt processing.
if Serious_Errors_Detected > 0
- and then No (Entity (Name (Item)))
+ and then No (Entity (Name (Item)))
then
Set_Entity (Name (Item), Standard_Standard);
end if;
end if;
elsif Nkind (Item) = N_Use_Package_Clause then
- Nam := First (Names (Item));
- while Present (Nam) loop
- Analyze (Nam);
- Next (Nam);
- end loop;
+ Analyze (Name (Item));
elsif Nkind (Item) = N_Use_Type_Clause then
- Nam := First (Subtype_Marks (Item));
- while Present (Nam) loop
- Analyze (Nam);
- Next (Nam);
- end loop;
+ Analyze (Subtype_Mark (Item));
end if;
Next (Item);
Re_Install_Parents (Library_Unit (L), Scope (Scop));
end if;
- Install_Context (L);
+ Install_Context (L, False);
-- If the subunit occurs within a child unit, we must restore the
-- immediate visibility of any siblings that may occur in context.
+ -- In addition, we must reset the previous visibility of the
+ -- parent unit which is now on the scope stack. This is because
+ -- the Previous_Visibility was previously set when removing the
+ -- context. This is necessary to prevent the parent entity from
+ -- remaining visible after the subunit is compiled. This only
+ -- has an effect if a homonym exists in a body to be processed
+ -- later if inlining is enabled.
if Present (Enclosing_Child) then
Install_Siblings (Enclosing_Child, L);
+ Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
+ False;
end if;
Push_Scope (Scop);
for J in reverse 1 .. Num_Scopes loop
U := Use_Clauses (J);
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
- Install_Use_Clauses (U, Force_Installation => True);
+ Install_Use_Clauses (U);
end loop;
end Re_Install_Use_Clauses;
Pop_Scope;
end Remove_Scope;
+ Saved_SM : SPARK_Mode_Type := SPARK_Mode;
+ Saved_SMP : Node_Id := SPARK_Mode_Pragma;
+ -- Save the SPARK mode-related data to restore on exit. Removing
+ -- enclosing scopes and contexts to provide a clean environment for the
+ -- context of the subunit will eliminate any previously set SPARK_Mode.
+
-- Start of processing for Analyze_Subunit
begin
Remove_Scope;
end if;
- if Nkind (Unit (Lib_Spec)) = N_Package_Body then
+ if Nkind (Unit (Lib_Spec)) in N_Package_Body | N_Subprogram_Body
+ then
Remove_Context (Library_Unit (Lib_Spec));
end if;
end if;
Analyze_Subunit_Context;
+ -- Take into account the effect of any SPARK_Mode configuration
+ -- pragma, which takes precedence over a different value of
+ -- SPARK_Mode inherited from the context of the stub.
+
+ if SPARK_Mode /= None then
+ Saved_SM := SPARK_Mode;
+ Saved_SMP := SPARK_Mode_Pragma;
+ end if;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
Set_Is_Immediately_Visible (Par_Unit);
end if;
Re_Install_Use_Clauses;
- Install_Context (N);
+ Install_Context (N, Chain => False);
-- Restore state of suppress flags for current body
end if;
Generate_Parent_References (Unit (N), Par_Unit);
+
+ -- Reinstall the SPARK_Mode which was in effect prior to any scope and
+ -- context manipulations, taking into account a possible SPARK_Mode
+ -- configuration pragma if present.
+
+ Install_SPARK_Mode (Saved_SM, Saved_SMP);
+
+ -- If the subunit is part of a compilation unit which is subject to
+ -- pragma Elaboration_Checks, set the model specified by the pragma
+ -- because it applies to all parts of the unit.
+
+ Install_Elaboration_Model (Par_Unit);
+
+ -- The syntax rules require a proper body for a subprogram subunit
+
+ if Nkind (Proper_Body (Sinfo.Nodes.Unit (N))) = N_Subprogram_Declaration
+ then
+ if Null_Present (Specification (Proper_Body (Sinfo.Nodes.Unit (N))))
+ then
+ Error_Msg_N
+ ("null procedure not allowed as subunit",
+ Proper_Body (Unit (N)));
+ else
+ Error_Msg_N
+ ("subprogram declaration not allowed as subunit",
+ Defining_Unit_Name (Specification (Proper_Body (Unit (N)))));
+ end if;
+ end if;
+
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
----------------------------
procedure Analyze_Task_Body_Stub (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (N);
- Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
+ Nam : Entity_Id := Current_Entity_In_Scope (Id);
begin
Check_Stub_Level (N);
Error_Msg_N ("missing specification for task body", N);
else
- -- Currently there are no language-defined aspects that can apply to
- -- a task body stub. Issue an error and remove the aspects to prevent
- -- cascaded errors.
+ Set_Scope (Id, Current_Scope);
+ Mutate_Ekind (Id, E_Task_Body);
+ Set_Etype (Id, Standard_Void_Type);
if Has_Aspects (N) then
- Error_Msg_N
- ("aspects on task bodies are not allowed",
- First (Aspect_Specifications (N)));
- Remove_Aspects (N);
+ Analyze_Aspect_Specifications (N, Id);
end if;
- Set_Scope (Defining_Entity (N), Current_Scope);
- Generate_Reference (Nam, Defining_Identifier (N), 'b');
+ Generate_Reference (Nam, Id, 'b');
Set_Corresponding_Spec_Of_Stub (N, Nam);
-- Check for duplicate stub, if so give message and terminate
if Expander_Active then
Insert_After (N,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Identifier (Loc,
Chars => New_External_Name (Chars (Etype (Nam)), 'E')),
Expression => New_Occurrence_Of (Standard_True, Loc)));
-- 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;
+ if In_Predefined_Renaming (U) then
+ Check_Restriction (No_Obsolescent_Features, N);
+ Restriction_Violation := True;
+ end if;
end if;
-- Check No_Implementation_Units violation
-- Ada 2005 (AI-50217): Build visibility structures but do not
-- analyze the unit.
+ -- If the designated unit is a predefined unit, which might be used
+ -- implicitly through the rtsfind machinery, a limited with clause
+ -- on such a unit is usually pointless, because run-time units are
+ -- unlikely to appear in mutually dependent units, and because this
+ -- disables the rtsfind mechanism. We transform such limited with
+ -- clauses into regular with clauses.
+
if Sloc (U) /= No_Location then
- Build_Limited_Views (N);
+ if In_Predefined_Unit (U) then
+ Set_Limited_Present (N, False);
+ Analyze_With_Clause (N);
+ else
+ Build_Limited_Views (N);
+ end if;
end if;
return;
end if;
- -- If the library unit is a predefined unit, and we are in high
- -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
- -- for the analysis of the with'ed unit. This mode does not prevent
- -- explicit with'ing of run-time units.
-
- if Configurable_Run_Time_Mode
- and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U)))
- then
- Configurable_Run_Time_Mode := False;
- Semantics (Library_Unit (N));
- Configurable_Run_Time_Mode := True;
+ -- If we are compiling under "don't quit" mode (-gnatq) and we have
+ -- already detected serious errors then we mark the with-clause nodes as
+ -- analyzed before the corresponding compilation unit is analyzed. This
+ -- is done here to protect the frontend against never ending recursion
+ -- caused by circularities in the sources (because the previous errors
+ -- may break the regular machine of the compiler implemented in
+ -- Load_Unit to detect circularities).
- else
- Semantics (Library_Unit (N));
+ if Serious_Errors_Detected > 0 and then Try_Semantics then
+ Set_Analyzed (N);
end if;
- Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
+ Semantics (Library_Unit (N));
+
+ Intunit := Is_Internal_Unit (Current_Sem_Unit);
if Sloc (U) /= No_Location then
if Nkind (Nam) = N_Selected_Component
and then Nkind (Prefix (Nam)) = N_Identifier
and then Chars (Prefix (Nam)) = Name_Gnat
- and then Nam_In (Chars (Selector_Name (Nam)),
- Name_Most_Recent_Exception,
- Name_Exception_Traces)
+ and then Chars (Selector_Name (Nam))
+ in Name_Most_Recent_Exception | Name_Exception_Traces
then
Check_Restriction (No_Exception_Propagation, N);
Special_Exception_Package_Used := True;
and then not Implicit_With (N)
and then not Restriction_Violation
then
- declare
- U_Kind : constant Kind_Of_Unit :=
- Get_Kind_Of_Unit (Get_Source_Unit (U));
-
- begin
- if U_Kind = Implementation_Unit then
+ case Get_Kind_Of_Unit (Get_Source_Unit (U)) is
+ when Implementation_Unit =>
Error_Msg_F ("& is an internal 'G'N'A'T unit?i?", Name (N));
-- Add alternative name if available, otherwise issue a
Error_Msg_F ("\use ""~"" instead?i?", Name (N));
else
Error_Msg_F
- ("\use of this unit is non-portable " &
- "and version-dependent?i?", Name (N));
+ ("\use of this unit is non-portable and "
+ & "version-dependent?i?", 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?i?", Name (N));
+ when Not_Predefined_Unit | Ada_95_Unit =>
+ null; -- no checks needed
- 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?i?", Name (N));
- end if;
- end;
+ when Ada_2005_Unit =>
+ if Ada_Version < Ada_2005
+ and then Warn_On_Ada_2005_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2005 unit?i?", Name (N));
+ end if;
+
+ when Ada_2012_Unit =>
+ if Ada_Version < Ada_2012
+ and then Warn_On_Ada_2012_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N));
+ end if;
+
+ when Ada_2022_Unit =>
+ if Ada_Version < Ada_2022
+ and then Warn_On_Ada_2022_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2022 unit?i?", Name (N));
+ end if;
+ end case;
end if;
end if;
if Private_Present (N) then
Set_Is_Immediately_Visible (E_Name, False);
end if;
+
+ -- Propagate Fatal_Error setting from with'ed unit to current unit
+
+ case Fatal_Error (Get_Source_Unit (Library_Unit (N))) is
+
+ -- Nothing to do if with'ed unit had no error
+
+ when None =>
+ null;
+
+ -- If with'ed unit had a detected fatal error, propagate it
+
+ when Error_Detected =>
+ Set_Fatal_Error (Current_Sem_Unit, Error_Detected);
+
+ -- If with'ed unit had an ignored error, then propagate it but do not
+ -- overide an existring setting.
+
+ when Error_Ignored =>
+ if Fatal_Error (Current_Sem_Unit) = None then
+ Set_Fatal_Error (Current_Sem_Unit, Error_Ignored);
+ end if;
+ end case;
end Analyze_With_Clause;
------------------------------
-- Start of processing for Check_Private_Child_Unit
begin
- if Nkind_In (Lib_Unit, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Lib_Unit) in N_Package_Body | N_Subprogram_Body then
Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
Par_Lib := Curr_Unit;
if Ekind (Priv_Child) = E_Generic_Package
and then Chars (Priv_Child) in Text_IO_Package_Name
and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
+ and then Scope (Scope (Scope (Priv_Child))) =
+ Standard_Standard
then
Error_Msg_NE
("& is a nested package, not a compilation unit",
- Name (Item), Priv_Child);
+ Name (Item), Priv_Child);
else
Error_Msg_N
elsif Curr_Private
or else Private_Present (Item)
- or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit)
+ or else Nkind (Lib_Unit) in N_Package_Body | N_Subunit
or else (Nkind (Lib_Unit) = N_Subprogram_Body
and then not Acts_As_Spec (Parent (Lib_Unit)))
then
Next (Item);
end loop;
-
end Check_Private_Child_Unit;
----------------------
Kind : constant Node_Kind := Nkind (Par);
begin
- 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)
+ if Kind in
+ N_Package_Body | N_Subprogram_Body | N_Task_Body | N_Protected_Body
+ and then Nkind (Parent (Par)) in N_Compilation_Unit | N_Subunit
then
null;
------------------------
procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Nam);
- Ent : constant Entity_Id := Entity (Nam);
- Withn : Node_Id;
- P : Node_Id;
+ Loc : constant Source_Ptr := Sloc (Nam);
function Build_Unit_Name (Nam : Node_Id) return Node_Id;
-- Build name to be used in implicit with_clause. In most cases this
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
+ 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
-- visible, so analyze the declaration for B now, in case it
-- has not been done yet.
- Ent := Entity (Selector_Name (Nam));
+ Ent := Entity (Selector_Name (Nam));
Analyze
(Parent
(Unit_Declaration_Node (Entity (Selector_Name (Nam)))));
Result :=
Make_Expanded_Name (Loc,
- Chars => Chars (Entity (Nam)),
- Prefix => Build_Unit_Name (Prefix (Nam)),
+ Chars => Chars (Entity (Nam)),
+ Prefix => Build_Unit_Name (Prefix (Nam)),
Selector_Name => New_Occurrence_Of (Ent, Loc));
Set_Entity (Result, Ent);
+
return Result;
end if;
end Build_Unit_Name;
+ -- Local variables
+
+ Ent : constant Entity_Id := Entity (Nam);
+ Withn : Node_Id;
+
-- Start of processing for Expand_With_Clause
begin
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);
-
- -- If the unit is a package or generic package declaration, a private_
- -- with_clause on a child unit implies that the implicit with on the
- -- parent is also private.
-
- if Nkind_In (Unit (N), N_Package_Declaration,
- N_Generic_Package_Declaration)
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+ Set_Library_Unit (Withn, Parent (Unit_Declaration_Node (Ent)));
+ Set_Parent_With (Withn);
+
+ -- If the unit is a [generic] package or subprogram declaration
+ -- (including a subprogram body acting as spec), a private_with_clause
+ -- on a child unit implies that the implicit with on the parent is also
+ -- private.
+
+ if Nkind (Unit (N)) in N_Generic_Package_Declaration
+ | N_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Body
then
Set_Private_Present (Withn, Private_Present (Item));
end if;
Prepend (Withn, Context_Items (N));
Mark_Rewrite_Insertion (Withn);
- Install_Withed_Unit (Withn);
+
+ Install_With_Clause (Withn);
-- If we have "with X.Y;", we want to recurse on "X", except in the
-- unusual case where X.Y is a renaming of X. In that case, the scope
P_Spec : Node_Id := P;
begin
- -- Ancestor may have been rewritten as a package body. Retrieve
- -- the original spec to trace earlier ancestors.
+ -- Ancestor may have been rewritten as a package body. Retrieve the
+ -- original spec to trace earlier ancestors.
if Nkind (P) = N_Package_Body
and then Nkind (Original_Node (P)) = N_Package_Instantiation
else
return
Make_Selected_Component (Loc,
- Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
+ Prefix =>
+ Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
Selector_Name => P_Ref);
end if;
end Build_Ancestor_Name;
else
Result :=
Make_Expanded_Name (Loc,
- Chars => Chars (P_Name),
- Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
+ Chars => Chars (P_Name),
+ Prefix =>
+ Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
Selector_Name => New_Occurrence_Of (P_Name, Loc));
Set_Entity (Result, P_Name);
+
return Result;
end if;
end Build_Unit_Name;
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
- Set_Library_Unit (Withn, P);
- Set_Corresponding_Spec (Withn, P_Name);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
+ Set_Corresponding_Spec (Withn, P_Name);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+ Set_Library_Unit (Withn, P);
+ Set_Parent_With (Withn);
-- Node is placed at the beginning of the context items, so that
-- subsequent use clauses on the parent can be validated.
Prepend (Withn, Context_Items (N));
Mark_Rewrite_Insertion (Withn);
- Install_Withed_Unit (Withn);
+
+ Install_With_Clause (Withn);
if Is_Child_Spec (P_Unit) then
Implicit_With_On_Parent (P_Unit, N);
-- Install_Context --
---------------------
- procedure Install_Context (N : Node_Id) is
+ procedure Install_Context (N : Node_Id; Chain : Boolean := True) is
Lib_Unit : constant Node_Id := Unit (N);
begin
- Install_Context_Clauses (N);
+ Install_Context_Clauses (N, Chain);
if Is_Child_Spec (Lib_Unit) then
- Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
+ Install_Parents
+ (Lib_Unit => Lib_Unit,
+ Is_Private => Private_Present (Parent (Lib_Unit)),
+ Chain => Chain);
end if;
Install_Limited_Context_Clauses (N);
-- Install_Context_Clauses --
-----------------------------
- procedure Install_Context_Clauses (N : Node_Id) is
+ procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True) is
Lib_Unit : constant Node_Id := Unit (N);
Item : Node_Id;
Uname_Node : Entity_Id;
Check_Private := True;
end if;
- Install_Withed_Unit (Item);
+ Install_With_Clause (Item);
Decl_Node := Unit_Declaration_Node (Uname_Node);
-- Exclude license check if withed unit is an internal unit.
-- This situation arises e.g. with the GPL version of GNAT.
- if Is_Internal_File_Name (Unit_File_Name (Withu)) then
+ if Is_Internal_Unit (Withu) then
null;
-- Otherwise check various cases
-- Case of USE PACKAGE clause
elsif Nkind (Item) = N_Use_Package_Clause then
- Analyze_Use_Package (Item);
+ Analyze_Use_Package (Item, Chain);
-- Case of USE TYPE clause
elsif Nkind (Item) = N_Use_Type_Clause then
- Analyze_Use_Type (Item);
+ Analyze_Use_Type (Item, Chain);
-- case of PRAGMA
or else (Nkind (Lib_Unit) = N_Subprogram_Body
and then not Acts_As_Spec (N))
then
- Install_Context (Library_Unit (N));
+ Install_Context (Library_Unit (N), Chain);
-- Only install private with-clauses of a spec that comes from
-- source, excluding specs created for a subprogram body that is
Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
end if;
- if Nkind_In (Lib_Unit, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ if Nkind (Lib_Unit) in 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)));
Item : Node_Id;
Spec : Node_Id;
WEnt : Entity_Id;
- Nam : Node_Id;
E : Entity_Id;
E2 : Entity_Id;
-- Protect the frontend against previous critical errors
case Nkind (Unit (Library_Unit (W))) is
- when N_Subprogram_Declaration |
- N_Package_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Generic_Package_Declaration =>
+ when N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Declaration
+ =>
null;
when others =>
if Nkind (Item) = N_Use_Package_Clause then
- -- Traverse the list of packages
-
- Nam := First (Names (Item));
- while Present (Nam) loop
- E := Entity (Nam);
+ E := Entity (Name (Item));
- pragma Assert (Present (Parent (E)));
+ pragma Assert (Present (Parent (E)));
- if Nkind (Parent (E)) = N_Package_Renaming_Declaration
- and then Renamed_Entity (E) = WEnt
- then
- -- The unlimited view is visible through use clause and
- -- renamings. There is no need to generate the error
- -- message here because Is_Visible_Through_Renamings
- -- takes care of generating the precise error message.
+ if Nkind (Parent (E)) = N_Package_Renaming_Declaration
+ and then Renamed_Entity (E) = WEnt
+ then
+ -- The unlimited view is visible through use clause and
+ -- renamings. There is no need to generate the error
+ -- message here because Is_Visible_Through_Renamings
+ -- takes care of generating the precise error message.
- return;
+ return;
- elsif Nkind (Parent (E)) = N_Package_Specification then
+ elsif Nkind (Parent (E)) = N_Package_Specification then
- -- The use clause may refer to a local package.
- -- Check all the enclosing scopes.
+ -- The use clause may refer to a local package.
+ -- Check all the enclosing scopes.
- E2 := E;
- while E2 /= Standard_Standard and then E2 /= WEnt loop
- E2 := Scope (E2);
- end loop;
+ E2 := E;
+ while E2 /= Standard_Standard and then E2 /= WEnt loop
+ E2 := Scope (E2);
+ end loop;
- if E2 = WEnt then
- Error_Msg_N
- ("unlimited view visible through use clause ", W);
- return;
- end if;
+ if E2 = WEnt then
+ Error_Msg_N
+ ("unlimited view visible through use clause", W);
+ return;
end if;
-
- Next (Nam);
- end loop;
+ end if;
end if;
Next (Item);
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)
+ or else Nkind (Unit (Parent (Item))) in
+ N_Package_Body | N_Subprogram_Body | N_Subunit
then
-- Current unit is private, of descendant of a private unit
function Previous_Withed_Unit (W : Node_Id) return Boolean;
-- Returns true if the context already includes a with_clause for
- -- this unit. If the with_clause is non-limited, the unit is fully
+ -- this unit. If the with_clause is nonlimited, the unit is fully
-- visible and an implicit limited_with should not be created. If
-- there is already a limited_with clause for W, a second one is
-- simply redundant.
Set_Parent (Withn, Parent (N));
end if;
- Set_Limited_Present (Withn);
Set_First_Name (Withn);
Set_Implicit_With (Withn);
+ Set_Limited_Present (Withn);
Unum :=
Load_Unit
Analyze (Withn);
if not Limited_View_Installed (Withn) then
- Install_Limited_Withed_Unit (Withn);
+ Install_Limited_With_Clause (Withn);
end if;
end if;
end Expand_Limited_With_Clause;
then
if not Private_Present (Item)
or else Private_Present (N)
- or else Nkind_In (Unit (N), N_Package_Body,
- N_Subprogram_Body,
- N_Subunit)
+ or else Nkind (Unit (N)) in
+ N_Package_Body | N_Subprogram_Body | N_Subunit
then
- Install_Limited_Withed_Unit (Item);
+ Install_Limited_With_Clause (Item);
end if;
end if;
end if;
if not Is_Incomplete_Type (Non_Lim_View) then
-- Convert an incomplete subtype declaration into a
- -- corresponding non-limited view subtype declaration.
+ -- corresponding nonlimited view subtype declaration.
-- This is usually the case when analyzing a body that
-- has regular with clauses, when the spec has limited
-- ones.
- -- If the non-limited view is still incomplete, it is
+ -- If the nonlimited view is still incomplete, it is
-- the dummy entry already created, and the declaration
-- cannot be reanalyzed. This is the case when installing
-- a parent unit that has limited with-clauses.
Set_Subtype_Indication (Decl,
New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id)));
Set_Etype (Def_Id, Non_Lim_View);
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
+ Mutate_Ekind
+ (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
Set_Analyzed (Decl, False);
-- Reanalyze the declaration, suppressing the call to
-- Install_Parents --
---------------------
- procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
+ procedure Install_Parents
+ (Lib_Unit : Node_Id;
+ Is_Private : Boolean;
+ Chain : Boolean := True)
+ is
P : Node_Id;
E_Name : Entity_Id;
P_Name : Entity_Id;
end if;
if Ekind (P_Name) = E_Generic_Package
- 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
+ and then Nkind (Lib_Unit) not in N_Generic_Subprogram_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Renaming_Declaration
then
Error_Msg_N
("child of a generic package must be a generic unit", Lib_Unit);
-- This is the recursive call that ensures all parents are loaded
if Is_Child_Spec (P) then
- Install_Parents (P,
- Is_Private or else Private_Present (Parent (Lib_Unit)));
+ Install_Parents
+ (Lib_Unit => P,
+ Is_Private =>
+ Is_Private or else Private_Present (Parent (Lib_Unit)),
+ Chain => Chain);
end if;
-- Now we can install the context for this parent
- Install_Context_Clauses (Parent_Spec (Lib_Unit));
+ Install_Context_Clauses (Parent_Spec (Lib_Unit), Chain);
Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit));
Install_Siblings (P_Name, Parent (Lib_Unit));
not Is_Ancestor_Unit (Library_Unit (Item),
Cunit (Current_Sem_Unit))
then
- Install_Limited_Withed_Unit (Item);
+ Install_Limited_With_Clause (Item);
end if;
else
- Install_Withed_Unit (Item, Private_With_OK => True);
+ Install_With_Clause (Item, Private_With_OK => True);
end if;
end if;
-- 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.
+ -- subprogram body the private_with_clause does not take effect
+ -- until after the specification.
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
or else Limited_Present (Item)
or else Error_Posted (Item)
+
+ -- Skip processing malformed trees
+
+ or else (Try_Semantics
+ and then Nkind (Name (Item)) not in N_Has_Entity)
then
null;
end;
end if;
- -- The With_Clause may be on a grand-child or one of its further
+ -- The With_Clause may be on a grandchild or one of its further
-- descendants, which makes a child immediately visible. Examine
-- ancestry to determine whether such a child exists. For example,
-- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
-- 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.
+ -- unit is a grandchild, the same applies to its parent.
----------------
-- In_Context --
end Install_Siblings;
---------------------------------
- -- Install_Limited_Withed_Unit --
+ -- Install_Limited_With_Clause --
---------------------------------
- procedure Install_Limited_Withed_Unit (N : Node_Id) is
+ procedure Install_Limited_With_Clause (N : Node_Id) is
P_Unit : constant Entity_Id := Unit (Library_Unit (N));
E : Entity_Id;
P : Entity_Id;
-- 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 --
-------------------------
while Present (Subp_Id) loop
if Chars (Node (Subp_Id)) = Chars (E) then
if Nkind (Parent (Parent (Node (Subp_Id))))
- /= N_Subprogram_Renaming_Declaration
+ /= N_Subprogram_Renaming_Declaration
then
Prev_Id := Subp_Id;
Next_Elmt (Subp_Id);
-- 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))
+ and then (Nkind (Decl) in 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)
+ elsif Nkind (Decl) in N_Package_Declaration
+ | N_Generic_Package_Declaration
then
Check_Declarations (Specification (Decl));
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))
+ and then Nkind (Decl) in 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)
+ elsif Nkind (Decl) in N_Package_Declaration
+ | N_Generic_Package_Declaration
then
Check_Declarations (Specification (Decl));
return False;
end Has_Limited_With_Clause;
- ----------------------------------
- -- Is_Visible_Through_Renamings --
- ----------------------------------
-
- function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
- Kind : constant Node_Kind :=
- Nkind (Unit (Cunit (Current_Sem_Unit)));
- Aux_Unit : Node_Id;
- Item : Node_Id;
- Decl : Entity_Id;
-
- begin
- -- Example of the error detected by this subprogram:
-
- -- package P is
- -- type T is ...
- -- end P;
-
- -- with P;
- -- package Q is
- -- package Ren_P renames P;
- -- end Q;
-
- -- with Q;
- -- package R is ...
-
- -- limited with P; -- ERROR
- -- package R.C is ...
-
- Aux_Unit := Cunit (Current_Sem_Unit);
-
- loop
- Item := First (Context_Items (Aux_Unit));
- 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
- then
- Decl :=
- First (Visible_Declarations
- (Specification (Unit (Library_Unit (Item)))));
- while Present (Decl) loop
- if Nkind (Decl) = N_Package_Renaming_Declaration
- and then Entity (Name (Decl)) = P
- 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
- -- indicate that the limited view must not be
- -- installed.
-
- if Kind = N_Package_Declaration then
- Error_Msg_N
- ("simultaneous visibility of the limited and " &
- "unlimited views not allowed", N);
- Error_Msg_Sloc := Sloc (Item);
- Error_Msg_NE
- ("\\ unlimited view of & visible through the " &
- "context clause #", N, P);
- Error_Msg_Sloc := Sloc (Decl);
- Error_Msg_NE ("\\ and the renaming #", N, P);
- end if;
-
- return True;
- end if;
-
- Next (Decl);
- end loop;
- end if;
-
- Next (Item);
- end loop;
-
- -- 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
- -- already been flagged as illegal.
-
- return False;
-
- else
- Aux_Unit := Library_Unit (Aux_Unit);
- end if;
-
- else
- Aux_Unit := Parent_Spec (Unit (Aux_Unit));
- end if;
-
- exit when No (Aux_Unit);
- end loop;
-
- return False;
- end Is_Visible_Through_Renamings;
-
- -- Start of processing for Install_Limited_Withed_Unit
+ -- Start of processing for Install_Limited_With_Clause
begin
pragma Assert (not Limited_View_Installed (N));
-- Do not install the limited-view if the full-view is already visible
-- through renaming declarations.
- if Is_Visible_Through_Renamings (P) then
+ if Is_Visible_Through_Renamings (P, N) then
return;
end if;
-- 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.
+ -- nonlimited views of all entities from Lim_Pack.
-- limited with Lim_Pack; -- [1]
-- package Par is ... package Lim_Pack is ...
-- Minimum decoration
- Set_Ekind (P, E_Package);
+ Mutate_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
Set_Scope (P, Standard_Standard);
Set_Is_Visible_Lib_Unit (P);
-- Replace E in the homonyms list, so that the limited view
-- becomes available.
- -- If the non-limited view is a record with an anonymous
+ -- If the nonlimited view is a record with an anonymous
-- self-referential component, the analysis of the record
-- declaration creates an incomplete type with the same name
-- in order to define an internal access type. The visible
-- 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). The unit
- -- entities are not fully analyzed, so we need to follow unit
- -- links in the tree.
+ -- semantic point of view. The unit entities are not fully
+ -- analyzed, so we need to follow unit links in the tree.
Set_Entity (Nam, Ent);
Set_Entity (Name (N), P);
Set_From_Limited_With (P);
- end Install_Limited_Withed_Unit;
+ end Install_Limited_With_Clause;
-------------------------
- -- Install_Withed_Unit --
+ -- Install_With_Clause --
-------------------------
- procedure Install_Withed_Unit
+ procedure Install_With_Clause
(With_Clause : Node_Id;
Private_With_OK : Boolean := False)
is
-- analyzing the private part of the package).
if Private_Present (With_Clause)
- and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration
- and then not (Private_With_OK)
+ and then Nkind (Unit (Parent (With_Clause)))
+ in N_Package_Declaration | N_Generic_Package_Declaration
+ and then not Private_With_OK
then
return;
end if;
-- 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))
+ and then (not Is_Internal_Unit (Current_Sem_Unit)
or else Current_Sem_Unit = Main_Unit)
then
Check_Restricted_Unit
Error_Msg_N
("instantiation depends on itself", Name (With_Clause));
+ elsif not Analyzed (Uname)
+ and then Is_Internal_Unit (Current_Sem_Unit)
+ and then not Is_Visible_Lib_Unit (Uname)
+ and then No (Scope (Uname))
+ then
+ if Is_Predefined_Unit (Current_Sem_Unit) then
+ Error_Msg_N
+ ("predefined unit depends on itself", Name (With_Clause));
+ else
+ Error_Msg_N
+ ("GNAT-defined unit depends on itself", Name (With_Clause));
+ end if;
+ return;
+
elsif not Is_Visible_Lib_Unit (Uname) then
-- Abandon processing in case of previous errors
Set_Is_Visible_Lib_Unit (Uname);
-- If the unit is a wrapper package for a compilation unit that is
- -- a subprogrm instance, indicate that the instance itself is a
+ -- a subprogram instance, indicate that the instance itself is a
-- visible unit. This is necessary if the instance is inlined.
if Is_Wrapper_Package (Uname) then
Set_Context_Installed (With_Clause);
end if;
- -- A with-clause overrides a with-type clause: there are no restric-
- -- tions on the use of package entities.
-
- if Ekind (Uname) = E_Package then
- Set_From_Limited_With (Uname, False);
+ -- A [private] with clause overrides a limited with clause. Restore the
+ -- proper view of the package by performing the following actions:
+ --
+ -- * Remove all shadow entities which hide their corresponding
+ -- entities from direct visibility by updating the entity and
+ -- homonym chains.
+ --
+ -- * Enter the corresponding entities back in direct visibility
+ --
+ -- Note that the original limited with clause which installed its view
+ -- is still marked as "active". This effect is undone when the clause
+ -- itself is removed, see Remove_Limited_With_Clause.
+
+ if Ekind (Uname) = E_Package and then From_Limited_With (Uname) then
+ Remove_Limited_With_Unit (Unit_Declaration_Node (Uname));
end if;
-- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
end loop;
end;
end if;
- end Install_Withed_Unit;
+ end Install_With_Clause;
-------------------
-- Is_Child_Spec --
E1 : constant Entity_Id := Defining_Entity (Unit (U1));
E2 : Entity_Id;
begin
- if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Unit (U2)) in N_Package_Body | N_Subprogram_Body then
E2 := Defining_Entity (Unit (Library_Unit (U2)));
return Is_Ancestor_Package (E1, E2);
else
end if;
end Is_Ancestor_Unit;
+ ----------------------------------
+ -- Is_Visible_Through_Renamings --
+ ----------------------------------
+
+ function Is_Visible_Through_Renamings
+ (P : Entity_Id;
+ Error_Node : Node_Id := Empty) return Boolean
+ is
+ function Is_Limited_Withed_Unit
+ (Lib_Unit : Node_Id;
+ Pkg_Ent : Entity_Id) return Boolean;
+ -- Return True if Pkg_Ent is a limited-withed package of the given
+ -- library unit.
+
+ ----------------------------
+ -- Is_Limited_Withed_Unit --
+ ----------------------------
+
+ function Is_Limited_Withed_Unit
+ (Lib_Unit : Node_Id;
+ Pkg_Ent : Entity_Id) return Boolean
+ is
+ Item : Node_Id := First (Context_Items (Lib_Unit));
+
+ begin
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Entity (Name (Item)) = Pkg_Ent
+ then
+ return True;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ return False;
+ end Is_Limited_Withed_Unit;
+
+ -- Local variables
+
+ Kind : constant Node_Kind := Nkind (Unit (Cunit (Current_Sem_Unit)));
+ Aux_Unit : Node_Id;
+ Item : Node_Id;
+ Decl : Entity_Id;
+
+ begin
+ -- Example of the error detected by this subprogram:
+
+ -- package P is
+ -- type T is ...
+ -- end P;
+
+ -- with P;
+ -- package Q is
+ -- package Ren_P renames P;
+ -- end Q;
+
+ -- with Q;
+ -- package R is ...
+
+ -- limited with P; -- ERROR
+ -- package R.C is ...
+
+ Aux_Unit := Cunit (Current_Sem_Unit);
+
+ loop
+ Item := First (Context_Items (Aux_Unit));
+ 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
+ then
+ Decl :=
+ First (Visible_Declarations
+ (Specification (Unit (Library_Unit (Item)))));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Package_Renaming_Declaration
+ and then Entity (Name (Decl)) = P
+ and then not Is_Limited_Withed_Unit
+ (Lib_Unit => Library_Unit (Item),
+ Pkg_Ent => Entity (Name (Decl)))
+ 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
+ -- indicate that the limited view must not be
+ -- installed.
+
+ if Kind = N_Package_Declaration
+ and then Present (Error_Node)
+ then
+ Error_Msg_N
+ ("simultaneous visibility of the limited and " &
+ "unlimited views not allowed", Error_Node);
+ Error_Msg_Sloc := Sloc (Item);
+ Error_Msg_NE
+ ("\\ unlimited view of & visible through the " &
+ "context clause #", Error_Node, P);
+ Error_Msg_Sloc := Sloc (Decl);
+ Error_Msg_NE ("\\ and the renaming #", Error_Node, P);
+ end if;
+
+ return True;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- 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 (Unit (Aux_Unit)) in
+ 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
+ -- already been flagged as illegal.
+
+ return False;
+
+ else
+ Aux_Unit := Library_Unit (Aux_Unit);
+ end if;
+
+ else
+ Aux_Unit := Parent_Spec (Unit (Aux_Unit));
+ end if;
+
+ exit when No (Aux_Unit);
+ end loop;
+
+ return False;
+ end Is_Visible_Through_Renamings;
+
-----------------------
-- Load_Needed_Body --
-----------------------
else
Compiler_State := Analyzing; -- reset after load
- if not Fatal_Error (Unum) or else Try_Semantics then
+ if Fatal_Error (Unum) /= Error_Detected or else Try_Semantics then
if Debug_Flag_L then
Write_Str ("*** Loaded generic body");
Write_Eol;
-- The abstract view of a variable is a state, not another variable
if Ekind (Ent) = E_Variable then
- Set_Ekind (Shadow, E_Abstract_State);
+ Mutate_Ekind (Shadow, E_Abstract_State);
else
- Set_Ekind (Shadow, Ekind (Ent));
+ Mutate_Ekind (Shadow, Ekind (Ent));
end if;
Set_Is_Internal (Shadow);
Decorate_Type (Shadow, Scop, Is_Tagged);
Set_Non_Limited_View (Shadow, Ent);
+ if Is_Tagged then
+ Set_Non_Limited_View
+ (Class_Wide_Type (Shadow), Class_Wide_Type (Ent));
+ end if;
+
if Is_Incomplete_Or_Private_Type (Ent) then
Set_Private_Dependents (Shadow, New_Elmt_List);
end if;
procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Package);
+ Mutate_Ekind (Ent, E_Package);
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Scop);
end Decorate_Package;
procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Abstract_State);
- Set_Etype (Ent, Standard_Void_Type);
- Set_Scope (Ent, Scop);
- Set_Encapsulating_State (Ent, Empty);
- Set_Refinement_Constituents (Ent, New_Elmt_List);
- Set_Part_Of_Constituents (Ent, New_Elmt_List);
+ Mutate_Ekind (Ent, E_Abstract_State);
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Scope (Ent, Scop);
+ Set_Encapsulating_State (Ent, Empty);
end Decorate_State;
-------------------
begin
-- An unanalyzed type or a shadow entity of a type is treated as an
- -- incomplete type.
-
- Set_Ekind (Ent, E_Incomplete_Type);
- Set_Etype (Ent, Ent);
- Set_Scope (Ent, Scop);
- Set_Is_First_Subtype (Ent);
- Set_Stored_Constraint (Ent, No_Elist);
- Set_Full_View (Ent, Empty);
- Init_Size_Align (Ent);
+ -- incomplete type, and carries the corresponding attributes.
+
+ Mutate_Ekind (Ent, E_Incomplete_Type);
+ Set_Etype (Ent, Ent);
+ Set_Full_View (Ent, Empty);
+ Set_Is_First_Subtype (Ent);
+ Set_Scope (Ent, Scop);
+ Set_Stored_Constraint (Ent, No_Elist);
+ Init_Size_Align (Ent);
+
+ if From_Limited_With (Ent) then
+ Set_Private_Dependents (Ent, New_Elmt_List);
+ end if;
-- A tagged type and its corresponding shadow entity share one common
-- class-wide type. The list of primitive operations for the shadow
Set_Is_Tagged_Type (Ent);
Set_Direct_Primitive_Operations (Ent, New_Elmt_List);
- if No (Class_Wide_Type (Ent)) then
- CW_Typ :=
- New_External_Entity
- (E_Void, Scope (Ent), Sloc (Ent), Ent, 'C', 0, 'T');
-
- Set_Class_Wide_Type (Ent, CW_Typ);
-
- -- 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_Typ, Parent (Ent));
-
- Set_Ekind (CW_Typ, E_Class_Wide_Type);
- Set_Etype (CW_Typ, Ent);
- Set_Scope (CW_Typ, Scop);
- Set_Is_Tagged_Type (CW_Typ);
- Set_Is_First_Subtype (CW_Typ);
- Init_Size_Align (CW_Typ);
- Set_Has_Unknown_Discriminants (CW_Typ);
- Set_Class_Wide_Type (CW_Typ, CW_Typ);
- Set_Equivalent_Type (CW_Typ, Empty);
- Set_From_Limited_With (CW_Typ, From_Limited_With (Ent));
- Set_Materialize_Entity (CW_Typ, Materialize);
- end if;
+ CW_Typ :=
+ New_External_Entity
+ (E_Void, Scope (Ent), Sloc (Ent), Ent, 'C', 0, 'T');
+
+ Set_Class_Wide_Type (Ent, CW_Typ);
+
+ -- 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_Typ, Parent (Ent));
+
+ Mutate_Ekind (CW_Typ, E_Class_Wide_Type);
+ Set_Class_Wide_Type (CW_Typ, CW_Typ);
+ Set_Etype (CW_Typ, Ent);
+ Set_Equivalent_Type (CW_Typ, Empty);
+ Set_From_Limited_With (CW_Typ, From_Limited_With (Ent));
+ Set_Has_Unknown_Discriminants (CW_Typ);
+ Set_Is_First_Subtype (CW_Typ);
+ Set_Is_Tagged_Type (CW_Typ);
+ Set_Materialize_Entity (CW_Typ, Materialize);
+ Set_Scope (CW_Typ, Scop);
+ Init_Size_Align (CW_Typ);
end if;
end Decorate_Type;
procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Variable);
+ Mutate_Ekind (Ent, E_Variable);
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Scop);
end Decorate_Variable;
Build_Shadow_Entity (Def_Id, Scop, Shadow);
Process_Declarations_And_States
- (Pack => Def_Id,
- Decls => Visible_Declarations (Specification (Decl)),
- Scop => Shadow,
+ (Pack => Def_Id,
+ Decls =>
+ Visible_Declarations (Specification (Decl)),
+ Scop => Shadow,
Create_Abstract_Views => Create_Abstract_Views);
-- Types
- elsif Nkind_In (Decl, N_Full_Type_Declaration,
- N_Incomplete_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration,
- N_Protected_Type_Declaration,
- N_Task_Type_Declaration)
+ elsif Nkind (Decl) in N_Full_Type_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Protected_Type_Declaration
+ | N_Task_Type_Declaration
then
Def_Id := Defining_Entity (Decl);
(Nkind (Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Def)));
- elsif Nkind_In (Decl, N_Incomplete_Type_Declaration,
- N_Private_Type_Declaration)
+ elsif Nkind (Decl) in N_Incomplete_Type_Declaration
+ | N_Private_Type_Declaration
then
Is_Tagged := Tagged_Present (Decl);
null;
when N_Subprogram_Declaration =>
- Error_Msg_N ("subprograms not allowed in limited with_clauses", N);
+ Error_Msg_N
+ ("subprogram not allowed in `LIMITED WITH` clause", N);
return;
- when N_Generic_Package_Declaration |
- N_Generic_Subprogram_Declaration =>
- Error_Msg_N ("generics not allowed in limited with_clauses", N);
+ when N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ =>
+ Error_Msg_N ("generic not allowed in `LIMITED WITH` clause", N);
return;
when N_Generic_Instantiation =>
Error_Msg_N
- ("generic instantiations not allowed in limited with_clauses",
+ ("generic instantiation not allowed in `LIMITED WITH` clause",
N);
return;
when N_Generic_Renaming_Declaration =>
Error_Msg_N
- ("generic renamings not allowed in limited with_clauses", N);
+ ("generic renaming not allowed in `LIMITED WITH` clause", N);
return;
when N_Subprogram_Renaming_Declaration =>
Error_Msg_N
- ("renamed subprograms not allowed in limited with_clauses", N);
+ ("renamed subprogram not allowed in `LIMITED WITH` clause", N);
return;
when N_Package_Renaming_Declaration =>
Error_Msg_N
- ("renamed packages not allowed in limited with_clauses", N);
+ ("renamed package not allowed in `LIMITED WITH` clause", N);
return;
when others =>
-- must be minimally decorated. This ensures that the checks on unused
-- with clauses also process limieted withs.
- Set_Ekind (Pack, E_Package);
+ Mutate_Ekind (Pack, E_Package);
Set_Etype (Pack, Standard_Void_Type);
if Is_Entity_Name (Nam) then
-- incomplete view of all types and packages declared within.
Shadow_Pack := Make_Temporary (Sloc (N), 'Z');
- Set_Ekind (Shadow_Pack, E_Package);
+ Mutate_Ekind (Shadow_Pack, E_Package);
Set_Is_Internal (Shadow_Pack);
Set_Limited_View (Pack, Shadow_Pack);
-- variables and types.
Process_Declarations_And_States
- (Pack => Pack,
- Decls => Visible_Declarations (Spec),
- Scop => Pack,
+ (Pack => Pack,
+ Decls => Visible_Declarations (Spec),
+ Scop => Pack,
Create_Abstract_Views => True);
Last_Public_Shadow := Last_Shadow;
-- Ada 2005 (AI-262): Build the limited view of the private declarations
- -- to accomodate limited private with clauses.
+ -- to accommodate limited private with clauses.
Process_Declarations_And_States
- (Pack => Pack,
- Decls => Private_Declarations (Spec),
- Scop => Pack,
+ (Pack => Pack,
+ Decls => Private_Declarations (Spec),
+ Scop => Pack,
Create_Abstract_Views => False);
if Present (Last_Public_Shadow) then
if Nkind (CI) = N_With_Clause
and then not
No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI)))
+
+ -- In GNATprove mode, some runtime units are implicitly
+ -- loaded to make their entities available for analysis. In
+ -- this case, ignore violations of No_Elaboration_Code_All
+ -- for this special analysis mode.
+
+ and then not
+ (GNATprove_Mode and then Implicit_With (CI))
then
Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma);
Error_Msg_N
-------------------------------
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
-
function Entity_Needs_Body (E : Entity_Id) return Boolean;
-- Determine whether use of entity E might require the presence of its
-- body. For a package this requires a recursive traversal of all nested
-- declarations.
- ---------------------------
- -- Entity_Needed_For_SAL --
- ---------------------------
+ -----------------------
+ -- Entity_Needs_Body --
+ -----------------------
function Entity_Needs_Body (E : Entity_Id) return Boolean is
Ent : Entity_Id;
if Is_Subprogram (E) and then Has_Pragma_Inline (E) then
return True;
- elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
- return True;
+ elsif Is_Generic_Subprogram (E) then
+
+ -- A generic subprogram always requires the presence of its
+ -- body because an instantiation needs both templates. The only
+ -- exceptions is a generic subprogram renaming. In this case the
+ -- body is needed only when the template is declared outside the
+ -- compilation unit being checked.
+
+ if Present (Renamed_Entity (E)) then
+ return not Within_Scope (E, Unit_Name);
+ else
+ return True;
+ end if;
elsif Ekind (E) = E_Generic_Package
and then
then
Set_Body_Needed_For_SAL (Unit_Name);
- elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
+ elsif Ekind (Unit_Name) in E_Generic_Procedure | E_Generic_Function then
Set_Body_Needed_For_SAL (Unit_Name);
elsif Is_Subprogram (Unit_Name)
begin
-- Ada 2005 (AI-50217): We remove the context clauses in two phases:
- -- limited-views first and regular-views later (to maintain the
- -- stack model).
+ -- limited-views first and regular-views later (to maintain the stack
+ -- model).
-- First Phase: Remove limited_with context clauses
Item := First (Context_Items (N));
while Present (Item) loop
- -- We are interested only in with clauses which got installed
- -- on entry.
+ -- We are interested only in with clauses that got installed on entry
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
- and then Limited_View_Installed (Item)
then
- Remove_Limited_With_Clause (Item);
+ if Limited_View_Installed (Item) then
+ Remove_Limited_With_Clause (Item);
+
+ -- An unusual case: If the library unit of the Main_Unit has a
+ -- limited with_clause on some unit P and the context somewhere
+ -- includes a with_clause on P, P has been analyzed. The entity
+ -- for P is still visible, which in general is harmless because
+ -- this is the end of the compilation, but it can affect pending
+ -- instantiations that may have been generated elsewhere, so it
+ -- it is necessary to remove U from visibility so that inlining
+ -- and the analysis of instance bodies can proceed cleanly.
+
+ elsif Current_Sem_Unit = Main_Unit
+ and then Serious_Errors_Detected = 0
+ and then not Implicit_With (Item)
+ then
+ Set_Is_Immediately_Visible
+ (Defining_Entity (Unit (Library_Unit (Item))), False);
+ end if;
end if;
Next (Item);
null;
elsif Nkind (Item) = N_With_Clause
- and then Context_Installed (Item)
+ and then Context_Installed (Item)
then
-- Remove items from one with'ed unit
--------------------------------
procedure Remove_Limited_With_Clause (N : Node_Id) is
- P_Unit : constant Entity_Id := Unit (Library_Unit (N));
- E : Entity_Id;
- P : Entity_Id;
- Lim_Header : Entity_Id;
- Lim_Typ : Entity_Id;
- Prev : Entity_Id;
+ Pack_Decl : constant Entity_Id := Unit (Library_Unit (N));
begin
pragma Assert (Limited_View_Installed (N));
- -- 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.
+ -- Limited with clauses that designate units other than packages are
+ -- illegal and are never installed.
- if Nkind (P_Unit) /= N_Package_Declaration then
- return;
+ if Nkind (Pack_Decl) = N_Package_Declaration then
+ Remove_Limited_With_Unit (Pack_Decl, N);
end if;
- P := Defining_Unit_Name (Specification (P_Unit));
+ -- Indicate that the limited views of the clause have been removed
- -- Handle child packages
+ Set_Limited_View_Installed (N, False);
+ end Remove_Limited_With_Clause;
- if Nkind (P) = N_Defining_Program_Unit_Name then
- P := Defining_Identifier (P);
- end if;
+ ------------------------------
+ -- Remove_Limited_With_Unit --
+ ------------------------------
- if Debug_Flag_I then
- Write_Str ("remove limited view of ");
- Write_Name (Chars (P));
- Write_Str (" from visibility");
- Write_Eol;
- end if;
+ procedure Remove_Limited_With_Unit
+ (Pack_Decl : Node_Id;
+ Lim_Clause : Node_Id := Empty)
+ is
+ procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id);
+ -- Remove the shadow entities of package Pack_Id from direct visibility
- -- 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
+ procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id);
+ -- Remove the shadow entities of package Pack_Id from direct visibility,
+ -- restore the corresponding entities they hide into direct visibility,
+ -- and update the entity and homonym chains.
- Lim_Header := Limited_View (P);
- Lim_Typ := First_Entity (Lim_Header);
+ --------------------------------------------
+ -- Remove_Shadow_Entities_From_Visibility --
+ --------------------------------------------
- -- Remove package and shadow entities from visibility if it has not
- -- been analyzed
+ procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id) is
+ Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
+ Upto : constant Entity_Id := First_Private_Entity (Lim_Header);
- if not Analyzed (P_Unit) then
- Unchain (P);
- Set_Is_Immediately_Visible (P, False);
+ Shadow : Entity_Id;
- while Present (Lim_Typ) loop
- Unchain (Lim_Typ);
- Next_Entity (Lim_Typ);
+ begin
+ -- Remove the package from direct visibility
+
+ Unchain (Pack_Id);
+ Set_Is_Immediately_Visible (Pack_Id, False);
+
+ -- Remove all shadow entities from direct visibility
+
+ Shadow := First_Entity (Lim_Header);
+ while Present (Shadow) and then Shadow /= Upto loop
+ Unchain (Shadow);
+ Next_Entity (Shadow);
end loop;
+ end Remove_Shadow_Entities_From_Visibility;
- -- Otherwise this package has already appeared in the closure and its
- -- shadow entities must be replaced by its real entities. This code
- -- must be kept synchronized with the complementary code in Install
- -- Limited_Withed_Unit.
+ -----------------------------------------
+ -- Remove_Shadow_Entities_With_Restore --
+ -----------------------------------------
- else
- -- Real entities that are type or subtype declarations were hidden
- -- from visibility at the point of installation of the limited-view.
- -- Now we recover the previous value of the hidden attribute.
+ procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id) is
+ procedure Restore_Chain_For_Shadow (Shadow : Entity_Id);
+ -- Remove shadow entity Shadow by updating the entity and homonym
+ -- chains.
- E := First_Entity (P);
- while Present (E) and then E /= First_Private_Entity (P) loop
- if Is_Type (E) then
- Set_Is_Hidden (E, Was_Hidden (E));
- end if;
+ procedure Restore_Chains
+ (From : Entity_Id;
+ Upto : Entity_Id);
+ -- Remove a sequence of shadow entities starting from From and ending
+ -- prior to Upto by updating the entity and homonym chains.
- Next_Entity (E);
- end loop;
+ procedure Restore_Type_Visibility
+ (From : Entity_Id;
+ Upto : Entity_Id);
+ -- Restore a sequence of types starting from From and ending prior to
+ -- Upto back in direct visibility.
- while Present (Lim_Typ)
- and then Lim_Typ /= First_Private_Entity (Lim_Header)
- loop
- -- Nested packages and child units were not unchained
+ ------------------------------
+ -- Restore_Chain_For_Shadow --
+ ------------------------------
- if Ekind (Lim_Typ) /= E_Package
- and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
+ procedure Restore_Chain_For_Shadow (Shadow : Entity_Id) is
+ Prev : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ -- 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 nonlimited 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 nonlimited view,
+ -- E2 must become the current entity and E3 must be ignored.
+
+ Typ := Non_Limited_View (Shadow);
+
+ -- Shadow 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 Present (Current_Entity (Typ))
+ and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
+ and then Full_View (Current_Entity (Typ)) = Typ
then
- -- 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
+ return;
+ end if;
+
+ pragma Assert (not In_Chain (Typ));
+
+ Prev := Current_Entity (Shadow);
+
+ if Prev = Shadow then
+ Set_Current_Entity (Typ);
+
+ else
+ while Present (Prev) and then Homonym (Prev) /= Shadow loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ if Present (Prev) then
+ Set_Homonym (Prev, Typ);
+ end if;
+ end if;
+
+ Set_Homonym (Typ, Homonym (Shadow));
+ end Restore_Chain_For_Shadow;
+
+ --------------------
+ -- Restore_Chains --
+ --------------------
- -- 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.
+ procedure Restore_Chains
+ (From : Entity_Id;
+ Upto : Entity_Id)
+ is
+ Shadow : Entity_Id;
+ begin
+ Shadow := From;
+ while Present (Shadow) and then Shadow /= Upto loop
+
+ -- Do not unchain nested packages and child units
+
+ if Ekind (Shadow) = E_Package then
+ null;
+
+ elsif Is_Child_Unit (Non_Limited_View (Shadow)) then
null;
else
- pragma Assert (not In_Chain (E));
+ Restore_Chain_For_Shadow (Shadow);
+ end if;
- Prev := Current_Entity (Lim_Typ);
+ Next_Entity (Shadow);
+ end loop;
+ end Restore_Chains;
- if Prev = Lim_Typ then
- Set_Current_Entity (E);
+ -----------------------------
+ -- Restore_Type_Visibility --
+ -----------------------------
- else
- while Present (Prev)
- and then Homonym (Prev) /= Lim_Typ
- loop
- Prev := Homonym (Prev);
- end loop;
+ procedure Restore_Type_Visibility
+ (From : Entity_Id;
+ Upto : Entity_Id)
+ is
+ Typ : Entity_Id;
- if Present (Prev) then
- Set_Homonym (Prev, E);
- end if;
- end if;
+ begin
+ Typ := From;
+ while Present (Typ) and then Typ /= Upto loop
+ if Is_Type (Typ) then
+ Set_Is_Hidden (Typ, Was_Hidden (Typ));
+ end if;
- -- Preserve structure of homonym chain
+ Next_Entity (Typ);
+ end loop;
+ end Restore_Type_Visibility;
- Set_Homonym (E, Homonym (Lim_Typ));
- end if;
- end if;
+ -- Local variables
- Next_Entity (Lim_Typ);
- end loop;
+ Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
+
+ -- Start of processing Remove_Shadow_Entities_With_Restore
+
+ begin
+ -- The limited view of a package is being uninstalled by removing
+ -- the effects of a limited with clause. If the clause appears in a
+ -- unit which is not part of the main unit closure, then the related
+ -- package must not be visible.
+
+ if Present (Lim_Clause)
+ and then not In_Extended_Main_Source_Unit (Lim_Clause)
+ then
+ Set_Is_Immediately_Visible (Pack_Id, False);
+
+ -- Otherwise a limited view is being overridden by a nonlimited view.
+ -- Leave the visibility of the package as is because the unit must be
+ -- visible when the nonlimited view is installed.
+
+ else
+ null;
+ end if;
+
+ -- Remove the shadow entities from visibility by updating the entity
+ -- and homonym chains.
+
+ Restore_Chains
+ (From => First_Entity (Lim_Header),
+ Upto => First_Private_Entity (Lim_Header));
+
+ -- Reinstate the types that were hidden by the shadow entities back
+ -- into direct visibility.
+
+ Restore_Type_Visibility
+ (From => First_Entity (Pack_Id),
+ Upto => First_Private_Entity (Pack_Id));
+ end Remove_Shadow_Entities_With_Restore;
+
+ -- Local variables
+
+ Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
+
+ -- Start of processing for Remove_Limited_With_Unit
+
+ begin
+ -- Nothing to do when the limited view of the package is not installed
+
+ if not From_Limited_With (Pack_Id) then
+ return;
+ end if;
+
+ if Debug_Flag_I then
+ Write_Str ("remove limited view of ");
+ Write_Name (Chars (Pack_Id));
+ Write_Str (" from visibility");
+ Write_Eol;
+ end if;
+
+ -- The package already appears in the compilation closure. As a result,
+ -- its shadow entities must be replaced by the real entities they hide
+ -- and the previously hidden entities must be entered back into direct
+ -- visibility.
+
+ -- WARNING: This code must be kept synchronized with that of routine
+ -- Install_Limited_Withed_Clause.
+
+ if Analyzed (Pack_Decl) then
+ Remove_Shadow_Entities_With_Restore (Pack_Id);
+
+ -- Otherwise the package is not analyzed and its shadow entities must be
+ -- removed from direct visibility.
+
+ else
+ Remove_Shadow_Entities_From_Visibility (Pack_Id);
end if;
-- Indicate that the limited view of the package is not installed
- Set_From_Limited_With (P, False);
- Set_Limited_View_Installed (N, False);
- end Remove_Limited_With_Clause;
+ Set_From_Limited_With (Pack_Id, False);
+ end Remove_Limited_With_Unit;
--------------------
-- Remove_Parents --
-- In_Regular_With_Clause --
----------------------------
- function In_Regular_With_Clause (E : Entity_Id) return Boolean
- is
+ function In_Regular_With_Clause (E : Entity_Id) return Boolean is
Item : Node_Id;
begin
Item := First (Context_Items (Comp_Unit));
+
while Present (Item) loop
if Nkind (Item) = N_With_Clause
then
return True;
end if;
+
Next (Item);
end loop;
-- 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.
+ -- clauses in other nested packages. We replace the clause with
+ -- a null statement, which is otherwise ignored by the rest of
+ -- the compiler.
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
Nxt : constant Node_Id := Next (Item);
begin
- Remove (Item);
+ Rewrite (Item, Make_Null_Statement (Sloc (Item)));
+ Analyze (Item);
Item := Nxt;
end;
git://gcc.gnu.org / gcc.git / blobdiff