+2008-09-23 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37588
+ * gfortran.h (gfc_compare_actual_formal): Removed, made private.
+ (gfc_arglist_matches_symbol): New method.
+ * interface.c (compare_actual_formal): Made static.
+ (gfc_procedure_use): Use new name of compare_actual_formal.
+ (gfc_arglist_matches_symbol): New method.
+ (gfc_search_interface): Moved code partially to new
+ gfc_arglist_matches_symbol.
+ * resolve.c (resolve_typebound_generic_call): Resolve actual arglist
+ before checking against formal and use new gfc_arglist_matches_symbol
+ for checking.
+ (resolve_compcall): Set type-spec of generated expression.
+
2008-09-23 Tobias Burnus <burnus@net-b.de>
PR fortran/37580
gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
-int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
- int, int, locus*);
+bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
/* io.c */
extern gfc_st_label format_asterisk;
errors when things don't match instead of just returning the status
code. */
-int
-gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
- int ranks_must_agree, int is_elemental, locus *where)
+static int
+compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+ int ranks_must_agree, int is_elemental, locus *where)
{
gfc_actual_arglist **new_arg, *a, *actual, temp;
gfc_formal_arglist *f;
return;
}
- if (!gfc_compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, where))
+ if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
return;
check_intents (sym->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. */
+
+bool
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+{
+ bool r;
+
+ gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+ r = !sym->attr.elemental;
+ if (compare_actual_formal (args, sym->formal, r, !r, NULL))
+ {
+ check_intents (sym->formal, *args);
+ if (gfc_option.warn_aliasing)
+ check_some_aliasing (sym->formal, *args);
+ return true;
+ }
+
+ return false;
+}
+
+
/* Given an interface pointer and an actual argument list, search for
a formal argument list that matches the actual. If found, returns
a pointer to the symbol of the correct interface. Returns NULL if
gfc_search_interface (gfc_interface *intr, int sub_flag,
gfc_actual_arglist **ap)
{
- int r;
-
for (; intr; intr = intr->next)
{
if (sub_flag && intr->sym->attr.function)
if (!sub_flag && intr->sym->attr.subroutine)
continue;
- r = !intr->sym->attr.elemental;
-
- if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
- {
- check_intents (intr->sym->formal, *ap);
- if (gfc_option.warn_aliasing)
- check_some_aliasing (intr->sym->formal, *ap);
- return intr->sym;
- }
+ if (gfc_arglist_matches_symbol (ap, intr->sym))
+ return intr->sym;
}
return NULL;
args = update_arglist_pass (args, po, g->specific->pass_arg_num);
}
+ resolve_actual_arglist (args, target->attr.proc,
+ is_external_proc (target) && !target->formal);
/* Check if this arglist matches the formal. */
- matches = gfc_compare_actual_formal (&args, target->formal, 1,
- target->attr.elemental, NULL);
+ matches = gfc_arglist_matches_symbol (&args, target);
/* Clean up and break out of the loop if we've found it. */
gfc_free_actual_arglist (args);
e->value.function.isym = NULL;
e->value.function.esym = NULL;
e->symtree = target;
+ e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
return gfc_resolve_expr (e);
+2008-09-23 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37588
+ * gfortran.dg/typebound_generic_4.f03: New test.
+ * gfortran.dg/typebound_generic_5.f03: New test.
+
2008-09-23 Eric Botcazou <ebotcazou@adacore.com>
* gcc.dg/pragma-init-fini.c: Use dg-warning in lieu of dg-error.
--- /dev/null
+! { dg-do run }
+
+! FIXME: Remove -w once the TYPE/CLASS issue is resolved
+! { dg-options "-w" }
+
+! PR fortran/37588
+! This test used to not resolve the GENERIC binding.
+
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+module bar_mod
+
+ type foo
+ integer :: i
+
+ contains
+ procedure, pass(a) :: foo_v => foo_v_inner
+ procedure, pass(a) :: foo_m => foo_m_inner
+ generic, public :: foo => foo_v, foo_m
+ end type foo
+
+ private foo_v_inner, foo_m_inner
+
+contains
+
+ subroutine foo_v_inner(x,a)
+ real :: x(:)
+ type(foo) :: a
+
+ a%i = int(x(1))
+ WRITE (*,*) "Vector"
+ end subroutine foo_v_inner
+
+ subroutine foo_m_inner(x,a)
+ real :: x(:,:)
+ type(foo) :: a
+
+ a%i = int(x(1,1))
+ WRITE (*,*) "Matrix"
+ end subroutine foo_m_inner
+end module bar_mod
+
+program foobar
+ use bar_mod
+ type(foo) :: dat
+ real :: x1(10), x2(10,10)
+
+ x1=1
+ x2=2
+
+ call dat%foo(x1)
+ call dat%foo(x2)
+
+end program foobar
+
+! { dg-output "Vector.*Matrix" }
+! { dg-final { cleanup-modules "bar_mod" } }
--- /dev/null
+! { dg-do run }
+
+! Check that generic bindings targetting ELEMENTAL procedures work.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE :: t
+ CONTAINS
+ PROCEDURE, NOPASS :: double
+ PROCEDURE, NOPASS :: double_here
+ GENERIC :: double_it => double
+ GENERIC :: double_inplace => double_here
+ END TYPE t
+
+CONTAINS
+
+ ELEMENTAL INTEGER FUNCTION double (val)
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: val
+ double = 2 * val
+ END FUNCTION double
+
+ ELEMENTAL SUBROUTINE double_here (val)
+ IMPLICIT NONE
+ INTEGER, INTENT(INOUT) :: val
+ val = 2 * val
+ END SUBROUTINE double_here
+
+END MODULE m
+
+PROGRAM main
+ USE m
+ IMPLICIT NONE
+
+ TYPE(t) :: obj
+ INTEGER :: arr(42), arr2(42), arr3(42), arr4(42)
+ INTEGER :: i
+
+ arr = (/ (i, i = 1, 42) /)
+
+ arr2 = obj%double (arr)
+ arr3 = obj%double_it (arr)
+
+ arr4 = arr
+ CALL obj%double_inplace (arr4)
+
+ IF (ANY (arr2 /= 2 * arr) .OR. &
+ ANY (arr3 /= 2 * arr) .OR. &
+ ANY (arr4 /= 2 * arr)) THEN
+ CALL abort ()
+ END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }