diff options
Diffstat (limited to 'gcc/fortran/resolve.cc')
| -rw-r--r-- | gcc/fortran/resolve.cc | 82 |
1 files changed, 80 insertions, 2 deletions
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index c33bd17..d51301a 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1630,7 +1630,7 @@ was_declared (gfc_symbol *sym) if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous || a.codimension) + || a.asynchronous || a.codimension || a.subroutine) return 1; return 0; @@ -5880,6 +5880,7 @@ gfc_resolve_ref (gfc_expr *expr) int current_part_dimension, n_components, seen_part_dimension, dim; gfc_ref *ref, **prev, *array_ref; bool equal_length; + gfc_symbol *last_pdt = NULL; for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) @@ -5927,6 +5928,11 @@ gfc_resolve_ref (gfc_expr *expr) n_components = 0; array_ref = NULL; + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_DERIVED + && expr->symtree->n.sym->ts.u.derived->attr.pdt_type) + last_pdt = expr->symtree->n.sym->ts.u.derived; + for (ref = expr->ref; ref; ref = ref->next) { switch (ref->type) @@ -5984,6 +5990,38 @@ gfc_resolve_ref (gfc_expr *expr) } } + /* Sometimes the component in a component reference is that of the + pdt_template. Point to the component of pdt_type instead. This + ensures that the component gets a backend_decl in translation. */ + if (last_pdt) + { + gfc_component *cmp = last_pdt->components; + for (; cmp; cmp = cmp->next) + if (!strcmp (cmp->name, ref->u.c.component->name)) + { + ref->u.c.component = cmp; + break; + } + ref->u.c.sym = last_pdt; + } + + /* Convert pdt_templates, if necessary, and update 'last_pdt'. */ + if (ref->u.c.component->ts.type == BT_DERIVED) + { + if (ref->u.c.component->ts.u.derived->attr.pdt_template) + { + if (gfc_get_pdt_instance (ref->u.c.component->param_list, + &ref->u.c.component->ts.u.derived, + NULL) != MATCH_YES) + return false; + last_pdt = ref->u.c.component->ts.u.derived; + } + else if (ref->u.c.component->ts.u.derived->attr.pdt_type) + last_pdt = ref->u.c.component->ts.u.derived; + else + last_pdt = NULL; + } + n_components++; break; @@ -15604,6 +15642,31 @@ error: } +static gfc_symbol * containing_dt; + +/* Helper function for check_generic_tbp_ambiguity, which ensures that passed + arguments whose declared types are PDT instances only transmit the PASS arg + if they match the enclosing derived type. */ + +static bool +check_pdt_args (gfc_tbp_generic* t, const char *pass) +{ + gfc_formal_arglist *dummy_args; + if (pass && containing_dt != NULL && containing_dt->attr.pdt_type) + { + dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym); + while (dummy_args && strcmp (pass, dummy_args->sym->name)) + dummy_args = dummy_args->next; + gcc_assert (strcmp (pass, dummy_args->sym->name) == 0); + if (dummy_args->sym->ts.type == BT_CLASS + && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name, + containing_dt->name)) + return true; + } + return false; +} + + /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ static bool @@ -15661,6 +15724,17 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, pass2 = NULL; } + /* Care must be taken with pdt types and templates because the declared type + of the argument that is not 'no_pass' need not be the same as the + containing derived type. If this is the case, subject the argument to + the full interface check, even though it cannot be used in the type + bound context. */ + pass1 = check_pdt_args (t1, pass1) ? NULL : pass1; + pass2 = check_pdt_args (t2, pass2) ? NULL : pass2; + + if (containing_dt != NULL && containing_dt->attr.pdt_template) + pass1 = pass2 = NULL; + /* Compare the interfaces. */ if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, NULL, 0, pass1, pass2)) @@ -16108,8 +16182,10 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - /* The derived type is not a PDT template. Resolve as usual. */ + /* The derived type is not a PDT template or type. Resolve as usual. */ if (!resolve_bindings_derived->attr.pdt_template + && !(containing_dt && containing_dt->attr.pdt_type + && CLASS_DATA (me_arg)->ts.u.derived != containing_dt) && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived)) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of " @@ -16256,6 +16332,7 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_derived = derived; resolve_bindings_result = true; + containing_dt = derived; /* Needed for checks of PDTs. */ if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, &resolve_typebound_procedure); @@ -16263,6 +16340,7 @@ resolve_typebound_procedures (gfc_symbol* derived) if (derived->f2k_derived->tb_uop_root) gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, &resolve_typebound_user_op); + containing_dt = NULL; for (op = 0; op != GFC_INTRINSIC_OPS; ++op) { |