Re: [PATCH, Fortran] PR fortran/60289 First try on: Fixing character array allocation for class(*) type variable

[Mikael Morin <mikael dot morin at sfr dot fr>]

Le 17/08/2014 14:46, Dominique Dhumieres a écrit :
>> My knowledge of unlimited polymorphic types is limited, but I think that
>> this is not correct.
> 
> My knowledge of unlimited polymorphic types is even more limited,
> then I cannot comment about the correctness of the patch. However
> 
>> The new length of the string has to be stored somewhere.  If you don't
>> do that, for example the intrinsic len() function won't work.
> 
> if I add a line
> 
>             if (len(P) /= 20) call abort()
> 
> in the 'type is (character(*))' block, the test still succeeds.
> 
> Dominique
> 
Here is a failing testcase.
I must admit it wasn't easy to find, and it's probably at least as much
a bug with select as with allocate.
It seems that for unlimited polymorphic entities, the _size vtable field
is used as character length.
So there is no need to explicitly set the character length as the whole
vtable is overwritten upon allocation.  And the patch works.
I don't know how we cope with non-default kind though (which is what the
testcase is about).

Mikael


$ ./unlimited_polymorphic_20
 here
 there

Program aborted. Backtrace:
#0  0x7FDFBA026B57
#1  0x7FDFBA028272
#2  0x7FDFBA0F3218
#3  0x400E24 in test_sub at unlimited_polymorphic_20.f90:24
(discriminator 1)
#4  0x400C0D in test at unlimited_polymorphic_20.f90:6
Abandon
$



program test
    call test_sub
  contains

    subroutine test_sub
    implicit none

    class(*), pointer :: P

    allocate(character(len=20, kind=4)::P)

    select type(P)
        type is (character(len=*, kind=4))
            print *, "here"
            P ="some test string"
            if (P .ne. 4_"some test string") then
                call abort()
            end if
            print *, "there"
            if (len(P) /= 20) call abort
            print *, "not there"
        class default
            print *, "bah"
            call abort()
    end select

    deallocate(P)
    end subroutine test_sub
end program test