TS29113 allows also non interoperable procedures with
c_funloc/c_f_procpointer; hence, this patch allows them with -std=f2008ts:
"The function C F PROCPOINTER from the intrinsic module ISO C BINDING
has the restriction in ISO/IEC 1539-1:2010 that CPTR and FPTR shall not
be the C address and interface of a noninteroperable Fortran procedure.
"The function C FUNLOC from the intrinsic module ISO C BINDING has the
restriction in ISO/IEC 1539-1:2010 that its argument shall be interoperable.
"These restrictions are removed."
Additionally, I changed "parameter" to "argument" and added a diagnostic
that the first argument to c_f_pointer/c_f_procpointer is the correct
one - before both accepted c_ptr and c_funptr.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: For c_loc/c_f_pointer a similar restriction has been removed.
However, to fix c_loc is more complicated as the current implementation
has several rejects-valid/wrong-code bugs (cf. the existing PRs). For
the full to-do list of TS29113, see
http://gcc.gnu.org/ml/fortran/2012-07/msg00115.html
2012-07-26 Tobias Burnus <bur...@net-b.de>
* interface.c (gfc_procedure_use): Return gfc_try instead of void.
* gfortran.h (gfc_procedure_use): Update prototype.
* resolve.c (gfc_iso_c_func_interface): Allow noninteroperable
procedures for c_funloc for TS29113.
* (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add
diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer.
2012-07-26 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/c_funloc_tests_6.f90: New.
* gfortran.dg/c_funloc_tests_7.f90: New.
* gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index e1f2e3c..f803916 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2848,7 +2848,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *);
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
char *, int, const char *, const char *);
void gfc_check_interfaces (gfc_namespace *);
-void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
+gfc_try gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
gfc_actual_arglist **);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 098ec3d2..0f8951c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2927,7 +2927,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
well, the actual argument list will also end up being properly
sorted. */
-void
+gfc_try
gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
/* Warn about calls with an implicit interface. Special case
@@ -2954,7 +2954,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The pointer object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
- return;
+ return FAILURE;
}
if (sym->attr.allocatable && !sym->attr.external)
@@ -2962,14 +2962,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The allocatable object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
- return;
+ return FAILURE;
}
if (sym->attr.allocatable)
{
gfc_error("Allocatable function '%s' at %L must have an explicit "
"function interface", sym->name, where);
- return;
+ return FAILURE;
}
for (a = *ap; a; a = a->next)
@@ -3009,7 +3009,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
&& a->expr->ts.type == BT_UNKNOWN)
{
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
- return;
+ return FAILURE;
}
/* TS 29113, C407b. */
@@ -3018,19 +3018,23 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
- return;
+ return FAILURE;
}
}
- return;
+ return SUCCESS;
}
if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
- return;
+ return FAILURE;
+
+ if (check_intents (sym->formal, *ap) == FAILURE)
+ return FAILURE;
- check_intents (sym->formal, *ap);
if (gfc_option.warn_aliasing)
check_some_aliasing (sym->formal, *ap);
+
+ return SUCCESS;
}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 370e5cd..b4c3e4d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3012,20 +3007,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
{
/* TODO: Update this error message to allow for procedure
pointers once they are implemented. */
- gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ gfc_error_now ("Argument '%s' to '%s' at %L must be a "
"procedure",
args_sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
- else if (args_sym->attr.is_bind_c != 1)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be "
- "BIND(C)",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
+ else if (args_sym->attr.is_bind_c != 1
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
+ "argument '%s' to '%s' at %L",
+ args_sym->name, sym->name,
+ &(args->expr->where)) == FAILURE)
+ retval = FAILURE;
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */
@@ -3480,7 +3473,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
/* Make sure the actual arguments are in the necessary order (based on the
formal args) before resolving. */
- gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
+ if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
+ {
+ c->resolved_sym = sym;
+ return MATCH_ERROR;
+ }
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
@@ -3491,6 +3488,15 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
{
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_error ("Argument at %L to C_F_POINTER shall have the type"
+ " C_PTR", &c->ext.actual->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
correct since we short-circuit this check in
@@ -3516,7 +3522,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
}
}
}
-
+ else /* ISOCBINDING_F_PROCPOINTER. */
+ {
+ if (c->ext.actual
+ && (c->ext.actual->expr->ts.type != BT_DERIVED
+ || c->ext.actual->expr->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_FUNPTR))
+ {
+ gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
+ "C_FUNPTR", &c->ext.actual->expr->where);
+ m = MATCH_ERROR;
+ }
+ if (c->ext.actual && c->ext.actual->next
+ && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
+ "procedure-pointer at %L to C_F_FUNPOINTER",
+ &c->ext.actual->next->expr->where)
+ == FAILURE)
+ m = MATCH_ERROR;
+ }
+
if (m != MATCH_ERROR)
{
/* the 1 means to add the optional arg to formal list */
--- /dev/null 2012-07-26 07:22:20.983742380 +0200
+++ gcc/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 2012-07-26 11:04:39.000000000 +0200
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! Check relaxed TS29113 constraints for procedures
+! and c_f_*pointer argument checking for c_ptr/c_funptr.
+!
+
+use iso_c_binding
+implicit none
+type(c_ptr) :: cp
+type(c_funptr) :: cfp
+
+interface
+ subroutine sub() bind(C)
+ end subroutine sub
+end interface
+integer(c_int), pointer :: int
+procedure(sub), pointer :: fsub
+
+integer, external :: noCsub
+procedure(integer), pointer :: fint
+
+cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." })
+cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
+
+call c_f_pointer (cfp, int) ! { dg-error "Argument at .1. to C_F_POINTER shall have the type C_PTR" }
+call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" }
+
+cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }
+call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" }
+end
--- /dev/null 2012-07-26 07:22:20.983742380 +0200
+++ gcc/gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90 2012-07-26 11:03:47.000000000 +0200
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts -fdump-tree-original" }
+!
+! Check relaxed TS29113 constraints for procedures
+! and c_f_*pointer argument checking for c_ptr/c_funptr.
+!
+
+use iso_c_binding
+implicit none
+type(c_funptr) :: cfp
+
+integer, external :: noCsub
+procedure(integer), pointer :: fint
+
+cfp = c_funloc (noCsub)
+call c_f_procpointer (cfp, fint)
+end
+
+! { dg-final { scan-tree-dump-times "cfp =\[^;\]+ nocsub;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "fint =\[^;\]+ cfp;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
index bbb418d..5d0862c 100644
--- a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
@@ -1,4 +1,5 @@
! { dg-do compile }
+! { dg-options "-std=f2003" }
! Test that the arg checking for c_funloc verifies the procedures are
! C interoperable.
module c_funloc_tests_5
@@ -7,9 +8,9 @@ contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
- my_c_funptr = c_funloc(sub1) ! { dg-error "must be BIND.C." }
+ my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" }
- my_c_funptr = c_funloc(func0) ! { dg-error "must be BIND.C." }
+ my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" }
end subroutine sub0
subroutine sub1()
