From 4a4fc7feda04b57e3bf767ba29836868f2f984d7 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Mon, 14 Oct 2019 21:37:34 +0000 Subject: [PATCH] re PR fortran/92004 (Rejection of different ranks for dummy array argument where actual argument is an element) 2019-10-14 Thomas Koenig PR fortran/92004 * array.c (expand_constructor): Set from_constructor on expression. * gfortran.h (gfc_symbol): Add maybe_array. (gfc_expr): Add from_constructor. * interface.c (maybe_dummy_array_arg): New function. (compare_parameter): If the formal argument is generated from a call, check the conditions where an array element could be passed to an array. Adjust error message for assumed-shape or pointer array. Use correct language for assumed shaped arrays. (gfc_get_formal_from_actual_arglist): Set maybe_array on the symbol if the actual argument is an array element fulfilling the conditions of 15.5.2.4. 2019-10-14 Thomas Koenig PR fortran/92004 * gfortran.dg/argument_checking_24.f90: New test. * gfortran.dg/abstract_type_6.f90: Add error message. * gfortran.dg/argument_checking_11.f90: Correct wording in error message. * gfortran.dg/argumeent_checking_13.f90: Likewise. * gfortran.dg/interface_40.f90: Add error message. From-SVN: r276972 --- gcc/fortran/ChangeLog | 16 +++ gcc/fortran/array.c | 1 + gcc/fortran/gfortran.h | 7 ++ gcc/fortran/interface.c | 100 +++++++++++++++++- gcc/testsuite/ChangeLog | 10 ++ gcc/testsuite/gfortran.dg/abstract_type_6.f03 | 2 +- .../gfortran.dg/argument_checking_11.f90 | 8 +- .../gfortran.dg/argument_checking_13.f90 | 6 +- .../gfortran.dg/argument_checking_24.f90 | 63 +++++++++++ gcc/testsuite/gfortran.dg/interface_40.f90 | 2 +- 10 files changed, 201 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_24.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1f119a84569..7e05e9105aa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2019-10-14 Thomas Koenig + + PR fortran/92004 + * array.c (expand_constructor): Set from_constructor on + expression. + * gfortran.h (gfc_symbol): Add maybe_array. + (gfc_expr): Add from_constructor. + * interface.c (maybe_dummy_array_arg): New function. + (compare_parameter): If the formal argument is generated from a + call, check the conditions where an array element could be + passed to an array. Adjust error message for assumed-shape + or pointer array. Use correct language for assumed shaped arrays. + (gfc_get_formal_from_actual_arglist): Set maybe_array on the + symbol if the actual argument is an array element fulfilling + the conditions of 15.5.2.4. + 2019-10-14 Tobias Burnus * error.c: Remove debug pragma added in previous commit. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index cbeece44ecf..427110bee74 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1782,6 +1782,7 @@ expand_constructor (gfc_constructor_base base) gfc_free_expr (e); return false; } + e->from_constructor = 1; current_expand.offset = &c->offset; current_expand.repeat = &c->repeat; current_expand.component = c->n.component; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d84d1fa7f7e..920acdafc6b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1614,6 +1614,9 @@ typedef struct gfc_symbol /* Set if a previous error or warning has occurred and no other should be reported. */ unsigned error:1; + /* Set if the dummy argument of a procedure could be an array despite + being called with a scalar actual argument. */ + unsigned maybe_array:1; int refs; struct gfc_namespace *ns; /* namespace containing this symbol */ @@ -2194,6 +2197,10 @@ typedef struct gfc_expr /* Set this if no warning should be given somewhere in a lower level. */ unsigned int do_not_warn : 1; + + /* Set this if the expression came from expanding an array constructor. */ + unsigned int from_constructor : 1; + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 3313e729db9..919c95a87c8 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2229,6 +2229,67 @@ argument_rank_mismatch (const char *name, locus *where, } +/* Under certain conditions, a scalar actual argument can be passed + to an array dummy argument - see F2018, 15.5.2.4, paragraph 14. + This function returns true for these conditions so that an error + or warning for this can be suppressed later. Always return false + for expressions with rank > 0. */ + +bool +maybe_dummy_array_arg (gfc_expr *e) +{ + gfc_symbol *s; + gfc_ref *ref; + bool array_pointer = false; + bool assumed_shape = false; + bool scalar_ref = true; + + if (e->rank > 0) + return false; + + if (e->ts.type == BT_CHARACTER && e->ts.kind == 1) + return true; + + /* If this comes from a constructor, it has been an array element + originally. */ + + if (e->expr_type == EXPR_CONSTANT) + return e->from_constructor; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + s = e->symtree->n.sym; + + if (s->attr.dimension) + { + scalar_ref = false; + array_pointer = s->attr.pointer; + } + + if (s->as && s->as->type == AS_ASSUMED_SHAPE) + assumed_shape = true; + + for (ref=e->ref; ref; ref=ref->next) + { + if (ref->type == REF_COMPONENT) + { + symbol_attribute *attr; + attr = &ref->u.c.component->attr; + if (attr->dimension) + { + array_pointer = attr->pointer; + assumed_shape = false; + scalar_ref = false; + } + else + scalar_ref = true; + } + } + + return !(scalar_ref || array_pointer || assumed_shape); +} + /* Given a symbol of a formal argument list and an expression, see if the two are compatible as arguments. Returns true if compatible, false if not compatible. */ @@ -2544,7 +2605,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) { - if (where) + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) { locus *where_formal; if (formal->attr.artificial) @@ -2594,9 +2657,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) { if (where) - gfc_error ("Element of assumed-shaped or pointer " - "array passed to array dummy argument %qs at %L", - formal->name, &actual->where); + { + if (formal->attr.artificial) + gfc_error ("Element of assumed-shape or pointer array " + "as actual argument at %L can not correspond to " + "actual argument at %L ", + &actual->where, &formal->declared_at); + else + gfc_error ("Element of assumed-shape or pointer " + "array passed to array dummy argument %qs at %L", + formal->name, &actual->where); + } return false; } @@ -2625,7 +2696,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (ref == NULL && actual->expr_type != EXPR_NULL) { - if (where) + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) { locus *where_formal; if (formal->attr.artificial) @@ -3717,6 +3790,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { gfc_actual_arglist *a; gfc_formal_arglist *dummy_args; + bool implicit = false; /* Warn about calls with an implicit interface. Special case for calling a ISO_C_BINDING because c_loc and c_funloc @@ -3724,6 +3798,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) explicitly declared at all if requested. */ if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) { + implicit = true; if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN) { const char *guessed @@ -3778,6 +3853,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (a->expr && a->expr->error) return false; + /* F2018, 15.4.2.2 Explicit interface is required for a + polymorphic dummy argument, so there is no way to + legally have a class appear in an argument with an + implicit interface. */ + + if (implicit && a->expr && a->expr->ts.type == BT_CLASS) + { + gfc_error ("Explicit interface required for polymorphic " + "argument at %L",&a->expr->where); + a->expr->error = 1; + break; + } + /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { @@ -5228,6 +5316,8 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym, s->as->upper[0] = NULL; s->as->type = AS_ASSUMED_SIZE; } + else + s->maybe_array = maybe_dummy_array_arg (a->expr); } s->attr.dummy = 1; s->declared_at = a->expr->where; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 494c67f9b19..0f4eb9f45c0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2019-10-14 Thomas Koenig + + PR fortran/92004 + * gfortran.dg/argument_checking_24.f90: New test. + * gfortran.dg/abstract_type_6.f90: Add error message. + * gfortran.dg/argument_checking_11.f90: Correct wording + in error message. + * gfortran.dg/argumeent_checking_13.f90: Likewise. + * gfortran.dg/interface_40.f90: Add error message. + 2019-10-14 Maya Rashish * gcc.c-torture/compile/pr85401: New test. diff --git a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 index 9dd0a37c564..ebef02ed82a 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 @@ -46,7 +46,7 @@ END SUBROUTINE bottom_b SUBROUTINE bottom_c(obj) CLASS(Bottom) :: obj - CALL top_c(obj) + CALL top_c(obj) ! { dg-error "Explicit interface required" } ! other stuff END SUBROUTINE bottom_c end module diff --git a/gcc/testsuite/gfortran.dg/argument_checking_11.f90 b/gcc/testsuite/gfortran.dg/argument_checking_11.f90 index 7c70c37ee47..43364a6d5c5 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_11.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_11.f90 @@ -29,8 +29,8 @@ SUBROUTINE test1(a,b,c,d,e) call as_size( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } call as_size( (d) ) call as_size( (e) ) ! { dg-error "Rank mismatch" } - call as_size(a(1)) ! { dg-error "Element of assumed-shaped" } - call as_size(b(1)) ! { dg-error "Element of assumed-shaped" } + call as_size(a(1)) ! { dg-error "Element of assumed-shape" } + call as_size(b(1)) ! { dg-error "Element of assumed-shape" } call as_size(c(1)) call as_size(d(1)) call as_size( (a(1)) ) ! { dg-error "Rank mismatch" } @@ -89,8 +89,8 @@ SUBROUTINE test1(a,b,c,d,e) call as_expl( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } call as_expl( (d) ) call as_expl( (e) ) ! { dg-error "Rank mismatch" } - call as_expl(a(1)) ! { dg-error "Element of assumed-shaped" } - call as_expl(b(1)) ! { dg-error "Element of assumed-shaped" } + call as_expl(a(1)) ! { dg-error "Element of assumed-shape" } + call as_expl(b(1)) ! { dg-error "Element of assumed-shape" } call as_expl(c(1)) call as_expl(d(1)) call as_expl( (a(1)) ) ! { dg-error "Rank mismatch" } diff --git a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 index 26e9497f1b1..1b7f0c646db 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 @@ -26,9 +26,9 @@ real, pointer :: pointer_dummy(:,:,:) real, allocatable :: deferred(:,:,:) real, pointer :: ptr(:,:,:) call rlv1(deferred(1,1,1)) ! valid since contiguous -call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } -call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } -call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" } +call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } +call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } +call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } end subroutine test2(assumed_sh_dummy, pointer_dummy) diff --git a/gcc/testsuite/gfortran.dg/argument_checking_24.f90 b/gcc/testsuite/gfortran.dg/argument_checking_24.f90 new file mode 100644 index 00000000000..a5f3abee3a8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_24.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! PR 92004 - checks in the absence of an explicit interface between +! array elements and arrays +module x + implicit none + type t + real :: x + end type t + type tt + real :: x(2) + end type tt + type pointer_t + real, pointer :: x(:) + end type pointer_t + type alloc_t + real, dimension(:), allocatable :: x + end type alloc_t +contains + subroutine foo(a) + real, dimension(:) :: a + real, dimension(2), parameter :: b = [1.0, 2.0] + real, dimension(10) :: x + type (t), dimension(1) :: vv + type (pointer_t) :: pointer_v + real, dimension(:), pointer :: p + call invalid_1(a(1)) ! { dg-error "Rank mismatch" } + call invalid_1(a) ! { dg-error "Rank mismatch" } + call invalid_2(a) ! { dg-error "Element of assumed-shape or pointer" } + call invalid_2(a(1)) ! { dg-error "Element of assumed-shape or pointer" } + call invalid_3(b) ! { dg-error "Rank mismatch" } + call invalid_3(1.0) ! { dg-error "Rank mismatch" } + call invalid_4 (vv(1)%x) ! { dg-error "Rank mismatch" } + call invalid_4 (b) ! { dg-error "Rank mismatch" }w + call invalid_5 (b) ! { dg-error "Rank mismatch" } + call invalid_5 (vv(1)%x) ! { dg-error "Rank mismatch" } + call invalid_6 (x) ! { dg-error "can not correspond to actual argument" } + call invalid_6 (pointer_v%x(1)) ! { dg-error "can not correspond to actual argument" } + call invalid_7 (pointer_v%x(1)) ! { dg-error "Rank mismatch" } + call invalid_7 (x) ! { dg-error "Rank mismatch" } + call invalid_8 (p(1)) ! { dg-error "Rank mismatch" } + call invalid_8 (x) ! { dg-error "Rank mismatch" } + call invalid_9 (x) ! { dg-error "can not correspond to actual argument" } + call invalid_9 (p(1)) ! { dg-error "can not correspond to actual argument" } + end subroutine foo + + subroutine bar(a, alloc) + real, dimension(*) :: a + real, dimension(2), parameter :: b = [1.0, 2.0] + type (alloc_t), pointer :: alloc + type (tt) :: tt_var + ! None of the ones below should issue an error. + call valid_1 (a) + call valid_1 (a(1)) + call valid_2 (a(1)) + call valid_2 (a) + call valid_3 (b) + call valid_3 (b(1)) + call valid_4 (tt_var%x) + call valid_4 (tt_var%x(1)) + call valid_5 (alloc%x(1)) + call valid_5 (a) + end subroutine bar +end module x diff --git a/gcc/testsuite/gfortran.dg/interface_40.f90 b/gcc/testsuite/gfortran.dg/interface_40.f90 index 085c6b30f39..68a10c8dd5d 100644 --- a/gcc/testsuite/gfortran.dg/interface_40.f90 +++ b/gcc/testsuite/gfortran.dg/interface_40.f90 @@ -3,6 +3,6 @@ ! Code contributed by Gerhard Steinmetz program p class(*) :: x ! { dg-error " must be dummy, allocatable or pointer" } - print *, f(x) + print *, f(x) ! { dg-error "Explicit interface required" } end -- 2.30.2