gcc/testsuite/gfortran.dg/typebound_proc_25.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/51995
   4 !
   5 ! Contributed by jilfa12@yahoo.com
   6 !
   7
   8 MODULE factory_pattern
   9
  10   TYPE CFactory
  11      PRIVATE
  12      CHARACTER(len=20) :: factory_type      !! Descriptive name for database
  13      CLASS(Connection), POINTER :: connection_type !! Which type of database ?
  14    CONTAINS                                        !! Note 'class' not 'type' !
  15      PROCEDURE :: init                             !! Constructor
  16      PROCEDURE :: create_connection                !! Connect to database
  17      PROCEDURE :: finalize                         !! Destructor
  18   END TYPE CFactory
  19
  20   TYPE, ABSTRACT :: Connection
  21    CONTAINS
  22      PROCEDURE(generic_desc), DEFERRED, PASS(self) :: description
  23   END TYPE Connection
  24
  25   ABSTRACT INTERFACE
  26      SUBROUTINE generic_desc(self)
  27        IMPORT :: Connection
  28        CLASS(Connection), INTENT(in) :: self
  29      END SUBROUTINE generic_desc
  30   END INTERFACE
  31
  32   !! An Oracle connection
  33   TYPE, EXTENDS(Connection) :: OracleConnection
  34    CONTAINS
  35      PROCEDURE, PASS(self) :: description => oracle_desc
  36   END TYPE OracleConnection
  37
  38   !! A MySQL connection
  39   TYPE, EXTENDS(Connection) :: MySQLConnection
  40    CONTAINS
  41      PROCEDURE, PASS(self) :: description => mysql_desc
  42   END TYPE MySQLConnection
  43
  44 CONTAINS
  45
  46   SUBROUTINE init(self, string)
  47     CLASS(CFactory), INTENT(inout) :: self
  48     CHARACTER(len=*), INTENT(in) :: string
  49     self%factory_type = TRIM(string)
  50     self%connection_type => NULL()            !! pointer is nullified
  51   END SUBROUTINE init
  52
  53   SUBROUTINE finalize(self)
  54     CLASS(CFactory), INTENT(inout) :: self
  55     DEALLOCATE(self%connection_type)          !! Free the memory
  56     NULLIFY(self%connection_type)
  57   END SUBROUTINE finalize
  58
  59   FUNCTION create_connection(self)  RESULT(ptr)
  60     CLASS(CFactory) :: self
  61     CLASS(Connection), POINTER :: ptr
  62
  63     IF(self%factory_type == "Oracle") THEN
  64        IF(ASSOCIATED(self%connection_type))   DEALLOCATE(self%connection_type)
  65        ALLOCATE(OracleConnection :: self%connection_type)
  66        ptr => self%connection_type
  67     ELSEIF(self%factory_type == "MySQL") THEN
  68        IF(ASSOCIATED(self%connection_type))   DEALLOCATE(self%connection_type)
  69        ALLOCATE(MySQLConnection :: self%connection_type)
  70        ptr => self%connection_type
  71     END IF
  72
  73   END FUNCTION create_connection
  74
  75   SUBROUTINE oracle_desc(self)
  76     CLASS(OracleConnection), INTENT(in) :: self
  77     WRITE(*,'(A)') "You are now connected with Oracle"
  78   END SUBROUTINE oracle_desc
  79
  80   SUBROUTINE mysql_desc(self)
  81     CLASS(MySQLConnection), INTENT(in) :: self
  82     WRITE(*,'(A)')  "You are now connected with MySQL"
  83   END SUBROUTINE mysql_desc
  84 end module
  85
  86
  87   PROGRAM main
  88    USE factory_pattern
  89
  90    IMPLICIT NONE
  91
  92    TYPE(CFactory) :: factory
  93    CLASS(Connection), POINTER :: db_connect => NULL()
  94
  95    CALL factory%init("Oracle")
  96    db_connect => factory%create_connection()   !! Create Oracle DB
  97    CALL db_connect%description()
  98
  99    !! The same factory can be used to create different connections
 100    CALL factory%init("MySQL")                  !! Create MySQL DB
 101
 102    !! 'connect' is a 'class' pointer. So can be used for either Oracle or MySQL
 103    db_connect => factory%create_connection()
 104    CALL db_connect%description()
 105
 106    CALL factory%finalize()        ! Destroy the object
 107
 108   END PROGRAM main