OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3) 

2012-07-20  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.
        * class.c (gfc_add_component_ref): Ditto.
        (gfc_build_class_symbol): Regard assumed-rank arrays
        as having GFC_MAX_DIMENSIONS. And build extra class
        container for a scalar pointer class.
        * decl.c (merge_array_spec): Add assert.
        * dump-parse-tree.c (show_array_spec): Add support for
        assumed-rank arrays.
        * expr.c (gfc_is_simply_contiguous): Ditto.
        * gfortran.h (array_type): Ditto.
        (gfc_array_spec, gfc_expr): Add comment to "rank" field.
        * interface.c (compare_type_rank, argument_rank_mismatch,
        compare_parameter, gfc_procedure_use): Ditto.
        (compare_actual_formal): Fix NULL() to optional-dummy
        handling for polymorphic dummies.
        * module.c (mio_typespec): Add support for
        assumed-rank arrays.
        * resolve.c (resolve_formal_arglist, resolve_actual_arglist,
        resolve_elemental_actual, resolve_global_procedure,
        expression_shape, resolve_variable, update_ppc_arglist,
        check_typebound_baseobject, gfc_resolve_expr,
        resolve_fl_var_and_proc, gfc_resolve_finalizers,
        resolve_typebound_procedure, resolve_symbol): Ditto.
        (assumed_type_expr_allowed): Remove static variable.
        (actual_arg, first_actual_arg): New static variables.
        * simplify.c (simplify_bound, gfc_simplify_range): Add
        support for assumed-rank arrays.
        * trans-array.c (gfc_conv_array_parameter): Ditto.
        (gfc_get_descriptor_dimension): New function, which returns
        the descriptor.
        (gfc_conv_descriptor_dimension): Use it.
        (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
        Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
        * trans-array.h (gfc_get_descriptor_dimension): New prototype.
        * trans-decl. (gfc_build_dummy_array_decl,
        gfc_trans_deferred_vars, add_argument_checking): Add
        support for assumed-rank arrays.
        * trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
        gfc_conv_procedure_call): Ditto.
        (get_scalar_to_descriptor_type, class_array_data_assign,
        conv_scalar_to_descriptor): New static functions.
        (gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
        them.
        * trans-intrinsic.c (get_rank_from_desc): New function.
        (gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
        * trans-types.c (gfc_array_descriptor_base_caf,
        gfc_array_descriptor_base): Make space for scalar array.
        (gfc_is_nodesc_array, gfc_is_nodesc_array,
        gfc_build_array_type, gfc_get_array_descriptor_base): Add
        support for assumed-rank arrays.
        * trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
        GFC_ARRAY_ASSUMED_RANK_CONT.

2012-07-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * gfortran.dg/assumed_type_3.f90: Update dg-error.
        * 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_4.f90: New.
        * gfortran.dg/assumed_rank_5.f90: New.
        * gfortran.dg/assumed_rank_6.f90: New.
        * gfortran.dg/assumed_rank_7.f90: New.
        * gfortran.dg/assumed_rank_8.f90: New.
        * gfortran.dg/assumed_rank_8_c.c: New.
        * gfortran.dg/assumed_rank_9.f90: New.
        * gfortran.dg/assumed_rank_10.f90: New.
        * gfortran.dg/assumed_rank_12.f90: New.

From-SVN: r189700
This commit is contained in:
Tobias Burnus 2012-07-20 07:56:37 +02:00 committed by Tobias Burnus
parent 02fe175c38
commit c62c6622bc
33 changed files with 1412 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
gcc/fortran/ChangeLog
View File

@ -1,3 +1,62 @@
2012-07-20 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.
* class.c (gfc_add_component_ref): Ditto.
(gfc_build_class_symbol): Regard assumed-rank arrays
as having GFC_MAX_DIMENSIONS. And build extra class
container for a scalar pointer class.
* decl.c (merge_array_spec): Add assert.
* dump-parse-tree.c (show_array_spec): Add support for
assumed-rank arrays.
* expr.c (gfc_is_simply_contiguous): Ditto.
* gfortran.h (array_type): Ditto.
(gfc_array_spec, gfc_expr): Add comment to "rank" field.
* interface.c (compare_type_rank, argument_rank_mismatch,
compare_parameter, gfc_procedure_use): Ditto.
(compare_actual_formal): Fix NULL() to optional-dummy
handling for polymorphic dummies.
* module.c (mio_typespec): Add support for
assumed-rank arrays.
* resolve.c (resolve_formal_arglist, resolve_actual_arglist,
resolve_elemental_actual, resolve_global_procedure,
expression_shape, resolve_variable, update_ppc_arglist,
check_typebound_baseobject, gfc_resolve_expr,
resolve_fl_var_and_proc, gfc_resolve_finalizers,
resolve_typebound_procedure, resolve_symbol): Ditto.
(assumed_type_expr_allowed): Remove static variable.
(actual_arg, first_actual_arg): New static variables.
* simplify.c (simplify_bound, gfc_simplify_range): Add
support for assumed-rank arrays.
* trans-array.c (gfc_conv_array_parameter): Ditto.
(gfc_get_descriptor_dimension): New function, which returns
the descriptor.
(gfc_conv_descriptor_dimension): Use it.
(gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
* trans-array.h (gfc_get_descriptor_dimension): New prototype.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars, add_argument_checking): Add
support for assumed-rank arrays.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
gfc_conv_procedure_call): Ditto.
(get_scalar_to_descriptor_type, class_array_data_assign,
conv_scalar_to_descriptor): New static functions.
(gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
them.
* trans-intrinsic.c (get_rank_from_desc): New function.
(gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
* trans-types.c (gfc_array_descriptor_base_caf,
gfc_array_descriptor_base): Make space for scalar array.
(gfc_is_nodesc_array, gfc_is_nodesc_array,
gfc_build_array_type, gfc_get_array_descriptor_base): Add
support for assumed-rank arrays.
* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
GFC_ARRAY_ASSUMED_RANK_CONT.
2012-07-19 Tobias Burnus <burnus@net-b.de>
* trans-expr.c (gfc_conv_procedure_call): Fix handling

32
gcc/fortran/array.c
View File

@ -390,9 +390,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)
{
@ -458,6 +460,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, "Assumed-rank array at %C")
== FAILURE)
goto cleanup;
if (!match_codim)
goto done;
goto coarray;
}
for (;;)
{
as->rank++;
@ -536,6 +552,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)
@ -642,6 +661,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)
@ -1960,6 +1982,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++)
@ -2116,6 +2141,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");

4
gcc/fortran/check.c
View File

@ -620,6 +620,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);

10
gcc/fortran/class.c
View File

@ -220,7 +220,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
void
gfc_add_class_array_ref (gfc_expr *e)
{
int rank = CLASS_DATA (e)->as->rank;
int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
gfc_add_component_ref (e, "_data");
@ -498,6 +498,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
int rank;
if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
{
@ -518,11 +519,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
return SUCCESS;
/* Determine the name of the encapsulating type. */
rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank);
sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
else if ((*as) && attr->pointer)
sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
else if (attr->pointer)
sprintf (name, "__class_%s_p", tname);
else if (attr->allocatable)

3
gcc/fortran/decl.c
View File

@ -594,6 +594,9 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
gcc_assert (from->rank != -1 || to->corank == 0);
gcc_assert (to->rank != -1 || from->corank == 0);
if (to->rank == 0 && from->rank > 0)
{
to->rank = from->rank;

3
gcc/fortran/dump-parse-tree.c
View File

@ -166,7 +166,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)
{
@ -174,6 +174,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.");

3
gcc/fortran/expr.c
View File

@ -4443,7 +4443,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)

7
gcc/fortran/gfortran.h
View File

@ -135,7 +135,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;
@ -917,7 +918,7 @@ gfc_typespec;
/* Array specification. */
typedef struct
{
int rank; /* A rank of zero means that a variable is a scalar. */
int rank; /* A scalar has a rank of 0, an assumed-rank array has -1. */
int corank;
array_type type, cotype;
struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
@ -1694,7 +1695,7 @@ typedef struct gfc_expr
gfc_typespec ts; /* These two refer to the overall expression */
int rank;
int rank; /* 0 indicates a scalar, -1 an assumed-rank array. */
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
/* Nonnull for functions and structure constructors, may also used to hold the

25
gcc/fortran/interface.c
View File

@ -512,7 +512,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)
@ -1635,7 +1637,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);
@ -1860,7 +1869,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
if (symbol_rank (formal) == actual->rank)
/* 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
@ -3001,6 +3011,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;

1
gcc/fortran/module.c
View File

@ -2341,6 +2341,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),

217
gcc/fortran/resolve.c
View File

@ -64,7 +64,13 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
static bool assumed_type_expr_allowed = false;
/* True when we are resolving an expression that is an actual argument to
a procedure. */
static bool actual_arg = false;
/* True when we are resolving an expression that is the first actual argument
to a procedure. */
static bool first_actual_arg = false;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@ -86,6 +92,7 @@ static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
int
gfc_is_formal_arg (void)
{
@ -240,7 +247,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;
@ -307,6 +314,7 @@ resolve_formal_arglist (gfc_symbol *proc)
}
if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
|| (as && as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& (CLASS_DATA (sym)->attr.class_pointer
@ -1610,8 +1618,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
gfc_try return_value = FAILURE;
bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
assumed_type_expr_allowed = true;
actual_arg = true;
first_actual_arg = true;
for (; arg; arg = arg->next)
{
@ -1625,9 +1636,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
return FAILURE;
goto cleanup;
}
}
first_actual_arg = false;
continue;
}
@ -1635,7 +1647,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
return FAILURE;
goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
@ -1643,7 +1655,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
@ -1687,7 +1699,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"Internal procedure '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
return FAILURE;
goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
@ -1700,8 +1712,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
return FAILURE;
goto cleanup;
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
@ -1722,7 +1734,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
return FAILURE;
goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
@ -1730,7 +1742,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
goto cleanup;
goto argument_list;
}
@ -1742,7 +1754,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
return FAILURE;
goto cleanup;
}
if (parent_st == NULL)
@ -1756,7 +1768,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|| sym->attr.external)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
goto cleanup;
goto argument_list;
}
@ -1784,7 +1796,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
@ -1798,14 +1810,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
return FAILURE;
goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
return FAILURE;
goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
@ -1819,7 +1831,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
return FAILURE;
goto cleanup;
}
}
@ -1831,23 +1843,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
return FAILURE;
goto cleanup;
}
}
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
&& gfc_has_ultimate_pointer (e))
{
gfc_error ("Coindexed actual argument at %L with ultimate pointer "
&& gfc_has_ultimate_pointer (e))
{
gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
return FAILURE;
}
}
assumed_type_expr_allowed = false;
goto cleanup;
}
return SUCCESS;
first_actual_arg = false;
}
return_value = SUCCESS;
cleanup:
actual_arg = actual_arg_sav;
first_actual_arg = first_actual_arg_sav;
return return_value;
}
@ -1907,7 +1926,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
@ -2206,6 +2225,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)
{
@ -2231,6 +2259,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)
@ -4976,7 +5013,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++)
@ -5079,23 +5116,79 @@ 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)
{
gfc_error ("Invalid expression with assumed-type variable %s at %L",
sym->name, &e->where);
return FAILURE;
if (!actual_arg)
{
gfc_error ("Assumed-type variable %s at %L may only be used "
"as actual argument", sym->name, &e->where);
return FAILURE;
}
else if (inquiry_argument && !first_actual_arg)
{
/* 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. */
gfc_error ("Assumed-type variable %s at %L as actual argument to "
"an inquiry function shall be the first argument",
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))
{
if (!actual_arg)
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
return FAILURE;
}
else if (inquiry_argument && !first_actual_arg)
{
/* 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. */
gfc_error ("Assumed-rank variable %s at %L as actual argument "
"to an inquiry function shall be the first argument",
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
&& e->ref->next == NULL))
&& e->ref->next == NULL))
{
gfc_error ("Assumed-type variable %s with designator at %L",
sym->name, &e->ref->u.ar.where);
gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
"reference", sym->name, &e->ref->u.ar.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))
&& e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
&& e->ref->next == NULL))
{
gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
"reference", 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. */
@ -5596,7 +5689,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;
@ -5644,7 +5737,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);
@ -6306,15 +6399,22 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
bool inquiry_save;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
actual_arg_save = actual_arg;
first_actual_arg_save = first_actual_arg;
if (e->expr_type != EXPR_VARIABLE)
inquiry_argument = false;
{
inquiry_argument = false;
actual_arg = false;
first_actual_arg = false;
}
switch (e->expr_type)
{
@ -6404,6 +6504,8 @@ gfc_resolve_expr (gfc_expr *e)
fixup_charlen (e);
inquiry_argument = inquiry_save;
actual_arg = actual_arg_save;
first_actual_arg = first_actual_arg_save;
return t;
}
@ -10332,10 +10434,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 "
@ -10344,10 +10446,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 "
"assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
@ -10961,7 +11063,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);
@ -11490,7 +11592,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);
@ -12504,6 +12606,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
@ -12576,6 +12692,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 "

13
gcc/fortran/simplify.c
View File

@ -2935,7 +2935,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@ -3381,7 +3380,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)
@ -3443,13 +3443,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);
}
}
@ -4780,6 +4783,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);
}

38
gcc/fortran/trans-array.c
View File

@ -81,7 +81,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "gimple.h"
#include "gimple.h" /* For create_tmp_var_name. */
#include "diagnostic-core.h" /* For internal_error/fatal_error. */
#include "flags.h"
#include "gfortran.h"
@ -247,12 +247,11 @@ gfc_conv_descriptor_dtype (tree desc)
desc, field, NULL_TREE);
}
static tree
gfc_conv_descriptor_dimension (tree desc, tree dim)
tree
gfc_get_descriptor_dimension (tree desc)
{
tree field;
tree type;
tree tmp;
tree type, field;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@ -262,10 +261,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
}
static tree
gfc_conv_descriptor_dimension (tree desc, tree dim)
{
tree tmp;
tmp = gfc_get_descriptor_dimension (desc);
return gfc_build_array_ref (tmp, dim, NULL);
}
@ -311,6 +319,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;
@ -6900,9 +6909,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. */
@ -6938,10 +6948,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));

1
gcc/fortran/trans-array.h
View File

@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree);
tree gfc_conv_descriptor_data_addr (tree);
tree gfc_conv_descriptor_offset_get (tree);
tree gfc_conv_descriptor_dtype (tree);
tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);

7
gcc/fortran/trans-decl.c
View File

@ -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"

173
gcc/fortran/trans-expr.c
View File

@ -42,6 +42,48 @@ along with GCC; see the file COPYING3. If not see
#include "dependency.h"
/* Convert a scalar to an array descriptor. To be used for assumed-rank
arrays. */
static tree
get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
{
enum gfc_array_kind akind;
if (attr.pointer)
akind = GFC_ARRAY_POINTER_CONT;
else if (attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
else
akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
akind, !(attr.pointer || attr.target));
}
static tree
conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
tree desc, type;
type = get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (type));
gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
if ((attr.pointer || attr.allocatable)
&& attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar)))
gfc_add_modify (&se->post, scalar,
fold_convert (TREE_TYPE (scalar),
gfc_conv_descriptor_data_get (desc)));
return desc;
}
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
@ -158,7 +200,34 @@ gfc_get_vptr_from_expr (tree expr)
tmp = gfc_class_vptr_get (tmp);
return tmp;
}
static void
class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
bool lhs_type)
{
tree tmp, tmp2, type;
gfc_conv_descriptor_data_set (block, lhs_desc,
gfc_conv_descriptor_data_get (rhs_desc));
gfc_conv_descriptor_offset_set (block, lhs_desc,
gfc_conv_descriptor_offset_get (rhs_desc));
gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
gfc_conv_descriptor_dtype (rhs_desc));
/* Assign the dimension as range-ref. */
tmp = gfc_get_descriptor_dimension (lhs_desc);
tmp2 = gfc_get_descriptor_dimension (rhs_desc);
type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
gfc_index_zero_node, NULL_TREE, NULL_TREE);
tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
gfc_index_zero_node, NULL_TREE, NULL_TREE);
gfc_add_modify (block, tmp, tmp2);
}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
@ -215,14 +284,33 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
/* Scalar to an assumed-rank array. */
if (class_ts.u.derived->components->as)
{
tree type;
type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
}
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
}
else
{
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e, ss);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
if (e->rank != class_ts.u.derived->components->as->rank)
class_array_data_assign (&parmse->pre, ctree, parmse->expr,
TREE_TYPE (parmse->expr));
else
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
@ -260,7 +348,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
break;
}
if (ref == NULL || class_ref == ref)
if ((ref == NULL || class_ref == ref)
&& (!class_ts.u.derived->components->as
|| class_ts.u.derived->components->as->rank != -1))
return;
/* Test for FULL_ARRAY. */
@ -273,13 +363,42 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
/* Set the data. */
ctree = gfc_class_data_get (var);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
{
tree type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
gfc_conv_descriptor_data_set (&parmse->pre, ctree,
gfc_class_data_get (parmse->expr));
}
else
class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
}
else
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
if (!elemental && full_array)
gfc_add_modify (&parmse->post, parmse->expr, ctree);
{
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
gfc_conv_descriptor_data_get (ctree));
else
class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
}
else
gfc_add_modify (&parmse->post, parmse->expr, ctree);
}
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
@ -730,7 +849,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 +1445,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 +3890,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
class object, if the formal argument is a class object. */
if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
&& ((CLASS_DATA (fsym)->as
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (e)->attr.dimension))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
if (fsym && (fsym->ts.type == BT_DERIVED
@ -3813,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->pre, tmp);
}
if (fsym && e->expr_type != EXPR_NULL
/* Wrap scalar variable in a descriptor. We need to convert
the address of a pointer back to the pointer itself before,
we can assign it to the data field. */
if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
&& fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
{
tmp = parmse.expr;
if (TREE_CODE (tmp) == ADDR_EXPR
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
tmp = TREE_OPERAND (tmp, 0);
parmse.expr = conv_scalar_to_descriptor (&parmse, tmp,
fsym->attr);
parmse.expr = gfc_build_addr_expr (NULL_TREE,
parmse.expr);
}
else if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
@ -3855,7 +3994,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
@ -3964,12 +4104,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);
@ -4215,7 +4356,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

37
gcc/fortran/trans-intrinsic.c
View File

@ -1315,29 +1315,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);
}
@ -5855,8 +5863,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));

51
gcc/fortran/trans-types.c
View File

@ -80,8 +80,8 @@ bool gfc_real16_is_float128 = false;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS];
static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
@ -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,9 +1695,15 @@ 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;
gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
/* Assumed-rank array. */
if (dimen == -1)
dimen = GFC_MAX_DIMENSIONS;
idx = 2 * (codimen + dimen) + restricted;
gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
{
@ -1721,16 +1740,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
TREE_NO_WARNING (decl) = 1;
/* Build the array type for the stride and bound components. */
arraytype =
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
gfc_index_zero_node,
gfc_rank_cst[codimen + dimen - 1]));
if (dimen + codimen > 0)
{
arraytype =
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
gfc_index_zero_node,
gfc_rank_cst[codimen + dimen - 1]));
decl = gfc_add_field_to_struct_1 (fat_type,
get_identifier ("dim"),
arraytype, &chain);
TREE_NO_WARNING (decl) = 1;
decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
arraytype, &chain);
TREE_NO_WARNING (decl) = 1;
}
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
&& akind == GFC_ARRAY_ALLOCATABLE)

2
gcc/fortran/trans.h
View File

@ -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

17
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,20 @@
2012-07-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_type_3.f90: Update dg-error.
* 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_4.f90: New.
* gfortran.dg/assumed_rank_5.f90: New.
* gfortran.dg/assumed_rank_6.f90: New.
* gfortran.dg/assumed_rank_7.f90: New.
* gfortran.dg/assumed_rank_8.f90: New.
* gfortran.dg/assumed_rank_8_c.c: New.
* gfortran.dg/assumed_rank_9.f90: New.
* gfortran.dg/assumed_rank_10.f90: New.
* gfortran.dg/assumed_rank_12.f90: New.
2012-07-19 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/opt25.adb: New test.

147
gcc/testsuite/gfortran.dg/assumed_rank_1.f90 Normal file
View File

@ -0,0 +1,147 @@
! { dg-do run }
! { dg-additional-sources assumed_rank_1_c.c }
!
! PR fortran/48820
!
! Assumed-rank tests
!
! FIXME: The ubound/lbound checks have to be re-enabled when
! after they are supported
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

106
gcc/testsuite/gfortran.dg/assumed_rank_10.f90 Normal file
View File

@ -0,0 +1,106 @@
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/48820
!
! Ensure that the value of scalars to assumed-rank arrays is
! copied back, if and only its pointer address could have changed.
!
program test
implicit none
type t
integer :: aa
end type t
integer, allocatable :: iia
integer, pointer :: iip
type(t), allocatable :: jja
type(t), pointer :: jjp
logical :: is_present
is_present = .true.
allocate (iip, jjp)
iia = 7
iip = 7
jja = t(88)
jjp = t(88)
call faa(iia, jja) ! Copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fai(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fpa(iip, jjp) ! Copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fpi(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fnn(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fno(iia, jja) ! No copy back
if (iia /= 7 .and. jja%aa /= 88) call abort ()
call fnn(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
call fno(iip, jjp) ! No copy back
if (iip /= 7 .and. jjp%aa /= 88) call abort ()
is_present = .false.
call fpa(null(), null()) ! No copy back
call fpi(null(), null()) ! No copy back
call fno(null(), null()) ! No copy back
call fno() ! No copy back
contains
subroutine faa (xx1, yy1)
integer, allocatable :: xx1(..)
type(t), allocatable :: yy1(..)
if (.not. allocated (xx1)) call abort ()
if (.not. allocated (yy1)) call abort ()
end subroutine faa
subroutine fai (xx1, yy1)
integer, allocatable, intent(in) :: xx1(..)
type(t), allocatable, intent(in) :: yy1(..)
if (.not. allocated (xx1)) call abort ()
if (.not. allocated (yy1)) call abort ()
end subroutine fai
subroutine fpa (xx1, yy1)
integer, pointer :: xx1(..)
type(t), pointer :: yy1(..)
if (is_present .neqv. associated (xx1)) call abort ()
if (is_present .neqv. associated (yy1)) call abort ()
end subroutine fpa
subroutine fpi (xx1, yy1)
integer, pointer, intent(in) :: xx1(..)
type(t), pointer, intent(in) :: yy1(..)
if (is_present .neqv. associated (xx1)) call abort ()
if (is_present .neqv. associated (yy1)) call abort ()
end subroutine fpi
subroutine fnn(xx2,yy2)
integer :: xx2(..)
type(t) :: yy2(..)
end subroutine fnn
subroutine fno(xx2,yy2)
integer, optional :: xx2(..)
type(t), optional :: yy2(..)
if (is_present .neqv. present (xx2)) call abort ()
if (is_present .neqv. present (yy2)) call abort ()
end subroutine fno
end program test
! We should have exactly one copy back per variable
!
! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

21
gcc/testsuite/gfortran.dg/assumed_rank_12.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/48820
!
! Ensure that the value of scalars to assumed-rank arrays is
! copied back - and everything happens in the correct order.
call sub(f())
contains
subroutine sub(x)
integer, pointer :: x(..)
end subroutine sub
function f() result(res)
integer, pointer :: res
end function f
end
! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } }
! { dg-final { cleanup-tree-dump "original" } }

16
gcc/testsuite/gfortran.dg/assumed_rank_1_c.c Normal file
View File

@ -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 ();
}

137
gcc/testsuite/gfortran.dg/assumed_rank_2.f90 Normal file
View File

@ -0,0 +1,137 @@
! { 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
!
! FIXME: The ubound/lbound checks have to be re-enabled when
! after they are supported
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

50
gcc/testsuite/gfortran.dg/assumed_rank_4.f90 Normal file
View File

@ -0,0 +1,50 @@
! { 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 at .1. shall not have a subobject reference" }
call valid3(x+1) ! { dg-error "Assumed-rank variable x at .1. may only be used as actual argument" }
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

9
gcc/testsuite/gfortran.dg/assumed_rank_5.f90 Normal file
View File

@ -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

39
gcc/testsuite/gfortran.dg/assumed_rank_6.f90 Normal file
View File

@ -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 "Assumed-rank variable y at .1. may only be used as actual argument" }
print *, y + 10 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
print *, y ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
end subroutine
subroutine foo2(x, y)
integer :: x(..), y(..)
call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" }
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

66
gcc/testsuite/gfortran.dg/assumed_rank_7.f90 Normal file
View File

@ -0,0 +1,66 @@
! { dg-do run }
!
! PR fortran/48820
!
! Handle type/class for assumed-rank arrays
!
! FIXME: The ubound/lbound checks have to be re-enabled when
! after they are supported.
! FIXME: Passing a CLASS to a CLASS has to be re-enabled.
implicit none
type t
integer :: i
end type
class(T), allocatable :: ac(:,:)
type(T), allocatable :: at(:,:)
integer :: i
allocate(ac(2:3,2:4))
allocate(at(2:3,2:4))
i = 0
call foo(ac)
call foo(at)
call bar(ac)
call bar(at)
if (i /= 12) call abort()
contains
subroutine bar(x)
type(t) :: x(..)
! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
if (size(x) /= 6) call abort()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
i = i + 1
call foo(x)
call bar2(x)
end subroutine
subroutine bar2(x)
type(t) :: x(..)
! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
if (size(x) /= 6) call abort()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
i = i + 1
end subroutine
subroutine foo(x)
class(t) :: x(..)
! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
if (size(x) /= 6) call abort()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
i = i + 1
call foo2(x)
! call bar2(x) ! Passing a CLASS to a TYPE does not yet work
end subroutine
subroutine foo2(x)
class(t) :: x(..)
! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
if (size(x) /= 6) call abort()
if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
i = i + 1
end subroutine
end

71
gcc/testsuite/gfortran.dg/assumed_rank_8.f90 Normal file
View File

@ -0,0 +1,71 @@
! { dg-do run }
! { dg-additional-sources assumed_rank_8_c.c }
!
! PR fortran/48820
!
! Scalars to assumed-rank tests
!
program main
implicit none
interface
subroutine check (x)
integer :: x(..)
end subroutine check
end interface
integer, target :: ii, j
integer, allocatable :: kk
integer, pointer :: ll
ii = 489
j = 0
call f (ii)
call f (489)
call f ()
call f (null())
call f (kk)
if (j /= 2) call abort()
j = 0
nullify (ll)
call g (null())
call g (ll)
call g (ii)
if (j /= 1) call abort()
j = 0
call h (kk)
kk = 489
call h (kk)
if (j /= 1) call abort()
contains
subroutine f (x)
integer, optional :: x(..)
if (.not. present (x)) return
if (rank (x) /= 0) call abort
call check (x)
j = j + 1
end subroutine
subroutine g (x)
integer, pointer, intent(in) :: x(..)
if (.not. associated (x)) return
if (rank (x) /= 0) call abort ()
call check (x)
j = j + 1
end subroutine
subroutine h (x)
integer, allocatable :: x(..)
if (.not. allocated (x)) return
if (rank (x) /= 0) call abort
call check (x)
j = j + 1
end subroutine
end program main

25
gcc/testsuite/gfortran.dg/assumed_rank_8_c.c Normal file
View File

@ -0,0 +1,25 @@
/* Called by assumed_rank_8.f90 and assumed_rank_9.f90. */
#include <stdlib.h> /* For abort(). */
struct a {
int *dat;
};
struct b {
struct a _data;
};
void check_ (struct a *x)
{
if (*x->dat != 489)
abort ();
}
void check2_ (struct b *x)
{
if (*x->_data.dat != 489)
abort ();
}

139
gcc/testsuite/gfortran.dg/assumed_rank_9.f90 Normal file
View File

@ -0,0 +1,139 @@
! { dg-do run }
! { dg-additional-sources assumed_rank_8_c.c }
!
! PR fortran/48820
!
! Scalars to assumed-rank tests
!
program main
implicit none
type t
integer :: i
end type t
interface
subroutine check (x)
integer :: x(..)
end subroutine check
subroutine check2 (x)
import t
class(t) :: x(..)
end subroutine check2
end interface
integer :: j
type(t), target :: y
class(t), allocatable, target :: yac
y%i = 489
allocate (yac)
yac%i = 489
j = 0
call fc()
call fc(null())
call fc(y)
call fc(yac)
if (j /= 2) call abort ()
j = 0
call gc(null())
call gc(y)
call gc(yac)
deallocate (yac)
call gc(yac)
if (j /= 2) call abort ()
j = 0
call hc(yac)
allocate (yac)
yac%i = 489
call hc(yac)
if (j /= 1) call abort ()
j = 0
call ft()
call ft(null())
call ft(y)
call ft(yac)
if (j /= 2) call abort ()
j = 0
call gt(null())
call gt(y)
call gt(yac)
deallocate (yac)
call gt(yac)
if (j /= 2) call abort ()
j = 0
call ht(yac)
allocate (yac)
yac%i = 489
call ht(yac)
if (j /= 1) call abort ()
contains
subroutine fc (x)
class(t), optional :: x(..)
if (.not. present (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort
call check2 (x)
j = j + 1
end subroutine
subroutine gc (x)
class(t), pointer, intent(in) :: x(..)
if (.not. associated (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort ()
call check2 (x)
j = j + 1
end subroutine
subroutine hc (x)
class(t), allocatable :: x(..)
if (.not. allocated (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort
call check2 (x)
j = j + 1
end subroutine
subroutine ft (x)
type(t), optional :: x(..)
if (.not. present (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort
call check2 (x)
j = j + 1
end subroutine
subroutine gt (x)
type(t), pointer, intent(in) :: x(..)
if (.not. associated (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort ()
call check2 (x)
j = j + 1
end subroutine
subroutine ht (x)
type(t), allocatable :: x(..)
if (.not. allocated (x)) return
if (.not. SAME_TYPE_AS (x, yac)) call abort ()
if (rank (x) /= 0) call abort
call check2 (x)
j = j + 1
end subroutine
end program main

4
gcc/testsuite/gfortran.dg/assumed_type_3.f90
View File

@ -31,7 +31,7 @@ end subroutine six
subroutine seven(y)
type(*) :: y(:)
call a7(y(3:5)) ! { dg-error "Assumed-type variable y with designator" }
call a7(y(3:5)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
contains
subroutine a7(x)
type(*) :: x(*)
@ -115,5 +115,5 @@ end subroutine thirteen
subroutine fourteen(x)
type(*) :: x
x = x ! { dg-error "Invalid expression with assumed-type variable" }
x = x ! { dg-error "Assumed-type variable x at .1. may only be used as actual argument" }
end subroutine fourteen