This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran] attribute declaration outside of INTERFACE body (PR36361)


> here is my patch for PR36361, including test cases, regtested on
> i686-pc-linux-gnu with no
> failures. It also includes the one-line fix from PR36275 comment #3.

I have modified the fix for PR36275 a little, so that it also fixes
PR36322, which is actually related. Both are based on a sub-optimal
mechanism for copying the typespec for a PROCEDURE from its interface
(which happens in "resolve_symbol"). Before, the elements of ts were
just copied one by one (missing a few, which caused the problems). Now
I made sure that all of them are copied, an that the way of doing this
still works even if new elements are added in the future.

I also added a test case for PR36322.

> There is just one thing I need someone's opinion on: The new test case
> interface_24.f90 has some slight issues regarding error recovery.

I'd still like to hear some thoughts on this.

Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/interface_24.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_24.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/interface_24.f90	(revision 0)
@@ -0,0 +1,66 @@
+! { dg-do compile }
+!
+! This tests the fix for PR36361: If a function was declared in an INTERFACE
+! statement, no attributes may be declared outside of the INTERFACE body.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m1
+  interface
+    real function f1()
+    end function
+  end interface
+  dimension :: f1(4)  ! { dg-error "outside its INTERFACE body" }
+end module
+
+
+module m2
+  dimension :: f2(4)
+  interface
+    real function f2()  ! { dg-error "outside its INTERFACE body" }
+    !end function
+  end interface
+end module
+
+
+! valid
+module m3
+  interface
+    real function f3()
+      dimension :: f3(4)
+    end function
+  end interface
+end module
+
+
+module m4
+  interface
+    function f4()  ! { dg-error "cannot have a deferred shape" }
+      real :: f4(:)
+    end function
+  end interface
+  allocatable :: f4  ! { dg-error "outside of INTERFACE body" }
+end module
+
+
+module m5
+  allocatable :: f5(:)
+  interface
+    function f5()  ! { dg-error "outside its INTERFACE body" }
+      !real f5(:)
+    !end function
+  end interface
+end module
+
+
+!valid
+module m6
+  interface
+    function f6()
+      real f6(:)
+      allocatable :: f6
+    end function
+  end interface
+end module
+
+! { dg-final { cleanup-modules "m1 m2 m3 m4 m5 m6" } }
Index: gcc/testsuite/gfortran.dg/proc_decl_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_2.f90	(revision 136252)
+++ gcc/testsuite/gfortran.dg/proc_decl_2.f90	(working copy)
@@ -4,16 +4,27 @@
 
 module m
 
+  use ISO_C_BINDING
+
   abstract interface
     subroutine csub() bind(c)
     end subroutine csub
   end interface
 
+  integer, parameter :: ckind = C_FLOAT_COMPLEX
+  abstract interface
+    function stub() bind(C)
+      import ckind
+      complex(ckind) stub
+    end function
+  end interface
+
   procedure():: mp1
   procedure(real), private:: mp2
   procedure(mfun), public:: mp3
   procedure(csub), public, bind(c) :: c, d
   procedure(csub), public, bind(c, name="myB") :: b
+  procedure(stub), bind(C) :: e
 
 contains
 
@@ -32,6 +43,15 @@ contains
     procedure(a), optional :: b
   end subroutine bar
 
+  subroutine bar2(x)
+    abstract interface
+      character function abs_fun()
+      end function
+    end interface
+    procedure(abs_fun):: x
+  end subroutine
+
+
 end module
 
 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 136252)
+++ gcc/fortran/symbol.c	(working copy)
@@ -814,6 +814,14 @@ gfc_add_allocatable (symbol_attribute *a
       return FAILURE;
     }
 
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE)
+    {
+      gfc_error ("ALLOCATABLE delaration outside of INTERFACE body at %L",
+		 where);
+      return FAILURE;
+    }
+
   attr->allocatable = 1;
   return check_conflict (attr, NULL, where);
 }
@@ -832,6 +840,14 @@ gfc_add_dimension (symbol_attribute *att
       return FAILURE;
     }
 
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE)
+    {
+      gfc_error ("DIMENSION declaration for %s outside its INTERFACE body "
+		 "at %L", name, where);
+      return FAILURE;
+    }
+
   attr->dimension = 1;
   return check_conflict (attr, name, where);
 }
@@ -1453,6 +1469,13 @@ gfc_add_explicit_interface (gfc_symbol *
       return FAILURE;
     }
 
+  if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
+    {
+      gfc_error ("Attribute declaration for %s outside its INTERFACE body "
+		 "at %L", sym->name, where);
+      return FAILURE;
+    }
+
   sym->formal = formal;
   sym->attr.if_source = source;
 
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 136252)
+++ gcc/fortran/decl.c	(working copy)
@@ -5216,7 +5216,7 @@ attr_decl1 (void)
   /* Update symbol table.  DIMENSION attribute is set
      in gfc_set_array_spec().  */
   if (current_attr.dimension == 0
-      && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
+      && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 136252)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7703,6 +7703,7 @@ resolve_symbol (gfc_symbol *sym)
   gfc_symtree *this_symtree;
   gfc_namespace *ns;
   gfc_component *c;
+  gfc_symbol *ifc;
 
   if (sym->attr.flavor == FL_UNKNOWN)
     {
@@ -7749,11 +7750,12 @@ resolve_symbol (gfc_symbol *sym)
       /* Get the attributes from the interface (now resolved).  */
       if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
 	{
-	  sym->ts.type = sym->ts.interface->ts.type;
-	  sym->ts.kind = sym->ts.interface->ts.kind;
-	  sym->attr.function = sym->ts.interface->attr.function;
-	  sym->attr.subroutine = sym->ts.interface->attr.subroutine;
-	  copy_formal_args (sym, sym->ts.interface);
+	  ifc = sym->ts.interface;
+	  sym->ts = ifc->ts;
+	  sym->ts.interface = ifc;
+	  sym->attr.function = ifc->attr.function;
+	  sym->attr.subroutine = ifc->attr.subroutine;
+	  copy_formal_args (sym, ifc);
 	}
       else if (sym->ts.interface->name[0] != '\0')
 	{
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 136252)
+++ gcc/fortran/parse.c	(working copy)
@@ -1914,23 +1914,18 @@ loop:
       unexpected_eof ();
 
     case ST_SUBROUTINE:
-      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)
+    case ST_FUNCTION:
+      if (st == ST_SUBROUTINE)
+	new_state = COMP_SUBROUTINE;
+      else if (st == ST_FUNCTION)
+	new_state = COMP_FUNCTION;
+      if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
+				  gfc_new_block->formal, NULL) == 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)

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]