@@ -484,13 +484,24 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
if (ts1->type == BT_VOID || ts2->type == BT_VOID)
return 1;
- if (ts1->type == BT_CLASS
- && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ /* The _data component is not always present, therefore check for its
+ presence before assuming, that its derived->attr is available.
+ When the _data component is not present, then nevertheless the
+ unlimited_polymorphic flag may be set in the derived type's attr. */
+ if (ts1->type == BT_CLASS && ts1->u.derived->components
+ && ((ts1->u.derived->attr.is_class
+ && ts1->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts1->u.derived->attr.unlimited_polymorphic))
return 1;
/* F2003: C717 */
if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
- && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
+ && ts2->u.derived->components
+ && ((ts2->u.derived->attr.is_class
+ && ts2->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts2->u.derived->attr.unlimited_polymorphic)
&& (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
return 1;
@@ -4567,7 +4567,10 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
if (is_class1
&& ts1->u.derived->components
- && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ && ((ts1->u.derived->attr.is_class
+ && ts1->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts1->u.derived->attr.unlimited_polymorphic))
return 1;
if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
@@ -4578,13 +4581,21 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
if (is_derived1 && is_class2)
return gfc_compare_derived_types (ts1->u.derived,
- ts2->u.derived->components->ts.u.derived);
+ ts2->u.derived->attr.is_class ?
+ ts2->u.derived->components->ts.u.derived
+ : ts2->u.derived);
if (is_class1 && is_derived2)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
+ ts1->u.derived->components->ts.u.derived
+ : ts1->u.derived,
ts2->u.derived);
else if (is_class1 && is_class2)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
- ts2->u.derived->components->ts.u.derived);
+ return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
+ ts1->u.derived->components->ts.u.derived
+ : ts1->u.derived,
+ ts2->u.derived->attr.is_class ?
+ ts2->u.derived->components->ts.u.derived
+ : ts2->u.derived);
else
return 0;
}
@@ -4,6 +4,12 @@
!
! Contributed by Reinhold Bader <Reinhold.Bader@lrz.de>
+! Add dump-fortran-original to check, if the patch preventing a gfortran
+! segfault is working correctly. No cleanup needed, because the dump
+! goes to stdout.
+! { dg-options "-fdump-fortran-original" }
+! { dg-prune-output "Namespace:.*" }
+
program upimp
implicit class(foo) (a-b)
implicit class(*) (c)