Dewedseed's Blog

Fortran 派生类型的构造函数问题及其作为函数参数时的行为

当类中包含指针时，在执行析构函数可能出现内存错误，由此测试派生类型作为 function 或 subroutine 输入输出变量时的差异

测试

创建对象 Student, 采用 参考链接 中的方法定义构造函数和析构函数, 并在不同位置输出信息, 查看析构函数调用情况.

测试程序

定义对象 Student 如下

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

module test_class_constructor
  implicit none
!...Define scope
  private
  public  :: new_ClassStudent_sub, ClassStudent
!...Declare class
  type :: ClassStudent
    integer,            private :: id
    character(len=128), public  :: name
  contains
    procedure, public, pass :: init => new_ClassStudent_sub2
    final :: delete_ClassStudent  !< Destructor
  end type ClassStudent
  !> Constructor of class ClassStudent
  interface ClassStudent
    module procedure new_ClassStudent_fun
  end interface ClassStudent
contains
  !> Constructor of class ClassStudent
  type(ClassStudent) function new_ClassStudent_fun(id, name)
    integer,          intent(in) :: id
    character(len=*), intent(in) :: name
  continue
    write (*,*) "Initial Student ", new_ClassStudent_fun%id, ": ", &
                                    trim(new_ClassStudent_fun%name)
    new_ClassStudent_fun%id   = id
    new_ClassStudent_fun%name = trim(name)
    write (*,*) "Creating Student ", new_ClassStudent_fun%id, ": ", &
                                    trim(new_ClassStudent_fun%name)
  end function new_ClassStudent_fun
  !> Destructor of class ClassStudent
  subroutine delete_ClassStudent(this)
    type(ClassStudent), intent(inout) :: this
  continue
    write (*,*) "Deleting Student ", this%id, ": ", trim(this%name)
  end subroutine delete_ClassStudent
  !> create new_student by subroutine
  subroutine new_ClassStudent_sub(id, name, new_Student)
    integer,            intent(in)  :: id
    character(len=*),   intent(in)  :: name
    type(ClassStudent), intent(inout) :: new_Student
  continue
    write (*,*) "Initial Student ", new_Student%id, ": ", &
                                    trim(new_Student%name)
    new_Student%id   = id
    new_Student%name = trim(name)
    write (*,*) "Creating Student ", new_Student%id, ": ", &
                                      trim(new_Student%name)
  end subroutine new_ClassStudent_sub
  !> create new_student by subroutine
  subroutine new_ClassStudent_sub2(this, id, name)
    integer,            intent(in)  :: id
    character(len=*),   intent(in)  :: name
    class(ClassStudent), intent(inout) :: this
  continue
    write (*,*) "Initial Student ", this%id, ": ", trim(this%name)
    this%id   = id
    this%name = trim(name)
    write (*,*) "Creating Student ", this%id, ": ", trim(this%name)
  end subroutine new_ClassStudent_sub2
end module test_class_constructor

执行的测试程序为

1
2
3
4
5
6
7
8
9
10
11
12
13
14
subroutine test_ClassStudent()
  use test_class_constructor
  type(ClassStudent) :: Bob, Nick, Alice
continue
  Bob%name = "Nick"
  Bob = ClassStudent(1, "Bob")
  write (*,*) "Checking Student: ", trim(Bob%name)
  Nick%name = "Bob"
  call new_ClassStudent_sub(2, "Nick", Nick)
  write (*,*) "Checking Student :", trim(Nick%name)
  Alice%name = "Eric"
  call Alice%init(3, "Alice")
  write (*,*) "Checking Student :", trim(Alice%name)
end subroutine test_ClassStudent

测试结果

  • 调用 ClassStudent() 时输出
1
2
3
4
5
6
Initial Student            0 : �=.����9�u�9��
Creating Student            1 : Bob
Deleting Student            0 : Nick
Deleting Student            1 : Bob
Checking Student: Bob
Deleting Student            1 : Bob
  • 调用 new_ClassStudent_sub 且输入类型为 intent(inout) 时输出
1
2
3
4
Initial Student            0 : Bob
Creating Student            2 : Nick
Checking Student :Nick
Deleting Student            2 : Nick
  • 调用 new_ClassStudent_sub 且输入类型为 intent(out) 时输出
1
2
3
4
5
Deleting Student            0 : Bob
Initial Student            0 : Bob
Creating Student            2 : Nick
Checking Student :Nick
Deleting Student            2 : Nick
  • 调用 init() 且输入类型为 intent(inout) 时输出
1
2
3
4
Initial Student        17748 : Eric
Creating Student            3 : Alice
Checking Student :Alice
Deleting Student            3 : Alice
  • 调用 init() 且输入类型为 intent(out) 时输出
1
2
3
4
5
Deleting Student      2752512 : Eric
Initial Student            0 :
Creating Student            3 : Alice
Checking Student :Alice
Deleting Student            3 : Alice

分析

在 StackOverflow What is the explicit difference between the fortran intents (in,out,inout)? 中提到:

1
2
3
intent(in) -- The actual argument is copied to the dummy argument at entry.
intent(out) -- The dummy argument points to the actual argument (they both point to the same place in memory).
intent(inout) -- the dummy argument is created locally, and then copied to the actual argument when the procedure is finished.

采用 gdb 查看不同方法下变量指向的内存

Paramter actual dummy
ClassStudent 0x7fffffffcf00 0x7fffffffcab0
new_ClassStudent_sub - intent(out) 0x7fffffffcf00 0x7fffffffcf00
new_ClassStudent_sub - intent(inout) 0x7fffffffcf00 0x7fffffffcf00
init - intent(out) 0x7fffffffcf00 0x7fffffffcf00
init - intent(inout) 0x7fffffffcf00 0x7fffffffcf00

推测使用 intent(out) 时发生了以下行为： 由于实参和形参指向相同内存，intent(out) 需确保形参为初始化状态，因此调用析构函数清理相同内存中实参所保存的先前内容

执行过程

调用 ClassStudent() 执行过程

1
2
3
4
5
6
7
8
9
1. 进入 `ClassStudent()`，执行 `(gdb) info locals` 确认局部参数为 `__result_new_classstudent_fun`，输出相关信息
  Initial Student            0 : �=.����9�u�9��
  Creating Student            1 : Bob
2. 执行赋值操作 `Bob = ClassStudent(1, "Bob")`，首先清除原 `Bob` 对象内容，赋值后清除 `__result_new_classstudent_fun` 内容
  Deleting Student            0 : Nick
  Deleting Student            1 : Bob
3. 测试程序 `test_ClassStudent()` 结束
  Checking Student: Bob
  Deleting Student            1 : Bob

调用 new_ClassStudent_sub() 执行过程

1
2
3
4
5
6
7
8
1. 进入 `new_ClassStudent_sub()`，定义变量 `type(ClassStudent), intent(out) :: new_Student` 后清除原 `Nick` 内容
  Deleting Student            0 : Bob
2. 重新赋值 `new_Student`
  Initial Student            0 : Bob
  Creating Student            2 : Nick
3. 测试程序 `test_ClassStudent()` 结束
  Checking Student :Nick
  Deleting Student            2 : Nick

调用 init() 执行过程

1
2
3
4
5
6
7
8
1. 进入 `init()`，定义变量 `class(ClassStudent), intent(out) :: this` 后清除原 `Alice` 内容
  Deleting Student      2752512 : Eric
2. 重新赋值 `this%_data`
  Initial Student            0 :
  Creating Student            3 : Alice
3. 测试程序 `test_ClassStudent()` 结束
  Checking Student :Alice
  Deleting Student            3 : Alice

指针

在 ClassStudent 中添加指针

1
type(ClassStudent), pointer :: next

在析构函数 final :: delete_ClassStudent 中释放内存

1
if ( associated(this%next) ) deallocate(this%next)

在执行 Bob = ClassStudent(1, "Bob") 发生段错误

1
2
3
4
5
 Initial Student            0 : ���V���j�8{5��8{�
 Creating Student            1 : Bob
 Deleting Student            0 : Nick

Program received signal SIGSEGV: Segmentation fault - invalid memory reference.

该错误发生在 ClassStudent(1, "Bob") 向 Bob 赋值时, 调用析构函数清除 Bob 初始内容, 而 Bob%next 未指向 null()

1
2
(gdb) p &bob%next
$1 = (PTR TO -> ( Type classstudent )) 0x1

解决方法: 在声明时直接初始化

1
2
3
integer,            private :: id   = 0
character(len=128), public  :: name = "None"
type(ClassStudent), pointer :: next => null()

测试另一种方法: 将 Bob 声明为指针, 构造函数声明为指针函数 Bob => ClassStudent(1, "Bob"), 执行结果如下

1
2
3
Initial Student            0 :
Creating Student            1 : Bob
Checking Student: Bob

整个过程中未调用析构函数, 检查内存地址变化情况

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
=======================================================================
(gdb) p bob
$1 = (PTR TO -> ( Type classstudent )) 0x1
(gdb) p &bob
$2 = (PTR TO -> ( PTR TO -> ( Type classstudent ) )) 0x7fffffffcf88
=======================================================================
(gdb) p new_student
$3 = (PTR TO -> ( Type classstudent )) 0x555555564b90
(gdb) p &new_student
$4 = (PTR TO -> ( PTR TO -> ( Type classstudent ) )) 0x7fffffffcd38
=======================================================================
(gdb) p bob
$5 = (PTR TO -> ( Type classstudent )) 0x555555564b90
(gdb) p &bob
$6 = (PTR TO -> ( PTR TO -> ( Type classstudent ) )) 0x7fffffffcf88
=======================================================================

链表

对链表对象 ClassStudent 添加析构函数, 无需在 ClassGroup 析构函数中循环释放内存, 测试代码如下

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
module test_linklist
  implicit none
!...Define scope
  private
  public :: ClassGroup
!...Declare local variables
  type :: ClassStudent
    integer,            private :: id   = 0
    character(len=128), public  :: name = "None"
    type(ClassStudent), pointer :: next => null()
  contains
    final :: delete_ClassStudent  !< Destructor
  end type ClassStudent
  !> Constructor of class ClassStudent
  interface ClassStudent
    module procedure new_ClassStudent_fun
  end interface ClassStudent

  type :: ClassGroup
    integer,                     private :: nstudents = 0
    type(ClassStudent), pointer, private :: head => null()
  contains
    procedure, public, pass :: add => add_student
    final :: delete_ClassGroup  !< Destructor
  end type ClassGroup

contains

  !> Constructor of class ClassStudent
  type(ClassStudent) function new_ClassStudent_fun(id, name) result(new_Student)
    integer,          intent(in) :: id
    character(len=*), intent(in) :: name
  continue
    new_Student%id   = id
    new_Student%name = trim(name)
    new_Student%next => null()
  end function new_ClassStudent_fun

  !> Destructor of class ClassStudent
  subroutine delete_ClassStudent(this)
    type(ClassStudent), intent(inout) :: this
  continue
    write (*,*) "Deleting Student ", this%id, ": ", trim(this%name)
    if ( associated(this%next) ) deallocate(this%next)
  end subroutine delete_ClassStudent

  !> Destructor of class ClassGroup
  subroutine delete_ClassGroup(this)
    type(ClassGroup), intent(inout) :: this
  continue
    write (*,*) "Deleting ClassGroup"
    if ( associated(this%head) ) deallocate(this%head)
  end subroutine delete_ClassGroup

  !> Add new student to group
  subroutine add_student(this, name)
    class(ClassGroup), intent(inout) :: this
    character(len=*),  intent(in)    :: name
  !...Define local variables
    type(ClassStudent), pointer :: new_Student
    integer :: ierr
  continue
    allocate(new_Student, stat=ierr)
    this%nstudents = this%nstudents + 1
    new_Student    = ClassStudent(this%nstudents, name)
    if ( associated(this%head) ) then
      new_Student%next => this%head
      this%head        => new_Student
    else
      this%head => new_Student
    end if
    nullify(new_Student)
  end subroutine add_student

end module test_linklist

执行代码

1
2
3
4
5
6
7
8
subroutine test_ClassGroup()
  use test_linklist
  type(ClassGroup) :: Group
continue
  call Group%add("Bob")
  call Group%add("Alice")
  call Group%add("Eric")
end subroutine test_ClassGroup

执行结果, 链表对象内存递归释放

1
2
3
4
5
6
7
8
9
10
11
Deleting Student            0 : None
Deleting Student            1 : Bob
Deleting Student            0 : None
Deleting Student            2 : Alice
Deleting Student            0 : None
Deleting Student            3 : Eric

Deleting ClassGroup
Deleting Student            3 : Eric
Deleting Student            2 : Alice
Deleting Student            1 : Bob

链表释放方式区别

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
subroutine test_process()
  type(ClassStudent), pointer :: Students => null()
  type(ClassStudent), pointer :: new_Student1 => null()
  type(ClassStudent), pointer :: new_Student2 => null()
  type(ClassStudent), pointer :: new_Student3 => null()
continue
  allocate(new_Student1)
  new_Student1 = ClassStudent(1, "John")
  allocate(new_Student2)
  new_Student2 = ClassStudent(2, "Bob")
  allocate(new_Student3)
  new_Student3 = ClassStudent(3, "Tom")
  Students           => new_Student1
  Students%next      => new_Student2
  Students%next%next => new_Student3
  write (*,*) "Deallocate new_Student1."
  ! nullify(new_Student1)
  ! deallocate(new_Student1)
  ! new_Student1 => null()
  write (*,*) "This is test_process."
  deallocate(Students)
end subroutine test_process
  • 方式1: nullify(new_Student1)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
=======================================================================
# type(ClassStudent), pointer :: new_Student1 => null()
(gdb) p new_student1
$1 = (PTR TO -> ( Type classstudent )) 0x0
(gdb) p new_student1%next
Cannot access memory at address 0x88
=======================================================================
# allocate(new_Student1)
(gdb) p new_student1
$2 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p new_student1%next
$3 = (PTR TO -> ( Type classstudent )) 0x0
=======================================================================
# new_Student1 = ClassStudent(1, "John")
(gdb) p new_student1
$4 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p new_student1%next
$5 = (PTR TO -> ( Type classstudent )) 0x0
=======================================================================
# Students           => new_Student1
# Students%next      => new_Student2
# Students%next%next => new_Student3
(gdb) p new_student1
$6 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p new_student1%next
$7 = (PTR TO -> ( Type classstudent )) 0x55555555cc90
(gdb) p students
$8 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p students%next
$9 = (PTR TO -> ( Type classstudent )) 0x55555555cc90
=======================================================================
# nullify(new_Student1)
(gdb) p new_student1
$10 = (PTR TO -> ( Type classstudent )) 0x0
(gdb) p new_student1%next
Cannot access memory at address 0x88
(gdb) p students
$11 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p students%next
$12 = (PTR TO -> ( Type classstudent )) 0x55555555cc90
=======================================================================
  • 方式2: deallocate(new_Student1)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
=======================================================================
# deallocate(new_Student1)
(gdb) p new_student1
$1 = (PTR TO -> ( Type classstudent )) 0x0
(gdb) p new_student1%next
Cannot access memory at address 0x88
(gdb) p new_student1%id
Cannot access memory at address 0x0
(gdb) p new_student1%name
Cannot access memory at address 0x4
(gdb) p students
$2 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p students%next
$3 = (PTR TO -> ( Type classstudent )) 0x0
(gdb) p students%id
$4 = 39372
(gdb) p students%name
$5 = 'PU\000\000\367XƑي\307\030', ' ' <repeats 116 times>
=======================================================================
  • 方式3: new_Student1 => null()
1
2
3
4
5
6
7
8
9
10
11
=======================================================================
# new_Student1 => null()
(gdb) p new_student1
$1 = (PTR TO -> ( Type classstudent )) 0x0
(gdb) p new_student1%next
Cannot access memory at address 0x88
(gdb) p students
$3 = (PTR TO -> ( Type classstudent )) 0x55555555cb90
(gdb) p students%next
$4 = (PTR TO -> ( Type classstudent )) 0x55555555cc90
=======================================================================

赋值操作

在程序中执行指针赋值操作时，可能会出现指向问题

1
2
3
4
5
6
7
8
9
10
11
12
13
14
!>
subroutine student_name(this, stu)
  class(ClassStudent), intent(inout) :: this ! 'Nick'
  type(ClassStudent),  pointer       :: stu1 ! 'Anne'
  type(ClassStudent),  pointer       :: stu2 ! 'Rock'
continue
  write (*,*) this%name, stu1%name, stu2%name
  stu1 = stu2
  stu2%name = 'Bob'
  write (*,*) this%name, stu1%name, stu2%name
  stu1 = this
  stu1%name = 'Jame'
  write (*,*) this%name, stu1%name, stu2%name
end subroutine student_name

执行结果如下，发现赋值操作变成指向操作，因此最好不要对派生类型进行赋值操作

1
2
3
4
5
=======================================================================
'Nick' 'Anne' 'Rock'
'Nick' 'Rock' 'Bob'
'Jame' 'Jame' 'Bob'
=======================================================================

参考

RIP Tutorial-Fortran type constructor
IBM-Object-Oriented Fortran: User-defined constructors
Tutorial OOP(III): Constructors and Destructors
Fortran Wiki-Object-oriented programming
Tutorial OOP(IV) : Operator and Assignment Overloading
GDB: The GNU Project Debugger
intent(out) behavior
Doctor Fortran in “I’ve Come Here For An Argument”

0%