From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 127388 invoked by alias); 8 Jul 2019 08:19:01 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 127342 invoked by uid 89); 8 Jul 2019 08:19:00 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.2 required=5.0 tests=AWL,BAYES_05,GIT_PATCH_2,GIT_PATCH_3,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.1 spammy=Image, Crash, sk:Expand_, sso16.adb X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 08 Jul 2019 08:18:59 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 85C5156180; Mon, 8 Jul 2019 04:18:57 -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 aSTEyE58OYQc; Mon, 8 Jul 2019 04:18:57 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 7399956098; Mon, 8 Jul 2019 04:18:57 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 70565602; Mon, 8 Jul 2019 04:18:57 -0400 (EDT) Date: Mon, 08 Jul 2019 08:19:00 -0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [Ada] Crash on Image and Value attributes Message-ID: <20190708081857.GA80582@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="8t9RHnE3ZwKMSgU+" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes X-SW-Source: 2019-07/txt/msg00536.txt.bz2 --8t9RHnE3ZwKMSgU+ Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 545 This patch fixes an issue whereby the creation of an enumeration within package where Default_Scalar_Storage_Order is in effect may lead to a crash when the attributes Image or Value are applied to objects of said type or the type directly. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-07-08 Justin Squirek gcc/ada/ * exp_imgv.adb (Build_Enumeration_Image_Tables): Default SSO for the building of image tables. (Expand_Image_Attribute): Minor cleanup. gcc/testsuite/ * gnat.dg/sso16.adb: New testcase. --8t9RHnE3ZwKMSgU+ Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" Content-length: 3736 --- gcc/ada/exp_imgv.adb +++ gcc/ada/exp_imgv.adb @@ -69,18 +69,23 @@ package body Exp_Imgv is ------------------------------------ procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (E); - Str : String_Id; + Loc : constant Source_Ptr := Sloc (E); + + Eind : Entity_Id; + Estr : Entity_Id; Ind : List_Id; + Ityp : Node_Id; + Len : Nat; Lit : Entity_Id; Nlit : Nat; - Len : Nat; - Estr : Entity_Id; - Eind : Entity_Id; - Ityp : Node_Id; + Str : String_Id; + + Saved_SSO : constant Character := Opt.Default_SSO; + -- Used to save the current scalar storage order during the generation + -- of the literal lookup table. begin - -- Nothing to do for other than a root enumeration type + -- Nothing to do for types other than a root enumeration type if E /= Root_Type (E) then return; @@ -138,6 +143,15 @@ package body Exp_Imgv is Set_Lit_Strings (E, Estr); Set_Lit_Indexes (E, Eind); + -- Temporarily set the current scalar storage order to the default + -- during the generation of the literals table, since both the Image and + -- Value attributes rely on runtime routines for interpreting table + -- values. + + Opt.Default_SSO := ' '; + + -- Generate literal table + Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -168,6 +182,10 @@ package body Exp_Imgv is Make_Aggregate (Loc, Expressions => Ind))), Suppress => All_Checks); + + -- Reset the scalar storage order to the saved value + + Opt.Default_SSO := Saved_SSO; end Build_Enumeration_Image_Tables; ---------------------------- @@ -433,13 +451,13 @@ package body Exp_Imgv is -- Local variables + Enum_Case : Boolean; Imid : RE_Id; + Proc_Ent : Entity_Id; Ptyp : Entity_Id; Rtyp : Entity_Id; Tent : Entity_Id := Empty; Ttyp : Entity_Id; - Proc_Ent : Entity_Id; - Enum_Case : Boolean; Arg_List : List_Id; -- List of arguments for run-time procedure call @@ -450,6 +468,8 @@ package body Exp_Imgv is Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + -- Start of processing for Expand_Image_Attribute + begin if Is_Object_Image (Pref) then Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/sso16.adb @@ -0,0 +1,55 @@ +-- { dg-do run } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure SSO16 is + + pragma Default_Scalar_Storage_Order (High_Order_First); + + type Enum_T is + (Event_0, + Event_1, + Event_2, + Event_3, + Event_4, + Event_5, + Event_11, + Event_12, + Event_13, + Event_14, + Event_15, + Event_21, + Event_22, + Event_23, + Event_24, + Event_25, + Event_31, + Event_32, + Event_33, + Event_34, + Event_35, + Event_41, + Event_42, + Event_43, + Event_44, + Event_45); + + Var : Enum_T := Event_0; + +begin + if Var'Image /= "EVENT_0" then + raise Program_Error; + end if; + + if Enum_T'Value ("Event_4")'Image /= "EVENT_4" then + raise Program_Error; + end if; + + if Enum_T'Val (20)'Image /= "EVENT_35" then + raise Program_Error; + end if; + + if Enum_T'Pos (Enum_T'Value ("Event_45"))'Image /= " 25" then + raise Program_Error; + end if; +end; --8t9RHnE3ZwKMSgU+--