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
76
77
78
79
80
|
! { dg-do run { target fd_truncate } }
!
! Test the fix for PR77657 in which the DTIO subroutine was not found,
! which led to an error in attempting to link to the abstract interface.
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
!
MODULE abstract_parent
implicit none
type, abstract :: parent
contains
procedure(write_formatted_interface), deferred :: write_formatted
generic :: write(formatted) => write_formatted
end type parent
abstract interface
subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg)
import parent
class(parent), intent(in) :: this
integer, intent(in) :: unit
character (len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
end subroutine
end interface
end module
module child_module
use abstract_parent, only : parent
implicit none
type, extends(parent) :: child
integer :: i = 99
contains
procedure :: write_formatted
end type
contains
subroutine write_formatted(this,unit,iotype,vlist,iostat,iomsg)
class(child), intent(in) :: this
integer, intent(in) :: unit
character (len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write (unit, "(i4)") this%i
end subroutine
end module
use child_module, only : child
implicit none
type (child) :: baby
integer :: v(1), istat
character(20) :: msg
open (10, status = "scratch")
call baby%write_formatted(10, "abcd", v, istat, msg) ! Call the dtio proc directly
rewind (10)
read (10, *) msg
if (trim (msg) .ne. "99") STOP 1
rewind (10)
baby%i = 42
write (10,"(DT)") baby ! Call the dtio proc via the library
rewind (10)
read (10, *) msg
if (trim (msg) .ne. "42") STOP 2
rewind (10)
write (10,"(DT)") child (77) ! The original testcase
rewind (10)
read (10, *) msg
if (trim (msg) .ne. "77") STOP 3
rewind (10)
write (10,40) child (77) ! Modified using format label
40 format(DT)
rewind (10)
read (10, *) msg
if (trim (msg) .ne. "77") STOP 4
close(10)
end
|
