OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Wrong equality on untagged private type

Browse Source 
When a private type declaration T1 is completed with a derivation of an
untagged private type that overrides the predefined equality primitive, and the
full view of T2 is a derivation of another private type T2 whose full view is a
tagged type, the compiler may generate code that references the wrong equality
primitive when processing comparisons of objects of type T1.

2018-05-29  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new
	subprogram Inherits_From_Tagged_Full_View to identify more reliably
	untagged private types completed with a derivation of an untagged
	private whose full view is a tagged type.
	* sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New
	subprogram.
	(Collect_Primitive_Operations): Handle untagged private types completed
	with a derivation of an untagged private type whose full view is a
	tagged type. In such case, collecting the list of primitives we may
	find two equality primitives: one associated with the untagged private
	and another associated with the ultimate tagged type (and we must
	remove from the returned list this latter one).

gcc/testsuite/

	* gnat.dg/equal2.adb: New testcase.

From-SVN: r260886
This commit is contained in:
Javier Miranda 2018-05-29 09:42:34 +00:00 committed by Pierre-Marie de Rodat
parent 999acab61b
commit 656412552b
6 changed files with 159 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/ada/ChangeLog
View File

@ -1,3 +1,18 @@
2018-05-29 Javier Miranda <miranda@adacore.com>
* exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new
subprogram Inherits_From_Tagged_Full_View to identify more reliably
untagged private types completed with a derivation of an untagged
private whose full view is a tagged type.
* sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New
subprogram.
(Collect_Primitive_Operations): Handle untagged private types completed
with a derivation of an untagged private type whose full view is a
tagged type. In such case, collecting the list of primitives we may
find two equality primitives: one associated with the untagged private
and another associated with the ultimate tagged type (and we must
remove from the returned list this latter one).
2018-05-29 Ed Schonberg <schonberg@adacore.com>
* exp_unst.adb (Visit_Node): Handle statement sequences that include an

32
gcc/ada/exp_ch4.adb
View File

@ -2488,17 +2488,13 @@ package body Exp_Ch4 is
Full_Type := Root_Type (Full_Type);
end if;
-- If this is derived from an untagged private type completed with a
-- tagged type, it does not have a full view, so we use the primitive
-- operations of the private type. This check should no longer be
-- necessary when these types receive their full views ???
-- If this is an untagged private type completed with a derivation of
-- an untagged private type whose full view is a tagged type, we use
-- the primitive operations of the private parent type (since it does
-- not have a full view, and also because its equality primitive may
-- have been overridden in its untagged full view).
if Is_Private_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Controlled (Typ)
and then Is_Derived_Type (Typ)
and then No (Full_View (Typ))
then
if Inherits_From_Tagged_Full_View (Typ) then
Prim := First_Elmt (Collect_Primitive_Operations (Typ));
else
Prim := First_Elmt (Primitive_Operations (Full_Type));
@ -7857,16 +7853,14 @@ package body Exp_Ch4 is
return;
end if;
-- If this is derived from an untagged private type completed with
-- a tagged type, it does not have a full view, so we use the
-- primitive operations of the private type. This check should no
-- longer be necessary when these types get their full views???
-- If this is an untagged private type completed with a derivation
-- of an untagged private type whose full view is a tagged type,
-- we use the primitive operations of the private type (since it
-- does not have a full view, and also because its equality
-- primitive may have been overridden in its untagged full view).
if Inherits_From_Tagged_Full_View (A_Typ) then
if Is_Private_Type (A_Typ)
and then not Is_Tagged_Type (A_Typ)
and then Is_Derived_Type (A_Typ)
and then No (Full_View (A_Typ))
then
-- Search for equality operation, checking that the operands
-- have the same type. Note that we must find a matching entry,
-- or something is very wrong.

89
gcc/ada/sem_util.adb
View File

@ -5084,15 +5084,7 @@ package body Sem_Util is
----------------------------------
function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
B_Type : constant Entity_Id := Base_Type (T);
B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
B_Scope : Entity_Id := Scope (B_Type);
Op_List : Elist_Id;
Formal : Entity_Id;
Is_Prim : Boolean;
Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False;
Id : Entity_Id;
B_Type : constant Entity_Id := Base_Type (T);
function Match (E : Entity_Id) return Boolean;
-- True if E's base type is B_Type, or E is of an anonymous access type
@ -5120,6 +5112,18 @@ package body Sem_Util is
and then Full_View (Etyp) = B_Type);
end Match;
-- Local variables
B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
B_Scope : Entity_Id := Scope (B_Type);
Op_List : Elist_Id;
Eq_Prims_List : Elist_Id := No_Elist;
Formal : Entity_Id;
Is_Prim : Boolean;
Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False;
Id : Entity_Id;
-- Start of processing for Collect_Primitive_Operations
begin
@ -5268,6 +5272,22 @@ package body Sem_Util is
else
Append_Elmt (Id, Op_List);
-- Save collected equality primitives for later filtering
-- (if we are processing a private type for which we can
-- collect several candidates).
if Inherits_From_Tagged_Full_View (T)
and then Chars (Id) = Name_Op_Eq
and then Etype (First_Formal (Id)) =
Etype (Next_Formal (First_Formal (Id)))
then
if No (Eq_Prims_List) then
Eq_Prims_List := New_Elmt_List;
end if;
Append_Elmt (Id, Eq_Prims_List);
end if;
end if;
end if;
end if;
@ -5285,6 +5305,43 @@ package body Sem_Util is
Id := First_Entity (System_Aux_Id);
end if;
end loop;
-- Filter collected equality primitives
if Inherits_From_Tagged_Full_View (T)
and then Present (Eq_Prims_List)
then
declare
First : constant Elmt_Id := First_Elmt (Eq_Prims_List);
Second : Elmt_Id;
begin
pragma Assert (No (Next_Elmt (First))
or else No (Next_Elmt (Next_Elmt (First))));
-- No action needed if we have collected a single equality
-- primitive
if Present (Next_Elmt (First)) then
Second := Next_Elmt (First);
if Is_Dispatching_Operation
(Ultimate_Alias (Node (First)))
then
Remove (Op_List, Node (First));
elsif Is_Dispatching_Operation
(Ultimate_Alias (Node (Second)))
then
Remove (Op_List, Node (Second));
else
pragma Assert (False);
raise Program_Error;
end if;
end if;
end;
end if;
end if;
return Op_List;
@ -12615,6 +12672,20 @@ package body Sem_Util is
end if;
end Inherit_Rep_Item_Chain;
------------------------------------
-- Inherits_From_Tagged_Full_View --
------------------------------------
function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is
begin
return Is_Private_Type (Typ)
and then Present (Full_View (Typ))
and then Is_Private_Type (Full_View (Typ))
and then not Is_Tagged_Type (Full_View (Typ))
and then Present (Underlying_Type (Full_View (Typ)))
and then Is_Tagged_Type (Underlying_Type (Full_View (Typ)));
end Inherits_From_Tagged_Full_View;
---------------------------------
-- Insert_Explicit_Dereference --
---------------------------------

6
gcc/ada/sem_util.ads
View File

@ -1452,6 +1452,12 @@ package Sem_Util is
-- Inherit the rep item chain of type From_Typ without clobbering any
-- existing rep items on Typ's chain. Typ is the destination type.
function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean;
pragma Inline (Inherits_From_Tagged_Full_View);
-- Return True if Typ is an untagged private type completed with a
-- derivation of an untagged private type declaration whose full view
-- is a tagged type.
procedure Insert_Explicit_Dereference (N : Node_Id);
-- In a context that requires a composite or subprogram type and where a
-- prefix is an access type, rewrite the access type node N (which is the

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2018-05-29 Javier Miranda <miranda@adacore.com>
* gnat.dg/equal2.adb: New testcase.
2018-05-29 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/float_attributes_overflows.adb: New testcase.

41
gcc/testsuite/gnat.dg/equal2.adb Normal file
View File

@ -0,0 +1,41 @@
-- { dg-do run }
procedure Equal2 is
package L1 is
type T is private;
overriding function "=" (Left, Right : T) return Boolean;
private
type T is tagged record
I : Integer := 0;
end record;
end L1;
package L2 is
type T is private;
private
type T is new L1.T;
overriding function "=" (Left, Right : T) return Boolean;
end L2;
package body L1 is
overriding function "=" (Left, Right : T) return Boolean is
begin
return False;
end "=";
end L1;
package body L2 is
overriding function "=" (Left, Right : T) return Boolean is
begin
return True;
end "=";
end L2;
use type L2.T;
Left, Right : L2.T;
begin
if Left /= Right then
raise Program_Error;
end if;
end;