diff options
author | Ian Lance Taylor <iant@golang.org> | 2021-10-07 15:28:36 -0700 |
---|---|---|
committer | Ian Lance Taylor <iant@golang.org> | 2021-10-07 15:28:36 -0700 |
commit | 0b6b70a0733672600644c8df96942cda5bf86d3d (patch) | |
tree | 9a1fbd7f782c54df55ab225ed1be057e3f3b0b8a /gcc/fortran | |
parent | a5b5cabc91c38710adbe5c8a2b53882abe994441 (diff) | |
parent | fba228e259dd5112851527f2dbb62c5601100985 (diff) | |
download | gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.zip gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.tar.gz gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.tar.bz2 |
Merge from trunk revision fba228e259dd5112851527f2dbb62c5601100985.
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 183 | ||||
-rw-r--r-- | gcc/fortran/array.c | 5 | ||||
-rw-r--r-- | gcc/fortran/check.c | 4 | ||||
-rw-r--r-- | gcc/fortran/cpp.c | 9 | ||||
-rw-r--r-- | gcc/fortran/cpp.h | 2 | ||||
-rw-r--r-- | gcc/fortran/decl.c | 14 | ||||
-rw-r--r-- | gcc/fortran/dump-parse-tree.c | 2 | ||||
-rw-r--r-- | gcc/fortran/expr.c | 32 | ||||
-rw-r--r-- | gcc/fortran/f95-lang.c | 4 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 8 | ||||
-rw-r--r-- | gcc/fortran/interface.c | 39 | ||||
-rw-r--r-- | gcc/fortran/openmp.c | 5 | ||||
-rw-r--r-- | gcc/fortran/options.c | 19 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 13 | ||||
-rw-r--r-- | gcc/fortran/scanner.c | 87 | ||||
-rw-r--r-- | gcc/fortran/simplify.c | 5 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 166 | ||||
-rw-r--r-- | gcc/fortran/trans-array.h | 2 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 14 | ||||
-rw-r--r-- | gcc/fortran/trans-expr.c | 77 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 246 | ||||
-rw-r--r-- | gcc/fortran/trans-openmp.c | 7 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 7 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 6 |
24 files changed, 705 insertions, 251 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 08e7d4c..b296797 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,186 @@ +2021-10-06 Tobias Burnus <tobias@codesourcery.com> + + * resolve.c (resolve_values): Only show + deprecated warning if attr.referenced. + +2021-10-04 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/54753 + * resolve.c (can_generate_init, resolve_fl_variable_derived, + resolve_symbol): Only do initialization with intent(out) if not + inside of an interface block. + +2021-10-01 Martin Sebor <msebor@redhat.com> + + PR c/102103 + * array.c: Remove an unnecessary test. + * trans-array.c: Same. + +2021-10-01 Jakub Jelinek <jakub@redhat.com> + + * gfortran.h (gfc_omp_clauses): Add order_reproducible bitfield. + * dump-parse-tree.c (show_omp_clauses): Print REPRODUCIBLE: for it. + * openmp.c (gfc_match_omp_clauses): Set order_reproducible for + explicit reproducible: modifier. + * trans-openmp.c (gfc_trans_omp_clauses): Set + OMP_CLAUSE_ORDER_REPRODUCIBLE for order_reproducible. + (gfc_split_omp_clauses): Also copy order_reproducible. + +2021-09-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102458 + * simplify.c (simplify_size): Resolve expressions used in array + specifications so that SIZE can be simplified. + +2021-09-30 Harald Anlauf <anlauf@gmx.de> + + * expr.c: The correct reference to Fortran standard is: F2018:10.1.12. + +2021-09-30 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/71703 + PR fortran/84007 + * trans-intrinsic.c (gfc_conv_same_type_as): Fix handling + of UNLIMITED_POLY. + * trans.h (gfc_vtpr_hash_get): Renamed prototype to ... + (gfc_vptr_hash_get): ... this to match function name. + +2021-09-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102520 + * array.c (expand_constructor): Do not dereference NULL pointer. + +2021-09-27 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/94070 + * trans-array.c (gfc_tree_array_size): New function to + find size inline (whole array or one dimension). + (array_parameter_size): Use it, take stmt_block as arg. + (gfc_conv_array_parameter): Update call. + * trans-array.h (gfc_tree_array_size): Add prototype. + * trans-decl.c (gfor_fndecl_size0, gfor_fndecl_size1): Remove + these global vars. + (gfc_build_intrinsic_function_decls): Remove their initialization. + * trans-expr.c (gfc_conv_procedure_call): Update + bounds of pointer/allocatable actual args to nonallocatable/nonpointer + dummies to be one based. + * trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for + assumed rank with allocatable/pointer dummy. + (gfc_conv_intrinsic_size): Update to use inline function. + * trans.h (gfor_fndecl_size0, gfor_fndecl_size1): Remove var decl. + +2021-09-26 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/101334 + * trans-intrinsic.c (gfc_conv_associated): Support assumed-rank + 'pointer' with scalar/array 'target' argument. + +2021-09-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102458 + * expr.c (is_non_constant_intrinsic): Check for intrinsics + excluded in constant expressions (F2018:10.1.2). + (gfc_is_constant_expr): Use that check. + +2021-09-24 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/101333 + * interface.c (compare_parameter): Enforce F2018 C711. + +2021-09-24 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/55534 + * scanner.c (load_file): Return void, call (gfc_)fatal_error for + all errors. + (include_line, include_stmt, gfc_new_file): Remove exit call + for failed load_file run. + +2021-09-23 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/101320 + * decl.c (gfc_verify_c_interop_param): Handle F2018 C1557, + aka TS29113 C516. + +2021-09-23 Harald Anlauf <anlauf@gmx.de> + Tobias Burnus <tobias@codesourcery.com> + + PR fortran/93834 + * trans-intrinsic.c (gfc_conv_allocated): Cleanup. Handle + coindexed scalar coarrays. + +2021-09-23 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/101319 + * interface.c (gfc_compare_actual_formal): Extend existing + assumed-type diagnostic to also check for argument with type + parameters. + +2021-09-23 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/101334 + * check.c (gfc_check_associated): Allow an assumed-rank + array for the pointer argument. + * interface.c (compare_parameter): Also give rank mismatch + error on assumed-rank array. + +2021-09-23 Sandra Loosemore <sandra@codesourcery.com> + + * trans-stmt.c (trans_associate_var): Check that result of + GFC_DECL_SAVED_DESCRIPTOR is not null before using it. + +2021-09-22 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/55534 + * cpp.c (gfc_cpp_register_include_paths, gfc_cpp_post_options): + Add new bool verbose_missing_dir_warn argument. + * cpp.h (gfc_cpp_post_options): Update prototype. + * f95-lang.c (gfc_init): Remove duplicated file-not found diag. + * gfortran.h (gfc_check_include_dirs): Takes bool + verbose_missing_dir_warn arg. + (gfc_new_file): Returns now void. + * options.c (gfc_post_options): Update to warn for -I and -J, + only, by default but for all when user requested. + * scanner.c (gfc_do_check_include_dir): + (gfc_do_check_include_dirs, gfc_check_include_dirs): Take bool + verbose warn arg and update to avoid printing the same message + twice or never. + (load_file): Fix indent. + (gfc_new_file): Return void and exit when load_file failed + as all other load_file users do. + +2021-09-22 Tobias Burnus <tobias@codesourcery.com> + + * trans-expr.c (gfc_simple_for_loop): New. + * trans.h (gfc_simple_for_loop): New prototype. + +2021-09-21 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/55534 + * cpp.c: Define GCC_C_COMMON_C for #include "options.h" to make + cpp_reason_option_codes available. + (gfc_cpp_register_include_paths): Make static, set pfile's + warn_missing_include_dirs and move before caller. + (gfc_cpp_init_cb): New, cb code moved from ... + (gfc_cpp_init_0): ... here. + (gfc_cpp_post_options): Call gfc_cpp_init_cb. + (cb_cpp_diagnostic_cpp_option): New. As implemented in c-family + to match CppReason flags to -W... names. + (cb_cpp_diagnostic): Use it to replace single special case. + * cpp.h (gfc_cpp_register_include_paths): Remove as now static. + * gfortran.h (gfc_check_include_dirs): New prototype. + (gfc_add_include_path): Add new bool arg. + * options.c (gfc_init_options): Don't set -Wmissing-include-dirs. + (gfc_post_options): Set it here after commandline processing. Call + gfc_add_include_path with defer_warn=false. + (gfc_handle_option): Call it with defer_warn=true. + * scanner.c (gfc_do_check_include_dir, gfc_do_check_include_dirs, + gfc_check_include_dirs): New. Diagnostic moved from ... + (add_path_to_list): ... here, which came before cmdline processing. + Take additional bool defer_warn argument. + (gfc_add_include_path): Take additional defer_warn arg. + * scanner.h (struct gfc_directorylist): Reorder for alignment issues, + add new 'bool warn'. + 2021-09-20 Tobias Burnus <tobias@codesourcery.com> * gfortran.h (gfc_omp_clauses): Add order_unconstrained. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b858bad..6552eaf 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1798,6 +1798,9 @@ expand_constructor (gfc_constructor_base base) e = c->expr; + if (e == NULL) + return false; + if (empty_constructor) empty_ts = e->ts; @@ -2578,7 +2581,7 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) } } - if (array->shape && array->shape[dimen]) + if (array->shape) { mpz_init_set (*result, array->shape[dimen]); return true; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 851af1b..f31ad68 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1520,7 +1520,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) t = true; if (!same_type_check (pointer, 0, target, 1, true)) t = false; - if (!rank_check (target, 0, pointer->rank)) + /* F2018 C838 explicitly allows an assumed-rank variable as the first + argument of intrinsic inquiry functions. */ + if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) t = false; if (target->rank > 0) { diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index 3ff8954..e86386c 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -245,11 +245,12 @@ gfc_cpp_temporary_file (void) } static void -gfc_cpp_register_include_paths (void) +gfc_cpp_register_include_paths (bool verbose_missing_dir_warn) { int cxx_stdinc = 0; cpp_get_options (cpp_in)->warn_missing_include_dirs - = global_options.x_cpp_warn_missing_include_dirs; + = (global_options.x_cpp_warn_missing_include_dirs + && verbose_missing_dir_warn); register_include_chains (cpp_in, gfc_cpp_option.sysroot, gfc_cpp_option.prefix, gfc_cpp_option.multilib, gfc_cpp_option.standard_include_paths, cxx_stdinc, @@ -484,7 +485,7 @@ gfc_cpp_init_cb (void) } void -gfc_cpp_post_options (void) +gfc_cpp_post_options (bool verbose_missing_dir_warn) { /* Any preprocessing-related option without '-cpp' is considered an error. */ @@ -547,7 +548,7 @@ gfc_cpp_post_options (void) diagnostic_initialize_input_context (global_dc, nullptr, true); gfc_cpp_init_cb (); - gfc_cpp_register_include_paths (); + gfc_cpp_register_include_paths (verbose_missing_dir_warn); } diff --git a/gcc/fortran/cpp.h b/gcc/fortran/cpp.h index 5cb7e5a..44644a2 100644 --- a/gcc/fortran/cpp.h +++ b/gcc/fortran/cpp.h @@ -41,7 +41,7 @@ void gfc_cpp_init_options (unsigned int decoded_options_count, int gfc_cpp_handle_option(size_t scode, const char *arg, int value); -void gfc_cpp_post_options (void); +void gfc_cpp_post_options (bool); bool gfc_cpp_preprocess (const char *source_file); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index f2e8896..b3c65b7 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1557,6 +1557,20 @@ gfc_verify_c_interop_param (gfc_symbol *sym) "CONTIGUOUS attribute as procedure %qs is BIND(C)", sym->name, &sym->declared_at, sym->ns->proc_name->name); + /* Per F2018, C1557, pointer/allocatable dummies to a bind(c) + procedure that are default-initialized are not permitted. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && sym->ts.type == BT_DERIVED + && gfc_has_default_initializer (sym->ts.u.derived)) + { + gfc_error ("Default-initialized %s dummy argument %qs " + "at %L is not permitted in BIND(C) procedure %qs", + (sym->attr.pointer ? "pointer" : "allocatable"), + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + /* Character strings are only C interoperable if they have a length of 1. However, as an argument they are also iteroperable when passed as descriptor (which requires len=: or len=*). */ diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 28eb09e..64e04c0 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1634,6 +1634,8 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" ORDER(", dumpfile); if (omp_clauses->order_unconstrained) fputs ("UNCONSTRAINED:", dumpfile); + else if (omp_clauses->order_reproducible) + fputs ("REPRODUCIBLE:", dumpfile); fputs ("CONCURRENT)", dumpfile); } if (omp_clauses->ordered) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 604e63e..6c38935 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -990,6 +990,34 @@ done: } +/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in + constant expressions, except TRANSFER (c.f. item (8)), which would need + separate treatment. */ + +static bool +is_non_constant_intrinsic (gfc_expr *e) +{ + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym) + { + switch (e->value.function.isym->id) + { + case GFC_ISYM_COMMAND_ARGUMENT_COUNT: + case GFC_ISYM_GET_TEAM: + case GFC_ISYM_NULL: + case GFC_ISYM_NUM_IMAGES: + case GFC_ISYM_TEAM_NUMBER: + case GFC_ISYM_THIS_IMAGE: + return true; + + default: + return false; + } + } + return false; +} + + /* Determine if an expression is constant in the sense of F08:7.1.12. * This function expects that the expression has already been simplified. */ @@ -1023,6 +1051,10 @@ gfc_is_constant_expr (gfc_expr *e) gcc_assert (e->symtree || e->value.function.esym || e->value.function.isym); + /* Check for intrinsics excluded in constant expressions. */ + if (e->value.function.isym && is_non_constant_intrinsic (e)) + return false; + /* Call to intrinsic with at least one argument. */ if (e->value.function.isym && e->value.function.actual) { diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 026228d..58dcaf0 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -259,8 +259,8 @@ gfc_init (void) gfc_init_1 (); - if (!gfc_new_file ()) - fatal_error (input_location, "cannot open input file: %s", gfc_source_file); + /* Calls exit in case of a fail. */ + gfc_new_file (); if (flag_preprocess_only) return false; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3c7a843..c25d1cc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1491,8 +1491,8 @@ typedef struct gfc_omp_clauses unsigned inbranch:1, notinbranch:1, nogroup:1; unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1; unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1; - unsigned order_unconstrained:1, capture:1, grainsize_strict:1; - unsigned num_tasks_strict:1; + unsigned order_unconstrained:1, order_reproducible:1, capture:1; + unsigned grainsize_strict:1, num_tasks_strict:1; ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; ENUM_BITFIELD (gfc_omp_device_type) device_type:2; ENUM_BITFIELD (gfc_omp_memorder) memorder:3; @@ -3032,7 +3032,7 @@ void gfc_scanner_init_1 (void); void gfc_add_include_path (const char *, bool, bool, bool, bool); void gfc_add_intrinsic_modules_path (const char *); void gfc_release_include_path (void); -void gfc_check_include_dirs (void); +void gfc_check_include_dirs (bool); FILE *gfc_open_included_file (const char *, bool, bool); int gfc_at_end (void); @@ -3064,7 +3064,7 @@ gfc_char_t gfc_peek_char (void); char gfc_peek_ascii_char (void); void gfc_error_recovery (void); void gfc_gobble_whitespace (void); -bool gfc_new_file (void); +void gfc_new_file (void); const char * gfc_read_orig_filename (const char *, const char **); extern gfc_source_form gfc_current_form; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9e3e8aa..a2fea0e 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2448,6 +2448,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return false; } + /* TS29113 C407c; F2018 C711. */ + if (actual->ts.type == BT_ASSUMED + && symbol_rank (formal) == -1 + && actual->rank != -1 + && !(actual->symtree->n.sym->as + && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)) + { + if (where) + gfc_error ("Assumed-type actual argument at %L corresponding to " + "assumed-rank dummy argument %qs must be " + "assumed-shape or assumed-rank", + &actual->where, formal->name); + return false; + } + /* F2008, 12.5.2.5; IR F08/0073. */ if (formal->ts.type == BT_CLASS && formal->attr.class_ok && actual->expr_type != EXPR_NULL @@ -2634,7 +2649,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && formal->as->type == AS_ASSUMED_SHAPE)) && actual->expr_type != EXPR_NULL) || (actual->rank == 0 && formal->attr.dimension - && gfc_is_coindexed (actual))) + && gfc_is_coindexed (actual)) + /* Assumed-rank actual argument; F2018 C838. */ + || actual->rank == -1) { if (where && (!formal->attr.artificial || (!formal->maybe_array @@ -3181,21 +3198,21 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, is_elemental, where)) return false; - /* TS 29113, 6.3p2. */ + /* TS 29113, 6.3p2; F2018 15.5.2.4. */ if (f->sym->ts.type == BT_ASSUMED && (a->expr->ts.type == BT_DERIVED || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) { - gfc_namespace *f2k_derived; - - f2k_derived = a->expr->ts.type == BT_DERIVED - ? a->expr->ts.u.derived->f2k_derived - : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived; - - if (f2k_derived - && (f2k_derived->finalizers || f2k_derived->tb_sym_root)) + gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED + ? a->expr->ts.u.derived + : CLASS_DATA (a->expr)->ts.u.derived); + gfc_namespace *f2k_derived = derived->f2k_derived; + if (derived->attr.pdt_type + || (f2k_derived + && (f2k_derived->finalizers || f2k_derived->tb_sym_root))) { - gfc_error ("Actual argument at %L to assumed-type dummy is of " + gfc_error ("Actual argument at %L to assumed-type dummy " + "has type parameters or is of " "derived type with type-bound or FINAL procedures", &a->expr->where); return false; diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 9ee52d6..6a4ca28 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -2374,8 +2374,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (m == MATCH_ERROR) goto error; - if (gfc_match (" reproducible : concurrent )") == MATCH_YES - || gfc_match (" concurrent )") == MATCH_YES) + if (gfc_match (" reproducible : concurrent )") == MATCH_YES) + c->order_reproducible = true; + else if (gfc_match (" concurrent )") == MATCH_YES) ; else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES) c->order_unconstrained = true; diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index d789397..016b704 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -251,14 +251,20 @@ gfc_post_options (const char **pfilename) { const char *filename = *pfilename, *canon_source_file = NULL; char *source_path; + bool verbose_missing_dir_warn; int i; /* This needs to be after the commandline has been processed. In Fortran, the options is by default enabled, in C/C++ - by default disabled. */ + by default disabled. + If not enabled explicitly by the user, only warn for -I + and -J, otherwise warn for all include paths. */ + verbose_missing_dir_warn + = (global_options_set.x_cpp_warn_missing_include_dirs + && global_options.x_cpp_warn_missing_include_dirs); SET_OPTION_IF_UNSET (&global_options, &global_options_set, cpp_warn_missing_include_dirs, 1); - gfc_check_include_dirs (); + gfc_check_include_dirs (verbose_missing_dir_warn); /* Finalize DEC flags. */ post_dec_flags (flag_dec); @@ -339,10 +345,13 @@ gfc_post_options (const char **pfilename) source_path = (char *) alloca (i + 1); memcpy (source_path, canon_source_file, i); source_path[i] = 0; - gfc_add_include_path (source_path, true, true, true, false); + /* Only warn if the directory is different from the input file as + if that one is not found, already an error is shown. */ + bool warn = gfc_option.flag_preprocessed && gfc_source_file != filename; + gfc_add_include_path (source_path, true, true, warn, false); } else - gfc_add_include_path (".", true, true, true, false); + gfc_add_include_path (".", true, true, false, false); if (canon_source_file != gfc_source_file) free (CONST_CAST (char *, canon_source_file)); @@ -490,7 +499,7 @@ gfc_post_options (const char **pfilename) gfc_fatal_error ("Maximum subrecord length cannot exceed %d", MAX_SUBRECORD_LENGTH); - gfc_cpp_post_options (); + gfc_cpp_post_options (verbose_missing_dir_warn); if (gfc_option.allow_std & GFC_STD_F2008) lang_hooks.name = "GNU Fortran2008"; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 30b96b2..0d0af39 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12351,7 +12351,7 @@ resolve_values (gfc_symbol *sym) if (sym->value == NULL) return; - if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED)) + if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced) gfc_warning (OPT_Wdeprecated_declarations, "Using parameter %qs declared at %L is deprecated", sym->name, &sym->declared_at); @@ -12676,7 +12676,8 @@ can_generate_init (gfc_symbol *sym) || a->cray_pointer || sym->assoc || (!a->referenced && !a->result) - || (a->dummy && a->intent != INTENT_OUT) + || (a->dummy && (a->intent != INTENT_OUT + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)) || (a->function && sym != sym->result) ); } @@ -12913,7 +12914,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) - && (!no_init_flag || sym->attr.intent == INTENT_OUT)) + && (!no_init_flag + || (sym->attr.intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))) sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); return true; @@ -16154,7 +16157,8 @@ resolve_symbol (gfc_symbol *sym) || sym->ts.u.derived->attr.alloc_comp || sym->ts.u.derived->attr.pointer_comp)) && !(a->function && sym != sym->result)) - || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) + || (a->dummy && !a->pointer && a->intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) apply_default_init (sym); else if (a->function && sym->result && a->access != ACCESS_PRIVATE && (sym->ts.u.derived->attr.alloc_comp @@ -16166,6 +16170,7 @@ resolve_symbol (gfc_symbol *sym) if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns && sym->attr.dummy && sym->attr.intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY && !CLASS_DATA (sym)->attr.class_pointer && !CLASS_DATA (sym)->attr.allocatable) apply_default_init (sym); diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 6fe74bd..5a45069 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -47,6 +47,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" /* For set_src_pwd. */ #include "debug.h" #include "options.h" +#include "diagnostic-core.h" /* For fatal_error. */ #include "cpp.h" #include "scanner.h" @@ -307,9 +308,9 @@ gfc_do_check_include_dir (const char *path, bool warn) if (errno != ENOENT) gfc_warning_now (0, "Include directory %qs: %s", path, xstrerror(errno)); - else if (warn && !gfc_cpp_enabled ()) + else if (warn) gfc_warning_now (OPT_Wmissing_include_dirs, - "Nonexistent include directory %qs", path); + "Nonexistent include directory %qs", path); return false; } else if (!S_ISDIR (st.st_mode)) @@ -323,7 +324,7 @@ gfc_do_check_include_dir (const char *path, bool warn) /* In order that -W(no-)missing-include-dirs works, the diagnostic can only be run after processing the commandline. */ static void -gfc_do_check_include_dirs (gfc_directorylist **list) +gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn) { gfc_directorylist *prev, *q, *n; prev = NULL; @@ -331,7 +332,7 @@ gfc_do_check_include_dirs (gfc_directorylist **list) while (n) { q = n; n = n->next; - if (gfc_do_check_include_dir (q->path, q->warn)) + if (gfc_do_check_include_dir (q->path, q->warn && do_warn)) { prev = q; continue; @@ -346,10 +347,16 @@ gfc_do_check_include_dirs (gfc_directorylist **list) } void -gfc_check_include_dirs () +gfc_check_include_dirs (bool verbose_missing_dir_warn) { - gfc_do_check_include_dirs (&include_dirs); - gfc_do_check_include_dirs (&intrinsic_modules_dirs); + /* This is a bit convoluted: If gfc_cpp_enabled () and + verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise, + it is shown here, still conditional on OPT_Wmissing_include_dirs. */ + bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn; + gfc_do_check_include_dirs (&include_dirs, warn); + gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn); + if (gfc_option.module_dir && gfc_cpp_enabled ()) + gfc_do_check_include_dirs (&include_dirs, true); } /* Adds path to the list pointed to by list. */ @@ -2224,7 +2231,7 @@ preprocessor_line (gfc_char_t *c) } -static bool load_file (const char *, const char *, bool); +static void load_file (const char *, const char *, bool); /* include_line()-- Checks a line buffer to see if it is an include line. If so, we call load_file() recursively to load the included @@ -2390,9 +2397,7 @@ include_line (gfc_char_t *line) read by anything else. */ filename = gfc_widechar_to_char (begin, -1); - if (!load_file (filename, NULL, false)) - exit (FATAL_EXIT_CODE); - + load_file (filename, NULL, false); free (filename); return 1; } @@ -2499,9 +2504,7 @@ include_stmt (gfc_linebuf *b) filename[i] = (unsigned char) c; } filename[length] = '\0'; - if (!load_file (filename, NULL, false)) - exit (FATAL_EXIT_CODE); - + load_file (filename, NULL, false); free (filename); do_ret: @@ -2519,9 +2522,11 @@ do_ret: return ret; } + + /* Load a file into memory by calling load_line until the file ends. */ -static bool +static void load_file (const char *realfilename, const char *displayedname, bool initial) { gfc_char_t *line; @@ -2543,13 +2548,8 @@ load_file (const char *realfilename, const char *displayedname, bool initial) for (f = current_file; f; f = f->up) if (filename_cmp (filename, f->filename) == 0) - { - fprintf (stderr, "%s:%d: Error: File '%s' is being included " - "recursively\n", current_file->filename, current_file->line, - filename); - return false; - } - + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "File %qs is being included recursively", filename); if (initial) { if (gfc_src_file) @@ -2561,10 +2561,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial) input = gfc_open_file (realfilename); if (input == NULL) - { - gfc_error_now ("Cannot open file %qs", filename); - return false; - } + gfc_fatal_error ("Cannot open file %qs", filename); } else { @@ -2573,22 +2570,20 @@ load_file (const char *realfilename, const char *displayedname, bool initial) { /* For -fpre-include file, current_file is NULL. */ if (current_file) - fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n", - current_file->filename, current_file->line, filename); + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "Cannot open included file %qs", filename); else - fprintf (stderr, "Error: Can't open pre-included file '%s'\n", - filename); - - return false; + gfc_fatal_error ("Cannot open pre-included file %qs", filename); } stat_result = stat (realfilename, &st); - if (stat_result == 0 && !S_ISREG(st.st_mode)) + if (stat_result == 0 && !S_ISREG (st.st_mode)) { - fprintf (stderr, "%s:%d: Error: Included path '%s'" - " is not a regular file\n", - current_file->filename, current_file->line, filename); fclose (input); - return false; + if (current_file) + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "Included file %qs is not a regular file", filename); + else + gfc_fatal_error ("Included file %qs is not a regular file", filename); } } @@ -2762,7 +2757,6 @@ load_file (const char *realfilename, const char *displayedname, bool initial) add_file_change (NULL, current_file->inclusion_line + 1); current_file = current_file->up; linemap_add (line_table, LC_LEAVE, 0, NULL, 0); - return true; } @@ -2771,23 +2765,20 @@ load_file (const char *realfilename, const char *displayedname, bool initial) it tries to determine the source form from the filename, defaulting to free form. */ -bool +void gfc_new_file (void) { - bool result; - - if (flag_pre_include != NULL - && !load_file (flag_pre_include, NULL, false)) - exit (FATAL_EXIT_CODE); + if (flag_pre_include != NULL) + load_file (flag_pre_include, NULL, false); if (gfc_cpp_enabled ()) { - result = gfc_cpp_preprocess (gfc_source_file); + gfc_cpp_preprocess (gfc_source_file); if (!gfc_cpp_preprocess_only ()) - result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true); + load_file (gfc_cpp_temporary_file (), gfc_source_file, true); } else - result = load_file (gfc_source_file, NULL, true); + load_file (gfc_source_file, NULL, true); gfc_current_locus.lb = line_head; gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line; @@ -2799,8 +2790,6 @@ gfc_new_file (void) exit (SUCCESS_EXIT_CODE); #endif - - return result; } static char * diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index b46cbfa..f40e493 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -7471,6 +7471,7 @@ simplify_size (gfc_expr *array, gfc_expr *dim, int k) mpz_t size; gfc_expr *return_value; int d; + gfc_ref *ref; /* For unary operations, the size of the result is given by the size of the operand. For binary ones, it's the size of the first operand @@ -7527,6 +7528,10 @@ simplify_size (gfc_expr *array, gfc_expr *dim, int k) return simplified; } + for (ref = array->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.as) + gfc_resolve_array_spec (ref->u.ar.as, 0); + if (dim == NULL) { if (!gfc_array_size (array, &size)) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0d013de..e2f59e0 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5104,7 +5104,6 @@ set_loop_bounds (gfc_loopinfo *loop) if (info->shape) { - gcc_assert (info->shape[dim]); /* The frontend has worked out the size for us. */ if (!loopspec[n] || !specinfo->shape @@ -7901,31 +7900,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_cleanup_loop (&loop); } + +/* Calculate the array size (number of elements); if dim != NULL_TREE, + return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ +tree +gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) +{ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + gcc_assert (dim == NULL_TREE); + return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); + } + tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; + symbol_attribute attr = gfc_expr_attr (expr); + gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + || !dim) + { + if (expr->rank < 0) + rank = fold_convert (signed_char_type_node, + gfc_conv_descriptor_rank (desc)); + else + rank = build_int_cst (signed_char_type_node, expr->rank); + } + + if (dim || expr->rank == 1) + { + if (!dim) + dim = gfc_index_zero_node; + tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); + tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + /* if (!allocatable && !pointer && assumed rank) + size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; + else + size = max (0, size); */ + size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + size, gfc_index_zero_node); + if (!attr.pointer && !attr.allocatable + && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + fold_convert (signed_char_type_node, dim), + tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, dim), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + tmp = build_int_cst (gfc_array_index_type, -1); + size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, tmp, size); + } + return size; + } + + /* size = 1. */ + size = gfc_create_var (gfc_array_index_type, "size"); + gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); + tree extent = gfc_create_var (gfc_array_index_type, "extent"); + + stmtblock_t cond_block, loop_body; + gfc_init_block (&cond_block); + gfc_init_block (&loop_body); + + /* Loop: for (i = 0; i < rank; ++i). */ + tree idx = gfc_create_var (signed_char_type_node, "idx"); + /* Loop body. */ + /* #if (assumed-rank + !allocatable && !pointer) + if (idx == rank - 1 && dim[idx].ubound == -1) + extent = -1; + else + #endif + extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 + if (extent < 0) + extent = 0 + size *= extent. */ + cond = NULL_TREE; + if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + idx, tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, idx), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + } + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, idx), + gfc_conv_descriptor_lbound_get (desc, idx)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_add_modify (&cond_block, extent, tmp); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, tmp, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, + extent, gfc_index_zero_node), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&cond_block, tmp); + tmp = gfc_finish_block (&cond_block); + if (cond) + tmp = build3_v (COND_EXPR, cond, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, extent, + build_int_cst (gfc_array_index_type, -1)), + tmp); + gfc_add_expr_to_block (&loop_body, tmp); + /* size *= extent. */ + gfc_add_modify (&loop_body, size, + fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, extent)); + /* Generate loop. */ + gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, + build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + return size; +} + /* Helper function for gfc_conv_array_parameter if array size needs to be computed. */ static void -array_parameter_size (tree desc, gfc_expr *expr, tree *size) +array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) { tree elem; - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - else if (expr->rank > 1) - *size = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, - gfc_build_addr_expr (NULL, desc)); - else - { - tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); - tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - - *size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *size, gfc_index_one_node); - *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - *size, gfc_index_zero_node); - } + *size = gfc_tree_array_size (block, desc, expr, NULL); elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, *size, fold_convert (gfc_array_index_type, elem)); @@ -8035,7 +8146,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, else se->expr = gfc_build_addr_expr (NULL_TREE, tmp); if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); return; } @@ -8047,7 +8158,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tmp = se->expr; } if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); se->expr = gfc_conv_array_data (tmp); return; } @@ -8122,7 +8233,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) se->string_length = expr->ts.u.cl->backend_decl; if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_conv_array_data (se->expr); return; } @@ -8132,7 +8243,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Result of the enclosing function. */ gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE @@ -8149,9 +8260,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); + array_parameter_size (&se->pre, + build_fold_indirect_ref_loc (input_location, + se->expr), + expr, size); } /* Deallocate the allocatable components of structures that are diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e4d443d..85ff216 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -39,6 +39,8 @@ 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 *); +tree gfc_tree_array_size (stmtblock_t *, tree, gfc_expr *, tree); + tree gfc_full_array_size (stmtblock_t *, tree, int); tree gfc_duplicate_allocatable (tree, tree, tree, int, tree); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3bd8a0f..c758d26 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -214,8 +214,6 @@ tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ -tree gfor_fndecl_size0; -tree gfor_fndecl_size1; tree gfor_fndecl_iargc; tree gfor_fndecl_kill; tree gfor_fndecl_kill_sub; @@ -3692,18 +3690,6 @@ gfc_build_intrinsic_function_decls (void) } /* Other functions. */ - gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("size0")), ". R ", - gfc_array_index_type, 1, pvoid_type_node); - DECL_PURE_P (gfor_fndecl_size0) = 1; - TREE_NOTHROW (gfor_fndecl_size0) = 1; - - gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("size1")), ". R . ", - gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type); - DECL_PURE_P (gfor_fndecl_size1) = 1; - TREE_NOTHROW (gfor_fndecl_size1) = 1; - gfor_fndecl_iargc = gfc_build_library_function_decl ( get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); TREE_NOTHROW (gfor_fndecl_iargc) = 1; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4a81f46..1c24556 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6450,6 +6450,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.force_tmp = 1; } + /* Special case for assumed-rank arrays: when passing an + argument to a nonallocatable/nonpointer dummy, the bounds have + to be reset as otherwise a last-dim ubound of -1 is + indistinguishable from an assumed-size array in the callee. */ + if (!sym->attr.is_bind_c && e && fsym && fsym->as + && fsym->as->type == AS_ASSUMED_RANK + && e->rank != -1 + && e->expr_type == EXPR_VARIABLE + && ((fsym->ts.type == BT_CLASS + && !CLASS_DATA (fsym)->attr.class_pointer + && !CLASS_DATA (fsym)->attr.allocatable) + || (fsym->ts.type != BT_CLASS + && !fsym->attr.pointer && !fsym->attr.allocatable))) + { + /* Change AR_FULL to a (:,:,:) ref to force bounds update. */ + gfc_ref *ref; + for (ref = e->ref; ref->next; ref = ref->next) + ; + if (ref->u.ar.type == AR_FULL + && ref->u.ar.as->type != AS_ASSUMED_SIZE) + ref->u.ar.type = AR_SECTION; + } + if (sym->attr.is_bind_c && e && (is_CFI_desc (fsym, NULL) || assumed_length_string)) /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ @@ -6510,16 +6533,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, sym->name, NULL); - /* Unallocated allocatable arrays and unassociated pointer arrays - need their dtype setting if they are argument associated with - assumed rank dummies, unless already assumed rank. */ + /* Special case for assumed-rank arrays. */ if (!sym->attr.is_bind_c && e && fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK && e->rank != -1) { - if (gfc_expr_attr (e).pointer + if ((gfc_expr_attr (e).pointer || gfc_expr_attr (e).allocatable) - set_dtype_for_unallocated (&parmse, e); + && ((fsym->ts.type == BT_CLASS + && (CLASS_DATA (fsym)->attr.class_pointer + || CLASS_DATA (fsym)->attr.allocatable)) + || (fsym->ts.type != BT_CLASS + && (fsym->attr.pointer || fsym->attr.allocatable)))) + { + /* Unallocated allocatable arrays and unassociated pointer + arrays need their dtype setting if they are argument + associated with assumed rank dummies. However, if the + dummy is nonallocate/nonpointer, the user may not + pass those. Hence, it can be skipped. */ + set_dtype_for_unallocated (&parmse, e); + } else if (e->expr_type == EXPR_VARIABLE && e->ref && e->ref->u.ar.type == AR_FULL @@ -11728,3 +11761,37 @@ gfc_trans_assign (gfc_code * code) { return gfc_trans_assignment (code->expr1, code->expr2, false, true); } + +/* Generate a simple loop for internal use of the form + for (var = begin; var <cond> end; var += step) + body; */ +void +gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end, + enum tree_code cond, tree step, tree body) +{ + tree tmp; + + /* var = begin. */ + gfc_add_modify (block, var, begin); + + /* Loop: for (var = begin; var <cond> end; var += step). */ + tree label_loop = gfc_build_label_decl (NULL_TREE); + tree label_cond = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_loop) = 1; + TREE_USED (label_cond) = 1; + + gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond)); + gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop)); + + /* Loop body. */ + gfc_add_expr_to_block (block, body); + + /* End of loop body. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step); + gfc_add_modify (block, var, tmp); + gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond)); + tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end); + tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); +} diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 42a995b..2a2829c 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -6697,6 +6697,8 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) gfc_expr *e; gfc_array_spec *as; gfc_ss *ss; + symbol_attribute attr; + tree result_desc = se->expr; /* Remove the KIND argument, if present. */ s = expr->value.function.actual; @@ -6707,17 +6709,25 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_funcall (se, expr); - as = gfc_get_full_arrayspec_from_expr (s->expr);; - ss = gfc_walk_expr (s->expr); - /* According to F2018 16.9.172, para 5, an assumed rank entity, argument associated with an assumed size array, has the ubound of the final dimension set to -1 and SHAPE must return this. */ - if (as && as->type == AS_ASSUMED_RANK - && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)) - && ss && ss->info->type == GFC_SS_SECTION) + + as = gfc_get_full_arrayspec_from_expr (s->expr); + if (!as || as->type != AS_ASSUMED_RANK) + return; + attr = gfc_expr_attr (s->expr); + ss = gfc_walk_expr (s->expr); + if (attr.pointer || attr.allocatable + || !ss || ss->info->type != GFC_SS_SECTION) + return; + if (se->expr) + result_desc = se->expr; + if (POINTER_TYPE_P (TREE_TYPE (result_desc))) + result_desc = build_fold_indirect_ref_loc (input_location, result_desc); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc))) { - tree desc, rank, minus_one, cond, ubound, tmp; + tree rank, minus_one, cond, ubound, tmp; stmtblock_t block; gfc_se ase; @@ -6745,8 +6755,7 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) /* Obtain the last element of the result from the library shape intrinsic and set it to -1 if that is the value of ubound. */ - desc = se->expr; - tmp = gfc_conv_array_data (desc); + tmp = gfc_conv_array_data (result_desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = gfc_build_array_ref (tmp, rank, NULL, NULL); @@ -6758,7 +6767,6 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, cond); } - } static void @@ -7968,8 +7976,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) gfc_actual_arglist *actual; tree arg1; tree type; - tree fncall0; - tree fncall1; + tree size; gfc_se argse; gfc_expr *e; gfc_symbol *sym = NULL; @@ -8046,37 +8053,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) /* For functions that return a class array conv_expr_descriptor is not able to get the descriptor right. Therefore this special case. */ gfc_conv_expr_reference (&argse, e); - argse.expr = gfc_build_addr_expr (NULL_TREE, - gfc_class_data_get (argse.expr)); + argse.expr = gfc_class_data_get (argse.expr); } else if (sym && sym->backend_decl) { gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl))); - argse.expr = sym->backend_decl; - argse.expr = gfc_build_addr_expr (NULL_TREE, - gfc_class_data_get (argse.expr)); + argse.expr = gfc_class_data_get (sym->backend_decl); } else - { - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); - } + gfc_conv_expr_descriptor (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - arg1 = gfc_evaluate_now (argse.expr, &se->pre); - - /* Build the call to size0. */ - fncall0 = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, arg1); + arg1 = argse.expr; actual = actual->next; - if (actual->expr) { + stmtblock_t block; + gfc_init_block (&block); gfc_init_se (&argse, NULL); gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&block, &argse.pre); + tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + size = gfc_tree_array_size (&block, arg1, e, tmp); /* Unusually, for an intrinsic, size does not exclude an optional arg2, so we must test for it. */ @@ -8084,59 +8085,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) && actual->expr->symtree->n.sym->attr.dummy && actual->expr->symtree->n.sym->attr.optional) { - tree tmp; - /* Build the call to size1. */ - fncall1 = build_call_expr_loc (input_location, - gfor_fndecl_size1, 2, - arg1, argse.expr); - + tree cond; + stmtblock_t block2; + gfc_init_block (&block2); gfc_init_se (&argse, NULL); argse.want_pointer = 1; argse.data_not_needed = 1; gfc_conv_expr (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - argse.expr, null_pointer_node); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = fold_build3_loc (input_location, COND_EXPR, - pvoid_type_node, tmp, fncall1, fncall0); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + argse.expr, null_pointer_node); + cond = gfc_evaluate_now (cond, &se->pre); + /* 'block2' contains the arg2 absent case, 'block' the arg2 present + case; size_var can be used in both blocks. */ + tree size_var = gfc_tree_array_size (&block2, arg1, e, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (size_var), size_var, size); + gfc_add_expr_to_block (&block, tmp); + tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block), + gfc_finish_block (&block2)); + gfc_add_expr_to_block (&se->pre, tmp); + size = size_var; } else - { - se->expr = NULL_TREE; - argse.expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - argse.expr, gfc_index_one_node); - } - } - else if (expr->value.function.actual->expr->rank == 1) - { - argse.expr = gfc_index_zero_node; - se->expr = NULL_TREE; + gfc_add_block_to_block (&se->pre, &block); } else - se->expr = fncall0; - - if (se->expr == NULL_TREE) - { - tree ubound, lbound; - - arg1 = build_fold_indirect_ref_loc (input_location, - arg1); - ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); - lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); - se->expr = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - se->expr = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - se->expr, gfc_index_one_node); - se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, se->expr, - gfc_index_zero_node); - } - + size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE); type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, se->expr); + se->expr = convert (type, size); } @@ -8887,50 +8864,63 @@ caf_this_image_ref (gfc_ref *ref) static void gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { - gfc_actual_arglist *arg1; gfc_se arg1se; tree tmp; - symbol_attribute caf_attr; + bool coindexed_caf_comp = false; + gfc_expr *e = expr->value.function.actual->expr; gfc_init_se (&arg1se, NULL); - arg1 = expr->value.function.actual; - - if (arg1->expr->ts.type == BT_CLASS) + if (e->ts.type == BT_CLASS) { /* Make sure that class array expressions have both a _data component reference and an array reference.... */ - if (CLASS_DATA (arg1->expr)->attr.dimension) - gfc_add_class_array_ref (arg1->expr); + if (CLASS_DATA (e)->attr.dimension) + gfc_add_class_array_ref (e); /* .... whilst scalars only need the _data component. */ else - gfc_add_data_component (arg1->expr); + gfc_add_data_component (e); } - /* When arg1 references an allocatable component in a coarray, then call + /* When 'e' references an allocatable component in a coarray, then call the caf-library function caf_is_present (). */ - if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION - && arg1->expr->value.function.isym - && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET) - caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr); - else - gfc_clear_attr (&caf_attr); - if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension - && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref)) - tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr); + if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CAF_GET) + { + e = e->value.function.actual->expr; + if (gfc_expr_attr (e).codimension) + { + /* Last partref is the coindexed coarray. As coarrays are collectively + (de)allocated, the allocation status must be the same as the one of + the local allocation. Convert to local access. */ + for (gfc_ref *ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + for (int i = ref->u.ar.dimen; + i < ref->u.ar.dimen + ref->u.ar.codimen; ++i) + ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE; + break; + } + } + else if (!caf_this_image_ref (e->ref)) + coindexed_caf_comp = true; + } + if (coindexed_caf_comp) + tmp = trans_caf_is_present (se, e); else { - if (arg1->expr->rank == 0) + if (e->rank == 0) { /* Allocatable scalar. */ arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); + gfc_conv_expr (&arg1se, e); tmp = arg1se.expr; } else { /* Allocatable array. */ arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr); + gfc_conv_expr_descriptor (&arg1se, e); tmp = gfc_conv_descriptor_data_get (arg1se.expr); } @@ -8961,7 +8951,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_se arg2se; tree tmp2; tree tmp; - tree nonzero_arraylen; + tree nonzero_arraylen = NULL_TREE; gfc_ss *ss; bool scalar; @@ -9061,14 +9051,16 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) { tmp = gfc_conv_descriptor_rank (arg1se.expr); tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (tmp), tmp, gfc_index_one_node); + TREE_TYPE (tmp), tmp, + build_int_cst (TREE_TYPE (tmp), 1)); } else tmp = gfc_rank_cst[arg1->expr->rank - 1]; tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); - nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); + if (arg2->expr->rank != 0) + nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); /* A pointer to an array, call library function _gfor_associated. */ arg1se.want_pointer = 1; @@ -9078,16 +9070,26 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) arg2se.want_pointer = 1; arg2se.force_no_tmp = 1; - gfc_conv_expr_descriptor (&arg2se, arg2->expr); + if (arg2->expr->rank != 0) + gfc_conv_expr_descriptor (&arg2se, arg2->expr); + else + { + gfc_conv_expr (&arg2se, arg2->expr); + arg2se.expr + = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr, + gfc_expr_attr (arg2->expr)); + arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr); + } gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); se->expr = build_call_expr_loc (input_location, gfor_fndecl_associated, 2, arg1se.expr, arg2se.expr); se->expr = convert (logical_type_node, se->expr); - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, se->expr, - nonzero_arraylen); + if (arg2->expr->rank != 0) + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, se->expr, + nonzero_arraylen); } /* If target is present zero character length pointers cannot @@ -9124,21 +9126,14 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) a = expr->value.function.actual->expr; b = expr->value.function.actual->next->expr; - if (UNLIMITED_POLY (a)) - { - tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl); - conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); - } - - if (UNLIMITED_POLY (b)) + bool unlimited_poly_a = UNLIMITED_POLY (a); + bool unlimited_poly_b = UNLIMITED_POLY (b); + if (unlimited_poly_a) { - tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl); - condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); + se1.want_pointer = 1; + gfc_add_vptr_component (a); } - - if (a->ts.type == BT_CLASS) + else if (a->ts.type == BT_CLASS) { gfc_add_vptr_component (a); gfc_add_hash_component (a); @@ -9147,7 +9142,12 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) a = gfc_get_int_expr (gfc_default_integer_kind, NULL, a->ts.u.derived->hash_value); - if (b->ts.type == BT_CLASS) + if (unlimited_poly_b) + { + se2.want_pointer = 1; + gfc_add_vptr_component (b); + } + else if (b->ts.type == BT_CLASS) { gfc_add_vptr_component (b); gfc_add_hash_component (b); @@ -9159,6 +9159,22 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_conv_expr (&se1, a); gfc_conv_expr (&se2, b); + if (unlimited_poly_a) + { + conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se1.expr, + build_int_cst (TREE_TYPE (se1.expr), 0)); + se1.expr = gfc_vptr_hash_get (se1.expr); + } + + if (unlimited_poly_b) + { + condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se2.expr, + build_int_cst (TREE_TYPE (se2.expr), 0)); + se2.expr = gfc_vptr_hash_get (se2.expr); + } + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 4ca2c3f..d234d1b 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -3804,6 +3804,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER); OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained; + OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -5895,6 +5896,8 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->order_concurrent; clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible + = code->ext.omp_clauses->order_reproducible; } if (mask & GFC_OMP_MASK_PARALLEL) { @@ -5951,6 +5954,8 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->order_concurrent; clausesa[GFC_OMP_SPLIT_DO].order_unconstrained = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_DO].order_reproducible + = code->ext.omp_clauses->order_reproducible; } if (mask & GFC_OMP_MASK_SIMD) { @@ -5969,6 +5974,8 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->order_concurrent; clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible + = code->ext.omp_clauses->order_reproducible; /* And this is copied to all. */ clausesa[GFC_OMP_SPLIT_SIMD].if_expr = code->ext.omp_clauses->if_expr; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 11df186..a8ff473 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1788,9 +1788,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Go straight to the class data. */ if (sym2->attr.dummy && !sym2->attr.optional) { - class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ? - GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) : - sym2->backend_decl; + class_decl = sym2->backend_decl; + if (DECL_LANG_SPECIFIC (class_decl) + && GFC_DECL_SAVED_DESCRIPTOR (class_decl)) + class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl); if (POINTER_TYPE_P (TREE_TYPE (class_decl))) class_decl = build_fold_indirect_ref_loc (input_location, class_decl); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 78578cf..fa3e865 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -438,7 +438,7 @@ tree gfc_class_vtab_def_init_get (tree); tree gfc_class_vtab_copy_get (tree); tree gfc_class_vtab_final_get (tree); /* Get an accessor to the vtab's * field, when a vptr handle is present. */ -tree gfc_vtpr_hash_get (tree); +tree gfc_vptr_hash_get (tree); tree gfc_vptr_size_get (tree); tree gfc_vptr_extends_get (tree); tree gfc_vptr_def_init_get (tree); @@ -518,6 +518,8 @@ tree gfc_string_to_single_character (tree len, tree str, int kind); tree gfc_get_tree_for_caf_expr (gfc_expr *); void gfc_get_caf_token_offset (gfc_se*, tree *, tree *, tree, tree, gfc_expr *); tree gfc_caf_get_image_index (stmtblock_t *, gfc_expr *, tree); +void gfc_simple_for_loop (stmtblock_t *, tree, tree, tree, enum tree_code, tree, + tree); /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); @@ -958,8 +960,6 @@ extern GTY(()) tree gfor_fndecl_convert_char1_to_char4; extern GTY(()) tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ -extern GTY(()) tree gfor_fndecl_size0; -extern GTY(()) tree gfor_fndecl_size1; extern GTY(()) tree gfor_fndecl_iargc; extern GTY(()) tree gfor_fndecl_kill; extern GTY(()) tree gfor_fndecl_kill_sub; |