From a588d1bdc7fb4aa8e1214b6a57d581ddcfa86159 Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 28 Apr 2011 18:47:28 +0000 Subject: [PATCH 194/200] 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173127 138bc75d-0d04-0410-961f-82ee72b054a4 index 58b6036..cfa1d57 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4367,15 +4367,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)) { @@ -4393,9 +4404,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 b0b74c1..b5f77c3 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 75e4697..f661140 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9858,6 +9858,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) { @@ -11946,11 +11951,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) { index 728c5ce..fb1e19b 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 8a114e6..eeb54c8 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 e64a2ef..e8347be 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 59022fa..0c1c6e2 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 0000000..20aa4af --- /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 535e884..d55af29 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 d477368..57660c7 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 c000896..a21916b 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 -- 1.7.0.4