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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@110453 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bcdd799..517535b 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index feb07f0..8b56d52 100644 (file)
--- a/gcc/fortran/check.c
+++ b/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;
 }
 

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 0e699c2..92a7dc0 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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));

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 47f6623..6b5c659 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/maxval_maxloc_conformance_1.f90 b/gcc/testsuite/gfortran.dg/maxval_maxloc_conformance_1.f90
new file mode 100644 (file)
index 0000000..828655c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/maxval_maxloc_conformance_1.f90
@@ -0,0 +1,35 @@
+! { 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