[Patch, Fortran] PR36592 - F2003: Procedure pointer in COMMON

["Janus Weil" <jaydub66 at googlemail dot com>]

Hi all,

the attached patch fixes PR36592, which concerns the usage of
procedure pointers in COMMON blocks.
No regressions on i686-pc-linux-gnu. Ok for trunk?

Cheers,
Janus



2008-09-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36592
	* symbol.c (check_conflict): If a symbol in a COMMON block is a
	procedure, it must be a procedure pointer.
	(gfc_add_in_common): Symbols in COMMON blocks may be variables or
	procedure pointers.
	* trans-types.c (gfc_sym_type): Make procedure pointers in COMMON
	blocks work.


2008-09-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36592
	* gfortran.dg/proc_ptr_common_1.f90: New.
	* gfortran.dg/proc_ptr_common_2.f90: New.

Index: gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90	(revision 0)
@@ -0,0 +1,30 @@
+! { dg-do run }
+
+! PR fortran/36592
+!
+! Procedure Pointers inside COMMON blocks.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>.
+
+subroutine one()
+  implicit none
+  common /com/ p1,p2,a,b
+  procedure(real), pointer :: p1,p2
+  integer :: a,b
+  if (a/=5 .or. b/=-9 .or. p1(0.0)/=1.0 .or. p2(0.0)/=0.0) call abort()
+end subroutine one
+
+program main
+  implicit none
+  integer :: x,y
+  intrinsic sin,cos
+  procedure(real), pointer :: func1
+  external func2
+  pointer func2
+  common /com/ func1,func2,x,y
+  x = 5
+  y = -9
+  func1 => cos
+  func2 => sin
+  call one()
+end program main 
Index: gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90	(revision 0)
@@ -0,0 +1,20 @@
+! { dg-do compile }
+
+! PR fortran/36592
+!
+! Procedure Pointers inside COMMON blocks.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>.
+
+abstract interface
+ subroutine foo() bind(C)
+ end subroutine foo
+end interface
+
+procedure(foo), pointer, bind(C) :: proc
+common /com/ proc,r
+
+common s
+call s()  ! { dg-error "PROCEDURE attribute conflicts with COMMON attribute" }
+
+end 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 140737)
+++ gcc/fortran/symbol.c	(working copy)
@@ -636,10 +636,12 @@ check_conflict (symbol_attribute *attr,
 	  conf2 (threadprivate);
 	}
 
+      if (!attr->proc_pointer)
+	conf2 (in_common);
+
       switch (attr->proc)
 	{
 	case PROC_ST_FUNCTION:
-	  conf2 (in_common);
 	  conf2 (dummy);
 	  break;
 
@@ -649,7 +651,6 @@ check_conflict (symbol_attribute *attr,
 
 	case PROC_DUMMY:
 	  conf2 (result);
-	  conf2 (in_common);
 	  conf2 (threadprivate);
 	  break;
 
@@ -1133,13 +1134,7 @@ gfc_add_in_common (symbol_attribute *att
 
   /* Duplicate attribute already checked for.  */
   attr->in_common = 1;
-  if (check_conflict (attr, name, where) == FAILURE)
-    return FAILURE;
-
-  if (attr->flavor == FL_VARIABLE)
-    return SUCCESS;
-
-  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
+  return check_conflict (attr, name, where);
 }
 
 
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 140737)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1627,6 +1627,16 @@ gfc_sym_type (gfc_symbol * sym)
   tree type;
   int byref;
 
+  /* Procedure Pointers inside COMMON blocks.  */
+  if (sym->attr.proc_pointer && sym->attr.in_common)
+    {
+      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
+      sym->attr.proc_pointer = 0;
+      type = build_pointer_type (gfc_get_function_type (sym));
+      sym->attr.proc_pointer = 1;
+      return type;
+    }
+
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     return void_type_node;