Hello world,
this patch fixes an overzealous interpretation of F2018 15.5.2.4, where
an idiom of passing an array element to an array was rejected. This
also restores Lapack compilation without warning.
Regression-tested. OK for trunk?
Regards
Thomas
2019-10-06 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/92004
* gfortran.h (gfc_symbol): Add maybe_array.
* 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.
(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-06 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/92004
* gfortran.dg/argument_checking_24.f90: New test.
Index: gfortran.h
===================================================================
--- gfortran.h (Revision 276506)
+++ 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 an interface to a procedure could actually be to an array
+ although the actual argument is scalar. */
+ unsigned maybe_array:1;
int refs;
struct gfc_namespace *ns; /* namespace containing this symbol */
Index: interface.c
===================================================================
--- interface.c (Revision 276506)
+++ interface.c (Arbeitskopie)
@@ -2229,6 +2229,36 @@ 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, clause 14. This
+ functin returns true for these conditions so that an error or
+ warning for this can be suppressed later. */
+
+bool
+maybe_dummy_array_arg (gfc_expr *e)
+{
+ gfc_symbol *s;
+
+ if (e->rank > 0)
+ return false;
+
+ if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
+ return true;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ s = e->symtree->n.sym;
+ if (s->as == NULL)
+ return false;
+
+ if (s->ts.type == BT_CLASS || s->as->type == AS_ASSUMED_SHAPE
+ || s->attr.pointer)
+ return false;
+
+ return true;
+}
+
/* 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 +2574,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 +2626,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-shaped 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-shaped or pointer "
+ "array passed to array dummy argument %qs at %L",
+ formal->name, &actual->where);
+ }
return false;
}
@@ -2625,7 +2665,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)
@@ -5228,6 +5270,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;
! { dg-do compile }
! PR
module x
implicit none
contains
subroutine foo(a)
real, dimension(:) :: a
call ext_1(a(1)) ! { dg-error "Rank mismatch" }
call ext_1(a) ! { dg-error "Rank mismatch" }
call ext_2(a) ! { dg-error "Element of assumed-shaped or pointer" }
call ext_2(a(1)) ! { dg-error "Element of assumed-shaped or pointer" }
end subroutine foo
subroutine bar(a)
real, dimension(*) :: a
! None of the ones below should issue an error.
call ext_3 (a)
call ext_3 (a(1))
call ext_4 (a(1))
call ext_4 (a)
end subroutine bar
end module x
