From patchwork Fri Oct 1 00:43:25 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 45640 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4F2BB385780E for ; Fri, 1 Oct 2021 00:44:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 3ABA23858C2C; Fri, 1 Oct 2021 00:43:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 3ABA23858C2C Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: ZAmgwfwmksIYL1pPSub3CVKKb4IM7O3XRwyjqlrq4JhWrLBX3nsYyjEgku8GP/0Z/nxlN/CkDN HYWGceSj2I7dsZFyD3PDyTWNW9U0INZkNjQoGz+08Yw1P3OW5bDx9AZxmii1Ca/lxDohjzEMOO nv1eHUEhRYCGq4Wo69oAt6TVgLe5GAAZDcRstJcBad4LGnIIugP3uQKcGiio5Cl1Jqw6d6rcl+ zi4tZjU7H+8J39pA9gSB5F3LcVmdU1IRiixo6IRwXSX+Kqfv2rEfSy0x+Vi7b9ejy7Ady0mnCR BYvYQamX4CDzNgb9mZwkUubW X-IronPort-AV: E=Sophos;i="5.85,337,1624348800"; d="diff'?scan'208";a="66693734" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 30 Sep 2021 16:43:32 -0800 IronPort-SDR: nNX1hMfHdfjvW8TRUPTGO9DSrXOzUJNyTeg82sWXY0oyGO13mNfV76ffzG47A65+Dx1DV+1egK zMvJF7tkuL+1SxLxm5/SnEfJU4jE6vJVHgJrnHNf6ZUv/waeozQqYMAWTX59rxqvdCiXYiDPHj wo9I/zCwG9BzKgkIGqebrakSTB5OaumnmtCg7bHmIYGJF+3r/DxuoYwowmV08/usiRywBAkTlm KYJEXBkj9i+QaZ3P87FtZs/DdUwWv2x3yCLCHyzBzTHjaS3IMoCJzTujspXeftPfoaQyqlOTGo WfM= To: gcc-patches , fortran From: Tobias Burnus Subject: [Patch] Fortran: Various CLASS + assumed-rank fixed [PR102541] Message-ID: Date: Fri, 1 Oct 2021 02:43:25 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.14.0 MIME-Version: 1.0 Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-06.mgc.mentorg.com (139.181.222.6) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi all, this patch fixes a bunch of issues with CLASS. * * * Side remark: I disliked the way CLASS is represented when it was introduced; when writing the testcase for this PR and kept fixing the testcase fallout, I started to hate it! I am sure that there are more issues – but I tried hard not too look closer at surrounding code to avoid hitting more issues. (If you look for a project, I think if you put attributes on separate lines, like a separate "POINTER :: var" line, you have a high chance to hit the error.) * * * What I found rather puzzling is that the 'optional' argument could be either on sym->attr.optional or on CLASS_DATA (sym)->attr.optional. I think one occurs for 'foo2' and the other for 'foo4' - not that I understand why it differs. I think it is otherwise straight forward. Regarding the original issue: In order to detect an assumed-size argument to an assumed-rank array, the last dimension has 'ubound = -1' to indicate an assume-size array; for those size(x, dim=rank(x)-1) == -1 and size(x) < 0 However, when the dummy argument (and hence: actual argument) is either a pointer or an allocatable, the bound is passed as is (in particular, "-1" is a valid ubound and size(x) >= 0). – However, if the actual argument is unallocated/not associated, rank(var) still is supposed to work - hence, it has to be set. The last two items did work before - but not for CLASS -> CLASS. Additionally, the ubound = -1 had an issue for CLASS -> TYPE as the code assumed that expr->ref is the whole array ("var(full-array-ref)") but for CLASS the expr->ref is a component and only expr->ref->next is the array ref. ("var%_data(full-array-ref)"). OK for mainline? Tobias ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 Fortran: Various CLASS + assumed-rank fixed [PR102541] Starting point was PR102541, were a previous patch caused an invalid e->ref access for class. When testing, it turned out that for CLASS to CLASS the code was never executed - additionally, issues appeared for optional and a bogus error for -fcheck=all. In particular: There were a bunch of issues related to optional CLASS, can have the 'attr.dummy' set in CLASS_DATA (sym) - but sometimes also in 'sym'!?! Additionally, gfc_variable_attr could return pointer = 1 for nonpointers when the expr is no longer "var" but "var%_data". PR fortran/102541 gcc/fortran/ChangeLog: * check.c (gfc_check_present): Handle optional CLASS. * interface.c (gfc_compare_actual_formal): Likewise. * trans-array.c (gfc_trans_g77_array): Likewise. * trans-decl.c (gfc_build_dummy_array_decl): Likewise. * trans-types.c (gfc_sym_type): Likewise. * primary.c (gfc_variable_attr): Fixes for dummy and pointer when 'class%_data' is passed. * trans-expr.c (set_dtype_for_unallocated, gfc_conv_procedure_call): For assumed-rank dummy, fix setting rank for dealloc/notassoc actual and setting ubound to -1 for assumed-size actuals. gcc/testsuite/ChangeLog: * gfortran.dg/assumed_rank_24.f90: New test. gcc/fortran/check.c | 4 +- gcc/fortran/interface.c | 9 +- gcc/fortran/primary.c | 20 +++- gcc/fortran/trans-array.c | 4 +- gcc/fortran/trans-decl.c | 3 +- gcc/fortran/trans-expr.c | 81 ++++++++------- gcc/fortran/trans-types.c | 3 +- gcc/testsuite/gfortran.dg/assumed_rank_24.f90 | 137 ++++++++++++++++++++++++++ 8 files changed, 213 insertions(+), 48 deletions(-) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f31ad68053b..677209ee95e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -4530,7 +4530,9 @@ gfc_check_present (gfc_expr *a) return false; } - if (!sym->attr.optional) + /* For CLASS, the optional attribute might be set at either location. */ + if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional) + && !sym->attr.optional) { gfc_error ("%qs argument of %qs intrinsic at %L must be of " "an OPTIONAL dummy variable", diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index a2fea0e97b8..34a0fddffe2 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3546,8 +3546,13 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "at %L", where); return false; } - if (!f->sym->attr.optional - || (in_statement_function && f->sym->attr.optional)) + /* For CLASS, the optional attribute might be set at either location. */ + if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional) + && !f->sym->attr.optional) + || (in_statement_function + && (f->sym->attr.optional + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.optional)))) { if (where) gfc_error ("Missing actual argument for argument %qs at %L", diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 56a78d6f89f..8d29b252fa4 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2627,7 +2627,7 @@ check_substring: symbol_attribute gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) { - int dimension, codimension, pointer, allocatable, target; + int dimension, codimension, pointer, allocatable, target, optional; symbol_attribute attr; gfc_ref *ref; gfc_symbol *sym; @@ -2640,12 +2640,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) sym = expr->symtree->n.sym; attr = sym->attr; + optional = attr.optional; if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) { dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; + optional |= CLASS_DATA (sym)->attr.optional; } else { @@ -2667,6 +2669,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (ref->type == REF_INQUIRY) { has_inquiry_part = true; + optional = false; break; } @@ -2684,12 +2687,13 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) case AR_SECTION: allocatable = pointer = 0; dimension = 1; + optional = false; break; case AR_ELEMENT: /* Handle coarrays. */ if (ref->u.ar.dimen > 0) - allocatable = pointer = 0; + allocatable = pointer = optional = false; break; case AR_UNKNOWN: @@ -2702,6 +2706,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; case REF_COMPONENT: + optional = false; comp = ref->u.c.component; attr = comp->attr; if (ts != NULL && !has_inquiry_part) @@ -2723,7 +2728,13 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) else { codimension = comp->attr.codimension; - pointer = comp->attr.pointer; + if (expr->ts.type == BT_CLASS + && comp->name[0] == '_' && comp->name[1] == 'd' + && comp->name[2] == 'a' && comp->name[3] == 't' + && comp->name[4] == 'a' && comp->name[5] == '\0') + pointer = comp->attr.class_pointer; + else + pointer = comp->attr.pointer; allocatable = comp->attr.allocatable; } if (pointer || attr.proc_pointer) @@ -2733,7 +2744,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) case REF_INQUIRY: case REF_SUBSTRING: - allocatable = pointer = 0; + allocatable = pointer = optional = false; break; } @@ -2743,6 +2754,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) attr.allocatable = allocatable; attr.target = target; attr.save = sym->attr.save; + attr.optional = optional; return attr; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b8061f37772..c403ff28488 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6550,7 +6550,9 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Add the initialization code to the start of the function. */ - if (sym->attr.optional || sym->attr.not_always_present) + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional + || sym->attr.not_always_present) { tree nullify; if (TREE_CODE (parm) != PARM_DECL) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index c758d26febf..87455f8ce25 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1303,7 +1303,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) DECL_EXTERNAL (decl) = 0; /* Avoid uninitialized warnings for optional dummy arguments. */ - if (sym->attr.optional) + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional) suppress_warning (decl); /* We should never get deferred shape arrays here. We used to because of diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1c24556c299..8a82e55d1f9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,3 +1,4 @@ +#pragma GCC optimize(0) /* Expression translation Copyright (C) 2002-2021 Free Software Foundation, Inc. Contributed by Paul Brook @@ -5454,7 +5455,8 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e) if (POINTER_TYPE_P (TREE_TYPE (desc))) desc = build_fold_indirect_ref_loc (input_location, desc); - + if (GFC_CLASS_TYPE_P (TREE_TYPE (desc))) + desc = gfc_class_data_get (desc); if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) return; @@ -6533,43 +6535,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, sym->name, NULL); - /* Special case for assumed-rank arrays. */ - if (!sym->attr.is_bind_c && e && fsym && fsym->as - && fsym->as->type == AS_ASSUMED_RANK - && e->rank != -1) - { - if ((gfc_expr_attr (e).pointer - || gfc_expr_attr (e).allocatable) - && ((fsym->ts.type == BT_CLASS - && (CLASS_DATA (fsym)->attr.class_pointer - || CLASS_DATA (fsym)->attr.allocatable)) - || (fsym->ts.type != BT_CLASS - && (fsym->attr.pointer || fsym->attr.allocatable)))) - { - /* Unallocated allocatable arrays and unassociated pointer - arrays need their dtype setting if they are argument - associated with assumed rank dummies. However, if the - dummy is nonallocate/nonpointer, the user may not - pass those. Hence, it can be skipped. */ - set_dtype_for_unallocated (&parmse, e); - } - else if (e->expr_type == EXPR_VARIABLE - && e->ref - && e->ref->u.ar.type == AR_FULL - && e->symtree->n.sym->attr.dummy - && e->symtree->n.sym->as - && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) - { - tree minus_one; - tmp = build_fold_indirect_ref_loc (input_location, - parmse.expr); - minus_one = build_int_cst (gfc_array_index_type, -1); - gfc_conv_descriptor_ubound_set (&parmse.pre, tmp, - gfc_rank_cst[e->rank - 1], - minus_one); - } - } - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable @@ -6621,6 +6586,46 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } } + /* Special case for an assumed-rank dummy argument. */ + if (!sym->attr.is_bind_c && e && fsym && e->rank > 0 + && (fsym->ts.type == BT_CLASS + ? (CLASS_DATA (fsym)->as + && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) + : (fsym->as && fsym->as->type == AS_ASSUMED_RANK))) + { + if (fsym->ts.type == BT_CLASS + ? (CLASS_DATA (fsym)->attr.class_pointer + || CLASS_DATA (fsym)->attr.allocatable) + : (fsym->attr.pointer || fsym->attr.allocatable)) + { + /* Unallocated allocatable arrays and unassociated pointer + arrays need their dtype setting if they are argument + associated with assumed rank dummies to set the rank. */ + set_dtype_for_unallocated (&parmse, e); + } + else if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.dummy + && (e->ts.type == BT_CLASS + ? (e->ref && e->ref->next + && e->ref->next->type == REF_ARRAY + && e->ref->next->u.ar.type == AR_FULL + && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE) + : (e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type == AR_FULL + && e->ref->u.ar.as->type == AS_ASSUMED_SIZE))) + { + /* Assumed-size actual to assumed-rank dummy requires + dim[rank-1].ubound = -1. */ + tree minus_one; + tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); + if (fsym->ts.type == BT_CLASS) + tmp = gfc_class_data_get (tmp); + minus_one = build_int_cst (gfc_array_index_type, -1); + gfc_conv_descriptor_ubound_set (&parmse.pre, tmp, + gfc_rank_cst[e->rank - 1], + minus_one); + } + } /* The case with fsym->attr.optional is that of a user subroutine with an interface indicating an optional argument. When we call diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 1c78a906397..220976babb8 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2342,7 +2342,8 @@ gfc_sym_type (gfc_symbol * sym) { /* We must use pointer types for potentially absent variables. The optimizers assume a reference type argument is never NULL. */ - if (sym->attr.optional + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master)) type = build_pointer_type (type); else diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 new file mode 100644 index 00000000000..d91b5ecdc46 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 @@ -0,0 +1,137 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=all" } +module m + implicit none (external, type) +contains + subroutine cl(x) + class(*) :: x(..) + if (rank(x) /= 1) stop 1 + if (ubound(x, dim=1) /= -1) stop 2 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 3 + end select + end select + end subroutine + subroutine tp(x) + type(*) :: x(..) + if (rank(x) /= 1) stop 4 + if (ubound(x, dim=1) /= -1) stop 5 + end subroutine + + subroutine foo (ccc, ddd, sss, ttt) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end + + subroutine foo2 (ccc, ddd, sss, ttt, ispresent) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + optional :: ccc, ddd, sss, ttt + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 6 + if (present(ccc)) then + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end if + end +end + +module m2 + implicit none (external, type) +contains + subroutine cl2(x) + class(*), allocatable :: x(..) + if (rank(x) /= 1) stop 7 + if (.not. allocated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 8 + if (ubound(x, dim=1) /= -1) stop 9 + if (size (x, dim=1) /= 2) stop 10 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 11 + end select + end select + end subroutine + + subroutine tp2(x) + class(*), pointer :: x(..) + if (rank(x) /= 1) stop 12 + if (.not. associated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 13 + if (ubound(x, dim=1) /= -1) stop 14 + if (size (x, dim=1) /= 2) stop 15 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 16 + end select + end select + end subroutine + + subroutine foo3 (ccc, ddd, sss, ttt) + class(*), allocatable :: sss(:) + class(*), pointer :: ttt(:) + class(*), allocatable :: ccc(:) + class(*), pointer :: ddd(:) + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end + + subroutine foo4 (ccc, ddd, sss, ttt, ispresent) + class(*), allocatable, optional :: sss(:) + class(*), pointer, optional :: ttt(:) + class(*), allocatable, optional :: ccc(:) + class(*), pointer, optional :: ddd(:) + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 17 + if (present(ccc)) then + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end if + end +end + +use m +use m2 +implicit none (external, type) +integer :: a(1),b(1),c(1),d(1) +class(*),allocatable :: aa(:),cc(:) +class(*),pointer :: bb(:),dd(:) +call foo (a,b,c,d) +call foo2 (a,b,c,d, .true.) +call foo2 (ispresent=.false.) + +nullify(bb,dd) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +allocate(integer :: aa(-2:-1), bb(-2:-1), cc(-2:-1), dd(-2:-1)) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +deallocate(aa,bb,cc,dd) +end