Re: [Patch, Fortran] specific or generic INTERFACE implies the EXTERNAL attribute (PR36325)

["Janus Weil" <janus at gcc dot gnu dot org>]

Ok, just totally forgot to attach the patch. Here it goes.

2008/5/28 Janus Weil <janus@gcc.gnu.org>:
> Hi all,
>
> here is the fix for PR36325, regtested on i686-pc-linux-gnu with no
> failures. Since I have svn write permission now, I can commit it
> myself. I just need someone to approve it.
>
> Cheers,
> Janus
>
>
> 2008-05-28  Janus Weil  <janus@gcc.gnu.org>
>
>        PR fortran/36325
>        * interface.c (gfc_procedure_use): Enable argument checking for
>        external procedures with explicit interface.
>        * symbol.c (check_conflict): Fix conflict checking for externals.
>        (copy_formal_args): Fix handling of arrays.
>        * resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling
>        of intrinsics.
>        * parse.c (parse_interface): Non-abstract INTERFACE statement implies
>        EXTERNAL attribute.
>
>
> 2008-05-28  Janus Weil  <janus@gcc.gnu.org>
>
>        PR fortran/36325
>        * gfortran.dg/interface_23.f90: New.
>        * gfortran.dg/gomp/reduction3.f90: Fixed invalid code.
>        * gfortran.dg/proc_decl_12.f90: New:
>        * gfortran.dg/external_procedures_1.f90: Fixed error message.
>

Index: gcc/testsuite/gfortran.dg/interface_23.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_23.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/interface_23.f90	(revision 0)
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! This tests the fix for PR36325, which corrected for the fact that a
+! specific or generic INTERFACE statement implies the EXTERNAL attibute.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module a
+  interface
+    subroutine foo
+    end subroutine
+  end interface
+  external foo  ! { dg-error "Duplicate EXTERNAL attribute" }
+end module
+
+module b
+  interface
+    function sin (x)
+      real :: sin, x
+    end function
+  end interface
+  intrinsic sin  ! { dg-error "EXTERNAL attribute conflicts with INTRINSIC attribute" }
+end module
+
+! argument checking was not done for external procedures with explicit interface
+program c
+  interface
+    subroutine bar(x)
+      real :: x
+    end subroutine
+  end interface
+  call bar()  ! { dg-error "Missing actual argument" }
+end program
+
+! { dg-final { cleanup-modules "a b" } }
Index: gcc/testsuite/gfortran.dg/gomp/reduction3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/gomp/reduction3.f90	(revision 136103)
+++ gcc/testsuite/gfortran.dg/gomp/reduction3.f90	(working copy)
@@ -33,11 +33,6 @@ subroutine f2
 end subroutine f2
 subroutine f3
   integer :: i
-  interface
-    function ior (a, b)
-      integer :: ior, a, b
-    end function
-  end interface
   intrinsic ior
   i = 6
 !$omp parallel reduction (ior:i)
Index: gcc/testsuite/gfortran.dg/proc_decl_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_12.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_12.f90	(revision 0)
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! This tests the fix for PR36325, which (among others) fixed the handling of
+! array arguments with the PROCEDURE statement.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+contains
+  subroutine one(a)
+      integer a(1:3)
+      if (any(a /= [1,2,3])) call abort()
+  end subroutine one
+end module m
+
+program test
+  use m
+  implicit none
+  call foo(one)
+contains
+  subroutine foo(f)
+    procedure(one) :: f
+    call f([1,2,3])
+  end subroutine foo
+end program test
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/external_procedures_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/external_procedures_1.f90	(revision 136103)
+++ gcc/testsuite/gfortran.dg/external_procedures_1.f90	(working copy)
@@ -24,7 +24,7 @@ program main
   interface
     function ext1 (y)
       real ext1, y
-      external ext1  ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
+      external ext1  ! { dg-error "Duplicate EXTERNAL attribute" }
     end function ext1
   end interface
   inval = 1.0
@@ -38,4 +38,4 @@ contains
     inv = y * y * y
   end function inv
 end program main
-
+
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 136103)
+++ gcc/fortran/interface.c	(working copy)
@@ -2421,8 +2421,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
 	}
     }
 
-  if (sym->attr.external
-      || sym->attr.if_source == IFSRC_UNKNOWN)
+  if (sym->attr.if_source == IFSRC_UNKNOWN)
     {
       gfc_actual_arglist *a;
       for (a = *ap; a; a = a->next)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 136103)
+++ gcc/fortran/symbol.c	(working copy)
@@ -434,12 +434,14 @@ check_conflict (symbol_attribute *attr, 
 
   conf (target, external);
   conf (target, intrinsic);
-  conf (external, dimension);   /* See Fortran 95's R504.  */
+
+  if (!attr->if_source)
+    conf (external, dimension);   /* See Fortran 95's R504.  */
 
   conf (external, intrinsic);
   conf (entry, intrinsic);
 
-  if ((attr->if_source && !attr->procedure) || attr->contained)
+  if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
     {
       conf (external, subroutine);
       conf (external, function);
@@ -3664,6 +3666,7 @@ copy_formal_args (gfc_symbol *dest, gfc_
       /* May need to copy more info for the symbol.  */
       formal_arg->sym->attr = curr_arg->sym->attr;
       formal_arg->sym->ts = curr_arg->sym->ts;
+      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
 
       /* If this isn't the first arg, set up the next ptr.  For the
         last arg built, the formal_arg->next will never get set to
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 136103)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1571,7 +1571,8 @@ resolve_specific_f0 (gfc_symbol *sym, gf
       /* Existance of isym should be checked already.  */
       gcc_assert (isym);
 
-      sym->ts = isym->ts;
+      sym->ts.type = isym->ts.type;
+      sym->ts.kind = isym->ts.kind;
       sym->attr.function = 1;
       sym->attr.proc = PROC_EXTERNAL;
       goto found;
@@ -2646,8 +2647,9 @@ resolve_specific_s0 (gfc_code *c, gfc_sy
       /* Existance of isym should be checked already.  */
       gcc_assert (isym);
 
-      sym->ts = isym->ts;
-      sym->attr.function = 1;
+      sym->ts.type = isym->ts.type;
+      sym->ts.kind = isym->ts.kind;
+      sym->attr.subroutine = 1;
       goto found;
     }
 
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 136103)
+++ gcc/fortran/parse.c	(working copy)
@@ -1917,12 +1917,28 @@ loop:
       new_state = COMP_SUBROUTINE;
       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
 				  gfc_new_block->formal, NULL);
+      if (current_interface.type != INTERFACE_ABSTRACT &&
+	 !gfc_new_block->attr.dummy &&
+	 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
+	{
+	  reject_statement ();
+	  gfc_free_namespace (gfc_current_ns);
+	  goto loop;
+	}
       break;
 
     case ST_FUNCTION:
       new_state = COMP_FUNCTION;
       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
 				  gfc_new_block->formal, NULL);
+      if (current_interface.type != INTERFACE_ABSTRACT &&
+	 !gfc_new_block->attr.dummy &&
+	 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
+	{
+	  reject_statement ();
+	  gfc_free_namespace (gfc_current_ns);
+	  goto loop;
+	}
       break;
 
     case ST_PROCEDURE: