1! { dg-do run }
2! A test of f95 style constructors with derived type extension.
3!
4! Contributed by Paul Thomas  <pault@gcc.gnu.org>
5!
6module persons
7  type :: person
8    character(24) :: name = ""
9    integer :: ss = 1
10  end type person
11end module persons
12
13module person_education
14  use persons
15  type, extends(person) :: education
16    integer ::  attainment = 0
17    character(24) :: institution = ""
18  end type education
19end module person_education
20
21  use person_education
22  type, extends(education) :: service
23    integer :: personnel_number = 0
24    character(24) :: department = ""
25  end type service
26
27  type, extends(service) :: person_record
28    type (person_record), pointer :: supervisor => NULL ()
29  end type person_record
30
31  type(person_record), pointer :: recruit, supervisor
32
33! Check that simple constructor works
34  allocate (supervisor)
35  supervisor%service = service ("Joe Honcho", 123455, 100, &
36                                "Celestial University", 1, &
37                                "Directorate")
38
39  recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
40                    99, "Records", supervisor)
41
42  if (trim (recruit%name) /= "John Smith") STOP 1
43  if (recruit%name /= recruit%service%name) STOP 2
44  if (recruit%supervisor%ss /= 123455) STOP 3
45  if (recruit%supervisor%ss /= supervisor%person%ss) STOP 4
46
47  deallocate (supervisor)
48  deallocate (recruit)
49contains
50  function entry (name, ss, attainment, institution, &
51                  personnel_number, department, supervisor) result (new_person)
52    integer :: ss, attainment, personnel_number
53    character (*) :: name, institution, department
54    type (person_record), pointer :: supervisor, new_person
55
56    allocate (new_person)
57
58! Check nested constructors
59    new_person = person_record (education (person (name, ss), &
60                                attainment, institution), &
61                                personnel_number, department, &
62                                supervisor)
63  end function
64end
65