[Bug fortran/98534] New: Intrinsic functions failing with unlimited polymorphic actual arguments

["pault at gcc dot gnu.org" <gcc-bugzilla@gcc.gnu.org>]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98534

            Bug ID: 98534
           Summary: Intrinsic functions failing with unlimited polymorphic
                    actual arguments
           Product: gcc
           Version: 11.0
            Status: UNCONFIRMED
          Keywords: wrong-code
          Severity: normal
          Priority: P3
         Component: fortran
          Assignee: pault at gcc dot gnu.org
          Reporter: pault at gcc dot gnu.org
  Target Milestone: ---

Created attachment 49891
  --> https://gcc.gnu.org/bugzilla/attachment.cgi?id=49891&action=edit
Provisional patch

Unlimited polymorphic actual arguments to 'storage_size' and 'transfer' fail,
when the dynamic type is character. This comes about because the '_len' field
is not used. The attached is a partial, provisional patch. I have not checked
other intrinsics yet.

It should also be noted that 'same_type_as' still uses the '_hash' field of the
vptr, rather than its address. This is known to fail in some cases.

A testcase can be found below.

Paul

! No errors with 
  character(*), parameter :: string = "abcdefgh"
  class(*), allocatable :: star
  character(len=:), allocatable :: chr
  integer :: sz, sum1, sum2

! Part 1: works correctly
  star = 1.0
  sz = storage_size (star)/8
  allocate (character(len=sz) :: chr)
  chr = transfer (star, chr)
  sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
  chr = transfer(1.0, chr)
  sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])

  if (sz /= kind (1.0)) stop 1
  if (sum1 /= sum2) stop 2

  deallocate (star) ! The automatic reallocation causes invalid writes
                    ! and memory leaks. Even with this deallocation
                    ! The invalid writes still occur.
  deallocate (chr)

! Part 2: gets everything from because '_len' field of 'star' not used
  star = string
  sz = storage_size (star)/8
  if (sz /= len (string)) print *, "stop 3" ! storage_size fails

  sz = len (string) ! Ignore previous error in storage_size
  allocate (character(len=sz) :: chr)
  chr = transfer (star, chr)
  sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
  chr = transfer(string, chr)
  sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
  if (sum1 /= sum2) print *, "stop 4"       ! transfer fails

  deallocate (star, chr)
end