[patch, fortran] Fix PR 26039, lack of conformance checking in some intrinsics

[Thomas Koenig]

On Tue, Jan 31, 2006 at 06:48:30AM +0100, Paul Thomas wrote:

:ADDPATCH fortran:

> Why don't you 
> use gfc_check_conformance (const char*, gfc_expr *, gfc_expr*), which 
> will check the shapes as well?  The standard does actually specify 
> conformability.

Because I didn't know that this exists :-) Thanks for the hint.

What about this?  OK for 4.2 and (after some days) for 4.1?

	Thomas

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.
-------------- next part --------------
Index: expr.c
===================================================================
--- expr.c	(revision 110306)
+++ expr.c	(working copy)
@@ -1821,7 +1821,7 @@ gfc_check_conformance (const char *optyp
 
       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));
Index: check.c
===================================================================
--- check.c	(revision 110306)
+++ check.c	(working copy)
@@ -354,7 +354,6 @@ dim_rank_check (gfc_expr * dim, gfc_expr
   return SUCCESS;
 }
 
-
 /***** Check functions *****/
 
 /* Check subroutine suitable for intrinsics taking a real argument and
@@ -1526,6 +1525,16 @@ gfc_check_minloc_maxloc (gfc_actual_argl
   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 +1557,9 @@ gfc_check_minloc_maxloc (gfc_actual_argl
 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 +1581,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;
 }
 
-------------- next part --------------
! { 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