From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x435.google.com (mail-wr1-x435.google.com [IPv6:2a00:1450:4864:20::435]) by sourceware.org (Postfix) with ESMTPS id 1BA6F385782F for ; Fri, 4 Nov 2022 13:58:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1BA6F385782F Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x435.google.com with SMTP id a14so7174172wru.5 for ; Fri, 04 Nov 2022 06:58:15 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=DGmx6mi8xfolPRIeyCzlNInEHg9/BwHZ3VLoFHm3cqo=; b=H5UT8o089l6mVIk7ZcQyZ3Zma1Dhls1qT9ZCOMNzL3Yb1htw88fJ03xSATFDzObiqp c9Is9kMunMp5JVmsimiJlRJdR/cR9jcTdzac/+2UVoTzbTsgrNEp0kEq/P2QQGZP6rNU 7enp4GZ/jgFwAk/tXOZIyjb6jGRxcbzJgmr9HPK7ZczR4DakUu2DetWHv+ic9gwQI59F fpIbzIIowMbsIKWDoz4lylDve/wKM6tjEBrHl90jQSzYkwmmA3nsm4GrZ56fbMc6I32D 79moghQkQC8JKB+BRbjydJQdnYSLiAntJ3cUcD4K+jUC6UoXmznFrJv1XRK+6tR/Uz3f 32OQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=DGmx6mi8xfolPRIeyCzlNInEHg9/BwHZ3VLoFHm3cqo=; b=SD4l6hLuFdhqJbq58sT+Gy8SZFMFzSL2VCsIrj7ad2c9MEMJSK8Y4wh6/YvpixQROY 2BEjo3wf8hLIF/3oV4t1gjildLc92f71Q459qpvA2ecDfWrrPNQEV5fFr3LkLoDDHZ9Y 2vJdJ3JfQ8oMn9m6Q2WC6YddDxUegwxC/Eis0+scsfaaD7ZUU8NJEjj9skXP8ksmok35 8bii8cEzujqEw3Ktu0Ybh7LusTldf750lMXJ+xU03kvXC4oT2a5zXT6x7OP0NgW9pMR1 rpAPeWq7K85AveH3ZWmxPhW8x37BpP/dmKk7f2ciG24XPOfQb7ZZ8UIFvjCg+x4NhDGX Us5g== X-Gm-Message-State: ACrzQf2JTVhT4UBlw9HE8LTxUgT+f2YzqJGdAerl4TBD+duOsmaxScpb RfhYLTLmBVxRsJBmL2qxPWjDFUS1Acc6cQ== X-Google-Smtp-Source: AMsMyM4c3gvvlEBc10YU7jntHsaximM+kNyG4ZLXtYpQ6Bt3nwaVP7zl2MuTY1XMTlwSpr35sWf2gA== X-Received: by 2002:a5d:6552:0:b0:236:73ff:9cd0 with SMTP id z18-20020a5d6552000000b0023673ff9cd0mr230862wrv.628.1667570293861; Fri, 04 Nov 2022 06:58:13 -0700 (PDT) Received: from localhost.localdomain (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id bu14-20020a056000078e00b0022cdb687bf9sm4806037wrb.0.2022.11.04.06.58.13 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 04 Nov 2022 06:58:13 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [COMMITTED] ada: Flag unsupported dispatching constructor calls Date: Fri, 4 Nov 2022 14:58:10 +0100 Message-Id: <20221104135810.86760-1-poulhies@adacore.com> X-Mailer: git-send-email 2.34.1 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,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 List-Id: From: Javier Miranda gcc/ada/ * exp_intr.adb (Expand_Dispatching_Constructor_Call): Report an error on unsupported dispatching constructor calls and report a warning on calls that may fail at run time. gcc/testsuite/ * gnat.dg/abstract1.ads: Cleanup whitespaces. * gnat.dg/abstract1.adb: Likewise and add -gnatws to silence new warning. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_intr.adb | 44 +++++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/abstract1.adb | 14 +++++---- gcc/testsuite/gnat.dg/abstract1.ads | 6 ++-- 3 files changed, 55 insertions(+), 9 deletions(-) diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index bd987f089e1..cb9b5be1090 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -24,13 +24,16 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Code; use Exp_Code; @@ -277,6 +280,47 @@ package body Exp_Intr is Result_Typ : Entity_Id; begin + pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N))))); + + -- Report case where we know that the generated code is wrong; that + -- is a dispatching constructor call whose controlling type has tasks + -- but its root type does not have tasks. In such case the constructor + -- subprogram of the root type does not have extra formals but the + -- constructor of the derivation must have extra formals. + + if not Global_No_Tasking + and then not No_Run_Time_Mode + and then Is_Build_In_Place_Function (Entity (Name (N))) + and then not Has_Task (Root_Type (Etype (Entity (Name (N))))) + and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))), + Aspect_No_Task_Parts) + then + -- Case 1: Explicit tag reference (which allows static check) + + if Nkind (Tag_Arg) = N_Identifier + and then Present (Entity (Tag_Arg)) + and then Is_Tag (Entity (Tag_Arg)) + then + if Has_Task (Related_Type (Entity (Tag_Arg))) then + Error_Msg_N ("unsupported dispatching constructor call", N); + Error_Msg_NE + ("\work around this problem by defining task component " + & "type& using access-to-task-type", + N, Related_Type (Entity (Tag_Arg))); + end if; + + -- Case 2: Dynamic tag which may fail at run time + + else + Error_Msg_N + ("unsupported dispatching constructor call if the type " + & "of the built object has task components??", N); + Error_Msg_N + ("\work around this problem by replacing task components " + & "with access-to-task-type components??", N); + end if; + end if; + -- Remove side effects from tag argument early, before rewriting -- the dispatching constructor call, as Remove_Side_Effects relies -- on Tag_Arg's Parent link properly attached to the tree (once the diff --git a/gcc/testsuite/gnat.dg/abstract1.adb b/gcc/testsuite/gnat.dg/abstract1.adb index 97508fac2b8..36f75e9d495 100644 --- a/gcc/testsuite/gnat.dg/abstract1.adb +++ b/gcc/testsuite/gnat.dg/abstract1.adb @@ -1,18 +1,20 @@ -- { dg-do compile } +-- { dg-options "-gnatws" } + with Ada.Tags.Generic_Dispatching_Constructor; use Ada.Tags; package body abstract1 is - + function New_T (Stream : not null access Root_Stream_Type'Class) return T'Class is function Construct is new Generic_Dispatching_Constructor (T, Root_Stream_Type'Class, Input); E : constant String := String'Input (Stream); I : constant Tag := Internal_Tag (E); - + begin return Construct (I, Stream); end New_T; - + function Input (Stream : not null access Root_Stream_Type'Class) return IT is begin @@ -20,12 +22,12 @@ package body abstract1 is Integer'Read (Stream, O.I); end return; end Input; - + function Input (Stream : not null access Root_Stream_Type'Class) return FT is begin return O : FT do Float'Read (Stream, O.F); - end return; - end Input; + end return; + end Input; end abstract1; diff --git a/gcc/testsuite/gnat.dg/abstract1.ads b/gcc/testsuite/gnat.dg/abstract1.ads index bad9ee69874..de14d77a948 100644 --- a/gcc/testsuite/gnat.dg/abstract1.ads +++ b/gcc/testsuite/gnat.dg/abstract1.ads @@ -3,15 +3,15 @@ package abstract1 is type T is abstract tagged limited null record; function Input (Stream : not null access Root_Stream_Type'Class) return T is abstract; - + function New_T (Stream : not null access Root_Stream_Type'Class) return T'Class; - + type IT is limited new T with record I : Integer; end record; function Input (Stream : not null access Root_Stream_Type'Class) return IT; - + type FT is limited new T with record F : Float; end record; -- 2.34.1