[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  <squirek@adacore.com>

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b1b2e48ab544c5265db272968103d01c6fb07e96..528556acc8be0a95dbed9a5354e9c5e4d4c9b4e0 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-08  Justin Squirek  <squirek@adacore.com>
+
+       * 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  <anisimko@adacore.com>
 
        * libgnat/g-socket.ads, libgnat/g-socket.adb: Improve

diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 6a8d626e92a14d7710a6346e766c282fbc32e233..a47de2fe3f1979b9e00838e10f9559f9893b3364 100644 (file)
--- 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 a5a44a557a73b461730c2808736e54bcd57ae48f..744f782435523c30958d3754d515b90194e68081 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-08  Justin Squirek  <squirek@adacore.com>
+
+       * gnat.dg/sso16.adb: New testcase.
+
 2019-07-08  Ed Schonberg  <schonberg@adacore.com>
 
        * 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 (file)
index 0000000..0480d91
--- /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;