re PR fortran/51995 ([OOP] Polymorphic class fails at runtime)

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.

From-SVN: r183528

4 files changed, 125 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 70bd5ee..b6adf23 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,10 @@
-2012-01-24  Tobias Burnus  <burnus@net-b.de>
+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/51966
 	* resolve.c (resolve_structure_cons): Only create an
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.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 493b040..6e38d08 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51995
+	* gfortran.dg/typebound_proc_25.f90: New.
+
 2012-01-25  Jason Merrill  <jason@redhat.com>
 
 	PR c++/51992
@@ -21,7 +26,7 @@
 
 	* gcc.dg/pr50908-2.c (dg-options): Add -fno-short-enums.
 
-2012-01-24  Tobias Burnus  <burnus@net-b.de>
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51966
 	* gfortran.dg/derived_constructor_char_3.f90: New.
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_25.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_25.f90
new file mode 100644
index 0000000..4a68fb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_proc_25.f90
@@ -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" } }