2012-06-24 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* array.c (match_array_element_spec, gfc_match_array_spec,
spec_size, gfc_array_dimen_size): Add support for
assumed-rank arrays.
* check.c (dim_rank_check): Ditto.
* decl.c (merge_array_spec): Ditto.
* dump-parse-tree.c (show_array_spec): Ditto.
* gfortran.h (array_type): Ditto.
* interface.c (compare_type_rank, compare_parameter,
argument_rank_mismatch, gfc_procedure_use): Ditto.
* module.c (mio_typespec): Ditto.
* resolve.c (resolve_formal_arglist, resolve_global_procedure,
expression_shape, resolve_variable, resolve_symbol,
resolve_fl_var_and_proc, resolve_actual_arglist,
resolve_elemental_actual, update_ppc_arglist,
check_typebound_baseobject, gfc_resolve_finalizers,
resolve_typebound_procedure): Ditto.
(assumed_rank_type_expr_allowed): Renamed static variable
from assumed_type_expr_allowed.
* simplify.c (simplify_bound, gfc_simplify_range): Ditto.
* trans-array.c (gfc_conv_array_parameter): Ditto.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars, add_argument_checking): Ditto.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
gfc_conv_procedure_call): Ditto.
* trans-intrinsic.c (get_rank_from_desc): New function.
(gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound,
gfc_conv_associated): Use it.
* trans-types.c (gfc_is_nodesc_array, gfc_is_nodesc_array,
gfc_build_array_type, gfc_get_array_descriptor_base): Ditto.
* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
GFC_ARRAY_ASSUMED_RANK_CONT.
2012-06-24 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_rank_1.f90: New.
* gfortran.dg/assumed_rank_1_c.c: New.
* gfortran.dg/assumed_rank_2.f90: New.
* gfortran.dg/assumed_rank_3.f90: New.
* gfortran.dg/assumed_rank_4.f90: New.
* gfortran.dg/assumed_rank_5.f90: New.
* gfortran.dg/assumed_rank_6.f90: New.
@@ -389,9 +389,11 @@ match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
+ int rank;
- lower = &as->lower[as->rank + as->corank - 1];
- upper = &as->upper[as->rank + as->corank - 1];
+ rank = as->rank == -1 ? 0 : as->rank;
+ lower = &as->lower[rank + as->corank - 1];
+ upper = &as->upper[rank + as->corank - 1];
if (gfc_match_char ('*') == MATCH_YES)
{
@@ -457,6 +459,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto coarray;
}
+ if (gfc_match (" .. )") == MATCH_YES)
+ {
+ as->type = AS_ASSUMED_RANK;
+ as->rank = -1;
+
+ if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+ "at %C") == FAILURE)
+ goto cleanup;
+
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
+
for (;;)
{
as->rank++;
@@ -535,6 +551,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@@ -641,6 +660,9 @@ coarray:
case AS_ASSUMED_SIZE:
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
@@ -1959,6 +1981,9 @@ spec_size (gfc_array_spec *as, mpz_t *result)
mpz_t size;
int d;
+ if (as->type == AS_ASSUMED_RANK)
+ return FAILURE;
+
mpz_init_set_ui (*result, 1);
for (d = 0; d < as->rank; d++)
@@ -2115,6 +2140,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
if (array->ts.type == BT_CLASS)
return FAILURE;
+ if (array->rank == -1)
+ return FAILURE;
+
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
@@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
@@ -593,7 +593,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
- if (to->rank == 0 && from->rank > 0)
+ if (to->rank == 0 && from->rank != 0)
{
to->rank = from->rank;
to->type = from->type;
@@ -621,20 +621,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
}
else if (to->corank == 0 && from->corank > 0)
{
+ int rank;
+
to->corank = from->corank;
to->cotype = from->cotype;
+ rank = to->rank == -1 ? 0 : to->rank;
+
for (i = 0; i < from->corank; i++)
{
if (copy)
{
- to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
- to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+ to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
+ to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
}
else
{
- to->lower[to->rank + i] = from->lower[i];
- to->upper[to->rank + i] = from->upper[i];
+ to->lower[rank + i] = from->lower[i];
+ to->upper[rank + i] = from->upper[i];
}
}
}
@@ -165,7 +165,7 @@ show_array_spec (gfc_array_spec *as)
fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
- if (as->rank + as->corank > 0)
+ if (as->rank + as->corank > 0 || as->rank == -1)
{
switch (as->type)
{
@@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as)
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+ case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
@@ -4441,7 +4441,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
- || sym->as->type == AS_ASSUMED_SHAPE))))
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
@@ -132,7 +132,8 @@ expr_t;
/* Array types. */
typedef enum
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
- AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+ AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+ AS_UNKNOWN
}
array_type;
@@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
- if (r1 != r2)
+ if (r1 != r2
+ && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+ && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1634,7 +1636,14 @@ static void
argument_rank_mismatch (const char *name, locus *where,
int rank1, int rank2)
{
- if (rank1 == 0)
+
+ /* TS 29113, C407b. */
+ if (rank2 == -1)
+ {
+ gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+ " '%s' has assumed-rank", where, name);
+ }
+ else if (rank1 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
"(scalar and rank-%d)", name, where, rank2);
@@ -1859,7 +1868,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
- if (symbol_rank (formal) == actual->rank)
+ if (symbol_rank (formal) == -1 && actual->rank == 0)
+ {
+ gfc_error ("Sorry, passing the scalar at %L to the assumed-rank dummy "
+ "argument '%s' is not yet supported", &actual->where,
+ formal->name);
+ return 0;
+ }
+
+ /* If the rank is the same or the formal argument has assumed-rank. */
+ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
@@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
return;
}
+
+ /* TS 29113, C407b. */
+ if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+ && symbol_rank (a->expr->symtree->n.sym) == -1)
+ {
+ gfc_error ("Assumed-rank argument requires an explicit interface "
+ "at %L", &a->expr->where);
+ return;
+ }
}
return;
@@ -2340,6 +2340,7 @@ mio_typespec (gfc_typespec *ts)
static const mstring array_spec_types[] = {
minit ("EXPLICIT", AS_EXPLICIT),
+ minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
minit ("DEFERRED", AS_DEFERRED),
minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
@@ -63,7 +63,8 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-static bool assumed_type_expr_allowed = false;
+/* Nonzero for assumed rank and for assumed type. */
+static bool assumed_rank_type_expr_allowed = false;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -239,7 +240,7 @@ resolve_formal_arglist (gfc_symbol *proc)
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
@@ -299,6 +300,7 @@ resolve_formal_arglist (gfc_symbol *proc)
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
{
@@ -1599,7 +1601,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_expr *e;
int save_need_full_assumed_size;
- assumed_type_expr_allowed = true;
+ assumed_rank_type_expr_allowed = true;
for (; arg; arg = arg->next)
{
@@ -1832,8 +1834,18 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"component", &e->where);
return FAILURE;
}
+
+ /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
+ allowed for the first argument.
+ Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
+ FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is that
+ the function-name resolution happens too late in that function. */
+ if (inquiry_argument)
+ assumed_rank_type_expr_allowed = false;
+
}
- assumed_type_expr_allowed = false;
+ assumed_rank_type_expr_allowed = false;
return SUCCESS;
}
@@ -1895,7 +1907,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
+ if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
@@ -2219,6 +2240,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
@@ -4964,7 +4994,7 @@ expression_shape (gfc_expr *e)
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
@@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
{
gfc_error ("Invalid expression with assumed-type variable %s at %L",
sym->name, &e->where);
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !assumed_rank_type_expr_allowed)
+ {
+ gfc_error ("Invalid expression with assumed-rank variable %s at %L",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
@@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-rank variable %s with designator at %L",
+ sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
@@ -5584,7 +5643,7 @@ update_ppc_arglist (gfc_expr* e)
return FAILURE;
/* F08:R739. */
- if (po->rank > 0)
+ if (po->rank != 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
@@ -5632,7 +5691,7 @@ check_typebound_baseobject (gfc_expr* e)
/* F08:C1230. If the procedure called is NOPASS,
the base object must be scalar. */
- if (e->value.compcall.tbp->nopass && base->rank > 0)
+ if (e->value.compcall.tbp->nopass && base->rank != 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
@@ -10319,10 +10378,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
if (allocatable)
{
- if (dimension)
+ if (dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have a deferred "
+ "shape or assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
@@ -10331,10 +10390,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
- if (pointer && dimension)
+ if (pointer && dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+ "deferred rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
@@ -10948,7 +11007,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
}
/* Warn if the procedure is non-scalar and not assumed shape. */
- if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
&& arg->as->type != AS_ASSUMED_SHAPE)
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
@@ -11461,7 +11520,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
@@ -12475,6 +12534,20 @@ resolve_symbol (gfc_symbol *sym)
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
@@ -12547,6 +12620,13 @@ resolve_symbol (gfc_symbol *sym)
sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
{
gfc_error ("Assumed-type variable %s at %L shall not be an "
@@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
-
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@@ -3380,7 +3379,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
done:
- if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+ || as->type == AS_ASSUMED_RANK))
return NULL;
if (dim == NULL)
@@ -3442,13 +3442,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > array->rank
+ if ((d < 1 || d > array->rank)
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
+ if (as && as->type == AS_ASSUMED_RANK)
+ return NULL;
+
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
@@ -4779,6 +4782,10 @@ gfc_simplify_range (gfc_expr *e)
gfc_expr *
gfc_simplify_rank (gfc_expr *e)
{
+ /* Assumed rank. */
+ if (e->rank == -1)
+ return NULL;
+
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
}
@@ -311,6 +311,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
@@ -6906,9 +6907,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
}
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
@@ -6944,10 +6946,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
@@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
break;
case AR_FULL:
- newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
+ newss = gfc_get_array_ss (ss, expr,
+ ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
+ : ar->as->rank,
+ GFC_SS_SECTION);
newss->info->data.array.ref = ref;
/* Make sure array is the same as array(:,:), this way
we don't need to special case all the time. */
- ar->dimen = ar->as->rank;
+ ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
for (n = 0; n < ar->dimen; n++)
{
ar->dimen_type[n] = DIMEN_RANGE;
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable. */
@@ -3669,6 +3670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
break;
+ case AS_ASSUMED_RANK:
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
@@ -4782,7 +4784,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
dummy argument is an array. (See "Sequence association" in
Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable
- || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+ || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK)))
{
comparison = NE_EXPR;
message = _("Actual string length does not match the declared one"
@@ -730,7 +730,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. */
if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK)
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
{
tree tmp;
@@ -1325,7 +1326,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym))
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
@@ -3769,7 +3771,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
+ && fsym->as->type != AS_ASSUMED_RANK;
if (comp)
f = f || !comp->attr.always_explicit;
else
@@ -3878,12 +3881,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank > 0 && sym->attr.elemental)
+ && ((e->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank > 0
+ || (e->rank != 0
&& (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_DEFERRED))))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
@@ -4129,7 +4133,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (fsym->as->type == AS_ASSUMED_SHAPE)
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+ && !fsym->attr.allocatable))
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
@@ -1316,29 +1316,37 @@ trans_num_images (gfc_se * se)
}
+static tree
+get_rank_from_desc (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
gfc_ss *ss;
- tree dtype, tmp;
ss = gfc_walk_expr (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
- argse.want_pointer = 1;
+ argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- dtype = gfc_conv_descriptor_dtype (argse.expr);
- tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
- dtype, tmp);
- se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+
+ se->expr = get_rank_from_desc (argse.expr);
}
@@ -1360,6 +1368,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
+ bool assumed_rank_lb_one;
arg = expr->value.function.actual;
arg2 = arg->next;
@@ -1401,27 +1410,40 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
desc = argse.expr;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
+ /* FIXME: Why is this extra indirect_ref required? */
+/* if (as->type == AS_ASSUMED_RANK)
+ desc = build_fold_indirect_ref_loc (input_location, desc);*/
+
if (INTEGER_CST_P (bound))
{
int hi, low;
hi = TREE_INT_CST_HIGH (bound);
low = TREE_INT_CST_LOW (bound);
- if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ if (hi || low < 0
+ || ((!as || as->type != AS_ASSUMED_RANK)
+ && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ || low > GFC_MAX_DIMENSIONS)
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
"dimension index", upper ? "UBOUND" : "LBOUND",
&expr->where);
}
- else
+
+ if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
bound = gfc_evaluate_now (bound, &se->pre);
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
bound, build_int_cst (TREE_TYPE (bound), 0));
- tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+ if (as && as->type == AS_ASSUMED_RANK)
+ tmp = get_rank_from_desc (desc);
+ else
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
- bound, tmp);
+ bound, fold_convert(TREE_TYPE (bound), tmp));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
boolean_type_node, cond, tmp);
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@@ -1429,11 +1451,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
}
}
+ /* Take care of the lbound shift for assumed-rank arrays, which are
+ nonallocatable and nonpointers. Those has a lbound of 1. */
+ assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
+ && ((arg->expr->ts.type != BT_CLASS
+ && !arg->expr->symtree->n.sym->attr.allocatable
+ && !arg->expr->symtree->n.sym->attr.pointer)
+ || (arg->expr->ts.type == BT_CLASS
+ && !CLASS_DATA (arg->expr)->attr.allocatable
+ && !CLASS_DATA (arg->expr)->attr.class_pointer));
+
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- as = gfc_get_full_arrayspec_from_expr (arg->expr);
-
/* 13.14.53: Result value for LBOUND
Case (i): For an array section or for an array expression other than a
@@ -1455,7 +1485,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
not have size zero and has value zero if dimension DIM has
size zero. */
- if (as)
+ if (!upper && assumed_rank_lb_one)
+ se->expr = gfc_index_one_node;
+ else if (as)
{
tree stride = gfc_conv_descriptor_stride_get (desc, bound);
@@ -1481,9 +1513,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
boolean_type_node, cond, cond5);
+ if (assumed_rank_lb_one)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, gfc_index_one_node);
+ }
+ else
+ tmp = ubound;
+
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- ubound, gfc_index_zero_node);
+ tmp, gfc_index_zero_node);
}
else
{
@@ -5856,8 +5898,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
- gfc_rank_cst[arg1->expr->rank - 1]);
+ if (arg1->expr->rank == -1)
+ {
+ tmp = get_rank_from_desc (arg1se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (tmp), tmp, gfc_index_one_node);
+ }
+ else
+ tmp = gfc_rank_cst[arg1->expr->rank - 1];
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 0;
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n;
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
+
for (n = 0; n < as->rank; n++)
{
/* Create expressions for the known bounds of the array. */
@@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_ASSUMED_SHAPE)
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE;
- return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+ else if (as->type == AS_ASSUMED_RANK)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ as->corank, lbound,
ubound, 0, akind, restricted);
}
@@ -1682,7 +1695,13 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
- int idx = 2 * (codimen + dimen - 1) + restricted;
+ int idx;
+
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
+ idx = 2 * (codimen + dimen - 1) + restricted;
gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
@@ -765,6 +765,8 @@ enum gfc_array_kind
GFC_ARRAY_UNKNOWN,
GFC_ARRAY_ASSUMED_SHAPE,
GFC_ARRAY_ASSUMED_SHAPE_CONT,
+ GFC_ARRAY_ASSUMED_RANK,
+ GFC_ARRAY_ASSUMED_RANK_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
@@ -0,0 +1,145 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_1_c.c }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+!
+
+implicit none
+
+interface
+ subroutine check_value(b, n, val)
+ integer :: b(..)
+ integer, value :: n
+ integer :: val(n)
+ end subroutine
+end interface
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (1 /= lbound(a,1)) call abort()
+ if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (1 /= lbound(a,i)) call abort()
+ if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
@@ -0,0 +1,16 @@
+/* Called by assumed_rank_1.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct array {
+ int *data;
+};
+
+void check_value_ (struct array *b, int n, int val[])
+{
+ int i;
+
+ for (i = 0; i < n; i++)
+ if (b->data[i] != val[i])
+ abort ();
+}
@@ -0,0 +1,135 @@
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests - same as assumed_rank_1.f90,
+! but with bounds checks and w/o call to C function
+!
+
+implicit none
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (1 /= lbound(a,1)) call abort()
+ if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (1 /= lbound(a,i)) call abort()
+ if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array reference out of bounds" }
+!
+! PR fortran/48820
+!
+! Do assumed-rank bound checking
+
+implicit none
+integer :: a(4,4)
+call bar(a)
+contains
+ subroutine bar(x)
+ integer :: x(..)
+ print *, ubound(x,dim=3) ! << wrong dim
+ end subroutine
+end
+
+! { dg-output "Fortran runtime error: Array reference out of bounds" }
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine valid1a(x)
+ integer, intent(in), pointer, contiguous :: x(..)
+end subroutine valid1a
+
+subroutine valid1(x)
+ integer, intent(in) :: x(..)
+end subroutine valid1
+
+subroutine valid2(x)
+ type(*) :: x
+end subroutine valid2
+
+subroutine foo99(x)
+ integer x(99)
+ call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
+ call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+end subroutine foo99
+
+subroutine foo(x)
+ integer :: x(..)
+ print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" }
+ call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" }
+ call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" }
+contains
+ subroutine intnl(x)
+ integer :: x(:)
+ end subroutine intnl
+end subroutine foo
+
+subroutine foo2(x)
+ integer :: x(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo3()
+ integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" }
+end subroutine
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+!
+subroutine foo(x)
+ integer :: x(..) ! { dg-error "TS 29113: Assumed-rank array" }
+end subroutine foo
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" }
+ type(*), intent(out) :: x
+end subroutine
+
+subroutine bar(x)
+ integer, intent(out) :: x(..)
+end subroutine bar
+
+subroutine foo3(y)
+ integer :: y(..)
+ y = 7 ! { dg-error "Invalid expression with assumed-rank variable" }
+ print *, y + 10 ! { dg-error "Invalid expression with assumed-rank variable" }
+ print *, y ! { dg-error "Invalid expression with assumed-rank variable" }
+end subroutine
+
+subroutine foo2(x, y)
+ integer :: x(..), y(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer, codimension[*] :: x(..)
+end subroutine
+
+subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: y(..)[*]
+end subroutine