Commit ffec45e3 by Justin Squirek Committed by Pierre-Marie de Rodat

[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
parent 0a904120
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> 2019-07-08 Dmitriy Anisimkov <anisimko@adacore.com>
* libgnat/g-socket.ads, libgnat/g-socket.adb: Improve * libgnat/g-socket.ads, libgnat/g-socket.adb: Improve
......
...@@ -69,18 +69,23 @@ package body Exp_Imgv is ...@@ -69,18 +69,23 @@ package body Exp_Imgv is
------------------------------------ ------------------------------------
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (E); Loc : constant Source_Ptr := Sloc (E);
Str : String_Id;
Eind : Entity_Id;
Estr : Entity_Id;
Ind : List_Id; Ind : List_Id;
Ityp : Node_Id;
Len : Nat;
Lit : Entity_Id; Lit : Entity_Id;
Nlit : Nat; Nlit : Nat;
Len : Nat; Str : String_Id;
Estr : Entity_Id;
Eind : Entity_Id; Saved_SSO : constant Character := Opt.Default_SSO;
Ityp : Node_Id; -- Used to save the current scalar storage order during the generation
-- of the literal lookup table.
begin 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 if E /= Root_Type (E) then
return; return;
...@@ -138,6 +143,15 @@ package body Exp_Imgv is ...@@ -138,6 +143,15 @@ package body Exp_Imgv is
Set_Lit_Strings (E, Estr); Set_Lit_Strings (E, Estr);
Set_Lit_Indexes (E, Eind); 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, Insert_Actions (N,
New_List ( New_List (
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -168,6 +182,10 @@ package body Exp_Imgv is ...@@ -168,6 +182,10 @@ package body Exp_Imgv is
Make_Aggregate (Loc, Make_Aggregate (Loc,
Expressions => Ind))), Expressions => Ind))),
Suppress => All_Checks); Suppress => All_Checks);
-- Reset the scalar storage order to the saved value
Opt.Default_SSO := Saved_SSO;
end Build_Enumeration_Image_Tables; end Build_Enumeration_Image_Tables;
---------------------------- ----------------------------
...@@ -433,13 +451,13 @@ package body Exp_Imgv is ...@@ -433,13 +451,13 @@ package body Exp_Imgv is
-- Local variables -- Local variables
Enum_Case : Boolean;
Imid : RE_Id; Imid : RE_Id;
Proc_Ent : Entity_Id;
Ptyp : Entity_Id; Ptyp : Entity_Id;
Rtyp : Entity_Id; Rtyp : Entity_Id;
Tent : Entity_Id := Empty; Tent : Entity_Id := Empty;
Ttyp : Entity_Id; Ttyp : Entity_Id;
Proc_Ent : Entity_Id;
Enum_Case : Boolean;
Arg_List : List_Id; Arg_List : List_Id;
-- List of arguments for run-time procedure call -- List of arguments for run-time procedure call
...@@ -450,6 +468,8 @@ package body Exp_Imgv is ...@@ -450,6 +468,8 @@ package body Exp_Imgv is
Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Start of processing for Expand_Image_Attribute
begin begin
if Is_Object_Image (Pref) then if Is_Object_Image (Pref) then
Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
......
2019-07-08 Justin Squirek <squirek@adacore.com>
* gnat.dg/sso16.adb: New testcase.
2019-07-08 Ed Schonberg <schonberg@adacore.com> 2019-07-08 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/predicate8.adb, gnat.dg/predicate8_pkg.adb, * gnat.dg/predicate8.adb, gnat.dg/predicate8_pkg.adb,
......
-- { 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment