summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Kraft <d@domob.eu>2008-09-23 16:26:47 +0200
committerDaniel Kraft <domob@gcc.gnu.org>2008-09-23 16:26:47 +0200
commitf0ac18b79931a074b5bc88e0b64ea8ef84e40941 (patch)
treec7feacbab392296b48eedf075c4af711194f8b63
parentf0580031a7919f8e1401db1c2e6515e1682eaaa7 (diff)
downloadgcc-f0ac18b79931a074b5bc88e0b64ea8ef84e40941.tar.gz
re PR fortran/37588 (GENERIC type-bound procedure is not resolved)
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 Daniel Kraft <d@domob.eu> PR fortran/37588 * gfortran.dg/typebound_generic_4.f03: New test. * gfortran.dg/typebound_generic_5.f03: New test. From-SVN: r140594
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/gfortran.h3
-rw-r--r--gcc/fortran/interface.c46
-rw-r--r--gcc/fortran/resolve.c6
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_generic_4.f0357
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_generic_5.f0355
7 files changed, 168 insertions, 20 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5d1ad31d01f..1210d393efc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fa3f865b74e..4e9959ea5bb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2517,8 +2517,7 @@ gfc_try gfc_add_interface (gfc_symbol *);
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;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9df24ffd33e..17f70331286 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1818,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
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;
@@ -2448,8 +2448,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
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);
@@ -2458,6 +2457,30 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
}
+/* 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
@@ -2467,8 +2490,6 @@ gfc_symbol *
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)
@@ -2476,15 +2497,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a7c62c30532..d682e10dd5a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4510,10 +4510,11 @@ resolve_typebound_generic_call (gfc_expr* e)
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);
@@ -4606,6 +4607,7 @@ resolve_compcall (gfc_expr* e)
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);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 715ffefb222..e3215bdf053 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03
new file mode 100644
index 00000000000..edd62be0ccf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03
@@ -0,0 +1,57 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_5.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_5.f03
new file mode 100644
index 00000000000..3fd94b154fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_generic_5.f03
@@ -0,0 +1,55 @@
+! { 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" } }
View Lorry Controller Status