diff options
Diffstat (limited to 'gcc/fortran/resolve.cc')
| -rw-r--r-- | gcc/fortran/resolve.cc | 1155 |
1 files changed, 985 insertions, 170 deletions
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f03708e..db6b52f 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -533,7 +533,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) } } } - + if (sym) + sym->formal_resolved = 1; gfc_current_ns = orig_current_ns; } @@ -1629,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; @@ -2029,7 +2030,7 @@ static bool resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, bool no_formal_args) { - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_symtree *parent_st; gfc_expr *e; gfc_component *comp; @@ -2294,6 +2295,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, goto cleanup; } + if (e->expr_type == EXPR_VARIABLE + && e->ts.type == BT_PROCEDURE + && no_formal_args + && sym->attr.flavor == FL_PROCEDURE + && sym->attr.if_source == IFSRC_UNKNOWN + && !sym->attr.external + && !sym->attr.intrinsic + && !sym->attr.artificial + && !sym->ts.interface) + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Procedure %qs at %L used as actual argument but " + "does neither have an explicit interface nor the " + "EXTERNAL attribute", sym->name, &e->where); + else + { + gfc_error ("Procedure %qs at %L used as actual argument but " + "does neither have an explicit interface nor the " + "EXTERNAL attribute", sym->name, &e->where); + goto cleanup; + } + } + first_actual_arg = false; } @@ -3472,7 +3497,7 @@ resolve_function (gfc_expr *expr) &expr->where, &sym->formal_at); } } - else + else if (!sym->formal_resolved) { gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual); sym->formal_at = expr->where; @@ -3918,10 +3943,153 @@ found: } + +static bool +check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e, + gfc_code *c, gfc_namespace *ns) +{ + locus *here; + + /* If the type has been imported then its vtype functions are OK. */ + if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype) + return true; + + if (e) + here = &e->where; + else + here = &c->loc; + + if (s && !s->import_only) + s = gfc_find_symtree (ns->sym_root, sym->name); + + if (ns->import_state == IMPORT_ONLY + && sym->ns != ns + && (!s || !s->import_only)) + { + gfc_error ("F2018: C8102 %qs at %L is host associated but does not " + "appear in an IMPORT or IMPORT, ONLY list", sym->name, here); + return false; + } + else if (ns->import_state == IMPORT_NONE + && sym->ns != ns) + { + gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that " + "has IMPORT, NONE", sym->name, here); + return false; + } + return true; +} + + +static bool +check_import_status (gfc_expr *e) +{ + gfc_symtree *st; + gfc_ref *ref; + gfc_symbol *sym, *der; + gfc_namespace *ns = gfc_current_ns; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + case EXPR_SUBSTRING: + sym = e->symtree ? e->symtree->n.sym : NULL; + + /* Check the symbol itself. */ + if (sym + && !(ns->proc_name + && (sym == ns->proc_name)) + && !check_sym_import_status (sym, e->symtree, e, NULL, ns)) + return false; + + /* Check the declared derived type. */ + if (sym->ts.type == BT_DERIVED) + { + der = sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym)) + { + der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived + : sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + /* Check the declared derived types of component references. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + { + gfc_component *c = ref->u.c.component; + if (c->ts.type == BT_DERIVED) + { + der = c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c)) + { + der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived + : c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + } + + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + /* Check the declared derived type. */ + if (e->ts.type == BT_DERIVED) + { + der = e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e)) + { + der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived + : e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + break; + +/* Either not applicable or resolved away + case EXPR_OP: + case EXPR_UNKNOWN: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_COMPCALL: + case EXPR_PPC: */ + + default: + break; + } + + return true; +} + + /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ + static bool resolve_call (gfc_code *c) { @@ -4033,7 +4201,7 @@ resolve_call (gfc_code *c) &c->loc, &csym->formal_at); } } - else + else if (!csym->formal_resolved) { gfc_get_formal_from_actual_arglist (csym, c->ext.actual); csym->formal_at = c->loc; @@ -4079,6 +4247,11 @@ resolve_call (gfc_code *c) "Using subroutine %qs at %L is deprecated", c->resolved_sym->name, &c->loc); + csym = c->resolved_sym ? c->resolved_sym : csym; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym + && csym != gfc_current_ns->proc_name) + return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns); + return t; } @@ -4806,34 +4979,6 @@ resolve_operator (gfc_expr *e) return false; } } - - /* coranks have to be equal or one has to be zero to be combinable. */ - if (op1->corank == op2->corank || (op1->corank != 0 && op2->corank == 0)) - { - e->corank = op1->corank; - /* Only do this, when regular array has not set a shape yet. */ - if (e->shape == NULL) - { - if (op1->corank != 0) - { - e->shape = gfc_copy_shape (op1->shape, op1->corank); - } - } - } - else if (op1->corank == 0 && op2->corank != 0) - { - e->corank = op2->corank; - /* Only do this, when regular array has not set a shape yet. */ - if (e->shape == NULL) - e->shape = gfc_copy_shape (op2->shape, op2->corank); - } - else - { - gfc_error ("Inconsistent coranks for operator at %L and %L", - &op1->where, &op2->where); - return false; - } - break; case INTRINSIC_PARENTHESES: @@ -4868,6 +5013,76 @@ simplify_op: return t; } +static bool +resolve_conditional (gfc_expr *expr) +{ + gfc_expr *condition, *true_expr, *false_expr; + + condition = expr->value.conditional.condition; + true_expr = expr->value.conditional.true_expr; + false_expr = expr->value.conditional.false_expr; + + if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr) + || !gfc_resolve_expr (false_expr)) + return false; + + if (condition->ts.type != BT_LOGICAL || condition->rank != 0) + { + gfc_error ( + "Condition in conditional expression must be a scalar logical at %L", + &condition->where); + return false; + } + + if (true_expr->ts.type != false_expr->ts.type) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same declared type", + &true_expr->where, &false_expr->where); + return false; + } + + if (true_expr->ts.kind != false_expr->ts.kind) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same kind parameter", + &true_expr->where, &false_expr->where); + return false; + } + + if (true_expr->rank != false_expr->rank) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same rank", + &true_expr->where, &false_expr->where); + return false; + } + + /* TODO: support more data types for conditional expressions */ + if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL + && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX + && true_expr->ts.type != BT_CHARACTER) + { + gfc_error ( + "Sorry, only integer, logical, real, complex and character types are " + "currently supported for conditional expressions at %L", + &expr->where); + return false; + } + + /* TODO: support arrays in conditional expressions */ + if (true_expr->rank > 0) + { + gfc_error ("Sorry, array is currently unsupported for conditional " + "expressions at %L", + &expr->where); + return false; + } + + expr->ts = true_expr->ts; + expr->rank = true_expr->rank; + return true; +} /************** Array resolution subroutines **************/ @@ -5751,14 +5966,49 @@ gfc_resolve_substring_charlen (gfc_expr *e) } +/* Convert an array reference to an array element so that PDT KIND and LEN + or inquiry references are always scalar. */ + +static void +reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref) +{ + gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + int dim; + + array_ref->u.ar.type = AR_ELEMENT; + expr->rank = 0; + /* Suppress the runtime bounds check. */ + expr->no_bounds_check = 1; + for (dim = 0; dim < array_ref->u.ar.dimen; dim++) + { + array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; + if (array_ref->u.ar.start[dim]) + gfc_free_expr (array_ref->u.ar.start[dim]); + + if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim]) + array_ref->u.ar.start[dim] + = gfc_copy_expr (array_ref->u.ar.as->lower[dim]); + else + array_ref->u.ar.start[dim] = gfc_copy_expr (unity); + + if (array_ref->u.ar.end[dim]) + gfc_free_expr (array_ref->u.ar.end[dim]); + if (array_ref->u.ar.stride[dim]) + gfc_free_expr (array_ref->u.ar.stride[dim]); + } + gfc_free_expr (unity); +} + + /* Resolve subtype references. */ bool gfc_resolve_ref (gfc_expr *expr) { - int current_part_dimension, n_components, seen_part_dimension, dim; + int current_part_dimension, n_components, seen_part_dimension; 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) @@ -5806,6 +6056,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) @@ -5863,6 +6118,46 @@ 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; + } + + /* The F08 standard requires(See R425, R431, R435, and in particular + Note 6.7) that a PDT parameter reference be a scalar even if + the designator is an array." */ + if (array_ref && last_pdt && last_pdt->attr.pdt_type + && (ref->u.c.component->attr.pdt_kind + || ref->u.c.component->attr.pdt_len)) + reset_array_ref_to_scalar (expr, array_ref); + n_components++; break; @@ -5875,27 +6170,7 @@ gfc_resolve_ref (gfc_expr *expr) if (ref->u.i == INQUIRY_LEN && array_ref && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length) || expr->ts.type == BT_INTEGER)) - { - array_ref->u.ar.type = AR_ELEMENT; - expr->rank = 0; - /* INQUIRY_LEN is not evaluated from the rest of the expr - but directly from the string length. This means that setting - the array indices to one does not matter but might trigger - a runtime bounds error. Suppress the check. */ - expr->no_bounds_check = 1; - for (dim = 0; dim < array_ref->u.ar.dimen; dim++) - { - array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; - if (array_ref->u.ar.start[dim]) - gfc_free_expr (array_ref->u.ar.start[dim]); - array_ref->u.ar.start[dim] - = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - if (array_ref->u.ar.end[dim]) - gfc_free_expr (array_ref->u.ar.end[dim]); - if (array_ref->u.ar.stride[dim]) - gfc_free_expr (array_ref->u.ar.stride[dim]); - } - } + reset_array_ref_to_scalar (expr, array_ref); break; } @@ -6069,8 +6344,8 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2) gfc_expression_rank (op2); return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank) - && (op1->corank == 0 || op2->corank == 0 - || op1->corank == op2->corank); + && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank + || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2))); } /* Resolve a variable expression. */ @@ -7819,6 +8094,7 @@ fixup_unique_dummy (gfc_expr *e) e->symtree = st; } + /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ @@ -7858,6 +8134,10 @@ gfc_resolve_expr (gfc_expr *e) t = resolve_operator (e); break; + case EXPR_CONDITIONAL: + t = resolve_conditional (e); + break; + case EXPR_FUNCTION: case EXPR_VARIABLE: @@ -7946,6 +8226,9 @@ gfc_resolve_expr (gfc_expr *e) && UNLIMITED_POLY (e->symtree->n.sym)) e->do_not_resolve_again = 1; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET) + t = check_import_status (e); + return t; } @@ -8178,7 +8461,20 @@ check_default_none_expr (gfc_expr **e, int *, void *data) break; ns2 = ns2->parent; } - if (ns2 != NULL) + + /* A DO CONCURRENT iterator cannot appear in a locality spec. */ + if (sym->ns->code->ext.concur.forall_iterator) + { + gfc_forall_iterator *iter + = sym->ns->code->ext.concur.forall_iterator; + for (; iter; iter = iter->next) + if (iter->var->symtree + && strcmp(sym->name, iter->var->symtree->name) == 0) + return 0; + } + + /* A named constant is not a variable, so skip test. */ + if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER) { gfc_error ("Variable %qs at %L not specified in a locality spec " "of DO CONCURRENT at %L but required due to " @@ -8458,6 +8754,8 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns) plist = &((*plist)->next); } } + + delete data.sym_hash; } /* Resolve a list of FORALL iterators. The FORALL index-name is constrained @@ -8739,8 +9037,25 @@ static bool conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; + bool scalar; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* If MOLD= is present and is not scalar, and the allocate-object has an + explicit-shape-spec, the ranks need not agree. This may be unintended, + so let's emit a warning if -Wsurprising is given. */ + scalar = !tail || tail->type == REF_COMPONENT; + if (e1->mold && e1->rank > 0 + && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL))) + { + if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank)) + gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d " + "but MOLD= expression at %L has rank %d", + &e2->where, scalar ? 0 : tail->u.ar.as->rank, + &e1->where, e1->rank); + return true; + } + /* First compare rank. */ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) || (!tail && e1->rank != e2->rank)) @@ -9484,8 +9799,10 @@ done_errmsg: /* Resolving the expr3 in the loop over all objects to allocate would execute loop invariant code for each loop item. Therefore do it just once here. */ + mpz_t nelem; if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_DERIVED) + && code->expr3->ts.type == BT_DERIVED + && !(code->expr3->ref && gfc_array_size (code->expr3, &nelem))) { /* Default initialization via MOLD (non-polymorphic). */ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); @@ -10475,6 +10792,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) /* If the target is a good class object, so is the associate variable. */ if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) sym->attr.class_ok = 1; + + /* If the target is a contiguous pointer, so is the associate variable. */ + if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous) + sym->attr.contiguous = 1; } @@ -10582,6 +10903,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) int rank = 0, corank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; + gfc_code *old_code = code; ns = code->ext.block.ns; if (code->expr2) @@ -10801,6 +11123,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ref = gfc_copy_ref (ref); } + gfc_expr *orig_expr1 = code->expr1; + /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; @@ -10828,7 +11152,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) for (body = code->block; body; body = body->block) { gfc_symbol *vtab; - gfc_expr *e; c = body->ext.block.case_list; /* Generate an index integer expression for address of the @@ -10836,6 +11159,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) is stored in c->high and is used to resolve intrinsic cases. */ if (c->ts.type != BT_UNKNOWN) { + gfc_expr *e; if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) { vtab = gfc_find_derived_vtab (c->ts.u.derived); @@ -10869,10 +11193,24 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) that does precisely this here (instead of using the 'global' one). */ + /* First check the derived type import status. */ + if (gfc_current_ns->import_state != IMPORT_NOT_SET + && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, + c->ts.u.derived->name); + if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code, + gfc_current_ns)) + error++; + } + + const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1); if (c->ts.type == BT_CLASS) - sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_class_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_DERIVED) - sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_type_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_CHARACTER) { HOST_WIDE_INT charlen = 0; @@ -10880,12 +11218,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind, + var_name); } else - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), - c->ts.kind); + snprintf (name, sizeof (name), "__tmp_%s_%d_%s", + gfc_basic_typename (c->ts.type), c->ts.kind, var_name); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); @@ -11484,6 +11823,109 @@ resolve_lock_unlock_event (gfc_code *code) } } +static void +resolve_team_argument (gfc_expr *team) +{ + gfc_resolve_expr (team); + if (team->rank != 0 || team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument at %L must be a scalar expression " + "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV", + &team->where); + } +} + +static void +resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0 + || e->expr_type != EXPR_VARIABLE)) + gfc_error ("%s argument at %L must be a scalar %s variable of at least " + "kind %d", name, &e->where, gfc_basic_typename (exp_type), + exp_kind); +} + +void +gfc_resolve_sync_stat (struct sync_stat *sync_stat) +{ + resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat); + resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER, + gfc_default_character_kind, + sync_stat->errmsg); +} + +static void +resolve_scalar_argument (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0)) + gfc_error ("%s argument at %L must be a scalar %s of at least kind %d", + name, &e->where, gfc_basic_typename (exp_type), exp_kind); +} + +static void +resolve_form_team (gfc_code *code) +{ + resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind, + code->expr1); + resolve_team_argument (code->expr2); + resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind, + code->expr3); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void resolve_block_construct (gfc_code *); + +static void +resolve_change_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.block.sync_stat); + resolve_block_construct (code); + /* Map the coarray bounds as selected. */ + for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next) + if (a->ar) + { + gfc_array_spec *src = a->ar->as, *dst; + if (a->st->n.sym->ts.type == BT_CLASS) + dst = CLASS_DATA (a->st->n.sym)->as; + else + dst = a->st->n.sym->as; + dst->corank = src->corank; + dst->cotype = src->cotype; + for (int i = 0; i < src->corank; ++i) + { + dst->lower[dst->rank + i] = src->lower[i]; + dst->upper[dst->rank + i] = src->upper[i]; + src->lower[i] = src->upper[i] = nullptr; + } + gfc_free_array_spec (src); + free (a->ar); + a->ar = nullptr; + dst->resolved = false; + gfc_resolve_array_spec (dst, 0); + } +} + +static void +resolve_sync_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void +resolve_end_team (gfc_code *code) +{ + gfc_resolve_sync_stat (&code->ext.sync_stat); +} static void resolve_critical (gfc_code *code) @@ -11493,6 +11935,8 @@ resolve_critical (gfc_code *code) char name[GFC_MAX_SYMBOL_LEN]; static int serial = 0; + gfc_resolve_sync_stat (&code->ext.sync_stat); + if (flag_coarray != GFC_FCOARRAY_LIB) return; @@ -11616,8 +12060,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (code->here == label) { - gfc_warning (0, - "Branch at %L may result in an infinite loop", &code->loc); + gfc_warning (0, "Branch at %L may result in an infinite loop", + &code->loc); return; } @@ -11640,6 +12084,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code) && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_CHANGE_TEAM + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct " + "for label at %L", &code->loc, &label->where); } return; @@ -11809,11 +12257,10 @@ static void gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) { int n; + gfc_symbol *forall_index; for (n = 0; n < nvar; n++) { - gfc_symbol *forall_index; - forall_index = var_expr[n]->symtree->n.sym; /* Check whether the assignment target is one of the FORALL index @@ -11827,8 +12274,12 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) /* If one of the FORALL index variables doesn't appear in the assignment variable, then there could be a many-to-one assignment. Emit a warning rather than an error because the - mask could be resolving this problem. */ - if (!find_forall_index (code->expr1, forall_index, 0)) + mask could be resolving this problem. + DO NOT emit this warning for DO CONCURRENT - reduction-like + many-to-one assignments are semantically valid (formalized with + the REDUCE locality-spec in Fortran 2023). */ + if (!find_forall_index (code->expr1, forall_index, 0) + && !gfc_do_concurrent_flag) gfc_warning (0, "The FORALL with index %qs is not used on the " "left side of the assignment at %L and so might " "cause multiple assignment to this object", @@ -11948,7 +12399,7 @@ gfc_count_forall_iterators (gfc_code *code) int max_iters, sub_iters, current_iters; gfc_forall_iterator *fa; - gcc_assert(code->op == EXEC_FORALL); + gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT); max_iters = 0; current_iters = 0; @@ -11959,7 +12410,7 @@ gfc_count_forall_iterators (gfc_code *code) while (code) { - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { sub_iters = gfc_count_forall_iterators (code); if (sub_iters > max_iters) @@ -11972,8 +12423,160 @@ gfc_count_forall_iterators (gfc_code *code) } -/* Given a FORALL construct, first resolve the FORALL iterator, then call - gfc_resolve_forall_body to resolve the FORALL body. */ +/* Given a FORALL construct. + 1) Resolve the FORALL iterator. + 2) Check for shadow index-name(s) and update code block. + 3) call gfc_resolve_forall_body to resolve the FORALL body. */ + +/* Custom recursive expression walker that replaces symbols. + This ensures we visit ALL expressions including those in array subscripts. */ + +static void +replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!expr) + return; + + /* Check if this is a variable reference to replace */ + if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym) + { + expr->symtree = new_st; + expr->ts = new_st->n.sym->ts; + } + + /* Walk through reference chain (array subscripts, substrings, etc.) */ + for (gfc_ref *ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + gfc_array_ref *ar = &ref->u.ar; + for (int i = 0; i < ar->dimen; i++) + { + replace_in_expr_recursive (ar->start[i], old_sym, new_st); + replace_in_expr_recursive (ar->end[i], old_sym, new_st); + replace_in_expr_recursive (ar->stride[i], old_sym, new_st); + } + } + else if (ref->type == REF_SUBSTRING) + { + replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st); + replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st); + } + } + + /* Walk through sub-expressions based on expression type */ + switch (expr->expr_type) + { + case EXPR_OP: + replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st); + replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st); + break; + + case EXPR_FUNCTION: + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + replace_in_expr_recursive (c->expr, old_sym, new_st); + if (c->iterator) + { + replace_in_expr_recursive (c->iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->iterator->step, old_sym, new_st); + } + } + break; + + default: + break; + } +} + + +/* Walk code tree and replace all variable references */ + +static void +replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!code) + return; + + for (gfc_code *c = code; c; c = c->next) + { + /* Replace in expressions associated with this code node */ + replace_in_expr_recursive (c->expr1, old_sym, new_st); + replace_in_expr_recursive (c->expr2, old_sym, new_st); + replace_in_expr_recursive (c->expr3, old_sym, new_st); + replace_in_expr_recursive (c->expr4, old_sym, new_st); + + /* Handle special code types with additional expressions */ + switch (c->op) + { + case EXEC_DO: + if (c->ext.iterator) + { + replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st); + } + break; + + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXEC_SELECT: + for (gfc_code *b = c->block; b; b = b->block) + { + for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next) + { + replace_in_expr_recursive (cp->low, old_sym, new_st); + replace_in_expr_recursive (cp->high, old_sym, new_st); + } + replace_in_code_recursive (b->next, old_sym, new_st); + } + break; + + case EXEC_FORALL: + case EXEC_DO_CONCURRENT: + for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next) + { + replace_in_expr_recursive (fa->start, old_sym, new_st); + replace_in_expr_recursive (fa->end, old_sym, new_st); + replace_in_expr_recursive (fa->stride, old_sym, new_st); + } + /* Don't recurse into nested FORALL/DO CONCURRENT bodies here, + they'll be handled separately */ + break; + + default: + break; + } + + /* Recurse into blocks */ + if (c->block) + replace_in_code_recursive (c->block->next, old_sym, new_st); + } +} + + +/* Replace all references to outer_sym with shadow_st in the given code. */ + +static void +gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym, + gfc_symtree *shadow_st) +{ + /* Use custom recursive walker to ensure we visit ALL expressions */ + replace_in_code_recursive (*code_ptr, outer_sym, shadow_st); +} + static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) @@ -11983,14 +12586,21 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static int nvar = 0; int i, old_nvar, tmp; gfc_forall_iterator *fa; + bool shadow = false; old_nvar = nvar; - if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) + /* Only warn about obsolescent FORALL, not DO CONCURRENT */ + if (code->op == EXEC_FORALL + && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) return; /* Start to resolve a FORALL construct */ - if (forall_save == 0) + /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level. + forall_save==0 means we're not nested in a FORALL in the current scope, + but nvar==0 ensures we're not nested in a parent scope either (prevents + double allocation when FORALL is nested inside DO CONCURRENT). */ + if (forall_save == 0 && nvar == 0) { /* Count the total number of FORALL indices in the nested FORALL construct in order to allocate the VAR_EXPR with proper size. */ @@ -12000,11 +12610,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) var_expr = XCNEWVEC (gfc_expr *, total_var); } - /* The information about FORALL iterator, including FORALL indices start, end - and stride. An outer FORALL indice cannot appear in start, end or stride. */ + /* The information about FORALL iterator, including FORALL indices start, + end and stride. An outer FORALL indice cannot appear in start, end or + stride. Check for a shadow index-name. */ for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) { - /* Fortran 20008: C738 (R753). */ + /* Fortran 2008: C738 (R753). */ if (fa->var->ref && fa->var->ref->type == REF_ARRAY) { gfc_error ("FORALL index-name at %L must be a scalar variable " @@ -12013,14 +12624,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) } /* Check if any outer FORALL index name is the same as the current - one. */ + one. Skip this check if the iterator is a shadow variable (from + DO CONCURRENT type spec) which may not have a symtree yet. */ for (i = 0; i < nvar; i++) { - if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) + if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree + && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) gfc_error ("An outer FORALL construct already has an index " "with this name %L", &fa->var->where); } + if (fa->shadow) + shadow = true; + /* Record the current FORALL index. */ var_expr[nvar] = gfc_copy_expr (fa->var); @@ -12030,6 +12646,47 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) gcc_assert (nvar <= total_var); } + /* Need to walk the code and replace references to the index-name with + references to the shadow index-name. This must be done BEFORE resolving + the body so that resolution uses the correct shadow variables. */ + if (shadow) + { + /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */ + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) + { + if (fa->shadow) + { + gfc_symtree *shadow_st; + const char *shadow_name_str; + char *outer_name; + + /* fa->var now points to the shadow variable "_name". */ + shadow_name_str = fa->var->symtree->name; + shadow_st = fa->var->symtree; + + if (shadow_name_str[0] != '_') + gfc_internal_error ("Expected shadow variable name to start with _"); + + outer_name = (char *) alloca (strlen (shadow_name_str)); + strcpy (outer_name, shadow_name_str + 1); + + /* Find the ITERATOR symbol in the current namespace. + This is the local DO CONCURRENT variable that body expressions reference. */ + gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name); + + if (!iter_st) + /* No iterator variable found - this shouldn't happen */ + continue; + + gfc_symbol *iter_sym = iter_st->n.sym; + + /* Walk the FORALL/DO CONCURRENT body and replace all references. */ + if (code->block && code->block->next) + gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st); + } + } + } + /* Resolve the FORALL body. */ gfc_resolve_forall_body (code, nvar, var_expr); @@ -13276,23 +13933,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } -static bool -check_team (gfc_expr *team, const char *intrinsic) -{ - if (team->rank != 0 - || team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument to %qs at %L must be a scalar expression " - "of type TEAM_TYPE", intrinsic, &team->where); - return false; - } - - return true; -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -13316,11 +13956,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) forall_save = forall_flag; do_concurrent_save = gfc_do_concurrent_flag; - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { - forall_flag = 1; + if (code->op == EXEC_FORALL) + forall_flag = 1; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 1; gfc_resolve_forall (code, ns, forall_save); - forall_flag = 2; + if (code->op == EXEC_FORALL) + forall_flag = 2; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 2; } else if (code->op == EXEC_OMP_METADIRECTIVE) for (gfc_omp_variant *variant @@ -13481,22 +14127,19 @@ start: break; case EXEC_FORM_TEAM: - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) - gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " - "a scalar INTEGER", &code->expr1->where); - check_team (code->expr2, "FORM TEAM"); + resolve_form_team (code); break; case EXEC_CHANGE_TEAM: - check_team (code->expr1, "CHANGE TEAM"); + resolve_change_team (code); break; case EXEC_END_TEAM: + resolve_end_team (code); break; case EXEC_SYNC_TEAM: - check_team (code->expr1, "SYNC TEAM"); + resolve_sync_team (code); break; case EXEC_ENTRY: @@ -14233,6 +14876,13 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init) gfc_code *init_st; gfc_namespace *ns = sym->ns; + if (sym->attr.function && sym->result == sym + && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_free_expr (init); + return; + } + /* Search for the function namespace if this is a contained function without an explicit result. */ if (sym->attr.function && sym == sym->result @@ -14971,6 +15621,39 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) return false; } + /* F2018:C1585: "The function result of a pure function shall not be both + polymorphic and allocatable, or have a polymorphic allocatable ultimate + component." */ + if (sym->attr.pure && sym->result && sym->ts.u.derived) + { + if (sym->ts.type == BT_CLASS + && sym->attr.class_ok + && CLASS_DATA (sym->result) + && CLASS_DATA (sym->result)->attr.allocatable) + { + gfc_error ("Result variable %qs of pure function at %L is " + "polymorphic allocatable", + sym->result->name, &sym->result->declared_at); + return false; + } + + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components) + { + gfc_component *c = sym->ts.u.derived->components; + for (; c; c = c->next) + if (c->ts.type == BT_CLASS + && CLASS_DATA (c) + && CLASS_DATA (c)->attr.allocatable) + { + gfc_error ("Result variable %qs of pure function at %L has " + "polymorphic allocatable component %qs", + sym->result->name, &sym->result->declared_at, + c->name); + return false; + } + } + } + if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) { gfc_formal_arglist *curr_arg; @@ -15155,7 +15838,7 @@ check_formal: static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { - gfc_finalizer* list; + gfc_finalizer *list, *pdt_finalizers = NULL; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; @@ -15185,6 +15868,41 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) return true; } + /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of + the template. If the finalizers field has the same value, it needs to be + supplied with finalizers of the same pdt_type. */ + if (derived->attr.pdt_type + && derived->template_sym + && derived->template_sym->f2k_derived + && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers) + && derived->f2k_derived->finalizers == pdt_finalizers) + { + gfc_finalizer *tmp = NULL; + derived->f2k_derived->finalizers = NULL; + prev_link = &derived->f2k_derived->finalizers; + for (list = pdt_finalizers; list; list = list->next) + { + gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym); + if (args->sym + && args->sym->ts.type == BT_DERIVED + && args->sym->ts.u.derived + && !strcmp (args->sym->ts.u.derived->name, derived->name)) + { + tmp = gfc_get_finalizer (); + *tmp = *list; + tmp->next = NULL; + if (*prev_link) + { + (*prev_link)->next = tmp; + prev_link = &tmp; + } + else + *prev_link = tmp; + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + } + } + } + /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ @@ -15241,7 +15959,8 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) } /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + if (!derived->attr.pdt_template + && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); @@ -15296,7 +16015,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) + if (dummy_args && !derived->attr.pdt_template) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); @@ -15344,9 +16063,13 @@ error: " rank finalizer has been declared", derived->name, &derived->declared_at); - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); + if (!derived->attr.pdt_template) + { + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym) + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + } if (finalizable) *finalizable = true; @@ -15355,6 +16078,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 @@ -15412,6 +16160,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)) @@ -15627,10 +16386,14 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, /* Preempt 'gfc_check_new_interface' for submodules, where the mechanism for handling module procedures winds up resolving - operator interfaces twice and would otherwise cause an error. */ + operator interfaces twice and would otherwise cause an error. + Likewise, new instances of PDTs can cause the operator inter- + faces to be resolved multiple times. */ for (intr = derived->ns->op[op]; intr; intr = intr->next) if (intr->sym == target_proc - && target_proc->attr.used_in_submodule) + && (target_proc->attr.used_in_submodule + || derived->attr.pdt_type + || derived->attr.pdt_template)) return true; if (!gfc_check_new_interface (derived->ns->op[op], @@ -15859,8 +16622,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 " @@ -16007,6 +16772,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); @@ -16014,6 +16780,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) { @@ -16236,6 +17003,26 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template + && !sym->attr.pdt_type && !sym->attr.pdt_template + && !(gfc_get_derived_super_type (sym) + && (gfc_get_derived_super_type (sym)->attr.pdt_type + || gfc_get_derived_super_type (sym)->attr.pdt_template))) + { + gfc_actual_arglist *type_spec_list; + if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived, + &type_spec_list) + != MATCH_YES) + return false; + gfc_free_actual_arglist (c->param_list); + c->param_list = type_spec_list; + if (!sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + } + else if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type + && !sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + if (c->attr.proc_pointer && c->ts.interface) { gfc_symbol *ifc = c->ts.interface; @@ -16430,27 +17217,30 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); + " inherited type-bound procedure", + c->name, sym->name, &c->loc); return false; } if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) - { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } + && !c->ts.deferred) + { + if (sym->attr.pdt_template || c->attr.pdt_string) + gfc_correct_parm_expr (sym, &c->ts.u.cl->length); + + if (c->ts.u.cl->length == NULL + || !resolve_charlen(c->ts.u.cl) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + return false; + } if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER) - { + { if (!c->ts.u.cl->length->error) { gfc_error ("Character length expression of component %qs at %L " @@ -16467,8 +17257,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->attr.pointer && !c->attr.allocatable) { gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); return false; } @@ -16483,14 +17273,14 @@ resolve_component (gfc_component *c, gfc_symbol *sym) sprintf (name, "_%s_length", c->name); strlen = gfc_find_component (sym, name, true, true, NULL); if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } } if (c->ts.type == BT_DERIVED @@ -16500,27 +17290,27 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) return false; if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) { gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); + "type %s", c->name, &c->loc, sym->name); return false; } if (sym->attr.sequence) { if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { + { gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } } if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) @@ -16528,7 +17318,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) else if (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->ts.u.derived->attr.generic) CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); /* If an allocatable component derived type is of the same type as the enclosing derived type, we need a vtable generating so that @@ -16541,10 +17331,10 @@ resolve_component (gfc_component *c, gfc_symbol *sym) derived type list; even in formal namespaces, where derived type pointer components might not have been declared. */ if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) add_dt_to_dt_list (c->ts.u.derived); if (c->as && c->as->type != AS_DEFERRED @@ -16552,8 +17342,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) return false; if (c->initializer && !sym->attr.vtype @@ -16729,8 +17519,8 @@ resolve_fl_derived0 (gfc_symbol *sym) return false; /* Now add the caf token field, where needed. */ - if (flag_coarray != GFC_FCOARRAY_NONE - && !sym->attr.is_class && !sym->attr.vtype) + if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class + && !sym->attr.vtype) { for (c = sym->components; c; c = c->next) if (!c->attr.dimension && !c->attr.codimension @@ -17355,6 +18145,7 @@ skip_interfaces: /* F2008, C530. */ if (sym->attr.contiguous + && !sym->attr.associate_var && (!class_attr.dimension || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK && !class_attr.pointer))) @@ -17926,17 +18717,30 @@ skip_interfaces: } /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate + if ((sym->attr.threadprivate || sym->attr.omp_groupprivate) && !(sym->attr.save || sym->attr.data || sym->attr.in_common) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL || (sym->ns->proc_name->attr.flavor != FL_MODULE && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + { + if (sym->attr.threadprivate) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + else + gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE " + "attribute", sym->name, &sym->declared_at); + } + + if (sym->attr.omp_groupprivate && sym->value) + gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an " + "initializer", sym->name, &sym->declared_at); /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target + if ((sym->attr.omp_declare_target + || sym->attr.omp_declare_target_link + || sym->attr.omp_declare_target_local) + && !sym->attr.omp_groupprivate /* already warned. */ && sym->attr.flavor == FL_VARIABLE && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) @@ -17969,16 +18773,16 @@ skip_interfaces: || (a->dummy && !a->pointer && a->intent == INTENT_OUT && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) apply_default_init (sym); + else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc + && sym->result) + /* Default initialization for function results. */ + apply_default_init (sym->result); else if (a->function && sym->result && a->access != ACCESS_PRIVATE && (sym->ts.u.derived->attr.alloc_comp || sym->ts.u.derived->attr.pointer_comp)) /* Mark the result symbol to be referenced, when it has allocatable components. */ sym->result->attr.referenced = 1; - else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc - && sym->result) - /* Default initialization for function results. */ - apply_default_init (sym->result); } if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns @@ -18460,12 +19264,23 @@ gfc_impure_variable (gfc_symbol *sym) if (sym->attr.use_assoc || sym->attr.in_common) return 1; + /* The namespace of a module procedure interface holds the arguments and + symbols, and so the symbol namespace can be different to that of the + procedure. */ + if (sym->ns != gfc_current_ns + && gfc_current_ns->proc_name->abr_modproc_decl + && sym->ns->proc_name->attr.function + && sym->attr.result + && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name)) + return 0; + /* Check if the symbol's ns is inside the pure procedure. */ for (ns = gfc_current_ns; ns; ns = ns->parent) { if (ns == sym->ns) break; - if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) + if (ns->proc_name->attr.flavor == FL_PROCEDURE + && !(sym->attr.function || sym->attr.result)) return 1; } |