Commit for PR92785

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d9dd618..b9293de 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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