Patchwork [Fortran] PR 51987 - Fix setting of f2k_derived - and thus fix CLASS-based TBP

login
register
mail settings
Submitter Tobias Burnus
Date Jan. 25, 2012, 4:38 p.m.
Message ID <4F202FF5.906@net-b.de>
Download mbox | patch
Permalink /patch/137796/
State New
Headers show

Comments

Tobias Burnus - Jan. 25, 2012, 4:38 p.m.
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
Paul Richard Thomas - Jan. 25, 2012, 5:13 p.m.
Dear Tobias,

On Wed, Jan 25, 2012 at 5:38 PM, Tobias Burnus <burnus@net-b.de> wrote:
> 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?

OK for trunk.

I think that this lack of an f2k_derived explains one of my earlier
fixes to typebound operators.  I was puzzled about why I had to check
the current namespace with the generic name in order to resolve for a
specific procedure.  I'll put it as one of my TODOs.

Thanks

Paul

> 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

Forward me the message and I will do the honours.

Patch

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" } }