From patchwork Sat Jun 8 15:56:46 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1112497 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-502632-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 45LkYY6lW3z9s9y for ; Sun, 9 Jun 2019 01:57:14 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:content-type; q= dns; s=default; b=CTVPCE0aeie3y5BlCEMc9VaOp534ZMh94SudVe2jmXZwpu 5bXbvDEmJbJ+s28+O+gEFOuRVMNQZCXB3Qe1txdrYozvzW5gIoAmxET+LvV3nA0D TzEqNE8NyplABvabdYwyTfdnhXJUcKP0AQ4s/c3NbGPmsQlnB19Z6u/VzxkE4= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:content-type; s= default; bh=WlcUK3bvkZkWLawwhKWM14kXA0s=; b=D8gkTkPuFuyuhWQWF60k c4DaefPsBdF6h+bT4LLYFfoiP1uPtm6pGxReADFqGOub45yESybKVtbMPlrRLpT9 PrH3zjRqUWK53GT5Gga5gnA1vTzsuxFDxn1OG3Rnl9WgWaldUqZLRIQH32Ju1tUb GdVwjQZ+yL9ou3r7OcuzEys= Received: (qmail 86782 invoked by alias); 8 Jun 2019 15:57:03 -0000 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 Received: (qmail 86766 invoked by uid 89); 8 Jun 2019 15:57:02 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-3.8 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_2, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=valued, benson, PR90786, pr90786 X-HELO: mail-lf1-f47.google.com Received: from mail-lf1-f47.google.com (HELO mail-lf1-f47.google.com) (209.85.167.47) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 08 Jun 2019 15:57:01 +0000 Received: by mail-lf1-f47.google.com with SMTP id b11so3790574lfa.5; Sat, 08 Jun 2019 08:57:00 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=mime-version:from:date:message-id:subject:to; bh=gexqg4H5aUqDWfOMSxiM4rJoCknyBugpgw22wS6b6Kg=; b=fhBejiNqi7JKDujhTXad6vyW9qX8tsfN+MVDE6YMeIxdj9d64DUBk0YGltZILDYV16 aHztZY7VyIo80fTLB0WmLvGj2cNDDMGn4Uy2ZlPf9Z1kB21j1DGtXFXx53F3TyQ3j3Rt NQUx9SJvQchVNStc3B4Ek5j5kXPMIPM9vOJUGZ6T8DrSJW9AqJnMfOUcImzpmy5ITE4I FCsynURcMGPIRz1NBLMuEJYuAD9v0rTUTViR4yDvZcniDRqlOzyoCWxgp6wk5krQS/tI eG8f3JE50zlN3R/Lhqk8EQipToIhOIVdWCEHBB4Eap9rdorKFC2QqJBz1V1b589KTnTM R/kA== MIME-Version: 1.0 From: Paul Richard Thomas Date: Sat, 8 Jun 2019 16:56:46 +0100 Message-ID: Subject: [Patch, fortran] PR90786 - [7/8/9/10 Regression] ICE on procedure pointer assignment to function with class pointer result To: gcc-patches , "fortran@gcc.gnu.org" Committed as obvious in revision 272084. The problem was that the lhs symbol itself was not being checked as a proc_pointer - just the expression component. I will get on with backporting tomorrow. Cheers Paul 2019-06-08 Paul Thomas PR fortran/90786 * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as it is very simple and only called from one place. (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign as non_proc_ptr_assign. Assign to it directly, rather than call to above, deleted function and use gfc_expr_attr instead of only checking the reference chain. 2019-06-08 Paul Thomas PR fortran/90786 * gfortran.dg/proc_ptr_51.f90 : New test. Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 272076) --- gcc/fortran/trans-expr.c (working copy) *************** class_array_fcn: *** 4881,4887 **** parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); /* Basically make this into ! if (present) { if (contiguous) --- 4881,4887 ---- parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); /* Basically make this into ! if (present) { if (contiguous) *************** trans_caf_token_assign (gfc_se *lse, gfc *** 8979,9001 **** } } - /* Indentify class valued proc_pointer assignments. */ - - static bool - pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2) - { - gfc_ref * ref; - - ref = expr1->ref; - while (ref && ref->next) - ref = ref->next; - - return ref && ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE; - } - /* Do everything that is needed for a CLASS function expr2. */ --- 8979,8984 ---- *************** gfc_trans_pointer_assignment (gfc_expr * *** 9048,9054 **** tree desc; tree tmp; tree expr1_vptr = NULL_TREE; ! bool scalar, non_proc_pointer_assign; gfc_ss *ss; gfc_start_block (&block); --- 9031,9037 ---- tree desc; tree tmp; tree expr1_vptr = NULL_TREE; ! bool scalar, non_proc_ptr_assign; gfc_ss *ss; gfc_start_block (&block); *************** gfc_trans_pointer_assignment (gfc_expr * *** 9056,9062 **** gfc_init_se (&lse, NULL); /* Usually testing whether this is not a proc pointer assignment. */ ! non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2); /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ --- 9039,9047 ---- gfc_init_se (&lse, NULL); /* Usually testing whether this is not a proc pointer assignment. */ ! non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer ! && expr2->expr_type == EXPR_VARIABLE ! && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE); /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ *************** gfc_trans_pointer_assignment (gfc_expr * *** 9066,9072 **** gfc_free_ss_chain (ss); if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS ! && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't --- 9051,9057 ---- gfc_free_ss_chain (ss); if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS ! && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign) { gfc_add_data_component (expr2); /* The following is required as gfc_add_data_component doesn't *************** gfc_trans_pointer_assignment (gfc_expr * *** 9086,9092 **** else gfc_conv_expr (&rse, expr2); ! if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS) { trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); --- 9071,9077 ---- else gfc_conv_expr (&rse, expr2); ! if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS) { trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); Index: gcc/testsuite/gfortran.dg/proc_ptr_51.f90 =================================================================== *** gcc/testsuite/gfortran.dg/proc_ptr_51.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/proc_ptr_51.f90 (working copy) *************** *** 0 **** --- 1,38 ---- + ! { dg-do run } + ! + ! Test the fix for PR90786. + ! + ! Contributed by Andrew benson + ! + module f + procedure(c), pointer :: c_ + + type :: s + integer :: i = 42 + end type s + class(s), pointer :: res, tgt + + contains + + function c() + implicit none + class(s), pointer :: c + c => tgt + return + end function c + + subroutine fs() + implicit none + c_ => c ! This used to ICE + return + end subroutine fs + + end module f + + use f + allocate (tgt, source = s(99)) + call fs() + res => c_() + if (res%i .ne. 99) stop 1 + deallocate (tgt) + end