From: Javier Miranda <mira...@adacore.com>
The compiler crashes when processing an object declaration
of a custom string type initialized with an interpolated
string.
gcc/ada/
* exp_attr.adb (Expand_N_Attribute_Reference: [Put_Image]): Add
support for custom string types.
* exp_ch2.adb (Expand_N_Interpolated_String_Literal): Add a type
conversion to the result object declaration of custom string
types.
* exp_put_image.adb (Build_String_Put_Image_Call): Handle custom
string types.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 28 +++++++++++++++++++++++++++-
gcc/ada/exp_ch2.adb | 14 ++++++++++++++
gcc/ada/exp_put_image.adb | 36 +++++++++++++++++++++++++++++++++++-
3 files changed, 76 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 6475308f71b..84c7a4bbdee 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6006,6 +6006,7 @@ package body Exp_Attr is
when Attribute_Put_Image => Put_Image : declare
use Exp_Put_Image;
U_Type : constant Entity_Id := Underlying_Type (Entity (Pref));
+ C_Type : Entity_Id;
Pname : Entity_Id;
Decl : Node_Id;
@@ -6031,6 +6032,21 @@ package body Exp_Attr is
end if;
if No (Pname) then
+ if Is_String_Type (U_Type) then
+ declare
+ R : constant Entity_Id := Root_Type (U_Type);
+
+ begin
+ if Is_Private_Type (R) then
+ C_Type := Component_Type (Full_View (R));
+ else
+ C_Type := Component_Type (R);
+ end if;
+
+ C_Type := Root_Type (Underlying_Type (C_Type));
+ end;
+ end if;
+
-- If Put_Image is disabled, call the "unknown" version
if not Put_Image_Enabled (U_Type) then
@@ -6046,7 +6062,17 @@ package body Exp_Attr is
Analyze (N);
return;
- elsif Is_Standard_String_Type (U_Type) then
+ -- String type objects, including custom string types, and
+ -- excluding C arrays.
+
+ elsif Is_String_Type (U_Type)
+ and then C_Type in Standard_Character
+ | Standard_Wide_Character
+ | Standard_Wide_Wide_Character
+ and then (not RTU_Loaded (Interfaces_C)
+ or else Enclosing_Lib_Unit_Entity (U_Type)
+ /= RTU_Entity (Interfaces_C))
+ then
Rewrite (N, Build_String_Put_Image_Call (N));
Analyze (N);
return;
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 958f4299b73..99a16947525 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -768,6 +768,7 @@ package body Exp_Ch2 is
New_Occurrence_Of (Sink_Entity, Loc))));
Actions : constant List_Id := New_List;
+ U_Type : constant Entity_Id := Underlying_Type (Etype (N));
Elem_Typ : Entity_Id;
Str_Elem : Node_Id;
@@ -810,6 +811,19 @@ package body Exp_Ch2 is
Next (Str_Elem);
end loop;
+ -- Add a type conversion to the result object declaration of custom
+ -- string types.
+
+ if not Is_Standard_String_Type (U_Type)
+ and then (not RTU_Loaded (Interfaces_C)
+ or else Enclosing_Lib_Unit_Entity (U_Type)
+ /= RTU_Entity (Interfaces_C))
+ then
+ Set_Expression (Result_Decl,
+ Convert_To (Etype (N),
+ Relocate_Node (Expression (Result_Decl))));
+ end if;
+
Append_To (Actions, Result_Decl);
return Make_Expression_With_Actions (Loc,
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 217c38a30e7..190ac99b565 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -417,14 +417,48 @@ package body Exp_Put_Image is
Lib_RE : RE_Id;
use Stand;
begin
+ pragma Assert (Is_String_Type (U_Type));
+ pragma Assert (not RTU_Loaded (Interfaces_C)
+ or else Enclosing_Lib_Unit_Entity (U_Type)
+ /= RTU_Entity (Interfaces_C));
+
if R = Standard_String then
Lib_RE := RE_Put_Image_String;
elsif R = Standard_Wide_String then
Lib_RE := RE_Put_Image_Wide_String;
elsif R = Standard_Wide_Wide_String then
Lib_RE := RE_Put_Image_Wide_Wide_String;
+
else
- raise Program_Error;
+ -- Handle custom string types. For example:
+
+ -- type T is array (1 .. 10) of Character;
+ -- Obj : T := (others => 'A');
+ -- ...
+ -- Put (Obj'Image);
+
+ declare
+ C_Type : Entity_Id;
+
+ begin
+ if Is_Private_Type (R) then
+ C_Type := Component_Type (Full_View (R));
+ else
+ C_Type := Component_Type (R);
+ end if;
+
+ C_Type := Root_Type (Underlying_Type (C_Type));
+
+ if C_Type = Standard_Character then
+ Lib_RE := RE_Put_Image_String;
+ elsif C_Type = Standard_Wide_Character then
+ Lib_RE := RE_Put_Image_Wide_String;
+ elsif C_Type = Standard_Wide_Wide_Character then
+ Lib_RE := RE_Put_Image_Wide_Wide_String;
+ else
+ raise Program_Error;
+ end if;
+ end;
end if;
-- Convert parameter to the required type (i.e. the type of the
--
2.45.2
