diff options
author | Thomas Koenig <tkoenig@gcc.gnu.org> | 2007-08-01 20:27:27 +0000 |
---|---|---|
committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2007-08-01 20:27:27 +0000 |
commit | 870c06b9d5b9d5771470b868232eeeb60f3d080a (patch) | |
tree | 147166a2485977f5092668b2dfccd1d28aa8c731 | |
parent | e4fd64d6757db8dba0b706f1b141b3d7cb1ac63c (diff) | |
download | gcc-870c06b9d5b9d5771470b868232eeeb60f3d080a.zip gcc-870c06b9d5b9d5771470b868232eeeb60f3d080a.tar.gz gcc-870c06b9d5b9d5771470b868232eeeb60f3d080a.tar.bz2 |
re PR libfortran/32954 (pack with -fdefault-integer-8)
2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32954
* intrinsic.c (resolve_mask_arg): New function.
(gfc_resolve_maxloc): Use resolve_mask_arg for mask resolution.
(gfc_resolve_maxval): Likewise.
(gfc_resolve_minloc): Likewise.
(gfc_resolve_minval): Likewise.
(gfc_resolve_pack): Likewise.
(gfc_resolve_product): Likewise.
(gfc_resolve_sum): Likewise.
(gfc_resolve_unpack): Likewise.
2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32954
* minmaxloc_3.f90: New test case.
From-SVN: r127137
-rw-r--r-- | gcc/fortran/ChangeLog | 13 | ||||
-rw-r--r-- | gcc/fortran/iresolve.c | 140 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/minmaxloc_3.f90 | 119 |
4 files changed, 180 insertions, 97 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 81bff2b..1d6ca66 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32954 + * intrinsic.c (resolve_mask_arg): New function. + (gfc_resolve_maxloc): Use resolve_mask_arg for mask resolution. + (gfc_resolve_maxval): Likewise. + (gfc_resolve_minloc): Likewise. + (gfc_resolve_minval): Likewise. + (gfc_resolve_pack): Likewise. + (gfc_resolve_product): Likewise. + (gfc_resolve_sum): Likewise. + (gfc_resolve_unpack): Likewise. + 2007-08-01 Tobias Burnus <burnus@net-b.de> PR fortran/32936 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 9c388c5..32ed6da 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -72,6 +72,41 @@ check_charlen_present (gfc_expr *source) } } +/* Helper function for resolving the "mask" argument. */ + +static void +resolve_mask_arg (gfc_expr *mask) +{ + int newkind; + + /* The mask can be kind 4 or 8 for the array case. + For the scalar case, coerce it to kind=4 unconditionally + (because this is the only kind we have a library function + for). */ + + newkind = 0; + + if (mask->rank == 0) + { + if (mask->ts.kind != 4) + newkind = 4; + } + else + { + if (mask->ts.kind < 4) + newkind = gfc_default_logical_kind; + } + + if (newkind) + { + gfc_typespec ts; + + ts.type = BT_LOGICAL; + ts.kind = newkind; + gfc_convert_type (mask, &ts, 2); + } +} + /********************** Resolution functions **********************/ @@ -1232,16 +1267,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, else name = "mmaxloc"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "maxloc"; @@ -1286,16 +1312,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, else name = "mmaxval"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "maxval"; @@ -1386,16 +1403,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, else name = "mminloc"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "minloc"; @@ -1440,16 +1448,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, else name = "mminval"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "minval"; @@ -1555,35 +1554,10 @@ void gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, gfc_expr *vector ATTRIBUTE_UNUSED) { - int newkind; - f->ts = array->ts; f->rank = 1; - /* The mask can be kind 4 or 8 for the array case. For the scalar - case, coerce it to kind=4 unconditionally (because this is the only - kind we have a library function for). */ - - newkind = 0; - if (mask->rank == 0) - { - if (mask->ts.kind != 4) - newkind = 4; - } - else - { - if (mask->ts.kind < 4) - newkind = gfc_default_logical_kind; - } - - if (newkind) - { - gfc_typespec ts; - - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type (mask, &ts, 2); - } + resolve_mask_arg (mask); if (mask->rank != 0) f->value.function.name = (array->ts.type == BT_CHARACTER @@ -1615,16 +1589,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, else name = "mproduct"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "product"; @@ -2112,16 +2077,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) else name = "msum"; - /* The mask can be kind 4 or 8 for the array case. For the - scalar case, coerce it to default kind unconditionally. */ - if ((mask->ts.kind < gfc_default_logical_kind) - || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind)) - { - gfc_typespec ts; - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type_warn (mask, &ts, 2, 0); - } + resolve_mask_arg (mask); } else name = "sum"; @@ -2350,17 +2306,7 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, { f->ts = vector->ts; f->rank = mask->rank; - - /* Coerce the mask to default logical kind if it has kind < 4. */ - - if (mask->ts.kind < 4) - { - gfc_typespec ts; - - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - gfc_convert_type (mask, &ts, 2); - } + resolve_mask_arg (mask); f->value.function.name = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0755f4f..15364b9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32954 + * minmaxloc_3.f90: New test case. + 2007-08-01 Tobias Burnus <burnus@net-b.de> PR fortran/32936 diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_3.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_3.f90 new file mode 100644 index 0000000..fbc1b09 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_3.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! Check max/minloc. +! PR fortran/32956, wrong mask kind with -fdefault-integer-8 +! +program test + implicit none + integer :: i(1), j(-1:1), res(1) + logical, volatile :: m(3), m2(3) + m = (/ .false., .false., .false. /) + m2 = (/ .false., .true., .false. /) + call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2)) + call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(7, 0, MAXLOC(i(1:0), DIM=1)) + call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(13,0, MINLOC(i(1:0), DIM=1)) + + j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1)) + + j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.)) + + j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.)) + + j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m)) + + j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2)) + +! Check the library minloc and maxloc + res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2, res(1)) + res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0, res(1)) + res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0, res(1)) + res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0, res(1)) + res = MAXLOC(i(1:0)); call check(50, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1)) + res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1)) + res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1)) + res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1)) + res = MINLOC(i(1:0)); call check(56,0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1)) + +contains +subroutine check(n, i,j) + integer, value, intent(in) :: i,j,n + if(i /= j) then + call abort() +! print *, 'ERROR: Test',n,' expected ',i,' received ', j + end if +end subroutine check +end program |