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
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@173059 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 46df318..7f797b4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+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-27  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/48788

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index dae2149..3d519db 100644 (file)
--- 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 5e7a1dc..1f75724 100644 (file)
--- 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 144d308..7fed7a5 100644 (file)
--- 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 9604518..cbad463 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,16 @@
+2011-04-28  Tobias Burnus  <burnus@net-b.de>
+
+       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  <jason@redhat.com>
 
        * 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 728c5ce..fb1e19b 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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