2012-06-21 Tobias Burnus * arraspec_sizey.c (gfc_match_array_spec, spec_size): Add support for assumed-rank arrays. * check.c (dim_rank_check): Ditto. * dump-parse-tree.c (show_array_spec): Ditto. * gfortran.h (array_type): Ditto. * interface.c (compare_type_rank, compare_parameter, argument_rank_mismatch, gfc_procedure_use): Ditto. * resolve.c (resolve_formal_arglist, resolve_global_procedure, expression_shape, resolve_variable, resolve_symbol, resolve_fl_var_and_proc): Ditto. (assumed_rank_type_expr_allowed): Renamed static variable from assumed_type_expr_allowed. * simplify.c (simplify_bound, gfc_simplify_range): Ditto. * trans-array.c (gfc_conv_array_parameter): Ditto. * trans-decl. (gfc_build_dummy_array_decl, gfc_trans_deferred_vars): Ditto. * trans-types.c (gfc_is_nodesc_array, gfc_build_array_type, gfc_get_array_descriptor_base): Ditto. * trans-expr.c (gfc_conv_procedure_call): Ditto. * trans-intrinsic.c (get_rank_from_desc): New function. (gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound, gfc_conv_associated): Use it. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b36d517..c7a994c 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -457,6 +457,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) goto coarray; } + if (gfc_match (" .. )") == MATCH_YES) + { + as->type = AS_ASSUMED_RANK; + as->rank = -1; + + if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array " + "at %C") == FAILURE) + goto cleanup; + + if (!match_codim) + goto done; + goto coarray; + } + for (;;) { as->rank++; @@ -535,6 +549,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 +658,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 +1979,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..da6f034 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) @@ -1617,7 +1619,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); @@ -1842,7 +1851,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 @@ -2973,6 +2983,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/resolve.c b/gcc/fortran/resolve.c index d09cb11..d35ca26 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -63,7 +63,8 @@ static code_stack *cs_base = NULL; static int forall_flag; static int do_concurrent_flag; -static bool assumed_type_expr_allowed = false; +/* Nonzero for assumed rank and for assumed type. */ +static bool assumed_rank_type_expr_allowed = false; /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -239,7 +240,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc) || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank > 0)) + || (sym->as && sym->as->rank != 0)) { proc->attr.always_explicit = 1; sym->attr.always_explicit = 1; @@ -299,6 +300,7 @@ resolve_formal_arglist (gfc_symbol *proc) } if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + || (sym->as && sym->as->type == AS_ASSUMED_RANK) || sym->attr.pointer || sym->attr.allocatable || sym->attr.target || sym->attr.optional) { @@ -1599,7 +1601,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; - assumed_type_expr_allowed = true; + assumed_rank_type_expr_allowed = true; for (; arg; arg = arg->next) { @@ -1832,8 +1834,18 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, "component", &e->where); return FAILURE; } + + /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only + allowed for the first argument. + Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html + FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is that + the function-name resolution happens too late in that function. */ + if (inquiry_argument) + assumed_rank_type_expr_allowed = false; + } - assumed_type_expr_allowed = false; + assumed_rank_type_expr_allowed = false; return SUCCESS; } @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* TS 29113, 6.2. */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_RANK) + { + gfc_error ("Procedure '%s' at %L with assumed-rank dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } /* F2008, 12.4.2.2 (2c) */ else if (arg->sym->attr.codimension) { @@ -2219,6 +2240,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + else if (arg->sym->ts.type == BT_ASSUMED) + { + gfc_error ("Procedure '%s' at %L with assumed-type dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } } if (def_sym->attr.function) @@ -4964,7 +4994,7 @@ expression_shape (gfc_expr *e) mpz_t array[GFC_MAX_DIMENSIONS]; int i; - if (e->rank == 0 || e->shape != NULL) + if (e->rank <= 0 || e->shape != NULL) return; for (i = 0; i < e->rank; i++) @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e) sym = e->symtree->n.sym; /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed) + if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed) { gfc_error ("Invalid expression with assumed-type variable %s at %L", sym->name, &e->where); return FAILURE; } + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && !assumed_rank_type_expr_allowed) + { + gfc_error ("Invalid expression with assumed-rank variable %s at %L", + sym->name, &e->where); + return FAILURE; + } + /* TS 29113, 407b. */ if (e->ts.type == BT_ASSUMED && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e) return FAILURE; } + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-rank variable %s with designator at %L", + sym->name, &e->ref->u.ar.where); + return FAILURE; + } + + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ @@ -10319,10 +10378,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (allocatable) { - if (dimension) + if (dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Allocatable array '%s' at %L must have " - "a deferred shape", sym->name, &sym->declared_at); + gfc_error ("Allocatable array '%s' at %L must have a deferred " + "shape or assumed rank", sym->name, &sym->declared_at); return FAILURE; } else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L " @@ -10331,10 +10390,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } - if (pointer && dimension) + if (pointer && dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Array pointer '%s' at %L must have a deferred shape", - sym->name, &sym->declared_at); + gfc_error ("Array pointer '%s' at %L must have a deferred shape or " + "deferred rank", sym->name, &sym->declared_at); return FAILURE; } } @@ -12463,6 +12522,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 +12608,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..10f654d 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) { @@ -3380,7 +3379,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE + || as->type == AS_ASSUMED_RANK)) return NULL; if (dim == NULL) @@ -3442,13 +3442,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > array->rank + if ((d < 1 || d > array->rank) || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; } + if (as && as->type == AS_ASSUMED_RANK) + return NULL; + return simplify_bound_dim (array, kind, d, upper, as, ref, false); } } @@ -4779,6 +4782,10 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * gfc_simplify_rank (gfc_expr *e) { + /* Assumed rank. */ + if (e->rank == -1) + return NULL; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); } 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..60ac084 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 @@ -5856,8 +5880,11 @@ 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); + 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..228b936 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. */ @@ -1320,10 +1328,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as, ubound[n] = gfc_conv_array_bound (as->upper[n]); } - if (as->type == AS_ASSUMED_SHAPE) + if (as->type == AS_ASSUMED_SHAPE + || (akind == GFC_ARRAY_UNKNOWN && as->type == AS_ASSUMED_RANK)) 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); } @@ -1682,7 +1693,13 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, { tree fat_type, decl, arraytype, *chain = NULL; char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; - int idx = 2 * (codimen + dimen - 1) + restricted; + int idx; + + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + + idx = 2 * (codimen + dimen - 1) + restricted; gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);