OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

trans-array.c (gfc_get_proc_ifc_for_expr): New function. 

* trans-array.c (gfc_get_proc_ifc_for_expr): New function.
	(gfc_walk_elemental_function_args): Move code to
	gfc_get_proc_ifc_for_expr and call it.

From-SVN: r184139
This commit is contained in:
Mikael Morin 2012-02-12 15:12:21 +00:00
parent 12e3c39614
commit 58b29fa342
2 changed files with 40 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2012-02-12 Mikael Morin <mikael@gcc.gnu.org>
* trans-array.c (gfc_get_proc_ifc_for_expr): New function.
(gfc_walk_elemental_function_args): Move code to
gfc_get_proc_ifc_for_expr and call it.
2012-02-08 Tobias Burnus <burnus@net-b.de>
PR fortran/52151

52
gcc/fortran/trans-array.c
View File

@ -8426,6 +8426,36 @@ gfc_reverse_ss (gfc_ss * ss)
}
/* Given an expression refering to a procedure, return the symbol of its
interface. We can't get the procedure symbol directly as we have to handle
the case of (deferred) type-bound procedures. */
gfc_symbol *
gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
{
gfc_symbol *sym;
gfc_ref *ref;
if (procedure_ref == NULL)
return NULL;
/* Normal procedure case. */
sym = procedure_ref->symtree->n.sym;
/* Typebound procedure case. */
for (ref = procedure_ref->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer)
sym = ref->u.c.component->ts.interface;
else
sym = NULL;
}
return sym;
}
/* Walk the arguments of an elemental function.
PROC_EXPR is used to check whether an argument is permitted to be absent. If
it is NULL, we don't do the check and the argument is assumed to be present.
@ -8435,6 +8465,7 @@ gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gfc_expr *proc_expr, gfc_ss_type type)
{
gfc_symbol *proc_ifc;
gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
@ -8444,24 +8475,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
if (proc_expr)
{
gfc_ref *ref;
/* Normal procedure case. */
dummy_arg = proc_expr->symtree->n.sym->formal;
/* Typebound procedure case. */
for (ref = proc_expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& ref->u.c.component->ts.interface)
dummy_arg = ref->u.c.component->ts.interface->formal;
else
dummy_arg = NULL;
}
}
proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
if (proc_ifc)
dummy_arg = proc_ifc->formal;
else
dummy_arg = NULL;