From: Thomas Koenig Date: Thu, 4 Jan 2018 21:04:23 +0000 (+0000) Subject: re PR fortran/83683 (eoshift accepts wrong-length boundary) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fbd35ba1b352baa785f7d11bafe1ae64706a2bf5;p=gcc.git re PR fortran/83683 (eoshift accepts wrong-length boundary) 2018-01-04 Thomas Koenig PR fortran/83683 PR fortran/45689 * check.c (gfc_check_eoshift): Check for string length and for conformance of boundary. * intrinsic.c (add_functions): Add gfc_simplify_eoshift. * intrinsic.h: Add prototype for gfc_simplify_eoshift. * simplify.c (gfc_simplify_eoshift): New function. 2018-01-04 Thomas Koenig PR fortran/83683 PR fortran/45689 * gfortran.dg/eoshift_8.f90: New test. * gfortran.dg/simplify_eoshift_1.f90: New test. From-SVN: r256265 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 480f36a0254..7eb453dd2cc 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2018-01-04 Thomas Koenig + + PR fortran/83683 + PR fortran/45689 + * check.c (gfc_check_eoshift): Check for string length and + for conformance of boundary. + * intrinsic.c (add_functions): Add gfc_simplify_eoshift. + * intrinsic.h: Add prototype for gfc_simplify_eoshift. + * simplify.c (gfc_simplify_eoshift): New function. + 2018-01-03 Richard Sandiford Alan Hayward David Sherwood diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9f0f4d5b209..fccb9275bec 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2185,6 +2185,8 @@ bool gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { + int d; + if (!array_check (array, 0)) return false; @@ -2197,6 +2199,13 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (!dim_rank_check (dim, array, false)) return false; + if (!dim) + d = 1; + else if (dim->expr_type == EXPR_CONSTANT) + gfc_extract_int (dim, &d); + else + d = -1; + if (array->rank == 1 || shift->rank == 0) { if (!scalar_check (shift, 1)) @@ -2204,14 +2213,6 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, } else if (shift->rank == array->rank - 1) { - int d; - if (!dim) - d = 1; - else if (dim->expr_type == EXPR_CONSTANT) - gfc_extract_int (dim, &d); - else - d = -1; - if (d > 0) { int i, j; @@ -2246,6 +2247,24 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (!same_type_check (array, 0, boundary, 2)) return false; + /* Reject unequal string lengths and emit a better error message than + gfc_check_same_strlen would. */ + if (array->ts.type == BT_CHARACTER) + { + ssize_t len_a, len_b; + + len_a = gfc_var_strlen (array); + len_b = gfc_var_strlen (boundary); + if (len_a != -1 && len_b != -1 && len_a != len_b) + { + gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[0]->name, + &boundary->where, gfc_current_intrinsic); + return false; + } + } + if (array->rank == 1 || boundary->rank == 0) { if (!scalar_check (boundary, 2)) @@ -2253,13 +2272,27 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, } else if (boundary->rank == array->rank - 1) { - if (!gfc_check_conformance (shift, boundary, - "arguments '%s' and '%s' for " - "intrinsic %s", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic)) - return false; + if (d > 0) + { + int i,j; + for (i = 0, j = 0; i < array->rank; i++) + { + if (i != d - 1) + { + if (!identical_dimen_shape (array, i, boundary, j)) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid shape in dimension %d (%ld/%ld)", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &shift->where, i+1, + mpz_get_si (array->shape[i]), + mpz_get_si (boundary->shape[j])); + return false; + } + j += 1; + } + } + } } else { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index fa262ce3618..ed732aa5252 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1756,7 +1756,7 @@ add_functions (void) make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_eoshift, NULL, gfc_resolve_eoshift, + gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift, ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 9fd83166dbd..a7db830d381 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -287,6 +287,7 @@ gfc_expr *gfc_simplify_dot_product (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dreal (gfc_expr *); gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_epsilon (gfc_expr *); gfc_expr *gfc_simplify_erf (gfc_expr *); gfc_expr *gfc_simplify_erfc (gfc_expr *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 55ae05de69a..bf8a5397c45 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2347,6 +2347,271 @@ gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) } +gfc_expr * +gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, + gfc_expr *dim) +{ + bool temp_boundary; + gfc_expr *bnd; + gfc_expr *result; + int which; + gfc_expr **arrayvec, **resultvec; + gfc_expr **rptr, **sptr; + mpz_t size; + size_t arraysize, i; + gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; + ssize_t shift_val, len; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], + a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS]; + ssize_t rsoffset; + int d, n; + bool continue_loop; + gfc_expr **src, **dest; + size_t s_len; + + if (!is_constant_array_expr (array)) + return NULL; + + if (shift->rank > 0) + gfc_simplify_expr (shift, 1); + + if (!gfc_is_constant_expr (shift)) + return NULL; + + if (boundary) + { + if (boundary->rank > 0) + gfc_simplify_expr (boundary, 1); + + if (!gfc_is_constant_expr (boundary)) + return NULL; + } + + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + which = mpz_get_si (dim->value.integer) - 1; + } + else + which = 0; + + s_len = 0; + if (boundary == NULL) + { + temp_boundary = true; + switch (array->ts.type) + { + + case BT_INTEGER: + bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); + break; + + case BT_LOGICAL: + bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); + break; + + case BT_REAL: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); + break; + + case BT_COMPLEX: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); + break; + + case BT_CHARACTER: + s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); + bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); + break; + + default: + gcc_unreachable(); + + } + } + else + { + temp_boundary = false; + bnd = boundary; + } + + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + result->shape = gfc_copy_shape (array->shape, array->rank); + result->rank = array->rank; + result->ts = array->ts; + + if (arraysize == 0) + goto final; + + arrayvec = XCNEWVEC (gfc_expr *, arraysize); + array_ctor = gfc_constructor_first (array->value.constructor); + for (i = 0; i < arraysize; i++) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + } + + resultvec = XCNEWVEC (gfc_expr *, arraysize); + + extent[0] = 1; + count[0] = 0; + + for (d=0; d < array->rank; d++) + { + a_extent[d] = mpz_get_si (array->shape[d]); + a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; + } + + if (shift->rank > 0) + { + shift_ctor = gfc_constructor_first (shift->value.constructor); + shift_val = 0; + } + else + { + shift_ctor = NULL; + shift_val = mpz_get_si (shift->value.integer); + } + + if (bnd->rank > 0) + bnd_ctor = gfc_constructor_first (bnd->value.constructor); + else + bnd_ctor = NULL; + + /* Shut up compiler */ + len = 1; + rsoffset = 1; + + n = 0; + for (d=0; d < array->rank; d++) + { + if (d == which) + { + rsoffset = a_stride[d]; + len = a_extent[d]; + } + else + { + count[n] = 0; + extent[n] = a_extent[d]; + sstride[n] = a_stride[d]; + ss_ex[n] = sstride[n] * extent[n]; + n++; + } + } + + continue_loop = true; + d = array->rank; + rptr = resultvec; + sptr = arrayvec; + + while (continue_loop) + { + ssize_t sh, delta; + + if (shift_ctor) + sh = mpz_get_si (shift_ctor->expr->value.integer); + else + sh = shift_val; + + if (( sh >= 0 ? sh : -sh ) > len) + { + delta = len; + sh = len; + } + else + delta = (sh >= 0) ? sh: -sh; + + if (sh > 0) + { + src = &sptr[delta * rsoffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[delta * rsoffset]; + } + + for (n = 0; n < len - delta; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + + if (sh < 0) + dest = rptr; + + n = delta; + + if (bnd_ctor) + { + while (n--) + { + *dest = gfc_copy_expr (bnd_ctor->expr); + dest += rsoffset; + } + } + else + { + while (n--) + { + *dest = gfc_copy_expr (bnd); + dest += rsoffset; + } + } + rptr += sstride[0]; + sptr += sstride[0]; + if (shift_ctor) + shift_ctor = gfc_constructor_next (shift_ctor); + + if (bnd_ctor) + bnd_ctor = gfc_constructor_next (bnd_ctor); + + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + rptr -= ss_ex[n]; + sptr -= ss_ex[n]; + n++; + if (n >= d - 1) + { + continue_loop = false; + break; + } + else + { + count[n]++; + rptr += sstride[n]; + sptr += sstride[n]; + } + } + } + + for (i = 0; i < arraysize; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (resultvec[i]), + NULL); + } + + final: + if (temp_boundary) + gfc_free_expr (bnd); + + return result; +} + gfc_expr * gfc_simplify_erf (gfc_expr *x) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1ac4c5fdb66..7f60c14e7e4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-01-04 Thomas Koenig + + PR fortran/83683 + PR fortran/45689 + * gfortran.dg/eoshift_8.f90: New test. + * gfortran.dg/simplify_eoshift_1.f90: New test. + 2018-01-04 Jakub Jelinek PR debug/83585 diff --git a/gcc/testsuite/gfortran.dg/eoshift_8.f90 b/gcc/testsuite/gfortran.dg/eoshift_8.f90 new file mode 100644 index 00000000000..0930638bc15 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/eoshift_8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 83664 - invalid code that used to be accepted. +program main + implicit none + integer :: n + integer :: i,n1, n2, n3 + character(len=3), parameter :: e(2,3,4) = reshape([(repeat(achar(i),3),i=iachar('a'),iachar('a')+2*3*4-1)], & + shape(e)) + character(len=3), parameter :: bnd2(3,5) = reshape([(repeat(achar(i),3),i=iachar('A'),iachar('A')+3*5-1)], & + shape(bnd2)) + character(len=3) :: f2(2,3,4) + + n = -1 + f2 = eoshift(e,shift=n,boundary=bnd2) ! { dg-error "has invalid shape" } + f2 = eoshift(e,shift=1,boundary="x") ! { dg-error "must be of same type and kind" } + + print '(*(1H",A,1H",:","))',f2 +end program main diff --git a/gcc/testsuite/gfortran.dg/simplify_eoshift_1.f90 b/gcc/testsuite/gfortran.dg/simplify_eoshift_1.f90 new file mode 100644 index 00000000000..29521b22eed --- /dev/null +++ b/gcc/testsuite/gfortran.dg/simplify_eoshift_1.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +program main + implicit none + integer :: i,n1, n2, n3 + integer, parameter :: a(3) = [1,2,3] + integer, parameter :: b1(3) = eoshift(a,0) + integer, parameter :: b2(3) = eoshift(a,1) + integer, parameter :: b3(3) = eoshift(a,-2) + integer, parameter :: b4(3) = eoshift(a,4,boundary=42) + integer, parameter :: c(3,3) = reshape([(i,i=1,3*3)],shape(c)) + integer, parameter :: b5(3,3) = eoshift(c,shift=1,dim=1,boundary=33) + integer, parameter :: b6(3,3) = eoshift(c,shift=2,dim=1) + integer, parameter :: b7(3,3) = eoshift(c,shift=-1,dim=2) + integer, parameter :: b8(3,3) = eoshift(c,shift=-1,dim=2,boundary=[-1,-2,-3]) + integer, parameter :: b9(3,3) = eoshift(c,shift=[-1,-1,-1]) + integer, parameter :: b10(3,3) = eoshift(c,shift=[-1,0,1]); + integer, parameter :: b11(3,3) = eoshift(c,dim=2,shift=[-2,-1,1],boundary=42); + integer, parameter :: b12(3,3) = eoshift(c,dim=1,shift=[-1,-2,0],boundary=[-3,-7,-9]) + real, parameter :: r(3,4,5) = reshape([(1.0*i**2,i=1,3*4*5)],shape(r)) + real, parameter :: q1(3,4,5) = eoshift(r,shift=1,dim=3) + integer, parameter :: sh1(3,4) = reshape([-1,-2,0,3,2,5,6,-6,3,1,-1,-5],shape(sh1)) + real, parameter :: bnd1(3,4) = reshape([-1.,-2.,-3.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,-11.,-12.],shape(bnd1)) + real, parameter :: q2(3,4,5) = eoshift(r,dim=3,shift=sh1) + real, parameter :: q3(3,4,5) = eoshift(r,dim=3,shift=sh1,boundary=bnd1) + complex(kind=8), parameter :: s(3,3) = reshape([(cmplx(i*i-5*i,-i+4,kind=8),i=1,9)],shape(s)) + complex(kind=8), parameter :: t(3,3) = eoshift(s,shift=4) + character(len=3), parameter :: e(2,3,4) = reshape([(repeat(achar(i),3),i=iachar('a'),iachar('a')+2*3*4-1)], & + shape(e)) + character(len=3) :: e2(2,3,4) + character(len=3), parameter :: f1(2,3,4) = eoshift(e,1) + character(len=3), parameter :: bnd2(2,4) = reshape([(repeat(achar(i),3),i=iachar('A'),iachar('A')+2*4-1)], & + shape(bnd2)) + character(len=3), parameter :: f2(2,3,4) = eoshift(e,dim=2,shift=-1,boundary=bnd2); + integer, parameter :: sh2(2,3) = reshape([1, -2, 0, 1, 2, -1, 2, 0],shape(sh2)) + character(len=3), parameter :: f3(2,3,4) = eoshift(e,dim=3,shift=sh2) + integer, parameter :: empty(1:0) =[integer ::] + integer, parameter :: empty2(1:0) = eoshift(empty,1) + + n1 = 1 + n2 = 2 + n3 = 3 + + if (any(b1 /= a)) call abort + if (any(b2 /= [2, 3, 0])) call abort + if (any(b3 /= [0, 0, 1])) call abort + if (any(b4 /= 42)) call abort + if (any(eoshift(c,shift=1,dim=n1,boundary=33) /= b5)) call abort + if (any(eoshift(c,shift=2,dim=1) /= b6)) call abort + if (any(eoshift(c,shift=-1,dim=2) /= b7)) call abort + if (any(eoshift(c,shift=-1,dim=n2,boundary=[-1,-2,-3]) /= b8)) call abort + if (any(eoshift(c,shift=-1) /= b9)) call abort + if (any(eoshift(r,shift=1,dim=n3) /= q1)) call abort + if (any(b10 /= reshape([ 0, 1, 2, 4, 5, 6, 8, 9, 0],shape(b10)))) call abort + if (any(b11 /= reshape([42, 42, 6, 42, 2, 9, 1, 5, 42],shape(b11)))) call abort + if (any(b12 /= reshape([ -3, 1, 2, -7, -7, 4, 7, 8, 9],shape(b11)))) call abort + if (any(q1 /= reshape([169.,196.,225.,256.,289.,324.,361.,400.,441.,484.,529.,576.,625.,& + 676.,729.,784.,841.,900.,961.,1024.,1089.,1156.,1225.,1296.,1369.,1444.,1521.,& + 1600.,1681.,1764.,1849.,1936.,2025.,2116.,2209.,2304.,2401.,2500.,2601.,2704.,& + 2809.,2916.,3025.,3136.,3249.,3364.,3481.,3600.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.],& + shape(q1)))) call abort + if (any(q2 /= reshape([0.,0.,9.,1600.,841.,0.,0.,0.,2025.,484.,0.,0.,1.,0.,225.,2704.,& + 1681.,0.,0.,0.,3249.,1156.,121.,0.,169.,4.,729.,0.,2809.,0.,0.,0.,0.,2116.,& + 529.,0.,625.,196.,1521.,0.,0.,0.,0.,0.,0.,3364.,1225.,0.,1369.,676.,2601.,& + 0.,0.,0.,0.,0.,0.,0.,2209.,0.],shape(q2)))) call abort + if (any(q3 /= reshape([-1.,-2.,9.,1600.,841.,-6.,-7.,-8.,2025.,484.,-11.,-12.,1.,& + -2.,225.,2704.,1681.,-6.,-7.,-8.,3249.,1156.,121.,-12.,169.,4.,729.,-4.,& + 2809.,-6.,-7.,-8.,-9.,2116.,529.,-12.,625.,196.,1521.,-4.,-5.,-6.,-7.,-8.,& + -9.,3364.,1225.,-12.,1369.,676.,2601.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,2209.,-12.],& + shape(q3)))) call abort + if (any(f1 /= reshape(["bbb"," ","ddd"," ","fff"," ","hhh"," ","jjj"," ","lll"," ",& + "nnn"," ","ppp"," ","rrr"," ","ttt"," ","vvv"," ","xxx"," "], & + shape(f1)))) call abort + if (any(f2 /= reshape(["AAA","BBB","aaa","bbb","ccc","ddd","CCC","DDD","ggg","hhh","iii","jjj",& + "EEE","FFF","mmm","nnn","ooo","ppp","GGG","HHH","sss","ttt","uuu","vvv"],shape(f2)))) call abort + + e2 = e + if (any (f2 /= eoshift(e2,dim=2,shift=-1,boundary=bnd2))) call abort + if (any (f3 /= reshape (["ggg"," ","ccc","jjj","qqq"," ","mmm"," ","iii","ppp",& + "www","fff","sss","bbb","ooo","vvv"," ","lll"," ","hhh","uuu",& + " "," ","rrr"], shape(f3)))) call abort + if (size(empty) /=0) call abort + if (any(t /= (0.0_8, 0.0_8))) call abort +end program main