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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178665 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b8c5e01..53c2929 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+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

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 8f3c7e5..bccf7d4 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/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)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 436c160..a12e6e7 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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);
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 61c6c95..5189d62 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90
index ef3005d..a5e951a 100644 (file)
--- a/gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90
+++ b/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

diff --git a/gcc/testsuite/gfortran.dg/impure_constructor_1.f90 b/gcc/testsuite/gfortran.dg/impure_constructor_1.f90
index 56a34cd..01aa01b 100644 (file)
--- a/gcc/testsuite/gfortran.dg/impure_constructor_1.f90
+++ b/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
 

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90
new file mode 100644 (file)
index 0000000..1bb863d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90
@@ -0,0 +1,71 @@
+! { 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" } }