Fortran2003: указатель процедуры на функцию, возвращающую указатель на полиморфный тип

Question

Для нового проекта я рассматриваю использование объектно-ориентированных функций Fortran2003. Одна вещь, которую я пробовал, включает указатель на процедуру, который указывает на функцию (не подпрограмму), которая возвращает указатель на полиморфный тип. Интересно, является ли такая конструкция законной, поскольку я получаю смешанные результаты от разных компиляторов (см. Ниже).

В качестве конкретного примера рассмотрим следующую функцию интерфейса:

abstract interface 
    function if_new_test(lbls) result(t) 
     import :: test_t 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
    end function if_new_test 
end interface 

И используя код должен иметь указатель процедуры, которые могут указывать на функции с этим интерфейсом:

procedure(if_new_test),pointer :: nt 

Я спрашивая, является ли это законным, поскольку gfortran (4.7.2) жалуется на это заявление указателя процедуры с сообщением:

Error: CLASS variable 'nt' at (1) must be dummy, allocatable or pointer

Я не понимаю это сообщение об ошибке, так как nt сам по себе является указателем, и то, что функция, на которую указывает точки возврата, также является указателем.

Для справки приведен полный исходный код для примера. Кулак, модуль, содержащий мои производные типы, интерфейсы и функции/подпрограммы:

module test_m 

    implicit none 

    type :: test_t 
     character(len=10) :: label 
     contains 
     procedure :: print => print_test 
    end type test_t 

    type,extends(test_t) :: test2_t 
     character(len=10) :: label2 
     contains 
     procedure :: print => print_test2 
    end type test2_t 

    abstract interface 
     function if_new_test(lbls) result(t) 
     import :: test_t 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     end function if_new_test 
     subroutine if_make_test(t,lbls) 
     import :: test_t 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     end subroutine if_make_test 
    end interface 

    contains 

    subroutine print_test(self) 
     implicit none 
     class(test_t),intent(in) :: self 
     print *, self%label 
    end subroutine print_test 

    subroutine print_test2(self) 
     implicit none 
     class(test2_t),intent(in) :: self 
     print *, self%label, self%label2 
    end subroutine print_test2 

    function new_test(lbls) result(t) 
     implicit none 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     call make_test(t,lbls) 
    end function new_test 

    function new_test2(lbls) result(t) 
     implicit none 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     call make_test2(t,lbls) 
    end function new_test2 

    subroutine make_test(t,lbls) 
     implicit none 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     allocate(test_t::t) 
     t%label = lbls(1) 
    end subroutine make_test 

    subroutine make_test2(t,lbls) 
     implicit none 
     class(test_t),pointer  :: t 
     character(len=*),intent(in) :: lbls(:) 
     allocate(test2_t::t) 
     select type(t) ! so the compiler knows the actual type 
     type is(test2_t) 
      t%label = lbls(1) 
      t%label2 = lbls(2) 
     class default 
      stop 1 
     end select 
    end subroutine make_test2 

end module test_m 

И основная программу с помощью этого модуля:

program test 

    use test_m 
    implicit none 

    class(test_t),pointer   :: p 
    procedure(if_make_test),pointer :: mt 
    procedure(if_new_test),pointer :: nt 

    mt => make_test 
    call mt(p,["foo"]) 
    call p%print 
    deallocate(p) 

    mt => make_test2 
    call mt(p,["bar","baz"]) 
    call p%print 
    deallocate(p) 

    p => new_test(["foo"]) 
    call p%print 
    deallocate(p) 

    p => new_test2(["bar","baz"]) 
    call p%print 
    deallocate(p) 

    nt => new_test 
    p => nt(["foo"]) 
    call p%print 
    deallocate(p) 

    nt => new_test2 
    p => nt(["bar","baz"]) 
    call p%print 
    deallocate(p) 

end program test 

Программа первого создает объекты с помощью подпрограммmake_test и make_test2 , и в моем тестировании это работает со всеми компиляторами, которые я пробовал. Затем объекты создаются путем прямого вызова функцийnew_test и new_test2, который также работает в моих тестах. Наконец, объекты должны быть снова созданы с помощью этих функций, но косвенно с помощью указателя процедуры nt.

Как указано выше, gfortran (4.7.2) не скомпилирует декларацию nt.

ifort (12.0.4.191) создает внутреннюю ошибку компилятора на линии nt => new_test.

pgfortran (12.9) компилируется без предупреждения, а исполняемый файл производит ожидаемые результаты.

Итак, что я пытаюсь сделать незаконным в соответствии с Fortran2003, или поддержка компилятора для таких функций еще недостаточна? Должен ли я просто использовать подпрограммы вместо функций (как это работает)?

Answer 1

Ваш код выглядит нормально. Я мог бы скомпилировать его как с Intel 13.0.1, так и с NAG 5.3.1 без каких-либо проблем. У старшего компилятора могут возникнуть проблемы с более «причудливыми» функциями Fortran 2003.

В зависимости от проблемы вы также можете использовать выделяемые типы вместо указателей.Должно быть больше доказательств памяти утечки, с другой стороны, вы не сможете вернуть полиморфный тип в результате функции:

module test_m 
    implicit none 

    type :: test_t 
    character(len=10) :: label 
    contains 
    procedure :: print => print_test 
    end type test_t 

    type,extends(test_t) :: test2_t 
    character(len=10) :: label2 
    contains 
    procedure :: print => print_test2 
    end type test2_t 

    abstract interface 
    function if_new_test(lbls) result(t) 
     import :: test_t 
     class(test_t), allocatable :: t 
     character(len=*),intent(in) :: lbls(:) 
    end function if_new_test 

    subroutine if_make_test(t,lbls) 
     import :: test_t 
     class(test_t), allocatable :: t 
     character(len=*),intent(in) :: lbls(:) 
    end subroutine if_make_test 
    end interface 

contains 

    subroutine print_test(self) 
    class(test_t), intent(in) :: self 
    print *, self%label 
    end subroutine print_test 

    subroutine print_test2(self) 
    class(test2_t), intent(in) :: self 
    print *, self%label, self%label2 
    end subroutine print_test2 

    subroutine make_test(t,lbls) 
    class(test_t), allocatable :: t 
    character(len=*),intent(in) :: lbls(:) 
    allocate(test_t::t) 
    t%label = lbls(1) 
    end subroutine make_test 

    subroutine make_test2(t,lbls) 
    class(test_t), allocatable :: t 
    character(len=*),intent(in) :: lbls(:) 
    allocate(test2_t::t) 
    select type(t) ! so the compiler knows the actual type 
    type is(test2_t) 
     t%label = lbls(1) 
     t%label2 = lbls(2) 
    class default 
     stop 1 
    end select 
    end subroutine make_test2 

end module test_m 


program test 
    use test_m 
    implicit none 

    class(test_t), allocatable :: p 
    procedure(if_make_test), pointer :: mt 

    mt => make_test 
    call mt(p, ["foo"]) 
    call p%print 
    deallocate(p) 

    mt => make_test2 
    call mt(p, ["bar","baz"]) 
    call p%print 
    deallocate(p) 

end program test 

еще одно замечание: неявное ни утверждение на уровне модуля является «унаследованным» процедурами модуля, поэтому вам не нужно выставлять его в каждой дополнительной подпрограмме.