http://gcc.gnu.org/bugzilla/show_bug.cgi?id=54667
janus at gcc dot gnu.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|UNCONFIRMED |ASSIGNED
Last reconfirmed| |2012-09-22
AssignedTo|unassigned at gcc dot |janus at gcc dot gnu.org
|gnu.org |
Ever Confirmed|0 |1
--- Comment #5 from janus at gcc dot gnu.org 2012-09-22 13:11:14 UTC ---
Here is a patch to reject polymorphic arguments of C_F_POINTER (together with a
bit of cleanup and fixing/improving two other error messages):
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 191382)
+++ gcc/fortran/resolve.c (working copy)
@@ -3532,34 +3532,43 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
{
- if (c->ext.actual->expr->ts.type != BT_DERIVED
- || c->ext.actual->expr->ts.u.derived->intmod_sym_id
- != ISOCBINDING_PTR)
+ gfc_actual_arglist *arg1 = c->ext.actual;
+ gfc_actual_arglist *arg2 = c->ext.actual->next;
+
+ /* Check first argument (CPTR). */
+ if (arg1->expr->ts.type != BT_DERIVED
+ || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
{
- gfc_error ("Argument at %L to C_F_POINTER shall have the type"
- " C_PTR", &c->ext.actual->expr->where);
+ gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
+ "the type C_PTR", &arg1->expr->where);
m = MATCH_ERROR;
}
- /* Make sure we got a third arg if the second arg has non-zero
- rank. We must also check that the type and rank are
+ /* Check second argument (FPTR). */
+ if (arg2->expr->ts.type == BT_CLASS)
+ {
+ gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
+ "polymorphic", &arg2->expr->where);
+ m = MATCH_ERROR;
+ }
+
+ /* Make sure we got a third arg (SHAPE) if the second arg has
+ non-zero rank. We must also check that the type and rank are
correct since we short-circuit this check in
gfc_procedure_use() (called above to sort actual args). */
- if (c->ext.actual->next->expr->rank != 0)
+ if (arg2->expr->rank != 0)
{
- if(c->ext.actual->next->next == NULL
- || c->ext.actual->next->next->expr == NULL)
+ if (arg2->next == NULL || arg2->next->expr == NULL)
{
m = MATCH_ERROR;
- gfc_error ("Missing SHAPE parameter for call to %s "
+ gfc_error ("Missing SHAPE argument for call to %s "
"at %L", sym->name, &(c->loc));
}
- else if (c->ext.actual->next->next->expr->ts.type
- != BT_INTEGER
- || c->ext.actual->next->next->expr->rank != 1)
+ else if (arg2->next->expr->ts.type != BT_INTEGER
+ || arg2->next->expr->rank != 1)
{
m = MATCH_ERROR;
- gfc_error ("SHAPE parameter for call to %s at %L must "
+ gfc_error ("SHAPE argument for call to %s at %L must "
"be a rank 1 INTEGER array", sym->name,
&(c->loc));
}
