From patchwork Thu Apr 28 23:18:54 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 93348 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 DF3F0B6F7D for ; Fri, 29 Apr 2011 09:19:21 +1000 (EST) Received: (qmail 10068 invoked by alias); 28 Apr 2011 23:19:15 -0000 Received: (qmail 10054 invoked by uid 22791); 28 Apr 2011 23:19:12 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_QT X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 28 Apr 2011 23:18:56 +0000 Received: from [192.168.178.22] (port-92-204-55-235.dynamic.qsc.de [92.204.55.235]) by mx02.qsc.de (Postfix) with ESMTP id 7F7C71DF23; Fri, 29 Apr 2011 01:18:54 +0200 (CEST) Message-ID: <4DB9F5DE.8090402@net-b.de> Date: Fri, 29 Apr 2011 01:18:54 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.13) Gecko/20101206 SUSE/3.1.7 Thunderbird/3.1.7 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Fix regressions PRs 48810 and 48800: wrong access flag and missing deferred-shape diagnostics 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 The attached patch fixes two regressions: a) PR 48810: For type-bound procedures, the access flags should be checked only for the generic function, not for the specific function the generic resolves to. (4.6/4.7 rejects-valid regression.) b) PR 48800: Function-results shall not be assumed-shape arrays, unless they are allocatable or a pointer. gfortran was missing a diagnostic for that. (The diagnostic never existed, but with 4.6/4.7 it now ICEs as realloc on assignment does not like it.) Build and regtested on x86-64-linux. OK for the trunk and the 4.6 branch? Tobias PS: We still have 4 other 4.6/4.7 regressions (+ the CPP target one). Two of them are true realloc-on-assignment bugs (PRs 42954 and 48746; wrong code). One is an OOP bug (PR 48786; rejects valid + ICE on invalid code), the other one is a tree-check bug (ICE) related to "restrict". -- As written before, we should try hard to fix all 4.6/4.7 regression before 4.6.1 is relased. Cf. http://gcc.gnu.org/ml/gcc/2011-04/msg00349.html 2011-04-28 Tobias Burnus PR fortran/48810 * resolve.c (resolve_typebound_generic_call): Don't check access flags of the specific function. PR fortran/48800 * resolve.c (resolve_formal_arglist): Don't change AS_DEFERRED to AS_ASSUMED_SHAPE for function results. (resolve_fl_var_and_proc): Print also for function results with AS_DEFERRED an error, if they are not a pointer or allocatable. (resolve_types): Make sure arguments of procedures in interface blocks are resolved. 2011-04-28 Tobias Burnus PR fortran/48810 * gfortran.dg/typebound_proc_22.f90: New. PR fortran/48800 * gfortran.dg/interface_36.f90: New. --- /dev/null 2011-04-28 20:20:21.287889577 +0200 +++ gcc/gcc/testsuite/gfortran.dg/typebound_proc_22.f90 2011-04-28 22:52:39.000000000 +0200 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/48810 +! +! Contributed by Andrew Baldwin +! + module qtest + type foobar + integer :: x + contains + private + procedure :: gimmex + generic, public :: getx => gimmex + end type foobar + contains + function gimmex(foo) + class (foobar) :: foo + integer :: gimmex + gimmex = foo%x + end function gimmex + end module qtest + + module qtestPriv + type foobarPriv + integer :: x + contains + private + procedure :: gimmexPriv + generic, private :: getxPriv => gimmexPriv + end type foobarPriv + contains + function gimmexPriv(foo) + class (foobarPriv) :: foo + integer :: gimmex + gimmex = foo%x + end function gimmexPriv + end module qtestPriv + + program quicktest + use qtest + use qtestPriv + type (foobar) :: foo + type (foobarPriv) :: fooPriv + integer :: bar + bar = foo%getx() ! OK + bar = fooPriv%getxPriv() ! { dg-error " is PRIVATE " } + end program quicktest + +! { dg-final { cleanup-modules "qtest qtestpriv" } } --- /dev/null 2011-04-28 20:20:21.287889577 +0200 +++ gcc/gcc/testsuite/gfortran.dg/interface_36.f90 2011-04-28 23:27:22.000000000 +0200 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/48800 +! +! Contributed by Daniel Carrera +! + pure function runge_kutta_step(t, r_, dr, h) result(res) + real, intent(in) :: t, r_(:), h + real, dimension(:), allocatable :: k1, k2, k3, k4, res + integer :: N + + interface + pure function dr(t, r_) ! { dg-error "cannot have a deferred shape" } + real, intent(in) :: t, r_(:) + real :: dr(:) + end function + end interface + + N = size(r_) + allocate(k1(N),k2(N),k3(N),k4(N),res(N)) + + k1 = dr(t, r_) + k2 = dr(t + h/2, r_ + k1*h/2) + k3 = dr(t + h/2, r_ + k2*h/2) + k4 = dr(t + h , r_ + k3*h) + + res = r_ + (k1 + 2*k2 + 2*k3 + k4) * h/6 + end function diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7fed7a5..a19b103 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -315,7 +315,8 @@ resolve_formal_arglist (gfc_symbol *proc) shape until we know if it has the pointer or allocatable attributes. */ if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED - && !(sym->attr.pointer || sym->attr.allocatable)) + && !(sym->attr.pointer || sym->attr.allocatable) + && sym->attr.flavor != FL_PROCEDURE) { sym->as->type = AS_ASSUMED_SHAPE; for (i = 0; i < sym->as->rank; i++) @@ -5684,7 +5685,7 @@ success: /* Make sure that we have the right specific instance for the name. */ derived = get_declared_from_expr (NULL, NULL, e); - st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); + st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); if (st) e->value.compcall.tbp = st->n.tb; @@ -9918,7 +9919,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) else { if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer - && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc) + && sym->ts.type != BT_CLASS && !sym->assoc) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); @@ -13533,6 +13534,10 @@ resolve_types (gfc_namespace *ns) resolve_contained_functions (ns); + if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE + && ns->proc_name->attr.if_source == IFSRC_IFBODY) + resolve_formal_arglist (ns->proc_name); + gfc_traverse_ns (ns, resolve_bind_c_derived_types); for (cl = ns->cl_list; cl; cl = cl->next)