From patchwork Wed Jan 25 16:38:13 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 137796 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 30345B6EEC for ; Thu, 26 Jan 2012 03:38:46 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1328114327; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=CXnOEhO WBvbjTecOBrDRT6gKTEA=; b=koaGRfe4mox3fQ47CccO3ARjUX/L9ychFok7oK3 4cDJC/BVAyXrOkjoDpsJ8U62xI20J+M3MS5gA0OiZd2FIqHqcD9/poJfWd/E3yWx Lakt+0wG/ECM5HszpwbWzdktP9QJjSysiFlUtTrID9w1uzR2zAJnyM9l3Skv9/0g zv8w= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=HWsFWFUjnKrR+Vgm2Lc15UJ6WpzfHTKxgFPZTeH5qojZwZU/m5gjAJ0eufeJYv ejvne/A4R+iciDqm9meG0fStr9xdtY5ajQEsSYjZDSJFG5BXGteoSO8H5Bxaib52 32GrneHW/Lj+hRU4vECMdKp5H5qpuErE2p7fJKehZA9Hs=; Received: (qmail 425 invoked by alias); 25 Jan 2012 16:38:33 -0000 Received: (qmail 32746 invoked by uid 22791); 25 Jan 2012 16:38:31 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 25 Jan 2012 16:38:16 +0000 Received: from [192.168.178.22] (port-92-204-93-204.dynamic.qsc.de [92.204.93.204]) by mx01.qsc.de (Postfix) with ESMTP id 1C7E53CA0C; Wed, 25 Jan 2012 17:38:13 +0100 (CET) Message-ID: <4F202FF5.906@net-b.de> Date: Wed, 25 Jan 2012 17:38:13 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:9.0) Gecko/20111220 Thunderbird/9.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR 51987 - Fix setting of f2k_derived - and thus fix CLASS-based TBP Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 PR fortran/51995 * class.c (gfc_build_class_symbol): Ensure that fclass->f2k_derived is set. 2012-01-25 Tobias Burnus 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" } }