re PR fortran/48112 (generic interface to external function in module)

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.

From-SVN: r173059

gcc/fortran/ChangeLog

+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

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)

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;
 

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)
     {
 

gcc/testsuite/ChangeLog

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

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

gcc/testsuite/gfortran.dg/erfc_scaled_1.f90

 ! { 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

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]

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

gcc/testsuite/gfortran.dg/interface_35.f90

+! { 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" } }

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

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

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