aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorIan Lance Taylor <iant@golang.org>2021-10-07 15:28:36 -0700
committerIan Lance Taylor <iant@golang.org>2021-10-07 15:28:36 -0700
commit0b6b70a0733672600644c8df96942cda5bf86d3d (patch)
tree9a1fbd7f782c54df55ab225ed1be057e3f3b0b8a /gcc/fortran
parenta5b5cabc91c38710adbe5c8a2b53882abe994441 (diff)
parentfba228e259dd5112851527f2dbb62c5601100985 (diff)
downloadgcc-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/ChangeLog183
-rw-r--r--gcc/fortran/array.c5
-rw-r--r--gcc/fortran/check.c4
-rw-r--r--gcc/fortran/cpp.c9
-rw-r--r--gcc/fortran/cpp.h2
-rw-r--r--gcc/fortran/decl.c14
-rw-r--r--gcc/fortran/dump-parse-tree.c2
-rw-r--r--gcc/fortran/expr.c32
-rw-r--r--gcc/fortran/f95-lang.c4
-rw-r--r--gcc/fortran/gfortran.h8
-rw-r--r--gcc/fortran/interface.c39
-rw-r--r--gcc/fortran/openmp.c5
-rw-r--r--gcc/fortran/options.c19
-rw-r--r--gcc/fortran/resolve.c13
-rw-r--r--gcc/fortran/scanner.c87
-rw-r--r--gcc/fortran/simplify.c5
-rw-r--r--gcc/fortran/trans-array.c166
-rw-r--r--gcc/fortran/trans-array.h2
-rw-r--r--gcc/fortran/trans-decl.c14
-rw-r--r--gcc/fortran/trans-expr.c77
-rw-r--r--gcc/fortran/trans-intrinsic.c246
-rw-r--r--gcc/fortran/trans-openmp.c7
-rw-r--r--gcc/fortran/trans-stmt.c7
-rw-r--r--gcc/fortran/trans.h6
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;