OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/19754 (Shape conformance not checked)

Browse Source 
PR fortran/19754
* resolve.c (compare_shapes):  New function.
(resolve_operator): Use it.

From-SVN: r95945
This commit is contained in:
Steven G. Kargl 2005-03-05 22:13:21 +00:00 committed by Steven G. Kargl
parent 098c1ef8fa
commit 2c5ed587af
2 changed files with 44 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2005-03-05 Steven G. Kargl <kargls@comcast.net>
PR fortran/19754
* resolve.c (compare_shapes): New function.
(resolve_operator): Use it.
2005-03-05 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
* trans-const.c (gfc_conv_constant_to_tree): Use correct tree

40
gcc/fortran/resolve.c
View File

@ -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. */
@ -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;
}