From patchwork Wed Apr 10 08:25:39 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1921845 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20230601 header.b=GB5kjU8p; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4VDwt36Hp2z1yYS for ; Wed, 10 Apr 2024 18:27:07 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2D41A3858416 for ; Wed, 10 Apr 2024 08:27:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pl1-x62f.google.com (mail-pl1-x62f.google.com [IPv6:2607:f8b0:4864:20::62f]) by sourceware.org (Postfix) with ESMTPS id 10B1A3858D32; Wed, 10 Apr 2024 08:25:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 10B1A3858D32 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 10B1A3858D32 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::62f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1712737556; cv=none; b=aI1LVrGoAI/6CBLGf9l5Q1N3bCBLQxm3E0dRYxRAx38wK3PHjDkNrbvFBX49/7TUBrgfYYyZKyUvf5Znu+//RPPMd5mDYKVvcQCISYNP6YA1xqFpo9y40o9/a4qDK9s0bCRPxivFedpjTM8t/hdp27DPm/c5NcWntnoIjaCRPGw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1712737556; c=relaxed/simple; bh=ONEHYohbBovvAvTIvxqFQqMVTgzwP+cS+6MR27vdhmQ=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=ZuYeO8spa5CQBWmAE4N4zKwbpVCiptwcUAl0NnYcZRomyEKAK2Wlrtk/TkhMoHn+wJuC0j8Lhd3gApBd7jKNwrbf5v+LcUiXnO6EiH93eiIUVmuQclFPqMcrM1nHTwfgDYj4474R6S2DRlFEYss3j0tBycc5sLalrM4fPHV3HZc= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pl1-x62f.google.com with SMTP id d9443c01a7336-1e0b889901bso52608665ad.1; Wed, 10 Apr 2024 01:25:53 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1712737551; x=1713342351; darn=gcc.gnu.org; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=m2oN0qIv/S2TAKo0iKNh20Ig4Zzdyu7UYFBUSu72bXo=; b=GB5kjU8pqP6XFhZqoiWqf20LKAf3giE+O3CH2DeHUlAsXc7F5u3CGaxR5zWa5CBfHf YYSzSIfkxqFftCru9/+lxxR+s8qPPR5KkE1cuB4nXY5Q1dS9xPQ7syHP5j+n8rAPpSaJ qIZ/QKqG+Kg0bTk7SgP+PQ7dqa7tWXh8o5G7OeTKiHcpRozY1p2I67EsDWhItYpMUOZw udbtmqBFhG166tccEPWgpMTTfiiQjS2q6bVgRCjx8UKfsi2HEDwIv9ZkXcS//O0k4RDt nkg2P1yiIbg2MBunwtGeSiuGdXaKDeDQDJoK4VUA+EPrINZD8/i8u7kmCak0I11mRSbe bM9A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1712737551; x=1713342351; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=m2oN0qIv/S2TAKo0iKNh20Ig4Zzdyu7UYFBUSu72bXo=; b=SpSMW/lSegC/elscVdFnTBg0GZgHEs37E1dZOBORFxxlRiQbZyYNPC9VnOlMHs2Mkz rnDPKD0wxB1/lbbLqb+ybEsgeOrcoz17azpnhKpoH9nQlecinU6N8yN6DIy5SVfhHE5d HAwlR/AaqMKjPyeaT3BHYcNQnHGG83rD87dPToe4BR1pswsmp9NpBrYOKzOcKJ773HDb LXc0f+kN9wKBqsPnjY/x5BvR0/JkdoHOjr+PWtesK3tB4PvDAU3ZIbeNRT7/j2RImsn3 IlmY/DiEQWzkZFmHcigUt2QulfcpLl++B51BqEyLPrQxwtVWtwlO0COgSVhetmaqArIu nCmg== X-Forwarded-Encrypted: i=1; AJvYcCW4dLI7HVUsu7bPpSLDVGxab1LLzlTSkox7CFoiRUKz3oaxCgRfBPDwJqsG6Tf8BdEcPCFKlOlqkSWnvOWmxS6IP3DXcZrGsQ== X-Gm-Message-State: AOJu0YwpUqFMrcJwMC3unODg80SeJLi1pifaesmJf/jSmHqFZwKTIC4d yprbe9A7T34PCICR5mmTAarnjdhuYJOl/D+zj1PH38kqMJOIojztNk2BNb6Kw8S6RFKo9CIpGDH zJsedLbmo3REy/EvipetfDt+tCePzHKdFN/E= X-Google-Smtp-Source: AGHT+IEW47Sgniydy+ruyaRoYA41GEhPh8ag6p8T6X5bI86hL6Nn+tr9ppBvp2hP3AHKHHB3u/QYNBnQAu1rCTKc/5E= X-Received: by 2002:a17:902:f60f:b0:1e4:6823:ec01 with SMTP id n15-20020a170902f60f00b001e46823ec01mr2101574plg.6.1712737551345; Wed, 10 Apr 2024 01:25:51 -0700 (PDT) MIME-Version: 1.0 From: Paul Richard Thomas Date: Wed, 10 Apr 2024 09:25:39 +0100 Message-ID: Subject: [Patch, fortran] PR113363 - ICE on ASSOCIATE and unlimited polymorphic function To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-7.5 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Hi All, This patch corrects incorrect results from assignment of unlimited polymorphic function results both in assignment statements and allocation with source. The first chunk in trans-array.cc ensures that the array dtype is set to the source dtype. The second chunk ensures that the lhs _len field does not default to zero and so is specific to dynamic types of character. The addition to trans-stmt.cc transforms the source expression, aka expr3, from a derived type of type "STAR" into a proper unlimited polymorphic expression ready for assignment to the newly allocated entity. OK for mainline? Paul Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363] 2024-04-10 Paul Thomas gcc/fortran PR fortran/113363 * trans-array.cc (gfc_array_init_size): Use the expr3 dtype so that the correct element size is used. (gfc_alloc_allocatable_for_assignment): Set the _len field for unlimited polymorphic assignments. * trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for the assignment of an unlimited polymorphic 'source'. gcc/testsuite/ PR fortran/113363 * gfortran.dg/pr113363.f90: New test. diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 30b84762346..2f9a32dda15 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -5957,6 +5957,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); } + else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc))) + { + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc)); + } else { tmp = gfc_conv_descriptor_dtype (descriptor); @@ -11324,6 +11329,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), TYPE_SIZE_UNIT (type))); + else if (UNLIMITED_POLY (expr2)) + gfc_add_modify (&fblock, tmp, + gfc_class_len_get (TREE_OPERAND (desc, 0))); else gfc_add_modify (&fblock, tmp, build_int_cst (TREE_TYPE (tmp), 0)); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 7997c167bae..c6953033cf4 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -7187,6 +7187,45 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); flag_realloc_lhs = 0; + /* The handling of code->expr3 above produces a derived type of + type "STAR", whose size defaults to size(void*). In order to + have the right type information for the assignment, we must + reconstruct an unlimited polymorphic rhs. */ + if (UNLIMITED_POLY (code->expr3) + && e3rhs && e3rhs->ts.type == BT_DERIVED + && !strcmp (e3rhs->ts.u.derived->name, "STAR")) + { + gfc_ref *ref; + gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF); + tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts), + "e3"); + gfc_add_modify (&block, tmp, + gfc_get_class_from_expr (expr3_vptr)); + rhs->symtree->n.sym->backend_decl = tmp; + rhs->ts = code->expr3->ts; + rhs->symtree->n.sym->ts = rhs->ts; + for (ref = init_expr->ref; ref; ref = ref->next) + { + /* Copy over the lhs _data component ref followed by the + full array reference for source expressions with rank. + Otherwise, just copy the _data component ref. */ + if (code->expr3->rank + && ref && ref->next && !ref->next->next) + { + rhs->ref = gfc_copy_ref (ref); + rhs->ref->next = gfc_copy_ref (ref->next); + break; + } + else if ((init_expr->rank && !code->expr3->rank + && ref && ref->next && !ref->next->next) + || (ref && !ref->next)) + { + rhs->ref = gfc_copy_ref (ref); + break; + } + } + } + /* Set the symbol to be artificial so that the result is not finalized. */ init_expr->symtree->n.sym->attr.artificial = 1; tmp = gfc_trans_assignment (init_expr, rhs, true, false, true, diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90 new file mode 100644 index 00000000000..7701539fdff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr113363.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! Test the fix for comment 1 in PR113363, which failed as in comments below. +! Contributed by Harald Anlauf +program p + implicit none + class(*), allocatable :: x(:), y + character(*), parameter :: arr(2) = ["hello ","bye "], & + sca = "Have a nice day" + +! Bug was detected in polymorphic array function results + allocate(x, source = foo ()) + call check1 (x, arr) ! Wrong output "6 hello e" + deallocate (x) + x = foo () + call check1 (x, arr) ! Wrong output "0 " + associate (var => foo ()) ! OK after r14-9489-g3fd46d859cda10 + call check1 (var, arr) ! Now OK - outputs: "6 hello bye " + end associate + +! Check scalar function results ! All OK + allocate (y, source = bar()) + call check2 (y, sca) + deallocate (y) + y = bar () + call check2 (y, sca) + deallocate (y) + associate (var => bar ()) + call check2 (var, sca) + end associate + +! Finally variable expressions... + allocate (y, source = x(1)) ! Gave zero length here + call check2 (y, "hello") + y = x(2) ! Segfaulted here + call check2 (y, "bye ") + associate (var => x(2)) ! Gave zero length here + call check2 (var, "bye ") + end associate + +! ...and constant expressions ! All OK + deallocate(y) + allocate (y, source = "abcde") + call check2 (y, "abcde") + y = "hijklmnopq" + call check2 (y, "hijklmnopq") + associate (var => "mnopq") + call check2 (var, "mnopq") + end associate + deallocate (x, y) + +contains + + function foo() result(res) + class(*), allocatable :: res(:) + res = arr + end function foo + + function bar() result(res) + class(*), allocatable :: res + res = sca + end function bar + + subroutine check1 (x, carg) + class(*), intent(in) :: x(:) + character(*) :: carg(:) + select type (x) + type is (character(*)) +! print *, len(x), x + if (any (x .ne. carg)) stop 1 + class default + stop 2 + end select + end subroutine check1 + + subroutine check2 (x, carg) + class(*), intent(in) :: x + character(*) :: carg + select type (x) + type is (character(*)) +! print *, len(x), x + if (x .ne. carg) stop 3 + class default + stop 4 + end select + end subroutine check2 +end