mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-24 16:16:17 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Daniel Franke 2007-05-17 08:37:24 -04:00 committed by Daniel Franke
parent a4e6a80f67
commit 0881653ce2
6 changed files with 98 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
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.

27
gcc/fortran/check.c
View File

@ -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;
}

44
gcc/fortran/intrinsic.c
View File

@ -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;
}
}

22
gcc/fortran/intrinsic.texi
View File

@ -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

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
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.

35
gcc/testsuite/gfortran.dg/min_max_conformance.f90 Normal file
View File

@ -0,0 +1,35 @@
! { 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