Enable support for Ada 2020's Put_Image and Image attributes for
tagged types.
Tested on x86_64-pc-linux-gnu, committed on trunk
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
--- 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
--- 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
--- 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
--- 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;
