diff options
| author | Tobias Burnus <burnus@net-b.de> | 2012-07-20 07:56:37 +0200 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2012-07-20 07:56:37 +0200 |
| commit | c62c6622bcf2906969975f5741072d842c667851 (patch) | |
| tree | 09b3829b3012cefb99599fd8befc8055b9e1d6b2 | |
| parent | 02fe175c38c7e2a6043548b6f1500c4cb2fa30e7 (diff) | |
| download | gcc-c62c6622bcf2906969975f5741072d842c667851.zip gcc-c62c6622bcf2906969975f5741072d842c667851.tar.gz gcc-c62c6622bcf2906969975f5741072d842c667851.tar.bz2 | |
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
33 files changed, 1411 insertions, 120 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6100796..0d8b4ba 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b852362..acae59f 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -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"); diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index bfd1205..c5bf79b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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); diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index fc083dc..21a91ba 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -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) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 01693ad..66e2ca8 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 26c5201..681dc8d 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -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."); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 88a59bc..6109607 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fa06883..98bfa8a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 2e181c9..7dd4b83 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 88519b7..a3b9088 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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), diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 753f1c7..7e2d621 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; - } + goto cleanup; + } + + first_actual_arg = false; } - assumed_type_expr_allowed = false; - return SUCCESS; + 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 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-type variable %s with designator at %L", - sym->name, &e->ref->u.ar.where); + 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 " diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index c7145d6..afc4bc4 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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); } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index d289ac3..ba108dc 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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)); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 9bafb94..b7ab806 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 75a2160..f1b7444 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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" diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 17964bb..f5ed4e3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e4905ff..be94219 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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)); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index aa50e3d..d96f5e6e 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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; + + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + + idx = 2 * (codimen + dimen) + restricted; - gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); + 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) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3b77281..d4092f7 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8b5afd0..25891a8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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. diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 new file mode 100644 index 0000000..d68f1f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 new file mode 100644 index 0000000..ac28283 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 new file mode 100644 index 0000000..a2abcba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 @@ -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" } } + diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c b/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c new file mode 100644 index 0000000..85dd72d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c @@ -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 (); +} diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 new file mode 100644 index 0000000..981e5cc2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 new file mode 100644 index 0000000..3391fba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 new file mode 100644 index 0000000..a794996 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 new file mode 100644 index 0000000..e5071bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 new file mode 100644 index 0000000..96d4d8f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 new file mode 100644 index 0000000..b1ccab5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c b/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c new file mode 100644 index 0000000..3910d31 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c @@ -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 (); +} diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 new file mode 100644 index 0000000..39151f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_type_3.f90 b/gcc/testsuite/gfortran.dg/assumed_type_3.f90 index d88da34..8d2be25 100644 --- a/gcc/testsuite/gfortran.dg/assumed_type_3.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_type_3.f90 @@ -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 |