re PR fortran/31919 ([4.1/4.2 only] min/max do not check array conformance)

gcc/fortran:
2007-05-15  Daniel Franke  <franke.daniel@gmail.com>

        PR fortran/31919
        PR fortran/31929
        PR fortran/31930
        * intrinsic.c (check_specific): Check elemental intrinsics for
        rank and shape.
        (add_functions): Fixed dummy argument names of BESJN and BESYN.
        Fixed elemental status of MCLOCK and MCLOCK8.
        * check.c (check_rest): Added check for array conformance.
        (gfc_check_merge): Removed check for array conformance.
        (gfc_check_besn): Removed check for scalarity.
        * intrinsic.texi (CSHIFT, EOSHIFT): Fixed typos.
        (BESJN, BESYN): Clarified documentation.

gcc/testsuite:
2007-05-17  Daniel Franke <franke.daniel@gmail.com>

        PR fortran/31919
        * gfortran.dg/min_max_conformance.f90: New test.

From-SVN: r124794

gcc/fortran/ChangeLog

+2007-05-15  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31919
+	PR fortran/31929
+	PR fortran/31930
+	* intrinsic.c (check_specific): Check elemental intrinsics for
+	rank and shape.
+	(add_functions): Fixed dummy argument names of BESJN and BESYN.
+	Fixed elemental status of MCLOCK and MCLOCK8.
+	* check.c (check_rest): Added check for array conformance.
+	(gfc_check_merge): Removed check for array conformance.
+	(gfc_check_besn): Removed check for scalarity.
+	* intrinsic.texi (CSHIFT, EOSHIFT): Fixed typos.
+	(BESJN, BESYN): Clarified documentation.
+
 2007-05-17  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.texi (GFORTRAN_CONVERT_UNIT): Improve documentation.

gcc/fortran/check.c

@@ -649,9 +649,6 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 try
 gfc_check_besn (gfc_expr *n, gfc_expr *x)
 {
-  if (scalar_check (n, 0) == FAILURE)
-    return FAILURE;
-
   if (type_check (n, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
@@ -1491,14 +1488,16 @@ min_max_args (gfc_actual_arglist *arg)
 static try
 check_rest (bt type, int kind, gfc_actual_arglist *arg)
 {
-  gfc_expr *x;
+  gfc_expr *x, *first_arg;
   int n;
+  char buffer[80];
 
   if (min_max_args (arg) == FAILURE)
     return FAILURE;
 
   n = 1;
 
+  first_arg = arg->expr;
   for (; arg; arg = arg->next, n++)
     {
       x = arg->expr;
@@ -1518,6 +1517,12 @@ check_rest (bt type, int kind, gfc_actual_arglist *arg)
 	      return FAILURE;
 	    }
 	}
+
+      snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
+		gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n-1],
+		gfc_current_intrinsic);
+      if (gfc_check_conformance (buffer, first_arg, x) == FAILURE)
+        return FAILURE;
     }
 
   return SUCCESS;
@@ -1797,26 +1802,12 @@ 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, 80, "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, 80, "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;
 }
 

gcc/fortran/intrinsic.c

@@ -896,7 +896,7 @@ add_functions (void)
   const char
     *a = "a", *f = "field", *pt = "pointer", *tg = "target",
     *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
-    *c = "c", *n = "ncopies", *pos = "pos", *bck = "back",
+    *c = "c", *n = "n", *ncopies= "ncopies", *pos = "pos", *bck = "back",
     *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
     *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
     *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
@@ -1819,12 +1819,12 @@ add_functions (void)
 
   make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
 
-  add_sym_0 ("mclock", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
+  add_sym_0 ("mclock", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
 	     NULL, NULL, gfc_resolve_mclock);
 
   make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
 
-  add_sym_0 ("mclock8", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
+  add_sym_0 ("mclock8", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
 	     NULL, NULL, gfc_resolve_mclock8);
 
   make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
@@ -2013,7 +2013,7 @@ add_functions (void)
   
   add_sym_2 ("repeat", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
 	     gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
-	     stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
+	     stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
 
   make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
 
@@ -2147,7 +2147,7 @@ add_functions (void)
   add_sym_3 ("spread", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_spread, NULL, gfc_resolve_spread,
 	     src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
-	     n, BT_INTEGER, di, REQUIRED);
+	     ncopies, BT_INTEGER, di, REQUIRED);
 
   make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
 
@@ -3201,7 +3201,6 @@ static try
 check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
 {
   gfc_actual_arglist *arg, **ap;
-  int r;
   try t;
 
   ap = &expr->value.function.actual;
@@ -3242,26 +3241,25 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
 	 t = do_check (specific, *ap);
      }
 
-  /* Check ranks for elemental intrinsics.  */
+  /* Check conformance of elemental intrinsics.  */
   if (t == SUCCESS && specific->elemental)
     {
-      r = 0;
-      for (arg = expr->value.function.actual; arg; arg = arg->next)
-	{
-	  if (arg->expr == NULL || arg->expr->rank == 0)
-	    continue;
-	  if (r == 0)
-	    {
-	      r = arg->expr->rank;
-	      continue;
-	    }
+      int n = 0;
+      gfc_expr *first_expr;
+      arg = expr->value.function.actual;
 
-	  if (arg->expr->rank != r)
-	    {
-	      gfc_error ("Ranks of arguments to elemental intrinsic '%s' "
-			 "differ at %L", specific->name, &arg->expr->where);
-	      return FAILURE;
-	    }
+      /* There is no elemental intrinsic without arguments.  */
+      gcc_assert(arg != NULL);
+      first_expr = arg->expr;
+
+      for ( ; arg && arg->expr; arg = arg->next, n++)
+	{
+          char buffer[80];
+	  snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
+		    gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n],
+		    gfc_current_intrinsic);
+	  if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE)
+	    return FAILURE;
 	}
     }
 

gcc/fortran/intrinsic.texi

@@ -1575,6 +1575,8 @@ end program test_besj1
 @code{BESJN(N, X)} computes the Bessel function of the first kind of order
 @var{N} of @var{X}.
 
+If both arguments are arrays, their ranks and shapes shall conform.
+
 @item @emph{Standard}:
 GNU extension
 
@@ -1586,8 +1588,8 @@ Elemental function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{N} @tab The type shall be @code{INTEGER(*)}, and it shall be scalar.
-@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar.
+@item @var{N} @tab Shall be a scalar or an array of type  @code{INTEGER(*)}.
+@item @var{X} @tab Shall be a scalar or an array of type  @code{REAL(*)}.
 @end multitable
 
 @item @emph{Return value}:
@@ -1712,6 +1714,8 @@ end program test_besy1
 @code{BESYN(N, X)} computes the Bessel function of the second kind of order
 @var{N} of @var{X}.
 
+If both arguments are arrays, their ranks and shapes shall conform.
+
 @item @emph{Standard}:
 GNU extension
 
@@ -1723,8 +1727,8 @@ Elemental function
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{N} @tab The type shall be @code{INTEGER(*)}, and it shall be scalar.
-@item @var{X} @tab The type shall be @code{REAL(*)}, and it shall be scalar.
+@item @var{N} @tab Shall be a scalar or an array of type  @code{INTEGER(*)}.
+@item @var{X} @tab Shall be a scalar or an array of type  @code{REAL(*)}.
 @end multitable
 
 @item @emph{Return value}:
@@ -2487,14 +2491,14 @@ shifted out one end of each rank one section are shifted back in the other end.
 F95 and later
 
 @item @emph{Class}:
-transformational function
+Transformational function
 
 @item @emph{Syntax}:
-@code{RESULT = CSHIFT(A, SHIFT [, DIM])}
+@code{RESULT = CSHIFT(ARRAY, SHIFT [, DIM])}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{ARRAY}  @tab May be any type, not scaler.
+@item @var{ARRAY}  @tab Shall be an array of any type.
 @item @var{SHIFT}  @tab The type shall be @code{INTEGER}.
 @item @var{DIM}    @tab The type shall be @code{INTEGER}.
 @end multitable
@@ -3120,10 +3124,10 @@ following are copied in depending on the type of @var{ARRAY}.
 F95 and later
 
 @item @emph{Class}:
-transformational function
+Transformational function
 
 @item @emph{Syntax}:
-@code{RESULT = EOSHIFT(A, SHIFT [, BOUNDARY, DIM])}
+@code{RESULT = EOSHIFT(ARRAY, SHIFT [, BOUNDARY, DIM])}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70

gcc/testsuite/ChangeLog

+2007-05-17  Daniel Franke <franke.daniel@gmail.com>
+
+	PR fortran/31919
+	* gfortran.dg/min_max_conformance.f90: New test.
+
 2007-05-17  Zdenek Dvorak  <dvorakz@suse.cz>
 
 	* gcc.dg/tree-ssa/ssa-dom-thread-2.c: New test.

gcc/testsuite/gfortran.dg/min_max_conformance.f90

+! { dg-compile }
+! PR 31919:  Tests for different ranks in min/max were missing.
+program pr31919
+  integer :: i4a(2, 2), i4b(2), i4c(4)
+  real(4) :: r4a(2, 2), r4b(2), r4c(4)
+  real(8) :: r8a(2, 2), r8b(2), r8c(4)
+
+  i4a = max(i4a, i4b)            ! { dg-error "Incompatible ranks" }
+  i4a = max0(i4a, i4b)           ! { dg-error "Incompatible ranks" }
+  r4a = amax0(i4a, i4b)          ! { dg-error "Incompatible ranks" }
+  i4a = max1(r4a, r4b)           ! { dg-error "Incompatible ranks" }
+  r4a = amax1(r4a, r4b)          ! { dg-error "Incompatible ranks" }
+  r8a = dmax1(r8a, r8b)          ! { dg-error "Incompatible ranks" }
+
+  i4a = min(i4a, i4b)            ! { dg-error "Incompatible ranks" }
+  i4a = min0(i4a, i4b)           ! { dg-error "Incompatible ranks" }
+  i4a = amin0(i4a, i4b)          ! { dg-error "Incompatible ranks" }
+  r4a = min1(r4a, r4b)           ! { dg-error "Incompatible ranks" }
+  r4a = amin1(r4a, r4b)          ! { dg-error "Incompatible ranks" }
+  r8a = dmin1(r8a, r8b)          ! { dg-error "Incompatible ranks" }
+
+  i4a = max(i4b, i4c)            ! { dg-error "different shape for arguments" }
+  i4a = max0(i4b, i4c)           ! { dg-error "different shape for arguments" }
+  r4a = amax0(i4b, i4c)          ! { dg-error "different shape for arguments" }
+  i4a = max1(r4b, r4c)           ! { dg-error "different shape for arguments" }
+  r4a = amax1(r4b, r4c)          ! { dg-error "different shape for arguments" }
+  r8a = dmax1(r8B, r8c)          ! { dg-error "different shape for arguments" }
+
+  i4a = min(i4b, i4c)            ! { dg-error "different shape for arguments" }
+  i4a = min0(i4b, i4c)           ! { dg-error "different shape for arguments" }
+  i4a = amin0(i4b, i4c)          ! { dg-error "different shape for arguments" }
+  r4a = min1(r4b, r4c)           ! { dg-error "different shape for arguments" }
+  r4a = amin1(r4b, r4c)          ! { dg-error "different shape for arguments" }
+  r8a = dmin1(r8b, r8c)          ! { dg-error "different shape for arguments" }
+end program