diff mbox

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

Message ID CAKwh3qif+xJRcY0XkGwnHmHREQ=dxMSEVgeYAH__wCjgeOOcrw@mail.gmail.com
State New
Headers show

Commit Message

Janus Weil Nov. 15, 2016, 8:19 p.m. UTC 
Hi all,

the attached patch fixes a wrong-code problem with the intrinsic
function EXTENDS_TYPE_OF. The simplification function which tries to
reduce calls to EXTENDS_TYPE_OF to a compile-time constant (if
possible) was a bit over-zealous and simplified cases that were
actually not decidable at compile-time, thus causing wrong code.

The patch fixes the simplification function and also the corresponding
test case (which unfortunately was wrong as well) and regtests
cleanly. Ok for trunk and the release branches?

Cheers,
Janus



2016-11-15  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/66227
    * simplify.c (gfc_simplify_extends_type_of): Prevent over-
    simplification. Fix a comment. Add a comment.

2016-11-15  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/66227
    * gfortran.dg/extends_type_of_3.f90: Fix and extend the test case.
diff mbox

Patch

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);
 
-  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 242447)
+++ 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()
@@ -83,8 +84,8 @@  if (extends_type_of(a1,a11) .neqv. .false.) call s
 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()
 
 ! Special case, simplified at tree folding:
@@ -92,19 +93,34 @@  if (extends_type_of(b1,b1)   .neqv. .true.) call a
 
 ! 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" 17 "original" } }
 ! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }