OK, so here's the update. There was a problem with uninitialized
variables, which for some reason was not detected on compilation.
OK for trunk?
2019-10-13 Thomas Koenig <tkoe...@gcc.gnu.org>
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-13 Thomas Koenig <tkoe...@gcc.gnu.org>
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.
Index: fortran/array.c
===================================================================
--- fortran/array.c (Revision 276506)
+++ fortran/array.c (Arbeitskopie)
@@ -1763,6 +1763,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;
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h (Revision 276506)
+++ fortran/gfortran.h (Arbeitskopie)
@@ -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,11 @@ 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
Index: fortran/interface.c
===================================================================
--- fortran/interface.c (Revision 276506)
+++ fortran/interface.c (Arbeitskopie)
@@ -2229,6 +2229,67 @@ argument_rank_mismatch (const char *name, locus *w
}
+/* 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 *a
|| (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 *a
&& (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 *a
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_arg
{
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_arg
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_arg
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 *sy
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;
Index: testsuite/gfortran.dg/abstract_type_6.f03
===================================================================
--- testsuite/gfortran.dg/abstract_type_6.f03 (Revision 276506)
+++ testsuite/gfortran.dg/abstract_type_6.f03 (Arbeitskopie)
@@ -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
Index: testsuite/gfortran.dg/argument_checking_11.f90
===================================================================
--- testsuite/gfortran.dg/argument_checking_11.f90 (Revision 276506)
+++ testsuite/gfortran.dg/argument_checking_11.f90 (Arbeitskopie)
@@ -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" }
Index: testsuite/gfortran.dg/argument_checking_13.f90
===================================================================
--- testsuite/gfortran.dg/argument_checking_13.f90 (Revision 276506)
+++ testsuite/gfortran.dg/argument_checking_13.f90 (Arbeitskopie)
@@ -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)
Index: testsuite/gfortran.dg/interface_40.f90
===================================================================
--- testsuite/gfortran.dg/interface_40.f90 (Revision 276506)
+++ testsuite/gfortran.dg/interface_40.f90 (Arbeitskopie)
@@ -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
! { 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
