[Patch, Fortran] PRs 48112/48279 - fix interface related regressions

[Patch, Fortran] PRs 48112/48279 - fix interface related regressions

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1224 bytes --]

This patch fixes three issues, (a) and (b) are 4.6/4.7 regressions.

a) PR48112: Due to incomplete resolution, there was an ICE when writing 
the module file. Solution: Back-out the patch which introduced the 
incomplete resolution - and add a similar patch later to avoid printing 
errors multiple times.

b) PR48279: The patch adding supporting functions calls as actual 
argument to intent-in dummies had problems with generics, which lead to 
an ICE. Solution: Use the expr's specific procedure (esym) instead.

c) PR48279 comment 8: gfortran was accepting internal procedures in 
INTERFACE; solution: Reject it with -std=f2008, but accept it with 
-std=gnu. Reasoning: Except of NAG all other tested compilers also 
accept it.

Build and currently regtesting on x86-64.
OK for the trunk - and for 4.6?

Tobias

PS: Besides those two, there are three other regressions:
1. PR 48462: -frealloc-lhs issue, partially fixed by Paul; follow-up 
patch pending - and then 4.6 backporting.
2. PR 45586: ICE (tree checking) with LTO, seems to be a restricted vs. 
not decl issue.
3. PR 42954: The target CPP issue ...
As (1) and (2) are 4.6/4.7 regressions, we should really concentrate on 
fixing them before the 4.6.1 release.

[-- Attachment #2: interface-reg.diff --]
[-- Type: text/x-patch, Size: 9763 bytes --]

2011-04-26  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-26  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.

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index dae2149..3d519db 100644
--- 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
--- 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 d7b95f5..59a863c 100644
--- 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)
     {
 

--- /dev/null	2011-04-21 07:44:25.943893902 +0200
+++ gcc/gcc/testsuite/gfortran.dg/interface_35.f90	2011-04-26 22:41:18.000000000 +0200
@@ -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/bessel_1.f90 b/gcc/testsuite/gfortran.dg/bessel_1.f90
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/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
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

Re: [Patch, Fortran] PRs 48112/48279 - fix interface related regressions

[Mikael Morin]

On Tuesday 26 April 2011 23:41:17 Tobias Burnus wrote:
> This patch fixes three issues, (a) and (b) are 4.6/4.7 regressions.
> 
> a) PR48112: Due to incomplete resolution, there was an ICE when writing
> the module file. Solution: Back-out the patch which introduced the
> incomplete resolution - and add a similar patch later to avoid printing
> errors multiple times.
Bah! A pity we need voodoo incantations such as this.

> 
> b) PR48279: The patch adding supporting functions calls as actual
> argument to intent-in dummies had problems with generics, which lead to
> an ICE. Solution: Use the expr's specific procedure (esym) instead.
> 
> c) PR48279 comment 8: gfortran was accepting internal procedures in
> INTERFACE; solution: Reject it with -std=f2008, but accept it with
> -std=gnu. Reasoning: Except of NAG all other tested compilers also
> accept it.
> 
> Build and currently regtesting on x86-64.
> OK for the trunk - and for 4.6?
Yes (The three of them).
Thanks

Mikael