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,
(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);
!
! 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
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()
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()
! 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" } }