From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 15726 invoked by alias); 20 Aug 2007 19:05:42 -0000 Received: (qmail 15658 invoked by uid 22791); 20 Aug 2007 19:05:40 -0000 X-Spam-Check-By: sourceware.org Received: from zs01.physik.fu-berlin.de (HELO zs01.physik.fu-berlin.de) (160.45.35.150) by sourceware.org (qpsmtpd/0.31) with ESMTP; Mon, 20 Aug 2007 19:05:34 +0000 Received: from ith.physik.fu-berlin.de ([160.45.32.115] helo=[127.0.0.1]) by zs01.physik.fu-berlin.de with esmtp (Exim 4.63) (envelope-from ) id 1INCZ7-0001FD-CC; Mon, 20 Aug 2007 21:05:31 +0200 Message-ID: <46C9E5FA.10207@net-b.de> Date: Mon, 20 Aug 2007 19:20:00 -0000 From: Tobias Burnus User-Agent: Thunderbird 2.0.0.4 (X11/20070613) MIME-Version: 1.0 To: gcc-patches , "'fortran@gcc.gnu.org'" Subject: [Patch, Fortran] PR32985 - COMMON checking Content-Type: multipart/mixed; boundary="------------060004080205050504080001" X-ZEDV-Virus-Scanned: No viruses found. [Could not determine clamav version] X-ZEDV-Spam-Level: ---- X-ZEDV-Spam-Checker-Version: SpamAssassin 3.1.7-deb (2006-10-05) on zs01.physik.fu-berlin.de X-ZEDV-Spam-Status: No, score=-4.4 required=5.0 tests=ALL_TRUSTED,BAYES_00 autolearn=ham version=3.1.7-deb X-ZEDV-Spam-Report: * -1.8 ALL_TRUSTED Passed through trusted hosts only via SMTP * -2.6 BAYES_00 BODY: Bayesian spam probability is 0 to 1% * [score: 0.0000] Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2007-08/txt/msg01300.txt.bz2 This is a multi-part message in MIME format. --------------060004080205050504080001 Content-Type: text/plain; charset=ISO-8859-15 Content-Transfer-Encoding: 7bit Content-length: 1508 :ADDPATCH fortran: This patch does two things: a) It fixes a really stupid bug be me. A tree is a tree is a tree -- and not a linked list; as I was treating the common_root symtree as list, the diagnostic did not always work. b) The checking in MATCH comes too early thus the check whether an element in COMMON lacks the SEQUENCE type did not work if "TYPE(...)" came after "COMMON". Additionally, there was no check for allocateable components. BIND(C) is now treated as SEQUENCE with regards to COMMON. For COMMON: "C589 (R558) If a common-block-object is of a derived type, it shall be a sequence type (4.5.1) or a type with the BIND attribute and it shall have no default initialization." "C588 (R558) A common-block-object shall not be a dummy argument, an allocatable variable, a derived-type object with an ultimate component that is allocatable, an automatic object, a function name, an entry name, a variable with the BIND attribute, or a result name." With regards to the standard, this patch fixes the BIND(C) (was rejected) and "derived-type object with an ultimate component that is allocatable" (was accepted). What currently is missing is a check for "it shall have no default initialization." By the way, BIND(C) in EQUIVALENCE is not allowed: "C576 An equivalence-object shall not be a designator with a base object that is [...] a variable with the BIND attribute". (gfortran did and still does the right thing.) Regression tested on x86-64-linux. Ok for the trunk? Tobias --------------060004080205050504080001 Content-Type: text/plain; name="common.diff" Content-Transfer-Encoding: 7bit Content-Disposition: inline; filename="common.diff" Content-length: 6162 2007-08-20 Tobias Burnus PR fortran/32985 * match.c (gfc_match_common): Remove SEQUENCE diagnostics. * resolve.c (resolve_common_blocks): Add SEQUENCE diagnostics; fix walking through the tree. 2007-08-20 Tobias Burnus PR fortran/32985 * gfortran.dg/namelist_14.f90: Make test case valid. * common_10.f90: New. Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (Revision 127647) +++ gcc/fortran/match.c (Arbeitskopie) @@ -2709,14 +2709,6 @@ gfc_match_common (void) if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; - /* Derived type names must have the SEQUENCE attribute. */ - if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence) - { - gfc_error ("Derived type variable in COMMON at %C does not " - "have the SEQUENCE attribute"); - goto cleanup; - } - if (tail != NULL) tail->common_next = sym; else Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 127647) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -606,49 +606,58 @@ resolve_entries (gfc_namespace *ns) static void resolve_common_blocks (gfc_symtree *common_root) { - gfc_symtree *symtree; - gfc_symbol *sym; + gfc_symbol *sym, *csym; - if (common_root == NULL) - return; + if (common_root == NULL) + return; - for (symtree = common_root; symtree->left; symtree = symtree->left); + if (common_root->left) + resolve_common_blocks (common_root->left); + if (common_root->right) + resolve_common_blocks (common_root->right); - for (; symtree; symtree = symtree->right) - { - gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym); - if (sym == NULL) - continue; + for (csym = common_root->n.common->head; csym; csym = csym->common_next) + { + if (csym->ts.type == BT_DERIVED + && !(csym->ts.derived->attr.sequence + || csym->ts.derived->attr.is_bind_c)) + { + gfc_error_now ("Derived type variable '%s' in COMMON at %L " + "has neither the SEQUENCE nor the BIND(C) " + "attribute", csym->name, + &csym->declared_at); + } + else if (csym->ts.type == BT_DERIVED + && csym->ts.derived->attr.alloc_comp) + { + gfc_error_now ("Derived type variable '%s' in COMMON at %L " + "has an ultimate component that is " + "allocatable", csym->name, + &csym->declared_at); + } + } - if (sym->attr.flavor == FL_PARAMETER) - { - gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L", - sym->name, &symtree->n.common->where, - &sym->declared_at); - } + gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); + if (sym == NULL) + return; - if (sym->attr.intrinsic) - { - gfc_error ("COMMON block '%s' at %L is also an intrinsic " - "procedure", sym->name, - &symtree->n.common->where); - } - else if (sym->attr.result - ||(sym->attr.function && gfc_current_ns->proc_name == sym)) - { - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' " - "at %L that is also a function result", sym->name, - &symtree->n.common->where); - } - else if (sym->attr.flavor == FL_PROCEDURE - && sym->attr.proc != PROC_INTERNAL - && sym->attr.proc != PROC_ST_FUNCTION) - { - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' " - "at %L that is also a global procedure", sym->name, - &symtree->n.common->where); - } - } + if (sym->attr.flavor == FL_PARAMETER) + gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L", + sym->name, &common_root->n.common->where, &sym->declared_at); + + if (sym->attr.intrinsic) + gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", + sym->name, &common_root->n.common->where); + else if (sym->attr.result + ||(sym->attr.function && gfc_current_ns->proc_name == sym)) + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + "that is also a function result", sym->name, + &common_root->n.common->where); + else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL + && sym->attr.proc != PROC_ST_FUNCTION) + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + "that is also a global procedure", sym->name, + &common_root->n.common->where); } Index: gcc/testsuite/gfortran.dg/namelist_14.f90 =================================================================== --- gcc/testsuite/gfortran.dg/namelist_14.f90 (Revision 127647) +++ gcc/testsuite/gfortran.dg/namelist_14.f90 (Arbeitskopie) @@ -6,6 +6,7 @@ module global type :: mt + sequence integer :: ii(4) end type mt end module global Index: gcc/testsuite/gfortran.dg/common_10.f90 =================================================================== --- gcc/testsuite/gfortran.dg/common_10.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/common_10.f90 (Revision 0) @@ -0,0 +1,55 @@ +use iso_c_binding +implicit none + +type, bind(C) :: mytype1 + integer(c_int) :: x + real(c_float) :: y +end type mytype1 + +type mytype2 + sequence + integer :: x + real :: y +end type mytype2 + +type mytype3 + integer :: x + real :: y +end type mytype3 + +type mytype4 + sequence + integer, allocatable, dimension(:) :: x +end type mytype4 + +type mytype5 + sequence + integer, pointer :: x + integer :: y +end type mytype5 + +type mytype6 + sequence + type(mytype5) :: t +end type mytype6 + +type mytype7 + sequence + type(mytype4) :: t +end type mytype7 + +common /a/ t1 +common /b/ t2 +common /c/ t3 ! { dg-error "has neither the SEQUENCE nor the BIND.C. attribute" } +common /d/ t4 ! { dg-error "has an ultimate component that is allocatable" } +common /e/ t5 +common /f/ t6 +common /f/ t7 ! { dg-error "has an ultimate component that is allocatable" } +type(mytype1) :: t1 +type(mytype2) :: t2 +type(mytype3) :: t3 +type(mytype4) :: t4 +type(mytype5) :: t5 +type(mytype6) :: t6 +type(mytype7) :: t7 +end --------------060004080205050504080001--