diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
-rw-r--r-- | gcc/fortran/resolve.c | 406 |
1 files changed, 293 insertions, 113 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 48bb6187c17..4e11fc6c311 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1858,29 +1858,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - if (gsym->ns->proc_name->attr.function - && gsym->ns->proc_name->as - && gsym->ns->proc_name->as->rank - && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); - - /* Non-assumed length character functions. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); - } - } - /* Differences in constant character lengths. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER) { @@ -1911,26 +1888,108 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&gsym->ns->proc_name->ts)); - /* Assumed shape arrays as dummy arguments. */ if (gsym->ns->proc_name->formal) { gfc_formal_arglist *arg = gsym->ns->proc_name->formal; for ( ; arg; arg = arg->next) - if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_SHAPE) + if (!arg->sym) + continue; + /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ + else if (arg->sym->attr.allocatable + || arg->sym->attr.asynchronous + || arg->sym->attr.optional + || arg->sym->attr.pointer + || arg->sym->attr.target + || arg->sym->attr.value + || arg->sym->attr.volatile_) + { + gfc_error ("Dummy argument '%s' of procedure '%s' at %L " + "has an attribute that requires an explicit " + "interface for this procedure", arg->sym->name, + sym->name, &sym->declared_at); + break; + } + /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_SHAPE) { gfc_error ("Procedure '%s' at %L with assumed-shape dummy " - "'%s' argument must have an explicit interface", + "argument '%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } - else if (arg->sym && arg->sym->attr.optional) + /* F2008, 12.4.2.2 (2c) */ + else if (arg->sym->attr.codimension) { - gfc_error ("Procedure '%s' at %L with optional dummy argument " + gfc_error ("Procedure '%s' at %L with coarray dummy argument " "'%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } + /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ + else if (false) /* TODO: is a parametrized derived type */ + { + gfc_error ("Procedure '%s' at %L with parametrized derived " + "type argument '%s' must have an explicit " + "interface", sym->name, &sym->declared_at, + arg->sym->name); + break; + } + /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ + else if (arg->sym->ts.type == BT_CLASS) + { + gfc_error ("Procedure '%s' at %L with polymorphic dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + } + + if (gsym->ns->proc_name->attr.function) + { + /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ + if (gsym->ns->proc_name->as + && gsym->ns->proc_name->as->rank + && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ + if (gsym->ns->proc_name->result->attr.pointer + || gsym->ns->proc_name->result->attr.allocatable) + gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " + "result must have an explicit interface", sym->name, + where); + + /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ + if (sym->ts.type == BT_CHARACTER + && gsym->ns->proc_name->ts.u.cl->length != NULL) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Nonconstant character-length function '%s' at %L " + "must have an explicit interface", sym->name, + &sym->declared_at); + } + } + } + + /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ + if (gsym->ns->proc_name->attr.elemental) + { + gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " + "interface", sym->name, &sym->declared_at); + } + + /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ + if (gsym->ns->proc_name->attr.is_bind_c) + { + gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " + "an explicit interface", sym->name, &sym->declared_at); } if (gfc_option.flag_whole_file == 1 @@ -2200,6 +2259,7 @@ is_external_proc (gfc_symbol *sym) && !(sym->attr.intrinsic || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer && !sym->attr.use_assoc && sym->name) return true; @@ -3615,11 +3675,11 @@ resolve_operator (gfc_expr *e) e->rank = op1->rank; if (e->shape == NULL) { - t = compare_shapes(op1, op2); + t = compare_shapes (op1, op2); if (t == FAILURE) e->shape = NULL; else - e->shape = gfc_copy_shape (op1->shape, op1->rank); + e->shape = gfc_copy_shape (op1->shape, op1->rank); } } else @@ -5160,6 +5220,43 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, } +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + if (class_ref) + *class_ref = NULL; + if (new_ref) + *new_ref = gfc_copy_ref (e->ref); + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if (ref->u.c.component->ts.type == BT_CLASS + || ref->u.c.component->ts.type == BT_DERIVED) + { + declared = ref->u.c.component->ts.u.derived; + if (class_ref) + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ @@ -5169,6 +5266,8 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; + gfc_symtree *st; + gfc_symbol *derived; gcc_assert (e->expr_type == EXPR_COMPCALL); genname = e->value.compcall.name; @@ -5236,6 +5335,19 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) return FAILURE; 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); + if (st) + e->value.compcall.tbp = st->n.tb; + return SUCCESS; } @@ -5343,38 +5455,6 @@ resolve_compcall (gfc_expr* e, const char **name) } -/* Get the ultimate declared type from an expression. In addition, - return the last class/derived type reference and the copy of the - reference list. */ -static gfc_symbol* -get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e) -{ - gfc_symbol *declared; - gfc_ref *ref; - - declared = NULL; - *class_ref = NULL; - *new_ref = gfc_copy_ref (e->ref); - for (ref = *new_ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - continue; - - if (ref->u.c.component->ts.type == BT_CLASS - || ref->u.c.component->ts.type == BT_DERIVED) - { - declared = ref->u.c.component->ts.u.derived; - *class_ref = ref; - } - } - - if (declared == NULL) - declared = e->symtree->n.sym->ts.u.derived; - - return declared; -} - /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ @@ -5395,6 +5475,9 @@ resolve_typebound_function (gfc_expr* e) if (st == NULL) return resolve_compcall (e, NULL); + if (resolve_ref (e) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); @@ -5416,18 +5499,16 @@ resolve_typebound_function (gfc_expr* e) /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ - resolve_compcall (e, &name); + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; ts = e->ts; /* Then convert the expression to a procedure pointer component call. */ e->value.function.esym = NULL; e->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - e->ref = new_ref; - } + if (new_ref) + e->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); @@ -5470,6 +5551,9 @@ resolve_typebound_subroutine (gfc_code *code) if (st == NULL) return resolve_typebound_call (code, NULL); + if (resolve_ref (code->expr1) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); @@ -5489,18 +5573,16 @@ resolve_typebound_subroutine (gfc_code *code) if (code->expr1->value.compcall.tbp->is_generic) genname = code->expr1->value.compcall.name; - resolve_typebound_call (code, &name); + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; ts = code->expr1->ts; /* Then convert the expression to a procedure pointer component call. */ code->expr1->value.function.esym = NULL; code->expr1->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - code->expr1->ref = new_ref; - } + if (new_ref) + code->expr1->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); @@ -6051,6 +6133,7 @@ resolve_deallocate_expr (gfc_expr *e) bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); + return FAILURE; } if (check_intent_in && sym->attr.intent == INTENT_IN) @@ -6125,8 +6208,11 @@ gfc_expr_to_initialize (gfc_expr *e) static gfc_try conformable_arrays (gfc_expr *e1, gfc_expr *e2) { + gfc_ref *tail; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* First compare rank. */ - if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + if (tail && e1->rank != tail->u.ar.as->rank) { gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", @@ -6143,15 +6229,15 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) for (i = 0; i < e1->rank; i++) { - if (e2->ref->u.ar.end[i]) + if (tail->u.ar.end[i]) { - mpz_set (s, e2->ref->u.ar.end[i]->value.integer); - mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.end[i]->value.integer); + mpz_sub (s, s, tail->u.ar.start[i]->value.integer); mpz_add_ui (s, s, 1); } else { - mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) @@ -6182,10 +6268,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6318,11 +6403,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or SOURCE=", sym->name, &e->where); + "type-spec or source-expr", sym->name, &e->where); goto failure; } @@ -6333,25 +6421,26 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (!code->expr3) + if (!code->expr3 || code->expr3->mold) { /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + gfc_expr *init_e = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = e->ts; + + if (ts.type == BT_DERIVED) + init_e = gfc_default_initializer (&ts); + /* FIXME: Use default init of dynamic type (cf. PR 44541). */ + else if (e->ts.type == BT_CLASS) + init_e = gfc_default_initializer (&ts.u.derived->components->ts); + + if (init_e) { gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; @@ -6503,8 +6592,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) - gfc_error ("Stat-variable at %L shall not be %sd within " - "the same %s statement", &stat->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Stat-variable at %L shall not be %sd within " + "the same %s statement", &stat->where, fcn, fcn); + break; + } + } } /* Check the errmsg variable. */ @@ -6532,8 +6642,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) - gfc_error ("Errmsg-variable at %L shall not be %sd within " - "the same %s statement", &errmsg->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Errmsg-variable at %L shall not be %sd within " + "the same %s statement", &errmsg->where, fcn, fcn); + break; + } + } } /* Check that an allocate-object appears only once in the statement. @@ -7137,7 +7268,7 @@ resolve_select_type (gfc_code *code) gfc_namespace *ns; int error = 0; - ns = code->ext.ns; + ns = code->ext.block.ns; gfc_resolve (ns); /* Check for F03:C813. */ @@ -7224,6 +7355,7 @@ resolve_select_type (gfc_code *code) else ns->code->next = new_st; code->op = EXEC_BLOCK; + code->ext.block.assoc = NULL; code->expr1 = code->expr2 = NULL; code->block = NULL; @@ -7967,10 +8099,11 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static void resolve_block_construct (gfc_code* code) { - /* Eventually, we may want to do some checks here or handle special stuff. - But so far the only thing we can do is resolving the local namespace. */ + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during gfc_resolve_symbol. */ - gfc_resolve (code->ext.ns); + /* Resolve the BLOCK's namespace. */ + gfc_resolve (code->ext.block.ns); } @@ -8291,7 +8424,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: - gfc_current_ns = code->ext.ns; + gfc_current_ns = code->ext.block.ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = ns; break; @@ -8455,7 +8588,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_BLOCK: - gfc_resolve (code->ext.ns); + gfc_resolve (code->ext.block.ns); break; case EXEC_DO: @@ -10694,6 +10827,14 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) + { + gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure && !sym->attr.vtype) @@ -10760,7 +10901,7 @@ resolve_fl_derived (gfc_symbol *sym) c->ts.u.cl = cl; } } - else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype) + else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') { gfc_error ("Interface '%s' of procedure pointer component " "'%s' at %L must be explicit", c->ts.interface->name, @@ -11004,6 +11145,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract + && !sym->attr.is_class && ensure_not_abstract (sym, super_type) == FAILURE) return FAILURE; @@ -11265,6 +11407,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.pure = ifc->attr.pure; sym->attr.elemental = ifc->attr.elemental; sym->attr.dimension = ifc->attr.dimension; + sym->attr.contiguous = ifc->attr.contiguous; sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; @@ -11297,6 +11440,31 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->attr.is_protected && !sym->attr.proc_pointer + && (sym->attr.procedure || sym->attr.external)) + { + if (sym->attr.external) + gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " + "at %L", &sym->declared_at); + else + gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " + "at %L", &sym->declared_at); + + return; + } + + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.pointer))) + { + gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape array", sym->name, + &sym->declared_at); + return; + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; @@ -11307,7 +11475,6 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal representation. This needs to be done before assigning a default type to avoid spurious warnings. */ @@ -11315,6 +11482,18 @@ resolve_symbol (gfc_symbol *sym) && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; + /* For associate names, resolve corresponding expression and make sure + they get their type-spec set this way. */ + if (sym->assoc) + { + gcc_assert (sym->attr.flavor == FL_VARIABLE); + if (gfc_resolve_expr (sym->assoc->target) != SUCCESS) + return; + + sym->ts = sym->assoc->target->ts; + gcc_assert (sym->ts.type != BT_UNKNOWN); + } + /* Assign default type to symbols that need one and don't have one. */ if (sym->ts.type == BT_UNKNOWN) { @@ -11344,6 +11523,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.dimension = sym->result->attr.dimension; sym->attr.pointer = sym->result->attr.pointer; sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; } } } |