diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 70bd5eea8de..b6adf238232 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,4 +1,10 @@ -2012-01-24 Tobias Burnus +2012-01-25 Tobias Burnus + + PR fortran/51995 + * class.c (gfc_build_class_symbol): Ensure that + fclass->f2k_derived is set. + +2012-01-25 Tobias Burnus PR fortran/51966 * resolve.c (resolve_structure_cons): Only create an diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 5e5de1400e6..92cfef76d6c 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 493b040c4d8..6e38d08b763 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-01-25 Tobias Burnus + + PR fortran/51995 + * gfortran.dg/typebound_proc_25.f90: New. + 2012-01-25 Jason Merrill PR c++/51992 @@ -21,7 +26,7 @@ * gcc.dg/pr50908-2.c (dg-options): Add -fno-short-enums. -2012-01-24 Tobias Burnus +2012-01-25 Tobias Burnus 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 00000000000..4a68fb9db51 --- /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" } }