Hello,
this fixes the fairly recent PR50981 patch
[http://gcc.gnu.org/ml/fortran/2011-12/msg00170.html] which didn't work
for subroutine calls, as they use code->resolved_sym instead of
code->expr1 to store the procedure symbol.
The first patch moves gfc_walk_elemental_function_args's code to get the
procedure interface into a new procedure.
The second patch moves the procedure call out of
gfc_walk_elemental_function_args.
The third patch changes the function called in gfc_trans_call so that
code->resolved_sym is used if code->expr1 fails to give the interface.
I choose to try code->expr1 first for fear that in typebound calls,
code->resolved_sym may point to the base object, which is obviously not
the procedure interface.
The testcase is Tobias' comment #13
[http://gcc.gnu.org/bugzilla/show_bug.cgi?id=50981#c13] stripped down to
the working part.
Regression tested on x86_64-unknown-freebsd9.0. OK for trunk?
Mikael
2012-02-07 Mikael Morin <mik...@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.
diff --git a/trans-array.c b/trans-array.c
index d3c81a8..2584e78 100644
--- a/trans-array.c
+++ b/trans-array.c
@@ -8427,6 +8427,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.
@@ -8436,6 +8466,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;
@@ -8445,24 +8476,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;
2012-02-07 Mikael Morin <mik...@gcc.gnu.org>
* trans-array.c (gfc_walk_elemental_function_args,
gfc_walk_function_expr): Move call to gfc_get_proc_ifc_for_expr out
of gfc_walk_elemental_function_args.
* trans-stmt.c (gfc_trans_call): Ditto.
* trans-array.h (gfc_get_proc_ifc_for_expr): New prototype.
(gfc_walk_elemental_function_args): Update prototype.
diff --git a/trans-array.c b/trans-array.c
index 2584e78..de6fa13 100644
--- a/trans-array.c
+++ b/trans-array.c
@@ -8464,9 +8464,8 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
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_ss_type type)
{
- gfc_symbol *proc_ifc;
gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
@@ -8476,7 +8475,6 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
- proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
if (proc_ifc)
dummy_arg = proc_ifc->formal;
else
@@ -8566,7 +8564,8 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
by reference. */
if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- expr, GFC_SS_REFERENCE);
+ gfc_get_proc_ifc_for_expr (expr),
+ GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
diff --git a/trans-array.h b/trans-array.h
index 6ca630e..9bafb94 100644
--- a/trans-array.h
+++ b/trans-array.h
@@ -66,6 +66,8 @@ void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate an initializer for a static pointer or allocatable array. */
void gfc_trans_static_array_pointer (gfc_symbol *);
+/* Get the procedure interface for a function call. */
+gfc_symbol *gfc_get_proc_ifc_for_expr (gfc_expr *);
/* Generate scalarization information for an expression. */
gfc_ss *gfc_walk_expr (gfc_expr *);
/* Workhorse for gfc_walk_expr. */
@@ -74,7 +76,7 @@ gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
/* Walk the arguments of an elemental function. */
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
- gfc_expr *, gfc_ss_type);
+ gfc_symbol *, gfc_ss_type);
/* Walk an intrinsic function. */
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
gfc_intrinsic_sym *);
diff --git a/trans-stmt.c b/trans-stmt.c
index 7a6f8b2..ddbf35e 100644
--- a/trans-stmt.c
+++ b/trans-stmt.c
@@ -372,7 +372,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
- code->expr1, GFC_SS_REFERENCE);
+ gfc_get_proc_ifc_for_expr (code->expr1),
+ GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)
2012-02-07 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/50981
* trans-stmt.c (gfc_get_proc_ifc_for_call): New function.
(gfc_trans_call): Use gfc_get_proc_ifc_for_call.
diff --git a/trans-stmt.c b/trans-stmt.c
index ddbf35e..9b116d3 100644
--- a/trans-stmt.c
+++ b/trans-stmt.c
@@ -348,6 +348,27 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
}
+/* Get the interface symbol for the procedure corresponding to the given call.
+ We can't get the procedure symbol directly as we have to handle the case
+ of (deferred) type-bound procedures. */
+
+static gfc_symbol *
+get_proc_ifc_for_call (gfc_code *c)
+{
+ gfc_symbol *sym;
+
+ gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
+
+ sym = gfc_get_proc_ifc_for_expr (c->expr1);
+
+ /* Fall back/last resort try. */
+ if (sym == NULL)
+ sym = c->resolved_sym;
+
+ return sym;
+}
+
+
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
@@ -372,7 +393,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
- gfc_get_proc_ifc_for_expr (code->expr1),
+ get_proc_ifc_for_call (code),
GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
2012-02-07 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/50981
* gfortran.dg/elemental_optional_args_5.f90: New test.
! { dg-do run }
!
! PR fortran/50981
! Test the handling of optional, polymorphic and non-polymorphic arguments
! to elemental procedures.
!
! Original testcase by Tobias Burnus <bur...@net-b.de>
implicit none
type t
integer :: a
end type t
type t2
integer, allocatable :: a
integer, allocatable :: a2(:)
integer, pointer :: p => null()
integer, pointer :: p2(:) => null()
end type t2
type(t), allocatable :: ta, taa(:)
type(t), pointer :: tp, tpa(:)
class(t), allocatable :: ca, caa(:)
class(t), pointer :: cp, cpa(:)
type(t2) :: x
integer :: s, v(2)
tp => null()
tpa => null()
cp => null()
cpa => null()
! =============== sub1 ==================
! SCALAR COMPONENTS: Non alloc/assoc
s = 3
v = [9, 33]
call sub1 (s, x%a, .false.)
call sub1 (v, x%a, .false.)
!print *, s, v
if (s /= 3) call abort()
if (any (v /= [9, 33])) call abort()
call sub1 (s, x%p, .false.)
call sub1 (v, x%p, .false.)
!print *, s, v
if (s /= 3) call abort()
if (any (v /= [9, 33])) call abort()
! SCALAR COMPONENTS: alloc/assoc
allocate (x%a, x%p)
x%a = 4
x%p = 5
call sub1 (s, x%a, .true.)
call sub1 (v, x%a, .true.)
!print *, s, v
if (s /= 4*2) call abort()
if (any (v /= [4*2, 4*2])) call abort()
call sub1 (s, x%p, .true.)
call sub1 (v, x%p, .true.)
!print *, s, v
if (s /= 5*2) call abort()
if (any (v /= [5*2, 5*2])) call abort()
contains
elemental subroutine sub1 (x, y, alloc)
integer, intent(inout) :: x
integer, intent(in), optional :: y
logical, intent(in) :: alloc
if (alloc .neqv. present (y)) &
x = -99
if (present(y)) &
x = y*2
end subroutine sub1
end
