[Ada] Enable Ada 2020 Put_Image and Image support for tagged types

gcc/ada/

	* exp_put_image.adb: Eliminate references to
	Debug_Flag_Underscore_Z.  Change the meaning of the function
	Enable_Put_Image. Previously, a result of False for a tagged
	type would mean that the type does not get a Put_Image (PI)
	routine at all. Now, it means that the type gets a PI routine
	with very abbreviated functionality (just a call to
	Unknown_Put_Image). This resolves problems in mixing code
	compiled with and without the -gnat2022 switch.
	* exp_ch3.adb: Enable_Put_Image no longer participates in
	determining whether a tagged type gets a Put_Image procedure.  A
	tagged type does not get a Put_Image procedure if the type
	Root_Buffer_Type is unavailable. This is needed to support cross
	targets where tagged types are supported but the type
	Root_Buffer_Type is not available.
	* exp_dist.adb: Add workarounds for some problems that arise
	when using the (obsolete?) Garlic implementation of the
	distributed systems annex with Ada 2022 constructs.
	* libgnat/a-sttebu.ads: Workaround a bootstrapping problem.
	Older compilers do not support raise expressions, so revise the
	the Pre'Class condition to meet this requirement without
	changing the condition's behavior at run time.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 504410d..ad6c7a7 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -10334,7 +10334,14 @@ package body Exp_Ch3 is
 
       --  Spec of Put_Image
 
-      if Enable_Put_Image (Tag_Typ) then
+      if (not No_Run_Time_Mode)
+         and then RTE_Available (RE_Root_Buffer_Type)
+      then
+         --  No_Run_Time_Mode implies that the declaration of Tag_Typ
+         --  (like any tagged type) will be rejected. Given this, avoid
+         --  cascading errors associated with the Tag_Typ's TSS_Put_Image
+         --  procedure.
+
          Append_To (Res, Predef_Spec_Or_Body (Loc,
            Tag_Typ => Tag_Typ,
            Name    => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
@@ -10936,8 +10943,9 @@ package body Exp_Ch3 is
 
       --  Body of Put_Image
 
-      if Enable_Put_Image (Tag_Typ)
-        and then No (TSS (Tag_Typ, TSS_Put_Image))
+      if No (TSS (Tag_Typ, TSS_Put_Image))
+         and then (not No_Run_Time_Mode)
+         and then RTE_Available (RE_Root_Buffer_Type)
       then
          Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
          Append_To (Res, Decl);

diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 9805457..35ccf9d 100644 (file)
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -4211,6 +4211,14 @@ package body Exp_Dist is
          --  Used only for the PolyORB case
 
       begin
+         --  workaround for later failures in Exp_Util.Find_Prim_Op
+         if Is_TSS (Defining_Unit_Name (Spec), TSS_Put_Image) then
+            Append_To (Statements,
+                       Make_Raise_Program_Error (Loc,
+                         Reason => PE_Stream_Operation_Not_Allowed));
+            return;
+         end if;
+
          --  The general form of a calling stub for a given subprogram is:
 
          --    procedure X (...) is P : constant Partition_ID :=
@@ -4726,11 +4734,11 @@ package body Exp_Dist is
          --  Formal parameter for receiving stubs: a descriptor for an incoming
          --  request.
 
-         Decls : constant List_Id := New_List;
+         Decls : List_Id := New_List;
          --  All the parameters will get declared before calling the real
          --  subprograms. Also the out parameters will be declared.
 
-         Statements : constant List_Id := New_List;
+         Statements : List_Id := New_List;
 
          Extra_Formal_Statements : constant List_Id := New_List;
          --  Statements concerning extra formal parameters
@@ -5165,6 +5173,19 @@ package body Exp_Dist is
                  Parameter_Type      =>
                    New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
 
+         --  workaround for later failures in Exp_Util.Find_Prim_Op
+         if Is_TSS (Defining_Unit_Name (Specification (Vis_Decl)),
+                    TSS_Put_Image)
+         then
+            --  drop everything on the floor
+            Decls := New_List;
+            Statements := New_List;
+            Excep_Handlers := New_List;
+            Append_To (Statements,
+                       Make_Raise_Program_Error (Loc,
+                         Reason => PE_Stream_Operation_Not_Allowed));
+         end if;
+
          return
            Make_Subprogram_Body (Loc,
              Specification              => Subp_Spec,

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 0cf38ac..082e08b 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -26,7 +26,6 @@
 with Aspects;        use Aspects;
 with Atree;          use Atree;
 with Csets;          use Csets;
-with Debug;          use Debug;
 with Einfo;          use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
@@ -45,15 +44,13 @@ with Sinfo.Nodes;    use Sinfo.Nodes;
 with Sinfo.Utils;    use Sinfo.Utils;
 with Snames;         use Snames;
 with Stand;
+with Stringt;        use Stringt;
 with Tbuild;         use Tbuild;
 with Ttypes;         use Ttypes;
 with Uintp;          use Uintp;
 
 package body Exp_Put_Image is
 
-   Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
-   --  Temporary until we resolve mixing Ada 2012 and 2022 code
-
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -531,6 +528,7 @@ package body Exp_Put_Image is
       Pnam : out Entity_Id)
    is
       Btyp : constant Entity_Id := Base_Type (Typ);
+      pragma Assert (not Is_Class_Wide_Type (Btyp));
       pragma Assert (not Is_Unchecked_Union (Btyp));
 
       First_Time : Boolean := True;
@@ -789,7 +787,31 @@ package body Exp_Put_Image is
    --  Start of processing for Build_Record_Put_Image_Procedure
 
    begin
-      if Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
+      if (Ada_Version < Ada_2022)
+        or else not Enable_Put_Image (Btyp)
+      then
+         --  generate a very simple Put_Image implementation
+
+         if Is_RTE (Typ, RE_Root_Buffer_Type) then
+            --  Avoid introducing a cyclic dependency between
+            --  Ada.Strings.Text_Buffers and System.Put_Images.
+
+            Append_To (Stms,
+              Make_Raise_Program_Error (Loc,
+              Reason => PE_Explicit_Raise));
+         else
+            Append_To (Stms,
+              Make_Procedure_Call_Statement (Loc,
+                Name => New_Occurrence_Of (RTE (RE_Put_Image_Unknown), Loc),
+                Parameter_Associations => New_List
+                  (Make_Identifier (Loc, Name_S),
+                   Make_String_Literal (Loc,
+                     To_String (Fully_Qualified_Name_String (Btyp))))));
+         end if;
+      elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
+
+         --  Interface types take this path.
+
          Append_To (Stms,
            Make_Procedure_Call_Statement (Loc,
              Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc),
@@ -908,42 +930,29 @@ package body Exp_Put_Image is
 
    function Enable_Put_Image (Typ : Entity_Id) return Boolean is
    begin
+      --  If this function returns False for a non-scalar type Typ, then
+      --    a) calls to Typ'Image will result in calls to
+      --       System.Put_Images.Put_Image_Unknown to generate the image.
+      --    b) If Typ is a tagged type, then similarly the implementation
+      --       of Typ's Put_Image procedure will call Put_Image_Unknown
+      --       and will ignore its formal parameter of type Typ.
+      --       Note that Typ will still have a Put_Image procedure
+      --       in this case, albeit one with a simplified implementation.
+      --
       --  The name "Sink" here is a short nickname for
       --  "Ada.Strings.Text_Buffers.Root_Buffer_Type".
-
-      --  There's a bit of a chicken&egg problem. The compiler is likely to
-      --  have trouble if we refer to the Put_Image of Sink itself, because
-      --  Sink is part of the parameter profile:
-      --
-      --     function Sink'Put_Image (S : in out Sink'Class; V : T);
-      --
-      --  Likewise, the Ada.Strings.Buffer package, where Sink is
-      --  declared, depends on various other packages, so if we refer to
-      --  Put_Image of types declared in those other packages, we could create
-      --  cyclic dependencies. Therefore, we disable Put_Image for some
-      --  types. It's not clear exactly what types should be disabled. Scalar
-      --  types are OK, even if predefined, because calls to Put_Image of
-      --  scalar types are expanded inline. We certainly want to be able to use
-      --  Integer'Put_Image, for example.
-
-      --  ???Temporarily disable to work around bugs:
       --
       --  Put_Image does not work for Remote_Types. We check the containing
       --  package, rather than the type itself, because we want to include
       --  types in the private part of a Remote_Types package.
-      --
-      --  Put_Image on tagged types triggers some bugs.
 
-      if Ada_Version < Ada_2022
-        or else Is_Remote_Types (Scope (Typ))
+      if Is_Remote_Types (Scope (Typ))
+        or else Is_Remote_Call_Interface (Typ)
         or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
-        or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled)
       then
          return False;
       end if;
 
-      --  End of workarounds.
-
       --  No sense in generating code for Put_Image if there are errors. This
       --  avoids certain cascade errors.
 
@@ -1192,8 +1201,6 @@ package body Exp_Put_Image is
       --  Don't do it if type Root_Buffer_Type is unavailable in the runtime.
 
       if not In_Predefined_Unit (Compilation_Unit)
-        and then Ada_Version >= Ada_2022
-        and then Tagged_Put_Image_Enabled
         and then Tagged_Seen
         and then not No_Run_Time_Mode
         and then RTE_Available (RE_Root_Buffer_Type)

diff --git a/gcc/ada/libgnat/a-sttebu.ads b/gcc/ada/libgnat/a-sttebu.ads
index 4f6fafc..39144a6 100644 (file)
--- a/gcc/ada/libgnat/a-sttebu.ads
+++ b/gcc/ada/libgnat/a-sttebu.ads
@@ -59,7 +59,8 @@ is
      (Buffer : in out Root_Buffer_Type;
       Amount :        Text_Buffer_Count := Standard_Indent) with
       Pre'Class => Current_Indent (Buffer) >= Amount
-      or else raise Constraint_Error,
+      --  or else raise Constraint_Error,
+      or else Boolean'Val (Current_Indent (Buffer) - Amount),
       Post'Class => Current_Indent (Buffer) =
       Current_Indent (Buffer)'Old - Amount;