re PR fortran/26039 (ICE with maxval)

2006-01-31  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/26039
	expr.c (gfc_check_conformance):  Reorder error message
	to avoid plural.
	check.c(gfc_check_minloc_maxloc):  Call gfc_check_conformance
	for checking arguments array and mask.
	(check_reduction):  Likewise.

2006-01-31  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/26039
	maxval_maxloc_conformance_1.f90:  New test.

From-SVN: r110453

gcc/fortran/ChangeLog

+2006-01-31  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/26039
+	expr.c (gfc_check_conformance):  Reorder error message
+	to avoid plural.
+	check.c(gfc_check_minloc_maxloc):  Call gfc_check_conformance
+	for checking arguments array and mask.
+	(check_reduction):  Likewise.
+
 2005-01-30  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	PR fortran/24266

gcc/fortran/check.c

@@ -1526,6 +1526,16 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (m != NULL)
+    {
+      char buffer[80];
+      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, a, m) == FAILURE)
+	return FAILURE;
+    }
+
   return SUCCESS;
 }
 
@@ -1548,8 +1558,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
 static try
 check_reduction (gfc_actual_arglist * ap)
 {
-  gfc_expr *m, *d;
+  gfc_expr *a, *m, *d;
 
+  a = ap->expr;
   d = ap->next->expr;
   m = ap->next->next->expr;
 
@@ -1571,6 +1582,16 @@ check_reduction (gfc_actual_arglist * ap)
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (m != NULL)
+    {
+      char buffer[80];
+      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, a, m) == FAILURE)
+	return FAILURE;
+    }
+
   return SUCCESS;
 }
 

gcc/fortran/expr.c

@@ -1821,7 +1821,7 @@ gfc_check_conformance (const char *optype_msgid,
 
       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
 	{
-	  gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
+	  gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
 		     _(optype_msgid), &op1->where, d + 1,
 		     (int) mpz_get_si (op1_size),
 		     (int) mpz_get_si (op2_size));

gcc/testsuite/ChangeLog

+2006-01-31  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/26039
+	maxval_maxloc_conformance_1.f90:  New test.
+
 2006-01-31  Richard Guenther  <rguenther@suse.de>
 
 	* gcc.target/i386/sselibm-1.c: New testcase.

gcc/testsuite/gfortran.dg/maxval_maxloc_conformance_1.f90

+! { dg-do compile }
+! PR 26039:  Tests for different ranks for (min|max)loc, (min|max)val, product
+!            and sum were missing.
+program main
+  integer, dimension(2) :: a
+  logical, dimension(2,1) :: lo
+  logical, dimension(3) :: lo2
+  a = (/ 1, 2 /)
+  lo = .true.
+  print *,minloc(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,maxloc(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,minval(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,maxval(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,sum(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,product(a,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,minloc(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,maxloc(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,minval(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,maxval(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,sum(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+  print *,product(a,1,mask=lo) ! { dg-error "Incompatible ranks" }
+
+  print *,minloc(a,mask=lo2) ! { dg-error "different shape" }
+  print *,maxloc(a,mask=lo2) ! { dg-error "different shape" }
+  print *,minval(a,mask=lo2) ! { dg-error "different shape" }
+  print *,maxval(a,mask=lo2) ! { dg-error "different shape" }
+  print *,sum(a,mask=lo2) ! { dg-error "different shape" }
+  print *,product(a,mask=lo2) ! { dg-error "different shape" }
+  print *,minloc(a,1,mask=lo2) ! { dg-error "different shape" }
+  print *,maxloc(a,1,mask=lo2) ! { dg-error "different shape" }
+  print *,minval(a,1,mask=lo2) ! { dg-error "different shape" }
+  print *,maxval(a,1,mask=lo2) ! { dg-error "different shape" }
+  print *,sum(a,1,mask=lo2) ! { dg-error "different shape" }
+  print *,product(a,1,mask=lo2) ! { dg-error "different shape" }
+end program main