diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 181 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 41 | ||||
| -rw-r--r-- | gcc/fortran/data.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/error.c | 20 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 47 | ||||
| -rw-r--r-- | gcc/fortran/frontend-passes.c | 55 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 30 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 101 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 44 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 128 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 20 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 324 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 56 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 55 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 36 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 29 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 33 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 98 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 3 |
23 files changed, 829 insertions, 525 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2c06b31f9e5..c7acf44c884 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,184 @@ +2016-12-14 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/78780 + * trans-expr.c (gfc_trans_assignment_1): Improve check whether detour + caf-runtime routines is needed. + +2016-12-14 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/78672 + * array.c (gfc_find_array_ref): Add flag to return NULL when no ref is + found instead of erroring out. + * data.c (gfc_assign_data_value): Only constant expressions are valid + for initializers. + * gfortran.h: Reflect change of gfc_find_array_ref's signature. + * interface.c (compare_actual_formal): Access the non-elemental + array-ref. Prevent taking a REF_COMPONENT for a REF_ARRAY. Correct + indentation. + * module.c (load_omp_udrs): Clear typespec before reading into it. + * trans-decl.c (gfc_build_qualified_array): Prevent accessing the array + when it is a coarray. + * trans-expr.c (gfc_conv_cst_int_power): Use wi::abs()-function instead + of crutch preventing sanitizer's bickering here. + * trans-stmt.c (gfc_trans_deallocate): Only get data-component when it + is a descriptor-array here. + +2016-12-13 Janus Weil <janus@gcc.gnu.org> + + PR fortran/78798 + * gfortran.h (gfc_is_constant_expr, gfc_is_formal_arg, + gfc_is_compile_time_shape): Return bool instead of int. + * array.c (gfc_is_compile_time_shape): Ditto. + * expr.c (gfc_is_constant_expr): Ditto. + * resolve.c (gfc_is_formal_arg): Ditto. Make formal_arg_flag bool. + +2016-12-13 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/77785 + * resolve.c (resolve_symbol): Correct attr lookup to the _data + component. + * trans-array.c (gfc_alloc_allocatable_for_assignment): Indirect ref + pointers and references before retrieving the caf-token. + +2016-12-13 Janus Weil <janus@gcc.gnu.org> + Paul Thomas <pault@gcc.gnu.org> + + PR fortran/78737 + * gfortran.h (gfc_find_typebound_dtio_proc): New prototype. + * interface.c (gfc_compare_interfaces): Whitespace fix. + (gfc_find_typebound_dtio_proc): New function. + (gfc_find_specific_dtio_proc): Use it. Improve error recovery. + * trans-io.c (get_dtio_proc): Implement polymorphic calls to DTIO + procedures. + +2016-12-12 Janus Weil <janus@gcc.gnu.org> + + PR fortran/78392 + * expr.c (gfc_is_constant_expr): Specification functions are not + compile-time constants. Update documentation (add reference to F08 + standard), add a FIXME. + (external_spec_function): Add reference to F08 standard. + * resolve.c (resolve_fl_variable): Ditto. + +2016-12-10 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/78226 + * error.c (gfc_warning_internal): New function. + * frontend-passes.c (gfc_run_passes): Call check_locus if + CHECKING_P is defined. + (check_locus_code): New function. + (check_locus_expr): New function. + (check_locus): New function. + * gfortran.h: Add prototype for gfc_warning_internal. + +2016-12-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/78350 + * resolve.c (resolve_structure_cons): Remove the block that + tried to remove a charlen and rely on namespace cleanup. + +2016-12-09 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/77903 + * decl.c (get_proc_name): Use the symbol tlink field instead of + the typespec interface field. + (gfc_match_function_decl, gfc_match_submod_proc): Ditto. + * gfortran.h : Since the symbol tlink field is no longer used + by the frontend for change management, change the comment to + reflect its current uses. + * parse.c (get_modproc_result): Same as decl.c changes. + * resolve.c (resolve_fl_procedure): Ditto. + +2016-12-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/61767 + * class.c (has_finalizer_component): Fix this function to detect only + non-pointer non-allocatable components which have a finalizer. + +2016-12-09 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/78505 + * trans-stmt.c (gfc_trans_allocate): Add sync all after the execution + of the whole allocate-statement to adhere to the standard. + +2016-12-09 Andre Vehreschild <vehre@gcc.gnu.org> + + * trans-array.c (gfc_array_deallocate): Remove wrapper. + (gfc_trans_dealloc_allocated): Same. + (structure_alloc_comps): Restructure deallocation of (nested) + allocatable components. Insert dealloc of sub-component into the block + guarded by the if != NULL for the component. + (gfc_trans_deferred_array): Use the almightly deallocate_with_status. + * trans-array.h: Remove prototypes. + * trans-expr.c (gfc_conv_procedure_call): Use the almighty deallocate_ + with_status. + * trans-openmp.c (gfc_walk_alloc_comps): Likewise. + (gfc_omp_clause_assign_op): Likewise. + (gfc_omp_clause_dtor): Likewise. + * trans-stmt.c (gfc_trans_deallocate): Likewise. + * trans.c (gfc_deallocate_with_status): Allow deallocation of scalar + and arrays as well as coarrays. + (gfc_deallocate_scalar_with_status): Get the data member for coarrays + only when freeing an array with descriptor. And set correct caf_mode + when freeing components of coarrays. + * trans.h: Change prototype of gfc_deallocate_with_status to allow + adding statements into the block guarded by the if (pointer != 0) and + supply a coarray handle. + +2016-12-09 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44265 + * gfortran.h : Add fn_result_spec bitfield to gfc_symbol. + * resolve.c (flag_fn_result_spec): New function. + (resolve_fntype): Call it for character result lengths. + * symbol.c (gfc_new_symbol): Set fn_result_spec to zero. + * trans-decl.c (gfc_sym_mangled_identifier): Include the + procedure name in the mangled name for symbols with the + fn_result_spec bit set. + (gfc_finish_var_decl): Mark the decls of these symbols + appropriately for the case where the function is external. + (gfc_get_symbol_decl): Mangle the name of these symbols. + (gfc_create_module_variable): Allow them through the assert. + (gfc_generate_function_code): Remove the assert before the + initialization of sym->tlink because the frontend no longer + uses this field. + * trans-expr.c (gfc_map_intrinsic_function): Add a case to + treat the LEN_TRIM intrinsic. + (gfc_trans_string_copy): Deal with Wstringop-overflow warning + that can occur with constant source lengths at -O3. + +2016-12-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/65173 + PR fortran/69064 + PR fortran/69859 + PR fortran/78350 + * gfortran.h (gfc_namespace): Remove old_cl_list member. + * parse.c (use_modules, next_statement): old_cl_list is gone. + (clear_default_charlen): Remove no longer used function. + (reject_statement): Do not try ot clean up gfc_charlen structure(s) + that may have been added to a cl_list list. + * symbol.c (gfc_new_charlen): old_cl_list structure is gone. + +2016-12-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/78659 + * resolve.c (resolve_fl_namelist): Remove unneeded error. + +2016-12-06 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/78226 + * class.c (finalize_component): Add missing locus information. + (finalization_scalarizer): Likewise. + (finalization_get_offset): Likewise. + (finalizer_insert_packed_call): Likewise. + (generate_finalization_wrapper): Likewise. + +2016-12-05 Nathan Sidwell <nathan@acm.org> + + * error.c (gfc_warning_check): Call diagnostic_check_max_errors. + (gfc_error_check): Likewise. + 2016-12-04 Janus Weil <janus@gcc.gnu.org> PR fortran/78618 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index e6917a53850..c531522f71f 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -2563,7 +2563,7 @@ cleanup: characterizes the reference. */ gfc_array_ref * -gfc_find_array_ref (gfc_expr *e) +gfc_find_array_ref (gfc_expr *e, bool allow_null) { gfc_ref *ref; @@ -2573,7 +2573,12 @@ gfc_find_array_ref (gfc_expr *e) break; if (ref == NULL) - gfc_internal_error ("gfc_find_array_ref(): No ref found"); + { + if (allow_null) + return NULL; + else + gfc_internal_error ("gfc_find_array_ref(): No ref found"); + } return &ref->u.ar; } @@ -2581,18 +2586,16 @@ gfc_find_array_ref (gfc_expr *e) /* Find out if an array shape is known at compile time. */ -int +bool gfc_is_compile_time_shape (gfc_array_spec *as) { - int i; - if (as->type != AS_EXPLICIT) - return 0; + return false; - for (i = 0; i < as->rank; i++) + for (int i = 0; i < as->rank; i++) if (!gfc_is_constant_expr (as->lower[i]) || !gfc_is_constant_expr (as->upper[i])) - return 0; + return false; - return 1; + return true; } diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index ba965c96114..1fba6c93072 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -841,20 +841,19 @@ has_finalizer_component (gfc_symbol *derived) gfc_component *c; for (c = derived->components; c; c = c->next) - { - if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived - && c->ts.u.derived->f2k_derived->finalizers) - return true; - - /* Stop infinite recursion through this function by inhibiting - calls when the derived type and that of the component are - the same. */ - if (c->ts.type == BT_DERIVED - && !gfc_compare_derived_types (derived, c->ts.u.derived) - && !c->attr.pointer && !c->attr.allocatable - && has_finalizer_component (c->ts.u.derived)) - return true; - } + if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable) + { + if (c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->finalizers) + return true; + + /* Stop infinite recursion through this function by inhibiting + calls when the derived type and that of the component are + the same. */ + if (!gfc_compare_derived_types (derived, c->ts.u.derived) + && has_finalizer_component (c->ts.u.derived)) + return true; + } return false; } @@ -965,6 +964,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, cond->block = gfc_get_code (EXEC_IF); cond->block->expr1 = gfc_get_expr (); cond->block->expr1->expr_type = EXPR_FUNCTION; + cond->block->expr1->where = gfc_current_locus; gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false); cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE; cond->block->expr1->symtree->n.sym->attr.intrinsic = 1; @@ -1077,6 +1077,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, gfc_commit_symbol (expr->symtree->n.sym); expr->ts.type = BT_INTEGER; expr->ts.kind = gfc_index_integer_kind; + expr->where = gfc_current_locus; /* TRANSFER. */ expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer", @@ -1093,6 +1094,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, block->ext.actual->expr->value.op.op1 = expr2; block->ext.actual->expr->value.op.op2 = offset; block->ext.actual->expr->ts = expr->ts; + block->ext.actual->expr->where = gfc_current_locus; /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ block->ext.actual->next = gfc_get_actual_arglist (); @@ -1149,6 +1151,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, expr->ref->u.ar.dimen = 1; expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); + expr->where = sizes->declared_at; expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod", gfc_current_locus, 2, @@ -1169,6 +1172,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1 = gfc_lval_expr_from_sym (idx2); @@ -1177,6 +1181,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, expr2->value.op.op2->ref->u.ar.start[0]->ts = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; expr2->ts = idx->ts; + expr2->where = gfc_current_locus; /* ... * strides(idx2). */ expr = gfc_get_expr (); @@ -1192,6 +1197,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); expr->value.op.op2->ref->u.ar.as = strides->as; expr->ts = idx->ts; + expr->where = gfc_current_locus; /* offset = offset + ... */ block->block->next = gfc_get_code (EXEC_ASSIGN); @@ -1202,6 +1208,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); block->block->next->expr2->value.op.op2 = expr; block->block->next->expr2->ts = idx->ts; + block->block->next->expr2->where = gfc_current_locus; /* After the loop: offset = offset * byte_stride. */ block->next = gfc_get_code (EXEC_ASSIGN); @@ -1213,6 +1220,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride); block->expr2->ts = block->expr2->value.op.op1->ts; + block->expr2->where = gfc_current_locus; return block; } @@ -1422,6 +1430,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, /* Offset calculation for the new array: idx * size of type (in bytes). */ offset2 = gfc_get_expr (); offset2->expr_type = EXPR_OP; + offset2->where = gfc_current_locus; offset2->value.op.op = INTRINSIC_TIMES; offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); offset2->value.op.op2 = gfc_copy_expr (size_expr); @@ -1826,6 +1835,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->expr2 = gfc_get_expr (); block->expr2->expr_type = EXPR_OP; block->expr2->value.op.op = INTRINSIC_TIMES; + block->expr2->where = gfc_current_locus; /* sizes(idx-1). */ block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); @@ -1837,6 +1847,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr (); block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus; block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1 = gfc_lval_expr_from_sym (idx); @@ -1890,6 +1901,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1 = gfc_lval_expr_from_sym (idx); @@ -1927,6 +1939,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->expr2->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); last_code->expr2->ts = last_code->expr2->value.op.op2->ts; + last_code->expr2->where = gfc_current_locus; last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); last_code->expr2->value.op.op1->ref = gfc_get_ref (); diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 139ce880534..ea19732ccc3 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -483,7 +483,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, if (ref || last_ts->type == BT_CHARACTER) { - if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) + /* An initializer has to be constant. */ + if (rvalue->expr_type != EXPR_CONSTANT + || (lvalue->ts.u.cl->length == NULL + && !(ref && ref->u.ss.length != NULL))) return false; expr = create_character_initializer (init, last_ts, ref, rvalue); } diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 411d496dd5b..c8adedb933e 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1119,12 +1119,12 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) { /* Create a partially populated interface symbol to carry the characteristics of the procedure and the result. */ - sym->ts.interface = gfc_new_symbol (name, sym->ns); - gfc_add_type (sym->ts.interface, &(sym->ts), + sym->tlink = gfc_new_symbol (name, sym->ns); + gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); - gfc_copy_attr (&sym->ts.interface->attr, &sym->attr, NULL); + gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); if (sym->attr.dimension) - sym->ts.interface->as = gfc_copy_array_spec (sym->as); + sym->tlink->as = gfc_copy_array_spec (sym->as); /* Ideally, at this point, a copy would be made of the formal arguments and their namespace. However, this does not appear @@ -1133,12 +1133,12 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) if (sym->result && sym->result != sym) { - sym->ts.interface->result = sym->result; + sym->tlink->result = sym->result; sym->result = NULL; } else if (sym->result) { - sym->ts.interface->result = sym->ts.interface; + sym->tlink->result = sym->tlink; } } else if (sym && !sym->gfc_new @@ -6063,7 +6063,6 @@ gfc_match_function_decl (void) sym->result = result; } - /* Warn if this procedure has the same name as an intrinsic. */ do_warn_intrinsic_shadow (sym, true); @@ -8254,11 +8253,11 @@ gfc_match_submod_proc (void) /* Make sure that the result field is appropriately filled, even though the result symbol will be replaced later on. */ - if (sym->ts.interface && sym->ts.interface->attr.function) + if (sym->tlink && sym->tlink->attr.function) { - if (sym->ts.interface->result - && sym->ts.interface->result != sym->ts.interface) - sym->result= sym->ts.interface->result; + if (sym->tlink->result + && sym->tlink->result != sym->tlink) + sym->result= sym->tlink->result; else sym->result = sym; } diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 0fd8a4e74e3..dcd9647dac6 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -1160,6 +1160,24 @@ gfc_warning_now (int opt, const char *gmsgid, ...) return ret; } +/* Internal warning, do not buffer. */ + +bool +gfc_warning_internal (int opt, const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + bool ret; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + DK_WARNING); + diagnostic.option_index = opt; + ret = report_diagnostic (&diagnostic); + va_end (argp); + return ret; +} /* Immediate error (i.e. do not buffer). */ @@ -1226,6 +1244,7 @@ gfc_warning_check (void) diagnostic_action_after_output (global_dc, warningcount_buffered ? DK_WARNING : DK_ERROR); + diagnostic_check_max_errors (global_dc, true); } } @@ -1370,6 +1389,7 @@ gfc_error_check (void) gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); pp->buffer = tmp_buffer; diagnostic_action_after_output (global_dc, DK_ERROR); + diagnostic_check_max_errors (global_dc, true); return true; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3464a204547..f57198fc35b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -881,18 +881,17 @@ done: } -/* Function to determine if an expression is constant or not. This - function expects that the expression has already been simplified. */ +/* Determine if an expression is constant in the sense of F08:7.1.12. + * This function expects that the expression has already been simplified. */ -int +bool gfc_is_constant_expr (gfc_expr *e) { gfc_constructor *c; gfc_actual_arglist *arg; - gfc_symbol *sym; if (e == NULL) - return 1; + return true; switch (e->expr_type) { @@ -902,7 +901,7 @@ gfc_is_constant_expr (gfc_expr *e) || gfc_is_constant_expr (e->value.op.op2))); case EXPR_VARIABLE: - return 0; + return false; case EXPR_FUNCTION: case EXPR_PPC: @@ -915,40 +914,21 @@ gfc_is_constant_expr (gfc_expr *e) { for (arg = e->value.function.actual; arg; arg = arg->next) if (!gfc_is_constant_expr (arg->expr)) - return 0; + return false; } - /* Specification functions are constant. */ - /* F95, 7.1.6.2; F2003, 7.1.7 */ - sym = NULL; - if (e->symtree) - sym = e->symtree->n.sym; - if (e->value.function.esym) - sym = e->value.function.esym; - - if (sym - && sym->attr.function - && sym->attr.pure - && !sym->attr.intrinsic - && !sym->attr.recursive - && sym->attr.proc != PROC_INTERNAL - && sym->attr.proc != PROC_ST_FUNCTION - && sym->attr.proc != PROC_UNKNOWN - && gfc_sym_get_dummy_args (sym) == NULL) - return 1; - if (e->value.function.isym && (e->value.function.isym->elemental || e->value.function.isym->pure || e->value.function.isym->inquiry || e->value.function.isym->transformational)) - return 1; + return true; - return 0; + return false; case EXPR_CONSTANT: case EXPR_NULL: - return 1; + return true; case EXPR_SUBSTRING: return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) @@ -962,14 +942,14 @@ gfc_is_constant_expr (gfc_expr *e) for (; c; c = gfc_constructor_next (c)) if (!gfc_is_constant_expr (c->expr)) - return 0; + return false; - return 1; + return true; default: gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); - return 0; + return false; } } @@ -2739,7 +2719,8 @@ restricted_args (gfc_actual_arglist *a) /************* Restricted/specification expressions *************/ -/* Make sure a non-intrinsic function is a specification function. */ +/* Make sure a non-intrinsic function is a specification function, + * see F08:7.1.11.5. */ static bool external_spec_function (gfc_expr *e) diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 44d2a4218b7..82812f883ed 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -48,6 +48,10 @@ static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, locus *, gfc_namespace *, char *vname=NULL); +#ifdef CHECKING_P +static void check_locus (gfc_namespace *); +#endif + /* How deep we are inside an argument list. */ static int count_arglist; @@ -127,6 +131,10 @@ gfc_run_passes (gfc_namespace *ns) doloop_list.release (); int w, e; +#ifdef CHECKING_P + check_locus (ns); +#endif + if (flag_frontend_optimize) { optimize_namespace (ns); @@ -145,6 +153,53 @@ gfc_run_passes (gfc_namespace *ns) realloc_strings (ns); } +#ifdef CHECKING_P + +/* Callback function: Warn if there is no location information in a + statement. */ + +static int +check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + current_code = c; + if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL))) + gfc_warning_internal (0, "No location in statement"); + + return 0; +} + + +/* Callback function: Warn if there is no location information in an + expression. */ + +static int +check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + + if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL))) + gfc_warning_internal (0, "No location in expression near %L", + &((*current_code)->loc)); + return 0; +} + +/* Run check for missing location information. */ + +static void +check_locus (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + check_locus (ns); + } +} + +#endif + /* Callback for each gfc_code node invoked from check_realloc_strings. For an allocatable LHS string which also appears as a variable on the RHS, replace diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 370b2a0e89c..ae1a01b0ec4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1532,19 +1532,27 @@ typedef struct gfc_symbol gfc_namelist *namelist, *namelist_tail; /* Change management fields. Symbols that might be modified by the - current statement have the mark member nonzero and are kept in a - singly linked list through the tlink field. Of these symbols, + current statement have the mark member nonzero. Of these symbols, symbols with old_symbol equal to NULL are symbols created within the current statement. Otherwise, old_symbol points to a copy of - the old symbol. */ - - struct gfc_symbol *old_symbol, *tlink; + the old symbol. gfc_new is used in symbol.c to flag new symbols. */ + struct gfc_symbol *old_symbol; unsigned mark:1, gfc_new:1; + + /* The tlink field is used in the front end to carry the module + declaration of separate module procedures so that the characteristics + can be compared with the corresponding declaration in a submodule. In + translation this field carries a linked list of symbols that require + deferred initialization. */ + struct gfc_symbol *tlink; + /* Nonzero if all equivalences associated with this symbol have been processed. */ unsigned equiv_built:1; /* Set if this variable is used as an index name in a FORALL. */ unsigned forall_index:1; + /* Set if the symbol is used in a function result specification . */ + unsigned fn_result_spec:1; /* Used to avoid multiple resolutions of a single symbol. */ unsigned resolved:1; /* Set if this is a module function or subroutine with the @@ -1768,7 +1776,7 @@ typedef struct gfc_namespace /* !$ACC ROUTINE names. */ gfc_oacc_routine_name *oacc_routine_names; - gfc_charlen *cl_list, *old_cl_list; + gfc_charlen *cl_list; gfc_dt_list *derived_types; @@ -2778,6 +2786,7 @@ const char *gfc_print_wide_char (gfc_char_t); bool gfc_warning (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); +bool gfc_warning_internal (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) ATTRIBUTE_GCC_GFC(3,4); @@ -3079,7 +3088,7 @@ bool gfc_check_init_expr (gfc_expr *); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); void gfc_type_convert_binary (gfc_expr *, int); -int gfc_is_constant_expr (gfc_expr *); +bool gfc_is_constant_expr (gfc_expr *); bool gfc_simplify_expr (gfc_expr *, int); int gfc_has_vector_index (gfc_expr *); @@ -3171,7 +3180,7 @@ bool gfc_resolve_iterator (gfc_iterator *, bool, bool); bool find_forall_index (gfc_expr *, gfc_symbol *, int); bool gfc_resolve_index (gfc_expr *, int); bool gfc_resolve_dim_arg (gfc_expr *); -int gfc_is_formal_arg (void); +bool gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); @@ -3205,11 +3214,11 @@ bool gfc_check_constructor (gfc_expr *, bool (*)(gfc_expr *)); bool gfc_array_size (gfc_expr *, mpz_t *); bool gfc_array_dimen_size (gfc_expr *, int, mpz_t *); bool gfc_array_ref_shape (gfc_array_ref *, mpz_t *); -gfc_array_ref *gfc_find_array_ref (gfc_expr *); +gfc_array_ref *gfc_find_array_ref (gfc_expr *, bool a = false); tree gfc_conv_array_initializer (tree type, gfc_expr *); bool spec_size (gfc_array_spec *, mpz_t *); bool spec_dimen_size (gfc_array_spec *, int, mpz_t *); -int gfc_is_compile_time_shape (gfc_array_spec *); +bool gfc_is_compile_time_shape (gfc_array_spec *); bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *); @@ -3243,6 +3252,7 @@ int gfc_has_vector_subscript (gfc_expr*); gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*); void gfc_check_dtio_interfaces (gfc_symbol*); +gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool); gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 8afba84a697..a6f4e7204e1 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1712,8 +1712,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, return 0; /* Special case: alternate returns. If both f1->sym and f2->sym are - NULL, then the leading formal arguments are alternate returns. - The previous conditional should catch argument lists with + NULL, then the leading formal arguments are alternate returns. + The previous conditional should catch argument lists with different number of argument. */ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) return 1; @@ -2803,6 +2803,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, int i, n, na; unsigned long actual_size, formal_size; bool full_array = false; + gfc_array_ref *actual_arr_ref; actual = *ap; @@ -2942,37 +2943,38 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, and assumed-shape dummies, the string length needs to match exactly. */ if (a->expr->ts.type == BT_CHARACTER - && a->expr->ts.u.cl && a->expr->ts.u.cl->length - && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT - && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length - && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT - && (f->sym->attr.pointer || f->sym->attr.allocatable - || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) - && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, - f->sym->ts.u.cl->length->value.integer) != 0)) - { - if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (OPT_Wargument_mismatch, - "Character length mismatch (%ld/%ld) between actual " - "argument and pointer or allocatable dummy argument " - "%qs at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - else if (where) - gfc_warning (OPT_Wargument_mismatch, - "Character length mismatch (%ld/%ld) between actual " - "argument and assumed-shape dummy argument %qs " - "at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - return 0; - } + && a->expr->ts.u.cl && a->expr->ts.u.cl->length + && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl + && f->sym->ts.u.cl->length + && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && (f->sym->attr.pointer || f->sym->attr.allocatable + || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) + && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, + f->sym->ts.u.cl->length->value.integer) != 0)) + { + if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) + gfc_warning (OPT_Wargument_mismatch, + "Character length mismatch (%ld/%ld) between actual " + "argument and pointer or allocatable dummy argument " + "%qs at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + else if (where) + gfc_warning (OPT_Wargument_mismatch, + "Character length mismatch (%ld/%ld) between actual " + "argument and assumed-shape dummy argument %qs " + "at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + return 0; + } if ((f->sym->attr.pointer || f->sym->attr.allocatable) - && f->sym->ts.deferred != a->expr->ts.deferred - && a->expr->ts.type == BT_CHARACTER) + && f->sym->ts.deferred != a->expr->ts.deferred + && a->expr->ts.type == BT_CHARACTER) { if (where) gfc_error ("Actual argument at %L to allocatable or " @@ -3195,15 +3197,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + /* Find the last array_ref. */ + actual_arr_ref = NULL; + if (a->expr->ref) + actual_arr_ref = gfc_find_array_ref (a->expr, true); + if (f->sym->attr.volatile_ - && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION + && actual_arr_ref && actual_arr_ref->type == AR_SECTION && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Array-section actual argument at %L is " "incompatible with the non-assumed-shape " "dummy argument %qs due to VOLATILE attribute", - &a->expr->where,f->sym->name); + &a->expr->where, f->sym->name); return 0; } @@ -4826,13 +4833,10 @@ gfc_check_dtio_interfaces (gfc_symbol *derived) } -gfc_symbol * -gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +gfc_symtree* +gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) { gfc_symtree *tb_io_st = NULL; - gfc_symbol *dtio_sub = NULL; - gfc_symbol *extended; - gfc_typebound_proc *tb_io_proc, *specific_proc; bool t = false; if (!derived || derived->attr.flavor != FL_DERIVED) @@ -4869,6 +4873,19 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) true, &derived->declared_at); } + return tb_io_st; +} + + +gfc_symbol * +gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + gfc_symbol *dtio_sub = NULL; + gfc_symbol *extended; + gfc_typebound_proc *tb_io_proc, *specific_proc; + + tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); if (tb_io_st != NULL) { @@ -4893,17 +4910,17 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) dtio_sub = st->n.tb->u.specific->n.sym; else dtio_sub = specific_proc->u.specific->n.sym; - } - if (tb_io_st != NULL) - goto finish; + goto finish; + } /* If there is not a typebound binding, look for a generic DTIO interface. */ for (extended = derived; extended; extended = gfc_get_derived_super_type (extended)) { - if (extended == NULL || extended->ns == NULL) + if (extended == NULL || extended->ns == NULL + || extended->attr.flavor == FL_UNKNOWN) return NULL; if (formatted == true) diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index e727adebc99..713f27271de 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -4710,6 +4710,7 @@ load_omp_udrs (void) mio_lparen (); mio_pool_string (&name); + gfc_clear_ts (&ts); mio_typespec (&ts); if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0) { diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index ec1d0d692bf..6addae3678e 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -116,7 +116,6 @@ use_modules (void) gfc_pop_error (&old_error); gfc_commit_symbols (); gfc_warning_check (); - gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; gfc_current_ns->old_equiv = gfc_current_ns->equiv; gfc_current_ns->old_data = gfc_current_ns->data; last_was_use_stmt = false; @@ -1386,7 +1385,6 @@ next_statement (void) gfc_new_block = NULL; - gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; gfc_current_ns->old_equiv = gfc_current_ns->equiv; gfc_current_ns->old_data = gfc_current_ns->data; for (;;) @@ -2483,41 +2481,13 @@ accept_statement (gfc_statement st) } -/* Clear default character types with charlen pointers that are about - to become invalid. */ - -static void -clear_default_charlen (gfc_namespace *ns, const gfc_charlen *cl, - const gfc_charlen *end) -{ - gfc_typespec *ts; - - for (ts = &ns->default_type[0]; ts < &ns->default_type[GFC_LETTERS]; ts++) - if (ts->type == BT_CHARACTER) - { - const gfc_charlen *cl2; - for (cl2 = cl; cl2 != end; cl2 = cl2->next) - if (ts->u.cl == cl2) - { - ts->u.cl = NULL; - ts->type = BT_UNKNOWN; - break; - } - } -} - -/* Undo anything tentative that has been built for the current - statement. */ +/* Undo anything tentative that has been built for the current statement, + except if a gfc_charlen structure has been added to current namespace's + list of gfc_charlen structure. */ static void reject_statement (void) { - /* Revert to the previous charlen chain. */ - clear_default_charlen (gfc_current_ns, - gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); - gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); - gfc_current_ns->cl_list = gfc_current_ns->old_cl_list; - gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); gfc_current_ns->equiv = gfc_current_ns->old_equiv; @@ -5586,11 +5556,11 @@ get_modproc_result (void) proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL; if (proc != NULL && proc->attr.function - && proc->ts.interface - && proc->ts.interface->result - && proc->ts.interface->result != proc->ts.interface) + && proc->tlink + && proc->tlink->result + && proc->tlink->result != proc->tlink) { - gfc_copy_dummy_sym (&proc->result, proc->ts.interface->result, 1); + gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1); gfc_set_sym_referenced (proc->result); proc->result->attr.if_source = IFSRC_DECL; gfc_commit_symbol (proc->result); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7bc9f5f5b6f..2c70e6cfe9b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -72,9 +72,9 @@ static bool first_actual_arg = false; static int omp_workshare_flag; -/* Nonzero if we are processing a formal arglist. The corresponding function +/* True if we are processing a formal arglist. The corresponding function resets the flag each time that it is read. */ -static int formal_arg_flag = 0; +static bool formal_arg_flag = false; /* True if we are resolving a specification expression. */ static bool specification_expr = false; @@ -89,7 +89,7 @@ static bitmap_obstack labels_obstack; static bool inquiry_argument = false; -int +bool gfc_is_formal_arg (void) { return formal_arg_flag; @@ -285,7 +285,7 @@ resolve_formal_arglist (gfc_symbol *proc) sym->attr.always_explicit = 1; } - formal_arg_flag = 1; + formal_arg_flag = true; for (f = proc->formal; f; f = f->next) { @@ -530,7 +530,7 @@ resolve_formal_arglist (gfc_symbol *proc) } } } - formal_arg_flag = 0; + formal_arg_flag = false; } @@ -566,6 +566,14 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) { bool t; + if (sym && sym->attr.flavor == FL_PROCEDURE + && sym->ns->parent + && sym->ns->parent->proc_name + && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE + && !strcmp (sym->name, sym->ns->parent->proc_name->name)) + gfc_error ("Contained procedure %qs at %L has the same name as its " + "encompassing procedure", sym->name, &sym->declared_at); + /* If this namespace is not a function or an entry master function, ignore it. */ if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) @@ -1249,31 +1257,12 @@ resolve_structure_cons (gfc_expr *expr, int init) gfc_constructor_append_expr (&cons->expr->value.constructor, para, &cons->expr->where); } + if (cons->expr->expr_type == EXPR_ARRAY) { - gfc_constructor *p; - p = gfc_constructor_first (cons->expr->value.constructor); - if (cons->expr->ts.u.cl != p->expr->ts.u.cl) - { - gfc_charlen *cl, *cl2; - - cl2 = NULL; - for (cl = gfc_current_ns->cl_list; cl; cl = cl->next) - { - if (cl == cons->expr->ts.u.cl) - break; - cl2 = cl; - } - - gcc_assert (cl); - - if (cl2) - cl2->next = cl->next; - - gfc_free_expr (cl->length); - free (cl); - } - + /* Rely on the cleanup of the namespace to deal correctly with + the old charlen. (There was a block here that attempted to + remove the charlen but broke the chain in so doing.) */ cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); cons->expr->ts.u.cl->length_from_typespec = true; cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); @@ -11836,8 +11825,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) && !sym->attr.pointer && is_non_constant_shape_array (sym)) { - /* The shape of a main program or module array needs to be - constant. */ + /* F08:C541. The shape of an array defined in a main program or module + * needs to be constant. */ gfc_error ("The module or main program array %qs at %L must " "have constant shape", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; @@ -12274,10 +12263,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) module_name = strtok (name, "."); submodule_name = strtok (NULL, "."); - /* Stop the dummy characteristics test from using the interface - symbol instead of 'sym'. */ - iface = sym->ts.interface; - sym->ts.interface = NULL; + iface = sym->tlink; + sym->tlink = NULL; /* Make sure that the result uses the correct charlen for deferred length results. */ @@ -12325,7 +12312,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } check_formal: - /* Check the charcateristics of the formal arguments. */ + /* Check the characteristics of the formal arguments. */ if (sym->formal && sym->formal_ns) { for (arg = sym->formal; arg && arg->sym; arg = arg->next) @@ -12334,8 +12321,6 @@ check_formal: gfc_traverse_ns (sym->formal_ns, compare_fsyms); } } - - sym->ts.interface = iface; } return true; } @@ -13900,15 +13885,7 @@ resolve_fl_namelist (gfc_symbol *sym) "or POINTER components", nl->sym->name, sym->name, &sym->declared_at)) return false; - - if (!dtio) - { - gfc_error ("NAMELIST object %qs in namelist %qs at %L has " - "ALLOCATABLE or POINTER components and thus requires " - "a defined input/output procedure", nl->sym->name, - sym->name, &sym->declared_at); - return false; - } + return true; } } @@ -14067,8 +14044,8 @@ resolve_symbol (gfc_symbol *sym) if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.codimension - && (sym->ts.u.derived->attr.alloc_comp - || sym->ts.u.derived->attr.pointer_comp)) + && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp + || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) { gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) " "type coarrays at %L are unsupported", &sym->declared_at); @@ -14745,14 +14722,14 @@ resolve_symbol (gfc_symbol *sym) an error for host associated variables in the specification expression for an array_valued function. */ if (sym->attr.function && sym->as) - formal_arg_flag = 1; + formal_arg_flag = true; saved_specification_expr = specification_expr; specification_expr = true; gfc_resolve_array_spec (sym->as, check_constant); specification_expr = saved_specification_expr; - formal_arg_flag = 0; + formal_arg_flag = false; /* Resolve formal namespaces. */ if (sym->formal_ns && sym->formal_ns != gfc_current_ns @@ -15755,6 +15732,54 @@ resolve_equivalence (gfc_equiv *eq) } +/* Function called by resolve_fntype to flag other symbol used in the + length type parameter specification of function resuls. */ + +static bool +flag_fn_result_spec (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + gfc_namespace *ns; + gfc_symbol *s; + + if (expr->expr_type == EXPR_VARIABLE) + { + s = expr->symtree->n.sym; + for (ns = s->ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (!s->fn_result_spec + && s->attr.flavor == FL_PARAMETER) + { + /* Function contained in a module.... */ + if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_symtree *st; + s->fn_result_spec = 1; + /* Make sure that this symbol is translated as a module + variable. */ + st = gfc_get_unique_symtree (ns); + st->n.sym = s; + s->refs++; + } + /* ... which is use associated and called. */ + else if (s->attr.use_assoc || s->attr.used_in_submodule + || + /* External function matched with an interface. */ + (s->ns->proc_name + && ((s->ns == ns + && s->ns->proc_name->attr.if_source == IFSRC_DECL) + || s->ns->proc_name->attr.if_source == IFSRC_IFBODY) + && s->ns->proc_name->attr.function)) + s->fn_result_spec = 1; + } + } + return false; +} + + /* Resolve function and ENTRY types, issue diagnostics if needed. */ static void @@ -15805,6 +15830,9 @@ resolve_fntype (gfc_namespace *ns) el->sym->attr.untyped = 1; } } + + if (sym->ts.type == BT_CHARACTER) + gfc_traverse_expr (sym->ts.u.cl->length, NULL, flag_fn_result_spec, 0); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0b711ca20b4..f16e6262b2e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2965,6 +2965,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) p->common_block = NULL; p->f2k_derived = NULL; p->assoc = NULL; + p->fn_result_spec = 0; return p; } @@ -3794,31 +3795,22 @@ gfc_charlen* gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) { gfc_charlen *cl; + cl = gfc_get_charlen (); /* Copy old_cl. */ if (old_cl) { - /* Put into namespace, but don't allow reject_statement - to free it if old_cl is given. */ - gfc_charlen **prev = &ns->cl_list; - cl->next = ns->old_cl_list; - while (*prev != ns->old_cl_list) - prev = &(*prev)->next; - *prev = cl; - ns->old_cl_list = cl; cl->length = gfc_copy_expr (old_cl->length); cl->length_from_typespec = old_cl->length_from_typespec; cl->backend_decl = old_cl->backend_decl; cl->passed_length = old_cl->passed_length; cl->resolved = old_cl->resolved; } - else - { - /* Put into namespace. */ - cl->next = ns->cl_list; - ns->cl_list = cl; - } + + /* Put into namespace. */ + cl->next = ns->cl_list; + ns->cl_list = cl; return cl; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ac90a4ba188..0cd83f41789 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5652,53 +5652,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, } -/* Deallocate an array variable. Also used when an allocated variable goes - out of scope. */ -/*GCC ARRAYS*/ - -tree -gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr, - int coarray_dealloc_mode) -{ - tree var; - tree tmp; - stmtblock_t block; - bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY; - - gfc_start_block (&block); - - /* Get a pointer to the data. */ - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Parameter is the address of the data component. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg, - errlen, label_finish, false, expr, - coarray_dealloc_mode); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer; only for coarrays an error can occur and then - the allocation status may not be changed. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - if (pstat != NULL_TREE && coarray && flag_coarray == GFC_FCOARRAY_LIB) - { - tree cond; - tree stat = build_fold_indirect_ref_loc (input_location, pstat); - - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - /* Create an array constructor from an initialization expression. We assume the frontend already did any expansions and conversions. */ @@ -7806,39 +7759,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, } -/* Generate code to deallocate an array, if it is allocated. */ - -tree -gfc_trans_dealloc_allocated (tree descriptor, gfc_expr *expr, - int coarray_dealloc_mode) -{ - tree tmp; - tree var; - stmtblock_t block; - bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY; - - gfc_start_block (&block); - - var = gfc_conv_descriptor_data_get (descriptor); - STRIP_NOPS (var); - - /* Call array_deallocate with an int * present in the second argument. - Although it is ignored here, it's presence ensures that arrays that - are already deallocated are ignored. */ - tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE, true, expr, - coarray_dealloc_mode); - gfc_add_expr_to_block (&block, tmp); - - /* Zero the data pointer. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - /* This helper function calculates the size in words of a full array. */ tree @@ -8157,8 +8077,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree null_cond = NULL_TREE; tree add_when_allocated; tree dealloc_fndecl; - bool called_dealloc_with_status; + tree caf_token; gfc_symbol *vtab; + int caf_dereg_mode; + symbol_attribute *attr; + bool deallocate_called; gfc_init_block (&fnblock); @@ -8265,7 +8188,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) && c->ts.u.derived->attr.alloc_comp; - bool same_type = c->ts.type == BT_DERIVED && der_type == c->ts.u.derived; + bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) + || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); cdecl = c->backend_decl; ctype = TREE_TYPE (cdecl); @@ -8274,112 +8198,118 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { case DEALLOCATE_ALLOC_COMP: - /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp - (i.e. this function) so generate all the calls and suppress the - recursion from here, if necessary. */ - called_dealloc_with_status = false; gfc_init_block (&tmpblock); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + attr = &CLASS_DATA (c)->attr; + else + attr = &c->attr; + if ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + /* Call the finalizer, which will free the memory and nullify the + pointer of an array. */ + deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, + caf_enabled (caf_mode)) + && attr->dimension; + else + deallocate_called = false; + + /* Add the _class ref for classes. */ + if (c->ts.type == BT_CLASS && attr->allocatable) + comp = gfc_class_data_get (comp); - /* The finalizer frees allocatable components. */ - called_dealloc_with_status - = gfc_add_comp_finalizer_call (&tmpblock, comp, c, - purpose == DEALLOCATE_ALLOC_COMP - && caf_enabled (caf_mode)); + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer + && !same_type + && !deallocate_called) + { + /* Add checked deallocation of the components. This code is + obviously added because the finalizer is not trusted to free + all memory. */ + if (c->ts.type == BT_CLASS) + { + rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; + add_when_allocated + = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, + comp, NULL_TREE, rank, purpose, + caf_mode); + } + else + { + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode); + } } - else - comp = NULL_TREE; - if (c->attr.allocatable && !c->attr.proc_pointer && !same_type - && (c->attr.dimension - || (caf_enabled (caf_mode) - && (caf_in_coarray (caf_mode) || c->attr.codimension)))) + if (attr->allocatable && !same_type + && (!attr->codimension || caf_enabled (caf_mode))) { - /* Allocatable arrays or coarray'ed components (scalar or - array). */ - int caf_dereg_mode - = (caf_in_coarray (caf_mode) || c->attr.codimension) + /* Handle all types of components besides components of the + same_type as the current one, because those would create an + endless loop. */ + caf_dereg_mode + = (caf_in_coarray (caf_mode) || attr->codimension) ? (gfc_caf_is_dealloc_only (caf_mode) ? GFC_CAF_COARRAY_DEALLOCATE_ONLY : GFC_CAF_COARRAY_DEREGISTER) : GFC_CAF_COARRAY_NOCOARRAY; - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension || c->attr.codimension) - /* Deallocate array. */ - tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode); - else + caf_token = NULL_TREE; + /* Coarray components are handled directly by + deallocate_with_status. */ + if (!attr->codimension + && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) { - /* Deallocate scalar. */ - tree cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, comp, - build_int_cst (TREE_TYPE (comp), - 0)); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, - pvoid_type_node, decl, c->caf_token, - NULL_TREE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - gfc_build_addr_expr (NULL_TREE, - tmp), - build_int_cst (integer_type_node, - caf_dereg_mode), - null_pointer_node, - null_pointer_node, - integer_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, cond, tmp, - build_empty_stmt (input_location)); + if (c->caf_token) + caf_token = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (c->caf_token), + decl, c->caf_token, NULL_TREE); + else if (attr->dimension && !attr->proc_pointer) + caf_token = gfc_conv_descriptor_token (comp); } + if (attr->dimension && !attr->codimension && !attr->proc_pointer) + /* When this is an array but not in conjunction with a coarray + then add the data-ref. For coarray'ed arrays the data-ref + is added by deallocate_with_status. */ + comp = gfc_conv_descriptor_data_get (comp); - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (c->attr.allocatable && !c->attr.codimension && !same_type) - { - /* Allocatable scalar components. */ - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, - NULL_TREE, true, NULL, - c->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; + tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, caf_dereg_mode, + add_when_allocated, caf_token); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&tmpblock, tmp); } - else if (c->attr.allocatable && !c->attr.codimension) + else if (attr->allocatable && !attr->codimension + && !deallocate_called) { /* Case of recursive allocatable derived types. */ tree is_allocated; tree ubound; tree cdesc; - tree data; stmtblock_t dealloc_block; gfc_init_block (&dealloc_block); + if (add_when_allocated) + gfc_add_expr_to_block (&dealloc_block, add_when_allocated); /* Convert the component into a rank 1 descriptor type. */ - if (comp == NULL_TREE) - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - if (c->attr.dimension) + if (attr->dimension) { tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank); + ubound = gfc_full_array_size (&dealloc_block, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); } else { @@ -8405,12 +8335,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, gfc_index_zero_node, ubound); - if (c->attr.dimension) - data = gfc_conv_descriptor_data_get (comp); - else - data = comp; + if (attr->dimension) + comp = gfc_conv_descriptor_data_get (comp); - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data); + gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); /* Now call the deallocator. */ vtab = gfc_find_vtab (&c->ts); @@ -8420,10 +8348,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dealloc_fndecl = gfc_vptr_deallocate_get (tmp); dealloc_fndecl = build_fold_indirect_ref_loc (input_location, dealloc_fndecl); - tmp = build_int_cst (TREE_TYPE (data), 0); + tmp = build_int_cst (TREE_TYPE (comp), 0); is_allocated = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, - data); + comp); cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); tmp = build_call_expr_loc (input_location, @@ -8438,49 +8366,20 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_empty_stmt (input_location)); gfc_add_expr_to_block (&tmpblock, tmp); - - gfc_add_modify (&tmpblock, data, - build_int_cst (TREE_TYPE (data), 0)); } + else if (add_when_allocated) + gfc_add_expr_to_block (&tmpblock, add_when_allocated); - else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable - && (!CLASS_DATA (c)->attr.codimension - || !caf_enabled (caf_mode))) + if (c->ts.type == BT_CLASS && attr->allocatable + && (!attr->codimension || !caf_enabled (caf_mode))) { - /* Allocatable CLASS components. */ - - /* Add reference to '_data' component. */ - tmp = CLASS_DATA (c)->backend_decl; - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), comp, tmp, NULL_TREE); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - tmp = gfc_trans_dealloc_allocated (comp, NULL, - CLASS_DATA (c)->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); - else - { - tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, - NULL_TREE, true, - NULL, - CLASS_DATA (c)->ts); - gfc_add_expr_to_block (&tmpblock, tmp); - called_dealloc_with_status = true; - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - } - gfc_add_expr_to_block (&tmpblock, tmp); - /* Finally, reset the vptr to the declared type vtable and, if necessary reset the _len field. First recover the reference to the component and obtain the vptr. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + decl, cdecl, NULL_TREE); tmp = gfc_class_vptr_get (comp); if (UNLIMITED_POLY (c)) @@ -8507,22 +8406,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, } } - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer - && !same_type - && !called_dealloc_with_status) - { - /* Do not deallocate the components of ultimate pointer - components or iteratively call self if call has been made - to gfc_trans_dealloc_allocated */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode); - gfc_add_expr_to_block (&fnblock, tmp); - } - /* Now add the deallocation of this component. */ gfc_add_block_to_block (&fnblock, &tmpblock); break; @@ -9454,6 +9337,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, if (token == NULL_TREE) { tmp = gfc_get_tree_for_caf_expr (expr1); + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref (tmp); gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, expr1); token = gfc_build_addr_expr (NULL_TREE, token); @@ -9723,10 +9608,11 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { gfc_expr *e; e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; - tmp = gfc_trans_dealloc_allocated (sym->backend_decl, e, - sym->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); + tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, e, + sym->attr.codimension + ? GFC_CAF_COARRAY_DEREGISTER + : GFC_CAF_COARRAY_NOCOARRAY); if (e) gfc_free_expr (e); gfc_add_expr_to_block (&cleanup, tmp); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 0a6621b0a63..ab0a6dee972 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -18,9 +18,6 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see <http://www.gnu.org/licenses/>. */ -/* Generate code to free an array. */ -tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*, int c = -2); - /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, @@ -41,8 +38,6 @@ void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *); void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); -/* Generate code to deallocate an array, if it is allocated. */ -tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int); tree gfc_full_array_size (stmtblock_t *, tree, int); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 2e6ef2a2bfc..a7a5e2a4b6b 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -356,12 +356,36 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) if (sym->attr.is_bind_c == 1 && sym->binding_label) return get_identifier (sym->binding_label); - if (sym->module == NULL) - return gfc_sym_identifier (sym); + if (!sym->fn_result_spec) + { + if (sym->module == NULL) + return gfc_sym_identifier (sym); + else + { + snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); + return get_identifier (name); + } + } else { - snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); - return get_identifier (name); + /* This is an entity that is actually local to a module procedure + that appears in the result specification expression. Since + sym->module will be a zero length string, we use ns->proc_name + instead. */ + if (sym->ns->proc_name && sym->ns->proc_name->module) + { + snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s", + sym->ns->proc_name->module, + sym->ns->proc_name->name, + sym->name); + return get_identifier (name); + } + else + { + snprintf (name, sizeof name, "__%s_PROC_%s", + sym->ns->proc_name->name, sym->name); + return get_identifier (name); + } } } @@ -615,6 +639,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) DECL_EXTERNAL (decl) = 1; TREE_PUBLIC (decl) = 1; } + else if (sym->fn_result_spec && !sym->ns->proc_name->module) + { + + if (sym->ns->proc_name->attr.if_source != IFSRC_DECL) + DECL_EXTERNAL (decl) = 1; + else + TREE_STATIC (decl) = 1; + + TREE_PUBLIC (decl) = 1; + } else if (sym->module && !sym->attr.result && !sym->attr.dummy) { /* TODO: Don't set sym->module for result or dummy variables. */ @@ -1019,7 +1053,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) layout_type (type); } - if (TYPE_NAME (type) != NULL_TREE + if (TYPE_NAME (type) != NULL_TREE && as->rank > 0 && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1))) { @@ -1632,7 +1666,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create string length decl first so that they can be used in the type declaration. For associate names, the target character length is used. Set 'length' to a constant so that if the - string lenght is a variable, it is not finished a second time. */ + string length is a variable, it is not finished a second time. */ if (sym->ts.type == BT_CHARACTER) { if (sym->attr.associate_var @@ -1654,7 +1688,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Symbols from modules should have their assembler names mangled. This is done here rather than in gfc_finish_var_decl because it is different for string length variables. */ - if (sym->module) + if (sym->module || sym->fn_result_spec) { gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); if (sym->attr.use_assoc && !intrinsic_array_parameter) @@ -4766,7 +4800,9 @@ gfc_create_module_variable (gfc_symbol * sym) /* Create the variable. */ pushdecl (decl); - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE + || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE + && sym->fn_result_spec)); DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; rest_of_decl_compilation (decl, 1, 0); gfc_module_add_decl (cur_module, decl); @@ -6153,8 +6189,8 @@ gfc_generate_function_code (gfc_namespace * ns) previous_procedure_symbol = current_procedure_symbol; current_procedure_symbol = sym; - /* Check that the frontend isn't still using this. */ - gcc_assert (sym->tlink == NULL); + /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get + lost or worse. */ sym->tlink = sym; /* Create the declaration for functions with global scope. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 78bff87cd1c..f908c25b9cb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2864,9 +2864,9 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) return 0; m = wrhs.to_shwi (); - /* 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); + /* Use the wide_int's routine to reliably get the absolute value on all + platforms. Then convert it to a HOST_WIDE_INT like above. */ + n = wi::abs (wrhs).to_shwi (); type = TREE_TYPE (lhs); sgn = tree_int_cst_sgn (rhs); @@ -4116,6 +4116,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) new_expr = gfc_copy_expr (arg1->ts.u.cl->length); break; + case GFC_ISYM_LEN_TRIM: + new_expr = gfc_copy_expr (arg1); + gfc_apply_interface_mapping_to_expr (mapping, new_expr); + + if (!new_expr) + return false; + + gfc_replace_expr (arg1, new_expr); + return true; + case GFC_ISYM_SIZE: if (!sym->as || sym->as->rank == 0) return false; @@ -5441,8 +5451,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp, e, - GFC_CAF_COARRAY_NOCOARRAY); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + e, + GFC_CAF_COARRAY_NOCOARRAY); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) @@ -6484,10 +6498,18 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, builtin_decl_explicit (BUILT_IN_MEMMOVE), 3, dest, src, slen); + /* Wstringop-overflow appears at -O3 even though this warning is not + explicitly available in fortran nor can it be switched off. If the + source length is a constant, its negative appears as a very large + postive number and triggers the warning in BUILTIN_MEMSET. Fixing + the result of the MINUS_EXPR suppresses this spurious warning. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE(dlen), dlen, slen); + if (slength && TREE_CONSTANT (slength)) + tmp = gfc_evaluate_now (tmp, block); + tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen); - tmp4 = fill_with_spaces (tmp4, chartype, - fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE(dlen), dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, tmp); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -9696,7 +9718,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool scalar_to_array; tree string_length; int n; - bool maybe_workshare = false; + bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false; symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; bool is_poly_assign; @@ -9736,8 +9758,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, mode. */ if (flag_coarray == GFC_FCOARRAY_LIB) { - lhs_caf_attr = gfc_caf_attr (expr1); - rhs_caf_attr = gfc_caf_attr (expr2); + lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp); + rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); } if (lss != gfc_ss_terminator) @@ -9937,10 +9959,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension - && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp) + && ((lhs_caf_attr.allocatable && lhs_refs_comp) + || (rhs_caf_attr.allocatable && rhs_refs_comp))) { + /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an + allocatable component, because those need to be accessed via the + caf-runtime. No need to check for coindexes here, because resolve + has rewritten those already. */ gfc_code code; gfc_actual_arglist a1, a2; + /* Clear the structures to prevent accessing garbage. */ + memset (&code, '\0', sizeof (gfc_code)); + memset (&a1, '\0', sizeof (gfc_actual_arglist)); + memset (&a2, '\0', sizeof (gfc_actual_arglist)); a1.expr = expr1; a1.next = &a2; a2.expr = expr2; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 253a5ac70a9..b60685ee157 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -2181,15 +2181,37 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) } if (ts->type == BT_DERIVED) - derived = ts->u.derived; - else - derived = ts->u.derived->components->ts.u.derived; + { + derived = ts->u.derived; + *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, + formatted); + + if (*dtio_sub) + return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); + } + else if (ts->type == BT_CLASS) + { + gfc_symtree *tb_io_st; - *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, - formatted); + derived = ts->u.derived->components->ts.u.derived; + tb_io_st = gfc_find_typebound_dtio_proc (derived, + last_dt == WRITE, formatted); + if (tb_io_st) + { + gfc_se se; + gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1); + gfc_add_vptr_component (expr); + gfc_add_component_ref (expr, + tb_io_st->n.tb->u.generic->specific_st->name); + *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym; + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gfc_free_expr (expr); + return se.expr; + } + } - if (*dtio_sub) - return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); return NULL_TREE; diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d460048d20d..6bc2dcdbaeb 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -420,8 +420,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) { - tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL, - GFC_CAF_COARRAY_NOCOARRAY); + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, + GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); } else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) @@ -810,10 +813,13 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) { gfc_init_block (&cond_block); if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_add_expr_to_block (&cond_block, - gfc_trans_dealloc_allocated (unshare_expr (dest), - NULL, - GFC_CAF_COARRAY_NOCOARRAY)); + { + tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + gfc_add_expr_to_block (&cond_block, tmp); + } else { destptr = gfc_evaluate_now (destptr, &cond_block); @@ -987,9 +993,14 @@ gfc_omp_clause_dtor (tree clause, tree decl) } if (GFC_DESCRIPTOR_TYPE_P (type)) - /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need - to be deallocated if they were allocated. */ - tem = gfc_trans_dealloc_allocated (decl, NULL, GFC_CAF_COARRAY_NOCOARRAY); + { + /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need + to be deallocated if they were allocated. */ + tem = gfc_conv_descriptor_data_get (decl); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + } else tem = gfc_call_free (decl); tem = gfc_omp_unshare_expr (tem); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 514db287478..d9e185f2927 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5506,7 +5506,7 @@ gfc_trans_allocate (gfc_code * code) stmtblock_t block; stmtblock_t post; tree nelems; - bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; + bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray ; gfc_symtree *newsym = NULL; if (!code->ext.alloc.list) @@ -5516,6 +5516,7 @@ gfc_trans_allocate (gfc_code * code) expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; label_errmsg = label_finish = errmsg = errlen = NULL_TREE; e3_is = E3_UNSET; + is_coarray = false; gfc_init_block (&block); gfc_init_block (&post); @@ -5555,8 +5556,9 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false, temp_var_needed = false, - is_coarray = gfc_is_coarray (code->expr3); + bool vtab_needed = false, temp_var_needed = false; + + is_coarray = gfc_is_coarray (code->expr3); /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; @@ -6093,6 +6095,9 @@ gfc_trans_allocate (gfc_code * code) tree caf_decl, token; gfc_se caf_se; + /* Set flag, to add synchronize after the allocate. */ + is_coarray = true; + gfc_init_se (&caf_se, NULL); caf_decl = gfc_get_tree_for_caf_expr (expr); @@ -6114,6 +6119,11 @@ gfc_trans_allocate (gfc_code * code) } else { + /* Allocating coarrays needs a sync after the allocate executed. + Set the flag to add the sync after all objects are allocated. */ + is_coarray = is_coarray || (gfc_caf_attr (expr).codimension + && flag_coarray == GFC_FCOARRAY_LIB); + if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE && expr3_len != NULL_TREE) { @@ -6357,6 +6367,15 @@ gfc_trans_allocate (gfc_code * code) gfc_add_modify (&block, se.expr, tmp); } + if (is_coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + /* Add a sync all after the allocation has been executed. */ + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&post, tmp); + } + gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &post); @@ -6464,7 +6483,8 @@ gfc_trans_deallocate (gfc_code *code) && !(!last && expr->symtree->n.sym->attr.pointer)) { if (is_coarray && expr->rank == 0 - && (!last || !last->u.c.component->attr.dimension)) + && (!last || !last->u.c.component->attr.dimension) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) { /* Add the ref to the data member only, when this is not a regular array or deallocate_alloc_comp will try to @@ -6489,8 +6509,9 @@ gfc_trans_deallocate (gfc_code *code) : GFC_CAF_COARRAY_DEREGISTER; else caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; - tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen, - label_finish, expr, caf_dtype); + tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, + label_finish, false, expr, + caf_dtype); gfc_add_expr_to_block (&se.pre, tmp); } else if (TREE_CODE (se.expr) == COMPONENT_REF diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6a1d4819ca6..e5dd98695fe 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1281,31 +1281,58 @@ tree gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, tree label_finish, bool can_fail, gfc_expr* expr, - int coarray_dealloc_mode) + int coarray_dealloc_mode, tree add_when_allocated, + tree caf_token) { stmtblock_t null, non_null; tree cond, tmp, error; tree status_type = NULL_TREE; - tree caf_decl = NULL_TREE; + tree token = NULL_TREE; gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))); - caf_decl = pointer; - pointer = gfc_conv_descriptor_data_get (caf_decl); - STRIP_NOPS (pointer); - if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + if (flag_coarray == GFC_FCOARRAY_LIB) { - bool comp_ref; - if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp - && comp_ref) - caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; - // else do a deregister as set by default. + if (caf_token) + token = caf_token; + else + { + tree caf_type, caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + caf_type = TREE_TYPE (caf_decl); + STRIP_NOPS (pointer); + if (GFC_DESCRIPTOR_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) + token = gfc_conv_descriptor_token (caf_decl); + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) + token = GFC_DECL_TOKEN (caf_decl); + else + { + gcc_assert (GFC_ARRAY_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) + != NULL_TREE); + token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); + } + } + + if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + { + bool comp_ref; + if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + // else do a deregister as set by default. + } + else + caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; } - else - caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + pointer = gfc_conv_descriptor_data_get (pointer); } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1348,6 +1375,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); + if (add_when_allocated) + gfc_add_expr_to_block (&non_null, add_when_allocated); gfc_add_finalizer_call (&non_null, expr); if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY || flag_coarray != GFC_FCOARRAY_LIB) @@ -1356,6 +1385,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); gfc_add_expr_to_block (&non_null, tmp); + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); if (status != NULL_TREE && !integer_zerop (status)) { @@ -1378,8 +1409,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, } else { - tree caf_type, token, cond2; - tree pstat = null_pointer_node; + tree cond2, pstat = null_pointer_node; if (errmsg == NULL_TREE) { @@ -1394,27 +1424,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); } - caf_type = TREE_TYPE (caf_decl); - if (status != NULL_TREE && !integer_zerop (status)) { gcc_assert (status_type == integer_type_node); pstat = status; } - if (GFC_DESCRIPTOR_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) - token = gfc_conv_descriptor_token (caf_decl); - else if (DECL_LANG_SPECIFIC (caf_decl) - && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) - token = GFC_DECL_TOKEN (caf_decl); - else - { - gcc_assert (GFC_ARRAY_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); - token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); - } - token = gfc_build_addr_expr (NULL_TREE, token); gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); tmp = build_call_expr_loc (input_location, @@ -1435,6 +1450,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, if (status != NULL_TREE) { tree stat = build_fold_indirect_ref_loc (input_location, status); + tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), + 0)); TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); @@ -1442,9 +1461,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, stat, build_zero_cst (TREE_TYPE (stat))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), - tmp, build_empty_stmt (input_location)); + tmp, nullify); gfc_add_expr_to_block (&non_null, tmp); } + else + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); } return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, @@ -1516,11 +1538,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, finalizable = gfc_add_finalizer_call (&non_null, expr); if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { - if (coarray) + int caf_mode = coarray + ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) + | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + : 0; + if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) tmp = gfc_conv_descriptor_data_get (pointer); else tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); gfc_add_expr_to_block (&non_null, tmp); } @@ -1573,7 +1601,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); tmp = build5_loc (input_location, ASM_EXPR, void_type_node, gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ae1f15651ef..bfc2a24d0fa 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -719,7 +719,8 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); /* Generate code to deallocate an array. */ tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, - gfc_expr *, int); + gfc_expr *, int, tree a = NULL_TREE, + tree c = NULL_TREE); tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, gfc_typespec, bool c = false); |