Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/extends_1.f03 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900 (2017-10-27)
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ! { dg-do run }
2 ! A basic functional test of derived type extension.
3 !
4 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
5 !
6 module persons
7 type :: person
8 character(24) :: name = ""
9 integer :: ss = 1
10 end type person
11 end module persons
12
13 module person_education
14 use persons
15 type, extends(person) :: education
16 integer :: attainment = 0
17 character(24) :: institution = ""
18 end type education
19 end 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 references by ultimate component work
34
35 allocate (supervisor)
36 supervisor%name = "Joe Honcho"
37 supervisor%ss = 123455
38 supervisor%attainment = 100
39 supervisor%institution = "Celestial University"
40 supervisor%personnel_number = 1
41 supervisor%department = "Directorate"
42
43 recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
44 99, "Records", supervisor)
45
46 if (trim (recruit%name) /= "John Smith") call abort
47 if (recruit%name /= recruit%service%name) call abort
48 if (recruit%supervisor%ss /= 123455) call abort
49 if (recruit%supervisor%ss /= supervisor%person%ss) call abort
50
51 deallocate (supervisor)
52 deallocate (recruit)
53 contains
54 function entry (name, ss, attainment, institution, &
55 personnel_number, department, supervisor) result (new_person)
56 integer :: ss, attainment, personnel_number
57 character (*) :: name, institution, department
58 type (person_record), pointer :: supervisor, new_person
59
60 allocate (new_person)
61
62 ! Check mixtures of references
63 new_person%person%name = name
64 new_person%service%education%person%ss = ss
65 new_person%service%attainment = attainment
66 new_person%education%institution = institution
67 new_person%personnel_number = personnel_number
68 new_person%service%department = department
69 new_person%supervisor => supervisor
70 end function
71 end