Hi,
I think I have resolved all the issues (see attached patch and test
case).
Basically, the patch now walks through the refs and looks at the
latest thing that could be an array or a scalar.
Regarding CLASS in argument lists without an explicit interface:
I think that this is disallowed because an explicit interface
is required for a polymorphic dummy argument, and I see no
way of passing a polymorphic argument to a procedure without
having a polymorphic argument as a dummy argument.
While I was at it, I also changed some language to match the
language of the standard more closely.
As you can see in the test case, I tried to cover all relevant
cases.
Regression-tested. OK for trunk?
Regards
Thomas
2019-10-12 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-12 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,64 @@ 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, assumed_shape, scalar_ref;
+
+ 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)
+ array_pointer = s->attr.pointer;
+ else
+ scalar_ref = true;
+
+ 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 +2602,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 +2654,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 +2693,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 +3787,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 +3795,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 +3850,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 +5313,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
