This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PR 51987 - Fix setting of f2k_derived - and thus fix CLASS-based TBP
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Wed, 25 Jan 2012 17:38:13 +0100
- Subject: [Patch, Fortran] PR 51987 - Fix setting of f2k_derived - and thus fix CLASS-based TBP
Dear all,
seemingly it can sometimes happen that "fclass" gets created but the
fclass->f2k_derived is not set. This patch now sets it explicitly, if unset.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: I am still looking for someone to review my rather straight-forward
patch at http://gcc.gnu.org/ml/fortran/2012-01/msg00197.html
2012-01-25 Tobias Burnus <burnus@net-b.de>
PR fortran/51995
* class.c (gfc_build_class_symbol): Ensure that
fclass->f2k_derived is set.
2012-01-25 Tobias Burnus <burnus@net-b.de>
PR fortran/51995
* gfortran.dg/typebound_proc_25.f90: New.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 5e5de14..92cfef7 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -421,6 +421,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->attr.access = ACCESS_PRIVATE;
c->attr.pointer = 1;
}
+ else if (!fclass->f2k_derived)
+ fclass->f2k_derived = fclass->components->ts.u.derived->f2k_derived;
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
--- /dev/null 2012-01-23 08:22:38.999666895 +0100
+++ gcc/gcc/testsuite/gfortran.dg/typebound_proc_25.f90 2012-01-25 14:31:02.000000000 +0100
@@ -0,0 +1,110 @@
+! { dg-do compile }
+!
+! PR fortran/51995
+!
+! Contributed by jilfa12@yahoo.com
+!
+
+MODULE factory_pattern
+
+ TYPE CFactory
+ PRIVATE
+ CHARACTER(len=20) :: factory_type !! Descriptive name for database
+ CLASS(Connection), POINTER :: connection_type !! Which type of database ?
+ CONTAINS !! Note 'class' not 'type' !
+ PROCEDURE :: init !! Constructor
+ PROCEDURE :: create_connection !! Connect to database
+ PROCEDURE :: finalize !! Destructor
+ END TYPE CFactory
+
+ TYPE, ABSTRACT :: Connection
+ CONTAINS
+ PROCEDURE(generic_desc), DEFERRED, PASS(self) :: description
+ END TYPE Connection
+
+ ABSTRACT INTERFACE
+ SUBROUTINE generic_desc(self)
+ IMPORT :: Connection
+ CLASS(Connection), INTENT(in) :: self
+ END SUBROUTINE generic_desc
+ END INTERFACE
+
+ !! An Oracle connection
+ TYPE, EXTENDS(Connection) :: OracleConnection
+ CONTAINS
+ PROCEDURE, PASS(self) :: description => oracle_desc
+ END TYPE OracleConnection
+
+ !! A MySQL connection
+ TYPE, EXTENDS(Connection) :: MySQLConnection
+ CONTAINS
+ PROCEDURE, PASS(self) :: description => mysql_desc
+ END TYPE MySQLConnection
+
+CONTAINS
+
+ SUBROUTINE init(self, string)
+ CLASS(CFactory), INTENT(inout) :: self
+ CHARACTER(len=*), INTENT(in) :: string
+ self%factory_type = TRIM(string)
+ self%connection_type => NULL() !! pointer is nullified
+ END SUBROUTINE init
+
+ SUBROUTINE finalize(self)
+ CLASS(CFactory), INTENT(inout) :: self
+ DEALLOCATE(self%connection_type) !! Free the memory
+ NULLIFY(self%connection_type)
+ END SUBROUTINE finalize
+
+ FUNCTION create_connection(self) RESULT(ptr)
+ CLASS(CFactory) :: self
+ CLASS(Connection), POINTER :: ptr
+
+ IF(self%factory_type == "Oracle") THEN
+ IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type)
+ ALLOCATE(OracleConnection :: self%connection_type)
+ ptr => self%connection_type
+ ELSEIF(self%factory_type == "MySQL") THEN
+ IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type)
+ ALLOCATE(MySQLConnection :: self%connection_type)
+ ptr => self%connection_type
+ END IF
+
+ END FUNCTION create_connection
+
+ SUBROUTINE oracle_desc(self)
+ CLASS(OracleConnection), INTENT(in) :: self
+ WRITE(*,'(A)') "You are now connected with Oracle"
+ END SUBROUTINE oracle_desc
+
+ SUBROUTINE mysql_desc(self)
+ CLASS(MySQLConnection), INTENT(in) :: self
+ WRITE(*,'(A)') "You are now connected with MySQL"
+ END SUBROUTINE mysql_desc
+end module
+
+
+ PROGRAM main
+ USE factory_pattern
+
+ IMPLICIT NONE
+
+ TYPE(CFactory) :: factory
+ CLASS(Connection), POINTER :: db_connect => NULL()
+
+ CALL factory%init("Oracle")
+ db_connect => factory%create_connection() !! Create Oracle DB
+ CALL db_connect%description()
+
+ !! The same factory can be used to create different connections
+ CALL factory%init("MySQL") !! Create MySQL DB
+
+ !! 'connect' is a 'class' pointer. So can be used for either Oracle or MySQL
+ db_connect => factory%create_connection()
+ CALL db_connect%description()
+
+ CALL factory%finalize() ! Destroy the object
+
+ END PROGRAM main
+
+! { dg-final { cleanup-modules "factory_pattern" } }