Commit 25409c3c by Javier Miranda Committed by Pierre-Marie de Rodat

[Ada] Membership test of class-wide interface

The compiler rejects the use of a membership test when the left operand
is a class-wide interface type object and the right operand is not a
class-wide type.

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

gcc/ada/

	* sem_res.adb (Resolve_Membership_Op): Allow the use of the membership
	test when the left operand is a class-wide interface and the right
	operand is not a class-wide type.
	* exp_ch4.adb (Tagged_Membership): Adding support for interface as the
	left operand.

gcc/testsuite/

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

From-SVN: r260738
parent 1f6237e3
2018-05-25 Javier Miranda <miranda@adacore.com>
* sem_res.adb (Resolve_Membership_Op): Allow the use of the membership
test when the left operand is a class-wide interface and the right
operand is not a class-wide type.
* exp_ch4.adb (Tagged_Membership): Adding support for interface as the
left operand.
2018-05-25 Ed Schonberg <schonberg@adacore.com>
* exp_aggr.adb (Flatten): A quantified expression cannot be duplicated
......
......@@ -13891,7 +13891,7 @@ package body Exp_Ch4 is
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
-- No need to issue a run-time check if we statically know that the
-- result of this membership test is always true. For example,
......
......@@ -9032,7 +9032,6 @@ package body Sem_Res is
elsif Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (Etype (L))
and then Is_Interface (Etype (L))
and then Is_Class_Wide_Type (Etype (R))
and then not Is_Interface (Etype (R))
then
return;
......
2018-05-25 Javier Miranda <miranda@adacore.com>
* gnat.dg/interface7.adb: New testcase.
2018-05-25 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/sec_stack2.adb: New testcase.
......
-- { dg-do compile }
procedure Interface7 is
type I_Type is interface;
type A1_Type is tagged null record;
type A2_Type is new A1_Type and I_Type with null record;
procedure Test (X : I_Type'Class) is
begin
if X in A2_Type then -- Test
null;
end if;
end Test;
begin null; end;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment