在尝试实现用户派生类型层次结构之前，我尝试使用 Fortran 2003 特性来理解多态释放。理想的目标是弄清楚如何释放可能指向任何其他兼容子类型的声明父类型指针。
如以下代码所示，该文件liboo.f90声明了一个基类型Parent和一个继承类型Child。这两种类型分别FINAL适用于标量和数组情况。该文件test_liboo.f90使用 18 个不同的子例程尝试不同的释放。
子程序TestParent_3_POINTER_CLASS, TestParent_7_array_POINTER_CLASS,
TestChild_3_POINTER_CLASS, TestChild_7_array_POINTER_CLASS,
TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents,
TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents, 都给出分段错误。的错误信息TestParent_3_POINTER_CLASS如下所示。
子程序TestPolymorph_1_Pointer_TypeForChild_ClassForParent说forrtl: severe (173): A pointer passed to DEALLOCATE points to an array that cannot be deallocated。
你能帮忙评论一下原因吗？
TestPolymorph_2_Pointer_ClassForChild_ClassForParent不给出分段错误，但只调用 Child's Final， whileTestChild_1等等可以调用 Child'sFinal和 Parent's Final，这应该是可取的。
我想知道如何取消分配在 Fortran 2003 中实际包含继承类型的声明父类型？任何见解将不胜感激！
PS：编译器为Intel Fortran Compiler，版本如下：
[root@localhost new]# ifort --version
ifort (IFORT) 12.1.0 20111011
Copyright (C) 1985-2011 Intel Corporation. All rights reserved.
错误消息之一
[root@localhost new]# make clean
rm -rf liboo.mod liboo.o test_liboo.o test_liboo
[root@localhost new]# make
ifort -c -O0 -check -g -traceback -openmp liboo.f90
ifort -c -O0 -check -g -traceback -openmp test_liboo.f90
ifort -o test_liboo liboo.o test_liboo.o -static -openmp
[root@localhost new]# ./test_liboo
TestParent_1 begins.
DestroyParent
TestParent_1 ends.
TestParent_2_POINTER_TYPE begins.
DestroyParent
TestParent_2_POINTER_TYPE ends.
TestParent_3_POINTER_CLASS begins.
DestroyParent
forrtl: severe (174): SIGSEGV, segmentation fault occurred
Image PC Routine Line Source
test_liboo 0000000000404B9C Unknown Unknown Unknown
test_liboo 0000000000404A9F Unknown Unknown Unknown
test_liboo 0000000000401ED5 test_liboo_IP_tes 140 test_liboo.f90
test_liboo 0000000000400829 MAIN__ 20 test_liboo.f90
test_liboo 00000000004002EC Unknown Unknown Unknown
test_liboo 00000000004F4B90 Unknown Unknown Unknown
test_liboo 00000000004001B9 Unknown Unknown Unknown
[root@localhost new]#
生成文件
# Compiler
FC = ifort
# Linker
LINKER = ${FC}
# Compiler flags
FCFLAGS = -c -O0 -check -g -traceback
FCFLAGS2 = -openmp
# Linker flags
FLFLAGS = -static
FLFLAGS2 = -openmp
# Utilities
RM = rm -rf
ECHO = echo
SHELL = /bin/sh
# clear out all suffixes
.SUFFIXES:
# list only those we use
.SUFFIXES: .o .f90 .f
# define a suffix rule for .f90 -> .o
.f90.o:
${FC} ${FCFLAGS} ${FCFLAGS2} $<
# define a suffix rule for .f -> .o
.f.o:
${FC} ${FCFLAGS} ${FCFLAGS2} $<
#
test_liboo: liboo.o test_liboo.o
${LINKER} -o test_liboo liboo.o test_liboo.o ${FLFLAGS} ${FLFLAGS2}
#
clean:
${RM} liboo.mod liboo.o test_liboo.o test_liboo
liboo.f90
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
MODULE LibOO
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
TYPE :: Parent
INTEGER :: a
CONTAINS
FINAL :: DestroyParent
FINAL :: DestroyParents
END TYPE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
TYPE, EXTENDS (Parent) :: child
INTEGER :: b
CONTAINS
FINAL :: DestroyChild
FINAL :: DestroyChildren
END TYPE
CONTAINS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE DestroyParent(this)
TYPE(Parent) :: this
WRITE (*,*) 'DestroyParent'
END SUBROUTINE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE DestroyParents(this)
TYPE(Parent), DIMENSION(:) :: this
WRITE (*,*) 'DestroyParents'
END SUBROUTINE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE DestroyChild(this)
TYPE(Child) :: this
WRITE (*,*) 'DestroyChild'
END SUBROUTINE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE DestroyChildren(this)
TYPE(Child), DIMENSION(:) :: this
WRITE (*,*) 'DestroyChildren'
END SUBROUTINE
END MODULE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
test_liboo.f90
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
PROGRAM test_liboo
USE LibOO
IMPLICIT NONE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
WRITE (*,*) 'TestParent_1 begins.'
CALL TestParent_1
WRITE (*,*) 'TestParent_1 ends.'
READ (*,*)
WRITE (*,*) 'TestParent_2_POINTER_TYPE begins.'
CALL TestParent_2_POINTER_TYPE
WRITE (*,*) 'TestParent_2_POINTER_TYPE ends.'
READ (*,*)
WRITE (*,*) 'TestParent_3_POINTER_CLASS begins.'
CALL TestParent_3_POINTER_CLASS
WRITE (*,*) 'TestParent_3_POINTER_CLASS ends.'
READ (*,*)
WRITE (*,*) 'TestParent_4_array begins.'
CALL TestParent_4_array
WRITE (*,*) 'TestParent_4_array ends.'
READ (*,*)
WRITE (*,*) 'TestParent_5_array_ALLOCATABLE begins.'
CALL TestParent_5_array_ALLOCATABLE
WRITE (*,*) 'TestParent_5_array_ALLOCATABLE ends.'
READ (*,*)
WRITE (*,*) 'TestParent_6_array_POINTER_TYPE begins.'
CALL TestParent_6_array_POINTER_TYPE
WRITE (*,*) 'TestParent_6_array_POINTER_TYPE ends.'
READ (*,*)
WRITE (*,*) 'TestParent_7_array_POINTER_CLASS begins.'
CALL TestParent_7_array_POINTER_CLASS
WRITE (*,*) 'TestParent_7_array_POINTER_CLASS ends.'
READ (*,*)
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
WRITE (*,*) 'TestChild_1 begins.'
CALL TestChild_1
WRITE (*,*) 'TestChild_1 ends.'
READ (*,*)
WRITE (*,*) 'TestChild_2_POINTER_TYPE begins.'
CALL TestChild_2_POINTER_TYPE
WRITE (*,*) 'TestChild_2_POINTER_TYPE ends.'
READ (*,*)
WRITE (*,*) 'TestChild_3_POINTER_CLASS begins.'
CALL TestChild_3_POINTER_CLASS
WRITE (*,*) 'TestChild_3_POINTER_CLASS ends.'
READ (*,*)
WRITE (*,*) 'TestChild_4_array begins.'
CALL TestChild_4_array
WRITE (*,*) 'TestChild_4_array ends.'
READ (*,*)
WRITE (*,*) 'TestChild_5_array_ALLOCATABLE begins.'
CALL TestChild_5_array_ALLOCATABLE
WRITE (*,*) 'TestChild_5_array_ALLOCATABLE ends.'
READ (*,*)
WRITE (*,*) 'TestChild_6_array_POINTER_TYPE begins.'
CALL TestChild_6_array_POINTER_TYPE
WRITE (*,*) 'TestChild_6_array_POINTER_TYPE ends.'
READ (*,*)
WRITE (*,*) 'TestChild_7_array_POINTER_CLASS begins.'
CALL TestChild_7_array_POINTER_CLASS
WRITE (*,*) 'TestChild_7_array_POINTER_CLASS ends.'
READ (*,*)
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
WRITE (*,*) 'TestPolymorph_1_Pointer_TypeForChild_ClassForParent begins.'
CALL TestPolymorph_1_Pointer_TypeForChild_ClassForParent
WRITE (*,*) 'TestPolymorph_1_Pointer_TypeForChild_ClassForParent ends.'
READ (*,*)
WRITE (*,*) 'TestPolymorph_2_Pointer_ClassForChild_ClassForParent begins.'
CALL TestPolymorph_2_Pointer_ClassForChild_ClassForParent
WRITE (*,*) 'TestPolymorph_2_Pointer_ClassForChild_ClassForParent ends.'
READ (*,*)
WRITE (*,*) 'TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents begins.'
CALL TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents
WRITE (*,*) 'TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents ends.'
READ (*,*)
WRITE (*,*) 'TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents begins.'
CALL TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents
WRITE (*,*) 'TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents ends.'
READ (*,*)
CONTAINS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_1
USE LibOO
IMPLICIT NONE
TYPE(Parent) :: myParent
myParent%a = 6
END SUBROUTINE TestParent_1
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_2_POINTER_TYPE
USE LibOO
IMPLICIT NONE
TYPE(Parent), POINTER :: pMyParent
ALLOCATE(pMyParent)
pMyParent%a = 6
DEALLOCATE(pMyParent)
END SUBROUTINE TestParent_2_POINTER_TYPE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_3_POINTER_CLASS
USE LibOO
IMPLICIT NONE
CLASS(Parent), POINTER :: pMyParent
ALLOCATE(pMyParent)
pMyParent%a = 6
DEALLOCATE(pMyParent)
END SUBROUTINE TestParent_3_POINTER_CLASS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_4_array
USE LibOO
IMPLICIT NONE
TYPE(Parent), DIMENSION(3) :: myParents
myParents(1)%a = 6
END SUBROUTINE TestParent_4_array
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_5_array_ALLOCATABLE
USE LibOO
IMPLICIT NONE
TYPE(Parent), DIMENSION(:), ALLOCATABLE :: myParents
ALLOCATE(myParents(3))
myParents(1)%a = 6
DEALLOCATE(myParents)
END SUBROUTINE TestParent_5_array_ALLOCATABLE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_6_array_POINTER_TYPE
USE LibOO
IMPLICIT NONE
TYPE(Parent), DIMENSION(:), POINTER :: pMyParents
ALLOCATE(pMyParents(3))
pMyParents(1)%a = 6
DEALLOCATE(pMyParents)
END SUBROUTINE TestParent_6_array_POINTER_TYPE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestParent_7_array_POINTER_CLASS
USE LibOO
IMPLICIT NONE
CLASS(Parent), DIMENSION(:), POINTER :: pMyParents
ALLOCATE(pMyParents(3))
pMyParents(1)%a = 6
DEALLOCATE(pMyParents)
END SUBROUTINE TestParent_7_array_POINTER_CLASS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_1
USE LibOO
IMPLICIT NONE
TYPE(child) :: myChild
myChild%b = 6
END SUBROUTINE TestChild_1
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_2_POINTER_TYPE
USE LibOO
IMPLICIT NONE
TYPE(child), POINTER :: pMyChild
ALLOCATE(pMyChild)
pMyChild%b = 6
DEALLOCATE(pMyChild)
END SUBROUTINE TestChild_2_POINTER_TYPE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_3_POINTER_CLASS
USE LibOO
IMPLICIT NONE
CLASS(child), POINTER :: pMyChild
ALLOCATE(pMyChild)
pMyChild%b = 6
DEALLOCATE(pMyChild)
END SUBROUTINE TestChild_3_POINTER_CLASS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_4_array
USE LibOO
IMPLICIT NONE
TYPE(child), DIMENSION(3) :: myChild
myChild(1)%b = 6
END SUBROUTINE TestChild_4_array
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_5_array_ALLOCATABLE
USE LibOO
IMPLICIT NONE
TYPE(child), DIMENSION(:), ALLOCATABLE :: myChildren
ALLOCATE(myChildren(3))
myChildren(1)%b = 6
DEALLOCATE(myChildren)
END SUBROUTINE TestChild_5_array_ALLOCATABLE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_6_array_POINTER_TYPE
USE LibOO
IMPLICIT NONE
TYPE(child), DIMENSION(:), POINTER :: pMyChildren
ALLOCATE(pMyChildren(3))
pMyChildren(1)%b = 6
DEALLOCATE(pMyChildren)
END SUBROUTINE TestChild_6_array_POINTER_TYPE
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestChild_7_array_POINTER_CLASS
USE LibOO
IMPLICIT NONE
CLASS(child), DIMENSION(:), POINTER :: pMyChildren
ALLOCATE(pMyChildren(3))
pMyChildren(1)%b = 6
DEALLOCATE(pMyChildren)
END SUBROUTINE TestChild_7_array_POINTER_CLASS
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestPolymorph_1_Pointer_TypeForChild_ClassForParent
USE LibOO
IMPLICIT NONE
TYPE(child), POINTER :: pMyChild
CLASS(parent), POINTER :: pMyParent
ALLOCATE(pMyChild)
pMyChild%b = 6
pMyParent => pMyChild
DEALLOCATE(pMyParent)
END SUBROUTINE TestPolymorph_1_Pointer_TypeForChild_ClassForParent
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestPolymorph_2_Pointer_ClassForChild_ClassForParent
USE LibOO
IMPLICIT NONE
CLASS(child), POINTER :: pMyChild
CLASS(parent), POINTER :: pMyParent
ALLOCATE(pMyChild)
pMyChild%b = 6
pMyParent => pMyChild
DEALLOCATE(pMyParent)
END SUBROUTINE TestPolymorph_2_Pointer_ClassForChild_ClassForParent
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents
USE LibOO
IMPLICIT NONE
TYPE(child), DIMENSION(:), POINTER :: pMyChildren
CLASS(parent), DIMENSION(:), POINTER :: pMyParents
ALLOCATE(pMyChildren(3))
pMyChildren(1)%b = 6
pMyParents => pMyChildren
DEALLOCATE(pMyParents)
END SUBROUTINE TestPolymorph_3_array_Pointer_TypeForChildren_ClassForParents
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
SUBROUTINE TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents
USE LibOO
IMPLICIT NONE
CLASS(child), DIMENSION(:), POINTER :: pMyChildren
CLASS(parent), DIMENSION(:), POINTER :: pMyParents
ALLOCATE(pMyChildren(3))
pMyChildren(1)%b = 6
pMyParents => pMyChildren
DEALLOCATE(pMyParents)
END SUBROUTINE TestPolymorph_4_array_Pointer_ClassForChildren_ClassForParents
END PROGRAM test_liboo
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**