code.ossystems Code Review - openembedded-core.git/blob

   1 Upstream-Status: Inappropriate [Backport]
   2 From a588d1bdc7fb4aa8e1214b6a57d581ddcfa86159 Mon Sep 17 00:00:00 2001
   3 From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
   4 Date: Thu, 28 Apr 2011 18:47:28 +0000
   5 Subject: [PATCH 194/200] 2011-04-28  Tobias Burnus  <burnus@net-b.de>
   6
   7         PR fortran/48112
   8         * resolve.c (resolve_fl_var_and_proc): Print diagnostic of
   9         function results only once.
  10         (resolve_symbol): Always resolve function results.
  11
  12         PR fortran/48279
  13         * expr.c (gfc_check_vardef_context): Fix handling of generic
  14         EXPR_FUNCTION.
  15         * interface.c (check_interface0): Reject internal functions
  16         in generic interfaces, unless -std=gnu.
  17
  18 2011-04-28  Tobias Burnus  <burnus@net-b.de>
  19
  20         PR fortran/48112
  21
  22
  23
  24 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173127 138bc75d-0d04-0410-961f-82ee72b054a4
  25
  26 index 58b6036..cfa1d57 100644
  27 --- a/gcc/fortran/expr.c
  28 +++ b/gcc/fortran/expr.c
  29 @@ -4367,15 +4367,26 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
  30  gfc_try
  31  gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
  32  {
  33 -  gfc_symbol* sym;
  34 +  gfc_symbol* sym = NULL;
  35    bool is_pointer;
  36    bool check_intentin;
  37    bool ptr_component;
  38    symbol_attribute attr;
  39    gfc_ref* ref;
  40
  41 +  if (e->expr_type == EXPR_VARIABLE)
  42 +    {
  43 +      gcc_assert (e->symtree);
  44 +      sym = e->symtree->n.sym;
  45 +    }
  46 +  else if (e->expr_type == EXPR_FUNCTION)
  47 +    {
  48 +      gcc_assert (e->symtree);
  49 +      sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
  50 +    }
  51 +
  52    if (!pointer && e->expr_type == EXPR_FUNCTION
  53 -      && e->symtree->n.sym->result->attr.pointer)
  54 +      && sym->result->attr.pointer)
  55      {
  56        if (!(gfc_option.allow_std & GFC_STD_F2008))
  57         {
  58 @@ -4393,9 +4404,6 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
  59        return FAILURE;
  60      }
  61
  62 -  gcc_assert (e->symtree);
  63 -  sym = e->symtree->n.sym;
  64 -
  65    if (!pointer && sym->attr.flavor == FL_PARAMETER)
  66      {
  67        if (context)
  68 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
  69 index b0b74c1..b5f77c3 100644
  70 --- a/gcc/fortran/interface.c
  71 +++ b/gcc/fortran/interface.c
  72 @@ -1128,6 +1128,12 @@ check_interface0 (gfc_interface *p, const char *interface_name)
  73                      " or all FUNCTIONs", interface_name, &p->sym->declared_at);
  74           return 1;
  75         }
  76 +
  77 +      if (p->sym->attr.proc == PROC_INTERNAL
  78 +         && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' "
  79 +                            "in %s at %L", p->sym->name, interface_name,
  80 +                            &p->sym->declared_at) == FAILURE)
  81 +       return 1;
  82      }
  83    p = psave;
  84
  85 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
  86 index 75e4697..f661140 100644
  87 --- a/gcc/fortran/resolve.c
  88 +++ b/gcc/fortran/resolve.c
  89 @@ -9858,6 +9858,11 @@ apply_default_init_local (gfc_symbol *sym)
  90  static gfc_try
  91  resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
  92  {
  93 +  /* Avoid double diagnostics for function result symbols.  */
  94 +  if ((sym->result || sym->attr.result) && !sym->attr.dummy
  95 +      && (sym->ns != gfc_current_ns))
  96 +    return SUCCESS;
  97 +
  98    /* Constraints on deferred shape variable.  */
  99    if (sym->as == NULL || sym->as->type != AS_DEFERRED)
 100      {
 101 @@ -11946,11 +11951,6 @@ resolve_symbol (gfc_symbol *sym)
 102    gfc_namespace *ns;
 103    gfc_component *c;
 104
 105 -  /* Avoid double resolution of function result symbols.  */
 106 -  if ((sym->result || sym->attr.result) && !sym->attr.dummy
 107 -      && (sym->ns != gfc_current_ns))
 108 -    return;
 109 -
 110    if (sym->attr.flavor == FL_UNKNOWN)
 111      {
 112
 113 index 728c5ce..fb1e19b 100644
 114 --- a/gcc/testsuite/gfortran.dg/bessel_1.f90
 115 +++ b/gcc/testsuite/gfortran.dg/bessel_1.f90
 116 @@ -26,11 +26,11 @@ program test
 117    call check(bessel_yn (3,x4), bessel_yn (3,1.9_4))
 118
 119  contains
 120 -  subroutine check_r4 (a, b)
 121 +  subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
 122      real(kind=4), intent(in) :: a, b
 123      if (abs(a - b) > 1.e-5 * abs(b)) call abort
 124    end subroutine
 125 -  subroutine check_r8 (a, b)
 126 +  subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
 127      real(kind=8), intent(in) :: a, b
 128      if (abs(a - b) > 1.e-7 * abs(b)) call abort
 129    end subroutine
 130 diff --git a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
 131 index 8a114e6..eeb54c8 100644
 132 --- a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
 133 +++ b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
 134 @@ -1,4 +1,8 @@
 135  ! { dg-do run }
 136 +!
 137 +! { dg-options "" }
 138 +! Do not run with -pedantic checks enabled as "check"
 139 +! contains internal procedures which is a vendor extension
 140
 141  program test
 142    implicit none
 143 diff --git a/gcc/testsuite/gfortran.dg/func_result_6.f90 b/gcc/testsuite/gfortran.dg/func_result_6.f90
 144 index e64a2ef..e8347be 100644
 145 --- a/gcc/testsuite/gfortran.dg/func_result_6.f90
 146 +++ b/gcc/testsuite/gfortran.dg/func_result_6.f90
 147 @@ -63,7 +63,7 @@ if (ptr /= 2) call abort()
 148  bar = gen()
 149  if (ptr /= 77) call abort()
 150  contains
 151 -  function foo()
 152 +  function foo() ! { dg-warning "Extension: Internal procedure .foo. in generic interface" }
 153      integer, allocatable :: foo(:)
 154      allocate(foo(2))
 155      foo = [33, 77]
 156 diff --git a/gcc/testsuite/gfortran.dg/hypot_1.f90 b/gcc/testsuite/gfortran.dg/hypot_1.f90
 157 index 59022fa..0c1c6e2 100644
 158 --- a/gcc/testsuite/gfortran.dg/hypot_1.f90
 159 +++ b/gcc/testsuite/gfortran.dg/hypot_1.f90
 160 @@ -18,11 +18,11 @@ program test
 161    call check(hypot(x4,y4), hypot(1.9_4,-2.1_4))
 162
 163  contains
 164 -  subroutine check_r4 (a, b)
 165 +  subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
 166      real(kind=4), intent(in) :: a, b
 167      if (abs(a - b) > 1.e-5 * abs(b)) call abort
 168    end subroutine
 169 -  subroutine check_r8 (a, b)
 170 +  subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
 171      real(kind=8), intent(in) :: a, b
 172      if (abs(a - b) > 1.e-7 * abs(b)) call abort
 173    end subroutine
 174 diff --git a/gcc/testsuite/gfortran.dg/interface_35.f90 b/gcc/testsuite/gfortran.dg/interface_35.f90
 175 new file mode 100644
 176 index 0000000..20aa4af
 177 --- /dev/null
 178 +++ b/gcc/testsuite/gfortran.dg/interface_35.f90
 179 @@ -0,0 +1,79 @@
 180 +! { dg-do compile }
 181 +! { dg-options "-std=f2008" }
 182 +!
 183 +! PR fortran/48112 (module_m)
 184 +! PR fortran/48279 (sidl_string_array, s_Hard)
 185 +!
 186 +! Contributed by mhp77@gmx.at (module_m)
 187 +! and Adrian Prantl (sidl_string_array, s_Hard)
 188 +!
 189 +
 190 +module module_m
 191 +  interface test
 192 +     function test1( )  result( test )
 193 +       integer ::  test
 194 +     end function test1
 195 +  end interface test
 196 +end module module_m
 197 +
 198 +! -----
 199 +
 200 +module sidl_string_array
 201 +  type sidl_string_1d
 202 +  end type sidl_string_1d
 203 +  interface set
 204 +    module procedure &
 205 +      setg1_p
 206 +  end interface
 207 +contains
 208 +  subroutine setg1_p(array, index, val)
 209 +    type(sidl_string_1d), intent(inout) :: array
 210 +  end subroutine setg1_p
 211 +end module sidl_string_array
 212 +
 213 +module s_Hard
 214 +  use sidl_string_array
 215 +  type :: s_Hard_t
 216 +     integer(8) :: dummy
 217 +  end type s_Hard_t
 218 +  interface set_d_interface
 219 +  end interface
 220 +  interface get_d_string
 221 +    module procedure get_d_string_p
 222 +  end interface
 223 +  contains ! Derived type member access functions
 224 +    type(sidl_string_1d) function get_d_string_p(s)
 225 +      type(s_Hard_t), intent(in) :: s
 226 +    end function get_d_string_p
 227 +    subroutine set_d_objectArray_p(s, d_objectArray)
 228 +    end subroutine set_d_objectArray_p
 229 +end module s_Hard
 230 +
 231 +subroutine initHard(h, ex)
 232 +  use s_Hard
 233 +  type(s_Hard_t), intent(inout) :: h
 234 +  call set(get_d_string(h), 0, 'Three') ! { dg-error "There is no specific subroutine for the generic" }
 235 +end subroutine initHard
 236 +
 237 +! -----
 238 +
 239 +  interface get
 240 +    procedure get1
 241 +  end interface
 242 +
 243 +  integer :: h
 244 +  call set1 (get (h))
 245 +
 246 +contains
 247 +
 248 +  subroutine set1 (a)
 249 +    integer, intent(in) :: a
 250 +  end subroutine
 251 +
 252 +  integer function get1 (s) ! { dg-error "Extension: Internal procedure .get1. in generic interface .get." }
 253 +    integer :: s
 254 +  end function
 255 +
 256 +end
 257 +
 258 +! { dg-final { cleanup-modules "module_m module_m2 s_hard sidl_string_array" } }
 259 diff --git a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
 260 index 535e884..d55af29 100644
 261 --- a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
 262 +++ b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
 263 @@ -16,7 +16,7 @@
 264
 265  contains
 266
 267 -  subroutine op_assign_VS_CH (var, exp)
 268 +  subroutine op_assign_VS_CH (var, exp) ! { dg-warning "Extension: Internal procedure" }
 269      type(varying_string), intent(out) :: var
 270      character(LEN=*), intent(in)      :: exp
 271    end subroutine
 272 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
 273 index d477368..57660c7 100644
 274 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
 275 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
 276 @@ -35,12 +35,12 @@ o1%ppc => o2%ppc  ! { dg-error "Type/kind mismatch" }
 277
 278  contains
 279
 280 -  real function f1(a,b)
 281 +  real function f1(a,b) ! { dg-warning "Extension: Internal procedure" }
 282      real,intent(in) :: a,b
 283      f1 = a + b
 284    end function
 285
 286 -  integer function f2(a,b)
 287 +  integer function f2(a,b) ! { dg-warning "Extension: Internal procedure" }
 288      real,intent(in) :: a,b
 289      f2 = a - b
 290    end function
 291 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
 292 index c000896..a21916b 100644
 293 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
 294 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
 295 @@ -19,7 +19,7 @@
 296
 297  contains
 298
 299 -  elemental subroutine op_assign (str, ch)
 300 +  elemental subroutine op_assign (str, ch) ! { dg-warning "Extension: Internal procedure" }
 301      type(nf_t), intent(out) :: str
 302      character(len=*), intent(in) :: ch
 303    end subroutine
 304 --
 305 1.7.0.4
 306