diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 117 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 30 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 15 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 12 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 250 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/target-memory.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 136 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 12 |
15 files changed, 420 insertions, 236 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 757678dc2df..19b45d859c5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,116 @@ +2013-01-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/55983 + * class.c (find_typebound_proc_uop): Check for f2k_derived instead of + asserting it. + +2013-01-13 Janus Weil <janus@gcc.gnu.org> + + PR fortran/55072 + * trans-array.c (gfc_conv_array_parameter): No packing was done for + full arrays of derived type. + +2013-01-13 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/55618 + * trans-expr.c (gfc_conv_procedure_call): Dereference scalar + character function arguments to elemental procedures in + scalarization loops. + +2013-01-08 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/42769 + PR fortran/45836 + PR fortran/45900 + * module.c (read_module): Don't reuse local symtree if the associated + symbol isn't exactly the one wanted. Don't reuse local symtree if it is + ambiguous. + * resolve.c (resolve_call): Use symtree's name instead of symbol's to + lookup the symtree. + +2013-01-07 Tobias Burnus <burnus@net-b.de> + Thomas Koenig <tkoenig@gcc.gnu.org> + Jakub Jelinek <jakub@redhat.com> + + PR fortran/55852 + * expr.c (gfc_build_intrinsic_call): Avoid clashes + with user's procedures. + * gfortran.h (gfc_build_intrinsic_call): Update prototype. + (GFC_PREFIX): Define. + * simplify.c (gfc_simplify_size): Update call. + +2013-01-07 Steven G. Kargl <kargl@gcc.gnu.org> + Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/55827 + * class.c (gfc_fix_class_refs): Adapt ts initialization for the case + e->symtree == NULL. + * trans-expr.c (gfc_conv_function_expr): Init sym earlier. Use it. + +2012-12-20 Tobias Burnus <burnus@net-b.de> + + PR fortran/54818 + * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Ensure that + the string length is of type gfc_charlen_type_node. + +2012-11-24 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/55314 + Backport from trunk + * resolve.c (resolve_allocate_deallocate): Compare all + subscripts when deciding if to reject a (de)allocate + statement. + +2012-11-23 Janus Weil <janus@gcc.gnu.org> + + PR fortran/55352 + * trans-decl.c (generate_local_decl): Don't warn for explicitly imported + but unused module variables which are in a namelist or common block. + +2012-11-06 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54917 + * target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr): + Handle BT_CLASS. + +2012-10-14 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54784 + * trans-stmt.c (gfc_trans_allocate): Correctly determine the reference + to the _data component for polymorphic allocation with SOURCE. + +2012-09-20 Release Manager + + * GCC 4.7.2 released. + +2012-09-13 Tobias Burnus <burnus@net-b.de> + + PR fortran/54556 + * resolve.c (resolve_formal_arglist): Allow VALUE arguments + with implicit_pure. + (gfc_impure_variable): Don't check gfc_pure such that the + function also works for gfc_implicit_pure procedures. + +2012-09-12 Tobias Burnus <burnus@net-b.de> + + PR fortran/54225 + PR fortran/53306 + * array.c (match_subscript, gfc_match_array_ref): Fix + diagnostic of coarray's '*'. + +2012-09-10 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54435 + PR fortran/54443 + * match.c (gfc_match_select_type): Make sure to only access CLASS_DATA + for BT_CLASS. + +2012-09-08 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/54208 + * simplify.c (simplify_bound_dim): Resolve array spec before + proceeding with simplification. + 2012-07-06 Mikael Morin <mikael@gcc.gnu.org> PR fortran/53732 @@ -515,7 +628,7 @@ PR fortran/50981 * trans-array.c (gfc_walk_elemental_function_args): Fix - passing of deallocated allocatables/pointers as absent argument. + passing of deallocated allocatables/pointers as absent argument. 2012-01-16 Tobias Burnus <burnus@net-b.de> @@ -551,7 +664,7 @@ 2012-01-16 Paul Thomas <pault@gcc.gnu.org> * trans-array.c (gfc_trans_create_temp_array): In the case of a - class array temporary, detect a null 'eltype' on entry and use + class array temporary, detect a null 'eltype' on entry and use 'initial' to provde the class reference and so, through the vtable, the element size for the dynamic type. * trans-stmt.c (gfc_conv_elemental_dependencies): For class diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b36d517cff7..d4e520b767d 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -92,9 +92,7 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) else if (!star) m = gfc_match_expr (&ar->start[i]); - if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES) - return MATCH_NO; - else if (m == MATCH_NO) + if (m == MATCH_NO) gfc_error ("Expected array subscript at %C"); if (m != MATCH_YES) return MATCH_ERROR; @@ -225,7 +223,7 @@ coarray: for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) { - m = match_subscript (ar, init, ar->codimen == (corank - 1)); + m = match_subscript (ar, init, true); if (m == MATCH_ERROR) return MATCH_ERROR; @@ -256,6 +254,13 @@ coarray: gfc_error ("Invalid form of coarray reference at %C"); return MATCH_ERROR; } + else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) + { + gfc_error ("Unexpected '*' for codimension %d of %d at %C", + ar->codimen + 1, corank); + return MATCH_ERROR; + } + if (ar->codimen >= corank) { gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index bfa8740288a..d4ed6b043ac 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -162,7 +162,23 @@ gfc_fix_class_refs (gfc_expr *e) && e->value.function.isym != NULL)) return; - ts = &e->symtree->n.sym->ts; + if (e->expr_type == EXPR_VARIABLE) + ts = &e->symtree->n.sym->ts; + else + { + gfc_symbol *func; + + gcc_assert (e->expr_type == EXPR_FUNCTION); + if (e->value.function.esym != NULL) + func = e->value.function.esym; + else + func = e->symtree->n.sym; + + if (func->result != NULL) + ts = &func->result->ts; + else + ts = &func->ts; + } for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) { @@ -924,15 +940,17 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, gfc_symtree* res; gfc_symtree* root; - /* Set correct symbol-root. */ - gcc_assert (derived->f2k_derived); - root = (uop ? derived->f2k_derived->tb_uop_root - : derived->f2k_derived->tb_sym_root); - /* Set default to failure. */ if (t) *t = FAILURE; + if (derived->f2k_derived) + /* Set correct symbol-root. */ + root = (uop ? derived->f2k_derived->tb_uop_root + : derived->f2k_derived->tb_sym_root); + else + return NULL; + /* Try to find it in the current type's namespace. */ res = gfc_find_symtree (root, name); if (res && res->n.tb && !res->n.tb->error) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 18e26e34c3a..8e52c472bad 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4511,29 +4511,36 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict) want to add arguments but with a NULL-expression. */ gfc_expr* -gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) +gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, + locus where, unsigned numarg, ...) { gfc_expr* result; gfc_actual_arglist* atail; gfc_intrinsic_sym* isym; va_list ap; unsigned i; + const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); - isym = gfc_find_function (name); + isym = gfc_intrinsic_function_by_id (id); gcc_assert (isym); result = gfc_get_expr (); result->expr_type = EXPR_FUNCTION; result->ts = isym->ts; result->where = where; - result->value.function.name = name; + result->value.function.name = mangled_name; result->value.function.isym = isym; - result->symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); + gfc_commit_symbol (result->symtree->n.sym); gcc_assert (result->symtree && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); + result->symtree->n.sym->intmod_sym_id = id; + result->symtree->n.sym->attr.flavor = FL_PROCEDURE; + result->symtree->n.sym->attr.intrinsic = 1; + va_start (ap, numarg); atail = NULL; for (i = 0; i < numarg; ++i) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a5edd1306ad..6e1fc780d66 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -61,6 +61,15 @@ along with GCC; see the file COPYING3. If not see #define PREFIX(x) "_gfortran_" x #define PREFIX_LEN 10 +/* A prefix for internal variables, which are not user-visible. */ +#if !defined (NO_DOT_IN_LABEL) +# define GFC_PREFIX(x) "_F." x +#elif !defined (NO_DOLLAR_IN_LABEL) +# define GFC_PREFIX(x) "_F$" x +#else +# define GFC_PREFIX(x) "_F_" x +#endif + #define BLANK_COMMON_NAME "__BLNK__" /* Macro to initialize an mstring structure. */ @@ -2764,7 +2773,8 @@ int gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); -gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...); +gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*, + locus, unsigned, ...); gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, const char*); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 14381608c90..cb750cf67d2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5248,10 +5248,10 @@ gfc_match_select_type (void) array, which can have a reference, from other expressions that have references, such as derived type components, and are not allowed by the standard. - TODO; see is it is sufficent to exclude component and substring + TODO: see if it is sufficent to exclude component and substring references. */ class_array = expr1->expr_type == EXPR_VARIABLE - && expr1->ts.type != BT_UNKNOWN + && expr1->ts.type == BT_CLASS && CLASS_DATA (expr1) && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) && (CLASS_DATA (expr1)->attr.dimension diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index e3631777fb4..f6662b47997 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -4641,8 +4641,14 @@ read_module (void) if (p == NULL) { st = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (st != NULL) - info->u.rsym.symtree = st; + if (st != NULL + && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0 + && st->n.sym->module != NULL + && strcmp (st->n.sym->module, info->u.rsym.module) == 0) + { + info->u.rsym.symtree = st; + info->u.rsym.sym = st->n.sym; + } continue; } @@ -4663,7 +4669,8 @@ read_module (void) /* Check for ambiguous symbols. */ if (check_for_ambiguous (st->n.sym, info)) st->ambiguous = 1; - info->u.rsym.symtree = st; + else + info->u.rsym.symtree = st; } else { diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9cca2810228..471fa61c1ae 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -94,7 +94,7 @@ static bool is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) { for (ns = ns->parent; ns; ns = ns->parent) - { + { if (sym->ns == ns) return true; } @@ -165,7 +165,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->ts = ifc->result->ts; sym->result = sym; } - else + else sym->ts = ifc->ts; sym->ts.interface = ifc; sym->attr.function = ifc->attr.function; @@ -363,10 +363,12 @@ resolve_formal_arglist (gfc_symbol *proc) } else if (!sym->attr.pointer) { - if (proc->attr.function && sym->attr.intent != INTENT_IN) + if (proc->attr.function && sym->attr.intent != INTENT_IN + && !sym->value) proc->attr.implicit_pure = 0; - if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN + && !sym->value) proc->attr.implicit_pure = 0; } } @@ -511,7 +513,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) } } - /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character + /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type, lists the only ways a character length value of * can be used: dummy arguments of procedures, named constants, and function results in external functions. Internal function results and results of module @@ -1253,7 +1255,7 @@ generic_sym (gfc_symbol *sym) return 0; gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); - + if (s != NULL) { if (s == sym) @@ -1374,7 +1376,7 @@ count_specific_procs (gfc_expr *e) int n; gfc_interface *p; gfc_symbol *sym; - + n = 0; sym = e->symtree->n.sym; @@ -1577,7 +1579,7 @@ resolve_procedure_expression (gfc_expr* expr) gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling" " itself recursively. Declare it RECURSIVE or use" " -frecursive", sym->name, &expr->where); - + return SUCCESS; } @@ -1685,7 +1687,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, with the same name before emitting an error. */ if (sym->attr.generic && count_specific_procs (e) != 1) return FAILURE; - + /* Just in case a specific was found for the expression. */ sym = e->symtree->n.sym; @@ -1874,7 +1876,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) else if (c && c->ext.actual != NULL) { arg0 = c->ext.actual; - + if (c->resolved_sym) esym = c->resolved_sym; else @@ -2273,7 +2275,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - if (sym->attr.if_source != IFSRC_IFBODY) + if (sym->attr.if_source != IFSRC_IFBODY) gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); @@ -2677,7 +2679,7 @@ 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); @@ -2744,7 +2746,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, the actual expression could be a part-ref of the expr symbol. */ arg_ts = &(args->expr->ts); arg_attr = gfc_expr_attr (args->expr); - + if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { /* If the user gave two args then they are providing something for @@ -2833,7 +2835,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, 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 (gfc_verify_c_interop (arg_ts) == SUCCESS || gfc_check_any_c_kind (arg_ts) == SUCCESS) @@ -2847,7 +2849,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, is not an array of zero size. */ if (args_sym->attr.allocatable == 1) { - if (args_sym->attr.dimension != 0 + if (args_sym->attr.dimension != 0 && (args_sym->as && args_sym->as->rank == 0)) { gfc_error_now ("Allocatable variable '%s' used as a " @@ -2886,7 +2888,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, retval = FAILURE; } } - + /* Make sure it's not a character string. Arrays of any type should be ok if the variable is of a C interoperable type. */ @@ -2926,7 +2928,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, with no length type parameters. It still must have either the pointer or target attribute, and it can be allocatable (but must be allocated when c_loc is called). */ - if (args->expr->rank != 0 + if (args->expr->rank != 0 && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("Parameter '%s' to '%s' at %L must be a " @@ -2934,7 +2936,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } - else if (arg_ts->type == BT_CHARACTER + else if (arg_ts->type == BT_CHARACTER && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("CHARACTER argument '%s' to '%s' at " @@ -2973,7 +2975,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, retval = FAILURE; } } - + /* for c_loc/c_funloc, the new symbol is the same as the old one */ *new_sym = sym; } @@ -3008,7 +3010,7 @@ resolve_function (gfc_expr *expr) /* If this is a procedure pointer component, it has already been resolved. */ if (gfc_is_proc_ptr_comp (expr, NULL)) return SUCCESS; - + if (sym && sym->attr.intrinsic && resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; @@ -3047,7 +3049,7 @@ resolve_function (gfc_expr *expr) } inquiry_argument = false; - + /* Need to setup the call to the correct c_associated, depending on the number of cptrs to user gives to compare. */ if (sym && sym->attr.is_iso_c == 1) @@ -3055,12 +3057,12 @@ resolve_function (gfc_expr *expr) if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym) == FAILURE) return FAILURE; - + /* Get the symtree for the new symbol (resolved func). the old one will be freed later, when it's no longer used. */ gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree)); } - + /* Resume assumed_size checking. */ need_full_assumed_size--; @@ -3389,7 +3391,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym, sprintf (name, "%s_%c%d", sym->name, type, kind); /* Set up the binding label as the given symbol's label plus the type and kind. */ - *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type, + *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type, kind); } else @@ -3400,7 +3402,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym, sprintf (name, "%s", sym->name); *binding_label = sym->binding_label; } - + return; } @@ -3424,7 +3426,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* default to success; will override if find error */ match m = MATCH_YES; - /* Make sure the actual arguments are in the necessary order (based on the + /* 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)); @@ -3432,7 +3434,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) { set_name_and_label (c, sym, name, &binding_label); - + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) @@ -3443,7 +3445,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) gfc_procedure_use() (called above to sort actual args). */ if (c->ext.actual->next->expr->rank != 0) { - if(c->ext.actual->next->next == NULL + if(c->ext.actual->next->next == NULL || c->ext.actual->next->next->expr == NULL) { m = MATCH_ERROR; @@ -3462,12 +3464,12 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) } } } - + if (m != MATCH_ERROR) { /* the 1 means to add the optional arg to formal list */ new_sym = get_iso_c_sym (sym, name, binding_label, 1); - + /* for error reporting, say it's declared where the original was */ new_sym->declared_at = sym->declared_at; } @@ -3483,7 +3485,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) c->resolved_sym = new_sym; else c->resolved_sym = sym; - + return m; } @@ -3500,7 +3502,7 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) m = gfc_iso_c_sub_interface (c,sym); return m; } - + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) { if (sym->attr.dummy) @@ -3634,7 +3636,7 @@ resolve_call (gfc_code *c) if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) { gfc_symtree *st; - gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st); + gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); sym = st ? st->n.sym : NULL; if (sym && csym != sym && sym->ns == gfc_current_ns @@ -3919,7 +3921,7 @@ resolve_operator (gfc_expr *e) if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) sprintf (msg, _("Logicals at %%L must be compared with %s instead of %s"), - (e->value.op.op == INTRINSIC_EQ + (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS) ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); else @@ -4159,7 +4161,7 @@ compare_bound_mpz_t (gfc_expr *a, mpz_t b) } -/* Compute the last value of a sequence given by a triplet. +/* Compute the last value of a sequence given by a triplet. Return 0 if it wasn't able to compute the last value, or if the sequence if empty, and 1 otherwise. */ @@ -6001,7 +6003,7 @@ resolve_typebound_function (gfc_expr* e) e->value.function.esym = NULL; e->symtree = st; - if (new_ref) + if (new_ref) e->ref = new_ref; /* '_vptr' points to the vtab, which contains the procedure pointers. */ @@ -6319,7 +6321,7 @@ gfc_resolve_expr (gfc_expr *e) if (t == SUCCESS && e->ts.type == BT_CHARACTER) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER - here rather then add a duplicate test for it above. */ + here rather then add a duplicate test for it above. */ gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } @@ -6476,7 +6478,7 @@ forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) { if (expr->expr_type != EXPR_VARIABLE) return false; - + /* A scalar assignment */ if (!expr->ref || *f == 1) { @@ -6759,7 +6761,7 @@ remove_last_array_ref (gfc_expr* e) /* Used in resolve_allocate_expr to check that a allocation-object and - a source-expr are conformable. This does not catch all possible + a source-expr are conformable. This does not catch all possible cases; in particular a runtime checking is needed. */ static gfc_try @@ -6767,7 +6769,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; for (tail = e2->ref; tail && tail->next; tail = tail->next); - + /* First compare rank. */ if (tail && e1->rank != tail->u.ar.as->rank) { @@ -7030,7 +7032,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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); + code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); } else if (!code->expr3) { @@ -7278,8 +7280,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; @@ -7291,7 +7293,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* 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 @@ -7327,11 +7329,18 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (pr->next && qr->next) { + int i; 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; + + for (i=0; i<par->dimen; i++) + { + if ((par->start[i] != NULL + || qar->start[i] != NULL) + && gfc_dep_compare_expr (par->start[i], + qar->start[i]) != 0) + goto break_label; + } } } else @@ -7339,10 +7348,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (pr->u.c.component->name != qr->u.c.component->name) break; } - + pr = pr->next; qr = qr->next; } + break_label: + ; } } } @@ -7364,7 +7375,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Callback function for our mergesort variant. Determines interval overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for - op1 > op2. Assumes we're not dealing with the default case. + op1 > op2. Assumes we're not dealing with the default case. We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). There are nine situations to check. */ @@ -8055,7 +8066,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) default_case = body; } } - + if (error > 0) return; @@ -8074,7 +8085,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 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; code->expr1->symtree->n.sym->assoc = assoc; @@ -8145,7 +8156,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) resolve_assoc_var (st->n.sym, false); } - + /* Take out CLASS IS cases for separate treatment. */ body = code; while (body && body->block) @@ -8154,7 +8165,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { /* Add to class_is list. */ if (class_is == NULL) - { + { class_is = body->block; tail = class_is; } @@ -8175,7 +8186,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) if (class_is) { gfc_symbol *vtab; - + if (!default_case) { /* Add a default case to hold the CLASS IS cases. */ @@ -8223,7 +8234,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) } while (swapped); } - + /* Generate IF chain. */ if_st = gfc_get_code (); if_st->op = EXEC_IF; @@ -8259,7 +8270,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->op = EXEC_IF; new_st->next = default_case->next; } - + /* Replace CLASS DEFAULT code by the IF chain. */ default_case->next = if_st; } @@ -8276,7 +8287,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components - -- a derived type being transferred doesn't have private components, unless + -- a derived type being transferred doesn't have private components, unless it's being transferred from the module where the type was defined -- we're not trying to transfer a whole assumed size array. */ @@ -8380,7 +8391,7 @@ resolve_transfer (gfc_code *code) /* Find the set of labels that are reachable from this block. We also record the last statement in each block. */ - + static void find_reachable_labels (gfc_code *block) { @@ -8686,7 +8697,7 @@ resolve_where (gfc_code *code, gfc_expr *mask) "inconsistent shape", &cnext->expr1->where); break; - + case EXEC_ASSIGN_CALL: resolve_call (cnext); if (!cnext->resolved_sym->attr.elemental) @@ -8772,7 +8783,7 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, case EXEC_ASSIGN: gfc_resolve_assign_in_forall (cnext, nvar, var_expr); break; - + /* WHERE operator assignment statement */ case EXEC_ASSIGN_CALL: resolve_call (cnext); @@ -8840,10 +8851,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) /* Counts the number of iterators needed inside a forall construct, including - nested forall constructs. This is used to allocate the needed memory + nested forall constructs. This is used to allocate the needed memory in gfc_resolve_forall. */ -static int +static int gfc_count_forall_iterators (gfc_code *code) { int max_iters, sub_iters, current_iters; @@ -8855,11 +8866,11 @@ gfc_count_forall_iterators (gfc_code *code) for (fa = code->ext.forall_iterator; fa; fa = fa->next) current_iters ++; - + code = code->block->next; while (code) - { + { if (code->op == EXEC_FORALL) { sub_iters = gfc_count_forall_iterators (code); @@ -9642,7 +9653,7 @@ resolve_values (gfc_symbol *sym) if (sym->value->expr_type == EXPR_STRUCTURE) t= resolve_structure_cons (sym->value, 1); - else + else t = gfc_resolve_expr (sym->value); if (t == FAILURE) @@ -9664,7 +9675,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) { gfc_gsymbol *binding_label_gsym; gfc_gsymbol *comm_name_gsym; - const char * bind_label = comm_block_tree->n.common->binding_label + const char * bind_label = comm_block_tree->n.common->binding_label ? comm_block_tree->n.common->binding_label : ""; /* See if a global symbol exists by the common block's name. It may @@ -9707,7 +9718,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) check and nothing to add as a global symbol for the label. */ if (!comm_block_tree->n.common->binding_label) return; - + binding_label_gsym = gfc_find_gsymbol (gfc_gsym_root, comm_block_tree->n.common->binding_label); @@ -9744,7 +9755,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree) comm_name_gsym->name, &(comm_name_gsym->where)); } } - + return; } @@ -9758,34 +9769,34 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym) if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED && derived_sym->attr.is_bind_c == 1) verify_bind_c_derived_type (derived_sym); - + return; } -/* Verify that any binding labels used in a given namespace do not collide +/* Verify that any binding labels used in a given namespace do not collide with the names or binding labels of any global symbols. */ static void gfc_verify_binding_labels (gfc_symbol *sym) { int has_error = 0; - - if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 + + if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0 && sym->attr.flavor != FL_DERIVED && sym->binding_label) { gfc_gsymbol *bind_c_sym; bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); - if (bind_c_sym != NULL + if (bind_c_sym != NULL && strcmp (bind_c_sym->name, sym->binding_label) == 0) { - if (sym->attr.if_source == IFSRC_DECL - && (bind_c_sym->type != GSYM_SUBROUTINE - && bind_c_sym->type != GSYM_FUNCTION) - && ((sym->attr.contained == 1 - && strcmp (bind_c_sym->sym_name, sym->name) != 0) - || (sym->attr.use_assoc == 1 + if (sym->attr.if_source == IFSRC_DECL + && (bind_c_sym->type != GSYM_SUBROUTINE + && bind_c_sym->type != GSYM_FUNCTION) + && ((sym->attr.contained == 1 + && strcmp (bind_c_sym->sym_name, sym->name) != 0) + || (sym->attr.use_assoc == 1 && (strcmp (bind_c_sym->mod_name, sym->module) != 0)))) { /* Make sure global procedures don't collide with anything. */ @@ -9795,10 +9806,10 @@ gfc_verify_binding_labels (gfc_symbol *sym) &(bind_c_sym->where)); has_error = 1; } - else if (sym->attr.contained == 0 - && (sym->attr.if_source == IFSRC_IFBODY - && sym->attr.flavor == FL_PROCEDURE) - && (bind_c_sym->sym_name != NULL + else if (sym->attr.contained == 0 + && (sym->attr.if_source == IFSRC_IFBODY + && sym->attr.flavor == FL_PROCEDURE) + && (bind_c_sym->sym_name != NULL && strcmp (bind_c_sym->sym_name, sym->name) != 0)) { /* Make sure procedures in interface bodies don't collide. */ @@ -9809,10 +9820,10 @@ gfc_verify_binding_labels (gfc_symbol *sym) &(bind_c_sym->where)); has_error = 1; } - else if (sym->attr.contained == 0 + else if (sym->attr.contained == 0 && sym->attr.if_source == IFSRC_UNKNOWN) if ((sym->attr.use_assoc && bind_c_sym->mod_name - && strcmp (bind_c_sym->mod_name, sym->module) != 0) + && strcmp (bind_c_sym->mod_name, sym->module) != 0) || sym->attr.use_assoc == 0) { gfc_error ("Binding label '%s' at %L collides with global " @@ -10008,7 +10019,7 @@ apply_default_init (gfc_symbol *sym) /* Build an initializer for a local integer, real, complex, logical, or character variable, based on the command line flags finit-local-zero, - finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns + finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns null if the symbol should not have a default initialization. */ static gfc_expr * build_default_init_expr (gfc_symbol *sym) @@ -10039,10 +10050,10 @@ build_default_init_expr (gfc_symbol *sym) characters, and only if the corresponding command-line flags were set. Otherwise, we free init_expr and return null. */ switch (sym->ts.type) - { + { case BT_INTEGER: if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_set_si (init_expr->value.integer, + mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else { @@ -10079,7 +10090,7 @@ build_default_init_expr (gfc_symbol *sym) break; } break; - + case BT_COMPLEX: switch (gfc_option.flag_init_real) { @@ -10111,7 +10122,7 @@ build_default_init_expr (gfc_symbol *sym) break; } break; - + case BT_LOGICAL: if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE) init_expr->value.logical = 0; @@ -10123,9 +10134,9 @@ build_default_init_expr (gfc_symbol *sym) init_expr = NULL; } break; - + case BT_CHARACTER: - /* For characters, the length must be constant in order to + /* For characters, the length must be constant in order to create a default initializer. */ if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON && sym->ts.u.cl->length @@ -10164,7 +10175,7 @@ build_default_init_expr (gfc_symbol *sym) init_expr->value.function.actual = arg; } break; - + default: gfc_free_expr (init_expr); init_expr = NULL; @@ -10192,7 +10203,7 @@ apply_default_init_local (gfc_symbol *sym) /* 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 + if (sym->attr.save || sym->ns->save_all || (gfc_option.flag_max_stack_var_size == 0 && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) { @@ -10297,7 +10308,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) return FAILURE; } } - + return SUCCESS; } @@ -10719,7 +10730,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) sym->attr.is_c_interop = 1; sym->ts.is_c_interop = 1; } - + curr_arg = sym->formal; while (curr_arg != NULL) { @@ -10731,7 +10742,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) BIND(C) to try and prevent multiple errors being reported. */ has_non_interop_arg = 1; - + curr_arg = curr_arg->next; } @@ -10744,7 +10755,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) sym->attr.is_bind_c = 0; } } - + if (!sym->attr.proc_pointer) { if (sym->attr.save == SAVE_EXPLICIT) @@ -10895,7 +10906,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) { gfc_error ("FINAL procedure '%s' declared at %L has the same" " rank (%d) as '%s'", - list->proc_sym->name, &list->where, my_rank, + list->proc_sym->name, &list->where, my_rank, i->proc_sym->name); goto error; } @@ -11145,7 +11156,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, { gfc_symbol* super_type; gfc_tbp_generic* target; - + /* If there's already an error here, do nothing (but don't fail again). */ if (p->error) return SUCCESS; @@ -11370,7 +11381,7 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg->name, &where, resolve_bindings_derived->name); goto error; } - + gcc_assert (me_arg->ts.type == BT_CLASS); if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) { @@ -11447,7 +11458,7 @@ resolve_typebound_procedures (gfc_symbol* derived) 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); @@ -11540,7 +11551,7 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) clearer than something sophisticated. */ gcc_assert (ancestor && !sub->attr.abstract); - + if (!ancestor->attr.abstract) return SUCCESS; @@ -11674,7 +11685,7 @@ resolve_fl_derived0 (gfc_symbol *sym) c->as = gfc_copy_array_spec (ifc->result->as); } else - { + { c->ts = ifc->ts; c->attr.allocatable = ifc->attr.allocatable; c->attr.pointer = ifc->attr.pointer; @@ -11843,7 +11854,7 @@ resolve_fl_derived0 (gfc_symbol *sym) || (!sym->attr.is_class && c == sym->components)) && strcmp (super_type->name, c->name) == 0) c->attr.access = super_type->attr.access; - + /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type && !sym->attr.is_class @@ -12017,10 +12028,10 @@ resolve_fl_derived (gfc_symbol *sym) 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; @@ -12028,7 +12039,7 @@ resolve_fl_derived (gfc_symbol *sym) /* Resolve the finalizer procedures. */ if (gfc_resolve_finalizers (sym) == FAILURE) return FAILURE; - + return SUCCESS; } @@ -12175,7 +12186,7 @@ static gfc_try resolve_fl_parameter (gfc_symbol *sym) { /* A parameter array's shape needs to be constant. */ - if (sym->as != NULL + if (sym->as != NULL && (sym->as->type == AS_DEFERRED || is_non_constant_shape_array (sym))) { @@ -12290,8 +12301,8 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal - representation. This needs to be done before assigning a default + /* Make sure that the intrinsic is consistent with its internal + representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) @@ -12450,7 +12461,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED) { gfc_try t = SUCCESS; - + /* First, make sure the variable is declared at the module-level scope (J3/04-007, Section 15.3). */ if (sym->ns->proc_name->attr.flavor != FL_MODULE && @@ -12480,7 +12491,7 @@ resolve_symbol (gfc_symbol *sym) verify_bind_c_derived_type (sym->ts.u.derived); t = FAILURE; } - + /* Verify the variable itself as C interoperable if it is BIND(C). It is not possible for this to succeed if the verify_bind_c_derived_type failed, so don't have to handle @@ -13191,10 +13202,9 @@ gfc_impure_variable (gfc_symbol *sym) } proc = sym->ns->proc_name; - if (sym->attr.dummy && gfc_pure (proc) - && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) - || - proc->attr.function)) + if (sym->attr.dummy + && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) + || proc->attr.function)) return 1; /* TODO: Sort out what can be storage associated, if anything, and include @@ -13253,12 +13263,12 @@ gfc_implicit_pure (gfc_symbol *sym) 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; } @@ -13429,7 +13439,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) } -/* Resolve equivalence object. +/* Resolve equivalence object. An EQUIVALENCE object shall not be a dummy argument, a pointer, a target, an allocatable array, an object of nonsequence derived type, an object of sequence derived type containing a pointer at any level of component diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 706dab440ce..f1219d61c18 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3255,6 +3255,9 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, gcc_assert (array->expr_type == EXPR_VARIABLE); gcc_assert (as); + if (gfc_resolve_array_spec (as, 0) == FAILURE) + return NULL; + /* The last dimension of an assumed-size array is special. */ if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) || (coarray && d == as->rank + as->corank @@ -5570,7 +5573,9 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) /* Otherwise, we build a new SIZE call. This is hopefully at least simpler than the original one. */ if (!simplified) - simplified = gfc_build_intrinsic_call ("size", array->where, 3, + simplified = gfc_build_intrinsic_call (gfc_current_ns, + GFC_ISYM_SIZE, "size", + array->where, 3, gfc_copy_expr (replacement), gfc_copy_expr (dim), gfc_copy_expr (kind)); diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 63878959b47..213ee52d307 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -120,6 +120,7 @@ gfc_target_expr_size (gfc_expr *e) case BT_HOLLERITH: return e->representation.length; case BT_DERIVED: + case BT_CLASS: { /* Determine type size without clobbering the typespec for ISO C binding types. */ @@ -563,6 +564,9 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, gfc_interpret_character (buffer, buffer_size, result); break; + case BT_CLASS: + result->ts = CLASS_DATA (result)->ts; + /* Fall through. */ case BT_DERIVED: result->representation.length = gfc_interpret_derived (buffer, buffer_size, result); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 807fb082546..d3114798c6d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6847,20 +6847,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, this_array_result = false; /* Passing address of the array if it is not pointer or assumed-shape. */ - if (full_array_var && g77 && !this_array_result) + if (full_array_var && g77 && !this_array_result + && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) { tmp = gfc_get_symbol_decl (sym); if (sym->ts.type == BT_CHARACTER) se->string_length = sym->ts.u.cl->backend_decl; - if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - { - gfc_conv_expr_descriptor (se, expr, ss); - se->expr = gfc_conv_array_data (se->expr); - return; - } - if (!sym->attr.pointer && sym->as && sym->as->type != AS_ASSUMED_SHAPE diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index e497fd6ede3..f225ab3b8c0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4586,22 +4586,25 @@ generate_local_decl (gfc_symbol * sym) } /* Warn for unused variables, but not if they're inside a common - block, a namelist, or are use-associated. */ + block or a namelist. */ else if (warn_unused_variable - && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark - || sym->attr.in_namelist)) + && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist)) { - gfc_warning ("Unused variable '%s' declared at %L", sym->name, - &sym->declared_at); - if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; - } - else if (warn_unused_variable && sym->attr.use_only) - { - gfc_warning ("Unused module variable '%s' which has been explicitly " - "imported at %L", sym->name, &sym->declared_at); - if (sym->backend_decl != NULL_TREE) - TREE_NO_WARNING(sym->backend_decl) = 1; + if (sym->attr.use_only) + { + gfc_warning ("Unused module variable '%s' which has been " + "explicitly imported at %L", sym->name, + &sym->declared_at); + if (sym->backend_decl != NULL_TREE) + TREE_NO_WARNING(sym->backend_decl) = 1; + } + else if (!sym->attr.use_assoc) + { + gfc_warning ("Unused variable '%s' declared at %L", + sym->name, &sym->declared_at); + if (sym->backend_decl != NULL_TREE) + TREE_NO_WARNING(sym->backend_decl) = 1; + } } /* For variable length CHARACTER parameters, the PARM_DECL already diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3552da36be8..b54a28ed8fd 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,6 +1,6 @@ /* Expression translation Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, - 2011, 2012 + 2011, 2012, 2013 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> and Steven Bosscher <s.bosscher@student.tudelft.nl> @@ -148,7 +148,7 @@ gfc_vtable_copy_get (tree decl) /* Takes a derived type expression and returns the address of a temporary - class object of the 'declared' type. */ + class object of the 'declared' type. */ static void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts) @@ -211,10 +211,10 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Takes a scalarized class array expression and returns the address of a temporary scalar class object of the 'declared' - type. + type. OOP-TODO: This could be improved by adding code that branched on the dynamic type being the same as the declared type. In this case - the original class expression can be passed directly. */ + the original class expression can be passed directly. */ void gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, bool elemental) @@ -267,7 +267,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, tmp = NULL_TREE; if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) tmp = e->symtree->n.sym->backend_decl; else { @@ -481,7 +481,7 @@ gfc_trans_class_init_assign (gfc_code *code) tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); } gfc_add_expr_to_block (&block, tmp); - + return gfc_finish_block (&block); } @@ -727,7 +727,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) tmp = gfc_get_int_type (kind); tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, se->expr)); - + /* Test for a NULL value. */ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); @@ -764,9 +764,9 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_ref *r; tree length; - gcc_assert (e->expr_type == EXPR_VARIABLE + gcc_assert (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER); - + length = NULL; /* To silence compiler warning. */ if (is_subref_array (e) && e->ts.u.cl->length) @@ -855,8 +855,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) { case EXPR_OP: - flatten_array_ctors_without_strlen (e->value.op.op1); - flatten_array_ctors_without_strlen (e->value.op.op2); + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); break; case EXPR_COMPCALL: @@ -1221,7 +1221,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se_expr = gfc_get_fake_result_decl (sym, parent_flag); /* Similarly for alternate entry points. */ - else if (alternate_entry + else if (alternate_entry && (sym->ns->proc_name->backend_decl == current_function_decl || parent_flag)) { @@ -1257,7 +1257,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated + are entirely different from other types, they are treated separately. */ if (sym->ts.type == BT_CHARACTER) { @@ -1287,7 +1287,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable || gfc_is_associate_pointer (sym)) @@ -1359,7 +1359,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL)) gfc_conv_string_parameter (se); - else + else se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); } } @@ -1441,11 +1441,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] = 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */ }; -/* If n is larger than lookup table's max index, we use the "window +/* If n is larger than lookup table's max index, we use the "window method". */ #define POWI_WINDOW_SIZE 3 -/* Recursive function to expand the power operator. The temporary +/* Recursive function to expand the power operator. The temporary values are put in tmpvar. The function returns tmpvar[1] ** n. */ static tree gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) @@ -1508,7 +1508,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care of the asymmetric range of the integer type. */ n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); - + type = TREE_TYPE (lhs); sgn = tree_int_cst_sgn (rhs); @@ -1619,7 +1619,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: ikind = 0; break; - + case 8: ikind = 1; break; @@ -1647,7 +1647,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: kind = 0; break; - + case 8: kind = 1; break; @@ -1663,7 +1663,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: @@ -1681,7 +1681,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 0: fndecl = builtin_decl_explicit (BUILT_IN_POWIF); break; - + case 1: fndecl = builtin_decl_explicit (BUILT_IN_POWI); break; @@ -1691,7 +1691,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 3: - /* Use the __builtin_powil() only if real(kind=16) is + /* Use the __builtin_powil() only if real(kind=16) is actually the C long double type. */ if (!gfc_real16_is_float128) fndecl = builtin_decl_explicit (BUILT_IN_POWIL); @@ -1702,7 +1702,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) } } - /* If we don't have a good builtin for this, go for the + /* If we don't have a good builtin for this, go for the library function. */ if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; @@ -2109,7 +2109,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { - /* The expr needs to be compatible with a C int. If the + /* The expr needs to be compatible with a C int. If the conversion fails, then the 2 causes an ICE. */ ts.type = BT_INTEGER; ts.kind = gfc_c_int_kind; @@ -2547,8 +2547,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) value = build_fold_indirect_ref_loc (input_location, se->expr); - - /* For character(*), use the actual argument's descriptor. */ + + /* For character(*), use the actual argument's descriptor. */ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) value = build_fold_indirect_ref_loc (input_location, se->expr); @@ -2958,7 +2958,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, rss = gfc_walk_expr (expr); gcc_assert (rss != gfc_ss_terminator); - + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, rss); @@ -3118,7 +3118,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); - + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop2, &body); @@ -3145,7 +3145,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (formal_ptr) { size = gfc_index_one_node; - offset = gfc_index_zero_node; + offset = gfc_index_zero_node; for (n = 0; n < dimen; n++) { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, @@ -3230,7 +3230,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { gfc_symbol *fsym; gfc_ss *argss; - + if (sym->intmod_sym_id == ISOCBINDING_LOC) { if (arg->expr->rank == 0) @@ -3247,7 +3247,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - + argss = gfc_walk_expr (arg->expr); gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL, NULL); @@ -3268,7 +3268,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; arg->expr->ts.kind = sym->ts.u.derived->ts.kind; gfc_conv_expr_reference (se, arg->expr); - + return 1; } else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER @@ -3293,12 +3293,12 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&fptrse, arg->next->expr); gfc_add_block_to_block (&se->pre, &fptrse.pre); gfc_add_block_to_block (&se->post, &fptrse.post); - + if (arg->next->expr->symtree->n.sym->attr.proc_pointer && arg->next->expr->symtree->n.sym->attr.dummy) fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr); - + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr), fptrse.expr, @@ -3332,7 +3332,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { tree eq_expr; tree not_null_expr; - + /* Given two arguments so build the arg2se from second arg. */ gfc_init_se (&arg2se, NULL); gfc_conv_expr (&arg2se, arg->next->expr); @@ -3356,7 +3356,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - + /* Nothing was done. */ return 0; } @@ -3536,7 +3536,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } else - gfc_conv_expr_reference (&parmse, e); + { + gfc_conv_expr_reference (&parmse, e); + if (e->ts.type == BT_CHARACTER && !e->rank + && e->expr_type == EXPR_FUNCTION) + parmse.expr = build_fold_indirect_ref_loc (input_location, + parmse.expr); + } /* The scalarizer does not repackage the reference to a class array - instead it returns a pointer to the data element. */ @@ -3625,7 +3631,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && !CLASS_DATA (e)->attr.codimension) parmse.expr = gfc_class_data_get (parmse.expr); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) @@ -3709,7 +3715,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* If the argument is a function call that may not create a temporary for the result, we have to check that we - can do it, i.e. that there is no alias between this + can do it, i.e. that there is no alias between this argument and another one. */ if (gfc_get_noncopying_intrinsic_argument (e) != NULL) { @@ -3770,7 +3776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) @@ -3787,7 +3793,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - } + } } /* The case with fsym->attr.optional is that of a user subroutine @@ -3813,7 +3819,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && ((e->rank > 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank > 0 - && (fsym == NULL + && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE || fsym->as->type == AS_DEFERRED)))))) @@ -3982,7 +3988,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } - + gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, msg); free (msg); @@ -4039,7 +4045,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); } - + VEC_safe_push (tree, gc, stringargs, tmp); if (GFC_DESCRIPTOR_TYPE_P (caf_type) @@ -4132,7 +4138,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); - + tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp, @@ -4799,20 +4805,20 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) return; } + /* expr.value.function.esym is the resolved (specific) function symbol for + most functions. However this isn't set for dummy procedures. */ + sym = expr->value.function.esym; + if (!sym) + sym = expr->symtree->n.sym; + /* We distinguish statement functions from general functions to improve runtime performance. */ - if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) + if (sym->attr.proc == PROC_ST_FUNCTION) { gfc_conv_statement_function (se, expr); return; } - /* expr.value.function.esym is the resolved (specific) function symbol for - most functions. However this isn't set for dummy procedures. */ - sym = expr->value.function.esym; - if (!sym) - sym = expr->symtree->n.sym; - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL); } @@ -4868,7 +4874,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) /* Build a static initializer. EXPR is the expression for the initial value. - The other parameters describe the variable of the component being + The other parameters describe the variable of the component being initialized. EXPR may be null. */ tree @@ -4899,7 +4905,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } - + if (array && !procptr) { tree ctor; @@ -4957,7 +4963,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, } } } - + static tree gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) { @@ -5004,7 +5010,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) cm->as->lower[n]->value.integer); mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1); } - + /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); gfc_add_ss_to_loop (&loop, rss); @@ -5070,7 +5076,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_start_block (&block); gfc_init_se (&se, NULL); - /* Get the descriptor for the expressions. */ + /* Get the descriptor for the expressions. */ rss = gfc_walk_expr (expr); se.want_pointer = 0; gfc_conv_expr_descriptor (&se, expr, rss); @@ -5325,7 +5331,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) fold_convert (TREE_TYPE (lse.expr), se.expr)); return gfc_finish_block (&block); - } + } for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) @@ -5407,7 +5413,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) } } se->expr = build_constructor (type, v); - if (init) + if (init) TREE_CONSTANT (se->expr) = 1; } @@ -5752,7 +5758,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) for (remap = expr1->ref; remap; remap = remap->next) if (!remap->next && remap->type == REF_ARRAY && remap->u.ar.type == AR_SECTION) - { + { remap->u.ar.type = AR_FULL; break; } @@ -6050,7 +6056,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { cond = NULL_TREE; - + /* Are the rhs and the lhs the same? */ if (r_is_var) { @@ -6146,7 +6152,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) /* Functions returning pointers or allocatables need temporaries. */ c = expr2->value.function.esym - ? (expr2->value.function.esym->attr.pointer + ? (expr2->value.function.esym->attr.pointer || expr2->value.function.esym->attr.allocatable) : (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable); @@ -6439,7 +6445,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) correctly take care of the reallocation internally. For intrinsic calls, the array data is freed and the library takes care of allocation. TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment - to the library. */ + to the library. */ if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension @@ -6713,7 +6719,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, gfc_init_se (&lse, NULL); lse.want_pointer = 1; gfc_conv_expr (&lse, expr1); - + jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label2 = gfc_build_label_decl (NULL_TREE); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index ac9f5074035..b351824b6d3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5659,7 +5659,7 @@ scalar_transfer: gfc_add_expr_to_block (&se->pre, tmp); se->expr = tmpdecl; - se->string_length = dest_word_len; + se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); } else { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index bb3a89084e0..630816ed401 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5087,7 +5087,7 @@ gfc_trans_allocate (gfc_code * code) gfc_actual_arglist *actual; gfc_expr *ppc; gfc_code *ppc_code; - gfc_ref *dataref; + gfc_ref *ref, *dataref; /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5099,13 +5099,15 @@ gfc_trans_allocate (gfc_code * code) actual->next->expr->ts.type = BT_CLASS; gfc_add_data_component (actual->next->expr); - dataref = actual->next->expr->ref; + dataref = NULL; /* Make sure we go up through the reference chain to the _data reference, where the arrayspec is found. */ - while (dataref->next && dataref->next->type != REF_ARRAY) - dataref = dataref->next; + for (ref = actual->next->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && strcmp (ref->u.c.component->name, "_data") == 0) + dataref = ref; - if (dataref->u.c.component->as) + if (dataref && dataref->u.c.component->as) { int dim; gfc_expr *temp; |