Second program causing an ICE

[Arjen Markus]

Hello,

here is the second program that causes an internal compiler error.
This time the message includes the name of a routine -
gfc+enforce_symbol_state in fortran/symbol.c
(line 3482)

The program is this (again: I know it is incorrect and I have achieved
what I wanted in a different way):


! classes_geom.f90 --
!     Classes of geometrical objects as an illustration
!     of object-oriented programming in Fortran
!
module geometrical_objects

    implicit none

    !
    ! General shape
    !
    type, abstract :: shape
        ! No data
    contains
        procedure(get_shape_area), deferred           :: get_area
        procedure(assign_shape), deferred, pass(that) :: assign_type_to_shape
        generic                                       :: assignment(=)
=> assign_type_to_shape
        !procedure                                    :: size  -- does not work
    end type shape

    abstract interface
        real function get_shape_area( this )
            import                   :: shape
            class(shape), intent(in) :: this
        end function get_shape_area
    end interface

    abstract interface
        subroutine assign_shape( this, that )
            import                      :: shape
            class(shape), intent(inout) :: this
            class(shape), intent(in)    :: that
        end subroutine assign_shape
    end interface

    !
    ! Rectangle
    !
    type, extends(shape) :: rectangle
        real :: width, height
    contains
        procedure :: get_area             => get_rectangle_area
        procedure :: size                 => rectangle_size
        procedure, pass(that) :: assign_type_to_shape => assign_rectangle
    end type rectangle

    !
    ! Square
    ! Note:
    ! square_size must have the same interface as its rectangle parent!
    !
    type, extends(rectangle) :: square
    contains
        procedure :: size => square_size
        procedure :: assign_type_to_shape => assign_square
    end type square

contains

!
! The various routines and functions we need
!
real function get_rectangle_area( this )
    class(rectangle), intent(in) :: this

    get_rectangle_area = this%width * this%height

end function get_rectangle_area

subroutine rectangle_size( this, width, height )
    class(rectangle), intent(inout) :: this
    real, intent(in)                :: width
    real, intent(in), optional      :: height

    this%width  = width
    if ( present(height) ) then
        this%height = height
    else
        this%height = width
    endif

end subroutine rectangle_size

subroutine assign_rectangle( this, that )
    class(shape),     intent(inout) :: this
    class(rectangle), intent(in)    :: that

    select type( that )
        class is (rectangle)
            this = that
    end select

end subroutine assign_rectangle

subroutine square_size( this, width, height )
    class(square), intent(inout) :: this
    real, intent(in)             :: width
    real, intent(in), optional   :: height  ! Ignored

    this%width  = width
    this%height = width

end subroutine square_size

subroutine assign_square( this, that )
    class(shape),  intent(inout) :: this
    class(square), intent(in)    :: that

    select type( that )
        class is (square)
            this = that
    end select

end subroutine assign_square

end module geometrical_objects

!
! Small test program
program test_objects

    use geometrical_objects

    implicit none

    class(shape), dimension(2) :: object
    type(rectangle)            :: rect
    type(square)               :: sq

    call rect%size( 1.0, 2.0 )
    call sq%size( 1.5 )

    object(1) = rect
    object(2) = sq

    do i = 1,size(object)
        write(*,*) 'Area: ', object(i)%get_area()
    enddo

contains

end program test_objects

Regards,

Arjen