From 04f1c83099aab49f530f492b9d8119cf9d5ffcdd Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 17 Nov 2016 08:52:24 +0100 Subject: [PATCH] re PR fortran/66227 ([OOP] EXTENDS_TYPE_OF n returns wrong result for polymorphic variable allocated to extended type) 2016-11-17 Janus Weil 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 PR fortran/66227 * gfortran.dg/extends_type_of_3.f90: Fix and extend the test case. From-SVN: r242535 --- gcc/fortran/ChangeLog | 6 +++++ gcc/fortran/simplify.c | 13 ++++++----- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/extends_type_of_3.f90 | 31 ++++++++++++++++++------- 4 files changed, 41 insertions(+), 14 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 428ebda..6d7d415 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-11-17 Janus Weil + + 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 PR fortran/58001 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 549d900..9047c63 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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, @@ -2527,18 +2527,19 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4d46794..abfea507 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-17 Janus Weil + + PR fortran/66227 + * gfortran.dg/extends_type_of_3.f90: Fix and extend the test case. + 2016-11-16 Marek Polacek PR c/78285 diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 index 4c1a6a0..6ba1dc3 100644 --- a/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 +++ b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 @@ -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" } } -- 2.7.4