diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 11 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 | 55 |
4 files changed, 78 insertions, 1 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d9dd618..b9293de 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2020-02-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/92785 + * trans-expr.c (gfc_conv_intrinsic_to_class): Renormalise non- + variable expressions to be unity lbound based. + 2020-02-25 Steven G. Kargl <kargl@gcc.gnu.org> * simplify.c (degrees_f): Remove unused code. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5825a4b..9d0921e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -843,6 +843,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, tree ctree; tree var; tree tmp; + int dim; /* The intrinsic type needs to be converted to a temporary CLASS object. */ @@ -892,6 +893,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, parmse->ss = ss; parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); + + /* Array references with vector subscripts and non-variable expressions + need be converted to a one-based descriptor. */ + if (e->expr_type != EXPR_VARIABLE) + { + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr, + dim, gfc_index_one_node); + } + if (class_ts.u.derived->components->as->rank != e->rank) { tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3727ae2..c149357 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2020-02-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/92785 + * gfortran.dg/unlimited_polymorphic_31.f03 : New test. + 2020-02-28 Jakub Jelinek <jakub@redhat.com> P1937R2 - Fixing inconsistencies between const{expr,eval} functions @@ -987,7 +992,7 @@ PR c++/93559 - ICE with CONSTRUCTOR flags verification. * g++.dg/cpp0x/initlist119.C: New test. * g++.dg/cpp0x/initlist120.C: New test. - + 2020-02-05 Jakub Jelinek <jakub@redhat.com> PR c++/93557 diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 new file mode 100644 index 0000000..dd47c34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Test the fix for PR92785, where the array passed to 'write scalar' was not +! normalised to LBOUND = 1. +! +! Contributed by <urbanjost@comcast.net> +! + program tst + use iso_fortran_env, only : compiler_version, compiler_options + implicit none + integer :: i + integer :: ibad=0 + integer :: iarr(10) = [(i*10, i = 1,size (iarr))] + character(len=:), allocatable :: line + character(len=*), parameter :: expected = '10 20 30 40 50 60 70 80 90 100' + character(len=*), parameter :: expected_minus = '-10 -20 -30 -40 -50 -60 -70 -80 -90 -100' + print '(4a)', & + 'This file was compiled by ', compiler_version(), & + ' using the options ', compiler_options() + call write_row ('iarr ', iarr) ! pass in the array, OK + call write_row ('iarr+0 ', iarr+0) ! pass in an expression, NOT OK + call write_row ('-iarr ', -iarr) ! pass in an expression, NOT OK + call write_row ('iarr(::1) ', iarr(::1)) ! pass in the array, OK + call write_row ('[iarr(::1)] ', [iarr(::1)]) ! pass in compound constructor, NOT OK + call write_row ('[(i*10,i=1,size(iarr))]', [(i*10,i=1,size(iarr))]) ! pass in constructor, OK + call write_row ('10*[(i,i=1,size(iarr))]', 10*[(i,i=1,size(iarr))]) ! pass in constructor, OK + if (ibad .gt. 0) stop 'FAILED' + contains + subroutine write_scalar (g1) + class(*) :: g1 + character(len = 20) :: word + select type(g1) + type is (integer) + write (word, '(i0)') g1 + line = line // trim( word) // ' ' + end select + end subroutine write_scalar + subroutine write_row (string,array) + character(len = *) :: string + class(*) :: array(:) + integer :: i + line = '' + do i = 1, size (array) + call write_scalar (array(i)) + enddo + if (expected .eq. line) then + write (*, *) string, ':GOOD' + else if (expected_minus .eq. line) then + write (*, *) string, ':GOOD' + else + write (*, *) string, ':BAD. EXPECTED [', expected, '] got [', trim (line),']' + ibad = ibad + 1 + endif + end subroutine write_row + end program tst |