summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorYvan Roux <yvan.roux@linaro.org>2016-10-16 20:12:52 +0200
committerYvan Roux <yvan.roux@linaro.org>2016-10-16 20:12:52 +0200
commit493a6a7da66b065821b3a22446968b272b5c45bc (patch)
tree3984391651c53c8a35beebf2446111c0dfb5d72a /gcc/fortran
parentfe89a30c89f79a4ddbb0c22c4ceaf6a1b2e34197 (diff)
downloadgcc-493a6a7da66b065821b3a22446968b272b5c45bc.tar.gz
Merge branches/gcc-6-branch rev 241214.
Change-Id: I2fc7e5fc01a9015199e9be293b8a7b503fd5a829
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog166
-rw-r--r--gcc/fortran/array.c20
-rw-r--r--gcc/fortran/check.c11
-rw-r--r--gcc/fortran/class.c14
-rw-r--r--gcc/fortran/decl.c27
-rw-r--r--gcc/fortran/dependency.c9
-rw-r--r--gcc/fortran/frontend-passes.c8
-rw-r--r--gcc/fortran/interface.c27
-rw-r--r--gcc/fortran/intrinsic.c7
-rw-r--r--gcc/fortran/io.c2
-rw-r--r--gcc/fortran/openmp.c33
-rw-r--r--gcc/fortran/parse.c13
-rw-r--r--gcc/fortran/resolve.c93
-rw-r--r--gcc/fortran/simplify.c18
-rw-r--r--gcc/fortran/target-memory.c23
-rw-r--r--gcc/fortran/target-memory.h2
-rw-r--r--gcc/fortran/trans-common.c21
-rw-r--r--gcc/fortran/trans-decl.c16
-rw-r--r--gcc/fortran/trans-openmp.c25
19 files changed, 445 insertions, 90 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 335ca6b956b..15e6ea2505b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,169 @@
+2016-10-11 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/77942
+ * simplify.c (gfc_simplify_cshift): Check for zero.
+
+2016-10-07 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/77406
+ * interface.c (gfc_compare_interfaces): Fix detection of ambiguous
+ interface involving alternate return.
+ (check_interface1): Improve error message and loci.
+
+2016-10-05 Steven G. Kargl <kargls@gcc.gnu.org>
+
+ PR fortran/58991
+ PR fortran/58992
+ * resolve.c (resolve_assoc_var): Fix CHARACTER type-spec for a
+ selector in ASSOCIATE.
+ (resolve_fl_variable): Skip checks for an ASSOCIATE variable.
+
+2016-09-28 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/41922
+ * target-memory.c (expr_to_char): Pass in locus and use it in error
+ messages.
+ (gfc_merge_initializers): Ditto.
+ * target-memory.h: Update prototype for gfc_merge_initializers ().
+ * trans-common.c (get_init_field): Use the correct locus.
+
+ PR fortran/60774
+ * parse.c (next_free,next_fixed): Issue error for statement label
+ without a statement.
+
+ PR fortran/61318
+ * interface.c (compare_parameter): Use better locus for error message.
+
+ PR fortran/68566
+ * check.c (gfc_check_reshape): Check for constant expression.
+
+ PR fortran/69514
+ * array.c (gfc_match_array_constructor): If type-spec is present,
+ walk the array constructor performing possible conversions for
+ numeric types.
+
+ PR fortran/69867
+ * decl.c (build_struct): Ensure that pointers point to something.
+
+ PR fortran/69962
+ * decl.c (gfc_set_constant_character_len): if expr is not
+ constant issue an error instead of an ICE.
+
+ PR fortran/70006
+ * io.c (gfc_resolve_dt): Use correct locus.
+ * resolve.c (resolve_branch): Ditto.
+
+ PR fortran/71067
+ * decl.c (match_data_constant): On error, set 'result' to NULL.
+
+ PR fortran/71730
+ * decl.c (char_len_param_value): Check return value of
+ gfc_reduce_init_expr().
+
+ PR fortran/71799
+ * resolve.c(gfc_resolve_iterator): Failure of type conversion need
+ not ICE.
+
+ PR fortran/71859
+ * check.c(numeric_check): Prevent ICE. Issue error for invalid
+ subroutine as an actual argument when numeric argument is expected.
+
+ PR fortran/71862
+ * class.c: Remove assert. Iterate over component only if non-null.
+
+ PR fortran/77260
+ * gcc/fortran/trans-decl.c (generate_local_decl): Suppress warning
+ for unused variable if symbol is entry point.
+
+ PR fortran/77351
+ * frontend-passes.c (remove_trim,combine_array_constructor): Check for
+ NULL pointer.
+
+ PR fortran/77372
+ simplify.c (simplify_ieee_selected_real_kind): Check for NULL pointers.
+
+ PR fortran/77380
+ * dependency.c (gfc_check_dependency): Do not assert with
+ -fcoarray=lib.
+
+ PR fortran/77391
+ * resolve.c (deferred_requirements): New function to check F2008:C402.
+ (resolve_fl_variable,resolve_fl_parameter): Use it.
+
+ PR fortran/77420
+ * trans-common.c: Handle array elements in equivalence when
+ the lower and upper bounds of array spec are NULL.
+
+ PR fortran/77429
+ * dependency.c (gfc_check_dependency): Convert gcc_assert() to
+ a conditional and possible call to gfc_internal_error().
+
+ PR fortran/77460
+ * simplify.c (simplify_transformation_to_scalar): On error, result
+ may be NULL, simply return.
+
+ PR fortran/77506
+ * array.c (gfc_match_array_constructor): CHARACTER(len=*) cannot
+ appear in an array constructor.
+
+ PR fortran/77507
+ * intrinsic.c (add_functions): Use correct keyword.
+
+ PR fortran/77612
+ * decl.c (char_len_param_value): Check parent namespace for
+ seen_implicit_none.
+
+ PR fortran/77694
+ * frontend-passes.c (optimize_binop_array_assignment): Check pointer
+ for NULL.
+
+2016-09-16 Jakub Jelinek <jakub@redhat.com>
+
+ Backported from mainline
+ 2016-09-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/77500
+ * trans-openmp.c (gfc_trans_omp_atomic): For atomic write or
+ swap, don't try to look through GFC_ISYM_CONVERSION. In other cases,
+ check that value.function.isym is non-NULL before dereferencing it.
+
+2016-09-01 Jakub Jelinek <jakub@redhat.com>
+
+ Backported from mainline
+ 2016-08-31 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/77352
+ * trans-openmp.c (gfc_trans_omp_parallel_workshare): Always add a
+ BIND_EXPR with BLOCK around what gfc_trans_omp_workshare returns.
+
+ PR fortran/77374
+ * parse.c (parse_omp_oacc_atomic): Copy over cp->ext.omp_atomic
+ to cp->block->ext.omp_atomic.
+ * resolve.c (gfc_resolve_blocks): Assert block with one or two
+ EXEC_ASSIGNs for EXEC_*_ATOMIC.
+ * openmp.c (resolve_omp_atomic): Don't assert one or two
+ EXEC_ASSIGNs, instead return quietly for EXEC_NOPs and otherwise
+ error unexpected statements.
+
+ 2016-08-19 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/71014
+ * resolve.c (gfc_resolve): For ns->construct_entities don't save, clear
+ and restore omp state around the resolving.
+
+ PR fortran/69281
+ * trans-openmp.c (gfc_trans_omp_parallel, gfc_trans_omp_task,
+ gfc_trans_omp_target): Wrap gfc_trans_omp_code result in an extra
+ BIND_EXPR with its own forced BLOCK.
+
+2016-08-24 Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/77358
+ * resolve.c (resolve_fl_procedure): Use the correct gfc_charlen
+ for deferred character length module procedures.
+
2016-08-22 Release Manager
* GCC 6.2.0 released.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 1430e80251d..b87e8555972 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1072,6 +1072,7 @@ match_array_cons_element (gfc_constructor_base *result)
match
gfc_match_array_constructor (gfc_expr **result)
{
+ gfc_constructor *c;
gfc_constructor_base head, new_cons;
gfc_undo_change_set changed_syms;
gfc_expr *expr;
@@ -1124,6 +1125,15 @@ gfc_match_array_constructor (gfc_expr **result)
gfc_restore_last_undo_checkpoint ();
goto cleanup;
}
+
+ if (ts.type == BT_CHARACTER
+ && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec)
+ {
+ gfc_error ("Type-spec at %L cannot contain an asterisk for a "
+ "type parameter", &where);
+ gfc_restore_last_undo_checkpoint ();
+ goto cleanup;
+ }
}
}
else if (m == MATCH_ERROR)
@@ -1177,8 +1187,6 @@ done:
be converted. See PR fortran/67803. */
if (ts.type == BT_CHARACTER)
{
- gfc_constructor *c;
-
c = gfc_constructor_first (head);
for (; c; c = gfc_constructor_next (c))
{
@@ -1201,6 +1209,14 @@ done:
}
}
}
+
+ /* Walk the constructor and ensure type conversion for numeric types. */
+ if (gfc_numeric_ts (&ts))
+ {
+ c = gfc_constructor_first (head);
+ for (; c; c = gfc_constructor_next (c))
+ gfc_convert_type (c->expr, &ts, 1);
+ }
}
else
expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index d26e45ec406..80c884738a4 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -72,6 +72,11 @@ type_check (gfc_expr *e, int n, bt type)
static bool
numeric_check (gfc_expr *e, int n)
{
+ /* Users sometime use a subroutine designator as an actual argument to
+ an intrinsic subprogram that expects an argument with a numeric type. */
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+ goto error;
+
if (gfc_numeric_ts (&e->ts))
return true;
@@ -86,7 +91,9 @@ numeric_check (gfc_expr *e, int n)
return true;
}
- gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type",
+error:
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
@@ -3820,7 +3827,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (!type_check (order, 3, BT_INTEGER))
return false;
- if (order->expr_type == EXPR_ARRAY)
+ if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
{
int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
gfc_expr *e;
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 3627828d21f..65e45ad3791 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -238,12 +238,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
/* Avoid losing memory. */
gfc_free_ref_list (*tail);
c = gfc_find_component (derived, name, true, true, tail);
- gcc_assert (c);
- for (ref = *tail; ref->next; ref = ref->next)
- ;
- ref->next = next;
- if (!next)
- e->ts = c->ts;
+
+ if (c) {
+ for (ref = *tail; ref->next; ref = ref->next)
+ ;
+ ref->next = next;
+ if (!next)
+ e->ts = c->ts;
+ }
}
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index da33b226101..333493531c0 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -395,6 +395,7 @@ match_data_constant (gfc_expr **result)
{
gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
name);
+ *result = NULL;
return MATCH_ERROR;
}
else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
@@ -905,6 +906,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
goto syntax;
else if ((*expr)->expr_type == EXPR_VARIABLE)
{
+ bool t;
gfc_expr *e;
e = gfc_copy_expr (*expr);
@@ -916,7 +918,16 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
&& e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
goto syntax;
- gfc_reduce_init_expr (e);
+ t = gfc_reduce_init_expr (e);
+
+ if (!t && e->ts.type == BT_UNKNOWN
+ && e->symtree->n.sym->attr.untyped == 1
+ && (e->symtree->n.sym->ns->seen_implicit_none == 1
+ || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
+ {
+ gfc_free_expr (e);
+ goto syntax;
+ }
if ((e->ref && e->ref->type == REF_ARRAY
&& e->ref->u.ar.type != AR_ELEMENT)
@@ -1485,10 +1496,14 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
gfc_char_t *s;
int slen;
- gcc_assert (expr->expr_type == EXPR_CONSTANT);
-
if (expr->ts.type != BT_CHARACTER)
return;
+
+ if (expr->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
+ return;
+ }
slen = expr->value.character.length;
if (len != slen)
@@ -1912,8 +1927,10 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
if (c->initializer->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, c->initializer, -1);
- else if (mpz_cmp (c->ts.u.cl->length->value.integer,
- c->initializer->ts.u.cl->length->value.integer))
+ else if (c->initializer
+ && c->initializer->ts.u.cl
+ && mpz_cmp (c->ts.u.cl->length->value.integer,
+ c->initializer->ts.u.cl->length->value.integer))
{
gfc_constructor *ctor;
ctor = gfc_constructor_first (c->initializer->value.constructor);
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index f117de03640..12e5d133151 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -1252,7 +1252,14 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
gfc_constructor *c;
int n;
- gcc_assert (expr1->expr_type == EXPR_VARIABLE);
+ /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
+ and a reference to _F.caf_get, so skip the assert. */
+ if (expr1->expr_type == EXPR_FUNCTION
+ && strcmp (expr1->value.function.name, "_F.caf_get") == 0)
+ return 0;
+
+ if (expr1->expr_type != EXPR_VARIABLE)
+ gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
switch (expr2->expr_type)
{
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 1655de2c9f8..60c3a70524a 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -1061,6 +1061,9 @@ optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
{
gfc_expr *e;
+ if (!*rhs)
+ return false;
+
e = *rhs;
if (e->expr_type == EXPR_OP)
{
@@ -1137,6 +1140,8 @@ remove_trim (gfc_expr *rhs)
bool ret;
ret = false;
+ if (!rhs)
+ return ret;
/* Check for a // b // trim(c). Looping is probably not
necessary because the parser usually generates
@@ -1274,6 +1279,9 @@ combine_array_constructor (gfc_expr *e)
op1 = e->value.op.op1;
op2 = e->value.op.op2;
+ if (!op1 || !op2)
+ return false;
+
if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
scalar_first = false;
else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 5bd1279291e..5366aa8c0ad 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1604,14 +1604,23 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
f1 = gfc_sym_get_dummy_args (s1);
f2 = gfc_sym_get_dummy_args (s2);
+ /* Special case: No arguments. */
if (f1 == NULL && f2 == NULL)
- return 1; /* Special case: No arguments. */
+ return 1;
if (generic_flag)
{
if (count_types_test (f1, f2, p1, p2)
|| count_types_test (f2, f1, p2, p1))
return 0;
+
+ /* Special case: alternate returns. If both f1->sym and f2->sym are
+ NULL, then the leading formal arguments are alternate returns.
+ The previous conditional should catch argument lists with
+ different number of argument. */
+ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
+ return 1;
+
if (generic_correspondence (f1, f2, p1, p2)
|| generic_correspondence (f2, f1, p2, p1))
return 0;
@@ -1779,13 +1788,15 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
generic_flag, 0, NULL, 0, NULL, NULL))
{
if (referenced)
- gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
- p->sym->name, q->sym->name, interface_name,
- &p->where);
+ gfc_error ("Ambiguous interfaces in %s for %qs at %L "
+ "and %qs at %L", interface_name,
+ q->sym->name, &q->sym->declared_at,
+ p->sym->name, &p->sym->declared_at);
else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
- gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
- p->sym->name, q->sym->name, interface_name,
- &p->where);
+ gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
+ "and %qs at %L", interface_name,
+ q->sym->name, &q->sym->declared_at,
+ p->sym->name, &p->sym->declared_at);
else
gfc_warning (0, "Although not referenced, %qs has ambiguous "
"interfaces at %L", interface_name, &p->where);
@@ -2146,7 +2157,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
if (where)
gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
- formal->name, &actual->where, gfc_typename (&actual->ts),
+ formal->name, where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
return 0;
}
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 1d7503dc9fd..ee87228f8f7 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1239,7 +1239,8 @@ add_functions (void)
*z = "z", *ln = "len", *ut = "unit", *han = "handler",
*num = "number", *tm = "time", *nm = "name", *md = "mode",
*vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
- *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed";
+ *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed",
+ *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2";
int di, dr, dd, dl, dc, dz, ii;
@@ -2811,8 +2812,8 @@ add_functions (void)
/* The following functions are part of ISO_C_BINDING. */
add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
- "C_PTR_1", BT_VOID, 0, REQUIRED,
- "C_PTR_2", BT_VOID, 0, OPTIONAL);
+ c_ptr_1, BT_VOID, 0, REQUIRED,
+ c_ptr_2, BT_VOID, 0, OPTIONAL);
make_from_module();
add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 6a4515d3c1a..f472e66fa5d 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -3052,7 +3052,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
&& dt->format_label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
- &dt->format_label->where);
+ loc);
return false;
}
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index de9a4ad47af..4a035063fa9 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -3914,12 +3914,33 @@ resolve_omp_atomic (gfc_code *code)
= (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
code = code->block->next;
- gcc_assert (code->op == EXEC_ASSIGN);
- gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
- || ((aop == GFC_OMP_ATOMIC_CAPTURE)
- && code->next != NULL
- && code->next->op == EXEC_ASSIGN
- && code->next->next == NULL));
+ /* resolve_blocks asserts this is initially EXEC_ASSIGN.
+ If it changed to EXEC_NOP, assume an error has been emitted already. */
+ if (code->op == EXEC_NOP)
+ return;
+ if (code->op != EXEC_ASSIGN)
+ {
+ unexpected:
+ gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
+ return;
+ }
+ if (aop != GFC_OMP_ATOMIC_CAPTURE)
+ {
+ if (code->next != NULL)
+ goto unexpected;
+ }
+ else
+ {
+ if (code->next == NULL)
+ goto unexpected;
+ if (code->next->op == EXEC_NOP)
+ return;
+ if (code->next->op != EXEC_ASSIGN || code->next->next)
+ {
+ code = code->next;
+ goto unexpected;
+ }
+ }
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 0aa736c7089..3dd25397c4d 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1071,13 +1071,8 @@ next_free (void)
}
if (gfc_match_eos () == MATCH_YES)
- {
- gfc_warning_now (0, "Ignoring statement label in empty statement "
- "at %L", &label_locus);
- gfc_free_st_label (gfc_statement_label);
- gfc_statement_label = NULL;
- return ST_NONE;
- }
+ gfc_error_now ("Statement label without statement at %L",
+ &label_locus);
}
}
else if (c == '!')
@@ -1333,8 +1328,7 @@ next_fixed (void)
blank_line:
if (digit_flag)
- gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
- &label_locus);
+ gfc_error_now ("Statement label without statement at %L", &label_locus);
gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
@@ -4701,6 +4695,7 @@ parse_omp_oacc_atomic (bool omp_p)
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
+ np->ext.omp_atomic = cp->ext.omp_atomic;
count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
== GFC_OMP_ATOMIC_CAPTURE);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 77f8c10bf7e..34998554706 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6508,15 +6508,15 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
/* Convert start, end, and step to the same type as var. */
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
- gfc_convert_type (iter->start, &iter->var->ts, 2);
+ gfc_convert_type (iter->start, &iter->var->ts, 1);
if (iter->end->ts.kind != iter->var->ts.kind
|| iter->end->ts.type != iter->var->ts.type)
- gfc_convert_type (iter->end, &iter->var->ts, 2);
+ gfc_convert_type (iter->end, &iter->var->ts, 1);
if (iter->step->ts.kind != iter->var->ts.kind
|| iter->step->ts.type != iter->var->ts.type)
- gfc_convert_type (iter->step, &iter->var->ts, 2);
+ gfc_convert_type (iter->step, &iter->var->ts, 1);
if (iter->start->expr_type == EXPR_CONSTANT
&& iter->end->expr_type == EXPR_CONSTANT
@@ -8244,6 +8244,18 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* Mark this as an associate variable. */
sym->attr.associate_var = 1;
+ /* Fix up the type-spec for CHARACTER types. */
+ if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
+ {
+ if (!sym->ts.u.cl)
+ sym->ts.u.cl = target->ts.u.cl;
+
+ if (!sym->ts.u.cl->length)
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, target->value.character.length);
+ }
+
/* If the target is a good class object, so is the associate variable. */
if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
sym->attr.class_ok = 1;
@@ -8936,7 +8948,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
if (label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("Label %d referenced at %L is never defined", label->value,
- &label->where);
+ &code->loc);
return;
}
@@ -9431,6 +9443,24 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_WAIT:
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OACC_ATOMIC:
+ {
+ gfc_omp_atomic_op aop
+ = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
+
+ /* Verify this before calling gfc_resolve_code, which might
+ change it. */
+ gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
+ gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE)
+ && b->next->next == NULL)
+ || ((aop == GFC_OMP_ATOMIC_CAPTURE)
+ && b->next->next != NULL
+ && b->next->next->op == EXEC_ASSIGN
+ && b->next->next->next == NULL));
+ }
+ break;
+
case EXEC_OACC_PARALLEL_LOOP:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
@@ -9443,9 +9473,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
- case EXEC_OACC_ATOMIC:
case EXEC_OACC_ROUTINE:
- case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
@@ -11479,6 +11507,27 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
}
+/* F2008, C402 (R401): A colon shall not be used as a type-param-value
+ except in the declaration of an entity or component that has the POINTER
+ or ALLOCATABLE attribute. */
+
+static bool
+deferred_requirements (gfc_symbol *sym)
+{
+ if (sym->ts.deferred
+ && !(sym->attr.pointer
+ || sym->attr.allocatable
+ || sym->attr.omp_udr_artificial_var))
+ {
+ gfc_error ("Entity %qs at %L has a deferred type parameter and "
+ "requires either the POINTER or ALLOCATABLE attribute",
+ sym->name, &sym->declared_at);
+ return false;
+ }
+ return true;
+}
+
+
/* Resolve symbols with flavor variable. */
static bool
@@ -11518,19 +11567,10 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
}
/* Constraints on deferred type parameter. */
- if (sym->ts.deferred
- && !(sym->attr.pointer
- || sym->attr.allocatable
- || sym->attr.omp_udr_artificial_var))
- {
- gfc_error ("Entity %qs at %L has a deferred type parameter and "
- "requires either the pointer or allocatable attribute",
- sym->name, &sym->declared_at);
- specification_expr = saved_specification_expr;
- return false;
- }
+ if (!deferred_requirements (sym))
+ return false;
- if (sym->ts.type == BT_CHARACTER)
+ if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
@@ -11961,6 +12001,13 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
iface = sym->ts.interface;
sym->ts.interface = NULL;
+ /* Make sure that the result uses the correct charlen for deferred
+ length results. */
+ if (iface && sym->result
+ && iface->ts.type == BT_CHARACTER
+ && iface->ts.deferred)
+ sym->result->ts.u.cl = iface->ts.u.cl;
+
if (iface == NULL)
goto check_formal;
@@ -13640,6 +13687,10 @@ resolve_fl_parameter (gfc_symbol *sym)
return false;
}
+ /* Constraints on deferred type parameter. */
+ if (!deferred_requirements (sym))
+ return false;
+
/* Make sure a parameter that has been implicitly typed still
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
@@ -15660,7 +15711,8 @@ gfc_resolve (gfc_namespace *ns)
/* As gfc_resolve can be called during resolution of an OpenMP construct
body, we should clear any state associated to it, so that say NS's
DO loops are not interpreted as OpenMP loops. */
- gfc_omp_save_and_clear_state (&old_omp_state);
+ if (!ns->construct_entities)
+ gfc_omp_save_and_clear_state (&old_omp_state);
resolve_types (ns);
component_assignment_level = 0;
@@ -15672,5 +15724,6 @@ gfc_resolve (gfc_namespace *ns)
gfc_run_passes (ns);
- gfc_omp_restore_state (&old_omp_state);
+ if (!ns->construct_entities)
+ gfc_omp_restore_state (&old_omp_state);
}
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index fcf49b7626d..9d54091fbad 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -489,6 +489,8 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *
}
result = op (result, gfc_copy_expr (a));
+ if (!result)
+ return result;
}
return result;
@@ -1840,7 +1842,7 @@ gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
shft = shft < 0 ? 1 - shft : shft;
/* Special case: Shift to the original order! */
- if (shft % sz == 0)
+ if (sz == 0 || shft % sz == 0)
return a;
result = gfc_copy_expr (a);
@@ -7043,9 +7045,17 @@ gfc_simplify_compiler_version (void)
gfc_expr *
simplify_ieee_selected_real_kind (gfc_expr *expr)
{
- gfc_actual_arglist *arg = expr->value.function.actual;
- gfc_expr *p = arg->expr, *q = arg->next->expr,
- *rdx = arg->next->next->expr;
+ gfc_actual_arglist *arg;
+ gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
+
+ arg = expr->value.function.actual;
+ p = arg->expr;
+ if (arg->next)
+ {
+ q = arg->next->expr;
+ if (arg->next->next)
+ rdx = arg->next->next->expr;
+ }
/* Currently, if IEEE is supported and this module is built, it means
all our floating-point types conform to IEEE. Hence, we simply handle
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index 0c71c3c805a..ac9cce262e3 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -639,7 +639,8 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
error. */
static size_t
-expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
+expr_to_char (gfc_expr *e, locus *loc,
+ unsigned char *data, unsigned char *chk, size_t len)
{
int i;
int ptr;
@@ -663,7 +664,7 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
- expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
+ expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len);
}
return len;
}
@@ -674,12 +675,16 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
buffer = (unsigned char*)alloca (len);
len = gfc_target_encode_expr (e, buffer, len);
- for (i = 0; i < (int)len; i++)
+ for (i = 0; i < (int)len; i++)
{
if (chk[i] && (buffer[i] != data[i]))
{
- gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
- "at %L", &e->where);
+ if (loc)
+ gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
+ "at %L", loc);
+ else
+ gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
+ "at %C");
return 0;
}
chk[i] = 0xFF;
@@ -695,7 +700,8 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
the union declaration. */
size_t
-gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
+gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
+ unsigned char *data,
unsigned char *chk, size_t length)
{
size_t len = 0;
@@ -705,8 +711,7 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
{
case EXPR_CONSTANT:
case EXPR_STRUCTURE:
- len = expr_to_char (e, &data[0], &chk[0], length);
-
+ len = expr_to_char (e, loc, &data[0], &chk[0], length);
break;
case EXPR_ARRAY:
@@ -718,7 +723,7 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
if (mpz_cmp_si (c->offset, 0) != 0)
len = elt_size * (size_t)mpz_get_si (c->offset);
- len = len + gfc_merge_initializers (ts, c->expr, &data[len],
+ len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len],
&chk[len], length - len);
}
break;
diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h
index f83cc2163b6..0d79c104b2f 100644
--- a/gcc/fortran/target-memory.h
+++ b/gcc/fortran/target-memory.h
@@ -44,7 +44,7 @@ int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *, bool);
/* Merge overlapping equivalence initializers for trans-common.c. */
-size_t gfc_merge_initializers (gfc_typespec, gfc_expr *,
+size_t gfc_merge_initializers (gfc_typespec, gfc_expr *, locus *,
unsigned char *, unsigned char *,
size_t);
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index 9467eac0c26..cbedab8ecd0 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -532,10 +532,15 @@ get_init_field (segment_info *head, tree union_type, tree *field_init,
memset (chk, '\0', (size_t)length);
for (s = head; s; s = s->next)
if (s->sym->value)
- gfc_merge_initializers (s->sym->ts, s->sym->value,
+ {
+ locus *loc = NULL;
+ if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
+ loc = &s->sym->ns->equiv->eq->expr->where;
+ gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
&data[s->offset],
&chk[s->offset],
(size_t)s->length);
+ }
for (i = 0; i < length; i++)
CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
@@ -800,13 +805,21 @@ element_number (gfc_array_ref *ar)
if (ar->dimen_type[i] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
- mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+ if (as && as->lower[i])
+ mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+ else
+ mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
mpz_mul (n, n, multiplier);
mpz_add (offset, offset, n);
- mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
- mpz_add_ui (extent, extent, 1);
+ if (as && as->upper[i] && as->lower[i])
+ {
+ mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
+ mpz_add_ui (extent, extent, 1);
+ }
+ else
+ mpz_set_ui (extent, 0);
if (mpz_sgn (extent) < 0)
mpz_set_ui (extent, 0);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 01756ed32cd..ba9cf06d4e4 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5279,9 +5279,19 @@ generate_local_decl (gfc_symbol * sym)
}
else if (!sym->attr.use_assoc)
{
- gfc_warning (OPT_Wunused_variable,
- "Unused variable %qs declared at %L",
- sym->name, &sym->declared_at);
+ /* Corner case: the symbol may be an entry point. At this point,
+ it may appear to be an unused variable. Suppress warning. */
+ bool enter = false;
+ gfc_entry_list *el;
+
+ for (el = sym->ns->entries; el; el=el->next)
+ if (strcmp(sym->name, el->sym->name) == 0)
+ enter = true;
+
+ if (!enter)
+ gfc_warning (OPT_Wunused_variable,
+ "Unused variable %qs declared at %L",
+ sym->name, &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index b3baeeca573..818fbb90c47 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -2816,7 +2816,11 @@ gfc_trans_omp_atomic (gfc_code *code)
gfc_start_block (&block);
expr2 = code->expr2;
- if (expr2->expr_type == EXPR_FUNCTION
+ if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ != GFC_OMP_ATOMIC_WRITE)
+ && (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP) == 0
+ && expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
expr2 = expr2->value.function.actual->expr;
@@ -2855,6 +2859,7 @@ gfc_trans_omp_atomic (gfc_code *code)
var = code->expr1->symtree->n.sym;
expr2 = code->expr2;
if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
expr2 = expr2->value.function.actual->expr;
}
@@ -2912,6 +2917,7 @@ gfc_trans_omp_atomic (gfc_code *code)
}
e = expr2->value.op.op1;
if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
e = e->value.function.actual->expr;
if (e->expr_type == EXPR_VARIABLE
@@ -2925,6 +2931,7 @@ gfc_trans_omp_atomic (gfc_code *code)
{
e = expr2->value.op.op2;
if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
e = e->value.function.actual->expr;
gcc_assert (e->expr_type == EXPR_VARIABLE
@@ -3039,6 +3046,7 @@ gfc_trans_omp_atomic (gfc_code *code)
code = code->next;
expr2 = code->expr2;
if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
expr2 = expr2->value.function.actual->expr;
@@ -3552,7 +3560,9 @@ gfc_trans_omp_parallel (gfc_code *code)
gfc_start_block (&block);
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
code->loc);
+ pushlevel ();
stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
omp_clauses);
gfc_add_expr_to_block (&block, stmt);
@@ -3997,10 +4007,7 @@ gfc_trans_omp_parallel_workshare (gfc_code *code)
code->loc);
pushlevel ();
stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
- if (TREE_CODE (stmt) != BIND_EXPR)
- stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
- else
- poplevel (0, 0);
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
omp_clauses);
OMP_PARALLEL_COMBINED (stmt) = 1;
@@ -4060,7 +4067,9 @@ gfc_trans_omp_task (gfc_code *code)
gfc_start_block (&block);
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
code->loc);
+ pushlevel ();
stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
omp_clauses);
gfc_add_expr_to_block (&block, stmt);
@@ -4213,7 +4222,11 @@ gfc_trans_omp_target (gfc_code *code)
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
code->loc);
if (code->op == EXEC_OMP_TARGET)
- stmt = gfc_trans_omp_code (code->block->next, true);
+ {
+ pushlevel ();
+ stmt = gfc_trans_omp_code (code->block->next, true);
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+ }
else
{
pushlevel ();