+2019-10-14 Thomas Koenig <tkoenig@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-14 Tobias Burnus <tobias@codesourcery.com>
* error.c: Remove debug pragma added in previous commit.
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;
/* 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 */
/* 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
}
+/* 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. */
|| (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)
&& (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;
}
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)
{
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
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
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] != '%')
{
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;
+2019-10-14 Thomas Koenig <tkoenig@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.
+
2019-10-14 Maya Rashish <coypu@sdf.org>
* gcc.c-torture/compile/pr85401: New test.
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
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" }
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" }
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)
--- /dev/null
+! { 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
! 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
projects / platform / upstream / gcc.git / commitdiff