gcc/testsuite/gfortran.dg/extends_3.f03

   1 ! { dg-do run }
   2 ! A test of f2k style constructors with 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 F2K constructor with missing entries works
  34   allocate (supervisor)
  35   supervisor%service = service (NAME = "Joe Honcho", SS= 123455)
  36
  37   recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
  38                     99, "Records", supervisor)
  39
  40   if (supervisor%ss /= 123455) STOP 1
  41   if (trim (supervisor%name) /= "Joe Honcho") STOP 2
  42   if (trim (supervisor%institution) /= "") STOP 3
  43   if (supervisor%attainment /= 0) STOP 4
  44
  45   if (trim (recruit%name) /= "John Smith") STOP 5
  46   if (recruit%name /= recruit%service%name) STOP 6
  47   if (recruit%supervisor%ss /= 123455) STOP 7
  48   if (recruit%supervisor%ss /= supervisor%person%ss) STOP 8
  49
  50   deallocate (supervisor)
  51   deallocate (recruit)
  52 contains
  53   function entry (name, ss, attainment, institution, &
  54                   personnel_number, department, supervisor) result (new_person)
  55     integer :: ss, attainment, personnel_number
  56     character (*) :: name, institution, department
  57     type (person_record), pointer :: supervisor, new_person
  58
  59     allocate (new_person)
  60
  61 ! Check F2K constructor with order shuffled a bit
  62     new_person = person_record (NAME = name, SS =ss, &
  63                                 DEPARTMENT = department, &
  64                                 INSTITUTION = institution, &
  65                                 PERSONNEL_NUMBER = personnel_number, &
  66                                 ATTAINMENT = attainment, &
  67                                 SUPERVISOR = supervisor)
  68   end function
  69 end