interface.c (gfc_procedure_use): Return gfc_try instead of
2012-07-31 Tobias Burnus <burnus@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-31 Tobias Burnus <burnus@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. From-SVN: r190003
This commit is contained in:
parent
4adf72f140
commit
f8552cd47a
|
@ -1,3 +1,12 @@
|
|||
2012-07-31 Tobias Burnus <burnus@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-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/51081
|
||||
|
|
|
@ -2849,7 +2849,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 **);
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
@ -3011,20 +3011,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 */
|
||||
|
@ -3479,7 +3477,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))
|
||||
|
@ -3490,6 +3492,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
|
||||
|
@ -3515,7 +3526,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 */
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
2012-07-31 Tobias Burnus <burnus@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.
|
||||
|
||||
2012-07-31 Paolo Carlini <paolo.carlini@oracle.com>
|
||||
|
||||
PR c++/53624
|
||||
|
|
|
@ -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()
|
||||
|
|
|
@ -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
|
|
@ -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" } }
|
||||
|
Loading…
Reference in New Issue