[讨论] 多态指针问题

module super_class !父类
    implicit none
    private
    public::point

    type::point !父类 
        real::x=0.0
        real::y=0.0
    contains
        procedure,pass(me)::point_new   !构造方法
        procedure,pass(me)::point_print !打印实例变量
        procedure,pass(me)::add 
        procedure,pass(me)::an
        generic::assignment(=) => an  !重载=
        generic::operator(+)   => add !重载+
    end type point
contains
    subroutine point_new(me,x,y) !父类构造方法
        class(point),intent(inout)::me
        real,intent(in)::x
        real,intent(in)::y

        me%x=x
        me%y=y
    end subroutine point_new

    subroutine point_print(me)
        class(point),intent(in)::me

        write(*,*)'x=',me%x,'y=',me%y
    end subroutine point_print

    subroutine an(me,p) !父类赋值运算
        class(point),intent(out)::me
        class(point),intent(in)::p

        me%x=p%x
        me%y=p%y
    end subroutine an

    function add(me,p) !父类加法运算
        class(point),intent(in)::me
        class(point),intent(in)::p
        class(point),pointer::add !返回类型为多态指针

        allocate(point::add) !多态指针分配父类内存
        add%x=me%x+p%x
        add%y=me%y+p%y
    end function add
end module super_class

module sub_class !子类
    use super_class
    implicit none
    private
    public::point3d

    type,extends(point)::point3d 
        real::z=0.0
    contains
        procedure,pass(me)::point_print !重写父类方法
        procedure,pass(me)::point3d_new !子类构造方法
        procedure,pass(me)::add !重写父类方法
        procedure,pass(me)::an  !重写父类方法
    end type point3d
contains
    subroutine point3d_new(me,x,y,z) !子类构造方法
        class(point3d),intent(inout)::me
        real,intent(in)::x
        real,intent(in)::y
        real,intent(in)::z
        !子类调用父类构造方法
        me%x=x;me%y=y !等价于call me%point%point_new(x,y)
        me%z=z
    end subroutine point3d_new

    subroutine point_print(me) !重写父类方法
        class(point3d),intent(in)::me

        write(*,*)'x=',me%x,'y=',me%y,'z=',me%z
    end subroutine point_print

    function add(me,p) !重写父类方法
        class(point3d),intent(in)::me
        class(point),intent(in)::p
        class(point),pointer::add !返回类型为多态指针
        type(point)::a
        type(point3d)::b

        allocate(point3d::add) !多态指针分配子类内存
        write(*,*)SAME_TYPE_AS(add,b),SAME_TYPE_AS(add,a)
        add%x=me%x+p%x
        add%y=me%y+p%y

        select type(add)
        type is(point3d)
            !一般情况下p%z不可访问
            select type(p) !可绕过上述限制
            type is(point3d)
                add%z=me%z+p%z !父类访问子类成员变量
            end select
        end select
    end function add

    subroutine an(me,p)
        class(point3d),intent(out)::me
        class(point),intent(in)::p

        me%x=p%x
        me%y=p%y
        !一般情况下p%z不可访问
        select type(p) !可绕过上述限制
        type is(point3d)
            me%z=p%z !父类访问子类成员变量
        end select
    end subroutine an
end module sub_class

program main !主程序
    use super_class
    use sub_class
    implicit none

    type(point)::b,d
    type(point3d)::a,c

    call b%point_new(1.0,1.0)
    call b%point_print()
    call d%point_new(3.0,3.0)
    call d%point_print()

    b=b+d !相当于b=b%add(d)
    call b%point_print()

    call a%point3d_new(1.0,1.0,1.0)
    call a%point_print()
    call c%point3d_new(3.0,3.0,3.0)
    call c%point_print()

    a=a+c !相当于a=a%add(c)
    call a%point_print()
    write(*,*)EXTENDS_TYPE_OF(a,b)
end program main