[Patch, Fortran] PR 36704/38290

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

Hi all,

this patch fixes two PRs (at least partially):

* PR 36704 - Procedure pointer as function result: This I was planning
to implement in 4.5, but when having a look at it over the weekend, I
found that certain cases (i.e. those using a RESULT statement, see
proc_ptr_12.f90) are really easy to implement, so maybe this could
still go into 4.4 (since it's more of a bugfix than a 'feature')? The
harder cases (without RESULT statement) I will then take care of
later.

* PR 38290 - Procedure pointer assignment checking: This adds a few
additional checks for procedure pointer assignments and fixes comment
#2 from the PR, including an ICE, so it's even a 4.4 regression.

The patch passes the testsuite on i686-pc-linux-gnu without
regressions. Ok for trunk?

Cheers,
Janus



2008-12-01  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	PR fortran/38290
	* decl.c (match_result): Result may be a standard variable or a
	procedure pointer.
	* expr.c (gfc_check_pointer_assign): Additional checks for procedure
	pointer assignments.
	* primary.c (gfc_match_rvalue): Bugfix for procedure pointer
	assignments.
	* resolve.c (resolve_function): Check for attr.subroutine.
	* trans-types.c (gfc_sym_type,gfc_get_function_type): Support
procedure pointers as function result.


2008-12-01  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	PR fortran/38290
	* gfortran.dg/entry_7.f90: Modified.
	* gfortran.dg/proc_ptr_2.f90: Extended.
	* gfortran.dg/proc_ptr_3.f90: Modified.
	* gfortran.dg/proc_ptr_11.f90: New.
	* gfortran.dg/proc_ptr_12.f90: New.

Index: gcc/testsuite/gfortran.dg/entry_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/entry_7.f90	(revision 142306)
+++ gcc/testsuite/gfortran.dg/entry_7.f90	(working copy)
@@ -9,7 +9,7 @@
 MODULE TT
 CONTAINS
   FUNCTION K(I) RESULT(J)
-    ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
+    ENTRY J() ! { dg-error "conflicts with RESULT attribute" }
   END FUNCTION K
 
   integer function foo ()
Index: gcc/testsuite/gfortran.dg/proc_ptr_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_2.f90	(revision 142306)
+++ gcc/testsuite/gfortran.dg/proc_ptr_2.f90	(working copy)
@@ -6,8 +6,11 @@
 
 PROCEDURE(REAL), POINTER :: ptr
 PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
+REAL :: x
 
-ptr => cos(4.0)        ! { dg-error "Invalid character" }
+ptr => cos(4.0)        ! { dg-error "Invalid procedure pointer assignment" }
+ptr => x               ! { dg-error "Invalid procedure pointer assignment" }
+ptr => sin(x)          ! { dg-error "Invalid procedure pointer assignment" }
 
 ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
 
Index: gcc/testsuite/gfortran.dg/proc_ptr_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_3.f90	(revision 142306)
+++ gcc/testsuite/gfortran.dg/proc_ptr_3.f90	(working copy)
@@ -6,14 +6,12 @@
 
 real function e1(x)
   real :: x
-  print *,'e1!',x
   e1 = x * 3.0
 end function
 
 subroutine e2(a,b)
   real, intent(inout) :: a
   real, intent(in) :: b
-  print *,'e2!',a,b
   a = a + b
 end subroutine
 
@@ -29,7 +27,15 @@ interface
   end subroutine sp
 end interface
 
-external :: e1,e2
+external :: e1
+
+interface
+  subroutine e2(a,b)
+    real, intent(inout) :: a
+    real, intent(in) :: b
+  end subroutine e2
+end interface
+
 real :: c = 1.2
 
 fp => e1
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 142306)
+++ gcc/fortran/decl.c	(working copy)
@@ -3974,8 +3974,7 @@ match_result (gfc_symbol *function, gfc_
   if (gfc_get_symbol (name, NULL, &r))
     return MATCH_ERROR;
 
-  if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
-      || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
+  if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
     return MATCH_ERROR;
 
   *result = r;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 142306)
+++ gcc/fortran/expr.c	(working copy)
@@ -3112,9 +3112,30 @@ gfc_check_pointer_assign (gfc_expr *lval
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
-  /* TODO checks on rvalue for a procedure pointer assignment.  */
+  /* Checks on rvalue for procedure pointer assignments.  */
   if (lvalue->symtree->n.sym->attr.proc_pointer)
-    return SUCCESS;
+    {
+      attr = gfc_expr_attr (rvalue);
+      if (!((rvalue->expr_type == EXPR_NULL)
+	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+	    || (rvalue->expr_type == EXPR_VARIABLE
+		&& attr.flavor == FL_PROCEDURE)))
+	{
+	  gfc_error ("Invalid procedure pointer assignment at %L",
+		     &rvalue->where);
+	  return FAILURE;
+	}
+      if (rvalue->expr_type == EXPR_VARIABLE
+	  && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
+	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
+				      rvalue->symtree->n.sym, 0))
+	{
+	  gfc_error ("Interfaces don't match "
+		     "in procedure pointer assignment at %L", &rvalue->where);
+	  return FAILURE;
+	}
+      return SUCCESS;
+    }
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 142306)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1613,8 +1613,8 @@ gfc_sym_type (gfc_symbol * sym)
   tree type;
   int byref;
 
-  /* Procedure Pointers inside COMMON blocks.  */
-  if (sym->attr.proc_pointer && sym->attr.in_common)
+  /* Procedure Pointers inside COMMON blocks or as function result.  */
+  if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
     {
       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
       sym->attr.proc_pointer = 0;
@@ -2143,6 +2143,9 @@ gfc_get_function_type (gfc_symbol * sym)
       type = gfc_typenode_for_spec (&sym->ts);
       sym->ts.kind = gfc_default_real_kind;
     }
+  else if (sym->result && sym->result->attr.proc_pointer)
+    /* Procedure pointer return values.  */
+    type = gfc_sym_type (sym->result);
   else
     type = gfc_sym_type (sym);
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 142306)
+++ gcc/fortran/resolve.c	(working copy)
@@ -2327,7 +2327,7 @@ resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  if (sym && sym->attr.flavor == FL_VARIABLE)
+  if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
     {
       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
       return FAILURE;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 142306)
+++ gcc/fortran/primary.c	(working copy)
@@ -2509,11 +2509,10 @@ gfc_match_rvalue (gfc_expr **result)
       if (gfc_matching_procptr_assignment)
 	{
 	  gfc_gobble_whitespace ();
-	  if (sym->attr.function && gfc_peek_ascii_char () == '(')
+	  if (gfc_peek_ascii_char () == '(')
 	    /* Parse functions returning a procptr.  */
 	    goto function0;
 
-	  if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
 	  if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
 	      || gfc_is_intrinsic (sym, 1, gfc_current_locus))
 	    sym->attr.intrinsic = 1;

Attachment: proc_ptr_11.f90
Description: Binary data

Attachment: proc_ptr_12.f90
Description: Binary data