[Patch, Fortran, OOP] PR 48095: Invalid assignment to procedure pointer component not rejected

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

Hi all,

the attached patch fixes this accepts-valid OOP PR. It consists of two parts:
1) resolve_structure_cons is being extended to check the interface of
proc-ptr components (comment #7).
2) A small fix to allow for correct parsing of structure constructors
including proc-ptr components (comment #8).

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2011-09-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/48095
	* primary.c (gfc_match_structure_constructor): Handle parsing of
	procedure pointers components in structure constructors.
	* resolve.c (resolve_structure_cons): Check interface of procedure
	pointer components.


2011-09-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/48095
	* gfortran.dg/proc_ptr_comp_33.f90: New.

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 178634)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1119,6 +1119,40 @@ resolve_structure_cons (gfc_expr *expr, int init)
 		     comp->name);
 	}
 
+      if (comp->attr.proc_pointer && comp->ts.interface)
+	{
+	  /* Check procedure pointer interface.  */
+	  gfc_symbol *s2 = NULL;
+	  gfc_component *c2;
+	  const char *name;
+	  char err[200];
+
+	  if (gfc_is_proc_ptr_comp (cons->expr, &c2))
+	    {
+	      s2 = c2->ts.interface;
+	      name = c2->name;
+	    }
+	  else if (cons->expr->expr_type == EXPR_FUNCTION)
+	    {
+	      s2 = cons->expr->symtree->n.sym->result;
+	      name = cons->expr->symtree->n.sym->result->name;
+	    }
+	  else if (cons->expr->expr_type != EXPR_NULL)
+	    {
+	      s2 = cons->expr->symtree->n.sym;
+	      name = cons->expr->symtree->n.sym->name;
+	    }
+
+	  if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
+					     err, sizeof(err)))
+	    {
+	      gfc_error ("In derived type constructor at %L: Interface mismatch"
+			 " in procedure pointer component '%s': %s",
+			 &cons->expr->where, comp->name, err);
+	      return FAILURE;
+	    }
+	}
+
       if (!comp->attr.pointer || comp->attr.proc_pointer
 	  || cons->expr->expr_type == EXPR_NULL)
 	continue;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 178634)
+++ gcc/fortran/primary.c	(working copy)
@@ -2418,7 +2418,10 @@ gfc_match_structure_constructor (gfc_symbol *sym,
 	    }
 
 	  /* Match the current initializer expression.  */
+	  if (this_comp->attr.proc_pointer)
+	    gfc_matching_procptr_assignment = 1;
 	  m = gfc_match_expr (&comp_tail->val);
+	  gfc_matching_procptr_assignment = 0;
 	  if (m == MATCH_NO)
 	    goto syntax;
 	  if (m == MATCH_ERROR)

! { dg-do compile }
!
! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected
!
! Original test case by Arjen Markus <arjen.markus895@gmail.com>
! Modified by Janus Weil <janus@gcc.gnu.org>

module m

  implicit none

  type :: rectangle
    real :: width, height
    procedure(get_area_ai), pointer :: get_area => get_my_area  ! { dg-error "Type/rank mismatch" }
  end type rectangle

  abstract interface
    real function get_area_ai( this )
      import                       :: rectangle
      class(rectangle), intent(in) :: this
    end function get_area_ai
  end interface

contains

  real function get_my_area( this )
    type(rectangle), intent(in) :: this
    get_my_area = 3.0 * this%width * this%height
  end function get_my_area

end

!-------------------------------------------------------------------------------

program p

  implicit none

  type :: rectangle
    real :: width, height
    procedure(get_area_ai), pointer :: get_area
  end type rectangle

  abstract interface
    real function get_area_ai (this)
      import                       :: rectangle
      class(rectangle), intent(in) :: this
    end function get_area_ai
  end interface

  type(rectangle) :: rect

  rect  = rectangle (1.0, 2.0, get1)
  rect  = rectangle (3.0, 4.0, get2)  ! { dg-error "Type/rank mismatch" }

contains

  real function get1 (this)
    class(rectangle), intent(in) :: this
    get1 = 1.0 * this%width * this%height
  end function get1

  real function get2 (this)
    type(rectangle), intent(in) :: this
    get2 = 2.0 * this%width * this%height
  end function get2

end


! { dg-final { cleanup-modules "m" } }