From patchwork Mon Aug 19 08:39:02 2019 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: 1149120 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-507232-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="sw8/RlWa"; dkim-atps=neutral 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 46BnVq1lVyz9s3Z for ; Mon, 19 Aug 2019 18:42:43 +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:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=v3le8PbXFOJjgGlB0qIanFe3NyTPmHpKpHfbavliTVO0Klj3kw 1H0hi3KQv6BUX2qq70YtMIQXeOrWiH6EuJzIYB+6ZWHS5ukEbE1dNp2NPp2r75xW GayGNs9lpAFCWxWnfb16pEiz7gu0X6/B0TamIboeb11EA5/PbhP35Qzps= 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:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=lSEql7F+Ogchat5KBOM3NPI2/34=; b=sw8/RlWaSBC65odJtOrE KhhQeNEHVl4xp3HxG/G6qcVF5C5zrIemQBt4FLtjEerbiHq22agW5Nopls/fejmu 3qh7ckzhOHNjK+019sG9GnVRfw8ju+8alnA1gNPptnHDBZU+zHiIO0/jefr0tMjW 0IrCXVONuUV0t4F7+sIdotA= Received: (qmail 118293 invoked by alias); 19 Aug 2019 08:39:27 -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 116867 invoked by uid 89); 19 Aug 2019 08:39:16 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=chosen, Valid, libgnat, corrects X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 19 Aug 2019 08:39:13 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hzdC1-0007zE-F0 for gcc-patches@gcc.gnu.org; Mon, 19 Aug 2019 04:39:11 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:35770) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hzdBz-0007vL-E6 for gcc-patches@gcc.gnu.org; Mon, 19 Aug 2019 04:39:07 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id B265F56053; Mon, 19 Aug 2019 04:39:02 -0400 (EDT) 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 KbozFYdg6U-H; Mon, 19 Aug 2019 04:39:02 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id A0E1111619A; Mon, 19 Aug 2019 04:39:02 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 9CE656AB; Mon, 19 Aug 2019 04:39:02 -0400 (EDT) Date: Mon, 19 Aug 2019 04:39:02 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Incorrect code for -gnateV switch Message-ID: <20190819083902.GA33522@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes This patch corrects the code generated by the -gnateV switch in the case of a private type whose full type is a modular type, removing spurious run-time failures. In addition, this corrects the initialization of exception occurrences in exception handlers to avoid leaving data uninitialized, which caused -gnateV to raise spurious errors. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-19 Bob Duff gcc/ada/ * exp_attr.adb (Attribute_Valid): Correct the handling of private types where the full type is modular. System.Address is an example. Otherwise, we convert uncheckedly to a signed type, so we get an incorrect range 0 .. -1, for which all values will fail. The 'Valid attribute is illegal for such types, but we generate such illegal attribute_references for 'Valid_Scalars, and we generate 'Valid_Scalars when the -gnateV switch is used. Rename Btyp --> PBtyp to avoid hiding the outer Btyp, which was confusing. * libgnat/a-except.adb: Set the Exception_Raised component. Otherwise, we have incorrect reads of invalid data. gcc/testsuite/ * gnat.dg/valid_scalars2.adb: New testcase. --- gcc/ada/exp_attr.adb +++ gcc/ada/exp_attr.adb @@ -6545,7 +6545,7 @@ package body Exp_Attr is -- See separate sections below for the generated code in each case. when Attribute_Valid => Valid : declare - Btyp : Entity_Id := Base_Type (Ptyp); + PBtyp : Entity_Id := Base_Type (Ptyp); Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; -- Save the validity checking mode. We always turn off validity @@ -6555,7 +6555,7 @@ package body Exp_Attr is function Make_Range_Test return Node_Id; -- Build the code for a range test of the form - -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last) + -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last) --------------------- -- Make_Range_Test -- @@ -6594,16 +6594,16 @@ package body Exp_Attr is return Make_In (Loc, - Left_Opnd => Unchecked_Convert_To (Btyp, Temp), + Left_Opnd => Unchecked_Convert_To (PBtyp, Temp), Right_Opnd => Make_Range (Loc, Low_Bound => - Unchecked_Convert_To (Btyp, + Unchecked_Convert_To (PBtyp, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_First)), High_Bound => - Unchecked_Convert_To (Btyp, + Unchecked_Convert_To (PBtyp, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Last)))); @@ -6631,8 +6631,8 @@ package body Exp_Attr is -- Retrieve the base type. Handle the case where the base type is a -- private enumeration type. - if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then - Btyp := Full_View (Btyp); + if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then + PBtyp := Full_View (PBtyp); end if; -- Floating-point case. This case is handled by the Valid attribute @@ -6665,7 +6665,7 @@ package body Exp_Attr is begin -- The C and AAMP back-ends handle Valid for fpt types - if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then + if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then Analyze_And_Resolve (Pref, Ptyp); Set_Etype (N, Standard_Boolean); Set_Analyzed (N); @@ -6758,13 +6758,13 @@ package body Exp_Attr is -- The way we do the range check is simply to create the -- expression: Valid (N) and then Base_Type(Pref) in Typ. - if not Subtypes_Statically_Match (Ptyp, Btyp) then + if not Subtypes_Statically_Match (Ptyp, PBtyp) then Rewrite (N, Make_And_Then (Loc, Left_Opnd => Relocate_Node (N), Right_Opnd => Make_In (Loc, - Left_Opnd => Convert_To (Btyp, Pref), + Left_Opnd => Convert_To (PBtyp, Pref), Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); end if; end Float_Valid; @@ -6793,24 +6793,24 @@ package body Exp_Attr is -- (X >= type(X)'First and then type(X)'Last <= X) elsif Is_Enumeration_Type (Ptyp) - and then Present (Enum_Pos_To_Rep (Btyp)) + and then Present (Enum_Pos_To_Rep (PBtyp)) then Tst := Make_Op_Ge (Loc, Left_Opnd => Make_Function_Call (Loc, Name => - New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc), + New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( Pref, New_Occurrence_Of (Standard_False, Loc))), Right_Opnd => Make_Integer_Literal (Loc, 0)); - if Ptyp /= Btyp + if Ptyp /= PBtyp and then - (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp) + (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp) or else - Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp)) + Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp)) then -- The call to Make_Range_Test will create declarations -- that need a proper insertion point, but Pref is now @@ -6843,16 +6843,16 @@ package body Exp_Attr is -- test has to take this into account, and the proper form of the -- test is: - -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length) + -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length) elsif Has_Biased_Representation (Ptyp) then - Btyp := RTE (RE_Unsigned_32); + PBtyp := RTE (RE_Unsigned_32); Rewrite (N, Make_Op_Lt (Loc, Left_Opnd => - Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), + Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)), Right_Opnd => - Unchecked_Convert_To (Btyp, + Unchecked_Convert_To (PBtyp, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Range_Length)))); @@ -6867,11 +6867,11 @@ package body Exp_Attr is -- the Valid attribute is exactly that this test does not work). -- What will work is: - -- Btyp!(X) >= Btyp!(type(X)'First) + -- PBtyp!(X) >= PBtyp!(type(X)'First) -- and then - -- Btyp!(X) <= Btyp!(type(X)'Last) + -- PBtyp!(X) <= PBtyp!(type(X)'Last) - -- where Btyp is an integer type large enough to cover the full + -- where PBtyp is an integer type large enough to cover the full -- range of possible stored values (i.e. it is chosen on the basis -- of the size of the type, not the range of the values). We write -- this as two tests, rather than a range check, so that static @@ -6895,11 +6895,13 @@ package body Exp_Attr is -- correct, even though a value greater than 127 looks signed to a -- signed comparison. - elsif Is_Unsigned_Type (Ptyp) then + elsif Is_Unsigned_Type (Ptyp) + or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp)) + then if Esize (Ptyp) <= 32 then - Btyp := RTE (RE_Unsigned_32); + PBtyp := RTE (RE_Unsigned_32); else - Btyp := RTE (RE_Unsigned_64); + PBtyp := RTE (RE_Unsigned_64); end if; Rewrite (N, Make_Range_Test); @@ -6908,9 +6910,9 @@ package body Exp_Attr is else if Esize (Ptyp) <= Esize (Standard_Integer) then - Btyp := Standard_Integer; + PBtyp := Standard_Integer; else - Btyp := Universal_Integer; + PBtyp := Universal_Integer; end if; Rewrite (N, Make_Range_Test); --- gcc/ada/libgnat/a-except.adb +++ gcc/ada/libgnat/a-except.adb @@ -1624,6 +1624,7 @@ package body Ada.Exceptions is Target.Machine_Occurrence := System.Null_Address; Target.Msg_Length := Source.Msg_Length; Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Exception_Raised := Source.Exception_Raised; Target.Pid := Source.Pid; Target.Msg (1 .. Target.Msg_Length) := --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/valid_scalars2.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- { dg-options "-O0 -gnata -gnateV" } + +with Ada.Exceptions; use Ada.Exceptions; + +procedure Valid_Scalars2 is + + Traced : Boolean := False; + + procedure Trace (E : in Exception_Occurrence) is + pragma Assert (E'Valid_scalars); + begin + Traced := True; + end Trace; + +begin + raise Program_Error; +exception + when E : others => + pragma Assert (E'Valid_scalars); + Trace (E); + if not Traced then + raise Program_Error; + end if; +end Valid_Scalars2;