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

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