[Patch, Fortran] PR 66227: [5/6/7 Regression] [OOP] EXTENDS_TYPE_OF n returns wrong result for polymorphic variable allocated to extended type

[Janus Weil]

Hi Mikael,

>> Index: gcc/fortran/simplify.c
>> ===================================================================
>> --- gcc/fortran/simplify.c      (Revision 242447)
>> +++ gcc/fortran/simplify.c      (Arbeitskopie)
>> @@ -2517,7 +2517,7 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_exp
>>    if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
>>      return NULL;
>>
>> -  /* Return .false. if the dynamic type can never be the same.  */
>> +  /* Return .false. if the dynamic type can never be an extension.  */
>>    if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
>>         && !gfc_type_is_extension_of
>>                         (mold->ts.u.derived->components->ts.u.derived,
>> @@ -2535,10 +2535,14 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_exp
>>        || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
>>           && !gfc_type_is_extension_of
>>                         (mold->ts.u.derived,
>> -                        a->ts.u.derived->components->ts.u.derived)))
>> +                        a->ts.u.derived->components->ts.u.derived)
>> +         && !gfc_type_is_extension_of
>> +                       (a->ts.u.derived->components->ts.u.derived,
>> +                        mold->ts.u.derived)))
>>      return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
>> false);
>
>
> this doesn’t catch the case where «mold» is of a base type and «a» of
> extended class.

indeed the piece of code above does not catch the case you describe,
but the piece that comes right after it in
gfc_simplify_extends_type_of does. In this situation we have to
simplify to a logical TRUE, because 'a' is guaranteed to be an
extension of 'mold'. This corresponds to the case "(b11,a1)" in the
test case.


> I believe gfc_type_is_extension is misused here. The original code intended
> meaning was probably that «a» is known not to be an extension of «mold», but
> the negation of gfc_type_is_extension only gives that it’s not known to be,
> which is weaker.

I'm not fully sure what you mean here. These things have the tendency
to tie a knot into my brain windings ;)

On top of that comes the complication that the arguments of
"gfc_type_is_extension_of" are in reversed order compared to
EXTENDS_TYPE_OF :(

In any case, I have thought about the logic of
gfc_simplify_extends_type_of once again, and the only remaining
problem I found was a case where the result was correct, but we missed
some optimization, namely "(a1,b11)" in the test case. This was left
as a runtime-case, but in fact it can be evaluated to FALSE at compile
time.

I fixed the simplification function and the test case accordingly, and
hope that everything should be fine now. Right? (Updated patch
attached ...)

Cheers,
Janus
-------------- next part --------------
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(Revision 242470)
+++ gcc/fortran/simplify.c	(Arbeitskopie)
@@ -2517,7 +2517,7 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_exp
   if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
     return NULL;
 
-  /* Return .false. if the dynamic type can never be the same.  */
+  /* Return .false. if the dynamic type can never be an extension.  */
   if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
        && !gfc_type_is_extension_of
 			(mold->ts.u.derived->components->ts.u.derived,
@@ -2527,18 +2527,19 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_exp
 			 mold->ts.u.derived->components->ts.u.derived))
       || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
 	  && !gfc_type_is_extension_of
-			(a->ts.u.derived,
-			 mold->ts.u.derived->components->ts.u.derived)
-	  && !gfc_type_is_extension_of
 			(mold->ts.u.derived->components->ts.u.derived,
 			 a->ts.u.derived))
       || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
 	  && !gfc_type_is_extension_of
 			(mold->ts.u.derived,
-			 a->ts.u.derived->components->ts.u.derived)))
+			 a->ts.u.derived->components->ts.u.derived)
+	  && !gfc_type_is_extension_of
+			(a->ts.u.derived->components->ts.u.derived,
+			 mold->ts.u.derived)))
     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
 
-  if (mold->ts.type == BT_DERIVED
+  /* Return .true. if the dynamic type is guaranteed to be an extension.  */
+  if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
       && gfc_type_is_extension_of (mold->ts.u.derived,
 				   a->ts.u.derived->components->ts.u.derived))
     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
Index: gcc/testsuite/gfortran.dg/extends_type_of_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/extends_type_of_3.f90	(Revision 242470)
+++ gcc/testsuite/gfortran.dg/extends_type_of_3.f90	(Arbeitskopie)
@@ -3,9 +3,7 @@
 !
 ! PR fortran/41580
 !
-! Compile-time simplification of SAME_TYPE_AS
-! and EXTENDS_TYPE_OF.
-!
+! Compile-time simplification of SAME_TYPE_AS and EXTENDS_TYPE_OF.
 
 implicit none
 type t1
@@ -37,6 +35,8 @@ logical, parameter :: p6 = same_type_as(a1,a1)  !
 
 if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist()
 
+if (same_type_as(b1,b1)   .neqv. .true.) call should_not_exist()
+
 ! Not (trivially) compile-time simplifiable:
 if (same_type_as(b1,a1)  .neqv. .true.) call abort()
 if (same_type_as(b1,a11) .neqv. .false.) call abort()
@@ -49,6 +49,7 @@ if (same_type_as(b1,a1)  .neqv. .false.) call abor
 if (same_type_as(b1,a11) .neqv. .true.) call abort()
 deallocate(b1)
 
+
 ! .true. -> same type
 if (extends_type_of(a1,a1)   .neqv. .true.) call should_not_exist()
 if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist()
@@ -78,33 +79,47 @@ if (extends_type_of(a2,b11) .neqv. .false.) call s
 ! type extension possible, compile-time checkable
 if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
 if (extends_type_of(a11,a1) .neqv. .true.) call should_not_exist()
-if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
 
 if (extends_type_of(b1,a1)   .neqv. .true.) call should_not_exist()
 if (extends_type_of(b11,a1)  .neqv. .true.) call should_not_exist()
 if (extends_type_of(b11,a11) .neqv. .true.) call should_not_exist()
-if (extends_type_of(b1,a11)  .neqv. .false.) call should_not_exist()
 
-if (extends_type_of(a1,b11)  .neqv. .false.) call abort()
+if (extends_type_of(a1,b11)  .neqv. .false.) call should_not_exist()
 
+
 ! Special case, simplified at tree folding:
 if (extends_type_of(b1,b1)   .neqv. .true.) call abort()
 
 ! All other possibilities are not compile-time checkable
 if (extends_type_of(b11,b1)  .neqv. .true.) call abort()
-!if (extends_type_of(b1,b11)  .neqv. .false.) call abort() ! FAILS due to PR 47189
+if (extends_type_of(b1,b11)  .neqv. .false.) call abort()
 if (extends_type_of(a11,b11) .neqv. .true.) call abort()
+
 allocate(t11 :: b11)
 if (extends_type_of(a11,b11) .neqv. .true.) call abort()
 deallocate(b11)
+
 allocate(t111 :: b11)
 if (extends_type_of(a11,b11) .neqv. .false.) call abort()
 deallocate(b11)
+
 allocate(t11 :: b1)
 if (extends_type_of(a11,b1) .neqv. .true.) call abort()
 deallocate(b1)
 
+allocate(t11::b1)
+if (extends_type_of(b1,a11) .neqv. .true.) call abort()
+deallocate(b1)
+
+allocate(b1,source=a11)
+if (extends_type_of(b1,a11) .neqv. .true.) call abort()
+deallocate(b1)
+
+allocate( b1,source=a1)
+if (extends_type_of(b1,a11) .neqv. .false.) call abort()
+deallocate(b1)
+
 end
 
-! { dg-final { scan-tree-dump-times "abort" 13 "original" } }
+! { dg-final { scan-tree-dump-times "abort" 16 "original" } }
 ! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }