/* Perform type resolution on the various structures.
- Copyright (C) 2001-2019 Free Software Foundation, Inc.
+ Copyright (C) 2001-2020 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
return t;
/* Walk the argument list looking for invalid BOZ. */
- if (expr->value.function.esym)
- {
- gfc_actual_arglist *a;
-
- for (a = expr->value.function.actual; a; a = a->next)
- if (a->expr && a->expr->ts.type == BT_BOZ)
- {
- gfc_error ("A BOZ literal constant at %L cannot appear as an "
- "actual argument in a function reference",
- &a->expr->where);
- return false;
- }
- }
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ if (arg->expr && arg->expr->ts.type == BT_BOZ)
+ {
+ gfc_error ("A BOZ literal constant at %L cannot appear as an "
+ "actual argument in a function reference",
+ &arg->expr->where);
+ return false;
+ }
temp = need_full_assumed_size;
need_full_assumed_size = 0;
return 0;
}
+/* Return true if TYPE is character based, false otherwise. */
+
+static int
+is_character_based (bt type)
+{
+ return type == BT_CHARACTER || type == BT_HOLLERITH;
+}
+
+
+/* If expression is a hollerith, convert it to character and issue a warning
+ for the conversion. */
+
+static void
+convert_hollerith_to_character (gfc_expr *e)
+{
+ if (e->ts.type == BT_HOLLERITH)
+ {
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = BT_CHARACTER;
+ t.kind = e->ts.kind;
+ gfc_convert_type_warn (e, &t, 2, 1);
+ }
+}
+
+/* Convert to numeric and issue a warning for the conversion. */
+
+static void
+convert_to_numeric (gfc_expr *a, gfc_expr *b)
+{
+ gfc_typespec t;
+ gfc_clear_ts (&t);
+ t.type = b->ts.type;
+ t.kind = b->ts.kind;
+ gfc_convert_type_warn (a, &t, 2, 1);
+}
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
}
sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
- gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (e));
goto bad_op;
case INTRINSIC_PLUS:
else
sprintf (msg,
_("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
case INTRINSIC_CONCAT:
sprintf (msg,
_("Operands of string concatenation operator at %%L are %s/%s"),
- gfc_typename (&op1->ts), gfc_typename (&op2->ts));
+ gfc_typename (op1), gfc_typename (op2));
goto bad_op;
case INTRINSIC_AND:
}
sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
}
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
- gfc_typename (&op1->ts));
+ gfc_typename (op1));
goto bad_op;
case INTRINSIC_GT:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
+
+ if (flag_dec
+ && is_character_based (op1->ts.type)
+ && is_character_based (op2->ts.type))
+ {
+ convert_hollerith_to_character (op1);
+ convert_hollerith_to_character (op2);
+ }
+
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
&& op1->ts.kind == op2->ts.kind)
{
if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
return false;
}
+ if (flag_dec
+ && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
+ convert_to_numeric (op1, op2);
+
+ if (flag_dec
+ && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
+ convert_to_numeric (op2, op1);
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
msg = "Inequality comparison for %s at %L";
gfc_warning (OPT_Wcompare_reals, msg,
- gfc_typename (&op1->ts), &op1->where);
+ gfc_typename (op1), &op1->where);
}
}
else
sprintf (msg,
_("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (op1),
+ gfc_typename (op2));
goto bad_op;
}
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
- e->value.op.uop->name, gfc_typename (&op1->ts));
+ e->value.op.uop->name, gfc_typename (op1));
else
{
sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ e->value.op.uop->name, gfc_typename (op1),
+ gfc_typename (op2));
e->value.op.uop->op->sym->attr.referenced = 1;
}
/* Resolve subtype references. */
-static bool
-resolve_ref (gfc_expr *expr)
+bool
+gfc_resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
gfc_ref *ref, **prev;
examining the base symbol and any reference structures it may have. */
void
-expression_rank (gfc_expr *e)
+gfc_expression_rank (gfc_expr *e)
{
gfc_ref *ref;
int i, rank;
goto done;
/* Constructors can have a rank different from one via RESHAPE(). */
- if (e->symtree == NULL)
- {
- e->rank = 0;
- goto done;
- }
-
- e->rank = (e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank;
+ e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
+ ? 0 : e->symtree->n.sym->as->rank);
goto done;
}
{
/* Figure out the rank of the section. */
if (rank != 0)
- gfc_internal_error ("expression_rank(): Two array specs");
+ gfc_internal_error ("gfc_expression_rank(): Two array specs");
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
}
}
- if (e->ref && !resolve_ref (e))
+ if (e->ref && !gfc_resolve_ref (e))
return false;
if (sym->attr.flavor == FL_PROCEDURE
}
if (t)
- expression_rank (e);
+ gfc_expression_rank (e);
if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
- /* If the base_object is not a variable, the corresponding actual
- argument expression must be stored in e->base_expression so
- that the corresponding tree temporary can be used as the base
- object in gfc_conv_procedure_call. */
- if (expr->expr_type != EXPR_VARIABLE)
- {
- gfc_actual_arglist *args;
-
- for (args= e->value.function.actual; args; args = args->next)
- {
- if (expr == args->expr)
- expr = args->expr;
- }
- }
-
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
if (st == NULL)
return resolve_compcall (e, NULL);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
/* Get the CLASS declared type. */
if (st == NULL)
return resolve_typebound_call (code, NULL, NULL);
- if (!resolve_ref (code->expr1))
+ if (!gfc_resolve_ref (code->expr1))
return false;
/* Get the CLASS declared type. */
if (!comp->attr.subroutine)
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
- if (!resolve_ref (c->expr1))
+ if (!gfc_resolve_ref (c->expr1))
return false;
if (!update_ppc_arglist (c->expr1))
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
return false;
if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
break;
case EXPR_SUBSTRING:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
break;
case EXPR_CONSTANT:
case EXPR_ARRAY:
t = false;
- if (!resolve_ref (e))
+ if (!gfc_resolve_ref (e))
break;
t = gfc_resolve_array_constructor (e);
/* Also try to expand a constructor. */
if (t)
{
- expression_rank (e);
+ gfc_expression_rank (e);
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
gfc_expand_constructor (e, false);
}
break;
case EXPR_STRUCTURE:
- t = resolve_ref (e);
+ t = gfc_resolve_ref (e);
if (!t)
break;
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
- &case_expr->where, gfc_typename (&case_expr->ts));
+ &case_expr->where, gfc_typename (case_expr));
/* Punt. Going on here just produce more garbage error messages. */
return;
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->low->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
if (cp->high
&& cp->low != cp->high
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->high->where,
- gfc_typename (&case_expr->ts));
+ gfc_typename (case_expr));
}
/* PR 19168 has a long discussion concerning a mismatch of the kinds
gcc_assert (target->symtree);
tsym = target->symtree->n.sym;
+ if (tsym->attr.flavor == FL_PROGRAM)
+ {
+ gfc_error ("Associating entity %qs at %L is a PROGRAM",
+ tsym->name, &target->where);
+ return;
+ }
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
lhs = code->expr1;
rhs = code->expr2;
+ if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
+ && rhs->ts.type == BT_CHARACTER
+ && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
+ {
+ /* Use of -fdec-char-conversions allows assignment of character data
+ to non-character variables. This not permited for nonconstant
+ strings. */
+ gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
+ gfc_typename (lhs), &rhs->where);
+ return false;
+ }
+
/* Handle the case of a BOZ literal on the RHS. */
if (rhs->ts.type == BT_BOZ)
{
"component in a PURE procedure",
&rhs->where);
else
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
+ /* F2008, C1283 (4). */
+ gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
+ "shall not be used as the expr at %L of an intrinsic "
+ "assignment statement in which the variable is of a "
+ "derived type if the derived type has a pointer "
+ "component at any level of component selection.",
&rhs->where);
return rval;
}
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
case EXEC_OACC_KERNELS:
+ case EXEC_OACC_SERIAL_LOOP:
+ case EXEC_OACC_SERIAL:
case EXEC_OACC_DATA:
case EXEC_OACC_HOST_DATA:
case EXEC_OACC_LOOP:
simplification now. */
for (i = 0; i < sym->as->rank + sym->as->corank; i++)
{
+ if (i == GFC_MAX_DIMENSIONS)
+ break;
+
e = sym->as->lower[i];
if (e && (!resolve_index_expr(e)
|| !gfc_is_constant_expr (e)))
}
-/* Function called by resolve_fntype to flag other symbol used in the
- length type parameter specification of function resuls. */
+/* Function called by resolve_fntype to flag other symbols used in the
+ length type parameter specification of function results. */
static bool
flag_fn_result_spec (gfc_expr *expr,
projects / thirdparty / gcc.git / blobdiff