re PR fortran/25075 ([4.1 only] array size mismatch in DOT_PRODUCT)

2006-02-04  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/25075
	check.c (identical_dimen_shape):  New function.
	(check_dot_product):  Use identical_dimen_shape() to check sizes
	for dot_product.
	(gfc_check_matmul):  Likewise.
	(gfc_check_merge):  Check conformance between tsource and fsource
	and between tsource and mask.
	(gfc_check_pack):  Check conformance between array and mask.

2006-02-04  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/25075
	intrinsic_argument_conformance_1.f90:  New test.

From-SVN: r110596

4 files changed, 111 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5dfdb52..2ea8316 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2006-02-04  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25075
+	check.c (identical_dimen_shape):  New function.
+	(check_dot_product):  Use identical_dimen_shape() to check sizes
+	for dot_product.
+	(gfc_check_matmul):  Likewise.
+	(gfc_check_merge):  Check conformance between tsource and fsource
+	and between tsource and mask.
+	(gfc_check_pack):  Check conformance between array and mask.
+
 2006-02-03  Steven G. Kargl  <kargls@comcast>
 	    Paul Thomas  <pault@gcc.gnu.org>
 
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 8b56d52..dc6541c 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -354,6 +354,34 @@ dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
   return SUCCESS;
 }
 
+/* Compare the size of a along dimension ai with the size of b along
+   dimension bi, returning 0 if they are known not to be identical,
+   and 1 if they are identical, or if this cannot be determined.  */
+
+static int
+identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
+{
+  mpz_t a_size, b_size;
+  int ret;
+
+  gcc_assert (a->rank > ai);
+  gcc_assert (b->rank > bi);
+
+  ret = 1;
+
+  if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
+    {
+      if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
+	{
+	  if (mpz_cmp (a_size, b_size) != 0)
+	    ret = 0;
+  
+	  mpz_clear (b_size);
+	}
+      mpz_clear (a_size);
+    }
+  return ret;
+}
 
 /***** Check functions *****/
 
@@ -802,6 +830,16 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
   if (rank_check (vector_b, 1, 1) == FAILURE)
     return FAILURE;
 
+  if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
+    {
+      gfc_error ("different shape for arguments '%s' and '%s' "
+		 "at %L for intrinsic 'dot_product'",
+		 gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic_arg[1],
+		 &vector_a->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
@@ -1461,13 +1499,35 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
     case 1:
       if (rank_check (matrix_b, 1, 2) == FAILURE)
 	return FAILURE;
+      /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
+      if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+	{
+	  gfc_error ("different shape on dimension 1 for arguments '%s' "
+		     "and '%s' at %L for intrinsic matmul",
+		     gfc_current_intrinsic_arg[0],
+		     gfc_current_intrinsic_arg[1],
+		     &matrix_a->where);
+	  return FAILURE;
+	}
       break;
 
     case 2:
-      if (matrix_b->rank == 2)
-	break;
-      if (rank_check (matrix_b, 1, 1) == FAILURE)
-	return FAILURE;
+      if (matrix_b->rank != 2)
+	{
+	  if (rank_check (matrix_b, 1, 1) == FAILURE)
+	    return FAILURE;
+	}
+      /* matrix_b has rank 1 or 2 here. Common check for the cases
+	 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+	 - matrix_a has shape (n,m) and matrix_b has shape (m).  */
+      if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+	{
+	  gfc_error ("different shape on dimension 2 for argument '%s' and "
+		     "dimension 1 for argument '%s' at %L for intrinsic "
+		     "matmul", gfc_current_intrinsic_arg[0],
+		     gfc_current_intrinsic_arg[1], &matrix_a->where);
+	  return FAILURE;
+	}
       break;
 
     default:
@@ -1621,12 +1681,26 @@ gfc_check_product_sum (gfc_actual_arglist * ap)
 try
 gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
 {
+  char buffer[80];
+
   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
     return FAILURE;
 
   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+	   gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+	   gfc_current_intrinsic);
+  if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
+    return FAILURE;
+
+  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+	   gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
+	   gfc_current_intrinsic);
+  if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -1672,20 +1746,19 @@ gfc_check_null (gfc_expr * mold)
 try
 gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
 {
+  char buffer[80];
+
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  if (mask->rank != 0 && mask->rank != array->rank)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
-		 "with '%s' argument", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic, &array->where,
-		 gfc_current_intrinsic_arg[1]);
-      return FAILURE;
-    }
+  snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+	   gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+	   gfc_current_intrinsic);
+  if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+    return FAILURE;
 
   if (vector != NULL)
     {
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f3ebef1..d35cfa1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2006-02-04  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25075
+	intrinsic_argument_conformance_1.f90:  New test.
+
 2006-02-03  Steven G. Kargl  <kargls@comcast.net>
 
 	PR fortran/20845
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90
new file mode 100644
index 0000000..bfdcf42
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+program main
+  real :: av(2), bv(4)
+  real :: a(2,2)
+  logical :: lo(3,2)
+  print *,dot_product(av, bv) ! { dg-error "different shape" }
+  print *,pack(a, lo) ! { dg-error "different shape" }
+  print *,merge(av, bv, lo(1,:)) ! { dg-error "different shape" }
+  print *,matmul(bv,a) ! { dg-error "different shape" }
+end program main