From 9b63f28250377b90a744fe57ff482df9c6ee70ed Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 21 Jun 2009 21:05:35 +0200 Subject: [PATCH] re PR fortran/39850 (Too strict checking for procedures as actual argument) 2009-06-21 Janus Weil PR fortran/39850 * interface.c (gfc_compare_interfaces): Take care of implicit typing when checking the function attribute. Plus another bugfix. (compare_parameter): Set attr.function and attr.subroutine according to the usage of a procedure as actual argument. 2009-06-21 Janus Weil PR fortran/39850 * gfortran.dg/interface_19.f90: Add 'cleanup-modules'. * gfortran.dg/interface_20.f90: Ditto. * gfortran.dg/interface_21.f90: Ditto. * gfortran.dg/interface_22.f90: Ditto. * gfortran.dg/interface_30.f90: New. * gfortran.dg/proc_ptr_11.f90: Fix invalid test case. From-SVN: r148767 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/interface.c | 16 +++++++--- gcc/testsuite/ChangeLog | 10 ++++++ gcc/testsuite/gfortran.dg/interface_19.f90 | 3 ++ gcc/testsuite/gfortran.dg/interface_20.f90 | 3 ++ gcc/testsuite/gfortran.dg/interface_21.f90 | 3 ++ gcc/testsuite/gfortran.dg/interface_22.f90 | 3 ++ gcc/testsuite/gfortran.dg/interface_30.f90 | 37 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 | 2 +- 9 files changed, 80 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_30.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0d88c4b9fa9..1c1a6c111e3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-06-21 Janus Weil + + PR fortran/39850 + * interface.c (gfc_compare_interfaces): Take care of implicit typing + when checking the function attribute. Plus another bugfix. + (compare_parameter): Set attr.function and attr.subroutine according + to the usage of a procedure as actual argument. + 2009-06-20 Tobias Burnus PR fortran/40452 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 4954389848b..7d26fe444f9 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -939,7 +939,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, { gfc_formal_arglist *f1, *f2; - if (s1->attr.function && !s2->attr.function) + if (s1->attr.function && (s2->attr.subroutine + || (!s2->attr.function && s2->ts.type == BT_UNKNOWN + && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN))) { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' is not a function", s2->name); @@ -967,8 +969,6 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, "of '%s'", s2->name); return 0; } - if (s1->attr.if_source == IFSRC_DECL) - return 1; } if (s1->attr.if_source == IFSRC_UNKNOWN @@ -1388,6 +1388,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (actual->ts.type == BT_PROCEDURE) { char err[200]; + gfc_symbol *act_sym = actual->symtree->n.sym; if (formal->attr.flavor != FL_PROCEDURE) { @@ -1396,7 +1397,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } - if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err, + if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err, sizeof(err))) { if (where) @@ -1405,6 +1406,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (formal->attr.function && !act_sym->attr.function) + gfc_add_function (&act_sym->attr, act_sym->name, &act_sym->declared_at); + + if (formal->attr.subroutine && !act_sym->attr.subroutine) + gfc_add_subroutine (&act_sym->attr, act_sym->name, + &act_sym->declared_at); + return 1; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 278e3f19110..3618373d514 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2009-06-21 Janus Weil + + PR fortran/39850 + * gfortran.dg/interface_19.f90: Add 'cleanup-modules'. + * gfortran.dg/interface_20.f90: Ditto. + * gfortran.dg/interface_21.f90: Ditto. + * gfortran.dg/interface_22.f90: Ditto. + * gfortran.dg/interface_30.f90: New. + * gfortran.dg/proc_ptr_11.f90: Fix invalid test case. + 2009-06-21 Uros Bizjak * gcc.dg/tree-ssa/fre-vce-1.c: Cleanup "fre" tree dump. diff --git a/gcc/testsuite/gfortran.dg/interface_19.f90 b/gcc/testsuite/gfortran.dg/interface_19.f90 index 2d72caa058d..7a88fc91b3e 100644 --- a/gcc/testsuite/gfortran.dg/interface_19.f90 +++ b/gcc/testsuite/gfortran.dg/interface_19.f90 @@ -27,3 +27,6 @@ intrinsic dcos call sub() call sub(dcos) end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/interface_20.f90 b/gcc/testsuite/gfortran.dg/interface_20.f90 index 829add2ff9b..9a7dc5cb131 100644 --- a/gcc/testsuite/gfortran.dg/interface_20.f90 +++ b/gcc/testsuite/gfortran.dg/interface_20.f90 @@ -18,3 +18,6 @@ implicit none intrinsic cos call sub(cos) ! { dg-error "wrong number of arguments" } end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/interface_21.f90 b/gcc/testsuite/gfortran.dg/interface_21.f90 index e3db771a93d..566a9ef3707 100644 --- a/gcc/testsuite/gfortran.dg/interface_21.f90 +++ b/gcc/testsuite/gfortran.dg/interface_21.f90 @@ -20,3 +20,6 @@ implicit none EXTERNAL foo ! implicit interface is undefined call sub(foo) ! { dg-error "is not a function" } end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/interface_22.f90 b/gcc/testsuite/gfortran.dg/interface_22.f90 index 6228fc9f133..fa8e517a186 100644 --- a/gcc/testsuite/gfortran.dg/interface_22.f90 +++ b/gcc/testsuite/gfortran.dg/interface_22.f90 @@ -23,3 +23,6 @@ module gswap module procedure sreal, schar, sint => sreal ! { dg-error "Syntax error in MODULE PROCEDURE statement" } end interface swap end module gswap + +! { dg-final { cleanup-modules "foo g gswap" } } + diff --git a/gcc/testsuite/gfortran.dg/interface_30.f90 b/gcc/testsuite/gfortran.dg/interface_30.f90 new file mode 100644 index 00000000000..0576a42510e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_30.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR39850: Too strict checking for procedures as actual argument +! +! Original test case by Tobias Burnus +! Modified by Janus Weil + +real function func() + print *,"func" + func = 42.0 +end function func + +program test + external func1,func2,func3,func4 ! subroutine or implicitly typed real function + call sub1(func1) + call sub2(func2) + call sub1(func3) + call sub2(func3) ! { dg-error "Type mismatch in argument" } + call sub2(func4) + call sub1(func4) ! { dg-error "Interface mismatch in dummy procedure" } +contains + subroutine sub1(a1) + interface + real function a1() + end function + end interface + print *, a1() + end subroutine sub1 + subroutine sub2(a2) + interface + subroutine a2 + end subroutine + end interface + call a2() + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 index 469ebd448b1..4e8b3c25314 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 @@ -55,7 +55,7 @@ program bsp end function add integer function f(x) - integer :: x + integer,intent(in) :: x f = 317 + x end function