X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Ffortran%2Fresolve.c;h=a6dd0dacdd0c74aed81a9ba8f2f96d6d8e3a8e61;hb=0e8d854eb8bbfc44c1fd9d2fa6e07514d2932e0e;hp=9814c14753af7d5c6ec89a4d03abf951a1f0c681;hpb=8ae1ec924d6775e4ed3dab5546ff8344b63321ee;p=gcc.git diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9814c14753a..a6dd0dacdd0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "obstack.h" @@ -63,7 +64,13 @@ static code_stack *cs_base = NULL; static int forall_flag; static int do_concurrent_flag; -static bool assumed_type_expr_allowed = false; +/* True when we are resolving an expression that is an actual argument to + a procedure. */ +static bool actual_arg = false; +/* True when we are resolving an expression that is the first actual argument + to a procedure. */ +static bool first_actual_arg = false; + /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -85,6 +92,7 @@ static bitmap_obstack labels_obstack; /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ static bool inquiry_argument = false; + int gfc_is_formal_arg (void) { @@ -131,7 +139,6 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) static void resolve_symbol (gfc_symbol *sym); -static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ @@ -139,28 +146,62 @@ static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); static gfc_try resolve_procedure_interface (gfc_symbol *sym) { - if (sym->ts.interface == sym) + gfc_symbol *ifc = sym->ts.interface; + + if (!ifc) + return SUCCESS; + + /* Several checks for F08:C1216. */ + if (ifc == sym) { gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", sym->name, &sym->declared_at); return FAILURE; } - if (sym->ts.interface->attr.procedure) + if (ifc->attr.procedure) { gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared " - "in a later PROCEDURE statement", sym->ts.interface->name, + "in a later PROCEDURE statement", ifc->name, sym->name, &sym->declared_at); return FAILURE; } + if (ifc->generic) + { + /* For generic interfaces, check if there is + a specific procedure with the same name. */ + gfc_interface *gen = ifc->generic; + while (gen && strcmp (gen->sym->name, ifc->name) != 0) + gen = gen->next; + if (!gen) + { + gfc_error ("Interface '%s' at %L may not be generic", + ifc->name, &sym->declared_at); + return FAILURE; + } + } + if (ifc->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Interface '%s' at %L may not be a statement function", + ifc->name, &sym->declared_at); + return FAILURE; + } + if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) + || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) + ifc->attr.intrinsic = 1; + if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) + { + gfc_error ("Intrinsic procedure '%s' not allowed in " + "PROCEDURE statement at %L", ifc->name, &sym->declared_at); + return FAILURE; + } /* Get the attributes from the interface (now resolved). */ - if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic) + if (ifc->attr.if_source || ifc->attr.intrinsic) { - gfc_symbol *ifc = sym->ts.interface; resolve_symbol (ifc); if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -172,7 +213,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->ts.interface = ifc; sym->attr.function = ifc->attr.function; sym->attr.subroutine = ifc->attr.subroutine; - gfc_copy_formal_args (sym, ifc); + gfc_copy_formal_args (sym, ifc, IFSRC_DECL); sym->attr.allocatable = ifc->attr.allocatable; sym->attr.pointer = ifc->attr.pointer; @@ -205,10 +246,10 @@ resolve_procedure_interface (gfc_symbol *sym) return FAILURE; } } - else if (sym->ts.interface->name[0] != '\0') + else if (ifc->name[0] != '\0') { gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", - sym->ts.interface->name, sym->name, &sym->declared_at); + ifc->name, sym->name, &sym->declared_at); return FAILURE; } @@ -239,7 +280,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc) || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank > 0)) + || (sym->as && sym->as->rank != 0)) { proc->attr.always_explicit = 1; sym->attr.always_explicit = 1; @@ -249,6 +290,8 @@ resolve_formal_arglist (gfc_symbol *proc) for (f = proc->formal; f; f = f->next) { + gfc_array_spec *as; + sym = f->sym; if (sym == NULL) @@ -264,9 +307,9 @@ resolve_formal_arglist (gfc_symbol *proc) &proc->declared_at); continue; } - else if (sym->attr.procedure && sym->ts.interface - && sym->attr.if_source != IFSRC_DECL) - resolve_procedure_interface (sym); + else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL + && resolve_procedure_interface (sym) == FAILURE) + return; if (sym->attr.if_source != IFSRC_UNKNOWN) resolve_formal_arglist (sym); @@ -283,23 +326,34 @@ resolve_formal_arglist (gfc_symbol *proc) gfc_set_default_type (sym, 1, sym->ns); } - gfc_resolve_array_spec (sym->as, 0); + as = sym->ts.type == BT_CLASS && sym->attr.class_ok + ? CLASS_DATA (sym)->as : sym->as; + + gfc_resolve_array_spec (as, 0); /* We can't tell if an array with dimension (:) is assumed or deferred 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) + if (as && as->rank > 0 && as->type == AS_DEFERRED + && ((sym->ts.type != BT_CLASS + && !(sym->attr.pointer || sym->attr.allocatable)) + || (sym->ts.type == BT_CLASS + && !(CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable))) && sym->attr.flavor != FL_PROCEDURE) { - sym->as->type = AS_ASSUMED_SHAPE; - for (i = 0; i < sym->as->rank; i++) - sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1); + as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < as->rank; i++) + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); } - if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) + || (as && as->type == AS_ASSUMED_RANK) || sym->attr.pointer || sym->attr.allocatable || sym->attr.target + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && (CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.target)) || sym->attr.optional) { proc->attr.always_explicit = 1; @@ -330,7 +384,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (proc->attr.function && sym->attr.intent != INTENT_IN) { if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + gfc_notify_std (GFC_STD_F2008, "Argument '%s'" " of pure function '%s' at %L with VALUE " "attribute but without INTENT(IN)", sym->name, proc->name, &sym->declared_at); @@ -343,7 +397,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) { if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + gfc_notify_std (GFC_STD_F2008, "Argument '%s'" " of pure subroutine '%s' at %L with VALUE " "attribute but without INTENT", sym->name, proc->name, &sym->declared_at); @@ -722,7 +776,7 @@ resolve_entries (gfc_namespace *ns) && ts->u.cl->length->expr_type == EXPR_CONSTANT && mpz_cmp (ts->u.cl->length->value.integer, fts->u.cl->length->value.integer) != 0))) - gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with " + gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " "entries returning variables of different " "string lengths", ns->entries->sym->name, &ns->entries->sym->declared_at); @@ -915,12 +969,12 @@ resolve_common_blocks (gfc_symtree *common_root) sym->name, &common_root->n.common->where); else if (sym->attr.result || gfc_is_function_return_value (sym, gfc_current_ns)) - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a function result", sym->name, &common_root->n.common->where); else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL && sym->attr.proc != PROC_ST_FUNCTION) - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a global procedure", sym->name, &common_root->n.common->where); } @@ -1152,7 +1206,7 @@ resolve_structure_cons (gfc_expr *expr, int init) } if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, - err, sizeof (err))) + err, sizeof (err), NULL, NULL)) { gfc_error ("Interface mismatch for procedure-pointer component " "'%s' in structure constructor at %L: %s", @@ -1401,7 +1455,7 @@ count_specific_procs (gfc_expr *e) /* See if a call to sym could possibly be a not allowed RECURSION because of - a missing RECURIVE declaration. This means that either sym is the current + a missing RECURSIVE declaration. This means that either sym is the current context itself, or sym is the parent of a contained procedure calling its non-RECURSIVE containing procedure. This also works if sym is an ENTRY. */ @@ -1478,8 +1532,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) /* Resolve an intrinsic procedure: Set its function/subroutine attribute, its typespec and formal argument list. */ -static gfc_try -resolve_intrinsic (gfc_symbol *sym, locus *loc) +gfc_try +gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_intrinsic_sym* isym = NULL; const char* symstd; @@ -1567,7 +1621,7 @@ resolve_procedure_expression (gfc_expr* expr) sym = expr->symtree->n.sym; if (sym->attr.intrinsic) - resolve_intrinsic (sym, &expr->where); + gfc_resolve_intrinsic (sym, &expr->where); if (sym->attr.flavor != FL_PROCEDURE || (sym->attr.function && sym->result == sym)) @@ -1598,8 +1652,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_symtree *parent_st; gfc_expr *e; int save_need_full_assumed_size; + gfc_try return_value = FAILURE; + bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; - assumed_type_expr_allowed = true; + actual_arg = true; + first_actual_arg = true; for (; arg; arg = arg->next) { @@ -1613,9 +1670,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("Label %d referenced at %L is never defined", arg->label->value, &arg->label->where); - return FAILURE; + goto cleanup; } } + first_actual_arg = false; continue; } @@ -1623,7 +1681,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, && e->symtree->n.sym->attr.generic && no_formal_args && count_specific_procs (e) != 1) - return FAILURE; + goto cleanup; if (e->ts.type != BT_PROCEDURE) { @@ -1631,7 +1689,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (gfc_resolve_expr (e) != SUCCESS) - return FAILURE; + goto cleanup; need_full_assumed_size = save_need_full_assumed_size; goto argument_list; } @@ -1648,10 +1706,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* If a procedure is not already determined to be something else check if it is intrinsic. */ - if (!sym->attr.intrinsic - && !(sym->attr.external || sym->attr.use_assoc - || sym->attr.if_source == IFSRC_IFBODY) - && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) + if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) sym->attr.intrinsic = 1; if (sym->attr.proc == PROC_ST_FUNCTION) @@ -1672,10 +1727,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, && sym->ns->proc_name->attr.flavor != FL_MODULE) { if (gfc_notify_std (GFC_STD_F2008, - "Fortran 2008: Internal procedure '%s' is" + "Internal procedure '%s' is" " used as actual argument at %L", sym->name, &e->where) == FAILURE) - return FAILURE; + goto cleanup; } if (sym->attr.elemental && !sym->attr.intrinsic) @@ -1688,8 +1743,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* Check if a generic interface has a specific procedure with the same name before emitting an error. */ if (sym->attr.generic && count_specific_procs (e) != 1) - return FAILURE; - + goto cleanup; + /* Just in case a specific was found for the expression. */ sym = e->symtree->n.sym; @@ -1710,7 +1765,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_error ("Unable to find a specific INTRINSIC procedure " "for the reference '%s' at %L", sym->name, &e->where); - return FAILURE; + goto cleanup; } sym->ts = isym->ts; sym->attr.intrinsic = 1; @@ -1718,7 +1773,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto cleanup; goto argument_list; } @@ -1730,7 +1785,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) { gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where); - return FAILURE; + goto cleanup; } if (parent_st == NULL) @@ -1744,7 +1799,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, || sym->attr.external) { if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto cleanup; goto argument_list; } @@ -1772,7 +1827,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (gfc_resolve_expr (e) != SUCCESS) - return FAILURE; + goto cleanup; need_full_assumed_size = save_need_full_assumed_size; argument_list: @@ -1786,14 +1841,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("By-value argument at %L is not of numeric " "type", &e->where); - return FAILURE; + goto cleanup; } if (e->rank) { gfc_error ("By-value argument at %L cannot be an array or " "an array section", &e->where); - return FAILURE; + goto cleanup; } /* Intrinsics are still PROC_UNKNOWN here. However, @@ -1807,7 +1862,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("By-value argument at %L is not allowed " "in this context", &e->where); - return FAILURE; + goto cleanup; } } @@ -1819,23 +1874,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("Passing internal procedure at %L by location " "not allowed", &e->where); - return FAILURE; + goto cleanup; } } } /* Fortran 2008, C1237. */ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) - && gfc_has_ultimate_pointer (e)) - { - gfc_error ("Coindexed actual argument at %L with ultimate pointer " + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " "component", &e->where); - return FAILURE; - } + goto cleanup; + } + + first_actual_arg = false; } - assumed_type_expr_allowed = false; - return SUCCESS; + return_value = SUCCESS; + +cleanup: + actual_arg = actual_arg_sav; + first_actual_arg = first_actual_arg_sav; + + return return_value; } @@ -1895,7 +1957,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) /* The rank of an elemental is the rank of its array argument(s). */ for (arg = arg0; arg; arg = arg->next) { - if (arg->expr != NULL && arg->expr->rank > 0) + if (arg->expr != NULL && arg->expr->rank != 0) { rank = arg->expr->rank; if (arg->expr->expr_type == EXPR_VARIABLE @@ -1957,7 +2019,6 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) "ELEMENTAL procedure unless there is a non-optional " "argument with the same rank (12.4.1.5)", arg->expr->symtree->n.sym->name, &arg->expr->where); - return FAILURE; } } @@ -2195,6 +2256,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* TS 29113, 6.2. */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_RANK) + { + gfc_error ("Procedure '%s' at %L with assumed-rank dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } /* F2008, 12.4.2.2 (2c) */ else if (arg->sym->attr.codimension) { @@ -2220,6 +2290,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + else if (arg->sym->ts.type == BT_ASSUMED) + { + gfc_error ("Procedure '%s' at %L with assumed-type dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } } if (def_sym->attr.function) @@ -2553,8 +2632,7 @@ static bool is_external_proc (gfc_symbol *sym) { if (!sym->attr.dummy && !sym->attr.contained - && !(sym->attr.intrinsic - || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) + && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) && sym->attr.proc != PROC_ST_FUNCTION && !sym->attr.proc_pointer && !sym->attr.use_assoc @@ -2963,20 +3041,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { /* TODO: Update this error message to allow for procedure pointers once they are implemented. */ - gfc_error_now ("Parameter '%s' to '%s' at %L must be a " + gfc_error_now ("Argument '%s' to '%s' at %L must be a " "procedure", args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } - else if (args_sym->attr.is_bind_c != 1) - { - gfc_error_now ("Parameter '%s' to '%s' at %L must be " - "BIND(C)", - args_sym->name, sym->name, - &(args->expr->where)); - retval = FAILURE; - } + else if (args_sym->attr.is_bind_c != 1 + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "argument '%s' to '%s' at %L", + args_sym->name, sym->name, + &(args->expr->where)) == FAILURE) + retval = FAILURE; } /* for c_loc/c_funloc, the new symbol is the same as the old one */ @@ -3015,7 +3091,7 @@ resolve_function (gfc_expr *expr) return SUCCESS; if (sym && sym->attr.intrinsic - && resolve_intrinsic (sym, &expr->where) == FAILURE) + && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) @@ -3431,7 +3507,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* Make sure the actual arguments are in the necessary order (based on the formal args) before resolving. */ - gfc_procedure_use (sym, &c->ext.actual, &(c->loc)); + if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE) + { + c->resolved_sym = sym; + return MATCH_ERROR; + } if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) || (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) @@ -3442,6 +3522,15 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) { + if (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR) + { + gfc_error ("Argument at %L to C_F_POINTER shall have the type" + " C_PTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + /* Make sure we got a third arg if the second arg has non-zero rank. We must also check that the type and rank are correct since we short-circuit this check in @@ -3467,7 +3556,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) } } } - + else /* ISOCBINDING_F_PROCPOINTER. */ + { + if (c->ext.actual + && (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_FUNPTR)) + { + gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type " + "C_FUNPTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + if (c->ext.actual && c->ext.actual->next + && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "procedure-pointer at %L to C_F_FUNPOINTER", + &c->ext.actual->next->expr->where) + == FAILURE) + m = MATCH_ERROR; + } + if (m != MATCH_ERROR) { /* the 1 means to add the optional arg to formal list */ @@ -4450,7 +4558,7 @@ gfc_resolve_index_1 (gfc_expr *index, int check_scalar, } if (index->ts.type == BT_REAL) - if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L", + if (gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", &index->where) == FAILURE) return FAILURE; @@ -4965,7 +5073,7 @@ expression_shape (gfc_expr *e) mpz_t array[GFC_MAX_DIMENSIONS]; int i; - if (e->rank == 0 || e->shape != NULL) + if (e->rank <= 0 || e->shape != NULL) return; for (i = 0; i < e->rank; i++) @@ -5068,23 +5176,79 @@ resolve_variable (gfc_expr *e) sym = e->symtree->n.sym; /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed) + if (e->ts.type == BT_ASSUMED) { - gfc_error ("Invalid expression with assumed-type variable %s at %L", - sym->name, &e->where); - return FAILURE; + if (!actual_arg) + { + gfc_error ("Assumed-type variable %s at %L may only be used " + "as actual argument", sym->name, &e->where); + return FAILURE; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-type variable %s at %L as actual argument to " + "an inquiry function shall be the first argument", + sym->name, &e->where); + return FAILURE; + } + } + + /* TS 29113, C535b. */ + if ((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + { + if (!actual_arg) + { + gfc_error ("Assumed-rank variable %s at %L may only be used as " + "actual argument", sym->name, &e->where); + return FAILURE; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-rank variable %s at %L as actual argument " + "to an inquiry function shall be the first argument", + sym->name, &e->where); + return FAILURE; + } } /* TS 29113, 407b. */ if (e->ts.type == BT_ASSUMED && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL - && e->ref->next == NULL)) + && e->ref->next == NULL)) { - gfc_error ("Assumed-type variable %s with designator at %L", - sym->name, &e->ref->u.ar.where); + gfc_error ("Assumed-type variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); return FAILURE; } + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); + return FAILURE; + } + + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ @@ -5585,7 +5749,7 @@ update_ppc_arglist (gfc_expr* e) return FAILURE; /* F08:R739. */ - if (po->rank > 0) + if (po->rank != 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); return FAILURE; @@ -5633,7 +5797,7 @@ check_typebound_baseobject (gfc_expr* e) /* F08:C1230. If the procedure called is NOPASS, the base object must be scalar. */ - if (e->value.compcall.tbp->nopass && base->rank > 0) + if (e->value.compcall.tbp->nopass && base->rank != 0) { gfc_error ("Base object for NOPASS type-bound procedure call at %L must" " be scalar", &e->where); @@ -5684,7 +5848,7 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, derived = e->value.compcall.base_object->ts.u.derived; st = NULL; - /* If necessary, go throught the inheritance chain. */ + /* If necessary, go through the inheritance chain. */ while (!st && derived) { /* Look for the typebound procedure 'name'. */ @@ -6295,15 +6459,22 @@ gfc_try gfc_resolve_expr (gfc_expr *e) { gfc_try t; - bool inquiry_save; + bool inquiry_save, actual_arg_save, first_actual_arg_save; if (e == NULL) return SUCCESS; /* inquiry_argument only applies to variables. */ inquiry_save = inquiry_argument; + actual_arg_save = actual_arg; + first_actual_arg_save = first_actual_arg; + if (e->expr_type != EXPR_VARIABLE) - inquiry_argument = false; + { + inquiry_argument = false; + actual_arg = false; + first_actual_arg = false; + } switch (e->expr_type) { @@ -6393,6 +6564,8 @@ gfc_resolve_expr (gfc_expr *e) fixup_charlen (e); inquiry_argument = inquiry_save; + actual_arg = actual_arg_save; + first_actual_arg = first_actual_arg_save; return t; } @@ -6420,7 +6593,7 @@ gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, { if (real_ok) return gfc_notify_std (GFC_STD_F95_DEL, - "Deleted feature: %s at %L must be integer", + "%s at %L must be integer", _(name_msgid), &expr->where); else { @@ -6879,7 +7052,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_component *c; gfc_try t; - /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR + /* Mark the utmost array component as being in allocate to allow DIMEN_STAR checking of coarrays. */ for (ref = e->ref; ref; ref = ref->next) if (ref->next == NULL) @@ -6986,6 +7159,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } } + /* Check for F08:C628. */ if (allocatable == 0 && pointer == 0) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", @@ -7130,7 +7304,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (dimension == 0 && codimension == 0) goto success; - /* Make sure the last reference node is an array specifiction. */ + /* Make sure the last reference node is an array specification. */ if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL || (dimension && ref2->u.ar.dimen == 0)) @@ -7325,8 +7499,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) } } - /* Check that an allocate-object appears only once in the statement. - FIXME: Checking derived types is disabled. */ + /* Check that an allocate-object appears only once in the statement. */ + for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; @@ -7376,9 +7550,10 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) { 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; + if ((par->start[0] != NULL || qar->start[0] != NULL) + && gfc_dep_compare_expr (par->start[0], + qar->start[0]) != 0) + break; } } else @@ -8200,7 +8375,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Chain in the new list only if it is marked as dangling. Otherwise there is a CASE label overlap and this is already used. Just ignore, - the error is diagonsed elsewhere. */ + the error is diagnosed elsewhere. */ if (st->n.sym->assoc->dangling) { new_st->ext.block.assoc = st->n.sym->assoc; @@ -9156,7 +9331,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) rhs = code->expr2; if (rhs->is_boz - && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside " + && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " "a DATA statement and outside INT/REAL/DBLE/CMPLX", &code->loc) == FAILURE) return false; @@ -9366,7 +9541,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; - /* FALLTHROUGH */ + /* FALL THROUGH */ default: gfc_resolve_blocks (code->block, ns); break; @@ -9945,12 +10120,24 @@ resolve_charlen (gfc_charlen *cl) cl->resolved = 1; - specification_expr = 1; - if (resolve_index_expr (cl->length) == FAILURE) + if (cl->length_from_typespec) { - specification_expr = 0; - return FAILURE; + if (gfc_resolve_expr (cl->length) == FAILURE) + return FAILURE; + + if (gfc_simplify_expr (cl->length, 0) == FAILURE) + return FAILURE; + } + else + { + specification_expr = 1; + + if (resolve_index_expr (cl->length) == FAILURE) + { + specification_expr = 0; + return FAILURE; + } } /* "If the character length parameter value evaluates to a negative @@ -10091,7 +10278,8 @@ build_default_init_expr (gfc_symbol *sym) || sym->attr.data || sym->module || sym->attr.cray_pointee - || sym->attr.cray_pointer) + || sym->attr.cray_pointer + || sym->assoc) return NULL; /* Now we'll try to build an initializer expression. */ @@ -10306,22 +10494,22 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (allocatable) { - if (dimension) + if (dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Allocatable array '%s' at %L must have " - "a deferred shape", sym->name, &sym->declared_at); + gfc_error ("Allocatable array '%s' at %L must have a deferred " + "shape or assumed rank", sym->name, &sym->declared_at); return FAILURE; } - else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L " - "may not be ALLOCATABLE", sym->name, - &sym->declared_at) == FAILURE) + else if (gfc_notify_std (GFC_STD_F2003, "Scalar object " + "'%s' at %L may not be ALLOCATABLE", + sym->name, &sym->declared_at) == FAILURE) return FAILURE; } - if (pointer && dimension) + if (pointer && dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Array pointer '%s' at %L must have a deferred shape", - sym->name, &sym->declared_at); + gfc_error ("Array pointer '%s' at %L must have a deferred shape or " + "assumed rank", sym->name, &sym->declared_at); return FAILURE; } } @@ -10408,7 +10596,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable && gfc_has_default_initializer (sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for " + && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for " "module variable '%s' at %L, needed due to " "the default initialization", sym->name, &sym->declared_at) == FAILURE) @@ -10623,7 +10811,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a " + && gfc_notify_std (GFC_STD_F2003, "'%s' is of a " "PRIVATE type and cannot be a dummy argument" " of '%s', which is PUBLIC at %L", arg->sym->name, sym->name, &sym->declared_at) @@ -10645,7 +10833,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " + && gfc_notify_std (GFC_STD_F2003, "Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " "PRIVATE", iface->sym->name, sym->name, @@ -10669,7 +10857,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " + && gfc_notify_std (GFC_STD_F2003, "Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " "PRIVATE", iface->sym->name, sym->name, @@ -10757,7 +10945,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (!sym->attr.contained && gfc_current_form != FORM_FIXED && !sym->ts.deferred) - gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function '%s' at %L", sym->name, &sym->declared_at); } @@ -10935,7 +11123,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) } /* Warn if the procedure is non-scalar and not assumed shape. */ - if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0 + if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0 && arg->as->type != AS_ASSUMED_SHAPE) gfc_warning ("Non-scalar FINAL procedure at %L should have assumed" " shape argument", &arg->declared_at); @@ -11007,8 +11195,8 @@ static gfc_try check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, const char* generic_name, locus where) { - gfc_symbol* sym1; - gfc_symbol* sym2; + gfc_symbol *sym1, *sym2; + const char *pass1, *pass2; gcc_assert (t1->specific && t2->specific); gcc_assert (!t1->specific->is_generic); @@ -11032,8 +11220,20 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } /* Compare the interfaces. */ + if (t1->specific->nopass) + pass1 = NULL; + else if (t1->specific->pass_arg) + pass1 = t1->specific->pass_arg; + else + pass1 = t1->specific->u.specific->n.sym->formal->sym->name; + if (t2->specific->nopass) + pass2 = NULL; + else if (t2->specific->pass_arg) + pass2 = t2->specific->pass_arg; + else + pass2 = t2->specific->u.specific->n.sym->formal->sym->name; if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, - NULL, 0)) + NULL, 0, pass1, pass2)) { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); @@ -11239,6 +11439,22 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, if (!gfc_check_operator_interface (target_proc, op, p->where)) goto error; + + /* Add target to non-typebound operator list. */ + if (!target->specific->deferred && !derived->attr.use_assoc + && p->access != ACCESS_PRIVATE) + { + gfc_interface *head, *intr; + if (gfc_check_new_interface (derived->ns->op[op], target_proc, + p->where) == FAILURE) + return FAILURE; + head = derived->ns->op[op]; + intr = gfc_get_interface (); + intr->sym = target_proc; + intr->where = p->where; + intr->next = head; + derived->ns->op[op] = intr; + } } return SUCCESS; @@ -11436,7 +11652,7 @@ resolve_typebound_procedure (gfc_symtree* stree) } gcc_assert (me_arg->ts.type == BT_CLASS); - if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) { gfc_error ("Passed-object dummy argument of '%s' at %L must be" " scalar", proc->name, &where); @@ -11727,7 +11943,7 @@ resolve_fl_derived0 (gfc_symbol *sym) resolve_symbol (ifc); if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -11748,7 +11964,7 @@ resolve_fl_derived0 (gfc_symbol *sym) c->ts.interface = ifc; c->attr.function = ifc->attr.function; c->attr.subroutine = ifc->attr.subroutine; - gfc_copy_formal_args_ppc (c, ifc); + gfc_copy_formal_args_ppc (c, ifc, IFSRC_DECL); c->attr.pure = ifc->attr.pure; c->attr.elemental = ifc->attr.elemental; @@ -11949,7 +12165,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && !is_sym_host_assoc (c->ts.u.derived, sym->ns) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " + && gfc_notify_std (GFC_STD_F2003, "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) @@ -12057,7 +12273,7 @@ resolve_fl_derived (gfc_symbol *sym) if (gen_dt && gen_dt->generic && gen_dt->generic->next && (!gen_dt->generic->sym->attr.use_assoc || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of " + && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of " "function '%s' at %L being the same name as derived " "type at %L", sym->name, gen_dt->generic->sym == sym @@ -12115,14 +12331,14 @@ resolve_fl_namelist (gfc_symbol *sym) } if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " "object '%s' with assumed shape in namelist " "'%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) return FAILURE; if (is_non_constant_shape_array (nl->sym) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " "object '%s' with nonconstant shape in namelist " "'%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12131,7 +12347,7 @@ resolve_fl_namelist (gfc_symbol *sym) 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 " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST object " "'%s' with nonconstant character length in " "namelist '%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12151,7 +12367,7 @@ resolve_fl_namelist (gfc_symbol *sym) && (nl->sym->ts.u.derived->attr.alloc_comp || nl->sym->ts.u.derived->attr.pointer_comp)) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object " + if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object " "'%s' in namelist '%s' at %L with ALLOCATABLE " "or POINTER components", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12330,8 +12546,7 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function) gfc_add_function (&sym->attr, sym->name, &sym->declared_at); - if (sym->attr.procedure && sym->ts.interface - && sym->attr.if_source != IFSRC_DECL + if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL && resolve_procedure_interface (sym) == FAILURE) return; @@ -12362,7 +12577,7 @@ resolve_symbol (gfc_symbol *sym) representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic - && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) + && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; /* Resolve associate names. */ @@ -12450,6 +12665,20 @@ resolve_symbol (gfc_symbol *sym) &sym->declared_at); return; } + /* TS 29113, C535a. */ + if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy) + { + gfc_error ("Assumed-rank array at %L must be a dummy argument", + &sym->declared_at); + return; + } + if (as->type == AS_ASSUMED_RANK + && (sym->attr.codimension || sym->attr.value)) + { + gfc_error ("Assumed-rank array at %L may not have the VALUE or " + "CODIMENSION attribute", &sym->declared_at); + return; + } } /* Make sure symbols with known intent or optional are really dummy @@ -12522,6 +12751,13 @@ resolve_symbol (gfc_symbol *sym) sym->name, &sym->declared_at); return; } + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) { gfc_error ("Assumed-type variable %s at %L shall not be an " @@ -12629,7 +12865,7 @@ resolve_symbol (gfc_symbol *sym) && !sym->ts.u.derived->attr.use_assoc && 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 " + && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L " "of PRIVATE derived type '%s'", (sym->attr.flavor == FL_PARAMETER) ? "parameter" : "variable", sym->name, &sym->declared_at, @@ -13795,7 +14031,7 @@ resolve_fntype (gfc_namespace *ns) && !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 " + gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at " "%L of PRIVATE type '%s'", sym->name, &sym->declared_at, sym->ts.u.derived->name); }