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 <ja...@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 <ja...@gcc.gnu.org> PR fortran/66227 * gfortran.dg/extends_type_of_3.f90: Fix and extend the test case.
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" } }