+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.
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;
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;
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;
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;
}
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",
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);
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);
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);
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;
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;
}
}
@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
@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}:
@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
@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}:
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
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
+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.
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
