PR fortran/40427
* gfortran.h (gfc_component): New member 'formal_ns'.
(gfc_copy_formal_args_ppc,void gfc_ppc_use): New.
* interface.c (gfc_ppc_use): New function, analogous to
gfc_procedure_use, but for procedure pointer components.
* module.c (MOD_VERSION): Bump module version.
(mio_component): Treat formal arguments.
(mio_formal_arglist): Changed argument from gfc_symbol to
gfc_formal_arglist.
(mio_symbol): Changed argument of mio_formal_arglist.
* resolve.c (resolve_ppc_call,resolve_expr_ppc): Call gfc_ppc_use,
to check actual arguments and treat formal args correctly.
(resolve_fl_derived): Copy formal args of procedure pointer components
from their interface.
* symbol.c (gfc_copy_formal_args_ppc): New function, analogous to
gfc_copy_formal_args, but for procedure pointer components.
2009-06-24 Janus Weil <janus@gcc.gnu.org>
PR fortran/40427
* gfortran.dg/proc_ptr_comp_11.f90: New.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148906
138bc75d-0d04-0410-961f-
82ee72b054a4
+2009-06-24 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40427
+ * gfortran.h (gfc_component): New member 'formal_ns'.
+ (gfc_copy_formal_args_ppc,void gfc_ppc_use): New.
+ * interface.c (gfc_ppc_use): New function, analogous to
+ gfc_procedure_use, but for procedure pointer components.
+ * module.c (MOD_VERSION): Bump module version.
+ (mio_component): Treat formal arguments.
+ (mio_formal_arglist): Changed argument from gfc_symbol to
+ gfc_formal_arglist.
+ (mio_symbol): Changed argument of mio_formal_arglist.
+ * resolve.c (resolve_ppc_call,resolve_expr_ppc): Call gfc_ppc_use,
+ to check actual arguments and treat formal args correctly.
+ (resolve_fl_derived): Copy formal args of procedure pointer components
+ from their interface.
+ * symbol.c (gfc_copy_formal_args_ppc): New function, analogous to
+ gfc_copy_formal_args, but for procedure pointer components.
+
2009-06-22 Janus Weil <janus@gcc.gnu.org>
PR fortran/37254
struct gfc_component *next;
struct gfc_formal_arglist *formal;
+ struct gfc_namespace *formal_ns;
}
gfc_component;
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
+void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int);
void gfc_check_interfaces (gfc_namespace *);
void 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 **);
gfc_try gfc_extend_expr (gfc_expr *);
}
+/* Check how a procedure pointer component is used against its interface.
+ If all goes well, the actual argument list will also end up being properly
+ sorted. Completely analogous to gfc_procedure_use. */
+
+void
+gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
+{
+
+ /* Warn about calls with an implicit interface. Special case
+ for calling a ISO_C_BINDING becase c_loc and c_funloc
+ are pseudo-unknown. */
+ if (gfc_option.warn_implicit_interface
+ && comp->attr.if_source == IFSRC_UNKNOWN
+ && !comp->attr.is_iso_c)
+ gfc_warning ("Procedure pointer component '%s' called with an implicit "
+ "interface at %L", comp->name, where);
+
+ if (comp->attr.if_source == IFSRC_UNKNOWN)
+ {
+ gfc_actual_arglist *a;
+ for (a = *ap; a; a = a->next)
+ {
+ /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
+ if (a->name != NULL && a->name[0] != '%')
+ {
+ gfc_error("Keyword argument requires explicit interface "
+ "for procedure pointer component '%s' at %L",
+ comp->name, &a->expr->where);
+ break;
+ }
+ }
+
+ return;
+ }
+
+ if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
+ return;
+
+ check_intents (comp->formal, *ap);
+ if (gfc_option.warn_aliasing)
+ check_some_aliasing (comp->formal, *ap);
+}
+
+
/* Try if an actual argument list matches the formal list of a symbol,
respecting the symbol's attributes like ELEMENTAL. This is used for
GENERIC resolution. */
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "0"
+#define MOD_VERSION "1"
/* Structure that describes a position within a module file. */
}
+static void mio_namespace_ref (gfc_namespace **nsp);
+static void mio_formal_arglist (gfc_formal_arglist **formal);
+
+
static void
mio_component (gfc_component *c)
{
pointer_info *p;
int n;
+ gfc_formal_arglist *formal;
mio_lparen ();
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
mio_expr (&c->initializer);
+
+ if (iomode == IO_OUTPUT)
+ {
+ formal = c->formal;
+ while (formal && !formal->sym)
+ formal = formal->next;
+
+ if (formal)
+ mio_namespace_ref (&formal->sym->ns);
+ else
+ mio_namespace_ref (&c->formal_ns);
+ }
+ else
+ {
+ mio_namespace_ref (&c->formal_ns);
+ /* TODO: if (c->formal_ns)
+ {
+ c->formal_ns->proc_name = c;
+ c->refs++;
+ }*/
+ }
+
+ mio_formal_arglist (&c->formal);
+
mio_rparen ();
}
/* Read and write formal argument lists. */
static void
-mio_formal_arglist (gfc_symbol *sym)
+mio_formal_arglist (gfc_formal_arglist **formal)
{
gfc_formal_arglist *f, *tail;
if (iomode == IO_OUTPUT)
{
- for (f = sym->formal; f; f = f->next)
+ for (f = *formal; f; f = f->next)
mio_symbol_ref (&f->sym);
}
else
{
- sym->formal = tail = NULL;
+ *formal = tail = NULL;
while (peek_atom () != ATOM_RPAREN)
{
f = gfc_get_formal_arglist ();
mio_symbol_ref (&f->sym);
- if (sym->formal == NULL)
- sym->formal = f;
+ if (*formal == NULL)
+ *formal = f;
else
tail->next = f;
/* Save/restore common block links. */
mio_symbol_ref (&sym->common_next);
- mio_formal_arglist (sym);
+ mio_formal_arglist (&sym->formal);
if (sym->attr.flavor == FL_PARAMETER)
mio_expr (&sym->value);
comp->formal == NULL) == FAILURE)
return FAILURE;
- /* TODO: Check actual arguments.
- gfc_procedure_use (stree->n.sym, &c->expr1->value.compcall.actual,
- &c->expr1->where);*/
+ gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
return SUCCESS;
}
comp->formal == NULL) == FAILURE)
return FAILURE;
- /* TODO: Check actual arguments.
- gfc_procedure_use (stree->n.sym, &e->value.compcall.actual, &e->where); */
+ gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
return SUCCESS;
}
c->ts.interface = ifc;
c->attr.function = ifc->attr.function;
c->attr.subroutine = ifc->attr.subroutine;
- /* TODO: gfc_copy_formal_args (c, ifc); */
+ gfc_copy_formal_args_ppc (c, ifc);
c->attr.allocatable = ifc->attr.allocatable;
c->attr.pointer = ifc->attr.pointer;
c->attr.always_explicit = ifc->attr.always_explicit;
/* Copy array spec. */
c->as = gfc_copy_array_spec (ifc->as);
- /*if (c->as)
+ /* TODO: if (c->as)
{
int i;
for (i = 0; i < c->as->rank; i++)
c->ts.cl = gfc_get_charlen();
c->ts.cl->resolved = ifc->ts.cl->resolved;
c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
- /*gfc_expr_replace_symbols (c->ts.cl->length, c);*/
+ /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/
/* Add charlen to namespace. */
/*if (c->formal_ns)
{
}
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ /* TODO: gfc_current_ns->proc_name = dest;*/
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ dest->formal = head;
+ dest->attr.if_source = IFSRC_DECL;
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
+2009-06-24 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40427
+ * gfortran.dg/proc_ptr_comp_11.f90: New.
+
2009-06-24 Andreas Krebbel <krebbel1@de.ibm.com>
* gcc.dg/pr40501.c: New testcase.
--- /dev/null
+! { dg-do run }
+!
+! PR 40427: Procedure Pointer Components with OPTIONAL arguments
+!
+! Original test case by John McFarland <john.mcfarland@swri.org>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+PROGRAM prog
+
+ ABSTRACT INTERFACE
+ SUBROUTINE sub_template(i,j,o)
+ INTEGER, INTENT(in) :: i
+ INTEGER, INTENT(in), OPTIONAL :: j, o
+ END SUBROUTINE sub_template
+ END INTERFACE
+
+ TYPE container
+ PROCEDURE(sub_template), POINTER, NOPASS :: s
+ END TYPE container
+
+ PROCEDURE(sub_template), POINTER :: f
+ TYPE (container) :: c
+
+ c%s => sub
+ f => sub
+
+ CALL f(2,o=4)
+ CALL c%s(3,o=6)
+
+CONTAINS
+
+ SUBROUTINE sub(i,arg2,arg3)
+ INTEGER, INTENT(in) :: i
+ INTEGER, INTENT(in), OPTIONAL :: arg2, arg3
+ if (present(arg2)) call abort()
+ if (.not. present(arg3)) call abort()
+ if (2*i/=arg3) call abort()
+ END SUBROUTINE sub
+
+END PROGRAM prog
+