diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
-rw-r--r-- | gcc/fortran/resolve.c | 160 |
1 files changed, 98 insertions, 62 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4e11fc6c311..2434be192d7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -905,7 +905,7 @@ resolve_structure_cons (gfc_expr *expr) && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || (comp->ts.type == BT_CLASS - && (CLASS_DATA (comp)->attr.pointer + && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; @@ -2440,10 +2440,11 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { char name[GFC_MAX_SYMBOL_LEN + 1]; char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; - int optional_arg = 0, is_pointer = 0; + int optional_arg = 0; gfc_try retval = SUCCESS; gfc_symbol *args_sym; gfc_typespec *arg_ts; + symbol_attribute arg_attr; if (args->expr->expr_type == EXPR_CONSTANT || args->expr->expr_type == EXPR_OP @@ -2460,8 +2461,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, and not necessarily that of the expr symbol (args_sym), because the actual expression could be a part-ref of the expr symbol. */ arg_ts = &(args->expr->ts); - - is_pointer = gfc_is_data_pointer (args->expr); + arg_attr = gfc_expr_attr (args->expr); if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { @@ -2504,7 +2504,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, else if (sym->intmod_sym_id == ISOCBINDING_LOC) { /* Make sure we have either the target or pointer attribute. */ - if (!args_sym->attr.target && !is_pointer) + if (!arg_attr.target && !arg_attr.pointer) { gfc_error_now ("Parameter '%s' to '%s' at %L must be either " "a TARGET or an associated pointer", @@ -2587,7 +2587,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } } } - else if (is_pointer + else if (arg_attr.pointer && is_scalar_expr_ptr (args->expr) != SUCCESS) { /* Case 1c, section 15.1.2.5, J3/04-007: an associated @@ -2622,6 +2622,13 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } + else if (arg_ts->type == BT_CLASS) + { + gfc_error_now ("Parameter '%s' to '%s' at %L must not be " + "polymorphic", args_sym->name, sym->name, + &(args->expr->where)); + retval = FAILURE; + } } } else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) @@ -4772,6 +4779,15 @@ resolve_variable (gfc_expr *e) sym->entry_id = current_entry_id + 1; } + /* If a symbol has been host_associated mark it. This is used latter, + to identify if aliasing is possible via host association. */ + if (sym->attr.flavor == FL_VARIABLE + && gfc_current_ns->parent + && (gfc_current_ns->parent == sym->ns + || (gfc_current_ns->parent->parent + && gfc_current_ns->parent->parent == sym->ns))) + sym->attr.host_assoc = 1; + resolve_procedure: if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) t = FAILURE; @@ -5320,10 +5336,11 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) if (matches) { e->value.compcall.tbp = g->specific; + genname = g->specific_st->name; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) - *name = g->specific_st->name; + *name = genname; goto success; } } @@ -5336,12 +5353,6 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) success: /* Make sure that we have the right specific instance for the name. */ - genname = e->value.compcall.tbp->u.specific->name; - - /* Is the symtree name a "unique name". */ - if (*genname == '@') - genname = e->value.compcall.tbp->u.specific->n.sym->name; - derived = get_declared_from_expr (NULL, NULL, e); st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); @@ -5468,10 +5479,38 @@ resolve_typebound_function (gfc_expr* e) gfc_ref *class_ref; gfc_symtree *st; const char *name; - const char *genname; gfc_typespec ts; + gfc_expr *expr; st = e->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = e->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && e->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : e->value.function.esym->name; + e->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (e, "$vptr"); + gfc_add_component_ref (e, name); + e->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_compcall (e, NULL); @@ -5492,11 +5531,6 @@ resolve_typebound_function (gfc_expr* e) c = gfc_find_component (declared, "$data", true, true); declared = c->ts.u.derived; - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (e->value.compcall.tbp->is_generic) - genname = e->value.compcall.name; - /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ if (resolve_compcall (e, &name) == FAILURE) @@ -5512,15 +5546,6 @@ resolve_typebound_function (gfc_expr* e) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (e, genname); - } gfc_add_component_ref (e, name); /* Recover the typespec for the expression. This is really only @@ -5543,11 +5568,39 @@ resolve_typebound_subroutine (gfc_code *code) gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; - const char *genname; const char *name; gfc_typespec ts; + gfc_expr *expr; st = code->expr1->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = code->expr1->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && code->expr1->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : code->expr1->value.function.esym->name; + code->expr1->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, name); + code->expr1->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_typebound_call (code, NULL); @@ -5555,7 +5608,7 @@ resolve_typebound_subroutine (gfc_code *code) return FAILURE; /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); + get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) @@ -5563,15 +5616,7 @@ resolve_typebound_subroutine (gfc_code *code) { gfc_free_ref_list (new_ref); return resolve_typebound_call (code, NULL); - } - - c = gfc_find_component (declared, "$data", true, true); - declared = c->ts.u.derived; - - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (code->expr1->value.compcall.tbp->is_generic) - genname = code->expr1->value.compcall.name; + } if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; @@ -5586,15 +5631,6 @@ resolve_typebound_subroutine (gfc_code *code) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (code->expr1, genname); - } gfc_add_component_ref (code->expr1, name); /* Recover the typespec for the expression. This is really only @@ -5776,7 +5812,7 @@ gfc_resolve_expr (gfc_expr *e) { expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); } /* This provides the opportunity for the length of constructors with @@ -5786,7 +5822,7 @@ gfc_resolve_expr (gfc_expr *e) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER here rather then add a duplicate test for it above. */ - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } @@ -6087,7 +6123,7 @@ resolve_deallocate_expr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; } else { @@ -6111,7 +6147,7 @@ resolve_deallocate_expr (gfc_expr *e) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; } else { @@ -6310,7 +6346,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; is_abstract = CLASS_DATA (sym)->attr.abstract; @@ -6348,7 +6384,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; dimension = CLASS_DATA (c)->attr.dimension; codimension = CLASS_DATA (c)->attr.codimension; is_abstract = CLASS_DATA (c)->attr.abstract; @@ -7496,7 +7532,7 @@ resolve_select_type (gfc_code *code) new_st->expr1->value.function.actual = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); - vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -9130,7 +9166,7 @@ build_default_init_expr (gfc_symbol *sym) { case BT_INTEGER: if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_init_set_si (init_expr->value.integer, + mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else { @@ -9140,7 +9176,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_REAL: - mpfr_init (init_expr->value.real); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -9170,7 +9205,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_COMPLEX: - mpc_init2 (init_expr->value.complex, mpfr_get_default_prec()); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -9318,7 +9352,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) { /* F03:C502. */ - if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) + if (sym->attr.class_ok + && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", CLASS_DATA (sym)->ts.u.derived->name, sym->name, @@ -10769,7 +10804,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false); + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -11084,7 +11119,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) { @@ -11096,7 +11131,8 @@ resolve_fl_derived (gfc_symbol *sym) /* C437. */ if (c->ts.type == BT_CLASS - && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable)) + && !(CLASS_DATA (c)->attr.class_pointer + || CLASS_DATA (c)->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); |