diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b36d517..0c2d1c9 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -457,6 +457,24 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) goto coarray; } + if (gfc_match (" .. )") == MATCH_YES) + { + as->type = AS_ASSUMED_RANK; + as->rank = -1; + + if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array " + "at %C") == FAILURE) + goto cleanup; + +/* gfc_error ("Sorry, support for assumed-rank array at %C is not yet " + "implemented"); + goto cleanup;*/ + + if (!match_codim) + goto done; + goto coarray; + } + for (;;) { as->rank++; @@ -535,6 +553,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (')') == MATCH_YES) @@ -641,6 +662,9 @@ coarray: case AS_ASSUMED_SIZE: gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (']') == MATCH_YES) @@ -1959,6 +1983,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++) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 7d505d5..b0c4b28 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) else rank = array->rank; + /* Assumed-rank array. */ + if (rank == -1) + rank = GFC_MAX_DIMENSIONS; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7f1d28f..14909f4 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as) case AS_DEFERRED: c = "AS_DEFERRED"; break; case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; + case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; default: gfc_internal_error ("show_array_spec(): Unhandled array shape " "type."); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 759074a..454d873 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -132,7 +132,8 @@ expr_t; /* Array types. */ typedef enum { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED, - AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN + AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK, + AS_UNKNOWN } array_type; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 95439c1..13f3ee8 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) r1 = (s1->as != NULL) ? s1->as->rank : 0; r2 = (s2->as != NULL) ? s2->as->rank : 0; - if (r1 != r2) + if (r1 != r2 + && (!s1->as || s1->as->type != AS_ASSUMED_RANK) + && (!s2->as || s2->as->type != AS_ASSUMED_RANK)) return 0; /* Ranks differ. */ return gfc_compare_types (&s1->ts, &s2->ts) @@ -1842,7 +1844,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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d09cb11..d256bfc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -239,7 +239,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc) || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank > 0)) + || (sym->as && sym->as->rank != 0)) { proc->attr.always_explicit = 1; sym->attr.always_explicit = 1; @@ -299,6 +299,7 @@ resolve_formal_arglist (gfc_symbol *proc) } if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + || (sym->as && sym->as->type == AS_ASSUMED_RANK) || sym->attr.pointer || sym->attr.allocatable || sym->attr.target || sym->attr.optional) { @@ -2194,6 +2195,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* TS 29113, 6.2. */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_RANK) + { + gfc_error ("Procedure '%s' at %L with assumed-rank dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } /* F2008, 12.4.2.2 (2c) */ else if (arg->sym->attr.codimension) { @@ -2219,6 +2229,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + else if (arg->sym->ts.type == BT_ASSUMED) + { + gfc_error ("Procedure '%s' at %L with assumed-type dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } } if (def_sym->attr.function) @@ -4964,7 +4983,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++) @@ -5084,6 +5103,17 @@ resolve_variable (gfc_expr *e) return FAILURE; } + /* TS 29113, C535b. */ + if (sym->as && sym->as->type == AS_ASSUMED_RANK && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-rank variable %s with designator at %L", + sym->name, &e->ref->u.ar.where); + return FAILURE; + } + + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ @@ -12463,6 +12493,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 @@ -12535,6 +12579,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 1578db1..13c8589 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) } - gfc_expr * gfc_simplify_is_iostat_end (gfc_expr *x) { @@ -2946,7 +2945,6 @@ gfc_simplify_is_iostat_end (gfc_expr *x) LIBERROR_END) == 0); } - gfc_expr * gfc_simplify_is_iostat_eor (gfc_expr *x) { @@ -3380,7 +3378,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE + || as->type == AS_ASSUMED_RANK)) return NULL; if (dim == NULL) @@ -3442,13 +3441,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > array->rank + if ((d < 1 || d > array->rank) || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; } + if (as && as->type == AS_ASSUMED_RANK) + return NULL; + return simplify_bound_dim (array, kind, d, upper, as, ref, false); } } @@ -4779,6 +4781,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 f135af1..99f7d62 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6906,9 +6906,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, } if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && !sym->attr.allocatable) + && sym->as + && sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_ASSUMED_RANK + && !sym->attr.allocatable) { /* Some variables are declared directly, others are declared as pointers and allocated on the heap. */ @@ -6944,10 +6945,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-decl.c b/gcc/fortran/trans-decl.c index 75a2160..b7e137e 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. */ @@ -3670,6 +3671,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) break; case AS_DEFERRED: + case AS_ASSUMED_RANK: seen_trans_deferred_array = true; gfc_trans_deferred_array (sym, block); break; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7d1a6d4..ccdd9e6 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3769,7 +3769,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 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c74e81a..430f4e7 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1316,12 +1316,28 @@ trans_num_images (gfc_se * se) } +static tree +get_rank_from_desc (tree desc) +{ + tree tmp; + tree dtype; + + tmp = build_fold_indirect_ref_loc (input_location, desc); + + dtype = gfc_conv_descriptor_dtype (tmp); + + 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); @@ -1332,13 +1348,11 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) 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); + + /* Does that make sense? */ 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); } @@ -1401,25 +1415,37 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) desc = argse.expr; + as = gfc_get_full_arrayspec_from_expr (arg->expr); + + /* That's bogus! */ + if (as->type == AS_ASSUMED_RANK) + desc = build_fold_indirect_ref_loc (input_location, desc); + if (INTEGER_CST_P (bound)) { int hi, low; hi = TREE_INT_CST_HIGH (bound); low = TREE_INT_CST_LOW (bound); - if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + if (hi || low < 0 + || (as->type != AS_ASSUMED_RANK && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + || low > GFC_MAX_DIMENSIONS) gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " "dimension index", upper ? "UBOUND" : "LBOUND", &expr->where); } - else + + if (!INTEGER_CST_P (bound) || as->type == AS_ASSUMED_RANK) { if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + if (as->type == AS_ASSUMED_RANK) + tmp = get_rank_from_desc (desc); + else + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, @@ -1432,8 +1458,6 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (desc, bound); - as = gfc_get_full_arrayspec_from_expr (arg->expr); - /* 13.14.53: Result value for LBOUND Case (i): For an array section or for an array expression other than a diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index aa50e3d..c6088e0 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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,9 @@ 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, + return gfc_get_array_type_bounds (type, as->rank == -1 + ? GFC_MAX_DIMENSIONS : as->rank, + as->corank, lbound, ubound, 0, akind, restricted); } @@ -1684,6 +1694,10 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; int idx = 2 * (codimen + dimen - 1) + restricted; + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)