From 09768159b3f4b5343848d12d6cd5e95b574d8cca Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Tue, 11 May 2021 11:45:06 -0700 Subject: [PATCH] [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. --- gcc/ada/exp_ch3.adb | 14 +++++++-- gcc/ada/exp_dist.adb | 25 ++++++++++++++-- gcc/ada/exp_put_image.adb | 69 ++++++++++++++++++++++++-------------------- gcc/ada/libgnat/a-sttebu.ads | 3 +- 4 files changed, 74 insertions(+), 37 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 504410d..ad6c7a7 100644 --- 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 --- 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 --- 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 --- 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; -- 2.7.4