procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] ACATS 4.1H - B853001 - missed errors for renamed limited

Browse source 
gcc/ada/

	* einfo.ads (Has_Limited_View): New synthesized attribute.
	* einfo.adb (Has_Limited_View): New synthesized attribute.
	(Set_Limited_View): Complete assertion.
	* sem_ch10.ads (Is_Visible_Through_Renamings): Make this routine
	public to invoke it from Find_Expanded_Name and avoid reporting
	spurious errors on renamings of limited-with packages.
	(Load_Needed_Body): Moved to have this spec alphabetically
	ordered.
	* sem_ch10.adb (Is_Visible_Through_Renamings): Moved to library
	level.
	(Is_Limited_Withed_Unit): New subprogram.
	* sem_ch3.adb (Access_Type_Declaration): Adding protection to
	avoid reading attribute Entity() when not available.
	* sem_ch8.adb (Analyze_Package_Renaming): Report error on
	renamed package not visible through context clauses.
	(Find_Expanded_Name): Report error on renamed package not
	visible through context clauses; handle special case where the
	prefix is a renaming of a (now visible) shadow package.
This commit is contained in:
Javier Miranda 2020-08-25 15:08:22 -04:00 • committed by Pierre-Marie de Rodat
parent f0c57fcd0a
commit b2dea70e92
6 changed files with 229 additions and 121 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/ada/einfo.adb
View file

@ -6071,7 +6071,8 @@ package body Einfo is
procedure Set_Limited_View (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Package);
pragma Assert (Ekind (Id) = E_Package
and then not Is_Generic_Instance (Id));
Set_Node23 (Id, V);
end Set_Limited_View;
@ -7846,6 +7847,17 @@ package body Einfo is
return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
end Has_Invariants;
--------------------------
-- Has_Limited_View --
--------------------------
function Has_Limited_View (Id : E) return B is
begin
return Ekind (Id) = E_Package
and then not Is_Generic_Instance (Id)
and then Present (Limited_View (Id));
end Has_Limited_View;
--------------------------
-- Has_Non_Limited_View --
--------------------------

7
gcc/ada/einfo.ads
View file

@ -1785,6 +1785,10 @@ package Einfo is
-- invariant of its own or inherits at least one class-wide invariant
-- from a parent type or an interface.
-- Has_Limited_View (synth)
-- Defined in all entities. True for non-generic package entities that
-- are non-instances and their Limited_View attribute is present.
-- Has_Loop_Entry_Attributes (Flag260)
-- Defined in E_Loop entities. Set when the loop is subject to at least
-- one attribute 'Loop_Entry. The flag also implies that the loop has
@ -6484,6 +6488,7 @@ package Einfo is
-- Has_Null_Abstract_State (synth)
-- Is_Elaboration_Target (synth)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Has_Limited_View (synth) (non-generic case only)
-- Scope_Depth (synth)
-- E_Package_Body
@ -7675,6 +7680,7 @@ package Einfo is
function Has_Foreign_Convention (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
function Has_Limited_View (Id : E) return B;
function Has_Non_Limited_View (Id : E) return B;
function Has_Non_Null_Abstract_State (Id : E) return B;
function Has_Non_Null_Visible_Refinement (Id : E) return B;
@ -9207,6 +9213,7 @@ package Einfo is
pragma Inline (Base_Type);
pragma Inline (Float_Rep);
pragma Inline (Has_Foreign_Convention);
pragma Inline (Has_Limited_View);
pragma Inline (Has_Non_Limited_View);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Boolean_Type);

250
gcc/ada/sem_ch10.adb
View file

@ -4480,10 +4480,6 @@ package body Sem_Ch10 is
-- 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 --
-------------------------
@ -4813,108 +4809,6 @@ package body Sem_Ch10 is
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 (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;
-- Start of processing for Install_Limited_With_Clause
begin
@ -4952,7 +4846,7 @@ package body Sem_Ch10 is
-- 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;
@ -5552,6 +5446,148 @@ package body Sem_Ch10 is
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 --
-----------------------

31
gcc/ada/sem_ch10.ads
View file

@ -51,6 +51,25 @@ package Sem_Ch10 is
-- view, determine whether the package where T resides is imported through
-- a regular with clause in the current package body.
function Is_Visible_Through_Renamings
(P : Entity_Id;
Error_Node : Node_Id := Empty) return Boolean;
-- Check if some package installed though normal with-clauses has a
-- renaming declaration of package P. AARM 10.1.2(21/2). Errors are
-- reported on Error_Node (if present); otherwise no error is reported.
procedure Load_Needed_Body
(N : Node_Id;
OK : out Boolean;
Do_Analyze : Boolean := True);
-- Load and analyze the body of a context unit that is generic, or that
-- contains generic units or inlined units. The body becomes part of the
-- semantic dependency set of the unit that needs it. The returned result
-- in OK is True if the load is successful, and False if the requested file
-- cannot be found. If the flag Do_Analyze is false, the unit is loaded and
-- parsed only. This allows a selective analysis in some inlining cases
-- where a full analysis would lead so circularities in the back-end.
procedure Remove_Context (N : Node_Id);
-- Removes the entities from the context clause of the given compilation
-- unit from the visibility chains. This is done on exit from a unit as
@ -66,16 +85,4 @@ package Sem_Ch10 is
-- rule imposes extra steps in order to install/remove the private_with
-- clauses of an enclosing unit.
procedure Load_Needed_Body
(N : Node_Id;
OK : out Boolean;
Do_Analyze : Boolean := True);
-- Load and analyze the body of a context unit that is generic, or that
-- contains generic units or inlined units. The body becomes part of the
-- semantic dependency set of the unit that needs it. The returned result
-- in OK is True if the load is successful, and False if the requested file
-- cannot be found. If the flag Do_Analyze is false, the unit is loaded and
-- parsed only. This allows a selective analysis in some inlining cases
-- where a full analysis would lead so circularities in the back-end.
end Sem_Ch10;

3
gcc/ada/sem_ch3.adb
View file

@ -1329,7 +1329,8 @@ package body Sem_Ch3 is
if Nkind (S) /= N_Subtype_Indication then
Analyze (S);
if Present (Entity (S))
if Nkind (S) in N_Has_Entity
and then Present (Entity (S))
and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
then
Set_Directly_Designated_Type (T, Entity (S));

45
gcc/ada/sem_ch8.adb
View file

@ -52,6 +52,7 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
@ -1544,6 +1545,21 @@ package body Sem_Ch8 is
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
elsif Present (Renamed_Entity (Old_P))
and then (From_Limited_With (Renamed_Entity (Old_P))
or else Has_Limited_View (Renamed_Entity (Old_P)))
and then not
Unit_Is_Visible (Cunit (Get_Source_Unit (Renamed_Entity (Old_P))))
then
Error_Msg_NE
("renaming of limited view of package & not usable in this context"
& " (RM 8.5.3(3.1/2))", Name (N), Renamed_Entity (Old_P));
-- Set basic attributes to minimize cascaded errors
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
-- Here for OK package renaming
else
@ -6290,6 +6306,22 @@ package body Sem_Ch8 is
then
P_Name := Renamed_Object (P_Name);
if From_Limited_With (P_Name)
and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
then
Error_Msg_NE
("renaming of limited view of package & not usable in this"
& " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name);
elsif Has_Limited_View (P_Name)
and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
and then not Is_Visible_Through_Renamings (P_Name)
then
Error_Msg_NE
("renaming of limited view of package & not usable in this"
& " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name);
end if;
-- Rewrite node with entity field pointing to renamed object
Rewrite (Prefix (N), New_Copy (Prefix (N)));
@ -6355,6 +6387,19 @@ package body Sem_Ch8 is
Candidate := Get_Full_View (Non_Limited_View (Id));
Is_New_Candidate := True;
-- Handle special case where the prefix is a renaming of a shadow
-- package which is visible. Required to avoid reporting spurious
-- errors.
elsif Ekind (P_Name) = E_Package
and then From_Limited_With (P_Name)
and then not From_Limited_With (Id)
and then Sloc (Scope (Id)) = Sloc (P_Name)
and then Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name)))
then
Candidate := Get_Full_View (Id);
Is_New_Candidate := True;
-- An unusual case arises with a fully qualified name for an
-- entity local to a generic child unit package, within an
-- instantiation of that package. The name of the unit now