ada: Crash on string interpolation with custom string types

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.

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 6475308f71b9bcdd901a0b66174bade58598065f..84c7a4bbdeebd69608ea57ed629d8235bfa3654e 100644 (file)
--- 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 958f4299b73a66b5303ce7aa4898547d68a943c3..99a1694752500c1e83fe26bf6934bd2eb917860c 100644 (file)
--- 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 217c38a30e7573adbd6d6d45a4bb34347be5d849..190ac99b565302fcca5d136e401db4581ef36b9e 100644 (file)
--- 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