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