From a300121e62712fdafb2b508f8a392cffccf075c8 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Thu, 28 Apr 2011 07:48:18 +0200 Subject: [PATCH] re PR fortran/48112 (generic interface to external function in module) 2011-04-28 Tobias Burnus PR fortran/48112 * resolve.c (resolve_fl_var_and_proc): Print diagnostic of function results only once. (resolve_symbol): Always resolve function results. PR fortran/48279 * expr.c (gfc_check_vardef_context): Fix handling of generic EXPR_FUNCTION. * interface.c (check_interface0): Reject internal functions in generic interfaces, unless -std=gnu. 2011-04-28 Tobias Burnus PR fortran/48112 PR fortran/48279 * gfortran.dg/interface_35.f90: New. * gfortran.dg/erfc_scaled_1.f90: Don't compile with -pedantic. * gfortran.dg/func_result_6.f90: Add dg-warning. * gfortran.dg/bessel_1.f90: Ditto. * gfortran.dg/hypot_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_20.f90: Ditto. * gfortran.dg/proc_ptr_comp_21.f90: Ditto. * gfortran.dg/interface_assignment_4.f90: Ditto. From-SVN: r173059 --- gcc/fortran/ChangeLog | 13 +++ gcc/fortran/expr.c | 18 +++-- gcc/fortran/interface.c | 6 ++ gcc/fortran/resolve.c | 10 +-- gcc/testsuite/ChangeLog | 13 +++ gcc/testsuite/gfortran.dg/bessel_1.f90 | 4 +- gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 | 4 + gcc/testsuite/gfortran.dg/func_result_6.f90 | 2 +- gcc/testsuite/gfortran.dg/hypot_1.f90 | 4 +- gcc/testsuite/gfortran.dg/interface_35.f90 | 79 +++++++++++++++++++ .../gfortran.dg/interface_assignment_4.f90 | 2 +- .../gfortran.dg/proc_ptr_comp_20.f90 | 4 +- .../gfortran.dg/proc_ptr_comp_21.f90 | 2 +- 13 files changed, 142 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_35.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 46df31889d7..7f797b4acf9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2011-04-28 Tobias Burnus + + PR fortran/48112 + * resolve.c (resolve_fl_var_and_proc): Print diagnostic of + function results only once. + (resolve_symbol): Always resolve function results. + + PR fortran/48279 + * expr.c (gfc_check_vardef_context): Fix handling of generic + EXPR_FUNCTION. + * interface.c (check_interface0): Reject internal functions + in generic interfaces, unless -std=gnu. + 2011-04-27 Tobias Burnus PR fortran/48788 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index dae2149b1de..3d519db4df2 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4371,15 +4371,26 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) gfc_try gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context) { - gfc_symbol* sym; + gfc_symbol* sym = NULL; bool is_pointer; bool check_intentin; bool ptr_component; symbol_attribute attr; gfc_ref* ref; + if (e->expr_type == EXPR_VARIABLE) + { + gcc_assert (e->symtree); + sym = e->symtree->n.sym; + } + else if (e->expr_type == EXPR_FUNCTION) + { + gcc_assert (e->symtree); + sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; + } + if (!pointer && e->expr_type == EXPR_FUNCTION - && e->symtree->n.sym->result->attr.pointer) + && sym->result->attr.pointer) { if (!(gfc_option.allow_std & GFC_STD_F2008)) { @@ -4397,9 +4408,6 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context) return FAILURE; } - gcc_assert (e->symtree); - sym = e->symtree->n.sym; - if (!pointer && sym->attr.flavor == FL_PARAMETER) { if (context) diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5e7a1dce196..1f757247a99 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1128,6 +1128,12 @@ check_interface0 (gfc_interface *p, const char *interface_name) " or all FUNCTIONs", interface_name, &p->sym->declared_at); return 1; } + + if (p->sym->attr.proc == PROC_INTERNAL + && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' " + "in %s at %L", p->sym->name, interface_name, + &p->sym->declared_at) == FAILURE) + return 1; } p = psave; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 144d3086650..7fed7a53961 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9886,6 +9886,11 @@ apply_default_init_local (gfc_symbol *sym) static gfc_try resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { + /* Avoid double diagnostics for function result symbols. */ + if ((sym->result || sym->attr.result) && !sym->attr.dummy + && (sym->ns != gfc_current_ns)) + return SUCCESS; + /* Constraints on deferred shape variable. */ if (sym->as == NULL || sym->as->type != AS_DEFERRED) { @@ -11974,11 +11979,6 @@ resolve_symbol (gfc_symbol *sym) gfc_namespace *ns; gfc_component *c; - /* Avoid double resolution of function result symbols. */ - if ((sym->result || sym->attr.result) && !sym->attr.dummy - && (sym->ns != gfc_current_ns)) - return; - if (sym->attr.flavor == FL_UNKNOWN) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9604518f190..cbad463803d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2011-04-28 Tobias Burnus + + PR fortran/48112 + PR fortran/48279 + * gfortran.dg/interface_35.f90: New. + * gfortran.dg/erfc_scaled_1.f90: Don't compile with -pedantic. + * gfortran.dg/func_result_6.f90: Add dg-warning. + * gfortran.dg/bessel_1.f90: Ditto. + * gfortran.dg/hypot_1.f90: Ditto. + * gfortran.dg/proc_ptr_comp_20.f90: Ditto. + * gfortran.dg/proc_ptr_comp_21.f90: Ditto. + * gfortran.dg/interface_assignment_4.f90: Ditto. + 2011-04-27 Jason Merrill * g++.dg/ext/complex8.C: New. diff --git a/gcc/testsuite/gfortran.dg/bessel_1.f90 b/gcc/testsuite/gfortran.dg/bessel_1.f90 index 728c5ce49ca..fb1e19beef5 100644 --- a/gcc/testsuite/gfortran.dg/bessel_1.f90 +++ b/gcc/testsuite/gfortran.dg/bessel_1.f90 @@ -26,11 +26,11 @@ program test call check(bessel_yn (3,x4), bessel_yn (3,1.9_4)) contains - subroutine check_r4 (a, b) + subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" } real(kind=4), intent(in) :: a, b if (abs(a - b) > 1.e-5 * abs(b)) call abort end subroutine - subroutine check_r8 (a, b) + subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" } real(kind=8), intent(in) :: a, b if (abs(a - b) > 1.e-7 * abs(b)) call abort end subroutine diff --git a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 index 8a114e60ef9..eeb54c829dc 100644 --- a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 +++ b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 @@ -1,4 +1,8 @@ ! { dg-do run } +! +! { dg-options "" } +! Do not run with -pedantic checks enabled as "check" +! contains internal procedures which is a vendor extension program test implicit none diff --git a/gcc/testsuite/gfortran.dg/func_result_6.f90 b/gcc/testsuite/gfortran.dg/func_result_6.f90 index e64a2ef7abc..e8347be587d 100644 --- a/gcc/testsuite/gfortran.dg/func_result_6.f90 +++ b/gcc/testsuite/gfortran.dg/func_result_6.f90 @@ -63,7 +63,7 @@ if (ptr /= 2) call abort() bar = gen() if (ptr /= 77) call abort() contains - function foo() + function foo() ! { dg-warning "Extension: Internal procedure .foo. in generic interface" } integer, allocatable :: foo(:) allocate(foo(2)) foo = [33, 77] diff --git a/gcc/testsuite/gfortran.dg/hypot_1.f90 b/gcc/testsuite/gfortran.dg/hypot_1.f90 index 59022fab93c..0c1c6e2ae17 100644 --- a/gcc/testsuite/gfortran.dg/hypot_1.f90 +++ b/gcc/testsuite/gfortran.dg/hypot_1.f90 @@ -18,11 +18,11 @@ program test call check(hypot(x4,y4), hypot(1.9_4,-2.1_4)) contains - subroutine check_r4 (a, b) + subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" } real(kind=4), intent(in) :: a, b if (abs(a - b) > 1.e-5 * abs(b)) call abort end subroutine - subroutine check_r8 (a, b) + subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" } real(kind=8), intent(in) :: a, b if (abs(a - b) > 1.e-7 * abs(b)) call abort end subroutine diff --git a/gcc/testsuite/gfortran.dg/interface_35.f90 b/gcc/testsuite/gfortran.dg/interface_35.f90 new file mode 100644 index 00000000000..20aa4af786d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_35.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48112 (module_m) +! PR fortran/48279 (sidl_string_array, s_Hard) +! +! Contributed by mhp77@gmx.at (module_m) +! and Adrian Prantl (sidl_string_array, s_Hard) +! + +module module_m + interface test + function test1( ) result( test ) + integer :: test + end function test1 + end interface test +end module module_m + +! ----- + +module sidl_string_array + type sidl_string_1d + end type sidl_string_1d + interface set + module procedure & + setg1_p + end interface +contains + subroutine setg1_p(array, index, val) + type(sidl_string_1d), intent(inout) :: array + end subroutine setg1_p +end module sidl_string_array + +module s_Hard + use sidl_string_array + type :: s_Hard_t + integer(8) :: dummy + end type s_Hard_t + interface set_d_interface + end interface + interface get_d_string + module procedure get_d_string_p + end interface + contains ! Derived type member access functions + type(sidl_string_1d) function get_d_string_p(s) + type(s_Hard_t), intent(in) :: s + end function get_d_string_p + subroutine set_d_objectArray_p(s, d_objectArray) + end subroutine set_d_objectArray_p +end module s_Hard + +subroutine initHard(h, ex) + use s_Hard + type(s_Hard_t), intent(inout) :: h + call set(get_d_string(h), 0, 'Three') ! { dg-error "There is no specific subroutine for the generic" } +end subroutine initHard + +! ----- + + interface get + procedure get1 + end interface + + integer :: h + call set1 (get (h)) + +contains + + subroutine set1 (a) + integer, intent(in) :: a + end subroutine + + integer function get1 (s) ! { dg-error "Extension: Internal procedure .get1. in generic interface .get." } + integer :: s + end function + +end + +! { dg-final { cleanup-modules "module_m module_m2 s_hard sidl_string_array" } } diff --git a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 index 535e8842549..d55af2905d5 100644 --- a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 +++ b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 @@ -16,7 +16,7 @@ contains - subroutine op_assign_VS_CH (var, exp) + subroutine op_assign_VS_CH (var, exp) ! { dg-warning "Extension: Internal procedure" } type(varying_string), intent(out) :: var character(LEN=*), intent(in) :: exp end subroutine diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 index d4773686090..57660c7b70e 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 @@ -35,12 +35,12 @@ o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" } contains - real function f1(a,b) + real function f1(a,b) ! { dg-warning "Extension: Internal procedure" } real,intent(in) :: a,b f1 = a + b end function - integer function f2(a,b) + integer function f2(a,b) ! { dg-warning "Extension: Internal procedure" } real,intent(in) :: a,b f2 = a - b end function diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 index c000896d549..a21916bc844 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 @@ -19,7 +19,7 @@ contains - elemental subroutine op_assign (str, ch) + elemental subroutine op_assign (str, ch) ! { dg-warning "Extension: Internal procedure" } type(nf_t), intent(out) :: str character(len=*), intent(in) :: ch end subroutine -- 2.30.2