summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2013-09-09 15:57:43 +0000
committerbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2013-09-09 15:57:43 +0000
commiteacbf1cd3aff3dbf47a71dc7fdb1d01dce8e777e (patch)
tree1bfb594134ffebca206d3ed2fe55693634759c1d /gcc/fortran
parent11fd42e7594bdb9c8d9cf10f9924cb8644752b78 (diff)
downloadgcc-eacbf1cd3aff3dbf47a71dc7fdb1d01dce8e777e.tar.gz
2013-09-09 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 202389 using svnmerge.py; notice that gcc/melt/xtramelt-ana-base.melt has been significantly updated, but some updates are yet missing... [gcc/] 2013-09-09 Basile Starynkevitch <basile@starynkevitch.net> {{When merging trunk GCC 4.9 with C++ passes}} * melt/xtramelt-ana-base.melt: Add GCC 4.9 specific code, still incomplete, for classy passes.... Only Gimple passes are yet possible... git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@202408 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog150
-rw-r--r--gcc/fortran/array.c66
-rw-r--r--gcc/fortran/class.c192
-rw-r--r--gcc/fortran/dependency.c105
-rw-r--r--gcc/fortran/expr.c5
-rw-r--r--gcc/fortran/f95-lang.c4
-rw-r--r--gcc/fortran/gfortran.h6
-rw-r--r--gcc/fortran/interface.c92
-rw-r--r--gcc/fortran/intrinsic.c7
-rw-r--r--gcc/fortran/invoke.texi5
-rw-r--r--gcc/fortran/io.c18
-rw-r--r--gcc/fortran/lang.opt4
-rw-r--r--gcc/fortran/match.c105
-rw-r--r--gcc/fortran/openmp.c4
-rw-r--r--gcc/fortran/options.c6
-rw-r--r--gcc/fortran/parse.c4
-rw-r--r--gcc/fortran/resolve.c59
-rw-r--r--gcc/fortran/st.c6
-rw-r--r--gcc/fortran/symbol.c3
-rw-r--r--gcc/fortran/trans-array.c40
-rw-r--r--gcc/fortran/trans-decl.c35
-rw-r--r--gcc/fortran/trans-expr.c222
-rw-r--r--gcc/fortran/trans-intrinsic.c10
-rw-r--r--gcc/fortran/trans-io.c5
-rw-r--r--gcc/fortran/trans-stmt.c3
25 files changed, 727 insertions, 429 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8ec11b6e453..2b34517741d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,153 @@
+2013-09-02 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/PR56519
+ * gfortran.h: Declare gfc_do_concurrent_flag as extern.
+ * resolve.c: Rename do_concurrent_flag to gfc_do_concurrent_flag
+ and make non-static.
+ (resolve_function): Use gfc_do_concurrent_flag instead of
+ do_concurrent_flag.
+ (pure_subroutine): Likewise.
+ (resolve_code): Likewise.
+ (resolve_types): Likewise.
+ * intrinsic.c (gfc_intrinsic_sub_interface): Raise error for
+ non-pure intrinsic subroutines within DO CONCURRENT.
+
+2013-08-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/52243
+ * trans-expr.c (is_runtime_conformable): New function.
+ * gfc_trans_assignment_1: Use it.
+
+2013-08-26 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/58146
+ * array.c (gfc_ref_dimen_size): If possible, use
+ gfc_dep_difference to calculate array refrence
+ sizes. Fall back to integer code otherwise.
+ * dependency.c (discard_nops). Move up.
+ Also discarde widening integer conversions.
+ (gfc_dep_compare_expr): Use discard_nops.
+
+2013-08-23 Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/57798
+ * trans-array.c (gfc_conv_ss_startstride, set_loop_bounds,
+ gfc_set_delta): Generate preliminary code before the outermost loop.
+
+2013-08-23 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/57843
+ * interface.c (gfc_extend_assign): Look for type-bound assignment
+ procedures before non-typebound.
+
+2013-08-23 Mikael Morin <mikael@gcc.gnu.org>
+
+ * trans-array.c (gfc_conv_section_startstride): Move &loop->pre access
+ to the callers.
+ (gfc_conv_ss_startstride, gfc_conv_expr_descriptor): Update callers.
+
+2013-08-22 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/58185
+ * match.c (copy_ts_from_selector_to_associate): Only build class
+ container for polymorphic selector. Some cleanup.
+
+2013-08-20 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/53655
+ * trans-decl.c (generate_local_decl): Check if type has any components.
+
+2013-08-19 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/46271
+ * openmp.c (resolve_omp_clauses): Bugfix for procedure pointers.
+
+2013-08-12 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/56666
+ * gfortran.h (gfc_option_t): Add warn_zerotrip.
+ * invoke.texi (-Wzerotrip): Document option.
+ * lang.opt (Wzerotrip): Add.
+ * options.c (gfc_init_options): Initialize warn_zerotrip.
+ (set_Wall): Add handling of warn_zerotrip.
+ (gfc_handle_option): Handle OPT_Wzerotrip.
+ * resolve.c (gfc_resolve_iterator): Honor
+ gfc_option.warn_zerotrip; update error message to show
+ how to suppress the warning.
+
+2013-08-09 Janus Weil <janus@gcc.gnu.org>
+
+ * gfortran.h (gfc_get_code): Modified prototype.
+ * class.c (finalize_component, finalization_scalarizer,
+ finalization_get_offset, finalizer_insert_packed_call,
+ generate_finalization_wrapper, gfc_find_derived_vtab,
+ gfc_find_intrinsic_vtab): Use 'gfc_get_code'.
+ * io.c (match_io_iterator, match_io_element, terminate_io, get_io_list,
+ gfc_match_inquire): Call 'gfc_get_code' with argument.
+ * match.c (match_simple_forall, gfc_match_forall, gfc_match_goto,
+ gfc_match_nullify, gfc_match_call, match_simple_where, gfc_match_where):
+ Ditto.
+ * parse.c (new_level): Ditto.
+ (add_statement): Use XCNEW.
+ * resolve.c (resolve_entries, resolve_allocate_expr,
+ resolve_select_type, build_assignment, build_init_assign): Call
+ 'gfc_get_code' with argument.
+ * st.c (gfc_get_code): Add argument 'op'.
+ * trans-expr.c (gfc_trans_class_array_init_assign): Call 'gfc_get_code'
+ with argument.
+ * trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2013-08-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/58058
+ * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Free the temporary
+ string, if necessary.
+
+2013-08-06 Martin Jambor <mjambor@suse.cz>
+
+ PR fortran/57987
+ * trans-decl.c (gfc_generate_function_code): Never call
+ cgraph_finalize_function on nested functions.
+
+2013-08-06 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/57306
+ * class.c (gfc_class_null_initializer): Rename to
+ 'gfc_class_initializer'. Treat non-NULL init-exprs.
+ * gfortran.h (gfc_class_null_initializer): Update prototype.
+ * trans-decl.c (gfc_get_symbol_decl): Treat class variables.
+ * trans-expr.c (gfc_conv_initializer): Ditto.
+ (gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.
+
+2013-07-30 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/57530
+ * symbol.c (gfc_type_compatible): A type is type compatible with
+ a class if both have the same declared type.
+ * interface.c (compare_type): Reject CLASS/TYPE even if they
+ are type compatible.
+
+2013-07-30 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/57530
+ * trans-expr.c (gfc_trans_class_assign): Handle CLASS array
+ functions.
+ (gfc_trans_pointer_assign): Ditto and support pointer assignment of
+ a polymorphic var to a nonpolymorphic var.
+
+2013-07-22 Po Chang <pchang9@cs.wisc.edu>
+
+ * match.c (gfc_match_call): Exit loop after setting i.
+
+ * resolve.c (resolve_variable): Exit loop after setting seen.
+
+ * expr.c (gfc_check_pointer_assign): Exit loop after setting warn.
+
+ * trans-array.c (set_loop_bounds): Exit loop after setting
+ nonoptional_arr.
+
+ * trans-io.c (gfc_trans_transfer): Exit loop after setting seen_vector.
+
2013-07-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/58009
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index f07bc64dbca..687ae3d2f0d 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -2112,6 +2112,7 @@ bool
gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
{
mpz_t upper, lower, stride;
+ mpz_t diff;
bool t;
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
@@ -2130,9 +2131,63 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
break;
case DIMEN_RANGE:
+
+ mpz_init (stride);
+
+ if (ar->stride[dimen] == NULL)
+ mpz_set_ui (stride, 1);
+ else
+ {
+ if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+ {
+ mpz_clear (stride);
+ return false;
+ }
+ mpz_set (stride, ar->stride[dimen]->value.integer);
+ }
+
+ /* Calculate the number of elements via gfc_dep_differce, but only if
+ start and end are both supplied in the reference or the array spec.
+ This is to guard against strange but valid code like
+
+ subroutine foo(a,n)
+ real a(1:n)
+ n = 3
+ print *,size(a(n-1:))
+
+ where the user changes the value of a variable. If we have to
+ determine end as well, we cannot do this using gfc_dep_difference.
+ Fall back to the constants-only code then. */
+
+ if (end == NULL)
+ {
+ bool use_dep;
+
+ use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
+ &diff);
+ if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
+ use_dep = gfc_dep_difference (ar->as->upper[dimen],
+ ar->as->lower[dimen], &diff);
+
+ if (use_dep)
+ {
+ mpz_init (*result);
+ mpz_add (*result, diff, stride);
+ mpz_div (*result, *result, stride);
+ if (mpz_cmp_ui (*result, 0) < 0)
+ mpz_set_ui (*result, 0);
+
+ mpz_clear (stride);
+ mpz_clear (diff);
+ return true;
+ }
+
+ }
+
+ /* Constant-only code here, which covers more cases
+ like a(:4) etc. */
mpz_init (upper);
mpz_init (lower);
- mpz_init (stride);
t = false;
if (ar->start[dimen] == NULL)
@@ -2163,15 +2218,6 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
mpz_set (upper, ar->end[dimen]->value.integer);
}
- if (ar->stride[dimen] == NULL)
- mpz_set_ui (stride, 1);
- else
- {
- if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
- goto cleanup;
- mpz_set (stride, ar->stride[dimen]->value.integer);
- }
-
mpz_init (*result);
mpz_sub (*result, upper, lower);
mpz_add (*result, *result, stride);
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 51bfd5685ea..629b052fb32 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -412,12 +412,12 @@ gfc_is_class_container_ref (gfc_expr *e)
}
-/* Build a NULL initializer for CLASS pointers,
- initializing the _data component to NULL and
- the _vptr component to the declared type. */
+/* Build an initializer for CLASS pointers,
+ initializing the _data component to the init_expr (or NULL) and the _vptr
+ component to the corresponding type (or the declared type, given by ts). */
gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{
gfc_expr *init;
gfc_component *comp;
@@ -430,6 +430,8 @@ gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
if (is_unlimited_polymorphic && init_expr)
vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
+ else if (init_expr && init_expr->expr_type != EXPR_NULL)
+ vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
else
vtab = gfc_find_derived_vtab (ts->u.derived);
@@ -442,6 +444,8 @@ gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
gfc_constructor *ctor = gfc_constructor_get();
if (strcmp (comp->name, "_vptr") == 0 && vtab)
ctor->expr = gfc_lval_expr_from_sym (vtab);
+ else if (init_expr && init_expr->expr_type != EXPR_NULL)
+ ctor->expr = gfc_copy_expr (init_expr);
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
@@ -859,7 +863,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
&& CLASS_DATA (comp)->attr.allocatable))
{
- block = XCNEW (gfc_code);
+ block = gfc_get_code (EXEC_IF);
if (*code)
{
(*code)->next = block;
@@ -868,19 +872,12 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
else
(*code) = block;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
-
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_IF);
block = block->block;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
}
- dealloc = XCNEW (gfc_code);
- dealloc->op = EXEC_DEALLOCATE;
- dealloc->loc = gfc_current_locus;
+ dealloc = gfc_get_code (EXEC_DEALLOCATE);
dealloc->ext.alloc.list = gfc_get_alloc ();
dealloc->ext.alloc.list->expr = e;
@@ -911,10 +908,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
break;
gcc_assert (c);
- final_wrap = XCNEW (gfc_code);
- final_wrap->op = EXEC_CALL;
- final_wrap->loc = gfc_current_locus;
- final_wrap->loc = gfc_current_locus;
+ final_wrap = gfc_get_code (EXEC_CALL);
final_wrap->symtree = c->initializer->symtree;
final_wrap->resolved_sym = c->initializer->symtree->n.sym;
final_wrap->ext.actual = gfc_get_actual_arglist ();
@@ -951,9 +945,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
gfc_expr *expr, *expr2;
/* C_F_POINTER(). */
- block = XCNEW (gfc_code);
- block->op = EXEC_CALL;
- block->loc = gfc_current_locus;
+ block = gfc_get_code (EXEC_CALL);
gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
block->resolved_sym = block->symtree->n.sym;
block->resolved_sym->attr.flavor = FL_PROCEDURE;
@@ -1033,10 +1025,8 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
gfc_expr *expr, *expr2;
/* offset = 0. */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- block->op = EXEC_ASSIGN;
- block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (offset);
block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
@@ -1046,13 +1036,10 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
iter->end = gfc_copy_expr (rank);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_DO);
block = block->next;
- block->op = EXEC_DO;
- block->loc = gfc_current_locus;
block->ext.iterator = iter;
- block->block = gfc_get_code ();
- block->block->op = EXEC_DO;
+ block->block = gfc_get_code (EXEC_DO);
/* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
* strides(idx2). */
@@ -1111,9 +1098,7 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
expr->ts = idx->ts;
/* offset = offset + ... */
- block->block->next = XCNEW (gfc_code);
- block->block->next->op = EXEC_ASSIGN;
- block->block->next->loc = gfc_current_locus;
+ block->block->next = gfc_get_code (EXEC_ASSIGN);
block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
block->block->next->expr2 = gfc_get_expr ();
block->block->next->expr2->expr_type = EXPR_OP;
@@ -1123,10 +1108,8 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
block->block->next->expr2->ts = idx->ts;
/* After the loop: offset = offset * byte_stride. */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- block->op = EXEC_ASSIGN;
- block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (offset);
block->expr2 = gfc_get_expr ();
block->expr2->expr_type = EXPR_OP;
@@ -1185,15 +1168,11 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
gfc_code *block2;
int i;
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_IF);
block = block->next;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_IF);
block = block->block;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
/* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
size_expr = gfc_get_expr ();
@@ -1270,9 +1249,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
/* IF body: call final subroutine. */
- block->next = XCNEW (gfc_code);
- block->next->op = EXEC_CALL;
- block->next->loc = gfc_current_locus;
+ block->next = gfc_get_code (EXEC_CALL);
block->next->symtree = fini->proc_tree;
block->next->resolved_sym = fini->proc_tree->n.sym;
block->next->ext.actual = gfc_get_actual_arglist ();
@@ -1280,17 +1257,13 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
/* ELSE. */
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_IF);
block = block->block;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
- block->next = XCNEW (gfc_code);
+ /* BLOCK ... END BLOCK. */
+ block->next = gfc_get_code (EXEC_BLOCK);
block = block->next;
- /* BLOCK ... END BLOCK. */
- block->op = EXEC_BLOCK;
- block->loc = gfc_current_locus;
ns = gfc_build_block_ns (sub_ns);
block->ext.block.ns = ns;
block->ext.block.assoc = NULL;
@@ -1343,13 +1316,10 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
iter->end = gfc_lval_expr_from_sym (nelem);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- block = XCNEW (gfc_code);
+ block = gfc_get_code (EXEC_DO);
ns->code = block;
- block->op = EXEC_DO;
- block->loc = gfc_current_locus;
block->ext.iterator = iter;
- block->block = gfc_get_code ();
- block->block->op = EXEC_DO;
+ block->block = gfc_get_code (EXEC_DO);
/* Offset calculation for the new array: idx * size of type (in bytes). */
offset2 = gfc_get_expr ();
@@ -1374,18 +1344,14 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block2 = block2->next;
/* ptr2 = ptr. */
- block2->next = XCNEW (gfc_code);
+ block2->next = gfc_get_code (EXEC_ASSIGN);
block2 = block2->next;
- block2->op = EXEC_ASSIGN;
- block2->loc = gfc_current_locus;
block2->expr1 = gfc_lval_expr_from_sym (ptr2);
block2->expr2 = gfc_lval_expr_from_sym (ptr);
/* Call now the user's final subroutine. */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_CALL);
block = block->next;
- block->op = EXEC_CALL;
- block->loc = gfc_current_locus;
block->symtree = fini->proc_tree;
block->resolved_sym = fini->proc_tree->n.sym;
block->ext.actual = gfc_get_actual_arglist ();
@@ -1403,13 +1369,10 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
iter->end = gfc_lval_expr_from_sym (nelem);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_DO);
block = block->next;
- block->op = EXEC_DO;
- block->loc = gfc_current_locus;
block->ext.iterator = iter;
- block->block = gfc_get_code ();
- block->block->op = EXEC_DO;
+ block->block = gfc_get_code (EXEC_DO);
/* Offset calculation of "array". */
block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
@@ -1427,9 +1390,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block2 = block2->next;
/* ptr = ptr2. */
- block2->next = XCNEW (gfc_code);
- block2->next->op = EXEC_ASSIGN;
- block2->next->loc = gfc_current_locus;
+ block2->next = gfc_get_code (EXEC_ASSIGN);
block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
}
@@ -1691,27 +1652,21 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Set return value to 0. */
- last_code = XCNEW (gfc_code);
- last_code->op = EXEC_ASSIGN;
- last_code->loc = gfc_current_locus;
+ last_code = gfc_get_code (EXEC_ASSIGN);
last_code->expr1 = gfc_lval_expr_from_sym (final);
last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
sub_ns->code = last_code;
/* Set: is_contiguous = .true. */
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
last_code = last_code->next;
- last_code->op = EXEC_ASSIGN;
- last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, true);
/* Set: sizes(0) = 1. */
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
last_code = last_code->next;
- last_code->op = EXEC_ASSIGN;
- last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_lval_expr_from_sym (sizes);
last_code->expr1->ref = gfc_get_ref ();
last_code->expr1->ref->type = REF_ARRAY;
@@ -1736,19 +1691,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
iter->end = gfc_copy_expr (rank);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_DO);
last_code = last_code->next;
- last_code->op = EXEC_DO;
- last_code->loc = gfc_current_locus;
last_code->ext.iterator = iter;
- last_code->block = gfc_get_code ();
- last_code->block->op = EXEC_DO;
+ last_code->block = gfc_get_code (EXEC_DO);
/* strides(idx) = _F._stride(array,dim=idx). */
- last_code->block->next = XCNEW (gfc_code);
+ last_code->block->next = gfc_get_code (EXEC_ASSIGN);
block = last_code->block->next;
- block->op = EXEC_ASSIGN;
- block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (strides);
block->expr1->ref = gfc_get_ref ();
@@ -1765,10 +1715,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_lval_expr_from_sym (idx));
/* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- block->op = EXEC_ASSIGN;
- block->loc = gfc_current_locus;
/* sizes(idx) = ... */
block->expr1 = gfc_lval_expr_from_sym (sizes);
@@ -1815,15 +1763,11 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->expr2->ts = idx->ts;
/* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_IF);
block = block->next;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_IF);
block = block->block;
- block->loc = gfc_current_locus;
- block->op = EXEC_IF;
/* if condition: strides(idx) /= sizes(idx-1). */
block->expr1 = gfc_get_expr ();
@@ -1860,10 +1804,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
= block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
/* if body: is_contiguous = .false. */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- block->op = EXEC_ASSIGN;
- block->loc = gfc_current_locus;
block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, false);
@@ -1879,10 +1821,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (nelem);
/* nelem = sizes (rank) - 1. */
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
last_code = last_code->next;
- last_code->op = EXEC_ASSIGN;
- last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_lval_expr_from_sym (nelem);
@@ -1934,10 +1874,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (ptr);
/* SELECT CASE (RANK (array)). */
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_SELECT);
last_code = last_code->next;
- last_code->op = EXEC_SELECT;
- last_code->loc = gfc_current_locus;
last_code->expr1 = gfc_copy_expr (rank);
block = NULL;
@@ -1952,16 +1890,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* CASE (fini_rank). */
if (block)
{
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_SELECT);
block = block->block;
}
else
{
- block = XCNEW (gfc_code);
+ block = gfc_get_code (EXEC_SELECT);
last_code->block = block;
}
- block->loc = gfc_current_locus;
- block->op = EXEC_SELECT;
block->ext.block.case_list = gfc_get_case ();
block->ext.block.case_list->where = gfc_current_locus;
if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
@@ -1982,9 +1918,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
rank, sub_ns);
else
{
- block->next = XCNEW (gfc_code);
- block->next->op = EXEC_CALL;
- block->next->loc = gfc_current_locus;
+ block->next = gfc_get_code (EXEC_CALL);
block->next->symtree = fini->proc_tree;
block->next->resolved_sym = fini->proc_tree->n.sym;
block->next->ext.actual = gfc_get_actual_arglist ();
@@ -1998,16 +1932,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* CASE DEFAULT. */
if (block)
{
- block->block = XCNEW (gfc_code);
+ block->block = gfc_get_code (EXEC_SELECT);
block = block->block;
}
else
{
- block = XCNEW (gfc_code);
+ block = gfc_get_code (EXEC_SELECT);
last_code->block = block;
}
- block->loc = gfc_current_locus;
- block->op = EXEC_SELECT;
block->ext.block.case_list = gfc_get_case ();
/* Create loop. */
@@ -2016,13 +1948,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
iter->end = gfc_lval_expr_from_sym (nelem);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_DO);
block = block->next;
- block->op = EXEC_DO;
- block->loc = gfc_current_locus;
block->ext.iterator = iter;
- block->block = gfc_get_code ();
- block->block->op = EXEC_DO;
+ block->block = gfc_get_code (EXEC_DO);
/* Offset calculation. */
block = finalization_get_offset (idx, idx2, offset, strides, sizes,
@@ -2039,10 +1968,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block = block->next;
/* CALL final_elemental (array). */
- block->next = XCNEW (gfc_code);
+ block->next = gfc_get_code (EXEC_CALL);
block = block->next;
- block->op = EXEC_CALL;
- block->loc = gfc_current_locus;
block->symtree = fini_elem->proc_tree;
block->resolved_sym = fini_elem->proc_sym;
block->ext.actual = gfc_get_actual_arglist ();
@@ -2084,13 +2011,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
iter->end = gfc_lval_expr_from_sym (nelem);
iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_DO);
last_code = last_code->next;
- last_code->op = EXEC_DO;
- last_code->loc = gfc_current_locus;
last_code->ext.iterator = iter;
- last_code->block = gfc_get_code ();
- last_code->block->op = EXEC_DO;
+ last_code->block = gfc_get_code (EXEC_DO);
/* Offset calculation. */
block = finalization_get_offset (idx, idx2, offset, strides, sizes,
@@ -2122,10 +2046,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Call the finalizer of the ancestor. */
if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
{
- last_code->next = XCNEW (gfc_code);
+ last_code->next = gfc_get_code (EXEC_CALL);
last_code = last_code->next;
- last_code->op = EXEC_CALL;
- last_code->loc = gfc_current_locus;
last_code->symtree = ancestor_wrapper->symtree;
last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
@@ -2371,8 +2293,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
/* Set up code. */
- sub_ns->code = gfc_get_code ();
- sub_ns->code->op = EXEC_INIT_ASSIGN;
+ sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
/* Set initializer. */
@@ -2655,8 +2576,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
/* Set up code. */
- sub_ns->code = gfc_get_code ();
- sub_ns->code->op = EXEC_INIT_ASSIGN;
+ sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
got_char_copy:
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index 350c7bd07a2..d85905cb6b8 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -240,6 +240,46 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
return -2;
}
+/* Helper function to look through parens, unary plus and widening
+ integer conversions. */
+
+static gfc_expr*
+discard_nops (gfc_expr *e)
+{
+ gfc_actual_arglist *arglist;
+
+ if (e == NULL)
+ return NULL;
+
+ while (true)
+ {
+ if (e->expr_type == EXPR_OP
+ && (e->value.op.op == INTRINSIC_UPLUS
+ || e->value.op.op == INTRINSIC_PARENTHESES))
+ {
+ e = e->value.op.op1;
+ continue;
+ }
+
+ if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
+ && e->value.function.isym->id == GFC_ISYM_CONVERSION
+ && e->ts.type == BT_INTEGER)
+ {
+ arglist = e->value.function.actual;
+ if (arglist->expr->ts.type == BT_INTEGER
+ && e->ts.kind > arglist->expr->ts.kind)
+ {
+ e = arglist->expr;
+ continue;
+ }
+ }
+ break;
+ }
+
+ return e;
+}
+
+
/* Compare two expressions. Return values:
* +1 if e1 > e2
* 0 if e1 == e2
@@ -252,59 +292,13 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
int
gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
{
- gfc_actual_arglist *args1;
- gfc_actual_arglist *args2;
int i;
- gfc_expr *n1, *n2;
-
- n1 = NULL;
- n2 = NULL;
if (e1 == NULL && e2 == NULL)
return 0;
- /* Remove any integer conversion functions to larger types. */
- if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
- && e1->value.function.isym->id == GFC_ISYM_CONVERSION
- && e1->ts.type == BT_INTEGER)
- {
- args1 = e1->value.function.actual;
- if (args1->expr->ts.type == BT_INTEGER
- && e1->ts.kind > args1->expr->ts.kind)
- n1 = args1->expr;
- }
-
- if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
- && e2->value.function.isym->id == GFC_ISYM_CONVERSION
- && e2->ts.type == BT_INTEGER)
- {
- args2 = e2->value.function.actual;
- if (args2->expr->ts.type == BT_INTEGER
- && e2->ts.kind > args2->expr->ts.kind)
- n2 = args2->expr;
- }
-
- if (n1 != NULL)
- {
- if (n2 != NULL)
- return gfc_dep_compare_expr (n1, n2);
- else
- return gfc_dep_compare_expr (n1, e2);
- }
- else
- {
- if (n2 != NULL)
- return gfc_dep_compare_expr (e1, n2);
- }
-
- if (e1->expr_type == EXPR_OP
- && (e1->value.op.op == INTRINSIC_UPLUS
- || e1->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1->value.op.op1, e2);
- if (e2->expr_type == EXPR_OP
- && (e2->value.op.op == INTRINSIC_UPLUS
- || e2->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1, e2->value.op.op1);
+ e1 = discard_nops (e1);
+ e2 = discard_nops (e2);
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
@@ -501,21 +495,6 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
}
-/* Helper function to look through parens and unary plus. */
-
-static gfc_expr*
-discard_nops (gfc_expr *e)
-{
-
- while (e && e->expr_type == EXPR_OP
- && (e->value.op.op == INTRINSIC_UPLUS
- || e->value.op.op == INTRINSIC_PARENTHESES))
- e = e->value.op.op1;
-
- return e;
-}
-
-
/* Return the difference between two expressions. Integer expressions of
the form
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c00fbc5493f..61f0f8275cc 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3764,7 +3764,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
ns = ns->parent)
if (ns->parent == lvalue->symtree->n.sym->ns)
- warn = true;
+ {
+ warn = true;
+ break;
+ }
if (warn)
gfc_warning ("Pointer at %L in pointer assignment might outlive the "
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 30cbfe59476..7bb2913552c 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -826,7 +826,7 @@ gfc_init_builtin_functions (void)
BUILT_IN_POWIF, "powif", ATTR_CONST_NOTHROW_LEAF_LIST);
- if (TARGET_C99_FUNCTIONS)
+ if (targetm.libc_has_function (function_c99_math_complex))
{
gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0],
BUILT_IN_CBRTL, "cbrtl",
@@ -848,7 +848,7 @@ gfc_init_builtin_functions (void)
ATTR_CONST_NOTHROW_LEAF_LIST);
}
- if (TARGET_HAS_SINCOS)
+ if (targetm.libc_has_function (function_sincos))
{
gfc_define_builtin ("__builtin_sincosl",
func_longdouble_longdoublep_longdoublep,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c11ffdda8b9..b28edd80002 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2252,6 +2252,7 @@ typedef struct
int warn_align_commons;
int warn_real_q_constant;
int warn_unused_dummy_argument;
+ int warn_zerotrip;
int warn_realloc_lhs;
int warn_realloc_lhs_all;
int warn_compare_reals;
@@ -2820,7 +2821,7 @@ bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
extern gfc_code new_st;
void gfc_clear_new_st (void);
-gfc_code *gfc_get_code (void);
+gfc_code *gfc_get_code (gfc_exec_op);
gfc_code *gfc_append_code (gfc_code *, gfc_code *);
void gfc_free_statement (gfc_code *);
void gfc_free_statements (gfc_code *);
@@ -2845,6 +2846,7 @@ gfc_expr *gfc_expr_to_initialize (gfc_expr *);
bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
+extern int gfc_do_concurrent_flag;
/* array.c */
@@ -2983,7 +2985,7 @@ void gfc_add_class_array_ref (gfc_expr *);
bool gfc_is_class_array_ref (gfc_expr *, bool *);
bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *);
+gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 339dd243c12..aa88b3c3fa6 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -514,6 +514,12 @@ compare_type (gfc_symbol *s1, gfc_symbol *s2)
if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
return 1;
+ /* TYPE and CLASS of the same declared type are type compatible,
+ but have different characteristics. */
+ if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
+ || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
+ return 0;
+
return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
}
@@ -3748,20 +3754,18 @@ gfc_extend_expr (gfc_expr *e)
}
-/* Tries to replace an assignment code node with a subroutine call to
- the subroutine associated with the assignment operator. Return
- true if the node was replaced. On false, no error is
- generated. */
+/* Tries to replace an assignment code node with a subroutine call to the
+ subroutine associated with the assignment operator. Return true if the node
+ was replaced. On false, no error is generated. */
bool
gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
- gfc_expr *lhs, *rhs;
- gfc_symbol *sym;
- const char *gname;
-
- gname = NULL;
+ gfc_expr *lhs, *rhs, *tb_base;
+ gfc_symbol *sym = NULL;
+ const char *gname = NULL;
+ gfc_typebound_proc* tbo;
lhs = c->expr1;
rhs = c->expr2;
@@ -3779,8 +3783,26 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
actual->next = gfc_get_actual_arglist ();
actual->next->expr = rhs;
- sym = NULL;
+ /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
+
+ /* See if we find a matching type-bound assignment. */
+ tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
+ NULL, &gname);
+ if (tbo)
+ {
+ /* Success: Replace the expression with a type-bound call. */
+ gcc_assert (tb_base);
+ c->expr1 = gfc_get_expr ();
+ build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+ c->expr1->value.compcall.assign = 1;
+ c->expr1->where = c->loc;
+ c->expr2 = NULL;
+ c->op = EXEC_COMPCALL;
+ return true;
+ }
+
+ /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
for (; ns; ns = ns->parent)
{
sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
@@ -3788,47 +3810,21 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
break;
}
- /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
-
- if (sym == NULL)
+ if (sym)
{
- gfc_typebound_proc* tbo;
- gfc_expr* tb_base;
-
- /* See if we find a matching type-bound assignment. */
- tbo = matching_typebound_op (&tb_base, actual,
- INTRINSIC_ASSIGN, NULL, &gname);
-
- /* If there is one, replace the expression with a call to it and
- succeed. */
- if (tbo)
- {
- gcc_assert (tb_base);
- c->expr1 = gfc_get_expr ();
- build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
- c->expr1->value.compcall.assign = 1;
- c->expr1->where = c->loc;
- c->expr2 = NULL;
- c->op = EXEC_COMPCALL;
-
- /* c is resolved from the caller, so no need to do it here. */
-
- return true;
- }
-
- free (actual->next);
- free (actual);
- return false;
+ /* Success: Replace the assignment with the call. */
+ c->op = EXEC_ASSIGN_CALL;
+ c->symtree = gfc_find_sym_in_symtree (sym);
+ c->expr1 = NULL;
+ c->expr2 = NULL;
+ c->ext.actual = actual;
+ return true;
}
- /* Replace the assignment with the call. */
- c->op = EXEC_ASSIGN_CALL;
- c->symtree = gfc_find_sym_in_symtree (sym);
- c->expr1 = NULL;
- c->expr2 = NULL;
- c->ext.actual = actual;
-
- return true;
+ /* Failure: No assignment procedure found. */
+ free (actual->next);
+ free (actual);
+ return false;
}
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c2e1525a268..3da3c5365a0 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4397,6 +4397,13 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
c->resolved_sym->attr.elemental = isym->elemental;
}
+ if (gfc_do_concurrent_flag && !isym->pure)
+ {
+ gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
+ "block at %L is not PURE", name, &c->loc);
+ return MATCH_ERROR;
+ }
+
if (gfc_pure (NULL) && !isym->pure)
{
gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 3af57a300f8..69bec275de9 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -954,6 +954,11 @@ This option is implied by @option{-Wextra}.
Warn if the pointer in a pointer assignment might be longer than the its
target. This option is implied by @option{-Wall}.
+@item -Wzerotrip
+@opindex @code{Wzerotrip}
+Warn if a @code{DO} loop is known to execute zero times at compile
+time. This option is implied by @option{-Wall}.
+
@item -Werror
@opindex @code{Werror}
@cindex warnings, to errors
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 678bc5d844e..cc5ce12781e 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -3055,12 +3055,10 @@ match_io_iterator (io_kind k, gfc_code **result)
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
- new_code = gfc_get_code ();
- new_code->op = EXEC_DO;
+ new_code = gfc_get_code (EXEC_DO);
new_code->ext.iterator = iter;
- new_code->block = gfc_get_code ();
- new_code->block->op = EXEC_DO;
+ new_code->block = gfc_get_code (EXEC_DO);
new_code->block->next = head;
*result = new_code;
@@ -3117,8 +3115,7 @@ match_io_element (io_kind k, gfc_code **cpp)
return MATCH_ERROR;
}
- cp = gfc_get_code ();
- cp->op = EXEC_TRANSFER;
+ cp = gfc_get_code (EXEC_TRANSFER);
cp->expr1 = expr;
if (k != M_INQUIRE)
cp->ext.dt = current_dt;
@@ -3180,8 +3177,7 @@ terminate_io (gfc_code *io_code)
if (io_code == NULL)
io_code = new_st.block;
- c = gfc_get_code ();
- c->op = EXEC_DT_END;
+ c = gfc_get_code (EXEC_DT_END);
/* Point to structure that is already there */
c->ext.dt = new_st.ext.dt;
@@ -3751,8 +3747,7 @@ get_io_list:
new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
new_st.ext.dt = dt;
- new_st.block = gfc_get_code ();
- new_st.block->op = new_st.op;
+ new_st.block = gfc_get_code (new_st.op);
new_st.block->next = io_code;
terminate_io (io_code);
@@ -3961,8 +3956,7 @@ gfc_match_inquire (void)
if (gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
- new_st.block = gfc_get_code ();
- new_st.block->op = EXEC_IOLENGTH;
+ new_st.block = gfc_get_code (EXEC_IOLENGTH);
terminate_io (code);
new_st.block->next = code;
return MATCH_YES;
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 61f77b4fc5f..4f7993433d4 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -293,6 +293,10 @@ Wunused-dummy-argument
Fortran Warning
Warn about unused dummy arguments.
+Wzerotrip
+Fortran Warning
+Warn about zero-trip DO loops
+
cpp
Fortran Negative(nocpp)
Enable preprocessing
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 7f30156624d..71e3862189a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1608,13 +1608,12 @@ got_match:
is in new_st. Rearrange things so that the IF statement appears
in new_st. */
- p = gfc_get_code ();
- p->next = gfc_get_code ();
+ p = gfc_get_code (EXEC_IF);
+ p->next = XCNEW (gfc_code);
*p->next = new_st;
p->next->loc = gfc_current_locus;
p->expr1 = expr;
- p->op = EXEC_IF;
gfc_clear_new_st ();
@@ -2224,7 +2223,7 @@ match_simple_forall (void)
goto syntax;
}
- c = gfc_get_code ();
+ c = XCNEW (gfc_code);
*c = new_st;
c->loc = gfc_current_locus;
@@ -2235,9 +2234,7 @@ match_simple_forall (void)
new_st.op = EXEC_FORALL;
new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
- new_st.block = gfc_get_code ();
-
- new_st.block->op = EXEC_FORALL;
+ new_st.block = gfc_get_code (EXEC_FORALL);
new_st.block->next = c;
return MATCH_YES;
@@ -2302,7 +2299,7 @@ gfc_match_forall (gfc_statement *st)
goto syntax;
}
- c = gfc_get_code ();
+ c = XCNEW (gfc_code);
*c = new_st;
c->loc = gfc_current_locus;
@@ -2310,8 +2307,7 @@ gfc_match_forall (gfc_statement *st)
new_st.op = EXEC_FORALL;
new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
- new_st.block = gfc_get_code ();
- new_st.block->op = EXEC_FORALL;
+ new_st.block = gfc_get_code (EXEC_FORALL);
new_st.block->next = c;
*st = ST_FORALL;
@@ -3283,15 +3279,14 @@ gfc_match_goto (void)
goto cleanup;
if (head == NULL)
- head = tail = gfc_get_code ();
+ head = tail = gfc_get_code (EXEC_GOTO);
else
{
- tail->block = gfc_get_code ();
+ tail->block = gfc_get_code (EXEC_GOTO);
tail = tail->block;
}
tail->label1 = label;
- tail->op = EXEC_GOTO;
}
while (gfc_match_char (',') == MATCH_YES);
@@ -3328,10 +3323,10 @@ gfc_match_goto (void)
goto cleanup;
if (head == NULL)
- head = tail = gfc_get_code ();
+ head = tail = gfc_get_code (EXEC_SELECT);
else
{
- tail->block = gfc_get_code ();
+ tail->block = gfc_get_code (EXEC_SELECT);
tail = tail->block;
}
@@ -3339,11 +3334,9 @@ gfc_match_goto (void)
cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
NULL, i++);
- tail->op = EXEC_SELECT;
tail->ext.block.case_list = cp;
- tail->next = gfc_get_code ();
- tail->next->op = EXEC_GOTO;
+ tail->next = gfc_get_code (EXEC_GOTO);
tail->next->label1 = label;
}
while (gfc_match_char (',') == MATCH_YES);
@@ -3800,14 +3793,16 @@ gfc_match_nullify (void)
/* Chain to list. */
if (tail == NULL)
- tail = &new_st;
+ {
+ tail = &new_st;
+ tail->op = EXEC_POINTER_ASSIGN;
+ }
else
{
- tail->next = gfc_get_code ();
+ tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
tail = tail->next;
}
- tail->op = EXEC_POINTER_ASSIGN;
tail->expr1 = p;
tail->expr2 = e;
@@ -4188,7 +4183,10 @@ gfc_match_call (void)
i = 0;
for (a = arglist; a; a = a->next)
if (a->expr == NULL)
- i = 1;
+ {
+ i = 1;
+ break;
+ }
if (i)
{
@@ -4196,8 +4194,7 @@ gfc_match_call (void)
gfc_symbol *select_sym;
char name[GFC_MAX_SYMBOL_LEN + 1];
- new_st.next = c = gfc_get_code ();
- c->op = EXEC_SELECT;
+ new_st.next = c = gfc_get_code (EXEC_SELECT);
sprintf (name, "_result_%s", sym->name);
gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
@@ -4222,17 +4219,15 @@ gfc_match_call (void)
i++;
- c->block = gfc_get_code ();
+ c->block = gfc_get_code (EXEC_SELECT);
c = c->block;
- c->op = EXEC_SELECT;
new_case = gfc_get_case ();
new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
new_case->low = new_case->high;
c->ext.block.case_list = new_case;
- c->next = gfc_get_code ();
- c->next->op = EXEC_GOTO;
+ c->next = gfc_get_code (EXEC_GOTO);
c->next->label1 = a->label;
}
}
@@ -5098,7 +5093,6 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
- int i;
assoc_sym = associate->symtree->n.sym;
@@ -5109,9 +5103,8 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
while (ref && ref->next)
ref = ref->next;
- if (selector->ts.type == BT_CLASS
- && CLASS_DATA (selector)->as
- && ref && ref->type == REF_ARRAY)
+ if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
+ && ref && ref->type == REF_ARRAY)
{
/* Ensure that the array reference type is set. We cannot use
gfc_resolve_expr at this point, so the usable parts of
@@ -5119,7 +5112,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
if (ref->u.ar.type == AR_UNKNOWN)
{
ref->u.ar.type = AR_ELEMENT;
- for (i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+ for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR
|| (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
@@ -5138,37 +5131,19 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
selector->rank = 0;
}
- if (selector->ts.type != BT_CLASS)
+ if (selector->rank)
{
- /* The correct class container has to be available. */
- if (selector->rank)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = selector->rank;
- assoc_sym->as->type = AS_DEFERRED;
- }
- else
- assoc_sym->as = NULL;
-
- assoc_sym->ts.type = BT_CLASS;
- assoc_sym->ts.u.derived = selector->ts.u.derived;
- assoc_sym->attr.pointer = 1;
- gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
- &assoc_sym->as, false);
+ assoc_sym->attr.dimension = 1;
+ assoc_sym->as = gfc_get_array_spec ();
+ assoc_sym->as->rank = selector->rank;
+ assoc_sym->as->type = AS_DEFERRED;
}
else
+ assoc_sym->as = NULL;
+
+ if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
- if (selector->rank)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = selector->rank;
- assoc_sym->as->type = AS_DEFERRED;
- }
- else
- assoc_sym->as = NULL;
assoc_sym->ts.type = BT_CLASS;
assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
assoc_sym->attr.pointer = 1;
@@ -5636,12 +5611,10 @@ match_simple_where (void)
if (gfc_match_eos () != MATCH_YES)
goto syntax;
- c = gfc_get_code ();
-
- c->op = EXEC_WHERE;
+ c = gfc_get_code (EXEC_WHERE);
c->expr1 = expr;
- c->next = gfc_get_code ();
+ c->next = XCNEW (gfc_code);
*c->next = new_st;
gfc_clear_new_st ();
@@ -5696,12 +5669,10 @@ gfc_match_where (gfc_statement *st)
/* We've got a simple WHERE statement. */
*st = ST_WHERE;
- c = gfc_get_code ();
-
- c->op = EXEC_WHERE;
+ c = gfc_get_code (EXEC_WHERE);
c->expr1 = expr;
- c->next = gfc_get_code ();
+ c->next = XCNEW (gfc_code);
*c->next = new_st;
gfc_clear_new_st ();
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 865f8365cfc..6c4dccbed10 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -847,7 +847,7 @@ resolve_omp_clauses (gfc_code *code)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
n->sym->mark = 0;
- if (n->sym->attr.flavor == FL_VARIABLE)
+ if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer)
continue;
if (n->sym->attr.flavor == FL_PROCEDURE
&& n->sym->result == n->sym
@@ -876,8 +876,6 @@ resolve_omp_clauses (gfc_code *code)
if (el)
continue;
}
- if (n->sym->attr.proc_pointer)
- continue;
}
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
&code->loc);
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 908b47e68bb..3a9c508dc27 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -109,6 +109,7 @@ gfc_init_options (unsigned int decoded_options_count,
gfc_option.warn_align_commons = 1;
gfc_option.warn_real_q_constant = 0;
gfc_option.warn_unused_dummy_argument = 0;
+ gfc_option.warn_zerotrip = 0;
gfc_option.warn_realloc_lhs = 0;
gfc_option.warn_realloc_lhs_all = 0;
gfc_option.warn_compare_reals = 0;
@@ -466,6 +467,7 @@ set_Wall (int setting)
gfc_option.warn_real_q_constant = setting;
gfc_option.warn_unused_dummy_argument = setting;
gfc_option.warn_target_lifetime = setting;
+ gfc_option.warn_zerotrip = setting;
warn_return_type = setting;
warn_uninitialized = setting;
@@ -747,6 +749,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
gfc_option.warn_unused_dummy_argument = value;
break;
+ case OPT_Wzerotrip:
+ gfc_option.warn_zerotrip = value;
+ break;
+
case OPT_fall_intrinsics:
gfc_option.flag_all_intrinsics = 1;
break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 737f3d61889..512babfd450 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1095,7 +1095,7 @@ new_level (gfc_code *q)
{
gfc_code *p;
- p = q->block = gfc_get_code ();
+ p = q->block = gfc_get_code (EXEC_NOP);
gfc_state_stack->head = gfc_state_stack->tail = p;
@@ -1111,7 +1111,7 @@ add_statement (void)
{
gfc_code *p;
- p = gfc_get_code ();
+ p = XCNEW (gfc_code);
*p = new_st;
p->loc = gfc_current_locus;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c3487881631..2929679aecc 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -60,7 +60,7 @@ static code_stack *cs_base = NULL;
/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag;
-static int do_concurrent_flag;
+int gfc_do_concurrent_flag;
/* True when we are resolving an expression that is an actual argument to
a procedure. */
@@ -723,8 +723,7 @@ resolve_entries (gfc_namespace *ns)
el = ns->entries;
/* Add an entry statement for it. */
- c = gfc_get_code ();
- c->op = EXEC_ENTRY;
+ c = gfc_get_code (EXEC_ENTRY);
c->ext.entry = el;
c->next = ns->code;
ns->code = c;
@@ -2987,11 +2986,11 @@ resolve_function (gfc_expr *expr)
forall_flag == 2 ? "mask" : "block");
t = false;
}
- else if (do_concurrent_flag)
+ else if (gfc_do_concurrent_flag)
{
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"DO CONCURRENT %s", name, &expr->where,
- do_concurrent_flag == 2 ? "mask" : "block");
+ gfc_do_concurrent_flag == 2 ? "mask" : "block");
t = false;
}
else if (gfc_pure (NULL))
@@ -3060,7 +3059,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc);
- else if (do_concurrent_flag)
+ else if (gfc_do_concurrent_flag)
gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
@@ -4908,7 +4907,10 @@ resolve_variable (gfc_expr *e)
for (formal = entry->sym->formal; formal; formal = formal->next)
{
if (formal->sym && sym->name == formal->sym->name)
- seen = true;
+ {
+ seen = true;
+ break;
+ }
}
/* If it has not been seen as a dummy, this is an error. */
@@ -6279,8 +6281,10 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
sgn = mpfr_sgn (iter->step->value.real);
cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
}
- if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
- gfc_warning ("DO loop at %L will be executed zero times",
+ if (gfc_option.warn_zerotrip &&
+ ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
+ gfc_warning ("DO loop at %L will be executed zero times"
+ " (use -Wno-zerotrip to suppress)",
&iter->step->where);
}
@@ -6877,9 +6881,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
{
- gfc_code *init_st = gfc_get_code ();
+ gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN);
init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
init_st->expr1 = gfc_expr_to_initialize (e);
init_st->expr2 = init_e;
init_st->next = code->next;
@@ -8017,8 +8020,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
code->ext.block.assoc = NULL;
/* Add EXEC_SELECT to switch on type. */
- new_st = gfc_get_code ();
- new_st->op = code->op;
+ new_st = gfc_get_code (code->op);
new_st->expr1 = code->expr1;
new_st->expr2 = code->expr2;
new_st->block = code->block;
@@ -8084,8 +8086,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
gfc_add_data_component (st->n.sym->assoc->target);
- new_st = gfc_get_code ();
- new_st->op = EXEC_BLOCK;
+ new_st = gfc_get_code (EXEC_BLOCK);
new_st->ext.block.ns = gfc_build_block_ns (ns);
new_st->ext.block.ns->code = body->next;
body->next = new_st;
@@ -8136,9 +8137,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
/* Add a default case to hold the CLASS IS cases. */
for (tail = code; tail->block; tail = tail->block) ;
- tail->block = gfc_get_code ();
+ tail->block = gfc_get_code (EXEC_SELECT_TYPE);
tail = tail->block;
- tail->op = EXEC_SELECT_TYPE;
tail->ext.block.case_list = gfc_get_case ();
tail->ext.block.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
@@ -8181,14 +8181,12 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
}
/* Generate IF chain. */
- if_st = gfc_get_code ();
- if_st->op = EXEC_IF;
+ if_st = gfc_get_code (EXEC_IF);
new_st = if_st;
for (body = class_is; body; body = body->block)
{
- new_st->block = gfc_get_code ();
+ new_st->block = gfc_get_code (EXEC_IF);
new_st = new_st->block;
- new_st->op = EXEC_IF;
/* Set up IF condition: Call _gfortran_is_extension_of. */
new_st->expr1 = gfc_get_expr ();
new_st->expr1->expr_type = EXPR_FUNCTION;
@@ -8210,9 +8208,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
}
if (default_case->next)
{
- new_st->block = gfc_get_code ();
+ new_st->block = gfc_get_code (EXEC_IF);
new_st = new_st->block;
- new_st->op = EXEC_IF;
new_st->next = default_case->next;
}
@@ -9238,8 +9235,7 @@ build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
{
gfc_code *this_code;
- this_code = gfc_get_code ();
- this_code->op = op;
+ this_code = gfc_get_code (op);
this_code->next = NULL;
this_code->expr1 = gfc_copy_expr (expr1);
this_code->expr2 = gfc_copy_expr (expr2);
@@ -9633,7 +9629,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
{
frame.current = code;
forall_save = forall_flag;
- do_concurrent_save = do_concurrent_flag;
+ do_concurrent_save = gfc_do_concurrent_flag;
if (code->op == EXEC_FORALL)
{
@@ -9667,9 +9663,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_DO_CONCURRENT:
- do_concurrent_flag = 1;
+ gfc_do_concurrent_flag = 1;
gfc_resolve_blocks (code->block, ns);
- do_concurrent_flag = 2;
+ gfc_do_concurrent_flag = 2;
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
@@ -9688,7 +9684,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
forall_flag = forall_save;
- do_concurrent_flag = do_concurrent_save;
+ gfc_do_concurrent_flag = do_concurrent_save;
if (!gfc_resolve_expr (code->expr2))
t = false;
@@ -10278,13 +10274,12 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
lval = gfc_lval_expr_from_sym (sym);
/* Add the code at scope entry. */
- init_st = gfc_get_code ();
+ init_st = gfc_get_code (EXEC_INIT_ASSIGN);
init_st->next = ns->code;
ns->code = init_st;
/* Assign the default initializer to the l-value. */
init_st->loc = sym->declared_at;
- init_st->op = EXEC_INIT_ASSIGN;
init_st->expr1 = lval;
init_st->expr2 = init;
}
@@ -14409,7 +14404,7 @@ resolve_types (gfc_namespace *ns)
}
forall_flag = 0;
- do_concurrent_flag = 0;
+ gfc_do_concurrent_flag = 0;
gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values);
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 836dac790a2..f8b341c0b6c 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -41,14 +41,16 @@ gfc_clear_new_st (void)
}
-/* Get a gfc_code structure. */
+/* Get a gfc_code structure, initialized with the current locus
+ and a statement code 'op'. */
gfc_code *
-gfc_get_code (void)
+gfc_get_code (gfc_exec_op op)
{
gfc_code *c;
c = XCNEW (gfc_code);
+ c->op = op;
c->loc = gfc_current_locus;
return c;
}
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index c72974dc003..9d23e8b48a3 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4489,6 +4489,9 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
if (is_derived1 && is_derived2)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+ if (is_derived1 && is_class2)
+ return gfc_compare_derived_types (ts1->u.derived,
+ ts2->u.derived->components->ts.u.derived);
if (is_class1 && is_derived2)
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
ts2->u.derived);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c269ea8bbf1..5a3cf80f9f6 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3715,7 +3715,7 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
/* Calculate the lower bound of an array section. */
static void
-gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
+gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
{
gfc_expr *stride = NULL;
tree desc;
@@ -3744,12 +3744,12 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
- evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
+ evaluate_bound (block, info->start, ar->start, desc, dim, true);
/* Similarly calculate the end. Although this is not used in the
scalarizer, it is needed when checking bounds and where the end
is an expression with side-effects. */
- evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
+ evaluate_bound (block, info->end, ar->end, desc, dim, false);
/* Calculate the stride. */
if (stride == NULL)
@@ -3758,8 +3758,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre);
+ gfc_add_block_to_block (block, &se.pre);
+ info->stride[dim] = gfc_evaluate_now (se.expr, block);
}
}
@@ -3776,6 +3776,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
gfc_ss *ss;
tree desc;
+ gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
loop->dimen = 0;
/* Determine the rank of the loop. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
@@ -3835,10 +3837,11 @@ done:
/* Get the descriptor for the array. If it is a cross loops array,
we got the descriptor already in the outermost loop. */
if (ss->parent == NULL)
- gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
+ gfc_conv_ss_descriptor (&outer_loop->pre, ss,
+ !loop->array_parameter);
for (n = 0; n < ss->dimen; n++)
- gfc_conv_section_startstride (loop, ss, ss->dim[n]);
+ gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
break;
case GFC_SS_INTRINSIC:
@@ -3874,7 +3877,7 @@ done:
fold_convert (gfc_array_index_type,
rank),
gfc_index_one_node);
- info->end[0] = gfc_evaluate_now (tmp, &loop->pre);
+ info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
info->start[0] = gfc_index_zero_node;
info->stride[0] = gfc_index_one_node;
continue;
@@ -4156,7 +4159,7 @@ done:
}
tmp = gfc_finish_block (&block);
- gfc_add_expr_to_block (&loop->pre, tmp);
+ gfc_add_expr_to_block (&outer_loop->pre, tmp);
}
for (loop = loop->nested; loop; loop = loop->next)
@@ -4439,6 +4442,8 @@ set_loop_bounds (gfc_loopinfo *loop)
mpz_t i;
bool nonoptional_arr;
+ gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
loopspec = loop->specloop;
mpz_init (i);
@@ -4456,7 +4461,10 @@ set_loop_bounds (gfc_loopinfo *loop)
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
&& ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
- nonoptional_arr = true;
+ {
+ nonoptional_arr = true;
+ break;
+ }
/* We use one SS term, and use that to determine the bounds of the
loop for this dimension. We try to pick the simplest term. */
@@ -4624,7 +4632,7 @@ set_loop_bounds (gfc_loopinfo *loop)
else
{
/* Set the delta for this section. */
- info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
+ info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
/* Number of iterations is (end - start + step) / step.
with start = 0, this simplifies to
last = end / step;
@@ -4636,7 +4644,7 @@ set_loop_bounds (gfc_loopinfo *loop)
gfc_array_index_type, tmp, info->stride[dim]);
tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
tmp, build_int_cst (gfc_array_index_type, -1));
- loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
+ loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
/* Make the loop variable start at 0. */
loop->from[n] = gfc_index_zero_node;
}
@@ -4712,6 +4720,8 @@ gfc_set_delta (gfc_loopinfo *loop)
tree tmp;
int n, dim;
+ gfc_loopinfo * const outer_loop = outermost_loop (loop);
+
loopspec = loop->specloop;
/* Calculate the translation from loop variables to array indices. */
@@ -4747,7 +4757,7 @@ gfc_set_delta (gfc_loopinfo *loop)
gfc_array_index_type,
info->start[dim], tmp);
- info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre);
+ info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
}
}
}
@@ -6724,10 +6734,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
/* Make sure the call to gfc_conv_section_startstride won't
- generate unnecessary code to calculate stride. */
+ generate unnecessary code to calculate stride. */
gcc_assert (ar->stride[n + ndim] == NULL);
- gfc_conv_section_startstride (&loop, ss, n + ndim);
+ gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
loop.from[n + loop.dimen] = info->start[n + ndim];
loop.to[n + loop.dimen] = info->end[n + ndim];
}
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2916b4cc52e..c2c736e1c66 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1491,14 +1491,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
SAVE is specified otherwise they need to be reinitialized
every time the procedure is entered. The TREE_STATIC is
in this case due to -fmax-stack-var-size=. */
+
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl),
- sym->attr.dimension
- || (sym->attr.codimension
- && sym->attr.allocatable),
- sym->attr.pointer
- || sym->attr.allocatable,
- sym->attr.proc_pointer);
+ TREE_TYPE (decl), sym->attr.dimension
+ || (sym->attr.codimension
+ && sym->attr.allocatable),
+ sym->attr.pointer || sym->attr.allocatable
+ || sym->ts.type == BT_CLASS,
+ sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)
@@ -4745,7 +4745,8 @@ generate_local_decl (gfc_symbol * sym)
gfc_warning ("Dummy argument '%s' at %L was declared "
"INTENT(OUT) but was not set", sym->name,
&sym->declared_at);
- else if (!gfc_has_default_initializer (sym->ts.u.derived))
+ else if (!gfc_has_default_initializer (sym->ts.u.derived)
+ && !sym->ts.u.derived->attr.zero_comp)
gfc_warning ("Derived-type dummy argument '%s' at %L was "
"declared INTENT(OUT) but was not set and "
"does not have a default initializer",
@@ -5643,14 +5644,16 @@ gfc_generate_function_code (gfc_namespace * ns)
}
current_function_decl = old_context;
- if (decl_function_context (fndecl) && gfc_option.coarray != GFC_FCOARRAY_LIB
- && has_coarray_vars)
- /* Register this function with cgraph just far enough to get it
- added to our parent's nested function list.
- If there are static coarrays in this function, the nested _caf_init
- function has already called cgraph_create_node, which also created
- the cgraph node for this function. */
- (void) cgraph_create_node (fndecl);
+ if (decl_function_context (fndecl))
+ {
+ /* Register this function with cgraph just far enough to get it
+ added to our parent's nested function list.
+ If there are static coarrays in this function, the nested _caf_init
+ function has already called cgraph_create_node, which also created
+ the cgraph node for this function. */
+ if (!has_coarray_vars || gfc_option.coarray != GFC_FCOARRAY_LIB)
+ (void) cgraph_create_node (fndecl);
+ }
else
cgraph_finalize_function (fndecl, true);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e0cdd49dfa2..0ecfdfce469 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -895,14 +895,13 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
ppc = gfc_copy_expr (obj);
gfc_add_vptr_component (ppc);
gfc_add_component_ref (ppc, "_copy");
- ppc_code = gfc_get_code ();
+ ppc_code = gfc_get_code (EXEC_CALL);
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
- ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
@@ -1043,7 +1042,7 @@ assign_vptr:
gfc_add_data_component (expr2);
goto assign;
}
- else if (CLASS_DATA (expr2)->attr.dimension)
+ else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
@@ -1061,9 +1060,10 @@ assign_vptr:
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS
- && !CLASS_DATA (expr2)->attr.dimension)
+ && !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
- else
+ else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
+ || !CLASS_DATA (expr2)->attr.dimension)
gfc_add_data_component (expr1);
assign:
@@ -5663,7 +5663,15 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
else if (pointer || procptr)
{
- if (!expr || expr->expr_type == EXPR_NULL)
+ if (ts->type == BT_CLASS && !procptr)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+ gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+ TREE_STATIC (se.expr) = 1;
+ return se.expr;
+ }
+ else if (!expr || expr->expr_type == EXPR_NULL)
return fold_convert (type, null_pointer_node);
else
{
@@ -5682,7 +5690,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
case BT_CLASS:
gfc_init_se (&se, NULL);
if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
- gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
+ gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
else
gfc_conv_structure (&se, expr, 1);
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
@@ -5992,7 +6000,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_class_null_initializer (&cm->ts, expr));
+ gfc_class_initializer (&cm->ts, expr));
gfc_add_expr_to_block (&block, tmp);
}
else if (cm->attr.dimension && !cm->attr.proc_pointer)
@@ -6417,6 +6425,7 @@ gfc_trans_pointer_assign (gfc_code * code)
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
+ gfc_expr *expr1_vptr = NULL;
gfc_se lse;
gfc_se rse;
stmtblock_t block;
@@ -6437,6 +6446,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (!scalar)
gfc_free_ss_chain (ss);
+ if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
+ && expr2->expr_type != EXPR_FUNCTION)
+ {
+ gfc_add_data_component (expr2);
+ /* The following is required as gfc_add_data_component doesn't
+ update ts.type if there is a tailing REF_ARRAY. */
+ expr2->ts.type = BT_DERIVED;
+ }
+
if (scalar)
{
/* Scalar pointers. */
@@ -6485,8 +6503,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0));
}
+ if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
+ rse.expr = gfc_class_data_get (rse.expr);
+
gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), rse.expr));
+ fold_convert (TREE_TYPE (lse.expr), rse.expr));
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
@@ -6508,8 +6529,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
break;
rank_remap = (remap && remap->u.ar.end[0]);
+ gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
+ if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
+ && expr1->ts.type == BT_CLASS)
+ expr1_vptr = gfc_copy_expr (expr1);
gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
@@ -6526,8 +6551,51 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL);
rse.direct_byref = 1;
rse.byref_noassign = 1;
- gfc_conv_expr_descriptor (&rse, expr2);
- strlen_rhs = rse.string_length;
+
+ if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+ {
+ gfc_conv_function_expr (&rse, expr2);
+
+ if (expr1->ts.type != BT_CLASS)
+ rse.expr = gfc_class_data_get (rse.expr);
+ else
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+ gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+ gfc_add_vptr_component (expr1_vptr);
+ gfc_init_se (&rse, NULL);
+ rse.want_pointer = 1;
+ gfc_conv_expr (&rse, expr1_vptr);
+ gfc_add_modify (&lse.pre, rse.expr,
+ fold_convert (TREE_TYPE (rse.expr),
+ gfc_class_vptr_get (tmp)));
+ rse.expr = gfc_class_data_get (tmp);
+ }
+ }
+ else if (expr2->expr_type == EXPR_FUNCTION)
+ {
+ tree bound[GFC_MAX_DIMENSIONS];
+ int i;
+
+ for (i = 0; i < expr2->rank; i++)
+ bound[i] = NULL_TREE;
+ tmp = gfc_typenode_for_spec (&expr2->ts);
+ tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
+ bound, bound, 0,
+ GFC_ARRAY_POINTER_CONT, false);
+ tmp = gfc_create_var (tmp, "ptrtemp");
+ lse.expr = tmp;
+ lse.direct_byref = 1;
+ gfc_conv_expr_descriptor (&lse, expr2);
+ strlen_rhs = lse.string_length;
+ rse.expr = tmp;
+ }
+ else
+ {
+ gfc_conv_expr_descriptor (&rse, expr2);
+ strlen_rhs = rse.string_length;
+ }
}
else if (expr2->expr_type == EXPR_VARIABLE)
{
@@ -6551,12 +6619,37 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
}
+ else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+ {
+ gfc_init_se (&rse, NULL);
+ rse.want_pointer = 1;
+ gfc_conv_function_expr (&rse, expr2);
+ if (expr1->ts.type != BT_CLASS)
+ {
+ rse.expr = gfc_class_data_get (rse.expr);
+ gfc_add_modify (&lse.pre, desc, rse.expr);
+ }
+ else
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
+ gfc_add_modify (&lse.pre, tmp, rse.expr);
+
+ gfc_add_vptr_component (expr1_vptr);
+ gfc_init_se (&rse, NULL);
+ rse.want_pointer = 1;
+ gfc_conv_expr (&rse, expr1_vptr);
+ gfc_add_modify (&lse.pre, rse.expr,
+ fold_convert (TREE_TYPE (rse.expr),
+ gfc_class_vptr_get (tmp)));
+ rse.expr = gfc_class_data_get (tmp);
+ gfc_add_modify (&lse.pre, desc, rse.expr);
+ }
+ }
else
{
/* Assign to a temporary descriptor and then copy that
temporary to the pointer. */
tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
-
lse.expr = tmp;
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2);
@@ -6564,6 +6657,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.pre, desc, tmp);
}
+ if (expr1_vptr)
+ gfc_free_expr (expr1_vptr);
+
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
@@ -7642,6 +7738,105 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
}
}
+/* Check for assignments of the type
+
+ a = a + 4
+
+ to make sure we do not check for reallocation unneccessarily. */
+
+
+static bool
+is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
+{
+ gfc_actual_arglist *a;
+ gfc_expr *e1, *e2;
+
+ switch (expr2->expr_type)
+ {
+ case EXPR_VARIABLE:
+ return gfc_dep_compare_expr (expr1, expr2) == 0;
+
+ case EXPR_FUNCTION:
+ if (expr2->value.function.esym
+ && expr2->value.function.esym->attr.elemental)
+ {
+ for (a = expr2->value.function.actual; a != NULL; a = a->next)
+ {
+ e1 = a->expr;
+ if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+ return false;
+ }
+ return true;
+ }
+ else if (expr2->value.function.isym
+ && expr2->value.function.isym->elemental)
+ {
+ for (a = expr2->value.function.actual; a != NULL; a = a->next)
+ {
+ e1 = a->expr;
+ if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+ return false;
+ }
+ return true;
+ }
+
+ break;
+
+ case EXPR_OP:
+ switch (expr2->value.op.op)
+ {
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ return is_runtime_conformable (expr1, expr2->value.op.op1);
+
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_POWER:
+ case INTRINSIC_AND:
+ case INTRINSIC_OR:
+ case INTRINSIC_EQV:
+ case INTRINSIC_NEQV:
+ case INTRINSIC_EQ:
+ case INTRINSIC_NE:
+ case INTRINSIC_GT:
+ case INTRINSIC_GE:
+ case INTRINSIC_LT:
+ case INTRINSIC_LE:
+ case INTRINSIC_EQ_OS:
+ case INTRINSIC_NE_OS:
+ case INTRINSIC_GT_OS:
+ case INTRINSIC_GE_OS:
+ case INTRINSIC_LT_OS:
+ case INTRINSIC_LE_OS:
+
+ e1 = expr2->value.op.op1;
+ e2 = expr2->value.op.op2;
+
+ if (e1->rank == 0 && e2->rank > 0)
+ return is_runtime_conformable (expr1, e2);
+ else if (e1->rank > 0 && e2->rank == 0)
+ return is_runtime_conformable (expr1, e1);
+ else if (e1->rank > 0 && e2->rank > 0)
+ return is_runtime_conformable (expr1, e1)
+ && is_runtime_conformable (expr1, e2);
+ break;
+
+ default:
+ break;
+
+ }
+
+ break;
+
+ default:
+ break;
+ }
+ return false;
+}
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
@@ -7839,7 +8034,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
&& !gfc_is_coindexed (expr1)
- && expr2->rank)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2))
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3fbf193d03c..6b85b5b78db 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5652,8 +5652,7 @@ scalar_transfer:
if (expr->ts.type == BT_CHARACTER)
{
- tree direct;
- tree indirect;
+ tree direct, indirect, free;
ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
@@ -5686,6 +5685,13 @@ scalar_transfer:
tmp = build3_v (COND_EXPR, tmp, direct, indirect);
gfc_add_expr_to_block (&se->pre, tmp);
+ /* Free the temporary string, if necessary. */
+ free = gfc_call_free (tmpdecl);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ dest_word_len, source_bytes);
+ tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
se->expr = tmpdecl;
se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
}
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index d60d15faf28..ec17dc97c21 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2260,7 +2260,10 @@ gfc_trans_transfer (gfc_code * code)
{
for (n = 0; n < ref->u.ar.dimen; n++)
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
- seen_vector = true;
+ {
+ seen_vector = true;
+ break;
+ }
}
if (seen_vector && last_dt == READ)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index e2d0110ba96..edd2dacf579 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5232,14 +5232,13 @@ gfc_trans_allocate (gfc_code * code)
(gfc_find_intrinsic_vtab (&rhs->ts));
gfc_add_component_ref (ppc, "_copy");
- ppc_code = gfc_get_code ();
+ ppc_code = gfc_get_code (EXEC_CALL);
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
- ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
View Lorry Controller Status