From patchwork Tue Jun 9 08:10:07 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1305701 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 49h2rs0449z9sRW for ; Tue, 9 Jun 2020 18:11:41 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 48E69388A81C; Tue, 9 Jun 2020 08:10:20 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTP id 709F9383E838 for ; Tue, 9 Jun 2020 08:10:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 709F9383E838 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 9FA63117A9E; Tue, 9 Jun 2020 04:10:07 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 2dz8K1KrcWpF; Tue, 9 Jun 2020 04:10:07 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 675A7117A94; Tue, 9 Jun 2020 04:10:07 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 661CF107; Tue, 9 Jun 2020 04:10:07 -0400 (EDT) Date: Tue, 9 Jun 2020 04:10:07 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Remove kludge for AI05-0087 Message-ID: <20200609081007.GA73963@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-1.7 required=5.0 tests=BAYES_00, JMQ_SPF_NEUTRAL, KAM_DMARC_STATUS, KAM_NUMSUBJECT, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=no autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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: , Cc: Arnaud Charlet Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" This is a code clean up as part of removing all calls to Error_Msg* in the expander. Tested on x86_64-pc-linux-gnu, committed on trunk 2020-06-09 Arnaud Charlet gcc/ada/ * exp_ch5.adb (Expand_N_Assignment): Remove kludge for AI05-0087. * sem_ch12.adb (Validate_Derived_Type_Instance): Implement AI05-0087 retroactively since it's a binding interpretation. --- gcc/ada/exp_ch5.adb +++ gcc/ada/exp_ch5.adb @@ -29,7 +29,6 @@ with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; -with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -2664,25 +2663,13 @@ package body Exp_Ch5 is and then not Restriction_Active (No_Dispatching_Calls)) then - if Is_Limited_Type (Typ) then - - -- This can happen in an instance when the formal is an - -- extension of a limited interface, and the actual is - -- limited. This is an error according to AI05-0087, but - -- is not caught at the point of instantiation in earlier - -- versions. We also must verify that the limited type does - -- not come from source as corner cases may exist where - -- an assignment was not intended like the pathological case - -- of a raise expression within a return statement. - - -- This is wrong, error messages cannot be issued during - -- expansion, since they would be missed in -gnatc mode ??? - - if Comes_From_Source (N) then - Error_Msg_N - ("assignment not available on limited type", N); - end if; + -- We should normally not encounter any limited type here, + -- except in the corner case where an assignment was not + -- intended like the pathological case of a raise expression + -- within a return statement. + if Is_Limited_Type (Typ) then + pragma Assert (not Comes_From_Source (N)); return; end if; --- gcc/ada/sem_ch12.adb +++ gcc/ada/sem_ch12.adb @@ -13460,17 +13460,8 @@ package body Sem_Ch12 is -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). - -- Even though this AI is a binding interpretation, we enable the - -- check only in Ada 2012 mode, because this improper construct - -- shows up in user code and in existing B-tests. - - if Is_Limited_Type (Act_T) - and then not Is_Limited_Type (A_Gen_T) - and then Ada_Version >= Ada_2012 - then - if In_Instance then - null; - else + if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) then + if not In_Instance then Error_Msg_NE ("actual for non-limited & cannot be a limited type", Actual, Gen_T); @@ -13479,30 +13470,25 @@ package body Sem_Ch12 is end if; end if; - -- Don't check Ada_Version here (for now) because AI12-0036 is - -- a binding interpretation; this decision may be reversed if - -- the situation turns out to be similar to that of the preceding - -- Is_Limited_Type test (see preceding comment). + -- Check for AI12-0036 declare Formal_Is_Private_Extension : constant Boolean := Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration; Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T); + begin if Actual_Is_Tagged /= Formal_Is_Private_Extension then - if In_Instance then - null; - else + if not In_Instance then if Actual_Is_Tagged then Error_Msg_NE - ("actual for & cannot be a tagged type", - Actual, Gen_T); + ("actual for & cannot be a tagged type", Actual, Gen_T); else Error_Msg_NE - ("actual for & must be a tagged type", - Actual, Gen_T); + ("actual for & must be a tagged type", Actual, Gen_T); end if; + Abandon_Instantiation (Actual); end if; end if;