re PR fortran/48095 ([OOP] Invalid assignment to procedure pointer component not rejected)

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. Changed wording of some error messages.


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

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

From-SVN: r178665

gcc/fortran/ChangeLog

+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. Changed wording of some error messages.
+
 2011-09-04  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/50227

gcc/fortran/primary.c

@@ -2418,7 +2418,10 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
 	    }
 
 	  /* 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)

gcc/fortran/resolve.c

@@ -1013,7 +1013,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
 	  && (comp->attr.allocatable || cons->expr->rank))
 	{
-	  gfc_error ("The rank of the element in the derived type "
+	  gfc_error ("The rank of the element in the structure "
 		     "constructor at %L does not match that of the "
 		     "component (%d/%d)", &cons->expr->where,
 		     cons->expr->rank, rank);
@@ -1035,7 +1035,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	      t = SUCCESS;
 	    }
 	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
-	    gfc_error ("The element in the derived type constructor at %L, "
+	    gfc_error ("The element in the structure constructor at %L, "
 		       "for pointer component '%s', is %s but should be %s",
 		       &cons->expr->where, comp->name,
 		       gfc_basic_typename (cons->expr->ts.type),
@@ -1113,12 +1113,46 @@ resolve_structure_cons (gfc_expr *expr, int init)
 		       || CLASS_DATA (comp)->attr.allocatable))))
 	{
 	  t = FAILURE;
-	  gfc_error ("The NULL in the derived type constructor at %L is "
+	  gfc_error ("The NULL in the structure constructor at %L is "
 		     "being applied to component '%s', which is neither "
 		     "a POINTER nor ALLOCATABLE", &cons->expr->where,
 		     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 ("Interface mismatch for procedure-pointer component "
+			 "'%s' in structure constructor at %L: %s",
+			 comp->name, &cons->expr->where, err);
+	      return FAILURE;
+	    }
+	}
+
       if (!comp->attr.pointer || comp->attr.proc_pointer
 	  || cons->expr->expr_type == EXPR_NULL)
 	continue;
@@ -1128,7 +1162,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
       if (!a.pointer && !a.target)
 	{
 	  t = FAILURE;
-	  gfc_error ("The element in the derived type constructor at %L, "
+	  gfc_error ("The element in the structure constructor at %L, "
 		     "for pointer component '%s' should be a POINTER or "
 		     "a TARGET", &cons->expr->where, comp->name);
 	}
@@ -1156,7 +1190,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	      || gfc_is_coindexed (cons->expr)))
 	{
 	  t = FAILURE;
-	  gfc_error ("Invalid expression in the derived type constructor for "
+	  gfc_error ("Invalid expression in the structure constructor for "
 		     "pointer component '%s' at %L in PURE procedure",
 		     comp->name, &cons->expr->where);
 	}

gcc/testsuite/ChangeLog

+2011-09-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/48095
+	* gfortran.dg/derived_constructor_comps_2.f90: Modified.
+	* gfortran.dg/impure_constructor_1.f90: Modified.
+	* gfortran.dg/proc_ptr_comp_33.f90: New.
+
 2011-09-07  Jakub Jelinek  <jakub@redhat.com>
 
 	PR target/50310

gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90

@@ -23,5 +23,5 @@ subroutine foo
   type (ByteType) :: bytes(4)
 
   print *, size(bytes)
-  bytes = ByteType((/'H', 'i', '!', ' '/)) ! { dg-error "rank of the element in the derived type constructor" }
+  bytes = ByteType((/'H', 'i', '!', ' '/)) ! { dg-error "rank of the element in the structure constructor" }
 end subroutine foo

gcc/testsuite/gfortran.dg/impure_constructor_1.f90

@@ -23,7 +23,7 @@ contains
    y = t2(x) ! Note: F2003, C1272 (3) and (4) do not apply
    
    ! Variant which is invalid as C1272 (3) applies
-   z = t3(x) ! { dg-error "Invalid expression in the derived type constructor" }
+   z = t3(x) ! { dg-error "Invalid expression in the structure constructor" }
  end subroutine foo
 end module m
 

gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90

+! { 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" } }