Hi Tobias,
function ("o" missing); I think it is not clause 14 but paragraph 14.
Fixed. (That one was easy :-)
+ 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;
What about PARAMETER? :-)
Good catch.
I found that, by the time the code is reached, an element of a
parameter array is already simplified; so I added a flag during
constructor expansion.
+ s = e->symtree->n.sym;
+ if (s->as == NULL)
+ return false;
This looks wrong. You also want to permit dt%array(1) – but not
dt(1)%scalar
Fixed.
+ if (s->ts.type == BT_CLASS || s->as->type == AS_ASSUMED_SHAPE
+ || s->attr.pointer)
+ return false;
dt%foo – again, "foo" can be an allocatable of polymorphic type or a
pointer, but at least, it cannot be of assumed shape.
Really? The paragraph reads
# 14 If the actual argument is a noncoindexed scalar, the corresponding
# dummy argument shall be scalar unless
# * the actual argument is default character, of type character with the
# C character kind (18.2.2), or is an element or substring of an
# element of an array that is not an assumed-shape, pointer, or
# polymorphic array,
(The last two points do not apply here because they are invalid without
explicit interface). Unless I have my negatives wrong, the code is
correct (but I have been getting standardese wrong before).
Anyway, here's an update of the patch. OK, or is there still something
missing? Or how should I interpret that paragraph? :-)
Regards
Thomas
Index: array.c
===================================================================
--- array.c (Revision 276506)
+++ 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: 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 */
@@ -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: interface.c
===================================================================
--- interface.c (Revision 276506)
+++ interface.c (Arbeitskopie)
@@ -2229,6 +2229,46 @@ 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;
+ gfc_ref *ref;
+ bool last_array_ref;
+
+ if (e->rank > 0)
+ return false;
+
+ if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
+ return true;
+
+ 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->as == NULL)
+ return false;
+
+ if (s->ts.type == BT_CLASS || s->as->type == AS_ASSUMED_SHAPE
+ || s->attr.pointer)
+ return false;
+
+ last_array_ref = false;
+
+ for (ref=e->ref; ref; ref=ref->next)
+ last_array_ref = ref->type == REF_ARRAY;
+
+ return last_array_ref;
+}
+
/* 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 +2584,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 +2636,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 +2675,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 +5280,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
type t
real :: x
end type t
type tt
real :: x(2)
end type tt
contains
subroutine foo(a)
real, dimension(:) :: a
real, dimension(2), parameter :: b = [1.0, 2.0]
type (t), dimension(1) :: vv
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" }
call ext_3(b) ! { dg-error "Rank mismatch" }
call ext_3(1.0) ! { dg-error "Rank mismatch" }
call ext_4 (vv(1)%x) ! { dg-error "Rank mismatch" }
call ext_4 (b) ! { dg-error "Rank mismatch" }
call ext_5 (b) ! { dg-error "Rank mismatch" }
call ext_5 (vv(1)%x) ! { dg-error "Rank mismatch" }
end subroutine foo
subroutine bar(a)
real, dimension(*) :: a
real, dimension(2), parameter :: b = [1.0, 2.0]
type (tt) :: tt_var
! None of the ones below should issue an error.
call ext_6 (a)
call ext_6 (a(1))
call ext_7 (a(1))
call ext_7 (a)
call ext_8 (b)
call ext_8 (b(1))
call ext_9 (tt_var%x)
call ext_9 (tt_var%x(1))
end subroutine bar
subroutine baz (a)
real :: a
end subroutine baz
end module x
