diff options
Diffstat (limited to 'gcc/fortran/decl.c')
| -rw-r--r-- | gcc/fortran/decl.c | 73 |
1 files changed, 73 insertions, 0 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index acc85d25484..91eb7109c80 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1378,6 +1378,51 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } } + /* If sym is implied-shape, set its upper bounds from init. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_IMPLIED_SHAPE) + { + int dim; + + if (init->rank == 0) + { + gfc_error ("Can't initialize implied-shape array at %L" + " with scalar", &sym->declared_at); + return FAILURE; + } + gcc_assert (sym->as->rank == init->rank); + + /* Shape should be present, we get an initialization expression. */ + gcc_assert (init->shape); + + for (dim = 0; dim < sym->as->rank; ++dim) + { + int k; + gfc_expr* lower; + gfc_expr* e; + + lower = sym->as->lower[dim]; + if (lower->expr_type != EXPR_CONSTANT) + { + gfc_error ("Non-constant lower bound in implied-shape" + " declaration at %L", &lower->where); + return FAILURE; + } + + /* All dimensions must be without upper bound. */ + gcc_assert (!sym->as->upper[dim]); + + k = lower->ts.kind; + e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); + mpz_add (e->value.integer, + lower->value.integer, init->shape[dim]); + mpz_sub_ui (e->value.integer, e->value.integer, 1); + sym->as->upper[dim] = e; + } + + sym->as->type = AS_EXPLICIT; + } + /* Need to check if the expression we initialized this to was one of the iso_c_binding named constants. If so, and we're a parameter (constant), let it be iso_c. @@ -1650,6 +1695,34 @@ variable_decl (int elem) else if (current_as) merge_array_spec (current_as, as, true); + /* At this point, we know for sure if the symbol is PARAMETER and can thus + determine (and check) whether it can be implied-shape. If it + was parsed as assumed-size, change it because PARAMETERs can not + be assumed-size. */ + if (as) + { + if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) + { + m = MATCH_ERROR; + gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape", + name, &var_locus); + goto cleanup; + } + + if (as->type == AS_ASSUMED_SIZE && as->rank == 1 + && current_attr.flavor == FL_PARAMETER) + as->type = AS_IMPLIED_SHAPE; + + if (as->type == AS_IMPLIED_SHAPE + && gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: Implied-shape array at %L", + &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + } + char_len = NULL; cl = NULL; |