re PR fortran/66227 ([OOP] EXTENDS_TYPE_OF n returns wrong result for polymorphic...
authorJanus Weil <janus@gcc.gnu.org>
Thu, 17 Nov 2016 07:52:24 +0000 (08:52 +0100)
committerJanus Weil <janus@gcc.gnu.org>
Thu, 17 Nov 2016 07:52:24 +0000 (08:52 +0100)
2016-11-17  Janus Weil  <janus@gcc.gnu.org>

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

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

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

From-SVN: r242535

gcc/fortran/ChangeLog
gcc/fortran/simplify.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/extends_type_of_3.f90

index 428ebdaeede73bc3f86c21d31b8138151db1a111..6d7d415eae100e981eeb1ab119862e949da977a5 100644 (file)
@@ -1,3 +1,9 @@
+2016-11-17  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/66227
+       * simplify.c (gfc_simplify_extends_type_of): Fix missed optimization.
+       Prevent over-simplification. Fix a comment. Add a comment.
+
 2016-11-16  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        PR fortran/58001
index 549d900538b1926418962f73688f22ebbcc83c13..9047c63db69d4dd82668a05b7df57b823dccf67a 100644 (file)
@@ -2517,7 +2517,7 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
   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,
@@ -2526,19 +2526,20 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
                        (a->ts.u.derived->components->ts.u.derived,
                         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 4d4679418a2bfd3dfe852f9ebd9586f0312eb353..abfea5077fb9a097d2c35d1bb9447fa91e714d9b 100644 (file)
@@ -1,3 +1,8 @@
+2016-11-17  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/66227
+       * gfortran.dg/extends_type_of_3.f90: Fix and extend the test case.
+
 2016-11-16  Marek Polacek  <polacek@redhat.com>
 
        PR c/78285
index 4c1a6a0f5a044d50a27600cee9265971810148f5..6ba1dc3212da30610cf0253e62570f8406c100dc 100644 (file)
@@ -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)  ! T
 
 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 abort()
 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 should_not_exist()
 ! 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" } }