From ffec45e390555f4881c841271464a9c264adbbca Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Mon, 8 Jul 2019 08:12:55 +0000 Subject: [PATCH] [Ada] Crash on Image and Value attributes 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. 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. From-SVN: r273199 --- gcc/ada/ChangeLog | 6 ++++ gcc/ada/exp_imgv.adb | 38 +++++++++++++++++------ gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/sso16.adb | 55 +++++++++++++++++++++++++++++++++ 4 files changed, 94 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/sso16.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b1b2e48ab54..528556acc8b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2019-07-08 Justin Squirek + + * exp_imgv.adb (Build_Enumeration_Image_Tables): Default SSO for + the building of image tables. + (Expand_Image_Attribute): Minor cleanup. + 2019-07-08 Dmitriy Anisimkov * libgnat/g-socket.ads, libgnat/g-socket.adb: Improve diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 6a8d626e92a..a47de2fe3f1 100644 --- a/gcc/ada/exp_imgv.adb +++ b/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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a5a44a557a7..744f7824355 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-08 Justin Squirek + + * gnat.dg/sso16.adb: New testcase. + 2019-07-08 Ed Schonberg * gnat.dg/predicate8.adb, gnat.dg/predicate8_pkg.adb, diff --git a/gcc/testsuite/gnat.dg/sso16.adb b/gcc/testsuite/gnat.dg/sso16.adb new file mode 100644 index 00000000000..0480d916245 --- /dev/null +++ b/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; -- 2.30.2