diff options
Diffstat (limited to 'meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch')
| -rw-r--r-- | meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch | 305 |
1 files changed, 305 insertions, 0 deletions
diff --git a/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch b/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch new file mode 100644 index 000000000..0a14655a5 --- /dev/null +++ b/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch @@ -0,0 +1,305 @@ +From a588d1bdc7fb4aa8e1214b6a57d581ddcfa86159 Mon Sep 17 00:00:00 2001 +From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4> +Date: Thu, 28 Apr 2011 18:47:28 +0000 +Subject: [PATCH 194/200] 2011-04-28 Tobias Burnus <burnus@net-b.de> + + 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 <burnus@net-b.de> + + 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 + |