aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/resolve.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/resolve.c')
-rw-r--r--gcc/fortran/resolve.c141
1 files changed, 98 insertions, 43 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index dd69a983406..16db94342d1 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -481,7 +481,7 @@ was_declared (gfc_symbol * sym)
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
return 1;
- if (a.allocatable || a.dimension || a.external || a.intrinsic
+ if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
@@ -884,8 +884,8 @@ set_type:
}
-/* Figure out if if a function reference is pure or not. Also sets the name
- of the function for a potential error message. Returns nonzero if the
+/* Figure out if a function reference is pure or not. Also set the name
+ of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
static int
@@ -1249,6 +1249,36 @@ resolve_call (gfc_code * c)
return t;
}
+/* Compare the shapes of two arrays that have non-NULL shapes. If both
+ op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
+ match. If both op1->shape and op2->shape are non-NULL return FAILURE
+ if their shapes do not match. If either op1->shape or op2->shape is
+ NULL, return SUCCESS. */
+
+static try
+compare_shapes (gfc_expr * op1, gfc_expr * op2)
+{
+ try t;
+ int i;
+
+ t = SUCCESS;
+
+ if (op1->shape != NULL && op2->shape != NULL)
+ {
+ for (i = 0; i < op1->rank; i++)
+ {
+ if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
+ {
+ gfc_error ("Shapes for operands at %L and %L are not conformable",
+ &op1->where, &op2->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
+ return t;
+}
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
@@ -1262,10 +1292,10 @@ resolve_operator (gfc_expr * e)
/* Resolve all subnodes-- give them types. */
- switch (e->operator)
+ switch (e->value.op.operator)
{
default:
- if (gfc_resolve_expr (e->op2) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
return FAILURE;
/* Fall through... */
@@ -1273,17 +1303,17 @@ resolve_operator (gfc_expr * e)
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
- if (gfc_resolve_expr (e->op1) == FAILURE)
+ if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
}
/* Typecheck the new node. */
- op1 = e->op1;
- op2 = e->op2;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
@@ -1296,7 +1326,7 @@ resolve_operator (gfc_expr * e)
}
sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
- gfc_op2string (e->operator), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
@@ -1312,7 +1342,7 @@ resolve_operator (gfc_expr * e)
sprintf (msg,
"Operands of binary numeric operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
@@ -1345,7 +1375,7 @@ resolve_operator (gfc_expr * e)
}
sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
@@ -1393,7 +1423,7 @@ resolve_operator (gfc_expr * e)
}
sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
- gfc_op2string (e->operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
@@ -1401,10 +1431,10 @@ resolve_operator (gfc_expr * e)
case INTRINSIC_USER:
if (op2 == NULL)
sprintf (msg, "Operand of user operator '%s' at %%L is %s",
- e->uop->name, gfc_typename (&op1->ts));
+ e->value.op.uop->name, gfc_typename (&op1->ts));
else
sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
- e->uop->name, gfc_typename (&op1->ts),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
@@ -1417,7 +1447,7 @@ resolve_operator (gfc_expr * e)
t = SUCCESS;
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
@@ -1460,10 +1490,14 @@ resolve_operator (gfc_expr * e)
if (op1->rank == op2->rank)
{
e->rank = op1->rank;
-
if (e->shape == NULL)
+ {
+ t = compare_shapes(op1, op2);
+ if (t == FAILURE)
+ e->shape = NULL;
+ else
e->shape = gfc_copy_shape (op1->shape, op1->rank);
-
+ }
}
else
{
@@ -1499,10 +1533,12 @@ resolve_operator (gfc_expr * e)
return t;
bad_op:
+
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
gfc_error (msg, &e->where);
+
return FAILURE;
}
@@ -1665,19 +1701,26 @@ gfc_resolve_index (gfc_expr * index, int check_scalar)
if (gfc_resolve_expr (index) == FAILURE)
return FAILURE;
- if (index->ts.type != BT_INTEGER)
+ if (check_scalar && index->rank != 0)
{
- gfc_error ("Array index at %L must be of INTEGER type", &index->where);
+ gfc_error ("Array index at %L must be scalar", &index->where);
return FAILURE;
}
- if (check_scalar && index->rank != 0)
+ if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
- gfc_error ("Array index at %L must be scalar", &index->where);
+ gfc_error ("Array index at %L must be of INTEGER type",
+ &index->where);
return FAILURE;
}
- if (index->ts.kind != gfc_index_integer_kind)
+ if (index->ts.type == BT_REAL)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
+ &index->where) == FAILURE)
+ return FAILURE;
+
+ if (index->ts.kind != gfc_index_integer_kind
+ || index->ts.type != BT_INTEGER)
{
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
@@ -3327,23 +3370,27 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
gfc_error ("Unsupported statement while finding forall index in "
"expression");
break;
- default:
+
+ case EXPR_OP:
+ /* Find the FORALL index in the first operand. */
+ if (expr->value.op.op1)
+ {
+ if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
+ return SUCCESS;
+ }
+
+ /* Find the FORALL index in the second operand. */
+ if (expr->value.op.op2)
+ {
+ if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
- }
- /* Find the FORALL index in the first operand. */
- if (expr->op1)
- {
- if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
- return SUCCESS;
+ default:
+ break;
}
- /* Find the FORALL index in the second operand. */
- if (expr->op2)
- {
- if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
- return SUCCESS;
- }
return FAILURE;
}
@@ -3648,10 +3695,17 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
break;
case EXEC_GOTO:
- if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
+ if (code->expr != NULL)
+ {
+ if (code->expr->ts.type != BT_INTEGER)
+ gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
- else
+ else if (code->expr->symtree->n.sym->attr.assign != 1)
+ gfc_error ("Variable '%s' has not been assigned a target label "
+ "at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
+ }
+ else
resolve_branch (code->label, code);
break;
@@ -4709,10 +4763,11 @@ gfc_resolve (gfc_namespace * ns)
if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
continue;
- if (cl->length->ts.type != BT_INTEGER)
- gfc_error
- ("Character length specification at %L must be of type INTEGER",
- &cl->length->where);
+ if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ continue;
+
+ if (gfc_specification_expr (cl->length) == FAILURE)
+ continue;
}
gfc_traverse_ns (ns, resolve_values);
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-28 14:11:58 +0000