This is the mail archive of the
gcc-bugs@gcc.gnu.org
mailing list for the GCC project.
[Bug fortran/57639] [OOP] ICE with polymorphism (and illegal code)
- From: "janus at gcc dot gnu.org" <gcc-bugzilla at gcc dot gnu dot org>
- To: gcc-bugs at gcc dot gnu dot org
- Date: Thu, 20 Jun 2013 11:09:46 +0000
- Subject: [Bug fortran/57639] [OOP] ICE with polymorphism (and illegal code)
- Auto-submitted: auto-generated
- References: <bug-57639-4 at http dot gcc dot gnu dot org/bugzilla/>
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57639
janus at gcc dot gnu.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|NEW |ASSIGNED
Assignee|unassigned at gcc dot gnu.org |janus at gcc dot gnu.org
--- Comment #3 from janus at gcc dot gnu.org ---
The following patch fixes both variants:
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 199689)
+++ gcc/fortran/interface.c (working copy)
@@ -1966,7 +1966,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
}
/* F2008, 12.5.2.5; IR F08/0073. */
- if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
+ if (formal->ts.type == BT_CLASS && formal->attr.class_ok
+ && actual->expr_type != EXPR_NULL
&& ((CLASS_DATA (formal)->attr.class_pointer
&& !formal->attr.intent == INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable))
@@ -1978,6 +1979,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
formal->name, &actual->where);
return 0;
}
+
+ if (!gfc_expr_attr (actual).class_ok)
+ return 0;
+
if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
CLASS_DATA (formal)->ts.u.derived))
{
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 199689)
+++ gcc/fortran/simplify.c (working copy)
@@ -2296,7 +2296,8 @@ gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *
/* Return .false. if the dynamic type can never be the
same. */
- if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+ if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
+ || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
&& !gfc_type_compatible (&a->ts, &b->ts)
&& !gfc_type_compatible (&b->ts, &a->ts))
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);