This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] PR40427: [F03] Procedure Pointer Components with OPTIONAL arguments
- From: Janus Weil <janus at gcc dot gnu dot org>
- To: Tobias Burnus <burnus at net-b dot de>
- Cc: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Wed, 24 Jun 2009 10:43:17 +0200
- Subject: Re: [Patch, Fortran] PR40427: [F03] Procedure Pointer Components with OPTIONAL arguments
- References: <20090623123441.GA9369@net-b.de>
>> The patch is regression-tested on x86_64-unknown-linux-gnu.
>> Ok for trunk?
>
> As you have modified what is put into the .mod files, you need
> to bump the module version:
>
> ? #define MOD_VERSION "0"
Ah, good point. Seems like I'm the first one to do this since the
MOD_VERSION was introduced.
(Updated patch attached.)
> Otherwise it looks OK to me.
I'll take this as an approval and commit later today.
Cheers,
Janus
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-24 Janus Weil <janus@gcc.gnu.org>
PR fortran/40427
* gfortran.dg/proc_ptr_comp_11.f90: New.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 148856)
+++ gcc/fortran/interface.c (working copy)
@@ -2397,6 +2397,50 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
}
+/* 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. */
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 148856)
+++ gcc/fortran/symbol.c (working copy)
@@ -3944,6 +3944,60 @@ gfc_copy_formal_args_intr (gfc_symbol *d
}
+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
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 148856)
+++ gcc/fortran/gfortran.h (working copy)
@@ -855,6 +855,7 @@ typedef struct gfc_component
struct gfc_component *next;
struct gfc_formal_arglist *formal;
+ struct gfc_namespace *formal_ns;
}
gfc_component;
@@ -2409,6 +2410,7 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_sy
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 */
@@ -2580,6 +2582,7 @@ int gfc_compare_types (gfc_typespec *, g
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 *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 148856)
+++ gcc/fortran/module.c (working copy)
@@ -77,7 +77,7 @@ along with GCC; see the file COPYING3.
/* 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. */
@@ -2262,11 +2262,16 @@ mio_component_ref (gfc_component **cp, g
}
+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 ();
@@ -2293,6 +2298,30 @@ mio_component (gfc_component *c)
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 ();
}
@@ -2386,7 +2415,7 @@ mio_actual_arglist (gfc_actual_arglist *
/* 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;
@@ -2394,20 +2423,20 @@ mio_formal_arglist (gfc_symbol *sym)
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;
@@ -3436,7 +3465,7 @@ mio_symbol (gfc_symbol *sym)
/* 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);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 148856)
+++ gcc/fortran/resolve.c (working copy)
@@ -4847,9 +4847,7 @@ resolve_ppc_call (gfc_code* c)
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;
}
@@ -4881,8 +4879,7 @@ resolve_expr_ppc (gfc_expr* e)
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;
}
@@ -9040,7 +9037,7 @@ resolve_fl_derived (gfc_symbol *sym)
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;
@@ -9051,7 +9048,7 @@ resolve_fl_derived (gfc_symbol *sym)
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++)
@@ -9066,7 +9063,7 @@ resolve_fl_derived (gfc_symbol *sym)
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)
{