[Fortran] RFC patch for gfc_trans_deferred_vars (PR 48786)

Dear all,

gfc_trans_deferred_vars is a bit of a mess; there is first a block which 
handles function results of the type proc_sym->result == proc_sym. 
Afterwards, deferred variables - local, dummys, and proc_sym->result (!= 
proc_sym) are handled.

The problem is that for allocatable results (esp. of CLASS type) and for 
deferred-length strings, the same initialization has to happen as for 
function results.

Consequence: There is code partial duplication - and some code should be 
duplicated, but is not; that causes the issue with the current code.

Attached patch tries to fix that; it fixes Arjan's wrong-code issue and 
it also reduces the code size; however, I do not think that it makes the 
code very readable.

What do you think? How can this be improved? Or should the patch be 
committed as is? (The patch was regtested on x86-64-linux.)

Tobias
! { dg-do run }
!
! PR fortran/24141
!
! Contributed by Arjen Markus; the trace module
! is from Simon Geard. 
!

! -------------------------------------
! Copyright 2011 Simon Geard. All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!    1. Redistributions of source code must retain the above copyright notice, this list of
!       conditions and the following disclaimer.
!
!    2. Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials
!       provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY <COPYRIGHT HOLDER> ``AS IS'' AND ANY EXPRESS OR IMPLIED
! WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module trace
  implicit none
  type tracing
     integer           :: level = 0
     character(len=3)  :: indent = '   '

   contains
     procedure, public :: in
     procedure, public :: out
     procedure, public :: message
     procedure, public :: get_current_indent
     procedure, public :: print_current_indent
  end type tracing

  type(tracing), public :: tr
  logical, private      :: s_trace_is_on = .false.

contains

  subroutine set_trace_on
    s_trace_is_on = .true.
  end subroutine set_trace_on

  subroutine set_trace_off
    s_trace_is_on = .false.
  end subroutine set_trace_off

  logical function trace_is_on()
    trace_is_on = s_trace_is_on
  end function trace_is_on

  subroutine in(this, name)
    implicit none
    class(tracing), intent(inout) :: this
    character(len=*), intent(in) :: name
    if (s_trace_is_on) then
       write(*,'(a)') repeat(this%indent,this%level)//name//'<in>'
    end if
    this%level = this%level + 1
  end subroutine in

  subroutine out(this, no_message)
    implicit none
    class(tracing), intent(inout) :: this
    logical, optional             :: no_message ! = .true.
    logical :: output_mess
    this%level = this%level - 1
    if (s_trace_is_on) then
       output_mess = merge(no_message, .true., present(no_message))
       if (output_mess) write(*,'(a)') repeat(this%indent,this%level)//'<out>'
    end if
  end subroutine out

  subroutine message(this, mess)
    class(tracing), intent(in)   :: this
    character(len=*), intent(in) :: mess
    if (s_trace_is_on) then
       write(*,'(a)') repeat(this%indent,this%level)//mess
    end if
  end subroutine message

  subroutine print_current_indent(this)
    class(tracing), intent(in)    :: this
    if (this%level > 0) then
       write(*,advance='no',fmt = '(a)') repeat(this%indent,this%level)
    end if
  end subroutine print_current_indent

  subroutine get_current_indent(this, indent, nindent)
    class(tracing), intent(in)    :: this
    character(len=*), intent(out) :: indent
    integer, intent(out)          :: nindent
    indent = repeat(this%indent,this%level)
    nindent = len(this%indent)*this%level
  end subroutine get_current_indent
end module trace

module points2d3d
  use trace
  implicit none

  type point2d
     real :: x, y
   contains
     procedure               :: print           => print_2d
     procedure               :: add_vector      => add_vector_2d
     procedure               :: random          => random_vector_2d
     procedure               :: assign          => assign_2d
     generic, public         :: operator(+)     => add_vector
     generic, public         :: assignment(=)   => assign
  end type point2d

  type, extends(point2d) :: point3d
     real :: z
   contains
     procedure               :: print           => print_3d
     procedure               :: add_vector      => add_vector_3d
     procedure               :: random          => random_vector_3d
     procedure               :: assign          => assign_3d
!!   generic, public         :: operator(+) => add_vector
!!   generic, public         :: assignment(=)   => assign
  end type point3d

contains
  subroutine print_2d( point )
    class(point2d) :: point

    write(*,'(2f10.4)') point%x, point%y
  end subroutine print_2d

  subroutine print_3d( point )
    class(point3d) :: point

    write(*,'(3f10.4)') point%x, point%y, point%z
  end subroutine print_3d

  subroutine random_vector_2d( point )
    class(point2d) :: point

    call random_number( point%x )
    call random_number( point%y )

    point%x = 2.0 * point%x - 1.0
    point%y = 2.0 * point%y - 1.0

  end subroutine random_vector_2d

  !
  ! This routine gets confused for the 2D variant
  ! - essentially the same interface?
  subroutine random_vector_3d( point )
    class(point3d) :: point

    call point%point2d%random
    call random_number( point%z )

    point%z = 2.0 * point%z - 1.0

  end subroutine random_vector_3d

function add_vector_2d( point, vector )
    class(point2d), intent(in)  :: point, vector
    class(point2d), allocatable :: add_vector_2d

    if ( allocated(add_vector_2d) ) then
        deallocate( add_vector_2d )
    endif
    allocate( add_vector_2d )
    add_vector_2d%x = point%x + vector%x
    add_vector_2d%y = point%y + vector%y
  end function add_vector_2d

  function add_vector_3d( point, vector )
    class(point3d), intent(in)  :: point
    class(point2d), intent(in)  :: vector

    class(point3d), allocatable :: vector_3d
    class(point2d), allocatable :: add_vector_3d

    allocate( vector_3d )

    select type (vector)
        class is (point3d)
            vector_3d%point2d = point%point2d + vector%point2d
            vector_3d%z       = point%z       + vector%z
    end select

    call move_alloc( vector_3d, add_vector_3d )

  end function add_vector_3d

  subroutine assign_2d( left, right )
    class(point2d), intent(inout) :: left
    class(point2d), intent(in)    :: right

    left%x = right%x
    left%y = right%y
  end subroutine assign_2d

  subroutine assign_3d( left, right )
    class(point3d), intent(inout) :: left
    class(point2d), intent(in)    :: right

    select type (right)
        type is (point3d)
            left%point2d = right%point2d
            left%z       = right%z
    end select

  end subroutine assign_3d

end module points2d3d

program random_walk

  use points2d3d   ! Both 2D and 3D points available

  type(point2d), target   :: point_2d, vector_2d
  type(point3d), target   :: point_3d, vector_3d

!
  ! A variable of class point2d can point to point_2d but
  ! also to point_3d
  !
  class(point2d), pointer :: point, vector

  integer        :: nsteps = 3 ! Was 10
  integer        :: i
  integer        :: trial
  real           :: deltt  = 0.1

  ! Select what type of point ...

  do trial = 1,2
     if (trial == 1) then
        write(*,*) 'Two-dimensional walk:'
        point => point_2d
        vector => vector_2d
     else
        ! Now let's take a 3D walk ...
        write(*,*) 'Three-dimensional walk:'
        point => point_3d
        vector => vector_3d
     end if

     call point%random

     do i = 1,nsteps
        call vector%random

        point = point + vector

        call point%print
     enddo
  enddo

end program random_walk

! { dg-final { cleanup-modules "trace points2d3d" } }

[Fortran] RFC patch for gfc_trans_deferred_vars (PR 48786)

Commit Message

Comments

Patch