re PR fortran/36592 (F2003: Procedure pointer in COMMON)

2008-09-30  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-30  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.

From-SVN: r140790

6 files changed, 80 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 389f8fa..253caa2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2008-09-30  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-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org
 
 	PR fortran/37498
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 37f07df..42df574 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -636,10 +636,12 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 	  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, const char *name, locus *where)
 
 	case PROC_DUMMY:
 	  conf2 (result);
-	  conf2 (in_common);
 	  conf2 (threadprivate);
 	  break;
 
@@ -1133,13 +1134,7 @@ gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
 
   /* 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);
 }
 
 
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 8178ae3..c3d2a91 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28086b3..02eb3b3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-09-30  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.
+
 2008-09-30  Paolo Bonzini  <bonzini@gnu.org>
 
 	* g++.dg/warn/if-empty-1.C: Copy from gcc.dg/if-empty-1.c.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
new file mode 100644
index 0000000..0cfdec0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90
@@ -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 
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90
new file mode 100644
index 0000000..f401c3a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90
@@ -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