diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 78698b3c44fe..dbd2cc85136a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2007-05-15 Daniel Franke + + 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 * gfortran.texi (GFORTRAN_CONVERT_UNIT): Improve documentation. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 722e9deae672..4c0a5920b55b 100644 --- a/gcc/fortran/check.c +++ b/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; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index c538d07b29ea..d64f77f94fad 100644 --- a/gcc/fortran/intrinsic.c +++ b/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; } } diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 7ee368361246..52d09fba526d 100644 --- a/gcc/fortran/intrinsic.texi +++ b/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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e829a0f9c725..a78f6753b557 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-05-17 Daniel Franke + + PR fortran/31919 + * gfortran.dg/min_max_conformance.f90: New test. + 2007-05-17 Zdenek Dvorak * gcc.dg/tree-ssa/ssa-dom-thread-2.c: New test. diff --git a/gcc/testsuite/gfortran.dg/min_max_conformance.f90 b/gcc/testsuite/gfortran.dg/min_max_conformance.f90 new file mode 100644 index 000000000000..565408cd26a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/min_max_conformance.f90 @@ -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