[gfortran] PATCH Fix PR 19754 (with regressions)

[Steve Kargl]

On Thu, Feb 03, 2005 at 05:28:35PM +0100, THOMAS Paul Richard wrote:
> Steve,
> 
> With the your patch, the following:
> 
> ! Steve Kargl's fix to PR19754 causes mixed intrinsic
> ! type operations to fail.
> !
> program ss
>    real a(2,2), b(2,2)
>    integer c(2,2)
>    a = 1.
>    b = 2.
>    c = 42
> !   a = b - floor( a / b )        ! this causes an ICE #1
> !   a = b - real(floor( a / b ))  ! this is OK         #2
> !   c = c - floor( a / b )        !     idem
> !   a = c                         !     idem  
> !   a = c + b                     ! this causes an ICE 
> !   c = a                         ! this is OK
>     c = a + b                     !     idem           #3
> !   c = c + a                     ! this causes an ICE #4
> end program ss
> 
> Shows that binary operations involving mixed intrinsic types generate the
> ICE (eg. #1 vs. #2 or #3 vs. #4.)
> 
> In fact, it seg faults because of a call to gfc_array_dimen_size (gfc_expr *
> array, int dimen, mpz_t * result) (array.c line 1787 ) with array->ref ==
> NULL.  Thus the loop that normally returns SUCCESS is skipped and the seg
> fault occurs because the call to spec_dimen_size(array->symtree->n.sym->as,
> dimen, result) is made with array->symtree == NULL.
> 
> If one forces the code to return SUCCESS, unsurprisingly an ICE occurs with
> the error "Array operation at (1) has different shape on dimension 1" (ie.
> the comparison of sizes does not work because array->ref does not point to
> anything.).
> 
> It seems to me, therefore, that the call to gfc_check_conformance is made
> too early because, if it is omitted, further down stream the compiler is
> able to build the operation(where?), albeit without checking the dimensions.
> 
> 
> I have to return to some "real" work now - I hope that this helps. I'll come
> back to it later or tomorrow.
> 

OK, I've determined why my patch wasn't working.  I was assuming that
the shape of each operand would be known by the time resolve_operator()
was called.  This is not the case.  Your above analysis gave me the
clues.

I have updated the patch to exclude comparisons of the shapes of the
operands if either op1->shape or op2->shape is NULL.  The attached
patch has been bootstrapped and regression tested with no new
regression.  All of the above statements now work as expected and
the code in the PR is flagged for non-conformible arrays.


2005-02-03  Steven G. Kargl  <kargls@comcast.net>

      * resolve.c (compare_shapes):  New function.
      (resolve_operator): Use it.


-- 
Steve
-------------- next part --------------
Index: resolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.31
diff -u -r1.31 resolve.c
--- resolve.c	22 Jan 2005 18:23:40 -0000	1.31
+++ resolve.c	3 Feb 2005 20:13:12 -0000
@@ -1249,6 +1249,41 @@
   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;
+		  
+  for (i = 0; i < op1->rank; i++)
+    {
+      if (op1->shape != NULL && op2->shape != NULL)
+	{
+	  if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
+	   {
+	     gfc_error ("Inconsistent shapes for operands at %L and %L",
+			 &op1->where, &op2->where);
+	     t = FAILURE;
+	     break;
+	   }
+	}
+      else
+	{
+          t = SUCCESS;
+	  break;
+	}
+    }
+
+  return t;
+}
 
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
@@ -1460,10 +1495,15 @@
 	  if (op1->rank == op2->rank)
 	    {
 	      e->rank = op1->rank;
-
 	      if (e->shape == NULL)
-		e->shape = gfc_copy_shape (op1->shape, op1->rank);
-
+		{
+		  e->shape = gfc_copy_shape (op1->shape, op1->rank);
+		  if (compare_shapes(op1, op2) == FAILURE)
+		    {
+                      msg[0] = '\0';
+		      goto bad_op;
+		    }
+		}
 	    }
 	  else
 	    {
@@ -1499,10 +1539,13 @@
   return t;
 
 bad_op:
+
   if (gfc_extend_expr (e) == SUCCESS)
     return SUCCESS;
 
-  gfc_error (msg, &e->where);
+  if (msg[0] != '\0')
+    gfc_error (msg, &e->where);
+
   return FAILURE;
 }