From 74e666d3ae606c47fcdc3ee4929cbc43e42aa212 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 7 Sep 2011 22:20:47 +0000 Subject: [PATCH] 2011-09-07 Janus Weil 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 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 --- gcc/fortran/ChangeLog | 8 +++ gcc/fortran/primary.c | 3 + gcc/fortran/resolve.c | 44 ++++++++++++-- gcc/testsuite/ChangeLog | 7 +++ .../gfortran.dg/derived_constructor_comps_2.f90 | 2 +- gcc/testsuite/gfortran.dg/impure_constructor_1.f90 | 2 +- gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90 | 71 ++++++++++++++++++++++ 7 files changed, 130 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b8c5e01..53c2929 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2011-09-07 Janus Weil + + 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 PR fortran/50227 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 8f3c7e5..bccf7d4 100644 --- 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 --- 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 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2011-09-07 Janus Weil + + 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 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 --- 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 --- 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 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 +! Modified by Janus Weil + +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" } } -- 2.7.4