Mikael Morin wrote:
The four of them are not directly related to the assumed rank stuff, and
thus deserve a separate commit.
As you said:
>* Unrelated bug fixes, found when writing the test cases and thus
included:
I assume they don't need testcases of their own, so that they are
approved as is.
Thanks for the review. I have committed them – after regtesting – as
Rev. 189669 (interface.c) and Rev. 189678 (resolve.c, interface.c).
I will now have a look at the other review comments and your patch.
Thanks for walking through the big patch.
* * *
Patches with pending review:
* Allowed assumed-shape with bind(C) [TS29113]:
http://gcc.gnu.org/ml/fortran/2012-07/msg00086.html
* C_F_POINTER changes for the fortran-dev branch:
http://gcc.gnu.org/ml/fortran/2012-07/msg00045.html
Tobias
Index: interface.c
===================================================================
--- interface.c (Revision 189668)
+++ interface.c (Arbeitskopie)
@@ -1743,7 +1743,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
}
/* F2008, 12.5.2.5; IR F08/0073. */
- if (formal->ts.type == BT_CLASS
+ if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
&& ((CLASS_DATA (formal)->attr.class_pointer
&& !formal->attr.intent == INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable))
@@ -2289,11 +2289,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
return 0;
}
- if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
- && (f->sym->attr.allocatable || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ if (a->expr->expr_type == EXPR_NULL
+ && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
+ && (f->sym->attr.allocatable || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ || (f->sym->ts.type == BT_CLASS
+ && !CLASS_DATA (f->sym)->attr.class_pointer
+ && (CLASS_DATA (f->sym)->attr.allocatable
+ || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
{
- if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+ if (where
+ && (!f->sym->attr.optional
+ || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.allocatable)))
gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
where, f->sym->name);
else if (where)
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 189668)
+++ ChangeLog (Arbeitskopie)
@@ -1,3 +1,8 @@
+2012-07-19 Tobias Burnus <bur...@net-b.de>
+
+ * interface.c (compare_parameter, compare_actual_formal): Fix
+ handling of polymorphic arguments.
+
2012-07-17 Janus Weil <ja...@gcc.gnu.org>
PR fortran/51081
Index: trans-expr.c
===================================================================
--- trans-expr.c (Revision 189675)
+++ trans-expr.c (Arbeitskopie)
@@ -3620,10 +3620,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
- else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+ else if (arg->expr->expr_type == EXPR_NULL
+ && fsym && !fsym->attr.pointer
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.class_pointer))
{
/* Pass a NULL pointer to denote an absent arg. */
- gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+ gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 189675)
+++ ChangeLog (Arbeitskopie)
@@ -1,5 +1,12 @@
2012-07-19 Tobias Burnus <bur...@net-b.de>
+ * trans-expr.c (gfc_conv_procedure_call): Fix handling
+ of polymorphic arguments.
+ * resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
+ assumed-shape arrays as such.
+
+2012-07-19 Tobias Burnus <bur...@net-b.de>
+
* interface.c (compare_parameter, compare_actual_formal): Fix
handling of polymorphic arguments.
Index: resolve.c
===================================================================
--- resolve.c (Revision 189675)
+++ resolve.c (Arbeitskopie)
@@ -251,6 +251,7 @@ resolve_formal_arglist (gfc_symbol *proc)
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
+ gfc_array_spec *as;
if (sym == NULL)
{
@@ -284,23 +285,33 @@ resolve_formal_arglist (gfc_symbol *proc)
gfc_set_default_type (sym, 1, sym->ns);
}
- gfc_resolve_array_spec (sym->as, 0);
+ as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+ ? CLASS_DATA (sym)->as : sym->as;
+ gfc_resolve_array_spec (as, 0);
+
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
*/
- if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable)
+ if (as && as->rank > 0 && as->type == AS_DEFERRED
+ && ((sym->ts.type != BT_CLASS
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ || (sym->ts.type == BT_CLASS
+ && !(CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
{
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < as->rank; i++)
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
- if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.target))
|| sym->attr.optional)
{
proc->attr.always_explicit = 1;
