X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fresolve.c;h=b24399d6a3fd7681680885e6f08ba9f44c3c786f;hp=526e6df32a05ac9cfe6c9a18bbecf75ec1ef126e;hb=0c806cea3faed6be472d3c7a0d7e20d1fceac956;hpb=8811c470d6396b6bf9c99a75e5313a38964ee6c1 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 526e6df32a0..b24399d6a3f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1,5 +1,6 @@ /* Perform type resolution on the various structures. - Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -57,9 +58,10 @@ code_stack; static code_stack *cs_base = NULL; -/* Nonzero if we're inside a FORALL block. */ +/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ static int forall_flag; +static int do_concurrent_flag; /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -159,7 +161,10 @@ resolve_procedure_interface (gfc_symbol *sym) resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) - sym->ts = ifc->result->ts; + { + sym->ts = ifc->result->ts; + sym->result = sym; + } else sym->ts = ifc->ts; sym->ts.interface = ifc; @@ -176,6 +181,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; + sym->attr.is_bind_c = ifc->attr.is_bind_c; /* Copy array spec. */ sym->as = gfc_copy_array_spec (ifc->as); if (sym->as) @@ -263,43 +269,17 @@ resolve_formal_arglist (gfc_symbol *proc) if (sym->attr.if_source != IFSRC_UNKNOWN) resolve_formal_arglist (sym); - if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic) + if (sym->attr.subroutine || sym->attr.external) { - if (gfc_pure (proc) && !gfc_pure (sym)) - { - gfc_error ("Dummy procedure '%s' of PURE procedure at %L must " - "also be PURE", sym->name, &sym->declared_at); - continue; - } - - if (gfc_elemental (proc)) - { - gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL " - "procedure", &sym->declared_at); - continue; - } - - if (sym->attr.function - && sym->ts.type == BT_UNKNOWN - && sym->attr.intrinsic) - { - gfc_intrinsic_sym *isym; - isym = gfc_find_function (sym->name); - if (isym == NULL || !isym->specific) - { - gfc_error ("Unable to find a specific INTRINSIC procedure " - "for the reference '%s' at %L", sym->name, - &sym->declared_at); - } - sym->ts = isym->ts; - } - - continue; + if (sym->attr.flavor == FL_UNKNOWN) + gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); + } + else + { + if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic + && (!sym->attr.function || sym->result == sym)) + gfc_set_default_type (sym, 1, sym->ns); } - - if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic - && (!sym->attr.function || sym->result == sym)) - gfc_set_default_type (sym, 1, sym->ns); gfc_resolve_array_spec (sym->as, 0); @@ -307,7 +287,8 @@ resolve_formal_arglist (gfc_symbol *proc) shape until we know if it has the pointer or allocatable attributes. */ if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED - && !(sym->attr.pointer || sym->attr.allocatable)) + && !(sym->attr.pointer || sym->attr.allocatable) + && sym->attr.flavor != FL_PROCEDURE) { sym->as->type = AS_ASSUMED_SHAPE; for (i = 0; i < sym->as->rank; i++) @@ -330,23 +311,69 @@ resolve_formal_arglist (gfc_symbol *proc) if (sym->attr.flavor == FL_UNKNOWN) gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); - if (gfc_pure (proc) && !sym->attr.pointer - && sym->attr.flavor != FL_PROCEDURE) + if (gfc_pure (proc)) { - if (proc->attr.function && sym->attr.intent != INTENT_IN) - gfc_error ("Argument '%s' of pure function '%s' at %L must be " - "INTENT(IN)", sym->name, proc->name, - &sym->declared_at); + if (sym->attr.flavor == FL_PROCEDURE) + { + /* F08:C1279. */ + if (!gfc_pure (sym)) + { + gfc_error ("Dummy procedure '%s' of PURE procedure at %L must " + "also be PURE", sym->name, &sym->declared_at); + continue; + } + } + else if (!sym->attr.pointer) + { + if (proc->attr.function && sym->attr.intent != INTENT_IN) + { + if (sym->attr.value) + gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + " of pure function '%s' at %L with VALUE " + "attribute but without INTENT(IN)", + sym->name, proc->name, &sym->declared_at); + else + gfc_error ("Argument '%s' of pure function '%s' at %L must " + "be INTENT(IN) or VALUE", sym->name, proc->name, + &sym->declared_at); + } - if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) - gfc_error ("Argument '%s' of pure subroutine '%s' at %L must " - "have its INTENT specified", sym->name, proc->name, - &sym->declared_at); + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) + { + if (sym->attr.value) + gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + " of pure subroutine '%s' at %L with VALUE " + "attribute but without INTENT", sym->name, + proc->name, &sym->declared_at); + else + gfc_error ("Argument '%s' of pure subroutine '%s' at %L " + "must have its INTENT specified or have the " + "VALUE attribute", sym->name, proc->name, + &sym->declared_at); + } + } + } + + if (proc->attr.implicit_pure) + { + if (sym->attr.flavor == FL_PROCEDURE) + { + if (!gfc_pure(sym)) + proc->attr.implicit_pure = 0; + } + else if (!sym->attr.pointer) + { + if (proc->attr.function && sym->attr.intent != INTENT_IN) + proc->attr.implicit_pure = 0; + + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) + proc->attr.implicit_pure = 0; + } } if (gfc_elemental (proc)) { - /* F2008, C1289. */ + /* F08:C1289. */ if (sym->attr.codimension) { gfc_error ("Coarray dummy argument '%s' at %L to elemental " @@ -427,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc) static void find_arglists (gfc_symbol *sym) { - if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns) + if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns + || sym->attr.flavor == FL_DERIVED) return; resolve_formal_arglist (sym); @@ -485,7 +513,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (sym->result->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->result->ts.u.cl; - if (!cl || !cl->length) + if ((!cl || !cl->length) && !sym->result->ts.deferred) { /* See if this is a module-procedure and adapt error message accordingly. */ @@ -869,6 +897,10 @@ resolve_common_blocks (gfc_symtree *common_root) gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L", sym->name, &common_root->n.common->where, &sym->declared_at); + if (sym->attr.external) + gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute", + sym->name, &common_root->n.common->where); + if (sym->attr.intrinsic) gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); @@ -915,6 +947,9 @@ resolve_contained_functions (gfc_namespace *ns) } +static gfc_try resolve_fl_derived0 (gfc_symbol *sym); + + /* Resolve all of the elements of a structure constructor and make sure that the types are correct. The 'init' flag indicates that the given constructor is an initializer. */ @@ -930,16 +965,9 @@ resolve_structure_cons (gfc_expr *expr, int init) t = SUCCESS; if (expr->ts.type == BT_DERIVED) - resolve_symbol (expr->ts.u.derived); + resolve_fl_derived0 (expr->ts.u.derived); cons = gfc_constructor_first (expr->value.constructor); - /* A constructor may have references if it is the result of substituting a - parameter variable. In this case we just pull out the component we - want. */ - if (expr->ref) - comp = expr->ref->u.c.sym->components; - else - comp = expr->ts.u.derived->components; /* See if the user is trying to invoke a structure constructor for one of the iso_c_binding derived types. */ @@ -958,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init) && cons->expr && cons->expr->expr_type == EXPR_NULL) return SUCCESS; + /* A constructor may have references if it is the result of substituting a + parameter variable. In this case we just pull out the component we + want. */ + if (expr->ref) + comp = expr->ref->u.c.sym->components; + else + comp = expr->ts.u.derived->components; + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { int rank; @@ -975,7 +1011,7 @@ resolve_structure_cons (gfc_expr *expr, int init) if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank && (comp->attr.allocatable || cons->expr->rank)) { - gfc_error ("The rank of the element in the derived type " + gfc_error ("The rank of the element in the structure " "constructor at %L does not match that of the " "component (%d/%d)", &cons->expr->where, cons->expr->rank, rank); @@ -988,16 +1024,16 @@ resolve_structure_cons (gfc_expr *expr, int init) !gfc_compare_types (&cons->expr->ts, &comp->ts)) { t = FAILURE; - if (strcmp (comp->name, "$extends") == 0) + if (strcmp (comp->name, "_extends") == 0) { - /* Can afford to be brutal with the $extends initializer. + /* Can afford to be brutal with the _extends initializer. The derived type can get lost because it is PRIVATE but it is not usage constrained by the standard. */ cons->expr->ts = comp->ts; t = SUCCESS; } else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) - gfc_error ("The element in the derived type constructor at %L, " + gfc_error ("The element in the structure constructor at %L, " "for pointer component '%s', is %s but should be %s", &cons->expr->where, comp->name, gfc_basic_typename (cons->expr->ts.type), @@ -1015,6 +1051,7 @@ resolve_structure_cons (gfc_expr *expr, int init) && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && cons->expr->rank != 0 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, comp->ts.u.cl->length->value.integer) != 0) { @@ -1057,7 +1094,7 @@ resolve_structure_cons (gfc_expr *expr, int init) cl2->next = cl->next; gfc_free_expr (cl->length); - gfc_free (cl); + free (cl); } cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -1075,12 +1112,46 @@ resolve_structure_cons (gfc_expr *expr, int init) || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; - gfc_error ("The NULL in the derived type constructor at %L is " + gfc_error ("The NULL in the structure constructor at %L is " "being applied to component '%s', which is neither " "a POINTER nor ALLOCATABLE", &cons->expr->where, comp->name); } + if (comp->attr.proc_pointer && comp->ts.interface) + { + /* Check procedure pointer interface. */ + gfc_symbol *s2 = NULL; + gfc_component *c2; + const char *name; + char err[200]; + + if (gfc_is_proc_ptr_comp (cons->expr, &c2)) + { + s2 = c2->ts.interface; + name = c2->name; + } + else if (cons->expr->expr_type == EXPR_FUNCTION) + { + s2 = cons->expr->symtree->n.sym->result; + name = cons->expr->symtree->n.sym->result->name; + } + else if (cons->expr->expr_type != EXPR_NULL) + { + s2 = cons->expr->symtree->n.sym; + name = cons->expr->symtree->n.sym->name; + } + + if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, + err, sizeof (err))) + { + gfc_error ("Interface mismatch for procedure-pointer component " + "'%s' in structure constructor at %L: %s", + comp->name, &cons->expr->where, err); + return FAILURE; + } + } + if (!comp->attr.pointer || comp->attr.proc_pointer || cons->expr->expr_type == EXPR_NULL) continue; @@ -1090,7 +1161,7 @@ resolve_structure_cons (gfc_expr *expr, int init) if (!a.pointer && !a.target) { t = FAILURE; - gfc_error ("The element in the derived type constructor at %L, " + gfc_error ("The element in the structure constructor at %L, " "for pointer component '%s' should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); } @@ -1118,11 +1189,17 @@ resolve_structure_cons (gfc_expr *expr, int init) || gfc_is_coindexed (cons->expr))) { t = FAILURE; - gfc_error ("Invalid expression in the derived type constructor for " + gfc_error ("Invalid expression in the structure constructor for " "pointer component '%s' at %L in PURE procedure", comp->name, &cons->expr->where); } + if (gfc_implicit_pure (NULL) + && cons->expr->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (cons->expr->symtree->n.sym) + || gfc_is_coindexed (cons->expr))) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + } return t; @@ -1327,7 +1404,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) gfc_symbol* context_proc; gfc_namespace* real_context; - if (sym->attr.flavor == FL_PROGRAM) + if (sym->attr.flavor == FL_PROGRAM + || sym->attr.flavor == FL_DERIVED) return false; gcc_assert (sym->attr.flavor == FL_PROCEDURE); @@ -1400,6 +1478,10 @@ resolve_intrinsic (gfc_symbol *sym, locus *loc) if (sym->formal) return SUCCESS; + /* Already resolved. */ + if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) + return SUCCESS; + /* We already know this one is an intrinsic, so we don't call gfc_is_intrinsic for full checking but rather use gfc_find_function and gfc_find_subroutine directly to check whether it is a function or @@ -1507,7 +1589,6 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_symtree *parent_st; gfc_expr *e; int save_need_full_assumed_size; - gfc_component *comp; for (; arg; arg = arg->next) { @@ -1527,20 +1608,6 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, continue; } - if (gfc_is_proc_ptr_comp (e, &comp)) - { - e->ts = comp->ts; - if (e->expr_type == EXPR_PPC) - { - if (comp->as != NULL) - e->rank = comp->as->rank; - e->expr_type = EXPR_FUNCTION; - } - if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; - goto argument_list; - } - if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.generic && no_formal_args @@ -2005,11 +2072,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (!gsym->ns->resolved) { gfc_dt_list *old_dt_list; + struct gfc_omp_saved_state old_omp_state; /* Stash away derived types so that the backend_decls do not get mixed up. */ old_dt_list = gfc_derived_types; gfc_derived_types = NULL; + /* And stash away openmp state. */ + gfc_omp_save_and_clear_state (&old_omp_state); gfc_resolve (gsym->ns); @@ -2019,6 +2089,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Restore the derived types of this namespace. */ gfc_derived_types = old_dt_list; + /* And openmp state. */ + gfc_omp_restore_state (&old_omp_state); } /* Make sure that translation for the gsymbol occurs before @@ -2157,7 +2229,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY - && def_sym->ts.u.cl->length != NULL) + && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; @@ -2255,6 +2327,7 @@ resolve_generic_f (gfc_expr *expr) { gfc_symbol *sym; match m; + gfc_interface *intr = NULL; sym = expr->symtree->n.sym; @@ -2267,6 +2340,11 @@ resolve_generic_f (gfc_expr *expr) return FAILURE; generic: + if (!intr) + for (intr = sym->generic; intr; intr = intr->next) + if (intr->sym->attr.flavor == FL_DERIVED) + break; + if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); @@ -2279,16 +2357,25 @@ generic: /* Last ditch attempt. See if the reference is to an intrinsic that possesses a matching interface. 14.1.2.4 */ - if (sym && !gfc_is_intrinsic (sym, 0, expr->where)) + if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) { - gfc_error ("There is no specific function for the generic '%s' at %L", - expr->symtree->n.sym->name, &expr->where); + gfc_error ("There is no specific function for the generic '%s' " + "at %L", expr->symtree->n.sym->name, &expr->where); return FAILURE; } + if (intr) + { + if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL, + false) != SUCCESS) + return FAILURE; + return resolve_structure_cons (expr, 0); + } + m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) return SUCCESS; + if (m == MATCH_NO) gfc_error ("Generic function '%s' at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, @@ -2546,21 +2633,11 @@ is_scalar_expr_ptr (gfc_expr *expr) switch (ref->type) { case REF_SUBSTRING: - if (ref->u.ss.length != NULL - && ref->u.ss.length->length != NULL - && ref->u.ss.start - && ref->u.ss.start->expr_type == EXPR_CONSTANT - && ref->u.ss.end - && ref->u.ss.end->expr_type == EXPR_CONSTANT) - { - start = (int) mpz_get_si (ref->u.ss.start->value.integer); - end = (int) mpz_get_si (ref->u.ss.end->value.integer); - if (end - start + 1 != 1) - retval = FAILURE; - } - else - retval = FAILURE; + if (ref->u.ss.start == NULL || ref->u.ss.end == NULL + || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0) + retval = FAILURE; break; + case REF_ARRAY: if (ref->u.ar.type == AR_ELEMENT) retval = SUCCESS; @@ -2589,7 +2666,8 @@ is_scalar_expr_ptr (gfc_expr *expr) { /* We have constant lower and upper bounds. If the difference between is 1, it can be considered a - scalar. */ + scalar. + FIXME: Use gfc_dep_compare_expr instead. */ start = (int) mpz_get_si (ref->u.ar.as->lower[0]->value.integer); end = (int) mpz_get_si @@ -2697,6 +2775,9 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } else if (sym->intmod_sym_id == ISOCBINDING_LOC) { + gfc_ref *ref; + bool seen_section; + /* Make sure we have either the target or pointer attribute. */ if (!arg_attr.target && !arg_attr.pointer) { @@ -2707,8 +2788,47 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, retval = FAILURE; } + if (gfc_is_coindexed (args->expr)) + { + gfc_error_now ("Coindexed argument not permitted" + " in '%s' call at %L", name, + &(args->expr->where)); + retval = FAILURE; + } + + /* Follow references to make sure there are no array + sections. */ + seen_section = false; + + for (ref=args->expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + if (ref->u.ar.type == AR_SECTION) + seen_section = true; + + if (ref->u.ar.type != AR_ELEMENT) + { + gfc_ref *r; + for (r = ref->next; r; r=r->next) + if (r->type == REF_COMPONENT) + { + gfc_error_now ("Array section not permitted" + " in '%s' call at %L", name, + &(args->expr->where)); + retval = FAILURE; + break; + } + } + } + } + + if (seen_section && retval == SUCCESS) + gfc_warning ("Array section in '%s' call at %L", name, + &(args->expr->where)); + /* See if we have interoperable type and type param. */ - if (verify_c_interop (arg_ts) == SUCCESS + if (gfc_verify_c_interop (arg_ts) == SUCCESS || gfc_check_any_c_kind (arg_ts) == SUCCESS) { if (args_sym->attr.target == 1) @@ -2946,6 +3066,7 @@ resolve_function (gfc_expr *expr) && sym->ts.u.cl && sym->ts.u.cl->length == NULL && !sym->attr.dummy + && !sym->ts.deferred && expr->value.function.esym == NULL && !sym->attr.contained) { @@ -3053,17 +3174,27 @@ resolve_function (gfc_expr *expr) { if (forall_flag) { - gfc_error ("reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function '%s' at %L inside a " "FORALL %s", name, &expr->where, forall_flag == 2 ? "mask" : "block"); t = FAILURE; } + else if (do_concurrent_flag) + { + gfc_error ("Reference to non-PURE function '%s' at %L inside a " + "DO CONCURRENT %s", name, &expr->where, + do_concurrent_flag == 2 ? "mask" : "block"); + t = FAILURE; + } else if (gfc_pure (NULL)) { gfc_error ("Function reference to '%s' at %L is to a non-PURE " "procedure within a PURE procedure", name, &expr->where); t = FAILURE; } + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; } /* Functions without the RECURSIVE attribution are not allowed to @@ -3121,9 +3252,15 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) if (forall_flag) gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", sym->name, &c->loc); + else if (do_concurrent_flag) + gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " + "PURE", sym->name, &c->loc); else if (gfc_pure (NULL)) gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, &c->loc); + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; } @@ -3792,9 +3929,12 @@ resolve_operator (gfc_expr *e) sprintf (msg, _("Operand of user operator '%s' at %%L is %s"), e->value.op.uop->name, gfc_typename (&op1->ts)); else - sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"), - e->value.op.uop->name, gfc_typename (&op1->ts), - gfc_typename (&op2->ts)); + { + sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"), + e->value.op.uop->name, gfc_typename (&op1->ts), + gfc_typename (&op2->ts)); + e->value.op.uop->op->sym->attr.referenced = 1; + } goto bad_op; @@ -3916,11 +4056,10 @@ resolve_operator (gfc_expr *e) bad_op: { - bool real_error; - if (gfc_extend_expr (e, &real_error) == SUCCESS) + match m = gfc_extend_expr (e); + if (m == MATCH_YES) return SUCCESS; - - if (real_error) + if (m == MATCH_ERROR) return FAILURE; } @@ -4087,6 +4226,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) switch (ar->dimen_type[i]) { case DIMEN_VECTOR: + case DIMEN_THIS_IMAGE: break; case DIMEN_STAR: @@ -4254,7 +4394,8 @@ compare_spec_to_ref (gfc_array_ref *ar) if (ar->codimen != 0) for (i = as->rank; i < as->rank + as->corank; i++) { - if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate + && ar->dimen_type[i] != DIMEN_THIS_IMAGE) { gfc_error ("Coindex of codimension %d must be a scalar at %L", i + 1 - as->rank, &ar->where); @@ -4375,14 +4516,12 @@ find_array_spec (gfc_expr *e) { gfc_array_spec *as; gfc_component *c; - gfc_symbol *derived; gfc_ref *ref; if (e->symtree->n.sym->ts.type == BT_CLASS) as = CLASS_DATA (e->symtree->n.sym)->as; else as = e->symtree->n.sym->as; - derived = NULL; for (ref = e->ref; ref; ref = ref->next) switch (ref->type) @@ -4396,26 +4535,7 @@ find_array_spec (gfc_expr *e) break; case REF_COMPONENT: - if (derived == NULL) - derived = e->symtree->n.sym->ts.u.derived; - - if (derived->attr.is_class) - derived = derived->components->ts.u.derived; - - c = derived->components; - - for (; c; c = c->next) - if (c == ref->u.c.component) - { - /* Track the sequence of component references. */ - if (c->ts.type == BT_DERIVED) - derived = c->ts.u.derived; - break; - } - - if (c == NULL) - gfc_internal_error ("find_array_spec(): Component not found"); - + c = ref->u.c.component; if (c->attr.dimension) { if (as != NULL) @@ -4481,10 +4601,11 @@ resolve_array_ref (gfc_array_ref *ar) /* Fill in the upper bound, which may be lower than the specified one for something like a(2:10:5), which is identical to a(2:7:5). Only relevant for strides not equal - to one. */ + to one. Don't try a division by zero. */ if (ar->dimen_type[i] == DIMEN_RANGE && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT - && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0) + && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 + && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) { mpz_t size, end; @@ -4511,8 +4632,23 @@ resolve_array_ref (gfc_array_ref *ar) } } - if (ar->type == AR_FULL && ar->as->rank == 0) - ar->type = AR_ELEMENT; + if (ar->type == AR_FULL) + { + if (ar->as->rank == 0) + ar->type = AR_ELEMENT; + + /* Make sure array is the same as array(:,:), this way + we don't need to special case all the time. */ + ar->dimen = ar->as->rank; + for (i = 0; i < ar->dimen; i++) + { + ar->dimen_type[i] = DIMEN_RANGE; + + gcc_assert (ar->start[i] == NULL); + gcc_assert (ar->end[i] == NULL); + gcc_assert (ar->stride[i] == NULL); + } + } /* If the reference type is unknown, figure out what kind it is. */ @@ -4531,6 +4667,14 @@ resolve_array_ref (gfc_array_ref *ar) if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE) return FAILURE; + if (ar->as->corank && ar->codimen == 0) + { + int n; + ar->codimen = ar->as->corank; + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + ar->dimen_type[n] = DIMEN_THIS_IMAGE; + } + return SUCCESS; } @@ -4702,7 +4846,8 @@ resolve_ref (gfc_expr *expr) break; case REF_SUBSTRING: - resolve_substring (ref); + if (resolve_substring (ref) == FAILURE) + return FAILURE; break; } @@ -4855,6 +5000,10 @@ expression_rank (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) { + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer + && ref->u.c.component->attr.function && !ref->next) + rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0; + if (ref->type != REF_ARRAY) continue; @@ -4905,6 +5054,9 @@ resolve_variable (gfc_expr *e) if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) return FAILURE; + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + /* On the other hand, the parser may not have known this is an array; in this case, we have to add a FULL reference. */ if (sym->assoc && sym->attr.dimension && !e->ref) @@ -5026,13 +5178,6 @@ resolve_procedure: { gfc_ref *ref, *ref2 = NULL; - if (e->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic subobject of coindexed object at %L", - &e->where); - t = FAILURE; - } - for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT) @@ -5045,6 +5190,14 @@ resolve_procedure: if (ref->type == REF_COMPONENT) break; + /* Expression itself is not coindexed object. */ + if (ref && e->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic subobject of coindexed object at %L", + &e->where); + t = FAILURE; + } + /* Expression itself is coindexed object. */ if (ref == NULL) { @@ -5104,13 +5257,7 @@ check_host_association (gfc_expr *e) && sym->attr.contained) { /* Clear the shape, since it might not be valid. */ - if (e->shape != NULL) - { - for (n = 0; n < e->rank; n++) - mpz_clear (e->shape[n]); - - gfc_free (e->shape); - } + gfc_free_shape (&e->shape, e->rank); /* Give the expression the right symtree! */ gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); @@ -5129,7 +5276,7 @@ check_host_association (gfc_expr *e) { /* Original was variable so convert array references into an actual arglist. This does not need any checking now - since gfc_resolve_function will take care of it. */ + since resolve_function will take care of it. */ e->value.function.actual = NULL; e->expr_type = EXPR_FUNCTION; e->symtree = st; @@ -5382,12 +5529,21 @@ update_ppc_arglist (gfc_expr* e) if (!po) return FAILURE; + /* F08:R739. */ if (po->rank > 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); return FAILURE; } + /* F08:C611. */ + if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract) + { + gfc_error ("Base object for procedure-pointer component call at %L is of" + " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name); + return FAILURE; + } + gcc_assert (tb->pass_arg_num > 0); e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, tb->pass_arg_num, @@ -5412,6 +5568,7 @@ check_typebound_baseobject (gfc_expr* e) gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); + /* F08:C611. */ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" @@ -5419,7 +5576,8 @@ check_typebound_baseobject (gfc_expr* e) goto cleanup; } - /* If the procedure called is NOPASS, the base object must be scalar. */ + /* F08:C1230. If the procedure called is NOPASS, + the base object must be scalar. */ if (e->value.compcall.tbp->nopass && base->rank > 0) { gfc_error ("Base object for NOPASS type-bound procedure call at %L must" @@ -5427,14 +5585,6 @@ check_typebound_baseobject (gfc_expr* e) goto cleanup; } - /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */ - if (base->rank > 0) - { - gfc_error ("Non-scalar base object at %L currently not implemented", - &e->where); - goto cleanup; - } - return_value = SUCCESS; cleanup: @@ -5465,16 +5615,50 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, e->ref = NULL; e->value.compcall.actual = NULL; + /* If we find a deferred typebound procedure, check for derived types + that an over-riding typebound procedure has not been missed. */ + if (e->value.compcall.tbp->deferred + && e->value.compcall.name + && !e->value.compcall.tbp->non_overridable + && e->value.compcall.base_object + && e->value.compcall.base_object->ts.type == BT_DERIVED) + { + gfc_symtree *st; + gfc_symbol *derived; + + /* Use the derived type of the base_object. */ + derived = e->value.compcall.base_object->ts.u.derived; + st = NULL; + + /* If necessary, go throught the inheritance chain. */ + while (!st && derived) + { + /* Look for the typebound procedure 'name'. */ + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, + e->value.compcall.name); + if (!st) + derived = gfc_get_derived_super_type (derived); + } + + /* Now find the specific name in the derived type namespace. */ + if (st && st->n.tb && st->n.tb->u.specific) + gfc_find_sym_tree (st->n.tb->u.specific->name, + derived->ns, 1, &st); + if (st) + *target = st; + } return SUCCESS; } /* Get the ultimate declared type from an expression. In addition, return the last class/derived type reference and the copy of the - reference list. */ + reference list. If check_types is set true, derived types are + identified as well as class references. */ static gfc_symbol* get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e) + gfc_expr *e, bool check_types) { gfc_symbol *declared; gfc_ref *ref; @@ -5490,8 +5674,9 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, if (ref->type != REF_COMPONENT) continue; - if (ref->u.c.component->ts.type == BT_CLASS - || ref->u.c.component->ts.type == BT_DERIVED) + if ((ref->u.c.component->ts.type == BT_CLASS + || (check_types && ref->u.c.component->ts.type == BT_DERIVED)) + && ref->u.c.component->attr.flavor != FL_PROCEDURE) { declared = ref->u.c.component->ts.u.derived; if (class_ref) @@ -5586,9 +5771,9 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) success: /* Make sure that we have the right specific instance for the name. */ - derived = get_declared_from_expr (NULL, NULL, e); + derived = get_declared_from_expr (NULL, NULL, e, true); - st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); + st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); if (st) e->value.compcall.tbp = st->n.tb; @@ -5714,20 +5899,36 @@ resolve_typebound_function (gfc_expr* e) const char *name; gfc_typespec ts; gfc_expr *expr; + bool overridable; 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) + overridable = !e->value.compcall.tbp->non_overridable; + if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) { + /* If the base_object is not a variable, the corresponding actual + argument expression must be stored in e->base_expression so + that the corresponding tree temporary can be used as the base + object in gfc_conv_procedure_call. */ + if (expr->expr_type != EXPR_VARIABLE) + { + gfc_actual_arglist *args; + + for (args= e->value.function.actual; args; args = args->next) + { + if (expr == args->expr) + expr = args->expr; + } + } + /* 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; + ts = expr->ts; declared = ts.u.derived; - c = gfc_find_component (declared, "$vptr", true, true); + c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); @@ -5737,10 +5938,27 @@ resolve_typebound_function (gfc_expr* e) /* 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"); + e->ref = gfc_copy_ref (expr->ref); + get_declared_from_expr (&class_ref, NULL, e, false); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (e->ref && !class_ref) + { + gfc_free_ref_list (e->ref); + e->ref = NULL; + } + + gfc_add_vptr_component (e); gfc_add_component_ref (e, name); e->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + e->base_expr = expr; return SUCCESS; } @@ -5751,7 +5969,7 @@ resolve_typebound_function (gfc_expr* e) return FAILURE; /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, e); + declared = get_declared_from_expr (&class_ref, &new_ref, e, true); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) @@ -5761,7 +5979,7 @@ resolve_typebound_function (gfc_expr* e) return resolve_compcall (e, NULL); } - c = gfc_find_component (declared, "$data", true, true); + c = gfc_find_component (declared, "_data", true, true); declared = c->ts.u.derived; /* Treat the call as if it is a typebound procedure, in order to roll @@ -5770,22 +5988,26 @@ resolve_typebound_function (gfc_expr* e) return FAILURE; ts = e->ts; - /* Then convert the expression to a procedure pointer component call. */ - e->value.function.esym = NULL; - e->symtree = st; + if (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + e->value.function.esym = NULL; + e->symtree = st; + + if (new_ref) + e->ref = new_ref; - if (new_ref) - e->ref = new_ref; + /* '_vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_vptr_component (e); + gfc_add_component_ref (e, name); - /* '$vptr' points to the vtab, which contains the procedure pointers. */ - gfc_add_component_ref (e, "$vptr"); - gfc_add_component_ref (e, name); + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + e->ts = ts; + } - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - e->ts = ts; return SUCCESS; } @@ -5804,20 +6026,34 @@ resolve_typebound_subroutine (gfc_code *code) const char *name; gfc_typespec ts; gfc_expr *expr; + bool overridable; 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) + overridable = !code->expr1->value.compcall.tbp->non_overridable; + if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) { + /* If the base_object is not a variable, the corresponding actual + argument expression must be stored in e->base_expression so + that the corresponding tree temporary can be used as the base + object in gfc_conv_procedure_call. */ + if (expr->expr_type != EXPR_VARIABLE) + { + gfc_actual_arglist *args; + + args= code->expr1->value.function.actual; + for (; args; args = args->next) + if (expr == args->expr) + expr = args->expr; + } + /* 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); + declared = expr->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); @@ -5827,10 +6063,28 @@ resolve_typebound_subroutine (gfc_code *code) /* 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"); + code->expr1->ref = gfc_copy_ref (expr->ref); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + get_declared_from_expr (&class_ref, NULL, code->expr1, false); + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (code->expr1->ref && !class_ref) + { + gfc_free_ref_list (code->expr1->ref); + code->expr1->ref = NULL; + } + + /* Now use the procedure in the vtable. */ + gfc_add_vptr_component (code->expr1); gfc_add_component_ref (code->expr1, name); code->expr1->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + code->expr1->base_expr = expr; return SUCCESS; } @@ -5841,7 +6095,7 @@ resolve_typebound_subroutine (gfc_code *code) return FAILURE; /* Get the CLASS declared type. */ - get_declared_from_expr (&class_ref, &new_ref, code->expr1); + get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) @@ -5855,22 +6109,26 @@ resolve_typebound_subroutine (gfc_code *code) 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 (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + code->expr1->value.function.esym = NULL; + code->expr1->symtree = st; - if (new_ref) - 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"); - gfc_add_component_ref (code->expr1, name); + /* '_vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_vptr_component (code->expr1); + gfc_add_component_ref (code->expr1, name); + + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + code->expr1->ts = ts; + } - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - code->expr1->ts = ts; return SUCCESS; } @@ -6137,7 +6395,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok) == FAILURE) return FAILURE; - if (gfc_check_vardef_context (iter->var, false, _("iterator variable")) + if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable")) == FAILURE) return FAILURE; @@ -6264,14 +6522,14 @@ resolve_forall_iterators (gfc_forall_iterator *it) gfc_error ("FORALL start expression at %L must be a scalar INTEGER", &iter->start->where); if (iter->var->ts.kind != iter->start->ts.kind) - gfc_convert_type (iter->start, &iter->var->ts, 2); + gfc_convert_type (iter->start, &iter->var->ts, 1); if (gfc_resolve_expr (iter->end) == SUCCESS && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) gfc_error ("FORALL end expression at %L must be a scalar INTEGER", &iter->end->where); if (iter->var->ts.kind != iter->end->ts.kind) - gfc_convert_type (iter->end, &iter->var->ts, 2); + gfc_convert_type (iter->end, &iter->var->ts, 1); if (gfc_resolve_expr (iter->stride) == SUCCESS) { @@ -6285,7 +6543,7 @@ resolve_forall_iterators (gfc_forall_iterator *it) &iter->stride->where); } if (iter->var->ts.kind != iter->stride->ts.kind) - gfc_convert_type (iter->stride, &iter->var->ts, 2); + gfc_convert_type (iter->stride, &iter->var->ts, 1); } for (iter = it; iter; iter = iter->next) @@ -6362,7 +6620,9 @@ resolve_deallocate_expr (gfc_expr *e) switch (ref->type) { case REF_ARRAY: - if (ref->u.ar.type != AR_FULL) + if (ref->u.ar.type != AR_FULL + && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 + && ref->u.ar.codimen && gfc_ref_this_image (ref))) allocatable = 0; break; @@ -6396,18 +6656,21 @@ resolve_deallocate_expr (gfc_expr *e) return FAILURE; } + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", &e->where); + return FAILURE; + } + if (pointer - && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE) + && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object")) + == FAILURE) return FAILURE; - if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE) + if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object")) + == FAILURE) return FAILURE; - if (e->ts.type == BT_CLASS) - { - /* Only deallocate the DATA component. */ - gfc_add_component_ref (e, "$data"); - } - return SUCCESS; } @@ -6452,10 +6715,13 @@ gfc_expr_to_initialize (gfc_expr *e) for (i = 0; i < ref->u.ar.dimen; i++) ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL; - result->rank = ref->u.ar.dimen; break; } + gfc_free_shape (&result->shape, result->rank); + + /* Recalculate rank, shape, etc. */ + gfc_resolve_expr (result); return result; } @@ -6549,6 +6815,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { int i, pointer, allocatable, dimension, is_abstract; int codimension; + bool coindexed; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_expr *e2; @@ -6590,7 +6857,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } else { - if (sym->ts.type == BT_CLASS) + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) { allocatable = CLASS_DATA (sym)->attr.allocatable; pointer = CLASS_DATA (sym)->attr.class_pointer; @@ -6606,18 +6873,32 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) codimension = sym->attr.codimension; } + coindexed = false; + for (ref = e->ref; ref; ref2 = ref, ref = ref->next) { switch (ref->type) { case REF_ARRAY: + if (ref->u.ar.codimen > 0) + { + int n; + for (n = ref->u.ar.dimen; + n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + { + coindexed = true; + break; + } + } + if (ref->next != NULL) pointer = 0; break; case REF_COMPONENT: /* F2008, C644. */ - if (gfc_is_coindexed (e)) + if (coindexed) { gfc_error ("Coindexed allocatable object at %L", &e->where); @@ -6682,6 +6963,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) &e->where, &code->expr3->where); goto failure; } + + /* Check F2008, C642. */ + if (code->expr3->ts.type == BT_DERIVED + && ((codimension && gfc_expr_attr (code->expr3).lock_comp) + || (code->expr3->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && code->expr3->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE))) + { + gfc_error ("The source-expr at %L shall neither be of type " + "LOCK_TYPE nor have a LOCK_TYPE component if " + "allocate-object at %L is a coarray", + &code->expr3->where, &e->where); + goto failure; + } } /* Check F08:C629. */ @@ -6694,20 +6990,42 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - /* In the variable definition context checks, gfc_expr_attr is used - on the expression. This is fooled by the array specification - present in e, thus we have to eliminate that one temporarily. */ - e2 = remove_last_array_ref (e); - t = SUCCESS; + if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred) + { + int cmp = gfc_dep_compare_expr (e->ts.u.cl->length, + code->ext.alloc.ts.u.cl->length); + if (cmp == 1 || cmp == -1 || cmp == -3) + { + gfc_error ("Allocating %s at %L with type-spec requires the same " + "character-length parameter as in the declaration", + sym->name, &e->where); + goto failure; + } + } + + /* In the variable definition context checks, gfc_expr_attr is used + on the expression. This is fooled by the array specification + present in e, thus we have to eliminate that one temporarily. */ + e2 = remove_last_array_ref (e); + t = SUCCESS; if (t == SUCCESS && pointer) - t = gfc_check_vardef_context (e2, true, _("ALLOCATE object")); + t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object")); if (t == SUCCESS) - t = gfc_check_vardef_context (e2, false, _("ALLOCATE object")); + t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object")); gfc_free_expr (e2); if (t == FAILURE) goto failure; - if (!code->expr3) + if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension + && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) + { + /* For class arrays, the initialization with SOURCE is done + using _copy and trans_call. It is convenient to exploit that + when the allocated type is different from the declared type but + no SOURCE exists by setting expr3. */ + code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); + } + else if (!code->expr3) { /* Set up default initializer if needed. */ gfc_typespec ts; @@ -6751,9 +7069,11 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; gfc_find_derived_vtab (ts.u.derived); + if (dimension) + e = gfc_expr_to_initialize (e); } - if (pointer || (dimension == 0 && codimension == 0)) + if (dimension == 0 && codimension == 0) goto success; /* Make sure the last reference node is an array specifiction. */ @@ -6771,12 +7091,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ar = &ref2->u.ar; - if (codimension && ar->codimen == 0) - { - gfc_error ("Coarray specification required in ALLOCATE statement " - "at %L", &e->where); - goto failure; - } + if (codimension) + for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) + if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } for (i = 0; i < ar->dimen; i++) { @@ -6799,6 +7121,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: case DIMEN_STAR: + case DIMEN_THIS_IMAGE: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); goto failure; @@ -6849,13 +7172,6 @@ check_symbols: goto failure; } - if (codimension && ar->as->rank == 0) - { - gfc_error ("Sorry, allocatable scalar coarrays are not yet supported " - "at %L", &e->where); - goto failure; - } - success: return SUCCESS; @@ -6875,7 +7191,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Check the stat variable. */ if (stat) { - gfc_check_vardef_context (stat, false, _("STAT variable")); + gfc_check_vardef_context (stat, false, false, _("STAT variable")); if ((stat->ts.type != BT_INTEGER && !(stat->ref && (stat->ref->type == REF_ARRAY @@ -6918,7 +7234,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_warning ("ERRMSG at %L is useless without a STAT tag", &errmsg->where); - gfc_check_vardef_context (errmsg, false, _("ERRMSG variable")); + gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable")); if ((errmsg->ts.type != BT_CHARACTER && !(errmsg->ref @@ -6960,17 +7276,66 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; - if ((pe->ref && pe->ref->type != REF_COMPONENT) - && (pe->symtree->n.sym->ts.type != BT_DERIVED)) + for (q = p->next; q; q = q->next) { - for (q = p->next; q; q = q->next) + qe = q->expr; + if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) { - qe = q->expr; - if ((qe->ref && qe->ref->type != REF_COMPONENT) - && (qe->symtree->n.sym->ts.type != BT_DERIVED) - && (pe->symtree->n.sym->name == qe->symtree->n.sym->name)) - gfc_error ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + /* This is a potential collision. */ + gfc_ref *pr = pe->ref; + gfc_ref *qr = qe->ref; + + /* Follow the references until + a) They start to differ, in which case there is no error; + you can deallocate a%b and a%c in a single statement + b) Both of them stop, which is an error + c) One of them stops, which is also an error. */ + while (1) + { + if (pr == NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); + break; + } + else if (pr != NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); + break; + } + else if (pr == NULL && qr != NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); + break; + } + /* Here, pr != NULL && qr != NULL */ + gcc_assert(pr->type == qr->type); + if (pr->type == REF_ARRAY) + { + /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), + which are legal. */ + gcc_assert (qr->type == REF_ARRAY); + + if (pr->next && qr->next) + { + gfc_array_ref *par = &(pr->u.ar); + gfc_array_ref *qar = &(qr->u.ar); + if (gfc_dep_compare_expr (par->start[0], + qar->start[0]) != 0) + break; + } + } + else + { + if (pr->u.c.component->name != qr->u.c.component->name) + break; + } + + pr = pr->next; + qr = qr->next; + } } } } @@ -7282,23 +7647,13 @@ resolve_select (gfc_code *code) return; } - if (case_expr->rank != 0) - { - gfc_error ("Argument of SELECT statement at %L must be a scalar " - "expression", &case_expr->where); - - /* Punt. */ - return; - } - - /* Raise a warning if an INTEGER case value exceeds the range of the case-expr. Later, all expressions will be promoted to the largest kind of all case-labels. */ if (type == BT_INTEGER) for (body = code->block; body; body = body->block) - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { if (cp->low && gfc_check_integer_range (cp->low->value.integer, @@ -7326,7 +7681,7 @@ resolve_select (gfc_code *code) for (body = code->block; body; body = body->block) { /* Walk the case label list. */ - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Intercept the DEFAULT case. It does not have a kind. */ if (cp->low == NULL && cp->high == NULL) @@ -7363,7 +7718,7 @@ resolve_select (gfc_code *code) /* Walk the case label list, making sure that all case labels are legal. */ - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Count the number of cases in the whole construct. */ ncases++; @@ -7464,19 +7819,19 @@ resolve_select (gfc_code *code) if (seen_unreachable) { /* Advance until the first case in the list is reachable. */ - while (body->ext.case_list != NULL - && body->ext.case_list->unreachable) + while (body->ext.block.case_list != NULL + && body->ext.block.case_list->unreachable) { - gfc_case *n = body->ext.case_list; - body->ext.case_list = body->ext.case_list->next; + gfc_case *n = body->ext.block.case_list; + body->ext.block.case_list = body->ext.block.case_list->next; n->next = NULL; gfc_free_case_list (n); } /* Strip all other unreachable cases. */ - if (body->ext.case_list) + if (body->ext.block.case_list) { - for (cp = body->ext.case_list; cp->next; cp = cp->next) + for (cp = body->ext.block.case_list; cp->next; cp = cp->next) { if (cp->next->unreachable) { @@ -7512,7 +7867,7 @@ resolve_select (gfc_code *code) unreachable case labels for a block. */ for (body = code; body && body->block; body = body->block) { - if (body->block->ext.case_list == NULL) + if (body->block->ext.block.case_list == NULL) { /* Cut the unreachable block from the code chain. */ gfc_code *c = body->block; @@ -7575,7 +7930,13 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.asynchronous = tsym->attr.asynchronous; sym->attr.volatile_ = tsym->attr.volatile_; - sym->attr.target = (tsym->attr.target || tsym->attr.pointer); + if (tsym->ts.type == BT_CLASS) + sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer; + else + sym->attr.target = tsym->attr.target || tsym->attr.pointer; + + if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS) + target->rank = sym->as ? sym->as->rank : 0; } /* Get type if this was not already set. Note that it can be @@ -7590,7 +7951,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ - if (sym->attr.dimension && target->rank == 0) + if (sym->attr.dimension + && (target->ts.type == BT_CLASS + ? !CLASS_DATA (target)->attr.dimension + : target->rank == 0)) { gfc_error ("Associate-name '%s' at %L is used as array", sym->name, &sym->declared_at); @@ -7639,6 +8003,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) return; } + if (!code->expr1->symtree->n.sym->attr.class_ok) + return; + if (code->expr2) { if (code->expr1->symtree->n.sym->attr.untyped) @@ -7651,7 +8018,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { - c = body->ext.case_list; + c = body->ext.block.case_list; /* Check F03:C815. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) @@ -7681,7 +8048,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", - &default_case->ext.case_list->where, &c->where); + &default_case->ext.block.case_list->where, &c->where); error++; continue; } @@ -7706,6 +8073,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) assoc = gfc_get_association_list (); assoc->st = code->expr1->symtree; assoc->target = gfc_copy_expr (code->expr2); + assoc->target->where = code->expr2->where; /* assoc->variable will be set by resolve_assoc_var. */ code->ext.block.assoc = assoc; @@ -7730,13 +8098,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ns->code->next = new_st; code = new_st; code->op = EXEC_SELECT; - gfc_add_component_ref (code->expr1, "$vptr"); - gfc_add_component_ref (code->expr1, "$hash"); + gfc_add_vptr_component (code->expr1); + gfc_add_hash_component (code->expr1); /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { - c = body->ext.case_list; + c = body->ext.block.case_list; if (c->ts.type == BT_DERIVED) c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, @@ -7751,14 +8119,15 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 'global' one). */ if (c->ts.type == BT_CLASS) - sprintf (name, "tmp$class$%s", c->ts.u.derived->name); + sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); else - sprintf (name, "tmp$type$%s", c->ts.u.derived->name); + sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); + st->n.sym->assoc->target->where = code->expr1->where; if (c->ts.type == BT_DERIVED) - gfc_add_component_ref (st->n.sym->assoc->target, "$data"); + gfc_add_data_component (st->n.sym->assoc->target); new_st = gfc_get_code (); new_st->op = EXEC_BLOCK; @@ -7782,7 +8151,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) body = code; while (body && body->block) { - if (body->block->ext.case_list->ts.type == BT_CLASS) + if (body->block->ext.block.case_list->ts.type == BT_CLASS) { /* Add to class_is list. */ if (class_is == NULL) @@ -7815,8 +8184,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) tail->block = gfc_get_code (); tail = tail->block; tail->op = EXEC_SELECT_TYPE; - tail->ext.case_list = gfc_get_case (); - tail->ext.case_list->ts.type = BT_UNKNOWN; + tail->ext.block.case_list = gfc_get_case (); + tail->ext.block.case_list->ts.type = BT_UNKNOWN; tail->next = NULL; default_case = tail; } @@ -7834,15 +8203,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { c2 = (*c1)->block; /* F03:C817 (check for doubles). */ - if ((*c1)->ext.case_list->ts.u.derived->hash_value - == c2->ext.case_list->ts.u.derived->hash_value) + if ((*c1)->ext.block.case_list->ts.u.derived->hash_value + == c2->ext.block.case_list->ts.u.derived->hash_value) { gfc_error ("Double CLASS IS block in SELECT TYPE " - "statement at %L", &c2->ext.case_list->where); + "statement at %L", + &c2->ext.block.case_list->where); return; } - if ((*c1)->ext.case_list->ts.u.derived->attr.extension - < c2->ext.case_list->ts.u.derived->attr.extension) + if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension + < c2->ext.block.case_list->ts.u.derived->attr.extension) { /* Swap. */ (*c1)->block = c2->block; @@ -7875,8 +8245,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Set up arguments. */ 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); + new_st->expr1->value.function.actual->expr->where = code->loc; + gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); + vtab = gfc_find_derived_vtab (body->ext.block.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); @@ -7924,6 +8295,13 @@ resolve_transfer (gfc_code *code) && exp->value.op.op == INTRINSIC_PARENTHESES) exp = exp->value.op.op1; + if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN) + { + gfc_error ("NULL intrinsic at %L in data transfer statement requires " + "MOLD=", &exp->where); + return; + } + if (exp == NULL || (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)) return; @@ -7932,7 +8310,8 @@ resolve_transfer (gfc_code *code) code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE statement -- but in this case, we are not reading, either. */ if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ - && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE) + && gfc_check_vardef_context (exp, false, false, _("item in READ")) + == FAILURE) return; sym = exp->symtree->n.sym; @@ -7943,21 +8322,40 @@ resolve_transfer (gfc_code *code) if (ref->type == REF_COMPONENT) ts = &ref->u.c.component->ts; + if (ts->type == BT_CLASS) + { + /* FIXME: Test for defined input/output. */ + gfc_error ("Data transfer element at %L cannot be polymorphic unless " + "it is processed by a defined input/output procedure", + &code->loc); + return; + } + if (ts->type == BT_DERIVED) { /* Check that transferred derived type doesn't contain POINTER components. */ if (ts->u.derived->attr.pointer_comp) { + gfc_error ("Data transfer element at %L cannot have POINTER " + "components unless it is processed by a defined " + "input/output procedure", &code->loc); + return; + } + + /* F08:C935. */ + if (ts->u.derived->attr.proc_pointer_comp) + { gfc_error ("Data transfer element at %L cannot have " - "POINTER components", &code->loc); + "procedure pointer components", &code->loc); return; } if (ts->u.derived->attr.alloc_comp) { - gfc_error ("Data transfer element at %L cannot have " - "ALLOCATABLE components", &code->loc); + gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " + "components unless it is processed by a defined " + "input/output procedure", &code->loc); return; } @@ -7969,7 +8367,7 @@ resolve_transfer (gfc_code *code) } } - if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE + if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) { gfc_error ("Data transfer element at %L cannot be a full reference to " @@ -7999,7 +8397,7 @@ find_reachable_labels (gfc_code *block) up through the code_stack. */ for (c = block; c; c = c->next) { - if (c->here && c->op != EXEC_END_BLOCK) + if (c->here && c->op != EXEC_END_NESTED_BLOCK) bitmap_set_bit (cs_base->reachable_labels, c->here->value); } @@ -8014,6 +8412,56 @@ find_reachable_labels (gfc_code *block) static void +resolve_lock_unlock (gfc_code *code) +{ + if (code->expr1->ts.type != BT_DERIVED + || code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE + || code->expr1->rank != 0 + || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1))) + gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", + &code->expr1->where); + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + if (code->expr2 + && gfc_check_vardef_context (code->expr2, false, false, + _("STAT variable")) == FAILURE) + return; + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + + if (code->expr3 + && gfc_check_vardef_context (code->expr3, false, false, + _("ERRMSG variable")) == FAILURE) + return; + + /* Check ACQUIRED_LOCK. */ + if (code->expr4 + && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 + || code->expr4->expr_type != EXPR_VARIABLE)) + gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " + "variable", &code->expr4->where); + + if (code->expr4 + && gfc_check_vardef_context (code->expr4, false, false, + _("ACQUIRED_LOCK variable")) == FAILURE) + return; +} + + +static void resolve_sync (gfc_code *code) { /* Check imageset. The * case matches expr1 == NULL. */ @@ -8100,10 +8548,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code) whether the label is still visible outside of the CRITICAL block, which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->op == EXEC_CRITICAL - && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" - " at %L", &code->loc, &label->where); + { + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CRITICAL construct for " + "label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_DO_CONCURRENT + && 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); + } return; } @@ -8124,11 +8578,17 @@ resolve_branch (gfc_st_label *label, gfc_code *code) " at %L", &code->loc, &label->where); return; } + else if (stack->current->op == EXEC_DO_CONCURRENT) + { + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " + "label at %L", &code->loc, &label->where); + return; + } } if (stack) { - gcc_assert (stack->current->next->op == EXEC_END_BLOCK); + gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); return; } @@ -8175,11 +8635,8 @@ ignore: result = SUCCESS; over: - for (i--; i >= 0; i--) - { - mpz_clear (shape[i]); - mpz_clear (shape2[i]); - } + gfc_clear_shape (shape, i); + gfc_clear_shape (shape2, i); return result; } @@ -8440,7 +8897,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) total_var = gfc_count_forall_iterators (code); /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ - var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *)); + var_expr = XCNEWVEC (gfc_expr *, total_var); } /* The information about FORALL iterator, including FORALL index start, end @@ -8485,7 +8942,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) gcc_assert (forall_save == 0); /* VAR_EXPR is not needed any more. */ - gfc_free (var_expr); + free (var_expr); total_var = 0; } } @@ -8550,6 +9007,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: + case EXEC_DO_CONCURRENT: case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: @@ -8570,6 +9028,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OMP_SINGLE: case EXEC_OMP_TASK: case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: case EXEC_OMP_WORKSHARE: break; @@ -8738,13 +9197,34 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } } + if (gfc_implicit_pure (NULL)) + { + if (lhs->expr_type == EXPR_VARIABLE + && lhs->symtree->n.sym != gfc_current_ns->proc_name + && lhs->symtree->n.sym->ns != gfc_current_ns) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (lhs->ts.type == BT_DERIVED + && lhs->expr_type == EXPR_VARIABLE + && lhs->ts.u.derived->attr.pointer_comp + && rhs->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + } + /* F03:7.4.1.2. */ /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */ if (lhs->ts.type == BT_CLASS) { - gfc_error ("Variable must not be polymorphic in assignment at %L", - &lhs->where); + gfc_error ("Variable must not be polymorphic in intrinsic assignment at " + "%L - check that there is a matching specific subroutine " + "for '=' operator", &lhs->where); return false; } @@ -8768,7 +9248,7 @@ static void resolve_code (gfc_code *code, gfc_namespace *ns) { int omp_workshare_save; - int forall_save; + int forall_save, do_concurrent_save; code_stack frame; gfc_try t; @@ -8782,6 +9262,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { frame.current = code; forall_save = forall_flag; + do_concurrent_save = do_concurrent_flag; if (code->op == EXEC_FORALL) { @@ -8814,6 +9295,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) /* Blocks are handled in resolve_select_type because we have to transform the SELECT TYPE into ASSOCIATE first. */ break; + case EXEC_DO_CONCURRENT: + do_concurrent_flag = 1; + gfc_resolve_blocks (code->block, ns); + do_concurrent_flag = 2; + break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; @@ -8831,6 +9317,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; + do_concurrent_flag = do_concurrent_save; if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; @@ -8843,6 +9330,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { case EXEC_NOP: case EXEC_END_BLOCK: + case EXEC_END_NESTED_BLOCK: case EXEC_CYCLE: case EXEC_PAUSE: case EXEC_STOP: @@ -8860,6 +9348,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_sync (code); break; + case EXEC_LOCK: + case EXEC_UNLOCK: + resolve_lock_unlock (code); + break; + case EXEC_ENTRY: /* Keep track of which entry we are up to. */ current_entry_id = code->ext.entry->id; @@ -8899,8 +9392,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; - if (gfc_check_vardef_context (code->expr1, false, _("assignment")) - == FAILURE) + if (gfc_check_vardef_context (code->expr1, false, false, + _("assignment")) == FAILURE) break; if (resolve_ordinary_assign (code, ns)) @@ -8938,9 +9431,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) array ref may be present on the LHS and fool gfc_expr_attr used in gfc_check_vardef_context. Remove it. */ e = remove_last_array_ref (code->expr1); - t = gfc_check_vardef_context (e, true, _("pointer assignment")); + t = gfc_check_vardef_context (e, true, false, + _("pointer assignment")); if (t == SUCCESS) - t = gfc_check_vardef_context (e, false, _("pointer assignment")); + t = gfc_check_vardef_context (e, false, false, + _("pointer assignment")); gfc_free_expr (e); if (t == FAILURE) break; @@ -9090,11 +9585,13 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_transfer (code); break; + case EXEC_DO_CONCURRENT: case EXEC_FORALL: resolve_forall_iterators (code->ext.forall_iterator); - if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL) - gfc_error ("FORALL mask clause at %L requires a LOGICAL " + if (code->expr1 != NULL + && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) + gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " "expression", &code->expr1->where); break; @@ -9108,6 +9605,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: case EXEC_OMP_WORKSHARE: gfc_resolve_omp_directive (code, ns); break; @@ -9372,6 +9870,7 @@ resolve_index_expr (gfc_expr *e) return SUCCESS; } + /* Resolve a charlen structure. */ static gfc_try @@ -9521,7 +10020,7 @@ build_default_init_expr (gfc_symbol *sym) int i; /* These symbols should never have a default initialization. */ - if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as)) + if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.pointer @@ -9645,6 +10144,26 @@ build_default_init_expr (gfc_symbol *sym) gfc_free_expr (init_expr); init_expr = NULL; } + if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON + && sym->ts.u.cl->length) + { + gfc_actual_arglist *arg; + init_expr = gfc_get_expr (); + init_expr->where = sym->declared_at; + init_expr->ts = sym->ts; + init_expr->expr_type = EXPR_FUNCTION; + init_expr->value.function.isym = + gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); + init_expr->value.function.name = "repeat"; + arg = gfc_get_actual_arglist (); + arg->expr = gfc_get_character_expr (sym->ts.kind, &sym->declared_at, + NULL, 1); + arg->expr->value.character.string[0] + = gfc_option.flag_init_character_value; + arg->next = gfc_get_actual_arglist (); + arg->next->expr = gfc_copy_expr (sym->ts.u.cl->length); + init_expr->value.function.actual = arg; + } break; default: @@ -9671,10 +10190,12 @@ apply_default_init_local (gfc_symbol *sym) if (init == NULL) return; - /* For saved variables, we don't want to add an initializer at - function entry, so we just add a static initializer. */ + /* For saved variables, we don't want to add an initializer at function + entry, so we just add a static initializer. Note that automatic variables + are stack allocated even with -fno-automatic. */ if (sym->attr.save || sym->ns->save_all - || gfc_option.flag_max_stack_var_size == 0) + || (gfc_option.flag_max_stack_var_size == 0 + && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) { /* Don't clobber an existing initializer! */ gcc_assert (sym->value == NULL); @@ -9685,17 +10206,45 @@ apply_default_init_local (gfc_symbol *sym) build_init_assign (sym, init); } + /* Resolution of common features of flavors variable and procedure. */ static gfc_try resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { + gfc_array_spec *as; + + /* Avoid double diagnostics for function result symbols. */ + if ((sym->result || sym->attr.result) && !sym->attr.dummy + && (sym->ns != gfc_current_ns)) + return SUCCESS; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + /* Constraints on deferred shape variable. */ - if (sym->as == NULL || sym->as->type != AS_DEFERRED) + if (as == NULL || as->type != AS_DEFERRED) { - if (sym->attr.allocatable) + bool pointer, allocatable, dimension; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) { - if (sym->attr.dimension) + pointer = CLASS_DATA (sym)->attr.class_pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + dimension = CLASS_DATA (sym)->attr.dimension; + } + else + { + pointer = sym->attr.pointer; + allocatable = sym->attr.allocatable; + dimension = sym->attr.dimension; + } + + if (allocatable) + { + if (dimension) { gfc_error ("Allocatable array '%s' at %L must have " "a deferred shape", sym->name, &sym->declared_at); @@ -9707,7 +10256,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } - if (sym->attr.pointer && sym->attr.dimension) + if (pointer && dimension) { gfc_error ("Array pointer '%s' at %L must have a deferred shape", sym->name, &sym->declared_at); @@ -9717,7 +10266,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) else { if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer - && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc) + && sym->ts.type != BT_CLASS && !sym->assoc) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); @@ -9771,6 +10320,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { gfc_symbol *s; gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); + if (s && s->attr.generic) + s = gfc_find_dt_in_generic (s); if (s && s->attr.flavor != FL_DERIVED) { gfc_error ("The type '%s' cannot be host associated at %L " @@ -9848,12 +10399,22 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) return FAILURE; } + /* Constraints on deferred type parameter. */ + if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable)) + { + gfc_error ("Entity '%s' at %L has a deferred type parameter and " + "requires either the pointer or allocatable attribute", + sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->ts.type == BT_CHARACTER) { /* Make sure that character string variables with assumed length are dummy arguments. */ e = sym->ts.u.cl->length; - if (e == NULL && !sym->attr.dummy && !sym->attr.result) + if (e == NULL && !sym->attr.dummy && !sym->attr.result + && !sym->ts.deferred) { gfc_error ("Entity with assumed character length at %L must be a " "dummy argument or a PARAMETER", &sym->declared_at); @@ -9868,15 +10429,22 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) if (!gfc_is_constant_expr (e) && !(e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - && sym->ns->proc_name - && (sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->ns->proc_name->attr.is_main_program) - && !sym->attr.use_assoc) - { - gfc_error ("'%s' at %L must have constant character length " - "in this context", sym->name, &sym->declared_at); - return FAILURE; + && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) + { + if (!sym->attr.use_assoc && sym->ns->proc_name + && (sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program)) + { + gfc_error ("'%s' at %L must have constant character length " + "in this context", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.in_common) + { + gfc_error ("COMMON variable '%s' at %L must have constant " + "character length", sym->name, &sym->declared_at); + return FAILURE; + } } } @@ -9895,7 +10463,14 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) /* Also, they must not have the SAVE attribute. SAVE_IMPLICIT is checked below. */ - if (sym->attr.save == SAVE_EXPLICIT) + if (sym->as && sym->attr.codimension) + { + int corank = sym->as->corank; + sym->as->corank = 0; + no_init_flag = automatic_flag = is_non_constant_shape_array (sym); + sym->as->corank = corank; + } + if (automatic_flag && sym->attr.save == SAVE_EXPLICIT) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); return FAILURE; @@ -9909,7 +10484,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) /* Reject illegal initializers. */ if (!sym->mark && sym->value) { - if (sym->attr.allocatable) + if (sym->attr.allocatable || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable)) gfc_error ("Allocatable '%s' at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.external) @@ -9975,7 +10551,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) the host. */ if (!(sym->ns->parent && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) - && gfc_check_access(sym->attr.access, sym->ns->default_access)) + && gfc_check_symbol_access (sym)) { gfc_interface *iface; @@ -9984,8 +10560,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (arg->sym && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.u.derived->attr.access, - arg->sym->ts.u.derived->ns->default_access) + && !gfc_check_symbol_access (arg->sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a " "PRIVATE type and cannot be a dummy argument" " of '%s', which is PUBLIC at %L", @@ -10007,8 +10582,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (arg->sym && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.u.derived->attr.access, - arg->sym->ts.u.derived->ns->default_access) + && !gfc_check_symbol_access (arg->sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " @@ -10032,8 +10606,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (arg->sym && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc - && !gfc_check_access (arg->sym->ts.u.derived->attr.access, - arg->sym->ts.u.derived->ns->default_access) + && !gfc_check_symbol_access (arg->sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " @@ -10076,6 +10649,14 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) return FAILURE; } + if (sym->attr.proc == PROC_ST_FUNCTION + && (sym->attr.allocatable || sym->attr.pointer)) + { + gfc_error ("Statement function '%s' at %L may not have pointer or " + "allocatable attribute", sym->name, &sym->declared_at); + return FAILURE; + } + /* 5.1.1.5 of the Standard: A function name declared with an asterisk char-len-param shall not be array-valued, pointer-valued, recursive or pure. ....snip... A character value of * may only be used in the @@ -10109,8 +10690,11 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } /* Appendix B.2 of the standard. Contained functions give an - error anyway. Fixed-form is likely to be F77/legacy. */ - if (!sym->attr.contained && gfc_current_form != FORM_FIXED) + error anyway. Fixed-form is likely to be F77/legacy. Deferred + character length is an F2003 feature. */ + if (!sym->attr.contained + && gfc_current_form != FORM_FIXED + && !sym->ts.deferred) gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " "CHARACTER(*) function '%s' at %L", sym->name, &sym->declared_at); @@ -10142,7 +10726,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { /* Skip implicitly typed dummy args here. */ if (curr_arg->sym->attr.implicit_type == 0) - if (verify_c_interop_param (curr_arg->sym) == FAILURE) + if (gfc_verify_c_interop_param (curr_arg->sym) == FAILURE) /* If something is found to fail, record the fact so we can mark the symbol for the procedure as not being BIND(C) to try and prevent multiple errors being @@ -10355,200 +10939,6 @@ error: } -/* Check that it is ok for the typebound procedure proc to override the - procedure old. */ - -static gfc_try -check_typebound_override (gfc_symtree* proc, gfc_symtree* old) -{ - locus where; - const gfc_symbol* proc_target; - const gfc_symbol* old_target; - unsigned proc_pass_arg, old_pass_arg, argpos; - gfc_formal_arglist* proc_formal; - gfc_formal_arglist* old_formal; - - /* This procedure should only be called for non-GENERIC proc. */ - gcc_assert (!proc->n.tb->is_generic); - - /* If the overwritten procedure is GENERIC, this is an error. */ - if (old->n.tb->is_generic) - { - gfc_error ("Can't overwrite GENERIC '%s' at %L", - old->name, &proc->n.tb->where); - return FAILURE; - } - - where = proc->n.tb->where; - proc_target = proc->n.tb->u.specific->n.sym; - old_target = old->n.tb->u.specific->n.sym; - - /* Check that overridden binding is not NON_OVERRIDABLE. */ - if (old->n.tb->non_overridable) - { - gfc_error ("'%s' at %L overrides a procedure binding declared" - " NON_OVERRIDABLE", proc->name, &where); - return FAILURE; - } - - /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ - if (!old->n.tb->deferred && proc->n.tb->deferred) - { - gfc_error ("'%s' at %L must not be DEFERRED as it overrides a" - " non-DEFERRED binding", proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is PURE, the overriding must be, too. */ - if (old_target->attr.pure && !proc_target->attr.pure) - { - gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE", - proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it - is not, the overriding must not be either. */ - if (old_target->attr.elemental && !proc_target->attr.elemental) - { - gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be" - " ELEMENTAL", proc->name, &where); - return FAILURE; - } - if (!old_target->attr.elemental && proc_target->attr.elemental) - { - gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not" - " be ELEMENTAL, either", proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is a SUBROUTINE, the overriding must also be a - SUBROUTINE. */ - if (old_target->attr.subroutine && !proc_target->attr.subroutine) - { - gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a" - " SUBROUTINE", proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is a FUNCTION, the overriding must also be a - FUNCTION and have the same characteristics. */ - if (old_target->attr.function) - { - if (!proc_target->attr.function) - { - gfc_error ("'%s' at %L overrides a FUNCTION and must also be a" - " FUNCTION", proc->name, &where); - return FAILURE; - } - - /* FIXME: Do more comprehensive checking (including, for instance, the - rank and array-shape). */ - gcc_assert (proc_target->result && old_target->result); - if (!gfc_compare_types (&proc_target->result->ts, - &old_target->result->ts)) - { - gfc_error ("'%s' at %L and the overridden FUNCTION should have" - " matching result types", proc->name, &where); - return FAILURE; - } - } - - /* If the overridden binding is PUBLIC, the overriding one must not be - PRIVATE. */ - if (old->n.tb->access == ACCESS_PUBLIC - && proc->n.tb->access == ACCESS_PRIVATE) - { - gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be" - " PRIVATE", proc->name, &where); - return FAILURE; - } - - /* Compare the formal argument lists of both procedures. This is also abused - to find the position of the passed-object dummy arguments of both - bindings as at least the overridden one might not yet be resolved and we - need those positions in the check below. */ - proc_pass_arg = old_pass_arg = 0; - if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) - proc_pass_arg = 1; - if (!old->n.tb->nopass && !old->n.tb->pass_arg) - old_pass_arg = 1; - argpos = 1; - for (proc_formal = proc_target->formal, old_formal = old_target->formal; - proc_formal && old_formal; - proc_formal = proc_formal->next, old_formal = old_formal->next) - { - if (proc->n.tb->pass_arg - && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) - proc_pass_arg = argpos; - if (old->n.tb->pass_arg - && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) - old_pass_arg = argpos; - - /* Check that the names correspond. */ - if (strcmp (proc_formal->sym->name, old_formal->sym->name)) - { - gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as" - " to match the corresponding argument of the overridden" - " procedure", proc_formal->sym->name, proc->name, &where, - old_formal->sym->name); - return FAILURE; - } - - /* Check that the types correspond if neither is the passed-object - argument. */ - /* FIXME: Do more comprehensive testing here. */ - if (proc_pass_arg != argpos && old_pass_arg != argpos - && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts)) - { - gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L " - "in respect to the overridden procedure", - proc_formal->sym->name, proc->name, &where); - return FAILURE; - } - - ++argpos; - } - if (proc_formal || old_formal) - { - gfc_error ("'%s' at %L must have the same number of formal arguments as" - " the overridden procedure", proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is NOPASS, the overriding one must also be - NOPASS. */ - if (old->n.tb->nopass && !proc->n.tb->nopass) - { - gfc_error ("'%s' at %L overrides a NOPASS binding and must also be" - " NOPASS", proc->name, &where); - return FAILURE; - } - - /* If the overridden binding is PASS(x), the overriding one must also be - PASS and the passed-object dummy arguments must correspond. */ - if (!old->n.tb->nopass) - { - if (proc->n.tb->nopass) - { - gfc_error ("'%s' at %L overrides a binding with PASS and must also be" - " PASS", proc->name, &where); - return FAILURE; - } - - if (proc_pass_arg != old_pass_arg) - { - gfc_error ("Passed-object dummy argument of '%s' at %L must be at" - " the same position as the passed-object dummy argument of" - " the overridden procedure", proc->name, &where); - return FAILURE; - } - } - - return SUCCESS; -} - - /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ static gfc_try @@ -11010,11 +11400,14 @@ resolve_typebound_procedure (gfc_symtree* stree) overridden = gfc_find_typebound_proc (super_type, NULL, stree->name, true, NULL); - if (overridden && overridden->n.tb) - stree->n.tb->overridden = overridden->n.tb; + if (overridden) + { + if (overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; - if (overridden && check_typebound_override (stree, overridden) == FAILURE) - goto error; + if (gfc_check_typebound_override (stree, overridden) == FAILURE) + goto error; + } } /* See if there's a name collision with a component directly in this type. */ @@ -11049,9 +11442,14 @@ static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { int op; + gfc_symbol* super_type; if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; + + super_type = gfc_get_derived_super_type (derived); + if (super_type) + resolve_typebound_procedures (super_type); resolve_bindings_derived = derived; resolve_bindings_result = SUCCESS; @@ -11163,28 +11561,17 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } -/* Resolve the components of a derived type. */ +/* Resolve the components of a derived type. This does not have to wait until + resolution stage, but can be done as soon as the dt declaration has been + parsed. */ static gfc_try -resolve_fl_derived (gfc_symbol *sym) +resolve_fl_derived0 (gfc_symbol *sym) { gfc_symbol* super_type; gfc_component *c; super_type = gfc_get_derived_super_type (sym); - - if (sym->attr.is_class && sym->ts.u.derived == NULL) - { - /* Fix up incomplete CLASS symbols. */ - gfc_component *data = gfc_find_component (sym, "$data", true, true); - 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); - gcc_assert (vtab); - vptr->ts.u.derived = vtab->ts.u.derived; - } - } /* F2008, C432. */ if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) @@ -11196,7 +11583,7 @@ resolve_fl_derived (gfc_symbol *sym) } /* Ensure the extended type gets resolved before we do. */ - if (super_type && resolve_fl_derived (super_type) == FAILURE) + if (super_type && resolve_fl_derived0 (super_type) == FAILURE) return FAILURE; /* An ABSTRACT type must be extensible. */ @@ -11207,10 +11594,22 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - for (c = sym->components; c != NULL; c = c->next) + c = (sym->attr.is_class) ? sym->components->ts.u.derived->components + : sym->components; + + for ( ; c != NULL; c = c->next) { + /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */ + if (c->ts.type == BT_CHARACTER && c->ts.deferred) + { + gfc_error ("Deferred-length character component '%s' at %L is not " + "yet supported", c->name, &c->loc); + return FAILURE; + } + /* F2008, C442. */ - if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */ + if ((!sym->attr.is_class || c != sym->components) + && c->attr.codimension && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { gfc_error ("Coarray component '%s' at %L must be allocatable with " @@ -11426,13 +11825,21 @@ resolve_fl_derived (gfc_symbol *sym) } /* Check type-spec if this is not the parent-type component. */ - if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype + if (((sym->attr.is_class + && (!sym->components->ts.u.derived->attr.extension + || c != sym->components->ts.u.derived->components)) + || (!sym->attr.is_class + && (!sym->attr.extension || c != sym->components))) + && !sym->attr.vtype && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) return FAILURE; /* If this type is an extension, set the accessibility of the parent component. */ - if (super_type && c == sym->components + if (super_type + && ((sym->attr.is_class + && c == sym->components->ts.u.derived->components) + || (!sym->attr.is_class && c == sym->components)) && strcmp (super_type->name, c->name) == 0) c->attr.access = super_type->attr.access; @@ -11447,7 +11854,8 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer) + 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) == FAILURE) @@ -11461,19 +11869,34 @@ resolve_fl_derived (gfc_symbol *sym) } } + if (c->ts.type == BT_CHARACTER && c->ts.deferred + && !c->attr.pointer && !c->attr.allocatable) + { + gfc_error ("Character component '%s' of '%s' at %L with deferred " + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); + return FAILURE; + } + if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE - && gfc_check_access (sym->attr.access, sym->ns->default_access) + && gfc_check_symbol_access (sym) && !is_sym_host_assoc (c->ts.u.derived, sym->ns) && !c->ts.u.derived->attr.use_assoc - && !gfc_check_access (c->ts.u.derived->attr.access, - c->ts.u.derived->ns->default_access) + && !gfc_check_symbol_access (c->ts.u.derived) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " "is a PRIVATE type and cannot be a component of " "'%s', which is PUBLIC at %L", c->name, sym->name, &sym->declared_at) == FAILURE) return FAILURE; + 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); + return FAILURE; + } + if (sym->attr.sequence) { if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) @@ -11485,6 +11908,13 @@ resolve_fl_derived (gfc_symbol *sym) } } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) + c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); + 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); + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) @@ -11495,7 +11925,8 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer + if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) { @@ -11506,9 +11937,10 @@ resolve_fl_derived (gfc_symbol *sym) } /* C437. */ - if (c->ts.type == BT_CLASS - && !(CLASS_DATA (c)->attr.class_pointer - || CLASS_DATA (c)->attr.allocatable)) + if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE + && (!c->attr.class_ok + || !(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); @@ -11531,14 +11963,6 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - /* Resolve the type-bound procedures. */ - if (resolve_typebound_procedures (sym) == FAILURE) - return FAILURE; - - /* Resolve the finalizer procedures. */ - if (gfc_resolve_finalizers (sym) == FAILURE) - return FAILURE; - /* 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 @@ -11553,6 +11977,59 @@ resolve_fl_derived (gfc_symbol *sym) } +/* The following procedure does the full resolution of a derived type, + including resolution of all type-bound procedures (if present). In contrast + to 'resolve_fl_derived0' this can only be done after the module has been + parsed completely. */ + +static gfc_try +resolve_fl_derived (gfc_symbol *sym) +{ + gfc_symbol *gen_dt = NULL; + + if (!sym->attr.is_class) + gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); + if (gen_dt && gen_dt->generic && gen_dt->generic->next + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of " + "function '%s' at %L being the same name as derived " + "type at %L", sym->name, + gen_dt->generic->sym == sym + ? gen_dt->generic->next->sym->name + : gen_dt->generic->sym->name, + gen_dt->generic->sym == sym + ? &gen_dt->generic->next->sym->declared_at + : &gen_dt->generic->sym->declared_at, + &sym->declared_at) == FAILURE) + return FAILURE; + + if (sym->attr.is_class && sym->ts.u.derived == NULL) + { + /* Fix up incomplete CLASS symbols. */ + gfc_component *data = gfc_find_component (sym, "_data", true, true); + 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); + gcc_assert (vtab); + vptr->ts.u.derived = vtab->ts.u.derived; + } + } + + if (resolve_fl_derived0 (sym) == FAILURE) + return FAILURE; + + /* Resolve the type-bound procedures. */ + if (resolve_typebound_procedures (sym) == FAILURE) + return FAILURE; + + /* Resolve the finalizer procedures. */ + if (gfc_resolve_finalizers (sym) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + static gfc_try resolve_fl_namelist (gfc_symbol *sym) { @@ -11561,53 +12038,76 @@ resolve_fl_namelist (gfc_symbol *sym) for (nl = sym->namelist; nl; nl = nl->next) { - /* Reject namelist arrays of assumed shape. */ + /* Check again, the check in match only works if NAMELIST comes + after the decl. */ + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not " + "allowed", nl->sym->name, sym->name, &sym->declared_at); + return FAILURE; + } + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " - "must not have assumed shape in namelist " + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + "object '%s' with assumed shape in namelist " "'%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) - return FAILURE; + return FAILURE; - /* Reject namelist arrays that are not constant shape. */ - if (is_non_constant_shape_array (nl->sym)) - { - gfc_error ("NAMELIST array object '%s' must have constant " - "shape in namelist '%s' at %L", nl->sym->name, - sym->name, &sym->declared_at); - return FAILURE; - } + if (is_non_constant_shape_array (nl->sym) + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + "object '%s' with nonconstant shape in namelist " + "'%s' at %L", nl->sym->name, sym->name, + &sym->declared_at) == FAILURE) + return FAILURE; - /* Namelist objects cannot have allocatable or pointer components. */ - if (nl->sym->ts.type != BT_DERIVED) - continue; + if (nl->sym->ts.type == BT_CHARACTER + && (nl->sym->ts.u.cl->length == NULL + || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) + && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object " + "'%s' with nonconstant character length in " + "namelist '%s' at %L", nl->sym->name, sym->name, + &sym->declared_at) == FAILURE) + return FAILURE; - if (nl->sym->ts.u.derived->attr.alloc_comp) + /* FIXME: Once UDDTIO is implemented, the following can be + removed. */ + if (nl->sym->ts.type == BT_CLASS) { - gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " - "have ALLOCATABLE components", - nl->sym->name, sym->name, &sym->declared_at); + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is " + "polymorphic and requires a defined input/output " + "procedure", nl->sym->name, sym->name, &sym->declared_at); return FAILURE; } - if (nl->sym->ts.u.derived->attr.pointer_comp) + if (nl->sym->ts.type == BT_DERIVED + && (nl->sym->ts.u.derived->attr.alloc_comp + || nl->sym->ts.u.derived->attr.pointer_comp)) { - gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " - "have POINTER components", - nl->sym->name, sym->name, &sym->declared_at); + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object " + "'%s' in namelist '%s' at %L with ALLOCATABLE " + "or POINTER components", nl->sym->name, + sym->name, &sym->declared_at) == FAILURE) + return FAILURE; + + /* FIXME: Once UDDTIO is implemented, the following can be + removed. */ + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has " + "ALLOCATABLE or POINTER components and thus requires " + "a defined input/output procedure", nl->sym->name, + sym->name, &sym->declared_at); return FAILURE; } } /* Reject PRIVATE objects in a PUBLIC namelist. */ - if (gfc_check_access(sym->attr.access, sym->ns->default_access)) + if (gfc_check_symbol_access (sym)) { for (nl = sym->namelist; nl; nl = nl->next) { if (!nl->sym->attr.use_assoc && !is_sym_host_assoc (nl->sym, sym->ns) - && !gfc_check_access(nl->sym->attr.access, - nl->sym->ns->default_access)) + && !gfc_check_symbol_access (nl->sym)) { gfc_error ("NAMELIST object '%s' was declared PRIVATE and " "cannot be member of PUBLIC namelist '%s' at %L", @@ -11628,9 +12128,7 @@ resolve_fl_namelist (gfc_symbol *sym) /* Types with private components that are defined in the same module. */ if (nl->sym->ts.type == BT_DERIVED && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) - && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp - ? ACCESS_PRIVATE : ACCESS_UNKNOWN, - nl->sym->ns->default_access)) + && nl->sym->ts.u.derived->attr.private_comp) { gfc_error ("NAMELIST object '%s' has PRIVATE components and " "cannot be a member of PUBLIC namelist '%s' at %L", @@ -11721,12 +12219,9 @@ resolve_symbol (gfc_symbol *sym) gfc_symtree *this_symtree; gfc_namespace *ns; gfc_component *c; + symbol_attribute class_attr; + gfc_array_spec *as; - /* Avoid double resolution of function result symbols. */ - if ((sym->result || sym->attr.result) && !sym->attr.dummy - && (sym->ns != gfc_current_ns)) - return; - if (sym->attr.flavor == FL_UNKNOWN) { @@ -11736,7 +12231,9 @@ resolve_symbol (gfc_symbol *sym) for (ns = gfc_current_ns->parent; ns; ns = ns->parent) { symtree = gfc_find_symtree (ns->sym_root, sym->name); - if (symtree && symtree->n.sym->generic) + if (symtree && (symtree->n.sym->generic || + (symtree->n.sym->attr.flavor == FL_PROCEDURE + && sym->ns->construct_entities))) { this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); @@ -11780,18 +12277,6 @@ resolve_symbol (gfc_symbol *sym) 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; @@ -11817,7 +12302,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->ts.type == BT_UNKNOWN) { if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) - gfc_set_default_type (sym, 1, NULL); + { + gfc_set_default_type (sym, 1, NULL); + } if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external && !sym->attr.function && !sym->attr.subroutine @@ -11847,19 +12334,44 @@ resolve_symbol (gfc_symbol *sym) } } } + else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) + gfc_resolve_array_spec (sym->result->as, false); + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + { + as = CLASS_DATA (sym)->as; + class_attr = CLASS_DATA (sym)->attr; + class_attr.pointer = class_attr.class_pointer; + } + else + { + class_attr = sym->attr; + as = sym->as; + } + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!class_attr.dimension + || (as->type != AS_ASSUMED_SHAPE && !class_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; + } /* Assumed size arrays and assumed shape arrays must be dummy arguments. Array-spec's of implied-shape should have been resolved to AS_EXPLICIT already. */ - if (sym->as) + if (as) { - gcc_assert (sym->as->type != AS_IMPLIED_SHAPE); - if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed) - || sym->as->type == AS_ASSUMED_SHAPE) + gcc_assert (as->type != AS_IMPLIED_SHAPE); + if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) + || as->type == AS_ASSUMED_SHAPE) && sym->attr.dummy == 0) { - if (sym->as->type == AS_ASSUMED_SIZE) + if (as->type == AS_ASSUMED_SIZE) gfc_error ("Assumed size array at %L must be a dummy argument", &sym->declared_at); else @@ -11908,6 +12420,20 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->attr.generic) + { + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + if (!sym->ts.u.derived) + { + gfc_error ("The derived type '%s' at %L is of type '%s', " + "which has not been defined", sym->name, + &sym->declared_at, sym->ts.u.derived->name); + sym->ts.type = BT_UNKNOWN; + return; + } + } + /* If the symbol is marked as bind(c), verify it's type and kind. Do not do this for something that was implicitly typed because that is handled in gfc_set_default_type. Handle dummy arguments and procedure @@ -11977,7 +12503,8 @@ resolve_symbol (gfc_symbol *sym) the type is not declared in the scope of the implicit statement. Change the type to BT_UNKNOWN, both because it is so and to prevent an ICE. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->components == NULL && !sym->ts.u.derived->attr.zero_comp) { gfc_error ("The derived type '%s' at %L is of type '%s', " @@ -11993,23 +12520,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE) - { - gfc_symbol *ds; - - if (resolve_fl_derived (sym->ts.u.derived) == FAILURE) - return; - - gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds); - if (!ds && sym->attr.function - && gfc_check_access (sym->attr.access, sym->ns->default_access)) - { - symtree = gfc_new_symtree (&sym->ns->sym_root, - sym->ts.u.derived->name); - symtree->n.sym = sym->ts.u.derived; - sym->ts.u.derived->refs++; - } - } + && sym->ns->proc_name->attr.flavor == FL_MODULE + && resolve_fl_derived (sym->ts.u.derived) == FAILURE) + return; /* Unless the derived-type declaration is use associated, Fortran 95 does not allow public entries of private derived types. @@ -12018,9 +12531,8 @@ resolve_symbol (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE && !sym->ts.u.derived->attr.use_assoc - && gfc_check_access (sym->attr.access, sym->ns->default_access) - && !gfc_check_access (sym->ts.u.derived->attr.access, - sym->ts.u.derived->ns->default_access) + && gfc_check_symbol_access (sym) + && !gfc_check_symbol_access (sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L " "of PRIVATE derived type '%s'", (sym->attr.flavor == FL_PARAMETER) ? "parameter" @@ -12028,6 +12540,19 @@ resolve_symbol (gfc_symbol *sym) sym->ts.u.derived->name) == FAILURE) return; + /* F2008, C1302. */ + if (sym->ts.type == BT_DERIVED + && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || sym->ts.u.derived->attr.lock_comp) + && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) + { + gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of " + "type LOCK_TYPE must be a coarray", sym->name, + &sym->declared_at); + return; + } + /* An assumed-size array with INTENT(OUT) shall not be of a type for which default initialization is defined (5.1.2.4.4). */ if (sym->ts.type == BT_DERIVED @@ -12048,61 +12573,99 @@ resolve_symbol (gfc_symbol *sym) } } - /* F2008, C526. */ - if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || sym->attr.codimension) - && sym->attr.result) - gfc_error ("Function result '%s' at %L shall not be a coarray or have " - "a coarray component", sym->name, &sym->declared_at); + /* F2008, C542. */ + if (sym->ts.type == BT_DERIVED && sym->attr.dummy + && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) + { + gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be " + "INTENT(OUT)", sym->name, &sym->declared_at); + return; + } + + /* F2008, C525. */ + if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->attr.coarray_comp)) + || class_attr.codimension) + && (sym->attr.result || sym->result == sym)) + { + gfc_error ("Function result '%s' at %L shall not be a coarray or have " + "a coarray component", sym->name, &sym->declared_at); + return; + } /* F2008, C524. */ if (sym->attr.codimension && sym->ts.type == BT_DERIVED && sym->ts.u.derived->ts.is_iso_c) - gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " - "shall not be a coarray", sym->name, &sym->declared_at); + { + gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", sym->name, &sym->declared_at); + return; + } /* F2008, C525. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp - && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension - || sym->attr.allocatable)) - gfc_error ("Variable '%s' at %L with coarray component " - "shall be a nonpointer, nonallocatable scalar", - sym->name, &sym->declared_at); + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->attr.coarray_comp)) + && (class_attr.codimension || class_attr.pointer || class_attr.dimension + || class_attr.allocatable)) + { + gfc_error ("Variable '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + sym->name, &sym->declared_at); + return; + } /* F2008, C526. The function-result case was handled above. */ - if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || sym->attr.codimension) - && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save + if (class_attr.codimension + && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save + || sym->attr.select_type_temporary + || sym->ns->save_all || sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) - gfc_error ("Variable '%s' at %L is a coarray or has a coarray " - "component and is not ALLOCATABLE, SAVE nor a " - "dummy argument", sym->name, &sym->declared_at); - /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */ - else if (sym->attr.codimension && !sym->attr.allocatable - && sym->as && sym->as->cotype == AS_DEFERRED) - gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " - "deferred shape", sym->name, &sym->declared_at); - else if (sym->attr.codimension && sym->attr.allocatable - && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED)) - gfc_error ("Allocatable coarray variable '%s' at %L must have " - "deferred shape", sym->name, &sym->declared_at); - + { + gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE " + "nor a dummy argument", sym->name, &sym->declared_at); + return; + } + /* F2008, C528. */ + else if (class_attr.codimension && !sym->attr.select_type_temporary + && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) + { + gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " + "deferred shape", sym->name, &sym->declared_at); + return; + } + else if (class_attr.codimension && class_attr.allocatable && as + && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED)) + { + gfc_error ("Allocatable coarray variable '%s' at %L must have " + "deferred shape", sym->name, &sym->declared_at); + return; + } /* F2008, C541. */ - if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || (sym->attr.codimension && sym->attr.allocatable)) + if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->attr.coarray_comp)) + || (class_attr.codimension && class_attr.allocatable)) && sym->attr.dummy && sym->attr.intent == INTENT_OUT) - gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an " - "allocatable coarray or have coarray components", - sym->name, &sym->declared_at); + { + gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an " + "allocatable coarray or have coarray components", + sym->name, &sym->declared_at); + return; + } - if (sym->attr.codimension && sym->attr.dummy + if (class_attr.codimension && sym->attr.dummy && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) - gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) " - "procedure '%s'", sym->name, &sym->declared_at, - sym->ns->proc_name->name); + { + gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) " + "procedure '%s'", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + return; + } switch (sym->attr.flavor) { @@ -12277,18 +12840,18 @@ check_data_variable (gfc_data_variable *var, locus *where) has_pointer = sym->attr.pointer; + if (gfc_is_coindexed (e)) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name, + where); + return FAILURE; + } + for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) has_pointer = 1; - if (ref->type == REF_ARRAY && ref->u.ar.codimen) - { - gfc_error ("DATA element '%s' at %L cannot have a coindex", - sym->name, where); - return FAILURE; - } - if (has_pointer && ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) @@ -12385,8 +12948,8 @@ check_data_variable (gfc_data_variable *var, locus *where) mpz_set_ui (size, 0); } - t = gfc_assign_data_value_range (var->expr, values.vnode->expr, - offset, range); + t = gfc_assign_data_value (var->expr, values.vnode->expr, + offset, &range); mpz_add (offset, offset, range); mpz_clear (range); @@ -12401,7 +12964,8 @@ check_data_variable (gfc_data_variable *var, locus *where) mpz_sub_ui (values.left, values.left, 1); mpz_sub_ui (size, size, 1); - t = gfc_assign_data_value (var->expr, values.vnode->expr, offset); + t = gfc_assign_data_value (var->expr, values.vnode->expr, + offset, NULL); if (t == FAILURE) break; @@ -12668,6 +13232,35 @@ gfc_pure (gfc_symbol *sym) } +/* Test whether a symbol is implicitly pure or not. For a NULL pointer, + checks if the current namespace is implicitly pure. Note that this + function returns false for a PURE procedure. */ + +int +gfc_implicit_pure (gfc_symbol *sym) +{ + gfc_namespace *ns; + + if (sym == NULL) + { + /* Check if the current procedure is implicit_pure. Walk up + the procedure list until we find a procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return 0; + + if (sym->attr.flavor == FL_PROCEDURE) + break; + } + } + + return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure + && !sym->attr.pure; +} + + /* Test whether the current procedure is elemental or not. */ int @@ -12919,7 +13512,7 @@ resolve_equivalence (gfc_equiv *eq) e->ts.u.cl = NULL; } ref = ref->next; - gfc_free (mem); + free (mem); } /* Any further ref is an error. */ @@ -13103,9 +13696,8 @@ resolve_fntype (gfc_namespace *ns) if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc && !sym->attr.contained - && !gfc_check_access (sym->ts.u.derived->attr.access, - sym->ts.u.derived->ns->default_access) - && gfc_check_access (sym->attr.access, sym->ns->default_access)) + && !gfc_check_symbol_access (sym->ts.u.derived) + && gfc_check_symbol_access (sym)) { gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at " "%L of PRIVATE type '%s'", sym->name, @@ -13254,6 +13846,10 @@ resolve_types (gfc_namespace *ns) resolve_contained_functions (ns); + if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE + && ns->proc_name->attr.if_source == IFSRC_IFBODY) + resolve_formal_arglist (ns->proc_name); + gfc_traverse_ns (ns, resolve_bind_c_derived_types); for (cl = ns->cl_list; cl; cl = cl->next) @@ -13274,6 +13870,7 @@ resolve_types (gfc_namespace *ns) } forall_flag = 0; + do_concurrent_flag = 0; gfc_check_interfaces (ns); gfc_traverse_ns (ns, resolve_values); @@ -13314,6 +13911,9 @@ resolve_codes (gfc_namespace *ns) gfc_namespace *n; bitmap_obstack old_obstack; + if (ns->resolved == 1) + return; + for (n = ns->contained; n; n = n->sibling) resolve_codes (n);