diff options
Diffstat (limited to 'gcc/fortran/parse.c')
| -rw-r--r-- | gcc/fortran/parse.c | 80 |
1 files changed, 80 insertions, 0 deletions
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 56c6782..c707142 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3958,6 +3958,8 @@ parse_associate (void) for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol* sym; + gfc_ref *ref; + gfc_array_ref *array_ref; if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) gcc_unreachable (); @@ -3974,6 +3976,84 @@ parse_associate (void) for parsing component references on the associate-name in case of association to a derived-type. */ sym->ts = a->target->ts; + + /* Check if the target expression is array valued. This can not always + be done by looking at target.rank, because that might not have been + set yet. Therefore traverse the chain of refs, looking for the last + array ref and evaluate that. */ + array_ref = NULL; + for (ref = a->target->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + array_ref = &ref->u.ar; + if (array_ref || a->target->rank) + { + gfc_array_spec *as; + int dim, rank = 0; + if (array_ref) + { + /* Count the dimension, that have a non-scalar extend. */ + for (dim = 0; dim < array_ref->dimen; ++dim) + if (array_ref->dimen_type[dim] != DIMEN_ELEMENT + && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN + && array_ref->end[dim] == NULL + && array_ref->start[dim] != NULL)) + ++rank; + } + else + rank = a->target->rank; + /* When the rank is greater than zero then sym will be an array. */ + if (sym->ts.type == BT_CLASS) + { + if ((!CLASS_DATA (sym)->as && rank != 0) + || (CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->rank != rank)) + { + /* Don't just (re-)set the attr and as in the sym.ts, + because this modifies the target's attr and as. Copy the + data and do a build_class_symbol. */ + symbol_attribute attr = CLASS_DATA (a->target)->attr; + int corank = gfc_get_corank (a->target); + gfc_typespec type; + + if (rank || corank) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = corank; + attr.dimension = rank ? 1 : 0; + attr.codimension = corank ? 1 : 0; + } + else + { + as = NULL; + attr.dimension = attr.codimension = 0; + } + attr.class_ok = 0; + type = CLASS_DATA (sym)->ts; + if (!gfc_build_class_symbol (&type, + &attr, &as)) + gcc_unreachable (); + sym->ts = type; + sym->ts.type = BT_CLASS; + sym->attr.class_ok = 1; + } + else + sym->attr.class_ok = 1; + } + else if ((!sym->as && rank != 0) + || (sym->as && sym->as->rank != rank)) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = gfc_get_corank (a->target); + sym->as = as; + sym->attr.dimension = 1; + if (as->corank) + sym->attr.codimension = 1; + } + } } accept_statement (ST_ASSOCIATE); |